patrmich has asked for the wisdom of the Perl Monks concerning the following question:

Hi,

I am using a cgi script to send an order e-mail confirmation. The trouble is the following :

- there is no carriage return in the html code of the generated e-mail.

I have to say that I have no knowledge in Perl, and aopologize in advance for it.

I am sending here below the copy of the cgi script and I thank you very much in advance for any help in this matter.

Kind Regards,

Patrick 

#!/usr/bin/perl

# $external_prefix is the prefix to append to lockssl-on.gif and thank
+you_url if necessary.
# If you want to use "/files/lockssl-on.gif" and "/files/thankyou.html
+" then $external_prefix
# must be set to '/files/'
$external_prefix = '';

$mailusing = 'sendmail';
$mailprog = '/usr/sbin/sendmail';
$smtp_addr = '127.0.0.1';
$pgp_tmp = "/tmp/pgporder.$$";
$pgp_cmd = '/usr/bin/pgpe';
$pgp_opt = '-fa +batchmode +force +NoBatchInvalidKeys=0';

# valid referers
@referers = (
    '.*blank\.html',
    '.*shopfactory5_orderDS\.cgi',        # standard
    '.*ordernav\.html',                # standard
    '.*method\.html',                # standard with custom payment fi
+elds
    '.*fields\.html',                # standard with custom payment fi
+elds
    '.*authorized\.html',            # various payment systems
    '.*VueltaOk\.html',                # banesto
    '.*vuelta\.exe',                # banesto
    '.*shopwizard_order\.cgi',        # obsolete
    '.*pgp_order\.cgi',                # obsolete
    '.*order2\.html',                # obsolete
    '.*order3\.html',                # obsolete
    '.*order4\.html',                # obsolete
    '.*customerdtl\.html',            # obsolete
    '.*deliverydtl\.html'            # obsolete
);
$body="";
$body_override="";
# required fields
@required = ('order_email');

&parse_form;
if($FORM{'email_format'} =~ m/text/) {
    $emailFormat="text/plain";
}
else {
    # original code avant le 23-09
# $emailFormat="text/html;\n".$FORM{'http_charset'};
#  modif Patrick le 23-10-09
$emailFormat="text/html; charset=ISO-8859-1\n\n".$FORM;

}
&check_referer;
&check_required;
&get_date;
&send_email;
if($FORM{'redirect_only'} ne "true") {
    &print_html;
} else {
    &redirect;
}

