X-Git-Url: http://git.treefish.org/fex.git/blobdiff_plain/97b87610331f53e756d032ad21db786037f921a1..c65ee6f7429eff9a7f58aad7c0aec858ad473092:/htdocs/download/fexsend diff --git a/htdocs/download/fexsend b/htdocs/download/fexsend index 16235b7..7e498dc 100755 --- a/htdocs/download/fexsend +++ b/htdocs/download/fexsend @@ -31,15 +31,15 @@ eval 'use Net::INET6Glue::INET_is_INET6'; $| = 1; -our ($SH,$fexhome,$idf,$tmpdir,$windoof,$useragent,$editor,$nomail); +our ($SH,$fexhome,$idf,$tmpdir,$windoof,$macos,$useragent,$editor,$nomail); our ($anonymous,$public); our ($tpid,$frecipient); our ($FEXID,$FEXXX,$HOME); our (%alias); our $chunksize = 0; -our $version = 20150729; +our $version = 20160104; our $_0 = $0; -our $DEBUG; +our $DEBUG = $ENV{DEBUG}; my %SSL = (SSL_version => 'TLSv1'); my $sigpipe; @@ -54,18 +54,31 @@ if ($Config{osname} =~ /^mswin/i) { $useragent = sprintf("fexsend-$version (%s %s)", $Config{osname},$Config{archname}); $SSL{SSL_verify_mode} = 0; +} elsif ($Config{osname} =~ /^darwin/i or $ENV{MACOS}) { + $macos = $Config{osname}; + # http://stackoverflow.com/questions/989349/running-a-command-in-a-new-mac-os-x-terminal-window + $HOME = (getpwuid($<))[7]||$ENV{HOME}; + $fexhome = $HOME.'/.fex'; + $tmpdir = $ENV{FEXTMP} || $ENV{TMPDIR} || "$fexhome/tmp"; + $tmpdir =~ s:/$::; + $idf = "$fexhome/id"; + chmod 0600,$idf; + $editor = $ENV{EDITOR} || 'open -W -n -e'; + $_ = `sw_vers -productVersion 2>/dev/null`||''; + chomp; + $useragent = "fexsend-$version (MacOS $_)"; } else { $0 =~ s:.*/::; $HOME = (getpwuid($<))[7]||$ENV{HOME}; $fexhome = $HOME.'/.fex'; $tmpdir = $ENV{FEXTMP} || "$fexhome/tmp"; $idf = "$fexhome/id"; + chmod 0600,$idf; $editor = $ENV{EDITOR} || 'vi'; $_ = `(lsb_release -d||uname -a)2>/dev/null`||''; chomp; s/^Description:\s+//; $useragent = "fexsend-$version ($_)"; - chmod 0600,$idf; } if (-f ($_ = '/etc/fex/config.pl')) { @@ -84,11 +97,11 @@ my %AB = (); # server based address book my ($server,$port,$sid,$https); my $proxy = ''; my $proxy_prefix = ''; -my $features = ''; +my $features = ''; my $timeout = 30; # server timeout my $fexlist = "$tmpdir/fexlist"; my ($usage,$hints); -my $xx = $0 =~ /^xx/; +my $xx = $0 =~ /\bxx$/; if ($xx) { $usage = "usage: send file(s): xx [:slot] file...\n". @@ -104,6 +117,7 @@ if ($xx) { $usage = < 1 and $ARGV[-1] =~ /(^|\/)anonymous/) { } else { $fexcgi = $opt_u if $opt_u; - + if (not -e $idf and not ($fexcgi and $from and $id)) { die "$0: no ID file $idf found, use \"fexsend -I\" to create it\n"; } - + unless ($fexcgi) { die "$0: no FEX URL found, use \"$0 -u URL\" or \"$0 -I\"\n"; } - + unless ($from and $id) { die "$0: no sender found, use \"$0 -f FROM:ID\" or \"$0 -I\"\n"; } @@ -499,8 +518,8 @@ $port = 443 if $server =~ s{https://}{}; $port = $1 if $server =~ s/:(\d+)//; if ($port == 443) { - # $opt_s and die "$0: cannot use -s with https due to stunnel bug\n"; - # $opt_g and die "$0: cannot use -g with https due to stunnel bug\n"; + # $opt_s and die "$0: cannot use -s with https due to stunnel bug\n"; + # $opt_g and die "$0: cannot use -g with https due to stunnel bug\n"; $https = $port; } @@ -525,7 +544,7 @@ if ($xx) { $transferfile = "$tmpdir/xx:$1"; shift @ARGV; } - open my $lock,'>>',$transferfile + open my $lock,'>>',$transferfile or die "$0: cannot write $transferfile - $!\n"; flock($lock,LOCK_EX|LOCK_NB) or die "$0: $transferfile is locked by another process\n"; @@ -536,7 +555,7 @@ if ($xx) { &send_xx($transferfile); } exit; -} +} # regular fexsend @@ -560,18 +579,18 @@ unless ($skey or $gkey or $anonymous) { } if ($opt_V and not @ARGV) { exit } -if ($opt_f) { &forward } -elsif ($opt_x) { &modify } -elsif ($opt_N) { &renotify } -elsif ($opt_Q) { &query_quotas } -elsif ($opt_S) { &query_settings } -elsif ($opt_l or $opt_L) { &list } -elsif ($opt_U) { &show_URL } -elsif ($opt_z or $opt_Z or ${'opt_!'}) { &get_log } +if ($opt_f) { &forward } +elsif ($opt_x) { &modify } +elsif ($opt_N) { &renotify } +elsif ($opt_Q) { &query_quotas } +elsif ($opt_S) { &query_settings } +elsif ($opt_l or $opt_L) { &list } +elsif ($opt_U) { &show_URL } +elsif ($opt_z or $opt_Z or ${'opt_!'}) { &get_log } elsif ($opt_A) { edit_address_book($from) } -elsif (${'opt_@'}) { &show_address_book } +elsif (${'opt_@'}) { &show_address_book } elsif ($opt_d and $anonymous) { &purge } -elsif ($opt_d and $ARGV[-1] =~ /^\d+$/) { &delete } +elsif ($opt_d and $ARGV[-1] =~ /^\d+$/) { &delete_file_number } else { &send_fex } exit; @@ -581,14 +600,14 @@ exit; sub init_id { my $tag; my $proxy = ''; - + if ($opt_I) { $tag = shift @ARGV; die $usage if @ARGV; } - + $fexcgi = $from = $id = ''; - + unless (-d $fexhome) { mkdir $fexhome,0700 or die "$0: cannot create FEXHOME $fexhome - $!\n"; } @@ -621,7 +640,7 @@ sub init_id { } if ($tag and $tag eq '.') { exec $ENV{EDITOR}||'vi',$idf } - + if ($tag) { print "F*EX server URL for [$tag]: " } else { print "F*EX server URL: " } $fexcgi = ; @@ -643,11 +662,11 @@ sub init_id { print "proxy address (hostname:port or empty if none): "; $proxy = ; $proxy =~ s/[\s\n]//g; - if ($proxy =~ /^[\w.-]+:\d+$/) { + if ($proxy =~ /^[\w.-]+:\d+$/) { $proxy = "!$proxy"; - } elsif ($proxy =~ /\S/) { + } elsif ($proxy =~ /\S/) { die "wrong proxy address format\n"; - } else { + } else { $proxy = ""; } if ($proxy) { @@ -697,6 +716,7 @@ sub show_id { my ($fexcgi,$from,$id); if (open $idf,$idf) { $fexcgi = <$idf>; + # $fexcgi = <$idf> if $fexcgi =~ /^\[.+\]/; $from = <$idf>; $id = <$idf>; while (<$idf>) { @@ -745,6 +765,7 @@ sub register { sendheader("$fs:$port","GET $proxy_prefix/fur?user=$mail&verify=no HTTP/1.1"); http_response(); + # header while (<$SH>) { s/\r//; printf "<-- $_"if $opt_v; @@ -779,16 +800,371 @@ sub register { } +# menu for MacOS users +sub menu { + my $key; + my $new; + local $_; + + system 'clear'; + print "\n"; + print "fexsend-$version\n"; + + for (;;) { + if (open $idf,$idf) { + $fexcgi = getline($idf) and + $from = getline($idf) and + $id = getline($idf); + close $idf; + last if $id; + } + &set_ID; + } + + print "\n"; + print "$from on $fexcgi\n"; + print "\n"; + + for (;;) { + print "\n"; + print "[s] send a file or directory\n"; + print "[u] update fexsend\n"; + print "[l] change login data (user, server, auth-ID)\n"; + print "[h] help\n"; + print "[q] quit\n"; + print "\n"; + print "your choice: "; + $key = ReadKey(0); + if ($key eq 'q') { + print "$key\n"; + print "\n"; + print "Type [Cmd]W to close this window.\n"; + exit; + } + if ($key eq 'h') { + print "$key\n"; + print + "\n". + "With fexsend you can send files of any size to any e-mail address.\n". + "\n". + "At the recipient or file prompt [RETURN] brings you to this option menu.\n". + "\n". + "To send more than one file:\n". + "When you enter * at the file prompt, you will be first asked for an archive name\n". + "and then you can drag+drop multiple files.\n". + "\n". + "Do not forget to terminate each input line with [RETURN].\n". + "\n". + "See http://fex.rus.uni-stuttgart.de/ for more informations.\n"; + next; + } + if ($key eq 'u') { + print "$key\n"; + if ($0 =~ m:(^/client/|/sw/):) { + print "\n"; + print "use swupdate to update fexsend!\n"; + next; + } + $new = $0.'.new'; + system "curl http://fex.belwue.de/download/fexsend>".quote($new); + chmod 0755,$new; + system qw'perl -c',$new; + if ($? == 0) { + rename $new,$0; + exec $0; + } else { + print "\n"; + print "cannot install new fexsend\n"; + } + next; + } + if ($key eq 'l') { + print "$key\n"; + system 'clear'; + &set_ID; + next; + } + if ($key eq 's' or $key eq "\n") { + print "s\n"; + &ask_file; + next; + } + } + exit; +} + + +# for MacOS +sub ask_file { + my ($file,$comment,$recipient,$archive,$size,$cmd,$key); + my @files; + my $qfiles; + local $_; + + system 'clear'; + + &set_ID unless -s $idf; + + print "\n"; + print "Enter [RETURN] after each input line.\n"; + print "\n"; + + for (;;) { + print "Recipient(s): "; + $recipient = ; + chomp $recipient; + $recipient =~ s/^\s+//; + $recipient =~ s/\s+$//; + $recipient =~ s/[\s;,]+/,/g; + &menu unless $recipient; + last if $recipient =~ /\w/ or $recipient eq '.'; + } + + for (;;) { + print "\n"; + print "Drag a file into this window or hit [RETURN] "; + print $archive ? "to continue.\n" : "for menu options.\n"; + print "File to send: "; + $file = ||''; + chomp $file; + $file =~ s/^\s+//; + $file =~ s/ $// if $file !~ /\\ $/; + &menu unless $file or $archive; + if ($file eq '*') { + print "Archive name: "; + $archive = ||''; + chomp $archive; + next unless $archive; + $archive =~ s/^\s+//g; + $archive =~ s/\s+$//g; + $archive =~ s/[^\w=.+-]/_/g; + next; + } + if ($file) { + unless (-e $file) { + $file =~ s/\\\\/\000/g; + $file =~ s/\\//g; + $file =~ s/\000/\\/g; + } + unless (-r $file) { + print "\"$file\" is not readable\n"; + next; + } + my $qf = quote($file); + if (`du -ms $qf` =~ /^(\d+)/) { + $size += $1; + printf "%d MB\n",$1; + } + if ($archive) { + push @files,$file; + next; + } + } + if ($archive) { + next unless @files; + $qfiles = join(' ',map(quote($_),@files)); + if ($size < 2048) { + $archive .= '.zip'; + } else { + $archive .= '.tar'; + } + } + print "\n"; + print "Comment: "; + $comment = ||''; + chomp $comment; + print "\n"; + if ($comment =~ s/^:\s*-/-/) { + $cmd = quote($0)." $comment "; + if ($archive) { + $cmd .= '-a '.quote($archive).' '.$qfiles; + } else { + $cmd .= quote($file); + } + $cmd .= ' '.quote($recipient); + print $cmd,"\n"; + system $cmd; + } else { + print quote($0)." -C '$comment' "; + if ($archive) { + printf "-a %s %s %s\n",quote($archive),$qfiles,$recipient; + system $0,'-C',$comment,'-a',$archive,@files,$recipient; + } else { + printf "%s %s\n",quote($file),$recipient; + system $0,'-C',$comment,$file,$recipient; + } + } + print "\n"; + print "[s] send another file to $recipient\n"; + print "[n] send another file to another recipient\n"; + print "[q] quit\n"; + print "\n"; + print "your choice: "; + for (;;) { + $key = ReadKey(0); + &ask_file if $key eq 'n'; + if ($key eq 's' or $key eq "\n") { + print "s\n"; + last; + } + if ($key eq 'q') { + print "$key\n"; + exit; + } + } + $file = $comment = $archive = ''; + @files = (); + } +} + + +sub set_ID { + my ($server,$port,$user,$logo); + local $_; + + print "\n"; + for (;;) { + print "F*EX server URL: "; + $server = ; + $server =~ s/[\s\n]//g; + if ($server =~ s:/fup/(\w+)$::) { + $_ = decode_b64($1); + if (/(from|user)=(.+)&id=(.+)/) { + $user = $2; + $id = $3; + } + } + $server =~ s:/fup.*::; + $server =~ s:/+$::; + next if $server !~ /\w/; + if ($server =~ s/^https:..// or $server =~ /:443/) { + $server =~ s/:.*//; + $port = 443; + eval "use IO::Socket::SSL"; + if ($@) { + print "\nno perl SSL modules installed - cannot use https\n\n"; + next; + } + $SH = IO::Socket::SSL->new( + PeerAddr => $server, + PeerPort => $port, + Proto => 'tcp', + %SSL + ); + } else { + $server =~ s:^http.//::; + if ($server =~ s/:(\d+)//) { + $port = $1; + } else { + $port = 80; + } + $SH = IO::Socket::INET->new( + PeerAddr => $server, + PeerPort => $port, + Proto => 'tcp', + ); + } + unless ($SH) { + print "\ncannot connect to $server:$port - $!\n\n"; + next; + } + sendheader( + "$server:$port", + "GET /logo.jpg HTTP/1.0", + "User-Agent: $useragent", + "Connection: close", + ); + $_ = <$SH>||''; + unless (/HTTP.1.1 200/) { + print "\nbad server reply: $_\n"; + next; + } + while (<$SH>) { last if /^\s*$/ } + local $/; + $logo = <$SH>||''; + close $SH; + if (length $logo < 9999) { + print "\n$server is not a F*EX server!\n\n"; + next; + } + open $logo,">$tmpdir/fex.jpg"; + print {$logo} $logo; + close $logo; + last; + } + + for (;;) { + last if $user; + print "Your login (e-mail address): "; + $user = ; + $user =~ s/[\s\n]//g; + if ($user !~ /.@[\w.-]+$/) { + print "\"$user\" is not a valid e-mail address!\n"; + next; + } + } + + for (;;) { + last if $id; + print "Your auth-ID for this account: "; + $id = ; + $id =~ s/[\s\n]//g; + } + + open $idf,'>',$idf or die "$0: cannot write to $idf - $!\n"; + print {$idf} "$server\n", + "$user\n", + "$id\n"; + close $idf; + print "\n"; + print "Login data written to $idf\n\n"; + print "fexing test file to $user:\n\n"; + system "$0 -o -M -C test $tmpdir/fex.jpg $user"; + print "\n"; + if ($? != 0) { + print "fexsend failed, login data is invalid, try again\n"; + &set_ID; + } else { + print "fexsend test succeeded!\n"; + sleep 3; + } +} + + +# read one key from terminal in raw mode +sub ReadKey { + my $key; + local $SIG{INT} = sub { stty('reset'); exit }; + + stty('raw'); + # loop necessary for ESXi support + while (not defined $key) { + $key = getc(STDIN); + } + stty('reset'); + return $key; +} + + +sub stty { + if (shift eq 'raw') { + system qw'stty -echo -icanon eol',"\001"; + } else { + system qw'stty echo icanon eol',"\000"; + } +} + + sub send_xx { my $transferfile = shift; my $file = ''; - my (@r,@tar); - + my (@r,@tar,$dir); + $SIG{PIPE} = $SIG{INT} = sub { unlink $transferfile; exit 3; }; - + if ($0 eq 'xxx') { @tar = qw'tar -cv' } else { @tar = qw'tar -cvz' } @@ -798,9 +1174,8 @@ sub send_xx { shelldo("cat >> $transferfile"); } elsif (@ARGV) { print "making tar transfer file $transferfile :\n"; - # single file? then add this directly + # single file? then add this directly if (scalar @ARGV == 1) { - my ($dir,$file); # strip path if not ending with / if ($ARGV[0] =~ m:(.+)/(.+): and $2 !~ m:/$:) { ($dir,$file) = ($1,$2); @@ -831,10 +1206,10 @@ sub send_xx { } die "$0: no transfer file\n" unless -s $transferfile; - + serverconnect($server,$port); query_sid($server,$port); - + @r = formdatapost( from => $from, to => $from, @@ -843,7 +1218,7 @@ sub send_xx { comment => 'NOMAIL', autodelete => $transferfile =~ /STDFEX/ ? 'NO' : 'DELAY', ); - + # open P,'|w3m -T text/html -dump' or die "$0: w3m - $!\n"; # print P @r; http_response(@r); @@ -852,7 +1227,7 @@ sub send_xx { print "wget -O- $2 | tar xvzf -\n"; } } - + unlink $transferfile; } @@ -867,7 +1242,7 @@ sub query_quotas { from => $from, to => $from, id => $sid, - command => $opt_C, + command => $opt_C, ); die "$0: no response from fex server $server\n" unless @r; $_ = shift @r; @@ -906,12 +1281,12 @@ sub query_settings { print "auth-ID: $id\n"; print "login URL: "; &show_URL; - + @r = formdatapost( from => $from, to => $from, id => $sid, - command => $opt_C, + command => $opt_C, ); die "$0: no response from fex server $server\n" unless @r; $_ = shift @r; @@ -947,56 +1322,61 @@ sub query_settings { # list spool sub list { my (@r,$r); - my ($data,$dkey,$n); + my ($data,$dkey); + my $n = 0; + my $s = 1; + my $a = shift @ARGV || '.'; local $_; female_mode("list spooled files?") if $opt_F; - if ($opt_l and $n = shift @ARGV and $n =~ /^\d+$/) { - open $fexlist,$fexlist or die "$0: $fexlist - $!\n"; - while (<$fexlist>) { - if (/^\s*(\d+)\) (\w+) (.+)/ and $1 eq $n) { - serverconnect($server,$port) unless $SH; - sendheader( - "$server:$port", - "GET $proxy_prefix/fop/$2/$2?LIST HTTP/1.1", - "User-Agent: $useragent", - ); - $_ = <$SH>||''; - s/\r//; - print "<-- $_" if $opt_v; - if (/^HTTP.* 200/) { + if ($opt_l) { + if ($a =~ /^\d+$/) { + open $fexlist,$fexlist or die "$0: $fexlist - $!\n"; + while (<$fexlist>) { + if (/^\s*(\d+)\) (\w+) (.+)/ and $1 eq $a) { + serverconnect($server,$port) unless $SH; + sendheader( + "$server:$port", + "GET $proxy_prefix/fop/$2/$2?LIST HTTP/1.1", + "User-Agent: $useragent", + ); + $_ = <$SH>||''; + s/\r//; print "<-- $_" if $opt_v; - while (<$SH>) { - s/\r//; - if (/^\n/) { - print; - print while <$SH>; + if (/^HTTP.* 200/) { + print "<-- $_" if $opt_v; + while (<$SH>) { + s/\r//; + if (/^\n/) { + print; + print while <$SH>; + } } + } elsif (s:HTTP/[\d\. ]+::) { + die "$0: server response: $_"; + } else { + die "$0: no response from fex server $server\n"; } - } elsif (s:HTTP/[\d\. ]+::) { - die "$0: server response: $_"; - } else { - die "$0: no response from fex server $server\n"; + exit; } - exit; } + die "$0: file \#$a not found in fexlist\n"; } - die "$0: file \#$n not found in fexlist\n"; - } else { - @r = formdatapost( - from => $from, - to => $opt_l ? '*' : $from, - command => $opt_C, - ); } + + @r = formdatapost( + from => $from, + to => $opt_l ? '*' : $from, + command => $opt_C, + ); die "$0: no response from fex server $server\n" unless @r; $_ = shift @r; unless (/^HTTP.* 200/) { s:HTTP/[\d\. ]+::; die "$0: server response: $_\n"; } - + # list sent files if ($opt_l) { open $fexlist,">$fexlist" or die "$0: cannot write $fexlist - $!\n"; @@ -1011,18 +1391,19 @@ sub list { s/&/&/g; s/"/\"/g; s/</ $from, to => $from, id => $sid, - command => $opt_C, + command => $opt_C, ); die "$0: no response from fex server $server\n" unless @r; $_ = shift @r; @@ -1071,7 +1452,7 @@ sub show_address_book { my (%AB,@r); my $alias; local $_; - + %AB = query_address_book($server,$port,$from); foreach $alias (sort keys %AB) { next if $alias eq 'ADDRESS_BOOK'; @@ -1092,13 +1473,13 @@ sub purge { } -sub delete { +sub delete_file_number { my ($to,$file); while (@ARGV) { $opt_d = shift @ARGV; - die "$usage: $0 -d #\n" if $opt_d !~ /^\d+$/; - + die "usage: $0 -d #\n" if $opt_d !~ /^\d+$/; + open $fexlist,$fexlist or die "$0: $fexlist - $!\n"; while (<$fexlist>) { if (/^to (.+\@.+) :/) { @@ -1139,6 +1520,37 @@ sub delete { } +sub delete_file { + my ($from,$to,$file) = @_; + local $_; + + unless ($SH) { + serverconnect($server,$port); + query_sid($server,$port) unless $anonymous; + } + + $file = urlencode($file); + sendheader( + "$server:$port", + "GET $proxy_prefix/fop/$to/$from/$file?id=$sid&DELETE HTTP/1.1", + "User-Agent: $useragent", + ); + + while (<$SH>) { + s/\r//; + printf "<-- $_"if $opt_v; + last if /^\s*$/; + } +} + + +sub urlencode { + local $_ = shift; + s/([^_=:,;<>()+.\w\-])/'%'.uc(unpack("H2",$1))/ge; + return $_; +} + + sub send_fex { my @to; my $file = ''; @@ -1149,7 +1561,7 @@ sub send_fex { my $transferfile; my @transferfiles; local $_; - + if ($from =~ /^SUBUSER|GROUPMEMBER$/) { $to = '_'; } else { @@ -1185,7 +1597,7 @@ sub send_fex { } } @to = split(',',lc($to)); - + die $usage unless @ARGV or $opt_a or $opt_s; die $usage if $opt_s and @ARGV; @@ -1194,7 +1606,7 @@ sub send_fex { if ($anonymous) { my $aok; - sendheader("$server:$port","OPTIONS FEX HTTP/1.1"); + sendheader("$server:$port","OPTIONS /FEX HTTP/1.1"); $_ = <$SH>||''; s/\r//; die "$0: no response from fex server $server\n" unless $_; @@ -1212,9 +1624,9 @@ sub send_fex { } } elsif ($public) { } else { - + query_sid($server,$port); - + if ($from eq 'SUBUSER') { $skey = $sid; # die "skey=$skey\nid=$id\nsid=$sid\n"; @@ -1223,7 +1635,7 @@ sub send_fex { if ($from eq 'GROUPMEMBER') { $gkey = $sid; } - + if ($to eq '.') { @to = ($from); $opt_C ||= 'NOMAIL'; @@ -1257,25 +1669,25 @@ sub send_fex { } } # alias in server address book? - elsif ($AB{$to}) { - # do not substitute alias with expanded addresses because then + elsif ($AB{$to}) { + # do not substitute alias with expanded addresses because then # keep and autodelete options from address book will get lost # $to = $AB{$to}; - } + } # look for mutt aliases 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; - + if ( not $skey and not $gkey and $from ne $to - and $features =~ /CHECKRECIPIENT/ + and $features =~ /CHECKRECIPIENT/ and $opt_C !~ /^(DELETE|LIST|RECEIVEDLOG|SENDLOG|FOPLOG)$/ ) { checkrecipient($from,$to); @@ -1287,10 +1699,21 @@ sub send_fex { } if (@ARGV > 1 and not ($opt_a or $opt_s or $opt_d)) { - print "Archive name (name.tar, name.tgz or name.zip) or [ENTER] to send file for file:\n"; + print "Archive name (name.tar, name.tgz or name.zip) or [RETURN] to send file for file:\n"; $opt_a = ; $opt_a =~ s/^\s+//; $opt_a =~ s/\s+$//; + $opt_a =~ s/\//_/g; + } + + if ($macos and not $opt_a and -d "@ARGV") { + my $dir = "@ARGV"; + my $qdir = quote($dir); + if (`du -s $qdir` =~ /^(\d+)/ and $1 < 2**21) { + $opt_a = "$dir.zip"; + } else { + $opt_a = "$dir.tar"; + } } if ($opt_s) { @@ -1317,7 +1740,7 @@ sub send_fex { $opt_a =~ s:.*/::g; } foreach my $file (@ARGV) { - die "$0: cannot read $file\n" unless -l $file or -r $file; + die "$0: cannot read \"$file\"\n" unless -l $file or -r $file; } $opt_a .= ".$atype" if $opt_a !~ /\.$atype$/; $transferfile = "$tmpdir/$opt_a"; @@ -1329,6 +1752,10 @@ sub send_fex { # else { system(qw'7z a -tzip -mm=copy',$transferfile,@ARGV) } system(qw'7z a -tzip',$transferfile,@ARGV); @files = ($transferfile); + } elsif ($macos and scalar(@ARGV) == 1) { + ## ditto-zip is now handled by formdatapost() + system 'true'; + @files = ($opt_a); } else { # zip archives must be < 2 GB, so split as necessary @files = zipsplit($transferfile,@ARGV); @@ -1358,6 +1785,7 @@ sub send_fex { } else { ## tar is now handled by formdatapost() # system(qw'tar cvf',$transferfile,@ARGV); + system 'true'; @files = ($opt_a); } } elsif ($atype eq 'tgz') { @@ -1371,25 +1799,25 @@ sub send_fex { } else { die "$0: unknown archive format \"$atype\"\n"; } - + if (@transferfiles) { - + # error in making transfer archive? if ($?) { unlink @transferfiles; die "$0: $! - aborting upload\n"; } - + # maybe timeout, so make new connect if (time-$t0 >= $timeout) { serverconnect($server,$port); query_sid($server,$port) unless $anonymous; } - + } - + } else { - + unless (@ARGV) { if ($windoof) { &inquire; @@ -1397,18 +1825,18 @@ sub send_fex { die $usage; } } - + foreach (@ARGV) { my $file = $_; unless ($opt_d) { unless (-f $file) { if (-e $file) { - die "$0: $file is not a regular file, try option -a\n" + die "$0: \"$file\" is not a regular file, try option -a\n" } else { - die "$0: $file does not exist\n"; + die "$0: \"$file\" does not exist\n"; } } - die "$0: cannot read $file\n" unless -r $file; + die "$0: cannot read \"$file\"\n" unless -r $file; } push @files,$file; } @@ -1418,15 +1846,15 @@ sub send_fex { foreach my $file (@files) { my @s = stat($file); unless (@s and ($s[2] & S_IROTH) and -r $file) { - die "$0: $file is not world readable\n"; + die "$0: \"$file\" is not world readable\n"; } } } - + foreach my $file (@files) { sleep 1; # do not overrun server! unless (-s $file or $opt_d or $opt_a or $opt_s) { - die "$0: cannot send empty file $file\n"; + die "$0: cannot send empty file \"$file\"\n"; } female_mode("send file $file?") if $opt_F; @r = formdatapost( @@ -1437,21 +1865,38 @@ sub send_fex { file => $file, keep => $opt_k, comment => $opt_C, - autodelete => $opt_D, + autodelete => $opt_D, ); if (not @r or not grep /\w/,@r) { die "$0: no response from server\n"; } + next if "@r" eq '0'; # already transfered if (($r) = grep /^ERROR:/,@r) { if ($anonymous and $r =~ /purge it/) { die "$0: file is already on server for $to - use another anonymous recipent\n"; + } elsif ($r =~ /timeout/i) { + close $SH; + retry("timed out"); } else { $r =~ s/.*?:\s*//; $r =~ s/<.+?>//g; die "$0: server error: $r\n"; } } + unless ($opt_d) { + if (scalar(@r) == 1) { + die "$0: server error: @r\n"; + } else { + if ($r[0] !~ /HTTP.1.. 2/) { + if ($r[0] =~ /HTTP.[\s\d.]+(.+)/) { + die "$0: server error: $1\n"; + } else { + die "$0: server error:\n".join("\n",@r)."\n"; + } + } + } + } if (($r) = grep /

