Updated 2007-12-02 11:38:02 by dkf

Roland B. Roberts - 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.11 2002-11-15 09:02:26 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.11 2002-11-15 09:02:26 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
    }
}