X-Git-Url: http://git.treefish.org/fex.git/blobdiff_plain/e60096926213ce02293a261254ff065cae44c1c8..20160104:/lib/fex.pp?ds=sidebyside diff --git a/lib/fex.pp b/lib/fex.pp index 352b412..be911d2 100644 --- a/lib/fex.pp +++ b/lib/fex.pp @@ -1,6 +1,7 @@ # -*- perl -*- use 5.008; +use utf8; use Fcntl qw':flock :seek :mode'; use IO::Handle; use IPC::Open3; @@ -71,13 +72,10 @@ if ($FHS) { $docdir = '/var/lib/fex/htdocs'; $notify_newrelease = ''; } - + # allowed download managers (HTTP User-Agent) $adlm = '^(Axel|fex)'; -# allowed multi download recipients -$amdl = '^(anonymous|_fexmail_)'; - # local config require "$FEXLIB/fex.ph" or die "$0: cannot load $FEXLIB/fex.ph - $!"; @@ -89,6 +87,13 @@ $debug = 0 if $debug =~ /no/i; @logdir = ($logdir) unless @logdir; $logdir = $logdir[0]; +# allowed multi download recipients: from any ip, any times +if (@mailing_lists) { + $amdl = '^('.join('|',map { quotewild($_) } @mailing_lists).')$'; +} else { + $amdl = '^-$'; +} + # check for name based virtual host $vhost = vhost($ENV{'HTTP_HOST'}); @@ -110,14 +115,14 @@ $ENV{PROTO} = 'http' unless $ENV{PROTO}; $keep = $keep_default ||= $keep || 5; $fra = $ENV{REMOTE_ADDR} || ''; $sid = $ENV{SID} || ''; - -mkdirp($dkeydir = "$spooldir/.dkeys"); # download keys -mkdirp($ukeydir = "$spooldir/.ukeys"); # upload keys -mkdirp($akeydir = "$spooldir/.akeys"); # authentification keys -mkdirp($skeydir = "$spooldir/.skeys"); # subuser authentification keys -mkdirp($gkeydir = "$spooldir/.gkeys"); # group authentification keys -mkdirp($xkeydir = "$spooldir/.xkeys"); # extra download keys -mkdirp($lockdir = "$spooldir/.locks"); # download lock files + +$dkeydir = "$spooldir/.dkeys"; # download keys +$ukeydir = "$spooldir/.ukeys"; # upload keys +$akeydir = "$spooldir/.akeys"; # authentification keys +$skeydir = "$spooldir/.skeys"; # subuser authentification keys +$gkeydir = "$spooldir/.gkeys"; # group authentification keys +$xkeydir = "$spooldir/.xkeys"; # extra download keys +$lockdir = "$spooldir/.locks"; # download lock files if (my $ra = $ENV{REMOTE_ADDR} and $max_fail) { mkdirp("$spooldir/.fail"); @@ -154,18 +159,20 @@ $default_locale ||= 'english'; # $durl is first default fop download URL # @durl is optional mandatory fop download URL list (from fex.ph) unless ($durl) { + my $host = ''; + my $port = 80; + my $xinetd = '/etc/xinetd.d/fex'; + if (@durl) { $durl = $durl[0]; } elsif ($ENV{HTTP_HOST} and $ENV{PROTO}) { - my $host = ''; - my $port = 0; - + ($host,$port) = split(':',$ENV{HTTP_HOST}||''); $host = $hostname; - + unless ($port) { $port = 80; - if (open my $xinetd,'<',"/etc/xinetd.d/fex") { + if (open $xinetd,$xinetd) { while (<$xinetd>) { if (/^\s*port\s*=\s*(\d+)/) { $port = $1; @@ -175,7 +182,7 @@ unless ($durl) { close $xinetd; } } - + # use same protocal as uploader for download if ($ENV{PROTO} eq 'https' and $port == 443 or $port == 80) { $durl = "$ENV{PROTO}://$host/fop"; @@ -183,9 +190,23 @@ unless ($durl) { $durl = "$ENV{PROTO}://$host:$port/fop"; } } else { - $durl = "http://$hostname/fop"; + if (open $xinetd,$xinetd) { + while (<$xinetd>) { + if (/^\s*port\s*=\s*(\d+)/) { + $port = $1; + last; + } + } + close $xinetd; + } + if ($port == 80) { + $durl = "http://$hostname/fop"; + } else { + $durl = "http://$hostname:$port/fop"; + } } } +@durl = ($durl) unless @durl; sub reexec { @@ -197,7 +218,7 @@ sub reexec { sub jsredirect { $url = shift; $cont = shift || 'request accepted: continue'; - + http_header('200 ok'); print html_header($head||$ENV{SERVER_NAME}); pq(qq( @@ -230,24 +251,24 @@ sub nvt_print { sub html_quote { local $_ = shift; - + s/&/&/g; s/' )); # '' - - if ($0 =~ /fexdev/) { $head .= "\n" } + + if ($0 =~ /fexdev/) { $head .= "\n" } else { $head .= "\n" } - + $title =~ s:F\*EX:F*EX:; if (open $header,'<',"$docdir/$header") { $head .= $_ while <$header>; close $header; } - + $head .= &$prolog($title) if defined($prolog); - + if (@H1_extra) { $head .= sprintf( '

