mirror of
https://github.com/captn3m0/Scripts.git
synced 2024-09-27 22:22:53 +00:00
3827 lines
143 KiB
Perl
Executable File
3827 lines
143 KiB
Perl
Executable File
#!/usr/bin/perl
|
|
|
|
# use 'swaks --help' to view documentation for this program
|
|
#
|
|
# Homepage: http://jetmore.org/john/code/swaks/
|
|
# Online Docs: http://jetmore.org/john/code/swaks/latest/doc/ref.txt
|
|
# http://jetmore.org/john/code/swaks/faq.html
|
|
# Announce List: send mail to updates-swaks@jetmore.net
|
|
# Project RSS: http://jetmore.org/john/blog/c/swaks/feed/
|
|
# Twitter: http://www.twitter.com/SwaksSMTP
|
|
|
|
use strict;
|
|
|
|
$| = 1;
|
|
my($p_name) = $0 =~ m|/?([^/]+)$|;
|
|
my $p_version = build_version("DEVRELEASE", '$Id$');
|
|
my $p_usage = "Usage: $p_name [--help|--version] (see --help for details)";
|
|
my $p_cp = <<'EOM';
|
|
Copyright (c) 2003-2008,2010-2019 John Jetmore <jj33@pobox.com>
|
|
|
|
This program is free software; you can redistribute it and/or modify
|
|
it under the terms of the GNU General Public License as published by
|
|
the Free Software Foundation; either version 2 of the License, or
|
|
(at your option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
GNU General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License
|
|
along with this program; if not, write to the Free Software
|
|
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
|
|
EOM
|
|
|
|
# Get all input provided to our program, via file, env, command line, etc
|
|
my %O = %{ load_args() };
|
|
|
|
# before we do anything else, check for --help and --version
|
|
if (get_arg('help', \%O)) {
|
|
ext_usage();
|
|
exit;
|
|
}
|
|
if (get_arg('version', \%O)) {
|
|
print "$p_name version $p_version\n\n$p_cp\n";
|
|
exit;
|
|
}
|
|
|
|
# Get our functional dependencies and then print and exit early if requested
|
|
load_dependencies();
|
|
if (get_arg('get_support', \%O)) {
|
|
test_support();
|
|
exit(0);
|
|
}
|
|
|
|
# This 'synthetic' command line used for debug and reference
|
|
$G::cmdline = reconstruct_options(\%O);
|
|
|
|
# We need to fix things up a bit and set a couple of global options
|
|
my $opts = process_args(\%O);
|
|
|
|
if (scalar(keys(%G::dump_args))) {
|
|
if (my $running_state = get_running_state($opts, \%G::dump_args)) {
|
|
# --dump is intended as a debug tool for swaks internally. Always,
|
|
# unconditionally, show the user's auth password if one is given
|
|
$running_state =~ s/'%RAW_PASSWORD_STRING%'/shquote($opts->{a_pass})/ge;
|
|
print $G::trans_fh_oh $running_state;
|
|
}
|
|
exit(0);
|
|
}
|
|
elsif ($G::dump_mail) {
|
|
# if the user just wanted to generate an email body, dump it now and exit
|
|
$opts->{data} =~ s/\n\.\Z//;
|
|
print $G::trans_fh_oh $opts->{data};
|
|
exit(0);
|
|
}
|
|
|
|
# we're going to abstract away the actual connection layer from the mail
|
|
# process, so move the act of connecting into its own sub. The sub will
|
|
# set info in global hash %G::link
|
|
# XXX instead of passing raw data, have processs_opts create a link_data
|
|
# XXX hash that we can pass verbatim here
|
|
open_link();
|
|
|
|
sendmail($opts->{from}, $opts->{to}, $opts->{helo}, $opts->{data},
|
|
$opts->{a_user}, $opts->{a_pass}, $opts->{a_type});
|
|
|
|
teardown_link();
|
|
|
|
exit(0);
|
|
|
|
sub teardown_link {
|
|
if ($G::link{type} eq 'socket-inet' || $G::link{type} eq 'socket-unix') {
|
|
# XXX need anything special for tls teardown?
|
|
close($G::link{sock});
|
|
ptrans(11, "Connection closed with remote host.");
|
|
} elsif ($G::link{type} eq 'pipe') {
|
|
delete($SIG{PIPE});
|
|
$SIG{CHLD} = 'IGNORE';
|
|
close($G::link{sock}{wr});
|
|
close($G::link{sock}{re});
|
|
ptrans(11, "Connection closed with child process.");
|
|
}
|
|
}
|
|
|
|
sub open_link {
|
|
if ($G::link{type} eq 'socket-inet') {
|
|
ptrans(11, 'Trying ' . $G::link{server} . ':' . $G::link{port} . '...');
|
|
$@ = "";
|
|
|
|
my @extra_options = ();
|
|
push(@extra_options, "LocalAddr", $G::link{lint}) if ($G::link{lint});
|
|
push(@extra_options, "LocalPort", $G::link{lport}) if ($G::link{lport});
|
|
|
|
# INET6 also supports v4, so use it for everything if it's available. That
|
|
# allows the module to handle A vs AAAA records on domain lookups where the
|
|
# user hasn't set a specific ip version to be used. If INET6 isn't available
|
|
# and it's a domain that only has AAAA records, INET will just handle it like
|
|
# a bogus record and we just won't be able to connect
|
|
if (avail("ipv6")) {
|
|
if ($G::link{force_ipv6}) {
|
|
push(@extra_options, "Domain", Socket::AF_INET6() );
|
|
} elsif ($G::link{force_ipv4}) {
|
|
push(@extra_options, "Domain", Socket::AF_INET() );
|
|
}
|
|
|
|
$G::link{sock} = IO::Socket::INET6->new(
|
|
PeerAddr => $G::link{server},
|
|
PeerPort => $G::link{port},
|
|
Proto => 'tcp',
|
|
Timeout => $G::link{timeout},
|
|
@extra_options
|
|
);
|
|
} else {
|
|
$G::link{sock} = IO::Socket::INET->new(
|
|
PeerAddr => $G::link{server},
|
|
PeerPort => $G::link{port},
|
|
Proto => 'tcp',
|
|
Timeout => $G::link{timeout},
|
|
@extra_options
|
|
);
|
|
}
|
|
|
|
if ($@) {
|
|
ptrans(12, "Error connecting" . ($G::link{lint} ? " $G::link{lint}" : '') .
|
|
" to $G::link{server}:$G::link{port}:\n\t$@");
|
|
exit(2);
|
|
}
|
|
ptrans(11, "Connected to $G::link{server}.");
|
|
} elsif ($G::link{type} eq 'socket-unix') {
|
|
ptrans(11, 'Trying ' . $G::link{sockfile} . '...');
|
|
$SIG{PIPE} = 'IGNORE';
|
|
$@ = "";
|
|
$G::link{sock} = IO::Socket::UNIX->new(Peer => $G::link{sockfile}, Timeout => $G::link{timeout});
|
|
|
|
if ($@) {
|
|
ptrans(12, 'Error connecting to ' . $G::link{sockfile} . ":\n\t$@");
|
|
exit(2);
|
|
}
|
|
ptrans(11, 'Connected to ' . $G::link{sockfile} . '.');
|
|
} elsif ($G::link{type} eq 'pipe') {
|
|
$SIG{PIPE} = 'IGNORE';
|
|
$SIG{CHLD} = 'IGNORE';
|
|
ptrans(11, "Trying pipe to $G::link{process}...");
|
|
eval{ open2($G::link{sock}{re}, $G::link{sock}{wr}, $G::link{process}); };
|
|
|
|
if ($@) {
|
|
ptrans(12, 'Error connecting to ' . $G::link{process} . ":\n\t$@");
|
|
exit(2);
|
|
}
|
|
select((select($G::link{sock}{wr}), $| = 1)[0]);
|
|
select((select($G::link{sock}{re}), $| = 1)[0]);
|
|
ptrans(11, 'Connected to ' . $G::link{process} . '.');
|
|
} else {
|
|
ptrans(12, 'Unknown or unimplemented connection type ' . $G::link{type});
|
|
exit(3);
|
|
}
|
|
}
|
|
|
|
sub sendmail {
|
|
my $from = shift; # envelope-from
|
|
my $to = shift; # envelope-to
|
|
my $helo = shift; # who am I?
|
|
my $data = shift; # body of message (content after DATA command)
|
|
my $a_user = shift; # what user to auth with?
|
|
my $a_pass = shift; # what pass to auth with
|
|
my $a_type = shift; # what kind of auth (this must be set to to attempt)
|
|
my $ehlo = {}; # If server is esmtp, save advertised features here
|
|
|
|
do_smtp_proxy() if ($G::proxy{try});
|
|
|
|
# start up tls if -tlsc specified
|
|
if ($G::tls_on_connect) {
|
|
if (start_tls()) {
|
|
tls_post_start();
|
|
do_smtp_drop() if ($G::drop_after eq 'tls');
|
|
do_smtp_quit(1, 0) if ($G::quit_after eq 'tls');
|
|
} else {
|
|
ptrans(12, "TLS startup failed ($G::link{tls}{res})");
|
|
exit(29);
|
|
}
|
|
}
|
|
|
|
# read the server's 220 banner.
|
|
do_smtp_gen(undef, '220') || do_smtp_quit(1, 21);
|
|
do_smtp_drop() if ($G::drop_after eq 'connect');
|
|
do_smtp_quit(1, 0) if ($G::quit_after eq 'connect');
|
|
|
|
# Send a HELO string
|
|
$G::drop_before_read = 1 if ($G::drop_after_send eq 'first-helo');
|
|
do_smtp_helo($helo, $ehlo, $G::protocol) || do_smtp_quit(1, 22);
|
|
do_smtp_drop() if ($G::drop_after eq 'first-helo');
|
|
do_smtp_quit(1, 0) if ($G::quit_after eq 'first-helo');
|
|
|
|
if ($G::xclient{before_tls}) {
|
|
xclient_try($helo, $ehlo);
|
|
}
|
|
|
|
# handle TLS here if user has requested it
|
|
if ($G::tls) {
|
|
# 0 = tls succeeded
|
|
# 1 = tls not advertised
|
|
# 2 = tls advertised and attempted negotiations failed
|
|
# note there's some duplicate logic here (with process_args) but I think
|
|
# it's best to do as thorough a job covering the options in both places
|
|
# so as to minimize chance of options falling through the cracks
|
|
$G::drop_before_read = 1 if ($G::drop_after_send eq 'tls');
|
|
my $result = do_smtp_tls($ehlo);
|
|
if ($result == 1) {
|
|
ptrans(12, "Host did not advertise STARTTLS");
|
|
do_smtp_quit(1, 29) if (!$G::tls_optional);
|
|
} elsif ($result == 2) {
|
|
ptrans(12, "STARTTLS attempted but failed");
|
|
exit(29) if ($G::tls_optional != 1);
|
|
}
|
|
} elsif ($G::tls_optional == 2 && $ehlo->{STARTTLS}) {
|
|
ptrans(12, "TLS requested, advertised, and locally unavailable. Exiting");
|
|
do_smtp_quit(1, 29);
|
|
}
|
|
do_smtp_drop() if ($G::drop_after eq 'tls');
|
|
do_smtp_quit(1, 0) if ($G::quit_after eq 'tls');
|
|
|
|
if (!$G::xclient{before_tls}) {
|
|
xclient_try($helo, $ehlo);
|
|
}
|
|
|
|
#if ($G::link{tls}{active} && $ehlo->{STARTTLS}) {
|
|
if ($G::link{tls}{active} && !$G::tls_on_connect) {
|
|
# According to RFC3207, we need to forget state info and re-EHLO here
|
|
$ehlo = {};
|
|
$G::drop_before_read = 1 if ($G::drop_after_send eq 'helo');
|
|
do_smtp_helo($helo, $ehlo, $G::protocol) || do_smtp_quit(1, 32);
|
|
}
|
|
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
|
|
do_smtp_drop() if ($G::drop_after eq 'helo');
|
|
do_smtp_quit(1, 0) if ($G::quit_after eq 'helo');
|
|
|
|
# handle auth here if user has requested it
|
|
if ($a_type) {
|
|
# 0 = auth succeeded
|
|
# 1 = auth not advertised
|
|
# 2 = auth advertised but not attempted, no matching auth types
|
|
# 3 = auth advertised but not attempted, auth not supported
|
|
# 4 = auth advertised and attempted but no type succeeded
|
|
# note there's some duplicate logic here (with process_args) but I think
|
|
# it's best to do as thorough a job covering the options in both places
|
|
# so as to minimize chance of options falling through the cracks
|
|
$G::drop_before_read = 1 if ($G::drop_after_send eq 'auth');
|
|
my $result = do_smtp_auth($ehlo, $a_type, $a_user, $a_pass);
|
|
if ($result == 1) {
|
|
ptrans(12, "Host did not advertise authentication");
|
|
do_smtp_quit(1, 28) if (!$G::auth_optional);
|
|
} elsif ($result == 2) {
|
|
if ($G::auth_type eq 'ANY') {
|
|
ptrans(12, "Auth not attempted, no advertised types available");
|
|
do_smtp_quit(1, 28) if ($G::auth_optional != 1);
|
|
} else {
|
|
ptrans(12, "Auth not attempted, requested type not available");
|
|
do_smtp_quit(1, 28) if (!$G::auth_optional);
|
|
}
|
|
} elsif ($result == 3) {
|
|
ptrans(12, "Auth advertised but not supported locally");
|
|
do_smtp_quit(1, 28) if ($G::auth_optional != 1);
|
|
} elsif ($result == 4) {
|
|
ptrans(12, "No authentication type succeeded");
|
|
do_smtp_quit(1, 28) if ($G::auth_optional != 1);
|
|
}
|
|
} elsif ($G::auth_optional == 2 && $ehlo->{AUTH}) {
|
|
ptrans(12, "Auth requested, advertised, and locally unavailable. Exiting");
|
|
do_smtp_quit(1, 28);
|
|
}
|
|
do_smtp_drop() if ($G::drop_after eq 'auth');
|
|
do_smtp_quit(1, 0) if ($G::quit_after eq 'auth');
|
|
|
|
# send MAIL
|
|
# 0 = mail succeeded
|
|
# 1 = prdr required but not advertised
|
|
$G::drop_before_read = 1 if ($G::drop_after_send eq 'mail');
|
|
my $result = do_smtp_mail($ehlo, $from); # failures in this handled by smtp_mail_callback
|
|
if ($result == 1) {
|
|
ptrans(12, "Host did not advertise PRDR support");
|
|
do_smtp_quit(1, 30);
|
|
}
|
|
do_smtp_drop() if ($G::drop_after eq 'mail');
|
|
do_smtp_quit(1, 0) if ($G::quit_after eq 'mail');
|
|
|
|
# send RCPT (sub handles multiple, comma-delimited recips)
|
|
$G::drop_before_read = 1 if ($G::drop_after_send eq 'rcpt');
|
|
do_smtp_rcpt($to); # failures in this handled by smtp_rcpt_callback
|
|
# note that smtp_rcpt_callback increments
|
|
# $G::smtp_rcpt_failures at every failure. This and
|
|
# $G::smtp_rcpt_total are used after DATA for LMTP
|
|
do_smtp_drop() if ($G::drop_after eq 'rcpt');
|
|
do_smtp_quit(1, 0) if ($G::quit_after eq 'rcpt');
|
|
|
|
# send DATA
|
|
$G::drop_before_read = 1 if ($G::drop_after_send eq 'data');
|
|
do_smtp_gen('DATA', '354') || do_smtp_quit(1, 25);
|
|
do_smtp_drop() if ($G::drop_after eq 'data');
|
|
|
|
# send the actual data
|
|
$G::drop_before_read = 1 if ($G::drop_after_send eq 'dot');
|
|
do_smtp_data($data, $G::suppress_data) || do_smtp_quit(1, 26);
|
|
do_smtp_drop() if ($G::drop_after eq 'dot');
|
|
|
|
# send QUIT
|
|
do_smtp_quit(0) || do_smtp_quit(1, 27);
|
|
}
|
|
|
|
sub xclient_try {
|
|
my $helo = shift;
|
|
my $ehlo = shift;
|
|
|
|
if ($G::xclient{try}) {
|
|
# 0 - xclient succeeded normally
|
|
# 1 - xclient not advertised
|
|
# 2 - xclient advertised but not attempted, mismatch in requested attrs
|
|
# 3 - xclient attempted but did not succeed
|
|
$G::drop_before_read = 1 if ($G::drop_after_send eq 'xclient');
|
|
my $result = do_smtp_xclient($ehlo);
|
|
if ($result == 1) {
|
|
ptrans(12, "Host did not advertise XCLIENT");
|
|
do_smtp_quit(1, 33) if (!$G::xclient{optional});
|
|
} elsif ($result == 2) {
|
|
ptrans(12, "Host did not advertise requested XCLIENT attributes");
|
|
do_smtp_quit(1, 33) if (!$G::xclient{optional});
|
|
} elsif ($result == 3) {
|
|
ptrans(12, "XCLIENT attempted but failed. Exiting");
|
|
do_smtp_quit(1, 33) if ($G::xclient{optional} != 1);
|
|
} else {
|
|
do_smtp_drop() if ($G::drop_after eq 'xclient');
|
|
do_smtp_quit(1, 0) if ($G::quit_after eq 'xclient');
|
|
|
|
# re-helo if the XCLIENT command succeeded
|
|
$G::drop_before_read = 1 if ($G::drop_after_send eq 'helo');
|
|
do_smtp_helo($helo, $ehlo, $G::protocol) || do_smtp_quit(1, 34);
|
|
do_smtp_drop() if ($G::drop_after eq 'helo');
|
|
do_smtp_quit(1, 0) if ($G::quit_after eq 'helo');
|
|
}
|
|
}
|
|
}
|
|
|
|
sub tls_post_start {
|
|
ptrans(11, "TLS started with cipher $G::link{tls}{cipher_string}");
|
|
if ($G::link{tls}{local_cert_subject}) {
|
|
ptrans(11, "TLS local DN=\"$G::link{tls}{local_cert_subject}\"");
|
|
} else {
|
|
ptrans(11, "TLS no local certificate set");
|
|
}
|
|
ptrans(11, "TLS peer DN=\"$G::link{tls}{cert_subject}\"");
|
|
|
|
if ($G::tls_get_peer_cert eq 'STDOUT') {
|
|
ptrans(11, $G::link{tls}{cert_x509});
|
|
} elsif ($G::tls_get_peer_cert) {
|
|
open(CERT, ">$G::tls_get_peer_cert") ||
|
|
ptrans(12, "Couldn't open $G::tls_get_peer_cert for writing: $!");
|
|
print CERT $G::link{tls}{cert_x509}, "\n";
|
|
close(CERT);
|
|
}
|
|
}
|
|
|
|
sub start_tls {
|
|
my %t = (); # This is a convenience var to access $G::link{tls}{...}
|
|
$G::link{tls} = \%t;
|
|
|
|
Net::SSLeay::load_error_strings();
|
|
Net::SSLeay::SSLeay_add_ssl_algorithms();
|
|
Net::SSLeay::randomize();
|
|
if (!($t{con} = Net::SSLeay::CTX_new())) {
|
|
$t{res} = "CTX_new(): " . Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
|
|
return(0);
|
|
}
|
|
|
|
my $ctx_options = &Net::SSLeay::OP_ALL;
|
|
if (scalar(@G::tls_protocols)) {
|
|
if ($G::tls_protocols[0] =~ /^no_/i) {
|
|
foreach my $p (@G::tls_supported_protocols) {
|
|
if (grep /^no_$p$/i, @G::tls_protocols) {
|
|
no strict "refs";
|
|
$ctx_options |= &{"Net::SSLeay::OP_NO_$p"}();
|
|
}
|
|
}
|
|
} else {
|
|
foreach my $p (@G::tls_supported_protocols) {
|
|
if (!grep /^$p$/i, @G::tls_protocols) {
|
|
no strict "refs";
|
|
$ctx_options |= &{"Net::SSLeay::OP_NO_$p"}();
|
|
}
|
|
}
|
|
}
|
|
}
|
|
Net::SSLeay::CTX_set_options($t{con}, $ctx_options);
|
|
Net::SSLeay::CTX_set_verify($t{con}, 0x01, 0) if ($G::tls_verify);
|
|
|
|
if ($G::tls_ca_path) {
|
|
my @args = ('', $G::tls_ca_path);
|
|
@args = ($G::tls_ca_path, '') if (-f $G::tls_ca_path);
|
|
if (!Net::SSLeay::CTX_load_verify_locations($t{con}, @args)) {
|
|
$t{res} = "Unable to set set CA path to (" . join(',', @args) . "): "
|
|
. Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
|
|
return(0);
|
|
}
|
|
} else {
|
|
Net::SSLeay::CTX_set_default_verify_paths($t{con});
|
|
}
|
|
|
|
if ($G::tls_cipher) {
|
|
if (!Net::SSLeay::CTX_set_cipher_list($t{con}, $G::tls_cipher)) {
|
|
$t{res} = "Unable to set cipher list to $G::tls_cipher: "
|
|
. Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
|
|
return(0);
|
|
}
|
|
}
|
|
if ($G::tls_cert && $G::tls_key) {
|
|
if (!Net::SSLeay::CTX_use_certificate_file($t{con}, $G::tls_cert, &Net::SSLeay::FILETYPE_PEM)) {
|
|
$t{res} = "Unable to add cert file $G::tls_cert to SSL CTX: "
|
|
. Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
|
|
return(0);
|
|
}
|
|
if (!Net::SSLeay::CTX_use_PrivateKey_file($t{con}, $G::tls_key, &Net::SSLeay::FILETYPE_PEM)) {
|
|
$t{res} = "Unable to add key file $G::tls_key to SSL CTX: "
|
|
. Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
|
|
return(0);
|
|
}
|
|
}
|
|
|
|
if (!($t{ssl} = Net::SSLeay::new($t{con}))) {
|
|
$t{res} = "new(): " . Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
|
|
return(0);
|
|
}
|
|
|
|
if ($G::tls_sni_hostname) {
|
|
if (!Net::SSLeay::set_tlsext_host_name($t{ssl}, $G::tls_sni_hostname)) {
|
|
$t{res} = "Unable to set SNI hostname to $G::tls_sni_hostname: "
|
|
. Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
|
|
return(0);
|
|
}
|
|
}
|
|
|
|
if ($G::link{type} eq 'pipe') {
|
|
Net::SSLeay::set_wfd($t{ssl}, fileno($G::link{sock}{wr})); # error check?
|
|
Net::SSLeay::set_rfd($t{ssl}, fileno($G::link{sock}{re})); # error check?
|
|
} else {
|
|
Net::SSLeay::set_fd($t{ssl}, fileno($G::link{sock})); # error check?
|
|
}
|
|
|
|
$t{active} = Net::SSLeay::connect($t{ssl}) == 1 ? 1 : 0;
|
|
if (!$t{active}) {
|
|
$t{res} = "connect(): " . Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
|
|
return(0);
|
|
}
|
|
|
|
# egrep 'define.*VERSION\b' *.h
|
|
# when adding new types here, see also the code that pushes supported values onto tls_supported_protocols
|
|
$t{version} = Net::SSLeay::version($t{ssl});
|
|
if ($t{version} == 0x0002) {
|
|
$t{version} = "SSLv2"; # openssl/ssl2.h
|
|
} elsif ($t{version} == 0x0300) {
|
|
$t{version} = "SSLv3"; # openssl/ssl3.h
|
|
} elsif ($t{version} == 0x0301) {
|
|
$t{version} = "TLSv1"; # openssl/tls1.h
|
|
} elsif ($t{version} == 0x0302) {
|
|
$t{version} = "TLSv1.1"; # openssl/tls1.h
|
|
} elsif ($t{version} == 0x0303) {
|
|
$t{version} = "TLSv1.2"; # openssl/tls1.h
|
|
} elsif ($t{version} == 0x0304) {
|
|
$t{version} = "TLSv1.3"; # openssl/tls1.h
|
|
} elsif ($t{version} == 0xFEFF) {
|
|
$t{version} = "DTLSv1"; # openssl/dtls1.h
|
|
} elsif ($t{version} == 0xFEFD) {
|
|
$t{version} = "DTLSv1.2"; # openssl/dtls1.h
|
|
} else {
|
|
$t{version} = sprintf("UNKNOWN(0x%04X)", $t{version});
|
|
}
|
|
$t{cipher} = Net::SSLeay::get_cipher($t{ssl});
|
|
if (!$t{cipher}) {
|
|
$t{res} = "empty response from get_cipher()";
|
|
return(0);
|
|
}
|
|
$t{cipher_bits} = Net::SSLeay::get_cipher_bits($t{ssl}, undef);
|
|
if (!$t{cipher_bits}) {
|
|
$t{res} = "empty response from get_cipher_bits()";
|
|
return(0);
|
|
}
|
|
$t{cipher_string} = sprintf("%s:%s:%s", $t{version}, $t{cipher}, $t{cipher_bits});
|
|
$t{cert} = Net::SSLeay::get_peer_certificate($t{ssl});
|
|
if (!$t{cert}) {
|
|
$t{res} = "error response from get_peer_certificate()";
|
|
return(0);
|
|
}
|
|
chomp($t{cert_x509} = Net::SSLeay::PEM_get_string_X509($t{cert}));
|
|
$t{cert_subject} = Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_subject_name($t{cert}));
|
|
|
|
if ($G::tls_cert && $G::tls_key) {
|
|
$t{local_cert} = Net::SSLeay::get_certificate($t{ssl});
|
|
chomp($t{local_cert_x509} = Net::SSLeay::PEM_get_string_X509($t{local_cert}));
|
|
$t{local_cert_subject} = Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_subject_name($t{local_cert}));
|
|
}
|
|
|
|
return($t{active});
|
|
}
|
|
|
|
sub deprecate {
|
|
my $message = shift;
|
|
|
|
ptrans(12, "DEPRECATION WARNING: $message");
|
|
}
|
|
|
|
sub ptrans {
|
|
my $c = shift; # transaction flag
|
|
my $m = shift; # message to print
|
|
my $b = shift; # be brief in what we print
|
|
my $a = shift; # return the message in an array ref instead of printing
|
|
my $o = $G::trans_fh_oh || \*STDOUT;
|
|
my $f = '';
|
|
|
|
return if (($G::hide_send && int($c/10) == 2) ||
|
|
($G::hide_receive && int($c/10) == 3) ||
|
|
($G::hide_informational && $c == 11) ||
|
|
($G::hide_all));
|
|
|
|
# global option silent controls what we echo to the terminal
|
|
# 0 - print everything
|
|
# 1 - don't show anything until you hit an error, then show everything
|
|
# received after that (done by setting option to 0 on first error)
|
|
# 2 - don't show anything but errors
|
|
# >=3 - don't print anything
|
|
if ($G::silent > 0) {
|
|
return if ($G::silent >= 3);
|
|
return if ($G::silent == 2 && $c%2 != 0);
|
|
if ($G::silent == 1 && !$G::ptrans_seen_error) {
|
|
if ($c%2 != 0) {
|
|
return();
|
|
} else {
|
|
$G::ptrans_seen_error = 1;
|
|
}
|
|
}
|
|
}
|
|
|
|
# 1x is program messages
|
|
# 2x is smtp send
|
|
# 3x is smtp recv
|
|
# x = 1 is info/normal
|
|
# x = 2 is error
|
|
# x = 3 dump output
|
|
# program info
|
|
if ($c == 11) { $f = $G::no_hints_info ? '' : '==='; }
|
|
# program error
|
|
elsif ($c == 12) { $f = $G::no_hints_info ? '' : '***'; $o = $G::trans_fh_eh || \*STDERR; }
|
|
# smtp send info
|
|
elsif ($c == 21) { $f = $G::no_hints_send ? '' : ($G::link{tls}{active} ? ' ~>' : ' ->'); }
|
|
# smtp send error
|
|
elsif ($c == 22) { $f = $G::no_hints_send ? '' : ($G::link{tls}{active} ? '*~>' : '**>'); }
|
|
# smtp send dump output
|
|
elsif ($c == 23) { $f = $G::no_hints_send ? '' : ' >'; }
|
|
# smtp recv info
|
|
elsif ($c == 31) { $f = $G::no_hints_recv ? '' : ($G::link{tls}{active} ? '<~ ' : '<- '); }
|
|
# smtp recv error
|
|
elsif ($c == 32) { $f = $G::no_hints_recv ? '' : ($G::link{tls}{active} ? '<~*' : '<**'); }
|
|
# smtp recv dump output
|
|
elsif ($c == 33) { $f = $G::no_hints_recv ? '' : '< '; }
|
|
# something went unexpectedly
|
|
else { $f = '???'; }
|
|
|
|
$f .= ' ' if ($f);
|
|
|
|
if ($b) {
|
|
# split to tmp list to prevent -w gripe
|
|
my @t = split(/\n/ms, $m); $m = scalar(@t) . " lines sent";
|
|
}
|
|
$m =~ s/\n/\n$f/msg;
|
|
|
|
if ($a) {
|
|
$m = "$f$m";
|
|
return([ split(/\n/, $m) ]);
|
|
}
|
|
else {
|
|
print $o "$f$m\n";
|
|
}
|
|
}
|
|
|
|
sub do_smtp_quit {
|
|
my $exit = shift;
|
|
my $err = shift;
|
|
|
|
# Ugh. Because PIPELINING allows mail's and rcpt's send to be disconnected,
|
|
# and possibly with a QUIT between them, we need to set a global "we have
|
|
# told the server we quit already" flag to prevent double-quits
|
|
return(1) if ($G::link{quit_sent});
|
|
$G::link{quit_sent} = 1;
|
|
|
|
$G::link{allow_lost_cxn} = 1;
|
|
my $r = do_smtp_gen('QUIT', '221');
|
|
$G::link{allow_lost_cxn} = 0;
|
|
|
|
handle_disconnect($err) if ($G::link{lost_cxn});
|
|
|
|
if ($exit) {
|
|
teardown_link();
|
|
exit $err;
|
|
}
|
|
|
|
return($r);
|
|
}
|
|
|
|
sub do_smtp_drop {
|
|
ptrans(11, "Dropping connection");
|
|
exit(0);
|
|
}
|
|
|
|
sub do_smtp_tls {
|
|
my $e = shift; # ehlo config hash
|
|
|
|
# 0 = tls succeeded
|
|
# 1 = tls not advertised
|
|
# 2 = tls advertised and attempted negotiations failed
|
|
if (!$e->{STARTTLS}) {
|
|
return(1);
|
|
} elsif (!do_smtp_gen("STARTTLS", '220')) {
|
|
return(2);
|
|
} elsif (!start_tls()) {
|
|
ptrans(12, "TLS startup failed ($G::link{tls}{res})");
|
|
return(2);
|
|
}
|
|
tls_post_start();
|
|
|
|
return(0);
|
|
}
|
|
|
|
sub do_smtp_xclient {
|
|
my $e = shift;
|
|
|
|
# 0 - xclient succeeded normally
|
|
# 1 - xclient not advertised
|
|
# 2 - xclient advertised but not attempted, mismatch in requested attrs
|
|
# 3 - xclient attempted but did not succeed
|
|
if (!$e->{XCLIENT}) {
|
|
return(1);
|
|
}
|
|
my @parts = ();
|
|
foreach my $attr (keys %{$G::xclient{attr}}) {
|
|
if (!$e->{XCLIENT}{$attr}) {
|
|
return(2) if (!$G::xclient{no_verify});
|
|
}
|
|
}
|
|
|
|
foreach my $string (@{$G::xclient{strings}}) {
|
|
my $str = "XCLIENT " . $string;
|
|
do_smtp_gen($str, '220') || return(3);
|
|
}
|
|
return(0);
|
|
}
|
|
|
|
# see xtext encoding in http://tools.ietf.org/html/rfc1891
|
|
sub to_xtext {
|
|
my $string = shift;
|
|
|
|
return join('', map { ($_ == 0x2b || $_ == 0x3d || $_ <= 0x20 || $_ >= 0xff)
|
|
? sprintf("+%02X", $_)
|
|
: chr($_)
|
|
} (unpack("C*", $string)));
|
|
}
|
|
|
|
sub do_smtp_auth {
|
|
my $e = shift; # ehlo config hash
|
|
my $at = shift; # auth type
|
|
my $au = shift; # auth user
|
|
my $ap = shift; # auth password
|
|
|
|
return(1) if (!$e->{AUTH});
|
|
return(3) if ($G::auth_unavailable);
|
|
|
|
my $auth_attempted = 0; # set to true if we ever attempt auth
|
|
|
|
foreach my $btype (@$at) {
|
|
# if server doesn't support, skip type (may change in future)
|
|
next if (!$e->{AUTH}{$btype});
|
|
|
|
foreach my $type (@{$G::auth_map_t{'CRAM-MD5'}}) {
|
|
if ($btype eq $type) {
|
|
return(0) if (do_smtp_auth_cram($au, $ap, $type));
|
|
$auth_attempted = 1;
|
|
}
|
|
}
|
|
foreach my $type (@{$G::auth_map_t{'CRAM-SHA1'}}) {
|
|
if ($btype eq $type) {
|
|
return(0) if (do_smtp_auth_cram($au, $ap, $type));
|
|
$auth_attempted = 1;
|
|
}
|
|
}
|
|
foreach my $type (@{$G::auth_map_t{'DIGEST-MD5'}}) {
|
|
if ($btype eq $type) {
|
|
return(0) if (do_smtp_auth_digest($au, $ap, $type));
|
|
$auth_attempted = 1;
|
|
}
|
|
}
|
|
foreach my $type (@{$G::auth_map_t{'NTLM'}}) {
|
|
if ($btype eq $type) {
|
|
return(0) if (do_smtp_auth_ntlm($au, $ap, $type));
|
|
$auth_attempted = 1;
|
|
}
|
|
}
|
|
foreach my $type (@{$G::auth_map_t{'PLAIN'}}) {
|
|
if ($btype eq $type) {
|
|
return(0) if (do_smtp_auth_plain($au, $ap, $type));
|
|
$auth_attempted = 1;
|
|
}
|
|
}
|
|
foreach my $type (@{$G::auth_map_t{'LOGIN'}}) {
|
|
if ($btype eq $type) {
|
|
return(0) if (do_smtp_auth_login($au, $ap, $type));
|
|
$auth_attempted = 1;
|
|
}
|
|
}
|
|
}
|
|
|
|
return $auth_attempted ? 4 : 2;
|
|
}
|
|
|
|
sub do_smtp_auth_ntlm {
|
|
my $u = shift; # auth user
|
|
my $p = shift; # auth password
|
|
my $as = shift; # auth type (since NTLM might be SPA or MSN)
|
|
my $r = ''; # will store smtp response
|
|
|
|
my $auth_string = "AUTH $as";
|
|
do_smtp_gen($auth_string, '334') || return(0);
|
|
|
|
my $d = db64(Authen::NTLM::ntlm());
|
|
|
|
$auth_string = eb64($d);
|
|
do_smtp_gen($auth_string, '334', \$r, '',
|
|
$G::auth_showpt ? "$d" : '',
|
|
$G::auth_showpt ? \&unencode_smtp : '') || return(0);
|
|
|
|
$r =~ s/^....//; # maybe something a little better here?
|
|
Authen::NTLM::ntlm_domain($G::auth_extras{DOMAIN});
|
|
Authen::NTLM::ntlm_user($u);
|
|
Authen::NTLM::ntlm_password($p);
|
|
$d = db64(Authen::NTLM::ntlm($r));
|
|
|
|
$auth_string = eb64($d);
|
|
do_smtp_gen($auth_string, '235', \$r, '', $G::auth_showpt ? "$d" : '') || return(0);
|
|
|
|
return(1);
|
|
}
|
|
|
|
sub do_smtp_auth_digest {
|
|
my $u = shift; # auth user
|
|
my $p = shift; # auth password
|
|
my $as = shift; # auth string
|
|
my $r = ''; # will store smtp response
|
|
my $e = ''; # will store Authen::SASL errors
|
|
my @digest_uri = ();
|
|
|
|
if (exists($G::auth_extras{"DMD5-SERV-TYPE"})) {
|
|
$digest_uri[0] = $G::auth_extras{"DMD5-SERV-TYPE"};
|
|
} else {
|
|
$digest_uri[0] = 'smtp';
|
|
}
|
|
if (exists($G::auth_extras{"DMD5-HOST"})) {
|
|
$digest_uri[1] = $G::auth_extras{"DMD5-HOST"};
|
|
} else {
|
|
if ($G::link{type} eq 'socket-unix') {
|
|
$digest_uri[1] = $G::link{sockfile};
|
|
$digest_uri[1] =~ s|[^a-zA-Z0-9\.\-]|-|g;
|
|
} elsif ($G::link{type} eq 'pipe') {
|
|
$digest_uri[1] = $G::link{process};
|
|
$digest_uri[1] =~ s|[^a-zA-Z0-9\.\-]|-|g;
|
|
} else {
|
|
$digest_uri[1] = $G::link{server};
|
|
}
|
|
}
|
|
if (exists($G::auth_extras{"DMD5-SERV-NAME"})) {
|
|
# There seems to be a hole in the Authen::SASL interface where there's
|
|
# no option to directory provide the digest-uri serv-name. But we can
|
|
# trick it into using the value we want by tacking it onto the end of host
|
|
$digest_uri[1] .= '/' . $G::auth_extras{"DMD5-SERV-NAME"};
|
|
}
|
|
|
|
my $auth_string = "AUTH $as";
|
|
do_smtp_gen($auth_string, '334', \$r, '', '', $G::auth_showpt ? \&unencode_smtp : '')
|
|
|| return(0);
|
|
|
|
$r =~ s/^....//; # maybe something a little better here?
|
|
$r = db64($r);
|
|
|
|
my $callbacks = { user => $u, pass => $p };
|
|
if (exists($G::auth_extras{REALM})) {
|
|
$callbacks->{realm} = $G::auth_extras{REALM};
|
|
}
|
|
|
|
my $sasl = Authen::SASL->new(
|
|
debug => 1,
|
|
mechanism => 'DIGEST-MD5',
|
|
callback => $callbacks,
|
|
);
|
|
my $sasl_client = $sasl->client_new(@digest_uri);
|
|
|
|
# Force the DIGEST-MD5 session to use qop=auth. I'm open to exposing this setting
|
|
# via some swaks options, but I don't know enough about the protocol to just guess
|
|
# here. I do know that letting it auto-negotiate didn't work in my reference
|
|
# environment. sendmail advertised auth,auth-int,auth-conf, but when Authen::SASL
|
|
# chose auth-int the session would fail (server would say auth succeeded, but then
|
|
# immediately terminate my session when I sent MAIL). My reference client
|
|
# (Mulberry) always sent auth, and indeed forcing swaks to auth also seems to work.
|
|
# If anyone out there knows more about this please let me know.
|
|
$sasl_client->property('maxssf' => 0);
|
|
|
|
$auth_string = $sasl_client->client_step($r);
|
|
if ($e = $sasl_client->error()) {
|
|
ptrans('12', "Error received from Authen::SASL sub-system: $e");
|
|
return(0);
|
|
}
|
|
|
|
do_smtp_gen(eb64($auth_string), '334', \$r, '',
|
|
$G::auth_showpt ? "$auth_string" : '',
|
|
$G::auth_showpt ? \&unencode_smtp : '')
|
|
|| return(0);
|
|
$r =~ s/^....//; # maybe something a little better here?
|
|
$r = db64($r);
|
|
|
|
$auth_string = $sasl_client->client_step($r);
|
|
if ($e = $sasl_client->error()) {
|
|
ptrans('12', "Canceling SASL exchange, error received from Authen::SASL sub-system: $e");
|
|
$auth_string = '*';
|
|
}
|
|
#do_smtp_gen(eb64($auth_string), '235', \$r, '', $G::auth_showpt ? "$auth_string" : '')
|
|
do_smtp_gen($auth_string, '235', \$r, '', $auth_string)
|
|
|| return(0);
|
|
if ($e = $sasl_client->error()) {
|
|
ptrans('12', "Error received from Authen::SASL sub-system: $e");
|
|
return(0);
|
|
}
|
|
return(0) if (!$sasl_client->is_success());
|
|
|
|
return(1);
|
|
}
|
|
|
|
# This can handle both CRAM-MD5 and CRAM-SHA1
|
|
sub do_smtp_auth_cram {
|
|
my $u = shift; # auth user
|
|
my $p = shift; # auth password
|
|
my $as = shift; # auth string
|
|
my $r = ''; # will store smtp response
|
|
|
|
my $auth_string = "AUTH $as";
|
|
do_smtp_gen($auth_string, '334', \$r, '', '', $G::auth_showpt ? \&unencode_smtp : '')
|
|
|| return(0);
|
|
|
|
$r =~ s/^....//; # maybe something a little better here?
|
|
# specify which type of digest we need based on $as
|
|
my $d = get_digest($p, $r, ($as =~ /-SHA1$/ ? 'sha1' : 'md5'));
|
|
$auth_string = eb64("$u $d");
|
|
|
|
do_smtp_gen($auth_string, '235', undef, '', $G::auth_showpt ? "$u $d" : '') || return(0);
|
|
return(1);
|
|
}
|
|
|
|
sub do_smtp_auth_login {
|
|
my $u = shift; # auth user
|
|
my $p = shift; # auth password
|
|
my $as = shift; # auth string
|
|
|
|
do_smtp_gen("AUTH $as", '334', undef, '', '', $G::auth_showpt ? \&unencode_smtp : '')
|
|
|| return(0);
|
|
do_smtp_gen(eb64($u), '334', undef, '', $G::auth_showpt ? $u : '', $G::auth_showpt ? \&unencode_smtp : '')
|
|
|| return(0);
|
|
do_smtp_gen(eb64($p), '235', undef, '',
|
|
$G::auth_showpt ? ($G::auth_hidepw || $p) : eb64($G::auth_hidepw || $p))
|
|
|| return(0);
|
|
return(1);
|
|
}
|
|
|
|
sub do_smtp_auth_plain {
|
|
my $u = shift; # auth user
|
|
my $p = shift; # auth password
|
|
my $as = shift; # auth string
|
|
|
|
return(do_smtp_gen("AUTH $as " . eb64("\0$u\0$p"), '235', undef, '',
|
|
$G::auth_showpt ? "AUTH $as \\0$u\\0" . ($G::auth_hidepw || $p)
|
|
: "AUTH $as " . eb64("\0$u\0" . ($G::auth_hidepw || $p))));
|
|
}
|
|
|
|
sub do_smtp_helo {
|
|
my $h = shift; # helo string to use
|
|
my $e = shift; # this is a hashref that will be populated w/ server options
|
|
my $p = shift; # protocol for the transaction
|
|
my $r = ''; # this'll be populated by do_smtp_gen
|
|
|
|
if ($p eq 'esmtp' || $p eq 'lmtp') {
|
|
my $l = $p eq 'lmtp' ? "LHLO" : "EHLO";
|
|
if (do_smtp_gen("$l $h", '250', \$r)) {
|
|
# There's not a standard structure for the $e hashref, each
|
|
# key is stored in the manner that makes the most sense
|
|
foreach my $l (split(/\n/, $r)) {
|
|
$l =~ s/^....//;
|
|
if ($l =~ /^AUTH=?(.*)$/) {
|
|
map { $e->{AUTH}{uc($_)} = 1 } (split(' ', $1));
|
|
} elsif ($l =~ /^XCLIENT\s*(.*?)$/) {
|
|
$e->{XCLIENT} = {}; # prime the pump in case no attributes were advertised
|
|
map { $e->{XCLIENT}{uc($_)} = 1 } (split(' ', $1));
|
|
} elsif ($l =~ /^STARTTLS$/) {
|
|
$e->{STARTTLS} = 1;
|
|
} elsif ($l =~ /^PIPELINING$/) {
|
|
$e->{PIPELINING} = 1;
|
|
$G::pipeline_adv = 1;
|
|
} elsif ($l =~ /^PRDR$/) {
|
|
$e->{PRDR} = 1;
|
|
}
|
|
}
|
|
return(1);
|
|
}
|
|
}
|
|
if ($p eq 'esmtp' || $p eq 'smtp') {
|
|
return(do_smtp_gen("HELO $h", '250'));
|
|
}
|
|
|
|
return(0);
|
|
}
|
|
|
|
sub do_smtp_mail {
|
|
my $e = shift; # ehlo response
|
|
my $a = shift; # from address
|
|
my $m = "MAIL FROM:<$a>";
|
|
|
|
if ($G::prdr) {
|
|
if (!$e->{PRDR}) {
|
|
return(1); # PRDR was required but was not advertised. Return error and let caller handle it
|
|
} else {
|
|
$m .= " PRDR";
|
|
}
|
|
}
|
|
|
|
transact(cxn_string => $m, expect => '250', defer => 1, fail_callback => \&smtp_mail_callback);
|
|
|
|
return(0); # the callback handles failures, so just return here
|
|
}
|
|
|
|
# this only really needs to exist until I figure out a clever way of making
|
|
# do_smtp_quit the callback while still preserving the exit codes
|
|
sub smtp_mail_callback {
|
|
do_smtp_quit(1, 23);
|
|
}
|
|
|
|
sub do_smtp_rcpt {
|
|
my $m = shift; # string of comma separated recipients
|
|
my $f = 0; # The number of failures we've experienced
|
|
my @a = split(/,/, $m);
|
|
$G::smtp_rcpt_total = scalar(@a);
|
|
|
|
foreach my $addr (@a) {
|
|
transact(cxn_string => 'RCPT TO:<' . $addr . '>', expect => '250', defer => 1,
|
|
fail_callback => \&smtp_rcpt_callback);
|
|
}
|
|
|
|
return(1); # the callback handles failures, so just return here
|
|
}
|
|
|
|
sub smtp_rcpt_callback {
|
|
# record that a failure occurred
|
|
$G::smtp_rcpt_failures++;
|
|
|
|
# if the number of failures is the same as the total rcpts (if every rcpt rejected), quit.
|
|
if ($G::smtp_rcpt_failures == $G::smtp_rcpt_total) {
|
|
do_smtp_quit(1, 24);
|
|
}
|
|
}
|
|
|
|
sub do_smtp_data {
|
|
my $m = shift; # string to send
|
|
my $b = shift; # be brief in the data we send
|
|
my $r = ''; # will store smtp response
|
|
my $e = $G::prdr ? '(250|353)' : '250';
|
|
|
|
my $calls = $G::smtp_rcpt_total - $G::smtp_rcpt_failures;
|
|
my $ok = transact(cxn_string => $m, expect => $e, summarize_output => $b, return_text => \$r);
|
|
|
|
# now be a little messy - lmtp is not a lockstep after data - we need to
|
|
# listen for as many calls as we had accepted recipients
|
|
if ($G::protocol eq 'lmtp') {
|
|
foreach my $c (1..($calls-1)) { # -1 because we already got 1 above
|
|
$ok += transact(cxn_string => undef, expect => '250');
|
|
}
|
|
} elsif ($G::protocol eq 'esmtp' && $G::prdr && $r =~ /^353 /) {
|
|
foreach my $c (1..$calls) {
|
|
transact(cxn_string => undef, expect => '250'); # read the status of each recipient off the wire
|
|
}
|
|
$ok = transact(cxn_string => undef, expect => '250'); # PRDR has an overall acceptance string, read it here and use it as th success indicator
|
|
}
|
|
return($ok)
|
|
}
|
|
|
|
sub do_smtp_gen {
|
|
my $m = shift; # string to send (if empty, we won't send anything, only read)
|
|
my $e = shift; # String we're expecting to get back
|
|
my $p = shift; # if this is a scalar ref, assign the server return string to it
|
|
my $b = shift; # be brief in the data we print
|
|
my $x = shift; # if this is populated, print this instead of $m
|
|
my $c = shift; # if this is a code ref, call it on the return value before printing it
|
|
my $n = shift; # if true, when the data is sent over the wire, it will not have \r\n appended to it
|
|
my $r = shift; # if true, we won't try to ready a response from the server
|
|
|
|
return transact(cxn_string => $m, expect => $e, return_text => $p,
|
|
summarize_output => $b, show_string => $x, print_callback => $c,
|
|
no_newline => $n, no_read_response => $r,
|
|
);
|
|
}
|
|
|
|
sub do_smtp_proxy {
|
|
my $send = undef;
|
|
my $print = undef;
|
|
my $no_newline = 0;
|
|
|
|
if ($G::proxy{version} == 2) {
|
|
$send = pack("W[12]", 0x0D, 0x0A,0x0D, 0x0A, 0x00, 0x0D, 0x0A, 0x51, 0x55, 0x49, 0x54, 0x0A);
|
|
if ($G::proxy{raw}) {
|
|
$send .= $G::proxy{raw};
|
|
} else {
|
|
# byte 13
|
|
# 4 bits = version (required to be 0x2)
|
|
# 4 bits = command (0x2 = LOCAL, 0x1 = PROXY)
|
|
$send .= pack("W", 0x20 + ($G::proxy{attr}{command} eq 'LOCAL' ? 0x02 : 0x01));
|
|
if ($G::proxy{attr}{command} eq 'LOCAL') {
|
|
# the protocol byte (14, including family and protocol) are ignored with local. Set to zeros
|
|
$send .= pack("W", 0x00);
|
|
# and, additionally, if we're local, there isn't going to be any address size (bytes 15 and 16)
|
|
$send .= pack("W", 0x00);
|
|
} else {
|
|
# byte 14
|
|
# 4 bits = address family (0x0 = AF_UNSPEC, 0x1 = AF_INET, 0x2 = AF_INET6, 0x3 = AF_UNIX)
|
|
# 4 bits = transport protocol (0x0 = UNSPEC, 0x1 = STREAM, 0x2 = DGRAM)
|
|
my $byte = 0;
|
|
if ($G::proxy{attr}{family} eq 'AF_UNSPEC') {
|
|
$byte = 0x00;
|
|
} elsif ($G::proxy{attr}{family} eq 'AF_INET') {
|
|
$byte = 0x10;
|
|
} elsif ($G::proxy{attr}{family} eq 'AF_INET6') {
|
|
$byte = 0x20;
|
|
} elsif ($G::proxy{attr}{family} eq 'AF_UNIX') {
|
|
$byte = 0x30;
|
|
}
|
|
if ($G::proxy{attr}{protocol} eq 'UNSPEC') {
|
|
$byte += 0x0;
|
|
} elsif ($G::proxy{attr}{protocol} eq 'STREAM') {
|
|
$byte += 0x1;
|
|
} elsif ($G::proxy{attr}{protocol} eq 'DGRAM') {
|
|
$byte += 0x2;
|
|
}
|
|
$send .= pack("W", $byte);
|
|
|
|
# network portion (bytes 17+)
|
|
my $net = pack_ip($G::proxy{attr}{source})
|
|
. pack_ip($G::proxy{attr}{dest})
|
|
. pack("n", $G::proxy{attr}{source_port})
|
|
. pack("n", $G::proxy{attr}{dest_port});
|
|
$send .= pack("n", length($net)) . $net; # add bytes 15+16 (length of network portion) plus the network portion
|
|
}
|
|
}
|
|
|
|
# version 2 is binary, so uuencode it before printing. Also, version 2 REQUIREs that you not send \r\n after it down the wire
|
|
$print = eb64($send);
|
|
$no_newline = 1;
|
|
} else {
|
|
if ($G::proxy{raw}) {
|
|
$send = "PROXY $G::proxy{raw}";
|
|
} else {
|
|
$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});
|
|
}
|
|
}
|
|
|
|
do_smtp_gen($send, # to be send over the wire
|
|
'220', # response code indicating success
|
|
undef, # the return string from the server (don't need it)
|
|
0, # do not be brief when printing
|
|
$print, # if populated, print this instead of $send
|
|
undef, # don't want a post-processing callback
|
|
$no_newline, # if true, don't add \r\n to the end of $send when sent over the wire
|
|
1, # don't read a response - we only want to send the value
|
|
);
|
|
}
|
|
|
|
# no special attempt made at verifying, on purpose
|
|
sub pack_ip {
|
|
my $ip = shift;
|
|
|
|
if ($ip =~ /:/) {
|
|
# this is the stupidest piece of code ever. Please tell me all the fun ways it breaks
|
|
my @pieces = split(/:/, $ip);
|
|
my $p;
|
|
shift(@pieces) if ($pieces[0] eq '' && $pieces[1] eq ''); #
|
|
foreach my $word (@pieces) {
|
|
if ($word eq '') {
|
|
foreach my $i (0..(8-scalar(@pieces))) {
|
|
$p .= pack("n", 0);
|
|
}
|
|
} else {
|
|
$p .= pack("n", hex($word));
|
|
}
|
|
}
|
|
return($p);
|
|
} else {
|
|
return(pack("W*", split(/\./, $ip)));
|
|
}
|
|
}
|
|
|
|
# If we detect that the other side has gone away when we were expecting
|
|
# to still be reading, come in here to error and die. Abstracted because
|
|
# the error message will vary depending on the type of connection
|
|
sub handle_disconnect {
|
|
my $e = shift || 6; # this is the code we will exit with
|
|
if ($G::link{type} eq 'socket-inet') {
|
|
ptrans(12, "Remote host closed connection unexpectedly.");
|
|
} elsif ($G::link{type} eq 'socket-unix') {
|
|
ptrans(12, "Socket closed connection unexpectedly.");
|
|
} elsif ($G::link{type} eq 'pipe') {
|
|
ptrans(12, "Child process closed connection unexpectedly.");
|
|
}
|
|
exit($e);
|
|
}
|
|
|
|
sub flush_send_buffer {
|
|
my $s = $G::link{type} eq 'pipe' ? $G::link{sock}->{wr} : $G::link{sock};
|
|
return if (!$G::send_buffer);
|
|
if ($G::link{tls}{active}) {
|
|
my $res = Net::SSLeay::write($G::link{tls}{ssl}, $G::send_buffer);
|
|
} else {
|
|
print $s $G::send_buffer;
|
|
}
|
|
ptrans(23, hdump($G::send_buffer)) if ($G::show_raw_text);
|
|
$G::send_buffer = '';
|
|
}
|
|
|
|
sub send_data {
|
|
my $d = shift; # data to write
|
|
my $nnl = shift || 0; # if true, don't add a newline (needed for PROXY v2 support)
|
|
$G::send_buffer .= $d . ($nnl ? '' : "\r\n");
|
|
}
|
|
|
|
sub recv_line {
|
|
# Either an IO::Socket obj or a FH to my child - the thing to read from
|
|
my $s = $G::link{type} eq 'pipe' ? $G::link{sock}->{re} : $G::link{sock};
|
|
my $r = undef;
|
|
my $t = undef;
|
|
my $c = 0;
|
|
|
|
while ($G::recv_buffer !~ m|\n|si) {
|
|
last if (++$c > 1000); # Maybe I'll remove this once I trust this code more
|
|
if ($G::link{tls}{active}) {
|
|
$t = Net::SSLeay::read($G::link{tls}{ssl});
|
|
return($t) if (!defined($t));
|
|
|
|
# THIS CODE COPIED FROM THE ELSE BELOW. Found I could trip this condition
|
|
# by having the server sever the connection but not have swaks realize the
|
|
# connection was gone. For instance, send a PIPELINE mail that includes a
|
|
# "-q rcpt". There was a bug in swaks that made it try to send another quit
|
|
# later, thus tripping this "1000 reads" error (but only in TLS).
|
|
# Short term: add line below to prevent these reads
|
|
# Short Term: fix the "double-quit" bug
|
|
# Longer term: test to see if remote side closed connection
|
|
|
|
# the above line should be good enough but it isn't returning
|
|
# undef for some reason. I think heuristically it will be sufficient
|
|
# to just look for an empty packet (I hope. gulp). Comment out the
|
|
# following line if your swaks seems to be saying that it lost connection
|
|
# for no good reason. Then email me about it.
|
|
return(undef()) if (!length($t));
|
|
} elsif ($G::link{type} eq 'pipe') {
|
|
# XXX in a future release see if I can get read() or equiv to work on a pipe
|
|
$t = <$s>;
|
|
return($t) if (!defined($t));
|
|
|
|
# THIS CODE COPIED FROM THE ELSE BELOW.
|
|
# the above line should be good enough but it isn't returning
|
|
# undef for some reason. I think heuristically it will be sufficient
|
|
# to just look for an empty packet (I hope. gulp). Comment out the
|
|
# following line if your swaks seems to be saying that it lost connection
|
|
# for no good reason. Then email me about it.
|
|
return(undef()) if (!length($t));
|
|
} else {
|
|
# if you're having problems with reads, swap the comments on the
|
|
# the following two lines
|
|
my $recv_r = recv($s, $t, 8192, 0);
|
|
#$t = <$s>;
|
|
return($t) if (!defined($t));
|
|
|
|
# the above line should be good enough but it isn't returning
|
|
# undef for some reason. I think heuristically it will be sufficient
|
|
# to just look for an empty packet (I hope. gulp). Comment out the
|
|
# following line if your swaks seems to be saying that it lost connection
|
|
# for no good reason. Then email me about it.
|
|
return(undef()) if (!length($t));
|
|
|
|
#print "\$t = $t (defined = ", defined($t) ? "yes" : "no",
|
|
# "), \$recv_r = $recv_r (", defined($recv_r) ? "yes" : "no", ")\n";
|
|
}
|
|
$G::recv_buffer .= $t;
|
|
ptrans(33, hdump($t)) if ($G::show_raw_text);
|
|
}
|
|
|
|
if ($c >= 1000) {
|
|
# If you saw this in the wild, I'd love to hear more about it
|
|
# at proj-swaks@jetmore.net
|
|
ptrans(12, "In recv_line, hit loop counter. Continuing in unknown state");
|
|
}
|
|
|
|
# using only bare newlines is bound to cause me problems in the future
|
|
# but it matches the expectation we've already been using. All we can
|
|
# do is hone in on the proper behavior iteratively.
|
|
if ($G::recv_buffer =~ s|^(.*?\n)||si) {
|
|
$r = $1;
|
|
} else {
|
|
ptrans(12, "I'm in an impossible state");
|
|
}
|
|
|
|
$r =~ s|\r||msg;
|
|
return($r);
|
|
}
|
|
|
|
# any request which has immediate set will be checking the return code.
|
|
# any non-immediate request will handle results through fail_callback().
|
|
# therefore, only return the state of the last transaction attempted,
|
|
# which will always be immediate
|
|
# defer - if true, does not require immediate flush when pipelining
|
|
# cxn_string - What we will be sending the server. If undefined, we won't send, only read
|
|
# no_read_response - if true, we won't read a response from the server, we'll just send
|
|
# summarize_output - if true, don't print to terminal everything we send to server
|
|
# no_newline - if true, do not append \r\n to the data we send to server
|
|
# return_text - should be scalar ref. will be assigned reference to what was returned from server
|
|
# print_callback - if present and a code reference, will be called with server return data for printing to terminal
|
|
# fail_callback - if present and a code reference, will be called on failure
|
|
sub transact {
|
|
my %h = @_; # this is an smtp transaction element
|
|
my $ret = 1; # this is our return value
|
|
my @handlers = (); # will hold any fail_handlers we need to run
|
|
my $time = ''; # used in time lapse calculations
|
|
|
|
push(@G::pending_send, \%h); # push onto send queue
|
|
if (!($G::pipeline && $G::pipeline_adv) || !$h{defer}) {
|
|
|
|
if ($G::show_time_lapse eq 'hires') {
|
|
$time = [Time::HiRes::gettimeofday()];
|
|
}
|
|
elsif ($G::show_time_lapse eq 'integer') {
|
|
$time = time();
|
|
}
|
|
|
|
while (my $i = shift(@G::pending_send)) {
|
|
if (defined($i->{cxn_string})) {
|
|
ptrans(21, $i->{show_string} || $i->{cxn_string}, $i->{summarize_output});
|
|
send_data($i->{cxn_string}, $i->{no_newline});
|
|
}
|
|
push(@G::pending_recv, $i) if (!$i->{no_read_response});
|
|
}
|
|
flush_send_buffer();
|
|
|
|
do_smtp_drop() if ($G::drop_before_read);
|
|
|
|
while (my $i = shift(@G::pending_recv)) {
|
|
my $buff = '';
|
|
eval {
|
|
local $SIG{'ALRM'} = sub {
|
|
$buff = "Timeout ($G::link{timeout} secs) waiting for server response";
|
|
die;
|
|
};
|
|
alarm($G::link{timeout});
|
|
while ($buff !~ /^\d\d\d /m) {
|
|
my $l = recv_line();
|
|
$buff .= $l;
|
|
if (!defined($l)) {
|
|
$G::link{lost_cxn} = 1;
|
|
last;
|
|
}
|
|
}
|
|
chomp($buff);
|
|
alarm(0);
|
|
};
|
|
|
|
if ($G::show_time_lapse eq 'hires') {
|
|
$time = sprintf("%0.03f", Time::HiRes::tv_interval($time, [Time::HiRes::gettimeofday()]));
|
|
ptrans(11, "response in ${time}s");
|
|
$time = [Time::HiRes::gettimeofday()];
|
|
} elsif ($G::show_time_lapse eq 'integer') {
|
|
$time = time() - $time;
|
|
ptrans(11, "response in ${time}s");
|
|
$time = time();
|
|
}
|
|
|
|
${$i->{return_text}} = $buff;
|
|
$buff = &{$i->{print_callback}}($buff) if (ref($i->{print_callback}) eq 'CODE');
|
|
my $ptc;
|
|
($ret,$ptc) = $buff !~ /^$i->{expect} /m ? (0,32) : (1,31);
|
|
ptrans($ptc, $buff) if ($buff);
|
|
if ($G::link{lost_cxn}) {
|
|
if ($G::link{allow_lost_cxn}) {
|
|
# this means the calling code wants to handle a lost cxn itself
|
|
return($ret);
|
|
} else {
|
|
# if caller didn't want to handle, we'll handle a lost cxn ourselves
|
|
handle_disconnect();
|
|
}
|
|
}
|
|
if (!$ret && ref($i->{fail_callback}) eq 'CODE') {
|
|
push(@handlers, $i->{fail_callback});
|
|
}
|
|
}
|
|
}
|
|
foreach my $h (@handlers) { &{$h}(); }
|
|
return($ret);
|
|
}
|
|
|
|
# a quick-and-dirty hex dumper. Currently used by --show-raw-text
|
|
sub hdump {
|
|
my $r = shift;
|
|
my $c = 0; # counter
|
|
my $i = 16; # increment value
|
|
my $b; # buffer
|
|
|
|
while (length($r) && ($r =~ s|^(.{1,$i})||smi)) {
|
|
my $s = $1; # $s will be the ascii string we manipulate for display
|
|
my @c = map { ord($_); } (split('', $s));
|
|
$s =~ s|[^\x21-\x7E]|.|g;
|
|
|
|
my $hfs = ''; # This is the hex format string for printf
|
|
for (my $hc = 0; $hc < $i; $hc++) {
|
|
$hfs .= ' ' if (!($hc%4));
|
|
if ($hc < scalar(@c)) { $hfs .= '%02X '; } else { $hfs .= ' '; }
|
|
}
|
|
|
|
$b .= sprintf("%04d:$hfs %-16s\n", $c, @c, $s);
|
|
$c += $i;
|
|
}
|
|
chomp($b); # inelegant remnant of hdump's previous life
|
|
return($b)
|
|
}
|
|
|
|
sub unencode_smtp {
|
|
my $t = shift;
|
|
|
|
my @t = split(' ', $t, 2);
|
|
if ($t[1] =~ /\s/) {
|
|
# very occasionally we can have a situation where a successful response will
|
|
# be b64 encoded, while an error will not be. Try to tell the difference.
|
|
return($t);
|
|
} else {
|
|
return("$t[0] " . db64($t[1]));
|
|
}
|
|
}
|
|
|
|
sub obtain_from_netrc {
|
|
my $field = shift;
|
|
my $login = shift;
|
|
|
|
return if !avail('netrc');
|
|
|
|
if (my $netrc = Net::Netrc->lookup($G::link{server}, defined($login) ? $login : ())) {
|
|
return($netrc->$field);
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
sub interact {
|
|
my $prompt = shift;
|
|
my $regexp = shift;
|
|
my $hide_input = shift;
|
|
my $response = '';
|
|
|
|
do {
|
|
print $prompt;
|
|
if (!$hide_input || !$G::protect_prompt || $G::interact_method eq 'default') {
|
|
chomp($response = <STDIN>);
|
|
} else {
|
|
if ($^O eq 'MSWin32') {
|
|
#if ($G::interact_method eq "win32-console" ||
|
|
# (!$G::interact_method && load("Win32::Console")))
|
|
#{
|
|
# Couldn't get this working in the time I wanted to devote to it
|
|
#}
|
|
if ($G::interact_method eq "win32-readkey" ||
|
|
(!$G::interact_method && load("Term::ReadKey")))
|
|
{
|
|
$G::interact_method ||= "win32-readkey";
|
|
# the trick to replace input w/ '*' doesn't work on Win32
|
|
# Term::ReadKey, so just use it as an stty replacement
|
|
ReadMode('noecho');
|
|
# need to think about this on windows some more
|
|
#local $SIG{INT} = sub { ReadMode('restore'); };
|
|
chomp($response = <STDIN>);
|
|
ReadMode('restore');
|
|
} else {
|
|
$G::interact_method ||= "default";
|
|
chomp($response = <STDIN>);
|
|
}
|
|
} else {
|
|
if ($G::interact_method eq "unix-readkey" || (!$G::interact_method && load("Term::ReadKey"))) {
|
|
$G::interact_method ||= "unix-readkey";
|
|
my @resp = ();
|
|
ReadMode('raw');
|
|
#local $SIG{INT} =
|
|
# reevaluate this code - what happens if del is first char we press?
|
|
while ((my $kp = ReadKey(0)) ne "\n") {
|
|
my $kp_num = ord($kp);
|
|
if($kp_num == 127 || $kp_num == 8) {
|
|
next if (!scalar(@resp));
|
|
pop(@resp);
|
|
print "\b \b";
|
|
} elsif($kp_num >= 32) {
|
|
push(@resp, $kp);
|
|
print "*";
|
|
}
|
|
}
|
|
ReadMode('restore');
|
|
$response = join('', @resp);
|
|
} elsif ($G::interact_method eq "unix-stty" || (!$G::interact_method && open(STTY, "stty -a |"))) {
|
|
$G::interact_method ||= "unix-stty";
|
|
{ my $foo = join('', <STTY>); }
|
|
system('stty', '-echo');
|
|
chomp($response = <STDIN>);
|
|
system('stty', 'echo');
|
|
} else {
|
|
$G::interact_method ||= "default";
|
|
chomp($response = <STDIN>);
|
|
}
|
|
}
|
|
}
|
|
} while ($regexp ne 'SKIP' && $response !~ /$regexp/);
|
|
|
|
return($response);
|
|
}
|
|
|
|
sub get_messageid {
|
|
if (!$G::message_id) {
|
|
my @time = localtime();
|
|
$G::message_id = sprintf("%04d%02d%02d%02d%02d%02d.%06d\@%s",
|
|
$time[5]+1900, $time[4]+1, $time[3], $time[2], $time[1], $time[0],
|
|
$$, get_hostname());
|
|
}
|
|
|
|
return($G::message_id);
|
|
}
|
|
|
|
sub get_hostname {
|
|
# in some cases hostname returns value but gethostbyname doesn't.
|
|
return("") if (!avail("hostname"));
|
|
|
|
my $h = hostname();
|
|
return("") if (!$h);
|
|
|
|
my $l = (gethostbyname($h))[0];
|
|
return($l || $h);
|
|
}
|
|
|
|
sub get_server {
|
|
my $addr = shift;
|
|
my $pref = -1;
|
|
my $server = "localhost";
|
|
|
|
if ($addr =~ /\@?\[(\d+\.\d+\.\d+\.\d+)\]$/) {
|
|
# handle automatic routing of domain literals (user@[1.2.3.4])
|
|
return($1);
|
|
} elsif ($addr =~ /\@?\#(\d+)$/) {
|
|
# handle automatic routing of decimal domain literals (user@#16909060)
|
|
$addr = $1;
|
|
return(($addr/(2**24))%(2**8) . '.' . ($addr/(2**16))%(2**8) . '.' .
|
|
($addr/(2**8))%(2**8) . '.' . ($addr/(2**0))%(2**8));
|
|
}
|
|
|
|
if (!avail("dns")) {
|
|
ptrans(12, avail_str("dns"). ". Using $server as mail server");
|
|
return($server);
|
|
}
|
|
my $res = Net::DNS::Resolver->new();
|
|
|
|
$addr =~ s/^.*\@([^\@]*)$/$1/;
|
|
return($server) if (!$addr);
|
|
$server = $addr;
|
|
|
|
my @mx = mx($res, $addr);
|
|
foreach my $rr (sort { $a->preference <=> $b->preference } @mx) {
|
|
if ($G::link{force_ipv4}) {
|
|
if ($res->query($rr->exchange, 'A')) {
|
|
$server = $rr->exchange;
|
|
last;
|
|
}
|
|
} elsif ($G::link{force_ipv6}) {
|
|
if ($res->query($rr->exchange, 'AAAA') || $res->query($rr->exchange, 'A6')) {
|
|
$server = $rr->exchange;
|
|
last;
|
|
}
|
|
} else {
|
|
# this is the old default behavior. Take the best priority MX, no matter what.
|
|
$server = $rr->exchange;
|
|
last;
|
|
}
|
|
}
|
|
return($server);
|
|
}
|
|
|
|
sub load {
|
|
my $m = shift;
|
|
|
|
return $G::modules{$m} if (exists($G::modules{$m}));
|
|
eval("use $m");
|
|
return $G::modules{$m} = $@ ? 0 : 1;
|
|
}
|
|
|
|
# Currently this is just an informational string - it's set on both
|
|
# success and failure. It currently has four output formats (supported,
|
|
# supported but not optimal, unsupported, unsupported and missing optimal)
|
|
sub avail_str { return $G::dependencies{$_[0]}{errstr}; }
|
|
|
|
sub avail {
|
|
my $f = shift; # this is the feature we want to check support for (auth, tls)
|
|
my $s = \%G::dependencies;
|
|
|
|
# return immediately if we've already tested this.
|
|
return($s->{$f}{avail}) if (exists($s->{$f}{avail}));
|
|
|
|
$s->{$f}{req_failed} = [];
|
|
$s->{$f}{opt_failed} = [];
|
|
foreach my $m (@{$s->{$f}{req}}) {
|
|
push(@{$s->{$f}{req_failed}}, $m) if (!load($m));
|
|
}
|
|
foreach my $m (@{$s->{$f}{opt}}) {
|
|
push(@{$s->{$f}{opt_failed}}, $m) if (!load($m));
|
|
}
|
|
|
|
if (scalar(@{$s->{$f}{req_failed}})) {
|
|
$s->{$f}{errstr} = "$s->{$f}{name} not available: requires " . join(', ', @{$s->{$f}{req_failed}});
|
|
if (scalar(@{$s->{$f}{opt_failed}})) {
|
|
$s->{$f}{errstr} .= ". Also missing optimizing " . join(', ', @{$s->{$f}{opt_failed}});
|
|
}
|
|
return $s->{$f}{avail} = 0;
|
|
} else {
|
|
if (scalar(@{$s->{$f}{opt_failed}})) {
|
|
$s->{$f}{errstr} = "$s->{$f}{name} supported, but missing optimizing " .
|
|
join(', ', @{$s->{$f}{opt_failed}});
|
|
} else {
|
|
$s->{$f}{errstr} = "$s->{$f}{name} supported";
|
|
}
|
|
return $s->{$f}{avail} = 1;
|
|
}
|
|
}
|
|
|
|
sub get_digest {
|
|
my $secr = shift;
|
|
my $chal = shift;
|
|
my $type = shift || 'md5';
|
|
my $ipad = chr(0x36) x 64;
|
|
my $opad = chr(0x5c) x 64;
|
|
|
|
if ($chal !~ /^</) {
|
|
chomp($chal = db64($chal));
|
|
}
|
|
|
|
if (length($secr) > 64) {
|
|
if ($type eq 'md5') {
|
|
$secr = Digest::MD5::md5($secr);
|
|
} elsif ($type eq 'sha1') {
|
|
$secr = Digest::SHA::sha1($secr);
|
|
}
|
|
} else {
|
|
$secr .= chr(0) x (64 - length($secr));
|
|
}
|
|
|
|
my $digest = $type eq 'md5' ? Digest::MD5::md5_hex(($secr ^ $opad), Digest::MD5::md5(($secr ^ $ipad), $chal))
|
|
: Digest::SHA::sha1_hex(($secr ^ $opad), Digest::SHA::sha1(($secr ^ $ipad), $chal));
|
|
return($digest);
|
|
}
|
|
|
|
sub test_support {
|
|
my $return = shift;
|
|
my $lines = [];
|
|
my $s = \%G::dependencies;
|
|
|
|
foreach my $act (sort { $s->{$a}{name} cmp $s->{$b}{name} } keys %$s) {
|
|
if ($return) {
|
|
push(@$lines, @{ptrans(avail($act) ? 11 : 12, avail_str($act), undef, 1)});
|
|
}
|
|
else {
|
|
ptrans(avail($act) ? 11 : 12, avail_str($act));
|
|
}
|
|
}
|
|
|
|
if ($return) {
|
|
return($lines);
|
|
}
|
|
}
|
|
|
|
sub time_to_seconds {
|
|
my $t = shift;
|
|
|
|
if ($t !~ /^(\d+)([hms])?$/i) {
|
|
ptrans(12, 'Unknown timeout format \'' . $t . '\'');
|
|
exit(1);
|
|
} else {
|
|
my $r = $1;
|
|
my $u = lc($2);
|
|
if ($u eq 'h') {
|
|
return($r * 3600);
|
|
} elsif ($u eq 'm') {
|
|
return($r * 60);
|
|
} else {
|
|
return($r);
|
|
}
|
|
}
|
|
}
|
|
|
|
sub load_dependencies {
|
|
%G::dependencies = (
|
|
auth => { name => "Basic AUTH", opt => ['MIME::Base64'],
|
|
req => [] },
|
|
auth_cram_md5 => { name => "AUTH CRAM-MD5", req => ['Digest::MD5'] },
|
|
auth_cram_sha1 => { name => "AUTH CRAM-SHA1", req => ['Digest::SHA'] },
|
|
auth_ntlm => { name => "AUTH NTLM", req => ['Authen::NTLM'] },
|
|
auth_digest_md5 => { name => "AUTH DIGEST-MD5", req => ['Authen::SASL'] },
|
|
dns => { name => "MX Routing", req => ['Net::DNS'] },
|
|
netrc => { name => 'Netrc Credentials', req => ['Net::Netrc'] },
|
|
tls => { name => "TLS", req => ['Net::SSLeay'] },
|
|
pipe => { name => "Pipe Transport", req => ['IPC::Open2'] },
|
|
socket => { name => "Socket Transport", req => ['IO::Socket'] },
|
|
ipv6 => { name => "IPv6", req => ['IO::Socket::INET6'] },
|
|
date_manip => { name => "Date Manipulation", req => ['POSIX'] },
|
|
hostname => { name => "Local Hostname Detection", req => ['Sys::Hostname'] },
|
|
hires_timing => { name => "High Resolution Timing", req => ['Time::HiRes'] },
|
|
);
|
|
}
|
|
|
|
sub process_opt_silent {
|
|
my $opt = shift;
|
|
my $arg = shift;
|
|
|
|
if ($arg =~ /^[123]$/) {
|
|
return($arg);
|
|
}
|
|
else {
|
|
return(1);
|
|
}
|
|
}
|
|
|
|
sub get_option_struct {
|
|
use constant {
|
|
OP_ARG_OPT => 0x01, # option takes an optional argument
|
|
OP_ARG_REQ => 0x02, # option takes a required argument
|
|
OP_ARG_NONE => 0x04, # option does not take any argument (will return boolean)
|
|
OP_FROM_PROMPT => 0x08, # option prompts for an argument if none provided
|
|
OP_FROM_FILE => 0x10, # option treats arg of '-' to mean 'read from stdin' (no prompt)
|
|
OP_DEPRECATED => 0x20, # This option is deprecated
|
|
};
|
|
|
|
@G::raw_option_data = (
|
|
# location of config file. Note that the "config" option is processed differently
|
|
# than any other option because it needs to be processed before standard option processing
|
|
# can happen. We still define it here to make Getopt::Long and fetch_args() happy.
|
|
{ opts => ['config'], suffix => ':s',
|
|
cfgs => OP_ARG_OPT,
|
|
okey => 'config_file', type => 'scalar', },
|
|
# envelope-(f)rom address
|
|
{ opts => ['from', 'f'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'From: ', match => '^.*$',
|
|
okey => 'mail_from', type => 'scalar', },
|
|
# envelope-(t)o address
|
|
{ opts => ['to', 't'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'To: ', match => '^.+$',
|
|
okey => 'mail_to', type => 'scalar', },
|
|
# (h)elo string
|
|
{ opts => ['helo', 'ehlo', 'lhlo', 'h'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'Helo: ', match => '^.*$',
|
|
okey => 'mail_helo', type => 'scalar', },
|
|
# (s)erver to use
|
|
{ opts => ['server', 's'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'Server: ', match => '^.*$',
|
|
okey => 'mail_server', type => 'scalar', },
|
|
# force ipv4 only
|
|
{ opts => ['4'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'force_ipv4', type => 'scalar', },
|
|
# force ipv6 only
|
|
{ opts => ['6'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'force_ipv6', type => 'scalar', },
|
|
# copy MX/routing from another domain
|
|
{ opts => ['copy-routing'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ,
|
|
okey => 'copy_routing', type => 'scalar', },
|
|
# (p)ort to use
|
|
{ opts => ['port', 'p'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'Port: ', match => '^\w+$',
|
|
okey => 'mail_port', type => 'scalar', },
|
|
# protocol to use (smtp, esmtp, lmtp)
|
|
{ opts => ['protocol'], suffix => '=s',
|
|
cfgs => OP_ARG_REQ,
|
|
okey => 'mail_protocol', type => 'scalar', },
|
|
# (d)ata portion ('\n' for newlines)
|
|
{ opts => ['data', 'd'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT|OP_FROM_FILE,
|
|
prompt => 'Data: ', match => '^.*$',
|
|
okey => 'mail_data', type => 'scalar', },
|
|
# use the --dump text as default body
|
|
{ opts => ['dump-as-body', 'dab'], suffix => ':s',
|
|
cfgs => OP_ARG_OPT,
|
|
okey => 'dump_as_body', type => 'scalar', },
|
|
# implies --dump-as-body; forces raw passwords to be used
|
|
{ opts => ['dump-as-body-shows-password', 'dabsp'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'dab_sp', type => 'scalar', },
|
|
# timeout for each trans (def 30s)
|
|
{ opts => ['timeout'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'Timeout: ', match => '^\d+[hHmMsS]?$',
|
|
okey => 'timeout', type => 'scalar', },
|
|
# (q)uit after
|
|
{ opts => ['quit-after', 'quit', 'q'], suffix => '=s',
|
|
cfgs => OP_ARG_REQ,
|
|
okey => 'quit_after', type => 'scalar', },
|
|
# drop after (don't quit, just drop)
|
|
{ opts => ['drop-after', 'drop', 'da'], suffix => '=s',
|
|
cfgs => OP_ARG_REQ,
|
|
okey => 'drop_after', type => 'scalar', },
|
|
# drop after send (between send and read)
|
|
{ opts => ['drop-after-send', 'das'], suffix => '=s',
|
|
cfgs => OP_ARG_REQ,
|
|
okey => 'drop_after_send', type => 'scalar', },
|
|
# do (n)ot print data portion
|
|
{ opts => ['suppress-data', 'n'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'suppress_data', type => 'scalar', },
|
|
# force auth, exit if not supported
|
|
{ opts => ['auth', 'a'], suffix => ':s',
|
|
cfgs => OP_ARG_OPT,
|
|
okey => 'auth', type => 'scalar', },
|
|
# user for auth
|
|
{ opts => ['auth-user', 'au'], suffix => ':s',
|
|
cfgs => OP_ARG_OPT, # we dynamically change this later
|
|
okey => 'auth_user', type => 'scalar', },
|
|
# pass for auth
|
|
{ opts => ['auth-password', 'ap'], suffix => ':s',
|
|
cfgs => OP_ARG_OPT, # we dynamically change this later
|
|
okey => 'auth_pass', type => 'scalar', },
|
|
# auth type map
|
|
{ opts => ['auth-map', 'am'], suffix => '=s',
|
|
cfgs => OP_ARG_REQ,
|
|
okey => 'auth_map', type => 'scalar', },
|
|
# extra, authenticator-specific options
|
|
{ opts => ['auth-extra', 'ae'], suffix => '=s',
|
|
cfgs => OP_ARG_REQ,
|
|
okey => 'auth_extra', type => 'scalar', },
|
|
# hide passwords when possible
|
|
{ opts => ['auth-hide-password', 'ahp'], suffix => ':s',
|
|
cfgs => OP_ARG_OPT,
|
|
okey => 'auth_hidepw', type => 'scalar', },
|
|
# translate base64 strings
|
|
{ opts => ['auth-plaintext', 'apt'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'auth_showpt', type => 'scalar', },
|
|
# auth optional (ignore failure)
|
|
{ opts => ['auth-optional', 'ao'], suffix => ':s',
|
|
cfgs => OP_ARG_OPT,
|
|
okey => 'auth_optional', type => 'scalar', },
|
|
# req auth if avail
|
|
{ opts => ['auth-optional-strict', 'aos'], suffix => ':s',
|
|
cfgs => OP_ARG_OPT,
|
|
okey => 'auth_optional_strict', type => 'scalar', },
|
|
# report capabilties
|
|
{ opts => ['support'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'get_support', type => 'scalar', },
|
|
# local interface to use
|
|
{ opts => ['local-interface', 'li'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'Interface: ', match => '^.*$',
|
|
okey => 'lint', type => 'scalar', },
|
|
# local port
|
|
{ opts => ['local-port', 'lport', 'lp'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'Local Port: ', match => '^\w+$',
|
|
okey => 'lport', type => 'scalar', },
|
|
# use TLS
|
|
{ opts => ['tls'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'tls', type => 'scalar', },
|
|
# use tls if available
|
|
{ opts => ['tls-optional', 'tlso'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'tls_optional', type => 'scalar', },
|
|
# req tls if avail
|
|
{ opts => ['tls-optional-strict', 'tlsos'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'tls_optional_strict', type => 'scalar', },
|
|
# use tls if available
|
|
{ opts => ['tls-on-connect', 'tlsc'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'tls_on_connect', type => 'scalar', },
|
|
# local cert to present to server
|
|
{ opts => ['tls-cert'], suffix => '=s',
|
|
cfgs => OP_ARG_REQ,
|
|
okey => 'tls_cert', type => 'scalar', },
|
|
# local key to present to server
|
|
{ opts => ['tls-key'], suffix => '=s',
|
|
cfgs => OP_ARG_REQ,
|
|
okey => 'tls_key', type => 'scalar', },
|
|
# tls protocol to use
|
|
{ opts => ['tls-protocol', 'tlsp'], suffix => '=s',
|
|
cfgs => OP_ARG_REQ,
|
|
okey => 'tls_protocol', type => 'scalar', },
|
|
# tls cipher to use
|
|
{ opts => ['tls-cipher'], suffix => '=s',
|
|
cfgs => OP_ARG_REQ,
|
|
okey => 'tls_cipher', type => 'scalar', },
|
|
# save tls peer certificate
|
|
{ opts => ['tls-get-peer-cert'], suffix => ':s',
|
|
cfgs => OP_ARG_OPT,
|
|
okey => 'tls_get_peer_cert', type => 'scalar', },
|
|
# hostname to request in TLS SNI header
|
|
{ opts => ['tls-sni'], suffix => '=s',
|
|
cfgs => OP_ARG_REQ,
|
|
okey => 'tls_sni_hostname', type => 'scalar', },
|
|
# require verification of server certificate
|
|
{ opts => ['tls-verify'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'tls_verify', type => 'scalar', },
|
|
# local key to present to server
|
|
{ opts => ['tls-ca-path'], suffix => '=s',
|
|
cfgs => OP_ARG_REQ,
|
|
okey => 'tls_ca_path', type => 'scalar', },
|
|
# suppress output to varying degrees
|
|
{ opts => ['silent', 'S'], suffix => ':i',
|
|
cfgs => OP_ARG_OPT,
|
|
callout => \&process_opt_silent,
|
|
okey => 'silent', type => 'scalar', },
|
|
# Don't strip From_ line from DATA
|
|
{ opts => ['no-strip-from', 'nsf'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'no_strip_from', type => 'scalar', },
|
|
# Don't show send/receive hints (legacy)
|
|
{ opts => ['no-hints', 'nth'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'no_hints', type => 'scalar', },
|
|
# Don't show transaction hints
|
|
{ opts => ['no-send-hints', 'nsh'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'no_hints_send', type => 'scalar', },
|
|
# Don't show transaction hints
|
|
{ opts => ['no-receive-hints', 'nrh'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'no_hints_recv', type => 'scalar', },
|
|
# Don't show transaction hints
|
|
{ opts => ['no-info-hints', 'nih'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'no_hints_info', type => 'scalar', },
|
|
# Don't show reception lines
|
|
{ opts => ['hide-receive', 'hr'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'hide_receive', type => 'scalar', },
|
|
# Don't show sending lines
|
|
{ opts => ['hide-send', 'hs'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'hide_send', type => 'scalar', },
|
|
# Don't echo input on potentially sensitive prompts
|
|
{ opts => ['protect-prompt', 'pp'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'protect_prompt', type => 'scalar', },
|
|
# Don't show any swaks-generated, non-error informational lines
|
|
{ opts => ['hide-informational', 'hi'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'hide_informational', type => 'scalar', },
|
|
# Don't send any output to the terminal
|
|
{ opts => ['hide-all', 'ha'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'hide_all', type => 'scalar', },
|
|
# print lapse for send/recv
|
|
{ opts => ['show-time-lapse', 'stl'], suffix => ':s',
|
|
cfgs => OP_ARG_OPT,
|
|
okey => 'show_time_lapse', type => 'scalar', },
|
|
# print version and exit
|
|
{ opts => ['version'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'version', type => 'scalar', },
|
|
# print help and exit
|
|
{ opts => ['help'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'help', type => 'scalar', },
|
|
# don't touch the data
|
|
{ opts => ['no-data-fixup', 'ndf'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'no_data_fixup', type => 'scalar', },
|
|
# show dumps of the raw read/written text
|
|
{ opts => ['show-raw-text', 'raw'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'show_raw_text', type => 'scalar', },
|
|
# specify file to write to
|
|
{ opts => ['output', 'output-file'], suffix => '=s',
|
|
cfgs => OP_ARG_REQ,
|
|
okey => 'output_file', type => 'scalar', },
|
|
# specify file to write to
|
|
{ opts => ['output-file-stdout'], suffix => '=s',
|
|
cfgs => OP_ARG_REQ,
|
|
okey => 'output_file_stdout', type => 'scalar', },
|
|
# specify file to write to
|
|
{ opts => ['output-file-stderr'], suffix => '=s',
|
|
cfgs => OP_ARG_REQ,
|
|
okey => 'output_file_stderr', type => 'scalar', },
|
|
# command to communicate with
|
|
{ opts => ['pipe'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'Pipe: ', match => '^.+$',
|
|
okey => 'pipe_cmd', type => 'scalar', },
|
|
# unix domain socket to talk to
|
|
{ opts => ['socket'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'Socket File: ', match => '^.+$',
|
|
okey => 'socket', type => 'scalar', },
|
|
# the content of the body of the DATA
|
|
{ opts => ['body'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT|OP_FROM_FILE,
|
|
prompt => 'Body: ', match => '.+',
|
|
okey => 'body_822', type => 'scalar', },
|
|
# A file to attach
|
|
{ opts => ['attach-name'], suffix => ':s',
|
|
cfgs => OP_ARG_OPT,
|
|
okey => 'attach_name', akey => 'attach_accum', type => 'list', },
|
|
# A file to attach
|
|
{ opts => ['attach-type'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ,
|
|
okey => 'attach_type', akey => 'attach_accum', type => 'list', },
|
|
# A file to attach
|
|
{ opts => ['attach'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_FILE,
|
|
okey => 'attach_attach', akey => 'attach_accum', type => 'list', },
|
|
# A file to attach
|
|
{ opts => ['attach-body'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_FILE,
|
|
okey => 'attach_body', akey => 'attach_accum', type => 'list', },
|
|
# replacement for %NEW_HEADERS% DATA token
|
|
{ opts => ['add-header', 'ah'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ,
|
|
okey => 'add_header', type => 'list', },
|
|
# replace header if exist, else add
|
|
{ opts => ['header'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ,
|
|
okey => 'header', type => 'list', },
|
|
# build options and dump
|
|
{ opts => ['dump'], suffix => ':s',
|
|
cfgs => OP_ARG_OPT,
|
|
okey => 'dump_args', type => 'scalar', },
|
|
# build options and dump the generate message body (EML)
|
|
{ opts => ['dump-mail'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'dump_mail', type => 'scalar', },
|
|
# attempt PIPELINING
|
|
{ opts => ['pipeline'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'pipeline', type => 'scalar', },
|
|
# attempt PRDR
|
|
{ opts => ['prdr'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'prdr', type => 'scalar', },
|
|
# use getpwuid building -f
|
|
{ opts => ['force-getpwuid'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'force_getpwuid', type => 'scalar', },
|
|
|
|
# XCLIENT
|
|
# These xclient_attrs options all get pushed onto an array so that we can determine their order later
|
|
# argument is a raw XCLIENT string
|
|
{ opts => ['xclient'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'XCLIENT string: ', match => '^.+$',
|
|
okey => 'xclient_raw', akey => 'xclient_accum', type => 'list', },
|
|
# XCLIENT NAME
|
|
{ opts => ['xclient-name'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'XCLIENT name: ', match => '^.+$',
|
|
okey => 'xclient_name', akey => 'xclient_accum', type => 'scalar', },
|
|
# XCLIENT ADDR
|
|
{ opts => ['xclient-addr'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'XCLIENT addr: ', match => '^.+$',
|
|
okey => 'xclient_addr', akey => 'xclient_accum', type => 'scalar', },
|
|
# XCLIENT PORT
|
|
{ opts => ['xclient-port'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'XCLIENT port: ', match => '^.+$',
|
|
okey => 'xclient_port', akey => 'xclient_accum', type => 'scalar', },
|
|
# XCLIENT PROTO
|
|
{ opts => ['xclient-proto'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'XCLIENT proto: ', match => '^.+$',
|
|
okey => 'xclient_proto', akey => 'xclient_accum', type => 'scalar', },
|
|
# XCLIENT DESTADDR
|
|
{ opts => ['xclient-destaddr'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'XCLIENT destaddr: ', match => '^.+$',
|
|
okey => 'xclient_destaddr', akey => 'xclient_accum', type => 'scalar', },
|
|
# XCLIENT DESTPORT
|
|
{ opts => ['xclient-destport'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'XCLIENT destport: ', match => '^.+$',
|
|
okey => 'xclient_destport', akey => 'xclient_accum', type => 'scalar', },
|
|
# XCLIENT HELO
|
|
{ opts => ['xclient-helo'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'XCLIENT helo: ', match => '^.+$',
|
|
okey => 'xclient_helo', akey => 'xclient_accum', type => 'scalar', },
|
|
# XCLIENT LOGIN
|
|
{ opts => ['xclient-login'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'XCLIENT login: ', match => '^.+$',
|
|
okey => 'xclient_login', akey => 'xclient_accum', type => 'scalar', },
|
|
# XCLIENT REVERSE_NAME
|
|
{ opts => ['xclient-reverse-name'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'XCLIENT reverse_name: ', match => '^.+$',
|
|
okey => 'xclient_reverse_name', akey => 'xclient_accum', type => 'scalar', },
|
|
# XCLIENT delimiter. Used to indicate that user wants to start a new xclient attr grouping
|
|
{ opts => ['xclient-delim'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'xclient_delim', akey => 'xclient_accum', type => 'list', },
|
|
# if set, XCLIENT will proceed even if XCLIENT not advertised
|
|
{ opts => ['xclient-optional'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'xclient_optional', type => 'scalar', },
|
|
# proceed if xclient not offered, but fail if offered and not accepted
|
|
{ opts => ['xclient-optional-strict'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'xclient_optional_strict', type => 'scalar', },
|
|
# we send xclient after starttls by default. if --xclient-before-starttls will send before tls
|
|
{ opts => ['xclient-before-starttls'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'xclient_before_starttls', type => 'scalar', },
|
|
# Don't require that the --xclient-ATTR attributes be advertised by server
|
|
{ opts => ['xclient-no-verify'], suffix => '',
|
|
cfgs => OP_ARG_NONE,
|
|
okey => 'xclient_no_verify', type => 'scalar', },
|
|
## xclient send by default after first helo, but can be sent almost anywhere (cf quit-after)
|
|
# { opts => ['xclient-after'], suffix => ':s',
|
|
# okey => 'xclient_after', type => 'scalar', },
|
|
|
|
# PROXY
|
|
# argument is the raw PROXY string
|
|
{ opts => ['proxy'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'PROXY string: ', match => '^.+$',
|
|
okey => 'proxy_raw', type => 'scalar', },
|
|
# PROXY version (1 or 2)
|
|
{ opts => ['proxy-version'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'PROXY version: ', match => '^[12]$',
|
|
okey => 'proxy_version', type => 'scalar', },
|
|
# PROXY protocol family (TCP4 or TCP6)
|
|
{ opts => ['proxy-family'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'PROXY family: ', match => '^.+$',
|
|
okey => 'proxy_family', type => 'scalar', },
|
|
# PROXY protocol command (LOCAL or PROXY)
|
|
{ opts => ['proxy-command'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'PROXY command: ', match => '^.+$',
|
|
okey => 'proxy_command', type => 'scalar', },
|
|
# PROXY transport protocol
|
|
{ opts => ['proxy-protocol'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'PROXY protocol: ', match => '^.+$',
|
|
okey => 'proxy_protocol', type => 'scalar', },
|
|
# PROXY source address (IPv4 or IPv6)
|
|
{ opts => ['proxy-source'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'PROXY source: ', match => '^.+$',
|
|
okey => 'proxy_source', type => 'scalar', },
|
|
# PROXY source port
|
|
{ opts => ['proxy-source-port'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'PROXY source_port: ', match => '^.+$',
|
|
okey => 'proxy_source_port', type => 'scalar', },
|
|
# PROXY destination address (IPv4 or IPv6)
|
|
{ opts => ['proxy-dest'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'PROXY dest: ', match => '^.+$',
|
|
okey => 'proxy_dest', type => 'scalar', },
|
|
# PROXY destination port
|
|
{ opts => ['proxy-dest-port'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_FROM_PROMPT,
|
|
prompt => 'PROXY dest_port: ', match => '^.+$',
|
|
okey => 'proxy_dest_port', type => 'scalar', },
|
|
|
|
# this option serve no purpose other than testing the deprecation system
|
|
{ opts => ['trigger-deprecation'], suffix => ':s',
|
|
cfgs => OP_ARG_REQ|OP_DEPRECATED,
|
|
okey => 'trigger_deprecation', type => 'scalar', },
|
|
);
|
|
|
|
return(\@G::raw_option_data);
|
|
}
|
|
|
|
# returns %O, the large raw option hash
|
|
# This sub is a jumping point. We will construct an argv based on the different ways that options can be specified
|
|
# and call GetOptions multiple times. We are essentially "layering" options. First we load from a config file (if
|
|
# exists/specified), then from any environment variables, then the actual command line.
|
|
sub load_args {
|
|
my %ARGS = (); # this is the structure that gets returned
|
|
my @fakeARGV = ();
|
|
|
|
# we load our options processing hash here. We abstract it back from the
|
|
# native getopt-format because we need to be able to intercept "no-" options
|
|
my $option_list = get_option_struct();
|
|
|
|
# do a loop through the options and make sure they are structured the way we expect
|
|
foreach my $e (@$option_list) {
|
|
if (!exists($e->{okey}) || !$e->{okey}) {
|
|
ptrans(12, 'Option configuration missing an okey (this is a swaks bug)');
|
|
exit(1);
|
|
}
|
|
elsif (!exists($e->{opts}) || ref($e->{opts}) ne 'ARRAY') {
|
|
ptrans(12, 'Option ' . $e->{okey} . ' missing or corrupt opts key (this is a swaks bug)');
|
|
exit(1);
|
|
}
|
|
elsif (!exists($e->{suffix})) {
|
|
ptrans(12, 'Option ' . $e->{okey} . ' missing suffix key (this is a swaks bug)');
|
|
exit(1);
|
|
}
|
|
elsif (!exists($e->{type}) || $e->{type} !~ /^(scalar|list)$/) {
|
|
ptrans(12, 'Option ' . $e->{okey} . ' missing or invalid type key (this is a swaks bug)');
|
|
exit(1);
|
|
}
|
|
elsif (!exists($e->{cfgs})) {
|
|
ptrans(12, 'Option ' . $e->{okey} . ' missing cfgs key (this is a swaks bug)');
|
|
exit(1);
|
|
}
|
|
|
|
$e->{akey} = $e->{okey} if (!exists($e->{akey}));
|
|
|
|
# 'cfgs' stores the okey config for easier access later
|
|
$ARGS{cfgs}{$e->{okey}} = $e;
|
|
}
|
|
|
|
# we want to process config files first. There's a default config file in
|
|
# ~/.swaksrc, but it is possible for the user to override this with the
|
|
# --config options. So, find the one and only file we will use here.
|
|
# If we encounter --config in later processing it is a noop.
|
|
# first find the default file
|
|
my $config_file = '';
|
|
my $skip_config = 0;
|
|
my $config_is_default = 1;
|
|
foreach my $v (qw(SWAKS_HOME HOME LOGDIR)) {
|
|
if (exists($ENV{$v}) && length($ENV{$v}) && -f $ENV{$v} . '/.swaksrc') {
|
|
$config_file = $ENV{$v} . '/.swaksrc';
|
|
last;
|
|
}
|
|
}
|
|
# then look through the ENV args to see if another file set there
|
|
if (exists($ENV{SWAKS_OPT_config})) {
|
|
if (!$ENV{SWAKS_OPT_config}) {
|
|
# if exist but not set, it just means "don't use default file"
|
|
$skip_config = 1;
|
|
} else {
|
|
$config_file = $ENV{SWAKS_OPT_config};
|
|
$config_is_default = 0;
|
|
}
|
|
}
|
|
# lastly go (backwards) through original command line looking for config file,
|
|
# choosing the first one found (meaning last one specified)
|
|
for (my $i = scalar(@ARGV) - 1; $i >= 0; $i--) {
|
|
if ($ARGV[$i] =~ /^-?-config$/) {
|
|
if ($i == scalar(@ARGV) - 1 || $ARGV[$i+1] =~ /^-/) {
|
|
$skip_config = 1;
|
|
} else {
|
|
$config_file = $ARGV[$i+1];
|
|
$config_is_default = 0;
|
|
$skip_config = 0;
|
|
}
|
|
last;
|
|
}
|
|
}
|
|
|
|
# All of the above will result in $config_file either being empty or
|
|
# containing the one and only config file we will use (though merged with DATA)
|
|
if (!$skip_config) {
|
|
my @configs = ('&DATA');
|
|
push(@configs, $config_file) if ($config_file);
|
|
foreach my $configf (@configs) {
|
|
my @fakeARGV = ();
|
|
if (open(C, '<' . $configf)) {
|
|
# "#" in col 0 is a comment
|
|
while (defined(my $m = <C>)) {
|
|
next if ($m =~ m|^#|);
|
|
chomp($m);
|
|
$m = '--' . $m if ($m !~ /^-/);
|
|
push(@fakeARGV, split(/\s/, $m, 2));
|
|
}
|
|
close(C);
|
|
} elsif (!$config_is_default && $configf eq $config_file) {
|
|
# we only print an error if the config was specified explicitly
|
|
ptrans(12, 'Config file ' . $configf . ' could not be opened ($!). Exiting');
|
|
exit(1);
|
|
}
|
|
|
|
# OK, all that work to load @fakeARGV with values from the config file. Now
|
|
# we just need to process it. (don't call if nothing set in @fakeARGV)
|
|
fetch_args(\%ARGS, $option_list, \@fakeARGV) if (scalar(@fakeARGV));
|
|
check_opt_processing(\@fakeARGV, 'Config file ' . $configf);
|
|
}
|
|
}
|
|
|
|
# OK, %ARGS contains all the settings from the config file. Now do it again
|
|
# with SWAKS_OPT_* environment variables
|
|
@fakeARGV = ();
|
|
foreach my $v (sort keys %ENV) {
|
|
if ($v =~ m|^SWAKS_OPT_(.*)$|) {
|
|
my $tv = $1; $tv =~ s|_|-|g;
|
|
push(@fakeARGV, '--' . $tv);
|
|
push(@fakeARGV, $ENV{$v}) if (length($ENV{$v}));
|
|
}
|
|
}
|
|
fetch_args(\%ARGS, $option_list, \@fakeARGV) if (scalar(@fakeARGV));
|
|
check_opt_processing(\@fakeARGV, 'environment');
|
|
|
|
# and now, after all of that, process the actual cmdline args
|
|
fetch_args(\%ARGS, $option_list, \@ARGV) if (scalar(@ARGV));
|
|
check_opt_processing(\@ARGV, 'command line');
|
|
|
|
return(\%ARGS);
|
|
}
|
|
|
|
# if there's anything left in the fake argv after Getopts processed it, it's an error. There's nothing
|
|
# that can be passed in to swaks that isn't an option or an argument to an option, all of which Getopt
|
|
# should consume. So if there's anything left, the user did something weird. Just let them know and
|
|
# error instead of letting them think their ignored stuff is working.
|
|
sub check_opt_processing {
|
|
my $argv_local = shift;
|
|
my $option_type = shift;
|
|
|
|
if (scalar(@$argv_local)) {
|
|
ptrans(12, 'Data left in option list when processing ' . $option_type . ' (' .
|
|
join(', ', map { "'$_'" } (@$argv_local)) .
|
|
'). Exiting');
|
|
exit(1);
|
|
}
|
|
}
|
|
|
|
sub fetch_args {
|
|
my $r = shift;
|
|
my $l = shift;
|
|
my $argv_local = shift;
|
|
|
|
my %to_delete = ();
|
|
|
|
# need to rewrite header-HEADER opts before std option parsing
|
|
# also see if there are any --no- options that need to be processed
|
|
RUNOPTS:
|
|
for (my $i = 0; $i < scalar(@$argv_local); $i++) {
|
|
# before doing any option processing, massage from the optional '--option=arg' format into '--option arg' format.
|
|
if ($argv_local->[$i] =~ /^(-[^=]+)=(.*)$/) {
|
|
$argv_local->[$i] = $1;
|
|
splice(@$argv_local, $i+1, 0, $2);
|
|
}
|
|
|
|
# -g is not really necessary. It is now deprecated. During the deprecation window, make
|
|
# it a straight-up alias to `--data -`. If has already appeared, just ignore -g. If
|
|
# --data has not appeared, change -g into `--data -`.
|
|
if ($argv_local->[$i] =~ /^-?-g$/) {
|
|
deprecate('The -g option is deprecated and will be removed. Please use \'--data -\' instead.');
|
|
if (scalar(grep(/^-?-data$/, @$argv_local)) || check_arg('mail_data', $r)) {
|
|
# if --data appears in the current stream or has already appeared in a previous stream, ignore -g
|
|
splice(@$argv_local, $i, 1); # remove the current index from @$argv_local
|
|
redo(RUNOPTS); # since there's now a new value at $i, redo this iteration of the loop
|
|
}
|
|
else {
|
|
# if we haven't seen --data yet, change -g into `--data -`
|
|
splice(@$argv_local, $i, 1, '--data', '-');
|
|
}
|
|
}
|
|
|
|
if ($argv_local->[$i] =~ /^-?-h(?:eader)?-([^:]+):?$/) {
|
|
# rewrite '--header-Foo bar' into '--header "Foo: bar"'
|
|
$argv_local->[$i] = "--header";
|
|
$argv_local->[$i+1] = $1 . ': ' . $argv_local->[$i+1];
|
|
}
|
|
elsif ($argv_local->[$i] =~ /^-?-no-h(?:eader)?-/) {
|
|
# rewrite '--no-header-Foo' into '--no-header'
|
|
$argv_local->[$i] = "--no-header";
|
|
}
|
|
}
|
|
|
|
# build the actual hash we will pass to GetOptions from our config list ($l):
|
|
# In the end I decided to build this at each call of this sub so that $r
|
|
# is defined. It's not much of a performance issue.
|
|
my %options = ();
|
|
foreach my $e (@$l) {
|
|
my $k = join('|', @{$e->{opts}}) . $e->{suffix};
|
|
my $nk = join('|', map { "no-$_" } (@{$e->{opts}}));
|
|
my $eval;
|
|
if ($e->{type} eq 'scalar' || $e->{type} eq 'list') {
|
|
$eval = "\$options{\$k} = sub { store_option(\$e, \$r, 0, \@_); };"
|
|
. "\$options{\$nk} = sub { store_option(\$e, \$r, 1, \@_); };";
|
|
}
|
|
else {
|
|
ptrans(12, "Unknown option type '$e->{type}' (this is a swaks bug)");
|
|
exit(1);
|
|
}
|
|
eval($eval);
|
|
if ($@) {
|
|
chomp($@);
|
|
ptrans(12, "Unable to load callback for $k option processing: $@");
|
|
exit(1);
|
|
}
|
|
}
|
|
|
|
if (!load("Getopt::Long")) {
|
|
ptrans(12, "Unable to load Getopt::Long for option processing, Exiting");
|
|
exit(1);
|
|
}
|
|
|
|
Getopt::Long::Configure("no_ignore_case");
|
|
Getopt::Long::GetOptionsFromArray($argv_local, %options) || exit(1);
|
|
}
|
|
|
|
sub store_option {
|
|
my $cfg_struct = shift; # this is the option definition structure
|
|
my $opt_struct = shift; # this is where we will be saving the option for later retrieval
|
|
my $remove = shift; # if true, we received a "no-" version of the option, remove all previous instances
|
|
my $opt_name = shift; # --xclient-name || --dump-mail || -f
|
|
my $opt_value = shift; # NAME || undef || foo@example.com
|
|
my $accum_key = $cfg_struct->{akey}; # xclient_attrs || dump_mail || mail_from
|
|
my $opt_key = $cfg_struct->{okey}; # xclient_name || dump_mail || mail_from
|
|
my $type = $cfg_struct->{type}; # scalar or list
|
|
|
|
# print "store_options called -> $cfg_struct, $opt_struct, $opt_name, $opt_value, $accum_key, $opt_key, $type\n";
|
|
|
|
if ($cfg_struct->{cfgs} & OP_DEPRECATED) {
|
|
deprecate("Option --$opt_name will be removed in the future. Please see documentation for more information.");
|
|
}
|
|
|
|
# 'accum' stores lists of the order they were received in
|
|
$opt_struct->{accums}{$accum_key} ||= [];
|
|
# 'values' stores the actual values and the name of the option that was used to pass it
|
|
$opt_struct->{values}{$opt_key} ||= [];
|
|
|
|
# if we're recording a scalar or were asked to remove, reset the values list to throw away any previous values
|
|
# and remove any previous recordings of this okey from the accumulator list
|
|
if ($type eq 'scalar' || $remove) {
|
|
$opt_struct->{values}{$opt_key} = [];
|
|
$opt_struct->{accums}{$accum_key} = [ grep { $_ ne $opt_key } (@{$opt_struct->{accums}{$accum_key}}) ];
|
|
}
|
|
|
|
# if we were asked to remove (which means called with a "--no-" prefix), get out now, there's nothing to record
|
|
return if ($remove);
|
|
|
|
push(@{$opt_struct->{accums}{$accum_key}}, $opt_key);
|
|
|
|
my $arg = $opt_value;
|
|
if ($cfg_struct->{callout}) {
|
|
$arg = $cfg_struct->{callout}("$opt_name", $arg);
|
|
}
|
|
|
|
push(@{$opt_struct->{values}{$opt_key}}, {
|
|
okey => $opt_key,
|
|
akey => $accum_key,
|
|
opt => "$opt_name",
|
|
arg => $arg,
|
|
});
|
|
}
|
|
|
|
# take a string and quote it such that it could be used in the shell
|
|
# O'Reilley -> 'O'\''Reilley'
|
|
sub shquote { my $s = shift; $s =~ s%'%'\\''%g; return "'$s'"; }
|
|
|
|
sub reconstruct_options {
|
|
my $o = shift; # ref to raw option hash (as returned by load_args)
|
|
my @c = (); # array to hold our reconstructed command line
|
|
my %already_seen = (); # for okeys like xclient_attrs, they only need to be processed once
|
|
my %indexer = ();
|
|
|
|
foreach my $opt (@G::raw_option_data) {
|
|
next if ($already_seen{$opt->{akey}});
|
|
next if (!exists($o->{accums}{$opt->{akey}}));
|
|
|
|
foreach my $okey (@{$o->{accums}{$opt->{akey}}}) {
|
|
$indexer{$okey} ||= 0;
|
|
my $optStruct = $o->{values}{$okey}[$indexer{$okey}];
|
|
my $lopt = $o->{cfgs}{$okey}{opts}[0];
|
|
|
|
push(@c, '--'.$lopt);
|
|
if (length($optStruct->{arg}) && !($o->{cfgs}{$okey}{cfgs} & OP_ARG_NONE)) {
|
|
if ($okey eq 'auth_pass') {
|
|
push(@c, shquote('%RAW_PASSWORD_STRING%'));
|
|
}
|
|
else {
|
|
push(@c, shquote($optStruct->{arg}));
|
|
}
|
|
}
|
|
}
|
|
$already_seen{$opt->{akey}} = 1;
|
|
}
|
|
|
|
#print join(', ', @c), "\n";
|
|
return join(' ', @c);
|
|
}
|
|
|
|
sub get_accum {
|
|
my $accum_key = shift;
|
|
my $userOpts = shift;
|
|
|
|
if (!exists($userOpts->{accums}{$accum_key})) {
|
|
return([]);
|
|
}
|
|
|
|
return($userOpts->{accums}{$accum_key});
|
|
}
|
|
|
|
# I might change this interface later, but I want a way to check whether the user provided the option
|
|
# without actually processing it.
|
|
sub check_arg {
|
|
my $opt = shift;
|
|
my $userOpts = shift;
|
|
|
|
if (exists($userOpts->{values}{$opt}) && scalar(@{$userOpts->{values}{$opt}})) {
|
|
return(1);
|
|
}
|
|
|
|
return(0);
|
|
}
|
|
|
|
# get the next value for $opt without doing any processing or popping it off of the list.
|
|
sub peek_arg {
|
|
my $opt = shift; # this should correspond to an okey from the @G::raw_option_data array
|
|
my $userOpts = shift; # all options we got from the command line
|
|
|
|
if (!exists($userOpts->{values}{$opt})) {
|
|
return(undef());
|
|
}
|
|
|
|
if (!scalar(@{$userOpts->{values}{$opt}})) {
|
|
return(undef());
|
|
}
|
|
|
|
return($userOpts->{values}{$opt}[0]{arg});
|
|
}
|
|
|
|
# there was a ton of repeated, boiler plate code in process_args. Attempt to abstract it out to get_arg
|
|
sub get_arg {
|
|
my $opt = shift; # this should correspond to an okey from the @G::raw_option_data array
|
|
my $userOpts = shift; # all options we got from the command line
|
|
my $optConfig = shift;
|
|
my $force = shift;
|
|
my $arg;
|
|
my $argExt;
|
|
my $return;
|
|
|
|
# print "in get_arg, opt = $opt\n";
|
|
|
|
# If the user didn't pass in a specific option config, look it up from the global option config
|
|
if (!$optConfig) {
|
|
if (!exists($userOpts->{cfgs}{$opt})) {
|
|
ptrans(12, "Internal option processing error: asked to evaluate non-existent option $opt");
|
|
exit(1);
|
|
}
|
|
$optConfig = $userOpts->{cfgs}{$opt};
|
|
}
|
|
|
|
# $arg will be the value actually provided on the command line
|
|
# !defined = not provided
|
|
# defined && !length = option provided but no argument provided
|
|
# defined && length = option provided and argument provided
|
|
if (!exists($userOpts->{values}{$opt})) {
|
|
# if the caller passed in $force, we act as if the option is present with an empty arg
|
|
# this is used when we need to use get_arg features like interact() even when the user
|
|
# didn't specify the option (specifically, --auth forces --auth-password to need to be
|
|
# processed, even if the user didn't pass it in)
|
|
$arg = $force ? '' : undef();
|
|
}
|
|
else {
|
|
$argExt = shift(@{$userOpts->{values}{$opt}});
|
|
$arg = $argExt->{arg};
|
|
}
|
|
|
|
# this option takes no arguments - it's a straight boolean
|
|
if ($optConfig->{cfgs} & OP_ARG_NONE) {
|
|
if ($arg) {
|
|
$return = 1;
|
|
}
|
|
else {
|
|
$return = 0;
|
|
}
|
|
}
|
|
|
|
# if the option is present, it must have an argument.
|
|
# theoretically I should have code here actually requiring the argument,
|
|
# but at the moment that's being handled by Getopt::Long
|
|
elsif ($optConfig->{cfgs} & OP_ARG_REQ) {
|
|
if (!defined($arg)) {
|
|
# the opt wasn't specified at all. Perfectly legal, return undef
|
|
$return = undef;
|
|
}
|
|
else {
|
|
# if there was an arg provided, just return it
|
|
if (length($arg)) {
|
|
$return = $arg;
|
|
}
|
|
# No arg, but we were requested to prompt the user - do so
|
|
elsif ($optConfig->{cfgs} & OP_FROM_PROMPT) {
|
|
if (!exists($optConfig->{prompt})) {
|
|
ptrans(12, "Internal option processing error: option $argExt->{opt} missing required prompt key (this is a swaks bug)");
|
|
exit(1);
|
|
}
|
|
if (!exists($optConfig->{match})) {
|
|
ptrans(12, "Internal option processing error: option $argExt->{opt} missing required match key (this is a swaks bug)");
|
|
exit(1);
|
|
}
|
|
$return = interact($optConfig->{prompt}, $optConfig->{match});
|
|
}
|
|
# No arg, no request to prompt - this is an error since we're requiring an arg
|
|
else {
|
|
ptrans(12, "Option processing error: option $argExt->{opt} specified with no argument");
|
|
exit(1);
|
|
}
|
|
|
|
# OP_FROM_FILE means that the above options might have resolved into '-' or @filename. If so, return the actual
|
|
# data contained in STDIN/@filename
|
|
if ($optConfig->{cfgs} & OP_FROM_FILE) {
|
|
if ($return eq '-') {
|
|
if (defined($G::stdin)) {
|
|
# multiple options can specify stdin, but we can only read it once. If anyone has
|
|
# already read stdin, provide the saved value here
|
|
$return = $G::stdin;
|
|
}
|
|
else {
|
|
$return = join('', <STDIN>);
|
|
$G::stdin = $return;
|
|
}
|
|
}
|
|
elsif ($return =~ /^\@\@/) {
|
|
# if the argument starts with \@\@, we take that to mean that the user wants a literal value that starts
|
|
# with an @. The first @ is just an indicator, so strip it off before continuing
|
|
$return =~ s/^\@//;
|
|
}
|
|
elsif ($return =~ /^\@/) {
|
|
# a single @ means it's a filename. Open it and use the contents as the return value
|
|
$return =~ s/^\@//;
|
|
if (!open(F, "<$return")) {
|
|
ptrans(12, "Option processing error: file $return not openable for option $argExt->{opt} ($!)");
|
|
exit(1);
|
|
}
|
|
$return = join('', <F>);
|
|
close(F);
|
|
}
|
|
|
|
{
|
|
# All of the functionality in this bare block is deprecated, remove the whole thing later.
|
|
# if --data and single line, try to open it, error otherwise
|
|
# if !--data and is openable file, try to open and read, otherwise just use it as literal data
|
|
if ($argExt->{opt} eq 'data') {
|
|
# the old rule for --data was that anything that didn't have a newline in it would be treated
|
|
# as a file, and we would error if we couldn't open it. That would prevent us from sending
|
|
# typoed filenames as the data of messages
|
|
if ($return !~ m/\\n|\n|%NEWLINE%/) {
|
|
deprecate('Inferring a filename from the argument to --' . $argExt->{opt} .
|
|
' will be removed in the future. Prefix filenames with \'@\' instead.');
|
|
if (!open(F, "<$return")) {
|
|
ptrans(12, "$argExt->{opt} option appears to be a file but is not openable: $return ($!)");
|
|
exit(1);
|
|
}
|
|
$return = join('', <F>);
|
|
close(F);
|
|
}
|
|
}
|
|
elsif (open(F, "<$return")) {
|
|
# the old rule for any other file option (--attach, --attach-body, --body) was that
|
|
# if it was openable, we would use the contents of the file, otherwise we would
|
|
# use the string itself
|
|
deprecate('Inferring a filename from the argument to --' . $argExt->{opt} .
|
|
' will be removed in the future. Prefix filenames with \'@\' instead.');
|
|
$return = join('', <F>);
|
|
close(F);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# The option can be present with or without an argument
|
|
# any "true" return value will be an actual provided option
|
|
# false and defined = option given but no argument given
|
|
# false and undefined = option not specified
|
|
elsif ($optConfig->{cfgs} & OP_ARG_OPT) {
|
|
if (!defined($arg)) {
|
|
# the opt wasn't specified at all. Perfectly legal, return undef
|
|
$return = undef;
|
|
}
|
|
else {
|
|
# we have an opt and an arg, return the arg
|
|
$return = $arg;
|
|
}
|
|
}
|
|
|
|
# if we read the last arg off an array, put it back on the array for future reads. I can't
|
|
# decide if this is the right behavior or not, but this makes it more like scalars, which
|
|
# can (and in a couple of cases, must) be read multiple times.
|
|
if (defined($arg) && ref($userOpts->{values}{$opt}) && !scalar(@{$userOpts->{values}{$opt}})) {
|
|
push(@{$userOpts->{values}{$opt}}, $argExt);
|
|
}
|
|
|
|
# print "returning ";
|
|
# if (defined($return)) {
|
|
# print length($return) ? "$return\n" : "defined but empty\n";
|
|
# }
|
|
# else {
|
|
# print "undefined\n";
|
|
# }
|
|
return($return);
|
|
}
|
|
|
|
# A couple of global options are set in here, they will be in the G:: namespace
|
|
sub process_args {
|
|
my $o = shift; # This is the args we got from command line
|
|
my %n = (); # This is the hash we will return w/ the fixed-up args
|
|
my $a = get_option_struct(); # defining information for all options
|
|
|
|
# handle the output file handles early so they can be used for errors
|
|
# we don't need to keep track of the actual files but it will make debugging
|
|
# easier later
|
|
$G::trans_fh_oh = \*STDOUT;
|
|
$G::trans_fh_of = "STDOUT";
|
|
$G::trans_fh_eh = \*STDERR;
|
|
$G::trans_fh_ef = "STDERR";
|
|
my $output_file = get_arg('output_file', $o);
|
|
my $output_file_stderr = get_arg('output_file_stderr', $o) || $output_file;
|
|
my $output_file_stdout = get_arg('output_file_stdout', $o) || $output_file;
|
|
if ($output_file_stderr) {
|
|
if (!open(OUTEFH, '>>'.$output_file_stderr)) {
|
|
ptrans(12, 'Unable to open ' . $output_file_stderr . ' for writing');
|
|
exit(1);
|
|
}
|
|
$G::trans_fh_eh = \*OUTEFH;
|
|
$G::trans_fh_ef = $output_file_stderr;
|
|
}
|
|
if ($output_file_stdout && $output_file_stdout eq $output_file_stderr) {
|
|
$G::trans_fh_oh = $G::trans_fh_eh;
|
|
$G::trans_fh_of = $G::trans_fh_ef;
|
|
}
|
|
elsif ($output_file_stdout) {
|
|
if (!open(OUTOFH, '>>'.$output_file_stdout)) {
|
|
ptrans(12, 'Unable to open ' . $output_file_stdout . ' for writing');
|
|
exit(1);
|
|
}
|
|
$G::trans_fh_oh = \*OUTOFH;
|
|
$G::trans_fh_of = $output_file_stdout;
|
|
}
|
|
|
|
if (get_arg('no_hints', $o)) {
|
|
$G::no_hints_send = 1;
|
|
$G::no_hints_recv = 1;
|
|
}
|
|
else {
|
|
$G::no_hints_send = get_arg('no_hints_send', $o);
|
|
$G::no_hints_recv = get_arg('no_hints_recv', $o);
|
|
}
|
|
$G::dump_mail = get_arg('dump_mail', $o);
|
|
$G::suppress_data = get_arg('suppress_data', $o);
|
|
$G::no_hints_info = get_arg('no_hints_info', $o);
|
|
$G::hide_send = get_arg('hide_send', $o);
|
|
$G::hide_receive = get_arg('hide_receive', $o);
|
|
$G::hide_informational = get_arg('hide_informational', $o);
|
|
$G::hide_all = get_arg('hide_all', $o);
|
|
$G::show_raw_text = get_arg('show_raw_text', $o);
|
|
$G::protect_prompt = get_arg('protect_prompt', $o);
|
|
$G::pipeline = get_arg('pipeline', $o);
|
|
$G::prdr = get_arg('prdr', $o);
|
|
$G::silent = get_arg('silent', $o) || 0;
|
|
|
|
if (defined(my $dump_args = get_arg('dump_args', $o))) {
|
|
map { $G::dump_args{uc($_)} = 1; } (split('\s*,\s*', $dump_args)); # map comma-delim options into a hash
|
|
$G::dump_args{'ALL'} = 1 if (!scalar(keys(%G::dump_args))); # if no options were given, just set ALL
|
|
}
|
|
|
|
my $mail_server_t = get_arg('mail_server', $o);
|
|
my $socket_t = get_arg('socket', $o);
|
|
my $pipe_cmd_t = get_arg('pipe_cmd', $o);
|
|
|
|
# it is an error if >1 of --server, --socket, or --pipe is specified
|
|
if ((defined($mail_server_t) && defined($socket_t)) ||
|
|
(defined($mail_server_t) && defined($pipe_cmd_t)) ||
|
|
(defined($pipe_cmd_t) && defined($socket_t)))
|
|
{
|
|
ptrans(12, "Multiple transport types specified, exiting");
|
|
exit(1);
|
|
}
|
|
|
|
my %protos = (
|
|
smtp => { proto => 'smtp', auth => 0, tls => '0' },
|
|
ssmtp => { proto => 'esmtp', auth => 0, tls => 'c' },
|
|
ssmtpa => { proto => 'esmtp', auth => 1, tls => 'c' },
|
|
smtps => { proto => 'smtp', auth => 0, tls => 'c' },
|
|
esmtp => { proto => 'esmtp', auth => 0, tls => '0' },
|
|
esmtpa => { proto => 'esmtp', auth => 1, tls => '0' },
|
|
esmtps => { proto => 'esmtp', auth => 0, tls => 's' },
|
|
esmtpsa => { proto => 'esmtp', auth => 1, tls => 's' },
|
|
lmtp => { proto => 'lmtp', auth => 0, tls => '0' },
|
|
lmtpa => { proto => 'lmtp', auth => 1, tls => '0' },
|
|
lmtps => { proto => 'lmtp', auth => 0, tls => 's' },
|
|
lmtpsa => { proto => 'lmtp', auth => 1, tls => 's' },
|
|
);
|
|
$G::protocol = lc(get_arg('mail_protocol', $o)) || 'esmtp';
|
|
my $tls = get_arg('tls', $o);
|
|
my $tls_optional = get_arg('tls_optional', $o);
|
|
my $tls_optional_strict = get_arg('tls_optional_strict', $o);
|
|
my $tls_on_connect = get_arg('tls_on_connect', $o);
|
|
if (!$protos{$G::protocol}) {
|
|
ptrans(12, "Unknown protocol $G::protocol specified, exiting");
|
|
exit(1);
|
|
}
|
|
my $auth_user_t = get_arg('auth_user', $o);
|
|
my $auth_pass_t = get_arg('auth_pass', $o);
|
|
my $auth_optional_t = get_arg('auth_optional', $o);
|
|
my $auth_optional_strict_t = get_arg('auth_optional_strict', $o);
|
|
my $auth_t = get_arg('auth', $o);
|
|
if ($protos{$G::protocol}{auth} && !$auth_user_t && !$auth_pass_t && !$auth_optional_t && !$auth_optional_strict_t && !$auth_t) {
|
|
$auth_t = ''; # cause auth to be processed below
|
|
}
|
|
if ($protos{$G::protocol}{tls} && !$tls && !$tls_optional && !$tls_optional_strict && !$tls_on_connect){
|
|
# 'touch' the variable so we process it below
|
|
if ($protos{$G::protocol}{tls} eq 's') {
|
|
$tls = 1;
|
|
} elsif ($protos{$G::protocol}{tls} eq 'c') {
|
|
$tls_on_connect = 1;
|
|
}
|
|
}
|
|
$G::protocol = $protos{$G::protocol}{proto};
|
|
|
|
# set global options for --quit-after, --drop-after, and --drop-after-send
|
|
foreach my $opt ('quit_after', 'drop_after', 'drop_after_send') {
|
|
no strict "refs";
|
|
if (my $value = get_arg($opt, $o)) {
|
|
${"G::$opt"} = lc($value);
|
|
if (${"G::$opt"} =~ /^[el]hlo$/) { ${"G::$opt"} = 'helo'; }
|
|
elsif (${"G::$opt"} =~ /first-[el]hlo/) { ${"G::$opt"} = 'first-helo'; }
|
|
elsif (${"G::$opt"} eq 'starttls') { ${"G::$opt"} = 'tls'; }
|
|
elsif (${"G::$opt"} eq 'banner') { ${"G::$opt"} = 'connect'; }
|
|
elsif (${"G::$opt"} eq 'from') { ${"G::$opt"} = 'mail'; }
|
|
elsif (${"G::$opt"} eq 'to') { ${"G::$opt"} = 'rcpt'; }
|
|
elsif (${"G::$opt"} ne 'connect' && ${"G::$opt"} ne 'first-helo' &&
|
|
${"G::$opt"} ne 'tls' && ${"G::$opt"} ne 'helo' &&
|
|
${"G::$opt"} ne 'auth' && ${"G::$opt"} ne 'mail' &&
|
|
${"G::$opt"} ne 'rcpt' && ${"G::$opt"} ne 'xclient' &&
|
|
${"G::$opt"} ne 'data' && ${"G::$opt"} ne 'dot')
|
|
{
|
|
ptrans(12, "Unknown $opt value " . ${"G::$opt"} . ", exiting");
|
|
exit(1);
|
|
}
|
|
# only rcpt, data, and dot _require_ a to address
|
|
$G::server_only = 1 if (${"G::$opt"} !~ /^(rcpt|data|dot)$/);
|
|
|
|
# data and dot aren't legal for quit_after
|
|
if ($opt eq 'quit_after' && (${"G::$opt"} eq 'data' || ${"G::$opt"} eq 'dot')) {
|
|
ptrans(12, "Unknown $opt value " . ${"G::$opt"} . ", exiting");
|
|
exit(1);
|
|
}
|
|
} else {
|
|
${"G::$opt"} = '';
|
|
}
|
|
}
|
|
|
|
# set global flag for -stl flag
|
|
$G::show_time_lapse = get_arg('show_time_lapse', $o);
|
|
if (defined($G::show_time_lapse)) {
|
|
if (length($G::show_time_lapse) && $G::show_time_lapse !~ /^i/i) {
|
|
ptrans(12, "Unknown argument '$G::show_time_lapse' to option show-time-lapse, exiting");
|
|
exit(1);
|
|
}
|
|
if (avail("hires_timing") && $G::show_time_lapse !~ /^i/i) {
|
|
$G::show_time_lapse = 'hires';
|
|
}
|
|
else {
|
|
$G::show_time_lapse = 'integer';
|
|
}
|
|
}
|
|
|
|
# pipe command, if one is specified
|
|
if ($pipe_cmd_t) {
|
|
$G::link{process} = $pipe_cmd_t;
|
|
$G::link{type} = 'pipe';
|
|
}
|
|
|
|
# socket file, if one is specified
|
|
if ($socket_t) {
|
|
$G::link{sockfile} = $socket_t;
|
|
$G::link{type} = 'socket-unix';
|
|
}
|
|
|
|
$n{force_getpwuid} = get_arg('force_getpwuid', $o); # make available for --dump
|
|
my $user = get_username($n{force_getpwuid});
|
|
my $hostname = get_hostname();
|
|
|
|
# SMTP mail from
|
|
if (!($n{from} = get_arg('mail_from', $o))) {
|
|
if ($hostname || ($G::server_only && $G::quit_after ne 'mail' && $G::drop_after ne 'mail' && $G::drop_after_send ne 'mail')) {
|
|
# if we have a hostname, or it doesn't matter anyway because we won't actually need it, use our manufactured from
|
|
$n{from} = "$user\@$hostname";
|
|
}
|
|
else {
|
|
ptrans(12, "From string required but couldn't be determined automatically. Please use --from");
|
|
exit(1);
|
|
}
|
|
}
|
|
$n{from} = '' if ($n{from} eq '<>');
|
|
|
|
# local interface and port
|
|
($G::link{lint},$G::link{lport}) = parse_server(get_arg('lint', $o), get_arg('lport', $o));
|
|
if ($G::link{lport} && $G::link{lport} !~ /^\d+$/) {
|
|
if (my $port = getservbyname($G::link{lport}, 'tcp')) {
|
|
$G::link{lport} = $port;
|
|
}
|
|
else {
|
|
ptrans(12, "unable to resolve service name $G::link{lport} into a port, exiting");
|
|
exit(1);
|
|
}
|
|
}
|
|
|
|
# SMTP helo/ehlo
|
|
if (!($n{helo} = get_arg('mail_helo', $o))) {
|
|
if ($hostname || ($G::quit_after eq 'connect' || $G::drop_after eq 'connect' || $G::drop_after_send eq 'connect')) {
|
|
# if we have a hostname, or it doesn't matter anyway because we won't actually need it, use our manufactured from
|
|
$n{helo} = $hostname;
|
|
}
|
|
else {
|
|
ptrans(12, "Helo string required but couldn't be determined automatically. Please use --helo");
|
|
exit(1);
|
|
}
|
|
}
|
|
|
|
# SMTP server, port and rcpt-to are interdependant, so they are handled together
|
|
$G::link{type} ||= 'socket-inet';
|
|
($G::link{server},$G::link{port}) = parse_server($mail_server_t, get_arg('mail_port', $o));
|
|
$n{to} = get_arg('mail_to', $o);
|
|
# we absolutely must have a recipient. If we don't have one yet, prompt for one
|
|
if (!$n{to} && !($G::server_only && ($G::link{server} || $G::link{type} eq 'socket-unix' || $G::link{type} eq 'pipe'))) {
|
|
$n{to} = interact("To: ", '^.+$'); # WCSXXXFIXME I wish we could look up the prompt and re from $a
|
|
}
|
|
|
|
# try to catch obvious -s/-li/-4/-6 errors as soon as possible. We don't actually do any DNS
|
|
# lookups ourselves, so errors like -s being a domain with only A RRs and -li being a domain
|
|
# with only AAAA RRs, or -s being an ipv6 and -li being a domain with only A RRs, will
|
|
# get passed into the IO::Socket module to deal with and will just registed as a connection
|
|
# failure.
|
|
if ($G::link{type} eq 'socket-inet') {
|
|
my $forceIPv4 = get_arg('force_ipv4', $o);
|
|
my $forceIPv6 = get_arg('force_ipv6', $o);
|
|
if ($forceIPv4 && $forceIPv6) {
|
|
ptrans(12, "Options -4 and -6 are mutually exclusive, cannot proceed");
|
|
exit 1;
|
|
} elsif ($forceIPv6) {
|
|
$G::link{force_ipv6} = 1;
|
|
} elsif ($forceIPv4) {
|
|
$G::link{force_ipv4} = 1;
|
|
}
|
|
|
|
if ($n{copy_routing} = get_arg('copy_routing', $o)) {
|
|
$G::link{server} ||= get_server($n{copy_routing});
|
|
}
|
|
else {
|
|
$G::link{server} ||= get_server($n{to});
|
|
}
|
|
|
|
if ($forceIPv4 && $G::link{server} =~ m|:|) {
|
|
ptrans(12, "Option -4 is set but server appears to be ipv6, cannot proceed");
|
|
exit 1;
|
|
} elsif ($forceIPv4 && $G::link{lint} =~ m|:|) {
|
|
ptrans(12, "Option -4 is set but local-interface appears to be ipv6, cannot proceed");
|
|
exit 1;
|
|
} elsif ($forceIPv6 && $G::link{server} =~ m|^\d+\.\d+\.\d+\.\d+$|) {
|
|
ptrans(12, "Option -6 is set but server appears to be ipv4, cannot proceed");
|
|
exit 1;
|
|
} elsif ($forceIPv6 && $G::link{lint} =~ m|^\d+\.\d+\.\d+\.\d+$|) {
|
|
ptrans(12, "Option -6 is set but local-interface appears to be ipv4, cannot proceed");
|
|
exit 1;
|
|
} elsif ($G::link{server} =~ m|:| && $G::link{lint} =~ m|^\d+\.\d+\.\d+\.\d+$|) {
|
|
ptrans(12, "server is ipv6 but local-interface is ipv4, cannot proceed");
|
|
exit 1;
|
|
} elsif ($G::link{server} =~ m|^\d+\.\d+\.\d+\.\d+$| && $G::link{lint} =~ m|:|) {
|
|
ptrans(12, "server is ipv4 but local-interface is ipv6, cannot proceed");
|
|
exit 1;
|
|
}
|
|
}
|
|
|
|
# Verify we are able to handle the requested transport
|
|
if ($G::link{type} eq 'pipe') {
|
|
if (!avail("pipe")) {
|
|
ptrans(12, avail_str("pipe").". Exiting");
|
|
exit(10);
|
|
}
|
|
} else {
|
|
if (!avail("socket")) {
|
|
ptrans(12, avail_str("socket").". Exiting");
|
|
exit(10);
|
|
} elsif (($G::link{force_ipv6} || $G::link{server} =~ m|:| || $G::link{lint} =~ m|:|) && !avail("ipv6")) {
|
|
ptrans(12, avail_str("ipv6").". Exiting");
|
|
exit(10);
|
|
}
|
|
}
|
|
|
|
# SMTP timeout
|
|
$G::link{timeout} = time_to_seconds(get_arg('timeout', $o) // '30s');
|
|
|
|
my $dab_sp = get_arg('dab_sp', $o);
|
|
my $dump_as_body = get_arg('dump_as_body', $o);
|
|
$dump_as_body = '' if ($dab_sp && !defined($dump_as_body));
|
|
my $body = 'This is a test mailing'; # default message body
|
|
$body = 'DUMP_AS_BODY_HAS_BEEN_SET' if (defined($dump_as_body));
|
|
my $bound = '';
|
|
my $main_content_type = 'multipart/mixed';
|
|
my $stdin = undef;
|
|
if (defined(my $body_822_t = get_arg('body_822', $o))) {
|
|
# the --body option is the entire 822 body and trumps any other options
|
|
# that mess with the body
|
|
$body = $body_822_t;
|
|
}
|
|
my $attach_accum = get_accum('attach_accum', $o);
|
|
if (scalar(@$attach_accum)) {
|
|
# this option is a list of files (or STDIN) to attach. In this case,
|
|
# the message become a mime message and the "body" goes in the
|
|
# first text/plain part
|
|
my $mime_type = '%SWAKS_DEFAULT_MIMETYTPE%';
|
|
my $next_name = undef();
|
|
my %parts = ( body => [], rest => [] );
|
|
$bound = "----=_MIME_BOUNDARY_000_$$";
|
|
foreach my $part (@$attach_accum) {
|
|
if ($part eq 'attach_type') {
|
|
$mime_type = get_arg($part, $o);
|
|
}
|
|
elsif ($part eq 'attach_name') {
|
|
$next_name = get_arg($part, $o);
|
|
}
|
|
elsif ($part eq 'attach_body') {
|
|
if ($mime_type eq '%SWAKS_DEFAULT_MIMETYTPE%') {
|
|
$mime_type = 'text/plain';
|
|
}
|
|
push(@{$parts{body}}, { body => get_arg($part, $o), type => $mime_type });
|
|
$next_name = undef(); # can't set filename for body, unset next_name so random attachment doesn't get it
|
|
$mime_type = '%SWAKS_DEFAULT_MIMETYTPE%'; # after each body, reset the default mime type
|
|
}
|
|
elsif ($part eq 'attach_attach') {
|
|
my $name = peek_arg($part, $o);
|
|
my $tpart = { body => get_arg($part, $o), type => $mime_type };
|
|
if (defined($next_name)) {
|
|
$tpart->{name} = $next_name;
|
|
$next_name = undef();
|
|
}
|
|
else {
|
|
my $filename = $name;
|
|
$filename =~ s/^\@//;
|
|
if ($name ne '-' && $filename !~ /^\@/ && $name ne $tpart->{body} && -f $filename) {
|
|
# name will have the unprocessed arg. If we think it came from a file, use the filename for
|
|
# the attachment name. Not super happy with this logic, try to improve in the future
|
|
($tpart->{name}) = $name =~ m|/?([^/]+)$|;
|
|
}
|
|
}
|
|
push(@{$parts{rest}}, $tpart);
|
|
} else {
|
|
ptrans(12, "Error processing attach args, unknown type $part when processing attachment options");
|
|
exit(1);
|
|
}
|
|
}
|
|
|
|
# if no body parts were set via --attach-body, set a text/plain body to $body
|
|
if (!scalar(@{$parts{body}})) {
|
|
push(@{$parts{body}}, { body => $body, type => 'text/plain' });
|
|
}
|
|
|
|
$body = '';
|
|
if (!scalar(@{$parts{rest}})) {
|
|
# if there are no non-body parts
|
|
if (scalar(@{$parts{body}}) > 1) {
|
|
$main_content_type = 'multipart/alternative';
|
|
}
|
|
else {
|
|
$main_content_type = 'multipart/mixed';
|
|
}
|
|
|
|
foreach my $part (@{$parts{body}}) {
|
|
$body .= encode_mime_part($part, $bound, 1);
|
|
}
|
|
}
|
|
else {
|
|
# otherwise, there's a mixture of both body and other. multipart/mixed
|
|
$main_content_type = 'multipart/mixed';
|
|
if (scalar(@{$parts{body}}) > 1) {
|
|
# we have multiple body parts, plus other attachments. Need to create a mp/mixes mime object for the bodies
|
|
my $mp_bound = "----=_MIME_BOUNDARY_004_$$";
|
|
|
|
$body .= "--$bound\n"
|
|
. 'Content-Type: multipart/alternative; boundary="' . $mp_bound . '"' . "\n\n";
|
|
|
|
foreach my $part (@{$parts{body}}) {
|
|
$body .= encode_mime_part($part, $mp_bound, 1);
|
|
}
|
|
$body .= "--$mp_bound--\n";
|
|
}
|
|
else {
|
|
$body .= encode_mime_part($parts{body}[0], $bound, 1);
|
|
}
|
|
|
|
# now handle the non-body attachments
|
|
foreach my $part (@{$parts{rest}}) {
|
|
$body .= encode_mime_part($part, $bound);
|
|
}
|
|
}
|
|
$body .= "--$bound--\n";
|
|
}
|
|
$body =~ s|%SWAKS_DEFAULT_MIMETYTPE%|application/octet-stream|g;
|
|
|
|
# SMTP DATA
|
|
$n{data} = get_arg('mail_data', $o) ||
|
|
'Date: %DATE%\nTo: %TO_ADDRESS%\nFrom: %FROM_ADDRESS%\nSubject: test %DATE%\n' .
|
|
"Message-Id: <%MESSAGEID%>\n" .
|
|
"X-Mailer: swaks v%SWAKS_VERSION% jetmore.org/john/code/swaks/".'\n' .
|
|
($bound ? 'MIME-Version: 1.0\nContent-Type: ' . $main_content_type . '; boundary="' . $bound. '"\n' : '') .
|
|
'%NEW_HEADERS%' . # newline will be added in replacement if it exists
|
|
'\n' .
|
|
'%BODY%\n';
|
|
if (!get_arg('no_data_fixup', $o)) {
|
|
$n{data} =~ s/%BODY%/$body/g;
|
|
$n{data} =~ s/\\n/\r\n/g;
|
|
my $addHeader_accum = get_accum('add_header', $o);
|
|
my $addHeaderOpt = [];
|
|
|
|
foreach my $okey (@$addHeader_accum) {
|
|
push(@$addHeaderOpt, get_arg($okey, $o));
|
|
}
|
|
|
|
# split the headers off into their own struct temporarily to make it much easier to manipulate them
|
|
my $header;
|
|
my @headers = ();
|
|
my %headers = ();
|
|
|
|
# cut the headers off of the data
|
|
if ($n{data} =~ s/\A(.*?)\r?\n\r?\n//s) {
|
|
$header = $1;
|
|
}
|
|
else {
|
|
$header = $n{data};
|
|
$n{data} = '';
|
|
}
|
|
|
|
# build the header string into an object. Each header is an array, each index is a line (to handle header continuation lines)
|
|
foreach my $headerLine (split(/\r?\n/, $header)) {
|
|
if ($headerLine =~ /^\s/) {
|
|
# continuation line
|
|
if (scalar(@headers)) {
|
|
push(@{$headers[-1]}, $headerLine);
|
|
}
|
|
else {
|
|
# it's illegal to have a continuation line w/o a previous header, but we're a test tool
|
|
push(@headers, [ $headerLine ]);
|
|
}
|
|
}
|
|
elsif ($headerLine =~ /^(\S[^:]+):/) {
|
|
# properly formed header
|
|
push(@headers, [ $headerLine ]);
|
|
$headers{$1} = $headers[-1];
|
|
}
|
|
else {
|
|
# malformed header - no colon. Allow it anyway, we're a test tool
|
|
push(@headers, [ $headerLine ]);
|
|
$headers{$headerLine} = $headers[-1];
|
|
}
|
|
}
|
|
|
|
# If the user specified headers and the header exists, replace it. If not, push it onto add_header to be added as new
|
|
my $header_accum = get_accum('header', $o);
|
|
my $headerOpt = [];
|
|
foreach my $okey (@$header_accum) {
|
|
push(@$headerOpt, get_arg($okey, $o));
|
|
}
|
|
foreach my $headerLine (map { split(/\\n/) } @{$headerOpt}) {
|
|
if (my($headerName) = $headerLine =~ /^([^:]+):/) {
|
|
if ($headers{$headerName}) {
|
|
$headers{$headerName}[0] = $headerLine;
|
|
splice(@{$headers{$headerName}}, 1); # remove from index 1 onward, if they existed (possible continuations)
|
|
}
|
|
else {
|
|
push(@{$addHeaderOpt}, $headerLine);
|
|
}
|
|
}
|
|
else {
|
|
push(@{$addHeaderOpt}, $headerLine);
|
|
}
|
|
}
|
|
|
|
# rebuild the header using our (possibly replaced) headers
|
|
my $newHeader = '';
|
|
foreach my $headerObj (@headers) {
|
|
foreach my $line (@$headerObj) {
|
|
$newHeader .= $line . "\r\n";
|
|
}
|
|
}
|
|
|
|
# if there are new headers, add them as appropriate
|
|
if ($newHeader =~ /%NEW_HEADERS%/) {
|
|
$n{add_header} = join("\r\n", @{$addHeaderOpt}) . "\r\n" if (@{$addHeaderOpt});
|
|
$newHeader =~ s/%NEW_HEADERS%/$n{add_header}/g;
|
|
} elsif (scalar(@{$addHeaderOpt})) {
|
|
foreach my $line (@{$addHeaderOpt}) {
|
|
$newHeader .= $line . "\r\n";
|
|
}
|
|
}
|
|
|
|
# Now re-assemble our data by adding the headers back on to the front
|
|
$n{data} = $newHeader . "\r\n" . $n{data};
|
|
|
|
$n{data} =~ s/\\n|%NEWLINE%/\r\n/g;
|
|
$n{data} =~ s/%FROM_ADDRESS%/$n{from}/g;
|
|
$n{data} =~ s/%TO_ADDRESS%/$n{to}/g;
|
|
$n{data} =~ s/%MESSAGEID%/get_messageid()/ge;
|
|
$n{data} =~ s/%SWAKS_VERSION%/$p_version/g;
|
|
$n{data} =~ s/%DATE%/get_date_string()/ge;
|
|
$n{data} =~ s/^From [^\n]*\n// if (!get_arg('no_strip_from', $o));
|
|
$n{data} =~ s/\r?\n\.\r?\n?$//s; # If there was a trailing dot, remove it
|
|
$n{data} =~ s/\n\./\n../g; # quote any other leading dots
|
|
$n{data} =~ s/([^\r])\n/$1\r\n/gs;
|
|
$n{data} =~ s/([^\r])\n/$1\r\n/gs; # this identical call is not a bug, called twice to get consecutive \n correctly
|
|
$n{data} .= "\r\n."; # add a trailing dot
|
|
}
|
|
|
|
# Handle TLS options
|
|
# tls => 0 - no. STARTTLS must be advertised and must succeed, else error.
|
|
# 1 - yes. Success if not advertised, advertised and fails _or_ succeeds.
|
|
# 2 - strict. Satisfied if not advertised, or advertised and succeeded.
|
|
# However, if it's advertised and fails, it's an error.
|
|
$G::tls_optional = 1 if ($tls_optional);
|
|
$G::tls_optional = 2 if ($tls_optional_strict);
|
|
$G::tls = 1 if ($tls || $G::tls_optional);
|
|
$G::tls_on_connect = 1 if ($tls_on_connect);
|
|
$G::link{tls}{active} = 0;
|
|
if ($G::tls || $G::tls_on_connect) {
|
|
if (!avail("tls")) {
|
|
if ($G::tls_optional) {
|
|
$G::tls = undef; # so we won't try it later
|
|
ptrans(12,avail_str("tls"));
|
|
} else {
|
|
ptrans(12,avail_str("tls").". Exiting");
|
|
exit(10);
|
|
}
|
|
}
|
|
$G::tls_verify = get_arg('tls_verify', $o);
|
|
$G::tls_sni_hostname = get_arg('tls_sni_hostname', $o);
|
|
$G::tls_cipher = get_arg('tls_cipher', $o);
|
|
$G::tls_cert = get_arg('tls_cert', $o);
|
|
$G::tls_key = get_arg('tls_key', $o);
|
|
if (($G::tls_cert || $G::tls_key) && !($G::tls_cert && $G::tls_key)) {
|
|
ptrans(12, "--tls-cert and --tls-key require each other. Exiting");
|
|
exit(1);
|
|
}
|
|
if (($G::tls_ca_path = get_arg('tls_ca_path', $o)) && !-f $G::tls_ca_path && !-d $G::tls_ca_path) {
|
|
ptrans(12, "--tls-ca-path: $G::tls_ca_path is not a valid file or directory. Exiting.");
|
|
exit(1);
|
|
}
|
|
|
|
# this is kind of a kludge. There doesn't appear to be a specific openssl call to find supported
|
|
# protocols, but the OP_NO_protocol functions exist for supported protocols. Loop through
|
|
# "known" protocols (which will unfortunately need to be added-to by hand when new protocols
|
|
# become available) to find out which of them are available (when adding new types here, see
|
|
# also the code that calls Net::SSLeay::version() and translates to a readable value
|
|
@G::tls_supported_protocols = ();
|
|
foreach my $p (qw(SSLv2 SSLv3 TLSv1 TLSv1_1 TLSv1_2 TLSv1_3)) {
|
|
eval { no strict "refs"; &{"Net::SSLeay::OP_NO_$p"}(); };
|
|
push(@G::tls_supported_protocols, $p) if (!$@);
|
|
}
|
|
|
|
if (my $tls_protocols = get_arg('tls_protocol', $o)) {
|
|
@G::tls_protocols = ();
|
|
my @requested = split(/,\s*/, $tls_protocols);
|
|
if (my $c = scalar(grep(/^no_/i, @requested))) {
|
|
if ($c != scalar(@requested)) {
|
|
ptrans(12, "cannot mix X and no_X forms in --tls-protocol option");
|
|
exit(1);
|
|
}
|
|
}
|
|
foreach my $p (@requested) {
|
|
my $t = $p;
|
|
$t =~ s/^no_//i;
|
|
if (grep /^$t$/i, @G::tls_supported_protocols) {
|
|
push(@G::tls_protocols, $p);
|
|
} else {
|
|
ptrans(12, "$p in --tls-protocol is not a known/supported protocol");
|
|
}
|
|
}
|
|
if (!scalar(@G::tls_protocols)) {
|
|
ptrans(12, "no valid arguments provided to --tls-protocol, exiting");
|
|
exit(1);
|
|
}
|
|
}
|
|
|
|
$G::tls_get_peer_cert = get_arg('tls_get_peer_cert', $o);
|
|
$G::tls_get_peer_cert = 'STDOUT' if (defined($G::tls_get_peer_cert) && !length($G::tls_get_peer_cert));
|
|
}
|
|
|
|
# SMTP port
|
|
if ($G::link{port}) {
|
|
if ($G::link{port} !~ /^\d+$/) {
|
|
if (my $port = getservbyname($G::link{port}, 'tcp')) {
|
|
$G::link{port} = $port;
|
|
}
|
|
else {
|
|
ptrans(12, "unable to resolve service name $G::link{port} into a port, exiting");
|
|
exit(1);
|
|
}
|
|
}
|
|
} else {
|
|
# in here, user wants us to use default ports, so try look up services,
|
|
# use default numbers is service names don't resolve. Never prompt user
|
|
if ($G::protocol eq 'lmtp') {
|
|
$G::link{port} = getservbyname('lmtp', 'tcp') || '24';
|
|
} elsif ($G::tls_on_connect) {
|
|
$G::link{port} = getservbyname('smtps', 'tcp') || '465';
|
|
} else {
|
|
$G::link{port} = getservbyname('smtp', 'tcp') || '25';
|
|
}
|
|
}
|
|
|
|
# XCLIENT
|
|
{ # Create a block for local variables
|
|
$G::xclient{try} = 0;
|
|
$G::xclient{attr} = {};
|
|
$G::xclient{strings} = [];
|
|
my @pieces = ();
|
|
my $xclient_accum = get_accum('xclient_accum', $o);
|
|
foreach my $attr (@$xclient_accum) {
|
|
if ($attr eq 'xclient_delim' || $attr eq 'xclient_raw') {
|
|
if (scalar(@pieces)) {
|
|
push(@{$G::xclient{strings}}, join(' ', @pieces));
|
|
@pieces = ();
|
|
}
|
|
|
|
if ($attr eq 'xclient_raw') {
|
|
push(@{$G::xclient{strings}}, get_arg('xclient_raw', $o));
|
|
}
|
|
} else {
|
|
if (my $value = get_arg($attr, $o)) {
|
|
$attr =~ /^xclient_(.*)$/;
|
|
my $name = uc($1);
|
|
$G::xclient{attr}{$name} = 1; # used later to verify that we haven't asked for an un-advertised attr
|
|
push(@pieces, $name . '=' . to_xtext($value));
|
|
}
|
|
}
|
|
}
|
|
push(@{$G::xclient{strings}}, join(' ', @pieces)) if (scalar(@pieces));
|
|
$G::xclient{no_verify} = get_arg('xclient_no_verify', $o);
|
|
$G::xclient{optional} = get_arg('xclient_optional', $o);
|
|
$G::xclient{optional} = 2 if (get_arg('xclient_optional_strict', $o));
|
|
#$G::xclient{after} = $o->{"xclient_after"} || interact("XCLIENT quit after: ", '^.+$')
|
|
# if (defined($o->{"xclient_after"}));
|
|
$G::xclient{try} = 1 if (scalar(@{$G::xclient{strings}}));
|
|
$G::xclient{before_tls} = get_arg('xclient_before_starttls', $o);
|
|
}
|
|
|
|
# PROXY
|
|
$G::proxy{try} = 0;
|
|
$G::proxy{attr} = {};
|
|
$G::proxy{version} = get_arg('proxy_version', $o);
|
|
$G::proxy{raw} = get_arg('proxy_raw', $o);
|
|
foreach my $attr ('family', 'source', 'source_port', 'dest', 'dest_port', 'protocol', 'command') {
|
|
if (my $val = get_arg('proxy_' . $attr, $o)) {
|
|
if ($G::proxy{raw}) {
|
|
ptrans(12, "Can't mix --proxy option with other --proxy-* options");
|
|
exit(35);
|
|
}
|
|
$G::proxy{attr}{$attr} = $val;
|
|
}
|
|
}
|
|
if ($G::proxy{version}) {
|
|
if ($G::proxy{version} != 1 && $G::proxy{version} != 2) {
|
|
ptrans(12, "Invalid argument to --proxy: $G::proxy{version} is not a legal proxy version");
|
|
exit(35);
|
|
}
|
|
}
|
|
else {
|
|
$G::proxy{version} = 1;
|
|
}
|
|
$G::proxy{try} = 1 if ($G::proxy{raw} || scalar(keys(%{$G::proxy{attr}})));
|
|
if ($G::proxy{try} && !$G::proxy{raw}) {
|
|
$G::proxy{attr}{protocol} ||= 'STREAM';
|
|
$G::proxy{attr}{command} ||= 'PROXY';
|
|
foreach my $attr ('family', 'source', 'source_port', 'dest', 'dest_port', 'protocol', 'command') {
|
|
if (!$G::proxy{attr}{$attr}) {
|
|
ptrans(12, "Incomplete set of --proxy-* options (missing $attr)");
|
|
exit(35);
|
|
}
|
|
$G::proxy{attr}{$attr} = uc($G::proxy{attr}{$attr});
|
|
}
|
|
if ($G::proxy{attr}{protocol} !~ /^(UNSPEC|STREAM|DGRAM)$/) {
|
|
ptrans(12, 'unknown --proxy-protocol argument ' . $G::proxy{attr}{protocol});
|
|
exit(35);
|
|
}
|
|
if ($G::proxy{attr}{command} !~ /^(LOCAL|PROXY)$/) {
|
|
ptrans(12, 'unknown --proxy-command argument ' . $G::proxy{attr}{command});
|
|
exit(35);
|
|
}
|
|
if ($G::proxy{version} == 2 && $G::proxy{attr}{family} !~ /^(AF_UNSPEC|AF_INET|AF_INET6|AF_UNIX)$/) {
|
|
ptrans(12, 'unknown --proxy-family argument ' . $G::proxy{attr}{family} . ' for version 2');
|
|
exit(35);
|
|
}
|
|
if ($G::proxy{version} == 1 && $G::proxy{attr}{family} !~ /^(TCP4|TCP6)$/) {
|
|
ptrans(12, 'unknown --proxy-family argument ' . $G::proxy{attr}{family} . ' for version 1');
|
|
exit(35);
|
|
}
|
|
}
|
|
|
|
# Handle AUTH options
|
|
# auth_optional => 0 - no. Auth must be advertised and must succeed, else error.
|
|
# 1 - yes. Success if not advertised, advertised and fails _or_ succeeds.
|
|
# 2 - strict. Satisfied if not advertised, or advertised and succeeded.
|
|
# However, if it's advertised and fails, it's an error.
|
|
$G::auth_optional = 1 if (defined($auth_optional_t));
|
|
$G::auth_optional = 2 if (defined($auth_optional_strict_t));
|
|
my $auth_types_t = [];
|
|
if ($auth_t) {
|
|
@{$auth_types_t} = map { uc($_) } (split(/,/, $auth_t));
|
|
} elsif ($auth_optional_strict_t) {
|
|
@{$auth_types_t} = map { uc($_) } (split(/,/, $auth_optional_strict_t));
|
|
} elsif ($auth_optional_t) {
|
|
@{$auth_types_t} = map { uc($_) } (split(/,/, $auth_optional_t));
|
|
} elsif (defined($auth_user_t) || defined($auth_pass_t) || $G::auth_optional || (defined($auth_t) && !$auth_t)) {
|
|
$auth_types_t->[0] = 'ANY';
|
|
$auth_t = 'ANY'; # this is checked below
|
|
$G::auth_type = 'ANY';
|
|
}
|
|
# if after that processing we've defined some auth type, do some more
|
|
# specific processing
|
|
if (scalar(@{$auth_types_t})) {
|
|
# there's a lot of option processing below. If any type looks like it
|
|
# will succeed later, set this to true
|
|
my $valid_auth_found = 0;
|
|
|
|
# handle the --auth-map options plus our default mappings
|
|
foreach (split(/\s*,\s*/, get_arg('auth_map', $o)),"PLAIN=PLAIN","LOGIN=LOGIN",
|
|
"CRAM-MD5=CRAM-MD5","DIGEST-MD5=DIGEST-MD5",
|
|
"CRAM-SHA1=CRAM-SHA1","NTLM=NTLM","SPA=NTLM","MSN=NTLM")
|
|
{
|
|
if (/^([^=]+)=(.+)$/) {
|
|
my($alias,$type) = ($1,$2);
|
|
$G::auth_map_f{$alias} = $type; # this gives us a list of all aliases pointing to types
|
|
$G::auth_map_t{$type} ||= []; # this gives a list of all base types and any aliases for it.
|
|
push(@{$G::auth_map_t{$type}}, $alias);
|
|
} else {
|
|
ptrans(12, "Unknown auth-map format '$_'");
|
|
exit(1);
|
|
}
|
|
}
|
|
# Now handle the --auth-extra options
|
|
foreach (split(/\s*,\s*/, get_arg('auth_extra', $o))) {
|
|
if (/^([^=]+)=(.+)$/) {
|
|
$G::auth_extras{uc($1)} = $2;
|
|
} else {
|
|
ptrans(12, "Unknown auth-extra format '$_'");
|
|
exit(1);
|
|
}
|
|
}
|
|
# handle the realm/domain synonyms
|
|
if ($G::auth_extras{DOMAIN}) {
|
|
$G::auth_extras{REALM} = $G::auth_extras{DOMAIN};
|
|
} elsif ($G::auth_extras{DOMAIN}) {
|
|
$G::auth_extras{DOMAIN} = $G::auth_extras{REALM};
|
|
}
|
|
if (!avail("auth")) { # check for general auth requirements
|
|
if ($G::auth_optional == 2) {
|
|
# we don't know yet if this is really an error. If the server
|
|
# doesn't advertise auth, then it's not really an error. So just
|
|
# save it in case we need it later
|
|
$G::auth_unavailable = avail_str("auth");
|
|
ptrans(12, avail_str("auth"));
|
|
} elsif ($G::auth_optional == 1) {
|
|
ptrans(12, avail_str("auth"). ". Skipping optional AUTH");
|
|
} else {
|
|
ptrans(12, avail_str("auth"). ". Exiting");
|
|
exit(10);
|
|
}
|
|
} else {
|
|
# if the user doesn't specify an auth type, create a list from our
|
|
# auth-map data. Simplifies processing later
|
|
if ($auth_types_t->[0] eq 'ANY') {
|
|
$auth_types_t = [sort keys %G::auth_map_f];
|
|
}
|
|
|
|
foreach my $type (@{$auth_types_t}) {
|
|
# we need to evaluate whether we will be able to run the auth types
|
|
# specified by the user
|
|
if (!$G::auth_map_f{$type}) {
|
|
ptrans(12, "$type is not a recognized auth type, skipping");
|
|
} elsif ($G::auth_map_f{$type} eq 'CRAM-MD5' && !avail("auth_cram_md5")) {
|
|
ptrans(12, avail_str("auth_cram_md5")) if ($auth_t ne 'ANY');
|
|
} elsif ($G::auth_map_f{$type} eq 'CRAM-SHA1' && !avail("auth_cram_sha1")) {
|
|
ptrans(12, avail_str("auth_cram_sha1")) if ($auth_t ne 'ANY');
|
|
} elsif ($G::auth_map_f{$type} eq 'NTLM' && !avail("auth_ntlm")) {
|
|
ptrans(12, avail_str("auth_ntlm")) if ($auth_t ne 'ANY');
|
|
} elsif ($G::auth_map_f{$type} eq 'DIGEST-MD5' && !avail("auth_digest_md5")) {
|
|
ptrans(12, avail_str("auth_digest_md5")) if ($auth_t ne 'ANY');
|
|
} else {
|
|
$valid_auth_found = 1;
|
|
push(@{$n{a_type}}, $type);
|
|
}
|
|
}
|
|
|
|
if (!$valid_auth_found) {
|
|
ptrans(12, "No auth types supported");
|
|
if ($G::auth_optional == 2) {
|
|
$G::auth_unavailable .= "No auth types supported";
|
|
} elsif ($G::auth_optional == 1) {
|
|
$n{a_user} = $n{a_pass} = $n{a_type} = undef;
|
|
} else {
|
|
exit(10);
|
|
}
|
|
} else {
|
|
$auth_user_t ||= obtain_from_netrc('login');
|
|
if (!$auth_user_t) {
|
|
my $cfg = { cfgs => OP_ARG_REQ|OP_FROM_PROMPT, prompt => 'Username: ', match => 'SKIP', okey => 'auth_user', akey => 'auth_user' };
|
|
$auth_user_t = get_arg('auth_user', $o, $cfg, 1);
|
|
}
|
|
$n{a_user} = $auth_user_t eq '<>' ? '' : $auth_user_t;
|
|
|
|
$auth_pass_t ||= obtain_from_netrc('password', $n{a_user});
|
|
if (!$auth_pass_t) {
|
|
my $cfg = { cfgs => OP_ARG_REQ|OP_FROM_PROMPT, prompt => 'Password: ', match => 'SKIP', okey => 'auth_pass', akey => 'auth_pass' };
|
|
$auth_pass_t = get_arg('auth_pass', $o, $cfg, 1);
|
|
}
|
|
$n{a_pass} = $auth_pass_t eq '<>' ? '' : $auth_pass_t;
|
|
|
|
$G::auth_showpt = get_arg('auth_showpt', $o);
|
|
$G::auth_hidepw = get_arg('auth_hidepw', $o);
|
|
if (defined($G::auth_hidepw) && !$G::auth_hidepw) {
|
|
$G::auth_hidepw = 'PROVIDED_BUT_REMOVED';
|
|
}
|
|
}
|
|
} # end avail("auth")
|
|
} # end auth parsing
|
|
|
|
# the very last thing we do is swap out the body if --dump-as-body used
|
|
if (defined($dump_as_body)) {
|
|
if ($dump_as_body) {
|
|
$dump_as_body = uc($dump_as_body);
|
|
$dump_as_body =~ s/\s//g;
|
|
map { $G::dump_as_body{$_} = 1; } (split(',', $dump_as_body));
|
|
}
|
|
else {
|
|
$G::dump_as_body{'ALL'} = 1;
|
|
}
|
|
|
|
$n{data} =~ s|DUMP_AS_BODY_HAS_BEEN_SET|get_running_state(\%n, \%G::dump_as_body, {SUPPORT => 1, DATA => 1})|e;
|
|
if ($dab_sp) {
|
|
$n{data} =~ s|'%RAW_PASSWORD_STRING%'|shquote($n{a_pass})|eg;
|
|
} elsif ($G::auth_hidepw) {
|
|
$n{data} =~ s|'%RAW_PASSWORD_STRING%'|shquote($G::auth_hidepw)|eg;
|
|
} else {
|
|
$n{data} =~ s|'%RAW_PASSWORD_STRING%'|shquote('PROVIDED_BUT_REMOVED')|eg;
|
|
}
|
|
}
|
|
|
|
return(\%n);
|
|
}
|
|
|
|
sub encode_mime_part {
|
|
my $part = shift;
|
|
my $boundary = shift;
|
|
my $no_attach_text = shift; # if this is true and there's no name, Don't set disposition to attachment
|
|
my $text = '';
|
|
|
|
$text .= "--$boundary\n";
|
|
if ($part->{type} =~ m|^text/plain$|i && !$part->{name}) {
|
|
$text .= "Content-Type: $part->{type}\n\n" . $part->{body} . "\n";
|
|
}
|
|
else {
|
|
if ($part->{name}) {
|
|
$text .= "Content-Type: $part->{type}; name=\"$part->{name}\"\n"
|
|
. "Content-Description: $part->{name}\n"
|
|
. "Content-Disposition: attachment; filename=\"$part->{name}\"\n";
|
|
}
|
|
else {
|
|
$text .= "Content-Type: $part->{type}\n";
|
|
if (!($part->{type} =~ m|^text/|i && $no_attach_text)) {
|
|
$text .= "Content-Disposition: attachment\n";
|
|
}
|
|
}
|
|
$text .= "Content-Transfer-Encoding: BASE64\n"
|
|
. "\n" . eb64($part->{body}, "\n") . "\n";
|
|
}
|
|
|
|
|
|
return($text);
|
|
}
|
|
|
|
sub parse_server {
|
|
my $server = shift;
|
|
my $port = shift;
|
|
|
|
if ($server =~ m|^\[([^\]]+)\]:(.*)$|) {
|
|
# [1.2.3.4]:25
|
|
# [hostname]:25
|
|
# [1:2::3]:25
|
|
return($1, $2);
|
|
} elsif ($server =~ m|^([^:]+):([^:]+)$|) {
|
|
# 1.2.3.4:25
|
|
# hostname:25
|
|
return($1, $2);
|
|
} elsif ($server =~ m|^\[?([^/\]]*)\]?/(\w+)$|) {
|
|
# 1.2.3.4/25 [1.2.3.4]/25
|
|
# hostname/25 [hostname]/25
|
|
# 1:2::3/25 [1:2::3]/25
|
|
return($1, $2);
|
|
} elsif ($server =~ m|^\[([^\]]+)\]$|) {
|
|
# [1.2.3.4]
|
|
# [hostname]
|
|
# [1:2::3]
|
|
return($1, $port);
|
|
}
|
|
return($server, $port);
|
|
}
|
|
|
|
sub get_running_state {
|
|
my $opts = shift;
|
|
my $dump_args = shift;
|
|
my $skip = shift;
|
|
my @parts = ();
|
|
|
|
if (($dump_args->{'SUPPORT'} || $dump_args->{'ALL'}) && !$skip->{'SUPPORT'}) {
|
|
push(@parts, test_support(1));
|
|
}
|
|
|
|
if ($dump_args->{'APP'} || $dump_args->{'ALL'}) {
|
|
push(@parts, [
|
|
'App Info:',
|
|
" X-Mailer = $p_name v$p_version jetmore.org/john/code/swaks/",
|
|
' Cmd Line = ' . $0 . ' ' . $G::cmdline,
|
|
]);
|
|
}
|
|
|
|
if ($dump_args->{'OUTPUT'} || $dump_args->{'ALL'}) {
|
|
push(@parts, [
|
|
'Output Info:',
|
|
' show_time_lapse = ' . ($G::show_time_lapse ? "TRUE ($G::show_time_lapse)" : 'FALSE'),
|
|
' show_raw_text = ' . ($G::show_raw_text ? 'TRUE' : 'FALSE'),
|
|
' suppress_data = ' . ($G::suppress_data ? 'TRUE' : 'FALSE'),
|
|
' protect_prompt = ' . ($G::protect_prompt ? 'TRUE' : 'FALSE'),
|
|
' no_hints_send = ' . ($G::no_hints_send ? 'TRUE' : 'FALSE'),
|
|
' no_hints_recv = ' . ($G::no_hints_recv ? 'TRUE' : 'FALSE'),
|
|
' no_hints_info = ' . ($G::no_hints_info ? 'TRUE' : 'FALSE'),
|
|
" silent = $G::silent",
|
|
' dump_mail = ' . ($G::dump_mail ? 'TRUE' : 'FALSE'),
|
|
' hide_send = ' . ($G::hide_send ? 'TRUE' : 'FALSE'),
|
|
' hide_receive = ' . ($G::hide_receive ? 'TRUE' : 'FALSE'),
|
|
' hide_informational = ' . ($G::hide_informational ? 'TRUE' : 'FALSE'),
|
|
' hide_all = ' . ($G::hide_all ? 'TRUE' : 'FALSE'),
|
|
" trans_fh_of = $G::trans_fh_of ($G::trans_fh_oh," . \*STDOUT . ')',
|
|
" trans_fh_ef = $G::trans_fh_ef ($G::trans_fh_eh," . \*STDERR . ')',
|
|
]);
|
|
}
|
|
|
|
if ($dump_args->{'TRANSPORT'} || $dump_args->{'ALL'}) {
|
|
push(@parts, [
|
|
'Transport Info:',
|
|
" type = $G::link{type}"
|
|
]);
|
|
if ($G::link{type} eq 'socket-inet') {
|
|
push(@{$parts[-1]},
|
|
' inet protocol = ' . ($G::link{force_ipv4} ? '4' : ($G::link{force_ipv6} ? '6' : 'any')),
|
|
" server = $G::link{server}",
|
|
" port = $G::link{port}",
|
|
" local interface = $G::link{lint}",
|
|
" local port = $G::link{lport}",
|
|
' copy routing = ' . ($opts->{copy_routing} ? $opts->{copy_routing} : 'FALSE'),
|
|
);
|
|
}
|
|
elsif ($G::link{type} eq 'socket-unix') {
|
|
push(@{$parts[-1]}, " sockfile = $G::link{sockfile}");
|
|
}
|
|
elsif ($G::link{type} eq 'pipe') {
|
|
push(@{$parts[-1]}, " process = $G::link{process}");
|
|
}
|
|
else {
|
|
push(@{$parts[-1]}, " UNKNOWN TRANSPORT TYPE");
|
|
}
|
|
}
|
|
|
|
if ($dump_args->{'PROTOCOL'} || $dump_args->{'ALL'}) {
|
|
push(@parts, [
|
|
'Protocol Info:',
|
|
" protocol = $G::protocol",
|
|
" helo = $opts->{helo}",
|
|
" from = $opts->{from}",
|
|
" to = $opts->{to}",
|
|
' force getpwuid = ' . ($opts->{force_getpwuid} ? 'TRUE' : 'FALSE'),
|
|
" quit after = $G::quit_after",
|
|
" drop after = $G::drop_after",
|
|
" drop after send = $G::drop_after_send",
|
|
' server_only = ' . ($G::server_only ? 'TRUE' : 'FALSE'),
|
|
" timeout = $G::link{timeout}",
|
|
' pipeline = ' . ($G::pipeline ? 'TRUE' : 'FALSE'),
|
|
' prdr = ' . ($G::prdr ? 'TRUE' : 'FALSE'),
|
|
]);
|
|
}
|
|
|
|
if ($dump_args->{'XCLIENT'} || $dump_args->{'ALL'}) {
|
|
push(@parts, ['XCLIENT Info:']);
|
|
if ($G::xclient{try}) {
|
|
if ($G::xclient{optional} == 2) { push(@{$parts[-1]}, ' xclient = optional-strict'); }
|
|
elsif ($G::xclient{optional} == 1) { push(@{$parts[-1]}, ' xclient = optional'); }
|
|
else { push(@{$parts[-1]}, ' xclient = required'); }
|
|
push(@{$parts[-1]},
|
|
' no_verify = ' . ($G::xclient{no_verify} ? 'TRUE' : 'FALSE'),
|
|
' before starttls = ' . ($G::xclient{before_tls} ? 'TRUE' : 'FALSE'),
|
|
);
|
|
for (my $i = 0; $i < scalar(@{$G::xclient{strings}}); $i++) {
|
|
my $prefix = $i ? ' ' : ' strings =';
|
|
push(@{$parts[-1]}, "$prefix XCLIENT $G::xclient{strings}[$i]");
|
|
}
|
|
} else {
|
|
push(@{$parts[-1]}, ' xclient = no');
|
|
}
|
|
}
|
|
|
|
if ($dump_args->{'PROXY'} || $dump_args->{'ALL'}) {
|
|
push(@parts, ['PROXY Info:']);
|
|
if ($G::proxy{try}) {
|
|
push(@{$parts[-1]}, ' proxy = yes');
|
|
push(@{$parts[-1]}, " version = $G::proxy{version}");
|
|
if ($G::proxy{raw}) {
|
|
push(@{$parts[-1]}, " raw string = $G::proxy{raw}");
|
|
} else {
|
|
push(@{$parts[-1]},
|
|
' family = ' . $G::proxy{attr}{family},
|
|
' source = ' . $G::proxy{attr}{source},
|
|
' source port = ' . $G::proxy{attr}{source_port},
|
|
' dest = ' . $G::proxy{attr}{dest},
|
|
' dest port = ' . $G::proxy{attr}{dest_port},
|
|
' protocol = ' . $G::proxy{attr}{protocol},
|
|
' command = ' . $G::proxy{attr}{command},
|
|
);
|
|
}
|
|
} else {
|
|
push(@{$parts[-1]}, ' proxy = no');
|
|
}
|
|
}
|
|
|
|
if ($dump_args->{'TLS'} || $dump_args->{'ALL'}) {
|
|
push(@parts, ['TLS / Encryption Info:']);
|
|
if ($G::tls || $G::tls_on_connect) {
|
|
if ($G::tls) {
|
|
if ($G::tls_optional == 2) { push(@{$parts[-1]}, ' tls = starttls (optional-strict)'); }
|
|
elsif ($G::tls_optional == 1) { push(@{$parts[-1]}, ' tls = starttls (optional)'); }
|
|
else { push(@{$parts[-1]}, ' tls = starttls (required)'); }
|
|
}
|
|
elsif ($G::tls_on_connect) { push(@{$parts[-1]}, ' tls = starttls on connect (required)'); }
|
|
push(@{$parts[-1]},
|
|
" peer cert = $G::tls_get_peer_cert",
|
|
" local cert = $G::tls_cert",
|
|
" local key = $G::tls_key",
|
|
" local cipher list = $G::tls_cipher",
|
|
" ca path = $G::tls_ca_path",
|
|
" sni string = $G::tls_sni_hostname",
|
|
' verify server cert = ' . ($G::tls_verify ? 'TRUE' : 'FALSE'),
|
|
' available protocols = ' . join(', ', @G::tls_supported_protocols),
|
|
' requested protocols = ' . join(', ', @G::tls_protocols),
|
|
);
|
|
}
|
|
else {
|
|
push(@{$parts[-1]}, ' tls = no');
|
|
}
|
|
}
|
|
|
|
if ($dump_args->{'AUTH'} || $dump_args->{'ALL'}) {
|
|
push(@parts, ['Authentication Info:']);
|
|
if ($opts->{a_type}) {
|
|
if ($G::auth_optional == 2) { push(@{$parts[-1]}, ' auth = optional-strict'); }
|
|
elsif ($G::auth_optional == 1) { push(@{$parts[-1]}, ' auth = optional'); }
|
|
else { push(@{$parts[-1]}, ' auth = required'); }
|
|
push(@{$parts[-1]},
|
|
" username = '$opts->{a_user}'",
|
|
" password = '%RAW_PASSWORD_STRING%'",
|
|
' show plaintext = ' . ($G::auth_showpt ? 'TRUE' : 'FALSE'),
|
|
' hide password = ' . ($G::auth_hidepw ? $G::auth_hidepw : 'FALSE'),
|
|
' allowed types = ' . join(', ', @{$opts->{a_type}}),
|
|
' extras = ' . join(', ', map { "$_=$G::auth_extras{$_}" } (sort(keys((%G::auth_extras))))),
|
|
' type map = ' . join("\n".' 'x19, map { "$_ = ". join(', ', @{$G::auth_map_t{$_}}) } (sort(keys(%G::auth_map_t)))),
|
|
);
|
|
}
|
|
else {
|
|
push(@{$parts[-1]}, " auth = no");
|
|
}
|
|
}
|
|
|
|
if (($dump_args->{'DATA'} || $dump_args->{'ALL'}) && !$skip->{'DATA'}) {
|
|
push(@parts, [
|
|
'DATA Info:',
|
|
' data = <<.',
|
|
$opts->{data}
|
|
]);
|
|
}
|
|
|
|
# rejoin the parts into a string now
|
|
# this whole exercise was to avoid extra newlines when only dumping certain parts
|
|
foreach my $part (@parts) {
|
|
$part = join("\n", @$part) . "\n";
|
|
}
|
|
return(join("\n", @parts));
|
|
}
|
|
|
|
sub get_username {
|
|
my $force_getpwuid = shift;
|
|
if ($^O eq 'MSWin32') {
|
|
require Win32;
|
|
return Win32::LoginName();
|
|
}
|
|
if ($force_getpwuid) {
|
|
return (getpwuid($<))[0];
|
|
}
|
|
return $ENV{LOGNAME} || (getpwuid($<))[0];
|
|
}
|
|
|
|
sub get_date_string {
|
|
return($G::date_string) if (length($G::date_string) > 0);
|
|
|
|
my $et = time();
|
|
|
|
if (!avail("date_manip")) {
|
|
ptrans(12, avail_str("date_manip").". Date strings will be in GMT");
|
|
my @l = gmtime($et);
|
|
$G::date_string = sprintf("%s, %02d %s %d %02d:%02d:%02d %+05d",
|
|
(qw(Sun Mon Tue Wed Thu Fri Sat))[$l[6]],
|
|
$l[3],
|
|
(qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec))[$l[4]],
|
|
$l[5]+1900, $l[2], $l[1], $l[0],
|
|
0);
|
|
} else {
|
|
$G::date_string = POSIX::strftime("%a, %d %b %Y %H:%M:%S %z", localtime($et));
|
|
}
|
|
return($G::date_string);
|
|
}
|
|
|
|
# partially Cribbed from "Programming Perl" and MIME::Base64 v2.12
|
|
sub db64 {
|
|
my $s = shift;
|
|
if (load("MIME::Base64")) {
|
|
return(decode_base64($s));
|
|
} else {
|
|
$s =~ tr#A-Za-z0-9+/##cd;
|
|
$s =~ s|=+$||;
|
|
$s =~ tr#A-Za-z0-9+/# -_#;
|
|
my $r = '';
|
|
while ($s =~ s/(.{1,60})//s) {
|
|
$r .= unpack("u", chr(32 + int(length($1)*3/4)) . $1);
|
|
}
|
|
return($r);
|
|
}
|
|
}
|
|
|
|
# partially Cribbed from MIME::Base64 v2.12
|
|
sub eb64 {
|
|
my $s = shift;
|
|
my $e = shift || ''; # line ending to use "empty by default"
|
|
if (load("MIME::Base64")) {
|
|
return(encode_base64($s, $e));
|
|
} else {
|
|
my $l = length($s);
|
|
chomp($s = pack("u", $s));
|
|
$s =~ s|\n.||gms;
|
|
$s =~ s|\A.||gms;
|
|
$s =~ tr#` -_#AA-Za-z0-9+/#;
|
|
my $p = (3 - $l%3) % 3;
|
|
$s =~ s/.{$p}$/'=' x $p/e if ($p);
|
|
$s =~ s/(.{1,76})/$1$e/g if (length($e));
|
|
return($s);
|
|
}
|
|
}
|
|
|
|
sub build_version {
|
|
my $static = shift;
|
|
my $svn = shift;
|
|
|
|
if ($static ne 'DEVRELEASE') {
|
|
# if gen-util passed in a static version, use it unconditionally
|
|
return $static;
|
|
} elsif ($svn =~ /\$Id:\s+\S+\s+(\d+)\s+(\d+)-(\d+)-(\d+)\s+/) {
|
|
# otherwise, this is a dev copy, dynamically build a version string for it
|
|
return("$2$3$4.$1-dev");
|
|
} else {
|
|
# we wanted a dynamic version, but the SVN Id tag wasn't in the format
|
|
# we expected, punt
|
|
return("DEVRELEASE");
|
|
}
|
|
}
|
|
|
|
sub ext_usage {
|
|
require Config;
|
|
$ENV{PATH} .= ":" unless $ENV{PATH} eq "";
|
|
$ENV{PATH} = $ENV{PATH} . $Config::Config{'installscript'};
|
|
$< = $> = 1 if ($> == 0 || $< == 0);
|
|
exec("perldoc", $0) || exit(1);
|
|
# make parser happy
|
|
%Config::Config = ();
|
|
|
|
exit(0);
|
|
}
|
|
|