Original release 20150826

[fex.git] / lib / fex.pp

diff --git a/lib/fex.pp b/lib/fex.pp
index 352b41298ebc5c47194e26c4368fdae9d94c0c77..c6f0562d4328e1a892cf299938321739eeca256d 100644 (file)
--- a/lib/fex.pp
+++ b/lib/fex.pp
@@ -71,13 +71,10 @@ if ($FHS) {
   $docdir = '/var/lib/fex/htdocs';
   $notify_newrelease = '';
 }
   $docdir = '/var/lib/fex/htdocs';
   $notify_newrelease = '';
 }

-  
+

 # allowed download managers (HTTP User-Agent)
 $adlm = '^(Axel|fex)';
 
 # 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 - $!";
 
 # local config
 require "$FEXLIB/fex.ph" or die "$0: cannot load $FEXLIB/fex.ph - $!";
 


@@ -89,6 +86,13 @@ $debug               = 0 if $debug           =~ /no/i;
 @logdir = ($logdir) unless @logdir;
 $logdir = $logdir[0];
 
 @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'});
 
 # check for name based virtual host
 $vhost = vhost($ENV{'HTTP_HOST'});
 


@@ -110,7 +114,7 @@ $ENV{PROTO} = 'http' unless $ENV{PROTO};
 $keep = $keep_default ||= $keep || 5;
 $fra = $ENV{REMOTE_ADDR} || '';
 $sid = $ENV{SID} || '';
 $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($dkeydir = "$spooldir/.dkeys"); # download keys
 mkdirp($ukeydir = "$spooldir/.ukeys"); # upload keys
 mkdirp($akeydir = "$spooldir/.akeys"); # authentification keys


