htdocs/download/sexsend

   1 #!/usr/bin/perl -w
   2
   3 # client for stream exchange of the FEX service
   4 #
   5 # Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
   6 #
   7 # Perl Artistic Licence
   8
   9 # sexsend / sexget / sexxx
  10
  11 use Getopt::Std;
  12 use Socket;
  13 use IO::Handle;
  14 use IO::Socket::INET;
  15 use Digest::MD5 qw(md5_hex);  # encypted ID / SID
  16
  17 use constant k => 2**10;
  18 use constant M => 2**20;
  19
  20 eval 'use Net::INET6Glue::INET_is_INET6';
  21
  22 our $version = 20160919;
  23 our $DEBUG = $ENV{DEBUG};
  24
  25 my %SSL = (SSL_version => 'TLSv1');
  26 my $sigpipe;
  27
  28 if (-f ($_ = '/etc/fex/config.pl')) {
  29   eval { require } or warn $@;
  30 }
  31
  32 $0 =~ s:.*/::;
  33 $| = 1;
  34
  35 # sexsend is default
  36 $usage =
  37   "usage: ... | $0 [options] [SEX-URL/]recipient [stream]\n".
  38   "options: -v           verbose mode\n".
  39   "         -g           show transfer rate\n".
  40   "         -V           show version\n".
  41   "         -t timeout   timeout in s (waiting for recipient)\n".
  42   "special: recipient may be \"public\" or \"anonymous\" or \".\"\n".
  43   "see also: sexget, sexxx\n".
  44   "example: tail -f /var/log/syslog | $0 fex.flupp.org/admin log\n";
  45
  46 if ($0 eq 'sexget' or $0 eq 'fuckme') {
  47   $usage =
  48     "usage: $0 [options] [[SEX-URL/]user:ID] [stream]\n".
  49     "options: -v           verbose mode\n".
  50     "         -g           show transfer rate\n".
  51     "         -V           show version\n".
  52     "arguments: user:ID    use this user & ID\n".
  53     "                      (ID may be \"public\" or user:ID may be \"anonymous\")\n".
  54     "           stream     name of the stream\n".
  55     "see also: sexsend, sexxx\n".
  56     "example: $0 log | grep kernel\n";
  57 }
  58
  59 if ($0 eq 'sexxx') {
  60   $usage =
  61     "usage: $0 [-v] [-g] [-c] [-u [SEX-URL/]user] [-s stream] [files...]\n".
  62     "usage: $0 [-v] [-g]      [-u [SEX-URL/]user] [-s stream] | ...\n".
  63     "options: -v               verbose mode\n".
  64     "         -g               show transfer rate\n".
  65     "         -q               quiet mode\n".
  66     "         -c               compress files\n".
  67     "         -u SEX-URL/user  SEX-URL and user (default: use FEXID/FEXXX)\n".
  68     "         -s stream        stream name (default: xx)\n".
  69     "see also: sexsend, sexget\n".
  70     "examples: $0 -s config /etc /usr/local/etc\n".
  71     "          $0 > backup.tar\n";
  72 }
  73
  74 $fexhome = $ENV{FEXHOME} || $ENV{HOME}.'/.fex';
  75 $user = $id = '';
  76 $type = $timeout = $stream = $mode = '';
  77 $idf = "$fexhome/id";
  78 $bs = $ENV{BS} || 2**16; # I/O blocksize
  79
  80 # server URL, user and auth-ID
  81 if ($FEXID = $ENV{FEXID}) {
  82   $FEXID = decode_b64($FEXID) if $FEXID !~ /\s/;
  83   ($fexcgi,$user,$id) = split(/\s+/,$FEXID);
  84 } else {
  85   if (open $idf,$idf) {
  86     chomp($fexcgi = <$idf>) or die "$0: no FEX-URL in $idf\n";
  87     chomp($user = <$idf>)   or die "$0: no FROM in $idf\n";
  88     chomp($id = <$idf>)     or die "$0: no ID in $idf\n";
  89     close $idf;
  90     despace($fexcgi,$user,$id);
  91     unless ($fexcgi =~ /^[_:=\w\-\.\/\@\%]+$/) {
  92       die "$0: illegal FEX-URL \"$fexcgi\" in $idf\n";
  93     }
  94     unless ($user =~ /^[_:=\w\-\.\/\@\%\+]+$/) {
  95       die "$0: illegal FROM \"$user\" in $idf\n";
  96     }
  97   }
  98 }
  99
 100 $opt_h = $opt_v = $opt_V = $opt_q = 0;
 101 $opt_u = $opt_s = $opt_c = $opt_t = '';
 102
 103 $_ = "$fexhome/config.pl"; require if -f;
 104
 105 if ($0 eq 'sexxx') {
 106
 107   # xx server URL, user and auth-ID
 108   if ($FEXXX = $ENV{FEXXX}) {
 109     $FEXXX = decode_b64($FEXXX) if $FEXXX !~ /\s/;
 110     ($fexcgi,$user,$id) = split(/\s+/,$FEXXX);
 111   } elsif (open $idf,$idf) {
 112     while (<$idf>) {
 113       if (/^\[xx\]/) {
 114         chomp($fexcgi = <$idf>) or die "$0: no xx FEX-URL in $idf\n";
 115         chomp($user = <$idf>)   or die "$0: no xx FROM in $idf\n";
 116         chomp($id = <$idf>)     or die "$0: no xx ID in $idf\n";
 117         last;
 118       }
 119     }
 120     close $idf;
 121   }
 122
 123   getopts('hgvcu:s:') or die $usage;
 124   die $usage if $opt_h;
 125   die $usage unless -t;
 126
 127   if ($opt_c) {
 128     $opt_c = 'z';
 129     $type = '&type=GZIP';
 130   }
 131
 132   if ($opt_u) {
 133     $fexcgi = $1 if $opt_u =~ s:(.+)/::;
 134     $user = $opt_u;
 135   }
 136
 137   unless ($fexcgi) {
 138     die "$0: no xx user found, use \"$0 -u SEX-URL/user\"\n";
 139   }
 140
 141   unless ($user) {
 142     die "$0: no xx user found, use \"$0 -u user\"\n";
 143   }
 144
 145 } elsif ($0 eq 'sexget' or $0 eq 'fuckme') {
 146
 147   $opt_g = 0;
 148   getopts('hgvVdu:') or die $usage;
 149   die $usage if $opt_h;
 150
 151
 152   if ($opt_V) {
 153     print "Version: $version\n";
 154     exit unless @ARGV;
 155   }
 156
 157   if (not $opt_u and @ARGV and $ARGV[0] =~ m{^anonymous|/|:}) {
 158     $opt_u = shift @ARGV;
 159   }
 160
 161   if ($opt_u) {
 162     $fexcgi = $1 if $opt_u =~ s:(.+)/::;
 163     ($user,$id) = split(':',$opt_u);
 164     if ($user =~ /^anonymous/) {
 165       $anonymous = $user;
 166     } elsif (not $id) {
 167       die $usage;
 168     }
 169   }
 170
 171   unless ($fexcgi) {
 172     die "$0: no SEX URL found, use \"$0 -u SEX-URL/recipient\" or \"fexsend -I\"\n";
 173   }
 174
 175   unless ($user) {
 176     die "$0: no recipient found, use \"$0 -u SEX-URL/recipient\" or \"fexsend -I\"\n";
 177   }
 178
 179 } else { # sexsend
 180
 181   $opt_g = 0;
 182   getopts('hguvqVTt:') or die $usage;
 183   die $usage if $opt_h;
 184
 185   if ($opt_V) {
 186     print "Version: $version\n";
 187     exit unless @ARGV;
 188   }
 189
 190   if ($opt_t and $opt_t =~ /^\d+$/) {
 191     $timeout = "&timeout=$opt_t";
 192   }
 193
 194   my $save_user = $user;
 195   $user = shift or die $usage;
 196   $fexcgi = $1 if $user =~ s:(.+)/::;
 197
 198   if ($user =~ /^anonymous/) {
 199     die "$0: need SEX-URL with anonymous SEX\n" unless $fexcgi;
 200     $mode = 'anonymous';
 201   } elsif ($user eq 'public') {
 202     unless ($id) {
 203       die "$0: public SEX not possible without FEXID, set it with \"fexsend -I\"\n";
 204     }
 205     $mode = $user;
 206     $user = $save_user;
 207   } elsif ($user eq '.') {
 208     open $idf,$idf or die "$0: no $idf\n";
 209     $_ = <$idf>;
 210     $user = <$idf>||'';
 211     chomp $user;
 212   } else {
 213     unless ($fexcgi) {
 214       die "$0: no SEX URL found, use \"$0 SEX-URL/recipient\" or \"fexsend -I\"\n";
 215     }
 216   }
 217
 218 }
 219
 220 &get_ssl_env;
 221
 222 $fexcgi =~ s(^http://)()i;
 223 $fexcgi =~ s(/fup.*)();
 224 $server = $fexcgi;
 225
 226 if    ($server =~ s(^https://)()i) { $port = 443 }
 227 elsif ($server =~ /:(\d+)/)        { $port = $1 }
 228 else                               { $port = 80 }
 229
 230 $server =~ s([:/].*)();
 231
 232 ## set up tcp/ip connection
 233 # $iaddr = gethostbyname($server)
 234 #          or die "$0: cannot find ip-address for $server $!\n";
 235 # socket(SH,PF_INET,SOCK_STREAM,getprotobyname('tcp')) or die "$0: socket $!\n";
 236 # connect(SH,sockaddr_in($port,$iaddr)) or die "$0: connect $!\n";
 237 # warn "connecting $server:$port user=$user\n";
 238 if ($port == 443) {
 239   if ($opt_v and %SSL) {
 240     foreach my $v (keys %SSL) {
 241       printf "%s => %s\n",$v,$SSL{$v};
 242     }
 243   }
 244   eval "use IO::Socket::SSL";
 245   die "$0: cannot load IO::Socket::SSL\n" if $@;
 246   $SH = IO::Socket::SSL->new(
 247     PeerAddr => $server,
 248     PeerPort => $port,
 249     Proto    => 'tcp',
 250     %SSL
 251   );
 252 } else {
 253   $SH = IO::Socket::INET->new(
 254     PeerAddr => $server,
 255     PeerPort => $port,
 256     Proto    => 'tcp',
 257   );
 258 }
 259
 260 die "cannot connect $server:$port - $!\n" unless $SH;
 261 warn "TCPCONNECT to $server:$port\n" if $opt_v;
 262
 263 # autoflush $SH 1;
 264 autoflush STDERR;
 265
 266 $SIG{PIPE} = \&sigpipehandler;
 267
 268 if ($0 eq 'sexget' or $0 eq 'fuckme') {
 269   $stream = "&stream=" . shift if @ARGV;
 270   if ($anonymous) {
 271     $cid = 'anonymous';
 272   } elsif ($id eq 'public') {
 273     $cid = 'public';
 274   } else {
 275     $cid = query_sid($server,$port,$id);
 276   }
 277   request("GET /sex?BS=$bs&user=$user&ID=$cid$stream HTTP/1.0");
 278   transfer($SH,STDOUT);
 279   # print while sysread $SH,$_,$bs;
 280   exit;
 281 }
 282
 283 if ($0 eq 'sexxx') {
 284   $stream = "&stream=" . ($opt_s || 'xx');
 285   if (@ARGV) {
 286     warn "streaming:\n";
 287     open my $tar,'-|','tar',"cv${opt_c}f",'-',@ARGV or die "$0: cannot run tar - $!\n";
 288     request("POST /sex?BS=$bs&user=$user$type$stream HTTP/1.0");
 289     transfer($tar,$SH);
 290     # while (read $tar,$_,$bs) { syswrite $SH,$_ }
 291   } else {
 292     $cid = query_sid($server,$port,$id);
 293     request("GET /sex?BS=$bs&user=$user&ID=$cid$stream HTTP/1.0");
 294     $opt_c = 'z' if $H{'CONTENT-TYPE'} =~ /gzip/i;
 295     if (-t STDOUT) {
 296       print "extracting from stream:\n";
 297       open $out,"|tar xv${opt_c}f -" or die "$0: cannot run tar - $!\n";
 298     } else {
 299       if ($opt_c) {
 300         open $out,"|gzip -d" or die "$0: cannot run gunzip - $!\n";
 301       } else {
 302         $out = *STDOUT;
 303       }
 304     }
 305     print {$out} $_ while sysread $SH,$_,$bs;
 306   }
 307   exit;
 308 }
 309
 310 # sexsend
 311 $stream = "&stream=" . shift if @ARGV;
 312
 313 if ($mode eq 'anonymous') {
 314   unless ($opt_q) {
 315     print "http://$server:$port/sex?user=$user&ID=anonymous$stream\n";
 316     printf "http://$server:$port/sex?%s\n",
 317            encode_b64("user=$user&ID=anonymous$stream");
 318   }
 319   $mode = "&mode=anonymous";
 320 } elsif ($mode eq 'public') {
 321   die "$0: need user/ID when sending to public, set it with fexsend -I\n" unless $user and $id;
 322   unless ($opt_q) {
 323     print "http://$server:$port/sex?user=$user&ID=public$stream\n";
 324     printf "http://$server:$port/sex?%s\n",
 325            encode_b64("user=$user&ID=public$stream");
 326   }
 327   $cid = query_sid($server,$port,$id);
 328   $mode = "&ID=$cid&mode=public";
 329 } else {
 330   # $user = checkalias($user) unless $opt_d;
 331 }
 332
 333 request("POST /sex?BS=$bs&user=$user$mode$type$timeout$stream HTTP/1.0");
 334 print STDERR "--> (streaming ...)\n" if $opt_v;
 335
 336 transfer(STDIN,$SH);
 337
 338 exit;
 339
 340
 341 sub transfer {
 342   my $source = shift;
 343   my $destination = shift;
 344   my ($t0,$t1,$tt);
 345   my ($B,$b,$bt);
 346
 347   $t0 = $t2 = time;
 348   $tt = $t0-1;
 349   $t1 = 0;
 350
 351   while ($b = sysread $source,$_,$bs) {
 352     print {$destination} $_ or die "$0: link failure - $!\n";
 353     $B += $b;
 354     $bt += $b;
 355     $t2 = time;
 356     if ($t2>$t1) {
 357       if ($opt_g) {
 358         if ($B>2*M) {
 359           printf STDERR "%d MB %d kB/s        \r",
 360             int($B/M),int($bt/k/($t2-$tt));
 361         } else {
 362           printf STDERR "%d kB %d kB/s        \r",
 363             int($B/k),int($bt/k/($t2-$tt));
 364         }
 365       }
 366       $t1 = $t2;
 367       if ($t2-$tt>10) {
 368         sleep 1; # be nice to bandwith
 369         $bt = 0;
 370         $tt = $t2;
 371       }
 372     }
 373   }
 374
 375   die "$0: no stream data\n" unless $B;
 376
 377   $tt = (time-$t0)||1;
 378
 379   if ($opt_v or $opt_g) {
 380     if ($B>2097152) {
 381       printf STDERR "transfered: %d MB in %d s with %d kB/s\n",
 382         int($B/1048576),$tt,int($B/1024/$tt);
 383     } elsif($B>2048) {
 384       printf STDERR "transfered: %d kB in %d s with %d kB/s\n",
 385         int($B/1024),$tt,int($B/1024/$tt);
 386     } else {
 387       printf STDERR "transfered: %d B in %d s with %d kB/s\n",
 388         $B,$tt,int($B/1024/$tt);
 389     }
 390   }
 391
 392 }
 393
 394
 395 sub request {
 396   my $req = shift;
 397
 398   print STDERR "--> $req\n" if $opt_v;
 399   syswrite $SH,"$req\r\n";
 400   syswrite $SH,"User-Agent: sexsend\r\n";
 401   syswrite $SH,"\r\n";
 402   for (;;) {
 403     unless (defined($_ = &getline)) {
 404       die "$0: server has closed the connection\n";
 405     }
 406     if (/^HTTP\/[\d\.]+ 200/) {
 407       print STDERR "<-- $_" if $opt_v;
 408       last;
 409     } elsif (/^HTTP\/[\d\.]+ 199/) {
 410       print STDERR "<-- $_" if $opt_v;
 411     } else {
 412       if ($opt_v) {
 413         print STDERR "<-- $_";
 414         exit 3;
 415       } else {
 416         s:^HTTP/[ \d\.]+::;
 417         s/\r//;
 418         die "$0: server response: $_";
 419       }
 420     }
 421   }
 422   while (defined($_ = &getline)) {
 423     last if /^\s*$/;
 424     $H{uc($1)} = $2 if /(.+):\s*(.+)/;
 425     print STDERR "<-- $_" if $opt_v;
 426   }
 427 }
 428
 429 # check for (mutt) alias
 430 sub checkalias {
 431   my $to = shift;
 432   if ($to !~ /@/ and open F,$ENV{HOME}.'/.mutt/aliases') {
 433     while (<F>) {
 434       next if /,/;
 435       if (/^alias $to\s/i) {
 436         chomp;
 437         s/\s*#.*//;
 438         s/\s+$//;
 439         s/.*\s+//;
 440         s/<//;
 441         s/>//;
 442         $to = $_;
 443         warn "$0: found alias, using address $to\n";
 444         die unless $to;
 445         last;
 446       }
 447     }
 448     close F;
 449   }
 450   return $to;
 451 }
 452
 453 sub despace {
 454   foreach (@_) {
 455     s/^\s+//;
 456     s/\s+$//;
 457   }
 458 }
 459
 460 sub query_sid {
 461   my ($server,$port,$id) = @_;
 462   my $req;
 463   local $_;
 464
 465   $req = "GET SID HTTP/1.1";
 466   print STDERR "--> $req\n" if $opt_v;
 467   syswrite $SH,"$req\r\n\r\n";
 468   $_ = &getline;
 469   unless (defined $_ and /\w/) {
 470     print STDERR "\n" if $opt_v;
 471     die "$0: no response from server\n";
 472   }
 473   s/\r//;
 474   if (/^HTTP.* 201 (.+)/) {
 475     print STDERR "<-- $_" if $opt_v;
 476     $id = 'MD5H:'.md5_hex($id.$1);
 477     while (defined($_ = &getline)) {
 478       s/\r//;
 479       last if /^\n/;
 480       print STDERR "<-- $_" if $opt_v;
 481     }
 482   } else {
 483     die "$0: $server does not support session ID\n";
 484   }
 485   return $id;
 486 }
 487
 488 sub sigpipehandler {
 489   local $_ = '';
 490   $SIG{ALRM} = sub { };
 491   alarm(1);
 492   $_ = &getline||'';
 493   if (/^HTTP.* \d+ (.*)/) {
 494     if ($opt_v) {
 495       die "\n$0: server error: @_\n";
 496     } else {
 497       die "\n$0: server error: $1\n";
 498     }
 499   } else {
 500     die "\n$0: got SIGPIPE (server closed connection)\n";
 501   }
 502 }
 503
 504 # read one text line from $SH;
 505 sub getline {
 506   my $line = '';
 507   my $c;
 508
 509   local $SIG{ALRM} = sub { die "$0: timeout while waiting for server reply\n" };
 510   alarm($opt_t||300);
 511
 512   # must use sysread to avoid perl line buffering
 513   while (sysread $SH,$c,1) {
 514     $line .= $c;
 515     last if $c eq "\n";
 516   }
 517
 518   alarm(0);
 519
 520   return $line;
 521 }
 522
 523 # from MIME::Base64::Perl
 524 sub decode_b64 {
 525   local $_ = shift;
 526   my $uu = '';
 527   my ($i,$l);
 528
 529   tr|A-Za-z0-9+=/||cd;
 530   s/=+$//;
 531   tr|A-Za-z0-9+/| -_|;
 532   return "" unless length;
 533
 534   $l = (length) - 60;
 535   for ($i = 0; $i <= $l; $i += 60) {
 536     $uu .= "M" . substr($_,$i,60);
 537   }
 538   $_ = substr($_,$i);
 539   if (length) {
 540     $uu .= chr(32 + (length)*3/4) . $_;
 541   }
 542   return unpack ("u",$uu);
 543 }
 544
 545
 546 ### common functions ###
 547
 548
 549 sub mtime {
 550   my @d = localtime((stat shift)[9]);
 551   return sprintf('%d%02d%02d',$d[5]+1900,$d[4]+1,$d[3]);
 552 }
 553
 554
 555 sub urldecode {
 556   local $_ = shift;
 557   s/\%([a-f\d]{2})/chr(hex($1))/ige;
 558   return $_;
 559 }
 560
 561
 562 sub get_ssl_env {
 563   # set SSL/TLS options
 564   $SSL{SSL_verify_mode} = $ENV{SSLVERIFY} if defined($ENV{SSLVERIFY});
 565   foreach my $opt (qw(
 566     SSL_version
 567     SSL_cipher_list
 568     SSL_verify_mode
 569     SSL_ca_path
 570     SSL_ca_file)
 571   ) {
 572     my $env = uc($opt);
 573     $env =~ s/_//g;
 574     $SSL{$opt} = $ENV{$env} if defined($ENV{$env});
 575   }
 576
 577   if ($SSL{SSL_verify_mode}) {
 578     &search_ca;
 579     unless ($SSL{SSL_ca_path} or $SSL{SSL_ca_file}) {
 580       die "$0: \$SSLVERIFYMODE, but not valid \$SSLCAPATH or \$SSLCAFILE\n";
 581     }
 582   } elsif (defined($SSL{SSL_verify_mode})) {
 583     # user has set SSLVERIFY=0 !
 584   } else {
 585     &search_ca;
 586     $SSL{SSL_verify_mode} = 1 if $SSL{SSL_ca_path} or $SSL{SSL_ca_file};
 587   }
 588 }
 589
 590 sub search_ca {
 591   local $_;
 592   return if $SSL{SSL_ca_file} or $SSL{SSL_ca_path};
 593   foreach (qw(/etc/ssl/certs/ca-certificates.crt)) {
 594     if (-f) {
 595       $SSL{SSL_ca_file} = $_;
 596       return;
 597     }
 598   }
 599   foreach (qw(/etc/ssl/certs /etc/pki/tls/certs)) {
 600     if (-f) {
 601       $SSL{SSL_ca_path} = $_;
 602       return;
 603     }
 604   }
 605 }
 606
 607
 608 sub serverconnect {
 609   my ($server,$port) = @_;
 610   my $connect = "CONNECT $server:$port HTTP/1.1";
 611   local $_;
 612
 613   if ($proxy) {
 614     tcpconnect(split(':',$proxy));
 615     if ($https) {
 616       printf "--> %s\n",$connect if $opt_v;
 617       nvtsend($connect,"");
 618       $_ = <$SH>;
 619       s/\r//;
 620       printf "<-- $_"if $opt_v;
 621       unless (/^HTTP.1.. 200/) {
 622         die "$0: proxy error : $_";
 623       }
 624       &enable_ssl;
 625       $SH = IO::Socket::SSL->start_SSL($SH,%SSL);
 626     }
 627   } else {
 628     tcpconnect($server,$port);
 629   }
 630 #  if ($https and $opt_v) {
 631 #    printf "%s\n",$SH->get_cipher();
 632 #  }
 633 }
 634
 635
 636 # set up tcp/ip connection
 637 sub tcpconnect {
 638   my ($server,$port) = @_;
 639
 640   if ($SH) {
 641     close $SH;
 642     undef $SH;
 643   }
 644
 645   if ($https) {
 646     # eval "use IO::Socket::SSL qw(debug3)";
 647     &enable_ssl;
 648     $SH = IO::Socket::SSL->new(
 649       PeerAddr => $server,
 650       PeerPort => $port,
 651       Proto    => 'tcp',
 652       %SSL
 653     );
 654   } else {
 655     $SH = IO::Socket::INET->new(
 656       PeerAddr => $server,
 657       PeerPort => $port,
 658       Proto    => 'tcp',
 659     );
 660   }
 661
 662   if ($SH) {
 663     autoflush $SH 1;
 664     binmode $SH;
 665   } else {
 666     die "$0: cannot connect $server:$port - $@\n";
 667   }
 668
 669   print "TCPCONNECT to $server:$port\n" if $opt_v;
 670 }
 671
 672
 673 sub enable_ssl {
 674   eval "use IO::Socket::SSL";
 675   die "$0: cannot load IO::Socket::SSL\n" if $@;
 676   eval '$SSL{SSL_verify_mode} = 0 if Net::SSLeay::SSLeay() <= 9470143';
 677   if ($opt_v) {
 678     foreach my $v (keys %SSL) {
 679       printf "%s => %s\n",$v,$SSL{$v};
 680     }
 681   }
 682 }
 683
 684
 685 sub sendheader {
 686   my $sp = shift;
 687   my @head = @_;
 688   my $head;
 689
 690   push @head,"Host: $sp";
 691
 692   foreach $head (@head) {
 693     print "--> $head\n" if $opt_v;
 694     print {$SH} $head,"\r\n";
 695   }
 696   print "-->\n" if $opt_v;
 697   print {$SH} "\r\n";
 698 }
 699
 700
 701 sub nvtsend {
 702   local $SIG{PIPE} = sub { $sigpipe = "@_" };
 703
 704   $sigpipe = '';
 705
 706   die "$0: internal error: no active network handle\n" unless $SH;
 707   die "$0: remote host has closed the link\n" unless $SH->connected;
 708
 709   foreach my $line (@_) {
 710     print {$SH} $line,"\r\n";
 711     if ($sigpipe) {
 712       undef $SH;
 713       return 0;
 714     }
 715   }
 716
 717   return 1;
 718 }
 719
 720
 721 sub quote {
 722   local $_ = shift;
 723   s/([^\w\@\/%^,.=+_:+-])/\\$1/g;
 724   return $_;
 725 }
 726
 727
 728 sub debug {
 729   print "## DEBUG: @_\n" if $DEBUG;
 730 }
 731
 732
 733 # from MIME::Base64::Perl
 734 sub encode_b64 {
 735   my $res = "";
 736   my $eol = "\n";
 737   my $padding;
 738
 739   pos($_[0]) = 0;
 740   $res = join '',map(pack('u',$_)=~ /^.(\S*)/, ($_[0]=~/(.{1,45})/gs));
 741   $res =~ tr|` -_|AA-Za-z0-9+/|;
 742   $padding = (3-length($_[0])%3)%3;
 743   $res =~ s/.{$padding}$/'=' x $padding/e if $padding;
 744   return $res;
 745 }