diff options
author | Craig A. Berry <craigberry@mac.com> | 2013-11-15 20:55:58 -0600 |
---|---|---|
committer | Craig A. Berry <craigberry@mac.com> | 2014-01-17 17:52:59 -0600 |
commit | 90e95a223539362808feea9b97b7ae99ccfaa210 (patch) | |
tree | 83e2ca69a48abeaa49c44b5ed6743d0974a9face /utils | |
parent | 2bb62a09cce1da4bab5ce16be333e9c54ece21b8 (diff) | |
download | perl-90e95a223539362808feea9b97b7ae99ccfaa210.tar.gz |
Switch perlbug mail sender on VMS.
The VMS mail utility can't do attachments because it always adds
a blank line in front of any headers you add. So use the Send
From File utility, which has been documented and supported for
any release in the last decade and was latently present before
that.
It takes the whole message verbatim just like sendmail, but also
needs the envelope prepended.
Diffstat (limited to 'utils')
-rw-r--r-- | utils/perlbug.PL | 33 |
1 files changed, 19 insertions, 14 deletions
diff --git a/utils/perlbug.PL b/utils/perlbug.PL index 10b66ab16d..e100192e68 100644 --- a/utils/perlbug.PL +++ b/utils/perlbug.PL @@ -1097,22 +1097,27 @@ sub save_message_to_disk { } sub _send_message_vms { - if ( ( $address =~ /@/ and $address !~ /^\w+%"/ ) - or ( $cc =~ /@/ and $cc !~ /^\w+%"/ ) ) { - my $prefix; - foreach ( qw[ IN MX SMTP UCX PONY WINS ], '' ) { - $prefix = "$_%", last if $ENV{"MAIL\$PROTOCOL_$_"}; + + my $mail_from = $from; + my $rcpt_to_to = $address; + my $rcpt_to_cc = $cc; + + map { $_ =~ s/^[^<]*<//; + $_ =~ s/>[^>]*//; } ($mail_from, $rcpt_to_to, $rcpt_to_cc); + + if ( open my $sff_fh, '|-', 'MCR TCPIP$SYSTEM:TCPIP$SMTP_SFF.EXE SYS$INPUT:' ) { + print $sff_fh "MAIL FROM:<$mail_from>\n"; + print $sff_fh "RCPT TO:<$rcpt_to_to>\n"; + print $sff_fh "RCPT TO:<$rcpt_to_cc>\n" if $rcpt_to_cc; + print $sff_fh "DATA\n"; + print $sff_fh build_complete_message(); + my $success = close $sff_fh; + if ($success ) { + print "\nMessage sent\n"; + return; } - $address = qq[${prefix}"$address"] unless $address =~ /^\w+%"/; - $cc = qq[${prefix}"$cc"] unless !$cc || $cc =~ /^\w+%"/; - } - $subject =~ s/"/""/g; - $address =~ s/"/""/g; - $cc =~ s/"/""/g; - my $sts = system(qq[mail/Subject="$subject" $filename. "$address","$cc"]); - if ($sts) { - die "Can't spawn off mail (leaving bug report in $filename): $sts"; } + die "Mail transport failed (leaving bug report in $filename): $^E\n"; } sub _send_message_mailsend { |