What changes do I have to make on this Unix perl source code to make it run on Windows TIA Steve
-------------------- #!/usr/bin/perl -w # Salter single-threaded email address salter # (c) 2003-2007 Julian Haight, http://www.julianhaight.com/ # All Rights Reserved under GPL: http://www.gnu.org/licenses/gpl.txt # Current version available here: http://www.julianhaight.com/salter my($VERSION) = 'V1.5'; # Version history # 30 Jan 07 V1.5 # add dkim and domain keys signing # 3/2/05 V1.4 # add more verbose status reporting # 2/10/05 V1.3 # fixed bug related to unavailable smtp/regex # 7/19/04 V1.2 # added stripsender feature # fixed missing newline between header & body # 3/26/04 V1.1 # cleaned up smtp sending code, added envonly mode, added version # 3/12/04 # give each recipient their own, permanent random virtual sender # move config to user-dir, not /etc. # 9/29/03 - changed to use only lowercase-alpha, avoid spam filters # Also, added final response after quit (worked without for pine, but not moz) use strict; use Socket; use FileHandle; use Digest::MD5; my($CONFIG) = ($ENV{HOME} . '/.salter'); my($MAPFN) = "$CONFIG/map.txt"; my($EOL) = "\015\012"; my($debug) = 0; my($SMTPTO) = 10; # 10 second timeout my($DKIMSELECT) = 'mail'; my($SAMP) = ' # here is a sample config file: listenport 2525 listenip 127.0.0.1 sendport 25 sendip your_isps_mailserver.example.com maxclient 5 # 1 for unsafe but fast!, 0 for slow & steady (not yet available) buffermode 1 # 1 remaps only envelope, not header, good if you want to filter bad bounces envonly 0 # 1 strips sender field (for pine or whatever) stripsender 1 # From this address To random @ this domain! # ----------------- ------------------------ remap [EMAIL PROTECTED] salty.you.example.com remap [EMAIL PROTECTED] foo.example.com # to set your identity per-recipient (email or part) # - use workplace address for work recipients hardwire workplace.example.com [EMAIL PROTECTED] # - use mailing list subscription address when posting to list. hardwire [EMAIL PROTECTED] [EMAIL PROTECTED] # if present for salted domain, # salter will sign with dkim, using dkim selector "mail" dkim.salty.you.example.com ~/.salter/dkim_priv_key dkim.foo.example.com ~/.salter/dkim_priv_key dkim.example.com ~/.salter/dkim_priv_key # end sample config! '; my(%config, %remap, %map, %hardwire); unless (-e $CONFIG) { mkdir($CONFIG); } readConfig(); # read the config file into %config readMap(); listenLoop(); # work 'til you die! exit 0; # listen for one connection at a time, and call the proxy for each one. # die if there are errors sub listenLoop { my($cliaddr, $cliip, $cliport); socket(SOCK, PF_INET, SOCK_STREAM, getprotobyname('tcp')) || die "Socket: $!"; setsockopt(SOCK, SOL_SOCKET, SO_REUSEADDR, pack('l', 1)) || die "Setsockopt: $!"; bind(SOCK, sockaddr_in($config{'listenport'}, inet_aton($config{'listenip'}))) || die "bind: $!"; listen(SOCK, $config{'maxclient'}) || die "listen: $!"; while ($cliaddr = accept(CLI, SOCK)) { # print STDERR "got connection\n"; ($cliport, $cliip) = (sockaddr_in($cliaddr)); CLI->autoflush(1); if ($_ = proxyIt(\*CLI)) { print STDERR "<< 550 Proxy error: $_\n"; } } } sub proxyIt { my($CLI) = @_; my($cmds, $head, $body, $cmd, $msgid); $body = ''; $cmds = ''; unless ($config{buffered}) { print $CLI "500 No safe delivery mode yet, sorry!$EOL"; close($CLI); die "No safe mode yet, sorry!"; } # read smtp print $CLI "220 localhost SMTP pretender: salter $VERSION $EOL"; while ($cmd = <$CLI>) { $cmds .= $cmd || ''; if (lc($cmd) eq "data$EOL") { last; } if (lc(substr($cmd, 0, 4)) eq 'ehlo') { # print $CLI "451 EHLO is so, so complicated$EOL"; print $CLI "250 Buffering$EOL"; } else { print $CLI "250 Buffering$EOL"; } } print $CLI "354 Ready for data$EOL"; # read head while ($cmd = <$CLI>) { if ($cmd eq $EOL) { last; } if ((!$config{stripsender}) || ($cmd !~ m/^sender:/i)) { $head .= $cmd; } } # read body while ($cmd = <$CLI>) { if ($cmd eq ".$EOL") { last; } $body .= $cmd; } while ($CLI && print $CLI "250 Buffering$EOL") { $cmd = <$CLI>; $cmds .= $cmd; if (lc($cmd) eq "quit$EOL") { last; } } print $CLI "221 Bye bye, hopefully it'll work!$EOL"; close $CLI; if ($head =~ m/message-id: (\S+)/i) { $msgid = $1; } print "Accepted message $msgid\n"; deliverAll($cmds, $head, $body); return undef(); } sub deliverAll { my($cmds, $head, $body) = @_; my($recipmap, $message, $line, $remap, $recip, $sender, $sremap, $sremap_dom, $cmd, $val, $S, @recips, $from); while ($cmds =~ m/([^:\n]*): ?\<?([^\>\n]*[^\s\>])?\>?/g) { $cmd = lc($1); $val = $2; if ($cmd eq 'mail from') { $sender = $val; } elsif ($cmd eq 'rcpt to') { $recip = $val; $remap = getRecipMapping($recip); push(@{$recipmap->{$remap}}, $recip); } } while ($_ = smtpOpen(*S)) { print STDERR "Cannot open smtp: $_, sleeping..\n"; sleep(3); } foreach $remap (keys(%{$recipmap})) { $message = 'X-Mailer-Addon: Salter ' . $VERSION . ' http://www.julianhaight.com/salter' . $EOL . $head; $_ = $recipmap->{$remap}; $sremap = $sender; (@recips) = (@$_); foreach $from (keys(%remap)) { if ($remap =~ m/\@/) { unless ($config{envonly}) { $message = replace($message, $from, $remap); } $sremap = replace($sremap, $from, $remap); } else { unless ($config{envonly}) { $message = replace($message, $from, $remap . '@' . $remap{$from}); } $sremap = replace($sremap, $from, $remap . '@' . $remap{$from}); } } unless ($sremap) { print STDERR "sender $sender not remapped\n"; $sremap = $sender; } $message .= $EOL . $body; if ($sremap =~ m/\@(.*)$/) { $sremap_dom = $1; } if ( $config{ 'dkim.' . $sremap_dom } ) { $message = signDkim($message, $sremap_dom); } if (($_ = smtpEnvelope(\*S, $sremap, @recips)) || ($_ = smtpData(\*S, $message))) { print STDERR ("Failed to send: $_ saving in $CONFIG/failed.txt"); open (SAVE, ">>$CONFIG/failed.txt"); print SAVE $message; close(SAVE); } else { print "Message delivered: $sremap -> @recips\n"; } } smtpClose(\*S); } sub signDkim { require Mail::DKIM::Signer; my($dkim, $message, $domain, $sig, $sigtxt, $dktxt); ($message, $domain) = @_; if (!-e $config{'dkim.' . $domain}) { print STDERR "dkim private key for $domain is missing\n"; return $message; } $dkim = new Mail::DKIM::Signer (Algorithm => 'rsa-sha1', Domain => $domain, Selector => $DKIMSELECT, Method => 'relaxed', KeyFile => $config{'dkim.' . $domain}); $dkim -> PRINT($message); $dkim->finish_body(); $sig = $dkim->signature(); $sigtxt = $sig->as_string(); $dktxt = $sigtxt; # $dktxt = $sigtxt = replace($sigtxt, ' ', $EOL . "\t"); $dktxt = replace(replace($dktxt, 'c=relaxed', 'c=nofws'), 'DKIM-Signature', 'DomainKey-Signature'); $dktxt =~ s/bh=\S+\s*//; return $sigtxt . $EOL . $dktxt . $EOL . $message; # return $sigtxt . $EOL . $message; } sub signDomainKeys { require Mail::DomainKeys; my($dk, $key, $head, $body, $message, $domain); ($message, $domain) = @_; $dk = new Mail::DomainKeys::Message; if ($_ = index($message, $EOL . $EOL) >=0) { $head = substr($message, 0, $_); $body = substr($message, $_); } else { print STDERR "Cannot find head/body split for DomainKeys\n"; } $dk->load(HeadString => $head, BodyReference => $body); $key = load Mail::domainKeys::Key::Private (File => $config{'dkim.' . $domain}); $dk->sign(Method=>'simple', Selector=>$DKIMSELECT); } sub randSecret { my($len) = @_; my($char, $pass, $i); for ($i=0; $i < $len; $i++) { $char = int(rand() * 26); $char += 97; $pass .= pack('c', $char); } return $pass; } sub readConfig { my($line); my($fn) = "$CONFIG/salter.conf"; unless (-e $fn) { print STDERR "Salter not configured. Please create $fn. Sample: $SAMP "; exit 1; } open (CONFIG, $fn) || die "$fn $!"; while ($line = <CONFIG>) { if ($line =~ m/^([^\#;\s]\S+)\s*(\S+)\s*(\S*).*$/) { if ($1 eq 'remap') { $remap{$2} = $3; } elsif ($1 eq 'hardwire') { $hardwire{$2} = $3; } else { $config{$1} = $2; } } } print STDERR "Listening on $config{'listenip'}:$config{'listenport'} Outbound on $config{'sendip'}:$config{'sendport'}\n"; } sub getSenderMapping { my($addr) = lc(@_); return $remap{$addr} } sub getRecipMapping { my($addr) = lc($_[0]); my(@parts, $part); # exact match if ($part = $hardwire{$addr}) { return $part; } # domain match (@parts) = (getDomParts($addr)); while (@parts) { if ($part = $hardwire{join('.', @parts)}) { return $part; } pop(@parts); } # default randomizer return getMapping($addr); } sub getDomParts { my($addr) = @_; my($dom, @parts); # print "getDomParts $addr\n"; # print hexDump($addr) . "\n"; if ($addr =~ m/[EMAIL PROTECTED]@(.*)/) { # if ($addr =~ m/[EMAIL PROTECTED]@([EMAIL PROTECTED])\s*$/) { $dom = $1; (@parts) = (split(/\./, $dom)); } # print STDERR "parts: @parts ($dom)\n"; return (@parts); } sub getMapping { my($addr) = @_; my($hash) = Digest::MD5::md5_base64($addr); my($rand); unless ($rand = $map{$hash}) { $map{$hash} = ($rand = randSecret(16)); writeMap($hash, $rand); } # print "getMapping $addr = $rand\n"; return ($rand); } sub writeMap { open(MAP, ">>$MAPFN") || return 1; print MAP join(' ', @_) . "\n"; close(MAP); } sub readMap { my($line); my($key, $val); unless (-e $MAPFN) { print STDERR "Starting hashed recip map in $MAPFN\n"; } elsif (open (MAP, $MAPFN)) { while (($key, $val) = split(' ', <MAP>)) { chop($map{$key} = $val); } } else { die "Error opening $MAPFN for read: $!"; } close(MAP); } sub replace { my($text, $old, $new) = @_; my($loc, $len); # print "text: $text\n"; if (index($new, $old) >= 0) { return $text; } $len = length($old); $loc = index($text, $old); while ($loc >= 0) { $text = substr($text, 0, $loc) . $new . substr($text, $loc + $len); $loc = index($text, $old); } # print "replaced $old with $new in text: $text\n"; return $text; } sub errlog { print STDERR "@_\n"; } sub hexDump { my($string) = @_; my($size) = 15; my($char, $rval, $hex, $str, $asc); foreach $char (split('', $string)) { $asc = unpack('C', $char); if (($asc < 32) || ($asc > 176)) { $char = '?'; $hex .= sprintf('%.2x<', $asc); } else { $hex .= sprintf('%.2x ', $asc); } $str .= $char; if (length($str) >= $size) { $rval .= $hex . $str . "\n"; $hex = ''; $str = ''; } } if ($hex) { $hex .= (' ' x (($size*3) - length($hex))); $rval .= $hex . $str . "\n" } $rval = substr($rval, 0, length($rval)-1); return $rval; } # (C) 2002, 2003 Julian Haight. All rights reserved # original sendmail 1.21 by Christian Mallwitz. # Modified and 'modulized' by [EMAIL PROTECTED] # totally mangled by julian # adapted for salter 3/13/04 sub smtpSend { my($message, $fromaddr, @recips) = @_; unless ($message) { errlog ("Refusing to send empty email $fromaddr -> @recips"); return undef(); } if ($debug) { errlog("trying smtpSend"); } # now, isn't that pretty? if (($_ = smtpOpen(\*S)) || ($_ = smtpEnvelope(\*S, $fromaddr, @recips)) || ($_ = smtpData(\*S, $message)) || ($_ = smtpClose(\*S))) { return ("smtpSend:" . $_); } else { return undef(); } } sub smtpOpen { my($fh) = @_; my($k, $proto, $smtpaddr); ($smtpaddr) = (gethostbyname($config{sendip}))[4]; my $save_w = $^W; local $/; $/ = "\015\012"; $proto = (getprotobyname('tcp'))[2]; unless (defined($smtpaddr)) { return ("smtpOpen: smtp host unknown:'" . $config{sendip} . "'"); } # open socket and start mail session if (!socket($fh, AF_INET, SOCK_STREAM, $proto)) { return ("smtpOpen: socket failed ( $! )"); } # connect if (!connect($fh, pack('Sna4x8', AF_INET, $config{sendport}, $smtpaddr))) { if ($! eq 'Interrupted system call') { return "smtpOpen: timeout after $SMTPTO seconds during connect"; } else { return ("smtpOpen: connect to smtp server failed ($!)"); } } my($oldfh) = select($fh); $| = 1; select($oldfh); if (($_ = smtpExchange($fh)) !~ m/^[23]/) { return ("smtpOpen: smtpsend connection error from smtp server ($_)"); } if (($_ = smtpExchange($fh, "HELO Salter" . $VERSION)) !~ m/^[23]/) { return ("smtpOpen: smtpsend HELO error ($_)"); } return undef(); } sub smtpEnvelope { my($fh, $from, @recips) = @_; if (($_ = smtpFrom($fh, $from)) || ($_ = smtpTo($fh, @recips))) { return "smtpEnvelope ($from, @recips): $_"; } return undef(); } sub smtpFrom { my($fh, $from) = @_; if (($_ = smtpExchange($fh, "MAIL FROM: <$from>")) !~ m/^[23]/) { return ("smtpFrom: mail From $from: error ($_)"); } return undef(); } sub smtpTo { my($fh, @recips) = @_; my($to); unless (@recips) { return ("No recipient!") } foreach $to (@recips) { unless ($to) { errlog("Null recipient in smtpTo, skipping"); next; } if (($_ = smtpExchange($fh, "RCPT TO: <$to>")) !~ m/^[23]/) { return ("smtpTo rcpt to:$to ($_)"); } } return undef(); } sub smtpData { my($fh, $data) = @_; $data =~ s/^\./\.\./gm; # handle . as first character if ($_ = smtpBeginData($fh)) { return $_; } smtpOutput($fh, $data); if ($debug) { errlog("Wrote " . length($data) . " bytes of data"); } return smtpEnd($fh); } sub smtpOutput { my($fh, $data) = @_; my($i, $c, $lc); for ($i = 0; $i < length($data); $i++) { $c = substr($data, $i, 1); if (($c eq "\012") && ($lc ne "\015")) { print $fh "\015"; } $lc = $c; print $fh $c; } } sub smtpBeginData { my($fh) = @_; if (($_ = smtpExchange($fh, "DATA")) !~ m/^[23]/) { return ("smtpBeginData: Cannot send data ($_)"); } return undef(); } sub smtpRset { my($fh) = @_; if (($_ = smtpExchange($fh, "RSET")) !~ m/^[23]/) { return ("smtpRset: Cannot rset smtp ($_)"); } return undef(); } sub smtpEnd { my($fh) = @_; if (($_ = smtpExchange($fh, "\015\012.")) !~ m/^[23]/) { return ("smtpEnd: message transmission failed: $_"); } return undef(); } sub smtpClose { my($fh) = @_; my($code) = smtpExchange($fh, "QUIT"); close $fh; if ($code !~ m/^[23]/) { return ("smtpClose: cannot quit: $_"); } else { return undef(); } } sub smtpExchange { my($fh, $cmd) = @_; my($resp); if ($cmd) { print $fh ($cmd . "\015\012"); if ($debug) { errlog(">> $cmd"); } } while (defined($resp = <$fh>) && ($resp !~ m/^(\d+)\s/)) { if ($debug) { errlog("<. $resp"); } } chomp($resp); if ($debug) { errlog("<< $resp"); } return $resp; } 1; _______________________________________________ Perl-Win32-Users mailing list [email protected] To unsubscribe: http://listserv.ActiveState.com/mailman/mysubs
