F:\WEBSITES\testbed\zipped\yabb_svn_new\branches\2.5.2\cgi-bin\yabb2\Sources\Smtp.pl F:\WEBSITES\testbed\zipped\yabb_svn_new\trunk\cgi-bin\yabb2\Sources\Smtp.pm
############################################################################### ###############################################################################
# Smtp.pl                                                                     # # Smtp.pm                                                                     #
  # $Date: 01.05.16 $                                                           #
############################################################################### ###############################################################################
# YaBB: Yet another Bulletin Board                                            # # YaBB: Yet another Bulletin Board                                            #
# Open-Source Community Software for Webmasters                               # # Open-Source Community Software for Webmasters                               #
# Version:        YaBB 2.5.2                                                  # # Version:        YaBB 2.6.12                                                 #
# Packaged:       October 21, 2012                                            # # Packaged:       January 5, 2016                                             #
# Distributed by: http://www.yabbforum.com                                    # # Distributed by: http://www.yabbforum.com                                    #
# =========================================================================== # # =========================================================================== #
# Copyright (c) 2000-2012 YaBB (www.yabbforum.com) - All Rights Reserved.     # # Copyright (c) 2000-2016 YaBB (www.yabbforum.com) - All Rights Reserved.     #
# Software by:  The YaBB Development Team                                     # # Software by:  The YaBB Development Team                                     #
#               with assistance from the YaBB community.                      # #               with assistance from the YaBB community.                      #
############################################################################### ###############################################################################
  use English '-no_match_vars';
  our $VERSION = '2.6.12';
   
$smtpplver = 'YaBB 2.5.2 $Revision: 1.0 $'; $smtppmver = 'YaBB 2.6.12 $Revision: 1710 $';
if ($action eq 'detailedversion') { return 1; } if ( $action eq 'detailedversion' ) { return 1; }
   
eval q^  eval q{ 
   use IO::Socket::INET;    use IO::Socket::INET;
   use Digest::HMAC_MD5 qw(hmac_md5_hex);    use Digest::HMAC_MD5 qw(hmac_md5_hex);
^;  }; 
   
&LoadLanguage('Smtp');  LoadLanguage('Smtp'); 
   
