发信人: vcc()
整理人: wenbobo(2002-12-27 15:54:18), 站内信件
|
【 在 love1974 (<marquee>令狐冲</) 的大作中提到: 】
好久不见你了，怎么你的主页去不了？
你可以去codeguru.com找，我记得有。
对了，我贴个tcl/tk写的，我想应该很简单吧，可是用脚本语言实现的。我想c
应该不会比他更复杂吧，何况tcl/tk可以很容易集成到c程序中。
#! /usr/bin/tclsh8.0
#set DEBUG(Mail) 0
#@ Scans for Options. opvar is a array with possible options. I
t may contain defaults.
#@ Takes options from args lists
proc bs_ScanOpts1 {optsvar} {
#puts "Got var: $optsvar"
#set arglist [split [string trim $args {\{\} }]]
#set args [list $args]
upvar args args
if {[llength $args]==1} {eval set args $args}
#puts "Got args: $args [lindex $args 3]"
set i 0; set count 0
while { $i < [llength $args]} {
set token [lindex $args $i]
#puts "Scan: $token"
if {[string index $token 0] == "-"} {
set argname [string range $token 1 end]
incr i
set argval [lindex $args $i]
uplevel set ${optsvar}($argname) \"$argval\"
#puts "set ${optsvar}($argname) to \"$argval\""
incr i
incr count;
continue
}
break
# no more args!
}
set body [lrange $args $i end]
if {[llength $body] > 1 } {
set body [list $body]
}
#uplevel set ${optsvar}(body) \"[eval set x [lrange $args $i end]]
\"
uplevel set ${optsvar}(body) \"[eval set x $body]\"
# tell me if you understand this...
return $count
}
#@ Debug output if context matches
proc bs_Debug {context txt} {
global DEBUG
if {$DEBUG(Mail) || $DEBUG(All)} {
puts "HF Debug ($context): $txt"
}
}
#@ Private. Build full address.
proc bs_GetAdr { fulladr } {
return "<[lindex $fulladr 1]>"
}
#@ Private. Returns first part.
proc bs_GetName { fulladr } {
return "[lindex $fulladr 0]"
}
#@ Private. Builds a full address.
proc bs_GetFullAdr { fulladr } {
return "[lindex $fulladr 0] <[lindex $fulladr 1]>"
}
#@ Send Mail to a SendMail deamon.<br>
#@ examples<pre>
#@ set fr {{Bob Schulze} {[email protected]}}
#@ set k {{Katrin S} {[email protected]}}
#@ set h {Hans [email protected]}
#@ tSMTPmail -debug 1 -from $fr -toList [list $k $h] fdf
#@
#@ tSMTPmaill -debug 1 -from $fr -toList {{{Bob Schulze} {[email protected]
}}} \
#@ -Subject "Test tSMTPMail" \
#@ -Reply-To [email protected] "This is a test of
#@ some mail"
#@
#@ set fr [list "tSMTPmail Tester"]
#@ set to {{Bob {[email protected]}}}
#@ tSMTPmail -debug 1 -from $fr -toList $to -Subject "tSMTPmail Test"
{
#@ ----------------------------------------------------
#@ I'am Testing tSMTPmail. Please tell me if it worked!
#@ ----------------------------------------------------}
#@
#@ Note how the (one element) list is build. Using list is probably mo
st straighforeward.
#@ </pre>
#@ note: You may use any allowed header as command line arg, su
ch as Reply-To etc. But thestring must conform exactly to the standard
, means not reply-TO etc. There is not explicit check for this.<br>
#@ Addresses are in form {{Bob Schulze} {<[email protected]>}<br>
#@ note: The name-address Syntax is fitting to most sendmail se
tups, in strange cases it might fail. You'll have to dig into the code
then.<br>
#@ option -smtphost Optional. Uses localhost otherwise. IP Addr
. or name.<br>
#@ option -authuser HELO Connection user. Sometimes rebuild as
"Sender".<br>
#@ option -toList,ccList,bccList Lists of Names/Addresses. See
Examples.<br>
#@ option -port Sendmail port<br>
#@ option -debug 1|0 overrides global DEBUG(Mail) (if exists).
1 Means verbose debug output on.<br>
#@ option -Timeout Defaults to 5 Seconds. This is sendmails all
owed response delay. An Error will be thrown otherwise.<br>
#@ option -blocking 0|1 On windows systems the fblocking call i
s not working well; you may disable the timeout check by setting this
to 1. Default is 0.<br>
#@ returns -1 on Error , Total Response time if all goes ok.<br
>
#@ error Throws tcl errors if something goes wrong (Unexpected
replies from sendmail or Timeout).<br>
#@ <br><br>
#@ How to Test: Check if the first line of this file points to
tclsh8.0, make it executable and start it. A dialog with sendmail will
appear. The code for this test is at the end of the file. Remove it i
f you start using it for production!1
proc tSMTPmail args {
# handles a complete smtp transaction
proc bs_TalkToSm { what should } {
upvar sock sock
upvar op op
upvar rtime rtime
upvar tout tout
puts $sock $what
flush $sock
bs_Debug Mail "Send: <$what>"
if {$should != 0} {
if [catch {
bs_CheckMailResponse $should
} e_info] {
error "Response Err When sending -- $what -- : $e_info"
}
}
}
# looks for returns within timeout. fblocking might show up strang
e
# on some platforms...
proc bs_CheckMailResponse should {
upvar op op
upvar sock sock
upvar rtime rtime
upvar tout tout
set res ""
set ttime 0
while 1 {
set ttt [time {set res [gets $sock]}]
if { $res != "" } break
incr ttime 100
after 100
if {$ttime > $tout } {
error "tSMTPmail: Err When Sending: Exceeded Timeout of $op(Timeout)
Sec."
break
}
}
incr rtime [expr [lindex $ttt 0]/1000 + $ttime]
bs_Debug Mail "Response: <$res>"
#bs_Debug Mail "Response time: $rtime ms"
if { [lindex $res 0] != $should } {
bs_Debug Mail "Wrong Response: Should be $should, is [lindex $res
0]"
error "Wrong Response: Should be $should, is [lindex $res 0]\n"
return 1
}
return 0
}
#
# Main Procedure.
#
if [catch {
global DEBUG
set rtime 0
# read options
set op(smtphost) 127.0.0.1
set op(authuser) tSMTPmail
set op(from) tSMTPmail
set op(toList) ""
set op(debug) -1
set op(ccList) ""
set op(bccList) ""
set op(port) 25
set op(Timeout) 5
set op(blocking) 0
bs_ScanOpts1 op
set tout [expr $op(Timeout) * 1000]
#set tout 5000
# handle DEBUGGING, option overrides
if {! [info exists DEBUG(Mail)]} {
set DEBUG(Mail) 0
}
if {! [info exists DEBUG(All)]} {
set DEBUG(All) 0
}
set olddebug $DEBUG(Mail)
if {$op(debug) != -1} {
set DEBUG(Mail) $op(debug)
}
# exclude list for header fields
set donotsend "Timeout smtphost body authuser port debug from toList
ccList bccList blocking"
#
bs_Debug Mail "Read Options:"
#bs_Debug Mail "[parray op]"
#bs_Debug Mail " ---end Options array---"
#
set sock [socket $op(smtphost) $op(port)]
fconfigure $sock -blocking $op(blocking)
bs_Debug Mail "Connected to $op(smtphost):$op(port)"
bs_CheckMailResponse 220
# authenticate..
bs_TalkToSm "HELO $op(authuser)" 250
bs_TalkToSm "MAIL FROM: <[bs_GetName $op(from)]>" 250
# to's
bs_Debug Mail "SMTP To's..."
foreach t $op(toList) {
bs_TalkToSm "RCPT TO: [bs_GetAdr $t]" 250
}
# cc's
bs_Debug Mail "SMPT CC's..."
foreach t $op(ccList) {
bs_TalkToSm "RCPT TO: [bs_GetAdr $t]" 250
}
# bcc's
bs_Debug Mail "SMPT BCC's..."
foreach t $op(bccList) {
bs_TalkToSm "RCPT TO: [bs_GetAdr $t]" 250
}
# data
bs_TalkToSm "DATA" 354
# header
bs_Debug Mail "Writing Header..."
# to's
bs_Debug Mail "Header To's..."
foreach t $op(toList) {
bs_TalkToSm "To: [bs_GetFullAdr $t]" 0
}
# cc's
bs_Debug Mail "Header cc's..."
foreach t $op(ccList) {
bs_TalkToSm "Cc: [bs_GetFullAdr $t]" 0
}
# bcc's NOT
# other fields
foreach f [array name op] {
#puts "$donotsend -- [lsearch -exact $donotsend $f] --"
if {[lsearch -exact $donotsend $f] > -1} {
continue
}
bs_Debug Mail "Header $f"
bs_TalkToSm "$f: $op($f)" 0
}
# text
bs_Debug Mail "Text Body..."
# escape leading .
bs_TalkToSm "$op(body)" 0
# close
bs_TalkToSm "." 250
bs_TalkToSm "QUIT" 221
catch {close $sock}
# restore debug
set DEBUG(Mail) $olddebug
#return 0
} e_info] {
catch {close $sock}
catch {set DEBUG(Mail) $olddebug}
error "tSMTPmail: $e_info"
return -1
}
return [expr $rtime / 1000.0]
}
# Test code. REMOVE after testing! You will get an reply each time you
send mail with it.
if [info exists env(USER)] {
set fr [list $env(USER)]
} else {
set fr [list "tSMTPmail Tester"]
}
set fr {{vcc} {[email protected]}}
set to {{vcc} {[email protected]}}
tSMTPmail -debug 1 -from $fr -toList $to -Subject "tSMTPmail Test" {
----------------------------------------------------
I'am Testing tSMTPmail. Please tell me if it worked!
----------------------------------------------------}
--
※ 来源:．月光软件站 http://www.moon-soft.com．[FROM: 202.103.146.3]
|
|