#!/usr/bin/perl -w

# client for stream exchange of the FEX service
#
# Author: Ulli Horlacher <framstag@belwue.de>
#
# Perl Artistic Licence

# sexsend / sexget / sexxx

use Getopt::Std;
use Socket;
use IO::Handle;
use IO::Socket::INET;
use Digest::MD5 qw(md5_hex);  # encypted ID / SID

use constant k => 2**10;
use constant M => 2**20;

eval 'use Net::INET6Glue::INET_is_INET6';

our $version = 20200429;
our $DEBUG = $ENV{DEBUG};
our $prg = $0;

our %SSL = (SSL_version => 'TLSv1');

my $sigpipe;

unless ($version) {
  my @d = localtime((stat $0)[9]);
  $version = sprintf('%d%02d%02d',$d[5]+1900,$d[4]+1,$d[3])
}

our $useragent = "sexsend-$version";
if (my $fua = $ENV{FUA}) {
  $useragent =~ s:^:$fua/:;
}

if (-f ($_ = '/etc/fex/config.pl')) {
  eval { require } or warn $@;
}

$| = 1;
$prg =~ s:(.*)/::; # and $fexsend = "$1/fexsend";
$0 = "$prg @ARGV";

# sexsend is default
$usage =
  "usage: ... | $prg [options] [SEX-URL/]recipient [stream]\n".
  "options: -v           verbose mode\n".
  "         -g           show transfer rate\n".
  "         -V           show version\n".
  "         -m KBS       limit throughput (KBS kB/s)\n".
  "         -t timeout   timeout in s (waiting for recipient)\n".
  "special: recipient may be \"public\" or \"anonymous\" or \".\"\n".
  "see also: sexget, sexxx\n".
  "example: tail -f /var/log/syslog | $prg fex.flupp.org/admin log\n";

if ($prg eq 'sexget' or $prg eq 'fuckme') {
  $usage =
    "usage: $prg [options] [[SEX-URL/]user:ID] [stream]\n".
    "options: -v           verbose mode\n".
    "         -g           show transfer rate\n".
    "         -m KBS       limit throughput (KBS kB/s)\n".
    "arguments: user:ID    use this user & ID\n".
    "                      (ID may be \"public\" or user:ID may be \"anonymous\")\n".
    "           stream     name of the stream\n".
    "see also: sexsend, sexxx\n".
    "example: $prg log | grep kernel\n";
}

if ($prg eq 'sexxx') {
  $usage =
    "usage: $prg [-v] [-g] [-c] [-u [SEX-URL/]user] [-s stream] [files...]\n".
    "usage: $prg [-v] [-g]      [-u [SEX-URL/]user] [-s stream] | ...\n".
    "options: -v               verbose mode\n".
    "         -g               show transfer rate\n".
    "         -q               quiet mode\n".
    "         -c               compress files\n".
    "         -m KBS           limit throughput (KBS kB/s)\n".
    "         -u SEX-URL/user  SEX-URL and user (default: use FEXID/FEXXX)\n".
    "         -s stream        stream name (default: xx)\n".
    "see also: sexsend, sexget\n".
    "examples: $prg -s config /etc /usr/local/etc\n".
    "          $prg > backup.tar\n";
}

$fexhome = $ENV{FEXHOME} || $ENV{HOME}.'/.fex';
$user = $id = '';
$type = $timeout = $stream = $mode = '';
$idf = "$fexhome/id";
$bs = $ENV{BS} || 2**16; # I/O blocksize

# server URL, user and auth-ID
if ($FEXID = $ENV{FEXID}) {
  $FEXID = decode_b64($FEXID) if $FEXID !~ /\s/;
  if ($FEXID =~ /!/) {
    die qq'$prg: \$FEXID contains "!" - proxy is not supported\n';
  }
  ($fexcgi,$user,$id) = split(/\s+/,$FEXID);
} else {
  if (open $idf,$idf) {
    chomp($fexcgi = <$idf>) or die "$prg: no FEX-URL in $idf\n";
    chomp($user = <$idf>)   or die "$prg: no FROM in $idf\n";
    chomp($id = <$idf>)     or die "$prg: no ID in $idf\n";
    close $idf;
    despace($fexcgi,$user,$id);
    if ($fexcgi =~ /!/) {
      die qq'$prg: FEX-URL "$fexcgi" in $idf contains "!"'.
          qq' - proxy is not supported\n';
    }
    if ($fexcgi !~ /^[_:=\w\-\.\/\@\%]+$/) {
      die qq'$prg: illegal FEX-URL "$fexcgi" in $idf\n';
    }
    unless ($user =~ /^[_:=\w\-\.\/\@\%\+]+$/) {
      die qq'$prg: illegal FROM "$user" in $idf\n';
    }
  }
}