sub use_smtp { sub use_smtp {
   $| = 1;     my ($smtpaddr); 
#   my ($code, $text, $more);     $OUTPUT_AUTOFLUSH = 1; 
#   my (%features);     my ($proto) = ( getprotobyname 'tcp' )[2]; 
   my ($proto)    = (getprotobyname('tcp'))[2];     my ($port) = ( getservbyname 'smtp', 'tcp' )[2] || 25; 
   my ($port)     = (getservbyname('smtp', 'tcp'))[2] || 25;     if ( $smtp_server =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/xsm ) { 
   my ($smtpaddr) = ($smtp_server =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/) ? pack('C4', $1, $2, $3, $4) : (gethostbyname($smtp_server))[4];         $smtpaddr = 
   $sendlog = "";           ( $smtp_server =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/xsm ) 
   $auth_ok = 0;           ? pack( 'C4', $1, $2, $3, $4 ) 
           : ( gethostbyname $smtp_server )[4];
   # Connect to the SMTP server.     } 
   $sock = IO::Socket::INET->new(     $sendlog = q{}; 
       PeerAddr => $smtp_server,     $auth_ok = 0; 
       PeerPort => $port,  
       Proto => 'tcp',     # Connect to the SMTP server. 
       Timeout => 5)     $sock = IO::Socket::INET->new( 
       # Check if the service is available and parse any errors         PeerAddr => $smtp_server, 
       or &fatal_error("smtp_unavail");         PeerPort => $port, 
         Proto    => 'tcp',
   &get_line;         Timeout  => 5 
   &say_hello ($smtp_server) or exit (1);       ) 
   
   if (defined ($features{'AUTH'}) && $smtp_auth_required) {       # Check if the service is available and parse any errors 
       # Try CRAM-MD5 if supported by the server       or fatal_error('smtp_unavail'); 
       if ($auth_ok == 0 && ($features{'AUTH'} =~ /CRAM-MD5/i || $smtp_auth_required == 3 || $smtp_auth_required == 4)) {  
           &send_line ("AUTH CRAM-MD5\r\n");     get_line(); 
           ($code, $text, $more) = &get_line;     say_hello($smtp_server) or exit 1; 
           if ($code != 334 && $smtp_auth_required != 4)  
           {    if ( $features{'AUTH'} && $smtp_auth_required ) {
               &fatal_error("smtp_error","[$code]: $smtp_txt{$code}<br /><br /><b>$smtp_txt{'5'}</b><br />$sendlog");  
#                return 0;         # Try CRAM-MD5 if supported by the server 
           }         if ( 
           my $response = &encode_cram_md5 ($text, $authuser, $authpass);             $auth_ok == 0 
           &send_line ("%s\r\n", $response);             && (   $features{'AUTH'} =~ /CRAM-MD5/ixsm 
           ($code, $text, $more) = &get_line;                 || $smtp_auth_required == 3 
           if ($code != 235 && $smtp_auth_required != 4)                 || $smtp_auth_required == 4 ) 
           {           ) 
               &fatal_error("smtp_error","[$code]: $smtp_txt{$code}<br /><br /><b>$smtp_txt{'5'}</b><br />$sendlog");         { 
#               return 0;             send_line("AUTH CRAM-MD5\r\n"); 
           }             ( $code, $text, $more ) = get_line(); 
           $auth_ok = 1;             if ( $code != 334 && $smtp_auth_required != 4 ) { 
       }                 fatal_error( 'smtp_error', 
       # Or try LOGIN method  "[$code]: $smtp_txt{$code}<br /><br /><b>$smtp_txt{'5'}</b><br />$sendlog" 
       elsif ($auth_ok == 0 && ($features{'AUTH'} =~ /LOGIN/i  || $smtp_auth_required == 2 || $smtp_auth_required == 4)) {                 ); 
           &send_line ("AUTH LOGIN\r\n");  
           ($code, $text, $more) = &get_line;             } 
           if ($code != 334 && $smtp_auth_required != 4)             my $response = encode_cram_md5( $text, $authuser, $authpass ); 
           {             send_line( "%s\r\n", $response ); 
               &fatal_error("smtp_error","[$code]: $smtp_txt{$code}<br /><br /><b>$smtp_txt{'5'}</b><br />$sendlog");             ( $code, $text, $more ) = get_line(); 
#               return 0;             if ( $code != 235 && $smtp_auth_required != 4 ) { 
           }                 fatal_error( 'smtp_error', 
  "[$code]: $smtp_txt{$code}<br /><br /><b>$smtp_txt{'5'}</b><br />$sendlog" 
           &send_line ("%s\r\n", encode_smtp64 ($authuser, ""));                 ); 
             }
           ($code, $text, $more) = &get_line;             $auth_ok = 1; 
           if ($code != 334 && $smtp_auth_required != 4)         } 
           {  
               &fatal_error("smtp_error","[$code]: $smtp_txt{$code}<br /><br /><b>$smtp_txt{'5'}</b><br />$sendlog");         # Or try LOGIN method 
#               return 0;         elsif ( 
           }             $auth_ok == 0 
           &send_line ("%s\r\n", encode_smtp64 ($authpass, ""));             && (   $features{'AUTH'} =~ /LOGIN/ism 
           ($code, $text, $more) = &get_line;                 || $smtp_auth_required == 2 
           if ($code != 235 && $smtp_auth_required != 4)                 || $smtp_auth_required == 4 ) 
           {           ) 
               &fatal_error("smtp_error","[$code]: $smtp_txt{$code}<br /><br /><b>$smtp_txt{'5'}</b><br />$sendlog");         { 
#               return 0;             send_line("AUTH LOGIN\r\n"); 
           }             ( $code, $text, $more ) = get_line(); 
           $auth_ok = 1;             if ( $code != 334 && $smtp_auth_required != 4 ) { 
       }                 fatal_error( 'smtp_error', 
       # Or finally PLAIN if nothing else was supported.  "[$code]: $smtp_txt{$code}<br /><br /><b>$smtp_txt{'5'}</b><br />$sendlog" 
       elsif ($auth_ok == 0 && ($features{'AUTH'} =~ /PLAIN/i || $smtp_auth_required == 1 || $smtp_auth_required == 4)) {                 ); 
           &send_line ("AUTH PLAIN %s\r\n",             } 
           encode_smtp64 ("$authuser\0$authuser\0$authpass", ""));             send_line( "%s\r\n", encode_smtp64( $authuser, q{} ) ); 
           ($code, $text, $more) = &get_line;  
           if ($code != 235 && $smtp_auth_required != 4)             ( $code, $text, $more ) = get_line(); 
           {            if ( $code != 334 && $smtp_auth_required != 4 ) {
               &fatal_error("smtp_error","[$code]: $smtp_txt{$code}<br /><br /><b>$smtp_txt{'5'}</b><br />$sendlog");                 fatal_error( 'smtp_error', 
#               return 0;  "[$code]: $smtp_txt{$code}<br /><br /><b>$smtp_txt{'5'}</b><br />$sendlog" 
           }                 ); 
           $auth_ok = 1;             } 
       }             send_line( "%s\r\n", encode_smtp64( $authpass, q{} ) ); 
       # Decide to complain about advertised methods not supported.             ( $code, $text, $more ) = get_line(); 
       else             if ( $code != 235 && $smtp_auth_required != 4 ) { 
       {                 fatal_error( 'smtp_error', 
           &fatal_error("smtp_error","$smtp_txt{'notsupported'}<br /><br /><b>$smtp_txt{'5'}</b><br />$sendlog");  "[$code]: $smtp_txt{$code}<br /><br /><b>$smtp_txt{'5'}</b><br />$sendlog" 
#           return 0;                 ); 
       }            }
   }             $auth_ok = 1; 
         }
   # build the Date per RFC822 - uses gmtime to create date & time stamp  
   ($smtpsec, $smtpmin, $smtphour, $smtpmday, $smtpmon, $smtpyear, $smtpwday, $smtpyday, $smtpisdst) = gmtime($date + (3600 * $timeoffset));         # Or finally PLAIN if nothing else was supported. 
   $smtpyear       = sprintf("%02d", ($smtpyear - 100));         elsif ( 
   $smtphour       = sprintf("%02d", $smtphour);             $auth_ok == 0 
   $smtpmin        = sprintf("%02d", $smtpmin);             && (   $features{'AUTH'} =~ /PLAIN/ism 
   $smtpsec        = sprintf("%02d", $smtpsec);                 || $smtp_auth_required == 1 
   my @months2     = ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');                 || $smtp_auth_required == 4 ) 
   $smtpyear       = qq~20$smtpyear~;           ) 
   $smtptimestring = qq~$days_short[$smtpwday], $smtpmday $months2[$smtpmon] $smtpyear $smtphour\:$smtpmin\:$smtpsec +0000~;         { 
             send_line( "AUTH PLAIN %s\r\n",
   # Fill the mail from field                 encode_smtp64( "$authuser\0$authuser\0$authpass", q{} ) ); 
   &send_line ("MAIL FROM: <$smtp_from>\r\n");             ( $code, $text, $more ) = get_line(); 
   ($code, $text, $more) = &get_line;             if ( $code != 235 && $smtp_auth_required != 4 ) { 
   # Add as many addressees as needed                 fatal_error( 'smtp_error', 
   foreach (split(/, /, $smtp_to)) {  "[$code]: $smtp_txt{$code}<br /><br /><b>$smtp_txt{'5'}</b><br />$sendlog" 
       &send_line ("RCPT TO: <$_>\r\n");                 ); 
       ($code, $text, $more) = &get_line;             } 
   }             $auth_ok = 1; 
         }
   # Send message data  
   &send_line ("DATA\r\n");         # Decide to complain about advertised methods not supported. 
   ($code, $text, $more) = &get_line;         else { 
   &send_line ("To: $toheader\r\n");             fatal_error( 'smtp_error', 
   &send_line ("Date: $smtptimestring\r\n");  "$smtp_txt{'notsupported'}<br /><br /><b>$smtp_txt{'5'}</b><br />$sendlog" 
   &send_line ("From: $fromheader\r\n");             ); 
   &send_line ("X-Mailer: YaBB SMTP\r\n");         } 
   &send_line ("Subject: $smtp_subject\r\n");     } 
   &send_line ("Content-Type: text/plain\; charset=$smtp_charset\r\n\r\n");  
   &send_line ("$smtp_message");     # build the Date per RFC822 - uses gmtime to create date & time stamp 
   &send_line ("\r\n.\r\n");     ( 
         $smtpsec,  $smtpmin,  $smtphour, $smtpmday, $smtpmon,
   # It is polite to close the door behind you         $smtpyear, $smtpwday, $smtpyday, $smtpisdst 
   &send_line ("QUIT\r\n");     ) = gmtime( $date ); 
   if ($smtp_from eq ""){ $proto_error = "$smtp_txt{'no_from'}<br />"; }     $smtpyear = sprintf '%02d', ( $smtpyear - 100 ); 
   if ($smtp_to eq ""){ $proto_error .= "$smtp_txt{'no_to'}<br />"; }     $smtphour = sprintf '%02d', $smtphour; 
   if ($proto_error){     $smtpmin  = sprintf '%02d', $smtpmin; 
       &fatal_error("smtp_error","<br />$proto_error<br />$sendlog");     $smtpsec  = sprintf '%02d', $smtpsec; 
   }     my @months2 = qw( 
   return 1;       Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec 
     );
     $smtpyear = qq~20$smtpyear~;
     $smtptimestring =
  qq~$days_short[$smtpwday], $smtpmday $months2[$smtpmon] $smtpyear $smtphour\:$smtpmin\:$smtpsec +0000~;
   
     # Fill the mail from field
     send_line("MAIL FROM: <$smtp_from>\r\n");
     ( $code, $text, $more ) = get_line();
   
     # Add as many addressees as needed
     foreach ( split /,\ /xsm, $smtp_to ) {
         send_line("RCPT TO: <$_>\r\n");
         ( $code, $text, $more ) = get_line();
     }
   
     # Send message data
     send_line("DATA\r\n");
     ( $code, $text, $more ) = get_line();
     send_line("To: $toheader\r\n");
     send_line("Date: $smtptimestring\r\n");
     send_line("From: $fromheader\r\n");
     send_line("X-Mailer: YaBB SMTP\r\n");
     send_line("Subject: $smtp_subject\r\n");
     send_line("Content-Type: text/html\; charset=$smtp_charset\r\n\r\n");
     send_line("$smtp_message");
     send_line("\r\n.\r\n");
   
     # It is polite to close the door behind you
     send_line("QUIT\r\n");
     if ( $smtp_from eq q{} ) { $proto_error = "$smtp_txt{'no_from'}<br />"; }
     if ( $smtp_to eq q{} ) { $proto_error .= "$smtp_txt{'no_to'}<br />"; }
     if ($proto_error) {
         fatal_error( 'smtp_error', "<br />$proto_error<br />$sendlog" );
     }
     return 1;
} }
   
# Get one line of response from the server. # Get one line of response from the server.
sub get_line { sub get_line {
   my ($code, $sep, $text) = ($sock->getline() =~ /(\d+)(.)([^\r]*)/);     my ( $code, $sep, $text ) = ( $sock->getline() =~ /(\d+)(.)([^\r]*)/xsm ); 
   my $more;    my $more;
   $code =~ s/ //g;     $code =~ s/ //gsm; 
   if ($sep eq "-") { $more = 1; } else { $more = 0; }     if   ( $sep eq q{-} ) { $more = 1; } 
   $sendlog .= qq~S:$code $text $sep~;     else                  { $more = 0; } 
   $sendlog .= qq~<br />~;     $sendlog .= qq~S:$code $text $sep~; 
   return ($code, $text, $more);     $sendlog .= q~<br />~; 
     return ( $code, $text, $more );
} }
   
   
# Send one line back to the server # Send one line back to the server
sub send_line (@) { sub send_line (@) {
   my @args = @_;    my @args = @_;
#   $args[0] =~ s/\n/\r\n/g;  
   $sendlog .= qq~C:$args[0]~;     #   $args[0] =~ s/\n/\r\n/gsm; 
   $sendlog =~ s/\r\n//g;     $sendlog .= qq~C:$args[0]~; 
   $sendlog .= qq~<br />~;     $sendlog =~ s/\r\n//gxsm; 
   $sock->printf (@args);     $sendlog .= q~<br />~; 
     $sock->printf(@args);
     return;
} }
   
# Helper function to encode CRAM-MD5 challenge # Helper function to encode CRAM-MD5 challenge
sub encode_cram_md5 ($$$) { sub encode_cram_md5 ($$$) {
   my ($ticket64, $username, $password) = @_;    my ( $ticket64, $username, $password ) = @_;
   my $ticket = decode_smtp64($ticket64) or     my $ticket = decode_smtp64($ticket64) 
       die ("Unable to decode Base64 encoded string '$ticket64'\n");       or die "Unable to decode Base64 encoded string '$ticket64'\n"; 
   
   my $password_md5 = hmac_md5_hex($ticket, $password);     my $password_md5 = hmac_md5_hex( $ticket, $password ); 
   return encode_smtp64 ("$username $password_md5", "");     return encode_smtp64( "$username $password_md5", q{} ); 
} }
   
sub encode_smtp64 { sub encode_smtp64 {
   if ($] >= 5.006) {     my ( $inp, $eol ) = @_; 
   require bytes;     if ( $] >= 5.006 ) { 
   if (bytes::length($_[0]) > length($_[0]) ||         require bytes; 
       ($] >= 5.008 && $_[0] =~ /[^\0-\xFF]/))         if ( bytes::length($inp) > length($inp) 
   {             || ( $] >= 5.008 && $inp =~ /[^\0-\xFF]/xsm ) ) 
       require Carp;         { 
       Carp::croak("The Base64 encoding is only defined for bytes");             require Carp; 
   }             Carp::croak('The Base64 encoding is only defined for bytes'); 
         }
   }    }
   require integer;    require integer;
   import integer;    import integer;
   my $eol = $_[1];     if ( !$eol ) { $eol = "\n"; } 
   $eol = "\n" unless defined $eol;  
     my $res = pack 'u', $inp;
   
   my $res = pack("u", $_[0]);  
   # Remove first character of each line, remove newlines    # Remove first character of each line, remove newlines
   $res =~ s/^.//mg;     $res =~ s/^.//gxsm; 
   $res =~ s/\n//g;     $res =~ s/\n//gxsm; 
   $res =~ tr|` -_|AA-Za-z0-9+/|;               # `# help emacs    $res =~ tr|` -_|AA-Za-z0-9+/|;    # `# help emacs
   # fix padding at the end                                      # fix padding at the end
   my $padding = (3 - length($_[0]) % 3) % 3;    my $padding = ( 3 - length($inp) % 3 ) % 3;
   $res =~ s/.{$padding}$/'=' x $padding/e if $padding;     if ($padding) { $res =~ s/.{$padding}$/q{=} x $padding/exsm; } 
   
   # break encoded string into lines of no more than 76 characters each    # break encoded string into lines of no more than 76 characters each
   if (length $eol) {    if ( length $eol ) {
   $res =~ s/(.{1,76})/$1$eol/g;         $res =~ s/(.{1,76})/$1$eol/gxsm; 
   }    }
   chomp $res;    chomp $res;
   return $res;    return $res;
} }
   
