## ********************************************************
##
## Name: smtp.tcl version 1.0
##
## Description:
## Simple Tcl SMTP client.
##
## Parameters:
##
## Usage:
##
## mailTo $rcpt(s) $subject $msg $attachment_filename(s)
##
## Comments:
##
## ********************************************************
package provide smtp 1.0
namespace eval smtp {}
## fully qualified name of mail relay, if needed
set ::MAIL_RELAY_FQDN localhost
## we have our own client, but sendmail in client
## mode is much better! Set to 0 to use marginally
## acceptable built in client code.
set ::USE_SENDMAIL_AS_MTA 1
## ********************************************************
##
## Name: mailTo
##
## Description:
## Non-exec'ing version of mailTo from genericAPI.tcl
##
## Parameters:
##
## Usage:
##
## Comments:
##
proc mailTo { { to "" } { subject "" } { body "" } { attach "" } } {
if { [ string equal $to $subject ] } {
return -code error "mailTo: missing required arguments"
}
set mailhost $::MAIL_RELAY_FQDN
set user $::env(USER)
set domain \
[ join [ lrange [ split $mailhost . ] 1 end ] . ]
if { ! [ string length $domain ] } {
set domain localhost
}
set from $user@$domain
if { [ catch {
;## since sendmail now supports the crappy greet_pause
;## option, slamming is no longer reliable, so we
;## should be configured to use sendmail directly.
;## note that greet_pause was INTENDED TO BE DISABLED
;## for LOCAL TRAFFIC.
if { [ info exists ::USE_SENDMAIL_AS_MTA ] && \
[ string equal 1 $::USE_SENDMAIL_AS_MTA ] } {
smtp::sendMail $mailhost $from $to $subject $body $attach
} else {
smtp::send $mailhost $from $to $subject $body $attach
}
} err ] } {
return -code error "[ myName ]: $err"
}
return {}
}
## ********************************************************
## ********************************************************
##
## Name: smtp::send
##
## Description:
## Send mail via Tcl. Note the 'HELO localhost' call,
## which seems to satisfy far more mail relays than it
## ever should!
##
## Parameters:
##
## Usage:
##
## Comments:
##
proc smtp::send { mailhost from to subject text { attachments "" } } {
if { [ catch {
set seqpt {}
set from [ smtp::validate $from ]
set to [ smtp::validate $to ]
set seqpt "socket($mailhost,25):"
set sid [ socket $mailhost 25 ]
set seqpt {}
set from_rx {^\{?\"?([^\"]+)\"?\s+<([^>]+)>\}?$}
if { [ regexp $from_rx $from -> name address ] } {
set from "\"$name\" <$address>"
} else {
set from [ string trim $from >< ]
set from "<$from>"
}
set date \
[ clock format [ clock seconds ] \
-format "%a, %e %b %Y %H:%M:%S %Z" ]
set id <[ clock seconds ].[ clock clicks ]@localhost>
fconfigure $sid -buffering line
fileevent $sid readable [ list smtp::handle gets $sid ]
smtp::handle puts $sid "HELO localhost"
set bare [ string trim [ lindex $from end ] >< ]
smtp::handle puts $sid "MAIL From:<$bare>"
foreach recipient $to {
set recipient [ lindex $recipient end ]
regsub -all {[<>]} $recipient {} recipient
if { [ regexp {\S+@\S+} $recipient ] && \
! [ regexp {\s+} $recipient ] } {
smtp::handle puts $sid "RCPT To:<$recipient>"
}
}
smtp::handle puts $sid DATA
smtp::handle puts $sid "From: $from"
smtp::handle puts $sid "To: [ join $to , ]"
smtp::handle puts $sid "Subject: $subject"
smtp::handle puts $sid "Date: $date"
smtp::handle puts $sid "Message-Id: $id"
set text [ smtp::multipart $text $attachments ]
foreach line [ split $text "\n" ] {
smtp::handle puts $sid $line
}
smtp::handle puts $sid ".\nQUIT"
::close $sid
} err ] } {
catch { ::close $sid }
return -code error "[ myName ]:$seqpt $err"
}
}
## ********************************************************
## ********************************************************
##
## Name: smtp::sendMail
##
## Description:
## Send mail via Tcl. Note the 'HELO localhost' call,
## which seems to satisfy far more mail relays than it
## ever should!
##
## Parameters:
##
## Usage:
##
## Comments:
##
proc smtp::sendMail { mailhost from to subject text { attachments "" } } {
if { [ catch {
set seqpt {}
set from [ smtp::validate $from ]
set to [ smtp::validate $to ]
set from_rx {^\{?\"?([^\"]+)\"?\s+<([^>]+)>\}?$}
if { [ regexp $from_rx $from -> name address ] } {
set from "\"$name\" <$address>"
} else {
set from [ string trim $from >< ]
set from "<$from>"
}
set msg "From: $from\n"
append msg "To: [ join $to , ]\n"
append msg "Subject: $subject\n"
set text [ smtp::multipart $text $attachments ]
append msg $text
smtp::useSendmail $msg
} err ] } {
catch { ::close $sid }
return -code error "[ myName ]:$seqpt $err"
}
}
## ********************************************************
## ********************************************************
##
## Name: smtp::useSendmail
##
## Description:
##
## Parameters:
##
## Usage:
##
## Comments:
##
proc smtp::useSendmail { mail } {
if { [ catch {
;## if this resource variable is defined, use it!
if { [ info exists ::PATH_TO_SENDMAIL ] } {
set sendmail $::PATH_TO_SENDMAIL
} else {
set sendmail /usr/lib/sendmail
}
set pipe [ open "|$sendmail -oi -t" a+ ]
fconfigure $pipe -blocking off
fconfigure $pipe -buffering line
puts $pipe $mail
::close $pipe
} err ] } {
catch { ::close $pipe }
return -code error "[ myName ]: $err"
}
}
## ********************************************************
## ********************************************************
##
## Name: smtp::validate
##
## Description:
## Validate email addresses. Only assumes that multiple
## addresses are separated by commas.
##
## Parameters:
##
## Usage:
##
## Comments:
##
proc smtp::validate { to } {
set rcpts [ list ]
set to [ string trim $to ]
set to [ split $to , ]
regsub -all {\s+} $to { } to
foreach rcpt $to {
set rcpt [ string trimright $rcpt " >" ]
set rcpt [ lindex $rcpt end ]
regsub -all {[<>]} $rcpt {} rcpt
set rcpt [ string trim $rcpt ]
if { ! [ regexp {^\S+@\S+$} $rcpt ] } {
return -code error "invalid address: '$rcpt'"
}
lappend rcpts $rcpt
}
return $rcpts
}
## ********************************************************
## ********************************************************
##
## Name: smtp::expand
##
## Description:
## If the text submitted was a filename, read the file
## and ship it off.
##
## Parameters:
##
## Usage:
##
## Comments:
##
proc smtp::expand { text } {
if { [ catch {
if { [ file exists $text ] && \
[ file readable $text ] } {
set fid [ open $text r ]
set text [ read $fid [ file size $text ] ]
::close $fid
}
append text [ smtp::sig ]
} err ] } {
catch { ::close $fid }
return -code error $err
}
return $text
}
## ********************************************************
## ********************************************************
##
## Name: smtp::sig
##
## Description:
## Signature file handling, if there is a signature file.
##
## Parameters:
##
## Usage:
##
## Comments:
##
proc smtp::sig { { fname .signature } } {
set signature [ list ]
if { [ file exists $fname ] && \
[ file readable $fname ] } {
set fid [ open $fname r ]
set signature \
[ read $fid [ file size $fname ] ]
::close $fid
set signature "\n\n--\n$signature"
}
return $signature
}
## ********************************************************
## ********************************************************
##
## Name: smtp::handle
##
## Description:
## send/receive callback
##
## Parameters:
##
## Usage:
##
## Comments:
##
proc smtp::handle { action sid { line "" } } {
if { [ catch {
fconfigure $sid -blocking off
$action $sid $line
fconfigure $sid -blocking on
} err ] } {
# nothing to be done, socket has gone
}
}
## ********************************************************
## ********************************************************
##
## Name: smtp::dump
##
## Description:
## Very expensive to run!!
##
## Parameters:
##
## Usage:
##
## Comments:
##
proc smtp::dump { attachment } {
if { [ catch {
set rname [ file tail $attachment ]
set data [ exec uuencode $attachment $rname ]
} err ] } {
return -code error "[ myName ]: $err"
}
return $data
}
## ********************************************************
## ********************************************************
##
## Name: smtp::multipart
##
## Description:
## RFC #822 and MIME
## Parameters:
##
## Usage:
##
## Comments:
##
proc smtp::multipart { text { attachments "" } } {
if { [ catch {
set attachments [ split $attachments , ]
set boundary TCL_SMTP_attachment_SMTP_TCL
set text [ smtp::expand $text ]
if { [ string length $attachments ] } {
set msg "MIME-Version: 1.0\n"
append msg "Content-Type: multipart/mixed;\n"
append msg " boundary=\"$boundary\"\n\n"
append msg "--$boundary\n"
append msg "Content-Type: text/plain; charset=US-ASCII\n\n"
append msg "$text\n"
foreach attachment $attachments {
set attachment [ string trim $attachment ]
if { ! [ file readable $attachment ] } {
set err "attachment not found: '$attachment'"
return -code error $err
}
append msg "--$boundary\n"
append msg "Content-Type: application/octet-stream\n"
append msg "Content-Transfer-Encoding: x-uuencode\n"
append msg "Content-Disposition: attachment;\n"
append msg " filename=\"[ file tail $attachment ]\"\n\n"
append msg [ smtp::dump $attachment ]
}
append msg "\n\n--${boundary}--\n\n"
} else {
set msg "\n$text"
}
} err ] } {
return -code error "[ myName ]: $err"
}
return $msg
}
## ********************************************************
![[Home]](/images/jpeg/slugwiki.jpg)