$_ = "$fexhome/config.pl"; require if -f;

$opt_h = $opt_v = $opt_V = $opt_q = 0;
$opt_u = $opt_s = $opt_c = $opt_t = $opt_m = '';

if ($prg eq 'sexxx') {

  # xx server URL, user and auth-ID
  if ($FEXXX = $ENV{FEXXX}) {
    $FEXXX = decode_b64($FEXXX) if $FEXXX !~ /\s/;
    ($fexcgi,$user,$id) = split(/\s+/,$FEXXX);
  } elsif (open $idf,$idf) {
    while (<$idf>) {
      if (/^\[xx\]/) {
        chomp($fexcgi = <$idf>) or die "$prg: no xx FEX-URL in $idf\n";
        chomp($user = <$idf>)   or die "$prg: no xx FROM in $idf\n";
        chomp($id = <$idf>)     or die "$prg: no xx ID in $idf\n";
        last;
      }
    }
    close $idf;
  }

  getopts('hgvcu:s:m:') or die $usage;
  die $usage if $opt_h;
  die $usage unless -t;

  if ($opt_c) {
    $opt_c = 'z';
    $type = '&type=GZIP';
  }

  if ($opt_u) {
    $fexcgi = $1 if $opt_u =~ s:(.+)/::;
    $user = $opt_u;
  }

  if ($opt_m !~ /^\d+$/) {
    $opt_m = 0;
  }

  unless ($fexcgi) {
    die "$prg: no xx user found, use \"$prg -u SEX-URL/user\"\n";
  }

  unless ($user) {
    die "$prg: no xx user found, use \"$prg -u user\"\n";
  }

} elsif ($prg eq 'sexget' or $prg eq 'fuckme') {

  $opt_g = 0;
  getopts('hgvVdqu:m:') or die $usage;
  die $usage if $opt_h;


  if ($opt_V) {
    print "Version: $version\n";
    exit unless @ARGV;
  }

  if (not $opt_u and @ARGV and $ARGV[0] =~ m{^anonymous|/|:}) {
    $opt_u = shift @ARGV;
  }

  if ($opt_u) {
    $fexcgi = $1 if $opt_u =~ s:(.+)/::;
    ($user,$id) = split(':',$opt_u);
    if ($user =~ /^anonymous/) {
      $anonymous = $user;
    } elsif (not $id) {
      die $usage;
    }
  }

  unless ($fexcgi) {
    die "$prg: no SEX URL found, use \"$prg -u SEX-URL/recipient\" or \"fexsend -I\"\n";
  }

  unless ($user) {
    die "$prg: no recipient found, use \"$prg -u SEX-URL/recipient\" or \"fexsend -I\"\n";
  }

} else { # sexsend

  $opt_g = 0;
  getopts('hguvqVTt:m:') or die $usage;
  die $usage if $opt_h;

  if ($opt_V) {
    print "Version: $version\n";
    exit unless @ARGV;
  }

  if ($opt_t and $opt_t =~ /^\d+$/) {
    $timeout = "&timeout=$opt_t";
  }

  my $save_user = $user;
  $user = shift or die $usage;
  $fexcgi = $1 if $user =~ s:(.+)/::;

  if ($user =~ /^anonymous/) {
    die "$prg: need SEX-URL with anonymous SEX\n" unless $fexcgi;
    $mode = 'anonymous';
  } elsif ($user eq 'public') {
    unless ($id) {
      die "$prg: public SEX not possible without FEXID, set it with \"fexsend -I\"\n";
    }
    $mode = $user;
    $user = $save_user;
  } elsif ($user eq 'DOX') {
    unless ($id) {
      die "$prg: DOX SEX not possible without FEXID\n";
    }
    $mode = $user;
    $user = $save_user;
  } elsif ($user eq '.') {
    open $idf,$idf or die "$prg: no $idf\n";
    $_ = <$idf>;
    $user = <$idf>||'';
    chomp $user;
  } else {
    unless ($fexcgi) {
      die "$prg: no SEX URL found, use \"$prg SEX-URL/recipient\" or \"fexsend -I\"\n";
    }
  }

}

# &get_ssl_env;

