SV (2003-10-14)
Response on request from LV on news:comp.lang.tcl
tested with 8.4.4 on windows 98
## made from example on ASPN by Jeff Hobbs and some code from
## nstcl (AOLserver/OpenNSD-style routines for tclsh)
## Copyright (c) 2000, 2001, 2002 Michael A. Cleverly
##
## Sinisa Vujic, Datagram d.o.o., 2003
## script which sends self as attachment
##
## 8.4.3 with trf2.1p1 has problems when location
## of Trf package isn't explicitly stated like this
## set ::env(PATH) $::env(PATH)\;H:/tcl/lib/trf
## because Trf can't find crypt.dll
package require smtp
namespace eval dg_mail {
namespace export sendmail
variable mailhost 127.0.0.1
variable mailport 25
}
proc dg_mail::sendmail {to from subject body {headers ""} {bcc ""}
{opt_attcs_type ""} {attcs_array_name ""}} {
if {[string length $opt_attcs_type]} {
if {$opt_attcs_type != "-file" && $opt_attcs_type != "-string"} {
error "unknown option $opt_attcs_type"
}
if {![string length $attcs_array_name]} {
error "unknown value for option $opt_attcs_type"
}
upvar 0 $attcs_array_name attcs_array
set parts [::mime::initialize -canonical text/plain -string $body]
foreach {attc_name attc_options} [array get attcs_array] {
set part [eval ::mime::initialize $attc_options]
lappend parts $part
}
set messageT [::mime::initialize -canonical multipart/mixed -parts $parts]
} else {
set messageT [::mime::initialize -canonical text/plain -string $body]
}
variable mailhost
variable mailport
set command [list ::smtp::sendmessage $messageT -servers $mailhost -ports $mailport]
lappend command -header [list From $from]
lappend command -header [list To $to]
lappend command -header [list Subject $subject]
if {[string length $bcc]} {
lappend command -header [list Bcc $bcc]
}
if {[string length $headers]} {
foreach {key value} $headers {
lappend command -header [list $key $value]
}
}
set err [catch { eval $command } result]
::mime::finalize $messageT -subordinates all
if {$err} {error $result}
}
array set attcs_options {}
set attcs [file join [pwd] [info script]]
foreach attc $attcs {
## charset is optional
set opts [list -canonical "text/plain; charset=\"[file tail $attc]\""]
lappend opts -encoding quoted-printable
lappend opts -header {Content-Disposition attachment}
lappend opts -file $attc
set attcs_options($attc) $opts
}
dg_mail::sendmail [email protected] [email protected] {Tcl smtp!} Hello! "" "" \
-file [namespace current]::attcs_options
snichols I tested this script, and everything worked except for the file attachment part. FYI ... I did get the attachment add to work, but changed the last argument to a filename not Tcl array, and changed the following code in the main email proc above:
if {[string length $opt_attcs_type]} {
log "Type: $opt_attcs_type"
log "Processing: $file"
set parts [mime::initialize -canonical text/plain -string $body]
set imageT [mime::initialize -canonical "image/tif; name=\"[file tail $file]\"" -file $file]
lappend parts $imageT
set messageT [::mime::initialize -canonical multipart/mixed -parts $parts]
} else {
set messageT [::mime::initialize -canonical text/plain -string $body]
}Basically, I was can get away with this because I am onlly adding one attachment and it will always be of the type tif