\Q$file/,@r) { $r =~ s/<.+?>//g; print "$r\n"; @@ -1459,36 +1904,27 @@ sub send_fex { if ($opt_a !~ /^afex_\d+\.tar$/ and $file !~ /afex_\d+\.tar$/) { # print grep({s/^(X-Recipient:.*\((.+)\))/Parameters: $2\n/i} @r); my $nonot = 0; - my ($recipient,$location); + my $recipient = ''; + my $location = ''; foreach (@r) { if (/^(X-)?(Recipient.*)/i) { $recipient = $2; if (/notification=no/i) { $nonot = 1 } else { $nonot = 0 } } - if (/^(X-)?(Location.*)/i) { - $location = $2; - if ($from eq $to or $from =~ /^\Q$to\E@/i - or $nomail or $anonymous or $nonot) { - print "$recipient\n"; - print "$location\n"; - } - } - } - unless ($opt_d or $location) { - if (scalar(@r) == 1) { - die "$0: server error: @r\n"; - } else { - if ($r[0] !~ /HTTP.1.. 2/ and $r[0] =~ /HTTP.[\s\d.]+(.+)/) { - die "$0: server error: $1\n"; - } else { - die "$0: server error:\n".join("\n",@r)."\n"; - } - } + if (/^(X-)?(Location.*)/i) { + $location = $2; + } + } + if ($from eq $to or $from =~ /^\Q$to\E@/i + or $nomail or $anonymous or $nonot) + { + print "$recipient\n" if $recipient; + print "$location\n" if $location; } } } - + # delete transfer tmp file unlink $transferfile if $transferfile; } @@ -1499,7 +1935,7 @@ sub forward { my ($to,$n,$dkey,$file,$req); my ($status,$fp); local $_; - + # look for single @ in arguments for (my $i=1; $i<$#ARGV; $i++) { if ($ARGV[$i] eq '@') { @@ -1518,10 +1954,10 @@ sub forward { open $fexlist,$fexlist or die "$0: $fexlist - $!\n"; while (<$fexlist>) { - if (/^\s*(\d+)\) (\w+) \[\d+ d\] (.+)/ and $1 eq $opt_f) { + if (/^\s*(\d+)\) (\w+) .\s*\d+ d. ([+-] )?(.+)/ and $1 eq $opt_f) { $n = $1; $dkey = $2; - $file = $3; + $file = $4; if ($file =~ s/ "(.*)"$//) { $opt_C ||= $1 if $1 ne 'NOMAIL'; } @@ -1529,7 +1965,7 @@ sub forward { } } close $fexlist; - + unless ($n) { die "$0: file #$opt_f not found in fexlist\n"; } @@ -1538,7 +1974,7 @@ sub forward { serverconnect($server,$port); query_sid($server,$port); - + $req = "GET $proxy_prefix/fup?" ."from=$from&ID=$sid&to=$to&dkey=$dkey&command=FORWARD"; $req .= "&comment=$opt_C" if $opt_C; @@ -1551,11 +1987,11 @@ sub forward { $fp = $file; $fp =~ s/[^\w_.-]/.+/g; # because of UTF8 filename $status = 1; - while (<$SH>) { + while (<$SH>) { $status = 0 if /"$fp"/; print if $opt_v or /"$fp"/; } - + if ($status) { die "$0: server failed, rerun command with option -v\n"; } @@ -1572,14 +2008,14 @@ sub renotify { open $fexlist,$fexlist or die "$0: $fexlist - $!\n"; while (<$fexlist>) { - if (/^\s*(\d+)\) (\w+) \[\d+ d\] (.+)/ and $1 eq $opt_N) { + if (/^\s*(\d+)\) (\w+) .\s*\d+ d. (.+)/ and $1 eq $opt_N) { $n = $1; $dkey = $2; last; } } close $fexlist; - + unless ($n) { die "$0: file #$opt_N not found in fexlist\n"; } @@ -1588,7 +2024,7 @@ sub renotify { serverconnect($server,$port); query_sid($server,$port); - + $req = "GET $proxy_prefix/fup?" ."from=$from&ID=$sid&dkey=$dkey&command=RENOTIFY" ." HTTP/1.1"; @@ -1603,7 +2039,7 @@ sub renotify { $file = $3; } } - + if ($file) { print "notification e-mail for $file has been resent to $recipient\n"; } else { @@ -1613,7 +2049,7 @@ sub renotify { die "$0: server failed, rerun command with option -v\n"; } } - + exit; } @@ -1622,13 +2058,13 @@ sub modify { my (@r); my ($n,$dkey,$file,$req); local $_; - + die $usage if @ARGV; die $usage unless $opt_C or $opt_k or $opt_D; - + open $fexlist,$fexlist or die "$0: $fexlist - $!\n"; while (<$fexlist>) { - if (/^\s*(\d+)\) (\w+) \[\d+ d\] (.+)/ and $1 eq $opt_x) { + if (/^\s*(\d+)\) (\w+) .\s*\d+ d. (.+)/ and $1 eq $opt_x) { $n = $1; $dkey = $2; $file = $3; @@ -1637,16 +2073,16 @@ sub modify { } } close $fexlist; - + unless ($n) { die "$0: file #$opt_x not found in fexlist\n"; } female_mode("modify file #$opt_x?") if $opt_F; - + serverconnect($server,$port); query_sid($server,$port); - + $req = "GET $proxy_prefix/fup?" ."from=$from&ID=$sid&dkey=$dkey&command=MODIFY"; $req .= "&comment=$opt_C" if $opt_C; @@ -1655,14 +2091,14 @@ sub modify { $req .= " HTTP/1.1"; sendheader("$server:$port",$req); http_response(); - while (<$SH>) { + while (<$SH>) { if ($opt_v) { print "<-- $_"; } else { print if /\Q$file/; } } - + exit; } @@ -1671,31 +2107,31 @@ sub get_xx { my $transferfile = shift; my $ft = ''; local $_; - + # get transfer file from FEX server unless ($SH) { serverconnect($server,$port); query_sid($server,$port); } - + xxget($from,$sid,$transferfile); - + # empty file? unless (-s $transferfile) { unlink $transferfile; exit; } - + # no further processing if delivering to pipe exec 'cat',$transferfile unless -t STDOUT; - + if ($ft = `file $transferfile 2>/dev/null`) { if ($ft =~ /compressed/) { rename $transferfile,"$transferfile.gz"; shelldo(ws("gunzip $transferfile.gz")); } $ft = `file $transferfile`; - } + } # file command failed, so we look ourself into the file... elsif (open $transferfile,$transferfile) { read $transferfile,$_,4; @@ -1737,8 +2173,8 @@ sub get_xx { sub formdatapost { - my %P = @_; - my ($boundary,$filename,$filesize,$length,$buf,$file,$fpsize,$resume,$seek); + my %P = @_; + my ($boundary,$filename,$length,$buf,$file,$fpsize,$resume,$seek); my ($flink); my (@hh,@hb,@r,@pv,$to); my ($bytes,$t,$bt); @@ -1746,21 +2182,23 @@ sub formdatapost { my $bs = 2**16; # blocksize for reading and sending file my $fileid = int(time); my $chunk = 0; + my $filesize = 0; my $connection = ''; my $pct = ''; - my ($tar,$aname,$atype,$tarlist,$tarerror,$location,$transferfile); + my $dittodir = '.'; + my ($tar,$ditto,$aname,$atype,$list,$error,$location,$transferfile); local $_; if (defined($file = $P{file})) { - + $to = $AB{$P{to}} || $P{to}; # for gpg - + # special file: stream from STDIN if ($opt_s) { $filename = encode_utf8($file); $filesize = -1; } - + # compression? if ($opt_c) { my ($if,$of); @@ -1771,20 +2209,20 @@ sub formdatapost { $of =~ s/([^_\w\.\-])/\\$1/g; shelldo("gzip <$if>$of"); $filesize = -s $transferfile; - die "$0: cannot gzip $file\n" unless $filesize; + die "$0: cannot gzip \"$file\"\n" unless $filesize; $file = $transferfile; - } - + } + # special file: tar-on-the-fly if (not $windoof and $opt_a and $file =~ /(.+)\.(tar|tgz)$/) { $aname = $1; $atype = $2; - $tarlist = "$tmpdir/$aname.list"; - $tarerror = "$tmpdir/$aname.error"; + $list = "$tmpdir/$aname.list"; + $error = "$tmpdir/$aname.error"; $tar = 'tar -cv'; $tar .= 'z' if $atype eq 'tgz'; if (`tar --help 2>/dev/null` =~ /--index-file/) { - $tar .= " --index-file=$tarlist -f-"; + $tar .= " --index-file=$list -f-"; } else { $tar .= " -f-"; } @@ -1794,12 +2232,10 @@ sub formdatapost { } } foreach (@ARGV) { - $file = $_; - $file =~ s/([^\w\-\@\#%,.=+~_:])/\\$1/g; - $tar .= ' '.$file; + $tar .= ' '.quote($_); } # print "calculating archive size... "; - open $tar,"$tar 2>$tarerror|" or die "$0: cannot run tar - $!\n"; + open $tar,"$tar 2>$error|" or die "$0: cannot run tar - $!\n"; $t0 = int(time) if -t STDOUT; while ($b = read $tar,$_,$bs) { $filesize += $b; @@ -1814,23 +2250,75 @@ sub formdatapost { printf "Archive size: %d MB\n",int($filesize/M) if -t STDOUT; unless (close $tar) { $_ = ''; - if (open $tarerror,$tarerror) { + if (open $error,$error) { local $/; - $_ = <$tarerror>; - close $tarerror; + $_ = <$error>; + close $error; } - unlink $tarlist,$tarerror; + unlink $list,$error; die "$0: tar error:\n$_"; } $file = "$aname.$atype"; $filename = encode_utf8($file); undef $SH; # force reconnect (timeout!) - } - + } + + # special file: ditto-zip-on-the-fly + # ditto: Can't archive multiple sources + elsif ($macos and $opt_a and $file =~ /(.+)\.(zip)$/ and scalar(@ARGV) == 1) { + $aname = $1; + $atype = $2; + $list = "$tmpdir/$aname.list"; + $error = "$tmpdir/$aname.error"; + $ditto = 'ditto -c -k --sequesterRsrc --keepParent'; + if (-d "@ARGV" and "@ARGV" =~ m:^(.+)/(.+):) { + $dittodir = $1; + $file = $2; + $file =~ s/([^\w\-\@\#%,.=+_:])/\\$1/g; + $ditto .= ' '.$file; + } else { + foreach (@ARGV) { + $file = $_; + $file =~ s/([^\w\-\@\#%,.=+_:])/\\$1/g; + $ditto .= ' '.$file; + } + } + # print "calculating archive size... "; + debug("cd $dittodir;$ditto -"); + open $ditto,"cd $dittodir;$ditto - 2>$error|" + or die "$0: cannot run ditto - $!\n"; + $t0 = int(time) if -t STDOUT; + while ($b = read $ditto,$_,$bs) { + $filesize += $b; + if ($t0) { + $t1 = int(time); + if ($t1>$t0) { + printf "Archive size: %d MB\r",int($filesize/M); + $t0 = $t1; + } + } + } + printf "Archive size: %d MB\n",int($filesize/M) if -t STDOUT; + unless (close $ditto) { + $_ = ''; + if (-s $error and open $error,$error) { + local $/; + $_ = <$error>; + close $error; + } + unlink $list,$error; + die "$0: ditto-zip error:\n$_"; + } + unlink $list,$error; + $file = "$aname.$atype"; + $filename = encode_utf8($file); + undef $SH; # force reconnect (timeout!) + } + # single file else { $filename = encode_utf8(${'opt_='} || $file); - + if ($windoof) { $filename =~ s/^[a-z]://; $filename =~ s/.*\\//; @@ -1840,7 +2328,7 @@ sub formdatapost { if ($opt_d) { $filesize = 0; } elsif (not $opt_g and not $opt_s) { - $filesize = -s $file or die "$0: $file is empty or not readable\n"; + $filesize = -s $file or die "$0: \"$file\" is empty or not readable\n"; } } @@ -1858,14 +2346,14 @@ sub formdatapost { } } } - + } else { $file = $filename = ''; $filesize = 0; } FORMDATAPOST: - + @hh = (); # HTTP header @hb = (); # HTTP body @r = (); @@ -1877,32 +2365,40 @@ sub formdatapost { serverconnect($server,$port); query_sid($server,$port) unless $anonymous; } - + $P{id} = $sid; # ugly hack! - + + $filename =~ s/\\/_/g; # \ is a illegal character for fexsrv + # ask server if this file has been already sent - if ($file and not $xx and not - ($opt_s or $opt_g or $opt_o or $opt_d or $opt_l or $opt_L or ${'opt_/'})) - { - ($seek,$location) = query_file($server,$port,$frecipient||$P{to},$P{from}, - $P{id},$filename,$fileid); - if ($filesize == $seek) { - print "Location: $location\n" if $location and $nomail; - warn "$0: $file has been already transferred\n"; - return $file; - } elsif ($seek and $seek < $filesize) { - $resume = " (resuming at byte $seek)"; - } elsif ($filesize <= $seek) { - $seek = 0; + if ($file and not $xx) { + if (not $opt_d and $opt_o) { + # delete before overwrite + delete_file($from,$to,$filename); + serverconnect($server,$port); + query_sid($server,$port) unless $anonymous; + $P{id} = $sid; # ugly hack! + } elsif (not($opt_s or $opt_g or $opt_d or $opt_l or $opt_L or ${'opt_/'})) { + ($seek,$location) = query_file($server,$port, + $frecipient||$P{to},$P{from},$P{id},$filename,$fileid); + if ($filesize == $seek) { + print "Location: $location\n" if $location and $nomail; + warn "$0: $file has been already transferred\n"; + return 0; + } elsif ($seek and $seek < $filesize) { + $resume = " (resuming at byte $seek)"; + } elsif ($filesize <= $seek) { + $seek = 0; + } } if ($proxy) { sleep 1; # do not overrun proxy serverconnect($server,$port); } } - + # file part size - if ($chunksize and $proxy and $port != 443 + if ($chunksize and $proxy and $port != 443 and $filesize - $seek > $chunksize - $bs) { if ($features !~ /MULTIPOST/) { die sprintf("$0: server does not support chunked multi-POST needed for" @@ -1915,7 +2411,7 @@ sub formdatapost { } $boundary = randstring(48); - + $P{seek} = $seek; $P{filesize} = $filesize; @@ -1935,10 +2431,11 @@ sub formdatapost { push @hb,"--$boundary"; push @hb,"Content-Disposition: form-data; name=\"$name\""; push @hb,""; - push @hb,encode_utf8($P{$v}); + # push @hb,encode_utf8($P{$v}); + push @hb,$P{$v}; } } - + # at last, POST the file if ($file) { push @hb,"--$boundary"; @@ -2003,14 +2500,14 @@ sub formdatapost { sleep 3; goto FORMDATAPOST; # necessary: new $sid ==> new @hh }; - + unless ($opt_d or $flink) { - + $t0 = $t2 = int(time); $tt = $t0-1; $t1 = 0; $tc = 0; - + if ($opt_s) { if ($opt_g) { open $file,"gpg -e -r $to|" or die "$0: cannot run gpg - $!\n"; @@ -2027,10 +2524,10 @@ sub formdatapost { $tpid = fork(); if (defined $tpid and $tpid == 0) { sleep 1; - if (open $tarlist,$tarlist) { - # print "\n$tar|\n"; system "ls -l $tarlist"; - while ($tarlist) { - while (<$tarlist>) { + if (open $list,$list) { + # print "\n$tar|\n"; system "ls -l $list"; + while ($list) { + while (<$list>) { print ' 'x(length($file)+40),"\r",$_; } sleep 1; @@ -2044,21 +2541,27 @@ sub formdatapost { print "Fast forward to byte $seek (resuming)\n"; readahead($file,$seek); } + } elsif ($ditto) { + $ditto =~ s/ditto/ditto -V/; + open $file,"cd $dittodir;$ditto -|" or die "$0: cannot run ditto - $!\n"; + if ($seek) { + print "Fast forward to byte $seek (resuming)\n"; + readahead($file,$seek); + } } else { if ($opt_g) { - my $fileq = $file; - $fileq =~ s/([^\w\-\@\#%,.=+~_:])/\\$1/g; + my $fileq = quote($file); open $file,"gpg -e -r $to <$fileq|" or die "$0: cannot run gpg - $!\n"; } else { - open $file,$file or die "$0: cannot read $file - $!\n"; + open $file,$file or die "$0: cannot read \"$file\" - $!\n"; seek $file,$seek,0; } binmode $file; } - + $bytes = 0; autoflush $SH 0; - + print $rcamel[0] if ${'opt_+'}; $SIG{ALRM} = sub { retry("timed out") }; @@ -2072,7 +2575,11 @@ sub formdatapost { alarm(0); $bytes += $b; if ($filesize > 0 and $bytes+$seek > $filesize) { - die "$0: $file filesize has grown while uploading\n"; + if ($tpid) { + kill 9,$tpid; + unlink $list; + } + die "$0: \"$file\" filesize has grown while uploading\n"; } $bt += $b; $t2 = time; @@ -2114,21 +2621,35 @@ sub formdatapost { } close $file; # or die "$0: error while reading $file - $!\n"; $tt = ($t2-$t0)||1; - + print $rcamel[2] if ${'opt_+'}; - + # terminate tar verbose output job if ($tpid) { sleep 2; kill 9,$tpid; - unlink $tarlist; + unlink $list; + } + + if ($fileid =~ /[a-z]/ and not ($opt_s or $opt_g)) { + if ($opt_a) { + if ($fileid ne md5_hex(fmd(@ARGV))) { + print "\n" unless $opt_q; + die "$0: files have been modified while uploading\n"; + } + } else { + if ($fileid ne fileid($file)) { + print "\n" unless $opt_q; + die "$0: file has been modified while uploading\n"; + } + } } - + unless ($opt_q) { if (not $chunksize and $bytes+$seek < $filesize) { - die "$0: $file filesize has shrunk while uploading\n"; + die "$0: \"$file\" filesize has shrunk while uploading\n"; } - + if ($seek or $chunksize and $chunksize < $filesize) { if ($fpsize>2*M) { printf STDERR "%s: %d MB in %d s (%d kB/s)", @@ -2170,13 +2691,13 @@ sub formdatapost { int($bytes/k/$tt); } } - + if (-t STDOUT and not ($opt_s or $opt_g)) { print STDERR "waiting for server ok..." } } } - + autoflush $SH 1; print {$SH} "\r\n--$boundary--\r\n"; @@ -2193,7 +2714,7 @@ sub formdatapost { } return "X-Location: $location\n"; } - + if ($flink) { $bytes = -s $flink; if ($bytes>2*M) { @@ -2208,8 +2729,8 @@ sub formdatapost { } # SuSe: Can't locate object method "BINMODE" via package "IO::Socket::SSL::SSL_HANDLE" - # binmode $SH,':utf8'; - + # binmode $SH,':utf8'; + if (not $opt_q and $file and -t STDOUT) { print STDERR "\r \r"; } @@ -2219,7 +2740,7 @@ sub formdatapost { last if @r and $r[0] =~ / 204 / and /^$/ or /<\/html>/i; push @r,decode_utf8($_); } - + if ($file) { close $SH; undef $SH; @@ -2227,7 +2748,7 @@ sub formdatapost { goto FORMDATAPOST; } } - + return @r; } @@ -2270,7 +2791,7 @@ sub zipsplit { $size = -s $file; if ($size > 2147480000) { unlink @zipfiles; - die "$0: $file too big for zip\n"; + die "$0: \"$file\" too big for zip\n"; } if ($zsize + $size > 2147000000) { push @zipfiles,zip($zipbase.'_'.$n.'.zip',@files); @@ -2305,7 +2826,7 @@ sub zip { } print $cmd,"\n" if $opt_v; open $cmd,"|$cmd" or die "$0: cannot create $zip - $!\n"; - foreach (@_) { + foreach (@_) { print {$cmd} $_."\n"; print " $_\n" if $opt_v; } @@ -2318,7 +2839,7 @@ sub zip { sub getline { my $file = shift; local $_; - + while (<$file>) { chomp; s/^#.*//; @@ -2336,9 +2857,9 @@ sub query_file { my $seek = 0; my $qfileid = ''; my ($head,$location); - my ($response,$fexsrv); + my ($response,$fexsrv,$cc); local $_; - + $to =~ s/,.*//; $to =~ s/:\w+=.*//; $to = $AB{$to} if $AB{$to}; @@ -2377,11 +2898,17 @@ sub query_file { if (/^X-File-ID:\s+(.+)/) { $qfileid = $1 } if (/^X-Features:\s+(.+)/) { $features = $1 } if (/^X-Location:\s+(.+)/) { $location = $1 } + if (/^Connection: close/) { $cc = $_ } } # return true seek only if file is identified $seek = 0 if $qfileid and $qfileid ne $fileid; - + + if ($cc) { + serverconnect($server,$port); + $sid = $id; + } + return ($seek,$location); } @@ -2392,7 +2919,7 @@ sub edit_address_book { my $ab = "$fexhome/ADDRESS_BOOK"; my (%AB,@r); local $_; - + die "$0: address book not available for subusers\n" if $skey; die "$0: address book not available for group members\n" if $gkey; @@ -2400,7 +2927,7 @@ sub edit_address_book { %AB = query_address_book($server,$port,$user); if ($AB{ADDRESS_BOOK} !~ /\w/) { - $AB{ADDRESS_BOOK} = + $AB{ADDRESS_BOOK} = "# Format: alias e-mail-address # Comment\n". "# Example:\n". "framstag framstag\@rus.uni-stuttgart.de\n"; @@ -2408,22 +2935,22 @@ sub edit_address_book { open $ab,">$ab" or die "$0: cannot write to $ab - $!\n"; print {$ab} $AB{ADDRESS_BOOK}; close $ab; - - system $editor,$ab; + + system "$editor $ab"; exit unless -s $ab; $opt_o = $opt_A; - + serverconnect($server,$port); query_sid($server,$port); - + @r = formdatapost( from => $user, to => $user, id => $sid, file => $ab, ); - + unlink $ab,$ab.'~'; } @@ -2438,7 +2965,7 @@ sub query_address_book { serverconnect($server,$port); query_sid($server,$port); } - + $req = "GET $proxy_prefix/fop/$user/$user/ADDRESS_BOOK?ID=$sid HTTP/1.1"; sendheader("$server:$port",$req); $_ = <$SH>; @@ -2465,7 +2992,7 @@ sub query_address_book { last if /^$/; $cl = $1 if /^Content-Length: (\d+)/; } - + if ($cl) { while (<$SH>) { $b += length; @@ -2495,9 +3022,9 @@ sub query_address_book { last if $b >= $cl; } } - + $AB{ADDRESS_BOOK} = $ab; - + return %AB; } @@ -2510,14 +3037,12 @@ sub query_sid { $sid = $id; - if ($port eq 443) { - return if $features; # early return if we know enough - $req = "OPTIONS FEX HTTP/1.1"; - } elsif ($proxy) { + if ($port eq 443 or $proxy) { return if $features; # early return if we know enough - $req = "GET $proxy_prefix/SID HTTP/1.1"; + $req = "OPTIONS /FEX HTTP/1.1"; + $req = "HEAD / HTTP/1.1"; } else { - $req = "GET SID HTTP/1.1"; + $req = "GET /SID HTTP/1.1"; } sendheader("$server:$port",$req,"User-Agent: $useragent"); @@ -2528,17 +3053,45 @@ sub query_sid { } s/\r//; print "<-- $_" if $opt_v; - - if (/^HTTP.* [25]0[01] /) { + + if ($req =~ /OPTIONS/ and /^HTTP.* 502 /) { + # (reverse) proxy error + close $SH; + serverconnect($server,$port); + $req = "GET /SID HTTP/1.0"; + sendheader("$server:$port",$req,"User-Agent: $useragent"); + $_ = <$SH>; + unless (defined $_ and /\w/) { + print "\n" if $opt_v; + die "$0: no response from server\n"; + } + s/\r//; + print "<-- $_" if $opt_v; + while (<$SH>) { + s/\r//; + print "<-- $_" if $opt_v; + $features = $1 if /^X-Features: (.+)/; + $timeout = $1 if /^X-Timeout: (\d+)/; + last if /^\n/; + } + close $SH; + serverconnect($server,$port); + } elsif (/^HTTP.* [25]0[01] /) { if (not $proxy and $port ne 443 and /^HTTP.* 201 (.+)/) { $sid = 'MD5H:'.md5_hex($id.$1); } + my $cc; while (<$SH>) { s/\r//; print "<-- $_" if $opt_v; $features = $1 if /^X-Features: (.+)/; $timeout = $1 if /^X-Timeout: (\d+)/; - last if /^\n/; + $cc = $_ if /^Connection: close/; + last if /^\n/; + } + if ($cc) { + serverconnect($server,$port); + $sid = $id; } } elsif (/^HTTP.* 301 /) { while (<$SH>) { last if /Location/ } @@ -2555,13 +3108,13 @@ sub query_sid { serverconnect($server,$port); $sid = $id; } - + # warn "proxy: $proxy\n"; if ($proxy) { serverconnect($server,$port); $sid = $id; } - + } @@ -2587,16 +3140,16 @@ sub xxget { } die "$0: no Content-Length in server-reply\n" unless $cl; - - open F,">$save" or die "$0: cannot write to $save - $!\n"; - binmode F; - + + open $save,">$save" or die "$0: cannot write to $save - $!\n"; + binmode $save; + $t0 = $t1 = int(time); $tso = ''; - + while ($b = read($SH,$_,$bs)) { $B += $b; - print F; + print {$save} $_; if (int(time) > $t1) { $t1 = int(time); $ts = ts($B,$cl); @@ -2607,9 +3160,9 @@ sub xxget { } sleep 1 while ($opt_m and $B/k/(time-$t0||1) > $opt_m); } - + print STDERR ts($B,$cl),"\n"; - close F; + close $save; } @@ -2618,7 +3171,7 @@ sub ts { my ($b,$tb) = @_; return sprintf("transferred: %d MB (%d%%)",int($b/M),int($b/$tb*100)); } - + sub sigpipehandler { retry("died"); @@ -2627,7 +3180,7 @@ sub sigpipehandler { sub retry { my $reason = shift; local $SIG{ALRM} = sub { }; - + if (fileno $SH) { alarm(1); my @r = <$SH>; @@ -2654,7 +3207,7 @@ sub checkrecipient { my ($from,$to) = @_; my @r; local $_; - + @r = formdatapost( from => $from, to => $to, @@ -2736,19 +3289,25 @@ sub readahead { my $s = 0; my $n; local $_; - - while ($s < $ba) { + + while ($s < $ba) { $n = $ba-$s; - $n = $bs if $n > $bs; - $s += read $fh,$_,$n; + $n = $bs if $n > $bs; + $s += read $fh,$_,$n; } } -# fileid is inode and mtime sub fileid { - my @s = stat(shift); - return @s ? $s[1].$s[9] : int(time); + my $file = shift; + my @s = stat($file); + + if (@s) { + return md5_hex($file.$s[0].$s[1].$s[7].$s[9]); + } else { + warn "$0: $file - $!\n"; + return int(time); + } } @@ -2757,7 +3316,7 @@ sub get_mutt_alias { my $ma = $HOME.'/.mutt/aliases'; my $alias; local $_; - + open $ma,$ma or return $to; while (<$ma>) { if (/^alias \Q$to\E\s/i) { @@ -2768,7 +3327,7 @@ sub get_mutt_alias { s/.*\s+//; s/[<>]//g; if (/,/) { - warn "$0: ignoring mutt multi-alias $to = $alias\n"; + warn "$0: ignoring mutt multi-alias $to = $_\n"; last; } if (/@/) { @@ -2783,12 +3342,12 @@ sub get_mutt_alias { } -# collect file meta data (filename, inode, mtime) +# collect (hashed) file meta data sub fmd { my @files = @_; my ($file,$dir); my $fmd = ''; - + foreach $file (@files) { if (not -l $file and -d $file) { $dir = $file; @@ -2796,7 +3355,7 @@ sub fmd { while (defined ($file = readdir($dir))) { next if $file eq '..'; if ($file eq '.') { - $fmd .= $file.fileid($dir); + $fmd .= fileid($dir); } else { $fmd .= fmd("$dir/$file"); } @@ -2804,10 +3363,10 @@ sub fmd { closedir $dir; } } else { - $fmd .= $file.fileid($file); + $fmd .= fileid($file); } } - + return $fmd; } @@ -2817,7 +3376,7 @@ sub decode_b64 { local $_ = shift; my $uu = ''; my ($i,$l); - + tr|A-Za-z0-9+=/||cd; s/=+$//; tr|A-Za-z0-9+/| -_|; @@ -2862,8 +3421,8 @@ sub http_response { unless (defined $_ and /\w/) { die "$0: no response from server\n"; } - print "<-- $_\n" if $opt_v; s/\r?\n//; + print "<-- $_\n" if $opt_v; # CGI fatalsToBrowser if (/^HTTP.* 500/) { @r = <$SH> unless @r; @@ -2883,7 +3442,6 @@ sub http_response { die "$0: server error: $error\n"; } - print "<-- $_\n" if $opt_v; return $_; } @@ -2897,16 +3455,15 @@ sub ws { sub update { my $cfb = '### common functions ###'; my $cfc; - + local $/; - + open $0,$0 or die "cannot read $0 - $!\n"; - $_ = <$0>; + $cfc = <$0>; close $0; - s/.*\n$cfb\n//s; - $cfc = $_; - - foreach my $p (qw(fexget sexsend)) { + $cfc =~ s/.*\n$cfb\n//s; + + foreach my $p (qw'fexget sexsend') { open $p,$p or die "cannot read $p - $!\n"; $_ = <$p>; close $p; @@ -2917,7 +3474,7 @@ sub update { close $p; } - exec "l $0 fexget sexsend"; + exec "l fexsend fexget sexsend"; exit; } @@ -2942,9 +3499,9 @@ sub get_ssl_env { $SSL{SSL_verify_mode} = $ENV{SSLVERIFY} if defined($ENV{SSLVERIFY}); foreach my $opt (qw( SSL_version - SSL_cipher_list - SSL_verify_mode - SSL_ca_path + SSL_cipher_list + SSL_verify_mode + SSL_ca_path SSL_ca_file) ) { my $env = uc($opt); @@ -2987,7 +3544,7 @@ sub serverconnect { my ($server,$port) = @_; my $connect = "CONNECT $server:$port HTTP/1.1"; local $_; - + if ($proxy) { tcpconnect(split(':',$proxy)); if ($https) { @@ -3014,12 +3571,12 @@ sub serverconnect { # set up tcp/ip connection sub tcpconnect { my ($server,$port) = @_; - + if ($SH) { close $SH; undef $SH; } - + if ($https) { # eval "use IO::Socket::SSL qw(debug3)"; &enable_ssl; @@ -3036,13 +3593,14 @@ sub tcpconnect { Proto => 'tcp', ); } - + if ($SH) { autoflush $SH 1; + binmode $SH; } else { die "$0: cannot connect $server:$port - $@\n"; } - + print "TCPCONNECT to $server:$port\n" if $opt_v; } @@ -3063,9 +3621,9 @@ sub sendheader { my $sp = shift; my @head = @_; my $head; - + push @head,"Host: $sp"; - + foreach $head (@head) { print "--> $head\n" if $opt_v; print {$SH} $head,"\r\n"; @@ -3077,12 +3635,12 @@ sub sendheader { sub nvtsend { local $SIG{PIPE} = sub { $sigpipe = "@_" }; - + $sigpipe = ''; - + die "$0: internal error: no active network handle\n" unless $SH; die "$0: remote host has closed the link\n" unless $SH->connected; - + foreach my $line (@_) { print {$SH} $line,"\r\n"; if ($sigpipe) { @@ -3090,17 +3648,29 @@ sub nvtsend { return 0; } } - + return 1; } +sub quote { + local $_ = shift; + s/([^\w\@\/%^,.=+_:+-])/\\$1/g; + return $_; +} + + +sub debug { + print "## DEBUG: @_\n" if $DEBUG; +} + + # from MIME::Base64::Perl sub encode_b64 { my $res = ""; my $eol = "\n"; my $padding; - + pos($_[0]) = 0; $res = join '',map(pack('u',$_)=~ /^.(\S*)/, ($_[0]=~/(.{1,45})/gs)); $res =~ tr|` -_|AA-Za-z0-9+/|;