X-Git-Url: https://git.treefish.org/fex.git/blobdiff_plain/7fa382617fbaccc0ce522b2b3adbbee9db5ad227..20160919:/htdocs/download/fexsend diff --git a/htdocs/download/fexsend b/htdocs/download/fexsend index 607d139..fae77e9 100755 --- a/htdocs/download/fexsend +++ b/htdocs/download/fexsend @@ -17,10 +17,10 @@ use IO::Handle; use IO::Socket::INET; use Getopt::Std; use File::Basename; -use Cwd qw'abs_path'; +use Cwd 'abs_path'; use Fcntl qw':flock :mode'; -use Digest::MD5 qw'md5_hex'; # encrypted ID / SID -use Time::HiRes qw'time'; +use Digest::MD5 'md5_hex'; # encrypted ID / SID +use Time::HiRes 'time'; # use Smart::Comments; use constant k => 2**10; use constant M => 2**20; @@ -31,20 +31,21 @@ 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 = 20150120; +our $version = 20160919; our $_0 = $0; -our $DEBUG; +our $DEBUG = $ENV{DEBUG}; my %SSL = (SSL_version => 'TLSv1'); my $sigpipe; if ($Config{osname} =~ /^mswin/i) { + # http://slu.livejournal.com/17395.html $windoof = $Config{osname}; $HOME = $ENV{USERPROFILE}; $fexhome = $ENV{FEXHOME} || $HOME.'\fex'; @@ -54,18 +55,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}) { + # http://stackoverflow.com/questions/989349/running-a-command-in-a-new-mac-os-x-terminal-window + $macos = $Config{osname}; + $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')) { @@ -81,14 +95,14 @@ my $atype = ''; # archive type my $fexcgi; # F*EX CGI URL my @files; # files to send my %AB = (); # server based address book -my ($server,$port,$sid); +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,14 +118,15 @@ if ($xx) { $usage = <||''; + if (/^y/i) { + my $new = `wget -nv -O- http://fex.belwue.de/download/fexsend`; + my $newversion = $1 if $new =~ /version = (\d+)/; + if ($new !~ /upgrade fexsend/ or not $newversion) { + die "$0: bad update\n"; + } + if ($newversion <= $version) { + die "$0: no newer version\n"; + } + $_0 = abs_path($_0); + system qw'rsync -a',$_0,$_0.'_old'; + exit $? if $?; + open $_0,'>',$_0 or die "$0: cannot write $_0. - $!\n"; + print {$_0} $new; + close $_0; + exec $_0,qw'-V .'; + } + } + exit; + exit if "@ARGV" eq '.'; } - + if ($opt_K and $opt_D) { die "$0: you cannot use both options -D and -K\n"; } @@ -348,7 +415,7 @@ if ($xx) { } # $opt_C is COMMENT command in F*EX protocol - $opt_C = + $opt_C = ($opt_d) ? 'DELETE': ($opt_l or $opt_L) ? 'LIST': ($opt_Q) ? 'CHECKQUOTA': @@ -357,8 +424,8 @@ if ($xx) { ($opt_z) ? 'SENDLOG': (${'opt_!'}) ? 'FOPLOG': $opt_C; - - $opt_D = + + $opt_D = ($opt_D) ? 'DELAY': ($opt_K) ? 'NO': $opt_D; @@ -381,7 +448,7 @@ if ($opt_R) { die $usage if $opt_m and $opt_m !~ /^\d+/; -if ($opt_P) { +if ($opt_P) { if ($opt_P =~ /^([\w.-]+:\d+)(:(\d+))?/) { $proxy = $1; $chunksize = $3 || 0; @@ -415,7 +482,7 @@ if ($xx) { unlink $idf.'xx'; } } - + # special xx ID? if ($FEXXX = $ENV{FEXXX}) { $FEXXX = decode_b64($FEXXX) if $FEXXX !~ /\s/; @@ -430,7 +497,7 @@ if ($xx) { } close $idf; } - + } else { # alternativ ID? @@ -449,11 +516,34 @@ if ($xx) { } if ($opt_I) { - if ($xx) { &show_id } + if ($xx) { &show_id } else { &init_id } exit; } +if ($opt_T) { + my ($up,$down); + + $usage = "usage: $0 -T MB_up[:MB_down] [fexserver]\n"; + if ($opt_T =~ /^(\d+)$/) { + $up = $down = $1; + } elsif ($opt_T =~ /^(\d+):(\d+)$/) { + $up = $1; + $down = $2; + } else { + die $usage; + } + + if (@ARGV) { + nettest($ARGV[0],$up,$down); + } elsif ($fexcgi) { + nettest($fexcgi,$up,$down); + } else { + nettest('fex.belwue.de',$up,$down); + } + exit; +} + if (@ARGV > 1 and $ARGV[-1] =~ /(^|\/)anonymous/) { $fexcgi = $1 if $ARGV[-1] =~ s:(.+)/::; die "usage: $0 [options] file FEXSERVER/anonymous\n" unless $fexcgi; @@ -468,15 +558,15 @@ if (@ARGV > 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"; } @@ -494,9 +584,10 @@ $port = 80; $port = 443 if $server =~ s{https://}{}; $port = $1 if $server =~ s/:(\d+)//; -if (0 and $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"; +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"; + $https = $port; } $server =~ s{http://}{}; @@ -520,7 +611,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"; @@ -531,7 +622,7 @@ if ($xx) { &send_xx($transferfile); } exit; -} +} # regular fexsend @@ -555,18 +646,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; @@ -576,14 +667,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"; } @@ -616,7 +707,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 = ; @@ -625,8 +716,10 @@ sub init_id { 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\-\.\/\@\%]+$/) { @@ -636,11 +729,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) { @@ -690,6 +783,7 @@ sub show_id { my ($fexcgi,$from,$id); if (open $idf,$idf) { $fexcgi = <$idf>; + # $fexcgi = <$idf> if $fexcgi =~ /^\[.+\]/; $from = <$idf>; $id = <$idf>; while (<$idf>) { @@ -738,6 +832,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; @@ -772,16 +867,470 @@ 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 information.\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", + "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; + } +} + + + +sub nettest { + my $url = shift; + my $up = shift; + my $down = shift; + my $bs = 2**16; + my ($length,$t0,$t1,$t2,$tt,$tb,$tc,$B,$kBs,$bt); + + my $nettest = $sid = 'nettest'; + + $port ||= 80; + if ($url =~ s:^https.//::) { + $https = $port = 443; + } else { + $url =~ s:^http.//::; + $port = $1 if $url =~ s/:(\d+)//; + } + $url =~ s/[\/:].*//; + $server = $url; + + if ($up) { + serverconnect($server,$port); + checkrecipient($nettest,$nettest); + warn "$0: send to $server:$port\n"; + formdatapost( + from => $nettest, + to => $nettest, + id => $nettest, + file => $nettest, + size => $up*M, + comment => 'NOSTORE', + ); + } + + if ($down) { + serverconnect($server,$port); + warn "$0: receive from $server:$port\n"; + sendheader("$server:$port","GET $proxy_prefix/ddd/$down HTTP/1.0"); + $_ = <$SH>; + die "$0: no response from fex server $server\n" unless $_; + s/\r//; + + if (/^HTTP\/[\d.]+ 2/) { + warn "<-- $_" if $opt_v; + while (<$SH>) { + s/\r//; + print "<-- $_" if $opt_v; + last if /^$/; + $length = $1 if /^Content-Length:\s*(\d+)/i; + } + } else { + s/HTTP\/[\d.]+ \d+ //; + die "$0: bad server reply: $_"; + } + + unless ($length) { + die "$0: no Content-Length header in server reply\n"; + } + + + if (${'opt_+'}) { + print $rrcamel[0]; + $tc = 0; + } + + $t0 = $t1 = $t2 = int(time); + $B = 0; + while ($B < $length) { + $b = read $SH,$_,$bs or die "$0: cannot read after $B bytes - $!\n"; + # defined($_ = <$SH>) or die "$0: cannot read after $B bytes - $!\n"; + # $b = length; + $B += $b; + $bt += $b; + $t2 = time; + if (${'opt_+'} and int($t2*10)>$tc) { + print $rrcamel[$tc%2+1]; + $tc = int($t2*10); + } + if (int($t2) > $t1) { + $kBs = int($bt/k/($t2-$t1)); + $t1 = $t2; + $bt = 0; + printf STDERR "nettest: %d MB (%d%%) %d kB/s \r", + int($B/M),int(100*$B/$length),$kBs; + } + } + close $SH; + + $tt = $t2-$t0; + $kBs = int($B/k/($tt||1)); + if (${'opt_+'}) { + print $rrcamel[1]; + print $rrcamel[2]; + } + printf STDERR "nettest: %d MB in %d s = %d kB/s \n", + int($B/M),$tt,$kBs; + } +} + + +# 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' } @@ -791,9 +1340,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); @@ -824,10 +1372,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, @@ -836,7 +1384,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); @@ -845,7 +1393,7 @@ sub send_xx { print "wget -O- $2 | tar xvzf -\n"; } } - + unlink $transferfile; } @@ -860,7 +1408,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; @@ -899,12 +1447,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; @@ -940,56 +1488,60 @@ 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", + ); + $_ = <$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"; @@ -1001,18 +1553,22 @@ sub list { else { $dkey = '' } # $_ = encode_utf8($_); s/<.*?>//g; - if (/^(to .* :)/) { - print "\n$1\n"; - print {$fexlist} "\n$1\n"; + 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; @@ -1061,7 +1617,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'; @@ -1082,13 +1638,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 (.+\@.+) :/) { @@ -1098,7 +1654,6 @@ sub delete { sendheader( "$server:$port", "GET $proxy_prefix/fop/$2/$2?DELETE HTTP/1.1", - "User-Agent: $useragent", ); $_ = <$SH>||''; s/\r//; @@ -1129,18 +1684,47 @@ 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", + ); + + 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 = ''; my @files = (); my ($data,$aname,$alias); my (@r,$r); - my $ma = $HOME.'/.mutt/aliases'; my $t0 = time; my $transferfile; my @transferfiles; local $_; - + if ($from =~ /^SUBUSER|GROUPMEMBER$/) { $to = '_'; } else { @@ -1176,7 +1760,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; @@ -1185,7 +1769,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 $_; @@ -1203,9 +1787,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"; @@ -1214,7 +1798,7 @@ sub send_fex { if ($from eq 'GROUPMEMBER') { $gkey = $sid; } - + if ($to eq '.') { @to = ($from); $opt_C ||= 'NOMAIL'; @@ -1248,45 +1832,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 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 $features =~ /CHECKRECIPIENT/ + and $from ne $to + and $features =~ /CHECKRECIPIENT/ and $opt_C !~ /^(DELETE|LIST|RECEIVEDLOG|SENDLOG|FOPLOG)$/ ) { checkrecipient($from,$to); @@ -1298,10 +1862,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) { @@ -1328,7 +1903,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"; @@ -1340,6 +1915,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); @@ -1369,6 +1948,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') { @@ -1382,25 +1962,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; @@ -1408,18 +1988,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; } @@ -1429,15 +2009,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( @@ -1448,21 +2028,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"; @@ -1470,7 +2067,8 @@ 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; @@ -1479,16 +2077,17 @@ sub send_fex { } 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"; - } } } + 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; } @@ -1497,9 +2096,9 @@ sub send_fex { sub forward { my (@r); my ($to,$n,$dkey,$file,$req); - my $status = 1; + my ($status,$fp); local $_; - + # look for single @ in arguments for (my $i=1; $i<$#ARGV; $i++) { if ($ARGV[$i] eq '@') { @@ -1512,13 +2111,16 @@ sub forward { # 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>) { - 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'; } @@ -1526,7 +2128,7 @@ sub forward { } } close $fexlist; - + unless ($n) { die "$0: file #$opt_f not found in fexlist\n"; } @@ -1535,7 +2137,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; @@ -1545,18 +2147,14 @@ sub forward { $req .= " HTTP/1.1"; sendheader("$server:$port",$req); http_response(); - while (<$SH>) { - if ($opt_v) { - print; - $status = 0 if /\Q"$file"/; - } else { - if (/\Q"$file"/) { - print; - $status = 0; - } - } + $fp = $file; + $fp =~ s/[^\w_.-]/.+/g; # because of UTF8 filename + $status = 1; + while (<$SH>) { + $status = 0 if /"$fp"/; + print if $opt_v or /"$fp"/; } - + if ($status) { die "$0: server failed, rerun command with option -v\n"; } @@ -1573,14 +2171,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"; } @@ -1589,7 +2187,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"; @@ -1604,7 +2202,7 @@ sub renotify { $file = $3; } } - + if ($file) { print "notification e-mail for $file has been resent to $recipient\n"; } else { @@ -1614,7 +2212,7 @@ sub renotify { die "$0: server failed, rerun command with option -v\n"; } } - + exit; } @@ -1623,13 +2221,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; @@ -1638,16 +2236,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; @@ -1656,14 +2254,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; } @@ -1672,31 +2270,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; @@ -1723,7 +2321,11 @@ sub get_xx { 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 { @@ -1734,30 +2336,32 @@ 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,$nettest); my ($flink); my (@hh,@hb,@r,@pv,$to); - my ($bytes,$t,$bt); + my ($bytes,$b,$t,$bt); my ($t0,$t1,$t2,$tt,$tc); 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); @@ -1768,20 +2372,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-"; } @@ -1791,12 +2395,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; @@ -1811,23 +2413,81 @@ 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!) + } + + elsif ($P{to} eq 'nettest') { + $filename = $nettest = 'nettest'; + $filesize = $P{size}; + $fileid = 0; + } + # single file else { $filename = encode_utf8(${'opt_='} || $file); - + if ($windoof) { $filename =~ s/^[a-z]://; $filename =~ s/.*\\//; @@ -1837,13 +2497,13 @@ 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"; } } $filename .= '.gpg' if $opt_g; - unless ($opt_d) { + unless ($opt_d or $nettest) { if ($opt_g) { $filesize = -1; $fileid = int(time); @@ -1855,14 +2515,14 @@ sub formdatapost { } } } - + } else { $file = $filename = ''; $filesize = 0; } FORMDATAPOST: - + @hh = (); # HTTP header @hb = (); # HTTP body @r = (); @@ -1872,34 +2532,42 @@ sub formdatapost { unless ($SH) { serverconnect($server,$port); - query_sid($server,$port) unless $anonymous; + query_sid($server,$port) unless $anonymous or $nettest; } - + $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 and not $nettest) { + 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" @@ -1912,7 +2580,7 @@ sub formdatapost { } $boundary = randstring(48); - + $P{seek} = $seek; $P{filesize} = $filesize; @@ -1932,10 +2600,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"; @@ -2000,14 +2669,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"; @@ -2024,10 +2693,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; @@ -2041,28 +2710,56 @@ 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); + } + } elsif ($nettest) { + # } 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_+'}; - while (my $b = read $file,$buf,$bs) { - print {$SH} $buf or &sigpipehandler; + $buf = '#' x $bs if $nettest; + + $SIG{ALRM} = sub { retry("timed out") }; + + while ($bytes < $fpsize) { + if ($nettest) { + $b = $bs; + } else { + $b = read $file,$buf,$bs; + last if $b == 0; + } + alarm($timeout*2); + if ($https) { + print {$SH} $buf or &sigpipehandler; + } else { + 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"; + if (not $nettest and $filesize > 0 and $bytes+$seek > $filesize) { + if ($tpid) { + kill 9,$tpid; + unlink $list; + } + die "$0: \"$file\" filesize has grown while uploading\n"; } $bt += $b; $t2 = time; @@ -2102,26 +2799,42 @@ sub formdatapost { last if $filesize > 0 and $bytes >= $fpsize; sleep 1 while ($opt_m and $bytes/k/(time-$t0||1) > $opt_m); } - close $file; # or die "$0: error while reading $file - $!\n"; + + close $file unless $nettest; + $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)", + printf STDERR "%s: %d MB in %d s = %d kB/s", $opt_s||$opt_a||$file, int($bytes/M), $tt, @@ -2133,7 +2846,7 @@ sub formdatapost { $chunk,int(($bytes+$seek)/M); } } else { - printf STDERR "%s: %d kB in %d s (%d kB/s)", + printf STDERR "%s: %d kB in %d s = %d kB/s", $opt_s||$opt_a||$file, int($bytes/k), $tt, @@ -2147,28 +2860,29 @@ sub formdatapost { } } else { if ($bytes>2*M) { - printf STDERR "%s: %d MB in %d s (%d kB/s) \n", + printf STDERR "%s: %d MB in %d s = %d kB/s \n", $opt_s||$opt_a||$file, int($bytes/M), $tt, int($bytes/k/$tt); } else { - printf STDERR "%s: %d kB in %d s (%d kB/s) \n", + printf STDERR "%s: %d kB in %d s = %d kB/s \n", $opt_s||$opt_a||$file, int($bytes/k), $tt, int($bytes/k/$tt); } } - - if (-t STDOUT and not ($opt_s or $opt_g)) { + + if (-t STDOUT and not ($opt_s or $opt_g or $nettest)) { print STDERR "waiting for server ok..." } } } - + autoflush $SH 1; print {$SH} "\r\n--$boundary--\r\n"; + # return if $nettest; # special handling of streaming file because of stunnel tcp shutdown bug if ($opt_s or $opt_g) { @@ -2183,7 +2897,7 @@ sub formdatapost { } return "X-Location: $location\n"; } - + if ($flink) { $bytes = -s $flink; if ($bytes>2*M) { @@ -2198,8 +2912,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"; } @@ -2209,7 +2923,7 @@ sub formdatapost { last if @r and $r[0] =~ / 204 / and /^$/ or /<\/html>/i; push @r,decode_utf8($_); } - + if ($file) { close $SH; undef $SH; @@ -2217,7 +2931,7 @@ sub formdatapost { goto FORMDATAPOST; } } - + return @r; } @@ -2260,7 +2974,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); @@ -2295,7 +3009,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; } @@ -2308,7 +3022,7 @@ sub zip { sub getline { my $file = shift; local $_; - + while (<$file>) { chomp; s/^#.*//; @@ -2326,11 +3040,10 @@ 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 =~ s/[,:].*//; $to = $AB{$to} if $AB{$to}; $filename =~ s/([^_=:,;<>()+.\w\-])/'%'.uc(unpack("H2",$1))/ge; # urlencode if ($skey) { @@ -2367,11 +3080,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); } @@ -2382,7 +3101,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; @@ -2390,7 +3109,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"; @@ -2398,22 +3117,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.'~'; } @@ -2428,7 +3147,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>; @@ -2455,7 +3174,7 @@ sub query_address_book { last if /^$/; $cl = $1 if /^Content-Length: (\d+)/; } - + if ($cl) { while (<$SH>) { $b += length; @@ -2485,9 +3204,9 @@ sub query_address_book { last if $b >= $cl; } } - + $AB{ADDRESS_BOOK} = $ab; - + return %AB; } @@ -2500,17 +3219,16 @@ sub query_sid { $sid = $id; - if ($port eq 443) { + if ($port eq 443 or $proxy) { + return if $opt_d; return if $features; # early return if we know enough - $req = "OPTIONS FEX HTTP/1.1"; - } elsif ($proxy) { - return if $features; # early return if we know enough - $req = "GET $proxy_prefix/SID HTTP/1.1"; + $req = "OPTIONS /FEX HTTP/1.1"; # does not work with (some) proxies + $req = "GET /SID HTTP/1.1"; # needed as FEATURES query } else { - $req = "GET SID HTTP/1.1"; + $req = "GET /SID HTTP/1.1"; } - sendheader("$server:$port",$req,"User-Agent: $useragent"); + sendheader("$server:$port",$req); $_ = <$SH>; unless (defined $_ and /\w/) { print "\n" if $opt_v; @@ -2518,17 +3236,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); + $_ = <$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/ } @@ -2545,13 +3291,13 @@ sub query_sid { serverconnect($server,$port); $sid = $id; } - + # warn "proxy: $proxy\n"; if ($proxy) { serverconnect($server,$port); $sid = $id; } - + } @@ -2566,7 +3312,7 @@ sub xxget { $xx =~ s:.*/::; $url = "$proxy_prefix/fop/$from/$from/$xx?ID=$id"; - sendheader("$server:$port","GET $url HTTP/1.0","User-Agent: $useragent"); + sendheader("$server:$port","GET $url HTTP/1.0"); http_response(); while (<$SH>) { s/\r//; @@ -2577,16 +3323,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); @@ -2597,9 +3343,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; } @@ -2608,24 +3354,30 @@ sub ts { my ($b,$tb) = @_; return sprintf("transferred: %d MB (%d%%)",int($b/M),int($b/$tb*100)); } - + 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 } @@ -2638,7 +3390,7 @@ sub checkrecipient { my ($from,$to) = @_; my @r; local $_; - + @r = formdatapost( from => $from, to => $to, @@ -2649,6 +3401,7 @@ sub checkrecipient { $_ = shift @r or die "$0: no reply from server\n"; if (/ 2\d\d /) { + return if $to eq 'nettest'; foreach (@r) { last if /^$/; if (s/X-(Recipient: .+)/$1\n/) { @@ -2720,28 +3473,69 @@ 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 $dirmode = shift; + my @s = $dirmode ? lstat($file) : stat($file); + + if (@s) { + return md5_hex($file.$s[0].$s[1].$s[7].$s[9]); + } else { + warn "$0: $file - $!\n"; + return int(time); + } +} + + +sub get_mutt_alias { + my $to = shift; + my $ma = $HOME.'/.mutt/aliases'; + my ($alias,$options); + local $_; + + $to =~ s/(:.+)// and $options = $1; + 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 = $_\n"; + last; + } + if (/@/) { + $alias = $_; + warn "$0: found mutt alias $to = $alias\n"; + $alias .= $options if $options; + last; + } + } + } + close $ma; + $to = "$to:$options" if $options; + return ($alias||$to); } -# 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; @@ -2749,7 +3543,10 @@ sub fmd { while (defined ($file = readdir($dir))) { next if $file eq '..'; if ($file eq '.') { - $fmd .= $file.fileid($dir); + $fmd .= fileid($dir); + } elsif (-l "$dir/$file") { + # hack for dangling symlinks: do not raise an error + $fmd .= fileid("$dir/$file",'dirmode'); } else { $fmd .= fmd("$dir/$file"); } @@ -2757,10 +3554,10 @@ sub fmd { closedir $dir; } } else { - $fmd .= $file.fileid($file); + $fmd .= fileid($file); } } - + return $fmd; } @@ -2770,7 +3567,7 @@ sub decode_b64 { local $_ = shift; my $uu = ''; my ($i,$l); - + tr|A-Za-z0-9+=/||cd; s/=+$//; tr|A-Za-z0-9+/| -_|; @@ -2816,6 +3613,7 @@ sub http_response { die "$0: no response from server\n"; } s/\r?\n//; + print "<-- $_\n" if $opt_v; # CGI fatalsToBrowser if (/^HTTP.* 500/) { @r = <$SH> unless @r; @@ -2825,14 +3623,16 @@ sub http_response { 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"; } - print "<-- $_\n" if $opt_v; return $_; } @@ -2846,16 +3646,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; @@ -2866,7 +3665,7 @@ sub update { close $p; } - exec "l $0 fexget sexsend"; + exec "l fexsend fexget sexsend"; exit; } @@ -2891,9 +3690,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); @@ -2936,16 +3735,10 @@ sub serverconnect { my ($server,$port) = @_; 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) { + if ($https) { printf "--> %s\n",$connect if $opt_v; nvtsend($connect,""); $_ = <$SH>; @@ -2954,14 +3747,13 @@ sub serverconnect { 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 { tcpconnect($server,$port); } -# if ($port == 443 and $opt_v) { +# if ($https and $opt_v) { # printf "%s\n",$SH->get_cipher(); # } } @@ -2970,16 +3762,15 @@ sub serverconnect { # set up tcp/ip connection sub tcpconnect { my ($server,$port) = @_; - + if ($SH) { close $SH; undef $SH; } - - if ($port == 443) { + + if ($https) { # 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, @@ -2993,25 +3784,40 @@ 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; } +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 = @_; my $head; - + push @head,"Host: $sp"; - + push @head,"User-Agent: $useragent"; + foreach $head (@head) { + chomp $head; print "--> $head\n" if $opt_v; print {$SH} $head,"\r\n"; } @@ -3022,12 +3828,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) { @@ -3035,17 +3841,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+/|;