Version 8 of Jeff Gosnell

Updated 2002-06-05 05:01:55

Category Home Page


A little about myself. I like to write Tcl/Tk programs, with the influence on the Tk part. I've also been practicing how to work with sockets, packages, and tcllib's MIME package.

I also have a few web pages, each for getting around the others limitation/policy. The most updated pages are listed first. However, they are all meant to be mirrors of each other.

I have also created some examples using Tcl/Tk which can be found on those pages. I will also make a list at the end of this document (with the code) of the scripts I've written, which I feel may be used by others. They may not always be cross-platform (I am in a Windows world) but I will try to write to that purpose.


Examples and free-to-use scripts

TOC 1 Email Authentication - email_authentication.tcl - uses tcllib's MIME package 2 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)


email_authentication.tcl [L1 ]

 # created by Jeff Gosnell for the tcl community
 # Tuesday, May 29, 2001
 #
 # a couple of simple procedures to authenticate a user
 # on a mailserver that requires authentication.
 #
 # Take care when using these procedures.  They use the 
 # global variable array user
 #
 # run the LogOn procedure to get a nice display.
 # LogOn will then run VrfyUser 
 # Make sure the pathname is correct for your installation
 # of tcllib0.9's MIME package
 #
 # There is no visible result that the login was successful
 # except that the .logOn window will disappear.
 # When sending an email (in another procedure), 
 # use $user(nameMIME) and $user(pwMIME) to authenticate.
 #

 proc LogOn {} {

        set w [toplevel .logOn]
        wm geometry $w 175x140+100+100
        wm title $w "Log On Information"

        set sw [frame $w.name]
        label $sw.lbl -text "Username: "
        entry $sw.ent -width 15 -textvariable user(name)
        pack $sw.lbl $sw.ent -side left -padx 2 -expand true

        set sw [frame $w.pw]
        label $sw.lbl -text "Password: "
        entry $sw.ent -width 15 -textvariable user(pw) -show *
        pack $sw.lbl $sw.ent -side left -padx 2 -expand true

        set sw [frame $w.server]
        label $sw.lbl -text "Mail Server:"
        entry $sw.ent -width 15 -textvariable user(mailserver)
        pack $sw.lbl $sw.ent -side left -padx 2 -expand true

        set sw [frame $w.buttons]
        button $sw.ok -text Ok -command {VrfyUser .logOn} -width 8
        button $sw.cancel -text Cancel -command {destroy .logOn; array unset user; return Cancelled} -width 8
        pack $sw.ok $sw.cancel -side left -padx 5 -expand true

        pack $w.name $w.pw $w.server $w.buttons -side top -pady 2 -expand true -fill both

        bind $w <Return> {.logOn.buttons.ok invoke}

 } ;# end proc LogOn


 ##########################################
 #            proc VrfyUser               #
 #                                        #
 # This procedure is designed to verify   #
 # the username and password for          #
 # authenticating the user for emailing.  #
 # It will notify the user if it fails.   #
 #                                        #
 #                                        #
 ##########################################
 proc VrfyUser {w} {

        global user

        source "/program files/tcl/tcllib0.8/mime/mime.tcl"
        source "/program files/tcl/tcllib0.8/mime/smtp.tcl"
        package provide mime 1.2
        package provide smtp 1.2

 # display a toplevel showing the system logging in.
        toplevel $w.working -width 200 -height 100 -bg #ff3d3d
        wm overrideredirect $w.working 1
        wm geometry $w.working +150+150
        pack [frame $w.working.frame -bd 2 -relief raised -width 200 -height 100] -ipadx 1 -ipady 1
        pack [label $w.working.frame.lbl -bg #ff3d3d -relief sunken \
                        -text "Logging $user(name) on the system." 
                        ] -fill both
        update

 # convert the username to mime format
        set t_name [mime::initialize -canonical text/octet-stream \
                                        -encoding base64 -string $user(name)]
        set user(nameMIME) [lindex [mime::buildmessage $t_name] end]
        mime::finalize $t_name -subordinates all

 # convert the password to mime format
   set t_pw   [mime::initialize -canonical text/octet-stream \
                                        -encoding base64 -string $user(pw)]
        set user(pwMIME) [lindex [mime::buildmessage $t_pw] end]
        mime::finalize $t_pw -subordinates all

 # log on to the server
        set sid [socket $user(mailserver) 25]
 # if the server doesn't return 220 it failed
        if {[lindex [gets $sid] 0] != 220} {
                catch {destroy $w.msg}
                pack [label $w.msg -text "Error logging in:  \nFailed to connect to server" \
                                        -font {-family Arial -size 10} -justify left
                        ] -side bottom -pady 2
                catch {destroy $w.working}
                focus $w
                return
        }

 # log on user
        puts $sid "HELO $user(name)"
        flush $sid
        if {[lindex [gets $sid] 0] != 250} {
                catch {destroy $w.msg}
                pack [label $w.msg -text "Error logging in:  \nInvalid username" \
                                        -font {-family Arial -size 10} -justify left
                        ] -side bottom -pady 2
                catch {destroy $w.working}
                focus $w
                return
        }

 # attempt authentication
        puts $sid "AUTH LOGIN"
        flush $sid
        if {[lindex [gets $sid] 0] != 334} {
                catch {destroy $w.msg}
                pack [label $w.msg -text "Error logging in:  \nFailed to initiate authorization" \
                                        -font {-family Arial -size 10} -justify left
                        ] -side bottom -pady 2
                catch {destroy $w.working}
                focus $w
                return
        }

 # Username:
        puts $sid $user(nameMIME)
        flush $sid
        if {[lindex [gets $sid] 0] != 334} {
                catch {destroy $w.msg}
                pack [label $w.msg -text "Error logging in:  \nInvalid username or password" \
                                        -font {-family Arial -size 10} -justify left
                        ] -side bottom -pady 2
                catch {destroy $w.working}
                focus $w
                return
        }

 # Password:
        puts $sid $user(pwMIME)
        flush $sid
        if {[lindex [gets $sid] 0] != 235} {
                catch {destroy $w.msg}
                pack [label $w.msg -text "Error logging in:  \nInvalid username or password" \
                                        -font {-family Arial -size 10} -justify left
                        ] -side bottom -pady 2
                catch {destroy $w.working}
                focus $w
                return
        }

        close $sid

        destroy $w

        return "Log on successful"

 } ;# end proc VrfyUser

server.access.tcl [L2 ]

 #####################################################################
 #                                                                   #
 # 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 $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