X-Git-Url: http://git.treefish.org/fex.git/blobdiff_plain/97b87610331f53e756d032ad21db786037f921a1..e5c93609849bda051fff54b5d5265af5608c6c69:/lib/fex.pp
diff --git a/lib/fex.pp b/lib/fex.pp
index bd7ed98..c6f0562 100644
--- a/lib/fex.pp
+++ b/lib/fex.pp
@@ -71,7 +71,7 @@ if ($FHS) {
$docdir = '/var/lib/fex/htdocs';
$notify_newrelease = '';
}
-
+
# allowed download managers (HTTP User-Agent)
$adlm = '^(Axel|fex)';
@@ -114,7 +114,7 @@ $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
@@ -161,14 +161,14 @@ 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}) {
-
+
($host,$port) = split(':',$ENV{HTTP_HOST}||'');
$host = $hostname;
-
+
unless ($port) {
$port = 80;
if (open $xinetd,$xinetd) {
@@ -181,7 +181,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";
@@ -217,7 +217,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(
@@ -250,24 +250,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
',
@@ -340,7 +340,7 @@ sub html_header {
$head .= "$title
";
}
$head .= "\n";
-
+
return $head;
}
@@ -350,14 +350,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);
@@ -376,15 +376,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";
@@ -395,7 +395,7 @@ sub http_die {
close $ukey;
}
}
-
+
html_error($error||'',@_);
}
@@ -421,7 +421,7 @@ sub check_maint {
sub check_status {
my $user = shift;
-
+
$user = lc $user;
$user .= '@'.$mdomain if $mdomain and $user !~ /@/;
@@ -452,7 +452,7 @@ sub encode_Q {
my $s = shift;
$s =~ s{([\=\x00-\x20\x7F-\xA0])}{sprintf("=%02X",ord($1))}eog;
return $s;
-}
+}
# from MIME::Base64::Perl
@@ -479,13 +479,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 $_;
}
@@ -498,7 +498,7 @@ sub rmrf {
my ($file,$dir);
local *D;
local $_;
-
+
foreach (@files) {
next if /(^|\/)\.\.$/;
/(.*)/; $file = $1;
@@ -544,7 +544,7 @@ sub gethostname {
if ($hostname !~ /\./ and $admin and $admin =~ /\@([\w.-]+)/) {
$hostname .= '.'.$1;
}
-
+
return $hostname;
}
@@ -552,10 +552,10 @@ sub gethostname {
# strip off path names (Windows or UNIX)
sub strip_path {
local $_ = shift;
-
+
s/.*\\// if /^([A-Z]:)?\\/;
s:.*/::;
-
+
return $_;
}
@@ -563,9 +563,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($_);
@@ -573,7 +573,7 @@ sub normalize {
s/[\x00-\x1F\x80-\x9F]/_/g;
s/^\s+//;
s/\s+$//;
-
+
return encode_utf8($_);
}
@@ -581,12 +581,12 @@ sub normalize {
# substitute all critcal chars
sub normalize_html {
local $_ = shift;
-
+
return '' unless defined $_;
-
+
$_ = normalize($_);
s/[\"<>]//g;
-
+
return $_;
}
@@ -600,20 +600,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/^\./_/;
/(.*)/;
@@ -623,7 +623,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");
@@ -648,7 +648,7 @@ sub untaint {
sub checkchars {
my $input = shift;
local $_ = shift;
-
+
if (/^([|+.])/) {
http_die("\"$1\" is not allowed at beginning of $input");
}
@@ -671,9 +671,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 !~ /@/;
@@ -686,7 +686,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;
@@ -694,7 +694,7 @@ sub checkaddress {
unless ($dns or mx('uni-stuttgart.de')) {
http_die("Internal error: bad resolver");
}
- }
+ }
};
if ($dns) {
return untaint($a);
@@ -735,10 +735,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;
}
@@ -748,7 +748,7 @@ sub randstring {
sub mkdirp {
my $dir = shift;
my $pdir;
-
+
return if -d $dir;
$dir =~ s:/+$::;
http_die("cannot mkdir /") unless $dir;
@@ -781,7 +781,7 @@ sub ipin {
$ipe = lc(ipe($ip));
map { lc } @list;
-
+
foreach $i (@list) {
if ($ip =~ /\./ and $i =~ /\./ or $ip =~ /:/ and $i =~ /:/) {
if ($i =~ /(.+)-(.+)/) {
@@ -824,12 +824,12 @@ sub filename {
chomp $filename;
close $file;
}
-
+
unless ($filename) {
$filename = $file;
$filename =~ s:.*/::;
}
-
+
return $filename;
}
@@ -861,7 +861,7 @@ sub fdlog {
sub debuglog {
my $prg = $0;
local $_;
-
+
return unless $debug and @_;
unless ($debuglog and fileno $debuglog) {
my $ddir = "$spooldir/.debug";
@@ -906,7 +906,7 @@ sub errorlog {
sub writelog {
my $log = shift;
my $msg = shift;
-
+
foreach my $logdir (@logdir) {
if (open $log,'>>',"$logdir/$log") {
flock $log,LOCK_EX;
@@ -983,7 +983,9 @@ sub qqq {
# print superquoted
sub pq {
my $H = STDOUT;
+
if (@_ > 1 and defined fileno $_[0]) { $H = shift }
+ binmode($H,':utf8');
print {$H} qqq(@_);
}
@@ -995,7 +997,7 @@ sub check_sender_quota {
my $du = 0;
my ($file,$size,%file,$data,$upload);
local $_;
-
+
if (open $qf,'<',"$sender/\@QUOTA") {
while (<$qf>) {
s/#.*//;
@@ -1003,7 +1005,7 @@ sub check_sender_quota {
}
close $qf;
}
-
+
foreach $file (glob "*/$sender/*") {
$data = "$file/data";
$upload = "$file/upload";
@@ -1023,7 +1025,7 @@ sub check_sender_quota {
}
}
}
-
+
return($squota,int($du/1024/1024));
}
@@ -1035,7 +1037,7 @@ sub check_recipient_quota {
my $du = 0;
my ($file,$size);
local $_;
-
+
if (open my $qf,'<',"$recipient/\@QUOTA") {
while (<$qf>) {
s/#.*//;
@@ -1043,7 +1045,7 @@ sub check_recipient_quota {
}
close $qf;
}
-
+
foreach $file (glob "$recipient/*/*") {
if (-f "$file/upload" and $size = readlink "$file/size") {
$du += $size;
@@ -1051,7 +1053,7 @@ sub check_recipient_quota {
$du += $size;
}
}
-
+
return($rquota,int($du/1024/1024));
}
@@ -1068,7 +1070,7 @@ sub getline {
sub wcmatch {
local $_ = shift;
my $p = quotemeta shift;
-
+
$p =~ s/\\\*/.*/g;
$p =~ s/\\\?/./g;
$p =~ s/\\\[/[/g;
@@ -1077,7 +1079,7 @@ sub wcmatch {
return /$p/;
}
-
+
sub logout {
my $logout;
if ($skey) { $logout = "/fup?logout=skey:$skey" }
@@ -1097,7 +1099,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/.//;
@@ -1107,7 +1109,7 @@ sub DD {
s/\n$_\n\n";
}
-
+
# make symlink
sub mksymlink {
my ($file,$link) = @_;
@@ -1124,7 +1126,7 @@ sub copy {
my $link;
local $/;
local $_;
-
+
$to .= '/'.basename($from) if -d $to;
if (defined($link = readlink $from)) {
@@ -1138,7 +1140,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;
}
@@ -1152,7 +1154,7 @@ sub slurp {
my $file = shift;
local $_;
local $/;
-
+
if (open $file,$file) {
$_ = <$file>;
close $file;
@@ -1196,11 +1198,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{$_} = $_ }
@@ -1253,7 +1257,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
@@ -1280,25 +1284,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;
close $po;
-
+
$enc .= $_ while <$pi>;
$err .= $_ while <$pe>;
errorlog("($from --> $to) $err") if $err;
-
+
close $pi;
close $pe;
waitpid($pid,0);
-
+
return $enc;
}
@@ -1323,12 +1327,12 @@ 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;
@@ -1345,7 +1349,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:^../::;
@@ -1355,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" || '';
- $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;
@@ -1405,12 +1409,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
@@ -1437,7 +1442,7 @@ sub notify {
if ($nowarning) {
$warning = '';
} else {
- $warning =
+ $warning =
"Please avoid download with Internet Explorer, ".
"because it has too many bugs.\n".
"We recommend Firefox or wget.";
@@ -1477,13 +1482,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";
@@ -1498,37 +1503,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
@@ -1538,7 +1543,7 @@ sub notify {
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(
@@ -1614,7 +1619,7 @@ sub reactivation {
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,"