$fexcgi =~ s(^http://)()i;
$fexcgi =~ s(/fup.*)();
$server = $fexcgi;

if    ($server =~ s(^https://)()i) { $port = 443 }
elsif ($server =~ /:(\d+)/)        { $port = $1 }
else                               { $port = 80 }

$server =~ s([:/].*)();

## set up tcp/ip connection
# $iaddr = gethostbyname($server)
#          or die "$prg: cannot find ip-address for $server $!\n";
# socket(SH,PF_INET,SOCK_STREAM,getprotobyname('tcp')) or die "$prg: socket $!\n";
# connect(SH,sockaddr_in($port,$iaddr)) or die "$prg: connect $!\n";
# warn "connecting $server:$port user=$user\n";
if ($port == 443) {
  if ($opt_v and %SSL) {
    foreach my $v (keys %SSL) {
      printf "%s => %s\n",$v,$SSL{$v};
    }
  }

  &enable_ssl;
  $SH = IO::Socket::SSL->new(
    PeerAddr => $server,
    PeerPort => $port,
    Proto    => 'tcp',
    %SSL
  );
} else {
  $SH = IO::Socket::INET->new(
    PeerAddr => $server,
    PeerPort => $port,
    Proto    => 'tcp',
  );
}

die "cannot connect $server:$port - $!\n" unless $SH;
warn "TCPCONNECT to $server:$port\n" if $opt_v;

# autoflush $SH 1;
autoflush STDERR;

$SIG{PIPE} = \&sigpipehandler;

if ($prg eq 'sexget' or $prg eq 'fuckme') {
  $stream = "&stream=" . shift if @ARGV;
  if ($anonymous) {
    $cid = 'anonymous';
  } elsif ($id eq 'public') {
    $cid = 'public';
  } else {
    $cid = query_sid($server,$port,$id);
  }
  request("GET /sex?BS=$bs&user=$user&ID=$cid$stream HTTP/1.0");
  transfer($SH,STDOUT);
  # print while sysread $SH,$_,$bs;
  exit;
}

if ($prg eq 'sexxx') {
  $stream = "&stream=" . ($opt_s || 'xx');
  if (@ARGV) {
    warn "streaming:\n";
    open my $tar,'-|','tar',"-cv${opt_c}f",'-',@ARGV or die "$prg: cannot run tar - $!\n";
    request("POST /sex?BS=$bs&user=$user$type$stream HTTP/1.0");
    transfer($tar,$SH);
    # while (read $tar,$_,$bs) { syswrite $SH,$_ }
  } else {
    $cid = query_sid($server,$port,$id);
    request("GET /sex?BS=$bs&user=$user&ID=$cid$stream HTTP/1.0");
    $opt_c = 'z' if $H{'CONTENT-TYPE'} =~ /gzip/i;
    if (-t STDOUT) {
      print "extracting from stream:\n";
      open $out,"|tar xv${opt_c}f -" or die "$prg: cannot run tar - $!\n";
    } else {
      if ($opt_c) {
        open $out,"|gzip -d" or die "$prg: cannot run gunzip - $!\n";
      } else {
        $out = *STDOUT;
      }
    }
    $B = 0;
    $t0 = time;
    while ($b = sysread $SH,$_,$bs) {
      $B += $b;
      print {$out} $_;
      if ($opt_m) {
        sleep 1 while $B/((time-$t0)||1)/k > $opt_m;
      }
    }
  }
  exit;
} # sexxx

# sexsend
$stream = "&stream=" . shift if @ARGV;

my $psp = "http://$server:$port";
$psp =~ s/:443// and $psp =~ s/http/https/;

if ($mode eq 'anonymous') {
  unless ($opt_q) {
    print "$psp/sex?user=$user&ID=anonymous$stream\n";
    printf "$psp/sex?%s\n",
           encode_b64("user=$user&ID=anonymous$stream");
  }
  $mode = "&mode=anonymous";
} elsif ($mode eq 'public') {
  unless ($user and $id) {
    die "$prg: need user/ID when sending to public, set it with fexsend -I\n";
  }
  unless ($opt_q) {
    unless ($ENV{GATEWAY_INTERFACE}) {
      print "$psp/sex?user=$user&ID=public$stream\n";
      printf "$psp/sex?%s\n",
             encode_b64("user=$user&ID=public$stream");
    }
    $stream =~ /=(.+)/ and
    print "sexget $psp/$user:public $1\n";
  }
  $cid = query_sid($server,$port,$id);
  $mode = "&ID=$cid&mode=$mode";
} elsif ($mode eq 'DOX') {
  unless ($user and $id) {
    die "$prg: need user/ID\n";
  }
  $cid = query_sid($server,$port,$id);
  $mode = "&ID=$cid&mode=$mode";
} else {
  # $user = checkalias($user) unless $opt_d;
}

request("POST /sex?BS=$bs&user=$user$mode$timeout$stream HTTP/1.0");
print STDERR "--> (streaming ...)\n" if $opt_v;

transfer(STDIN,$SH);

exit;


sub transfer {
  my $source = shift;
  my $destination = shift;
  my $B = 0;
  my ($t0,$t1,$tt);
  my ($b,$bt);

  $t0 = $t2 = time;
  $tt = $t0-1;
  $t1 = 0;

  while ($b = sysread $source,$_,$bs) {
    print {$destination} $_ or die "$prg: link failure - $!\n";
    $B += $b;
    $bt += $b;
    $t2 = time;
    if ($opt_m) {
      sleep 1 while $B/((time-$t0)||1)/k > $opt_m;
    }
    if ($t2>$t1) {
      if ($opt_g) {
        if ($B>2*M) {
          printf "%d MB %d kB/s        \n",
            int($B/M),int($bt/k/($t2-$tt));
        } else {
          printf "%d kB %d kB/s        \n",
            int($B/k),int($bt/k/($t2-$tt));
        }
        # print "\n" if $dox;
      }
      $t1 = $t2;
      if ($t2-$tt>10) {
        $bt = 0;
        $tt = $t2;
      }
    }
  }

  die "$prg: no stream data\n" unless $B;

  $tt = (time-$t0)||1;

  if ($opt_v or $opt_g) {
    if ($B>2097152) {
      printf "transfered: %d MB in %d s with %d kB/s\n",
        int($B/1048576),$tt,int($B/1024/$tt);
    } elsif($B>2048) {
      printf "transfered: %d kB in %d s with %d kB/s\n",
        int($B/1024),$tt,int($B/1024/$tt);
    } else {
      printf "transfered: %d B in %d s with %d kB/s\n",
        $B,$tt,int($B/1024/$tt);
    }
  }

}


sub request {
  my $req = shift;

  print STDERR "--> $req\n" if $opt_v;
  syswrite $SH,"$req\r\n";
  syswrite $SH,"Host: $server\r\n";
  syswrite $SH,"User-Agent: $useragent\r\n";
  syswrite $SH,"\r\n";
  for (;;) {
    unless (defined($_ = &getline)) {
      die "$prg: server has closed the connection\n";
    }
    if (/^HTTP\/[\d\.]+ 200/) {
      print STDERR "<-- $_" if $opt_v;
      last;
    } elsif (/^HTTP\/[\d\.]+ 199/) {
      print STDERR "<-- $_" if $opt_v;
    } else {
      if ($opt_v) {
        print STDERR "<-- $_";
        exit 3;
      } else {
        s:^HTTP/[ \d\.]+::;
        s/\r//;
        die "$prg: server response: $_";
      }
    }
  }
  while (defined($_ = &getline)) {
    last if /^\s*$/;
    $H{uc($1)} = $2 if /(.+):\s*(.+)/;
    print STDERR "<-- $_" if $opt_v;
  }
}

# check for (mutt) alias
sub checkalias {
  my $to = shift;
  if ($to !~ /@/ and open F,$ENV{HOME}.'/.mutt/aliases') {
    while (<F>) {
      next if /,/;
      if (/^alias $to\s/i) {
        chomp;
        s/\s*#.*//;
        s/\s+$//;
        s/.*\s+//;
        s/<//;
        s/>//;
        $to = $_;
        warn "$prg: found alias, using address $to\n";
        die unless $to;
        last;
      }
    }
    close F;
  }
  return $to;
}

sub despace {
  foreach (@_) {
    s/^\s+//;
    s/\s+$//;
  }
}

sub query_sid {
  my ($server,$port,$id) = @_;
  my $req;
  local $_;

  $req = "GET SID HTTP/1.1";
  print STDERR "--> $req\n" if $opt_v;
  syswrite $SH,"$req\r\n\r\n";
  $_ = &getline;
  unless (defined $_ and /\w/) {
    print STDERR "\n" if $opt_v;
    die "$prg: no response from server\n";
  }
  s/\r//;
  if (/^HTTP.* 201 (.+)/) {
    print STDERR "<-- $_" if $opt_v;
    $id = 'MD5H:'.md5_hex($id.$1);
    while (defined($_ = &getline)) {
      s/\r//;
      last if /^\n/;
      print STDERR "<-- $_" if $opt_v;
    }
  } else {
    die "$prg: $server does not support session ID\n";
  }
  return $id;
}

sub sigpipehandler {
  local $_ = '';
  $SIG{ALRM} = sub { };
  alarm(1);
  $_ = &getline||'';
  if (/^HTTP.* \d+ (.*)/) {
    if ($opt_v) {
      die "\n$prg: server error: @_\n";
    } else {
      die "\n$prg: server error: $1\n";
    }
  } else {
    die "\n$prg: got SIGPIPE (server closed connection)\n";
  }
}

# read one text line from $SH;
sub getline {
  my $line = '';
  my $c;

  local $SIG{ALRM} = sub { die "$prg: timeout while waiting for server reply\n" };
  alarm($opt_t||300);

  # must use sysread to avoid perl line buffering
  while (sysread $SH,$c,1) {
    $line .= $c;
    last if $c eq "\n";
  }

  alarm(0);

  return $line;
}

### common functions ###

sub mtime {
  my @d = localtime((stat shift)[9]);
  return sprintf('%d%02d%02d',$d[5]+1900,$d[4]+1,$d[3]);
}


sub urldecode {
  local $_ = shift;
  s/\%([a-f\d]{2})/chr(hex($1))/ige;
  return $_;
}


sub serverconnect {
  my ($server,$port) = @_;
  my $connect = "CONNECT $server:$port HTTP/1.1";
  local $_;

  if ($proxy) {
    tcpconnect(split(':',$proxy));
    if ($port == 443) {
      nvtsend($connect,"");
      $_ = <$SH>;
      s/\r//;
      warn "<-- $_"if $opt_v;
      unless (/^HTTP.1.. 200/) {
        die "$prg: proxy error : $_";
      }
      &enable_ssl;
      $SH = IO::Socket::SSL->start_SSL($SH,%SSL);
    }
  } else {
    tcpconnect($server,$port);
  }
}


# set up tcp/ip connection
sub tcpconnect {
  my ($server,$port) = @_;

  if ($SH) {
    close $SH;
    undef $SH;
  }

  if ($port == 443) {
    # eval "use IO::Socket::SSL qw(debug3)";
    &enable_ssl;
    $SH = IO::Socket::SSL->new(
      PeerAddr => $server,
      PeerPort => $port,
      Proto    => 'tcp',
      %SSL
    );
  } else {
    $SH = IO::Socket::INET->new(
      PeerAddr => $server,
      PeerPort => $port,
      Proto    => 'tcp',
    );
  }

  if ($SH) {
    autoflush $SH 1;
    binmode $SH;
  } else {
    die "$prg: cannot connect $server:$port - $@\n";
  }

  warn "TCPCONNECT to $server:$port\n" if $opt_v;
}


sub sendheader {
  my $sp = shift;
  my @head = @_;
  my $head;

  push @head,"Host: $sp";
  push @head,"User-Agent: $useragent";

  foreach $head (@head) {
    chomp $head;
    warn "--> $head\n" if $opt_v;
    print {$SH} $head,"\r\n";
  }
  warn "-->\n" if $opt_v;
  print {$SH} "\r\n";
}


sub nvtsend {
  local $SIG{PIPE} = sub { $sigpipe = "@_" };

  $sigpipe = '';

  die "$prg: internal error: no active network handle\n" unless $SH;
  die "$prg: remote host has closed the link\n" unless $SH->connected;

  foreach my $line (@_) {
    warn "--> $line\n" if $opt_v;
    print {$SH} $line,"\r\n";
    if ($sigpipe) {
      undef $SH;
      return 0;
    }
  }

  return 1;
}


sub shellquote {
  local $_ = shift;
  s/([^\w\@\/!^%:_.,=+-])/\\$1/g;
  return $_;
}


sub debug {
  print "## DEBUG: @_\n" if $DEBUG;
}


sub locale {
  my $string = shift;

  # my @x = Encode->encodings(':all');  die "$CTYPE - @x";
  if ($CTYPE) {
    if ($CTYPE =~ /UTF-?8/i) {
      return $string;
    } elsif (grep { $CTYPE =~ /^$_$/i } Encode->encodings(':all')) {
      return encode($CTYPE,decode('UTF8',$string));
    } else {
      return encode('ISO-8859-1',decode('UTF8',$string));
    }
  }

  return $string;
}


sub enable_ssl {
  eval "use IO::Socket::SSL";
  die "$prg: cannot load IO::Socket::SSL\n" if $@;
  # needed for CentOS (Redhat, too?)
  foreach (qw'/etc/ssl/cert.pem /etc/ssl/certs/ca-bundle.crt') {
    $SSL{SSL_ca_file} = $_ if -f;
  }
  &get_ssl_env;
  eval '$SSL{SSL_verify_mode} = 0 if Net::SSLeay::SSLeay() <= 9470143';
  if ($opt_v) {
    foreach my $v (keys %SSL) {
      printf STDERR "%s => %s\n",$v,$SSL{$v};
    }
  }
}


sub get_ssl_env {
  # set SSL/TLS options
  $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_ca_file)
  ) {
    my $env = uc($opt);
    $env =~ s/_//g;
    $SSL{$opt} = $ENV{$env} if defined($ENV{$env});
  }

  if ($SSL{SSL_verify_mode} and $SSL{SSL_verify_mode} ne 'SSL_VERIFY_NONE') {
    &search_ca;
    unless ($SSL{SSL_ca_path} or $SSL{SSL_ca_file}) {
      die "$prg: \$SSLVERIFYMODE, but not valid \$SSLCAPATH or \$SSLCAFILE\n";
    }
  } elsif (defined($SSL{SSL_verify_mode})) {
    # user has set SSLVERIFY=0 !
  } else {
    &search_ca;
    $SSL{SSL_verify_mode} = 1 if $SSL{SSL_ca_path} or $SSL{SSL_ca_file};
  }
}


sub search_ca {
  local $_;

  return if $SSL{SSL_ca_file} or $SSL{SSL_ca_path};

  foreach (qw(/etc/ssl/certs/ca-certificates.crt)) {
    if (-f) {
      $SSL{SSL_ca_file} = $_;
      return;
    }
  }

  foreach (qw(/etc/ssl/certs /etc/pki/tls/certs)) {
    if (-d) {
      $SSL{SSL_ca_path} = $_;
      return;
    }
  }
}


# 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+/|;
  $padding = (3-length($_[0])%3)%3;
  $res =~ s/.{$padding}$/'=' x $padding/e if $padding;
  return $res;
}