sub get_date {
    @days = ('Sunday','Monday','Tuesday','Wednesday','Thursday','Frida
+y','Saturday');
    @months = ('January','February','March','April','May','June','July
+','August','September','October','November','December');

    ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(
+time);
    if ($hour < 10) { $hour = "0$hour"; }
    if ($min < 10) { $min = "0$min"; }
    if ($sec < 10) { $sec = "0$sec"; }

    $year += 1900;

    if($FORM{'date_format'}) {
        $date = $FORM{'date_format'};
        my($m_adj) = $mon + 1;
        if($m_adj < 10) { $m_adj = "0$m_adj"; }
        my($d_adj) = $mday;
        if($d_adj < 10) { $d_adj = "0$d_adj"; }
        $date =~ s/([yY]{4}?)/$year/eg;
        $date =~ s/([mM]{2}?)/$m_adj/eg;
        $date =~ s/([dD]{2}?)/$d_adj/eg;
        $date .= ", $hour\:$min\:$sec";
    } else {
        $date = "$days[$wday], $months[$mon] $mday, $year, $hour\:$min
+\:$sec";
    }
}

sub send_email {

    if($FORM{'recipient'} eq "") {
        print "Content-type: text/html\n\n";

        print "<html";
        if ($CONFIG{'html_lang'}) {
            print " lang=\"$CONFIG{'html_lang'}\"";
        }
        if ($CONFIG{'html_dir'}) {
            print " dir=\"$CONFIG{'html_dir'}\"";
        }
        print ">\n";
        print "<head>\n";
        if ($CONFIG{'http_charset'}) {
            print "<meta http-equiv=\"Content-Type\" content=\"text/ht
+ml; charset=$CONFIG{'http_charset'}\">\n";
        }
        print "</head>\n";

        print "<body";
        &body_attributes;
        print ">\n";
        # Original line
        # print "<center><img src=\"" . $external_prefix . "lockssl-on
+.gif\"></center><br>\n";
        # Modification date : 03/07/09 05:58
        print "<center><img src=\"http://www.3d3.com/encrypt/lockssl-o
+n.gif\"></center><br>\n";
        print "<br><br><br><br><center>\n";
        print "<font size=\"+2\">$FORM{'ln_email_required'}</font><br>
+<br>\n";
        print "</center>";
        print "</body>\n</html>";
        die;
    }

    $FORM{'order_email'} =~ s/\\n/\r\n/g;
    $FORM{'order_email'} =~ s/%%/"/g;
    $FORM{'order_email'} =~ s/##.*##/$date/g;
    $FORM{'order_email'} =~ s/<space>/&nbsp;/g;
    $to = "$FORM{'recipient'}";
    if($FORM{'email_from_field'} eq ("OFF")) {
        $from = "$FORM{'recipient'}";
    }
    else {
        $from = "$FORM{'customer_email'}";
    }            
    # Original line :
    # $subject = "$FORM{'ln_orderfrom'} $FORM{'shopname'}";
    # Modification date : 03/07/09 04:48
    $subject = "$FORM{'ln_orderfrom'}";
    $body = "\r\n";
    $body .= qq/$FORM{'order_email'}\r\n/;
    if($FORM{'email_format'} eq ("text")) {
        $body .= "\r\n------ $FORM{'ln_payment_method'} -----\r\n";
        $body .= "$FORM{'paysys'}\r\n";
        $pay ="";
        while (($key,$value) = each %FORM) {
            if ($key =~ "field_") {
                ($temp = $key) =~ s/field_//g;
                $body .= "$temp: $value\r\n";
                $pay .= "$temp=$value|";
            }
        }
        $body .= "\r\nBrowser: $ENV{'HTTP_USER_AGENT'}\r\n";
        $body .= "Remote Host: $ENV{'REMOTE_HOST'}\r\n";
        $body .= "Remote Address: $ENV{'REMOTE_ADDR'}\r\n";
    }
    else {
        $pay ="";
        $payhtml="";
        while (($key,$value) = each %FORM) {
            if ($key =~ "field_") {
                ($temp = $key) =~ s/field_//g;
                $payhtml .= "<tr valign=\"top\"><td><b>$temp:</b></td>
+";
                $payhtml .= "<td>$value</td></tr>";
                $pay .= "$temp=$value|";
            }
        }        
    }
    if($FORM{'override'}) {
        $body_override = "\r\n";
        $body_override .= qq/$FORM{'override_content'}\r\n/;
        $body_override .= "\r\n------ $FORM{'ln_payment_method'} -----
+\r\n";
        $body_override .= "$FORM{'paysys'}\r\n";
        while (($key,$value) = each %FORM) {
            if ($key =~ "field_") {
                ($temp = $key) =~ s/field_//g;
                $body_override .= "$temp: $value\r\n";
            }
        }
        $body_override .= "\r\nBrowser: $ENV{'HTTP_USER_AGENT'}\r\n";
        $body_override .= "Remote Host: $ENV{'REMOTE_HOST'}\r\n";
        $body_override .= "Remote Address: $ENV{'REMOTE_ADDR'}\r\n";
    }
    $date =~ s/,/-/g;
    
    $bodytemp = $body;
    $body =~ s/paysys/$payhtml/g;
    $FORM{account} =~ s/field1/$date/g;
    $FORM{account} =~ s/paysys/$pay/g;
    $FORM{account2} =~ s/field1/$date/g;
    
    if (!&sendmail($to, $from, $subject, $body, $FORM{account},$FORM{a
+ccount2}, 1)) {    # 1 = encrypt if PGP key supplied
        return;
    }
    $body = $bodytemp;
    $body =~ s/paysys//g;
    # check for @ symbol before sending email
    if ($FORM{'dont_email_customer'} ne "true") {
        if ($FORM{'customer_email'} =~ "\@") {
            $to = "$FORM{'customer_email'}";
            $from = "$FORM{'recipient'}";
            # Original line :
            # $subject = "$FORM{'ln_confirm'} $FORM{'shopname'}";
            # Modification date : 03/07/09 04:45
            $subject = "$FORM{'ln_confirm'}";
            if ($FORM{'email_format'} eq ("text")) {    
                $body = qq/$FORM{'order_email'}\r\n/;
                $body .= "$FORM{'contact_details'}\r\n";
                $body .= "\r\nBrowser: $ENV{'HTTP_USER_AGENT'}\r\n";
                $body .= "Remote Host: $ENV{'REMOTE_HOST'}\r\n";
                $body .= "Remote Address: $ENV{'REMOTE_ADDR'}\r\n";
            }
            &sendmail($to, $from, $subject, $body);
        }
    }

}

sub print_html {
    print "Content-type: text/html\n\n";

    print "<html";
    if ($CONFIG{'html_lang'}) {
        print " lang=\"$CONFIG{'html_lang'}\"";
    }
    if ($CONFIG{'html_dir'}) {
        print " dir=\"$CONFIG{'html_dir'}\"";
    }
    print ">\n";
    print "<head>\n";
    if ($CONFIG{'http_charset'}) {
        print "<meta http-equiv=\"Content-Type\" content=\"text/html; 
+charset=$CONFIG{'http_charset'}\">\n";
    }
    print "<meta http-equiv=\"refresh\" content=\"3;url=$FORM{'thankyo
+u_url'}\">\n";
    print "</head>\n";
    print "<body";
    &body_attributes;
    print ">\n";
    # Original line
    # print "<center><img src=\"" . $external_prefix . "lockssl-on.gif
+\"></center><br>\n";
    # Modification date : 03/07/09 06:00
    print "<center><img src=\"http://www.3d3.com/encrypt/lockssl-on.gi
+f\"></center><br>\n";
    print "<br><br><br><br><center>\n";
    print "<font size=\"+2\">$FORM{'ln_secure_final'}.</font><br><br>\
+n";
    print "<font size=\"-1\"><a href=\"$FORM{'thankyou_url'}\">$FORM{'
+ln_next'}</a></font>\n";
    print "</center>";
    print "</body>\n</html>";
}

sub redirect {
    print "Location: $FORM{'thankyou_url'}\n\n";
}

sub check_referer {
    if ($ENV{'HTTP_REFERER'}) {
        foreach $referer (@referers) {
            if ($ENV{'HTTP_REFERER'} =~ /$referer/i) {
                $referer_ok = '1';
                last;
            }
        }
    } else {
        $referer_ok = '1';
    }

    if ($referer_ok != 1) {
        &error('bad_referer');
    }
}

sub check_required {
    foreach $require (@required) {
        if ($require eq 'bgcolor' ||
            $require eq 'background' ||
            $require eq 'text_color' ||
            $require eq 'link_color' ||
            $require eq 'alink_color' ||
            $require eq 'vlink_color') {
            if (!($CONFIG{$require}) || $CONFIG{$require} eq ' ') {
                push(@ERROR, $require);
            }
        } elsif (!($FORM{$require}) || $FORM{$require} eq ' ') {
            push(@ERROR, $require);
        }
    }
    if (@ERROR) {
        &error('missing_fields', @ERROR);
    }
}

sub parse_form {

    if ($ENV{'REQUEST_METHOD'} =~ 'GET') {
        @pairs = split(/&/, $ENV{'QUERY_STRING'});        # Split the 
+name-value pairs
    } elsif ($ENV{'REQUEST_METHOD'} =~ 'POST') {
        read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});    # Get the inp
+ut
        @pairs = split(/&/, $buffer);                    # Split the n
+ame-value pairs
    } else {
        &error('request_method');
    }

    foreach $pair (@pairs) {
        ($name, $value) = split(/=/, $pair);            # Split pair i
+nto name and value

        $name =~ tr/+/ /;                                # un-URL-enco
+de the name
        $name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
        $value =~ tr/+/ /;                                # un-URL-enc
+ode the value
        $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;

        $value =~ s/<!--(.|\n)*-->//g;                    # remove pos
+sible SSI directives from value

        if ($name eq 'mail_encoding' ||
            $name eq 'http_charset' ||
            $name eq 'mail_charset' ||
            $name eq 'html_lang' ||
            $name eq 'html_dir' ||
            $name eq 'bgcolor' ||
            $name eq 'background' ||
            $name eq 'text_color' ||
            $name eq 'link_color' ||
            $name eq 'alink_color' ||
            $name eq 'vlink_color' && ($value)) {
            $CONFIG{$name} = $value;
        } else {
            if ($FORM{$name} && ($value)) {
                $FORM{$name} = "$FORM{$name}, $value";
            } elsif ($value) {
                $FORM{$name} = $value;
            }
        }
    }
    # defaults
    if(!$FORM{'ln_badreferer'}) { $FORM{'ln_badreferer'} = 'Bad Referr
+er - Access Denied'; }
    if(!$FORM{'ln_badreferer_desc'}) { $FORM{'ln_badreferer_desc'} = '
+The URL of the form that is trying to use this CGI application is not
+ in the list of valid referrers.'; }
    if(!$FORM{'ln_error_missing'}) { $FORM{'ln_error_missing'} = 'Miss
+ing Fields'; }
    if(!$FORM{'ln_error'}) { $FORM{'ln_error'} = 'Error'; }
    if(!$FORM{'ln_orderfrom'}) { $FORM{'ln_orderfrom'} = 'Order from';
+ }
    if(!$FORM{'ln_submitted'}) { $FORM{'ln_submitted'} = 'Submitted by
+'; }
    if(!$FORM{'ln_email'}) { $FORM{'ln_email'} = 'email'; }
    if(!$FORM{'ln_date'}) { $FORM{'ln_date'} = 'date'; }
    # Original line :
    # if(!$FORM{'ln_confirm'}) { $FORM{'ln_confirm'} = 'Order confirma
+tion from'; }
    # Modification date : 03/07/09 04:52
    if(!$FORM{'ln_confirm'}) { $FORM{'ln_confirm'} = 'Confirmation de 
+commande sur biomidi.fr - BIOMIDI'; }
    if(!$FORM{'ln_pgp_failed'}) { $FORM{'ln_pgp_failed'} = 'PGP Encryp
+tion Failed.  Check your User ID.'; }
    if(!$FORM{'ln_userid_sub'}) { $FORM{'ln_userid_sub'} = 'The User I
+D submitted was:'; }

    # fix thankyou_url if necessary
    if($FORM{'thankyou_url'} eq 'thankyou.html') { $FORM{'thankyou_url
+'} = $external_prefix . 'thankyou.html'; }

    # set default mail charset
    if(!$CONFIG{'mail_charset'}) { $CONFIG{'mail_charset'} = $CONFIG{'
+http_charset'}; }
}

sub error {
    ($error, @error_fields) = @_;

    print "Content-type: text/html\n\n";
    print "<html";
    if ($CONFIG{'html_lang'}) {
        print " lang=\"$CONFIG{'html_lang'}\"";
    }
    if ($CONFIG{'html_dir'}) {
        print " dir=\"$CONFIG{'html_dir'}\"";
    }
    print ">\n";
    print "<head>\n";
    if ($CONFIG{'http_charset'}) {
        print "<meta http-equiv=\"Content-Type\" content=\"text/html; 
+charset=$CONFIG{'http_charset'}\">\n";
    }
    print "</head>\n";
    print "<body";
    &body_attributes;
    print ">\n";
    print $ENV{'HTTP_REFERER'};
    if ($error eq 'bad_referer') {
        print "<center>\n<h1>$FORM{'ln_badreferer'}</h1>\n</center>\n"
+;
        print "$FORM{'ln_badreferer_desc'}\n";
    } elsif ($error eq 'request_method') {
        print "<center>\n<h1>Invalid Request Method</h1>\n</center>\n"
+;
        print "The Request Method of the submitted form did not match\
+n";
        print "either GET or POST.<p>\n";
    } elsif ($error eq 'missing_fields') {
        print "<center>\n<h1>$FORM{'ln_error_missing'}</h1>\n</center>
+\n";
        print "$FORM{'ln_error_fields'}:<p>\n";
        print "<ul>\n";
        foreach $missing_field (@error_fields) {
            print "<li>$missing_field\n";
        }
        print "</ul>\n";
    } else {
        print "<center>\n<h1>$FORM{'ln_error'}: $error</h1>\n</center>
+\n";
        foreach $field (@error_fields) {
            print "$field<br>";
        }
    }
    print "</body>\n</html>\n";

    exit;
}

sub body_attributes {
    if ($CONFIG{'bgcolor'}) {
        print " bgcolor=\"$CONFIG{'bgcolor'}\"";
    }
    if ($CONFIG{'background'} =~ /http\:\/\/.*\..*/) {
        print " background=\"$CONFIG{'background'}\"";
    }
    if ($CONFIG{'link_color'}) {
        print " link=\"$CONFIG{'link_color'}\"";
    }
    if ($CONFIG{'vlink_color'}) {
        print " vlink=\"$CONFIG{'vlink_color'}\"";
    }
    if ($CONFIG{'alink_color'}) {
        print " alink=\"$CONFIG{'alink_color'}\"";
    }
    if ($CONFIG{'text_color'}) {
        print " text=\"$CONFIG{'text_color'}\"";
    }
}

sub sendmail {
    my($to, $from, $subject, $body, $attach, $attach2, $encrypt) = @_;

    my($encodedbody, $encodedsubject);

    # Here we PGP encrypt the body if applicable

    if($encrypt && $FORM{'pgp_user'}) {
        my($pgp_user) = $FORM{'pgp_user'};
        chomp($pgp_user);
        if($FORM{'override'}) {
            $body = "\r\n".&pgp_encrypt($body_override, $pgp_user);
        } else {
            $body = "\r\n".&pgp_encrypt($body, $pgp_user);
        }
        $attach = &pgp_encrypt($attach, $pgp_user) if defined $attach;
        $attach2 = &pgp_encrypt($attach2, $pgp_user) if defined $attac
+h2;        
    }
    if($CONFIG{'mail_encoding'} && $encrypt && $FORM{'pgp_user'}) {
        if($encrypt && $FORM{'pgp_user'}) {
            if(defined $attach) {
                $encodedbody = "Mime-Version: 1.0\r\n" .
                    "Content-Type: multipart/mixed;\r\n" .
                    qq'  boundary="endofmail"\r\n\r\n' .
                    "This is a multi-part message in MIME format.\r\n"
+ .
                    "--endofmail\r\n" .
                    "Content-Type: text/plain\r\n" .
                    "$body\r\n\r\n" .
                    "--endofmail\r\n" .
                    "Content-Type: application/pgp\r\n" .
                    "Content-Disposition: attachment; filename=\"custo
+mer.txt\"\r\n\r\n$attach\r\n" .
                    "--endofmail\r\n".
                    "Content-Type: application/pgp\r\n" .
                    "Content-Disposition: attachment; filename=\"order
+_details.txt\"\r\n\r\n$attach2\r\n\r\n" .
                    "--endofmail--\r\n";                    
            } else {
                $encodedbody = "Mime-Version: 1.0\r\n\r\n$body";
            }
        } else {
            $encodedbody = &encode($body, $CONFIG{'mail_charset'}, $CO
+NFIG{'mail_encoding'});
        }
        $encodedsubject = &encode_header($subject, $CONFIG{'mail_chars
+et'}, $CONFIG{'mail_encoding'}, 40);
    } else {
        if(defined $attach) {
            $encodedbody = "Mime-Version: 1.0\r\n" .
                "Content-Type: multipart/mixed;\r\n" .
                qq'  boundary="endofmail"\r\n\r\n' .
                "This is a multi-part message in MIME format.\r\n" .
                "--endofmail\r\n" .
                "Content-Type: ".$emailFormat."\r\n" .
                "$body\r\n\r\n" .
                "--endofmail\r\n" .
                "Content-Type: text/plain\r\n" .
                "Content-Disposition: attachment; filename=\"customer.
+txt\"\r\n\r\n$attach\r\n" .
                 "--endofmail\r\n" .    
                "Content-Type: text/plain\r\n" .
                "Content-Disposition: attachment; filename=\"order_det
+ails.txt\"\r\n\r\n$attach2\r\n\r\n" .
                "--endofmail--\r\n";                
        } else {

            $encodedbody = "Mime-Version: 1.0\r\n" .
                "Content-Type: multipart/mixed;\r\n" .
                qq'  boundary="endofmail"\r\n\r\n' .
                "This is a multi-part message in MIME format.\r\n" .
                "--endofmail\r\n" .
                "Content-Type: ".$emailFormat."\r\n" .
                "$body\r\n\r\n" .
        #            "--endofmail\r\n" .
        #        "Content-Type: text/plain\r\n" .
        #        "Content-Disposition: attachment; filename=\"order_de
+tails.txt\"\r\n\r\n$emailFormat\r\n\r\n" .
                "--endofmail--\r\n";                
        #    if ($FORM{'email_format'} eq ("html")) {
        #        $body =~s/<tr>/<tr>&nbsp;/g;
        #    }
        #    $encodedbody= "Content-Type: ".$emailFormat."\r\n".
        #        "\r\n" . $body;
        }
        $encodedsubject = $subject;
    }
    if (lc $mailusing eq 'sendmail') {
        open (MAIL, "|$mailprog -t") || &error("Can't open $mailprog!"
+);
        print MAIL "To: $to\r\n";
        print MAIL "From: $from\r\n";
        print MAIL "Subject: $encodedsubject\r\n";
        print MAIL "$encodedbody\r\n";
        close MAIL;
    } else {
        $err = &sockets_mail($to, $from, $encodedsubject, $encodedbody
+);
        if ($err < 1) {
            &error("SMTP error # $err");
            return 0;
        }
    }
    return 1;
}

sub pgp_encrypt {
    my($in_text, $pgp_user) = @_;
    my($out_text) = '';

    #
    # We are piping the output of pgp to null.  stderr ends up in the 
+web server's error log.
    # We should capture both of these, and display them to the user, i
+f applicable
    #
    if( open(PGP, "|$pgp_cmd -r \"${pgp_user}\" $pgp_opt -o $pgp_tmp >
+ /dev/null") ) {
        print PGP $in_text;
        close(PGP);

        if( open(CRYPTTMP, "<${pgp_tmp}") ) {
            while(<CRYPTTMP>) {
                $out_text .= $_;
            }

            close(CRYPTTMP);
            `rm -f ${pgp_tmp}`;
        } else {
            #
            # If we get to here, it means $pgp_tmp could not be opened
+ for reading.
            # This will usually be because pgp did not create an outpu
+t file, which
            # is probably because pgp was given a non-existent user id
+.
            #
            # We send the email anyway, with a warning at the top.
            #
            $out_text  = "$FORM{'ln_pgp_failed'}\r\n";
            $out_text .= "$FORM{'ln_userid_sub'}\r\n";
            $out_text .= "$pgp_user\r\n\r\n";
            $out_text .= $in_text
        }

    } else {
        #
        # If we get to here, it means we couldn't fork $pgp_cmd.  Chec
+k the path to
        # pgp defined at the top of this file.  Also check the web ser
+ver error log.
        &error("Can't run PGP");
    }

    return($out_text);
}

sub sockets_mail {
    my ($to, $from, $subject, $message) = @_;
    my ($replyaddr) = $from;
    if (!$to) { return -8; }
    my ($proto, $port, $smptaddr);
    my ($AF_INET)     =  2;
    my ($SOCK_STREAM) =  1;
    $proto = (getprotobyname('tcp'))[2];
    $port  = 25;
    $smtpaddr = ($smtp_addr =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{
+1,3})$/)
                    ? pack('C4',$1,$2,$3,$4)
                    : (gethostbyname($smtp_addr))[4];
    if (!defined($smtpaddr)) { return -1; }
    if (!socket(S, $AF_INET, $SOCK_STREAM, $proto))             { retu
+rn -2; }
    if (!connect(S, pack('Sna4x8', $AF_INET, $port, $smtpaddr))) { ret
+urn -3; }
    select(S);
    $| = 1;
    select(STDOUT);
    $_ = <S>; if (/^[45]/) { close S; return -4; }
    print S "helo localhost\r\n";
    $_ = <S>; if (/^[45]/) { close S; return -5; }
    print S "mail from: $from\r\n";
    $_ = <S>; if (/^[45]/) { close S; return -5; }
    print S "rcpt to: $to\r\n";
    $_ = <S>; if (/^[45]/) { close S; return -6; }
    print S "data\r\n";
    $_ = <S>; if (/^[45]/) { close S; return -5; }
    print S "Content-Type: text/plain; charset=us-ascii\r\n";
    print S "To: $to\r\n";
    print S "From: $from\r\n";
    print S "Reply-to: $replyaddr\r\n" if $replyaddr;
    print S "Subject: $subject\r\n";
    print S "$message";
    print S "\r\n.\r\n";
    $_ = <S>; if (/^[45]/) { close S; return -7; }
    print S "quit\r\n";
    $_ = <S>;
    close S;
    return 1;
}

sub encode {
    my($body, $charset, $encoding) = @_;
    my($r);
    if( ($encoding =~ 'Quoted-Printable') || ($encoding =~ 'Base64') )
+ {
        $r  = "MIME-Version: 1.0\r\n";
        $r .= "Content-Type: text/plain; charset=$charset\r\n";
        $r .= "Content-transfer-encoding: $encoding\r\n\r\n";
        if($encoding =~ 'Quoted-Printable') {
            $r .= &encode_qp($body);
        } else {
            $r .= &encode_base64($body,"\n",76);
        }
    } else {
        $r = "\r\n$body";
    }
    return($r);
}

# Encodes a header line as either Base64 or modified Quoted-Prinable
# as per RFC 2047. $maxlen is the maximum length of the encoded part
# of the string.  If the encoded string exceeds this length, the
# remainder will be appended after CRLF SPACE
sub encode_header {
    my($text, $charset, $encoding, $maxlen) = @_;
    my($r) = "";
    my($e, $t);
    if($encoding =~ 'Quoted-Printable') {
        $e = encode_head_qp($text, $maxlen);
        $t = 'Q';
    } elsif ($encoding =~ 'Base64') {
        $e = encode_base64($text, "\n", $maxlen);
        $t = 'B';
    }
    if($e) {
        my(@el) = split(/\n/, $e);

        for $i (0 .. $#el) {
            $r .= "=?$charset?$t?$el[$i]?=";
            if($i != $#el) {
                $r .= "\r\n ";
            }
        }
    } else {
        $r = $text;
    }
    return($r);
}

# stolen from MIME::Base64.pm and modified to include max length
sub encode_base64 ($;$;$) {
    my $res = "";
    my $eol = $_[1];
    $eol = "\n" unless defined $eol;
    my $maxlen = $_[2];
    $maxlen = 76 unless defined $maxlen;
    pos($_[0]) = 0;                          # ensure start at the beg
+inning
    while ($_[0] =~ /(.{1,45})/gs) {
    $res .= substr(pack('u', $1), 1);
    chop($res);
    }
    $res =~ tr|` -_|AA-Za-z0-9+/|;               # `# help emacs
    # fix padding at the end
    my $padding = (3 - length($_[0]) % 3) % 3;
    $res =~ s/.{$padding}$/'=' x $padding/e if $padding;
    # break encoded string into lines of no more than 76 characters ea
+ch
    if (length $eol) {
    $res =~ s/(.{1,$maxlen})/$1$eol/g;
    }
    $res;
}

# stolen from MIME::QuotedPrint.pm
sub encode_qp ($){
    my $res = shift;
    $res =~ s/([^ \t\n!-<>-~])/sprintf("=%02X", ord($1))/eg;  # rule #
+2,#3
    $res =~ s/([ \t]+)$/
      join('', map { sprintf("=%02X", ord($_)) }
           split('', $1)
      )/egm;                        # rule #3 (encode whitespace at eo
+l)

    # rule #5 (lines must be shorter than 76 chars, but we are not all
+owed
    # to break =XX escapes.  This makes things complicated :-( )
    my $brokenlines = "";
    $brokenlines .= "$1=\n"
    while $res =~ s/(.*?^[^\n]{73} (?:
         [^=\n]{2} (?! [^=\n]{0,1} $) # 75 not followed by .?\n
        |[^=\n]    (?! [^=\n]{0,2} $) # 74 not followed by .?.?\n
        |          (?! [^=\n]{0,3} $) # 73 not followed by .?.?.?\n
        ))//xsm;

    "$brokenlines$res";
}

# modified encode_qp for doing headers.  Includes max length
sub encode_head_qp ($;$){
    my $res = $_[0];
    my $maxlen = $_[1];
    $res =~ s/([^A-Za-z0-9!*+\-\/=_])/sprintf("=%02X", ord($1))/eg;
    $res =~ s/([ \t]+)$/
      join('', map { sprintf("=%02X", ord($_)) }
           split('', $1)
      )/egm;

    my $brokenlines = "";
    $maxlen -= 3;
    $brokenlines .= "$1\n"
    while $res =~ s/(.*?^[^\n]{$maxlen} (?:
         [^=\n]{2} (?! [^=\n]{0,1} $)
        |[^=\n]    (?! [^=\n]{0,2} $)
        |          (?! [^=\n]{0,3} $)
        ))//xsm;

    "$brokenlines$res";
}

[download]

20101118 Janitored by Corion: Added formatting, code tags, as per Writeup Formatting Tips

Replies are listed 'Best First'.
Re: I should need about a cgi script
by Corion (Patriarch) on Nov 18, 2010 at 09:51 UTC

    You should not use this script. It allows to easily forge mails sent from your domain, for example by sending data with newlines in $FORM{'recipient'}.

    Please use CGI to read and decode your form data and use MIME::Lite to send the mail. If you want to keep <c>pgp

    in the pipeline, you can create the mail body using MIME::Lite and then pipe that through pgp.

[reply]
[d/l]
Re: I should need about a cgi script
by marto (Cardinal) on Nov 18, 2010 at 10:10 UTC
[reply]
Re: I should need about a cgi script
by roboticus (Chancellor) on Nov 18, 2010 at 12:39 UTC

    patrmich:

    A couple random notes:

    • You state that that one of your problems is that "there is no carriage return in the html code of the generated e-mail." In HTML, you don't need carriage returns, so you'll have to describe your problem a bit better. Perhaps you need some better HTML code in your letter body? Or maybe you can't see the EMails properly when you look at them in Notepad.exe? Or is the problem something else?
    • Some of your strings are a bit harder to read than necessary because you're having to escape quotes. You can use the qq operator to clean those up a bit, so you can turn this:
      print "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=$CONFIG{'http_charset'}\">\n";
      into this:
      print qq(<meta http-equiv="Content-Type" content="text/html; charset=$CONFIG{'http_charset'}">\n);
    • You should get into the habit of putting
      use strict;
use warnings;

      [download]
      in the beginning of your code to warn you of problems. I'm not saying it would help in this case, but whenever working on someone's program, it's the first step for me. Often, cleaning up the code that causes error messages is enough to fix the program.
    • You should use indentation more consistently. It'll help you visualize the overall structure of your program better, and make it simpler to pinpoint the chunk of code you're looking for.

    ...roboticus

[reply]
[d/l]
[select]
Re: I should need about a cgi script
by locked_user sundialsvc4 (Abbot) on Nov 18, 2010 at 14:20 UTC

    (Please put large blocks of code in optional code-tags... see “Markup in the Monastery.”)

    Easily the best way to handle a complex formatting-task like this one is to use a system such as Template::Toolkit.   The code that you have now, even (though|if) it actually works, would be extremely hard to maintain.   In addition, it is certainly going to be something that The Marketing Department™ will want to change fairly constantly!   Trust me, that is not a place where you want to be.

    By moving the presentation details out to a template ... which by the way is very fast ... you achieve “separation of concerns.” The Perl code becomes responsible for preparing the data, while the Template is responsible for presentation.   Since the templating is accomplished using very clever Perl-coding tricks voodoo, it is very efficient indeed.

Re: I should need about a cgi script
by Anonymous Monk on Nov 18, 2010 at 09:41 UTC
    Gesundheit
[reply]

Back to Seekers of Perl Wisdom