//gi } @msg;
-
+
errorlog($msg);
-
- # cannot send standard HTTP Status-Code 400, because stupid
+
+ $SIG{ALRM} = sub {
+ $SIG{__DIE__} = 'DEFAULT';
+ die "TIMEOUT\n";
+ };
+ alarm($timeout);
+
+ # 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);
@@ -342,12 +399,15 @@ sub html_error {
sub http_die {
-
+
# not in CGI mode
- die "$0: @_\n" unless $ENV{GATEWAY_INTERFACE};
-
+ 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";
@@ -358,7 +418,7 @@ sub http_die {
close $ukey;
}
}
-
+
html_error($error||'',@_);
}
@@ -384,7 +444,7 @@ sub check_maint {
sub check_status {
my $user = shift;
-
+
$user = lc $user;
$user .= '@'.$mdomain if $mdomain and $user !~ /@/;
@@ -415,7 +475,7 @@ sub encode_Q {
my $s = shift;
$s =~ s{([\=\x00-\x20\x7F-\xA0])}{sprintf("=%02X",ord($1))}eog;
return $s;
-}
+}
# from MIME::Base64::Perl
@@ -442,13 +502,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 $_;
}
@@ -461,7 +521,7 @@ sub rmrf {
my ($file,$dir);
local *D;
local $_;
-
+
foreach (@files) {
next if /(^|\/)\.\.$/;
/(.*)/; $file = $1;
@@ -507,7 +567,7 @@ sub gethostname {
if ($hostname !~ /\./ and $admin and $admin =~ /\@([\w.-]+)/) {
$hostname .= '.'.$1;
}
-
+
return $hostname;
}
@@ -515,10 +575,10 @@ sub gethostname {
# strip off path names (Windows or UNIX)
sub strip_path {
local $_ = shift;
-
+
s/.*\\// if /^([A-Z]:)?\\/;
s:.*/::;
-
+
return $_;
}
@@ -526,9 +586,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($_);
@@ -536,7 +596,7 @@ sub normalize {
s/[\x00-\x1F\x80-\x9F]/_/g;
s/^\s+//;
s/\s+$//;
-
+
return encode_utf8($_);
}
@@ -544,12 +604,12 @@ sub normalize {
# substitute all critcal chars
sub normalize_html {
local $_ = shift;
-
+
return '' unless defined $_;
-
+
$_ = normalize($_);
s/[\"<>]//g;
-
+
return $_;
}
@@ -563,20 +623,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/^\./_/;
/(.*)/;
@@ -584,6 +644,23 @@ 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");
+ return untaint($user);
+}
+
+
+sub urldecode {
+ local $_ = shift;
+ s/%([a-f0-9]{2})/chr(hex($1))/gie;
+ return $_;
+}
+
+
sub untaint {
local $_ = shift;
/(.*)/s;
@@ -594,7 +671,7 @@ sub untaint {
sub checkchars {
my $input = shift;
local $_ = shift;
-
+
if (/^([|+.])/) {
http_die("\"$1\" is not allowed at beginning of $input");
}
@@ -617,12 +694,14 @@ sub checkaddress {
my $re;
local $_;
local ($domain,$dns);
-
+
$a =~ s/:\w+=.*//; # remove options from address
-
+
return $a if $a eq 'anonymous';
-
- $re = '^[.@]|@.*@|local(host|domain)$|["\'\`\|\s()<>/;,]';
+
+ $a .= '@'.$mdomain if $mdomain and $a !~ /@/;
+
+ $re = '^[.@-]|@.*@|local(host|domain)$|["\'\`\|\s()<>/;,]';
if ($a =~ /$re/i) {
debuglog("$a has illegal syntax ($re)");
return '';
@@ -630,7 +709,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;
@@ -638,7 +717,7 @@ sub checkaddress {
unless ($dns or mx('uni-stuttgart.de')) {
http_die("Internal error: bad resolver");
}
- }
+ }
};
if ($dns) {
return untaint($a);
@@ -663,8 +742,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) {
@@ -680,10 +758,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;
}
@@ -693,16 +771,16 @@ sub randstring {
sub mkdirp {
my $dir = shift;
my $pdir;
-
+
return if -d $dir;
$dir =~ s:/+$::;
- http_die("cannot mkdir /\n") unless $dir;
+ http_die("cannot mkdir /") unless $dir;
$pdir = $dir;
if ($pdir =~ s:/[^/]+$::) {
mkdirp($pdir) unless -d $pdir;
}
unless (-d $dir) {
- mkdir $dir,0770 or http_die("mkdir $dir - $!\n");
+ mkdir $dir,0770 or http_die("mkdir $dir - $!");
}
}
@@ -726,7 +804,7 @@ sub ipin {
$ipe = lc(ipe($ip));
map { lc } @list;
-
+
foreach $i (@list) {
if ($ip =~ /\./ and $i =~ /\./ or $ip =~ /:/ and $i =~ /:/) {
if ($i =~ /(.+)-(.+)/) {
@@ -769,12 +847,12 @@ sub filename {
chomp $filename;
close $file;
}
-
+
unless ($filename) {
$filename = $file;
$filename =~ s:.*/::;
}
-
+
return $filename;
}
@@ -789,20 +867,16 @@ sub urlencode {
# file and document log
sub fdlog {
my ($log,$file,$s,$size) = @_;
- my $ra;
-
- if (open $log,'>>',$log) {
- flock $log,LOCK_EX;
- seek $log,0,SEEK_END;
- $ra = $ENV{REMOTE_ADDR}||'-';
- $ra .= '/'.$ENV{HTTP_X_FORWARDED_FOR} if $ENV{HTTP_X_FORWARDED_FOR};
- $ra =~ s/\s//g;
- $file =~ s:/data$::;
- printf {$log}
- "%s [%s_%s] %s %s %s/%s\n",
- isodate(time),$$,$ENV{REQUESTCOUNT},$ra,encode_Q($file),$s,$size;
- close $log;
- }
+ my $ra = $ENV{REMOTE_ADDR}||'-';
+ my $msg;
+
+ $ra .= '/'.$ENV{HTTP_X_FORWARDED_FOR} if $ENV{HTTP_X_FORWARDED_FOR};
+ $ra =~ s/\s//g;
+ $file =~ s:/data$::;
+ $msg = sprintf "%s [%s_%s] %s %s %s/%s\n",
+ isodate(time),$$,$ENV{REQUESTCOUNT},$ra,encode_Q($file),$s,$size;
+
+ writelog($log,$msg);
}
@@ -810,21 +884,25 @@ sub fdlog {
sub debuglog {
my $prg = $0;
local $_;
-
+
return unless $debug and @_;
unless ($debuglog and fileno $debuglog) {
- mkdir "$logdir/.debug",0770 unless -d "$logdir/.debug";
+ my $ddir = "$spooldir/.debug";
+ mkdir $ddir,0770 unless -d $ddir;
$prg =~ s:.*/::;
$prg = untaint($prg);
- $debuglog = sprintf("%s/.debug/%s_%s_%s.%s",
- $logdir,time,$$,$ENV{REQUESTCOUNT}||0,$prg);
+ $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} $_;
@@ -836,22 +914,32 @@ sub debuglog {
# extra debug log
sub errorlog {
my $prg = $0;
- my $log = "$logdir/error.log";
my $msg = "@_";
+ my $ra = $ENV{REMOTE_ADDR}||'-';
+ $ra .= '/'.$ENV{HTTP_X_FORWARDED_FOR} if $ENV{HTTP_X_FORWARDED_FOR};
+ $ra =~ s/\s//g;
$prg =~ s:.*/::;
$msg =~ s/[\r\n]+$//;
$msg =~ s/[\r\n]+/ /;
$msg =~ s/\s*.*//;
+ $msg = sprintf "%s %s %s %s\n",isodate(time),$prg,$ra,$msg;
+
+ writelog('error.log',$msg);
+}
+
- if (open $log,'>>',$log) {
- flock $log,LOCK_EX;
- seek $log,0,SEEK_END;
- $ra = $ENV{REMOTE_ADDR}||'-';
- $ra .= '/'.$ENV{HTTP_X_FORWARDED_FOR} if $ENV{HTTP_X_FORWARDED_FOR};
- $ra =~ s/\s//g;
- printf {$log} "%s %s %s %s\n",isodate(time),$prg,$ra,$msg;
- close $log;
+sub writelog {
+ my $log = shift;
+ my $msg = shift;
+
+ foreach my $logdir (@logdir) {
+ if (open $log,'>>',"$logdir/$log") {
+ flock $log,LOCK_EX;
+ seek $log,0,SEEK_END;
+ print {$log} $msg;
+ close $log;
+ }
}
}
@@ -886,11 +974,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";
@@ -921,7 +1009,9 @@ sub qqq {
# print superquoted
sub pq {
my $H = STDOUT;
+
if (@_ > 1 and defined fileno $_[0]) { $H = shift }
+ binmode($H,':utf8');
print {$H} qqq(@_);
}
@@ -931,9 +1021,9 @@ sub check_sender_quota {
my $sender = shift;
my $squota = $sender_quota||0;
my $du = 0;
- my ($file,$size,%file,$data);
+ my ($file,$size,%file,$data,$upload);
local $_;
-
+
if (open $qf,'<',"$sender/\@QUOTA") {
while (<$qf>) {
s/#.*//;
@@ -941,9 +1031,10 @@ sub check_sender_quota {
}
close $qf;
}
-
+
foreach $file (glob "*/$sender/*") {
$data = "$file/data";
+ $upload = "$file/upload";
if (not -l $data and $size = -s $data) {
# count hard links only once (= same inode)
my $i = (stat($data))[1]||0;
@@ -951,11 +1042,16 @@ sub check_sender_quota {
$du += $size;
$file{$i} = $i;
}
- } elsif (-f "$file/upload" and $size = readlink "$file/size") {
- $du += $size;
+ } elsif (-f $upload) {
+ # count hard links only once (= same inode)
+ my $i = (stat($upload))[1]||0;
+ unless ($file{$i}) {
+ $size = readlink "$file/size" and $du += $size;
+ $file{$i} = $i;
+ }
}
}
-
+
return($squota,int($du/1024/1024));
}
@@ -967,7 +1063,7 @@ sub check_recipient_quota {
my $du = 0;
my ($file,$size);
local $_;
-
+
if (open my $qf,'<',"$recipient/\@QUOTA") {
while (<$qf>) {
s/#.*//;
@@ -975,7 +1071,7 @@ sub check_recipient_quota {
}
close $qf;
}
-
+
foreach $file (glob "$recipient/*/*") {
if (-f "$file/upload" and $size = readlink "$file/size") {
$du += $size;
@@ -983,7 +1079,7 @@ sub check_recipient_quota {
$du += $size;
}
}
-
+
return($rquota,int($du/1024/1024));
}
@@ -1000,7 +1096,7 @@ sub getline {
sub wcmatch {
local $_ = shift;
my $p = quotemeta shift;
-
+
$p =~ s/\\\*/.*/g;
$p =~ s/\\\?/./g;
$p =~ s/\\\[/[/g;
@@ -1009,7 +1105,7 @@ sub wcmatch {
return /$p/;
}
-
+
sub logout {
my $logout;
if ($skey) { $logout = "/fup?logout=skey:$skey" }
@@ -1029,7 +1125,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/.//;
@@ -1039,7 +1135,7 @@ sub DD {
s/\n$_\n\n";
}
-
+
# make symlink
sub mksymlink {
my ($file,$link) = @_;
@@ -1056,7 +1152,7 @@ sub copy {
my $link;
local $/;
local $_;
-
+
$to .= '/'.basename($from) if -d $to;
if (defined($link = readlink $from)) {
@@ -1070,7 +1166,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;
}
@@ -1084,7 +1180,7 @@ sub slurp {
my $file = shift;
local $_;
local $/;
-
+
if (open $file,$file) {
$_ = <$file>;
close $file;
@@ -1094,6 +1190,91 @@ sub slurp {
}
+# read one line from STDIN (net socket) and assign it to $_
+# return number of read bytes
+# also set global variable $RB (read bytes)
+sub nvt_read {
+ my $len = 0;
+
+ if (defined ($_ = )) {
+ debuglog($_);
+ $len = length;
+ $RB += $len;
+ s/\r?\n//;
+ }
+ return $len;
+}
+
+
+# read forward to given pattern
+sub nvt_skip_to {
+ my $pattern = shift;
+
+ while (&nvt_read) { return if /$pattern/ }
+}
+
+
+# HTTP GET and POST parameters
+# (not used by fup)
+# fills global variable %PARAM :
+# normal parameter is $PARAM{$parameter}
+# file parameter is $PARAM{$parameter}{filename} $PARAM{$parameter}{data}
+sub parse_parameters {
+ my $cl = $ENV{X_CONTENT_LENGTH} || $ENV{CONTENT_LENGTH} || 0;
+ 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{$_} = $_ }
+ }
+ $_ = $ENV{CONTENT_TYPE}||'';
+ if ($ENV{REQUEST_METHOD} eq 'POST' and /boundary=\"?([\w\-\+\/_]+)/) {
+ my $boundary = $1;
+ while ($RB<$cl and &nvt_read) { last if /^--\Q$boundary/ }
+ # continuation lines are not checked!
+ while ($RB<$cl and &nvt_read) {
+ $filename = '';
+ if (/^Content-Disposition:.*\s*filename="(.+?)"/i) {
+ $filename = $1;
+ }
+ if (/^Content-Disposition:\s*form-data;\s*name="(.+?)"/i) {
+ my $p = $1;
+ # skip rest of mime part header
+ while ($RB<$cl and &nvt_read) { last if /^\s*$/ }
+ $data = '';
+ while () {
+ if ($p =~ /password/i) {
+ debuglog('*' x length)
+ } else {
+ debuglog($_)
+ }
+ $RB += length;
+ last if /^--\Q$boundary/;
+ $data .= $_;
+ }
+ unless (defined $_) { die "premature end of HTTP POST\n" }
+ $data =~ s/\r?\n$//;
+ if ($filename) {
+ $PARAM{$p}{filename} = $filename;
+ $PARAM{$p}{data} = $data;
+ } else {
+ $PARAM{$p} = $data;
+ }
+ last if /^--\Q$boundary--/;
+ }
+ }
+ }
+}
+
+
# name based virtual host?
sub vhost {
my $hh = shift; # HTTP_HOST
@@ -1102,13 +1283,14 @@ 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
$ENV{FEXLIB} = $FEXLIB = "$vhost/lib";
$logdir = $spooldir = "$vhost/spool";
$docdir = "$vhost/htdocs";
+ @logdir = ($logdir);
if ($locale and -e "$vhost/locale/$locale/lib/fex.ph") {
$ENV{FEXLIB} = $FEXLIB = "$vhost/locale/$locale/lib";
}
@@ -1128,41 +1310,55 @@ 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;
}
+sub mtime {
+ my @s = stat(shift) or return;
+ return $s[9];
+}
+
+
+# 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;
@@ -1179,7 +1375,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:^../::;
@@ -1189,13 +1385,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;
@@ -1207,23 +1403,27 @@ sub notify_locale {
status => $status,
dkey => $dkey,
filename => $filename,
- keep => $keep-int((time-$mtime)/DS),
+ keep => $keep-int((time-$mtime)/$DS),
comment => $comment,
autodelete => $autodelete,
replyto => $replyto,
);
}
-### 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 = @_;
my ($to,$from,$file,$mimefilename,$receiver,$warn,$comment,$autodelete);
- my ($size,$bytes,$days,$header,$data,$replyto);
+ my ($size,$bytes,$days,$header,$data,$replyto,$uurl);
my ($mfrom,$mto,$dfrom,$dto);
+ my $proto = 'http';
+ my $durl = $::durl;
my $index;
my $fileid = 0;
my $fua = $ENV{HTTP_USER_AGENT}||'';
@@ -1235,15 +1435,22 @@ 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;
- $index = $durl;
- $index =~ s/fop/index.html/;
- (undef,$to,$from,$file) = split('/',untaint(readlink("$dkeydir/$P{dkey}")));
+ $file = untaint(readlink("$dkeydir/$P{dkey}"));
+ $file =~ s/^\.\.\///;
+ # make download protocal same as upload protocol
+ if ($uurl = readlink("$file/uurl") and $uurl =~ /^(\w+):/) {
+ $proto = $1;
+ $durl =~ s/^\w+::/$proto::/;
+ }
+ $index = "$proto://$hostname/index.html";
+ ($to,$from,$file) = split('/',$file);
$filename = strip_path($P{filename});
$mfrom = $from;
$mto = $to;
@@ -1258,10 +1465,17 @@ sub notify {
$data = "$dkeydir/$P{dkey}/data";
$size = $bytes = -s $data;
return unless $size;
- $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".
@@ -1288,17 +1502,22 @@ sub notify {
} else {
$autodelete = '';
}
- $mimefilename = $filename;
- if ($mimefilename =~ s{([_\?\=\x00-\x1F\x7F-\xFF])}{sprintf("=%02X",ord($1))}eog) {
- $mimefilename =~ s/ /_/g;
- $mimefilename = '=?UTF-8?Q?'.$mimefilename.'?=';
+
+ if (-s $keyring) {
+ $mimefilename = '';
+ } else {
+ $mimefilename = $filename;
+ if ($mimefilename =~ s/([_\?\=\x00-\x1F\x7F-\xFF])/sprintf("=%02X",ord($1))/eog) {
+ $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";
@@ -1308,62 +1527,61 @@ sub notify {
}
$header .= "X-FEX-Client-Address: $fra\n" if $fra;
$header .= "X-FEX-Client-Agent: $fua\n" if $fua;
- foreach my $u (@durl) {
+ foreach my $u (@durl?@durl:($durl)) {
my $durl = sprintf("%s/%s/%s",$u,$P{dkey},normalize_filename($filename));
$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 - $!\n");
+ 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
- or http_die("cannot start sendmail - $!\n");
+ or http_die("cannot start sendmail - $!");
} else {
open $sendmail,'|-',$sendmail,'-f',$mfrom,$mto,$bcc
- or http_die("cannot start sendmail - $!\n");
+ or http_die("cannot start sendmail - $!");
}
}
- if ($comment =~ s/^!(shortmail|\.)!\s*//i
- or (readlink "$to/\@NOTIFICATION"||'') =~ /short/i
+ $comment = "\n$comment\n" if $comment;
+ if ($comment =~ s/\n!(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'
''
@@ -1372,8 +1590,9 @@ sub notify {
''
'Questions? ==> F*EX admin: $admin'
));
- $disclaimer .= "\n" . $::disclaimer if $::disclaimer;
+ $disclaimer .= "\n$::disclaimer\n" if $::disclaimer;
$body = qqq(qq(
+ '$comment'
'$from has uploaded the file'
' "$filename"'
'($size) for $receiver. Use'
@@ -1381,12 +1600,12 @@ sub notify {
'$download'
'to download this file within $days.'
''
- '$comment'
'$autodelete'
''
'$disclaimer'
));
}
+ $body =~ s/\n\n+/\n\n/g;
if (-s $keyring) {
$enc_body = gpg_encrypt($body,$to,$keyring,$from);
}
@@ -1417,30 +1636,32 @@ sub notify {
"Content-Transfer-Encoding: 8bit\n";
}
print {$sendmail} $header,"\n",$body;
- close $sendmail
- or $! and http_die("cannot send notification e-mail (sendmail error $!)\n");
- return $to;
+ close $sendmail and return $to;
+ http_die("cannot send notification e-mail (sendmail error $!)");
}
+# 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";
}