# from MIME::Base64::Perl
sub decode_b64 {
  local $_ = shift;
  my $uu = '';
  my ($i,$l);

  tr|A-Za-z0-9+=/||cd;
  s/=+$//;
  tr|A-Za-z0-9+/| -_|;
  return "" unless length;

  $l = (length)-60;
  for ($i = 0; $i <= $l; $i += 60) {
    $uu .= "M" . substr($_,$i,60);
  }
  $_ = substr($_,$i);
  if (length) {
    $uu .= chr(32+(length)*3/4) . $_;
  }
  return unpack("u",$uu);
}


sub inputline {
  my $prompt = shift;
  my $default = shift||'';
  my $term = new Term::ReadLine $prg;

  $term->ornaments(0) unless $ENV{PERL_RL};
  return $term->readline($prompt,$default)||'';
}


sub vexec {
  vsystem(@_);
  exit $?;
}


sub vsystem {
  my @cmd = @_;
  my $cmd;
  my $shellmeta = '[\\\'"`*?&|<>(){};]';
  local $_;

  if ($opt_v) {
    if (-t STDIN) { print STDERR '$ ' }
    else          { print STDERR '| ' }
    if (scalar(@cmd) == 1) {
      warn "@cmd\n";
    } else {
      my @w;
      foreach (@cmd) {
        if (/\'/) {
          push @w,shellquote($_);
        } elsif (/[^\w\/:=~^%@,.+-]/) {
          push @w,"'$_'";
        } else {
          push @w,$_;
        }
      }
      warn "@w\n";
    }
  }

  $_ = "@cmd";
  if (scalar(@cmd) == 1 and /\s/ and not (/^\w+=/ or /$shellmeta/)) {
    @cmd = split;
  }

  if (scalar(@cmd) == 1) {
    $cmd = "@cmd";
    $cmd =~ s/\|&$/ 2>&1|/;
    if ($cmd =~ s/\|$//) {
      my @a = `$cmd`;
      if (wantarray) {
        map { chomp } @a;
        return @a;
      } else {
        chomp $a[0] if scalar(@a) == 1;
        return join('',@a);
      }
    } else {
      system $cmd;
    }
  } else {
    system @cmd;
  }
}