%s

', @@ -320,7 +342,7 @@ sub html_header { $head .= "

$title

"; } $head .= "\n"; - + return $head; } @@ -330,14 +352,14 @@ sub html_error { my $msg = "@_"; my @msg = @_; my $isodate = isodate(time); - + $msg =~ s/[\s\n]+/ /g; $msg =~ s/<.+?>//g; # remove HTML map { s///gi } @msg; - + errorlog($msg); - - # cannot send standard HTTP Status-Code 400, because stupid + + # cannot send standard HTTP Status-Code 400, because stupid # Internet Explorer then refuses to display HTML body! http_header("666 Bad Request - $msg"); print html_header($error); @@ -356,15 +378,15 @@ sub html_error { sub http_die { - + # not in CGI mode unless ($ENV{GATEWAY_INTERFACE}) { warn "$0: @_\n"; # must not die, because of fex_cleanup! return; } - + debuglog(@_); - + # create special error file on upload if ($uid) { my $ukey = "$spooldir/.ukeys/$uid"; @@ -375,7 +397,7 @@ sub http_die { close $ukey; } } - + html_error($error||'',@_); } @@ -401,7 +423,7 @@ sub check_maint { sub check_status { my $user = shift; - + $user = lc $user; $user .= '@'.$mdomain if $mdomain and $user !~ /@/; @@ -432,7 +454,7 @@ sub encode_Q { my $s = shift; $s =~ s{([\=\x00-\x20\x7F-\xA0])}{sprintf("=%02X",ord($1))}eog; return $s; -} +} # from MIME::Base64::Perl @@ -459,13 +481,13 @@ sub decode_b64 { sub b64 { local $_ = ''; my $x = 0; - + pos($_[0]) = 0; $_ = join '',map(pack('u',$_)=~ /^.(\S*)/, ($_[0]=~/(.{1,45})/gs)); tr|` -_|AA-Za-z0-9+/|; $x = (3 - length($_[0]) % 3) % 3; s/.{$x}$//; - + return $_; } @@ -478,7 +500,7 @@ sub rmrf { my ($file,$dir); local *D; local $_; - + foreach (@files) { next if /(^|\/)\.\.$/; /(.*)/; $file = $1; @@ -524,7 +546,7 @@ sub gethostname { if ($hostname !~ /\./ and $admin and $admin =~ /\@([\w.-]+)/) { $hostname .= '.'.$1; } - + return $hostname; } @@ -532,10 +554,10 @@ sub gethostname { # strip off path names (Windows or UNIX) sub strip_path { local $_ = shift; - + s/.*\\// if /^([A-Z]:)?\\/; s:.*/::; - + return $_; } @@ -543,9 +565,9 @@ sub strip_path { # substitute all critcal chars sub normalize { local $_ = shift; - + return '' unless defined $_; - + # we need perl native utf8 (see perldoc utf8) $_ = decode_utf8($_) unless utf8::is_utf8($_); @@ -553,7 +575,7 @@ sub normalize { s/[\x00-\x1F\x80-\x9F]/_/g; s/^\s+//; s/\s+$//; - + return encode_utf8($_); } @@ -561,12 +583,12 @@ sub normalize { # substitute all critcal chars sub normalize_html { local $_ = shift; - + return '' unless defined $_; - + $_ = normalize($_); s/[\"<>]//g; - + return $_; } @@ -580,20 +602,20 @@ sub normalize_filename { # we need native utf8 $_ = decode_utf8($_) unless utf8::is_utf8($_); - + $_ = strip_path($_); - + # substitute all critcal chars with underscore s/[^a-zA-Z0-9_=.+-]/_/g; s/^\./_/; - + return encode_utf8($_); } sub normalize_email { local $_ = lc shift; - + s/[^\w_.+=!~#^\@\-]//g; s/^\./_/; /(.*)/; @@ -603,7 +625,7 @@ sub normalize_email { sub normalize_user { my $user = shift; - + $user = lc(urldecode(despace($user))); $user .= '@'.$mdomain if $mdomain and $user !~ /@/; checkaddress($user) or http_die("$user is not a valid e-mail address"); @@ -628,7 +650,7 @@ sub untaint { sub checkchars { my $input = shift; local $_ = shift; - + if (/^([|+.])/) { http_die("\"$1\" is not allowed at beginning of $input"); } @@ -651,9 +673,9 @@ sub checkaddress { my $re; local $_; local ($domain,$dns); - + $a =~ s/:\w+=.*//; # remove options from address - + return $a if $a eq 'anonymous'; $a .= '@'.$mdomain if $mdomain and $a !~ /@/; @@ -666,7 +688,7 @@ sub checkaddress { $re = '^[!^=~#_:.+*{}\w\-\[\]]+\@(\w[.\w\-]*\.[a-z]+)$'; if ($a =~ /$re/i) { $domain = $dns = $1; - { + { local $SIG{__DIE__} = sub { die "\n" }; eval q{ use Net::DNS; @@ -674,7 +696,7 @@ sub checkaddress { unless ($dns or mx('uni-stuttgart.de')) { http_die("Internal error: bad resolver"); } - } + } }; if ($dns) { return untaint($a); @@ -699,8 +721,7 @@ sub checkforbidden { return $a if -d "$spooldir/$a"; # ok, if user already exists if (@forbidden_recipients) { foreach (@forbidden_recipients) { - $fr = quotemeta; - $fr =~ s/\\\*/.*/g; # allow wildcard * + $fr = quotewild($_); # skip public recipients if (@public_recipients) { foreach $pr (@public_recipients) { @@ -716,10 +737,10 @@ sub checkforbidden { sub randstring { my $n = shift; - my @rc = ('A'..'Z','a'..'z',0..9 ); - my $rn = @rc; + my @rc = ('A'..'Z','a'..'z',0..9 ); + my $rn = @rc; my $rs; - + for (1..$n) { $rs .= $rc[int(rand($rn))] }; return $rs; } @@ -729,7 +750,7 @@ sub randstring { sub mkdirp { my $dir = shift; my $pdir; - + return if -d $dir; $dir =~ s:/+$::; http_die("cannot mkdir /") unless $dir; @@ -762,7 +783,7 @@ sub ipin { $ipe = lc(ipe($ip)); map { lc } @list; - + foreach $i (@list) { if ($ip =~ /\./ and $i =~ /\./ or $ip =~ /:/ and $i =~ /:/) { if ($i =~ /(.+)-(.+)/) { @@ -805,12 +826,12 @@ sub filename { chomp $filename; close $file; } - + unless ($filename) { $filename = $file; $filename =~ s:.*/::; } - + return $filename; } @@ -842,7 +863,7 @@ sub fdlog { sub debuglog { my $prg = $0; local $_; - + return unless $debug and @_; unless ($debuglog and fileno $debuglog) { my $ddir = "$spooldir/.debug"; @@ -852,12 +873,15 @@ sub debuglog { $debuglog = sprintf("%s/%s_%s_%s.%s", $ddir,time,$$,$ENV{REQUESTCOUNT}||0,$prg); $debuglog =~ s/\s/_/g; + # http://perldoc.perl.org/perlunifaq.html#What-is-a-%22wide-character%22%3f # open $debuglog,'>>:encoding(UTF-8)',$debuglog or return; open $debuglog,'>>',$debuglog or return; + # binmode($debuglog,":utf8"); autoflush $debuglog 1; # printf {$debuglog} "\n### %s ###\n",isodate(time); } while ($_ = shift @_) { + $_ = encode_utf8($_) if utf8::is_utf8($_); s/\n*$/\n/; s/<.+?>//g; # remove HTML print {$debuglog} $_; @@ -887,7 +911,7 @@ sub errorlog { sub writelog { my $log = shift; my $msg = shift; - + foreach my $logdir (@logdir) { if (open $log,'>>',"$logdir/$log") { flock $log,LOCK_EX; @@ -929,11 +953,11 @@ sub qqq { my $q = "[\'\"]"; # quote delimiter chars " and ' # remove first newline and look for default indention - s/^(\«(\d+)?)?\n//; + s/^((\d+)?)?\n//; $i = ' ' x ($2||0); # remove trailing spaces at end - s/[ \t]*\»?$//; + s/[ \t]*?$//; @s = split "\n"; @@ -964,7 +988,9 @@ sub qqq { # print superquoted sub pq { my $H = STDOUT; + if (@_ > 1 and defined fileno $_[0]) { $H = shift } + binmode($H,':utf8'); print {$H} qqq(@_); } @@ -976,7 +1002,7 @@ sub check_sender_quota { my $du = 0; my ($file,$size,%file,$data,$upload); local $_; - + if (open $qf,'<',"$sender/\@QUOTA") { while (<$qf>) { s/#.*//; @@ -984,7 +1010,7 @@ sub check_sender_quota { } close $qf; } - + foreach $file (glob "*/$sender/*") { $data = "$file/data"; $upload = "$file/upload"; @@ -1004,7 +1030,7 @@ sub check_sender_quota { } } } - + return($squota,int($du/1024/1024)); } @@ -1016,7 +1042,7 @@ sub check_recipient_quota { my $du = 0; my ($file,$size); local $_; - + if (open my $qf,'<',"$recipient/\@QUOTA") { while (<$qf>) { s/#.*//; @@ -1024,7 +1050,7 @@ sub check_recipient_quota { } close $qf; } - + foreach $file (glob "$recipient/*/*") { if (-f "$file/upload" and $size = readlink "$file/size") { $du += $size; @@ -1032,7 +1058,7 @@ sub check_recipient_quota { $du += $size; } } - + return($rquota,int($du/1024/1024)); } @@ -1049,7 +1075,7 @@ sub getline { sub wcmatch { local $_ = shift; my $p = quotemeta shift; - + $p =~ s/\\\*/.*/g; $p =~ s/\\\?/./g; $p =~ s/\\\[/[/g; @@ -1058,7 +1084,7 @@ sub wcmatch { return /$p/; } - + sub logout { my $logout; if ($skey) { $logout = "/fup?logout=skey:$skey" } @@ -1078,7 +1104,7 @@ sub logout { # print data dump of global or local variables in HTML # input musst be a string, eg: '%ENV' sub DD { - my $v = shift; + my $v = shift; local $_; $n =~ s/.//; @@ -1088,7 +1114,7 @@ sub DD { s/\n$_\n\n"; } - + # make symlink sub mksymlink { my ($file,$link) = @_; @@ -1105,7 +1131,7 @@ sub copy { my $link; local $/; local $_; - + $to .= '/'.basename($from) if -d $to; if (defined($link = readlink $from)) { @@ -1119,7 +1145,7 @@ sub copy { eval $mod if $mod; print {$to} $_; close $to or http_die("internal error: $to - $!"); - if (my @s = stat($from)) { + if (my @s = stat($from)) { chmod $s[2],$to; utime @s[8,9],$to unless $mod; } @@ -1133,7 +1159,7 @@ sub slurp { my $file = shift; local $_; local $/; - + if (open $file,$file) { $_ = <$file>; close $file; @@ -1177,11 +1203,13 @@ sub parse_parameters { my $data = ''; my $filename; local $_; - + if ($cl > 128*$MB) { http_die("request too large"); } - + + binmode(STDIN,':raw'); + foreach (split('&',$ENV{QUERY_STRING})) { if (/(.+?)=(.*)/) { $PARAM{$1} = $2 } else { $PARAM{$_} = $_ } @@ -1234,7 +1262,7 @@ sub vhost { # memorized vhost? (default is in fex.ph) %vhost = split(':',$ENV{VHOST}) if $ENV{VHOST}; - + if (%vhost and $hh and $hh =~ s/^([\w\.-]+).*/$1/) { if ($vhost = $vhost{$hh} and -f "$vhost/lib/fex.ph") { $ENV{VHOST} = "$hh:$vhost"; # memorize vhost for next run @@ -1261,25 +1289,25 @@ sub gpg_encrypt { my ($plain,$to,$keyring,$from) = @_; my ($pid,$pi,$po,$pe,$enc,$err); local $_; - + $pe = gensym; - + $pid = open3($po,$pi,$pe, "gpg --batch --trust-model always --keyring $keyring". " -a -e -r $bcc -r $to" ) or return; - - print {$po} $plain; + + print {$po} "\n",$plain,"\n"; close $po; - + $enc .= $_ while <$pi>; $err .= $_ while <$pe>; errorlog("($from --> $to) $err") if $err; - + close $pi; close $pe; waitpid($pid,0); - + return $enc; } @@ -1290,18 +1318,26 @@ sub mtime { } +# wildcard * to perl regexp +sub quotewild { + local $_ = quotemeta shift; + s/\\\*/.*/g; # allow wildcard * + return $_; +} + + # extract locale functions into hash of subroutine references # e.g. \&german ==> $notify{german} sub locale_functions { my $locale = shift; local $/; local $_; - + if ($locale and open my $fexpp,"$FEXHOME/locale/$locale/lib/fex.pp") { $_ = <$fexpp>; s/.*\n(\#\#\# locale functions)/$1/s; # sub xx {} ==> xx{$locale} = sub {} - s/\nsub (\w+)/\n\$$1\{$locale\} = sub/gs; + s/\nsub (\w+)/\n\$$1\{$locale\} = sub/gs; s/\n}\n/\n};\n/gs; eval $_; close $fexpp; @@ -1318,7 +1354,7 @@ sub notify_locale { $file = $dkey; $dkey = readlink("$file/dkey"); } else { - $file = readlink("$dkeydir/$dkey") + $file = readlink("$dkeydir/$dkey") or http_die("internal error: no DKEY $DKEY"); } $file =~ s:^../::; @@ -1328,13 +1364,13 @@ sub notify_locale { $mtime = mtime("$file/data") or http_die("internal error: no $file/data"); $comment = slurp("$file/comment") || ''; $replyto = readlink "$file/replyto" || ''; - $autodelete = readlink "$file/autodelete" - || readlink "$to/\@AUTODELETE" + $autodelete = readlink "$file/autodelete" + || readlink "$to/\@AUTODELETE" || $::autodelete; - $keep = readlink "$file/keep" - || readlink "$to/\@KEEP" + $keep = readlink "$file/keep" + || readlink "$to/\@KEEP" || $keep_default; - + $locale = readlink "$to/\@LOCALE" || readlink "$file/locale" || 'english'; $_ = untaint("$FEXHOME/locale/$locale/lib/lf.pl"); require if -f; @@ -1353,10 +1389,12 @@ sub notify_locale { ); } -### locale functions ### -# will be extracted by install process and saved in $FEXHOME/lib/lf.pl -# you cannot modify them here without re-installing! +########################### locale functions ########################### +# Will be extracted by install process and saved in $FEXHOME/lib/lf.pl # +# You cannot modify them here without re-installing! # +######################################################################## +# locale function! sub notify { # my ($status,$dkey,$filename,$keep,$warn,$comment,$autodelete) = @_; my %P = @_; @@ -1376,12 +1414,13 @@ sub notify { my ($body,$enc_body); return if $nomail; - + $warn = $P{warn}||2; - $comment = encode_utf8($P{comment}||''); + $comment = $P{comment}||''; + $comment = encode_utf8($P{comment}||'') if utf8::is_utf8($comment); $comment =~ s/^!\*!//; # multi download allow flag $autodelete = $P{autodelete}||$::autodelete; - + $file = untaint(readlink("$dkeydir/$P{dkey}")); $file =~ s/^\.\.\///; # make download protocal same as upload protocol @@ -1405,14 +1444,17 @@ sub notify { $data = "$dkeydir/$P{dkey}/data"; $size = $bytes = -s $data; return unless $size; - if ($nowarning) { - $warning = ''; - } else { - $warning = - "Please avoid download with Internet Explorer, ". - "because it has too many bugs.\n". - "We recommend Firefox or wget."; - } + $warning = + "We recommend fexget or fexit for download,\n". + "because these clients can resume the download after an interruption.\n". + "See $proto://$hostname/tools.html"; + # if ($nowarning) { + # $warning = ''; + # } else { + # $warning = + # "Please avoid download with Internet Explorer, ". + # "because it has too many bugs.\n\n"; + # } if ($filename =~ /\.(tar|zip|7z|arj|rar)$/) { $warning .= "\n\n". "$filename is a container file.\n". @@ -1448,13 +1490,13 @@ sub notify { $mimefilename =~ s/ /_/g; $mimefilename = '=?UTF-8?Q?'.$mimefilename.'?='; } - } - + } + unless ($fileid = readlink("$dkeydir/$P{dkey}/id")) { my @s = stat($data); $fileid = @s ? $s[1].$s[9] : 0; } - + if ($P{status} eq 'new') { $days = $P{keep}; $header .= "Subject: F*EX-upload: $mimefilename\n"; @@ -1469,37 +1511,37 @@ sub notify { $header .= "X-FEX-URL: $durl\n" unless -s $keyring; $download .= "$durl\n"; } - $header .= + $header .= "X-FEX-Filesize: $bytes\n". "X-FEX-File-ID: $fileid\n". "X-FEX-Fexmaster: $ENV{SERVER_ADMIN}\n". "X-Mailer: F*EX\n". "MIME-Version: 1.0\n"; - if ($comment =~ s/^\[(\@(.*?))\]\s*//) { + if ($comment =~ s/^\[(\@(.*?))\]\s*//) { $receiver = "group $1"; if ($_ = readlink "$from/\@GROUP/$2" and m:^../../(.+?)/:) { $receiver .= " (maintainer: $1)"; } - } else { + } else { $receiver = 'you'; } if ($days == 1) { $days .= " day" } else { $days .= " days" } - + # explicite sender set in fex.ph? if ($sender_from) { map { s/^From: <$mfrom/From: <$sender_from/ } $header; open $sendmail,'|-',$sendmail,$mto,$bcc or http_die("cannot start sendmail - $!"); } else { - # for special remote domains do not use same domain in From, + # for special remote domains do not use same domain in From, # because remote MTA will probably reject this e-mail $dfrom = $1 if $mfrom =~ /@(.+)/; $dto = $1 if $mto =~ /@(.+)/; - if ($dfrom and $dto and @remote_domains and - grep { - $dfrom =~ /(^|\.)$_$/ and $dto =~ /(^|\.)$_$/ - } @remote_domains) + if ($dfrom and $dto and @remote_domains and + grep { + $dfrom =~ /(^|\.)$_$/ and $dto =~ /(^|\.)$_$/ + } @remote_domains) { $header =~ s/(From: <)\Q$mfrom\E(.*?)\n/$1$admin$2\nReply-To: $mfrom\n/; open $sendmail,'|-',$sendmail,$mto,$bcc @@ -1509,17 +1551,16 @@ sub notify { or http_die("cannot start sendmail - $!"); } } - if ($comment =~ s/^!(shortmail|\.)!\s*//i - or (readlink "$to/\@NOTIFICATION"||'') =~ /short/i + $comment .= "\n" if $comment; + if ($comment =~ s/^!(shortmail|\.)!\s*//i + or (readlink("$to/\@NOTIFICATION")||'') =~ /short/i ) { $body = qqq(qq( '$comment' - '' '$download' '$size' )); } else { - $comment = "Comment: $comment\n" if $comment; $disclaimer = slurp("$from/\@DISCLAIMER") || qqq(qq( '$warning' '' @@ -1530,6 +1571,7 @@ sub notify { )); $disclaimer .= "\n" . $::disclaimer if $::disclaimer; $body = qqq(qq( + '$comment' '$from has uploaded the file' ' "$filename"' '($size) for $receiver. Use' @@ -1537,7 +1579,6 @@ sub notify { '$download' 'to download this file within $days.' '' - '$comment' '$autodelete' '' '$disclaimer' @@ -1579,24 +1620,27 @@ sub notify { } +# locale function! sub reactivation { my ($expire,$user) = @_; my $fexsend = "$FEXHOME/bin/fexsend"; + my $reactivation = "$FEXLIB/reactivation.txt"; return if $nomail; - + if (-x $fexsend) { + if ($locale) { + my $lr = "$FEXHOME/locale/$locale/lib/reactivation.txt"; + $reactivation = $lr if -f $lr and -s $lr; + } $fexsend .= " -M -D -k 30 -C" ." 'Your F*EX account has been inactive for $expire days," ." you must download this file to reactivate it." ." Otherwise your account will be deleted.'" - ." $FEXLIB/reactivation.txt $user"; + ." $reactivation $user"; # on error show STDOUT and STDERR - system "$fexsend >/dev/null 2>&1"; - if ($?) { - warn "$fexsend\n"; - system $fexsend; - } + my $fo = `$fexsend 2>&1`; + warn $fexsend.'\n'.$fo if $?; } else { warn "$0: cannot execute $fexsend for reactivation()\n"; }