SOURCES: swaks.pl (NEW) - from http://jetmore.org/john/code/swaks
pawelz
pawelz at pld-linux.org
Sun Feb 22 22:54:55 CET 2009
Author: pawelz Date: Sun Feb 22 21:54:55 2009 GMT
Module: SOURCES Tag: HEAD
---- Log message:
- from http://jetmore.org/john/code/swaks
---- Files affected:
SOURCES:
swaks.pl (NONE -> 1.1) (NEW)
---- Diffs:
================================================================
Index: SOURCES/swaks.pl
diff -u /dev/null SOURCES/swaks.pl:1.1
--- /dev/null Sun Feb 22 22:54:55 2009
+++ SOURCES/swaks.pl Sun Feb 22 22:54:49 2009
@@ -0,0 +1,2028 @@
+#!/usr/bin/perl
+
+# use 'swaks --help' to view documentation for this program
+# if you want to be notified about future releases of this program,
+# please send an email to updates-swaks at jetmore.net
+
+use strict;
+
+my($p_name) = $0 =~ m|/?([^/]+)$|;
+my $p_version = "20061116.0";
+my $p_usage = "Usage: $p_name [--help|--version] (see --help for details)";
+my $p_cp = <<EOM;
+ Copyright (c) 2003-2006 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
+ext_usage(); # before we do anything else, check for --help
+
+my %O = ();
+$| = 1;
+
+# need to rewrite header-HEADER opts before std option parsing
+for (my $i = 0; $i < scalar(@ARGV); $i++) {
+ if ($ARGV[$i] =~ /^--h(?:eader)?-(.*)$/) {
+ $ARGV[$i] = "--header"; $ARGV[$i+1] = "$1: $ARGV[$i+1]";
+ }
+}
+if (!load("Getopt::Long")) {
+ ptrans(12, "Unable to load Getopt::Long for option processing, Exiting");
+ exit(1);
+}
+Getopt::Long::Configure("bundling_override");
+GetOptions(
+ 'l|input-file=s' => \$O{option_file}, # (l)ocation of input data
+ 'f|from:s' => \$O{mail_from}, # envelope-(f)rom address
+ 't|to:s' => \$O{mail_to}, # envelope-(t)o address
+ 'h|helo|ehlo|lhlo:s' => \$O{mail_helo}, # (h)elo string
+ 's|server:s' => \$O{mail_server}, # (s)erver to use
+ 'p|port:s' => \$O{mail_port}, # (p)ort to use
+ 'protocol:s' => \$O{mail_protocol}, # protocol to use (smtp, esmtp, lmtp)
+ 'd|data:s' => \$O{mail_data}, # (d)ata portion ('\n' for newlines)
+ 'timeout:s' => \$O{timeout}, # timeout for each trans (def 30s)
+ 'g' => \$O{data_on_stdin}, # (g)et data on stdin
+ 'm' => \$O{emulate_mail}, # emulate (M)ail command
+ 'q|quit|quit-after=s' => \$O{quit_after}, # (q)uit after
+ 'n|suppress-data' => \$O{suppress_data}, # do (n)ot print data portion
+ 'a|auth:s' => \$O{auth}, # force auth, exit if not supported
+ 'au|auth-user:s' => \$O{auth_user}, # user for auth
+ 'ap|auth-password:s' => \$O{auth_pass}, # pass for auth
+ 'am|auth-map=s' => \$O{auth_map}, # auth type map
+ #'ahp|auth-hide-password' => \$O{auth_hidepw}, # hide passwords when possible
+ 'apt|auth-plaintext' => \$O{auth_showpt}, # translate base64 strings
+ 'ao|auth-optional:s' => \$O{auth_optional}, # auth optional (ignore failure)
+ 'support' => \$O{get_support}, # report capabilties
+ 'li|local-interface:s' => \$O{lint}, # local interface to use
+ 'tls' => \$O{tls}, # use TLS
+ 'tlso|tls-optional' => \$O{tls_optional}, # use tls if available
+ 'tlsc|tls-on-connect' => \$O{tls_on_connect}, # use tls if available
+ 'S|silent+' => \$O{silent}, # suppress output to varying degrees
+ 'nsf|no-strip-from' => \$O{no_strip_from}, # Don't strip From_ line from DATA
+ 'nth|no-hints' => \$O{no_hints}, # Don't show transaction hints
+ 'hr|hide-receive' => \$O{hide_receive}, # Don't show reception lines
+ 'hs|hide-send' => \$O{hide_send}, # Don't show sending lines
+ 'stl|show-time-lapse:s' => \$O{show_time_lapse}, # print lapse for send/recv
+ 'ndf|no-data-fixup' => \$O{no_data_fixup}, # don't touch the data
+ 'pipe:s' => \$O{pipe_cmd}, # command to communicate with
+ 'socket:s' => \$O{socket}, # unix domain socket to talk to
+ 'body:s' => \$O{body_822}, # the content of the body of the DATA
+ 'attach-type|attach:s' => \@{$O{attach_822}}, # A file to attach
+ 'ah|add-header:s' => \@{$O{add_header}}, # replacement for %H DATA token
+ 'header:s' => \@{$O{header}}, # replace header if exist, else add
+ 'dump' => \$O{dump_args}, # build options and dump
+ 'pipeline' => \$O{pipeline}, # attempt PIPELINING
+ 'force-getpwuid' => \$O{force_getpwuid} # use getpwuid building -f
+) || exit(1);
+
+# lists of dependencies for features
+%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::SHA1'] },
+ auth_ntlm => { name => "AUTH NTLM", req => ['Authen::NTLM'] },
+ auth_digest_md5 => { name => "AUTH DIGEST-MD5",
+ req => ['Authen::DigestMD5'] },
+ dns => { name => "MX Routing", req => ['Net::DNS'] },
+ tls => { name => "TLS", req => ['Net::SSLeay'] },
+ pipe => { name => "Pipe Transport", req => ['IPC::Open2'] },
+ socket => { name => "Socket Transport", req => ['IO::Socket'] },
+ date_manip => { name => "Date Manipulation", req => ['Time::Local'] },
+ hostname => { name => "Local Hostname Detection",
+ req => ['Sys::Hostname'] },
+ hires_timing => { name => "High Resolution Timing",
+ req => ['Time::HiRes'] },
+);
+
+if ($O{get_support}) {
+ test_support();
+ exit(0);
+}
+
+# We need to fix things up a bit and set a couple of global options
+my $opts = process_args(\%O);
+
+if ($G::dump_args) {
+ test_support();
+ print "dump_args = ", $G::dump_args ? "TRUE" : "FALSE", "\n";
+ print "server_only = ", $G::server_only ? "TRUE" : "FALSE", "\n";
+ print "show_time_lapse = ", $G::show_time_lapse ? "TRUE" : "FALSE", "\n";
+ print "show_time_hires = ", $G::show_time_hires ? "TRUE" : "FALSE", "\n";
+ print "auth_showpt = ", $G::auth_showpt ? "TRUE" : "FALSE", "\n";
+ print "suppress_data = ", $G::suppress_data ? "TRUE" : "FALSE", "\n";
+ print "no_hints = ", $G::no_hints ? "TRUE" : "FALSE", "\n";
+ print "hide_send = ", $G::hide_send ? "TRUE" : "FALSE", "\n";
+ print "hide_receive = ", $G::hide_receive ? "TRUE" : "FALSE", "\n";
+ print "pipeline = ", $G::pipeline ? "TRUE" : "FALSE", "\n";
+ print "silent = $G::silent\n";
+ print "protocol = $G::protocol\n";
+ print "type = $G::link{type}\n";
+ print "server = $G::link{server}\n";
+ print "sockfile = $G::link{sockfile}\n";
+ print "process = $G::link{process}\n";
+ print "from = $opts->{from}\n";
+ print "to = $opts->{to}\n";
+ print "helo = $opts->{helo}\n";
+ print "port = $G::link{port}\n";
+ print "tls = ";
+ if ($G::tls) {
+ print "starttls (", $G::tls_optional ? 'optional' : 'required', ")\n";
+ } elsif ($G::tls_on_connect) {
+ print "on connect (required)\n";
+ } else { print "no\n"; }
+ print "auth = ";
+ if ($opts->{a_type}) {
+ print $G::auth_optional ? 'optional' : 'yes', " type='",
+ join(',', @{$opts->{a_type}}), "' ",
+ "user='$opts->{a_user}' pass='$opts->{a_pass}'\n";
+ } else { print "no\n"; }
+ print "auth map = ", join("\n".' 'x19,
+ map { "$_ = ".
+ join(', ', @{$G::auth_map_t{$_}})
+ } (keys %G::auth_map_t)
+ ), "\n";
+ print "quit after = $G::quit_after\n";
+ print "local int = $G::link{lint}\n";
+ print "timeout = $G::link{timeout}\n";
+ print "data = <<.\n$opts->{data}\n";
+ 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}...");
+ $@ = "";
+ $G::link{sock} = IO::Socket::INET->new(PeerAddr => $G::link{server},
+ PeerPort => $G::link{port}, Proto => 'tcp',
+ Timeout => $G::link{timeout},
+ LocalAddr => $G::link{lint});
+
+ if ($@) {
+ ptrans(12, "Error connecting $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
+
+ # start up tls if -tlsc specified
+ if ($G::tls_on_connect) {
+ if (start_tls()) {
+ ptrans(11, "TLS started w/ cipher $G::link{tls}{cipher}");
+ } 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);
+
+ # QUIT here if the user has asked us to do so
+ do_smtp_quit(1, 0) if ($G::quit_after eq 'connect');
+
+ # Send a HELO string
+ do_smtp_helo($helo, $ehlo, $G::protocol) || do_smtp_quit(1, 22);
+
+ # QUIT here if the user has asked us to do so
+ do_smtp_quit(1, 0) if ($G::quit_after eq 'first-helo');
+
+ # handle TLS here if user has requested it
+ if ($G::tls) {
+ do_smtp_quit(1, 29) if (!do_smtp_tls($ehlo) && !$G::tls_optional);
+ }
+
+ # QUIT here if the user has asked us to do so
+ do_smtp_quit(1, 0) if ($G::quit_after eq 'tls');
+
+ #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 = {};
+ do_smtp_helo($helo, $ehlo, $G::protocol) || do_smtp_quit(1, 32);
+ }
+
+ # QUIT here if the user has asked us to do so
+ do_smtp_quit(1, 0) if ($G::quit_after eq 'helo');
+
+ # handle auth here if user has requested it
+ if ($a_type) {
+ do_smtp_quit(1, 28) if (!do_smtp_auth($ehlo, $a_type, $a_user, $a_pass)
+ && !$G::auth_optional);
+ }
+
+ # QUIT here if the user has asked us to do so
+ do_smtp_quit(1, 0) if ($G::quit_after eq 'auth');
+
+ # send MAIL
+ #do_smtp_gen("MAIL FROM:<$from>", '250') || do_smtp_quit(1, 23);
+ do_smtp_mail($from); # failures in this handled by smtp_mail_callback
+
+ # QUIT here if the user has asked us to do so
+ do_smtp_quit(1, 0) if ($G::quit_after eq 'mail');
+
+ # send RCPT (sub handles multiple, comma-delimited recips
+ #do_smtp_rcpt($to) || do_smtp_quit(1, 24);
+ 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
+
+ # QUIT here if the user has asked us to do so
+ do_smtp_quit(1, 0) if ($G::quit_after eq 'rcpt');
+
+ # send DATA
+ do_smtp_gen('DATA', '354') || do_smtp_quit(1, 25);
+
+ # send the actual data
+ #do_smtp_gen($data, '250', undef, $G::suppress_data) || do_smtp_quit(1, 26);
+ # this was moved to a custom sub because the server will have a custom
+ # behaviour when using LMTP
+ do_smtp_data($data, $G::suppress_data) || do_smtp_quit(1, 26);
+
+ # send QUIT
+ do_smtp_quit(0) || do_smtp_quit(1, 27);
+}
+
+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();
+ $t{con} = Net::SSLeay::CTX_new() || return(0);
+ Net::SSLeay::CTX_set_options($t{con}, &Net::SSLeay::OP_ALL); # error check
+ $t{ssl} = Net::SSLeay::new($t{con}) || 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;
+ $t{res} = Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error())
+ if (!$t{active});
+ $t{cipher} = Net::SSLeay::get_cipher($t{ssl});
+
+ return($t{active});
+}
+
+sub ptrans {
+ my $c = shift; # transaction flag
+ my $m = shift; # message to print
+ my $b = shift; # be brief in what we print
+ my $o = \*STDOUT;
+ my $f;
+
+ return if (($G::hide_send && int($c/10) == 2) ||
+ ($G::hide_receive && int($c/10) == 3));
+
+ # 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) {
+ if ($c%2 != 0) {
+ return();
+ } else {
+ $G::silent = 0;
+ }
+ }
+ }
+
+ # 1x is program messages
+ # 2x is smtp send
+ # 3x is smtp recv
+ # x = 1 is info/normal
+ # x = 2 is error
+ # program info
+ if ($c == 11) { $f = '==='; }
+ # program error
+ elsif ($c == 12) { $f = '***'; $o = \*STDERR; }
+ # smtp send info
+ elsif ($c == 21) { $f = $G::link{tls}{active} ? ' ~>' : ' ->'; }
+ # smtp send error
+ elsif ($c == 22) { $f = $G::link{tls}{active} ? '*~>' : '**>'; }
+ # smtp recv info
+ elsif ($c == 31) { $f = $G::link{tls}{active} ? '<~ ' : '<- '; }
+ # smtp recv error
+ elsif ($c == 32) { $f = $G::link{tls}{active} ? '<~*' : '<**'; }
+ # something went unexpectedly
+ else { $c = '???'; }
+
+ $f .= ' ';
+ $f = '' if ($G::no_hints && int($c/10) != 1);
+
+ 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;
+ print $o "$f$m\n";
+}
+
+sub do_smtp_quit {
+ my $exit = shift;
+ my $err = shift;
+
+ $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_tls {
+ my $e = shift; # ehlo config hash
+
+ if (!$e->{STARTTLS}) {
+ ptrans(12, "STARTTLS not supported");
+ return $G::tls_optional ? 1 : 0;
+ } elsif (!do_smtp_gen("STARTTLS", '220')) {
+ return $G::tls_optional ? 1 : 0;
+ } elsif (!start_tls()) {
+ ptrans(12, "TLS startup failed ($G::link{tls}{res})");
+ return $G::tls_optional ? 1 : 0;
+ }
+
+ ptrans(11, "TLS started w/ cipher $G::link{tls}{cipher}");
+ return(1);
+}
+
+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
+
+ # the auth_optional stuff is handled higher up, so tell the truth about
+ # failing here
+
+ # note that we don't have to check whether the modules are loaded here,
+ # that's done in the option processing - trust that an auth type
+ # wouldn't be in $at if we didn't have the correct tools.
+
+ 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(1) 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(1) 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(1) if (do_smtp_auth_digest($au, $ap, $type));
+ $auth_attempted = 1;
+ }
+ }
+ foreach my $type (@{$G::auth_map_t{'NTLM'}}) {
+ if ($btype eq $type) {
+ return(1) if (do_smtp_auth_ntlm($au, $ap, $type));
+ $auth_attempted = 1;
+ }
+ }
+ foreach my $type (@{$G::auth_map_t{'PLAIN'}}) {
+ if ($btype eq $type) {
+ return(1) if (do_smtp_auth_plain($au, $ap, $type));
+ $auth_attempted = 1;
+ }
+ }
+ foreach my $type (@{$G::auth_map_t{'LOGIN'}}) {
+ if ($btype eq $type) {
+ return(1) if (do_smtp_auth_login($au, $ap, $type));
+ $auth_attempted = 1;
+ }
+ }
+ }
+
+ if ($auth_attempted) {
+ ptrans(12, "No authentication type succeeded");
+ } else {
+ ptrans(12, "No acceptable authentication types available");
+ }
+ return(0);
+}
+
+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 $domain;
+ ($u,$domain) = split(/%/, $u);
+
+ 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($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 $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 $req = Authen::DigestMD5::Request->new($r);
+ my $res = Authen::DigestMD5::Response->new();
+ $res->got_request($req);
+ # XXX using link{server} here is probably a bug, but I don;t know what else
+ # XXX to use yet on a non-inet-socket connection
+ $res->set('username' => $u, 'realm' => '',
+ 'digest-uri' => "smtp/$G::link{server}");
+ $res->add_digest(password => $p);
+ my $d = $res->output();
+ $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?
+ $r = db64($r);
+ $req->input($r);
+ return(0) if (!$req->auth_ok);
+
+ do_smtp_gen("", '235', undef, '',
+ $G::auth_showpt ? "" : '') || return(0);
+ 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
<<Diff was trimmed, longer than 597 lines>>
More information about the pld-cvs-commit
mailing list