Skip to content

P
Postgres FD Implementation
Commit ed966c46 authored by Bruce Momjian's avatar Bruce Momjian
Browse files
Options

Updates for 6.2.1. Update pgaccess to 0.61. Add to HISTORY.

parent 05a436b3
Show whitespace changes
Inline Side-by-side
Showing with 847 additions and 501 deletions
HISTORY
View file @ ed966c46
...@@ -14,6 +14,7 @@ fix for buffer cache reference count problem(Vadim) ...@@ -14,6 +14,7 @@ fix for buffer cache reference count problem(Vadim)
Allow strings to span lines, like ANSI(Thomas) Allow strings to span lines, like ANSI(Thomas)
Fix for backward ORDER BY(Vadim) Fix for backward ORDER BY(Vadim)
Fix avg(cash) computation(Thomas) Fix avg(cash) computation(Thomas)
Fix for specifying a column twice in ORDER BY(Vadim)
PostgreSQL 6.2 Thu Oct 02 12:53:46 EDT 1997 PostgreSQL 6.2 Thu Oct 02 12:53:46 EDT 1997
......
src/bin/pgaccess/README
View file @ ed966c46
---------------------------------------------------------------------------
...@@ -23,7 +24,7 @@ PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. ...@@ -23,7 +24,7 @@ PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
PGACCESS 0.51 , 3 October 1997 PGACCESS 0.61 , 14 October 1997
================================ ================================
I dedicate this program to my little 4 year daughter Ana-Maria and my wife I dedicate this program to my little 4 year daughter Ana-Maria and my wife
for their understanding. I hope they will forgive me for spending so many for their understanding. I hope they will forgive me for spending so many
...@@ -83,6 +84,8 @@ pgaccess.tcl file. ...@@ -83,6 +84,8 @@ pgaccess.tcl file.
Tables Tables
- opening tables for vieweing, max 200 records - opening tables for vieweing, max 200 records
- column resizing by dragging the vertical grid lines - column resizing by dragging the vertical grid lines
- text will wrap in cells now
- dynamic row height when editing
- table layout saved for every table - table layout saved for every table
- import/export to external files (SDF,CSV) - import/export to external files (SDF,CSV)
- filter capabilities ,enter filter like price>3.14 - filter capabilities ,enter filter like price>3.14
...@@ -92,7 +95,7 @@ Tables ...@@ -92,7 +95,7 @@ Tables
- adding new records ,save new row with right-button-click on table for the moment - adding new records ,save new row with right-button-click on table for the moment
- table generator assistant lizzard :-) (not wizzard) - table generator assistant lizzard :-) (not wizzard)
- table renaming and deleting (dropping) - table renaming and deleting (dropping)
- table information retrieving : owner, field information - table information retrieving : owner, field information, indexes
Queries Queries
- define, edit and store "user defined queries" - define, edit and store "user defined queries"
......
src/bin/pgaccess/pgaccess.tcl
View file @ ed966c46
...@@ -9,8 +9,7 @@ ...@@ -9,8 +9,7 @@
global activetab; global activetab;
global dbc; global dbc;
global dbname; global dbname;
global dirty; global mw;
global fldval;
global host; global host;
global newdbname; global newdbname;
global newhost; global newhost;
...@@ -26,15 +25,17 @@ global widget; ...@@ -26,15 +25,17 @@ global widget;
# USER DEFINED PROCEDURES # USER DEFINED PROCEDURES
# #
proc init {argc argv} { proc init {argc argv} {
global dbc host pport tablist dirty fldval activetab qlvar global dbc host pport tablist mw fldval activetab qlvar
foreach wid {Label Text Button Listbox Checkbutton Radiobutton} {
option add *$wid.font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*
}
set host localhost set host localhost
set pport 5432 set pport 5432
set dbc {} set dbc {}
set tablist [list Tables Queries Views Sequences Functions Reports Scripts] set tablist [list Tables Queries Views Sequences Functions Reports Scripts]
set activetab {} set activetab {}
set dirty false set mw(dirtyrec) 0
set fldval "" set mw(id_edited) {}
trace variable fldval w mark_dirty
catch {unset qlvar} catch {unset qlvar}
set qlvar(yoffs) 360 set qlvar(yoffs) 360
set qlvar(xoffs) 50 set qlvar(xoffs) 50
...@@ -180,24 +181,40 @@ if {$activetab=="Tables"} { ...@@ -180,24 +181,40 @@ if {$activetab=="Tables"} {
} }
proc cmd_Information {} { proc cmd_Information {} {
global dbc tiw activetab global dbc tiw activetab indexlist
if {$dbc==""} return; if {$dbc==""} return;
if {$activetab!="Tables"} return; if {$activetab!="Tables"} return;
set tiw(tablename) [get_dwlb_Selection] set tiw(tablename) [get_dwlb_Selection]
if {$tiw(tablename)==""} return; if {$tiw(tablename)==""} return;
Window show .tiw Window show .tiw
.tiw.lb delete 0 end .tiw.lb delete 0 end
pg_select $dbc "select attnum,attname,typname,attlen,usename from pg_class,pg_user,pg_attribute,pg_type where (pg_class.relname='$tiw(tablename)') and (pg_class.oid=pg_attribute.attrelid) and (pg_class.relowner=pg_user.usesysid) and (pg_attribute.atttypid=pg_type.oid) and (attnum>0) order by attnum" rec { .tiw.ilb delete 0 end
set tiw(isunique) {}
set tiw(isclustered) {}
set tiw(indexfields) {}
pg_select $dbc "select attnum,attname,typname,attlen,usename,pg_class.oid from pg_class,pg_user,pg_attribute,pg_type where (pg_class.relname='$tiw(tablename)') and (pg_class.oid=pg_attribute.attrelid) and (pg_class.relowner=pg_user.usesysid) and (pg_attribute.atttypid=pg_type.oid) order by attnum" rec {
set fsize $rec(attlen) set fsize $rec(attlen)
set ftype $rec(typname) set ftype $rec(typname)
if {$ftype=="varchar"} { if {$ftype=="varchar"} {
incr fsize -4 incr fsize -4
} }
if {$ftype=="bpchar"} {
incr fsize -4
}
if {$ftype=="text"} { if {$ftype=="text"} {
set fsize "" set fsize ""
} }
.tiw.lb insert end [format "%-32s %-14s %-4s" $rec(attname) $ftype $fsize] if {$rec(attnum)>0} {.tiw.lb insert end [format "%-32s %-14s %-4s" $rec(attname) $ftype $fsize]}
set tiw(owner) $rec(usename) set tiw(owner) $rec(usename)
set tiw(tableoid) $rec(oid)
set tiw(f$rec(attnum)) $rec(attname)
}
set tiw(indexlist) {}
pg_select $dbc "select oid,indexrelid from pg_index where (pg_class.relname='$tiw(tablename)') and (pg_class.oid=pg_index.indrelid)" rec {
lappend tiw(indexlist) $rec(oid)
pg_select $dbc "select relname from pg_class where oid=$rec(indexrelid)" rec1 {
.tiw.ilb insert end $rec1(relname)
}
} }
} }
...@@ -348,20 +365,28 @@ catch { ...@@ -348,20 +365,28 @@ catch {
cursor_arrow .dw cursor_arrow .dw
} }
proc color_record {obj} { proc mw_show_record {row} {
global newrec_fields global mw msg
set oid [get_tag_info $obj o] set mw(errorsavingnew) 0
if {![hide_entry]} return; if {$mw(newrec_fields)!=""} {
if {$newrec_fields!=""} { if {$row!=$mw(last_rownum)} {
if {[get_tag_info $obj n]!="ew"} { if {![mw_save_new_record]} {
if {![save_new_record]} return; set mw(errorsavingnew) 1
return
}
} }
} }
.mw.c itemconfigure hili -fill black set y1 [lindex $mw(rowy) $row]
if {$oid==0} return; set y2 [lindex $mw(rowy) [expr $row+1]]
if {$y2==""} {set y2 [expr $y1+14]}
.mw.c dtag hili hili .mw.c dtag hili hili
.mw.c addtag hili withtag o$oid .mw.c addtag hili withtag r$row
.mw.c itemconfigure hili -fill blue # Making a rectangle arround the record
set x 3
foreach wi $mw(colwidth) {incr x [expr $wi+2]}
.mw.c delete crtrec
.mw.c create rectangle [expr -1-$mw(leftoffset)] $y1 [expr $x-$mw(leftoffset)] $y2 -fill #EEEEEE -outline {} -tags {q crtrec}
.mw.c lower crtrec
} }
proc cursor_arrow {w} { proc cursor_arrow {w} {
...@@ -388,14 +413,15 @@ set lispar [join $lispar ,] ...@@ -388,14 +413,15 @@ set lispar [join $lispar ,]
sql_exec noquiet "drop function $objname ($lispar)" sql_exec noquiet "drop function $objname ($lispar)"
} }
proc delete_record {} { proc mw_delete_record {} {
global dbc ds_updatable tablename global dbc mw tablename
if {$ds_updatable=="false"} return; if {!$mw(updatable)} return;
if {![hide_entry]} return; if {![mw_exit_edit]} return;
set taglist [.mw.c gettags hili] set taglist [.mw.c gettags hili]
if {[llength $taglist]==0} return; if {[llength $taglist]==0} return;
set oidtag [lindex $taglist [lsearch -regexp $taglist "^o"]] set rowtag [lindex $taglist [lsearch -regexp $taglist "^r"]]
set oid [string range $oidtag 1 end] set row [string range $rowtag 1 end]
set oid [lindex $mw(keylist) $row]
if {[tk_messageBox -title "FINAL WARNING" -icon question -message "Delete current record ?" -type yesno -default no]=="no"} return if {[tk_messageBox -title "FINAL WARNING" -icon question -message "Delete current record ?" -type yesno -default no]=="no"} return
if {[sql_exec noquiet "delete from $tablename where oid=$oid"]} { if {[sql_exec noquiet "delete from $tablename where oid=$oid"]} {
.mw.c delete hili .mw.c delete hili
...@@ -428,52 +454,52 @@ set draglocation(start) $x ...@@ -428,52 +454,52 @@ set draglocation(start) $x
} }
proc drag_stop {w x y} { proc drag_stop {w x y} {
global draglocation colcount colwidth layout_name dbc global draglocation mw dbc
set dlo "" set dlo ""
catch { set dlo $draglocation(obj) } catch { set dlo $draglocation(obj) }
if {$dlo != ""} { if {$dlo != ""} {
.mw.c bind movable <Leave> {.mw configure -cursor top_left_arrow} .mw.c bind movable <Leave> {.mw configure -cursor top_left_arrow}
.mw configure -cursor top_left_arrow .mw configure -cursor top_left_arrow
set ctr [get_tag_info $draglocation(obj) g] set ctr [get_tag_info $draglocation(obj) v]
set diff [expr $x-$draglocation(start)] set diff [expr $x-$draglocation(start)]
if {$diff==0} return; if {$diff==0} return;
set newcw {} set newcw {}
for {set i 0} {$i<$colcount} {incr i} { for {set i 0} {$i<$mw(colcount)} {incr i} {
if {$i==$ctr} { if {$i==$ctr} {
lappend newcw [expr [lindex $colwidth $i]+$diff] lappend newcw [expr [lindex $mw(colwidth) $i]+$diff]
} else { } else {
lappend newcw [lindex $colwidth $i] lappend newcw [lindex $mw(colwidth) $i]
} }
} }
set colwidth $newcw set mw(colwidth) $newcw
draw_headers .mw.c itemconfigure c$ctr -width [expr [lindex $mw(colwidth) $ctr]-5]
for {set i [expr $ctr+1]} {$i<$colcount} {incr i} { mw_draw_headers
mw_draw_hgrid
if {$mw(crtrow)!=""} {mw_show_record $mw(crtrow)}
for {set i [expr $ctr+1]} {$i<$mw(colcount)} {incr i} {
.mw.c move c$i $diff 0 .mw.c move c$i $diff 0
} }
cursor_watch .mw cursor_watch .mw
sql_exec quiet "update pga_layout set colwidth='$colwidth' where tablename='$layout_name'" sql_exec quiet "update pga_layout set colwidth='$mw(colwidth)' where tablename='$mw(layout_name)'"
cursor_arrow .mw cursor_arrow .mw
} }
} }
proc draw_headers {} { proc mw_draw_headers {} {
global colcount colname colwidth global mw
.mw.c delete header .mw.c delete header
set posx 5 set posx [expr 5-$mw(leftoffset)]
for {set i 0} {$i<$colcount} {incr i} { for {set i 0} {$i<$mw(colcount)} {incr i} {
set xf [expr $posx+[lindex $colwidth $i]] set xf [expr $posx+[lindex $mw(colwidth) $i]]
.mw.c create rectangle $posx 3 $xf 22 -fill #CCCCCC -outline "" -width 0 -tags header .mw.c create rectangle $posx 1 $xf 22 -fill #CCCCCC -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 text [expr $posx+[lindex $mw(colwidth) $i]*1.0/2] 14 -text [lindex $mw(colnames) $i] -tags header -fill navy -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*
.mw.c create line $posx 22 [expr $xf-1] 22 -fill #AAAAAA -tags header .mw.c create line $posx 22 [expr $xf-1] 22 -fill #AAAAAA -tags header
.mw.c create line [expr $xf-1] 5 [expr $xf-1] 22 -fill #AAAAAA -tags header .mw.c create line [expr $xf-1] 5 [expr $xf-1] 22 -fill #AAAAAA -tags header
.mw.c create line [expr $xf+1] 5 [expr $xf+1] 22 -fill white -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 #CCCCCC -tags [subst {header movable g$i}] .mw.c create line $xf -15000 $xf 15000 -fill #CCCCCC -tags [subst {header movable v$i}]
set posx [expr $xf+2] set posx [expr $xf+2]
} }
for {set i 0} {$i < 100} {incr i} { set mw(r_edge) $posx
.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 <Button-1> {drag_start %W %x %y}
.mw.c bind movable <B1-Motion> {drag_it %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} .mw.c bind movable <ButtonRelease-1> {drag_stop %W %x %y}
...@@ -481,13 +507,22 @@ for {set i 0} {$i < 100} {incr i} { ...@@ -481,13 +507,22 @@ for {set i 0} {$i < 100} {incr i} {
.mw.c bind movable <Leave> {.mw configure -cursor top_left_arrow} .mw.c bind movable <Leave> {.mw configure -cursor top_left_arrow}
} }
proc draw_new_record {} { proc mw_draw_new_record {} {
global ds_updatable last_rownum colwidth colcount global mw pref
set posx 10 set posx 10
if {$ds_updatable} {for {set j 0} {$j<$colcount} {incr j} { set posy [lindex $mw(rowy) $mw(last_rownum)]
.mw.c create text $posx [expr 30+$last_rownum*14] -text * -tags [subst {o0 c$j rows new unt}] -anchor w -font -*-Clean-Medium-R-Normal-*-*-130-*-*-*-*-* if {$pref(tvfont)=="helv"} {
incr posx [expr [lindex $colwidth $j]+2] set tvfont -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*
} else {
set tvfont -*-Clean-Medium-R-Normal-*-*-130-*-*-*-*-*
}
if {$mw(updatable)} {for {set j 0} {$j<$mw(colcount)} {incr j} {
.mw.c create text $posx $posy -text * -tags [subst {r$mw(nrecs) c$j q new unt}] -anchor nw -font $tvfont -width [expr [lindex $mw(colwidth) $j]-5]
incr posx [expr [lindex $mw(colwidth) $j]+2]
} }
incr posy 14
lappend mw(rowy) $posy
.mw.c create line [expr -$mw(leftoffset)] $posy [expr $mw(r_edge)-$mw(leftoffset)] $posy -fill gray -tags [subst {hgrid g$mw(nrecs)}]
} }
} }
...@@ -504,6 +539,37 @@ foreach tab $tablist { ...@@ -504,6 +539,37 @@ foreach tab $tablist {
set activetab "" set activetab ""
} }
proc mw_edit_text {c k} {
global mw msg
set bbin [.mw.c bbox r$mw(row_edited)]
switch $k {
BackSpace { set dp [expr [.mw.c index $mw(id_edited) insert]-1];if {$dp>=0} {.mw.c dchars $mw(id_edited) $dp $dp; set mw(dirtyrec) 1}}
Home {.mw.c icursor $mw(id_edited) 0}
End {.mw.c icursor $mw(id_edited) end}
Left {.mw.c icursor $mw(id_edited) [expr [.mw.c index $mw(id_edited) insert]-1]}
Delete {}
Right {.mw.c icursor $mw(id_edited) [expr [.mw.c index $mw(id_edited) insert]+1]}
Return {if {[mw_exit_edit]} {.mw.c focus {}}}
Escape {set mw(dirtyrec) 0; .mw.c itemconfigure $mw(id_edited) -text $mw(text_initial_value); .mw.c focus {}}
default {if {[string compare $c " "]>-1} {.mw.c insert $mw(id_edited) insert $c;set mw(dirtyrec) 1}}
}
set bbout [.mw.c bbox r$mw(row_edited)]
set dy [expr [lindex $bbout 3]-[lindex $bbin 3]]
if {$dy==0} return
set re $mw(row_edited)
.mw.c move g$re 0 $dy
for {set i [expr 1+$re]} {$i<=$mw(nrecs)} {incr i} {
.mw.c move r$i 0 $dy
.mw.c move g$i 0 $dy
set rh [lindex $mw(rowy) $i]
incr rh $dy
set mw(rowy) [lreplace $mw(rowy) $i $i $rh]
}
mw_show_record $mw(row_edited)
# Delete is trapped by window interpreted as record delete
# Delete {.mw.c dchars $mw(id_edited) insert insert; set mw(dirtyrec) 1}
}
proc get_dwlb_Selection {} { proc get_dwlb_Selection {} {
set temp [.dw.lb curselection] set temp [.dw.lb curselection]
if {$temp==""} return ""; if {$temp==""} return "";
...@@ -526,66 +592,84 @@ set thetag [lindex $taglist $i] ...@@ -526,66 +592,84 @@ set thetag [lindex $taglist $i]
return [string range $thetag 1 end] return [string range $thetag 1 end]
} }
proc hide_entry {} { proc mw_exit_edit {} {
global dirty dbc msg fldval itemid colname tablename global mw dbc msg tablename
global newrec_fields newrec_values # User has edited the text ?
if {!$mw(dirtyrec)} {
if {$dirty} { # No, unfocus text
cursor_watch .mw .mw.c focus {}
set oid [get_tag_info $itemid o] # For restoring * to the new record position
set fld [lindex $colname [get_tag_info $itemid c]] if {$mw(id_edited)!=""} {
set fldval [string trim $fldval] if {[lsearch [.mw.c gettags $mw(id_edited)] new]!=-1} {
set fillcolor black .mw.c itemconfigure $mw(id_edited) -text $mw(text_initial_value)
if {$oid==0} { }
}
set mw(id_edited) {};set mw(text_initial_value) {}
return 1
}
# Trimming the spaces
set fldval [string trim [.mw.c itemcget $mw(id_edited) -text]]
.mw.c itemconfigure $mw(id_edited) -text $fldval
if {[string compare $mw(text_initial_value) $fldval]==0} {
set mw(dirtyrec) 0
.mw.c focus {}
set mw(id_edited) {};set mw(text_initial_value) {}
return 1
}
cursor_watch .mw
set oid [lindex $mw(keylist) $mw(row_edited)]
set fld [lindex $mw(colnames) [get_tag_info $mw(id_edited) c]]
set fillcolor black
if {$mw(row_edited)==$mw(last_rownum)} {
set fillcolor red set fillcolor red
set sfp [lsearch $newrec_fields $fld] set sfp [lsearch $mw(newrec_fields) $fld]
if {$sfp>-1} { if {$sfp>-1} {
set newrec_fields [lreplace $newrec_fields $sfp $sfp] set mw(newrec_fields) [lreplace $mw(newrec_fields) $sfp $sfp]
set newrec_values [lreplace $newrec_values $sfp $sfp] set mw(newrec_values) [lreplace $mw(newrec_values) $sfp $sfp]
} }
lappend newrec_fields $fld lappend mw(newrec_fields) $fld
lappend newrec_values '$fldval' lappend mw(newrec_values) '$fldval'
# Remove the untouched tag from the object # Remove the untouched tag from the object
.mw.c dtag $itemid unt .mw.c dtag $mw(id_edited) unt
.mw.c itemconfigure $mw(id_edited) -fill red
set retval 1 set retval 1
} else { } else {
set msg "Updating record ..." set msg "Updating record ..."
after 1000 {set msg ""} after 1000 {set msg ""}
set retval [sql_exec noquiet "update $tablename set $fld='$fldval' where oid=$oid"] set retval [sql_exec noquiet "update $tablename set $fld='$fldval' where oid=$oid"]
} }
cursor_arrow .mw cursor_arrow .mw
if {!$retval} { if {!$retval} {
set msg "" set msg ""
focus .mw.c
return 0 return 0
}
.mw.c itemconfigure $itemid -text $fldval -fill $fillcolor
} }
catch {destroy .mw.entf} set mw(dirtyrec) 0
set dirty false .mw.c focus {}
set mw(id_edited) {};set mw(text_initial_value) {}
return 1 return 1
} }
proc load_layout {tablename} { proc mw_load_layout {tablename} {
global dbc msg colcount colname colwidth layout_found layout_name global dbc msg mw
cursor_watch .mw cursor_watch .mw
set layout_name $tablename set mw(layout_name) $tablename
catch {unset colcount colname colwidth} catch {unset mw(colcount) mw(colnames) mw(colwidth)}
set layout_found false set mw(layout_found) 0
set retval [catch {set pgres [pg_exec $dbc "select *,oid from pga_layout where tablename='$tablename' order by oid desc"]}] set retval [catch {set pgres [pg_exec $dbc "select *,oid from pga_layout where tablename='$tablename' order by oid desc"]}]
if {$retval} { if {$retval} {
# Probably table pga_layout isn't yet defined # 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 noquiet "create table pga_layout (tablename varchar(64),nrcols int2,colnames text,colwidth text)"
sql_exec quiet "grant ALL on pga_layout to PUBLIC" sql_exec quiet "grant ALL on pga_layout to PUBLIC"
} else { } else {
set nrlay [pg_result $pgres -numTuples] set nrlay [pg_result $pgres -numTuples]
if {$nrlay>=1} { if {$nrlay>=1} {
set layoutinfo [pg_result $pgres -getTuple 0] set layoutinfo [pg_result $pgres -getTuple 0]
set colcount [lindex $layoutinfo 1] set mw(colcount) [lindex $layoutinfo 1]
set colname [lindex $layoutinfo 2] set mw(colnames) [lindex $layoutinfo 2]
set colwidth [lindex $layoutinfo 3] set mw(colwidth) [lindex $layoutinfo 3]
set goodoid [lindex $layoutinfo 4] set goodoid [lindex $layoutinfo 4]
set layout_found true set mw(layout_found) 1
} }
if {$nrlay>1} { if {$nrlay>1} {
show_error "Multiple ([pg_result $pgres -numTuples]) layout info found\n\nPlease report the bug!" show_error "Multiple ([pg_result $pgres -numTuples]) layout info found\n\nPlease report the bug!"
...@@ -615,18 +699,62 @@ if {$retval} { ...@@ -615,18 +699,62 @@ if {$retval} {
} }
proc load_table {objname} { proc load_table {objname} {
global ds_query ds_updatable ds_isaquery sortfield filter tablename global mw sortfield filter tablename
set tablename $objname set tablename $objname
load_layout $objname mw_load_layout $objname
set ds_query "select oid,$tablename.* from $objname" set mw(query) "select oid,$tablename.* from $objname"
set ds_updatable true set mw(updatable) 1
set ds_isaquery false set mw(isaquery) 0
select_records $ds_query mw_select_records $mw(query)
wm title .mw "Table viewer : $objname"
}
proc mw_canvas_click {x y} {
global mw msg
if {![mw_exit_edit]} return
# Determining row
for {set row 0} {$row<$mw(nrecs)} {incr row} {
if {[lindex $mw(rowy) $row]>$y} break
}
incr row -1
if {$y>[lindex $mw(rowy) $mw(last_rownum)]} {set row $mw(last_rownum)}
if {$row<0} return
set mw(row_edited) $row
set mw(crtrow) $row
mw_show_record $row
if {$mw(errorsavingnew)} return
# Determining column
set posx [expr -$mw(leftoffset)]
set col 0
foreach cw $mw(colwidth) {
incr posx [expr $cw+2]
if {$x<$posx} break
incr col
}
set itlist [.mw.c find withtag r$row]
foreach item $itlist {
if {[get_tag_info $item c]==$col} {
mw_start_edit $item $x $y
break
}
}
} }
proc mark_dirty {name1 name2 op} { proc mw_start_edit {id x y} {
global dirty global mw msg
set dirty true if {!$mw(updatable)} return
set mw(id_edited) $id
set mw(dirtyrec) 0
set mw(text_initial_value) [.mw.c itemcget $id -text]
focus .mw.c
.mw.c focus $id
.mw.c icursor $id @$x,$y
if {$mw(row_edited)==$mw(nrecs)} {
if {[.mw.c itemcget $id -text]=="*"} {
.mw.c itemconfigure $id -text ""
.mw.c icursor $id 0
}
}
} }
proc open_database {} { proc open_database {} {
...@@ -679,7 +807,7 @@ set funcpar [join $funcpar ,] ...@@ -679,7 +807,7 @@ set funcpar [join $funcpar ,]
} }
proc open_query {how} { proc open_query {how} {
global dbc queryname layout_found queryoid ds_query ds_updatable ds_isaquery sortfield filter global dbc queryname mw queryoid sortfield filter
if {[.dw.lb curselection]==""} return; if {[.dw.lb curselection]==""} return;
set queryname [.dw.lb get [.dw.lb curselection]] set queryname [.dw.lb get [.dw.lb curselection]]
...@@ -704,11 +832,12 @@ if {$how=="design"} { ...@@ -704,11 +832,12 @@ if {$how=="design"} {
} else { } else {
if {$qtype=="S"} then { if {$qtype=="S"} then {
Window show .mw Window show .mw
load_layout $queryname wm title .mw "Query result: $queryname"
set ds_query $qcmd mw_load_layout $queryname
set ds_updatable false set mw(query) $qcmd
set ds_isaquery true set mw(updatable) 0
select_records $qcmd set mw(isaquery) 1
mw_select_records $qcmd
} else { } 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?"] 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 {$answ} {
...@@ -746,37 +875,39 @@ if {$flag} { ...@@ -746,37 +875,39 @@ if {$flag} {
} }
proc open_view {} { proc open_view {} {
global ds_query ds_updatable ds_isaquery global mw
set vn [get_dwlb_Selection] set vn [get_dwlb_Selection]
if {$vn==""} return; if {$vn==""} return;
Window show .mw Window show .mw
set ds_query "select * from $vn" set mw(query) "select * from $vn"
set ds_isaquery false set mw(isaquery) 0
set ds_updatable false set mw(updatable) 0
load_layout $vn mw_load_layout $vn
select_records $ds_query mw_select_records $mw(query)
} }
proc pan_left {} { proc mw_pan_left {} {
global leftcol leftoffset colwidth colcount global mw
if {![hide_entry]} return; if {![mw_exit_edit]} return;
if {$leftcol==[expr $colcount-1]} return; if {$mw(leftcol)==[expr $mw(colcount)-1]} return;
set diff [expr 2+[lindex $colwidth $leftcol]] set diff [expr 2+[lindex $mw(colwidth) $mw(leftcol)]]
incr leftcol incr mw(leftcol)
incr leftoffset $diff incr mw(leftoffset) $diff
.mw.c move header -$diff 0 .mw.c move header -$diff 0
.mw.c move rows -$diff 0 .mw.c move q -$diff 0
.mw.c move hgrid -$diff 0
} }
proc pan_right {} { proc mw_pan_right {} {
global leftcol leftoffset colcount colwidth global mw
if {![hide_entry]} return; if {![mw_exit_edit]} return;
if {$leftcol==0} return; if {$mw(leftcol)==0} return;
incr leftcol -1 incr mw(leftcol) -1
set diff [expr 2+[lindex $colwidth $leftcol]] set diff [expr 2+[lindex $mw(colwidth) $mw(leftcol)]]
incr leftoffset -$diff incr mw(leftoffset) -$diff
.mw.c move header $diff 0 .mw.c move header $diff 0
.mw.c move rows $diff 0 .mw.c move q $diff 0
.mw.c move hgrid $diff 0
} }
proc ql_add_new_table {} { proc ql_add_new_table {} {
...@@ -856,42 +987,56 @@ global qlvar ...@@ -856,42 +987,56 @@ global qlvar
# Checking if there # Checking if there
set obj [.ql.c find withtag hili] set obj [.ql.c find withtag hili]
if {$obj==""} return if {$obj==""} return
# Is object a link ?
if {[ql_get_tag_info $obj link]=="s"} { if {[ql_get_tag_info $obj link]=="s"} {
if {[tk_messageBox -title WARNING -icon question -message "Remove link ?" -type yesno -default no]=="no"} return if {[tk_messageBox -title WARNING -icon question -message "Remove link ?" -type yesno -default no]=="no"} return
set linkid [ql_get_tag_info $obj lkid] set linkid [ql_get_tag_info $obj lkid]
set qlvar(links) [lreplace $qlvar(links) $linkid $linkid] set qlvar(links) [lreplace $qlvar(links) $linkid $linkid]
.ql.c delete links .ql.c delete links
ql_draw_links ql_draw_links
} else { }
set tablename [ql_get_tag_info $obj tab] # Is object a result field ?
if {$tablename==""} return if {[ql_get_tag_info $obj res]=="f"} {
if {[tk_messageBox -title WARNING -icon question -message "Remove table $tablename from query ?" -type yesno -default no]=="no"} return set col [ql_get_tag_info $obj col]
for {set i [expr [llength $qlvar(restables)]-1]} {$i>=0} {incr i -1} { if {$col==""} return
if {[tk_messageBox -title WARNING -icon question -message "Remove field from result ?" -type yesno -default no]=="no"} return
set qlvar(resfields) [lreplace $qlvar(resfields) $col $col]
set qlvar(restables) [lreplace $qlvar(restables) $col $col]
set qlvar(rescriteria) [lreplace $qlvar(rescriteria) $col $col]
ql_draw_res_panel
return
}
# Is object a table ?
set tablename [ql_get_tag_info $obj tab]
if {$tablename==""} return
if {[tk_messageBox -title WARNING -icon question -message "Remove table $tablename from query ?" -type yesno -default no]=="no"} return
for {set i [expr [llength $qlvar(restables)]-1]} {$i>=0} {incr i -1} {
if {$tablename==[lindex $qlvar(restables) $i]} { if {$tablename==[lindex $qlvar(restables) $i]} {
set qlvar(resfields) [lreplace $qlvar(resfields) $i $i] set qlvar(resfields) [lreplace $qlvar(resfields) $i $i]
set qlvar(restables) [lreplace $qlvar(restables) $i $i] set qlvar(restables) [lreplace $qlvar(restables) $i $i]
set qlvar(rescriteria) [lreplace $qlvar(rescriteria) $i $i] set qlvar(rescriteria) [lreplace $qlvar(rescriteria) $i $i]
} }
} }
for {set i [expr [llength $qlvar(links)]-1]} {$i>=0} {incr i -1} { for {set i [expr [llength $qlvar(links)]-1]} {$i>=0} {incr i -1} {
set thelink [lindex $qlvar(links) $i] set thelink [lindex $qlvar(links) $i]
if {($tablename==[lindex $thelink 0]) || ($tablename==[lindex $thelink 2])} { if {($tablename==[lindex $thelink 0]) || ($tablename==[lindex $thelink 2])} {
set qlvar(links) [lreplace $qlvar(links) $i $i] set qlvar(links) [lreplace $qlvar(links) $i $i]
} }
} }
for {set i 0} {$i<$qlvar(ntables)} {incr i} { for {set i 0} {$i<$qlvar(ntables)} {incr i} {
if {$qlvar(tablename$i)=="$tablename"} { set temp {}
catch {set temp $qlvar(tablename$i)}
if {$temp=="$tablename"} {
unset qlvar(tablename$i) unset qlvar(tablename$i)
unset qlvar(tablestruct$i) unset qlvar(tablestruct$i)
break break
} }
}
incr qlvar(ntables) -1
.ql.c delete tab$tablename
.ql.c delete links
ql_draw_links
ql_draw_res_panel
} }
incr qlvar(ntables) -1
.ql.c delete tab$tablename
.ql.c delete links
ql_draw_links
ql_draw_res_panel
} }
proc ql_dragit {w x y} { proc ql_dragit {w x y} {
...@@ -1075,17 +1220,18 @@ proc ql_draw_res_panel {} { ...@@ -1075,17 +1220,18 @@ proc ql_draw_res_panel {} {
global qlvar global qlvar
# Compute the offset of the result panel due to panning # Compute the offset of the result panel due to panning
set resoffset [expr [lindex [.ql.c bbox resmarker] 0]-$qlvar(xoffs)] set resoffset [expr [lindex [.ql.c bbox resmarker] 0]-$qlvar(xoffs)]
.ql.c delete resp .ql.c delete resp
for {set i 0} {$i<[llength $qlvar(resfields)]} {incr i} { for {set i 0} {$i<[llength $qlvar(resfields)]} {incr i} {
.ql.c create text [expr $resoffset+4+$qlvar(xoffs)+$i*$qlvar(reswidth)] [expr 1+$qlvar(yoffs)] -text [lindex $qlvar(resfields) $i] -anchor nw -fill navy -tags {resf resp} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* .ql.c create text [expr $resoffset+4+$qlvar(xoffs)+$i*$qlvar(reswidth)] [expr 1+$qlvar(yoffs)] -text [lindex $qlvar(resfields) $i] -anchor nw -tags [subst {resf resp col$i}] -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*
.ql.c create text [expr $resoffset+4+$qlvar(xoffs)+$i*$qlvar(reswidth)] [expr 16+$qlvar(yoffs)] -text [lindex $qlvar(restables) $i] -anchor nw -tags {resp rest} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* .ql.c create text [expr $resoffset+4+$qlvar(xoffs)+$i*$qlvar(reswidth)] [expr 16+$qlvar(yoffs)] -text [lindex $qlvar(restables) $i] -anchor nw -tags {resp rest} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*
.ql.c create text [expr $resoffset+4+$qlvar(xoffs)+$i*$qlvar(reswidth)] [expr 31+$qlvar(yoffs)] -text [lindex $qlvar(ressort) $i] -anchor nw -tags {resp sort} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* .ql.c create text [expr $resoffset+4+$qlvar(xoffs)+$i*$qlvar(reswidth)] [expr 31+$qlvar(yoffs)] -text [lindex $qlvar(ressort) $i] -anchor nw -tags {resp sort} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*
if {[lindex $qlvar(rescriteria) $i]!=""} { if {[lindex $qlvar(rescriteria) $i]!=""} {
.ql.c create text [expr $resoffset+4+$qlvar(xoffs)+$i*$qlvar(reswidth)] [expr $qlvar(yoffs)+46+15*0] -anchor nw -text [lindex $qlvar(rescriteria) $i] -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags [subst {resp cr-c$i-r0}] .ql.c create text [expr $resoffset+4+$qlvar(xoffs)+$i*$qlvar(reswidth)] [expr $qlvar(yoffs)+46+15*0] -anchor nw -text [lindex $qlvar(rescriteria) $i] -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags [subst {resp cr-c$i-r0}]
} }
} }
.ql.c raise reshdr .ql.c raise reshdr
.ql.c bind sort <Button-1> {ql_swap_sort %W %x %y} .ql.c bind resf <Button-1> {ql_resfield_click %x %y}
.ql.c bind sort <Button-1> {ql_swap_sort %W %x %y}
} }
proc ql_draw_table {it} { proc ql_draw_table {it} {
...@@ -1163,6 +1309,17 @@ if {$qlvar(panobject)=="tables"} { ...@@ -1163,6 +1309,17 @@ if {$qlvar(panobject)=="tables"} {
} }
} }
proc ql_resfield_click {x y} {
global qlvar
set obj [.ql.c find closest $x $y]
if {[ql_get_tag_info $obj res]!="f"} return
.ql.c itemconfigure [.ql.c find withtag hili] -fill black
.ql.c dtag [.ql.c find withtag hili] hili
.ql.c addtag hili withtag $obj
.ql.c itemconfigure $obj -fill blue
}
proc ql_show_sql {} { proc ql_show_sql {} {
global qlvar global qlvar
...@@ -1237,14 +1394,14 @@ set qlvar(critrow) 0 ...@@ -1237,14 +1394,14 @@ set qlvar(critrow) 0
set qlvar(critedit) 1 set qlvar(critedit) 1
} }
proc save_new_record {} { proc mw_save_new_record {} {
global dbc newrec_fields newrec_values tablename msg last_rownum global dbc mw tablename msg
if {![hide_entry]} {return 0} if {![mw_exit_edit]} {return 0}
if {$newrec_fields==""} {return 1} if {$mw(newrec_fields)==""} {return 1}
set msg "Saving new record ..." set msg "Saving new record ..."
after 1000 {set msg ""} after 1000 {set msg ""}
set retval [catch { set retval [catch {
set sqlcmd "insert into $tablename ([join $newrec_fields ,]) values ([join $newrec_values ,])" set sqlcmd "insert into $tablename ([join $mw(newrec_fields) ,]) values ([join $mw(newrec_values) ,])"
set pgres [pg_exec $dbc $sqlcmd] set pgres [pg_exec $dbc $sqlcmd]
} errmsg] } errmsg]
if {$retval} { if {$retval} {
...@@ -1252,26 +1409,28 @@ if {$retval} { ...@@ -1252,26 +1409,28 @@ if {$retval} {
return 0 return 0
} }
set oid [pg_result $pgres -oid] set oid [pg_result $pgres -oid]
lappend mw(keylist) $oid
pg_result $pgres -clear pg_result $pgres -clear
# Get bounds of the last record
set lrbb [.mw.c bbox new]
lappend mw(rowy) [lindex $lrbb 3]
.mw.c itemconfigure new -fill black .mw.c itemconfigure new -fill black
.mw.c addtag o$oid withtag new .mw.c dtag q new
.mw.c dtag new o0
.mw.c dtag rows new
# Replace * from untouched new row elements with " " # Replace * from untouched new row elements with " "
foreach item [.mw.c find withtag unt] { foreach item [.mw.c find withtag unt] {
.mw.c itemconfigure $item -text " " .mw.c itemconfigure $item -text " "
} }
.mw.c dtag rows unt .mw.c dtag q unt
incr last_rownum incr mw(last_rownum)
draw_new_record incr mw(nrecs)
set newrec_fields {} mw_draw_new_record
set newrec_values {} set mw(newrec_fields) {}
set mw(newrec_values) {}
return 1 return 1
} }
proc save_pref {} { proc save_pref {} {
global pref global pref
catch { catch {
set fid [open "~/.pgaccessrc" w] set fid [open "~/.pgaccessrc" w]
foreach {opt val} [array get pref] { puts $fid "$opt $val" } foreach {opt val} [array get pref] { puts $fid "$opt $val" }
...@@ -1279,81 +1438,99 @@ catch { ...@@ -1279,81 +1438,99 @@ catch {
} }
} }
proc scroll_window {par1 par2 args} { proc mw_scroll_window {par1 par2 args} {
global nrecs toprec global mw
if {![hide_entry]} return; if {![mw_exit_edit]} return;
if {$par1=="scroll"} { if {$par1=="scroll"} {
set newtop $toprec set newtop $mw(toprec)
if {[lindex $args 0]=="units"} { if {[lindex $args 0]=="units"} {
incr newtop $par2 incr newtop $par2
} else { } else {
incr newtop [expr $par2*25] incr newtop [expr $par2*25]
if {$newtop<0} {set newtop 0} if {$newtop<0} {set newtop 0}
if {$newtop>=[expr $nrecs-1]} {set newtop [expr $nrecs-1]} if {$newtop>=[expr $mw(nrecs)-1]} {set newtop [expr $mw(nrecs)-1]}
} }
} else { } else {
set newtop [expr int($par2*$nrecs)] set newtop [expr int($par2*$mw(nrecs))]
} }
if {$newtop<0} return; if {$newtop<0} return;
if {$newtop>=[expr $nrecs-1]} return; if {$newtop>=[expr $mw(nrecs)-1]} return;
.mw.c move rows 0 [expr 14*($toprec-$newtop)] set dy [expr [lindex $mw(rowy) $mw(toprec)]-[lindex $mw(rowy) $newtop]]
set toprec $newtop .mw.c move q 0 $dy
set_scrollbar .mw.c move hgrid 0 $dy
} set newrowy {}
foreach y $mw(rowy) {lappend newrowy [expr $y+$dy]}
proc select_records {sql} { set mw(rowy) $newrowy
global dbc field dirty nrecs toprec colwidth colname colcount ds_updatable set mw(toprec) $newtop
global layout_found layout_name tablename leftcol leftoffset msg pref mw_set_scrollbar
global newrec_fields newrec_values }
global last_rownum
set newrec_fields {} proc mw_select_records {sql} {
set newrec_values {} global dbc field mw
if {![hide_entry]} return; global tablename msg pref
.mw.c delete rows set mw(newrec_fields) {}
set mw(newrec_values) {}
if {![mw_exit_edit]} return;
.mw.c delete q
.mw.c delete header .mw.c delete header
set leftcol 0 .mw.c delete hgrid
set leftoffset 0 .mw.c delete new
set mw(leftcol) 0
set mw(leftoffset) 0
set mw(crtrow) {}
set msg {} set msg {}
set msg "Accessing data. Please wait ..."
cursor_watch .mw cursor_watch .mw
set retval [catch {set pgres [pg_exec $dbc $sql]} errmsg] set retval [catch {set pgres [pg_exec $dbc "BEGIN"]} errmsg]
if {!$retval} {
pg_result $pgres -clear
set retval [catch {set pgres [pg_exec $dbc "declare mycursor cursor for $sql"]} errmsg]
if {!$retval} {
pg_result $pgres -clear
set retval [catch {set pgres [pg_exec $dbc "fetch $pref(rows) in mycursor"]} errmsg]
}
}
#set retval [catch {set pgres [pg_exec $dbc $sql]} errmsg]
if {$retval} { if {$retval} {
sql_exec quiet "END"
set msg {}
cursor_arrow .mw cursor_arrow .mw
show_error "Error executing SQL command\n\n$sql\n\nError message:$errmsg" show_error "Error executing SQL command\n\n$sql\n\nError message:$errmsg"
set msg "Error executing : $sql" set msg "Error executing : $sql"
return return
} }
if {$ds_updatable} then {set shift 1} else {set shift 0} if {$mw(updatable)} then {set shift 1} else {set shift 0}
# #
# checking at least the numer of fields # checking at least the numer of fields
set attrlist [pg_result $pgres -lAttributes] set attrlist [pg_result $pgres -lAttributes]
if {$layout_found} then { if {$mw(layout_found)} then {
if { ($colcount != [expr [llength $attrlist]-$shift]) || if { ($mw(colcount) != [expr [llength $attrlist]-$shift]) ||
($colcount != [llength $colname]) || ($mw(colcount) != [llength $mw(colnames)]) ||
($colcount != [llength $colwidth]) } then { ($mw(colcount) != [llength $mw(colwidth)]) } then {
# No. of columns don't match, something is wrong # No. of columns don't match, something is wrong
# tk_messageBox -title Information -message "Layout info changed !\nRescanning..." # tk_messageBox -title Information -message "Layout info changed !\nRescanning..."
set layout_found false set mw(layout_found) 0
sql_exec quiet "delete from pga_layout where tablename='$layout_name'" sql_exec quiet "delete from pga_layout where tablename='$mw(layout_name)'"
} }
} }
# Always take the col. names from the result # Always take the col. names from the result
set colcount [llength $attrlist] set mw(colcount) [llength $attrlist]
if {$ds_updatable} then {incr colcount -1} if {$mw(updatable)} then {incr mw(colcount) -1}
set colname {} set mw(colnames) {}
# In defcolwidth prepare colwidth (in case that not layout_found) # In defmw(colwidth) prepare mw(colwidth) (in case that not layout_found)
set defcolwidth {} set defmw(colwidth) {}
for {set i 0} {$i<$colcount} {incr i} { for {set i 0} {$i<$mw(colcount)} {incr i} {
lappend colname [lindex [lindex $attrlist [expr $i+$shift]] 0] lappend mw(colnames) [lindex [lindex $attrlist [expr $i+$shift]] 0]
lappend defcolwidth 150 lappend defmw(colwidth) 150
} }
if {$layout_found=="false"} { if {!$mw(layout_found)} {
set colwidth $defcolwidth set mw(colwidth) $defmw(colwidth)
sql_exec quiet "insert into pga_layout values ('$layout_name',$colcount,'$colname','$colwidth')" sql_exec quiet "insert into pga_layout values ('$mw(layout_name)',$mw(colcount),'$mw(colnames)','$mw(colwidth)')"
} }
set nrecs [pg_result $pgres -numTuples] set mw(nrecs) [pg_result $pgres -numTuples]
if {$nrecs>$pref(rows)} { if {$mw(nrecs)>$pref(rows)} {
set msg "Only first $pref(rows) records from $nrecs have been loaded" set msg "Only first $pref(rows) records from $mw(nrecs) have been loaded"
set nrecs $pref(rows) set mw(nrecs) $pref(rows)
} }
set tagoid {} set tagoid {}
if {$pref(tvfont)=="helv"} { if {$pref(tvfont)=="helv"} {
...@@ -1361,64 +1538,75 @@ if {$pref(tvfont)=="helv"} { ...@@ -1361,64 +1538,75 @@ if {$pref(tvfont)=="helv"} {
} else { } else {
set tvfont -*-Clean-Medium-R-Normal-*-*-130-*-*-*-*-* set tvfont -*-Clean-Medium-R-Normal-*-*-130-*-*-*-*-*
} }
for {set i 0} {$i<$nrecs} {incr i} { # Computing column's left edge
set posx 10
for {set j 0} {$j<$mw(colcount)} {incr j} {
set ledge($j) $posx
incr posx [expr [lindex $mw(colwidth) $j]+2]
set textwidth($j) [expr [lindex $mw(colwidth) $j]-5]
}
incr posx -6
set posy 24
mw_draw_headers
set mw(updatekey) oid
set mw(keylist) {}
set mw(rowy) {24}
set msg [time {for {set i 0} {$i<$mw(nrecs)} {incr i} {
set curtup [pg_result $pgres -getTuple $i] set curtup [pg_result $pgres -getTuple $i]
if {$ds_updatable} then {set tagoid o[lindex $curtup 0]} if {$mw(updatable)} then {lappend mw(keylist) [lindex $curtup 0]}
set posx 10 for {set j 0} {$j<$mw(colcount)} {incr j} {
for {set j 0} {$j<$colcount} {incr j} { .mw.c create text $ledge($j) $posy -text [lindex $curtup [expr $j+$shift]] -tags [subst {r$i c$j q}] -anchor nw -font $tvfont -width $textwidth($j)
set fldtext [lindex $curtup [expr $j+$shift]] }
if {[string length $fldtext]==0} {set fldtext " "}; set bb [.mw.c bbox r$i]
.mw.c create text $posx [expr 30+$i*14] -text $fldtext -tags [subst {$tagoid c$j rows}] -anchor w -font $tvfont incr posy [expr [lindex $bb 3]-[lindex $bb 1]]
incr posx [expr [lindex $colwidth $j]+2] lappend mw(rowy) $posy
} .mw.c create line 0 [lindex $bb 3] $posx [lindex $bb 3] -fill gray -tags [subst {hgrid g$i}]
} if {$i==25} {update; update idletasks}
set last_rownum $i }
}]
after 2000 set msg {}
set mw(last_rownum) $i
# Defining position for input data # Defining position for input data
draw_new_record mw_draw_new_record
pg_result $pgres -clear pg_result $pgres -clear
set toprec 0 #set msg {}
set_scrollbar sql_exec quiet "END"
if {$ds_updatable} then { set mw(toprec) 0
.mw.c bind rows <Button-1> {color_record [%W find closest %x %y]} mw_set_scrollbar
.mw.c bind rows <Double-Button-1> {show_entry [%W find closest %x %y]} if {$mw(updatable)} then {
.mw.c bind q <Key> {mw_edit_text %A %K}
} else { } else {
.mw.c bind rows <Button-1> {} .mw.c bind q <Key> {}
.mw.c bind rows <Double-Button-1> {bell}
} }
set dirty false set mw(dirtyrec) 0
draw_headers #mw_draw_headers
.mw.c raise header
cursor_arrow .mw cursor_arrow .mw
} }
proc set_scrollbar {} { proc mw_draw_hgrid {} {
global nrecs toprec global mw
.mw.c delete hgrid
if {$nrecs==0} return; set posx 10
.mw.sb set [expr $toprec*1.0/$nrecs] [expr ($toprec+27.0)/$nrecs] for {set j 0} {$j<$mw(colcount)} {incr j} {
set ledge($j) $posx
incr posx [expr [lindex $mw(colwidth) $j]+2]
set textwidth($j) [expr [lindex $mw(colwidth) $j]-5]
} }
incr posx -6
proc show_entry {id} { for {set i 0} {$i<$mw(nrecs)} {incr i} {
global dirty fldval msg itemid colname colwidth .mw.c create line [expr -$mw(leftoffset)] [lindex $mw(rowy) [expr $i+1]] [expr $posx-$mw(leftoffset)] [lindex $mw(rowy) [expr $i+1]] -fill gray -tags [subst {hgrid g$i}]
}
if {![hide_entry]} return; if {$mw(updatable)} {
set itemid $id set i $mw(nrecs)
set colidx [get_tag_info $id c] .mw.c create line [expr -$mw(leftoffset)] [lindex $mw(rowy) [expr $i+1]] [expr $posx-$mw(leftoffset)] [lindex $mw(rowy) [expr $i+1]] -fill gray -tags [subst {hgrid g$i}]
set fldval [string trim [.mw.c itemcget $id -text]]
# It's a new record tag ?
if {[get_tag_info $id n]=="ew"} {
set fldval ""
} else {
if {![save_new_record]} return;
} }
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-*-*-*-*-*; proc mw_set_scrollbar {} {
place .mw.entf -x [expr 4+[lindex $coord 0]] -y [expr 18+[lindex $coord 1]]; global mw
focus .mw.entf if {$mw(nrecs)==0} return;
bind .mw.entf <Return> {hide_entry} .mw.sb set [expr $mw(toprec)*1.0/$mw(nrecs)] [expr ($mw(toprec)+27.0)/$mw(nrecs)]
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} { proc show_error {emsg} {
...@@ -1461,7 +1649,7 @@ cmd_$curtab ...@@ -1461,7 +1649,7 @@ cmd_$curtab
} }
proc main {argc argv} { proc main {argc argv} {
global pref newdbname newpport newhost global pref newdbname newpport newhost dbc
load libpgtcl.so load libpgtcl.so
catch {draw_tabs} catch {draw_tabs}
load_pref load_pref
...@@ -1471,6 +1659,40 @@ if {$pref(autoload) && ($pref(lastdb)!="")} { ...@@ -1471,6 +1659,40 @@ if {$pref(autoload) && ($pref(lastdb)!="")} {
set newpport $pref(lastport) set newpport $pref(lastport)
open_database open_database
} }
wm protocol .dw WM_DELETE_WINDOW {
catch {pg_disconnect $dbc}
exit
}
}
proc tiw_show_index {} {
global tiw dbc
set cs [.tiw.ilb curselection]
if {$cs==""} return
set idxname [.tiw.ilb get $cs]
pg_select $dbc "select pg_index.*,pg_class.oid from pg_index,pg_class where pg_class.relname='$idxname' and pg_class.oid=pg_index.indexrelid" rec {
if {$rec(indisunique)=="t"} {
set tiw(isunique) Yes
} else {
set tiw(isunique) No
}
if {$rec(indisclustered)=="t"} {
set tiw(isclustered) Yes
} else {
set tiw(isclustered) No
}
set tiw(indexfields) {}
foreach field $rec(indkey) {
if {$field!=0} {
# pg_select $dbc "select attname from pg_attribute where attrelid=$tiw(tableoid) and attnum=$field" rec1 {
# set tiw(indexfields) "$tiw(indexfields) $rec1(attname)"
# }
set tiw(indexfields) "$tiw(indexfields) $tiw(f$field)"
}
}
}
set tiw(indexfields) [string trim $tiw(indexfields)]
} }
proc Window {args} { proc Window {args} {
...@@ -1545,24 +1767,40 @@ proc vTclWindow.about {base} { ...@@ -1545,24 +1767,40 @@ proc vTclWindow.about {base} {
wm overrideredirect $base 0 wm overrideredirect $base 0
wm resizable $base 1 1 wm resizable $base 1 1
wm title $base "About" wm title $base "About"
label $base.l1 -borderwidth 3 -font -Adobe-Helvetica-Bold-R-Normal-*-*-180-*-*-*-*-* -relief ridge -text PGACCESS label $base.l1 \
label $base.l2 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief groove -text {A Tcl/Tk interface to -borderwidth 3 -font -Adobe-Helvetica-Bold-R-Normal-*-*-180-*-*-*-*-* \
-relief ridge -text PgAccess
label $base.l2 \
-relief groove \
-text {A Tcl/Tk interface to
PostgreSQL PostgreSQL
by Constantin Teodorescu} by Constantin Teodorescu}
label $base.l3 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief sunken -text {vers 0.5} label $base.l3 \
label $base.l4 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief groove -text {You will always get the latest version at: -borderwidth 0 \
-relief sunken -text {vers 0.61}
label $base.l4 \
-relief groove \
-text {You will always get the latest version at:
http://ww.flex.ro/pgaccess http://ww.flex.ro/pgaccess
Suggestions : teo@flex.ro} Suggestions : teo@flex.ro}
button $base.b1 -borderwidth 1 -command {Window hide .about} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text Ok button $base.b1 \
-borderwidth 1 -command {Window hide .about} \
-padx 9 \
-pady 3 -text Ok
################### ###################
# SETTING GEOMETRY # SETTING GEOMETRY
################### ###################
place $base.l1 -x 10 -y 10 -width 196 -height 103 -anchor nw -bordermode ignore place $base.l1 \
place $base.l2 -x 10 -y 115 -width 198 -height 55 -anchor nw -bordermode ignore -x 10 -y 10 -width 196 -height 103 -anchor nw -bordermode ignore
place $base.l3 -x 145 -y 80 -anchor nw -bordermode ignore place $base.l2 \
place $base.l4 -x 215 -y 10 -width 246 -height 103 -anchor nw -bordermode ignore -x 10 -y 115 -width 198 -height 55 -anchor nw -bordermode ignore
place $base.b1 -x 295 -y 130 -width 105 -height 28 -anchor nw -bordermode ignore place $base.l3 \
-x 145 -y 80 -anchor nw -bordermode ignore
place $base.l4 \
-x 215 -y 10 -width 246 -height 103 -anchor nw -bordermode ignore
place $base.b1 \
-x 295 -y 130 -width 105 -height 28 -anchor nw -bordermode ignore
} }
proc vTclWindow.dbod {base} { proc vTclWindow.dbod {base} {
...@@ -1586,32 +1824,28 @@ proc vTclWindow.dbod {base} { ...@@ -1586,32 +1824,28 @@ proc vTclWindow.dbod {base} {
wm title $base "Open database" wm title $base "Open database"
label $base.lhost \ label $base.lhost \
-borderwidth 0 \ -borderwidth 0 \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
-relief raised -text Host -relief raised -text Host
entry $base.ehost \ entry $base.ehost \
-background #fefefe -borderwidth 1 -highlightthickness 1 \ -background #fefefe -borderwidth 1 -highlightthickness 1 \
-selectborderwidth 0 -textvariable newhost -selectborderwidth 0 -textvariable newhost
label $base.lport \ label $base.lport \
-borderwidth 0 \ -borderwidth 0 \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
-relief raised -text Port -relief raised -text Port
entry $base.epport \ entry $base.epport \
-background #fefefe -borderwidth 1 -highlightthickness 1 \ -background #fefefe -borderwidth 1 -highlightthickness 1 \
-selectborderwidth 0 -textvariable newpport -selectborderwidth 0 -textvariable newpport
label $base.ldbname \ label $base.ldbname \
-borderwidth 0 \ -borderwidth 0 \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
-relief raised -text Database -relief raised -text Database
entry $base.edbname \ entry $base.edbname \
-background #fefefe -borderwidth 1 -highlightthickness 1 \ -background #fefefe -borderwidth 1 -highlightthickness 1 \
-selectborderwidth 0 -textvariable newdbname -selectborderwidth 0 -textvariable newdbname
button $base.opbtu \ button $base.opbtu \
-borderwidth 1 -command open_database \ -borderwidth 1 -command open_database \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ -padx 9 -pady 3 -text Open
-pady 3 -text Open
button $base.canbut \ button $base.canbut \
-borderwidth 1 -command {Window hide .dbod} \ -borderwidth 1 -command {Window hide .dbod} \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ -padx 9 \
-pady 3 -text Cancel -pady 3 -text Cancel
################### ###################
# SETTING GEOMETRY # SETTING GEOMETRY
...@@ -1647,7 +1881,7 @@ proc vTclWindow.dw {base} { ...@@ -1647,7 +1881,7 @@ proc vTclWindow.dw {base} {
toplevel $base -class Toplevel \ toplevel $base -class Toplevel \
-background #efefef -background #efefef
wm focusmodel $base passive wm focusmodel $base passive
wm geometry $base 322x355+78+129 wm geometry $base 322x355+93+104
wm maxsize $base 1009 738 wm maxsize $base 1009 738
wm minsize $base 1 1 wm minsize $base 1 1
wm overrideredirect $base 0 wm overrideredirect $base 0
...@@ -1655,7 +1889,6 @@ proc vTclWindow.dw {base} { ...@@ -1655,7 +1889,6 @@ proc vTclWindow.dw {base} {
wm deiconify $base wm deiconify $base
wm title $base "PostgreSQL access" wm title $base "PostgreSQL access"
label $base.labframe \ label $base.labframe \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
-relief raised -relief raised
listbox $base.lb \ listbox $base.lb \
-background #fefefe \ -background #fefefe \
...@@ -1667,23 +1900,21 @@ proc vTclWindow.dw {base} { ...@@ -1667,23 +1900,21 @@ proc vTclWindow.dw {base} {
} }
button $base.btnnew \ button $base.btnnew \
-borderwidth 1 -command cmd_New \ -borderwidth 1 -command cmd_New \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ -padx 9 \
-pady 3 -text New -pady 3 -text New
button $base.btnopen \ button $base.btnopen \
-borderwidth 1 -command cmd_Open \ -borderwidth 1 -command cmd_Open \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ -padx 9 \
-pady 3 -text Open -pady 3 -text Open
button $base.btndesign \ button $base.btndesign \
-borderwidth 1 -command cmd_Design \ -borderwidth 1 -command cmd_Design \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ -padx 9 \
-pady 3 -state disabled -text Design -pady 3 -state disabled -text Design
label $base.lmask \ label $base.lmask \
-borderwidth 0 \ -borderwidth 0 \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
-relief raised -text { } -relief raised -text { }
label $base.label22 \ label $base.label22 \
-borderwidth 1 \ -borderwidth 1 \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
-relief raised -relief raised
menubutton $base.menubutton23 \ menubutton $base.menubutton23 \
-borderwidth 1 \ -borderwidth 1 \
...@@ -1722,11 +1953,9 @@ set sdbname {}} \ ...@@ -1722,11 +1953,9 @@ set sdbname {}} \
save_pref save_pref
exit} -label Exit exit} -label Exit
label $base.lshost \ label $base.lshost \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
-relief groove -text localhost -textvariable host -relief groove -text localhost -textvariable host
label $base.lsdbname \ label $base.lsdbname \
-anchor w -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ -anchor w -relief groove -textvariable sdbname
-relief groove -textvariable sdbname
scrollbar $base.sb \ scrollbar $base.sb \
-borderwidth 1 -command {.dw.lb yview} -orient vert -borderwidth 1 -command {.dw.lb yview} -orient vert
menubutton $base.mnob \ menubutton $base.mnob \
...@@ -1806,16 +2035,31 @@ proc vTclWindow.fw {base} { ...@@ -1806,16 +2035,31 @@ proc vTclWindow.fw {base} {
wm minsize $base 1 1 wm minsize $base 1 1
wm overrideredirect $base 0 wm overrideredirect $base 0
wm resizable $base 0 0 wm resizable $base 0 0
wm deiconify $base
wm title $base "Function" wm title $base "Function"
label $base.l1 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text Name label $base.l1 \
entry $base.e1 -background #fefefe -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable funcname -borderwidth 0 \
label $base.l2 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text Parameters -relief raised -text Name
entry $base.e2 -background #fefefe -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable funcpar entry $base.e1 \
label $base.l3 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text Returns -background #fefefe -borderwidth 1 -highlightthickness 1 \
entry $base.e3 -background #fefefe -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable funcret -selectborderwidth 0 -textvariable funcname
text $base.text1 -background #fefefe -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -highlightthickness 1 -selectborderwidth 0 -wrap word label $base.l2 \
button $base.okbtn -borderwidth 1 -command { -borderwidth 0 \
-relief raised -text Parameters
entry $base.e2 \
-background #fefefe -borderwidth 1 -highlightthickness 1 \
-selectborderwidth 0 -textvariable funcpar
label $base.l3 \
-borderwidth 0 \
-relief raised -text Returns
entry $base.e3 \
-background #fefefe -borderwidth 1 -highlightthickness 1 \
-selectborderwidth 0 -textvariable funcret
text $base.text1 \
-background #fefefe -borderwidth 1 \
-highlightthickness 1 -selectborderwidth 0 -wrap word
button $base.okbtn \
-borderwidth 1 \
-command {
if {$funcname==""} { if {$funcname==""} {
show_error "You must supply a name for this function!" show_error "You must supply a name for this function!"
} elseif {$funcret==""} { } elseif {$funcret==""} {
...@@ -1830,20 +2074,34 @@ proc vTclWindow.fw {base} { ...@@ -1830,20 +2074,34 @@ proc vTclWindow.fw {base} {
} }
} }
} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text Define } \
button $base.cancelbtn -borderwidth 1 -command {Window hide .fw} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text Close -padx 9 \
-pady 3 -state disabled -text Define
button $base.cancelbtn \
-borderwidth 1 -command {Window hide .fw} \
-padx 9 \
-pady 3 -text Close
################### ###################
# SETTING GEOMETRY # SETTING GEOMETRY
################### ###################
place $base.l1 -x 15 -y 18 -anchor nw -bordermode ignore place $base.l1 \
place $base.e1 -x 95 -y 15 -width 198 -height 22 -anchor nw -bordermode ignore -x 15 -y 18 -anchor nw -bordermode ignore
place $base.l2 -x 15 -y 48 -anchor nw -bordermode ignore place $base.e1 \
place $base.e2 -x 95 -y 45 -width 198 -height 22 -anchor nw -bordermode ignore -x 95 -y 15 -width 198 -height 22 -anchor nw -bordermode ignore
place $base.l3 -x 15 -y 78 -anchor nw -bordermode ignore place $base.l2 \
place $base.e3 -x 95 -y 75 -width 198 -height 22 -anchor nw -bordermode ignore -x 15 -y 48 -anchor nw -bordermode ignore
place $base.text1 -x 15 -y 105 -width 275 -height 141 -anchor nw -bordermode ignore place $base.e2 \
place $base.okbtn -x 90 -y 255 -anchor nw -bordermode ignore -x 95 -y 45 -width 198 -height 22 -anchor nw -bordermode ignore
place $base.cancelbtn -x 160 -y 255 -anchor nw -bordermode ignore place $base.l3 \
-x 15 -y 78 -anchor nw -bordermode ignore
place $base.e3 \
-x 95 -y 75 -width 198 -height 22 -anchor nw -bordermode ignore
place $base.text1 \
-x 15 -y 105 -width 275 -height 141 -anchor nw -bordermode ignore
place $base.okbtn \
-x 90 -y 400 -anchor nw -bordermode ignore
place $base.cancelbtn \
-x 160 -y 255 -anchor nw -bordermode ignore
} }
proc vTclWindow.iew {base} { proc vTclWindow.iew {base} {
...@@ -1864,13 +2122,24 @@ proc vTclWindow.iew {base} { ...@@ -1864,13 +2122,24 @@ proc vTclWindow.iew {base} {
wm overrideredirect $base 0 wm overrideredirect $base 0
wm resizable $base 0 0 wm resizable $base 0 0
wm title $base "Import-Export table" wm title $base "Import-Export table"
label $base.l1 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text {Table name} label $base.l1 \
entry $base.e1 -background #fefefe -borderwidth 1 -textvariable ie_tablename -borderwidth 0 \
label $base.l2 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text {File name} -relief raised -text {Table name}
entry $base.e2 -background #fefefe -borderwidth 1 -textvariable ie_filename entry $base.e1 \
label $base.l3 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text {Field delimiter} -background #fefefe -borderwidth 1 -textvariable ie_tablename
entry $base.e3 -background #fefefe -borderwidth 1 -textvariable ie_delimiter label $base.l2 \
button $base.expbtn -borderwidth 1 -command {if {$ie_tablename==""} { -borderwidth 0 \
-relief raised -text {File name}
entry $base.e2 \
-background #fefefe -borderwidth 1 -textvariable ie_filename
label $base.l3 \
-borderwidth 0 \
-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!" show_error "You have to supply a table name!"
} elseif {$ie_filename==""} { } elseif {$ie_filename==""} {
show_error "You have to supply a external file name!" show_error "You have to supply a external file name!"
...@@ -1898,21 +2167,37 @@ proc vTclWindow.iew {base} { ...@@ -1898,21 +2167,37 @@ proc vTclWindow.iew {base} {
Window hide .iew Window hide .iew
} }
cursor_arrow .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 -padx 9 \
checkbutton $base.oicb -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -text {with OIDs} -variable oicb -pady 3 -text Export
button $base.cancelbtn \
-borderwidth 1 -command {Window hide .iew} \
-padx 9 \
-pady 3 -text Cancel
checkbutton $base.oicb \
-borderwidth 1 \
-text {with OIDs} -variable oicb
################### ###################
# SETTING GEOMETRY # SETTING GEOMETRY
################### ###################
place $base.l1 -x 25 -y 15 -anchor nw -bordermode ignore place $base.l1 \
place $base.e1 -x 115 -y 10 -anchor nw -bordermode ignore -x 25 -y 15 -anchor nw -bordermode ignore
place $base.l2 -x 25 -y 45 -anchor nw -bordermode ignore place $base.e1 \
place $base.e2 -x 115 -y 40 -anchor nw -bordermode ignore -x 115 -y 10 -anchor nw -bordermode ignore
place $base.l3 -x 25 -y 75 -height 18 -anchor nw -bordermode ignore place $base.l2 \
place $base.e3 -x 115 -y 74 -width 33 -height 22 -anchor nw -bordermode ignore -x 25 -y 45 -anchor nw -bordermode ignore
place $base.expbtn -x 60 -y 110 -anchor nw -bordermode ignore place $base.e2 \
place $base.cancelbtn -x 155 -y 110 -anchor nw -bordermode ignore -x 115 -y 40 -anchor nw -bordermode ignore
place $base.oicb -x 170 -y 75 -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} { proc vTclWindow.mw {base} {
...@@ -1928,44 +2213,43 @@ proc vTclWindow.mw {base} { ...@@ -1928,44 +2213,43 @@ proc vTclWindow.mw {base} {
toplevel $base -class Toplevel \ toplevel $base -class Toplevel \
-cursor top_left_arrow -cursor top_left_arrow
wm focusmodel $base passive wm focusmodel $base passive
wm geometry $base 631x452+160+238 wm geometry $base 631x452+239+226
wm maxsize $base 1009 738 wm maxsize $base 1009 738
wm minsize $base 1 1 wm minsize $base 1 1
wm overrideredirect $base 0 wm overrideredirect $base 0
wm resizable $base 0 0 wm resizable $base 0 0
wm title $base "Table browser" wm title $base "Table browser"
bind $base <Key-Delete> { bind $base <Key-Delete> {
delete_record mw_delete_record
} }
label $base.hoslbl \ label $base.hoslbl \
-borderwidth 0 \ -borderwidth 0 \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
-relief raised -text {Sort field} -relief raised -text {Sort field}
button $base.fillbtn \ button $base.fillbtn \
-borderwidth 1 \ -borderwidth 1 \
-command {set nq $ds_query -command {set nq $mw(query)
if {($ds_isaquery=="true") && ("$filter$sortfield"!="")} { if {($mw(isaquery)) && ("$filter$sortfield"!="")} {
show_error "Sorting and filtering not (yet) available from queries!\n\nPlease enter them in the query definition!" show_error "Sorting and filtering not (yet) available from queries!\n\nPlease enter them in the query definition!"
set sortfield {} set sortfield {}
set filter {} set filter {}
} else { } else {
if {$filter!=""} { if {$filter!=""} {
set nq "$ds_query where ($filter)" set nq "$mw(query) where ($filter)"
} else { } else {
set nq $ds_query set nq $mw(query)
} }
if {$sortfield!=""} { if {$sortfield!=""} {
set nq "$nq order by $sortfield" set nq "$nq order by $sortfield"
} }
} }
if {[save_new_record]} {select_records $nq} if {[mw_save_new_record]} {mw_select_records $nq}
} \ } \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ -padx 9 \
-pady 3 -text Reload -pady 3 -text Reload
button $base.exitbtn \ button $base.exitbtn \
-borderwidth 1 \ -borderwidth 1 \
-command { -command {
if {[save_new_record]} { if {[mw_save_new_record]} {
.mw.c delete rows .mw.c delete rows
.mw.c delete header .mw.c delete header
set sortfield {} set sortfield {}
...@@ -1973,26 +2257,29 @@ if {[save_new_record]} { ...@@ -1973,26 +2257,29 @@ if {[save_new_record]} {
Window hide .mw Window hide .mw
} }
} \ } \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ -padx 9 \
-pady 3 -text Close -pady 3 -text Close
canvas $base.c \ canvas $base.c \
-background #fefefe -borderwidth 2 -height 207 -relief ridge \ -background #fefefe -borderwidth 2 -height 207 -highlightthickness 0 \
-width 295 -relief ridge -selectborderwidth 0 -takefocus 1 -width 295
bind $base.c <Button-1> {
mw_canvas_click %x %y
}
bind $base.c <Button-3> { bind $base.c <Button-3> {
if {[hide_entry]} {save_new_record} if {[mw_exit_edit]} {mw_save_new_record}
} }
label $base.msglbl \ label $base.msglbl \
-anchor w -borderwidth 1 \ -anchor w -borderwidth 1 \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
-relief sunken -textvariable msg -relief sunken -textvariable msg
scrollbar $base.sb \ scrollbar $base.sb \
-borderwidth 1 -command scroll_window -orient vert -borderwidth 1 -command mw_scroll_window -highlightthickness 0 \
-orient vert
button $base.ert \ button $base.ert \
-borderwidth 1 -command pan_left \ -borderwidth 1 -command mw_pan_left \
-font -Adobe-Helvetica-Bold-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ -font -Adobe-Helvetica-Bold-R-Normal-*-*-120-*-*-*-*-* -padx 9 \
-pady 3 -text > -pady 3 -text >
button $base.dfggfh \ button $base.dfggfh \
-borderwidth 1 -command pan_right \ -borderwidth 1 -command mw_pan_right \
-font -Adobe-Helvetica-Bold-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ -font -Adobe-Helvetica-Bold-R-Normal-*-*-120-*-*-*-*-* -padx 9 \
-pady 3 -text < -pady 3 -text <
entry $base.tbn \ entry $base.tbn \
...@@ -2000,7 +2287,6 @@ if {[save_new_record]} { ...@@ -2000,7 +2287,6 @@ if {[save_new_record]} {
-selectborderwidth 0 -textvariable filter -selectborderwidth 0 -textvariable filter
label $base.tbllbl \ label $base.tbllbl \
-borderwidth 0 \ -borderwidth 0 \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
-relief raised -text {Filter conditions} -relief raised -text {Filter conditions}
entry $base.dben \ entry $base.dben \
-background #fefefe -borderwidth 1 -highlightthickness 1 \ -background #fefefe -borderwidth 1 -highlightthickness 1 \
...@@ -2019,7 +2305,7 @@ if {[save_new_record]} { ...@@ -2019,7 +2305,7 @@ if {[save_new_record]} {
place $base.msglbl \ place $base.msglbl \
-x 33 -y 430 -width 567 -height 18 -anchor nw -bordermode ignore -x 33 -y 430 -width 567 -height 18 -anchor nw -bordermode ignore
place $base.sb \ place $base.sb \
-x 610 -y 26 -width 18 -height 404 -anchor nw -bordermode ignore -x 612 -y 26 -width 13 -height 404 -anchor nw -bordermode ignore
place $base.ert \ place $base.ert \
-x 603 -y 428 -width 25 -height 22 -anchor nw -bordermode ignore -x 603 -y 428 -width 25 -height 22 -anchor nw -bordermode ignore
place $base.dfggfh \ place $base.dfggfh \
...@@ -2076,14 +2362,14 @@ proc vTclWindow.nt {base} { ...@@ -2076,14 +2362,14 @@ proc vTclWindow.nt {base} {
bind $base.e5 <Key-Return> { bind $base.e5 <Key-Return> {
focus .nt.cb1 focus .nt.cb1
} }
checkbutton $base.cb1 -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -offvalue { } -onvalue { NOT NULL} -text {field cannot be null} -variable notnull checkbutton $base.cb1 -borderwidth 1 -offvalue { } -onvalue { NOT NULL} -text {field cannot be null} -variable notnull
label $base.lab1 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text {Field type} label $base.lab1 -borderwidth 0 -relief raised -text {Field type}
label $base.lab2 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text {Field name} label $base.lab2 -borderwidth 0 -relief raised -text {Field name}
label $base.lab3 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text {Field size} label $base.lab3 -borderwidth 0 -relief raised -text {Field size}
label $base.lab4 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text {Default value} label $base.lab4 -borderwidth 0 -relief raised -text {Default value}
button $base.addfld -borderwidth 1 -command add_new_field -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text {Add field} button $base.addfld -borderwidth 1 -command add_new_field -padx 9 -pady 3 -text {Add field}
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.delfld -borderwidth 1 -command {catch {.nt.lb delete [.nt.lb curselection]}} -padx 9 -pady 3 -text {Delete field}
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.emptb -borderwidth 1 -command {.nt.lb delete 0 [.nt.lb size]} -padx 9 -pady 3 -text {Delete all}
button $base.maketbl -borderwidth 1 -command {if {$newtablename==""} then { button $base.maketbl -borderwidth 1 -command {if {$newtablename==""} then {
show_error "You must supply a name for your table!" show_error "You must supply a name for your table!"
focus .nt.etabn focus .nt.etabn
...@@ -2092,10 +2378,12 @@ proc vTclWindow.nt {base} { ...@@ -2092,10 +2378,12 @@ proc vTclWindow.nt {base} {
focus .nt.e2 focus .nt.e2
} else { } else {
set temp "create table $newtablename ([join [.nt.lb get 0 end] ,])" set temp "create table $newtablename ([join [.nt.lb get 0 end] ,])"
cursor_watch .nt
set retval [catch { set retval [catch {
set pgres [pg_exec $dbc $temp] set pgres [pg_exec $dbc $temp]
pg_result $pgres -clear pg_result $pgres -clear
} errmsg ] } errmsg ]
cursor_arrow .nt
if {$retval} { if {$retval} {
show_error "Error creating table\n$errmsg" show_error "Error creating table\n$errmsg"
} else { } else {
...@@ -2103,19 +2391,19 @@ proc vTclWindow.nt {base} { ...@@ -2103,19 +2391,19 @@ proc vTclWindow.nt {base} {
Window hide .nt Window hide .nt
cmd_Tables cmd_Tables
} }
}} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text {Create table} }} -padx 9 -pady 3 -text {Create table}
listbox $base.lb -background #fefefe -borderwidth 1 -font -*-Clean-Medium-R-Normal--*-130-*-*-*-*-*-* -highlightthickness 1 -selectborderwidth 0 -yscrollcommand {.nt.sb set} listbox $base.lb -background #fefefe -borderwidth 1 -font -*-Clean-Medium-R-Normal--*-130-*-*-*-*-*-* -highlightthickness 1 -selectborderwidth 0 -yscrollcommand {.nt.sb set}
bind $base.lb <ButtonRelease-1> { bind $base.lb <ButtonRelease-1> {
if {[.nt.lb curselection]!=""} { if {[.nt.lb curselection]!=""} {
set fldname [string trim [lindex [split [.nt.lb get [.nt.lb curselection]]] 0]] set fldname [string trim [lindex [split [.nt.lb get [.nt.lb curselection]]] 0]]
} }
} }
button $base.exitbtn -borderwidth 1 -command {Window hide .nt} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text Cancel button $base.exitbtn -borderwidth 1 -command {Window hide .nt} -padx 9 -pady 3 -text Cancel
label $base.l1 -anchor w -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text {field name} label $base.l1 -anchor w -borderwidth 1 -relief raised -text {field name}
label $base.l2 -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text type label $base.l2 -borderwidth 1 -relief raised -text type
label $base.l3 -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text options label $base.l3 -borderwidth 1 -relief raised -text options
scrollbar $base.sb -borderwidth 1 -command {.nt.lb yview} -orient vert 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} label $base.l93 -borderwidth 0 -relief raised -text {Table name}
menu $base.pop -tearoff 0 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 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 char2; if {("char2"=="varchar")||("char2"=="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 char2 $base.pop add command -command {set fldtype char2; if {("char2"=="varchar")||("char2"=="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 char2
...@@ -2137,7 +2425,7 @@ proc vTclWindow.nt {base} { ...@@ -2137,7 +2425,7 @@ proc vTclWindow.nt {base} {
.nt.lb delete [expr $i+1] .nt.lb delete [expr $i+1]
.nt.lb selection set [expr $i-1] .nt.lb selection set [expr $i-1]
} }
}} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text {Move field up} }} -padx 9 -pady 3 -text {Move field up}
button $base.mvdn -borderwidth 1 -command {if {[.nt.lb size]>2} { button $base.mvdn -borderwidth 1 -command {if {[.nt.lb size]>2} {
set i [.nt.lb curselection] set i [.nt.lb curselection]
if {($i!="")&&($i<[expr [.nt.lb size]-1])} { if {($i!="")&&($i<[expr [.nt.lb size]-1])} {
...@@ -2145,8 +2433,8 @@ proc vTclWindow.nt {base} { ...@@ -2145,8 +2433,8 @@ proc vTclWindow.nt {base} {
.nt.lb delete $i .nt.lb delete $i
.nt.lb selection set [expr $i+1] .nt.lb selection set [expr $i+1]
} }
}} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text {Move field down} }} -padx 9 -pady 3 -text {Move field down}
label $base.ll -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief sunken label $base.ll -borderwidth 1 -relief sunken
################### ###################
# SETTING GEOMETRY # SETTING GEOMETRY
################### ###################
...@@ -2194,18 +2482,18 @@ proc vTclWindow.pw {base} { ...@@ -2194,18 +2482,18 @@ proc vTclWindow.pw {base} {
wm overrideredirect $base 0 wm overrideredirect $base 0
wm resizable $base 1 1 wm resizable $base 1 1
wm title $base "Preferences" wm title $base "Preferences"
label $base.l1 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text {Max rows displayed in table/query view} label $base.l1 -borderwidth 0 -relief raised -text {Max rows displayed in table/query view}
entry $base.e1 -background #fefefe -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable pref(rows) entry $base.e1 -background #fefefe -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable pref(rows)
label $base.l2 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text Font label $base.l2 -borderwidth 0 -relief raised -text Font
radiobutton $base.tvf -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -text {fixed (clean)} -value clean -variable pref(tvfont) radiobutton $base.tvf -borderwidth 1 -text {fixed (clean)} -value clean -variable pref(tvfont)
radiobutton $base.tvfv -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -text {proportional (helvetica)} -value helv -variable pref(tvfont) radiobutton $base.tvfv -borderwidth 1 -text {proportional (helvetica)} -value helv -variable pref(tvfont)
label $base.ll -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief sunken label $base.ll -borderwidth 1 -relief sunken
checkbutton $base.alcb -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -text {Auto-load the last opened database at startup} -variable pref(autoload) checkbutton $base.alcb -borderwidth 1 -text {Auto-load the last opened database at startup} -variable pref(autoload)
button $base.okbtn -borderwidth 1 -command {if {$pref(rows)>200} { button $base.okbtn -borderwidth 1 -command {if {$pref(rows)>200} {
tk_messageBox -title Warning -message "A big number of rows displayed in table view will take a lot of memory!" tk_messageBox -title Warning -message "A big number of rows displayed in table view will take a lot of memory!"
} }
save_pref save_pref
Window hide .pw} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text Ok Window hide .pw} -padx 9 -pady 3 -text Ok
################### ###################
# SETTING GEOMETRY # SETTING GEOMETRY
################### ###################
...@@ -2229,9 +2517,10 @@ proc vTclWindow.qb {base} { ...@@ -2229,9 +2517,10 @@ proc vTclWindow.qb {base} {
################### ###################
# CREATING WIDGETS # CREATING WIDGETS
################### ###################
toplevel $base -class Toplevel toplevel $base -class Toplevel \
-cursor top_left_arrow
wm focusmodel $base passive wm focusmodel $base passive
wm geometry $base 442x344+258+271 wm geometry $base 442x344+277+276
wm maxsize $base 1009 738 wm maxsize $base 1009 738
wm minsize $base 1 1 wm minsize $base 1 1
wm overrideredirect $base 0 wm overrideredirect $base 0
...@@ -2239,7 +2528,6 @@ proc vTclWindow.qb {base} { ...@@ -2239,7 +2528,6 @@ proc vTclWindow.qb {base} {
wm title $base "Query builder" wm title $base "Query builder"
label $base.lqn \ label $base.lqn \
-borderwidth 0 \ -borderwidth 0 \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
-relief raised -text {Query name} -relief raised -text {Query name}
entry $base.eqn \ entry $base.eqn \
-background #fefefe -borderwidth 1 -highlightthickness 1 \ -background #fefefe -borderwidth 1 -highlightthickness 1 \
...@@ -2289,20 +2577,19 @@ proc vTclWindow.qb {base} { ...@@ -2289,20 +2577,19 @@ proc vTclWindow.qb {base} {
catch {pg_result $pgres -clear} catch {pg_result $pgres -clear}
} }
}} \ }} \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ -padx 9 -pady 3 -text {Save query definition}
-pady 3 -text {Save query definition}
button $base.execbtn \ button $base.execbtn \
-borderwidth 1 \ -borderwidth 1 \
-command {Window show .mw -command {Window show .mw
set qcmd [.qb.text1 get 0.0 end] set qcmd [.qb.text1 get 0.0 end]
regsub -all "\n" $qcmd " " qcmd regsub -all "\n" $qcmd " " qcmd
set layout_name $queryname set mw(layout_name) $queryname
load_layout $queryname mw_load_layout $queryname
set ds_query $qcmd set mw(query) $qcmd
set ds_updatable false set mw(updatable) 0
set ds_isaquery true set mw(isaquery) 1
select_records $qcmd} \ mw_select_records $qcmd} \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ -padx 9 \
-pady 3 -text {Execute query} -pady 3 -text {Execute query}
button $base.termbtn \ button $base.termbtn \
-borderwidth 1 \ -borderwidth 1 \
...@@ -2311,22 +2598,20 @@ set cbv 0 ...@@ -2311,22 +2598,20 @@ set cbv 0
set queryname {} set queryname {}
.qb.text1 delete 1.0 end .qb.text1 delete 1.0 end
Window hide .qb} \ Window hide .qb} \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ -padx 9 \
-pady 3 -text Close -pady 3 -text Close
text $base.text1 \ text $base.text1 \
-background #fefefe -borderwidth 1 \ -background #fefefe -borderwidth 1 \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
-highlightthickness 1 -wrap word -highlightthickness 1 -wrap word
checkbutton $base.cbv \ checkbutton $base.cbv \
-borderwidth 1 \ -borderwidth 1 \
-font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \
-text {Save this query as a view} -variable cbv -text {Save this query as a view} -variable cbv
button $base.qlshow \ button $base.qlshow \
-borderwidth 1 \ -borderwidth 1 \
-command {Window show .ql -command {Window show .ql
ql_draw_lizzard ql_draw_lizzard
focus .ql.entt} \ focus .ql.entt} \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ -padx 9 \
-pady 3 -text {Visual designer} -pady 3 -text {Visual designer}
################### ###################
# SETTING GEOMETRY # SETTING GEOMETRY
...@@ -2359,10 +2644,9 @@ proc vTclWindow.ql {base} { ...@@ -2359,10 +2644,9 @@ proc vTclWindow.ql {base} {
################### ###################
# CREATING WIDGETS # CREATING WIDGETS
################### ###################
toplevel $base -class Toplevel \ toplevel $base -class Toplevel -cursor top_left_arrow
-cursor top_left_arrow
wm focusmodel $base passive wm focusmodel $base passive
wm geometry $base 759x530+135+154 wm geometry $base 759x530+228+154
wm maxsize $base 1009 738 wm maxsize $base 1009 738
wm minsize $base 1 1 wm minsize $base 1 1
wm overrideredirect $base 0 wm overrideredirect $base 0
...@@ -2380,71 +2664,39 @@ proc vTclWindow.ql {base} { ...@@ -2380,71 +2664,39 @@ proc vTclWindow.ql {base} {
bind $base <Key-Delete> { bind $base <Key-Delete> {
ql_delete_object ql_delete_object
} }
canvas $base.c \ canvas $base.c -background #fefefe -borderwidth 2 -height 207 -relief ridge -takefocus 0 -width 295
-background #fefefe -borderwidth 2 -height 207 -relief ridge \ button $base.b1 -borderwidth 1 -command ql_add_new_table -padx 9 -pady 3 -text {Add table}
-takefocus 0 -width 295 button $base.exitbtn -borderwidth 1 -command {ql_init
button $base.b1 \ Window hide .ql} -padx 9 -pady 3 -text Close
-borderwidth 1 -command ql_add_new_table \ button $base.showbtn -borderwidth 1 -command ql_show_sql -padx 9 -pady 3 -text {Show SQL}
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ label $base.l12 -borderwidth 0 -relief raised -text Table
-pady 3 -text {Add table} entry $base.entt -background #fefefe -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable qlvar(newtablename)
button $base.exitbtn \
-borderwidth 1 -command {ql_init
Window hide .ql} \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \
-pady 3 -text Close
button $base.showbtn \
-borderwidth 1 -command ql_show_sql \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \
-pady 3 -text {Show SQL}
label $base.l12 \
-borderwidth 0 \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
-relief raised -text Table
entry $base.entt \
-background #fefefe -borderwidth 1 -highlightthickness 1 \
-selectborderwidth 0 -textvariable qlvar(newtablename)
bind $base.entt <Key-Return> { bind $base.entt <Key-Return> {
ql_add_new_table ql_add_new_table
} }
button $base.execbtn \ button $base.execbtn -borderwidth 1 -command {Window show .mw
-borderwidth 1 \
-command {Window show .mw
set qcmd [ql_compute_sql] set qcmd [ql_compute_sql]
set layout_name nolayoutneeded set mw(layout_name) nolayoutneeded
load_layout $layout_name mw_load_layout $mw(layout_name)
set ds_query $qcmd set mw(query) $qcmd
set ds_updatable false set mw(updatable) 0
set ds_isaquery true set mw(isaquery) 1
select_records $qcmd} \ mw_select_records $qcmd} -padx 9 -pady 3 -text {Execute SQL}
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ button $base.stoqb -borderwidth 1 -command {Window show .qb
-pady 3 -text {Execute SQL}
button $base.stoqb \
-borderwidth 1 \
-command {Window show .qb
.qb.text1 delete 1.0 end .qb.text1 delete 1.0 end
.qb.text1 insert end [ql_compute_sql] .qb.text1 insert end [ql_compute_sql]
focus .qb} \ focus .qb} -padx 9 -pady 3 -text {Save to query builder}
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \
-pady 3 -text {Save to query builder}
################### ###################
# SETTING GEOMETRY # SETTING GEOMETRY
################### ###################
place $base.c \ place $base.c -x 5 -y 30 -width 748 -height 500 -anchor nw -bordermode ignore
-x 5 -y 30 -width 748 -height 500 -anchor nw -bordermode ignore place $base.b1 -x 180 -y 5 -height 26 -anchor nw -bordermode ignore
place $base.b1 \ place $base.exitbtn -x 695 -y 5 -height 26 -anchor nw -bordermode ignore
-x 180 -y 5 -height 26 -anchor nw -bordermode ignore place $base.showbtn -x 367 -y 5 -height 26 -anchor nw -bordermode ignore
place $base.exitbtn \ place $base.l12 -x 10 -y 8 -width 33 -height 16 -anchor nw -bordermode ignore
-x 695 -y 5 -height 26 -anchor nw -bordermode ignore place $base.entt -x 50 -y 7 -width 126 -height 20 -anchor nw -bordermode ignore
place $base.showbtn \ place $base.execbtn -x 452 -y 5 -height 26 -anchor nw -bordermode ignore
-x 367 -y 5 -height 26 -anchor nw -bordermode ignore place $base.stoqb -x 550 -y 5 -height 26 -anchor nw -bordermode ignore
place $base.l12 \
-x 10 -y 8 -width 33 -height 16 -anchor nw -bordermode ignore
place $base.entt \
-x 50 -y 7 -width 126 -height 20 -anchor nw -bordermode ignore
place $base.execbtn \
-x 452 -y 5 -height 26 -anchor nw -bordermode ignore
place $base.stoqb \
-x 550 -y 5 -height 26 -anchor nw -bordermode ignore
} }
proc vTclWindow.rf {base} { proc vTclWindow.rf {base} {
...@@ -2465,7 +2717,7 @@ proc vTclWindow.rf {base} { ...@@ -2465,7 +2717,7 @@ proc vTclWindow.rf {base} {
wm overrideredirect $base 0 wm overrideredirect $base 0
wm resizable $base 0 0 wm resizable $base 0 0
wm title $base "Rename" wm title $base "Rename"
label $base.l1 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text {New name} label $base.l1 -borderwidth 0 -relief raised -text {New name}
entry $base.e1 -background #fefefe -borderwidth 1 -textvariable newobjname entry $base.e1 -background #fefefe -borderwidth 1 -textvariable newobjname
button $base.b1 -borderwidth 1 -command { button $base.b1 -borderwidth 1 -command {
if {$newobjname==""} { if {$newobjname==""} {
...@@ -2492,8 +2744,8 @@ proc vTclWindow.rf {base} { ...@@ -2492,8 +2744,8 @@ proc vTclWindow.rf {base} {
Window hide .rf Window hide .rf
} }
} }
} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text Rename } -padx 9 -pady 3 -text Rename
button $base.b2 -borderwidth 1 -command {Window hide .rf} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text Cancel button $base.b2 -borderwidth 1 -command {Window hide .rf} -padx 9 -pady 3 -text Cancel
################### ###################
# SETTING GEOMETRY # SETTING GEOMETRY
################### ###################
...@@ -2521,15 +2773,15 @@ proc vTclWindow.sqf {base} { ...@@ -2521,15 +2773,15 @@ proc vTclWindow.sqf {base} {
wm overrideredirect $base 0 wm overrideredirect $base 0
wm resizable $base 0 0 wm resizable $base 0 0
wm title $base "Sequence" wm title $base "Sequence"
label $base.l1 -anchor w -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text {Sequence name} label $base.l1 -anchor w -borderwidth 0 -relief raised -text {Sequence name}
entry $base.e1 -borderwidth 1 -highlightthickness 1 -textvariable seq_name entry $base.e1 -borderwidth 1 -highlightthickness 1 -textvariable seq_name
label $base.l2 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text Increment label $base.l2 -borderwidth 0 -relief raised -text Increment
entry $base.e2 -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable seq_inc entry $base.e2 -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable seq_inc
label $base.l3 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text {Start value} label $base.l3 -borderwidth 0 -relief raised -text {Start value}
entry $base.e3 -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable seq_start entry $base.e3 -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable seq_start
label $base.l4 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text Minvalue label $base.l4 -borderwidth 0 -relief raised -text Minvalue
entry $base.e4 -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable seq_minval entry $base.e4 -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable seq_minval
label $base.l5 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text Maxvalue label $base.l5 -borderwidth 0 -relief raised -text Maxvalue
entry $base.e5 -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable seq_maxval entry $base.e5 -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable seq_maxval
button $base.defbtn -borderwidth 1 -command { button $base.defbtn -borderwidth 1 -command {
if {$seq_name==""} { if {$seq_name==""} {
...@@ -2546,7 +2798,7 @@ proc vTclWindow.sqf {base} { ...@@ -2546,7 +2798,7 @@ proc vTclWindow.sqf {base} {
tk_messageBox -title Information -message "Sequence created!" tk_messageBox -title Information -message "Sequence created!"
} }
} }
} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text {Define sequence} } -padx 9 -pady 3 -text {Define sequence}
button $base.closebtn -borderwidth 1 -command {for {set i 1} {$i<6} {incr i} { button $base.closebtn -borderwidth 1 -command {for {set i 1} {$i<6} {incr i} {
.sqf.e$i configure -state normal .sqf.e$i configure -state normal
.sqf.e$i delete 0 end .sqf.e$i delete 0 end
...@@ -2555,7 +2807,7 @@ proc vTclWindow.sqf {base} { ...@@ -2555,7 +2807,7 @@ proc vTclWindow.sqf {base} {
} }
place .sqf.defbtn -x 40 -y 175 place .sqf.defbtn -x 40 -y 175
Window hide .sqf Window hide .sqf
} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text Close } -padx 9 -pady 3 -text Close
################### ###################
# SETTING GEOMETRY # SETTING GEOMETRY
################### ###################
...@@ -2585,35 +2837,125 @@ proc vTclWindow.tiw {base} { ...@@ -2585,35 +2837,125 @@ proc vTclWindow.tiw {base} {
################### ###################
toplevel $base -class Toplevel toplevel $base -class Toplevel
wm focusmodel $base passive wm focusmodel $base passive
wm geometry $base 395x309+300+240 wm geometry $base 390x460+243+120
wm maxsize $base 1009 738 wm maxsize $base 1009 738
wm minsize $base 1 1 wm minsize $base 1 1
wm overrideredirect $base 0 wm overrideredirect $base 0
wm resizable $base 1 1 wm resizable $base 1 1
wm title $base "Table information" wm title $base "Table information"
label $base.l1 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text {Table name} label $base.l1 \
label $base.l2 -anchor w -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text note -textvariable tiw(tablename) -borderwidth 0 \
label $base.l3 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text Owner -relief raised -text {Table name}
label $base.l4 -anchor w -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -text teo -textvariable tiw(owner) label $base.l2 \
listbox $base.lb -background #fefefe -borderwidth 1 -font -*-Clean-Medium-R-Normal--*-130-*-*-*-*-*-* -highlightthickness 1 -selectborderwidth 0 -yscrollcommand {.tiw.sb set} -anchor w -borderwidth 0 \
scrollbar $base.sb -activebackground #d9d9d9 -activerelief sunken -borderwidth 1 -command {.tiw.lb yview} -orient vert -relief raised -text conturi -textvariable tiw(tablename)
button $base.closebtn -borderwidth 1 -command {Window hide .tiw} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text Close label $base.l3 \
label $base.l10 -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text {field name} -borderwidth 0 \
label $base.l11 -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text {field type} -relief raised -text Owner
label $base.l12 -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text size label $base.l4 \
-anchor w -borderwidth 1 \
-textvariable tiw(owner)
listbox $base.lb \
-background #fefefe -borderwidth 1 \
-font -*-Clean-Medium-R-Normal--*-130-*-*-*-*-*-* \
-highlightthickness 1 -selectborderwidth 0 \
-yscrollcommand {.tiw.sb set}
scrollbar $base.sb \
-activebackground #d9d9d9 -activerelief sunken -borderwidth 1 \
-command {.tiw.lb yview} -orient vert
button $base.closebtn \
-borderwidth 1 -command {Window hide .tiw} \
-pady 3 -text Close
label $base.l10 \
-borderwidth 1 \
-relief raised -text {field name}
label $base.l11 \
-borderwidth 1 \
-relief raised -text {field type}
label $base.l12 \
-borderwidth 1 \
-relief raised -text size
label $base.lfi \
-borderwidth 0 \
-relief raised -text {Field information}
label $base.lii \
-borderwidth 1 \
-relief raised -text {Indexes defined}
listbox $base.ilb \
-background #fefefe -borderwidth 1 \
-highlightthickness 1 -selectborderwidth 0
bind $base.ilb <ButtonRelease-1> {
tiw_show_index
}
label $base.lip \
-borderwidth 1 \
-relief raised -text {index properties}
frame $base.fr11 \
-borderwidth 1 -height 75 -relief sunken -width 125
label $base.fr11.l9 \
-borderwidth 0 \
-relief raised -text {Is clustered ?}
label $base.fr11.l2 \
-borderwidth 0 \
-relief raised -text {Is unique ?}
label $base.fr11.liu \
-anchor nw -borderwidth 0 \
-relief raised -text Yes -textvariable tiw(isunique)
label $base.fr11.lic \
-anchor nw -borderwidth 0 \
-relief raised -text No -textvariable tiw(isclustered)
label $base.fr11.l5 \
-borderwidth 0 \
-relief raised -text {Fields :}
label $base.fr11.lif \
-anchor nw -borderwidth 1 \
-justify left -relief sunken -text cont \
-textvariable tiw(indexfields) -wraplength 170
################### ###################
# SETTING GEOMETRY # SETTING GEOMETRY
################### ###################
place $base.l1 -x 25 -y 15 -anchor nw -bordermode ignore place $base.l1 \
place $base.l2 -x 100 -y 14 -width 161 -height 18 -anchor nw -bordermode ignore -x 20 -y 15 -anchor nw -bordermode ignore
place $base.l3 -x 25 -y 35 -anchor nw -bordermode ignore place $base.l2 \
place $base.l4 -x 100 -y 34 -width 226 -height 18 -anchor nw -bordermode ignore -x 100 -y 14 -width 161 -height 18 -anchor nw -bordermode ignore
place $base.lb -x 25 -y 90 -width 333 -height 176 -anchor nw -bordermode ignore place $base.l3 \
place $base.sb -x 355 -y 90 -width 18 -height 177 -anchor nw -bordermode ignore -x 20 -y 35 -anchor nw -bordermode ignore
place $base.closebtn -x 170 -y 275 -anchor nw -bordermode ignore place $base.l4 \
place $base.l10 -x 26 -y 75 -width 199 -height 18 -anchor nw -bordermode ignore -x 100 -y 34 -width 226 -height 18 -anchor nw -bordermode ignore
place $base.l11 -x 225 -y 75 -width 90 -height 18 -anchor nw -bordermode ignore place $base.lb \
place $base.l12 -x 315 -y 75 -width 41 -height 18 -anchor nw -bordermode ignore -x 20 -y 91 -width 338 -height 171 -anchor nw -bordermode ignore
place $base.sb \
-x 355 -y 90 -width 18 -height 173 -anchor nw -bordermode ignore
place $base.closebtn \
-x 325 -y 5 -anchor nw -bordermode ignore
place $base.l10 \
-x 21 -y 75 -width 204 -height 18 -anchor nw -bordermode ignore
place $base.l11 \
-x 225 -y 75 -width 90 -height 18 -anchor nw -bordermode ignore
place $base.l12 \
-x 315 -y 75 -width 41 -height 18 -anchor nw -bordermode ignore
place $base.lfi \
-x 20 -y 55 -anchor nw -bordermode ignore
place $base.lii \
-x 20 -y 280 -width 151 -height 18 -anchor nw -bordermode ignore
place $base.ilb \
-x 20 -y 296 -width 150 -height 148 -anchor nw -bordermode ignore
place $base.lip \
-x 171 -y 280 -width 198 -height 18 -anchor nw -bordermode ignore
place $base.fr11 \
-x 170 -y 297 -width 199 -height 147 -anchor nw -bordermode ignore
place $base.fr11.l9 \
-x 10 -y 30 -anchor nw -bordermode ignore
place $base.fr11.l2 \
-x 10 -y 10 -anchor nw -bordermode ignore
place $base.fr11.liu \
-x 95 -y 10 -width 27 -height 16 -anchor nw -bordermode ignore
place $base.fr11.lic \
-x 95 -y 30 -width 32 -height 16 -anchor nw -bordermode ignore
place $base.fr11.l5 \
-x 10 -y 55 -anchor nw -bordermode ignore
place $base.fr11.lif \
-x 10 -y 70 -width 178 -height 68 -anchor nw -bordermode ignore
} }
Window show . Window show .
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment