Roland B. Roberts - RBR 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. Although this is functional enough to use as is, it can almost certainly stand some improvement. From a purely stylistic standpoint, I originally wrote it using StudlyCapitalizedNames which I don't particularly like anymore. Even apart from that, 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, showLogon will be called with the logon-handle, the handle used by Oratcl's oraopen call. 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 <[email protected]>
#
#************************************************************************
# Copyright Info:
#
# This code is derived from wosql, distributed with Oratcl 2.7
#
#************************************************************************
#
# RCS Revision
# $Id: 4588,v 1.10 2002-11-15 09:02:25 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.10 2002-11-15 09:02:25 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
}
}