@@ -154,18 +158,20 @@ $default_locale ||= 'english';
 # $durl is first default fop download URL
 # @durl is optional mandatory fop download URL list (from fex.ph)
 unless ($durl) {
 # $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}) {
   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;
     ($host,$port) = split(':',$ENV{HTTP_HOST}||'');
     $host = $hostname;

-  
+

     unless ($port) {
       $port = 80;
     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;
         while (<$xinetd>) {
           if (/^\s*port\s*=\s*(\d+)/) {
             $port = $1;


@@ -175,7 +181,7 @@ unless ($durl) {
         close $xinetd;
       }
     }
         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";
     # 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 +189,23 @@ unless ($durl) {
       $durl = "$ENV{PROTO}://$host:$port/fop";
     }
   } else {
       $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 {
 
 
 sub reexec {


@@ -197,7 +217,7 @@ sub reexec {
 sub jsredirect {
   $url = shift;
   $cont = shift || 'request accepted: continue';
 sub jsredirect {
   $url = shift;
   $cont = shift || 'request accepted: continue';

-  
+

   http_header('200 ok');
   print html_header($head||$ENV{SERVER_NAME});
   pq(qq(
   http_header('200 ok');
   print html_header($head||$ENV{SERVER_NAME});
   pq(qq(


@@ -230,24 +250,24 @@ sub nvt_print {
 
 sub html_quote {
   local $_ = shift;
 
 sub html_quote {
   local $_ = shift;

-  
+

   s/&/&amp;/g;
   s/</&lt;/g;
   s/\"/&quot;/g;
   s/&/&amp;/g;
   s/</&lt;/g;
   s/\"/&quot;/g;

-  
+

   return $_;
 }
 
 
 
 sub http_header {
   return $_;
 }
 
 
 
 sub http_header {

-  
+

   my $status = shift;
   my $msg = $status;
 
   return if $HTTP_HEADER;
   $HTTP_HEADER = $status;
   my $status = shift;
   my $msg = $status;
 
   return if $HTTP_HEADER;
   $HTTP_HEADER = $status;

-  
+

   $msg =~ s/^\d+\s*//;
 
   nvt_print("HTTP/1.1 $status");
   $msg =~ s/^\d+\s*//;
 
   nvt_print("HTTP/1.1 $status");


@@ -260,7 +280,7 @@ sub http_header {
   nvt_print("X-Frame-Options: SAMEORIGIN");
   if ($force_https) {
     # https://www.owasp.org/index.php/HTTP_Strict_Transport_Security
   nvt_print("X-Frame-Options: SAMEORIGIN");
   if ($force_https) {
     # https://www.owasp.org/index.php/HTTP_Strict_Transport_Security

-    nvt_print("Strict-Transport-Security: max-age=2851200");
+    nvt_print("Strict-Transport-Security: max-age=2851200; preload");

   }
   if ($use_cookies) {
     if ($akey) {
   }
   if ($use_cookies) {
     if ($akey) {


@@ -298,19 +318,19 @@ sub html_header {
     '</head>'
   ));
   # '<!-- <style type="text/css">\@import "/fex.css";</style> -->'
     '</head>'
   ));
   # '<!-- <style type="text/css">\@import "/fex.css";</style> -->'

-  
-  if ($0 =~ /fexdev/) { $head .= "<body bgcolor=\"pink\">\n" } 
+
+  if ($0 =~ /fexdev/) { $head .= "<body bgcolor=\"pink\">\n" }

   else                { $head .= "<body>\n" }
   else                { $head .= "<body>\n" }

-  
+

   $title =~ s:F\*EX:<a href="/index.html">F*EX</a>:;
 
   if (open $header,'<',"$docdir/$header") {
     $head .= $_ while <$header>;
     close $header;
   }
   $title =~ s:F\*EX:<a href="/index.html">F*EX</a>:;
 
   if (open $header,'<',"$docdir/$header") {
     $head .= $_ while <$header>;
     close $header;
   }

-  
+

   $head .= &$prolog($title) if defined($prolog);
   $head .= &$prolog($title) if defined($prolog);

-  
+

   if (@H1_extra) {
     $head .= sprintf(
       '<h1><a href="%s"><img align=center src="%s" border=0></a>%s</h1>',
   if (@H1_extra) {
     $head .= sprintf(
       '<h1><a href="%s"><img align=center src="%s" border=0></a>%s</h1>',


@@ -320,7 +340,7 @@ sub html_header {
     $head .= "<h1>$title</h1>";
   }
   $head .= "\n";
     $head .= "<h1>$title</h1>";
   }
   $head .= "\n";

-  
+

   return $head;
 }
 
   return $head;
 }
 


@@ -330,14 +350,14 @@ sub html_error {
   my $msg = "@_";
   my @msg = @_;
   my $isodate = isodate(time);
   my $msg = "@_";
   my @msg = @_;
   my $isodate = isodate(time);

-  
+

   $msg =~ s/[\s\n]+/ /g;
   $msg =~ s/<.+?>//g; # remove HTML
   map { s/<script.*?>//gi } @msg;
   $msg =~ s/[\s\n]+/ /g;
   $msg =~ s/<.+?>//g; # remove HTML
   map { s/<script.*?>//gi } @msg;

-  
+

   errorlog($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);
   # Internet Explorer then refuses to display HTML body!
   http_header("666 Bad Request - $msg");
   print html_header($error);


@@ -356,15 +376,15 @@ sub html_error {
 
 
 sub http_die {
 
 
 sub http_die {

-  
+

   # not in CGI mode
   unless ($ENV{GATEWAY_INTERFACE}) {
     warn "$0: @_\n"; # must not die, because of fex_cleanup!
     return;
   }
   # not in CGI mode
   unless ($ENV{GATEWAY_INTERFACE}) {
     warn "$0: @_\n"; # must not die, because of fex_cleanup!
     return;
   }

-  
+

   debuglog(@_);
   debuglog(@_);

-  
+

   # create special error file on upload
   if ($uid) {
     my $ukey = "$spooldir/.ukeys/$uid";
   # create special error file on upload
   if ($uid) {
     my $ukey = "$spooldir/.ukeys/$uid";


@@ -375,7 +395,7 @@ sub http_die {
       close $ukey;
     }
   }
       close $ukey;
     }
   }

-  
+

   html_error($error||'',@_);
 }
 
   html_error($error||'',@_);
 }
 


@@ -401,7 +421,7 @@ sub check_maint {
 
 sub check_status {
   my $user = shift;
 
 sub check_status {
   my $user = shift;

-  
+

   $user = lc $user;
   $user .= '@'.$mdomain if $mdomain and $user !~ /@/;
 
   $user = lc $user;
   $user .= '@'.$mdomain if $mdomain and $user !~ /@/;
 


@@ -432,7 +452,7 @@ sub encode_Q {
   my $s = shift;
   $s =~ s{([\=\x00-\x20\x7F-\xA0])}{sprintf("=%02X",ord($1))}eog;
   return $s;
   my $s = shift;
   $s =~ s{([\=\x00-\x20\x7F-\xA0])}{sprintf("=%02X",ord($1))}eog;
   return $s;

-}  
+}

 
 
 # from MIME::Base64::Perl
 
 
 # from MIME::Base64::Perl


@@ -459,13 +479,13 @@ sub decode_b64 {
 sub b64 {
   local $_ = '';
   my $x = 0;
 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}$//;
   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 $_;
 }
 
   return $_;
 }
 


@@ -478,7 +498,7 @@ sub rmrf {
   my ($file,$dir);
   local *D;
   local $_;
   my ($file,$dir);
   local *D;
   local $_;

-  
+

   foreach (@files) {
     next if /(^|\/)\.\.$/;
     /(.*)/; $file = $1;
   foreach (@files) {
     next if /(^|\/)\.\.$/;
     /(.*)/; $file = $1;


@@ -524,7 +544,7 @@ sub gethostname {
   if ($hostname !~ /\./ and $admin and $admin =~ /\@([\w.-]+)/) {
     $hostname .= '.'.$1;
   }
   if ($hostname !~ /\./ and $admin and $admin =~ /\@([\w.-]+)/) {
     $hostname .= '.'.$1;
   }

-  
+

   return $hostname;
 }
 
   return $hostname;
 }
 


@@ -532,10 +552,10 @@ sub gethostname {
 # strip off path names (Windows or UNIX)
 sub strip_path {
   local $_ = shift;
 # strip off path names (Windows or UNIX)
 sub strip_path {
   local $_ = shift;

-  
+

   s/.*\\// if /^([A-Z]:)?\\/;
   s:.*/::;
   s/.*\\// if /^([A-Z]:)?\\/;
   s:.*/::;

-  
+

   return $_;
 }
 
   return $_;
 }
 


@@ -543,9 +563,9 @@ sub strip_path {
 # substitute all critcal chars
 sub normalize {
   local $_ = shift;
 # substitute all critcal chars
 sub normalize {
   local $_ = shift;

-  
+

   return '' unless defined $_;
   return '' unless defined $_;

-  
+

   # we need perl native utf8 (see perldoc utf8)
   $_ = decode_utf8($_) unless utf8::is_utf8($_);
 
   # we need perl native utf8 (see perldoc utf8)
   $_ = decode_utf8($_) unless utf8::is_utf8($_);
 


@@ -553,7 +573,7 @@ sub normalize {
   s/[\x00-\x1F\x80-\x9F]/_/g;
   s/^\s+//;
   s/\s+$//;
   s/[\x00-\x1F\x80-\x9F]/_/g;
   s/^\s+//;
   s/\s+$//;

-  
+

   return encode_utf8($_);
 }
 
   return encode_utf8($_);
 }
 


@@ -561,12 +581,12 @@ sub normalize {
 # substitute all critcal chars
 sub normalize_html {
   local $_ = shift;
 # substitute all critcal chars
 sub normalize_html {
   local $_ = shift;

-  
+

   return '' unless defined $_;
   return '' unless defined $_;

-  
+

   $_ = normalize($_);
   s/[\"<>]//g;
   $_ = normalize($_);
   s/[\"<>]//g;

-  
+

   return $_;
 }
 
   return $_;
 }
 


@@ -580,20 +600,20 @@ sub normalize_filename {
 
   # we need native utf8
   $_ = decode_utf8($_) unless utf8::is_utf8($_);
 
   # we need native utf8
   $_ = decode_utf8($_) unless utf8::is_utf8($_);

- 
+

   $_ = strip_path($_);
   $_ = strip_path($_);

-  
+

   # substitute all critcal chars with underscore
   s/[^a-zA-Z0-9_=.+-]/_/g;
   s/^\./_/;
   # substitute all critcal chars with underscore
   s/[^a-zA-Z0-9_=.+-]/_/g;
   s/^\./_/;

-  
+

   return encode_utf8($_);
 }
 
 
 sub normalize_email {
   local $_ = lc shift;
   return encode_utf8($_);
 }
 
 
 sub normalize_email {
   local $_ = lc shift;

-  
+

   s/[^\w_.+=!~#^\@\-]//g;
   s/^\./_/;
   /(.*)/;
   s/[^\w_.+=!~#^\@\-]//g;
   s/^\./_/;
   /(.*)/;


@@ -603,7 +623,7 @@ sub normalize_email {
 
 sub normalize_user {
   my $user = shift;
 
 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");
   $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 +648,7 @@ sub untaint {
 sub checkchars {
   my $input = shift;
   local $_ = shift;
 sub checkchars {
   my $input = shift;
   local $_ = shift;

-  
+

   if (/^([|+.])/) {
     http_die("\"$1\" is not allowed at beginning of $input");
   }
   if (/^([|+.])/) {
     http_die("\"$1\" is not allowed at beginning of $input");
   }


@@ -651,9 +671,9 @@ sub checkaddress {
   my $re;
   local $_;
   local ($domain,$dns);
   my $re;
   local $_;
   local ($domain,$dns);

-  
+

   $a =~ s/:\w+=.*//; # remove options from address
   $a =~ s/:\w+=.*//; # remove options from address

-  
+

   return $a if $a eq 'anonymous';
 
   $a .= '@'.$mdomain if $mdomain and $a !~ /@/;
   return $a if $a eq 'anonymous';
 
   $a .= '@'.$mdomain if $mdomain and $a !~ /@/;


@@ -666,7 +686,7 @@ sub checkaddress {
   $re = '^[!^=~#_:.+*{}\w\-\[\]]+\@(\w[.\w\-]*\.[a-z]+)$';
   if ($a =~ /$re/i) {
     $domain = $dns = $1;
   $re = '^[!^=~#_:.+*{}\w\-\[\]]+\@(\w[.\w\-]*\.[a-z]+)$';
   if ($a =~ /$re/i) {
     $domain = $dns = $1;

-    { 
+    {

       local $SIG{__DIE__} = sub { die "\n" };
       eval q{
         use Net::DNS;
       local $SIG{__DIE__} = sub { die "\n" };
       eval q{
         use Net::DNS;


@@ -674,7 +694,7 @@ sub checkaddress {
         unless ($dns or mx('uni-stuttgart.de')) {
           http_die("Internal error: bad resolver");
         }
         unless ($dns or mx('uni-stuttgart.de')) {
           http_die("Internal error: bad resolver");
         }

-      } 
+      }

     };
     if ($dns) {
       return untaint($a);
     };
     if ($dns) {
       return untaint($a);


@@ -699,8 +719,7 @@ sub checkforbidden {
   return $a if -d "$spooldir/$a"; # ok, if user already exists
   if (@forbidden_recipients) {
     foreach (@forbidden_recipients) {
   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) {
       # skip public recipients
       if (@public_recipients) {
         foreach $pr (@public_recipients) {


@@ -716,10 +735,10 @@ sub checkforbidden {
 
 sub randstring {
   my $n = shift;
 
 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;
   my $rs;

-  
+

   for (1..$n) { $rs .= $rc[int(rand($rn))] };
   return $rs;
 }
   for (1..$n) { $rs .= $rc[int(rand($rn))] };
   return $rs;
 }


@@ -729,7 +748,7 @@ sub randstring {
 sub mkdirp {
   my $dir = shift;
   my $pdir;
 sub mkdirp {
   my $dir = shift;
   my $pdir;

-  
+

   return if -d $dir;
   $dir =~ s:/+$::;
   http_die("cannot mkdir /") unless $dir;
   return if -d $dir;
   $dir =~ s:/+$::;
   http_die("cannot mkdir /") unless $dir;


@@ -762,7 +781,7 @@ sub ipin {
 
   $ipe = lc(ipe($ip));
   map { lc } @list;
 
   $ipe = lc(ipe($ip));
   map { lc } @list;

-  
+

   foreach $i (@list) {
     if ($ip =~ /\./ and $i =~ /\./ or $ip =~ /:/ and $i =~ /:/) {
       if ($i =~ /(.+)-(.+)/) {
   foreach $i (@list) {
     if ($ip =~ /\./ and $i =~ /\./ or $ip =~ /:/ and $i =~ /:/) {
       if ($i =~ /(.+)-(.+)/) {


@@ -805,12 +824,12 @@ sub filename {
     chomp $filename;
     close $file;
   }
     chomp $filename;
     close $file;
   }

-  
+

   unless ($filename) {
     $filename = $file;
     $filename =~ s:.*/::;
   }
   unless ($filename) {
     $filename = $file;
     $filename =~ s:.*/::;
   }

-  
+

   return $filename;
 }
 
   return $filename;
 }
 


@@ -842,7 +861,7 @@ sub fdlog {
 sub debuglog {
   my $prg = $0;
   local $_;
 sub debuglog {
   my $prg = $0;
   local $_;

-  
+

   return unless $debug and @_;
   unless ($debuglog and fileno $debuglog) {
     my $ddir = "$spooldir/.debug";
   return unless $debug and @_;
   unless ($debuglog and fileno $debuglog) {
     my $ddir = "$spooldir/.debug";


@@ -887,7 +906,7 @@ sub errorlog {
 sub writelog {
   my $log = shift;
   my $msg = shift;
 sub writelog {
   my $log = shift;
   my $msg = shift;

-  
+

   foreach my $logdir (@logdir) {
     if (open $log,'>>',"$logdir/$log") {
       flock $log,LOCK_EX;
   foreach my $logdir (@logdir) {
     if (open $log,'>>',"$logdir/$log") {
       flock $log,LOCK_EX;


@@ -964,7 +983,9 @@ sub qqq {
 # print superquoted
 sub pq {
   my $H = STDOUT;
 # print superquoted
 sub pq {
   my $H = STDOUT;

+

   if (@_ > 1 and defined fileno $_[0]) { $H = shift }
   if (@_ > 1 and defined fileno $_[0]) { $H = shift }

+  binmode($H,':utf8');

   print {$H} qqq(@_);
 }
 
   print {$H} qqq(@_);
 }
 


@@ -976,7 +997,7 @@ sub check_sender_quota {
   my $du = 0;
   my ($file,$size,%file,$data,$upload);
   local $_;
   my $du = 0;
   my ($file,$size,%file,$data,$upload);
   local $_;

-  
+

   if (open $qf,'<',"$sender/\@QUOTA") {
     while (<$qf>) {
       s/#.*//;
   if (open $qf,'<',"$sender/\@QUOTA") {
     while (<$qf>) {
       s/#.*//;


@@ -984,7 +1005,7 @@ sub check_sender_quota {
     }
     close $qf;
   }
     }
     close $qf;
   }

-  
+

   foreach $file (glob "*/$sender/*") {
     $data = "$file/data";
     $upload = "$file/upload";
   foreach $file (glob "*/$sender/*") {
     $data = "$file/data";
     $upload = "$file/upload";


@@ -1004,7 +1025,7 @@ sub check_sender_quota {
       }
     }
   }
       }
     }
   }

-  
+

   return($squota,int($du/1024/1024));
 }
 
   return($squota,int($du/1024/1024));
 }
 


@@ -1016,7 +1037,7 @@ sub check_recipient_quota {
   my $du = 0;
   my ($file,$size);
   local $_;
   my $du = 0;
   my ($file,$size);
   local $_;

-  
+

   if (open my $qf,'<',"$recipient/\@QUOTA") {
     while (<$qf>) {
       s/#.*//;
   if (open my $qf,'<',"$recipient/\@QUOTA") {
     while (<$qf>) {
       s/#.*//;


@@ -1024,7 +1045,7 @@ sub check_recipient_quota {
     }
     close $qf;
   }
     }
     close $qf;
   }

-  
+

   foreach $file (glob "$recipient/*/*") {
     if (-f "$file/upload" and $size = readlink "$file/size") {
       $du += $size;
   foreach $file (glob "$recipient/*/*") {
     if (-f "$file/upload" and $size = readlink "$file/size") {
       $du += $size;


@@ -1032,7 +1053,7 @@ sub check_recipient_quota {
       $du += $size;
     }
   }
       $du += $size;
     }
   }

-  
+

   return($rquota,int($du/1024/1024));
 }
 
   return($rquota,int($du/1024/1024));
 }
 


@@ -1049,7 +1070,7 @@ sub getline {
 sub wcmatch {
   local $_ = shift;
   my $p = quotemeta shift;
 sub wcmatch {
   local $_ = shift;
   my $p = quotemeta shift;

-  
+

   $p =~ s/\\\*/.*/g;
   $p =~ s/\\\?/./g;
   $p =~ s/\\\[/[/g;
   $p =~ s/\\\*/.*/g;
   $p =~ s/\\\?/./g;
   $p =~ s/\\\[/[/g;


@@ -1058,7 +1079,7 @@ sub wcmatch {
   return /$p/;
 }
 
   return /$p/;
 }
 

-  
+

 sub logout {
   my $logout;
   if    ($skey) { $logout = "/fup?logout=skey:$skey" }
 sub logout {
   my $logout;
   if    ($skey) { $logout = "/fup?logout=skey:$skey" }


@@ -1078,7 +1099,7 @@ sub logout {
 # print data dump of global or local variables in HTML
 # input musst be a string, eg: '%ENV'
 sub DD {
 # 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/.//;
   local $_;
 
   $n =~ s/.//;


@@ -1088,7 +1109,7 @@ sub DD {
   s/</&lt;/g;
   print "<pre>\n$_\n</pre>\n";
 }
   s/</&lt;/g;
   print "<pre>\n$_\n</pre>\n";
 }

-  
+

 # make symlink
 sub mksymlink {
   my ($file,$link) = @_;
 # make symlink
 sub mksymlink {
   my ($file,$link) = @_;


@@ -1105,7 +1126,7 @@ sub copy {
   my $link;
   local $/;
   local $_;
   my $link;
   local $/;
   local $_;

-  
+

   $to .= '/'.basename($from) if -d $to;
 
   if (defined($link = readlink $from)) {
   $to .= '/'.basename($from) if -d $to;
 
   if (defined($link = readlink $from)) {


@@ -1119,7 +1140,7 @@ sub copy {
     eval $mod if $mod;
     print {$to} $_;
     close $to or http_die("internal error: $to - $!");
     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;
     }
       chmod $s[2],$to;
       utime @s[8,9],$to unless $mod;
     }


@@ -1133,7 +1154,7 @@ sub slurp {
   my $file = shift;
   local $_;
   local $/;
   my $file = shift;
   local $_;
   local $/;

-  
+

   if (open $file,$file) {
     $_ = <$file>;
     close $file;
   if (open $file,$file) {
     $_ = <$file>;
     close $file;


@@ -1177,11 +1198,13 @@ sub parse_parameters {
   my $data = '';
   my $filename;
   local $_;
   my $data = '';
   my $filename;
   local $_;

-  
+

   if ($cl > 128*$MB) {
     http_die("request too large");
   }
   if ($cl > 128*$MB) {
     http_die("request too large");
   }

-  
+
+  binmode(STDIN,':raw');
+

   foreach (split('&',$ENV{QUERY_STRING})) {
     if (/(.+?)=(.*)/) { $PARAM{$1} = $2 }
     else              { $PARAM{$_} = $_ }
   foreach (split('&',$ENV{QUERY_STRING})) {
     if (/(.+?)=(.*)/) { $PARAM{$1} = $2 }
     else              { $PARAM{$_} = $_ }


@@ -1234,7 +1257,7 @@ sub vhost {
 
   # memorized vhost? (default is in fex.ph)
   %vhost = split(':',$ENV{VHOST}) if $ENV{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
   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 +1284,25 @@ sub gpg_encrypt {
   my ($plain,$to,$keyring,$from) = @_;
   my ($pid,$pi,$po,$pe,$enc,$err);
   local $_;
   my ($plain,$to,$keyring,$from) = @_;
   my ($pid,$pi,$po,$pe,$enc,$err);
   local $_;

-  
+

   $pe = gensym;
   $pe = gensym;

-  
+

   $pid = open3($po,$pi,$pe,
     "gpg --batch --trust-model always --keyring $keyring".
     "    -a -e -r $bcc -r $to"
   ) or return;
   $pid = open3($po,$pi,$pe,
     "gpg --batch --trust-model always --keyring $keyring".
     "    -a -e -r $bcc -r $to"
   ) or return;

-  
+

   print {$po} $plain;
   close $po;
   print {$po} $plain;
   close $po;

-    
+

   $enc .= $_ while <$pi>;
   $err .= $_ while <$pe>;
   errorlog("($from --> $to) $err") if $err;
   $enc .= $_ while <$pi>;
   $err .= $_ while <$pe>;
   errorlog("($from --> $to) $err") if $err;

-  
+

   close $pi;
   close $pe;
   waitpid($pid,0);
   close $pi;
   close $pe;
   waitpid($pid,0);

-  
+

   return $enc;
 }
 
   return $enc;
 }
 


@@ -1290,18 +1313,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 $_;
 # 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 {}
   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;
     s/\n}\n/\n};\n/gs;
     eval $_;
     close $fexpp;


@@ -1318,7 +1349,7 @@ sub notify_locale {
     $file = $dkey;
     $dkey = readlink("$file/dkey");
   } else {
     $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:^../::;
       or http_die("internal error: no DKEY $DKEY");
   }
   $file =~ s:^../::;


@@ -1328,13 +1359,13 @@ sub notify_locale {
   $mtime = mtime("$file/data") or http_die("internal error: no $file/data");
   $comment = slurp("$file/comment") || '';
   $replyto = readlink "$file/replyto" || '';
   $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;
              || $::autodelete;

-  $keep = readlink "$file/keep" 
-       || readlink "$to/\@KEEP" 
+  $keep = readlink "$file/keep"
+       || readlink "$to/\@KEEP"

        || $keep_default;
        || $keep_default;

-  
+

   $locale = readlink "$to/\@LOCALE" || readlink "$file/locale" || 'english';
   $_ = untaint("$FEXHOME/locale/$locale/lib/lf.pl");
   require if -f;
   $locale = readlink "$to/\@LOCALE" || readlink "$file/locale" || 'english';
   $_ = untaint("$FEXHOME/locale/$locale/lib/lf.pl");
   require if -f;


@@ -1353,10 +1384,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 = @_;
 sub notify {
   # my ($status,$dkey,$filename,$keep,$warn,$comment,$autodelete) = @_;
   my %P = @_;


@@ -1376,12 +1409,13 @@ sub notify {
   my ($body,$enc_body);
 
   return if $nomail;
   my ($body,$enc_body);
 
   return if $nomail;

-  
+

   $warn = $P{warn}||2;
   $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;
   $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
   $file = untaint(readlink("$dkeydir/$P{dkey}"));
   $file =~ s/^\.\.\///;
   # make download protocal same as upload protocol


@@ -1408,7 +1442,7 @@ sub notify {
   if ($nowarning) {
     $warning = '';
   } else {
   if ($nowarning) {
     $warning = '';
   } else {

-    $warning = 
+    $warning =

       "Please avoid download with Internet Explorer, ".
       "because it has too many bugs.\n".
       "We recommend Firefox or wget.";
       "Please avoid download with Internet Explorer, ".
       "because it has too many bugs.\n".
       "We recommend Firefox or wget.";


@@ -1448,13 +1482,13 @@ sub notify {
       $mimefilename =~ s/ /_/g;
       $mimefilename = '=?UTF-8?Q?'.$mimefilename.'?=';
     }
       $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;
   }
   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";
   if ($P{status} eq 'new') {
     $days = $P{keep};
     $header .= "Subject: F*EX-upload: $mimefilename\n";


@@ -1469,37 +1503,37 @@ sub notify {
     $header .= "X-FEX-URL: $durl\n" unless -s $keyring;
     $download .= "$durl\n";
   }
     $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";
     "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)";
     }
     $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" }
     $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 {
   # 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   =~ /@(.+)/;
     # 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
     {
       $header =~ s/(From: <)\Q$mfrom\E(.*?)\n/$1$admin$2\nReply-To: $mfrom\n/;
       open $sendmail,'|-',$sendmail,$mto,$bcc


@@ -1509,7 +1543,7 @@ sub notify {
         or http_die("cannot start sendmail - $!");
     }
   }
         or http_die("cannot start sendmail - $!");
     }
   }

-  if ($comment =~ s/^!(shortmail|\.)!\s*//i 
+  if ($comment =~ s/^!(shortmail|\.)!\s*//i

     or (readlink "$to/\@NOTIFICATION"||'') =~ /short/i
   ) {
     $body = qqq(qq(
     or (readlink "$to/\@NOTIFICATION"||'') =~ /short/i
   ) {
     $body = qqq(qq(


@@ -1579,12 +1613,13 @@ sub notify {
 }
 
 
 }
 
 

+# locale function!

 sub reactivation {
   my ($expire,$user) = @_;
   my $fexsend = "$FEXHOME/bin/fexsend";
 
   return if $nomail;
 sub reactivation {
   my ($expire,$user) = @_;
   my $fexsend = "$FEXHOME/bin/fexsend";
 
   return if $nomail;

-  
+

   if (-x $fexsend) {
     $fexsend .= " -M -D -k 30 -C"
                ." 'Your F*EX account has been inactive for $expire days,"
   if (-x $fexsend) {
     $fexsend .= " -M -D -k 30 -C"
                ." 'Your F*EX account has been inactive for $expire days,"