"Fossies" - the Fresh Open Source Software Archive

Member "swaks-20201014.0/swaks" (14 Oct 2020, 220118 Bytes) of package /linux/privat/swaks-20201014.0.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "swaks": 20201010.0_vs_20201014.0.

    1 #!/usr/bin/perl
    2 
    3 # use 'swaks --help' to view documentation for this program
    4 #
    5 #      Homepage: http://jetmore.org/john/code/swaks/
    6 #   Online Docs: http://jetmore.org/john/code/swaks/latest/doc/ref.txt
    7 #                http://jetmore.org/john/code/swaks/faq.html
    8 # Announce List: send mail to updates-swaks@jetmore.net
    9 #   Project RSS: http://jetmore.org/john/blog/c/swaks/feed/
   10 #       Twitter: http://www.twitter.com/SwaksSMTP
   11 
   12 use strict;
   13 
   14 $|            = 1;
   15 my($p_name)   = $0 =~ m|/?([^/]+)$|;
   16 my $p_version = build_version("20201014.0", '$Id$');
   17 my $p_usage   = "Usage: $p_name [--help|--version] (see --help for details)";
   18 my $p_cp      = <<'EOM';
   19         Copyright (c) 2003-2008,2010-2020 John Jetmore <jj33@pobox.com>
   20 
   21     This program is free software; you can redistribute it and/or modify
   22     it under the terms of the GNU General Public License as published by
   23     the Free Software Foundation; either version 2 of the License, or
   24     (at your option) any later version.
   25 
   26     This program is distributed in the hope that it will be useful,
   27     but WITHOUT ANY WARRANTY; without even the implied warranty of
   28     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   29     GNU General Public License for more details.
   30 
   31     You should have received a copy of the GNU General Public License
   32     along with this program; if not, write to the Free Software
   33     Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   34 EOM
   35 
   36 # Get all input provided to our program, via file, env, command line, etc
   37 my %O = %{ load_args() };
   38 
   39 # before we do anything else, check for --help and --version
   40 if (get_arg('help', \%O)) {
   41     ext_usage();
   42     exit;
   43 }
   44 if (get_arg('version', \%O)) {
   45     print "$p_name version $p_version\n\n$p_cp\n";
   46     exit;
   47 }
   48 
   49 # Get our functional dependencies and then print and exit early if requested
   50 load_dependencies();
   51 if (get_arg('get_support', \%O)) {
   52     test_support();
   53     exit(0);
   54 }
   55 
   56 # This 'synthetic' command line used for debug and reference
   57 $G::cmdline = reconstruct_options(\%O);
   58 
   59 # We need to fix things up a bit and set a couple of global options
   60 my $opts = process_args(\%O);
   61 
   62 if (scalar(keys(%G::dump_args))) {
   63     if (my $running_state = get_running_state($opts, \%G::dump_args)) {
   64         # --dump is intended as a debug tool for swaks internally.  Always,
   65         # unconditionally, show the user's auth password if one is given
   66         $running_state =~ s/'%RAW_PASSWORD_STRING%'/shquote($opts->{a_pass})/ge;
   67         print $G::trans_fh_oh $running_state;
   68     }
   69     exit(0);
   70 }
   71 elsif ($G::dump_mail) {
   72     # if the user just wanted to generate an email body, dump it now and exit
   73     $opts->{data} =~ s/\n\.\Z//;
   74     print $G::trans_fh_oh $opts->{data};
   75     exit(0);
   76 }
   77 
   78 # we're going to abstract away the actual connection layer from the mail
   79 # process, so move the act of connecting into its own sub.  The sub will
   80 # set info in global hash %G::link
   81 # XXX instead of passing raw data, have processs_opts create a link_data
   82 # XXX hash that we can pass verbatim here
   83 open_link();
   84 
   85 sendmail($opts->{from}, $opts->{to}, $opts->{helo}, $opts->{data},
   86          $opts->{a_user}, $opts->{a_pass}, $opts->{a_type});
   87 
   88 teardown_link();
   89 
   90 exit(0);
   91 
   92 sub teardown_link {
   93     if ($G::link{type} eq 'socket-inet' || $G::link{type} eq 'socket-unix') {
   94         # XXX need anything special for tls teardown?
   95         close($G::link{sock});
   96         ptrans(11,  "Connection closed with remote host.");
   97     } elsif ($G::link{type} eq 'pipe') {
   98         delete($SIG{PIPE});
   99         $SIG{CHLD} = 'IGNORE';
  100         close($G::link{sock}{wr});
  101         close($G::link{sock}{re});
  102         ptrans(11,  "Connection closed with child process.");
  103     }
  104 }
  105 
  106 sub open_link {
  107     if ($G::link{type} eq 'socket-inet') {
  108         ptrans(11, 'Trying ' . $G::link{server} . ':' . $G::link{port} . '...');
  109         $@ = "";
  110 
  111         my @extra_options = ();
  112         push(@extra_options, "LocalAddr", $G::link{lint})  if ($G::link{lint});
  113         push(@extra_options, "LocalPort", $G::link{lport}) if ($G::link{lport});
  114 
  115         # INET6 also supports v4, so use it for everything if it's available.  That
  116         # allows the module to handle A vs AAAA records on domain lookups where the
  117         # user hasn't set a specific ip version to be used.  If INET6 isn't available
  118         # and it's a domain that only has AAAA records, INET will just handle it like
  119         # a bogus record and we just won't be able to connect
  120         if (avail("ipv6")) {
  121             if ($G::link{force_ipv6}) {
  122                 push(@extra_options, "Domain", Socket::AF_INET6() );
  123             } elsif ($G::link{force_ipv4}) {
  124                 push(@extra_options, "Domain", Socket::AF_INET() );
  125             }
  126 
  127             $G::link{sock} = IO::Socket::INET6->new(
  128                 PeerAddr  => $G::link{server},
  129                 PeerPort  => $G::link{port},
  130                 Proto     => 'tcp',
  131                 Timeout   => $G::link{timeout},
  132                 @extra_options
  133             );
  134         } else {
  135             $G::link{sock} = IO::Socket::INET->new(
  136                 PeerAddr  => $G::link{server},
  137                 PeerPort  => $G::link{port},
  138                 Proto     => 'tcp',
  139                 Timeout   => $G::link{timeout},
  140                 @extra_options
  141             );
  142         }
  143 
  144         if ($@) {
  145             ptrans(12, "Error connecting" . ($G::link{lint} ? " $G::link{lint}" : '') .
  146                        " to $G::link{server}:$G::link{port}:\n\t$@");
  147             exit(2);
  148         }
  149         ptrans(11, "Connected to $G::link{server}.");
  150     } elsif ($G::link{type} eq 'socket-unix') {
  151         ptrans(11, 'Trying ' . $G::link{sockfile} . '...');
  152         $SIG{PIPE} = 'IGNORE';
  153         $@ = "";
  154         $G::link{sock} = IO::Socket::UNIX->new(Peer => $G::link{sockfile}, Timeout => $G::link{timeout});
  155 
  156         if ($@) {
  157             ptrans(12, 'Error connecting to ' . $G::link{sockfile} . ":\n\t$@");
  158             exit(2);
  159         }
  160         ptrans(11, 'Connected to ' . $G::link{sockfile} . '.');
  161     } elsif ($G::link{type} eq 'pipe') {
  162         $SIG{PIPE} = 'IGNORE';
  163         $SIG{CHLD} = 'IGNORE';
  164         ptrans(11, "Trying pipe to $G::link{process}...");
  165         eval{ open2($G::link{sock}{re}, $G::link{sock}{wr}, $G::link{process}); };
  166 
  167         if ($@) {
  168             ptrans(12, 'Error connecting to ' . $G::link{process} . ":\n\t$@");
  169             exit(2);
  170         }
  171         select((select($G::link{sock}{wr}), $| = 1)[0]);
  172         select((select($G::link{sock}{re}), $| = 1)[0]);
  173         ptrans(11, 'Connected to ' . $G::link{process} . '.');
  174     } else {
  175         ptrans(12, 'Unknown or unimplemented connection type ' . $G::link{type});
  176         exit(3);
  177     }
  178 }
  179 
  180 sub sendmail {
  181     my $from    = shift; # envelope-from
  182     my $to      = shift; # envelope-to
  183     my $helo    = shift; # who am I?
  184     my $data    = shift; # body of message (content after DATA command)
  185     my $a_user  = shift; # what user to auth with?
  186     my $a_pass  = shift; # what pass to auth with
  187     my $a_type  = shift; # what kind of auth (this must be set to to attempt)
  188     my $ehlo    = {};    # If server is esmtp, save advertised features here
  189 
  190     do_smtp_proxy() if ($G::proxy{try});
  191 
  192     # start up tls if -tlsc specified
  193     if ($G::tls_on_connect) {
  194         if (start_tls()) {
  195             tls_post_start();
  196             do_smtp_drop()     if ($G::drop_after eq 'tls');
  197             do_smtp_quit(1, 0) if ($G::quit_after eq 'tls');
  198         } else {
  199             ptrans(12, "TLS startup failed ($G::link{tls}{res})");
  200             exit(29);
  201         }
  202     }
  203 
  204     # read the server's 220 banner.
  205     do_smtp_gen(undef, '220') || do_smtp_quit(1, 21);
  206     do_smtp_drop()     if ($G::drop_after eq 'connect');
  207     do_smtp_quit(1, 0) if ($G::quit_after eq 'connect');
  208 
  209     # Send a HELO string
  210     $G::drop_before_read = 1 if ($G::drop_after_send eq 'first-helo');
  211     do_smtp_helo($helo, $ehlo, $G::protocol) || do_smtp_quit(1, 22);
  212     do_smtp_drop()     if ($G::drop_after eq 'first-helo');
  213     do_smtp_quit(1, 0) if ($G::quit_after eq 'first-helo');
  214 
  215     if ($G::xclient{before_tls}) {
  216         xclient_try($helo, $ehlo);
  217     }
  218 
  219     # handle TLS here if user has requested it
  220     if ($G::tls) {
  221         # 0 = tls succeeded
  222         # 1 = tls not advertised
  223         # 2 = tls advertised and attempted negotiations failed
  224         # note there's some duplicate logic here (with process_args) but I think
  225         # it's best to do as thorough a job covering the options in both places
  226         # so as to minimize chance of options falling through the cracks
  227         $G::drop_before_read = 1 if ($G::drop_after_send eq 'tls');
  228         my $result = do_smtp_tls($ehlo);
  229         if ($result == 1) {
  230             ptrans(12, "Host did not advertise STARTTLS");
  231             do_smtp_quit(1, 29) if (!$G::tls_optional);
  232         } elsif ($result == 2) {
  233             ptrans(12, "STARTTLS attempted but failed");
  234             exit(29) if ($G::tls_optional != 1);
  235         }
  236     } elsif ($G::tls_optional == 2 && $ehlo->{STARTTLS}) {
  237         ptrans(12, "TLS requested, advertised, and locally unavailable.  Exiting");
  238         do_smtp_quit(1, 29);
  239     }
  240     do_smtp_drop()     if ($G::drop_after eq 'tls');
  241     do_smtp_quit(1, 0) if ($G::quit_after eq 'tls');
  242 
  243     #if ($G::link{tls}{active} && $ehlo->{STARTTLS}) {
  244     if ($G::link{tls}{active} && !$G::tls_on_connect) {
  245         # According to RFC3207, we need to forget state info and re-EHLO here
  246         $ehlo = {};
  247         $G::drop_before_read = 1 if ($G::drop_after_send eq 'helo');
  248         do_smtp_helo($helo, $ehlo, $G::protocol) || do_smtp_quit(1, 32);
  249     }
  250     do_smtp_drop()     if ($G::drop_after_send eq 'helo'); # haaaack.  Need to use first-helo for this. Just quit here to prevent the mail from being delivered
  251     do_smtp_drop()     if ($G::drop_after eq 'helo');
  252     do_smtp_quit(1, 0) if ($G::quit_after eq 'helo');
  253 
  254     if (!$G::xclient{before_tls}) {
  255         xclient_try($helo, $ehlo);
  256     }
  257 
  258     # handle auth here if user has requested it
  259     if ($a_type) {
  260         # 0 = auth succeeded
  261         # 1 = auth not advertised
  262         # 2 = auth advertised but not attempted, no matching auth types
  263         # 3 = auth advertised but not attempted, auth not supported
  264         # 4 = auth advertised and attempted but no type succeeded
  265         # note there's some duplicate logic here (with process_args) but I think
  266         # it's best to do as thorough a job covering the options in both places
  267         # so as to minimize chance of options falling through the cracks
  268         $G::drop_before_read = 1 if ($G::drop_after_send eq 'auth');
  269         my $result = do_smtp_auth($ehlo, $a_type, $a_user, $a_pass);
  270         if ($result == 1) {
  271             ptrans(12, "Host did not advertise authentication");
  272             do_smtp_quit(1, 28) if (!$G::auth_optional);
  273         } elsif ($result == 2) {
  274             if ($G::auth_type eq 'ANY') {
  275                 ptrans(12, "Auth not attempted, no advertised types available");
  276                 do_smtp_quit(1, 28) if ($G::auth_optional != 1);
  277             } else {
  278                 ptrans(12, "Auth not attempted, requested type not available");
  279                 do_smtp_quit(1, 28) if (!$G::auth_optional);
  280             }
  281         } elsif ($result == 3) {
  282             ptrans(12, "Auth advertised but not supported locally");
  283             do_smtp_quit(1, 28) if ($G::auth_optional != 1);
  284         } elsif ($result == 4) {
  285             ptrans(12, "No authentication type succeeded");
  286             do_smtp_quit(1, 28) if ($G::auth_optional != 1);
  287         }
  288     } elsif ($G::auth_optional == 2 && $ehlo->{AUTH}) {
  289         ptrans(12, "Auth requested, advertised, and locally unavailable.  Exiting");
  290         do_smtp_quit(1, 28);
  291     }
  292     do_smtp_drop()     if ($G::drop_after eq 'auth');
  293     do_smtp_quit(1, 0) if ($G::quit_after eq 'auth');
  294 
  295     # send MAIL
  296     # 0 = mail succeeded
  297     # 1 = prdr required but not advertised
  298     $G::drop_before_read = 1 if ($G::drop_after_send eq 'mail');
  299     my $result = do_smtp_mail($ehlo, $from); # failures in this handled by smtp_mail_callback
  300     if ($result == 1) {
  301         ptrans(12, "Host did not advertise PRDR support");
  302         do_smtp_quit(1, 30);
  303     }
  304     do_smtp_drop()     if ($G::drop_after eq 'mail');
  305     do_smtp_quit(1, 0) if ($G::quit_after eq 'mail');
  306 
  307     # send RCPT (sub handles multiple, comma-delimited recips)
  308     $G::drop_before_read = 1 if ($G::drop_after_send eq 'rcpt');
  309     do_smtp_rcpt($to); # failures in this handled by smtp_rcpt_callback
  310                        # note that smtp_rcpt_callback increments
  311                        # $G::smtp_rcpt_failures at every failure.  This and
  312                        # $G::smtp_rcpt_total are used after DATA for LMTP
  313     do_smtp_drop()     if ($G::drop_after eq 'rcpt');
  314     do_smtp_quit(1, 0) if ($G::quit_after eq 'rcpt');
  315 
  316     # send DATA
  317     $G::drop_before_read = 1 if ($G::drop_after_send eq 'data');
  318     do_smtp_gen('DATA', '354') || do_smtp_quit(1, 25);
  319     do_smtp_drop() if ($G::drop_after eq 'data');
  320 
  321     # send the actual data
  322     $G::drop_before_read = 1 if ($G::drop_after_send eq 'dot');
  323     do_smtp_data($data, $G::suppress_data) || do_smtp_quit(1, 26);
  324     do_smtp_drop() if ($G::drop_after eq 'dot');
  325 
  326     # send QUIT
  327     do_smtp_quit(0) || do_smtp_quit(1, 27);
  328 }
  329 
  330 sub xclient_try {
  331     my $helo = shift;
  332     my $ehlo = shift;
  333 
  334     if ($G::xclient{try}) {
  335         # 0 - xclient succeeded normally
  336         # 1 - xclient not advertised
  337         # 2 - xclient advertised but not attempted, mismatch in requested attrs
  338         # 3 - xclient attempted but did not succeed
  339         $G::drop_before_read = 1 if ($G::drop_after_send eq 'xclient');
  340         my $result = do_smtp_xclient($ehlo);
  341         if ($result == 1) {
  342             ptrans(12, "Host did not advertise XCLIENT");
  343             do_smtp_quit(1, 33) if (!$G::xclient{optional});
  344         } elsif ($result == 2) {
  345             ptrans(12, "Host did not advertise requested XCLIENT attributes");
  346             do_smtp_quit(1, 33) if (!$G::xclient{optional});
  347         } elsif ($result == 3) {
  348             ptrans(12, "XCLIENT attempted but failed.  Exiting");
  349             do_smtp_quit(1, 33) if ($G::xclient{optional} != 1);
  350         } else {
  351             do_smtp_drop()     if ($G::drop_after eq 'xclient');
  352             do_smtp_quit(1, 0) if ($G::quit_after eq 'xclient');
  353 
  354             # re-helo if the XCLIENT command succeeded
  355             $G::drop_before_read = 1 if ($G::drop_after_send eq 'helo');
  356             do_smtp_helo($helo, $ehlo, $G::protocol) || do_smtp_quit(1, 34);
  357             do_smtp_drop()     if ($G::drop_after eq 'helo');
  358             do_smtp_quit(1, 0) if ($G::quit_after eq 'helo');
  359         }
  360     }
  361 }
  362 
  363 sub tls_post_start {
  364     ptrans(11, "TLS started with cipher $G::link{tls}{cipher_string}");
  365     if ($G::link{tls}{local_cert_subject}) {
  366         ptrans(11, "TLS local DN=\"$G::link{tls}{local_cert_subject}\"");
  367     } else {
  368         ptrans(11, "TLS no local certificate set");
  369     }
  370     ptrans(11, "TLS peer DN=\"$G::link{tls}{cert_subject}\"");
  371 
  372     if ($G::tls_get_peer_cert eq 'STDOUT') {
  373         ptrans(11, $G::link{tls}{cert_x509});
  374     } elsif ($G::tls_get_peer_cert) {
  375         open(CERT, ">$G::tls_get_peer_cert") ||
  376             ptrans(12, "Couldn't open $G::tls_get_peer_cert for writing: $!");
  377         print CERT $G::link{tls}{cert_x509}, "\n";
  378         close(CERT);
  379     }
  380 }
  381 
  382 sub start_tls {
  383     my %t         = (); # This is a convenience var to access $G::link{tls}{...}
  384     $G::link{tls} = \%t;
  385 
  386     Net::SSLeay::load_error_strings();
  387     Net::SSLeay::SSLeay_add_ssl_algorithms();
  388     Net::SSLeay::randomize();
  389     if (!($t{con} = Net::SSLeay::CTX_new())) {
  390         $t{res} = "CTX_new(): " . Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
  391         return(0);
  392     }
  393 
  394     my $ctx_options = &Net::SSLeay::OP_ALL;
  395     if (scalar(@G::tls_protocols)) {
  396         if ($G::tls_protocols[0] =~ /^no_/i) {
  397             foreach my $p (@G::tls_supported_protocols) {
  398                 if (grep /^no_$p$/i, @G::tls_protocols) {
  399                     no strict "refs";
  400                     $ctx_options |= &{"Net::SSLeay::OP_NO_$p"}();
  401                 }
  402             }
  403         } else {
  404             foreach my $p (@G::tls_supported_protocols) {
  405                 if (!grep /^$p$/i, @G::tls_protocols) {
  406                     no strict "refs";
  407                     $ctx_options |= &{"Net::SSLeay::OP_NO_$p"}();
  408                 }
  409             }
  410         }
  411     }
  412     Net::SSLeay::CTX_set_options($t{con}, $ctx_options);
  413     Net::SSLeay::CTX_set_verify($t{con}, 0x01, 0) if ($G::tls_verify);
  414 
  415     if ($G::tls_ca_path) {
  416         my @args = ('', $G::tls_ca_path);
  417         @args    = ($G::tls_ca_path, '') if (-f $G::tls_ca_path);
  418         if (!Net::SSLeay::CTX_load_verify_locations($t{con}, @args)) {
  419             $t{res} = "Unable to set set CA path to (" . join(',', @args) . "): "
  420                     . Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
  421             return(0);
  422         }
  423     } else {
  424         Net::SSLeay::CTX_set_default_verify_paths($t{con});
  425     }
  426 
  427     if ($G::tls_cipher) {
  428         if (!Net::SSLeay::CTX_set_cipher_list($t{con}, $G::tls_cipher)) {
  429             $t{res} = "Unable to set cipher list to $G::tls_cipher: "
  430                     . Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
  431             return(0);
  432         }
  433     }
  434     if ($G::tls_cert && $G::tls_key) {
  435         if (!Net::SSLeay::CTX_use_certificate_file($t{con}, $G::tls_cert, &Net::SSLeay::FILETYPE_PEM)) {
  436             $t{res} = "Unable to add cert file $G::tls_cert to SSL CTX: "
  437                     . Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
  438             return(0);
  439         }
  440         if (!Net::SSLeay::CTX_use_PrivateKey_file($t{con}, $G::tls_key, &Net::SSLeay::FILETYPE_PEM)) {
  441             $t{res} = "Unable to add key file $G::tls_key to SSL CTX: "
  442                     . Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
  443             return(0);
  444         }
  445     }
  446 
  447     if (!($t{ssl} = Net::SSLeay::new($t{con}))) {
  448         $t{res} = "new(): " . Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
  449         return(0);
  450     }
  451 
  452     if ($G::tls_sni_hostname) {
  453         if (!Net::SSLeay::set_tlsext_host_name($t{ssl}, $G::tls_sni_hostname)) {
  454             $t{res} = "Unable to set SNI hostname to $G::tls_sni_hostname: "
  455                     . Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
  456             return(0);
  457         }
  458     }
  459 
  460     if ($G::link{type} eq 'pipe') {
  461         Net::SSLeay::set_wfd($t{ssl}, fileno($G::link{sock}{wr})); # error check?
  462         Net::SSLeay::set_rfd($t{ssl}, fileno($G::link{sock}{re})); # error check?
  463     } else {
  464         Net::SSLeay::set_fd($t{ssl}, fileno($G::link{sock})); # error check?
  465     }
  466 
  467     $t{active} = Net::SSLeay::connect($t{ssl}) == 1 ? 1 : 0;
  468     if (!$t{active}) {
  469         $t{res} = "connect(): " . Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
  470         return(0);
  471     }
  472 
  473     # egrep 'define.*VERSION\b' *.h
  474     # when adding new types here, see also the code that pushes supported values onto tls_supported_protocols
  475     $t{version} = Net::SSLeay::version($t{ssl});
  476     if ($t{version} == 0x0002) {
  477         $t{version} = "SSLv2";    # openssl/ssl2.h
  478     } elsif ($t{version} == 0x0300) {
  479         $t{version} = "SSLv3";    # openssl/ssl3.h
  480     } elsif ($t{version} == 0x0301) {
  481         $t{version} = "TLSv1";    # openssl/tls1.h
  482     } elsif ($t{version} == 0x0302) {
  483         $t{version} = "TLSv1.1";  # openssl/tls1.h
  484     } elsif ($t{version} == 0x0303) {
  485         $t{version} = "TLSv1.2";  # openssl/tls1.h
  486     } elsif ($t{version} == 0x0304) {
  487         $t{version} = "TLSv1.3";  # openssl/tls1.h
  488     } elsif ($t{version} == 0xFEFF) {
  489         $t{version} = "DTLSv1";   # openssl/dtls1.h
  490     } elsif ($t{version} == 0xFEFD) {
  491         $t{version} = "DTLSv1.2"; # openssl/dtls1.h
  492     } else {
  493         $t{version} = sprintf("UNKNOWN(0x%04X)", $t{version});
  494     }
  495     $t{cipher}          = Net::SSLeay::get_cipher($t{ssl});
  496     if (!$t{cipher}) {
  497         $t{res} = "empty response from get_cipher()";
  498         return(0);
  499     }
  500     $t{cipher_bits}     = Net::SSLeay::get_cipher_bits($t{ssl}, undef);
  501     if (!$t{cipher_bits}) {
  502         $t{res} = "empty response from get_cipher_bits()";
  503         return(0);
  504     }
  505     $t{cipher_string}   = sprintf("%s:%s:%s", $t{version}, $t{cipher}, $t{cipher_bits});
  506     $t{cert}            = Net::SSLeay::get_peer_certificate($t{ssl});
  507     if (!$t{cert}) {
  508         $t{res} = "error response from get_peer_certificate()";
  509         return(0);
  510     }
  511     chomp($t{cert_x509} = Net::SSLeay::PEM_get_string_X509($t{cert}));
  512     $t{cert_subject}    = Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_subject_name($t{cert}));
  513 
  514     if ($G::tls_cert && $G::tls_key) {
  515         $t{local_cert}            = Net::SSLeay::get_certificate($t{ssl});
  516         chomp($t{local_cert_x509} = Net::SSLeay::PEM_get_string_X509($t{local_cert}));
  517         $t{local_cert_subject}    = Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_subject_name($t{local_cert}));
  518     }
  519 
  520     return($t{active});
  521 }
  522 
  523 sub deprecate {
  524     my $message = shift;
  525 
  526     ptrans(12, "DEPRECATION WARNING: $message");
  527 }
  528 
  529 sub ptrans {
  530     my $c = shift;  # transaction flag
  531     my $m = shift;  # message to print
  532     my $b = shift;  # be brief in what we print
  533     my $a = shift;  # return the message in an array ref instead of printing
  534     my $o = $G::trans_fh_oh || \*STDOUT;
  535     my $f = '';
  536 
  537     return if (($G::hide_send          && int($c/10) == 2)  ||
  538                ($G::hide_receive       && int($c/10) == 3)  ||
  539                ($G::hide_informational && $c         == 11) ||
  540                ($G::hide_all));
  541 
  542     # global option silent controls what we echo to the terminal
  543     # 0 - print everything
  544     # 1 - don't show anything until you hit an error, then show everything
  545     #     received after that (done by setting option to 0 on first error)
  546     # 2 - don't show anything but errors
  547     # >=3 - don't print anything
  548     if ($G::silent > 0) {
  549         return if ($G::silent >= 3);
  550         return if ($G::silent == 2 && $c%2 != 0);
  551         if ($G::silent == 1 && !$G::ptrans_seen_error) {
  552             if ($c%2 != 0) {
  553                 return();
  554             } else {
  555                 $G::ptrans_seen_error = 1;
  556             }
  557         }
  558     }
  559 
  560     # 1x is program messages
  561     # 2x is smtp send
  562     # 3x is smtp recv
  563     # x = 1 is info/normal
  564     # x = 2 is error
  565     # x = 3 dump output
  566     # program info
  567     if    ($c == 11) { $f = $G::no_hints_info ? '' : '==='; }
  568     # program error
  569     elsif ($c == 12) { $f = $G::no_hints_info ? '' : '***'; $o = $G::trans_fh_eh || \*STDERR; }
  570     # smtp send info
  571     elsif ($c == 21) { $f = $G::no_hints_send ? '' : ($G::link{tls}{active} ? ' ~>' : ' ->'); }
  572     # smtp send error
  573     elsif ($c == 22) { $f = $G::no_hints_send ? '' : ($G::link{tls}{active} ? '*~>' : '**>'); }
  574     # smtp send dump output
  575     elsif ($c == 23) { $f = $G::no_hints_send ? '' : '  >'; }
  576     # smtp recv info
  577     elsif ($c == 31) { $f = $G::no_hints_recv ? '' : ($G::link{tls}{active} ? '<~ ' : '<- '); }
  578     # smtp recv error
  579     elsif ($c == 32) { $f = $G::no_hints_recv ? '' : ($G::link{tls}{active} ? '<~*' : '<**'); }
  580     # smtp recv dump output
  581     elsif ($c == 33) { $f = $G::no_hints_recv ? '' : '<  '; }
  582     # something went unexpectedly
  583     else             { $f = '???'; }
  584 
  585     $f .= ' ' if ($f);
  586 
  587     if ($b) {
  588         # split to tmp list to prevent -w gripe
  589         my @t = split(/\n/ms, $m); $m = scalar(@t) . " lines sent";
  590     }
  591     $m =~ s/\n/\n$f/msg;
  592 
  593     if ($a) {
  594         $m = "$f$m";
  595         return([ split(/\n/, $m) ]);
  596     }
  597     else {
  598         print $o "$f$m\n";
  599     }
  600 }
  601 
  602 sub do_smtp_quit {
  603     my $exit = shift;
  604     my $err  = shift;
  605 
  606     # Ugh.  Because PIPELINING allows mail's and rcpt's send to be disconnected,
  607     # and possibly with a QUIT between them, we need to set a global "we have
  608     # told the server we quit already" flag to prevent double-quits
  609     return(1) if ($G::link{quit_sent});
  610     $G::link{quit_sent} = 1;
  611 
  612     $G::link{allow_lost_cxn} = 1;
  613     my $r = do_smtp_gen('QUIT', '221');
  614     $G::link{allow_lost_cxn} = 0;
  615 
  616     handle_disconnect($err) if ($G::link{lost_cxn});
  617 
  618     if ($exit) {
  619         teardown_link();
  620         exit $err;
  621     }
  622 
  623     return($r);
  624 }
  625 
  626 sub do_smtp_drop {
  627     ptrans(11, "Dropping connection");
  628     exit(0);
  629 }
  630 
  631 sub do_smtp_tls {
  632     my $e  = shift; # ehlo config hash
  633 
  634     # 0 = tls succeeded
  635     # 1 = tls not advertised
  636     # 2 = tls advertised and attempted negotiations failed
  637     if (!$e->{STARTTLS}) {
  638         return(1);
  639     } elsif (!do_smtp_gen("STARTTLS", '220')) {
  640         return(2);
  641     } elsif (!start_tls()) {
  642         ptrans(12, "TLS startup failed ($G::link{tls}{res})");
  643         return(2);
  644     }
  645     tls_post_start();
  646 
  647     return(0);
  648 }
  649 
  650 sub do_smtp_xclient {
  651     my $e = shift;
  652 
  653     # 0 - xclient succeeded normally
  654     # 1 - xclient not advertised
  655     # 2 - xclient advertised but not attempted, mismatch in requested attrs
  656     # 3 - xclient attempted but did not succeed
  657     if (!$e->{XCLIENT}) {
  658         return(1);
  659     }
  660     my @parts = ();
  661     foreach my $attr (keys %{$G::xclient{attr}}) {
  662         if (!$e->{XCLIENT}{$attr}) {
  663             return(2) if (!$G::xclient{no_verify});
  664         }
  665     }
  666 
  667     foreach my $string (@{$G::xclient{strings}}) {
  668         my $str = "XCLIENT " . $string;
  669         do_smtp_gen($str, '220') || return(3);
  670     }
  671     return(0);
  672 }
  673 
  674 # see xtext encoding in http://tools.ietf.org/html/rfc1891
  675 sub to_xtext {
  676     my $string = shift;
  677 
  678     return join('', map { ($_ == 0x2b || $_ == 0x3d || $_ <= 0x20 || $_ >= 0xff)
  679                            ? sprintf("+%02X", $_)
  680                            : chr($_)
  681                         } (unpack("C*", $string)));
  682 }
  683 
  684 sub do_smtp_auth {
  685     my $e  = shift; # ehlo config hash
  686     my $at = shift; # auth type
  687     my $au = shift; # auth user
  688     my $ap = shift; # auth password
  689 
  690     return(1) if (!$e->{AUTH});
  691     return(3) if ($G::auth_unavailable);
  692 
  693     my $auth_attempted = 0; # set to true if we ever attempt auth
  694 
  695     foreach my $btype (@$at) {
  696         # if server doesn't support, skip type (may change in future)
  697         next if (!$e->{AUTH}{$btype});
  698 
  699         foreach my $type (@{$G::auth_map_t{'CRAM-MD5'}}) {
  700             if ($btype eq $type) {
  701                 return(0) if (do_smtp_auth_cram($au, $ap, $type));
  702                 $auth_attempted = 1;
  703             }
  704         }
  705         foreach my $type (@{$G::auth_map_t{'CRAM-SHA1'}}) {
  706             if ($btype eq $type) {
  707                 return(0) if (do_smtp_auth_cram($au, $ap, $type));
  708                 $auth_attempted = 1;
  709             }
  710         }
  711         foreach my $type (@{$G::auth_map_t{'DIGEST-MD5'}}) {
  712             if ($btype eq $type) {
  713                 return(0) if (do_smtp_auth_digest($au, $ap, $type));
  714                 $auth_attempted = 1;
  715             }
  716         }
  717         foreach my $type (@{$G::auth_map_t{'NTLM'}}) {
  718             if ($btype eq $type) {
  719                 return(0) if (do_smtp_auth_ntlm($au, $ap, $type));
  720                 $auth_attempted = 1;
  721             }
  722         }
  723         foreach my $type (@{$G::auth_map_t{'PLAIN'}}) {
  724             if ($btype eq $type) {
  725                 return(0) if (do_smtp_auth_plain($au, $ap, $type));
  726                 $auth_attempted = 1;
  727             }
  728         }
  729         foreach my $type (@{$G::auth_map_t{'LOGIN'}}) {
  730             if ($btype eq $type) {
  731                 return(0) if (do_smtp_auth_login($au, $ap, $type));
  732                 $auth_attempted = 1;
  733             }
  734         }
  735     }
  736 
  737     return $auth_attempted ? 4 : 2;
  738 }
  739 
  740 sub do_smtp_auth_ntlm {
  741     my $u  = shift; # auth user
  742     my $p  = shift; # auth password
  743     my $as = shift; # auth type (since NTLM might be SPA or MSN)
  744     my $r  = '';    # will store smtp response
  745 
  746     my $auth_string = "AUTH $as";
  747     do_smtp_gen($auth_string, '334') || return(0);
  748 
  749     my $d = db64(Authen::NTLM::ntlm());
  750 
  751     $auth_string = eb64($d);
  752     do_smtp_gen($auth_string, '334', \$r, '',
  753                 $G::auth_showpt ? "$d" : '',
  754                 $G::auth_showpt ? \&unencode_smtp : '') || return(0);
  755 
  756     $r =~ s/^....//; # maybe something a little better here?
  757     Authen::NTLM::ntlm_domain($G::auth_extras{DOMAIN});
  758     Authen::NTLM::ntlm_user($u);
  759     Authen::NTLM::ntlm_password($p);
  760     $d = db64(Authen::NTLM::ntlm($r));
  761 
  762     $auth_string = eb64($d);
  763     do_smtp_gen($auth_string, '235', \$r, '', $G::auth_showpt ? "$d" : '') || return(0);
  764 
  765     return(1);
  766 }
  767 
  768 sub do_smtp_auth_digest {
  769     my $u  = shift; # auth user
  770     my $p  = shift; # auth password
  771     my $as = shift; # auth string
  772     my $r  = '';    # will store smtp response
  773     my $e  = '';    # will store Authen::SASL errors
  774     my @digest_uri = ();
  775 
  776     if (exists($G::auth_extras{"DMD5-SERV-TYPE"})) {
  777         $digest_uri[0] = $G::auth_extras{"DMD5-SERV-TYPE"};
  778     } else {
  779         $digest_uri[0] = 'smtp';
  780     }
  781     if (exists($G::auth_extras{"DMD5-HOST"})) {
  782         $digest_uri[1] = $G::auth_extras{"DMD5-HOST"};
  783     } else {
  784         if ($G::link{type} eq 'socket-unix') {
  785             $digest_uri[1] = $G::link{sockfile};
  786             $digest_uri[1] =~ s|[^a-zA-Z0-9\.\-]|-|g;
  787         } elsif ($G::link{type} eq 'pipe') {
  788             $digest_uri[1] = $G::link{process};
  789             $digest_uri[1] =~ s|[^a-zA-Z0-9\.\-]|-|g;
  790         } else {
  791             $digest_uri[1] = $G::link{server};
  792         }
  793     }
  794     if (exists($G::auth_extras{"DMD5-SERV-NAME"})) {
  795         # There seems to be a hole in the Authen::SASL interface where there's
  796         # no option to directory provide the digest-uri serv-name.  But we can
  797         # trick it into using the value we want by tacking it onto the end of host
  798         $digest_uri[1] .= '/' . $G::auth_extras{"DMD5-SERV-NAME"};
  799     }
  800 
  801     my $auth_string = "AUTH $as";
  802     do_smtp_gen($auth_string, '334', \$r, '', '', $G::auth_showpt ? \&unencode_smtp : '')
  803         || return(0);
  804 
  805     $r =~ s/^....//; # maybe something a little better here?
  806     $r = db64($r);
  807 
  808     my $callbacks = { user => $u, pass => $p };
  809     if (exists($G::auth_extras{REALM})) {
  810         $callbacks->{realm} = $G::auth_extras{REALM};
  811     }
  812 
  813     my $sasl = Authen::SASL->new(
  814         debug     => 1,
  815         mechanism => 'DIGEST-MD5',
  816         callback  => $callbacks,
  817     );
  818     my $sasl_client = $sasl->client_new(@digest_uri);
  819 
  820     # Force the DIGEST-MD5 session to use qop=auth.  I'm open to exposing this setting
  821     # via some swaks options, but I don't know enough about the protocol to just guess
  822     # here.  I do know that letting it auto-negotiate didn't work in my reference
  823     # environment.  sendmail advertised auth,auth-int,auth-conf, but when Authen::SASL
  824     # chose auth-int the session would fail (server would say auth succeeded, but then
  825     # immediately terminate my session when I sent MAIL).  My reference client
  826     # (Mulberry) always sent auth, and indeed forcing swaks to auth also seems to work.
  827     # If anyone out there knows more about this please let me know.
  828     $sasl_client->property('maxssf' => 0);
  829 
  830     $auth_string = $sasl_client->client_step($r);
  831     if ($e = $sasl_client->error()) {
  832         ptrans('12', "Error received from Authen::SASL sub-system: $e");
  833         return(0);
  834     }
  835 
  836     do_smtp_gen(eb64($auth_string), '334', \$r, '',
  837                      $G::auth_showpt ? "$auth_string" : '',
  838                      $G::auth_showpt ? \&unencode_smtp : '')
  839         || return(0);
  840     $r =~ s/^....//; # maybe something a little better here?
  841     $r = db64($r);
  842 
  843     $auth_string = $sasl_client->client_step($r);
  844     if ($e = $sasl_client->error()) {
  845         ptrans('12', "Canceling SASL exchange, error received from Authen::SASL sub-system: $e");
  846         $auth_string = '*';
  847     }
  848     #do_smtp_gen(eb64($auth_string), '235', \$r, '', $G::auth_showpt ? "$auth_string" : '')
  849     do_smtp_gen($auth_string, '235', \$r, '', $auth_string)
  850         || return(0);
  851     if ($e = $sasl_client->error()) {
  852         ptrans('12', "Error received from Authen::SASL sub-system: $e");
  853         return(0);
  854     }
  855     return(0) if (!$sasl_client->is_success());
  856 
  857     return(1);
  858 }
  859 
  860 # This can handle both CRAM-MD5 and CRAM-SHA1
  861 sub do_smtp_auth_cram {
  862     my $u  = shift; # auth user
  863     my $p  = shift; # auth password
  864     my $as = shift; # auth string
  865     my $r  = '';    # will store smtp response
  866 
  867     my $auth_string = "AUTH $as";
  868     do_smtp_gen($auth_string, '334', \$r, '', '', $G::auth_showpt ? \&unencode_smtp : '')
  869             || return(0);
  870 
  871     $r =~ s/^....//; # maybe something a little better here?
  872     # specify which type of digest we need based on $as
  873     my $d = get_digest($p, $r, ($as =~ /-SHA1$/ ? 'sha1' : 'md5'));
  874     $auth_string = eb64("$u $d");
  875 
  876     do_smtp_gen($auth_string, '235', undef, '', $G::auth_showpt ? "$u $d" : '') || return(0);
  877     return(1);
  878 }
  879 
  880 sub do_smtp_auth_login {
  881     my $u  = shift; # auth user
  882     my $p  = shift; # auth password
  883     my $as = shift; # auth string
  884 
  885     do_smtp_gen("AUTH $as", '334', undef, '', '', $G::auth_showpt ? \&unencode_smtp : '')
  886         || return(0);
  887     do_smtp_gen(eb64($u),   '334', undef, '', $G::auth_showpt ? $u : '', $G::auth_showpt ? \&unencode_smtp : '')
  888         || return(0);
  889     do_smtp_gen(eb64($p),   '235', undef, '',
  890                 $G::auth_showpt ? ($G::auth_hidepw || $p) : eb64($G::auth_hidepw || $p))
  891         || return(0);
  892     return(1);
  893 }
  894 
  895 sub do_smtp_auth_plain {
  896     my $u  = shift; # auth user
  897     my $p  = shift; # auth password
  898     my $as = shift; # auth string
  899 
  900     return(do_smtp_gen("AUTH $as " . eb64("\0$u\0$p"), '235', undef, '',
  901                        $G::auth_showpt ? "AUTH $as \\0$u\\0" . ($G::auth_hidepw || $p)
  902                        : "AUTH $as " . eb64("\0$u\0" . ($G::auth_hidepw || $p))));
  903 }
  904 
  905 sub do_smtp_helo {
  906     my $h = shift;  # helo string to use
  907     my $e = shift;  # this is a hashref that will be populated w/ server options
  908     my $p = shift;  # protocol for the transaction
  909     my $r = '';     # this'll be populated by do_smtp_gen
  910 
  911     if ($p eq 'esmtp' || $p eq 'lmtp') {
  912         my $l = $p eq 'lmtp' ? "LHLO" : "EHLO";
  913         if (do_smtp_gen("$l $h", '250', \$r)) {
  914             # There's not a standard structure for the $e hashref, each
  915             # key is stored in the manner that makes the most sense
  916             foreach my $l (split(/\n/, $r)) {
  917                 $l =~ s/^....//;
  918                 if ($l =~ /^AUTH=?(.*)$/) {
  919                     map { $e->{AUTH}{uc($_)} = 1 } (split(' ', $1));
  920                 } elsif ($l =~ /^XCLIENT\s*(.*?)$/) {
  921                     $e->{XCLIENT} = {}; # prime the pump in case no attributes were advertised
  922                     map { $e->{XCLIENT}{uc($_)} = 1 } (split(' ', $1));
  923                 } elsif ($l =~ /^STARTTLS$/) {
  924                     $e->{STARTTLS} = 1;
  925                 } elsif ($l =~ /^PIPELINING$/) {
  926                     $e->{PIPELINING} = 1;
  927                     $G::pipeline_adv = 1;
  928                 } elsif ($l =~ /^PRDR$/) {
  929                     $e->{PRDR} = 1;
  930                 }
  931             }
  932             return(1);
  933         }
  934     }
  935     if ($p eq 'esmtp' || $p eq 'smtp') {
  936         return(do_smtp_gen("HELO $h", '250'));
  937     }
  938 
  939     return(0);
  940 }
  941 
  942 sub do_smtp_mail {
  943     my $e = shift;  # ehlo response
  944     my $a = shift;  # from address
  945     my $m = "MAIL FROM:<$a>";
  946 
  947     if ($G::prdr) {
  948         if (!$e->{PRDR}) {
  949             return(1); # PRDR was required but was not advertised.  Return error and let caller handle it
  950         } else {
  951             $m .= " PRDR";
  952         }
  953     }
  954 
  955     transact(cxn_string => $m, expect => '250', defer => 1, fail_callback => \&smtp_mail_callback);
  956 
  957     return(0); # the callback handles failures, so just return here
  958 }
  959 
  960 # this only really needs to exist until I figure out a clever way of making
  961 # do_smtp_quit the callback while still preserving the exit codes
  962 sub smtp_mail_callback {
  963     do_smtp_quit(1, 23);
  964 }
  965 
  966 sub do_smtp_rcpt {
  967     my $m = shift;  # string of comma separated recipients
  968     my $f = 0;      # The number of failures we've experienced
  969     my @a = split(/,/, $m);
  970     $G::smtp_rcpt_total = scalar(@a);
  971 
  972     foreach my $addr (@a) {
  973         transact(cxn_string => 'RCPT TO:<' . $addr . '>', expect => '250', defer => 1,
  974                  fail_callback => \&smtp_rcpt_callback);
  975     }
  976 
  977     return(1); # the callback handles failures, so just return here
  978 }
  979 
  980 sub smtp_rcpt_callback {
  981     # record that a failure occurred
  982     $G::smtp_rcpt_failures++;
  983 
  984     # if the number of failures is the same as the total rcpts (if every rcpt rejected), quit.
  985     if ($G::smtp_rcpt_failures == $G::smtp_rcpt_total) {
  986         do_smtp_quit(1, 24);
  987     }
  988 }
  989 
  990 sub do_smtp_data {
  991     my $m = shift; # string to send
  992     my $b = shift; # be brief in the data we send
  993     my $r  = '';   # will store smtp response
  994     my $e = $G::prdr ? '(250|353)' : '250';
  995 
  996     my $calls = $G::smtp_rcpt_total - $G::smtp_rcpt_failures;
  997     my $ok    = transact(cxn_string => $m, expect => $e, summarize_output => $b, return_text => \$r);
  998 
  999     # now be a little messy - lmtp is not a lockstep after data - we need to
 1000     # listen for as many calls as we had accepted recipients
 1001     if ($G::protocol eq 'lmtp') {
 1002         foreach my $c (1..($calls-1)) { # -1 because we already got 1 above
 1003             $ok += transact(cxn_string => undef, expect => '250');
 1004         }
 1005     } elsif ($G::protocol eq 'esmtp' && $G::prdr && $r =~ /^353 /) {
 1006         foreach my $c (1..$calls) {
 1007             transact(cxn_string => undef, expect => '250'); # read the status of each recipient off the wire
 1008         }
 1009         $ok = transact(cxn_string => undef, expect => '250'); # PRDR has an overall acceptance string, read it here and use it as th success indicator
 1010     }
 1011     return($ok)
 1012 }
 1013 
 1014 sub do_smtp_gen {
 1015     my $m = shift; # string to send (if empty, we won't send anything, only read)
 1016     my $e = shift; # String we're expecting to get back
 1017     my $p = shift; # if this is a scalar ref, assign the server return string to it
 1018     my $b = shift; # be brief in the data we print
 1019     my $x = shift; # if this is populated, print this instead of $m
 1020     my $c = shift; # if this is a code ref, call it on the return value before printing it
 1021     my $n = shift; # if true, when the data is sent over the wire, it will not have \r\n appended to it
 1022     my $r = shift; # if true, we won't try to ready a response from the server
 1023 
 1024     return transact(cxn_string       => $m, expect           => $e, return_text    => $p,
 1025                     summarize_output => $b, show_string      => $x, print_callback => $c,
 1026                     no_newline       => $n, no_read_response => $r,
 1027                    );
 1028 }
 1029 
 1030 sub do_smtp_proxy {
 1031     my $send       = undef;
 1032     my $print      = undef;
 1033     my $no_newline = 0;
 1034 
 1035     if ($G::proxy{version} == 2) {
 1036         $send = pack("W[12]", 0x0D, 0x0A,0x0D, 0x0A, 0x00, 0x0D, 0x0A, 0x51, 0x55, 0x49, 0x54, 0x0A);
 1037         if ($G::proxy{raw}) {
 1038             $send .= $G::proxy{raw};
 1039         } else {
 1040             # byte 13
 1041             #    4 bits = version (required to be 0x2)
 1042             #    4 bits = command (0x2 = LOCAL, 0x1 = PROXY)
 1043             $send .= pack("W", 0x20 + ($G::proxy{attr}{command} eq 'LOCAL' ? 0x02 : 0x01));
 1044             if ($G::proxy{attr}{command} eq 'LOCAL') {
 1045                 # the protocol byte (14, including family and protocol) are ignored with local.  Set to zeros
 1046                 $send .= pack("W", 0x00);
 1047                 # and, additionally, if we're local, there isn't going to be any address size (bytes 15 and 16)
 1048                 $send .= pack("W", 0x00);
 1049             } else {
 1050                 # byte 14
 1051                 #    4 bits = address family (0x0 = AF_UNSPEC, 0x1 = AF_INET, 0x2 = AF_INET6, 0x3 = AF_UNIX)
 1052                 #    4 bits = transport protocol (0x0 = UNSPEC, 0x1 = STREAM, 0x2 = DGRAM)
 1053                 my $byte = 0;
 1054                 if ($G::proxy{attr}{family} eq 'AF_UNSPEC') {
 1055                     $byte = 0x00;
 1056                 } elsif ($G::proxy{attr}{family} eq 'AF_INET') {
 1057                     $byte = 0x10;
 1058                 } elsif ($G::proxy{attr}{family} eq 'AF_INET6') {
 1059                     $byte = 0x20;
 1060                 } elsif ($G::proxy{attr}{family} eq 'AF_UNIX') {
 1061                     $byte = 0x30;
 1062                 }
 1063                 if ($G::proxy{attr}{protocol} eq 'UNSPEC') {
 1064                     $byte += 0x0;
 1065                 } elsif ($G::proxy{attr}{protocol} eq 'STREAM') {
 1066                     $byte += 0x1;
 1067                 } elsif ($G::proxy{attr}{protocol} eq 'DGRAM') {
 1068                     $byte += 0x2;
 1069                 }
 1070                 $send .= pack("W", $byte);
 1071 
 1072                 # network portion (bytes 17+)
 1073                 my $net = pack_ip($G::proxy{attr}{source})
 1074                         . pack_ip($G::proxy{attr}{dest})
 1075                         . pack("n", $G::proxy{attr}{source_port})
 1076                         . pack("n", $G::proxy{attr}{dest_port});
 1077                 $send  .= pack("n", length($net)) . $net; # add bytes 15+16 (length of network portion) plus the network portion
 1078             }
 1079         }
 1080 
 1081         # version 2 is binary, so uuencode it before printing.  Also, version 2 REQUIREs that you not send \r\n after it down the wire
 1082         $print      = eb64($send);
 1083         $no_newline = 1;
 1084     } else {
 1085         if ($G::proxy{raw}) {
 1086             $send = "PROXY $G::proxy{raw}";
 1087         } else {
 1088             $send = join(' ', 'PROXY', $G::proxy{attr}{family}, $G::proxy{attr}{source}, $G::proxy{attr}{dest}, $G::proxy{attr}{source_port}, $G::proxy{attr}{dest_port});
 1089         }
 1090     }
 1091 
 1092     do_smtp_gen($send,       # to be send over the wire
 1093                 '220',       # response code indicating success
 1094                 undef,       # the return string from the server (don't need it)
 1095                 0,           # do not be brief when printing
 1096                 $print,      # if populated, print this instead of $send
 1097                 undef,       # don't want a post-processing callback
 1098                 $no_newline, # if true, don't add \r\n to the end of $send when sent over the wire
 1099                 1,           # don't read a response - we only want to send the value
 1100     );
 1101 }
 1102 
 1103 # no special attempt made at verifying, on purpose
 1104 sub pack_ip {
 1105     my $ip = shift;
 1106 
 1107     if ($ip =~ /:/) {
 1108         # this is the stupidest piece of code ever.  Please tell me all the fun ways it breaks
 1109         my @pieces = split(/:/, $ip);
 1110         my $p;
 1111         shift(@pieces) if ($pieces[0] eq '' && $pieces[1] eq ''); #
 1112         foreach my $word (@pieces) {
 1113             if ($word eq '') {
 1114                 foreach my $i (0..(8-scalar(@pieces))) {
 1115                     $p .= pack("n", 0);
 1116                 }
 1117             } else {
 1118                 $p .= pack("n", hex($word));
 1119             }
 1120         }
 1121         return($p);
 1122     } else {
 1123         return(pack("W*", split(/\./, $ip)));
 1124     }
 1125 }
 1126 
 1127 # If we detect that the other side has gone away when we were expecting
 1128 # to still be reading, come in here to error and die.  Abstracted because
 1129 # the error message will vary depending on the type of connection
 1130 sub handle_disconnect {
 1131     my $e = shift || 6; # this is the code we will exit with
 1132     if ($G::link{type} eq 'socket-inet') {
 1133         ptrans(12, "Remote host closed connection unexpectedly.");
 1134     } elsif ($G::link{type} eq 'socket-unix') {
 1135         ptrans(12, "Socket closed connection unexpectedly.");
 1136     } elsif ($G::link{type} eq 'pipe') {
 1137         ptrans(12, "Child process closed connection unexpectedly.");
 1138     }
 1139     exit($e);
 1140 }
 1141 
 1142 sub flush_send_buffer {
 1143     my $s = $G::link{type} eq 'pipe' ? $G::link{sock}->{wr} : $G::link{sock};
 1144     return if (!$G::send_buffer);
 1145     if ($G::link{tls}{active}) {
 1146         my $res = Net::SSLeay::write($G::link{tls}{ssl}, $G::send_buffer);
 1147     } else {
 1148         print $s $G::send_buffer;
 1149     }
 1150     ptrans(23, hdump($G::send_buffer)) if ($G::show_raw_text);
 1151     $G::send_buffer = '';
 1152 }
 1153 
 1154 sub send_data {
 1155     my $d   = shift;      # data to write
 1156     my $nnl = shift || 0; # if true, don't add a newline (needed for PROXY v2 support)
 1157     $G::send_buffer .= $d . ($nnl ? '' : "\r\n");
 1158 }
 1159 
 1160 sub recv_line {
 1161     # Either an IO::Socket obj or a FH to my child - the thing to read from
 1162     my $s = $G::link{type} eq 'pipe' ? $G::link{sock}->{re} : $G::link{sock};
 1163     my $r = undef;
 1164     my $t = undef;
 1165     my $c = 0;
 1166 
 1167     while ($G::recv_buffer !~ m|\n|si) {
 1168         last if (++$c > 1000); # Maybe I'll remove this once I trust this code more
 1169         if ($G::link{tls}{active}) {
 1170             $t = Net::SSLeay::read($G::link{tls}{ssl});
 1171             return($t) if (!defined($t));
 1172 
 1173             # THIS CODE COPIED FROM THE ELSE BELOW.  Found I could trip this condition
 1174             # by having the server sever the connection but not have swaks realize the
 1175             # connection was gone.  For instance, send a PIPELINE mail that includes a
 1176             # "-q rcpt".  There was a bug in swaks that made it try to send another quit
 1177             # later, thus tripping this "1000 reads" error (but only in TLS).
 1178             # Short term: add line below to prevent these reads
 1179             # Short Term: fix the "double-quit" bug
 1180             # Longer term: test to see if remote side closed connection
 1181 
 1182             # the above line should be good enough but it isn't returning
 1183             # undef for some reason.  I think heuristically it will be sufficient
 1184             # to just look for an empty packet (I hope.  gulp).  Comment out the
 1185             # following line if your swaks seems to be saying that it lost connection
 1186             # for no good reason.  Then email me about it.
 1187             return(undef()) if (!length($t));
 1188         } elsif ($G::link{type} eq 'pipe') {
 1189             # XXX in a future release see if I can get read() or equiv to work on a pipe
 1190             $t = <$s>;
 1191             return($t) if (!defined($t));
 1192 
 1193             # THIS CODE COPIED FROM THE ELSE BELOW.
 1194             # the above line should be good enough but it isn't returning
 1195             # undef for some reason.  I think heuristically it will be sufficient
 1196             # to just look for an empty packet (I hope.  gulp).  Comment out the
 1197             # following line if your swaks seems to be saying that it lost connection
 1198             # for no good reason.  Then email me about it.
 1199             return(undef()) if (!length($t));
 1200         } else {
 1201             # if you're having problems with reads, swap the comments on the
 1202             # the following two lines
 1203             my $recv_r = recv($s, $t, 8192, 0);
 1204             #$t = <$s>;
 1205             return($t) if (!defined($t));
 1206 
 1207             # the above line should be good enough but it isn't returning
 1208             # undef for some reason.  I think heuristically it will be sufficient
 1209             # to just look for an empty packet (I hope.  gulp).  Comment out the
 1210             # following line if your swaks seems to be saying that it lost connection
 1211             # for no good reason.  Then email me about it.
 1212             return(undef()) if (!length($t));
 1213 
 1214             #print "\$t = $t (defined = ", defined($t) ? "yes" : "no",
 1215             #      "), \$recv_r = $recv_r (", defined($recv_r) ? "yes" : "no", ")\n";
 1216         }
 1217         $G::recv_buffer .= $t;
 1218         ptrans(33, hdump($t)) if ($G::show_raw_text);
 1219     }
 1220 
 1221     if ($c >= 1000) {
 1222         # If you saw this in the wild, I'd love to hear more about it
 1223         # at proj-swaks@jetmore.net
 1224         ptrans(12, "In recv_line, hit loop counter.  Continuing in unknown state");
 1225     }
 1226 
 1227     # using only bare newlines is bound to cause me problems in the future
 1228     # but it matches the expectation we've already been using.  All we can
 1229     # do is hone in on the proper behavior iteratively.
 1230     if ($G::recv_buffer =~ s|^(.*?\n)||si) {
 1231         $r = $1;
 1232     } else {
 1233         ptrans(12, "I'm in an impossible state");
 1234     }
 1235 
 1236     $r =~ s|\r||msg;
 1237     return($r);
 1238 }
 1239 
 1240 # any request which has immediate set will be checking the return code.
 1241 # any non-immediate request will handle results through fail_callback().
 1242 # therefore, only return the state of the last transaction attempted,
 1243 # which will always be immediate
 1244 # defer            - if true, does not require immediate flush when pipelining
 1245 # cxn_string       - What we will be sending the server. If undefined, we won't send, only read
 1246 # no_read_response - if true, we won't read a response from the server, we'll just send
 1247 # summarize_output - if true, don't print to terminal everything we send to server
 1248 # no_newline       - if true, do not append \r\n to the data we send to server
 1249 # return_text      - should be scalar ref.  will be assigned reference to what was returned from server
 1250 # print_callback   - if present and a code reference, will be called with server return data for printing to terminal
 1251 # fail_callback    - if present and a code reference, will be called on failure
 1252 sub transact {
 1253     my %h        = @_; # this is an smtp transaction element
 1254     my $ret      = 1;  # this is our return value
 1255     my @handlers = (); # will hold any fail_handlers we need to run
 1256     my $time     = ''; # used in time lapse calculations
 1257 
 1258     push(@G::pending_send, \%h); # push onto send queue
 1259     if (!($G::pipeline && $G::pipeline_adv) || !$h{defer}) {
 1260 
 1261         if ($G::show_time_lapse eq 'hires') {
 1262             $time = [Time::HiRes::gettimeofday()];
 1263         }
 1264         elsif ($G::show_time_lapse eq 'integer') {
 1265             $time = time();
 1266         }
 1267 
 1268         while (my $i = shift(@G::pending_send)) {
 1269             if (defined($i->{cxn_string})) {
 1270                 ptrans(21, $i->{show_string} || $i->{cxn_string}, $i->{summarize_output});
 1271                 send_data($i->{cxn_string}, $i->{no_newline});
 1272             }
 1273             push(@G::pending_recv, $i) if (!$i->{no_read_response});
 1274         }
 1275         flush_send_buffer();
 1276 
 1277         do_smtp_drop() if ($G::drop_before_read);
 1278 
 1279         while (my $i = shift(@G::pending_recv)) {
 1280             my $buff = '';
 1281             eval {
 1282                 local $SIG{'ALRM'} = sub {
 1283                     $buff = "Timeout ($G::link{timeout} secs) waiting for server response";
 1284                     die;
 1285                 };
 1286                 alarm($G::link{timeout});
 1287                 while ($buff !~ /^\d\d\d /m) {
 1288                     my $l = recv_line();
 1289                     $buff .= $l;
 1290                     if (!defined($l)) {
 1291                         $G::link{lost_cxn} = 1;
 1292                         last;
 1293                     }
 1294                 }
 1295                 chomp($buff);
 1296                 alarm(0);
 1297             };
 1298 
 1299             if ($G::show_time_lapse eq 'hires') {
 1300                 $time = sprintf("%0.03f", Time::HiRes::tv_interval($time, [Time::HiRes::gettimeofday()]));
 1301                 ptrans(11, "response in ${time}s");
 1302                 $time = [Time::HiRes::gettimeofday()];
 1303             } elsif ($G::show_time_lapse eq 'integer') {
 1304                 $time = time() - $time;
 1305                 ptrans(11, "response in ${time}s");
 1306                 $time = time();
 1307             }
 1308 
 1309             ${$i->{return_text}} = $buff;
 1310             $buff = &{$i->{print_callback}}($buff) if (ref($i->{print_callback}) eq 'CODE');
 1311             my $ptc;
 1312             ($ret,$ptc) = $buff !~ /^$i->{expect} /m ? (0,32) : (1,31);
 1313             ptrans($ptc, $buff) if ($buff);
 1314             if ($G::link{lost_cxn}) {
 1315                 if ($G::link{allow_lost_cxn}) {
 1316                     # this means the calling code wants to handle a lost cxn itself
 1317                     return($ret);
 1318                 } else {
 1319                     # if caller didn't want to handle, we'll handle a lost cxn ourselves
 1320                     handle_disconnect();
 1321                 }
 1322             }
 1323             if (!$ret && ref($i->{fail_callback}) eq 'CODE') {
 1324                 push(@handlers, $i->{fail_callback});
 1325             }
 1326         }
 1327     }
 1328     foreach my $h (@handlers) { &{$h}(); }
 1329     return($ret);
 1330 }
 1331 
 1332 # a quick-and-dirty hex dumper.  Currently used by --show-raw-text
 1333 sub hdump {
 1334     my $r = shift;
 1335     my $c = 0;  # counter
 1336     my $i = 16; # increment value
 1337     my $b;      # buffer
 1338 
 1339     while (length($r) && ($r =~ s|^(.{1,$i})||smi)) {
 1340         my $s = $1; # $s will be the ascii string we manipulate for display
 1341         my @c = map { ord($_); } (split('', $s));
 1342         $s =~ s|[^\x21-\x7E]|.|g;
 1343 
 1344         my $hfs = ''; # This is the hex format string for printf
 1345         for (my $hc = 0; $hc < $i; $hc++) {
 1346             $hfs .= ' ' if (!($hc%4));
 1347             if ($hc < scalar(@c)) { $hfs .= '%02X '; } else { $hfs .= '   '; }
 1348         }
 1349 
 1350         $b .= sprintf("%04d:$hfs   %-16s\n", $c, @c, $s);
 1351         $c += $i;
 1352     }
 1353     chomp($b); # inelegant remnant of hdump's previous life
 1354     return($b)
 1355 }
 1356 
 1357 sub unencode_smtp {
 1358     my $t = shift;
 1359 
 1360     my @t = split(' ', $t, 2);
 1361     if ($t[1] =~ /\s/) {
 1362         # very occasionally we can have a situation where a successful response will
 1363         # be b64 encoded, while an error will not be.  Try to tell the difference.
 1364         return($t);
 1365     } else {
 1366         return("$t[0] " . db64($t[1]));
 1367     }
 1368 }
 1369 
 1370 sub obtain_from_netrc {
 1371     my $field = shift;
 1372     my $login = shift;
 1373 
 1374     return if !avail('netrc');
 1375 
 1376     if (my $netrc = Net::Netrc->lookup($G::link{server}, defined($login) ? $login : ())) {
 1377         return($netrc->$field);
 1378     }
 1379 
 1380     return;
 1381 }
 1382 
 1383 sub interact {
 1384     my $prompt     = shift;
 1385     my $regexp     = shift;
 1386     my $hide_input = shift;
 1387     my $response   = '';
 1388 
 1389     do {
 1390         print $prompt;
 1391         if (!$hide_input || !$G::protect_prompt || $G::interact_method eq 'default') {
 1392             chomp($response = <STDIN>);
 1393         } else {
 1394             if ($^O eq 'MSWin32') {
 1395                 #if ($G::interact_method eq "win32-console" ||
 1396                 #   (!$G::interact_method && load("Win32::Console")))
 1397                 #{
 1398                 #    Couldn't get this working in the time I wanted to devote to it
 1399                 #}
 1400                 if ($G::interact_method eq "win32-readkey" ||
 1401                      (!$G::interact_method && load("Term::ReadKey")))
 1402                 {
 1403                     $G::interact_method ||= "win32-readkey";
 1404                     # the trick to replace input w/ '*' doesn't work on Win32
 1405                     # Term::ReadKey, so just use it as an stty replacement
 1406                     ReadMode('noecho');
 1407                     # need to think about this on windows some more
 1408                     #local $SIG{INT} = sub { ReadMode('restore'); };
 1409                     chomp($response = <STDIN>);
 1410                     ReadMode('restore');
 1411                     print "\n";
 1412                 } else {
 1413                     $G::interact_method ||= "default";
 1414                     chomp($response = <STDIN>);
 1415                 }
 1416             } else {
 1417                 if ($G::interact_method eq "unix-readkey" || (!$G::interact_method && load("Term::ReadKey"))) {
 1418                     $G::interact_method ||= "unix-readkey";
 1419                     my @resp = ();
 1420                     ReadMode('raw');
 1421                     #local $SIG{INT} =
 1422                     # reevaluate this code - what happens if del is first char we press?
 1423                     while ((my $kp = ReadKey(0)) ne "\n") {
 1424                         my $kp_num = ord($kp);
 1425                         if($kp_num == 127 || $kp_num == 8) {
 1426                             next if (!scalar(@resp));
 1427                             pop(@resp);
 1428                             print "\b \b";
 1429                         } elsif($kp_num >= 32) {
 1430                             push(@resp, $kp);
 1431                             print "*";
 1432                         }
 1433                     }
 1434                     ReadMode('restore');
 1435                     print "\n";
 1436                     $response = join('', @resp);
 1437                 } elsif ($G::interact_method eq "unix-stty" || (!$G::interact_method && open(STTY, "stty -a |"))) {
 1438                     $G::interact_method ||= "unix-stty";
 1439                     { my $foo = join('', <STTY>); }
 1440                     system('stty', '-echo');
 1441                     chomp($response = <STDIN>);
 1442                     system('stty', 'echo');
 1443                     print "\n";
 1444                 } else {
 1445                     $G::interact_method ||= "default";
 1446                     chomp($response = <STDIN>);
 1447                 }
 1448             }
 1449         }
 1450     } while ($regexp ne 'SKIP' && $response !~ /$regexp/);
 1451 
 1452     return($response);
 1453 }
 1454 
 1455 sub get_messageid {
 1456     if (!$G::message_id) {
 1457         my @time = localtime();
 1458         $G::message_id = sprintf("%04d%02d%02d%02d%02d%02d.%06d\@%s",
 1459                                  $time[5]+1900, $time[4]+1, $time[3], $time[2], $time[1], $time[0],
 1460                                  $$, get_hostname());
 1461     }
 1462 
 1463     return($G::message_id);
 1464 }
 1465 
 1466 sub get_hostname {
 1467     # in some cases hostname returns value but gethostbyname doesn't.
 1468     return("") if (!avail("hostname"));
 1469 
 1470     my $h = hostname();
 1471     return("") if (!$h);
 1472 
 1473     my $l = (gethostbyname($h))[0];
 1474     return($l || $h);
 1475 }
 1476 
 1477 sub get_server {
 1478     my $addr   = shift;
 1479     my $pref   = -1;
 1480     my $server = "localhost";
 1481 
 1482     if ($addr =~ /\@?\[(\d+\.\d+\.\d+\.\d+)\]$/) {
 1483         # handle automatic routing of domain literals (user@[1.2.3.4])
 1484         return($1);
 1485     } elsif ($addr =~ /\@?\#(\d+)$/) {
 1486         # handle automatic routing of decimal domain literals (user@#16909060)
 1487         $addr = $1;
 1488         return(($addr/(2**24))%(2**8) . '.' . ($addr/(2**16))%(2**8) . '.' .
 1489                ($addr/(2**8))%(2**8)  . '.' . ($addr/(2**0))%(2**8));
 1490     }
 1491 
 1492     if (!avail("dns")) {
 1493         ptrans(12, avail_str("dns"). ".  Using $server as mail server");
 1494         return($server);
 1495     }
 1496     my $res = Net::DNS::Resolver->new();
 1497 
 1498     $addr =~ s/^.*\@([^\@]*)$/$1/;
 1499     return($server) if (!$addr);
 1500     $server = $addr;
 1501 
 1502     my @mx = mx($res, $addr);
 1503     foreach my $rr (sort { $a->preference <=> $b->preference } @mx) {
 1504         if ($G::link{force_ipv4}) {
 1505             if ($res->query($rr->exchange, 'A')) {
 1506                 $server = $rr->exchange;
 1507                 last;
 1508             }
 1509         } elsif ($G::link{force_ipv6}) {
 1510             if ($res->query($rr->exchange, 'AAAA') || $res->query($rr->exchange, 'A6')) {
 1511                 $server = $rr->exchange;
 1512                 last;
 1513             }
 1514         } else {
 1515             # this is the old default behavior.  Take the best priority MX, no matter what.
 1516             $server = $rr->exchange;
 1517             last;
 1518         }
 1519     }
 1520     return($server);
 1521 }
 1522 
 1523 sub load {
 1524     my $m = shift;
 1525 
 1526     return $G::modules{$m} if (exists($G::modules{$m}));
 1527     eval("use $m");
 1528     return $G::modules{$m} = $@ ? 0 : 1;
 1529 }
 1530 
 1531 # Currently this is just an informational string - it's set on both
 1532 # success and failure.  It currently has four output formats (supported,
 1533 # supported but not optimal, unsupported, unsupported and missing optimal)
 1534 sub avail_str { return $G::dependencies{$_[0]}{errstr}; }
 1535 
 1536 sub avail {
 1537     my $f = shift; # this is the feature we want to check support for (auth, tls)
 1538     my $s = \%G::dependencies;
 1539 
 1540     # return immediately if we've already tested this.
 1541     return($s->{$f}{avail}) if (exists($s->{$f}{avail}));
 1542 
 1543     $s->{$f}{req_failed} = [];
 1544     $s->{$f}{opt_failed} = [];
 1545     foreach my $m (@{$s->{$f}{req}}) {
 1546         push(@{$s->{$f}{req_failed}}, $m) if (!load($m));
 1547     }
 1548     foreach my $m (@{$s->{$f}{opt}}) {
 1549         push(@{$s->{$f}{opt_failed}}, $m) if (!load($m));
 1550     }
 1551 
 1552     if (scalar(@{$s->{$f}{req_failed}})) {
 1553         $s->{$f}{errstr} = "$s->{$f}{name} not available: requires " . join(', ', @{$s->{$f}{req_failed}});
 1554         if (scalar(@{$s->{$f}{opt_failed}})) {
 1555             $s->{$f}{errstr} .= ".  Also missing optimizing " . join(', ', @{$s->{$f}{opt_failed}});
 1556         }
 1557         return $s->{$f}{avail} = 0;
 1558     } else {
 1559         if (scalar(@{$s->{$f}{opt_failed}})) {
 1560             $s->{$f}{errstr} = "$s->{$f}{name} supported, but missing optimizing " .
 1561                                join(', ', @{$s->{$f}{opt_failed}});
 1562         } else {
 1563             $s->{$f}{errstr} = "$s->{$f}{name} supported";
 1564         }
 1565         return $s->{$f}{avail} = 1;
 1566     }
 1567 }
 1568 
 1569 sub get_digest {
 1570     my $secr = shift;
 1571     my $chal = shift;
 1572     my $type = shift || 'md5';
 1573     my $ipad = chr(0x36) x 64;
 1574     my $opad = chr(0x5c) x 64;
 1575 
 1576     if ($chal !~ /^</) {
 1577         chomp($chal = db64($chal));
 1578     }
 1579 
 1580     if (length($secr) > 64) {
 1581         if ($type eq 'md5') {
 1582             $secr = Digest::MD5::md5($secr);
 1583         } elsif ($type eq 'sha1') {
 1584             $secr = Digest::SHA::sha1($secr);
 1585         }
 1586     } else {
 1587         $secr .= chr(0) x (64 - length($secr));
 1588     }
 1589 
 1590     my $digest = $type eq 'md5' ? Digest::MD5::md5_hex(($secr ^ $opad), Digest::MD5::md5(($secr ^ $ipad), $chal))
 1591                                 : Digest::SHA::sha1_hex(($secr ^ $opad), Digest::SHA::sha1(($secr ^ $ipad), $chal));
 1592     return($digest);
 1593 }
 1594 
 1595 sub test_support {
 1596     my $return = shift;
 1597     my $lines  = [];
 1598     my $s      = \%G::dependencies;
 1599 
 1600     foreach my $act (sort { $s->{$a}{name} cmp $s->{$b}{name} } keys %$s) {
 1601         if ($return) {
 1602             push(@$lines, @{ptrans(avail($act) ? 11 : 12, avail_str($act), undef, 1)});
 1603         }
 1604         else {
 1605             ptrans(avail($act) ? 11 : 12, avail_str($act));
 1606         }
 1607     }
 1608 
 1609     if ($return) {
 1610         return($lines);
 1611     }
 1612 }
 1613 
 1614 sub time_to_seconds {
 1615     my $t = shift;
 1616 
 1617     if ($t !~ /^(\d+)([hms])?$/i) {
 1618         ptrans(12, 'Unknown timeout format \'' . $t . '\'');
 1619         exit(1);
 1620     } else {
 1621         my $r = $1;
 1622         my $u = lc($2);
 1623         if ($u eq 'h') {
 1624             return($r * 3600);
 1625         } elsif ($u eq 'm') {
 1626             return($r * 60);
 1627         } else {
 1628             return($r);
 1629         }
 1630     }
 1631 }
 1632 
 1633 sub load_dependencies {
 1634     %G::dependencies = (
 1635         auth            => { name => "Basic AUTH",               opt => ['MIME::Base64'],
 1636                                                                  req => []                    },
 1637         auth_cram_md5   => { name => "AUTH CRAM-MD5",            req => ['Digest::MD5']       },
 1638         auth_cram_sha1  => { name => "AUTH CRAM-SHA1",           req => ['Digest::SHA']       },
 1639         auth_ntlm       => { name => "AUTH NTLM",                req => ['Authen::NTLM']      },
 1640         auth_digest_md5 => { name => "AUTH DIGEST-MD5",          req => ['Authen::SASL']      },
 1641         dns             => { name => "MX Routing",               req => ['Net::DNS']          },
 1642         netrc           => { name => 'Netrc Credentials',        req => ['Net::Netrc']        },
 1643         tls             => { name => "TLS",                      req => ['Net::SSLeay']       },
 1644         pipe            => { name => "Pipe Transport",           req => ['IPC::Open2']        },
 1645         socket          => { name => "Socket Transport",         req => ['IO::Socket']        },
 1646         ipv6            => { name => "IPv6",                     req => ['IO::Socket::INET6'] },
 1647         date_manip      => { name => "Date Manipulation",        req => ['POSIX']             },
 1648         hostname        => { name => "Local Hostname Detection", req => ['Sys::Hostname']     },
 1649         hires_timing    => { name => "High Resolution Timing",   req => ['Time::HiRes']       },
 1650     );
 1651 }
 1652 
 1653 sub process_opt_silent {
 1654     my $opt = shift;
 1655     my $arg = shift;
 1656 
 1657     if ($arg =~ /^[123]$/) {
 1658         return($arg);
 1659     }
 1660     else {
 1661         return(1);
 1662     }
 1663 }
 1664 
 1665 sub get_option_struct {
 1666     use constant {
 1667         OP_ARG_OPT     => 0x01, # option takes an optional argument
 1668         OP_ARG_REQ     => 0x02, # option takes a required argument
 1669         OP_ARG_NONE    => 0x04, # option does not take any argument (will return boolean)
 1670         OP_FROM_PROMPT => 0x08, # option prompts for an argument if none provided
 1671         OP_FROM_FILE   => 0x10, # option treats arg of '-' to mean 'read from stdin' (no prompt)
 1672         OP_DEPRECATED  => 0x20, # This option is deprecated
 1673         OP_SENSITIVE   => 0x40, # indicates that if prompted for, the argument should be masked (see --protect-prompt)
 1674     };
 1675 
 1676     @G::raw_option_data = (
 1677         # location of config file.  Note that the "config" option is processed differently
 1678         # than any other option because it needs to be processed before standard option processing
 1679         # can happen.  We still define it here to make Getopt::Long and fetch_args() happy.
 1680         { opts    => ['config'],                                           suffix => ':s',
 1681           cfgs    => OP_ARG_OPT,
 1682           okey    => 'config_file',                                        type   => 'scalar', },
 1683         # envelope-(f)rom address
 1684         { opts    => ['from', 'f'],                                        suffix => ':s',
 1685           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 1686           prompt  => 'From: ',                                             match  => '^.*$',
 1687           okey    => 'mail_from',                                          type   => 'scalar', },
 1688         # envelope-(t)o address
 1689         { opts    => ['to', 't'],                                          suffix => ':s',
 1690           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 1691           prompt  => 'To: ',                                               match  => '^.+$',
 1692           okey    => 'mail_to',                                            type   => 'scalar', },
 1693         # (h)elo string
 1694         { opts    => ['helo', 'ehlo', 'lhlo', 'h'],                        suffix => ':s',
 1695           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 1696           prompt  => 'Helo: ',                                             match  => '^.*$',
 1697           okey    => 'mail_helo',                                          type   => 'scalar', },
 1698         # (s)erver to use
 1699         { opts    => ['server', 's'],                                      suffix => ':s',
 1700           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 1701           prompt  => 'Server: ',                                           match  => '^.*$',
 1702           okey    => 'mail_server',                                        type   => 'scalar', },
 1703         # force ipv4 only
 1704         { opts    => ['4'],                                                suffix => '',
 1705           cfgs    => OP_ARG_NONE,
 1706           okey    => 'force_ipv4',                                         type   => 'scalar', },
 1707         # force ipv6 only
 1708         { opts    => ['6'],                                                suffix => '',
 1709           cfgs    => OP_ARG_NONE,
 1710           okey    => 'force_ipv6',                                         type   => 'scalar', },
 1711         # copy MX/routing from another domain
 1712         { opts    => ['copy-routing'],                                     suffix => ':s',
 1713           cfgs    => OP_ARG_REQ,
 1714           okey    => 'copy_routing',                                       type   => 'scalar', },
 1715         # (p)ort to use
 1716         { opts    => ['port', 'p'],                                        suffix => ':s',
 1717           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 1718           prompt  => 'Port: ',                                             match  => '^\w+$',
 1719           okey    => 'mail_port',                                          type   => 'scalar', },
 1720         # protocol to use (smtp, esmtp, lmtp)
 1721         { opts    => ['protocol'],                                         suffix => '=s',
 1722           cfgs    => OP_ARG_REQ,
 1723           okey    => 'mail_protocol',                                      type   => 'scalar', },
 1724         # (d)ata portion ('\n' for newlines)
 1725         { opts    => ['data', 'd'],                                        suffix => ':s',
 1726           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT|OP_FROM_FILE,
 1727           prompt  => 'Data: ',                                             match  => '^.*$',
 1728           okey    => 'mail_data',                                          type   => 'scalar', },
 1729         # use the --dump text as default body
 1730         { opts    => ['dump-as-body', 'dab'],                              suffix => ':s',
 1731           cfgs    => OP_ARG_OPT,
 1732           okey    => 'dump_as_body',                                       type   => 'scalar', },
 1733         # implies --dump-as-body; forces raw passwords to be used
 1734         { opts    => ['dump-as-body-shows-password', 'dabsp'],             suffix => '',
 1735           cfgs    => OP_ARG_NONE,
 1736           okey    => 'dab_sp',                                             type   => 'scalar', },
 1737         # timeout for each trans (def 30s)
 1738         { opts    => ['timeout'],                                          suffix => ':s',
 1739           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 1740           prompt  => 'Timeout: ',                                          match  => '^\d+[hHmMsS]?$',
 1741           okey    => 'timeout',                                            type   => 'scalar', },
 1742         # (q)uit after
 1743         { opts    => ['quit-after', 'quit', 'q'],                          suffix => '=s',
 1744           cfgs    => OP_ARG_REQ,
 1745           okey    => 'quit_after',                                         type   => 'scalar', },
 1746         # drop after (don't quit, just drop)
 1747         { opts    => ['drop-after', 'drop', 'da'],                         suffix => '=s',
 1748           cfgs    => OP_ARG_REQ,
 1749           okey    => 'drop_after',                                         type   => 'scalar', },
 1750         # drop after send (between send and read)
 1751         { opts    => ['drop-after-send', 'das'],                           suffix => '=s',
 1752           cfgs    => OP_ARG_REQ,
 1753           okey    => 'drop_after_send',                                    type   => 'scalar', },
 1754         # do (n)ot print data portion
 1755         { opts    => ['suppress-data', 'n'],                               suffix => '',
 1756           cfgs    => OP_ARG_NONE,
 1757           okey    => 'suppress_data',                                      type   => 'scalar', },
 1758         # force auth, exit if not supported
 1759         { opts    => ['auth', 'a'],                                        suffix => ':s',
 1760           cfgs    => OP_ARG_OPT,
 1761           okey    => 'auth',                                               type   => 'scalar', },
 1762         # user for auth
 1763         { opts    => ['auth-user', 'au'],                                  suffix => ':s',
 1764           cfgs    => OP_ARG_OPT, # we dynamically change this later
 1765           okey    => 'auth_user',                                          type   => 'scalar', },
 1766         # pass for auth
 1767         { opts    => ['auth-password', 'ap'],                              suffix => ':s',
 1768           cfgs    => OP_ARG_OPT|OP_SENSITIVE, # we dynamically change this later
 1769           okey    => 'auth_pass',                                          type   => 'scalar', },
 1770         # auth type map
 1771         { opts    => ['auth-map', 'am'],                                   suffix => '=s',
 1772           cfgs    => OP_ARG_REQ,
 1773           okey    => 'auth_map',                                           type   => 'scalar', },
 1774         # extra, authenticator-specific options
 1775         { opts    => ['auth-extra', 'ae'],                                 suffix => '=s',
 1776           cfgs    => OP_ARG_REQ,
 1777           okey    => 'auth_extra',                                         type   => 'scalar', },
 1778         # hide passwords when possible
 1779         { opts    => ['auth-hide-password', 'ahp'],                        suffix => ':s',
 1780           cfgs    => OP_ARG_OPT,
 1781           okey    => 'auth_hidepw',                                        type   => 'scalar', },
 1782         # translate base64 strings
 1783         { opts    => ['auth-plaintext', 'apt'],                            suffix => '',
 1784           cfgs    => OP_ARG_NONE,
 1785           okey    => 'auth_showpt',                                        type   => 'scalar', },
 1786         # auth optional (ignore failure)
 1787         { opts    => ['auth-optional', 'ao'],                              suffix => ':s',
 1788           cfgs    => OP_ARG_OPT,
 1789           okey    => 'auth_optional',                                      type   => 'scalar', },
 1790         # req auth if avail
 1791         { opts    => ['auth-optional-strict', 'aos'],                      suffix => ':s',
 1792           cfgs    => OP_ARG_OPT,
 1793           okey    => 'auth_optional_strict',                               type   => 'scalar', },
 1794         # report capabilties
 1795         { opts    => ['support'],                                          suffix => '',
 1796           cfgs    => OP_ARG_NONE,
 1797           okey    => 'get_support',                                        type   => 'scalar', },
 1798         # local interface to use
 1799         { opts    => ['local-interface', 'li'],                            suffix => ':s',
 1800           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 1801           prompt  => 'Interface: ',                                        match  => '^.*$',
 1802           okey    => 'lint',                                               type   => 'scalar', },
 1803         # local port
 1804         { opts    => ['local-port', 'lport', 'lp'],                        suffix => ':s',
 1805           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 1806           prompt  => 'Local Port: ',                                       match  => '^\w+$',
 1807           okey    => 'lport',                                              type   => 'scalar', },
 1808         # use TLS
 1809         { opts    => ['tls'],                                              suffix => '',
 1810           cfgs    => OP_ARG_NONE,
 1811           okey    => 'tls',                                                type   => 'scalar', },
 1812         # use tls if available
 1813         { opts    => ['tls-optional', 'tlso'],                             suffix => '',
 1814           cfgs    => OP_ARG_NONE,
 1815           okey    => 'tls_optional',                                       type   => 'scalar', },
 1816         # req tls if avail
 1817         { opts    => ['tls-optional-strict', 'tlsos'],                     suffix => '',
 1818           cfgs    => OP_ARG_NONE,
 1819           okey    => 'tls_optional_strict',                                type   => 'scalar', },
 1820         # use tls if available
 1821         { opts    => ['tls-on-connect', 'tlsc'],                           suffix => '',
 1822           cfgs    => OP_ARG_NONE,
 1823           okey    => 'tls_on_connect',                                     type   => 'scalar', },
 1824         # local cert to present to server
 1825         { opts    => ['tls-cert'],                                         suffix => '=s',
 1826           cfgs    => OP_ARG_REQ,
 1827           okey    => 'tls_cert',                                           type   => 'scalar', },
 1828         # local key to present to server
 1829         { opts    => ['tls-key'],                                          suffix => '=s',
 1830           cfgs    => OP_ARG_REQ,
 1831           okey    => 'tls_key',                                            type   => 'scalar', },
 1832         # tls protocol to use
 1833         { opts    => ['tls-protocol', 'tlsp'],                             suffix => '=s',
 1834           cfgs    => OP_ARG_REQ,
 1835           okey    => 'tls_protocol',                                       type   => 'scalar', },
 1836         # tls cipher to use
 1837         { opts    => ['tls-cipher'],                                       suffix => '=s',
 1838           cfgs    => OP_ARG_REQ,
 1839           okey    => 'tls_cipher',                                         type   => 'scalar', },
 1840         # save tls peer certificate
 1841         { opts    => ['tls-get-peer-cert'],                                suffix => ':s',
 1842           cfgs    => OP_ARG_OPT,
 1843           okey    => 'tls_get_peer_cert',                                  type   => 'scalar', },
 1844         # hostname to request in TLS SNI header
 1845         { opts    => ['tls-sni'],                                          suffix => '=s',
 1846           cfgs    => OP_ARG_REQ,
 1847           okey    => 'tls_sni_hostname',                                   type   => 'scalar', },
 1848         # require verification of server certificate
 1849         { opts    => ['tls-verify'],                                       suffix => '',
 1850           cfgs    => OP_ARG_NONE,
 1851           okey    => 'tls_verify',                                         type   => 'scalar', },
 1852         # local key to present to server
 1853         { opts    => ['tls-ca-path'],                                      suffix => '=s',
 1854           cfgs    => OP_ARG_REQ,
 1855           okey    => 'tls_ca_path',                                        type   => 'scalar', },
 1856         # suppress output to varying degrees
 1857         { opts    => ['silent', 'S'],                                      suffix => ':i',
 1858           cfgs    => OP_ARG_OPT,
 1859           callout => \&process_opt_silent,
 1860           okey    => 'silent',                                             type   => 'scalar', },
 1861         # Don't strip From_ line from DATA
 1862         { opts    => ['no-strip-from', 'nsf'],                             suffix => '',
 1863           cfgs    => OP_ARG_NONE,
 1864           okey    => 'no_strip_from',                                      type   => 'scalar', },
 1865         # Don't show send/receive hints (legacy)
 1866         { opts    => ['no-hints', 'nth'],                                  suffix => '',
 1867           cfgs    => OP_ARG_NONE,
 1868           okey    => 'no_hints',                                           type   => 'scalar', },
 1869         # Don't show transaction hints
 1870         { opts    => ['no-send-hints', 'nsh'],                             suffix => '',
 1871           cfgs    => OP_ARG_NONE,
 1872           okey    => 'no_hints_send',                                      type   => 'scalar', },
 1873         # Don't show transaction hints
 1874         { opts    => ['no-receive-hints', 'nrh'],                          suffix => '',
 1875           cfgs    => OP_ARG_NONE,
 1876           okey    => 'no_hints_recv',                                      type   => 'scalar', },
 1877         # Don't show transaction hints
 1878         { opts    => ['no-info-hints', 'nih'],                             suffix => '',
 1879           cfgs    => OP_ARG_NONE,
 1880           okey    => 'no_hints_info',                                      type   => 'scalar', },
 1881         # Don't show reception lines
 1882         { opts    => ['hide-receive', 'hr'],                               suffix => '',
 1883           cfgs    => OP_ARG_NONE,
 1884           okey    => 'hide_receive',                                       type   => 'scalar', },
 1885         # Don't show sending lines
 1886         { opts    => ['hide-send', 'hs'],                                  suffix => '',
 1887           cfgs    => OP_ARG_NONE,
 1888           okey    => 'hide_send',                                          type   => 'scalar', },
 1889         # Don't echo input on potentially sensitive prompts
 1890         { opts    => ['protect-prompt', 'pp'],                             suffix => '',
 1891           cfgs    => OP_ARG_NONE,
 1892           okey    => 'protect_prompt',                                     type   => 'scalar', },
 1893         # Don't show any swaks-generated, non-error informational lines
 1894         { opts    => ['hide-informational', 'hi'],                         suffix => '',
 1895           cfgs    => OP_ARG_NONE,
 1896           okey    => 'hide_informational',                                 type   => 'scalar', },
 1897         # Don't send any output to the terminal
 1898         { opts    => ['hide-all', 'ha'],                                   suffix => '',
 1899           cfgs    => OP_ARG_NONE,
 1900           okey    => 'hide_all',                                           type   => 'scalar', },
 1901         # print lapse for send/recv
 1902         { opts    => ['show-time-lapse', 'stl'],                           suffix => ':s',
 1903           cfgs    => OP_ARG_OPT,
 1904           okey    => 'show_time_lapse',                                    type   => 'scalar', },
 1905         # print version and exit
 1906         { opts    => ['version'],                                          suffix => '',
 1907           cfgs    => OP_ARG_NONE,
 1908           okey    => 'version',                                            type   => 'scalar', },
 1909         # print help and exit
 1910         { opts    => ['help'],                                             suffix => '',
 1911           cfgs    => OP_ARG_NONE,
 1912           okey    => 'help',                                               type   => 'scalar', },
 1913         # don't touch the data
 1914         { opts    => ['no-data-fixup', 'ndf'],                             suffix => '',
 1915           cfgs    => OP_ARG_NONE,
 1916           okey    => 'no_data_fixup',                                      type   => 'scalar', },
 1917         # show dumps of the raw read/written text
 1918         { opts    => ['show-raw-text', 'raw'],                             suffix => '',
 1919           cfgs    => OP_ARG_NONE,
 1920           okey    => 'show_raw_text',                                      type   => 'scalar', },
 1921         # specify file to write to
 1922         { opts    => ['output', 'output-file'],                            suffix => '=s',
 1923           cfgs    => OP_ARG_REQ,
 1924           okey    => 'output_file',                                        type   => 'scalar', },
 1925         # specify file to write to
 1926         { opts    => ['output-file-stdout'],                               suffix => '=s',
 1927           cfgs    => OP_ARG_REQ,
 1928           okey    => 'output_file_stdout',                                 type   => 'scalar', },
 1929         # specify file to write to
 1930         { opts    => ['output-file-stderr'],                               suffix => '=s',
 1931           cfgs    => OP_ARG_REQ,
 1932           okey    => 'output_file_stderr',                                 type   => 'scalar', },
 1933         # command to communicate with
 1934         { opts    => ['pipe'],                                             suffix => ':s',
 1935           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 1936           prompt  => 'Pipe: ',                                             match  => '^.+$',
 1937           okey    => 'pipe_cmd',                                           type   => 'scalar', },
 1938         # unix domain socket to talk to
 1939         { opts    => ['socket'],                                           suffix => ':s',
 1940           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 1941           prompt  => 'Socket File: ',                                      match  => '^.+$',
 1942           okey    => 'socket',                                             type   => 'scalar', },
 1943         # the content of the body of the DATA
 1944         { opts    => ['body'],                                             suffix => ':s',
 1945           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT|OP_FROM_FILE,
 1946           prompt  => 'Body: ',                                             match  => '.+',
 1947           okey    => 'body_822',                                           type   => 'scalar', },
 1948         # A file to attach
 1949         { opts    => ['attach-name'],                                      suffix => ':s',
 1950           cfgs    => OP_ARG_OPT,
 1951           okey    => 'attach_name',       akey => 'attach_accum',          type   => 'list', },
 1952         # A file to attach
 1953         { opts    => ['attach-type'],                                      suffix => ':s',
 1954           cfgs    => OP_ARG_REQ,
 1955           okey    => 'attach_type',       akey => 'attach_accum',          type   => 'list', },
 1956         # A file to attach
 1957         { opts    => ['attach'],                                           suffix => ':s',
 1958           cfgs    => OP_ARG_REQ|OP_FROM_FILE,
 1959           okey    => 'attach_attach',     akey => 'attach_accum',          type   => 'list', },
 1960         # A file to attach
 1961         { opts    => ['attach-body'],                                      suffix => ':s',
 1962           cfgs    => OP_ARG_REQ|OP_FROM_FILE,
 1963           okey    => 'attach_body',       akey => 'attach_accum',          type   => 'list', },
 1964         # replacement for %NEW_HEADERS% DATA token
 1965         { opts    => ['add-header', 'ah'],                                 suffix => ':s',
 1966           cfgs    => OP_ARG_REQ,
 1967           okey    => 'add_header',                                         type   => 'list', },
 1968         # replace header if exist, else add
 1969         { opts    => ['header'],                                           suffix => ':s',
 1970           cfgs    => OP_ARG_REQ,
 1971           okey    => 'header',                                             type   => 'list', },
 1972         # build options and dump
 1973         { opts    => ['dump'],                                             suffix => ':s',
 1974           cfgs    => OP_ARG_OPT,
 1975           okey    => 'dump_args',                                          type   => 'scalar', },
 1976         # build options and dump the generate message body (EML)
 1977         { opts    => ['dump-mail'],                                        suffix => '',
 1978           cfgs    => OP_ARG_NONE,
 1979           okey    => 'dump_mail',                                          type   => 'scalar', },
 1980         # attempt PIPELINING
 1981         { opts    => ['pipeline'],                                         suffix => '',
 1982           cfgs    => OP_ARG_NONE,
 1983           okey    => 'pipeline',                                           type   => 'scalar', },
 1984         # attempt PRDR
 1985         { opts    => ['prdr'],                                             suffix => '',
 1986           cfgs    => OP_ARG_NONE,
 1987           okey    => 'prdr',                                               type   => 'scalar', },
 1988         # use getpwuid building -f
 1989         { opts    => ['force-getpwuid'],                                   suffix => '',
 1990           cfgs    => OP_ARG_NONE,
 1991           okey    => 'force_getpwuid',                                     type   => 'scalar', },
 1992 
 1993         # XCLIENT
 1994         # These xclient_attrs options all get pushed onto an array so that we can determine their order later
 1995         # argument is a raw XCLIENT string
 1996         { opts    => ['xclient'],                                          suffix => ':s',
 1997           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 1998           prompt  => 'XCLIENT string: ',                                   match  => '^.+$',
 1999           okey    => 'xclient_raw',             akey => 'xclient_accum',   type   => 'list',    },
 2000         # XCLIENT NAME
 2001         { opts    => ['xclient-name'],                                     suffix => ':s',
 2002           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 2003           prompt  => 'XCLIENT name: ',                                     match  => '^.+$',
 2004           okey    => 'xclient_name',            akey => 'xclient_accum',   type   => 'scalar',    },
 2005         # XCLIENT ADDR
 2006         { opts    => ['xclient-addr'],                                     suffix => ':s',
 2007           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 2008           prompt  => 'XCLIENT addr: ',                                     match  => '^.+$',
 2009           okey    => 'xclient_addr',            akey => 'xclient_accum',   type   => 'scalar',    },
 2010         # XCLIENT PORT
 2011         { opts    => ['xclient-port'],                                     suffix => ':s',
 2012           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 2013           prompt  => 'XCLIENT port: ',                                     match  => '^.+$',
 2014           okey    => 'xclient_port',            akey => 'xclient_accum',   type   => 'scalar',    },
 2015         # XCLIENT PROTO
 2016         { opts    => ['xclient-proto'],                                    suffix => ':s',
 2017           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 2018           prompt  => 'XCLIENT proto: ',                                    match  => '^.+$',
 2019           okey    => 'xclient_proto',           akey => 'xclient_accum',   type   => 'scalar',    },
 2020         # XCLIENT DESTADDR
 2021         { opts    => ['xclient-destaddr'],                                 suffix => ':s',
 2022           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 2023           prompt  => 'XCLIENT destaddr: ',                                 match  => '^.+$',
 2024           okey    => 'xclient_destaddr',        akey => 'xclient_accum',   type   => 'scalar',    },
 2025         # XCLIENT DESTPORT
 2026         { opts    => ['xclient-destport'],                                 suffix => ':s',
 2027           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 2028           prompt  => 'XCLIENT destport: ',                                 match  => '^.+$',
 2029           okey    => 'xclient_destport',        akey => 'xclient_accum',   type   => 'scalar',    },
 2030         # XCLIENT HELO
 2031         { opts    => ['xclient-helo'],                                     suffix => ':s',
 2032           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 2033           prompt  => 'XCLIENT helo: ',                                     match  => '^.+$',
 2034           okey    => 'xclient_helo',            akey => 'xclient_accum',   type   => 'scalar',    },
 2035         # XCLIENT LOGIN
 2036         { opts    => ['xclient-login'],                                    suffix => ':s',
 2037           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 2038           prompt  => 'XCLIENT login: ',                                    match  => '^.+$',
 2039           okey    => 'xclient_login',           akey => 'xclient_accum',   type   => 'scalar',    },
 2040         # XCLIENT REVERSE_NAME
 2041         { opts    => ['xclient-reverse-name'],                             suffix => ':s',
 2042           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 2043           prompt  => 'XCLIENT reverse_name: ',                             match  => '^.+$',
 2044           okey    => 'xclient_reverse_name',    akey => 'xclient_accum',   type   => 'scalar',    },
 2045         # XCLIENT delimiter.  Used to indicate that user wants to start a new xclient attr grouping
 2046         { opts    => ['xclient-delim'],                                    suffix => '',
 2047           cfgs    => OP_ARG_NONE,
 2048           okey    => 'xclient_delim',           akey => 'xclient_accum',   type   => 'list',    },
 2049         # if set, XCLIENT will proceed even if XCLIENT not advertised
 2050         { opts    => ['xclient-optional'],                                 suffix => '',
 2051           cfgs    => OP_ARG_NONE,
 2052           okey    => 'xclient_optional',                                   type   => 'scalar', },
 2053         # proceed if xclient not offered, but fail if offered and not accepted
 2054         { opts    => ['xclient-optional-strict'],                          suffix => '',
 2055           cfgs    => OP_ARG_NONE,
 2056           okey    => 'xclient_optional_strict',                            type   => 'scalar', },
 2057         # we send xclient after starttls by default.  if --xclient-before-starttls will send before tls
 2058         { opts    => ['xclient-before-starttls'],                          suffix => '',
 2059           cfgs    => OP_ARG_NONE,
 2060           okey    => 'xclient_before_starttls',                            type   => 'scalar', },
 2061         # Don't require that the --xclient-ATTR attributes be advertised by server
 2062         { opts    => ['xclient-no-verify'],                                suffix => '',
 2063           cfgs    => OP_ARG_NONE,
 2064           okey    => 'xclient_no_verify',                                  type   => 'scalar', },
 2065         ## xclient send by default after first helo, but can be sent almost anywhere (cf quit-after)
 2066         # { opts    => ['xclient-after'],                                    suffix => ':s',
 2067         #   okey    => 'xclient_after',                                      type   => 'scalar', },
 2068 
 2069         # PROXY
 2070         # argument is the raw PROXY string
 2071         { opts    => ['proxy'],                                            suffix => ':s',
 2072           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 2073           prompt  => 'PROXY string: ',                                     match  => '^.+$',
 2074           okey    => 'proxy_raw',                                          type   => 'scalar', },
 2075         # PROXY version (1 or 2)
 2076         { opts    => ['proxy-version'],                                    suffix => ':s',
 2077           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 2078           prompt  => 'PROXY version: ',                                    match  => '^[12]$',
 2079           okey    => 'proxy_version',                                      type   => 'scalar', },
 2080         # PROXY protocol family (TCP4 or TCP6)
 2081         { opts    => ['proxy-family'],                                     suffix => ':s',
 2082           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 2083           prompt  => 'PROXY family: ',                                     match  => '^.+$',
 2084           okey    => 'proxy_family',                                       type   => 'scalar', },
 2085         # PROXY protocol command (LOCAL or PROXY)
 2086         { opts    => ['proxy-command'],                                    suffix => ':s',
 2087           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 2088           prompt  => 'PROXY command: ',                                    match  => '^.+$',
 2089           okey    => 'proxy_command',                                      type   => 'scalar', },
 2090         # PROXY transport protocol
 2091         { opts    => ['proxy-protocol'],                                   suffix => ':s',
 2092           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 2093           prompt  => 'PROXY protocol: ',                                   match  => '^.+$',
 2094           okey    => 'proxy_protocol',                                     type   => 'scalar', },
 2095         # PROXY source address (IPv4 or IPv6)
 2096         { opts    => ['proxy-source'],                                     suffix => ':s',
 2097           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 2098           prompt  => 'PROXY source: ',                                     match  => '^.+$',
 2099           okey    => 'proxy_source',                                       type   => 'scalar', },
 2100         # PROXY source port
 2101         { opts    => ['proxy-source-port'],                                suffix => ':s',
 2102           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 2103           prompt  => 'PROXY source_port: ',                                match  => '^.+$',
 2104           okey    => 'proxy_source_port',                                  type   => 'scalar', },
 2105         # PROXY destination address (IPv4 or IPv6)
 2106         { opts    => ['proxy-dest'],                                       suffix => ':s',
 2107           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 2108           prompt  => 'PROXY dest: ',                                       match  => '^.+$',
 2109           okey    => 'proxy_dest',                                         type   => 'scalar', },
 2110         # PROXY destination port
 2111         { opts    => ['proxy-dest-port'],                                  suffix => ':s',
 2112           cfgs    => OP_ARG_REQ|OP_FROM_PROMPT,
 2113           prompt  => 'PROXY dest_port: ',                                  match  => '^.+$',
 2114           okey    => 'proxy_dest_port',                                    type   => 'scalar', },
 2115 
 2116         # this option serve no purpose other than testing the deprecation system
 2117         { opts    => ['trigger-deprecation'],                              suffix => ':s',
 2118           cfgs    => OP_ARG_REQ|OP_DEPRECATED,
 2119           okey    => 'trigger_deprecation',                                type   => 'scalar', },
 2120     );
 2121 
 2122     return(\@G::raw_option_data);
 2123 }
 2124 
 2125 # returns %O, the large raw option hash
 2126 # This sub is a jumping point.  We will construct an argv based on the different ways that options can be specified
 2127 # and call GetOptions multiple times.  We are essentially "layering" options.  First we load from a config file (if
 2128 # exists/specified), then from any environment variables, then the actual command line.
 2129 sub load_args {
 2130     my %ARGS      = (); # this is the structure that gets returned
 2131     my @fakeARGV  = ();
 2132 
 2133     # we load our options processing hash here.  We abstract it back from the
 2134     # native getopt-format because we need to be able to intercept "no-" options
 2135     my $option_list = get_option_struct();
 2136 
 2137     # do a loop through the options and make sure they are structured the way we expect
 2138     foreach my $e (@$option_list) {
 2139         if (!exists($e->{okey}) || !$e->{okey}) {
 2140             ptrans(12, 'Option configuration missing an okey (this is a swaks bug)');
 2141             exit(1);
 2142         }
 2143         elsif (!exists($e->{opts}) || ref($e->{opts}) ne 'ARRAY') {
 2144             ptrans(12, 'Option ' . $e->{okey} . ' missing or corrupt opts key (this is a swaks bug)');
 2145             exit(1);
 2146         }
 2147         elsif (!exists($e->{suffix})) {
 2148             ptrans(12, 'Option ' . $e->{okey} . ' missing suffix key (this is a swaks bug)');
 2149             exit(1);
 2150         }
 2151         elsif (!exists($e->{type}) || $e->{type} !~ /^(scalar|list)$/) {
 2152             ptrans(12, 'Option ' . $e->{okey} . ' missing or invalid type key (this is a swaks bug)');
 2153             exit(1);
 2154         }
 2155         elsif (!exists($e->{cfgs})) {
 2156             ptrans(12, 'Option ' . $e->{okey} . ' missing cfgs key (this is a swaks bug)');
 2157             exit(1);
 2158         }
 2159 
 2160         $e->{akey} = $e->{okey} if (!exists($e->{akey}));
 2161 
 2162         # 'cfgs' stores the okey config for easier access later
 2163         $ARGS{cfgs}{$e->{okey}} = $e;
 2164     }
 2165 
 2166     # we want to process config files first.  There's a default config file in
 2167     # ~/.swaksrc, but it is possible for the user to override this with the
 2168     # --config options.  So, find the one and only file we will use here.
 2169     # If we encounter --config in later processing it is a noop.
 2170     # first find the default file
 2171     my $config_file       = '';
 2172     my $skip_config       = 0;
 2173     my $config_is_default = 1;
 2174     foreach my $v (qw(SWAKS_HOME HOME LOGDIR)) {
 2175         if (exists($ENV{$v}) && length($ENV{$v}) && -f $ENV{$v} . '/.swaksrc') {
 2176             $config_file = $ENV{$v} . '/.swaksrc';
 2177             last;
 2178         }
 2179     }
 2180     # then look through the ENV args to see if another file set there
 2181     if (exists($ENV{SWAKS_OPT_config})) {
 2182         if (!$ENV{SWAKS_OPT_config}) {
 2183             # if exist but not set, it just means "don't use default file"
 2184             $skip_config = 1;
 2185         } else {
 2186             $config_file = $ENV{SWAKS_OPT_config};
 2187             $config_is_default = 0;
 2188         }
 2189     }
 2190     # lastly go (backwards) through original command line looking for config file,
 2191     # choosing the first one found (meaning last one specified)
 2192     for (my $i = scalar(@ARGV) - 1; $i >= 0; $i--) {
 2193         if ($ARGV[$i] =~ /^-?-config$/) {
 2194             if ($i == scalar(@ARGV) - 1 || $ARGV[$i+1] =~ /^-/) {
 2195                 $skip_config = 1;
 2196             } else {
 2197                 $config_file       = $ARGV[$i+1];
 2198                 $config_is_default = 0;
 2199                 $skip_config       = 0;
 2200             }
 2201             last;
 2202         }
 2203     }
 2204 
 2205     # All of the above will result in $config_file either being empty or
 2206     # containing the one and only config file we will use (though merged with DATA)
 2207     if (!$skip_config) {
 2208         my @configs = ('&DATA');
 2209         push(@configs, $config_file) if ($config_file);
 2210         foreach my $configf (@configs) {
 2211             my @fakeARGV = ();
 2212             if (open(C, '<' . $configf)) {
 2213                 # "#" in col 0 is a comment
 2214                 while (defined(my $m = <C>)) {
 2215                     next if ($m =~ m|^#|);
 2216                     chomp($m);
 2217                     $m = '--' . $m if ($m !~ /^-/);
 2218                     push(@fakeARGV, split(/\s/, $m, 2));
 2219                 }
 2220                 close(C);
 2221             } elsif (!$config_is_default && $configf eq $config_file) {
 2222                 # we only print an error if the config was specified explicitly
 2223                 ptrans(12, 'Config file ' . $configf . ' could not be opened ($!).  Exiting');
 2224                 exit(1);
 2225             }
 2226 
 2227             # OK, all that work to load @fakeARGV with values from the config file.  Now
 2228             # we just need to process it.  (don't call if nothing set in @fakeARGV)
 2229             fetch_args(\%ARGS, $option_list, \@fakeARGV) if (scalar(@fakeARGV));
 2230             check_opt_processing(\@fakeARGV, 'Config file ' . $configf);
 2231         }
 2232     }
 2233 
 2234     # OK, %ARGS contains all the settings from the config file.  Now do it again
 2235     # with SWAKS_OPT_* environment variables
 2236     @fakeARGV = ();
 2237     foreach my $v (sort keys %ENV) {
 2238         if ($v =~ m|^SWAKS_OPT_(.*)$|) {
 2239             my $tv = $1; $tv =~ s|_|-|g;
 2240             push(@fakeARGV, '--' . $tv);
 2241             push(@fakeARGV, $ENV{$v}) if (length($ENV{$v}));
 2242         }
 2243     }
 2244     fetch_args(\%ARGS, $option_list, \@fakeARGV) if (scalar(@fakeARGV));
 2245     check_opt_processing(\@fakeARGV, 'environment');
 2246 
 2247     # and now, after all of that, process the actual cmdline args
 2248     fetch_args(\%ARGS, $option_list, \@ARGV) if (scalar(@ARGV));
 2249     check_opt_processing(\@ARGV, 'command line');
 2250 
 2251     return(\%ARGS);
 2252 }
 2253 
 2254 # if there's anything left in the fake argv after Getopts processed it, it's an error.  There's nothing
 2255 # that can be passed in to swaks that isn't an option or an argument to an option, all of which Getopt
 2256 # should consume.  So if there's anything left, the user did something weird.  Just let them know and
 2257 # error instead of letting them think their ignored stuff is working.
 2258 sub check_opt_processing {
 2259     my $argv_local  = shift;
 2260     my $option_type = shift;
 2261 
 2262     if (scalar(@$argv_local)) {
 2263         ptrans(12, 'Data left in option list when processing  ' . $option_type . ' (' .
 2264                    join(', ', map { "'$_'" } (@$argv_local)) .
 2265                    ').  Exiting');
 2266         exit(1);
 2267     }
 2268 }
 2269 
 2270 sub fetch_args {
 2271     my $r          = shift;
 2272     my $l          = shift;
 2273     my $argv_local = shift;
 2274 
 2275     my %to_delete = ();
 2276 
 2277     # need to rewrite header-HEADER opts before std option parsing
 2278     # also see if there are any --no- options that need to be processed
 2279     RUNOPTS:
 2280     for (my $i = 0; $i < scalar(@$argv_local); $i++) {
 2281         # before doing any option processing, massage from the optional '--option=arg' format into '--option arg' format.
 2282         if ($argv_local->[$i] =~ /^(-[^=]+)=(.*)$/) {
 2283             $argv_local->[$i] = $1;
 2284             splice(@$argv_local, $i+1, 0, $2);
 2285         }
 2286 
 2287         # -g is not really necessary.  It is now deprecated. During the deprecation window, make
 2288         # it a straight-up alias to `--data -`.  If has already appeared, just ignore -g.  If
 2289         # --data has not appeared, change -g into `--data -`.
 2290         if ($argv_local->[$i] =~ /^-?-g$/) {
 2291             deprecate('The -g option is deprecated and will be removed. Please use \'--data -\' instead.');
 2292             if (scalar(grep(/^-?-data$/, @$argv_local)) || check_arg('mail_data', $r)) {
 2293                 # if --data appears in the current stream or has already appeared in a previous stream, ignore -g
 2294                 splice(@$argv_local, $i, 1); # remove the current index from @$argv_local
 2295                 redo(RUNOPTS);        # since there's now a new value at $i, redo this iteration of the loop
 2296             }
 2297             else {
 2298                 # if we haven't seen --data yet, change -g into `--data -`
 2299                 splice(@$argv_local, $i, 1, '--data', '-');
 2300             }
 2301         }
 2302 
 2303         if ($argv_local->[$i] =~ /^-?-h(?:eader)?-([^:]+):?$/) {
 2304             # rewrite '--header-Foo bar' into '--header "Foo: bar"'
 2305             $argv_local->[$i]   = "--header";
 2306             $argv_local->[$i+1] = $1 . ': ' . $argv_local->[$i+1];
 2307         }
 2308         elsif ($argv_local->[$i] =~ /^-?-no-h(?:eader)?-/) {
 2309             # rewrite '--no-header-Foo' into '--no-header'
 2310             $argv_local->[$i]   = "--no-header";
 2311         }
 2312     }
 2313 
 2314     # build the actual hash we will pass to GetOptions from our config list ($l):
 2315     # In the end I decided to build this at each call of this sub so that $r
 2316     # is defined.  It's not much of a performance issue.
 2317     my %options = ();
 2318     foreach my $e (@$l) {
 2319         my $k      = join('|', @{$e->{opts}}) . $e->{suffix};
 2320         my $nk     = join('|', map { "no-$_" } (@{$e->{opts}}));
 2321         my $eval;
 2322         if ($e->{type} eq 'scalar' || $e->{type} eq 'list') {
 2323             $eval = "\$options{\$k} = sub { store_option(\$e, \$r, 0, \@_); };"
 2324                   . "\$options{\$nk} = sub { store_option(\$e, \$r, 1, \@_); };";
 2325         }
 2326         else {
 2327             ptrans(12, "Unknown option type '$e->{type}' (this is a swaks bug)");
 2328             exit(1);
 2329         }
 2330         eval($eval);
 2331         if ($@) {
 2332             chomp($@);
 2333             ptrans(12, "Unable to load callback for $k option processing: $@");
 2334             exit(1);
 2335         }
 2336     }
 2337 
 2338     if (!load("Getopt::Long")) {
 2339         ptrans(12, "Unable to load Getopt::Long for option processing, Exiting");
 2340         exit(1);
 2341     }
 2342 
 2343     Getopt::Long::Configure("no_ignore_case");
 2344     Getopt::Long::GetOptionsFromArray($argv_local, %options) || exit(1);
 2345 }
 2346 
 2347 sub store_option {
 2348     my $cfg_struct = shift;               # this is the option definition structure
 2349     my $opt_struct = shift;               # this is where we will be saving the option for later retrieval
 2350     my $remove     = shift;               # if true, we received a "no-" version of the option, remove all previous instances
 2351     my $opt_name   = shift;               # --xclient-name   || --dump-mail  || -f
 2352     my $opt_value  = shift;               # NAME             || undef        || foo@example.com
 2353     my $accum_key  = $cfg_struct->{akey}; # xclient_attrs    || dump_mail    || mail_from
 2354     my $opt_key    = $cfg_struct->{okey}; # xclient_name     || dump_mail    || mail_from
 2355     my $type       = $cfg_struct->{type}; # scalar or list
 2356 
 2357     # print "store_options called -> $cfg_struct, $opt_struct, $opt_name, $opt_value, $accum_key, $opt_key, $type\n";
 2358 
 2359     if ($cfg_struct->{cfgs} & OP_DEPRECATED) {
 2360         deprecate("Option --$opt_name will be removed in the future.  Please see documentation for more information.");
 2361     }
 2362 
 2363     # 'accum' stores lists of the order they were received in
 2364     $opt_struct->{accums}{$accum_key} ||= [];
 2365     # 'values' stores the actual values and the name of the option that was used to pass it
 2366     $opt_struct->{values}{$opt_key}   ||= [];
 2367 
 2368     # if we're recording a scalar or were asked to remove, reset the values list to throw away any previous values
 2369     # and remove any previous recordings of this okey from the accumulator list
 2370     if ($type eq 'scalar' || $remove) {
 2371         $opt_struct->{values}{$opt_key}   = [];
 2372         $opt_struct->{accums}{$accum_key} = [ grep { $_ ne $opt_key } (@{$opt_struct->{accums}{$accum_key}}) ];
 2373     }
 2374 
 2375     # if we were asked to remove (which means called with a "--no-" prefix), get out now, there's nothing to record
 2376     return if ($remove);
 2377 
 2378     push(@{$opt_struct->{accums}{$accum_key}}, $opt_key);
 2379 
 2380     my $arg = $opt_value;
 2381     if ($cfg_struct->{callout}) {
 2382         $arg = $cfg_struct->{callout}("$opt_name", $arg);
 2383     }
 2384 
 2385     push(@{$opt_struct->{values}{$opt_key}}, {
 2386         okey => $opt_key,
 2387         akey => $accum_key,
 2388         opt  => "$opt_name",
 2389         arg  => $arg,
 2390     });
 2391 }
 2392 
 2393 # take a string and quote it such that it could be used in the shell
 2394 # O'Reilley -> 'O'\''Reilley'
 2395 sub shquote { my $s = shift; $s =~ s%'%'\\''%g; return "'$s'"; }
 2396 
 2397 sub reconstruct_options {
 2398     my $o            = shift; # ref to raw option hash (as returned by load_args)
 2399     my @c            = ();    # array to hold our reconstructed command line
 2400     my %already_seen = ();    # for okeys like xclient_attrs, they only need to be processed once
 2401     my %indexer      = ();
 2402 
 2403     foreach my $opt (@G::raw_option_data) {
 2404         next if ($already_seen{$opt->{akey}});
 2405         next if (!exists($o->{accums}{$opt->{akey}}));
 2406 
 2407         foreach my $okey (@{$o->{accums}{$opt->{akey}}}) {
 2408             $indexer{$okey} ||= 0;
 2409             my $optStruct     = $o->{values}{$okey}[$indexer{$okey}];
 2410             my $lopt          = $o->{cfgs}{$okey}{opts}[0];
 2411 
 2412             push(@c, '--'.$lopt);
 2413             if (length($optStruct->{arg}) && !($o->{cfgs}{$okey}{cfgs} & OP_ARG_NONE)) {
 2414                 if ($okey eq 'auth_pass') {
 2415                     push(@c, shquote('%RAW_PASSWORD_STRING%'));
 2416                 }
 2417                 else {
 2418                     push(@c, shquote($optStruct->{arg}));
 2419                 }
 2420             }
 2421         }
 2422         $already_seen{$opt->{akey}} = 1;
 2423     }
 2424 
 2425     #print join(', ', @c), "\n";
 2426     return join(' ', @c);
 2427 }
 2428 
 2429 sub get_accum {
 2430     my $accum_key = shift;
 2431     my $userOpts  = shift;
 2432 
 2433     if (!exists($userOpts->{accums}{$accum_key})) {
 2434         return([]);
 2435     }
 2436 
 2437     return($userOpts->{accums}{$accum_key});
 2438 }
 2439 
 2440 # I might change this interface later, but I want a way to check whether the user provided the option
 2441 # without actually processing it.
 2442 sub check_arg {
 2443     my $opt      = shift;
 2444     my $userOpts = shift;
 2445 
 2446     if (exists($userOpts->{values}{$opt}) && scalar(@{$userOpts->{values}{$opt}})) {
 2447         return(1);
 2448     }
 2449 
 2450     return(0);
 2451 }
 2452 
 2453 # get the next value for $opt without doing any processing or popping it off of the list.
 2454 sub peek_arg {
 2455     my $opt       = shift; # this should correspond to an okey from the @G::raw_option_data array
 2456     my $userOpts  = shift; # all options we got from the command line
 2457 
 2458     if (!exists($userOpts->{values}{$opt})) {
 2459         return(undef());
 2460     }
 2461 
 2462     if (!scalar(@{$userOpts->{values}{$opt}})) {
 2463         return(undef());
 2464     }
 2465 
 2466     return($userOpts->{values}{$opt}[0]{arg});
 2467 }
 2468 
 2469 # there was a ton of repeated, boiler plate code in process_args.  Attempt to abstract it out to get_arg
 2470 sub get_arg {
 2471     my $opt       = shift; # this should correspond to an okey from the @G::raw_option_data array
 2472     my $userOpts  = shift; # all options we got from the command line
 2473     my $optConfig = shift;
 2474     my $force     = shift;
 2475     my $arg;
 2476     my $argExt;
 2477     my $return;
 2478 
 2479     # print "in get_arg, opt = $opt\n";
 2480 
 2481     # If the user didn't pass in a specific option config, look it up from the global option config
 2482     if (!$optConfig) {
 2483         if (!exists($userOpts->{cfgs}{$opt})) {
 2484             ptrans(12, "Internal option processing error: asked to evaluate non-existent option $opt");
 2485             exit(1);
 2486         }
 2487         $optConfig = $userOpts->{cfgs}{$opt};
 2488     }
 2489 
 2490     # $arg will be the value actually provided on the command line
 2491     # !defined = not provided
 2492     # defined && !length = option provided but no argument provided
 2493     # defined && length = option provided and argument provided
 2494     if (!exists($userOpts->{values}{$opt})) {
 2495         # if the caller passed in $force, we act as if the option is present with an empty arg
 2496         # this is used when we need to use get_arg features like interact() even when the user
 2497         # didn't specify the option (specifically, --auth forces --auth-password to need to be
 2498         # processed, even if the user didn't pass it in)
 2499         $arg = $force ? '' : undef();
 2500     }
 2501     else {
 2502         $argExt = shift(@{$userOpts->{values}{$opt}});
 2503         $arg    = $argExt->{arg};
 2504     }
 2505 
 2506     # this option takes no arguments - it's a straight boolean
 2507     if ($optConfig->{cfgs} & OP_ARG_NONE) {
 2508         if ($arg) {
 2509             $return = 1;
 2510         }
 2511         else {
 2512             $return = 0;
 2513         }
 2514     }
 2515 
 2516     # if the option is present, it must have an argument.
 2517     # theoretically I should have code here actually requiring the argument,
 2518     # but at the moment that's being handled by Getopt::Long
 2519     elsif ($optConfig->{cfgs} & OP_ARG_REQ) {
 2520         if (!defined($arg)) {
 2521             # the opt wasn't specified at all.  Perfectly legal, return undef
 2522             $return = undef;
 2523         }
 2524         else {
 2525             # if there was an arg provided, just return it
 2526             if (length($arg)) {
 2527                 $return = $arg;
 2528             }
 2529             # No arg, but we were requested to prompt the user - do so
 2530             elsif ($optConfig->{cfgs} & OP_FROM_PROMPT) {
 2531                 if (!exists($optConfig->{prompt})) {
 2532                     ptrans(12, "Internal option processing error: option $argExt->{opt} missing required prompt key (this is a swaks bug)");
 2533                     exit(1);
 2534                 }
 2535                 if (!exists($optConfig->{match})) {
 2536                     ptrans(12, "Internal option processing error: option $argExt->{opt} missing required match key (this is a swaks bug)");
 2537                     exit(1);
 2538                 }
 2539                 $return = interact($optConfig->{prompt}, $optConfig->{match}, $optConfig->{cfgs} & OP_SENSITIVE);
 2540             }
 2541             # No arg, no request to prompt - this is an error since we're requiring an arg
 2542             else {
 2543                 ptrans(12, "Option processing error: option $argExt->{opt} specified with no argument");
 2544                 exit(1);
 2545             }
 2546 
 2547             # OP_FROM_FILE means that the above options might have resolved into '-' or @filename.  If so, return the actual
 2548             # data contained in STDIN/@filename
 2549             if ($optConfig->{cfgs} & OP_FROM_FILE) {
 2550                 if ($return eq '-') {
 2551                     if (defined($G::stdin)) {
 2552                         # multiple options can specify stdin, but we can only read it once.  If anyone has
 2553                         # already read stdin, provide the saved value here
 2554                         $return = $G::stdin;
 2555                     }
 2556                     else {
 2557                         $return   = join('', <STDIN>);
 2558                         $G::stdin = $return;
 2559                     }
 2560                 }
 2561                 elsif ($return =~ /^\@\@/) {
 2562                     # if the argument starts with \@\@, we take that to mean that the user wants a literal value that starts
 2563                     # with an @.  The first @ is just an indicator, so strip it off before continuing
 2564                     $return =~ s/^\@//;
 2565                 }
 2566                 elsif ($return =~ /^\@/) {
 2567                     # a single @ means it's a filename.  Open it and use the contents as the return value
 2568                     $return =~ s/^\@//;
 2569                     if (!open(F, "<$return")) {
 2570                         ptrans(12, "Option processing error: file $return not openable for option $argExt->{opt} ($!)");
 2571                         exit(1);
 2572                     }
 2573                     $return = join('', <F>);
 2574                     close(F);
 2575                 }
 2576 
 2577                 {
 2578                     # All of the functionality in this bare block is deprecated, remove the whole thing later.
 2579                     # if --data and single line, try to open it, error otherwise
 2580                     # if !--data and is openable file, try to open and read, otherwise just use it as literal data
 2581                     if ($argExt->{opt} eq 'data') {
 2582                         # the old rule for --data was that anything that didn't have a newline in it would be treated
 2583                         # as a file, and we would error if we couldn't open it. That would prevent us from sending
 2584                         # typoed filenames as the data of messages
 2585                         if ($return !~ m/\\n|\n|%NEWLINE%/) {
 2586                             deprecate('Inferring a filename from the argument to --' . $argExt->{opt} .
 2587                                       ' will be removed in the future.  Prefix filenames with \'@\' instead.');
 2588                             if (!open(F, "<$return")) {
 2589                                 ptrans(12, "$argExt->{opt} option appears to be a file but is not openable: $return ($!)");
 2590                                 exit(1);
 2591                             }
 2592                             $return = join('', <F>);
 2593                             close(F);
 2594                         }
 2595                     }
 2596                     elsif (open(F, "<$return")) {
 2597                         # the old rule for any other file option (--attach, --attach-body, --body) was that
 2598                         # if it was openable, we would use the contents of the file, otherwise we would
 2599                         # use the string itself
 2600                         deprecate('Inferring a filename from the argument to --' . $argExt->{opt} .
 2601                                   ' will be removed in the future.  Prefix filenames with \'@\' instead.');
 2602                         $return = join('', <F>);
 2603                         close(F);
 2604                     }
 2605                 }
 2606             }
 2607         }
 2608     }
 2609 
 2610     # The option can be present with or without an argument
 2611     # any "true" return value will be an actual provided option
 2612     # false and defined = option given but no argument given
 2613     # false and undefined = option not specified
 2614     elsif ($optConfig->{cfgs} & OP_ARG_OPT) {
 2615         if (!defined($arg)) {
 2616             # the opt wasn't specified at all.  Perfectly legal, return undef
 2617             $return = undef;
 2618         }
 2619         else {
 2620             # we have an opt and an arg, return the arg
 2621             $return = $arg;
 2622         }
 2623     }
 2624 
 2625     # if we read the last arg off an array, put it back on the array for future reads.  I can't
 2626     # decide if this is the right behavior or not, but this makes it more like scalars, which
 2627     # can (and in a couple of cases, must) be read multiple times.
 2628     if (defined($arg) && ref($userOpts->{values}{$opt}) && !scalar(@{$userOpts->{values}{$opt}})) {
 2629         push(@{$userOpts->{values}{$opt}}, $argExt);
 2630     }
 2631 
 2632     # print "returning ";
 2633     # if (defined($return)) {
 2634     #   print length($return) ? "$return\n" : "defined but empty\n";
 2635     # }
 2636     # else {
 2637     #   print "undefined\n";
 2638     # }
 2639     return($return);
 2640 }
 2641 
 2642 # A couple of global options are set in here, they will be in the G:: namespace
 2643 sub process_args {
 2644     my $o     = shift; # This is the args we got from command line
 2645     my %n     = ();    # This is the hash we will return w/ the fixed-up args
 2646     my $a     = get_option_struct(); # defining information for all options
 2647 
 2648     # handle the output file handles early so they can be used for errors
 2649     # we don't need to keep track of the actual files but it will make debugging
 2650     # easier later
 2651     $G::trans_fh_oh        = \*STDOUT;
 2652     $G::trans_fh_of        = "STDOUT";
 2653     $G::trans_fh_eh        = \*STDERR;
 2654     $G::trans_fh_ef        = "STDERR";
 2655     my $output_file        = get_arg('output_file', $o);
 2656     my $output_file_stderr = get_arg('output_file_stderr', $o) || $output_file;
 2657     my $output_file_stdout = get_arg('output_file_stdout', $o) || $output_file;
 2658     if ($output_file_stderr) {
 2659         if (!open(OUTEFH, '>>'.$output_file_stderr)) {
 2660             ptrans(12, 'Unable to open ' . $output_file_stderr . ' for writing');
 2661             exit(1);
 2662         }
 2663         $G::trans_fh_eh = \*OUTEFH;
 2664         $G::trans_fh_ef = $output_file_stderr;
 2665     }
 2666     if ($output_file_stdout && $output_file_stdout eq $output_file_stderr) {
 2667         $G::trans_fh_oh = $G::trans_fh_eh;
 2668         $G::trans_fh_of = $G::trans_fh_ef;
 2669     }
 2670     elsif ($output_file_stdout) {
 2671         if (!open(OUTOFH, '>>'.$output_file_stdout)) {
 2672             ptrans(12, 'Unable to open ' . $output_file_stdout . ' for writing');
 2673             exit(1);
 2674         }
 2675         $G::trans_fh_oh = \*OUTOFH;
 2676         $G::trans_fh_of = $output_file_stdout;
 2677     }
 2678 
 2679     if (get_arg('no_hints', $o)) {
 2680         $G::no_hints_send = 1;
 2681         $G::no_hints_recv = 1;
 2682     }
 2683     else {
 2684         $G::no_hints_send      = get_arg('no_hints_send', $o);
 2685         $G::no_hints_recv      = get_arg('no_hints_recv', $o);
 2686     }
 2687     $G::dump_mail          = get_arg('dump_mail', $o);
 2688     $G::suppress_data      = get_arg('suppress_data', $o);
 2689     $G::no_hints_info      = get_arg('no_hints_info', $o);
 2690     $G::hide_send          = get_arg('hide_send', $o);
 2691     $G::hide_receive       = get_arg('hide_receive', $o);
 2692     $G::hide_informational = get_arg('hide_informational', $o);
 2693     $G::hide_all           = get_arg('hide_all', $o);
 2694     $G::show_raw_text      = get_arg('show_raw_text', $o);
 2695     $G::protect_prompt     = get_arg('protect_prompt', $o);
 2696     $G::pipeline           = get_arg('pipeline', $o);
 2697     $G::prdr               = get_arg('prdr', $o);
 2698     $G::silent             = get_arg('silent', $o) || 0;
 2699 
 2700     if (defined(my $dump_args = get_arg('dump_args', $o))) {
 2701         map { $G::dump_args{uc($_)} = 1; } (split('\s*,\s*', $dump_args)); # map comma-delim options into a hash
 2702         $G::dump_args{'ALL'} = 1 if (!scalar(keys(%G::dump_args)));        # if no options were given, just set ALL
 2703     }
 2704 
 2705     my $mail_server_t = get_arg('mail_server', $o);
 2706     my $socket_t      = get_arg('socket', $o);
 2707     my $pipe_cmd_t    = get_arg('pipe_cmd', $o);
 2708 
 2709     # it is an error if >1 of --server, --socket, or --pipe is specified
 2710     if ((defined($mail_server_t) && defined($socket_t))   ||
 2711         (defined($mail_server_t) && defined($pipe_cmd_t)) ||
 2712         (defined($pipe_cmd_t)    && defined($socket_t)))
 2713     {
 2714         ptrans(12, "Multiple transport types specified, exiting");
 2715         exit(1);
 2716     }
 2717 
 2718     my %protos = (
 2719         smtp    => { proto => 'smtp',  auth => 0, tls => '0' },
 2720         ssmtp   => { proto => 'esmtp', auth => 0, tls => 'c' },
 2721         ssmtpa  => { proto => 'esmtp', auth => 1, tls => 'c' },
 2722         smtps   => { proto => 'smtp',  auth => 0, tls => 'c' },
 2723         esmtp   => { proto => 'esmtp', auth => 0, tls => '0' },
 2724         esmtpa  => { proto => 'esmtp', auth => 1, tls => '0' },
 2725         esmtps  => { proto => 'esmtp', auth => 0, tls => 's' },
 2726         esmtpsa => { proto => 'esmtp', auth => 1, tls => 's' },
 2727         lmtp    => { proto => 'lmtp',  auth => 0, tls => '0' },
 2728         lmtpa   => { proto => 'lmtp',  auth => 1, tls => '0' },
 2729         lmtps   => { proto => 'lmtp',  auth => 0, tls => 's' },
 2730         lmtpsa  => { proto => 'lmtp',  auth => 1, tls => 's' },
 2731     );
 2732     $G::protocol            = lc(get_arg('mail_protocol', $o)) || 'esmtp';
 2733     my $tls                 = get_arg('tls', $o);
 2734     my $tls_optional        = get_arg('tls_optional', $o);
 2735     my $tls_optional_strict = get_arg('tls_optional_strict', $o);
 2736     my $tls_on_connect      = get_arg('tls_on_connect', $o);
 2737     if (!$protos{$G::protocol}) {
 2738         ptrans(12, "Unknown protocol $G::protocol specified, exiting");
 2739         exit(1);
 2740     }
 2741     my $auth_user_t            = get_arg('auth_user', $o);
 2742     my $auth_pass_t            = get_arg('auth_pass', $o);
 2743     my $auth_optional_t        = get_arg('auth_optional', $o);
 2744     my $auth_optional_strict_t = get_arg('auth_optional_strict', $o);
 2745     my $auth_t                 = get_arg('auth', $o);
 2746     if ($protos{$G::protocol}{auth} && !$auth_user_t && !$auth_pass_t && !$auth_optional_t && !$auth_optional_strict_t && !$auth_t) {
 2747         $auth_t = ''; # cause auth to be processed below
 2748     }
 2749     if ($protos{$G::protocol}{tls} && !$tls && !$tls_optional && !$tls_optional_strict && !$tls_on_connect){
 2750         # 'touch' the variable so we process it below
 2751         if ($protos{$G::protocol}{tls} eq 's') {
 2752             $tls = 1;
 2753         } elsif ($protos{$G::protocol}{tls} eq 'c') {
 2754             $tls_on_connect = 1;
 2755         }
 2756     }
 2757     $G::protocol = $protos{$G::protocol}{proto};
 2758 
 2759     # set global options for --quit-after, --drop-after, and --drop-after-send
 2760     foreach my $opt ('quit_after', 'drop_after', 'drop_after_send') {
 2761         no strict "refs";
 2762         if (my $value = get_arg($opt, $o)) {
 2763             ${"G::$opt"} = lc($value);
 2764             if (${"G::$opt"} =~ /^[el]hlo$/)        { ${"G::$opt"} = 'helo';       }
 2765             elsif (${"G::$opt"} =~ /first-[el]hlo/) { ${"G::$opt"} = 'first-helo'; }
 2766             elsif (${"G::$opt"} eq 'starttls')      { ${"G::$opt"} = 'tls';        }
 2767             elsif (${"G::$opt"} eq 'banner')        { ${"G::$opt"} = 'connect';    }
 2768             elsif (${"G::$opt"} eq 'from')          { ${"G::$opt"} = 'mail';       }
 2769             elsif (${"G::$opt"} eq 'to')            { ${"G::$opt"} = 'rcpt';       }
 2770             elsif (${"G::$opt"} ne 'connect' && ${"G::$opt"} ne 'first-helo' &&
 2771                    ${"G::$opt"} ne 'tls'     && ${"G::$opt"} ne 'helo'       &&
 2772                    ${"G::$opt"} ne 'auth'    && ${"G::$opt"} ne 'mail'       &&
 2773                    ${"G::$opt"} ne 'rcpt'    && ${"G::$opt"} ne 'xclient'    &&
 2774                    ${"G::$opt"} ne 'data'    && ${"G::$opt"} ne 'dot')
 2775             {
 2776                 ptrans(12, "Unknown $opt value " . ${"G::$opt"} . ", exiting");
 2777                 exit(1);
 2778             }
 2779             # only rcpt, data, and dot _require_ a to address
 2780             $G::server_only = 1 if (${"G::$opt"} !~ /^(rcpt|data|dot)$/);
 2781 
 2782             # data and dot aren't legal for quit_after
 2783             if ($opt eq 'quit_after' && (${"G::$opt"} eq 'data' || ${"G::$opt"} eq 'dot')) {
 2784                 ptrans(12, "Unknown $opt value " . ${"G::$opt"} . ", exiting");
 2785                 exit(1);
 2786             }
 2787         } else {
 2788             ${"G::$opt"} = '';
 2789         }
 2790     }
 2791 
 2792     # set global flag for -stl flag
 2793     $G::show_time_lapse = get_arg('show_time_lapse', $o);
 2794     if (defined($G::show_time_lapse)) {
 2795         if (length($G::show_time_lapse) && $G::show_time_lapse !~ /^i/i) {
 2796             ptrans(12, "Unknown argument '$G::show_time_lapse' to option show-time-lapse, exiting");
 2797             exit(1);
 2798         }
 2799         if (avail("hires_timing") && $G::show_time_lapse !~ /^i/i) {
 2800             $G::show_time_lapse = 'hires';
 2801         }
 2802         else {
 2803             $G::show_time_lapse = 'integer';
 2804         }
 2805     }
 2806 
 2807     # pipe command, if one is specified
 2808     if ($pipe_cmd_t) {
 2809         $G::link{process} = $pipe_cmd_t;
 2810         $G::link{type}    = 'pipe';
 2811     }
 2812 
 2813     # socket file, if one is specified
 2814     if ($socket_t) {
 2815         $G::link{sockfile} = $socket_t;
 2816         $G::link{type}     = 'socket-unix';
 2817     }
 2818 
 2819     $n{force_getpwuid} = get_arg('force_getpwuid', $o); # make available for --dump
 2820     my $user           = get_username($n{force_getpwuid});
 2821     my $hostname       = get_hostname();
 2822 
 2823     # SMTP mail from
 2824     if (!($n{from} = get_arg('mail_from', $o))) {
 2825         if ($hostname || ($G::server_only && $G::quit_after ne 'mail' && $G::drop_after ne 'mail' && $G::drop_after_send ne 'mail')) {
 2826             # if we have a hostname, or it doesn't matter anyway because we won't actually need it, use our manufactured from
 2827             $n{from} = "$user\@$hostname";
 2828         }
 2829         else {
 2830             ptrans(12, "From string required but couldn't be determined automatically.  Please use --from");
 2831             exit(1);
 2832         }
 2833     }
 2834     $n{from} = '' if ($n{from} eq '<>');
 2835 
 2836     # local interface and port
 2837     ($G::link{lint},$G::link{lport}) = parse_server(get_arg('lint', $o), get_arg('lport', $o));
 2838     if ($G::link{lport} && $G::link{lport} !~ /^\d+$/) {
 2839         if (my $port = getservbyname($G::link{lport}, 'tcp')) {
 2840             $G::link{lport} = $port;
 2841         }
 2842         else {
 2843             ptrans(12, "unable to resolve service name $G::link{lport} into a port, exiting");
 2844             exit(1);
 2845         }
 2846     }
 2847 
 2848     # SMTP helo/ehlo
 2849     if (!($n{helo} = get_arg('mail_helo', $o))) {
 2850         if ($hostname || ($G::quit_after eq 'connect' || $G::drop_after eq 'connect' || $G::drop_after_send eq 'connect')) {
 2851             # if we have a hostname, or it doesn't matter anyway because we won't actually need it, use our manufactured from
 2852             $n{helo} = $hostname;
 2853         }
 2854         else {
 2855             ptrans(12, "Helo string required but couldn't be determined automatically.  Please use --helo");
 2856             exit(1);
 2857         }
 2858     }
 2859 
 2860     # SMTP server, port and rcpt-to are interdependant, so they are handled together
 2861     $G::link{type}                    ||= 'socket-inet';
 2862     ($G::link{server},$G::link{port})   = parse_server($mail_server_t, get_arg('mail_port', $o));
 2863     $n{to}                              = get_arg('mail_to', $o);
 2864     # we absolutely must have a recipient. If we don't have one yet, prompt for one
 2865     if (!$n{to} && !($G::server_only && ($G::link{server} || $G::link{type} eq 'socket-unix' || $G::link{type} eq 'pipe'))) {
 2866         $n{to} = interact("To: ", '^.+$'); # WCSXXXFIXME I wish we could look up the prompt and re from $a
 2867     }
 2868 
 2869     # try to catch obvious -s/-li/-4/-6 errors as soon as possible.  We don't actually do any DNS
 2870     # lookups ourselves, so errors like -s being a domain with only A RRs and -li being a domain
 2871     # with only AAAA RRs, or -s being an ipv6 and -li being a domain with only A RRs, will
 2872     # get passed into the IO::Socket module to deal with and will just registed as a connection
 2873     # failure.
 2874     if ($G::link{type} eq 'socket-inet') {
 2875         my $forceIPv4 = get_arg('force_ipv4', $o);
 2876         my $forceIPv6 = get_arg('force_ipv6', $o);
 2877         if ($forceIPv4 && $forceIPv6) {
 2878             ptrans(12, "Options -4 and -6 are mutually exclusive, cannot proceed");
 2879             exit 1;
 2880         } elsif ($forceIPv6) {
 2881             $G::link{force_ipv6} = 1;
 2882         } elsif ($forceIPv4) {
 2883             $G::link{force_ipv4} = 1;
 2884         }
 2885 
 2886         if ($n{copy_routing} = get_arg('copy_routing', $o)) {
 2887             $G::link{server} ||= get_server($n{copy_routing});
 2888         }
 2889         else {
 2890             $G::link{server} ||= get_server($n{to});
 2891         }
 2892 
 2893         if ($forceIPv4 && $G::link{server} =~ m|:|) {
 2894             ptrans(12, "Option -4 is set but server appears to be ipv6, cannot proceed");
 2895             exit 1;
 2896         } elsif ($forceIPv4 && $G::link{lint} =~ m|:|) {
 2897             ptrans(12, "Option -4 is set but local-interface appears to be ipv6, cannot proceed");
 2898             exit 1;
 2899         } elsif ($forceIPv6 && $G::link{server} =~ m|^\d+\.\d+\.\d+\.\d+$|) {
 2900             ptrans(12, "Option -6 is set but server appears to be ipv4, cannot proceed");
 2901             exit 1;
 2902         } elsif ($forceIPv6 && $G::link{lint} =~ m|^\d+\.\d+\.\d+\.\d+$|) {
 2903             ptrans(12, "Option -6 is set but local-interface appears to be ipv4, cannot proceed");
 2904             exit 1;
 2905         } elsif ($G::link{server} =~ m|:| && $G::link{lint} =~ m|^\d+\.\d+\.\d+\.\d+$|) {
 2906             ptrans(12, "server is ipv6 but local-interface is ipv4, cannot proceed");
 2907             exit 1;
 2908         } elsif ($G::link{server} =~ m|^\d+\.\d+\.\d+\.\d+$| && $G::link{lint} =~ m|:|) {
 2909             ptrans(12, "server is ipv4 but local-interface is ipv6, cannot proceed");
 2910             exit 1;
 2911         }
 2912     }
 2913 
 2914     # Verify we are able to handle the requested transport
 2915     if ($G::link{type} eq 'pipe') {
 2916         if (!avail("pipe")) {
 2917             ptrans(12, avail_str("pipe").".  Exiting");
 2918             exit(10);
 2919         }
 2920     } else {
 2921         if (!avail("socket")) {
 2922             ptrans(12, avail_str("socket").".  Exiting");
 2923             exit(10);
 2924         } elsif (($G::link{force_ipv6} || $G::link{server} =~ m|:| ||  $G::link{lint} =~ m|:|) && !avail("ipv6")) {
 2925             ptrans(12, avail_str("ipv6").".  Exiting");
 2926             exit(10);
 2927         }
 2928     }
 2929 
 2930     # SMTP timeout
 2931     $G::link{timeout} = time_to_seconds(get_arg('timeout', $o) // '30s');
 2932 
 2933     my $dab_sp            = get_arg('dab_sp', $o);
 2934     my $dump_as_body      = get_arg('dump_as_body', $o);
 2935     $dump_as_body         = '' if ($dab_sp && !defined($dump_as_body));
 2936     my $body              = 'This is a test mailing'; # default message body
 2937     $body                 = 'DUMP_AS_BODY_HAS_BEEN_SET' if (defined($dump_as_body));
 2938     my $bound             = '';
 2939     my $main_content_type = 'multipart/mixed';
 2940     my $stdin             = undef;
 2941     if (defined(my $body_822_t = get_arg('body_822', $o))) {
 2942         # the --body option is the entire 822 body and trumps any other options
 2943         # that mess with the body
 2944         $body = $body_822_t;
 2945     }
 2946     my $attach_accum = get_accum('attach_accum', $o);
 2947     if (scalar(@$attach_accum)) {
 2948         # this option is a list of files (or STDIN) to attach.  In this case,
 2949         # the message become a mime message and the "body" goes in the
 2950         # first text/plain part
 2951         my $mime_type = '%SWAKS_DEFAULT_MIMETYTPE%';
 2952         my $next_name = undef();
 2953         my %parts     = ( body => [], rest => [] );
 2954         $bound        = "----=_MIME_BOUNDARY_000_$$";
 2955         foreach my $part (@$attach_accum) {
 2956             if ($part eq 'attach_type') {
 2957                 $mime_type = get_arg($part, $o);
 2958             }
 2959             elsif ($part eq 'attach_name') {
 2960                 $next_name = get_arg($part, $o);
 2961             }
 2962             elsif ($part eq 'attach_body') {
 2963                 if ($mime_type eq '%SWAKS_DEFAULT_MIMETYTPE%') {
 2964                     $mime_type = 'text/plain';
 2965                 }
 2966                 push(@{$parts{body}}, { body => get_arg($part, $o), type => $mime_type });
 2967                 $next_name = undef(); # can't set filename for body, unset next_name so random attachment doesn't get it
 2968                 $mime_type = '%SWAKS_DEFAULT_MIMETYTPE%'; # after each body, reset the default mime type
 2969             }
 2970             elsif ($part eq 'attach_attach') {
 2971                 my $name  = peek_arg($part, $o);
 2972                 my $tpart = { body => get_arg($part, $o), type => $mime_type };
 2973                 if (defined($next_name)) {
 2974                     $tpart->{name} = $next_name;
 2975                     $next_name     = undef();
 2976                 }
 2977                 else {
 2978                     my $filename = $name;
 2979                     $filename =~ s/^\@//;
 2980                     if ($name ne '-' && $filename !~ /^\@/ && $name ne $tpart->{body} && -f $filename) {
 2981                         # name will have the unprocessed arg.  If we think it came from a file, use the filename for
 2982                         # the attachment name.  Not super happy with this logic, try to improve in the future
 2983                         ($tpart->{name}) = $name =~ m|/?([^/]+)$|;
 2984                     }
 2985                 }
 2986                 push(@{$parts{rest}}, $tpart);
 2987             } else {
 2988                 ptrans(12, "Error processing attach args, unknown type $part when processing attachment options");
 2989                 exit(1);
 2990             }
 2991         }
 2992 
 2993         # if no body parts were set via --attach-body, set a text/plain body to $body
 2994         if (!scalar(@{$parts{body}})) {
 2995             push(@{$parts{body}}, { body => $body, type => 'text/plain' });
 2996         }
 2997 
 2998         $body = '';
 2999         if (!scalar(@{$parts{rest}})) {
 3000             # if there are no non-body parts
 3001             if (scalar(@{$parts{body}}) > 1) {
 3002                 $main_content_type = 'multipart/alternative';
 3003             }
 3004             else {
 3005                 $main_content_type = 'multipart/mixed';
 3006             }
 3007 
 3008             foreach my $part (@{$parts{body}}) {
 3009                 $body .= encode_mime_part($part, $bound, 1);
 3010             }
 3011         }
 3012         else {
 3013             # otherwise, there's a mixture of both body and other. multipart/mixed
 3014             $main_content_type = 'multipart/mixed';
 3015             if (scalar(@{$parts{body}}) > 1) {
 3016                 # we have multiple body parts, plus other attachments.  Need to create a mp/mixes mime object for the bodies
 3017                 my $mp_bound = "----=_MIME_BOUNDARY_004_$$";
 3018 
 3019                 $body .= "--$bound\n"
 3020                       .  'Content-Type: multipart/alternative; boundary="' . $mp_bound . '"' . "\n\n";
 3021 
 3022                 foreach my $part (@{$parts{body}}) {
 3023                     $body .= encode_mime_part($part, $mp_bound, 1);
 3024                 }
 3025                 $body .= "--$mp_bound--\n";
 3026             }
 3027             else {
 3028                 $body .= encode_mime_part($parts{body}[0], $bound, 1);
 3029             }
 3030 
 3031             # now handle the non-body attachments
 3032             foreach my $part (@{$parts{rest}}) {
 3033                 $body .= encode_mime_part($part, $bound);
 3034             }
 3035         }
 3036         $body .= "--$bound--\n";
 3037     }
 3038     $body =~ s|%SWAKS_DEFAULT_MIMETYTPE%|application/octet-stream|g;
 3039 
 3040     # SMTP DATA
 3041     $n{data} = get_arg('mail_data', $o) ||
 3042                'Date: %DATE%\nTo: %TO_ADDRESS%\nFrom: %FROM_ADDRESS%\nSubject: test %DATE%\n' .
 3043                "Message-Id: <%MESSAGEID%>\n" .
 3044                "X-Mailer: swaks v%SWAKS_VERSION% jetmore.org/john/code/swaks/".'\n' .
 3045                ($bound ? 'MIME-Version: 1.0\nContent-Type: ' . $main_content_type . '; boundary="' . $bound. '"\n' : '') .
 3046                '%NEW_HEADERS%' . # newline will be added in replacement if it exists
 3047                '\n' .
 3048                '%BODY%\n';
 3049     if (!get_arg('no_data_fixup', $o)) {
 3050         $n{data}            =~ s/%BODY%/$body/g;
 3051         $n{data}            =~ s/\\n/\r\n/g;
 3052         my $addHeader_accum =  get_accum('add_header', $o);
 3053         my $addHeaderOpt    =  [];
 3054 
 3055         foreach my $okey (@$addHeader_accum) {
 3056             push(@$addHeaderOpt, get_arg($okey, $o));
 3057         }
 3058 
 3059         # split the headers off into their own struct temporarily to make it much easier to manipulate them
 3060         my $header;
 3061         my @headers = ();
 3062         my %headers = ();
 3063 
 3064         # cut the headers off of the data
 3065         if ($n{data} =~ s/\A(.*?)\r?\n\r?\n//s) {
 3066             $header = $1;
 3067         }
 3068         else {
 3069             $header  = $n{data};
 3070             $n{data} = '';
 3071         }
 3072 
 3073         # build the header string into an object.  Each header is an array, each index is a line (to handle header continuation lines)
 3074         foreach my $headerLine (split(/\r?\n/, $header)) {
 3075             if ($headerLine =~ /^\s/) {
 3076                 # continuation line
 3077                 if (scalar(@headers)) {
 3078                     push(@{$headers[-1]}, $headerLine);
 3079                 }
 3080                 else {
 3081                     # it's illegal to have a continuation line w/o a previous header, but we're a test tool
 3082                     push(@headers, [ $headerLine ]);
 3083                 }
 3084             }
 3085             elsif ($headerLine =~ /^(\S[^:]+):/) {
 3086                 # properly formed header
 3087                 push(@headers, [ $headerLine ]);
 3088                 $headers{$1} = $headers[-1];
 3089             }
 3090             else {
 3091                 # malformed header - no colon.  Allow it anyway, we're a test tool
 3092                 push(@headers, [ $headerLine ]);
 3093                 $headers{$headerLine} = $headers[-1];
 3094             }
 3095         }
 3096 
 3097         # If the user specified headers and the header exists, replace it.  If not, push it onto add_header to be added as new
 3098         my $header_accum =  get_accum('header', $o);
 3099         my $headerOpt    =  [];
 3100         foreach my $okey (@$header_accum) {
 3101             push(@$headerOpt, get_arg($okey, $o));
 3102         }
 3103         foreach my $headerLine (map { split(/\\n/) } @{$headerOpt}) {
 3104             if (my($headerName) = $headerLine =~ /^([^:]+):/) {
 3105                 if ($headers{$headerName}) {
 3106                     $headers{$headerName}[0] = $headerLine;
 3107                     splice(@{$headers{$headerName}}, 1); # remove from index 1 onward, if they existed (possible continuations)
 3108                 }
 3109                 else {
 3110                     push(@{$addHeaderOpt}, $headerLine);
 3111                 }
 3112             }
 3113             else {
 3114                 push(@{$addHeaderOpt}, $headerLine);
 3115             }
 3116         }
 3117 
 3118         # rebuild the header using our (possibly replaced) headers
 3119         my $newHeader = '';
 3120         foreach my $headerObj (@headers) {
 3121             foreach my $line (@$headerObj) {
 3122                 $newHeader .= $line . "\r\n";
 3123             }
 3124         }
 3125 
 3126         # if there are new headers, add them as appropriate
 3127         if ($newHeader =~ /%NEW_HEADERS%/) {
 3128             $n{add_header} = join("\r\n", @{$addHeaderOpt}) . "\r\n" if (@{$addHeaderOpt});
 3129             $newHeader     =~ s/%NEW_HEADERS%/$n{add_header}/g;
 3130         } elsif (scalar(@{$addHeaderOpt})) {
 3131             foreach my $line (@{$addHeaderOpt}) {
 3132                 $newHeader .= $line . "\r\n";
 3133             }
 3134         }
 3135 
 3136         # Now re-assemble our data by adding the headers back on to the front
 3137         $n{data} = $newHeader . "\r\n" . $n{data};
 3138 
 3139         $n{data} =~ s/\\n|%NEWLINE%/\r\n/g;
 3140         $n{data} =~ s/%FROM_ADDRESS%/$n{from}/g;
 3141         $n{data} =~ s/%TO_ADDRESS%/$n{to}/g;
 3142         $n{data} =~ s/%MESSAGEID%/get_messageid()/ge;
 3143         $n{data} =~ s/%SWAKS_VERSION%/$p_version/g;
 3144         $n{data} =~ s/%DATE%/get_date_string()/ge;
 3145         $n{data} =~ s/^From [^\n]*\n// if (!get_arg('no_strip_from', $o));
 3146         $n{data} =~ s/\r?\n\.\r?\n?$//s;   # If there was a trailing dot, remove it
 3147         $n{data} =~ s/\n\./\n../g;         # quote any other leading dots
 3148         $n{data} =~ s/([^\r])\n/$1\r\n/gs;
 3149         $n{data} =~ s/([^\r])\n/$1\r\n/gs; # this identical call is not a bug, called twice to get consecutive \n correctly
 3150         $n{data} .= "\r\n.";               # add a trailing dot
 3151     }
 3152 
 3153     # Handle TLS options
 3154     # tls => 0 - no.  STARTTLS must be advertised and must succeed, else error.
 3155     #        1 - yes.  Success if not advertised, advertised and fails _or_ succeeds.
 3156     #        2 - strict.  Satisfied if not advertised, or advertised and succeeded.
 3157     #                     However, if it's advertised and fails, it's an error.
 3158     $G::tls_optional      = 1 if ($tls_optional);
 3159     $G::tls_optional      = 2 if ($tls_optional_strict);
 3160     $G::tls               = 1 if ($tls || $G::tls_optional);
 3161     $G::tls_on_connect    = 1 if ($tls_on_connect);
 3162     $G::link{tls}{active} = 0;
 3163     if ($G::tls || $G::tls_on_connect) {
 3164         if (!avail("tls")) {
 3165             if ($G::tls_optional) {
 3166                 $G::tls = undef; # so we won't try it later
 3167                 ptrans(12,avail_str("tls"));
 3168             } else {
 3169                 ptrans(12,avail_str("tls").".  Exiting");
 3170                 exit(10);
 3171             }
 3172         }
 3173         $G::tls_verify       = get_arg('tls_verify', $o);
 3174         $G::tls_sni_hostname = get_arg('tls_sni_hostname', $o);
 3175         $G::tls_cipher       = get_arg('tls_cipher', $o);
 3176         $G::tls_cert         = get_arg('tls_cert', $o);
 3177         $G::tls_key          = get_arg('tls_key', $o);
 3178         if (($G::tls_cert || $G::tls_key) && !($G::tls_cert && $G::tls_key)) {
 3179             ptrans(12, "--tls-cert and --tls-key require each other.  Exiting");
 3180             exit(1);
 3181         }
 3182         if (($G::tls_ca_path = get_arg('tls_ca_path', $o)) && !-f $G::tls_ca_path && !-d $G::tls_ca_path) {
 3183             ptrans(12, "--tls-ca-path: $G::tls_ca_path is not a valid file or directory.  Exiting.");
 3184             exit(1);
 3185         }
 3186 
 3187         # this is kind of a kludge.  There doesn't appear to be a specific openssl call to find supported
 3188         # protocols, but the OP_NO_protocol functions exist for supported protocols.  Loop through
 3189         # "known" protocols (which will unfortunately need to be added-to by hand when new protocols
 3190         # become available) to find out which of them are available (when adding new types here, see
 3191         # also the code that calls Net::SSLeay::version() and translates to a readable value
 3192         @G::tls_supported_protocols = ();
 3193         foreach my $p (qw(SSLv2 SSLv3 TLSv1 TLSv1_1 TLSv1_2 TLSv1_3)) {
 3194             eval { no strict "refs"; &{"Net::SSLeay::OP_NO_$p"}(); };
 3195             push(@G::tls_supported_protocols, $p) if (!$@);
 3196         }
 3197 
 3198         if (my $tls_protocols = get_arg('tls_protocol', $o)) {
 3199             @G::tls_protocols = ();
 3200             my @requested = split(/,\s*/, $tls_protocols);
 3201             if (my $c = scalar(grep(/^no_/i, @requested))) {
 3202                 if ($c != scalar(@requested)) {
 3203                     ptrans(12, "cannot mix X and no_X forms in --tls-protocol option");
 3204                     exit(1);
 3205                 }
 3206             }
 3207             foreach my $p (@requested) {
 3208                 my $t = $p;
 3209                 $t =~ s/^no_//i;
 3210                 if (grep /^$t$/i, @G::tls_supported_protocols) {
 3211                     push(@G::tls_protocols, $p);
 3212                 } else {
 3213                     ptrans(12, "$p in --tls-protocol is not a known/supported protocol");
 3214                 }
 3215             }
 3216             if (!scalar(@G::tls_protocols)) {
 3217                 ptrans(12, "no valid arguments provided to --tls-protocol, exiting");
 3218                 exit(1);
 3219             }
 3220         }
 3221 
 3222         $G::tls_get_peer_cert = get_arg('tls_get_peer_cert', $o);
 3223         $G::tls_get_peer_cert = 'STDOUT' if (defined($G::tls_get_peer_cert) && !length($G::tls_get_peer_cert));
 3224     }
 3225 
 3226     # SMTP port
 3227     if ($G::link{port}) {
 3228         if ($G::link{port} !~ /^\d+$/) {
 3229             if (my $port = getservbyname($G::link{port}, 'tcp')) {
 3230                 $G::link{port} = $port;
 3231             }
 3232             else {
 3233                 ptrans(12, "unable to resolve service name $G::link{port} into a port, exiting");
 3234                 exit(1);
 3235             }
 3236         }
 3237     } else {
 3238         # in here, user wants us to use default ports, so try look up services,
 3239         # use default numbers is service names don't resolve.  Never prompt user
 3240         if ($G::protocol eq 'lmtp') {
 3241             $G::link{port} = getservbyname('lmtp',  'tcp') || '24';
 3242         } elsif ($G::tls_on_connect) {
 3243             $G::link{port} = getservbyname('smtps', 'tcp') || '465';
 3244         } else {
 3245             $G::link{port} = getservbyname('smtp',  'tcp') || '25';
 3246         }
 3247     }
 3248 
 3249     # XCLIENT
 3250     { # Create a block for local variables
 3251         $G::xclient{try}     = 0;
 3252         $G::xclient{attr}    = {};
 3253         $G::xclient{strings} = [];
 3254         my @pieces           = ();
 3255         my $xclient_accum    = get_accum('xclient_accum', $o);
 3256         foreach my $attr (@$xclient_accum) {
 3257             if ($attr eq 'xclient_delim' || $attr eq 'xclient_raw') {
 3258                 if (scalar(@pieces)) {
 3259                     push(@{$G::xclient{strings}}, join(' ', @pieces));
 3260                     @pieces = ();
 3261                 }
 3262 
 3263                 if ($attr eq 'xclient_raw') {
 3264                     push(@{$G::xclient{strings}}, get_arg('xclient_raw', $o));
 3265                 }
 3266             } else {
 3267                 if (my $value = get_arg($attr, $o)) {
 3268                     $attr =~ /^xclient_(.*)$/;
 3269                     my $name = uc($1);
 3270                     $G::xclient{attr}{$name} = 1; # used later to verify that we haven't asked for an un-advertised attr
 3271                     push(@pieces, $name . '=' . to_xtext($value));
 3272                 }
 3273             }
 3274         }
 3275         push(@{$G::xclient{strings}}, join(' ', @pieces)) if (scalar(@pieces));
 3276         $G::xclient{no_verify}  = get_arg('xclient_no_verify', $o);
 3277         $G::xclient{optional}   = get_arg('xclient_optional', $o);
 3278         $G::xclient{optional}   = 2 if (get_arg('xclient_optional_strict', $o));
 3279         #$G::xclient{after}      = $o->{"xclient_after"} || interact("XCLIENT quit after: ", '^.+$')
 3280         #   if (defined($o->{"xclient_after"}));
 3281         $G::xclient{try}        = 1 if (scalar(@{$G::xclient{strings}}));
 3282         $G::xclient{before_tls} = get_arg('xclient_before_starttls', $o);
 3283     }
 3284 
 3285     # PROXY
 3286     $G::proxy{try}     = 0;
 3287     $G::proxy{attr}    = {};
 3288     $G::proxy{version} = get_arg('proxy_version', $o);
 3289     $G::proxy{raw}     = get_arg('proxy_raw', $o);
 3290     foreach my $attr ('family', 'source', 'source_port', 'dest', 'dest_port', 'protocol', 'command') {
 3291         if (my $val = get_arg('proxy_' . $attr, $o)) {
 3292             if ($G::proxy{raw}) {
 3293                 ptrans(12, "Can't mix --proxy option with other --proxy-* options");
 3294                 exit(35);
 3295             }
 3296             $G::proxy{attr}{$attr} = $val;
 3297         }
 3298     }
 3299     if ($G::proxy{version}) {
 3300         if ($G::proxy{version} != 1 && $G::proxy{version} != 2) {
 3301             ptrans(12, "Invalid argument to --proxy: $G::proxy{version} is not a legal proxy version");
 3302             exit(35);
 3303         }
 3304     }
 3305     else {
 3306         $G::proxy{version} = 1;
 3307     }
 3308     $G::proxy{try}       = 1 if ($G::proxy{raw} || scalar(keys(%{$G::proxy{attr}})));
 3309     if ($G::proxy{try} && !$G::proxy{raw}) {
 3310         $G::proxy{attr}{protocol} ||= 'STREAM';
 3311         $G::proxy{attr}{command}  ||= 'PROXY';
 3312         foreach my $attr ('family', 'source', 'source_port', 'dest', 'dest_port', 'protocol', 'command') {
 3313             if (!$G::proxy{attr}{$attr}) {
 3314                 ptrans(12, "Incomplete set of --proxy-* options (missing $attr)");
 3315                 exit(35);
 3316             }
 3317             $G::proxy{attr}{$attr} = uc($G::proxy{attr}{$attr});
 3318         }
 3319         if ($G::proxy{attr}{protocol} !~ /^(UNSPEC|STREAM|DGRAM)$/) {
 3320             ptrans(12, 'unknown --proxy-protocol argument ' . $G::proxy{attr}{protocol});
 3321             exit(35);
 3322         }
 3323         if ($G::proxy{attr}{command} !~ /^(LOCAL|PROXY)$/) {
 3324             ptrans(12, 'unknown --proxy-command argument ' . $G::proxy{attr}{command});
 3325             exit(35);
 3326         }
 3327         if ($G::proxy{version} == 2 && $G::proxy{attr}{family} !~ /^(AF_UNSPEC|AF_INET|AF_INET6|AF_UNIX)$/) {
 3328             ptrans(12, 'unknown --proxy-family argument ' . $G::proxy{attr}{family} . ' for version 2');
 3329             exit(35);
 3330         }
 3331         if ($G::proxy{version} == 1 && $G::proxy{attr}{family} !~ /^(TCP4|TCP6)$/) {
 3332             ptrans(12, 'unknown --proxy-family argument ' . $G::proxy{attr}{family} . ' for version 1');
 3333             exit(35);
 3334         }
 3335     }
 3336 
 3337     # Handle AUTH options
 3338     # auth_optional => 0 - no.     Auth must be advertised and must succeed, else error.
 3339     #                  1 - yes.    Success if not advertised, advertised and fails _or_ succeeds.
 3340     #                  2 - strict. Satisfied if not advertised, or advertised and succeeded.
 3341     #                              However, if it's advertised and fails, it's an error.
 3342     $G::auth_optional        = 1 if (defined($auth_optional_t));
 3343     $G::auth_optional        = 2 if (defined($auth_optional_strict_t));
 3344     my $auth_types_t         = [];
 3345     if ($auth_t) {
 3346         @{$auth_types_t} = map { uc($_) } (split(/,/, $auth_t));
 3347     } elsif ($auth_optional_strict_t) {
 3348         @{$auth_types_t} = map { uc($_) } (split(/,/, $auth_optional_strict_t));
 3349     } elsif ($auth_optional_t) {
 3350         @{$auth_types_t} = map { uc($_) } (split(/,/, $auth_optional_t));
 3351     } elsif (defined($auth_user_t) || defined($auth_pass_t) || $G::auth_optional || (defined($auth_t) && !$auth_t)) {
 3352         $auth_types_t->[0] = 'ANY';
 3353         $auth_t            = 'ANY'; # this is checked below
 3354         $G::auth_type      = 'ANY';
 3355     }
 3356     # if after that processing we've defined some auth type, do some more
 3357     # specific processing
 3358     if (scalar(@{$auth_types_t})) {
 3359         # there's a lot of option processing below.  If any type looks like it
 3360         # will succeed later, set this to true
 3361         my $valid_auth_found = 0;
 3362 
 3363         # handle the --auth-map options plus our default mappings
 3364         foreach (split(/\s*,\s*/, get_arg('auth_map', $o)),"PLAIN=PLAIN","LOGIN=LOGIN",
 3365                                   "CRAM-MD5=CRAM-MD5","DIGEST-MD5=DIGEST-MD5",
 3366                                   "CRAM-SHA1=CRAM-SHA1","NTLM=NTLM","SPA=NTLM","MSN=NTLM")
 3367         {
 3368             if (/^([^=]+)=(.+)$/) {
 3369                 my($alias,$type)        = ($1,$2);
 3370                 $G::auth_map_f{$alias}  = $type; # this gives us a list of all aliases pointing to types
 3371                 $G::auth_map_t{$type} ||= [];    # this gives a list of all base types and any aliases for it.
 3372                 push(@{$G::auth_map_t{$type}}, $alias);
 3373             } else {
 3374                 ptrans(12, "Unknown auth-map format '$_'");
 3375                 exit(1);
 3376             }
 3377         }
 3378         # Now handle the --auth-extra options
 3379         foreach (split(/\s*,\s*/, get_arg('auth_extra', $o))) {
 3380             if (/^([^=]+)=(.+)$/) {
 3381                 $G::auth_extras{uc($1)} = $2;
 3382             } else {
 3383                 ptrans(12, "Unknown auth-extra format '$_'");
 3384                 exit(1);
 3385             }
 3386         }
 3387         # handle the realm/domain synonyms
 3388         if ($G::auth_extras{DOMAIN}) {
 3389             $G::auth_extras{REALM}  = $G::auth_extras{DOMAIN};
 3390         } elsif ($G::auth_extras{DOMAIN}) {
 3391             $G::auth_extras{DOMAIN} = $G::auth_extras{REALM};
 3392         }
 3393         if (!avail("auth")) { # check for general auth requirements
 3394             if ($G::auth_optional == 2) {
 3395                 # we don't know yet if this is really an error.  If the server
 3396                 # doesn't advertise auth, then it's not really an error.  So just
 3397                 # save it in case we need it later
 3398                 $G::auth_unavailable = avail_str("auth");
 3399                 ptrans(12, avail_str("auth"));
 3400             } elsif ($G::auth_optional == 1) {
 3401                 ptrans(12, avail_str("auth"). ".  Skipping optional AUTH");
 3402             } else {
 3403                 ptrans(12, avail_str("auth"). ".  Exiting");
 3404                 exit(10);
 3405             }
 3406         } else {
 3407             # if the user doesn't specify an auth type, create a list from our
 3408             # auth-map data.  Simplifies processing later
 3409             if ($auth_types_t->[0] eq 'ANY') {
 3410                 $auth_types_t = [sort keys %G::auth_map_f];
 3411             }
 3412 
 3413             foreach my $type (@{$auth_types_t}) {
 3414                 # we need to evaluate whether we will be able to run the auth types
 3415                 # specified by the user
 3416                 if (!$G::auth_map_f{$type}) {
 3417                     ptrans(12, "$type is not a recognized auth type, skipping");
 3418                 } elsif ($G::auth_map_f{$type} eq 'CRAM-MD5'   && !avail("auth_cram_md5")) {
 3419                     ptrans(12, avail_str("auth_cram_md5"))   if ($auth_t ne 'ANY');
 3420                 } elsif ($G::auth_map_f{$type} eq 'CRAM-SHA1'  && !avail("auth_cram_sha1")) {
 3421                     ptrans(12, avail_str("auth_cram_sha1"))  if ($auth_t ne 'ANY');
 3422                 } elsif ($G::auth_map_f{$type} eq 'NTLM'       && !avail("auth_ntlm")) {
 3423                     ptrans(12, avail_str("auth_ntlm"))       if ($auth_t ne 'ANY');
 3424                 } elsif ($G::auth_map_f{$type} eq 'DIGEST-MD5' && !avail("auth_digest_md5")) {
 3425                     ptrans(12, avail_str("auth_digest_md5")) if ($auth_t ne 'ANY');
 3426                 } else {
 3427                     $valid_auth_found = 1;
 3428                     push(@{$n{a_type}}, $type);
 3429                 }
 3430             }
 3431 
 3432             if (!$valid_auth_found) {
 3433                 ptrans(12, "No auth types supported");
 3434                 if ($G::auth_optional == 2) {
 3435                     $G::auth_unavailable .= "No auth types supported";
 3436                 } elsif ($G::auth_optional == 1) {
 3437                     $n{a_user} = $n{a_pass} = $n{a_type} = undef;
 3438                 } else {
 3439                     exit(10);
 3440                 }
 3441             } else {
 3442                 $auth_user_t ||= obtain_from_netrc('login');
 3443                 if (!$auth_user_t) {
 3444                     my $cfg = { cfgs => OP_ARG_REQ|OP_FROM_PROMPT, prompt  => 'Username: ', match  => 'SKIP', okey => 'auth_user', akey => 'auth_user' };
 3445                     $auth_user_t = get_arg('auth_user', $o, $cfg, 1);
 3446                 }
 3447                 $n{a_user} = $auth_user_t eq '<>' ? '' : $auth_user_t;
 3448 
 3449                 $auth_pass_t ||= obtain_from_netrc('password', $n{a_user});
 3450                 if (!$auth_pass_t) {
 3451                     my $cfg = { cfgs => OP_ARG_REQ|OP_FROM_PROMPT|OP_SENSITIVE, prompt  => 'Password: ', match  => 'SKIP', okey => 'auth_pass', akey => 'auth_pass' };
 3452                     $auth_pass_t = get_arg('auth_pass', $o, $cfg, 1);
 3453                 }
 3454                 $n{a_pass} = $auth_pass_t eq '<>' ? '' : $auth_pass_t;
 3455 
 3456                 $G::auth_showpt = get_arg('auth_showpt', $o);
 3457                 $G::auth_hidepw = get_arg('auth_hidepw', $o);
 3458                 if (defined($G::auth_hidepw) && !$G::auth_hidepw) {
 3459                     $G::auth_hidepw = 'PROVIDED_BUT_REMOVED';
 3460                 }
 3461             }
 3462         } # end avail("auth")
 3463     } # end auth parsing
 3464 
 3465     # the very last thing we do is swap out the body if --dump-as-body used
 3466     if (defined($dump_as_body)) {
 3467         if ($dump_as_body) {
 3468             $dump_as_body = uc($dump_as_body);
 3469             $dump_as_body =~ s/\s//g;
 3470             map { $G::dump_as_body{$_} = 1; } (split(',', $dump_as_body));
 3471         }
 3472         else {
 3473             $G::dump_as_body{'ALL'} = 1;
 3474         }
 3475 
 3476         $n{data} =~ s|DUMP_AS_BODY_HAS_BEEN_SET|get_running_state(\%n, \%G::dump_as_body, {SUPPORT => 1, DATA => 1})|e;
 3477         if ($dab_sp) {
 3478             $n{data} =~ s|'%RAW_PASSWORD_STRING%'|shquote($n{a_pass})|eg;
 3479         } elsif ($G::auth_hidepw) {
 3480             $n{data} =~ s|'%RAW_PASSWORD_STRING%'|shquote($G::auth_hidepw)|eg;
 3481         } else {
 3482             $n{data} =~ s|'%RAW_PASSWORD_STRING%'|shquote('PROVIDED_BUT_REMOVED')|eg;
 3483         }
 3484     }
 3485 
 3486     return(\%n);
 3487 }
 3488 
 3489 sub encode_mime_part {
 3490     my $part           = shift;
 3491     my $boundary       = shift;
 3492     my $no_attach_text = shift; # if this is true and there's no name, Don't set disposition to attachment
 3493     my $text           = '';
 3494 
 3495     $text .= "--$boundary\n";
 3496     if ($part->{type} =~ m|^text/plain$|i && !$part->{name}) {
 3497         $text .= "Content-Type: $part->{type}\n\n" . $part->{body} . "\n";
 3498     }
 3499     else {
 3500         if ($part->{name}) {
 3501             $text .= "Content-Type: $part->{type}; name=\"$part->{name}\"\n"
 3502                   .  "Content-Description: $part->{name}\n"
 3503                   .  "Content-Disposition: attachment; filename=\"$part->{name}\"\n";
 3504         }
 3505         else {
 3506             $text .= "Content-Type: $part->{type}\n";
 3507             if (!($part->{type} =~ m|^text/|i && $no_attach_text)) {
 3508                 $text .= "Content-Disposition: attachment\n";
 3509             }
 3510         }
 3511         $text .= "Content-Transfer-Encoding: BASE64\n"
 3512               .  "\n" . eb64($part->{body}, "\n") . "\n";
 3513     }
 3514 
 3515 
 3516     return($text);
 3517 }
 3518 
 3519 sub parse_server {
 3520     my $server = shift;
 3521     my $port   = shift;
 3522 
 3523     if ($server =~ m|^\[([^\]]+)\]:(.*)$|) {
 3524         # [1.2.3.4]:25
 3525         # [hostname]:25
 3526         # [1:2::3]:25
 3527         return($1, $2);
 3528     } elsif ($server =~ m|^([^:]+):([^:]+)$|) {
 3529         # 1.2.3.4:25
 3530         # hostname:25
 3531         return($1, $2);
 3532     } elsif ($server =~ m|^\[?([^/\]]*)\]?/(\w+)$|) {
 3533         # 1.2.3.4/25   [1.2.3.4]/25
 3534         # hostname/25  [hostname]/25
 3535         # 1:2::3/25    [1:2::3]/25
 3536         return($1, $2);
 3537     } elsif ($server =~ m|^\[([^\]]+)\]$|) {
 3538         # [1.2.3.4]
 3539         # [hostname]
 3540         # [1:2::3]
 3541         return($1, $port);
 3542     }
 3543     return($server, $port);
 3544 }
 3545 
 3546 sub get_running_state {
 3547     my $opts      = shift;
 3548     my $dump_args = shift;
 3549     my $skip      = shift;
 3550     my @parts     = ();
 3551 
 3552     if (($dump_args->{'SUPPORT'} || $dump_args->{'ALL'}) && !$skip->{'SUPPORT'}) {
 3553         push(@parts, test_support(1));
 3554     }
 3555 
 3556     if ($dump_args->{'APP'} || $dump_args->{'ALL'}) {
 3557         push(@parts, [
 3558             'App Info:',
 3559             "  X-Mailer = $p_name v$p_version jetmore.org/john/code/swaks/",
 3560             '  Cmd Line = ' . $0 . ' ' . $G::cmdline,
 3561         ]);
 3562     }
 3563 
 3564     if ($dump_args->{'OUTPUT'} || $dump_args->{'ALL'}) {
 3565         push(@parts, [
 3566             'Output Info:',
 3567             '  show_time_lapse    = ' . ($G::show_time_lapse    ? "TRUE ($G::show_time_lapse)"  : 'FALSE'),
 3568             '  show_raw_text      = ' . ($G::show_raw_text      ? 'TRUE' : 'FALSE'),
 3569             '  suppress_data      = ' . ($G::suppress_data      ? 'TRUE' : 'FALSE'),
 3570             '  protect_prompt     = ' . ($G::protect_prompt     ? 'TRUE' : 'FALSE'),
 3571             '  no_hints_send      = ' . ($G::no_hints_send      ? 'TRUE' : 'FALSE'),
 3572             '  no_hints_recv      = ' . ($G::no_hints_recv      ? 'TRUE' : 'FALSE'),
 3573             '  no_hints_info      = ' . ($G::no_hints_info      ? 'TRUE' : 'FALSE'),
 3574             "  silent             = $G::silent",
 3575             '  dump_mail          = ' . ($G::dump_mail          ? 'TRUE' : 'FALSE'),
 3576             '  hide_send          = ' . ($G::hide_send          ? 'TRUE' : 'FALSE'),
 3577             '  hide_receive       = ' . ($G::hide_receive       ? 'TRUE' : 'FALSE'),
 3578             '  hide_informational = ' . ($G::hide_informational ? 'TRUE' : 'FALSE'),
 3579             '  hide_all           = ' . ($G::hide_all           ? 'TRUE' : 'FALSE'),
 3580             "  trans_fh_of        = $G::trans_fh_of ($G::trans_fh_oh," . \*STDOUT . ')',
 3581             "  trans_fh_ef        = $G::trans_fh_ef ($G::trans_fh_eh," . \*STDERR . ')',
 3582         ]);
 3583     }
 3584 
 3585     if ($dump_args->{'TRANSPORT'} || $dump_args->{'ALL'}) {
 3586         push(@parts, [
 3587             'Transport Info:',
 3588             "  type            = $G::link{type}"
 3589         ]);
 3590         if ($G::link{type} eq 'socket-inet') {
 3591             push(@{$parts[-1]},
 3592                 '  inet protocol   = ' . ($G::link{force_ipv4} ? '4' : ($G::link{force_ipv6} ? '6' : 'any')),
 3593                 "  server          = $G::link{server}",
 3594                 "  port            = $G::link{port}",
 3595                 "  local interface = $G::link{lint}",
 3596                 "  local port      = $G::link{lport}",
 3597                 '  copy routing    = ' . ($opts->{copy_routing} ?  $opts->{copy_routing} : 'FALSE'),
 3598             );
 3599         }
 3600         elsif ($G::link{type} eq 'socket-unix') {
 3601             push(@{$parts[-1]}, "  sockfile        = $G::link{sockfile}");
 3602         }
 3603         elsif ($G::link{type} eq 'pipe') {
 3604             push(@{$parts[-1]}, "  process         = $G::link{process}");
 3605         }
 3606         else {
 3607             push(@{$parts[-1]}, "  UNKNOWN TRANSPORT TYPE");
 3608         }
 3609     }
 3610 
 3611     if ($dump_args->{'PROTOCOL'} || $dump_args->{'ALL'}) {
 3612         push(@parts, [
 3613             'Protocol Info:',
 3614             "  protocol        = $G::protocol",
 3615             "  helo            = $opts->{helo}",
 3616             "  from            = $opts->{from}",
 3617             "  to              = $opts->{to}",
 3618             '  force getpwuid  = ' . ($opts->{force_getpwuid} ? 'TRUE' : 'FALSE'),
 3619             "  quit after      = $G::quit_after",
 3620             "  drop after      = $G::drop_after",
 3621             "  drop after send = $G::drop_after_send",
 3622             '  server_only     = ' . ($G::server_only ? 'TRUE' : 'FALSE'),
 3623             "  timeout         = $G::link{timeout}",
 3624             '  pipeline        = ' . ($G::pipeline    ? 'TRUE' : 'FALSE'),
 3625             '  prdr            = ' . ($G::prdr        ? 'TRUE' : 'FALSE'),
 3626         ]);
 3627     }
 3628 
 3629     if ($dump_args->{'XCLIENT'} || $dump_args->{'ALL'}) {
 3630         push(@parts, ['XCLIENT Info:']);
 3631         if ($G::xclient{try}) {
 3632             if ($G::xclient{optional} == 2)    { push(@{$parts[-1]}, '  xclient         = optional-strict'); }
 3633             elsif ($G::xclient{optional} == 1) { push(@{$parts[-1]}, '  xclient         = optional');        }
 3634             else                               { push(@{$parts[-1]}, '  xclient         = required');        }
 3635             push(@{$parts[-1]},
 3636                 '  no_verify       = ' . ($G::xclient{no_verify}  ? 'TRUE' : 'FALSE'),
 3637                 '  before starttls = ' . ($G::xclient{before_tls} ? 'TRUE' : 'FALSE'),
 3638             );
 3639             for (my $i = 0; $i < scalar(@{$G::xclient{strings}}); $i++) {
 3640                 my $prefix = $i ? '                   ' : '  strings         =';
 3641                 push(@{$parts[-1]}, "$prefix XCLIENT $G::xclient{strings}[$i]");
 3642             }
 3643         } else {
 3644             push(@{$parts[-1]}, '  xclient = no');
 3645         }
 3646     }
 3647 
 3648     if ($dump_args->{'PROXY'} || $dump_args->{'ALL'}) {
 3649         push(@parts, ['PROXY Info:']);
 3650         if ($G::proxy{try}) {
 3651             push(@{$parts[-1]}, '  proxy       = yes');
 3652             push(@{$parts[-1]}, "  version     = $G::proxy{version}");
 3653             if ($G::proxy{raw}) {
 3654                 push(@{$parts[-1]}, "  raw string  = $G::proxy{raw}");
 3655             } else {
 3656                 push(@{$parts[-1]},
 3657                     '  family      = ' . $G::proxy{attr}{family},
 3658                     '  source      = ' . $G::proxy{attr}{source},
 3659                     '  source port = ' . $G::proxy{attr}{source_port},
 3660                     '  dest        = ' . $G::proxy{attr}{dest},
 3661                     '  dest port   = ' . $G::proxy{attr