sub decode_smtp64 ($)  sub decode_smtp64 ($) { 
{     local $WARNING = 0;    # unpack("u",...) gives bogus warning in 5.00[123] 
   local($^W) = 0; # unpack("u",...) gives bogus warning in 5.00[123]  
   require integer;    require integer;
   import integer;    import integer;
   
   my $str = shift;    my $str = shift;
   $str =~ tr|A-Za-z0-9+=/||cd;            # remove non-base64 chars    $str =~ tr|A-Za-z0-9+=/||cd;    # remove non-base64 chars
#    if (length($str) % 4) {     $str =~ s/=+$//xsm;             # remove padding 
#    require Carp;     $str =~ tr|A-Za-z0-9+/| -_|;    # convert to uuencoded format 
#   Carp::carp("Length of base64 data not a multiple of 4")     if ( !length $str ) { return q{}; } 
#   }  
   $str =~ s/=+$//;                        # remove padding     my $uustr = q{}; 
   $str =~ tr|A-Za-z0-9+/| -_|;            # convert to uuencoded format     my $l     = length($str) - 60; 
   return "" unless length $str;     foreach my $i ( 0 .. $l ) { 
         if ( $i % 60 == 0 ) {
   ## I guess this could be written as             $uustr .= 'M' . substr $str, $i, 60; 
   #return unpack("u", join('', map( chr(32 + length($_)*3/4) . $_,         } 
   #           $str =~ /(.{1,60})/gs) ) );  
   ## but I do not like that...  
   my $uustr = '';  
   my ($i, $l);  
   $l = length($str) - 60;  
   for ($i = 0; $i <= $l; $i += 60) {  
   $uustr .= "M" . substr($str, $i, 60);  
   }    }
   $str = substr($str, $i);     $str = substr $str, $i; 
   
   # and any leftover chars    # and any leftover chars
   if ($str ne "") {    if ( $str ne q{} ) {
   $uustr .= chr(32 + length($str)*3/4) . $str;        $uustr .= chr( 32 + length($str) * 3 / 4 ) . $str;
   }    }
   return unpack ("u", $uustr);     return unpack 'u', $uustr; 
} }
   
sub say_hello ($) { sub say_hello ($) {
   my ($hello_host) = $_[0];     my ($hello_host) = @_; 
   my ($feat, $param);     my ( $feat, $param ); 
   #send RFC2821 compliant identifyer  
   &send_line ("EHLO $hello_host\r\n");     #send RFC2821 compliant identifier 
   ($code, $text, $more) = &get_line;     send_line("EHLO $hello_host\r\n"); 
   if($code != 250){     ( $code, $text, $more ) = get_line(); 
       #try sending an old RFC281 compliant identifyer (older Exchange servers)     if ( $code != 250 ) { 
       &send_line ("HELO $hello_host\r\n");  
   }         #try sending an old RFC281 compliant identifier (older Exchange servers) 
   ($code, $text, $more) = &get_line;         send_line("HELO $hello_host\r\n"); 
   if($code == 250){     } 
       &read_features(\%features);     ( $code, $text, $more ) = get_line(); 
   }     if ( $code == 250 ) { 
   return 1;         read_features( \%features ); 
     }
     return 1;
} }
   
sub read_features ($) { sub read_features ($) {
   my ($featref) = $_[0];     my ($featref) = @_; 
   # Empty the hash  
   %{$featref} = ();     # Empty the hash 
   ($feat, $param) = ($text =~ /^(\w+)[= ]*(.*)$/);     %{$featref} = (); 
   $featref->{$feat} = $param;     ( $feat, $param ) = ( $text =~ /^(\w+)[= ]*(.*)$/xsm ); 
     $featref->{$feat} = $param;
   # Load all features presented by the server into the hash  
   while ($more == 1) {     # Load all features presented by the server into the hash 
       ($code, $text, $more) = &get_line;     while ( $more == 1 ) { 
       ($feat, $param) = ($text =~ /^(\w+)[= ]*(.*)$/);         ( $code, $text, $more ) = get_line(); 
       $featref->{$feat} = $param;         ( $feat, $param ) = ( $text =~ /^(\w+)[= ]*(.*)$/xsm ); 
   }         $featref->{$feat} = $param; 
   return 1;     } 
     return 1;
} }
   
1; 1;