--- /dev/null
+#!/usr/bin/wish
+#############################################################################
+# Visual Tcl v1.10 Project
+#
+
+#################################
+# GLOBAL VARIABLES
+#
+global activetab;
+global dbc;
+global dirty;
+global fldval;
+global host;
+global pport;
+global sdbname;
+global tablist;
+global widget;
+
+#################################
+# USER DEFINED PROCEDURES
+#
+proc init {argc argv} {
+global dbc host pport tablist dirty fldval activetab
+set host localhost
+set pport 5432
+set dbc {}
+set tablist [list Tables Queries Views Sequences Reports Scripts]
+set activetab {}
+set dirty false
+set fldval ""
+trace variable fldval w mark_dirty
+}
+
+init $argc $argv
+
+proc cmd_Design {} {
+global dbc activetab tablename
+if {$dbc==""} return;
+if {[.dw.lb curselection]==""} return;
+set tablename [.dw.lb get [.dw.lb curselection]]
+switch $activetab {
+ Queries {open_query design}
+}
+}
+
+proc cmd_Import_Export {how} {
+global dbc ie_tablename ie_filename activetab
+if {$dbc==""} return;
+Window show .iew
+set ie_tablename {}
+set ie_filename {}
+set ie_delimiter {}
+if {$activetab=="Tables"} {
+ set tn [get_dwlb_Selection]
+ set ie_tablename $tn
+ if {$tn!=""} {set ie_filename "$tn.txt"}
+}
+.iew.expbtn configure -text $how
+}
+
+proc cmd_New {} {
+global dbc activetab queryname qtype queryoid
+if {$dbc==""} return;
+switch $activetab {
+ Tables {Window show .nt}
+ Queries {
+ Window show .qb
+ set queryname {}
+ set qtype "S"
+ set queryoid 0
+ .qb.text1 delete 1.0 end
+ }
+}
+}
+
+proc cmd_Open {} {
+global dbc activetab tablename
+if {$dbc==""} return;
+if {[.dw.lb curselection]==""} return;
+set tablename [.dw.lb get [.dw.lb curselection]]
+switch $activetab {
+ Tables {Window show .mw; load_table $tablename}
+ Queries {open_query view}
+ Views {open_view}
+}
+}
+
+proc cmd_Queries {} {
+global dbc
+
+.dw.lb delete 0 end
+catch {
+ pg_select $dbc "select * from pga_queries order by queryname" rec {
+ .dw.lb insert end $rec(queryname)
+ }
+}
+}
+
+proc cmd_Reports {} {
+global dbc
+}
+
+proc cmd_Scripts {} {
+global dbc
+}
+
+proc cmd_Sequences {} {
+global dbc
+
+cursor_watch .dw
+.dw.lb delete 0 end
+catch {
+ pg_select $dbc "select * from pg_class where (relname not like 'pg_%') and (relkind='S') order by relname" rec {
+ .dw.lb insert end $rec(relname)
+ }
+}
+cursor_arrow .dw
+}
+
+proc cmd_Tables {} {
+global dbc
+
+cursor_watch .dw
+.dw.lb delete 0 end
+catch {
+ pg_select $dbc "select * from pg_class where (relname not like 'pg_%') and (relkind='r') and (not relhasrules) order by relname" rec {
+ .dw.lb insert end $rec(relname)
+ }
+}
+cursor_arrow .dw
+}
+
+proc cmd_Vacuum {} {
+global dbc dbname sdbname
+
+if {$dbc==""} return;
+cursor_watch .dw
+set sdbname "vacuuming database $dbname ..."
+update; update idletasks
+set retval [catch {
+ set pgres [pg_exec $dbc "vacuum;"]
+ pg_result $pgres -clear
+ } msg]
+cursor_arrow .dw
+set sdbname $dbname
+if {$retval} {
+ show_error $msg
+}
+}
+
+proc cmd_Views {} {
+global dbc
+
+cursor_watch .dw
+.dw.lb delete 0 end
+catch {
+ pg_select $dbc "select * from pg_class where (relname not like 'pg_%') and (relkind='r') and (relhasrules) order by relname" rec {
+ .dw.lb insert end $rec(relname)
+ }
+}
+cursor_arrow .dw
+}
+
+proc cursor_arrow {w} {
+$w configure -cursor top_left_arrow
+update idletasks
+}
+
+proc cursor_watch {w} {
+$w configure -cursor watch
+update idletasks
+}
+
+proc drag_it {w x y} {
+global draglocation
+ if {"$draglocation(obj)" != ""} {
+ set dx [expr $x - $draglocation(x)]
+ set dy [expr $y - $draglocation(y)]
+ $w move $draglocation(obj) $dx $dy
+ set draglocation(x) $x
+ set draglocation(y) $y
+ }
+}
+
+proc drag_start {w x y} {
+global draglocation
+catch {unset draglocation}
+set draglocation(obj) [$w find closest $x $y]
+set draglocation(x) $x
+set draglocation(y) $y
+set draglocation(start) $x
+}
+
+proc drag_stop {w x y} {
+global draglocation colcount colwidth layout_name dbc
+ if {"$draglocation(obj)" != ""} {
+ set ctr [get_tag_info $draglocation(obj) g]
+ set diff [expr $x-$draglocation(start)]
+ if {$diff==0} return;
+ set newcw {}
+ for {set i 0} {$i<$colcount} {incr i} {
+ if {$i==$ctr} {
+ lappend newcw [expr [lindex $colwidth $i]+$diff]
+ } else {
+ lappend newcw [lindex $colwidth $i]
+ }
+ }
+ set colwidth $newcw
+ draw_headers
+ for {set i [expr $ctr+1]} {$i<$colcount} {incr i} {
+ .mw.c move c$i $diff 0
+ }
+ cursor_watch .mw
+ sql_exec quiet "update pga_layout set colwidth='$colwidth' where tablename='$layout_name'"
+ cursor_arrow .mw
+ }
+}
+
+proc draw_headers {} {
+global colcount colname colwidth
+
+.mw.c delete header
+set posx 5
+for {set i 0} {$i<$colcount} {incr i} {
+ set xf [expr $posx+[lindex $colwidth $i]]
+ .mw.c create rectangle $posx 3 $xf 22 -fill lightgray -outline "" -width 0 -tags header
+ .mw.c create text [expr $posx+[lindex $colwidth $i]*1.0/2] 14 -text [lindex $colname $i] -tags header -fill navy -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*
+ .mw.c create line $posx 22 [expr $xf-1] 22 -fill darkgray -tags header
+ .mw.c create line [expr $xf-1] 5 [expr $xf-1] 22 -fill darkgray -tags header
+ .mw.c create line [expr $xf+1] 5 [expr $xf+1] 22 -fill white -tags header
+ .mw.c create line $xf -15000 $xf 15000 -fill gray -tags [subst {header movable g$i}]
+ set posx [expr $xf+2]
+}
+for {set i 0} {$i < 100} {incr i} {
+ .mw.c create line 0 [expr 37+$i*14] $posx [expr 37+$i*14] -fill gray -tags header
+}
+.mw.c bind movable <Button-1> {drag_start %W %x %y}
+.mw.c bind movable <B1-Motion> {drag_it %W %x %y}
+.mw.c bind movable <ButtonRelease-1> {drag_stop %W %x %y}
+}
+
+proc draw_tabs {} {
+global tablist activetab
+set ypos 85
+foreach tab $tablist {
+ label .dw.tab$tab -borderwidth 1 -anchor w -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text $tab
+ place .dw.tab$tab -x 10 -y $ypos -height 25 -width 82 -anchor nw -bordermode ignore
+ lower .dw.tab$tab
+ bind .dw.tab$tab <Button-1> {tab_click %W}
+ incr ypos 25
+}
+set activetab ""
+}
+
+proc get_dwlb_Selection {} {
+set temp [.dw.lb curselection]
+if {$temp==""} return "";
+return [.dw.lb get $temp]
+}
+
+proc get_tag_info {itemid prefix} {
+set taglist [.mw.c itemcget $itemid -tags]
+set i [lsearch -glob $taglist $prefix*]
+set thetag [lindex $taglist $i]
+return [string range $thetag 1 end]
+}
+
+proc hide_entry {} {
+global dirty dbc msg fldval itemid colname tablename
+
+if {$dirty} {
+ cursor_watch .mw
+ set msg "Saving record ..."
+ after 1000 {set msg ""}
+ set oid [get_tag_info $itemid o]
+ set fld [lindex $colname [get_tag_info $itemid c]]
+ set retval [catch {
+ set pgr [pg_exec $dbc "update $tablename set $fld='$fldval' where oid=$oid"]
+ pg_result $pgr -clear
+ } errmsg ]
+ cursor_arrow .mw
+ if {$retval} {
+ show_error "Error updating record:\n$errmsg"
+ return
+ }
+ .mw.c itemconfigure $itemid -text $fldval
+}
+catch {destroy .mw.entf}
+set dirty false
+}
+
+proc load_layout {tablename} {
+global dbc msg colcount colname colwidth layout_found layout_name
+
+cursor_watch .mw
+set layout_name $tablename
+catch {unset colcount colname colwidth}
+set layout_found false
+set retval [catch {set pgres [pg_exec $dbc "select * from pga_layout where tablename='$tablename'"]}]
+if {$retval} {
+ # Probably table pga_layout isn't yet defined
+ sql_exec noquiet "create table pga_layout (tablename varchar(64),nrcols int2,colname text,colwidth text)"
+ sql_exec quiet "grant ALL on pga_layout to PUBLIC"
+} else {
+ if {[pg_result $pgres -numTuples]==1} {
+ set layoutinfo [pg_result $pgres -getTuple 0]
+ set colcount [lindex $layoutinfo 1]
+ set colname [lindex $layoutinfo 2]
+ set colwidth [lindex $layoutinfo 3]
+ set layout_found true
+ } elseif {[pg_result $pgres -numTuples]>1} {
+ show_error "Multiple ([pg_result $pgres -numTuples]) layout info found\n\nPlease report the bug!"
+ }
+}
+catch {pg_result $pgres -clear}
+}
+
+proc load_table {tablename} {
+global ds_query ds_updatable ds_isaquery sortfield filter
+load_layout $tablename
+set ds_query "select oid,$tablename.* from $tablename"
+set ds_updatable true
+set ds_isaquery false
+select_records $ds_query
+}
+
+proc mark_dirty {name1 name2 op} {
+global dirty
+set dirty true
+}
+
+proc open_database {} {
+global dbc host pport dbname sdbname newdbname newhost newpport
+cursor_watch .dbod
+if {[catch {set newdbc [pg_connect $newdbname -host $newhost -port $newpport]} msg]} {
+ cursor_arrow .dbod
+ show_error "Error connecting database\n$msg"
+} else {
+ catch {pg_disconnect $dbc}
+ set dbc $newdbc
+ set host $newhost
+ set pport $newpport
+ set dbname $newdbname
+ set sdbname $dbname
+ cursor_arrow .dbod
+ Window hide .dbod
+ tab_click .dw.tabTables
+ set pgres [pg_exec $dbc "select relname from pg_class where relname='pga_queries'"]
+ if {[pg_result $pgres -numTuples]==0} {
+ pg_result $pgres -clear
+ sql_exec quiet "create table pga_queries (queryname varchar(64),querytype char(1),querycommand text)"
+ sql_exec quiet "grant ALL on pga_queries to PUBLIC"
+ }
+ catch { pg_result $pgres -clear }
+}
+}
+
+proc open_query {how} {
+global dbc qtype queryname layout_found queryoid ds_query ds_updatable ds_isaquery sortfield filter
+
+if {[.dw.lb curselection]==""} return;
+set queryname [.dw.lb get [.dw.lb curselection]]
+if {[catch {set pgres [pg_exec $dbc "select querycommand,querytype,oid from pga_queries where queryname='$queryname'"]}]} then {
+ show_error "Error retrieving query definition
+ return
+}
+if {[pg_result $pgres -numTuples]==0} {
+ show_error "Query $queryname was not found!"
+ pg_result $pgres -clear
+ return
+}
+set tuple [pg_result $pgres -getTuple 0]
+set qtype [lindex $tuple 1]
+set qcmd [lindex $tuple 0]
+set queryoid [lindex $tuple 2]
+pg_result $pgres -clear
+if {$how=="design"} {
+ Window show .qb
+ .qb.text1 delete 0.0 end
+ .qb.text1 insert end $qcmd
+} else {
+ if {$qtype=="S"} then {
+ Window show .mw
+ load_layout $queryname
+ set ds_query $qcmd
+ set ds_updatable false
+ set ds_isaquery true
+ select_records $qcmd
+ } else {
+ set answ [tk_messageBox -title Warning -type yesno -message "This query is an action query!\n\n$qcmd\n\nDo you want to execute it?"]
+ if {$answ} {
+ if {[sql_exec noquiet $qcmd]} {
+ tk_messageBox -title Information -message "Your query has been executed without error!"
+ }
+ }
+ }
+}
+}
+
+proc open_view {} {
+global ds_query ds_updatable ds_isaquery
+set vn [get_dwlb_Selection]
+if {$vn==""} return;
+Window show .mw
+set ds_query "select * from $vn"
+set ds_isaquery false
+set ds_updatable false
+load_layout $vn
+select_records $ds_query
+}
+
+
+proc pan_left {} {
+global leftcol leftoffset colwidth colcount
+hide_entry
+if {$leftcol==[expr $colcount-1]} return;
+set diff [expr 2+[lindex $colwidth $leftcol]]
+incr leftcol
+incr leftoffset $diff
+.mw.c move header -$diff 0
+.mw.c move rows -$diff 0
+}
+
+proc pan_right {} {
+global leftcol leftoffset colcount colwidth
+hide_entry
+if {$leftcol==0} return;
+incr leftcol -1
+set diff [expr 2+[lindex $colwidth $leftcol]]
+incr leftoffset -$diff
+.mw.c move header $diff 0
+.mw.c move rows $diff 0
+}
+
+proc scroll_window {par1 par2 args} {
+global nrecs toprec
+hide_entry
+if {$par1=="scroll"} {
+ set newtop $toprec
+ if {[lindex $args 0]=="units"} {
+ incr newtop $par2
+ } else {
+ incr newtop [expr $par2*25]
+ if {$newtop<0} {set newtop 0}
+ if {$newtop>=[expr $nrecs-1]} {set newtop [expr $nrecs-1]}
+ }
+} else {
+ set newtop [expr int($par2*$nrecs)]
+}
+if {$newtop<0} return;
+if {$newtop>=[expr $nrecs-1]} return;
+.mw.c move rows 0 [expr 14*($toprec-$newtop)]
+set toprec $newtop
+set_scrollbar
+}
+
+proc select_records {sql} {
+global dbc field dirty nrecs toprec colwidth colname colcount ds_updatable
+global layout_found layout_name tablename leftcol leftoffset msg
+hide_entry
+.mw.c delete rows
+.mw.c delete header
+set leftcol 0
+set leftoffset 0
+set msg {}
+cursor_watch .mw
+set retval [catch {set pgres [pg_exec $dbc $sql]} errmsg]
+if {$retval} {
+ cursor_arrow .mw
+ show_error "Error executing SQL command\n\n$sql\n\nError message:$errmsg"
+ set msg "Error executing : $sql"
+ return
+}
+if {$ds_updatable} then {set shift 1} else {set shift 0}
+#
+# checking at least the numer of fields
+set attrlist [pg_result $pgres -lAttributes]
+if {$layout_found} then {
+ if { ($colcount != [expr [llength $attrlist]-$shift]) ||
+ ($colcount != [llength $colname]) ||
+ ($colcount != [llength $colwidth]) } then {
+ # No. of columns don't match, something is wrong
+ show_error "Layout info corrupted!"
+ set layout_found false
+ sql_exec quiet "delete from pga_layout where tablename='$tablename'"
+ }
+}
+if {$layout_found=="false"} {
+ set colcount [llength $attrlist]
+ if {$ds_updatable} then {incr colcount -1}
+ set colname {}
+ set colwidth {}
+ for {set i 0} {$i<$colcount} {incr i} {
+ lappend colname [lindex [lindex $attrlist [expr $i+$shift]] 0]
+ lappend colwidth 150
+ }
+ sql_exec quiet "insert into pga_layout values ('$layout_name',$colcount,'$colname','$colwidth')"
+}
+set nrecs [pg_result $pgres -numTuples]
+if {$nrecs>200} {
+ set msg "Only first 200 records from $nrecs have been loaded"
+ set nrecs 200
+}
+set tagoid {}
+for {set i 0} {$i<$nrecs} {incr i} {
+ set curtup [pg_result $pgres -getTuple $i]
+ if {$ds_updatable} then {set tagoid o[lindex $curtup 0]}
+ set posx 10
+ for {set j 0} {$j<$colcount} {incr j} {
+ set fldtext [lindex $curtup [expr $j+$shift]]
+ if {$fldtext==""} {set fldtext " "};
+ .mw.c create text $posx [expr 30+$i*14] -text $fldtext -tags [subst {$tagoid c$j rows}] -anchor w -font -*-Clean-Medium-R-Normal-*-*-130-*-*-*-*-*
+ incr posx [expr [lindex $colwidth $j]+2]
+ }
+}
+pg_result $pgres -clear
+set toprec 0
+set_scrollbar
+if {$ds_updatable} then {
+ .mw.c bind rows <Button-1> {show_entry [%W find closest %x %y]}
+} else {
+ .mw.c bind rows <Button-1> {bell}
+}
+set dirty false
+draw_headers
+cursor_arrow .mw
+}
+
+proc set_scrollbar {} {
+global nrecs toprec
+
+if {$nrecs==0} return;
+.mw.sb set [expr $toprec*1.0/$nrecs] [expr ($toprec+27.0)/$nrecs]
+}
+
+proc show_entry {id} {
+global dirty fldval msg itemid colname colwidth
+
+hide_entry
+set itemid $id
+set colidx [get_tag_info $id c]
+set fldval [.mw.c itemcget $id -text]
+set dirty false
+set coord [.mw.c coords $id]
+entry .mw.entf -textvar fldval -width [expr int(([lindex $colwidth $colidx]-5)/6.2)] -borderwidth 0 -background #ddfefe -highlightthickness 0 -selectborderwidth 0 -font -*-Clean-Medium-R-Normal-*-*-130-*-*-*-*-*;
+place .mw.entf -x [expr 4+[lindex $coord 0]] -y [expr 18+[lindex $coord 1]];
+focus .mw.entf
+bind .mw.entf <Return> {hide_entry}
+bind .mw.entf <Escape> {set dirty false;hide_entry;set msg {}}
+set msg "Editing field [lindex $colname $colidx]"
+after 2000 {set msg ""}
+}
+
+proc show_error {emsg} {
+tk_messageBox -title Error -icon error -message $emsg
+}
+
+proc sql_exec {how cmd} {
+global dbc
+set retval [catch {set pgr [pg_exec $dbc $cmd]} errmsg]
+if { $retval } {
+ if {$how != "quiet"} {
+ show_error "Error executing query\n\n$cmd\n\nPostgreSQL error message:\n$errmsg"
+ }
+ return 0
+}
+pg_result $pgr -clear
+return 1
+}
+
+proc tab_click {w} {
+global dbc tablist activetab
+if {$dbc==""} return;
+set curtab [$w cget -text]
+#if {$activetab==$curtab} return;
+if {$activetab!=""} {
+ place .dw.tab$activetab -x 10
+ .dw.tab$activetab configure -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*
+}
+$w configure -font -Adobe-Helvetica-Bold-R-Normal-*-*-120-*-*-*-*-*
+place $w -x 7
+place .dw.lmask -x 80 -y [expr 86+25*[lsearch -exact $tablist $curtab]]
+set activetab $curtab
+.dw.lb delete 0 end
+cmd_$curtab
+}
+
+proc main {argc argv} {
+load libpgtcl.so
+catch {draw_tabs}
+}
+
+proc Window {args} {
+global vTcl
+ set cmd [lindex $args 0]
+ set name [lindex $args 1]
+ set newname [lindex $args 2]
+ set rest [lrange $args 3 end]
+ if {$name == "" || $cmd == ""} {return}
+ if {$newname == ""} {
+ set newname $name
+ }
+ set exists [winfo exists $newname]
+ switch $cmd {
+ show {
+ if {$exists == "1" && $name != "."} {wm deiconify $name; return}
+ if {[info procs vTclWindow(pre)$name] != ""} {
+ eval "vTclWindow(pre)$name $newname $rest"
+ }
+ if {[info procs vTclWindow$name] != ""} {
+ eval "vTclWindow$name $newname $rest"
+ }
+ if {[info procs vTclWindow(post)$name] != ""} {
+ eval "vTclWindow(post)$name $newname $rest"
+ }
+ }
+ hide { if $exists {wm withdraw $newname; return} }
+ iconify { if $exists {wm iconify $newname; return} }
+ destroy { if $exists {destroy $newname; return} }
+ }
+}
+
+#################################
+# VTCL GENERATED GUI PROCEDURES
+#
+
+proc vTclWindow. {base} {
+ if {$base == ""} {
+ set base .
+ }
+ ###################
+ # CREATING WIDGETS
+ ###################
+ wm focusmodel $base passive
+ wm geometry $base 1x1+0+0
+ wm maxsize $base 1009 738
+ wm minsize $base 1 1
+ wm overrideredirect $base 0
+ wm resizable $base 1 1
+ wm withdraw $base
+ wm title $base "vt.tcl"
+ ###################
+ # SETTING GEOMETRY
+ ###################
+}
+
+proc vTclWindow.dbod {base} {
+ if {$base == ""} {
+ set base .dbod
+ }
+ if {[winfo exists $base]} {
+ wm deiconify $base; return
+ }
+ ###################
+ # CREATING WIDGETS
+ ###################
+ toplevel $base -class Toplevel \
+ -cursor top_left_arrow
+ wm focusmodel $base passive
+ wm geometry $base 282x128+353+310
+ wm maxsize $base 1009 738
+ wm minsize $base 1 1
+ wm overrideredirect $base 0
+ wm resizable $base 0 0
+ wm title $base "Open database"
+ label $base.lhost \
+ -borderwidth 0 \
+ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
+ -relief raised -text Host
+ entry $base.ehost \
+ -background #fefefe -borderwidth 1 -textvariable newhost
+ label $base.lport \
+ -borderwidth 0 \
+ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
+ -relief raised -text Port
+ entry $base.epport \
+ -background #fefefe -borderwidth 1 -textvariable newpport
+ label $base.ldbname \
+ -borderwidth 0 \
+ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
+ -relief raised -text Database
+ entry $base.edbname \
+ -background #fefefe -borderwidth 1 -textvariable newdbname
+ button $base.opbtu \
+ -borderwidth 1 -command open_database \
+ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \
+ -pady 3 -text Open
+ button $base.canbut \
+ -borderwidth 1 -command {Window hide .dbod} \
+ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \
+ -pady 3 -text Cancel
+ ###################
+ # SETTING GEOMETRY
+ ###################
+ place $base.lhost \
+ -x 35 -y 5 -anchor nw -bordermode ignore
+ place $base.ehost \
+ -x 100 -y 5 -anchor nw -bordermode ignore
+ place $base.lport \
+ -x 35 -y 30 -anchor nw -bordermode ignore
+ place $base.epport \
+ -x 100 -y 30 -anchor nw -bordermode ignore
+ place $base.ldbname \
+ -x 35 -y 60 -anchor nw -bordermode ignore
+ place $base.edbname \
+ -x 100 -y 55 -anchor nw -bordermode ignore
+ place $base.opbtu \
+ -x 70 -y 90 -width 60 -height 26 -anchor nw -bordermode ignore
+ place $base.canbut \
+ -x 150 -y 90 -width 60 -height 26 -anchor nw -bordermode ignore
+}
+
+proc vTclWindow.dw {base} {
+ if {$base == ""} {
+ set base .dw
+ }
+ if {[winfo exists $base]} {
+ wm deiconify $base; return
+ }
+ ###################
+ # CREATING WIDGETS
+ ###################
+ toplevel $base -class Toplevel \
+ -background #efefef
+ wm focusmodel $base passive
+ wm geometry $base 322x355+131+142
+ wm maxsize $base 1009 738
+ wm minsize $base 1 1
+ wm overrideredirect $base 0
+ wm resizable $base 0 0
+ wm deiconify $base
+ wm title $base "PostgreSQL access"
+ label $base.labframe \
+ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
+ -relief raised
+ listbox $base.lb \
+ -background #fefefe \
+ -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \
+ -highlightthickness 0 -selectborderwidth 0 \
+ -yscrollcommand {.dw.sb set}
+ button $base.btnnew \
+ -borderwidth 1 -command cmd_New \
+ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \
+ -pady 3 -text New
+ button $base.btnopen \
+ -borderwidth 1 -command cmd_Open \
+ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \
+ -pady 3 -text Open
+ button $base.btndesign \
+ -borderwidth 1 -command cmd_Design \
+ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \
+ -pady 3 -text Design
+ label $base.lmask \
+ -borderwidth 0 \
+ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
+ -relief raised -text { }
+ label $base.label22 \
+ -borderwidth 1 \
+ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
+ -relief raised
+ menubutton $base.menubutton23 \
+ -borderwidth 1 \
+ -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \
+ -menu .dw.menubutton23.01 -padx 4 -pady 3 -text Database
+ menu $base.menubutton23.01 \
+ -cursor {} -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \
+ -tearoff 0
+ $base.menubutton23.01 add command \
+ \
+ -command {set newhost $host
+set newpport $pport
+Window show .dbod
+focus .dbod.edbname} \
+ -label Open
+ $base.menubutton23.01 add command \
+ \
+ -command {.dw.lb delete 0 end
+set dbc {}
+set dbname {}
+set sdbname {}} \
+ -label Close
+ $base.menubutton23.01 add command \
+ -command cmd_Vacuum -label Vacuum
+ $base.menubutton23.01 add separator
+ $base.menubutton23.01 add command \
+ -command {cmd_Import_Export Import} -label {Import table}
+ $base.menubutton23.01 add command \
+ -command {cmd_Import_Export Export} -label {Export table}
+ $base.menubutton23.01 add separator
+ $base.menubutton23.01 add command \
+ -command { catch {pg_disconnect $dbc}; exit } -label Exit
+ label $base.lshost \
+ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
+ -relief groove -text localhost -textvariable host
+ label $base.lsdbname \
+ -anchor w -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
+ -relief groove -textvariable sdbname
+ scrollbar $base.sb \
+ -borderwidth 1 -command {.dw.lb yview} -orient vert
+ ###################
+ # SETTING GEOMETRY
+ ###################
+ place $base.labframe \
+ -x 80 -y 30 -width 236 -height 300 -anchor nw -bordermode ignore
+ place $base.lb \
+ -x 90 -y 75 -width 205 -height 248 -anchor nw -bordermode ignore
+ place $base.btnnew \
+ -x 90 -y 40 -width 60 -height 25 -anchor nw -bordermode ignore
+ place $base.btnopen \
+ -x 165 -y 40 -width 60 -height 25 -anchor nw -bordermode ignore
+ place $base.btndesign \
+ -x 235 -y 40 -width 60 -height 25 -anchor nw -bordermode ignore
+ place $base.lmask \
+ -x 155 -y 45 -height 23 -anchor nw -bordermode ignore
+ place $base.label22 \
+ -x 0 -y 0 -width 396 -height 23 -anchor nw -bordermode ignore
+ place $base.menubutton23 \
+ -x 0 -y 3 -width 63 -height 17 -anchor nw -bordermode ignore
+ place $base.lshost \
+ -x 3 -y 335 -width 91 -height 20 -anchor nw -bordermode ignore
+ place $base.lsdbname \
+ -x 95 -y 335 -width 223 -height 20 -anchor nw -bordermode ignore
+ place $base.sb \
+ -x 295 -y 75 -width 18 -height 249 -anchor nw -bordermode ignore
+}
+
+proc vTclWindow.iew {base} {
+ if {$base == ""} {
+ set base .iew
+ }
+ if {[winfo exists $base]} {
+ wm deiconify $base; return
+ }
+ ###################
+ # CREATING WIDGETS
+ ###################
+ toplevel $base -class Toplevel \
+ -cursor top_left_arrow
+ wm focusmodel $base passive
+ wm geometry $base 287x151+259+304
+ wm maxsize $base 1009 738
+ wm minsize $base 1 1
+ wm overrideredirect $base 0
+ wm resizable $base 0 0
+ wm title $base "Import-Export table"
+ label $base.l1 \
+ -borderwidth 0 \
+ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
+ -relief raised -text {Table name}
+ entry $base.e1 \
+ -background #fefefe -borderwidth 1 -textvariable ie_tablename
+ label $base.l2 \
+ -borderwidth 0 \
+ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
+ -relief raised -text {File name}
+ entry $base.e2 \
+ -background #fefefe -borderwidth 1 -textvariable ie_filename
+ label $base.l3 \
+ -borderwidth 0 \
+ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
+ -relief raised -text {Field delimiter}
+ entry $base.e3 \
+ -background #fefefe -borderwidth 1 -textvariable ie_delimiter
+ button $base.expbtn \
+ -borderwidth 1 \
+ -command {if {$ie_tablename==""} {
+ show_error "You have to supply a table name!"
+} elseif {$ie_filename==""} {
+ show_error "You have to supply a external file name!"
+} else {
+ if {$ie_delimiter==""} {
+ set sup ""
+ } else {
+ set sup " USING DELIMITERS '$ie_delimiter'"
+ }
+ if {[.iew.expbtn cget -text]=="Import"} {
+ set oper "FROM"
+ } else {
+ set oper "TO"
+ }
+ if {$oicb} {
+ set sup2 " WITH OIDS "
+ } else {
+ set sup2 ""
+ }
+ set sqlcmd "COPY $ie_tablename $sup2 $oper '$ie_filename'$sup"
+ cursor_watch .iew
+ if {[sql_exec noquiet $sqlcmd]} {
+ cursor_arrow .iew
+ tk_messageBox -title Information -message "Operation completed!"
+ Window hide .iew
+ }
+ cursor_arrow .iew
+}} \
+ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \
+ -pady 3 -text Export
+ button $base.cancelbtn \
+ -borderwidth 1 -command {Window hide .iew} \
+ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \
+ -pady 3 -text Cancel
+ checkbutton $base.oicb \
+ -borderwidth 1 \
+ -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \
+ -text {with OIDs} -variable oicb
+ ###################
+ # SETTING GEOMETRY
+ ###################
+ place $base.l1 \
+ -x 25 -y 15 -anchor nw -bordermode ignore
+ place $base.e1 \
+ -x 115 -y 10 -anchor nw -bordermode ignore
+ place $base.l2 \
+ -x 25 -y 45 -anchor nw -bordermode ignore
+ place $base.e2 \
+ -x 115 -y 40 -anchor nw -bordermode ignore
+ place $base.l3 \
+ -x 25 -y 75 -height 18 -anchor nw -bordermode ignore
+ place $base.e3 \
+ -x 115 -y 74 -width 33 -height 22 -anchor nw -bordermode ignore
+ place $base.expbtn \
+ -x 60 -y 110 -anchor nw -bordermode ignore
+ place $base.cancelbtn \
+ -x 155 -y 110 -anchor nw -bordermode ignore
+ place $base.oicb \
+ -x 170 -y 75 -anchor nw -bordermode ignore
+}
+
+proc vTclWindow.mw {base} {
+ if {$base == ""} {
+ set base .mw
+ }
+ if {[winfo exists $base]} {
+ wm deiconify $base; return
+ }
+ ###################
+ # CREATING WIDGETS
+ ###################
+ toplevel $base -class Toplevel -cursor top_left_arrow
+ wm focusmodel $base passive
+ wm geometry $base 631x452+152+213
+ wm maxsize $base 1009 738
+ wm minsize $base 1 1
+ wm overrideredirect $base 0
+ wm resizable $base 1 1
+ wm title $base "Table browser"
+ label $base.hoslbl -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text {Sort field}
+ button $base.fillbtn -borderwidth 1 -command {set nq $ds_query
+if {($ds_isaquery=="true") && ("$filter$sortfield"!="")} {
+ show_error "Sorting and filtering not (yet) available from queries!\n\nPlease enter them in the query definition!"
+ set sortfield {}
+ set filter {}
+} else {
+ if {$filter!=""} {
+ set nq "$ds_query where ($filter)"
+ } else {
+ set nq $ds_query
+ }
+ if {$sortfield!=""} {
+ set nq "$nq order by $sortfield"
+ }
+}
+select_records $nq} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text Reload
+ button $base.exitbtn -borderwidth 1 -command {.mw.c delete rows
+.mw.c delete header
+set sortfield {}
+set filter {}
+Window hide .mw} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text Exit
+ canvas $base.c -background #fefefe -borderwidth 2 -height 207 -relief ridge -width 295
+ label $base.msglbl -anchor w -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief sunken -textvariable msg
+ scrollbar $base.sb -borderwidth 1 -command scroll_window -orient vert
+ button $base.ert -borderwidth 1 -command pan_left -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text <
+ button $base.dfggfh -borderwidth 1 -command pan_right -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text >
+ entry $base.tbn -background #fefefe -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable filter
+ label $base.tbllbl -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text {Filter conditions}
+ entry $base.dben -background #fefefe -borderwidth 1 -highlightthickness 1 -textvariable sortfield
+ ###################
+ # SETTING GEOMETRY
+ ###################
+ place $base.hoslbl -x 5 -y 5 -anchor nw -bordermode ignore
+ place $base.fillbtn -x 487 -y 1 -height 25 -anchor nw -bordermode ignore
+ place $base.exitbtn -x 590 -y 1 -width 39 -height 25 -anchor nw -bordermode ignore
+ place $base.c -x 5 -y 25 -width 608 -height 405 -anchor nw -bordermode ignore
+ place $base.msglbl -x 9 -y 430 -width 616 -height 18 -anchor nw -bordermode ignore
+ place $base.sb -x 610 -y 26 -width 18 -height 404 -anchor nw -bordermode ignore
+ place $base.ert -x 552 -y 1 -width 20 -height 25 -anchor nw -bordermode ignore
+ place $base.dfggfh -x 570 -y 1 -width 20 -height 25 -anchor nw -bordermode ignore
+ place $base.tbn -x 280 -y 3 -width 203 -height 21 -anchor nw -bordermode ignore
+ place $base.tbllbl -x 180 -y 5 -anchor nw -bordermode ignore
+ place $base.dben -x 65 -y 3 -width 81 -height 21 -anchor nw -bordermode ignore
+}
+
+proc vTclWindow.nt {base} {
+ if {$base == ""} {
+ set base .nt
+ }
+ if {[winfo exists $base]} {
+ wm deiconify $base; return
+ }
+ ###################
+ # CREATING WIDGETS
+ ###################
+ toplevel $base -class Toplevel
+ wm focusmodel $base passive
+ wm geometry $base 628x239+143+203
+ wm maxsize $base 1009 738
+ wm minsize $base 1 1
+ wm overrideredirect $base 0
+ wm resizable $base 1 1
+ wm title $base "Create table"
+ entry $base.e1 -background #fefefe -borderwidth 1 -cursor {} -highlightthickness 1 -selectborderwidth 0 -textvariable fldtype
+ bind $base.e1 <Button-1> {
+ tk_popup .nt.pop %X %Y
+ }
+ label $base.lab1 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text {Field type}
+ label $base.lab2 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text {Field name}
+ entry $base.e2 -background #fefefe -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable fldname
+ label $base.lab3 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text {Field size}
+ entry $base.e3 -background #fefefe -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable fldsize
+ checkbutton $base.cb1 -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -offvalue { } -onvalue { NOT NULL} -text {field cannot be empty} -variable notnull
+ label $base.lab4 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text {Default value}
+ entry $base.e5 -background #fefefe -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable defaultval
+ button $base.addfld -borderwidth 1 -command {if {$fldname==""} {
+ show_error "Enter a field name"
+ focus .nt.e2
+} elseif {$fldtype==""} {
+ show_error "The field type is not specified!"
+} elseif {(($fldtype=="varchar")||($fldtype=="char"))&&($fldsize=="")} {
+ focus .nt.e3
+ show_error "You must specify field size!"
+} else {
+ if {$fldsize==""} then {set sup ""} else {set sup "($fldsize)"}
+ if {$defaultval==""} then {set sup2 ""} else {set sup2 " DEFAULT '$defaultval'"}
+ .nt.lb insert end [format "%-17s%-14s%-16s" $fldname $fldtype$sup $sup2$notnull]
+ focus .nt.e2
+ set fldname {}
+ set fldsize {}
+ set defaultval {}
+}} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text {Add field}
+ listbox $base.lb -background #fefefe -borderwidth 1 -font -*-Clean-Medium-R-Normal--*-130-*-*-*-*-*-* -highlightthickness 1 -selectborderwidth 0 -yscrollcommand {.nt.sb set}
+ button $base.emptb -borderwidth 1 -command {.nt.lb delete 0 [.nt.lb size]} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text {Delete all}
+ button $base.delfld -borderwidth 1 -command {catch {.nt.lb delete [.nt.lb curselection]}} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text {Delete field}
+ button $base.exitbtn -borderwidth 1 -command {Window hide .nt} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text Cancel
+ button $base.maketbl -borderwidth 1 -command {if {$newtablename==""} then {
+ show_error "You must supply a name for your table!"
+ focus .nt.etabn
+} elseif {[.nt.lb size]==0} then {
+ show_error "Your table has no fields!"
+ focus .nt.e2
+} else {
+ set temp "create table $newtablename ([join [.nt.lb get 0 end] ,])"
+ set retval [catch {
+ set pgres [pg_exec $dbc $temp]
+ pg_result $pgres -clear
+ } errmsg ]
+ if {$retval} {
+ show_error "Error creating table\n$errmsg"
+ } else {
+ .nt.lb delete 0 end
+ Window hide .nt
+ cmd_Tables
+ }
+}} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text {Create table}
+ label $base.l1 -anchor w -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text {field name}
+ label $base.l2 -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text type
+ label $base.l3 -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text options
+ scrollbar $base.sb -borderwidth 1 -command {.nt.lb yview} -orient vert
+ label $base.l93 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text {Table name}
+ entry $base.etabn -background #fefefe -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable newtablename
+ menu $base.pop -tearoff 0
+ $base.pop add command -command {set fldtype char; if {("char"=="varchar")||("char"=="char")} then {.nt.e3 configure -state normal;focus .nt.e3} else {.nt.e3 configure -state disabled;focus .nt.e5} } -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -label char
+ $base.pop add command -command {set fldtype char4; if {("char4"=="varchar")||("char4"=="char")} then {.nt.e3 configure -state normal;focus .nt.e3} else {.nt.e3 configure -state disabled;focus .nt.e5} } -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -label char4
+ $base.pop add command -command {set fldtype char8; if {("char8"=="varchar")||("char8"=="char")} then {.nt.e3 configure -state normal;focus .nt.e3} else {.nt.e3 configure -state disabled;focus .nt.e5} } -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -label char8
+ $base.pop add command -command {set fldtype char16; if {("char16"=="varchar")||("char16"=="char")} then {.nt.e3 configure -state normal;focus .nt.e3} else {.nt.e3 configure -state disabled;focus .nt.e5} } -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -label char16
+ $base.pop add command -command {set fldtype varchar; if {("varchar"=="varchar")||("varchar"=="char")} then {.nt.e3 configure -state normal;focus .nt.e3} else {.nt.e3 configure -state disabled;focus .nt.e5} } -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -label varchar
+ $base.pop add command -command {set fldtype text; if {("text"=="varchar")||("text"=="char")} then {.nt.e3 configure -state normal;focus .nt.e3} else {.nt.e3 configure -state disabled;focus .nt.e5} } -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -label text
+ $base.pop add command -command {set fldtype int2; if {("int2"=="varchar")||("int2"=="char")} then {.nt.e3 configure -state normal;focus .nt.e3} else {.nt.e3 configure -state disabled;focus .nt.e5} } -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -label int2
+ $base.pop add command -command {set fldtype int4; if {("int4"=="varchar")||("int4"=="char")} then {.nt.e3 configure -state normal;focus .nt.e3} else {.nt.e3 configure -state disabled;focus .nt.e5} } -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -label int4
+ $base.pop add command -command {set fldtype float4; if {("float4"=="varchar")||("float4"=="char")} then {.nt.e3 configure -state normal;focus .nt.e3} else {.nt.e3 configure -state disabled;focus .nt.e5} } -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -label float4
+ $base.pop add command -command {set fldtype float8; if {("float8"=="varchar")||("float8"=="char")} then {.nt.e3 configure -state normal;focus .nt.e3} else {.nt.e3 configure -state disabled;focus .nt.e5} } -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -label float8
+ $base.pop add command -command {set fldtype date; if {("date"=="varchar")||("date"=="char")} then {.nt.e3 configure -state normal;focus .nt.e3} else {.nt.e3 configure -state disabled;focus .nt.e5} } -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -label date
+ $base.pop add command -command {set fldtype datetime; if {("datetime"=="varchar")||("datetime"=="char")} then {.nt.e3 configure -state normal;focus .nt.e3} else {.nt.e3 configure -state disabled;focus .nt.e5} } -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -label datetime
+ ###################
+ # SETTING GEOMETRY
+ ###################
+ place $base.e1 -x 95 -y 65 -anchor nw -bordermode ignore
+ place $base.lab1 -x 10 -y 67 -anchor nw -bordermode ignore
+ place $base.lab2 -x 10 -y 45 -anchor nw -bordermode ignore
+ place $base.e2 -x 95 -y 40 -anchor nw -bordermode ignore
+ place $base.lab3 -x 10 -y 93 -anchor nw -bordermode ignore
+ place $base.e3 -x 95 -y 90 -anchor nw -bordermode ignore
+ place $base.cb1 -x 95 -y 135 -anchor nw -bordermode ignore
+ place $base.lab4 -x 10 -y 118 -anchor nw -bordermode ignore
+ place $base.e5 -x 95 -y 115 -anchor nw -bordermode ignore
+ place $base.lb -x 260 -y 25 -width 353 -height 206 -anchor nw -bordermode ignore
+ place $base.addfld -x 10 -y 175 -anchor nw -bordermode ignore
+ place $base.delfld -x 90 -y 175 -width 82 -anchor nw -bordermode ignore
+ place $base.emptb -x 175 -y 175 -anchor nw -bordermode ignore
+ place $base.exitbtn -x 175 -y 205 -width 77 -height 26 -anchor nw -bordermode ignore
+ place $base.maketbl -x 10 -y 205 -width 161 -height 26 -anchor nw -bordermode ignore
+ place $base.l1 -x 261 -y 9 -width 98 -height 18 -anchor nw -bordermode ignore
+ place $base.l2 -x 360 -y 9 -width 86 -height 18 -anchor nw -bordermode ignore
+ place $base.l3 -x 446 -y 9 -width 166 -height 18 -anchor nw -bordermode ignore
+ place $base.sb -x 610 -y 25 -width 18 -height 207 -anchor nw -bordermode ignore
+ place $base.l93 -x 10 -y 10 -anchor nw -bordermode ignore
+ place $base.etabn -x 95 -y 7 -anchor nw -bordermode ignore
+}
+
+proc vTclWindow.qb {base} {
+ if {$base == ""} {
+ set base .qb
+ }
+ if {[winfo exists $base]} {
+ wm deiconify $base; return
+ }
+ ###################
+ # CREATING WIDGETS
+ ###################
+ toplevel $base -class Toplevel
+ wm focusmodel $base passive
+ wm geometry $base 442x344+256+232
+ wm maxsize $base 1009 738
+ wm minsize $base 1 1
+ wm overrideredirect $base 0
+ wm resizable $base 1 1
+ wm title $base "Query builder"
+ label $base.lqn -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text {Query name}
+ entry $base.eqn -background #fefefe -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable queryname
+ button $base.savebtn -borderwidth 1 -command {if {$queryname==""} then {
+ show_error "You have to supply a name for this query!"
+ focus .qb.eqn
+} else {
+ set qcmd [.qb.text1 get 1.0 end]
+ regsub -all "\n" $qcmd " " qcmd
+ regsub -all "'" $qcmd "''" qcmd
+ if {$qcmd==""} then {
+ show_error "This query has no commands ?"
+ } else {
+ set retval [catch {
+ if {$queryoid==0} then {
+ set pgres [pg_exec $dbc "insert into pga_queries values ('$queryname','$qtype','$qcmd')"]
+ } else {
+ set pgres [pg_exec $dbc "update pga_queries set queryname='$queryname',querytype='$qtype',querycommand='$qcmd' where oid=$queryoid"]
+ }
+ } errmsg]
+ if {$retval} then {
+ show_error "Error executing query\n$errmsg"
+ } else {
+ cmd_Queries
+ if {$queryoid==0} {set queryoid [pg_result $pgres -oid]}
+ }
+ catch {pg_result $pgres -clear}
+ }
+}} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text {Save query definition}
+ button $base.execbtn -borderwidth 1 -command {Window show .mw
+set qcmd [.qb.text1 get 0.0 end]
+regsub -all "\n" $qcmd " " qcmd
+set layout_name $queryname
+load_layout $queryname
+set ds_query $qcmd
+set ds_updatable false
+set ds_isaquery true
+select_records $qcmd} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text {Execute query}
+ radiobutton $base.qt1 -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -text {Select query} -value S -variable qtype
+ radiobutton $base.qt2 -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -text {Insert,update,delete query} -value A -variable qtype
+ button $base.termbtn -borderwidth 1 -command {Window hide .qb} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text Close
+ text $base.text1 -background #fefefe -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*
+ ###################
+ # SETTING GEOMETRY
+ ###################
+ place $base.lqn -x 5 -y 5 -anchor nw -bordermode ignore
+ place $base.eqn -x 80 -y 1 -width 355 -height 24 -anchor nw -bordermode ignore
+ place $base.savebtn -x 5 -y 60 -anchor nw -bordermode ignore
+ place $base.execbtn -x 150 -y 60 -anchor nw -bordermode ignore
+ place $base.qt1 -x 5 -y 30 -anchor nw -bordermode ignore
+ place $base.qt2 -x 145 -y 30 -anchor nw -bordermode ignore
+ place $base.termbtn -x 255 -y 60 -anchor nw -bordermode ignore
+ place $base.text1 -x 5 -y 90 -width 430 -height 246 -anchor nw -bordermode ignore
+}
+
+Window show .
+Window show .dw
+
+main $argc $argv
projects / postgresql / commitdiff