JMN 2006-03-30 Using the mime package is I guess a correct but somewhat over-inventive way of encoding the username/password for SMTP Authentication.More efficient would be to use the base64 packag from tcllib.
package require base64 set username_encoded [base64::encode $username]
Examples and free-to-use scriptsTOC1 Email Authentication with MIME - uses tcllib's MIME package2 Server Access - server.access.tcl - see the raw data to/from servers such as SMTP, POP, HTTP, FTP, etc. (Latest edit, included a catch for EOF statements from the server. Before this was added, the script would lock up. Written for MS Windows, soon to have a *nix version)
server.access.tcl [1]
#####################################################################
# #
# server.access.tcl v1.0 #
# by: Jeff "Machtyn" Gosnell #
# #
# Purpose: An instruction on how to use sockets, #
# fileevent, regexp, and optimize my style some. #
# It will also show you the exact data coming through #
# the port you are using to access whatever kind of #
# server. Particularly useful for SMTP, POP, FTP. #
# #
# Feel free to use any part of this code. It would be #
# nice of you to give me some credit if you do use it. #
# #
# global variables worth mentioning (ie used in more than 1 proc) #
# sid = socket id (referred to as chId in the I/O procs) #
# lastIp = used to populate the menu with last accessed IP's #
# #
#####################################################################
##########################################
# I/O from the socket #
# #
# The following procedurees are #
# for the formatting of text into the #
# display screen. #
# #
##########################################
proc General {chId} {
if {[eof $chId] || [catch {gets $chId msg}]} {
close $chId
set msg "Connection closed by server"
}
append msg \n
.output.scr insert end $msg hldscolor
.output.scr see end
return $msg
}
proc RdPop {chId} {
if {[eof $chId] || [catch {gets $chId msg}]} {
close $chId
set msg "Connection closed by server"
}
append msg \n
.output.scr insert end $msg popcolor
.output.scr see end
return $msg
}
proc RdSmtp {chId} {
if {[eof $chId] || [catch {gets $chId msg}]} {
close $chId
set msg "Connection closed by server"
}
append msg \n
.output.scr insert end $msg smtpcolor
.output.scr see end
return $msg
}
proc RdFtp {chId} {
if {[eof $chId] || [catch {gets $chId msg}]} {
close $chId
set msg "Connection closed by server"
}
append msg \n
.output.scr insert end $msg ftpcolor
.output.scr see end
return $msg
}
proc RdHLDS {chId} {
if {[eof $chId] || [catch {gets $chId msg}]} {
close $chId
set msg "Connection closed by server"
}
append msg \n
.output.scr insert end $msg hldscolor
.output.scr see end
return $msg
}
proc SdCnl {chId msg} {
# send the command
puts $chId $msg
flush $chId
if {[string tolower $msg] == "quit"} {
close $chId
}
# change the password to display *'s on the display
if [regexp {[pP][aA][sS][sS]} $msg] {
set passIndex [string first pass [string tolower $msg]]
# results in pw = pass password
set pw [string range $msg $passIndex end]
# results in pw = password
set pw [string trimleft $pw "PASS "]
set user [string trimright $msg $pw]
# results in pw = ********
regsub -all -- {[[:alnum:]]} $pw {*} pw
set msg $user$pw
}
.output.scr insert end \n$msg\n sendcolor
.output.scr see end
}
##########################################
# Open Socket #
# #
# The following procedures will open a #
# a socket, apply the proper fileevent #
# and return the socket id to the caller #
# #
##########################################
proc OpenGeneral {addy port} {
global genId
set genId [socket $addy $port]
fileevent $genId readable "General $genId"
puts "genId = $genId"
return $genId
}
proc OpenSmtp {addy port} {
global smtpId
set smtpId [socket $addy $port]
fileevent $smtpId readable "RdSmtp $smtpId"
puts "smtpId = $smtpId"
return $smtpId
}
proc OpenPop {addy port} {
global popId
set popId [socket $addy $port]
fileevent $popId readable "RdPop $popId"
puts "popId = $popId"
return $popId
}
proc OpenFtp {addy port} {
global ftpId
set ftpId [socket $addy $port]
fileevent $ftpId readable "RdFtp $ftpId"
puts "ftpId = $ftpId"
return $ftpId
}
##########################################
# proc LogOnFormat #
# #
# This proc will extract the port number #
# from the line and use it to send the #
# data to the proper procedure. #
# #
##########################################
proc LogOnFormat {ip user pw} {
global sid lastIp
# extract data from ip
regexp {([^:]+):([0-9]+)} $ip ip host port
if ![info exists port] {
tk_messageBox -type ok -title "Port Error" -parent .logon -icon error \
-message "Missing port number.\nPlease check your entry."
return -errorcode "Missing Port Number"
}
# if there is an open connection, close it
if {[info exists sid] == 1} {
catch {SdCnl $sid QUIT}
}
# set the list under the File menu
catch {llength $lastIp} res
if {$res > 3} {
set lastIp [lreplace $lastIp 0 0]
}
lappend lastIp [list $ip]
# open the connection and log on.
switch $port {
23 {
set sid [OpenFtp $host $port]
SdCnl $sid "USER $user\nPASS $pw"
}
25 {
set sid [OpenSmtp $host $port]
SdCnl $sid "HELO $user"
}
110 {
set sid [OpenPop $host $port]
SdCnl $sid "USER $user\nPASS $pw"
}
default {
set sid [OpenGeneral $host $port]
SdCnl $sid "USER $user\nPASS $pw"
}
}
} ;# end LogOnFormat
##########################################
# proc SocketDisplay #
# #
# This proc will format the I/O screen #
# with the proper colors for text, etc #
# #
##########################################
proc SocketDisplay {} {
set w [toplevel .output]
wm geometry $w +0+165
wm title $w "Socket Display"
pack [scrollbar $w.scy -orient vertical -command {.output.scr yview}] \
-side right -fill y -expand 1
pack [scrollbar $w.scx -orient horizontal -command {.output.scr xview}] \
-side bottom -fill x -expand 1
pack [text $w.scr -width 75 -height 20 -wrap none \
-xscrollcommand {.output.scx set} -yscrollcommand {.output.scy set}] \
-fill both -expand 1
$w.scr tag configure popcolor -foreground blue
$w.scr tag configure smtpcolor -foreground red
$w.scr tag configure sendcolor -foreground #007000
$w.scr tag configure hldscolor -font {-slant italic}
} ;# end SocketDisplay
##########################################
# proc LogOnDisplay #
# #
# User Interface for quickly logging #
# into a server. #
# #
##########################################
proc LogOnDisplay {} {
set w [toplevel .logon]
wm geometry $w +0+0
wm title $w "Log On Info"
wm protocol $w WM_DELETE_WINDOW {ShutDown}
Gui_Menubar
set sw [frame $w.ip]
label $sw.lbl -text "IP/URL:port"
entry $sw.ent -textvariable ip -width 30
pack $sw.lbl $sw.ent -side left -expand 1 -fill x
set sw [frame $w.user]
label $sw.lbl -text "Username"
entry $sw.ent -textvariable username -width 20
pack $sw.lbl $sw.ent -side left -expand 1 -fill x
set sw [frame $w.pass]
label $sw.lbl -text "Password"
entry $sw.ent -textvariable password -width 20 -show *
pack $sw.lbl $sw.ent -side left -expand 1 -fill x
button $w.btn -text "Log On" -command {LogOnFormat $ip $username $password}
set sw [frame $w.send -relief groove]
label $sw.lbl -text "Command"
entry $sw.ent -textvariable svrCmd -width 30
button $sw.btn -text Send -command {SdCnl $sid $svrCmd; set svrCmd ""}
pack $sw.lbl $sw.ent $sw.btn -side left -fill x -pady 3 -padx 1
pack $w.ip $w.user $w.pass $w.btn $w.send -side top
bind $w.ip.ent <Return> {.logon.btn invoke}
bind $w.user.ent <Return> {.logon.btn invoke}
bind $w.pass.ent <Return> {.logon.btn invoke}
bind $w.btn <Return> {.logon.btn invoke}
bind $w.send.ent <Return> {.logon.send.btn invoke}
} ;# end LogOnDisplay
##########################################
# proc Gui_Menubar #
# #
# This procedure is designed to create #
# the user the Menubar. #
# #
##########################################
proc Gui_Menubar {} {
set w .logon
$w config -menu $w.menu
menu $w.menu -tearoff 0
#
# Create the menu File
# submenus - New, Exit
#
set m [menu $w.menu.file -tearoff 0]
$w.menu add cascade -label File -menu $m -underline 0
$m add command -label New -command {}
$m add separator
$m add command -label Exit -command {destroy .}
.logon.menu.file add separator
#
# Create the menu Help
# submenus - Help, About
#
set m [menu $w.menu.help -tearoff 0]
$w.menu add cascade -label Help -menu $m -underline 0
$m add command -label Help -command {Help}
$m add separator
$m add command -label About -command {About}
LastUsedIp
} ;#end proc Gui_Menubar
##########################################
# proc LastUsedIp #
# #
# This proc is used to put the last used #
# ip address in the File menu. #
# The purpose is to allow the user to #
# choose that ip and have it fill the #
# proper field. #
# #
##########################################
proc LastUsedIp {args} {
global lastIp
.logon.menu.file delete 3 end
.logon.menu.file add separator
if ![info exists lastIp] {
.logon.menu.file delete 3 end
return
}
for {set ctr 4} {$ctr > -1} {incr ctr -1} {
set ip [lindex $lastIp $ctr]
if {$ip != ""} {
.logon.menu.file add command -label $ip \
-command ".logon.ip.ent delete 0 end; .logon.ip.ent insert 0 $ip"
}
}
} ;# end proc LastUsedIp
##########################################
# proc InitReg #
# #
# Get the lastIp used from the registry. #
# #
##########################################
proc InitReg {} {
global lastIp tcl_platform
if {$tcl_platform(platform) != "windows"} {
return
}
for {set ctr 0} {$ctr < 4} {incr ctr 1} {
catch {
lappend lastIp [registry get "HKEY_LOCAL_MACHINE\\Software\\server.access.tcl\\" \
"ip$ctr"]
}
}
if ![info exists lastIp] {
set lastIp ""
}
} ;# end InitReg
##########################################
# proc ShutDown #
# #
# Put the lastIp used into the registry. #
# #
##########################################
proc ShutDown {} {
global lastIp tcl_platform
if {$tcl_platform(platform) != "windows"} {
destroy .
}
if ![info exists lastIp] {
destroy .
}
for {set ctr 3} {$ctr > -1} {incr ctr -1} {
registry set "HKEY_LOCAL_MACHINE\\Software\\server.access.tcl\\" \
"ip$ctr" "[lindex $lastIp $ctr]"
}
destroy .
} ;# end proc ShutDown
##########################################
# Main #
# #
##########################################
package require registry 1.0
# make program reintrant
foreach a [winfo children .] {
destroy $a
}
wm withdraw .
wm protocol . WM_DELETE_WINDOW {ShutDown}
catch {console show}
InitReg
SocketDisplay
LogOnDisplay
trace variable lastIp w {LastUsedIp}
puts "The available commands are as follows:"
puts "SdCnl $<*Id> <command>"
focus .logon
##########################################
# proc Help #
# #
# Displays the help info. #
# #
##########################################
proc Help {} {
set w [toplevel .help]
wm title .help Help
wm geometry .help +150+60
set msg "
This program is a basic port snooper. It doesn't do much.
In the IP/URL:port line insert your IP or URL and the port number
i.e. mail.mymailserver.net:110
or 128.0.0.1:25
The command line will send whatever is on the line to the port.
SMTP (port 25) commands are:
HELO (takes the username)
MAIL FROM: (where the email is coming from)- RCPT TO
- (where the email is going)
DATA (the email data)
HELP (gives list of available commands)
QUIT (logs out and closes connection)
POP (port 110) commands are:
USER (Username, for logon)
PASS (Password, for logon)
STAT (displays number of emails and total size)
LIST (list all emails and size)
RETR # (displays specific email)
DELE # (deletes specific email)
QUIT (logs out and closes connection)
FTP (port 21) I am unsure of all the commands for FTP.
"
message $w.msg -text $msg -font {-family "Courier New" -size 10}
button $w.btn -text Ok -command {destroy .help}
pack $w.msg $w.btn -side top
} ;# end proc Help
##########################################
# proc About #
# #
# Displays the about info. #
# #
##########################################
proc About {} {
set w [toplevel .about]
wm title .about About
wm geometry .about +150+60
set msg "
server.access.tcl v1.0
by: Jeff \"Machtyn\" Gosnell
Purpose: An instruction on how to use sockets,
fileevent, regexp, and optimize my style some.
It will also show you the exact data coming through
the port you are using to access whatever kind of
server. Particularly useful for SMTP, POP, FTP.
Feel free to use any part of this code. It would be
nice of you to give me some credit if you do use it.
"
message $w.msg -text $msg
button $w.btn -text Ok -command {destroy .about}
pack $w.msg $w.btn -side top
} ;# end proc About