#!/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!"

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