When I originally started using [Oratcl], it included an application call wosql which provided a simple windowed interface to [Oracle].  wosql included a logon dialog that I liked so much that I stole it :-).  More recent versions os [Oratcl] do not come with wosql, but below is my current version of the logon dialog widget.  This is definitely a work in progress, and if you have suggestions, enhancements or bug fixes, please let me know.

This should work with Oratcl 3.x; it certainly works with Oratcl 3.3.  It ''may'' work with Oratcl 2.7; I don't know of anything incompatible with Oratcl 2.7 or Tcl 8.0, but I haven't paid close enough attention to be sure.  I will ''not'' work with Oratcl 4.x.  Among other things, there are are references to oramsg to retrieve the error message and that array has been removed in version 4.0.  Working around that is probably trivial, but I don't have Oracle 9 libraries for testing.

After sourcing the file below, you will call '''::tkora::getSignOn callback''' to launch the dialog.  Here is a sample extracted from one of my applications.  If you run this from a shell window, or from tkcon.tcl, showLogon will be called with the logon-handle.  You will then see the contents of your Oracle signon (user, password, TNS name) and a message indicating the logon dialog was destroyed.

    #!/bin/sh
    #
    # The following is a required on unix and harmless elsewhere
    # *** DO NOT TOUCH THIS OR THE FOLLOWING LINE! *** \
    exec wish $0 ${1+"$@"}

    # Not all of these are required by everything, but...better to find
    # out at the beginning that something is missing.
    package require Tk
    package require Oratcl

    wm withdraw .
    source logon.tcl
	
    proc showLogon args {
	foreach k $args {
	    puts "Oracle handle => $k"
	}
	foreach {k v} [array get ::tkora::logon::logon] {
	    puts "$k ==> $v"
	}
    }

    # Fire up sign-on screen and wait.
    set w [::tkora::logon::getSignOn ::showLogon]
    tkwait window $w
    puts "$w destroyed!"

