What changes do I have to make to turn an unix perl scipt to a windows perl scrip?

Posted by kcom1989 on 2007-02-08 13:07

Hi:

There is this unix perl scrip/program that I would like to change to a window perl scrip/program. Is this possible, and if so what changes do I have to make? Here's a copy of the unix perl scipt/program. Is suppose to work with Mozilla Thunderbird.
--------------------------------
#!/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 you@example.com salty.you.example.com
remap other@example.com foo.example.com

# to set your identity per-recipient (email or part)
# - use workplace address for work recipients
hardwire workplace.example.com you@workplace.example.com
# - use mailing list subscription address when posting to list.
hardwire list1@ml.example.com listsubaddr@example.com

# 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 = ) {
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/[^\@]*\@(.*)/) {
# if ($addr =~ m/^\s*[^\@\s]+\@([^\@\s]+)\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(' ', )) {
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 ivkovic@csi.com
# 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;

kevinw
ActiveState Staff
Fri, 2007-02-09 14:15

Hi,

If you run "perldoc perlport" from the command line it will bring up the manual for Perl portability. Reading this through will give you a good overview of the issues you'll need to be on the lookout for.

Cheers,

kjw