our ($FEXID,$FEXXX,$HOME);
our (%alias);
our $chunksize = 0;
-our $version = 20150120;
+our $version = 20150615;
our $_0 = $0;
our $DEBUG;
$0 -b # other\@address
Where # is the file number.
+You can list an uploaded file in more detail with
+ $0 -l #
+Where # is the file number.
+
If you want to modify the keep time, comment or auto-delete behaviour of an
already uploaded file then you first have to query the file number with:
$0 -l
if ($fexcgi =~ /\?/) {
$from = $1 if $fexcgi =~ /\bfrom=(.+?)(&|$)/i;
$id = $1 if $fexcgi =~ /\bid=(.+?)(&|$)/i;
- $skey = $1 if $fexcgi =~ /\bskey=(.+?)(&|$)/i;
- $gkey = $1 if $fexcgi =~ /\bgkey=(.+?)(&|$)/i;
+ # $skey = $1 if $fexcgi =~ /\bskey=(.+?)(&|$)/i;
+ # $gkey = $1 if $fexcgi =~ /\bgkey=(.+?)(&|$)/i;
+ die "$0: cannot use GKEY URL in ID file\n" if $fexcgi =~ /gkey=/i;
+ die "$0: cannot use SKEY URL in ID file\n" if $fexcgi =~ /skey=/i;
$fexcgi =~ s/\?.*//;
}
unless ($fexcgi =~ /^[_:=\w\-\.\/\@\%]+$/) {
else { $dkey = '' }
# $_ = encode_utf8($_);
s/<.*?>//g;
+ s/&/&/g;
+ s/"/\"/g;
+ s/</</g;
if (/^(to .* :)/) {
print "\n$1\n";
print {$fexlist} "\n$1\n";
my @files = ();
my ($data,$aname,$alias);
my (@r,$r);
- my $ma = $HOME.'/.mutt/aliases';
my $t0 = time;
my $transferfile;
my @transferfiles;
# $to = $AB{$to};
}
# look for mutt aliases
- elsif ($to !~ /@/ and $to ne $from and open $ma,$ma) {
- $alias = $to;
- while (<$ma>) {
- if (/^alias \Q$to\E\s/i) {
- chomp;
- s/\s*#.*//;
- s/\(.*?\)//;
- s/\s+$//;
- s/.*\s+//;
- s/[<>]//g;
- if (/,/) {
- warn "$0: ignoring mutt multi-alias $to = $alias\n";
- last;
- }
- if (/@/) {
- $alias = $_;
- warn "$0: found mutt alias $to = $alias\n";
- last;
- }
- }
- }
- close $ma;
- $to = $alias;
+ elsif ($to !~ /@/ and $to ne $from) {
+ $to = get_mutt_alias($to);
}
}
}
$to = join(',',grep /./,@to) or exit;
- warn "Server/User: $fexcgi/$from\n" unless $opt_q;
+ # warn "Server/User: $fexcgi/$from\n" unless $opt_q;
if (
not $skey and not $gkey
+ and $from ne $to
and $features =~ /CHECKRECIPIENT/
and $opt_C !~ /^(DELETE|LIST|RECEIVEDLOG|SENDLOG|FOPLOG)$/
) {
sub forward {
my (@r);
my ($to,$n,$dkey,$file,$req);
- my $status = 1;
+ my ($status,$fp);
local $_;
# look for single @ in arguments
# if ($windoof and not @ARGV) { &inquire }
$to = pop @ARGV or die $usage;
$to = $from if $to eq '.';
+ if ($to !~ /@/ and $to ne $from) {
+ $to = get_mutt_alias($to);
+ }
open $fexlist,$fexlist or die "$0: $fexlist - $!\n";
while (<$fexlist>) {
$req .= " HTTP/1.1";
sendheader("$server:$port",$req);
http_response();
+ $fp = $file;
+ $fp =~ s/[^\w_.-]/.+/g; # because of UTF8 filename
+ $status = 1;
while (<$SH>) {
- if ($opt_v) {
- print;
- $status = 0 if /\Q"$file"/;
- } else {
- if (/\Q"$file"/) {
- print;
- $status = 0;
- }
- }
+ $status = 0 if /"$fp"/;
+ print if $opt_v or /"$fp"/;
}
if ($status) {
if (/^n/i) {
print "keeping $transferfile\n";
} else {
- system("tar xvf $transferfile && rm $transferfile");
+ my $untar = "tar xvf";
+ # if ($> == 0 and `tar --help 2>&1` =~ /gnu/) {
+ # $untar = "tar --no-same-owner -xvf";
+ # }
+ system("$untar $transferfile && rm $transferfile");
die "$0: error while untaring, see $transferfile\n" if -f $transferfile;
}
} else {
print $rcamel[0] if ${'opt_+'};
+ $SIG{ALRM} = sub { retry("timed out") };
while (my $b = read $file,$buf,$bs) {
- print {$SH} $buf or &sigpipehandler;
+ alarm($timeout*2);
+ syswrite $SH,$buf or &sigpipehandler;
+ alarm(0);
$bytes += $b;
if ($filesize > 0 and $bytes+$seek > $filesize) {
die "$0: $file filesize has grown while uploading\n";
sub sigpipehandler {
- $SIG{ALRM} = sub { };
+ retry("died");
+}
+
+sub retry {
+ my $reason = shift;
+ local $SIG{ALRM} = sub { };
+
if (fileno $SH) {
alarm(1);
- @_ = <$SH>;
+ my @r = <$SH>;
alarm(0);
kill 9,$tpid if $tpid;
- if (@_ and $opt_v) {
- die "\n$0: ($$) server error: @_\n";
+ if (@r and $opt_v) {
+ die "\n$0: ($$) server error: @r\n";
}
- if (@_ and $_[0] =~ /^HTTP.* \d+ (.*)/) {
+ if (@r and $r[0] =~ /^HTTP.* \d+ (.*)/) {
die "\n$0: server error: $1\n";
}
}
$timeout *= 2;
- warn "\n$0: connection to $server died\n";
+ warn "\n$0: connection to $server $reason\n";
warn "retrying after $timeout seconds...\n";
sleep $timeout;
if ($windoof) { exec $^X,$0,@_ARGV }
}
+sub get_mutt_alias {
+ my $to = shift;
+ my $ma = $HOME.'/.mutt/aliases';
+ my $alias;
+ local $_;
+
+ open $ma,$ma or return $to;
+ while (<$ma>) {
+ if (/^alias \Q$to\E\s/i) {
+ chomp;
+ s/\s*#.*//;
+ s/\(.*?\)//;
+ s/\s+$//;
+ s/.*\s+//;
+ s/[<>]//g;
+ if (/,/) {
+ warn "$0: ignoring mutt multi-alias $to = $alias\n";
+ last;
+ }
+ if (/@/) {
+ $alias = $_;
+ warn "$0: found mutt alias $to = $alias\n";
+ last;
+ }
+ }
+ }
+ close $ma;
+ return ($alias||$to);
+}
+
+
# collect file meta data (filename, inode, mtime)
sub fmd {
my @files = @_;
unless (defined $_ and /\w/) {
die "$0: no response from server\n";
}
+ print "<-- $_\n" if $opt_v;
s/\r?\n//;
# CGI fatalsToBrowser
if (/^HTTP.* 500/) {
unless (/^HTTP.* 200/) {
$error = $_;
$error =~ s/HTTP.[\s\d.]+//;
- if ($opt_v) {
- print "<-- $_";
- print "<-- $_" while <$SH>;
+ @r = <$SH> unless @r;
+ @r = () unless @r;
+ foreach (@r) {
+ chomp;
+ $error .= "\n".$_ if /^Location/;
+ print "<-- $_\n" if $opt_v;
}
die "$0: server error: $error\n";
}
my $connect = "CONNECT $server:$port HTTP/1.1";
local $_;
- if ($opt_v and $port == 443 and %SSL) {
- foreach my $v (keys %SSL) {
- printf "%s => %s\n",$v,$SSL{$v};
- }
- }
-
if ($proxy) {
tcpconnect(split(':',$proxy));
if ($port == 443) {
unless (/^HTTP.1.. 200/) {
die "$0: proxy error : $_";
}
- eval "use IO::Socket::SSL";
- die "$0: cannot load IO::Socket::SSL\n" if $@;
+ &enable_ssl;
$SH = IO::Socket::SSL->start_SSL($SH,%SSL);
}
} else {
if ($port == 443) {
# eval "use IO::Socket::SSL qw(debug3)";
- eval "use IO::Socket::SSL";
- die "$0: cannot load IO::Socket::SSL\n" if $@;
+ &enable_ssl;
$SH = IO::Socket::SSL->new(
PeerAddr => $server,
PeerPort => $port,
}
+sub enable_ssl {
+ eval "use IO::Socket::SSL";
+ die "$0: cannot load IO::Socket::SSL\n" if $@;
+ eval '$SSL{SSL_verify_mode} = 0 if Net::SSLeay::SSLeay() <= 9470143';
+ if ($opt_v) {
+ foreach my $v (keys %SSL) {
+ printf "%s => %s\n",$v,$SSL{$v};
+ }
+ }
+}
+
+
sub sendheader {
my $sp = shift;
my @head = @_;
projects / fex.git / blobdiff