And here is the file "logon.tcl" referenced above.

    #
    # Copyright � 2000-2002, FT/Interactive Data
    # Copyright � 1998-1999, Muller Data Corporation
    # Copyright � 1993?, Tom Poindexter <URL:http://www.nyx.net/~tpoindex/tcl.html>
    # Roland B. Roberts <roland.roberts@ftid.com>
    #
    #************************************************************************
    # Copyright Info:
    #
    #     This code is derived from wosql, distributed with Oratcl 2.7
    #
    #************************************************************************
    #
    # RCS Revision
    #   $Id: 4588,v 1.2 2002-11-15 09:02:16 jcw Exp $
    #   $Source: /home/kennykb/Tcl/wiki/cvsroot/twhist/4588,v $
    #
    # Required by old TRCS scripts
    #   $Header: /home/kennykb/Tcl/wiki/cvsroot/twhist/4588,v 1.2 2002-11-15 09:02:16 jcw Exp $
    #
    # 
    # Variables
    #    logon        - array holding logon information after successful
    #                   logon
    #    widget       - name of the toplevel widget containing the login
    #                   dialog 
    #    usropt       - dialog (display) options
    #    serverList   - list of servers obtained from tnsnames.ora
    #
    # Procedures
    #    getSignOn       - Oracle login dialog
    #    reconnect       - reconnect using old (or specified) Oracle
    #                      connect-string 
    #    getServerList   - 
    #    getFile         - Suck a whole file into a string
    #    showSignOnError - Update logon dialog to display Oracle error
    #    connect         - called by getSignOn when user enters Oracle logon
    #                      information.  Retrieves dialog strings for actual
    #                      Oracle logon attempt. 
    #    connect_1       - called by connect to do "real" Oracle logon
    #                      attempt. 
    #
    # Description
    #
    #    Only getSignOn and reconnect are intended to be public funcions.
    #
    #    getSignOn displays a dialog for entering an Oracle username,
    #    password, and DB name.  getSignOn takes a single argument, the name
    #    of a callback to be called when the signon completes successfully.
    #    It returns the name of the toplevel widget containing the entire
    #    signon dialog.
    #
    #    reconnect takes a single optional argument which is a connect
    #    string of any form which is acceptable to oralogon with the default
    #    to reuse the previous connect string, the one generated by
    #    getSignOn in ::tkora::logon::logon(connect-string).
    #
    #    usropt contains logon-dialog specific options.  Eventually, I hope
    #    to change getSignOn to take Tcl-style options for the values in
    #    this array, something like "getSignon -title $text ...."
    #    
    �
    namespace eval ::tkora::logon {
	# Holds actual logon toplevel widget name.
	variable widget
	# Eye candy
	variable usropt
	array set usropt [list title "MIPS Operations" \
			      iconname "MIPS/OPS" \
			      geometry 275x300]
	# Cached copy of valid Oracle TNS names.
	variable serverList
	variable logon

	# o s.m is the contains the message header, this is a message widget.
	# o Menubutton and Button takes care of the labels on the buttons.
	# o Label takes care of the text (entry) labels.
	# o Entry takes care of the text entry widgets.
	# o s.err is the error message; this is a message widget.
	option add *MIPSLogon*s.m*font {-*-helvetica-bold-o-*-*-20-*-*-*-*-*-*-*}
	option add *MIPSLogon*Menubutton*font {-*-helvetica-bold-*-*-*-14-*-*-*-*-*-*-*}
	option add *MIPSLogon*Button*font {-*-helvetica-bold-*-*-*-14-*-*-*-*-*-*-*}
	option add *MIPSLogon*Label*font {-*-helvetica-bold-o-*-*-14-*-*-*-*-*-*-*}
	option add *MIPSLogon*Entry*font {-*-helvetica-normal-*-*-*-14-*-*-*-*-*-*-*}
	option add *MIPSLogon*s.err*font {-*-helvetica-bold-*-*-*-12-*-*-*-*-*-*-*}
	option add *MIPSLogon*s.err*foreground red

	# Should make a more OS-friendly name here.
	catch {option readfile [file join $env(HOME) .mipslogon]}
    }

    ########################
    # getServerlist
    #  figure out what Oracle servers are available
    #
    proc ::tkora::logon::getServerList {} {
	global env
	set serverList ""

	# On Windows 95, look in these locations, depending on what version
	# of the Oracle libraries you have.
	foreach {ffile fremote} [list $env(ORACLE_HOME)/network/admin/tnsnames.ora 1 \
				     $env(ORACLE_HOME)/net80/admin/tnsnames.ora 1] {
	    set lines ""
	    if {[file isfile $ffile]} {
		set ifile [split [::tkora::logon::getFile $ffile] \n]
		foreach line $ifile {
		    if {[regexp -nocase {sid = ([a-z_]*)} $line m s1]} {
			if {$fremote} {
			    lappend serverList @$s1
			} else {
			    set s1 [lindex [split $s1 :] 0]
			    lappend serverList $s1
			}
		    }
		}
	    }
	}

	foreach {ffile fremote} [list /etc/oratab 0 \
				     /etc/sqlnet 1 \
				     $env(HOME)/.sqlnet 1 \
				     $env(HOME)/.tnsnames.ora 1] {

	    set lines ""
	    if {[file isfile $ffile]} {
		set ifile [split [::tkora::logon::getFile $ffile] \n]
		foreach line $ifile {
		    if {[regexp -nocase "(^\[a-z_]\[^ \t\r]*).*$" $line m s1]} {
			if {$fremote} {
			    lappend serverList @$s1
			} else {
			    set s1 [lindex [split $s1 :] 0]
			    lappend serverList $s1
			}
		    }
		}
	    }

	}

	# nothing found? put in serverList what names should look like
	if {[llength $serverList] == 0} {
	    lappend serverList "(localdb)"
	    lappend serverList "(@remote_alias)"
	    lappend serverList "(@T:host:remotedb)"
	}
	return $serverList
    }

    ########################
    # getSignOn
    #   The first window, get logon info and trys to connect to the server
    #
    proc ::tkora::logon::getSignOn {callback} {
	global env
	global tcl_platform
	variable logon
	variable serverList
	variable widget
	variable usropt

	# set ORACLE_HOME if not already set
	set ora_home [lsearch [array names env] ORACLE_HOME]

	if {$ora_home == -1} {
	    set ora_home ""
	    if {[string compare $tcl_platform(platform) windows] == 0} {
		# Okay, I really only know that this works for Win2k.  Under
		# Win95, the environment variable ORACLE_HOME was set.
		set ora_home [registry get "HKEY_LOCAL_MACHINE\\SOFTWARE\\ORACLE" ORACLE_HOME]
	    } else {
		catch {set ora_home [exec ypcat passwd | egrep  ^oracle: ]}
		if {[string length $ora_home] > 0} {
		    set ora_home [lindex [split $ora_home :] 5]
		} else {
		    catch {set ora_home [exec egrep ^oracle: < /etc/passwd ]}
		    if {[string length $ora_home] > 0} {
			set ora_home [lindex [split $ora_home :] 5]
		    } else {
			set ora_home ""
		    }
		}
	    }
	    set env(ORACLE_HOME) $ora_home
	} else {
	    set ora_home $env(ORACLE_HOME)
	}

	# Get valid servers from various files
	if {![info exists serverList]} {
	    set serverList [getServerList]
	} elseif {[llength serverList] == 0} {
	    set serverList [getServerList]
	}

	# Maybe someone else likes the name ".logon" for their logon screen
	set mytop .logon
	for {set i 0} {$i < 100} {incr i} {
	    if [catch {toplevel $mytop -class MIPSLogon} widget] {
		set mytop .logon$i
	    } else {
		break;
	    }
	}

	wm title    $widget $usropt(title)
	wm iconname $widget $usropt(iconname)
	wm geometry $widget $usropt(geometry)

	frame $widget.s
	message $widget.s.m -justify center  -text "Oracle Server Sign-On" -aspect 2000
	frame $widget.s.i
	entry $widget.s.i.uid -relief sunken  -width 12
	label $widget.s.i.id  -text "  User Id" -anchor e

	frame $widget.s.p
	entry $widget.s.p.pw  -relief sunken -width 12 -show * -exportselection false
	label $widget.s.p.p   -text "  Password" -anchor e

	frame $widget.s.s
	entry $widget.s.s.ser -relief sunken -width 12
	menubutton $widget.s.s.s -text " Servers  " -anchor e -menu $widget.s.s.s.m \
		-relief raised
	menu $widget.s.s.s.m
	foreach s $serverList {
	    $widget.s.s.s.m add command -label $s \
		-command "$widget.s.s.ser delete 0 end; $widget.s.s.ser insert 0 $s "

	}
	if {[lsearch [array names env] ORACLE_SID] >= 0} {
	    $widget.s.s.s.m add command -label $env(ORACLE_SID)
	}

	message $widget.s.err -text " " -justify center -aspect 500

	frame $widget.s.b
	button $widget.s.b.ok  -text "Sign on" -command "::tkora::logon::connect $callback"
	button $widget.s.b.can -text "Cancel" -command "destroy $widget"

	pack $widget.s.b     -side bottom -fill x -expand 0
	pack $widget.s.b.ok $widget.s.b.can -side left -fill x -expand 1

	pack $widget.s    -side top -fill both -expand 1
	pack $widget.s.m  -side top -fill x -pady 5

	pack $widget.s.i.uid -side right -expand 1 -padx 20
	pack $widget.s.i.id  -side left
	pack $widget.s.i  -side top -pady 10 -anchor e

	pack $widget.s.p.pw  -side right -expand 1 -padx 20
	pack $widget.s.p.p   -side left
	pack $widget.s.p  -side top -pady 10 -anchor e

	pack $widget.s.err   -side top -fill both

	pack $widget.s.s.ser -side right -expand 1 -padx 20

	pack $widget.s.s.s   -side left
	pack $widget.s.s     -side bottom -pady 10 -anchor se -expand 1

	$widget.s.i.uid delete 0 end
	if [info exists logon(userid)] {
	    $widget.s.i.uid insert 0 $logon(userid)
	    $widget.s.i.uid selection range 0 end
	}
	$widget.s.s.ser delete 0 end
	if [info exists logon(server)] {
	    $widget.s.s.ser insert 0 $logon(server)
	} else {
	    $widget.s.s.ser insert 0 [lindex $serverList 0]
	}

	focus $widget.s.i.uid

	bind $widget.s.i.uid <KeyPress-Return> "focus $widget.s.p.pw"
	bind $widget.s.p.pw  <KeyPress-Return> "$widget.s.b.ok invoke"
	bind $widget.s.s.ser <KeyPress-Return> "$widget.s.b.ok invoke"

	# allow Entry and Text to paste selections
	bind Entry <ButtonRelease-2> {
	    set tk_s_rc [catch {set tk_s_s [selection get]} ]
	    if {$tk_s_rc == 0} {%W insert insert $tk_s_s}
	}

	return $widget
    }

    ########################
    # getFile
    #  read a file, return contents as string
    #
    proc ::tkora::logon::getFile {afile} {
	set contents {}
	catch { 
	    set fd [open $afile]
	    set contents [read $fd]
	    close $fd
	}
	return $contents
    }

    proc ::tkora::logon::showSignOnError {w1 w2} {
	global oramsg
	$w1 configure -text $oramsg(errortxt)
	focus $w2
    }


    proc ::tkora::logon::connect {callback} {
	variable widget
	set userid [$widget.s.i.uid get]
	set passwd [$widget.s.p.pw get]
	set server [$widget.s.s.ser get]
	::tkora::logon::connect_1 $userid $passwd $server $callback \
		[list ::tkora::logon::showSignOnError \
		${::tkora::logon::widget}.s.err ${::tkora::logon::widget}.s.p.pw]
    }

    ########################
    # logon::connect_1
    #   Try a connection to the Oracle server.
    #
    proc ::tkora::logon::connect_1 {userid passwd server cbokay cbfail} {
	global env
	variable logon
	variable widget

	# Check for local DB specification
	if {[string first @ $server] != 0} {
	    set oldsid $env(ORACLE_SID)
	    set env(ORACLE_SID) $server
	    set server ""
	}

	set retcode [catch {oralogon ${userid}/${passwd}${server}} lda]
	if {$retcode == 0} {
	    destroy $widget
	    set dbh $lda
	    set logon(connect-string) ${userid}/${passwd}${server}
	    set logon(server) $server
	    set logon(userid) $userid
	    set logon(passwd) $passwd
	    eval $cbokay $dbh
	} else {
	    if [info exists oldsid] {
		set env(ORACLE_SID) $oldsid
	    }
	    eval $cbfail
	}
    }

    proc ::tkora::logon::reconnect {{connect-string {}}} {
	variable logon
	if {[string length ${connect-string}] == 0} {
	    set connect-string $logon(connect-string)
	}
	set retcode [catch {oralogon ${connect-string}} lda]
	if {$retcode == 0} {
	    return $lda
	} else {
	    return
	}
    }

Roland Roberts [mailto:roland.roberts@ftid.com]