" . $_ . "
\n";
}
}
sub loadlang {
my ($lang, $p_str, $b_partial) = @_;
my $err = '';
Err: {
if ((not defined($lang)) or ($lang eq '')) {
$err = "invalid argument; subroutine loadlang called will null string";
my ($package, $file, $line) = &he(caller());
$err .= "";
next Err;
}
my $full = "$const{'preferences folder'}templates/$lang";
unless (-e $full) {
my $f = &he($full);
$err = "folder '$f' does not exist";
next Err;
}
unless (-d $full) {
my $f = &he($full);
$err = "folder '$f' does not exist as a folder";
next Err;
}
unless (-e "$full/strings.txt") {
my $f = &he($full);
$err = "language folder '$f' does not contain a strings.txt file";
next Err;
}
# Pull in the language settings:
my $file = "$const{'preferences folder'}templates/$lang/strings.txt";
my @new = (''); # Initialize with a null element
unless (open(FILE, "<$file")) {
$err = "unable to read from file '$file' - $!";#notranslate
next Err;
}
binmode(FILE);
local $_;
while (defined($_ = )) {
s!\015|\012!!sg;
push(@new,$_);
if ($b_partial) {
last if ($#new > 10);
}
}
close(FILE);
if ($new[1] =~ m!^VERSION (\d+\.\d+\.\d+\.\d+)$!) {
my $strings_version = $1;
if ($strings_version ne $VERSION) {
$err = "strings '$file' is version $strings_version, but this script is version $VERSION. Versions much match";#notranslate
next Err;
}
}
else {
my $f = &he($full);
$err = "strings.txt file in language folder '$f' did not start with required VERSION $VERSION block; instead contained the following:" . &text_to_html( join("\n", @new[0..5] ), 1 ) . "
.end";
next Err;
}
@$p_str = @new;
last Err;
}
return $err;
}
sub render_h {
my ($self, $index, @params) = @_;
return $self->render($index, &he(@params));
}
sub render {
my ($self, $index, @params) = @_;
local $_ = '';
Err: {
$_ = $index;
my $x = 0;
while (defined($params[$x])) {
my $value = $params[$x];
$x++;
my $c = (s!\$s$x!$value!sg);
# optional error handling if $c == 0 (no replacements made)
}
last Err;
}
return $_;
}
sub load_best_values {
my ($p_schema, $p_hash) = @_;
my %finish = ();
my @errors = ();
my $err = '';
Err: {
my ($key, $err_key);
foreach $key (keys %$p_schema) {
my $p_valid = $$p_schema{$key};
$err_key = &fd_validate( $$p_hash{$key}, @$p_valid );
if ($err_key) {
push( @errors, $err_key );
$finish{$key} = $$p_valid[4];
}
else {
$finish{$key} = $$p_hash{$key};
}
}
last Err;
}
return ( &multi_error_frag(@errors), %finish);
}
sub multi_error_frag {
my ($first, $last) = ( $str[6], '');
if ($first =~ m!^(.*)\$s1(.*)$!) {
($first, $last) = ($1, $2);
}
return join( "$last$first", @_ );
};
sub validate_hash {
my ($p_schema, $p_hash, $b_full) = @_;
my $err = '';
Err: {
my $key;
foreach $key (keys %$p_schema) {
next if ((not $b_full) and (not defined($$p_hash{$key})));
$err = &fd_validate( $$p_hash{$key}, @{ $p_schema->{$key} } );
next Err if ($err);
}
last Err;
}
return $err;
}
sub fd_validate($$$$$);
sub fd_validate($$$$$) {
my ($value, $type, $min, $max, $name) = @_;
my $err = '';
Err: {
$type = 'any' unless (defined($type));
if ($type =~ m!^\d+$!) {
$type = ('int', 'real', 'string', 'email', 'hostname', 'regex', 'bool')[$type];
}
# type == undef()/any means that anything goes:
last Err if ($type eq 'any');
my %types = (
'int' => 1,
'real' => 2,
'string' => 3,
'email' => 4,
'hostname' => 5,
'regex' => 6,
'bool' => 7,
'file' => 8,
'folder' => 9,
'http_url' => 10,
'string_p' => 11,
);
unless ($types{$type}) {
$err = $fd_lang->render_h( 'unknown type $s1', $type );
next Err;
}
# undefined values are acceptable if and only if the $min param is also undef()
if (not defined($value)) {
if (not defined($min)) {
last Err;
}
else {
$err = $fd_lang->render( 'received undefined value' );
next Err;
}
}
# from here on out, we are guaranteed that $value is defined
if (($type eq 'int') or ($type eq 'real')) {
# integer or real-number
$value =~ s!^\+!!;
}
# store value length for later checks:
my $vlen = length($value);
# under what conditions can the value *not* be blank?
# if int, real, bool
# or
# if $min is defined and $min > 0
if ($vlen == 0) {
if (($type =~ m!^(int|real|bool)$!) or ($min)) {
$err = $fd_lang->render( 'value cannot be blank' );
next Err;
}
else {
last Err;
}
}
# what are the system maximum string limits?
my %sys_max = (
'email' => 255,
'hostname' => 255,
'regex' => 65535,
'file' => 255,
'folder' => 255,
);
if (($sys_max{$type}) and ($sys_max{$type} < $vlen)) {
$err = $fd_lang->render( 'value is $s1 characters long but the maximum supported by this software is $s2 characters', $vlen, $sys_max{$type} );
next Err;
}
if (($type eq 'int') or ($type eq 'real')) {
# integer or real-number
if ($type eq 'int') {
unless ($value =~ m!^(\-?\d+)$!) {
$err = $fd_lang->render( 'must be of the format "$s1"', 'ddd' );
next Err;
}
}
else {
unless ($value =~ m!^-?\d*\.?\d*$!) {
$err = $fd_lang->render( 'must be of the format "$s1"', 'dd.dd' );
next Err;
}
}
if (defined($min)) {
if ($value < $min) {
$err = $fd_lang->render( 'minimum acceptable value is $s1', $min );
next Err;
}
}
if (defined($max)) {
if ($value > $max) {
$err = $fd_lang->render( 'maximum acceptable value is $s1', $max );
next Err;
}
}
last Err;
}
elsif ($type eq 'string') {
if ((defined($min)) and ($min > $vlen)) {
$err = $fd_lang->render( 'string is $s1 characters, but minimum acceptable length is $s2 characters', $vlen, $min );
next Err;
}
if ((defined($max)) and ($max < $vlen)) {
$err = $fd_lang->render( 'string is $s1 characters, but maximum acceptable length is $s2 characters', $vlen, $max );
next Err;
}
}
elsif ($type eq 'string_p') {
# string-plain; cannot contain HTML
if ((defined($min)) and ($min > $vlen)) {
$err = $fd_lang->render( 'string is $s1 characters, but minimum acceptable length is $s2 characters', $vlen, $min );
next Err;
}
if ((defined($max)) and ($max < $vlen)) {
$err = $fd_lang->render( 'string is $s1 characters, but maximum acceptable length is $s2 characters', $vlen, $max );
next Err;
}
if ($value =~ m!\&|\>|\<|\"!s) {
$err = $fd_lang->render( 'string cannot contain any of the following four characters: & < > "' );
next Err;
}
}
elsif ($type eq 'email') {
unless ($value =~ m!^(.+?)\@(.+?)$!) {
$err = $fd_lang->render( 'must be of the format "$s1"', 'user@host' );
next Err;
}
my $domain = $2;
if ($domain =~ m![^a-zA-Z0-9\.\-]!) {
$err = "host portion contains characters outside the allowed character set of A-Z, 0-9, '.' and '-'";
next Err;
}
if ($value =~ m!\s!) {
$err = 'value cannot contain whitespace';
next Err;
}
if (($value =~ m!\.([^\.]+)$!) and (2 < length($1))) {
my $tld = quotemeta(lc($1));
unless (' biz com edu info int museum net org gov mil ' =~ m! $tld !) {
$err = $fd_lang->render_h( 'unrecognized top-level domain "$s1"', $tld );
next Err;
}
}
}
elsif ($type eq 'hostname') {
if ($value =~ m![^a-zA-Z0-9\.\-]!) {
$err = "value contains characters outside the allowed character set of A-Z, 0-9, '.' and '-'";
next Err;
}
if ($max) {
my $addr = (gethostbyname($value))[4];
unless (defined($addr)) {
$err = "value could not be resolved to an IP address; check for proper spelling";
next Err;
}
}
}
elsif ($type eq 'regex') {
if ($value =~ m!\?\{!) {
$err = 'regular expression contains illegal ?{} code-executing regular expression';
next Err;
}
eval '"foo" =~ m!$value!;';
if ($@) {
$err = 'regular expression cannot be evaluated - ' . &he($@);
eval '1;'; # used to set $@ back to ''
next Err;
}
}
elsif ($type eq 'bool') {
unless (($value eq '0') or ($value eq '1')) {
$err = $fd_lang->render( 'value must be either "0" or "1"' );
next Err;
}
}
elsif ($type eq 'file') {
if ((defined($min)) and ($max)) {
unless (-e $value) {
$err = $fd_lang->render( 'file does not exist' );
next Err;
}
if (-d $value) {
$err = $fd_lang->render( 'path points to a folder; must point to a normal file' );
next Err;
}
}
}
elsif ($type eq 'folder') {
if ((defined($min)) and ($max)) {
unless (-e $value) {
$err = $fd_lang->render( 'folder does not exist' );
next Err;
}
unless (-d $value) {
$err = $fd_lang->render( 'path points to a file; must point to a folder' );
next Err;
}
}
}
elsif ($type eq 'http_url') {
if (defined($min)) {
unless ($value =~ m!^http://.+$!) {
$err = $fd_lang->render( 'must be of the format "$s1"', 'http://host.tld/path/' );
next Err;
}
}
}
else {
$err = $fd_lang->render_h( 'validation data type "$s1" not defined', $type );
last Err;
}
last Err;
}
continue {
my %type_names = (
'int' => 'integer value',
'real' => 'real number value',
'string' => 'string',
'email' => 'email address',
'hostname' => 'hostname value',
'file' => 'file',
'folder' => 'folder',
'regex' => 'Perl regular expression',
);
my $type_name = $type_names{$type} || 'value';
$err = $fd_lang->render( '$s1 failed validation; $s2', $type_name, $err );
my $h_value = &he($value);
if ($h_value) {
$err =~ s!$type_name !$type_name '$h_value' !;
}
if ($name) {
$err =~ s!$type_name !$type_name '$name' !;
}
#$err .= $fd_lang->render( '.
Caller: package $s1; file $s2 line $s3', caller() );
}
return $err;
}
sub ue(@);
sub ue(@) {
my @out = @_;
local $_;
foreach (@out) {
$_ = '' if (not defined($_));
s!([^a-zA-Z0-9_.-])!uc(sprintf("%%%02x", ord($1)))!eg;
}
if ((wantarray) or ($#out > 0)) {
return @out;
}
else {
return $out[0];
}
}
=item text_to_html
=cut
sub text_to_html($$);
sub text_to_html($$) {
my ($text, $b_no_url) = @_;
$text = &he($text);
&force_CRLF( \$text );
$text =~ s!http://(\S+)!http://$1!sg unless ($b_no_url);
$text =~ s!\015\012!
\015\012!sg;
return $text;
}
sub get_age_str {
my ($age) = @_;
my $age_str = '';
$age += 59; # round up
if ($age > (2 * 86400)) {
$age_str = &pstr( 390, int($age / 86400) );
}
elsif ($age > (100 * 60)) {
$age_str = &pstr( 389, int($age / 3600) );
}
else {
$age_str = &pstr( 388, int($age / 60) );
}
return $age_str;
}
=item validate_system_settings
Usage:
$err = &validate_system_setting( \%hash );
next Err if ($err);
NOTE: this subroutine performs read-write operations on the input %hash hash.
This subroutine will return $err if there is a problem with the values entered in %hash, but it will also replace the offending value with the system default. In this way, it can be used to audit admin-initiated changes in the UI, and also to audit values as they are read off of the disk at system start-up.
=cut
sub validate_system_settings($);
sub validate_system_settings($) {
my ($p_hash) = @_;
my @errors = ();
Err: {
my $te = '';
$te = &fd_validate( $$p_hash{'Mail Server'}, 'hostname', 0, 0, 'Mail Server' );
if ($te) {
push( @errors, $te );
}
my $b_sec_error = 0;
$te = &fd_validate( $$p_hash{'sec_mode'}, 'int', 0, 4, 'Security Mode' );
if ($te) {
push( @errors, $te );
$b_sec_error = 1;
}
my $var;
foreach $var ('Permission - CGI Scripts', 'Permission - Normal Files', 'Permission - Folder') {
$te = &fd_validate( $$p_hash{$var}, 'string_p', 4, 4, $var );
if ($te) {
push( @errors, $te );
$b_sec_error = 1;
next;
}
$te = &fd_validate( $$p_hash{$var}, 'int', 0, 7777, $var );
if ($te) {
push( @errors, $te );
$b_sec_error = 1;
next;
}
if ($$p_hash{$var} =~ m!(8|9)!) {
push( @errors, &pstr( 288, $var, &he($$p_hash{$var}), $1 ) );
$b_sec_error = 1;
next;
}
}
if ($b_sec_error) {
# re-parse all file-security permissions using auto-detect
$$p_hash{'sec_mode'} = 0;
}
if ($$p_hash{'RegKey'}) {
my $virtual = $const{'code_validate'};
unless (&$virtual( $$p_hash{'RegKey'} )) {
#should not happen
push( @errors, qq!$str[227] [$str[55]]! );
$$p_hash{'RegKey'} = '';
}
}
$te = &fd_validate( $$p_hash{'mode'}, 'int', 0, 3, 'License Mode' );
if ($te) {
push( @errors, $te );
$$p_hash{'mode'} = 1; # default Trial Shareware
}
foreach $var ('Media Types', 'CGI Types', 'Known Types') {
$te = &fd_validate( $$p_hash{$var}, 'string_p', 0, 1024, $var );
if ($te) {
push( @errors, $te );
$$p_hash{$var} = '';
}
}
$te = &fd_validate( $$p_hash{'Min Password Length'}, 'int', 0, 8, 'Minimum Password Length' );
if ($te) {
push( @errors, $te );
$$p_hash{'Min Password Length'} = 0;
}
# strip leading/trailing whitespace, and force a trailing slash:
foreach $var ('Base Folder', 'Base URL', 'Images URL') {
$$p_hash{$var} = &Trim($$p_hash{$var});
next if ($$p_hash{$var} =~ m!/$!);
$$p_hash{$var} .= '/';
}
last Err;
}
my ($first, $last) = ( $str[6], '' );
if ($first =~ m!^(.*)\$s1(.*)$!) {
($first, $last) = ($1, $2);
}
my $err = join( "$last$first", @errors );
return $err;
};
sub system_settings_load($$$);
sub system_settings_load($$$) {
my ($file, $p_effective, $p_raw) = @_;
my $sys_load_warnings = '';
my $err = '';
Err: {
my $text;
($err, $text) = &ReadFile( $file );
next Err if ($err);
my %merge = %$p_raw;
foreach (split(m!\r?\n!s, $text)) {
next unless (m!^(.+)\==(.*)$!);
my ($name, $value) = ($1, $2);
next unless (defined($merge{$name}));
$value =~ s!\\CRLF!\015\012!sg;
$merge{$name} = $value;
}
%$p_raw = %merge;
# if there are validation failures, we will overwrite them with default values, and then add the warning info to the queue for later display in StartHTML
$sys_load_warnings = &validate_system_settings( \%merge );
%$p_effective = %merge;
$$p_effective{'Images URL'} = &he($$p_effective{'Images URL'});
}
return ($err, $sys_load_warnings);
};
=item file_security_init
Usage:
$err = &file_security_init();
next Err if ($err);
Initializes the global @file_sec array based on the system 'sec_mode' setting. If sec_mode == 0 for auto-detect, then this subroutine handles the auto-detection process.
Currently there is no error handling. The $err return value is for future use.
This routine trusts that the sec_mode and the various Permissions settings from the %system_eff global hash will be valid-format. This subroutine should only be called after &validate_system_settings( \%system_eff ).
=cut
sub file_security_init($);
sub file_security_init($) {
my ($sec_mode) = @_;
my $err = '';
Err: {
unless ($sec_mode) {
$sec_mode = &detect_sec_mode();
}
# @file_sec == b_use_chmod, perm folder, data file, script file
if ($sec_mode == 2) { # setuid
@file_sec = (1, 755, 644, 755);
}
elsif ($sec_mode == 3) { # permissive
@file_sec = (1, 777, 666, 777);
}
elsif ($sec_mode == 4) { # custom
@file_sec = (1, $system_eff{'Permission - Folder'}, $system_eff{'Permission - Normal Files'}, $system_eff{'Permission - CGI Scripts'});
}
elsif ($sec_mode == 1) { # none
@file_sec = (0);
}
if ($file_sec[0]) {
for (1..3) {
unless ($file_sec[$_] =~ m!(\d\d\d)$!) {
$err = "file security descriptor must be of the format ddd";
next Err;
}
$file_sec[$_] = oct("0$1");
}
}
last Err;
}
return $err;
};
sub clean_path {
my $path = &Trim($_[0]);
my ($base, $question, $query) = ($path, '', '');
if ($path =~ m!^(.+?)(\??)(.*)$!s) {
($base, $question, $query) = ($1, $2, $3);
}
local $_ = $base;
# strip pound signs and all that follows (links internal to a page)
s!\#.*$!!;
# map /%7E to /~ (common source of duplicate URL's)
s!\/\%7E!\/\~!ig;
# map "/./" to "/"
s!/+\./+!/!g;
# map trailing "/." to "/"
s!/+\.$!/!g;
# map "/folder/../" => "/"
while (s!([^/]+)/+\.\./+!/!) {}
# map /../foo => /foo
while (s!^/+\.\./+!/!) {}
s!^/+\.\.$!/!;
# collapse back-to-back slashes in the path
s!/+!/!g;
return $_ . $question . $query;
}
1;