From c77c608aa2aba1d8b8e70f6d35371d09b48ff584 Mon Sep 17 00:00:00 2001 From: "Marc G. Fournier" Date: Mon, 12 Jan 1998 18:10:28 +0000 Subject: [PATCH] Upgrade to 0.76 --- src/bin/pgaccess/copyright.html | 39 + src/bin/pgaccess/pgaccess.tcl | 2776 ++++++++++++++++++++++++--------------- 2 files changed, 1769 insertions(+), 1046 deletions(-) create mode 100644 src/bin/pgaccess/copyright.html diff --git a/src/bin/pgaccess/copyright.html b/src/bin/pgaccess/copyright.html new file mode 100644 index 0000000000..d67654b88e --- /dev/null +++ b/src/bin/pgaccess/copyright.html @@ -0,0 +1,39 @@ + + + + + PgAccess - Copyright notice + + +--------------------------------------------------------------------------- +
  +
  + +

Copyright (c) 1994-7 Regents of the University of California + +

Permission to use, copy, modify, and distribute this software and +its +
documentation for any purpose, without fee, and without a written +agreement +
is hereby granted, provided that the above copyright notice and +this +
paragraph and the following two paragraphs appear in all copies. + +

IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY +PARTY FOR +
DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES, +INCLUDING +
LOST PROFITS, ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS +
DOCUMENTATION, EVEN IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED +OF THE +
POSSIBILITY OF SUCH DAMAGE. + +

THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, +
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY +
AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER +IS +
ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATIONS +TO +
PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + + diff --git a/src/bin/pgaccess/pgaccess.tcl b/src/bin/pgaccess/pgaccess.tcl index b0f6f93f99..3dddf5ad9e 100644 --- a/src/bin/pgaccess/pgaccess.tcl +++ b/src/bin/pgaccess/pgaccess.tcl @@ -1,6 +1,6 @@ #!/usr/bin/wish ############################################################################# -# Visual Tcl v1.10 Project +# Visual Tcl v1.11 Project # ################################# @@ -9,8 +9,8 @@ global activetab; global dbc; global dbname; -global mw; global host; +global mw; global newdbname; global newhost; global newpport; @@ -32,7 +32,7 @@ foreach wid {Label Text Button Listbox Checkbutton Radiobutton} { set host localhost set pport 5432 set dbc {} -set tablist [list Tables Queries Views Sequences Functions Reports Scripts] +set tablist [list Tables Queries Views Sequences Functions Reports Forms Scripts] set activetab {} set mw(dirtyrec) 0 set mw(id_edited) {} @@ -53,7 +53,11 @@ set qlvar(newtablename) {} init $argc $argv -proc add_new_field {} { +proc {MsgBox} {mesaj} { +tk_messageBox -title Mesaj -message $mesaj +} + +proc {add_new_field} {} { global fldname fldtype fldsize defaultval notnull if {$fldname==""} { show_error "Enter a field name" @@ -89,7 +93,7 @@ set fldsize {} set defaultval {} } -proc cmd_Delete {} { +proc {cmd_Delete} {} { global dbc activetab if {$dbc==""} return; set objtodelete [get_dwlb_Selection] @@ -117,6 +121,18 @@ switch $activetab { cmd_Queries } } + Scripts { + if {[tk_messageBox -title "FINAL WARNING" -message "You are going to delete script:\n\n$objtodelete\n\nProceed ?" -type yesno -default no]=="yes"} { + sql_exec quiet "delete from pga_scripts where scriptname='$objtodelete'" + cmd_Scripts + } + } + Forms { + if {[tk_messageBox -title "FINAL WARNING" -message "You are going to delete form:\n\n$objtodelete\n\nProceed ?" -type yesno -default no]=="yes"} { + sql_exec quiet "delete from pga_forms where formname='$objtodelete'" + cmd_Forms + } + } Sequences { if {[tk_messageBox -title "FINAL WARNING" -message "You are going to delete sequence:\n\n$objtodelete\n\nProceed ?" -type yesno -default no]=="yes"} { sql_exec quiet "drop sequence $objtodelete" @@ -129,21 +145,49 @@ switch $activetab { cmd_Functions } } + Reports { + if {[tk_messageBox -title "FINAL WARNING" -message "You are going to delete report:\n\n$objtodelete\n\nProceed ?" -type yesno -default no]=="yes"} { + sql_exec noquiet "delete from pga_reports where reportname='$objtodelete'" + cmd_Reports + } + } } if {$temp==""} return; } -proc cmd_Design {} { -global dbc activetab tablename +proc {cmd_Design} {} { +global dbc activetab tablename rbvar if {$dbc==""} return; if {[.dw.lb curselection]==""} return; -set tablename [.dw.lb get [.dw.lb curselection]] +set objname [.dw.lb get [.dw.lb curselection]] +set tablename $objname switch $activetab { Queries {open_query design} + Scripts {design_script $objname} + Reports { + Window show .rb + tkwait visibility .rb + rb_init + set rbvar(reportname) $objname + rb_load_report + set rbvar(justpreview) 0 + } +} +} + +proc {cmd_Forms} {} { +global dbc +cursor_watch .dw +.dw.lb delete 0 end +catch { + pg_select $dbc "select * from pga_forms order by formname" rec { + .dw.lb insert end $rec(formname) + } } +cursor_arrow .dw } -proc cmd_Functions {} { +proc {cmd_Functions} {} { global dbc set maxim 0 set pgid 0 @@ -165,7 +209,7 @@ cursor_arrow .dw } } -proc cmd_Import_Export {how} { +proc {cmd_Import_Export} {how} { global dbc ie_tablename ie_filename activetab if {$dbc==""} return; Window show .iew @@ -180,103 +224,83 @@ if {$activetab=="Tables"} { .iew.expbtn configure -text $how } -proc cmd_Information {} { -global dbc tiw activetab indexlist +proc {cmd_Information} {} { +global dbc tiw activetab if {$dbc==""} return; if {$activetab!="Tables"} return; -set tiw(tablename) [get_dwlb_Selection] -if {$tiw(tablename)==""} return; -Window show .tiw -.tiw.lb delete 0 end -.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 ftype $rec(typname) - if {$ftype=="varchar"} { - incr fsize -4 - } - if {$ftype=="bpchar"} { - incr fsize -4 - } - if {$ftype=="text"} { - set fsize "" - } - if {$rec(attnum)>0} {.tiw.lb insert end [format "%-32s %-14s %-4s" $rec(attname) $ftype $fsize]} - 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) - } -} +show_table_information [get_dwlb_Selection] } -proc cmd_New {} { -global dbc activetab queryname queryoid cbv funcpar funcname funcret +proc {cmd_New} {} { +global dbc activetab queryname queryoid cbv funcpar funcname funcret rbvar if {$dbc==""} return; switch $activetab { - Tables {Window show .nt; focus .nt.etabn} + Tables { + Window show .nt + focus .nt.etabn + } Queries { - Window show .qb - set queryoid 0 - set queryname {} - set cbv 0 - .qb.cbv configure -state normal - } + Window show .qb + set queryoid 0 + set queryname {} + set cbv 0 + .qb.cbv configure -state normal + } Views { - set queryoid 0 - set queryname {} - Window show .qb - set cbv 1 - .qb.cbv configure -state disabled - } + set queryoid 0 + set queryname {} + Window show .qb + set cbv 1 + .qb.cbv configure -state disabled + } Sequences { - Window show .sqf - focus .sqf.e1 - } - Functions { - Window show .fw - set funcname {} - set funcpar {} - set funcret {} - place .fw.okbtn -y 255 - .fw.okbtn configure -state normal - .fw.okbtn configure -text Define - .fw.text1 delete 1.0 end - focus .fw.e1 - } + Window show .sqf + focus .sqf.e1 + } + Reports { + Window show .rb ; tkwait visibility .rb ; rb_init ; set rbvar(reportname) {} ; set rbvar(justpreview) 0 + focus .rb.e2 + } + Scripts { + design_script {} + } + Functions { + Window show .fw + set funcname {} + set funcpar {} + set funcret {} + place .fw.okbtn -y 255 + .fw.okbtn configure -state normal + .fw.okbtn configure -text Define + .fw.text1 delete 1.0 end + focus .fw.e1 + } } } -proc cmd_Open {} { +proc {cmd_Open} {} { global dbc activetab if {$dbc==""} return; set objname [get_dwlb_Selection] if {$objname==""} return; switch $activetab { - Tables {Window show .mw; load_table $objname} + Tables {open_table $objname} + Forms {open_form $objname} + Scripts {execute_script $objname} Queries {open_query view} - Views {open_view} - Sequences {open_sequence $objname} - Functions {open_function $objname} + Views {open_view} + Sequences {open_sequence $objname} + Functions {open_function $objname} + Reports {open_report $objname} } } -proc cmd_Preferences {} { -# Show +proc {cmd_Preferences} {} { Window show .pw } -proc cmd_Queries {} { +proc {cmd_Queries} {} { global dbc - .dw.lb delete 0 end catch { pg_select $dbc "select * from pga_queries order by queryname" rec { @@ -285,7 +309,7 @@ catch { } } -proc cmd_Rename {} { +proc {cmd_Rename} {} { global dbc oldobjname activetab if {$dbc==""} return; if {$activetab=="Views"} return; @@ -300,59 +324,47 @@ set oldobjname $temp Window show .rf } -proc cmd_Reports {} { +proc {cmd_Reports} {} { global dbc +catch { + pg_select $dbc "select * from pga_reports order by reportname" rec { + .dw.lb insert end "$rec(reportname)" + } } - -proc cmd_Scripts {} { -global dbc } -proc cmd_Sequences {} { +proc {cmd_Scripts} {} { global dbc - -cursor_watch .dw .dw.lb delete 0 end catch { - pg_select $dbc "select * from pg_class where (relname not like 'pg_%') and (relkind='S') order by relname" rec { - .dw.lb insert end $rec(relname) + pg_select $dbc "select * from pga_scripts order by scriptname" rec { + .dw.lb insert end $rec(scriptname) } } -cursor_arrow .dw } -proc cmd_Tables {} { +proc {cmd_Sequences} {} { global dbc cursor_watch .dw .dw.lb delete 0 end catch { - pg_select $dbc "select * from pg_class where (relname !~ '^pg_') and (relkind='r') and (not relhasrules) order by relname" rec { - if {![regexp "^pga_" $rec(relname)]} {.dw.lb insert end $rec(relname)} + pg_select $dbc "select * from pg_class where (relname not like 'pg_%') and (relkind='S') order by relname" rec { + .dw.lb insert end $rec(relname) } } cursor_arrow .dw } -proc cmd_Vacuum {} { -global dbc dbname sdbname - -if {$dbc==""} return; +proc {cmd_Tables} {} { +global dbc cursor_watch .dw -set sdbname "vacuuming database $dbname ..." -update; update idletasks -set retval [catch { - set pgres [pg_exec $dbc "vacuum;"] - pg_result $pgres -clear - } msg] +.dw.lb delete 0 end +foreach tbl [get_tables] {.dw.lb insert end $tbl} cursor_arrow .dw -set sdbname $dbname -if {$retval} { - show_error $msg -} } -proc cmd_Views {} { +proc {cmd_Views} {} { global dbc cursor_watch .dw @@ -365,41 +377,26 @@ catch { cursor_arrow .dw } -proc mw_show_record {row} { -global mw msg -set mw(errorsavingnew) 0 -if {$mw(newrec_fields)!=""} { - if {$row!=$mw(last_rownum)} { - if {![mw_save_new_record]} { - set mw(errorsavingnew) 1 - return - } - } -} -set y1 [lindex $mw(rowy) $row] -set y2 [lindex $mw(rowy) [expr $row+1]] -if {$y2==""} {set y2 [expr $y1+14]} -.mw.c dtag hili hili -.mw.c addtag hili withtag r$row -# 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 {create_drop_down} {base x y} { +frame $base.ddf -borderwidth 1 -height 75 -relief raised -width 55 +listbox $base.ddf.lb -background #fefefe -borderwidth 1 -font -Adobe-Helvetica-medium-R-Normal--*-120-*-*-*-*-*-* -highlightthickness 0 -selectborderwidth 0 -yscrollcommand [subst {$base.ddf.sb set}] +scrollbar $base.ddf.sb -borderwidth 1 -command [subst {$base.ddf.lb yview}] -highlightthickness 0 -orient vert +place $base.ddf -x $x -y $y -width 220 -height 185 -anchor nw -bordermode ignore +place $base.ddf.lb -x 1 -y 1 -width 202 -height 182 -anchor nw -bordermode ignore +place $base.ddf.sb -x 205 -y 1 -width 14 -height 183 -anchor nw -bordermode ignore } -proc cursor_arrow {w} { +proc {cursor_arrow} {w} { $w configure -cursor top_left_arrow update idletasks } -proc cursor_watch {w} { +proc {cursor_watch} {w} { $w configure -cursor watch update idletasks } -proc delete_function {objname} { +proc {delete_function} {objname} { global dbc pg_select $dbc "select * from pg_proc where proname='$objname'" rec { set funcpar $rec(proargtypes) @@ -413,22 +410,18 @@ set lispar [join $lispar ,] sql_exec noquiet "drop function $objname ($lispar)" } -proc mw_delete_record {} { -global dbc mw tablename -if {!$mw(updatable)} return; -if {![mw_exit_edit]} return; -set taglist [.mw.c gettags hili] -if {[llength $taglist]==0} return; -set rowtag [lindex $taglist [lsearch -regexp $taglist "^r"]] -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 {[sql_exec noquiet "delete from $tablename where oid=$oid"]} { - .mw.c delete hili +proc {design_script} {sname} { +global dbc scriptname +Window show .sw +set scriptname $sname +.sw.src delete 1.0 end +if {[string length $sname]==0} return; +pg_select $dbc "select * from pga_scripts where scriptname='$sname'" rec { + .sw.src insert end $rec(scriptsource) } } -proc drag_it {w x y} { +proc {drag_it} {w x y} { global draglocation set dlo "" catch { set dlo $draglocation(obj) } @@ -441,7 +434,7 @@ global draglocation } } -proc drag_start {w x y} { +proc {drag_start} {w x y} { global draglocation catch {unset draglocation} set object [$w find closest $x $y] @@ -453,7 +446,7 @@ set draglocation(y) $y set draglocation(start) $x } -proc drag_stop {w x y} { +proc {drag_stop} {w x y} { global draglocation mw dbc set dlo "" catch { set dlo $draglocation(obj) } @@ -485,7 +478,129 @@ global draglocation mw dbc } } -proc mw_draw_headers {} { +proc {draw_tabs} {} { +global tablist activetab +set ypos 85 +foreach tab $tablist { + label .dw.tab$tab -borderwidth 1 -anchor w -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text $tab + place .dw.tab$tab -x 10 -y $ypos -height 25 -width 82 -anchor nw -bordermode ignore + lower .dw.tab$tab + bind .dw.tab$tab {tab_click %W} + incr ypos 25 +} +set activetab "" +} + +proc {execute_script} {scriptname} { +global dbc + set ss {} + pg_select $dbc "select * from pga_scripts where scriptname='$scriptname'" rec { + set ss $rec(scriptsource) + } +# if {[string length $ss] > 0} { + eval $ss +# } +} + +proc {get_dwlb_Selection} {} { +set temp [.dw.lb curselection] +if {$temp==""} return ""; +return [.dw.lb get $temp] +} + +proc {get_pgtype} {oid} { +global dbc +set temp "unknown" +pg_select $dbc "select typname from pg_type where oid=$oid" rec { + set temp $rec(typname) +} +return $temp +} + +proc {get_tables} {} { +global dbc +set tbl {} +catch { + pg_select $dbc "select * from pg_class where (relname !~ '^pg_') and (relkind='r') and (not relhasrules) order by relname" rec { + if {![regexp "^pga_" $rec(relname)]} then {lappend tbl $rec(relname)} + } +} +return $tbl +} + +proc {get_tag_info} {itemid prefix} { +set taglist [.mw.c itemcget $itemid -tags] +set i [lsearch -glob $taglist $prefix*] +set thetag [lindex $taglist $i] +return [string range $thetag 1 end] +} + +proc {load_pref} {} { +global pref +set retval [catch {set fid [open "~/.pgaccessrc" r]}] +if {$retval} { + set pref(rows) 200 + set pref(tvfont) clean + set pref(autoload) 1 + set pref(lastdb) {} + set pref(lasthost) localhost + set pref(lastport) 5432 +} else { + while {![eof $fid]} { + set pair [gets $fid] + set pref([lindex $pair 0]) [lindex $pair 1] + } + close $fid +} +} + +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 {mw_delete_record} {} { +global dbc mw tablename +if {!$mw(updatable)} return; +if {![mw_exit_edit]} return; +set taglist [.mw.c gettags hili] +if {[llength $taglist]==0} return; +set rowtag [lindex $taglist [lsearch -regexp $taglist "^r"]] +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 {[sql_exec noquiet "delete from $tablename where oid=$oid"]} { + .mw.c delete hili +} +} + +proc {mw_draw_headers} {} { global mw .mw.c delete header set posx [expr 5-$mw(leftoffset)] @@ -507,8 +622,28 @@ set mw(r_edge) $posx .mw.c bind movable {.mw configure -cursor top_left_arrow} } -proc mw_draw_new_record {} { -global mw pref +proc {mw_draw_hgrid} {} { +global mw +.mw.c delete hgrid +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 +for {set i 0} {$i<$mw(nrecs)} {incr i} { + .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 {$mw(updatable)} { + set i $mw(nrecs) + set posy [expr 14+[lindex $mw(rowy) $mw(nrecs)]] + .mw.c create line [expr -$mw(leftoffset)] $posy [expr $posx-$mw(leftoffset)] $posy -fill gray -tags [subst {hgrid g$i}] +} +} + +proc {mw_draw_new_record} {} { +global mw pref msg set posx 10 set posy [lindex $mw(rowy) $mw(last_rownum)] if {$pref(tvfont)=="helv"} { @@ -516,30 +651,17 @@ if {$pref(tvfont)=="helv"} { } 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] +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)}] } } -proc draw_tabs {} { -global tablist activetab -set ypos 85 -foreach tab $tablist { - label .dw.tab$tab -borderwidth 1 -anchor w -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text $tab - place .dw.tab$tab -x 10 -y $ypos -height 25 -width 82 -anchor nw -bordermode ignore - lower .dw.tab$tab - bind .dw.tab$tab {tab_click %W} - incr ypos 25 -} -set activetab "" -} - -proc mw_edit_text {c k} { +proc {mw_edit_text} {c k} { global mw msg set bbin [.mw.c bbox r$mw(row_edited)] switch $k { @@ -570,29 +692,7 @@ mw_show_record $mw(row_edited) # Delete {.mw.c dchars $mw(id_edited) insert insert; set mw(dirtyrec) 1} } -proc get_dwlb_Selection {} { -set temp [.dw.lb curselection] -if {$temp==""} return ""; -return [.dw.lb get $temp] -} - -proc get_pgtype {oid} { -global dbc -set temp "unknown" -pg_select $dbc "select typname from pg_type where oid=$oid" rec { - set temp $rec(typname) -} -return $temp -} - -proc get_tag_info {itemid prefix} { -set taglist [.mw.c itemcget $itemid -tags] -set i [lsearch -glob $taglist $prefix*] -set thetag [lindex $taglist $i] -return [string range $thetag 1 end] -} - -proc mw_exit_edit {} { +proc {mw_exit_edit} {} { global mw dbc msg tablename # User has edited the text ? if {!$mw(dirtyrec)} { @@ -636,7 +736,8 @@ if {$mw(row_edited)==$mw(last_rownum)} { } else { set msg "Updating record ..." after 1000 {set msg ""} - set retval [sql_exec noquiet "update $tablename set $fld='$fldval' where oid=$oid"] + regsub -all ' $fldval \\' sqlfldval + set retval [sql_exec noquiet "update $tablename set $fld='$sqlfldval' where oid=$oid"] } cursor_arrow .mw if {!$retval} { @@ -650,7 +751,7 @@ set mw(id_edited) {};set mw(text_initial_value) {} return 1 } -proc mw_load_layout {tablename} { +proc {mw_load_layout} {tablename} { global dbc msg mw cursor_watch .mw set mw(layout_name) $tablename @@ -676,71 +777,245 @@ if {$retval} { sql_exec quiet "delete from pga_layout where (tablename='$tablename') and (oid<>$goodoid)" } } -catch {pg_result $pgres -clear} +catch {pg_result $pgres -clear} +} + +proc {mw_pan_left} {} { +global mw +if {![mw_exit_edit]} return; +if {$mw(leftcol)==[expr $mw(colcount)-1]} return; +set diff [expr 2+[lindex $mw(colwidth) $mw(leftcol)]] +incr mw(leftcol) +incr mw(leftoffset) $diff +.mw.c move header -$diff 0 +.mw.c move q -$diff 0 +.mw.c move hgrid -$diff 0 +} + +proc {mw_pan_right} {} { +global mw +if {![mw_exit_edit]} return; +if {$mw(leftcol)==0} return; +incr mw(leftcol) -1 +set diff [expr 2+[lindex $mw(colwidth) $mw(leftcol)]] +incr mw(leftoffset) -$diff +.mw.c move header $diff 0 +.mw.c move q $diff 0 +.mw.c move hgrid $diff 0 +} + +proc {mw_save_new_record} {} { +global dbc mw tablename msg +if {![mw_exit_edit]} {return 0} +if {$mw(newrec_fields)==""} {return 1} +set msg "Saving new record ..." +after 1000 {set msg ""} +set retval [catch { + set sqlcmd "insert into $tablename ([join $mw(newrec_fields) ,]) values ([join $mw(newrec_values) ,])" + set pgres [pg_exec $dbc $sqlcmd] + } errmsg] +if {$retval} { + show_error "Error inserting new record\n\n$errmsg" + return 0 +} +set oid [pg_result $pgres -oid] +lappend mw(keylist) $oid +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 dtag q new +# Replace * from untouched new row elements with " " +foreach item [.mw.c find withtag unt] { + .mw.c itemconfigure $item -text " " +} +.mw.c dtag q unt +incr mw(last_rownum) +incr mw(nrecs) +mw_draw_new_record +set mw(newrec_fields) {} +set mw(newrec_values) {} +return 1 +} + +proc {mw_scroll_window} {par1 par2 args} { +global mw +if {![mw_exit_edit]} return; +if {$par1=="scroll"} { + set newtop $mw(toprec) + if {[lindex $args 0]=="units"} { + incr newtop $par2 + } else { + incr newtop [expr $par2*25] + if {$newtop<0} {set newtop 0} + if {$newtop>=[expr $mw(nrecs)-1]} {set newtop [expr $mw(nrecs)-1]} + } +} else { + set newtop [expr int($par2*$mw(nrecs))] +} +if {$newtop<0} return; +if {$newtop>=[expr $mw(nrecs)-1]} return; +set dy [expr [lindex $mw(rowy) $mw(toprec)]-[lindex $mw(rowy) $newtop]] +.mw.c move q 0 $dy +.mw.c move hgrid 0 $dy +set newrowy {} +foreach y $mw(rowy) {lappend newrowy [expr $y+$dy]} +set mw(rowy) $newrowy +set mw(toprec) $newtop +mw_set_scrollbar +} + +proc {mw_select_records} {sql} { +global dbc field mw +global tablename msg pref +set mw(newrec_fields) {} +set mw(newrec_values) {} +if {![mw_exit_edit]} return; +.mw.c delete q +.mw.c delete header +.mw.c delete hgrid +.mw.c delete new +set mw(leftcol) 0 +set mw(leftoffset) 0 +set mw(crtrow) {} +set msg {} +set msg "Accessing data. Please wait ..." +cursor_watch .mw +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} { + sql_exec quiet "END" + set msg {} + cursor_arrow .mw + show_error "Error executing SQL command\n\n$sql\n\nError message:$errmsg" + set msg "Error executing : $sql" + return +} +if {$mw(updatable)} then {set shift 1} else {set shift 0} +# +# checking at least the numer of fields +set attrlist [pg_result $pgres -lAttributes] +if {$mw(layout_found)} then { + if { ($mw(colcount) != [expr [llength $attrlist]-$shift]) || + ($mw(colcount) != [llength $mw(colnames)]) || + ($mw(colcount) != [llength $mw(colwidth)]) } then { + # No. of columns don't match, something is wrong + # tk_messageBox -title Information -message "Layout info changed !\nRescanning..." + set mw(layout_found) 0 + sql_exec quiet "delete from pga_layout where tablename='$mw(layout_name)'" + } +} +# Always take the col. names from the result +set mw(colcount) [llength $attrlist] +if {$mw(updatable)} then {incr mw(colcount) -1} +set mw(colnames) {} +# In defmw(colwidth) prepare mw(colwidth) (in case that not layout_found) +set defmw(colwidth) {} +for {set i 0} {$i<$mw(colcount)} {incr i} { + lappend mw(colnames) [lindex [lindex $attrlist [expr $i+$shift]] 0] + lappend defmw(colwidth) 150 +} +if {!$mw(layout_found)} { + set mw(colwidth) $defmw(colwidth) + sql_exec quiet "insert into pga_layout values ('$mw(layout_name)',$mw(colcount),'$mw(colnames)','$mw(colwidth)')" + set mw(layout_found) 1 +} +set mw(nrecs) [pg_result $pgres -numTuples] +if {$mw(nrecs)>$pref(rows)} { + set msg "Only first $pref(rows) records from $mw(nrecs) have been loaded" + set mw(nrecs) $pref(rows) +} +set tagoid {} +if {$pref(tvfont)=="helv"} { + set tvfont -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* +} else { + set tvfont -*-Clean-Medium-R-Normal-*-*-130-*-*-*-*-* +} +# 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 "Loading maximum $pref(rows) records ..." +for {set i 0} {$i<$mw(nrecs)} {incr i} { + set curtup [pg_result $pgres -getTuple $i] + if {$mw(updatable)} then {lappend mw(keylist) [lindex $curtup 0]} + for {set j 0} {$j<$mw(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) -fill black + } + set bb [.mw.c bbox r$i] + incr posy [expr [lindex $bb 3]-[lindex $bb 1]] + 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} } - -proc load_pref {} { -global pref -set retval [catch {set fid [open "~/.pgaccessrc" r]}] -if {$retval} { - set pref(rows) 200 - set pref(tvfont) clean - set pref(autoload) 1 - set pref(lastdb) {} - set pref(lasthost) localhost - set pref(lastport) 5432 +after 3000 {set msg {} } +set mw(last_rownum) $i +# Defining position for input data +mw_draw_new_record +pg_result $pgres -clear +sql_exec quiet "END" +set mw(toprec) 0 +mw_set_scrollbar +if {$mw(updatable)} then { + .mw.c bind q {mw_edit_text %A %K} } else { - while {![eof $fid]} { - set pair [gets $fid] - set pref([lindex $pair 0]) [lindex $pair 1] - } - close $fid + .mw.c bind q {} } +set mw(dirtyrec) 0 +#mw_draw_headers +.mw.c raise header +cursor_arrow .mw } -proc load_table {objname} { -global mw sortfield filter tablename -set tablename $objname -mw_load_layout $objname -set mw(query) "select oid,$tablename.* from $objname" -set mw(updatable) 1 -set mw(isaquery) 0 -mw_select_records $mw(query) -wm title .mw "Table viewer : $objname" +proc {mw_set_scrollbar} {} { +global mw +if {$mw(nrecs)==0} return; +.mw.sb set [expr $mw(toprec)*1.0/$mw(nrecs)] [expr ($mw(toprec)+27.0)/$mw(nrecs)] } -proc mw_canvas_click {x y} { +proc {mw_show_record} {row} { 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 - } +set mw(errorsavingnew) 0 +if {$mw(newrec_fields)!=""} { + if {$row!=$mw(last_rownum)} { + if {![mw_save_new_record]} { + set mw(errorsavingnew) 1 + return + } + } } +set y1 [lindex $mw(rowy) $row] +set y2 [lindex $mw(rowy) [expr $row+1]] +if {$y2==""} {set y2 [expr $y1+14]} +.mw.c dtag hili hili +.mw.c addtag hili withtag r$row +# 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 mw_start_edit {id x y} { +proc {mw_start_edit} {id x y} { global mw msg if {!$mw(updatable)} return set mw(id_edited) $id @@ -757,7 +1032,7 @@ if {$mw(row_edited)==$mw(nrecs)} { } } -proc open_database {} { +proc {open_database} {} { global dbc host pport dbname sdbname newdbname newhost newpport pref catch {cursor_watch .dbod} if {[catch {set newdbc [pg_connect $newdbname -host $newhost -port $newpport]} msg]} { @@ -776,17 +1051,34 @@ if {[catch {set newdbc [pg_connect $newdbname -host $newhost -port $newpport]} m save_pref catch {cursor_arrow .dbod; Window hide .dbod} tab_click .dw.tabTables - set pgres [pg_exec $dbc "select relname from pg_class where relname='pga_queries'"] - if {[pg_result $pgres -numTuples]==0} { - pg_result $pgres -clear - sql_exec quiet "create table pga_queries (queryname varchar(64),querytype char(1),querycommand text)" - sql_exec quiet "grant ALL on pga_queries to PUBLIC" + # Check for pga_ tables + foreach {table structure} { pga_queries {queryname varchar(64),querytype char(1),querycommand text} pga_forms {formname varchar(64),formsource text} pga_scripts {scriptname varchar(64),scriptsource text} pga_reports {reportname varchar(64),reportsource text,reportbody text,reportprocs text,reportoptions text}} { + set pgres [pg_exec $dbc "select relname from pg_class where relname='$table'"] + if {[pg_result $pgres -numTuples]==0} { + pg_result $pgres -clear + sql_exec quiet "create table $table ($structure)" + sql_exec quiet "grant ALL on $table to PUBLIC" + } + catch { pg_result $pgres -clear } } - catch { pg_result $pgres -clear } + # searching for autoexec script + pg_select $dbc "select * from pga_scripts where scriptname ~* '^autoexec$'" recd { + eval $recd(scriptsource) + } +} +} + +proc {open_form} {formname} { +global dbc + +set frmsrc {} +pg_select $dbc "select * from pga_forms where formname='$formname'" rec { + set frmsrc $rec(formsource) } +eval $frmsrc } -proc open_function {objname} { +proc {open_function} {objname} { global dbc funcname funcpar funcret Window show .fw place .fw.okbtn -y 400 @@ -806,7 +1098,21 @@ for {set i 0} {$i<$funcnrp} {incr i} { set funcpar [join $funcpar ,] } -proc open_query {how} { +proc {open_report} {objname} { +global dbc rbvar +Window show .rb +#tkwait visibility .rb +Window hide .rb +Window show .rpv +rb_init +set rbvar(reportname) $objname +rb_load_report +tkwait visibility .rpv +set rbvar(justpreview) 1 +rb_preview +} + +proc {open_query} {how} { global dbc queryname mw queryoid sortfield filter if {[.dw.lb curselection]==""} return; @@ -839,7 +1145,7 @@ if {$how=="design"} { set mw(isaquery) 1 mw_select_records $qcmd } else { - set answ [tk_messageBox -title Warning -type yesno -message "This query is an action query!\n\n$qcmd\n\nDo you want to execute it?"] + set answ [tk_messageBox -title Warning -type yesno -message "This query is an action query!\n\n[string range $qcmd 0 30] ...\n\nDo you want to execute it?"] if {$answ} { if {[sql_exec noquiet $qcmd]} { tk_messageBox -title Information -message "Your query has been executed without error!" @@ -849,7 +1155,7 @@ if {$how=="design"} { } } -proc open_sequence {objname} { +proc {open_sequence} {objname} { global dbc seq_name seq_inc seq_start seq_minval seq_maxval Window show .sqf set flag 1 @@ -874,7 +1180,19 @@ if {$flag} { } } -proc open_view {} { +proc {open_table} {objname} { +global mw sortfield filter tablename +Window show .mw +set tablename $objname +mw_load_layout $objname +set mw(query) "select oid,$tablename.* from $objname" +set mw(updatable) 1 +set mw(isaquery) 0 +mw_select_records $mw(query) +wm title .mw "Table viewer : $objname" +} + +proc {open_view} {} { global mw set vn [get_dwlb_Selection] if {$vn==""} return; @@ -886,31 +1204,7 @@ mw_load_layout $vn mw_select_records $mw(query) } -proc mw_pan_left {} { -global mw -if {![mw_exit_edit]} return; -if {$mw(leftcol)==[expr $mw(colcount)-1]} return; -set diff [expr 2+[lindex $mw(colwidth) $mw(leftcol)]] -incr mw(leftcol) -incr mw(leftoffset) $diff -.mw.c move header -$diff 0 -.mw.c move q -$diff 0 -.mw.c move hgrid -$diff 0 -} - -proc mw_pan_right {} { -global mw -if {![mw_exit_edit]} return; -if {$mw(leftcol)==0} return; -incr mw(leftcol) -1 -set diff [expr 2+[lindex $mw(colwidth) $mw(leftcol)]] -incr mw(leftoffset) -$diff -.mw.c move header $diff 0 -.mw.c move q $diff 0 -.mw.c move hgrid $diff 0 -} - -proc ql_add_new_table {} { +proc {ql_add_new_table} {} { global qlvar dbc if {$qlvar(newtablename)==""} return @@ -926,6 +1220,8 @@ if {$fldlist==""} { } set qlvar(tablename$qlvar(ntables)) $qlvar(newtablename) set qlvar(tablestruct$qlvar(ntables)) $fldlist +set qlvar(tablealias$qlvar(ntables)) "t$qlvar(ntables)" +set qlvar(ali_t$qlvar(ntables)) $qlvar(newtablename) incr qlvar(ntables) if {$qlvar(ntables)==1} { ql_draw_lizzard @@ -936,7 +1232,7 @@ set qlvar(newtablename) {} focus .ql.entt } -proc ql_compute_sql {} { +proc {ql_compute_sql} {} { global qlvar set sqlcmd "select " for {set i 0} {$i<[llength $qlvar(resfields)]} {incr i} { @@ -947,7 +1243,7 @@ set tables {} for {set i 0} {$i<$qlvar(ntables)} {incr i} { set thename {} catch {set thename $qlvar(tablename$i)} - if {$thename!=""} {lappend tables $qlvar(tablename$i)} + if {$thename!=""} {lappend tables "$qlvar(tablename$i) $qlvar(tablealias$i)"} } set sqlcmd "$sqlcmd from [join $tables ,] " set sup1 {} @@ -973,7 +1269,7 @@ for {set i 0} {$i<[llength $qlvar(ressort)]} {incr i} { if {$how!="unsorted"} { if {$how=="Ascending"} {set how asc} else {set how desc} if {$sup2==""} {set sup2 " order by "} else {set sup2 "$sup2,"} - set sup2 "$sup2 [lindex $qlvar(resfields) $i] $how " + set sup2 "$sup2 [lindex $qlvar(restables) $i].[lindex $qlvar(resfields) $i] $how " } } set sqlcmd "$sqlcmd $sup2" @@ -982,7 +1278,7 @@ set qlvar(sql) $sqlcmd return $sqlcmd } -proc ql_delete_object {} { +proc {ql_delete_object} {} { global qlvar # Checking if there set obj [.ql.c find withtag hili] @@ -994,6 +1290,7 @@ if {[ql_get_tag_info $obj link]=="s"} { set qlvar(links) [lreplace $qlvar(links) $linkid $linkid] .ql.c delete links ql_draw_links + return } # Is object a result field ? if {[ql_get_tag_info $obj res]=="f"} { @@ -1007,7 +1304,8 @@ if {[ql_get_tag_info $obj res]=="f"} { return } # Is object a table ? -set tablename [ql_get_tag_info $obj tab] +set tablealias [ql_get_tag_info $obj tab] +set tablename $qlvar(ali_$tablealias) 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} { @@ -1019,27 +1317,28 @@ for {set i [expr [llength $qlvar(restables)]-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] - if {($tablename==[lindex $thelink 0]) || ($tablename==[lindex $thelink 2])} { + if {($tablealias==[lindex $thelink 0]) || ($tablealias==[lindex $thelink 2])} { set qlvar(links) [lreplace $qlvar(links) $i $i] } } for {set i 0} {$i<$qlvar(ntables)} {incr i} { set temp {} catch {set temp $qlvar(tablename$i)} - if {$temp=="$tablename"} { + if {"$temp"=="$tablename"} { unset qlvar(tablename$i) unset qlvar(tablestruct$i) + unset qlvar(tablealias$i) break } } -incr qlvar(ntables) -1 -.ql.c delete tab$tablename +#incr qlvar(ntables) -1 +.ql.c delete tab$tablealias .ql.c delete links ql_draw_links ql_draw_res_panel } -proc ql_dragit {w x y} { +proc {ql_dragit} {w x y} { global draginfo if {"$draginfo(obj)" != ""} { set dx [expr $x - $draginfo(x)] @@ -1057,7 +1356,7 @@ if {"$draginfo(obj)" != ""} { } } -proc ql_dragstart {w x y} { +proc {ql_dragstart} {w x y} { global draginfo catch {unset draginfo} set draginfo(obj) [$w find closest $x $y] @@ -1084,8 +1383,10 @@ set draginfo(sx) $x set draginfo(sy) $y } -proc ql_dragstop {x y} { +proc {ql_dragstop} {x y} { global draginfo qlvar +# when click Close, ql window is destroyed but event ButtonRelease-1 is fired +if {![winfo exists .ql]} return; .ql configure -cursor top_left_arrow set este {} catch {set este $draginfo(obj)} @@ -1148,7 +1449,7 @@ if {($y>$qlvar(yoffs)) && ($x>$qlvar(xoffs))} { set draginfo(obj) {} } -proc ql_draw_links {} { +proc {ql_draw_links} {} { global qlvar .ql.c delete links set i 0 @@ -1167,7 +1468,7 @@ foreach link $qlvar(links) { .ql.c create line $x1 $y1 [expr $x1+10] $y1 -tags [subst {links lkid$i}] -width 3 set x2 [lindex $dbbox 0] set y2 [expr ([lindex $dbbox 1]+[lindex $dbbox 3])/2] - .ql.c create line [expr $x2-10] $y2 $x2 $y2 -tags {links} -width 3 + .ql.c create line [expr $x2-10] $y2 $x2 $y2 -tags [subst {links lkid$i}] -width 3 .ql.c create line [expr $x1+10] $y1 [expr $x2-10] $y2 -tags [subst {links lkid$i}] -width 2 } else { # source object is on the right of target object @@ -1185,7 +1486,7 @@ foreach link $qlvar(links) { .ql.c bind links {ql_link_click %x %y} } -proc ql_draw_lizzard {} { +proc {ql_draw_lizzard} {} { global qlvar .ql.c delete all set posx 20 @@ -1216,14 +1517,14 @@ bind .ql {ql_pan %x %y} bind .ql {ql_delete_object} } -proc ql_draw_res_panel {} { +proc {ql_draw_res_panel} {} { global qlvar # Compute the offset of the result panel due to panning set resoffset [expr [lindex [.ql.c bbox resmarker] 0]-$qlvar(xoffs)] .ql.c delete resp 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 -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 $qlvar(ali_[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-*-*-*-*-* 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}] @@ -1234,27 +1535,28 @@ for {set i 0} {$i<[llength $qlvar(resfields)]} {incr i} { .ql.c bind sort {ql_swap_sort %W %x %y} } -proc ql_draw_table {it} { +proc {ql_draw_table} {it} { global qlvar set posy 10 set allbox [.ql.c bbox rect] if {$allbox==""} {set posx 10} else {set posx [expr 20+[lindex $allbox 2]]} set tablename $qlvar(tablename$it) -.ql.c create text $posx $posy -text $tablename -anchor nw -tags [subst {tab$tablename f-oid mov tableheader}] -font -Adobe-Helvetica-Bold-R-Normal-*-*-120-*-*-*-*-* +set tablealias $qlvar(tablealias$it) +.ql.c create text $posx $posy -text $tablename -anchor nw -tags [subst {tab$tablealias f-oid mov tableheader}] -font -Adobe-Helvetica-Bold-R-Normal-*-*-120-*-*-*-*-* incr posy 16 foreach fld $qlvar(tablestruct$it) { - .ql.c create text $posx $posy -text $fld -anchor nw -tags [subst {f-$fld tab$tablename mov}] -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* + .ql.c create text $posx $posy -text $fld -fill #010101 -anchor nw -tags [subst {f-$fld tab$tablealias mov}] -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* incr posy 14 } -set reg [.ql.c bbox tab$tablename] -.ql.c create rectangle [lindex $reg 0] [lindex $reg 1] [lindex $reg 2] [lindex $reg 3] -fill #EEEEEE -tags [subst {rect tab$tablename}] -.ql.c create line [lindex $reg 0] [expr [lindex $reg 1]+15] [lindex $reg 2] [expr [lindex $reg 1]+15] -tags [subst {rect tab$tablename}] -.ql.c lower tab$tablename +set reg [.ql.c bbox tab$tablealias] +.ql.c create rectangle [lindex $reg 0] [lindex $reg 1] [lindex $reg 2] [lindex $reg 3] -fill #EEEEEE -tags [subst {rect tab$tablealias}] +.ql.c create line [lindex $reg 0] [expr [lindex $reg 1]+15] [lindex $reg 2] [expr [lindex $reg 1]+15] -tags [subst {rect tab$tablealias}] +.ql.c lower tab$tablealias .ql.c lower rect } -proc ql_get_tag_info {obj prefix} { +proc {ql_get_tag_info} {obj prefix} { set taglist [.ql.c gettags $obj] set tagpos [lsearch -regexp $taglist "^$prefix"] if {$tagpos==-1} {return ""} @@ -1262,7 +1564,7 @@ set thattag [lindex $taglist $tagpos] return [string range $thattag [string length $prefix] end] } -proc ql_init {} { +proc {ql_init} {} { global qlvar catch {unset qlvar} set qlvar(yoffs) 360 @@ -1278,7 +1580,7 @@ set qlvar(ntables) 0 set qlvar(newtablename) {} } -proc ql_link_click {x y} { +proc {ql_link_click} {x y} { global qlvar set obj [.ql.c find closest $x $y 1 links] @@ -1289,7 +1591,7 @@ if {[ql_get_tag_info $obj link]!="s"} return .ql.c itemconfigure $obj -fill blue } -proc ql_pan {x y} { +proc {ql_pan} {x y} { global qlvar set panstarted 0 catch {set panstarted $qlvar(panstarted) } @@ -1309,7 +1611,7 @@ if {$qlvar(panobject)=="tables"} { } } -proc ql_resfield_click {x y} { +proc {ql_resfield_click} {x y} { global qlvar set obj [.ql.c find closest $x $y] @@ -1320,7 +1622,7 @@ if {[ql_get_tag_info $obj res]!="f"} return .ql.c itemconfigure $obj -fill blue } -proc ql_show_sql {} { +proc {ql_show_sql} {} { global qlvar set sqlcmd [ql_compute_sql] @@ -1330,7 +1632,7 @@ set sqlcmd [ql_compute_sql] .ql.c bind sqlpage {.ql.c delete sqlpage} } -proc ql_swap_sort {w x y} { +proc {ql_swap_sort} {w x y} { global qlvar set obj [$w find closest $x $y] set taglist [.ql.c gettags $obj] @@ -1348,7 +1650,7 @@ set qlvar(ressort) [lreplace $qlvar(ressort) $col $col $cum] .ql.c itemconfigure $obj -text $cum } -proc qlc_click {x y w} { +proc {qlc_click} {x y w} { global qlvar set qlvar(panstarted) 0 if {$w==".ql.c"} { @@ -1394,226 +1696,326 @@ set qlvar(critrow) 0 set qlvar(critedit) 1 } -proc mw_save_new_record {} { -global dbc mw tablename msg -if {![mw_exit_edit]} {return 0} -if {$mw(newrec_fields)==""} {return 1} -set msg "Saving new record ..." -after 1000 {set msg ""} -set retval [catch { - set sqlcmd "insert into $tablename ([join $mw(newrec_fields) ,]) values ([join $mw(newrec_values) ,])" - set pgres [pg_exec $dbc $sqlcmd] - } errmsg] -if {$retval} { - show_error "Error inserting new record\n\n$errmsg" - return 0 -} -set oid [pg_result $pgres -oid] -lappend mw(keylist) $oid -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 dtag q new -# Replace * from untouched new row elements with " " -foreach item [.mw.c find withtag unt] { - .mw.c itemconfigure $item -text " " -} -.mw.c dtag q unt -incr mw(last_rownum) -incr mw(nrecs) -mw_draw_new_record -set mw(newrec_fields) {} -set mw(newrec_values) {} -return 1 -} - -proc save_pref {} { -global pref -catch { - set fid [open "~/.pgaccessrc" w] - foreach {opt val} [array get pref] { puts $fid "$opt $val" } - close $fid -} -} - -proc mw_scroll_window {par1 par2 args} { -global mw -if {![mw_exit_edit]} return; -if {$par1=="scroll"} { - set newtop $mw(toprec) - if {[lindex $args 0]=="units"} { - incr newtop $par2 - } else { - incr newtop [expr $par2*25] - if {$newtop<0} {set newtop 0} - if {$newtop>=[expr $mw(nrecs)-1]} {set newtop [expr $mw(nrecs)-1]} - } -} else { - set newtop [expr int($par2*$mw(nrecs))] -} -if {$newtop<0} return; -if {$newtop>=[expr $mw(nrecs)-1]} return; -set dy [expr [lindex $mw(rowy) $mw(toprec)]-[lindex $mw(rowy) $newtop]] -.mw.c move q 0 $dy -.mw.c move hgrid 0 $dy -set newrowy {} -foreach y $mw(rowy) {lappend newrowy [expr $y+$dy]} -set mw(rowy) $newrowy -set mw(toprec) $newtop -mw_set_scrollbar -} - -proc mw_select_records {sql} { -global dbc field mw -global tablename msg pref -set mw(newrec_fields) {} -set mw(newrec_values) {} -if {![mw_exit_edit]} return; -.mw.c delete q -.mw.c delete header -.mw.c delete hgrid -.mw.c delete new -set mw(leftcol) 0 -set mw(leftoffset) 0 -set mw(crtrow) {} -set msg {} -set msg "Accessing data. Please wait ..." -cursor_watch .mw -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} { - sql_exec quiet "END" - set msg {} - cursor_arrow .mw - show_error "Error executing SQL command\n\n$sql\n\nError message:$errmsg" - set msg "Error executing : $sql" - return +proc {rb_add_field} {} { +global rbvar +set fldname [.rb.lb get [.rb.lb curselection]] +set newid [.rb.c create text $rbvar(xf_auto) [expr $rbvar(y_rpthdr)+5] -text $fldname -tags [subst {t_l mov ro}] -anchor nw -font -Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-*] +.rb.c create text $rbvar(xf_auto) [expr $rbvar(y_pghdr)+5] -text $fldname -tags [subst {f-$fldname t_f rg_detail mov ro}] -anchor nw -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* +set bb [.rb.c bbox $newid] +incr rbvar(xf_auto) [expr 5+[lindex $bb 2]-[lindex $bb 0]] } -if {$mw(updatable)} then {set shift 1} else {set shift 0} -# -# checking at least the numer of fields -set attrlist [pg_result $pgres -lAttributes] -if {$mw(layout_found)} then { - if { ($mw(colcount) != [expr [llength $attrlist]-$shift]) || - ($mw(colcount) != [llength $mw(colnames)]) || - ($mw(colcount) != [llength $mw(colwidth)]) } then { - # No. of columns don't match, something is wrong - # tk_messageBox -title Information -message "Layout info changed !\nRescanning..." - set mw(layout_found) 0 - sql_exec quiet "delete from pga_layout where tablename='$mw(layout_name)'" - } + +proc {rb_add_label} {} { +global rbvar +set fldname $rbvar(labeltext) +set newid [.rb.c create text $rbvar(xl_auto) [expr $rbvar(y_rpthdr)+5] -text $fldname -tags [subst {t_l mov ro}] -anchor nw -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*] +set bb [.rb.c bbox $newid] +incr rbvar(xl_auto) [expr 5+[lindex $bb 2]-[lindex $bb 0]] } -# Always take the col. names from the result -set mw(colcount) [llength $attrlist] -if {$mw(updatable)} then {incr mw(colcount) -1} -set mw(colnames) {} -# In defmw(colwidth) prepare mw(colwidth) (in case that not layout_found) -set defmw(colwidth) {} -for {set i 0} {$i<$mw(colcount)} {incr i} { - lappend mw(colnames) [lindex [lindex $attrlist [expr $i+$shift]] 0] - lappend defmw(colwidth) 150 + +proc {rb_change_object_font} {} { +global rbvar +.rb.c itemconfigure hili -font -Adobe-[.rb.bfont cget -text]-[rb_get_bold]-[rb_get_italic]-Normal--*-$rbvar(pointsize)-*-*-*-*-*-* } -if {!$mw(layout_found)} { - set mw(colwidth) $defmw(colwidth) - sql_exec quiet "insert into pga_layout values ('$mw(layout_name)',$mw(colcount),'$mw(colnames)','$mw(colwidth)')" + +proc {rb_delete_object} {} { +if {[tk_messageBox -title Warning -message "Delete current report object?" -type yesno -default no]=="no"} return; +.rb.c delete hili } -set mw(nrecs) [pg_result $pgres -numTuples] -if {$mw(nrecs)>$pref(rows)} { - set msg "Only first $pref(rows) records from $mw(nrecs) have been loaded" - set mw(nrecs) $pref(rows) + +proc {rb_dragit} {w x y} { +global draginfo rbvar +# Showing current region +foreach rg $rbvar(regions) { + set rbvar(msg) $rbvar(e_$rg) + if {$rbvar(y_$rg)>$y} break; } -set tagoid {} -if {$pref(tvfont)=="helv"} { - set tvfont -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -} else { - set tvfont -*-Clean-Medium-R-Normal-*-*-130-*-*-*-*-* +set temp {} +catch {set temp $draginfo(obj)} +if {"$temp" != ""} { + set dx [expr $x - $draginfo(x)] + set dy [expr $y - $draginfo(y)] + if {$draginfo(region)!=""} { + set x $draginfo(x) ; $w move bg_$draginfo(region) 0 $dy + } else { + $w move $draginfo(obj) $dx $dy + } + set draginfo(x) $x + set draginfo(y) $y } -# 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] - if {$mw(updatable)} then {lappend mw(keylist) [lindex $curtup 0]} - for {set j 0} {$j<$mw(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) + +proc {rb_dragstart} {w x y} { +global draginfo rbvar +focus .rb.c +catch {unset draginfo} +set obj {} +# Only movable objects start dragging +foreach id [$w find overlapping $x $y $x $y] { + if {[rb_has_tag $id mov]} { + set obj $id + break } - set bb [.mw.c bbox r$i] - incr posy [expr [lindex $bb 3]-[lindex $bb 1]] - 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} } -}] -after 2000 set msg {} -set mw(last_rownum) $i -# Defining position for input data -mw_draw_new_record -pg_result $pgres -clear -#set msg {} -sql_exec quiet "END" -set mw(toprec) 0 -mw_set_scrollbar -if {$mw(updatable)} then { - .mw.c bind q {mw_edit_text %A %K} +if {$obj==""} return; +set draginfo(obj) $obj +set taglist [.rb.c itemcget $obj -tags] +set i [lsearch -glob $taglist bg_*] +if {$i==-1} { + set draginfo(region) {} } else { - .mw.c bind q {} + set draginfo(region) [string range [lindex $taglist $i] 3 64] +} +.rb configure -cursor hand1 +.rb.c itemconfigure [.rb.c find withtag hili] -fill black +.rb.c dtag [.rb.c find withtag hili] hili +.rb.c addtag hili withtag $draginfo(obj) +.rb.c itemconfigure hili -fill blue +set draginfo(x) $x +set draginfo(y) $y +set draginfo(sx) $x +set draginfo(sy) $y +# Setting font information +if {[.rb.c type hili]=="text"} { + set fnta [split [.rb.c itemcget hili -font] -] + .rb.bfont configure -text [lindex $fnta 2] + if {[lindex $fnta 3]=="Medium"} then {.rb.lbold configure -relief raised} else {.rb.lbold configure -relief sunken} + if {[lindex $fnta 4]=="R"} then {.rb.lita configure -relief raised} else {.rb.lita configure -relief sunken} + set rbvar(pointsize) [lindex $fnta 8] + if {[rb_has_tag $obj t_f]} {set rbvar(info) "Database field"} + if {[rb_has_tag $obj t_l]} {set rbvar(info) "Label"} + if {[.rb.c itemcget $obj -anchor]=="nw"} then {.rb.balign configure -text left} else {.rb.balign configure -text right} +} +} + +proc {rb_dragstop} {x y} { +global draginfo rbvar +# when click Close, ql window is destroyed but event ButtonRelease-1 is fired +if {![winfo exists .rb]} return; +.rb configure -cursor top_left_arrow +set este {} +catch {set este $draginfo(obj)} +if {$este==""} return +# Erase information about object beeing dragged +if {$draginfo(region)!=""} { + set dy 0 + foreach rg $rbvar(regions) { + .rb.c move rg_$rg 0 $dy + if {$rg==$draginfo(region)} { + set dy [expr $y-$rbvar(y_$draginfo(region))] + } + incr rbvar(y_$rg) $dy + } +# .rb.c move det 0 [expr $y-$rbvar(y_$draginfo(region))] + set rbvar(y_$draginfo(region)) $y + rb_draw_regions +} else { + # Check if object beeing dragged is inside the canvas + set bb [.rb.c bbox $draginfo(obj)] + if {[lindex $bb 0] < 5} { + .rb.c move $draginfo(obj) [expr 5-[lindex $bb 0]] 0 + } } -set mw(dirtyrec) 0 -#mw_draw_headers -.mw.c raise header -cursor_arrow .mw +set draginfo(obj) {} +unset draginfo } -proc mw_draw_hgrid {} { -global mw -.mw.c delete hgrid -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] +proc {rb_draw_regions} {} { +global rbvar +foreach rg $rbvar(regions) { + .rb.c delete bg_$rg + .rb.c create line 0 $rbvar(y_$rg) 5000 $rbvar(y_$rg) -tags [subst {bg_$rg}] + .rb.c create rectangle 6 [expr $rbvar(y_$rg)-3] 12 [expr $rbvar(y_$rg)+3] -fill black -tags [subst {bg_$rg mov reg}] + .rb.c lower bg_$rg } -incr posx -6 -for {set i 0} {$i<$mw(nrecs)} {incr i} { - .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 {$mw(updatable)} { - set i $mw(nrecs) - .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}] + +proc {rb_flip_align} {} { +set bb [.rb.c bbox hili] +if {[.rb.balign cget -text]=="left"} then { + .rb.balign configure -text right + .rb.c itemconfigure hili -anchor ne + .rb.c move hili [expr [lindex $bb 2]-[lindex $bb 0]-3] 0 +} else { + .rb.balign configure -text left + .rb.c itemconfigure hili -anchor nw + .rb.c move hili [expr [lindex $bb 0]-[lindex $bb 2]+3] 0 +} +} + +proc {rb_get_bold} {} { +if {[.rb.lbold cget -relief]=="raised"} then {return Medium} else {return Bold} +} + +proc {rb_get_italic} {} { +if {[.rb.lita cget -relief]=="raised"} then {return R} else {return O} +} + +proc {rb_get_report_fields} {} { +global dbc rbvar +.rb.lb delete 0 end +if {$rbvar(tablename)==""} return ; +#cursor_watch .ql +pg_select $dbc "select attnum,attname from pg_class,pg_attribute where (pg_class.relname='$rbvar(tablename)') and (pg_class.oid=pg_attribute.attrelid) and (attnum>0) order by attnum" rec { + .rb.lb insert end $rec(attname) +} +#cursor_arrow .ql +} + +proc {rb_has_tag} {id tg} { +if {[lsearch [.rb.c itemcget $id -tags] $tg]==-1} then {return 0 } else {return 1} +} + +proc {rb_init} {} { +global rbvar +set rbvar(xl_auto) 10 +set rbvar(xf_auto) 10 +set rbvar(regions) {rpthdr pghdr detail pgfoo rptfoo} +set rbvar(y_rpthdr) 30 +set rbvar(y_pghdr) 60 +set rbvar(y_detail) 90 +set rbvar(y_pgfoo) 120 +set rbvar(y_rptfoo) 150 +set rbvar(e_rpthdr) {Report header} +set rbvar(e_pghdr) {Page header} +set rbvar(e_detail) {Detail record} +set rbvar(e_pgfoo) {Page footer} +set rbvar(e_rptfoo) {Report footer} +rb_draw_regions +} + +proc {rb_load_report} {} { +global rbvar dbc +.rb.c delete all +pg_select $dbc "select * from pga_reports where reportname='$rbvar(reportname)'" rcd { + eval $rcd(reportbody) +} +rb_get_report_fields +rb_draw_regions +} + +proc {rb_preview} {} { +global dbc rbvar +Window show .rpv +.rpv.fr.c delete all +set ol [.rb.c find withtag ro] +set fields {} +foreach objid $ol { + set tags [.rb.c itemcget $objid -tags] + lappend fields [string range [lindex $tags [lsearch -glob $tags f-*]] 2 64] + lappend fields [lindex [.rb.c coords $objid] 0] + lappend fields [lindex [.rb.c coords $objid] 1] + lappend fields $objid + lappend fields [lindex $tags [lsearch -glob $tags t_*]] +} +#msgbox $fields +# Parsing page header +set py 10 +foreach {field x y objid objtype} $fields { + if {$objtype=="t_l"} { + .rpv.fr.c create text $x [expr $py+$y] -text [.rb.c itemcget $objid -text] -font [.rb.c itemcget $objid -font] -anchor nw + } +} +incr py [expr $rbvar(y_pghdr)-$rbvar(y_rpthdr)] +# Parsing detail group +set di [lsearch $rbvar(regions) detail] +set y_hi $rbvar(y_detail) +set y_lo $rbvar(y_[lindex $rbvar(regions) [expr $di-1]]) +pg_select $dbc "select * from $rbvar(tablename)" rec { + foreach {field x y objid objtype} $fields { + if {($y>=$y_lo) && ($y<=$y_hi)} then { + if {$objtype=="t_f"} { + .rpv.fr.c create text $x [expr $py+$y] -text $rec($field) -font [.rb.c itemcget $objid -font] -anchor [.rb.c itemcget $objid -anchor] + } + if {$objtype=="t_l"} { + .rpv.fr.c create text $x [expr $py+$y] -text [.rb.c itemcget $objid -text] -font [.rb.c itemcget $objid -font] -anchor nw + } + } + } + incr py [expr $rbvar(y_detail)-$rbvar(y_pghdr)] } +.rpv.fr.c configure -scrollregion [subst {0 0 1000 $py}] } -proc mw_set_scrollbar {} { -global mw -if {$mw(nrecs)==0} return; -.mw.sb set [expr $mw(toprec)*1.0/$mw(nrecs)] [expr ($mw(toprec)+27.0)/$mw(nrecs)] +proc {rb_print_report} {} { +set bb [.rpv.fr.c bbox all] +.rpv.fr.c postscript -file "pgaccess-report.ps" -width [expr 10+[lindex $bb 2]-[lindex $bb 0]] -height [expr 10+[lindex $bb 3]-[lindex $bb 1]] +tk_messageBox -title Information -message "The printed image in Postscript is in the file pgaccess-report.ps" +} + +proc {rb_save_report} {} { +global rbvar +set prog "set rbvar(tablename) $rbvar(tablename)" +foreach region $rbvar(regions) { + set prog "$prog ; set rbvar(y_$region) $rbvar(y_$region)" +} +foreach obj [.rb.c find all] { + if {[.rb.c type $obj]=="text"} { + set bb [.rb.c bbox $obj] + if {[.rb.c itemcget $obj -anchor]=="nw"} then {set x [expr [lindex $bb 0]+1]} else {set x [expr [lindex $bb 2]-2]} + set prog "$prog ; .rb.c create text $x [lindex $bb 1] -font [.rb.c itemcget $obj -font] -anchor [.rb.c itemcget $obj -anchor] -text {[.rb.c itemcget $obj -text]} -tags {[.rb.c itemcget $obj -tags]}" + } +} +sql_exec noquiet "delete from pga_reports where reportname='$rbvar(reportname)'" +sql_exec noquiet "insert into pga_reports (reportname,reportsource,reportbody) values ('$rbvar(reportname)','$rbvar(tablename)','$prog')" +} + +proc {main} {argc argv} { +global dbc +set dbc [pg_connect ultex] +rb_init +} + +proc {save_pref} {} { +global pref +catch { + set fid [open "~/.pgaccessrc" w] + foreach {opt val} [array get pref] { puts $fid "$opt $val" } + close $fid +} } -proc show_error {emsg} { +proc {show_error} {emsg} { tk_messageBox -title Error -icon error -message $emsg } -proc sql_exec {how cmd} { +proc {show_table_information} {tblname} { +global dbc tiw activetab indexlist +set tiw(tablename) $tblname +if {$tiw(tablename)==""} return; +Window show .tiw +.tiw.lb delete 0 end +.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 ftype $rec(typname) + if {$ftype=="varchar"} { + incr fsize -4 + } + if {$ftype=="bpchar"} { + incr fsize -4 + } + if {$ftype=="text"} { + set fsize "" + } + if {$rec(attnum)>0} {.tiw.lb insert end [format "%-33s %-14s %-4s" $rec(attname) $ftype $fsize]} + 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) + } +} +} + +proc {sql_exec} {how cmd} { global dbc set retval [catch {set pgr [pg_exec $dbc $cmd]} errmsg] if { $retval } { @@ -1626,7 +2028,7 @@ pg_result $pgr -clear return 1 } -proc tab_click {w} { +proc {tab_click} {w} { global dbc tablist activetab if {$dbc==""} return; set curtab [$w cget -text] @@ -1641,31 +2043,14 @@ place $w -x 7 place .dw.lmask -x 80 -y [expr 86+25*[lsearch -exact $tablist $curtab]] set activetab $curtab # Tabs where button Design is enabled -if {[lsearch $activetab [list Queries]]!=-1} { +if {[lsearch {Scripts Queries Reports} $activetab]!=-1} { .dw.btndesign configure -state normal } .dw.lb delete 0 end cmd_$curtab } -proc main {argc argv} { -global pref newdbname newpport newhost dbc -load libpgtcl.so -catch {draw_tabs} -load_pref -if {$pref(autoload) && ($pref(lastdb)!="")} { - set newdbname $pref(lastdb) - set newhost $pref(lasthost) - set newpport $pref(lastport) - open_database -} -wm protocol .dw WM_DELETE_WINDOW { - catch {pg_disconnect $dbc} - exit - } -} - -proc tiw_show_index {} { +proc {tiw_show_index} {} { global tiw dbc set cs [.tiw.ilb curselection] if {$cs==""} return @@ -1695,7 +2080,41 @@ pg_select $dbc "select pg_index.*,pg_class.oid from pg_index,pg_class where pg_c set tiw(indexfields) [string trim $tiw(indexfields)] } -proc Window {args} { +proc {vacuum} {} { +global dbc dbname sdbname + +if {$dbc==""} return; +cursor_watch .dw +set sdbname "vacuuming database $dbname ..." +update; update idletasks +set retval [catch { + set pgres [pg_exec $dbc "vacuum;"] + pg_result $pgres -clear + } msg] +cursor_arrow .dw +set sdbname $dbname +if {$retval} { + show_error $msg +} +} + +proc {main} {argc argv} { +global pref newdbname newpport newhost dbc +load libpgtcl.so +catch {draw_tabs} +load_pref +if {$pref(autoload) && ($pref(lastdb)!="")} { + set newdbname $pref(lastdb) + set newhost $pref(lasthost) + set newpport $pref(lastport) + open_database +} +wm protocol .dw WM_DELETE_WINDOW { + catch {pg_disconnect $dbc} + exit } +} + +proc {Window} {args} { global vTcl set cmd [lindex $args 0] set name [lindex $args 1] @@ -1767,40 +2186,24 @@ proc vTclWindow.about {base} { wm overrideredirect $base 0 wm resizable $base 1 1 wm title $base "About" - label $base.l1 \ - -borderwidth 3 -font -Adobe-Helvetica-Bold-R-Normal-*-*-180-*-*-*-*-* \ - -relief ridge -text PgAccess - label $base.l2 \ - -relief groove \ - -text {A Tcl/Tk interface to + label $base.l1 -borderwidth 3 -font -Adobe-Helvetica-Bold-R-Normal-*-*-180-*-*-*-*-* -relief ridge -text PgAccess + label $base.l2 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief groove -text {A Tcl/Tk interface to PostgreSQL by Constantin Teodorescu} - label $base.l3 \ - -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 + label $base.l3 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief sunken -text {vers 0.76} + label $base.l4 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief groove -text {You will always get the latest version at: +http://www.flex.ro/pgaccess Suggestions : teo@flex.ro} - button $base.b1 \ - -borderwidth 1 -command {Window hide .about} \ - -padx 9 \ - -pady 3 -text Ok + button $base.b1 -borderwidth 1 -command {Window destroy .about} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text Ok ################### # SETTING GEOMETRY ################### - place $base.l1 \ - -x 10 -y 10 -width 196 -height 103 -anchor nw -bordermode ignore - place $base.l2 \ - -x 10 -y 115 -width 198 -height 55 -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 + place $base.l1 -x 10 -y 10 -width 196 -height 103 -anchor nw -bordermode ignore + place $base.l2 -x 10 -y 115 -width 198 -height 55 -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} { @@ -1813,8 +2216,7 @@ proc vTclWindow.dbod {base} { ################### # CREATING WIDGETS ################### - toplevel $base -class Toplevel \ - -cursor top_left_arrow + toplevel $base -class Toplevel -cursor top_left_arrow wm focusmodel $base passive wm geometry $base 282x128+353+310 wm maxsize $base 1009 738 @@ -1822,50 +2224,25 @@ proc vTclWindow.dbod {base} { wm overrideredirect $base 0 wm resizable $base 0 0 wm title $base "Open database" - label $base.lhost \ - -borderwidth 0 \ - -relief raised -text Host - entry $base.ehost \ - -background #fefefe -borderwidth 1 -highlightthickness 1 \ - -selectborderwidth 0 -textvariable newhost - label $base.lport \ - -borderwidth 0 \ - -relief raised -text Port - entry $base.epport \ - -background #fefefe -borderwidth 1 -highlightthickness 1 \ - -selectborderwidth 0 -textvariable newpport - label $base.ldbname \ - -borderwidth 0 \ - -relief raised -text Database - entry $base.edbname \ - -background #fefefe -borderwidth 1 -highlightthickness 1 \ - -selectborderwidth 0 -textvariable newdbname - button $base.opbtu \ - -borderwidth 1 -command open_database \ - -padx 9 -pady 3 -text Open - button $base.canbut \ - -borderwidth 1 -command {Window hide .dbod} \ - -padx 9 \ - -pady 3 -text Cancel + label $base.lhost -borderwidth 0 -relief raised -text Host + entry $base.ehost -background #fefefe -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable newhost + label $base.lport -borderwidth 0 -relief raised -text Port + entry $base.epport -background #fefefe -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable newpport + label $base.ldbname -borderwidth 0 -relief raised -text Database + entry $base.edbname -background #fefefe -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable newdbname + button $base.opbtu -borderwidth 1 -command open_database -padx 9 -pady 3 -text Open + button $base.canbut -borderwidth 1 -command {Window hide .dbod} -padx 9 -pady 3 -text Cancel ################### # SETTING GEOMETRY ################### - place $base.lhost \ - -x 35 -y 7 -anchor nw -bordermode ignore - place $base.ehost \ - -x 100 -y 5 -anchor nw -bordermode ignore - place $base.lport \ - -x 35 -y 32 -anchor nw -bordermode ignore - place $base.epport \ - -x 100 -y 30 -anchor nw -bordermode ignore - place $base.ldbname \ - -x 35 -y 57 -anchor nw -bordermode ignore - place $base.edbname \ - -x 100 -y 55 -anchor nw -bordermode ignore - place $base.opbtu \ - -x 70 -y 90 -width 60 -height 26 -anchor nw -bordermode ignore - place $base.canbut \ - -x 150 -y 90 -width 60 -height 26 -anchor nw -bordermode ignore + place $base.lhost -x 35 -y 7 -anchor nw -bordermode ignore + place $base.ehost -x 100 -y 5 -anchor nw -bordermode ignore + place $base.lport -x 35 -y 32 -anchor nw -bordermode ignore + place $base.epport -x 100 -y 30 -anchor nw -bordermode ignore + place $base.ldbname -x 35 -y 57 -anchor nw -bordermode ignore + place $base.edbname -x 100 -y 55 -anchor nw -bordermode ignore + place $base.opbtu -x 70 -y 90 -width 60 -height 26 -anchor nw -bordermode ignore + place $base.canbut -x 150 -y 90 -width 60 -height 26 -anchor nw -bordermode ignore } proc vTclWindow.dw {base} { @@ -1879,9 +2256,9 @@ proc vTclWindow.dw {base} { # CREATING WIDGETS ################### toplevel $base -class Toplevel \ - -background #efefef + -background #efefef -cursor top_left_arrow wm focusmodel $base passive - wm geometry $base 322x355+93+104 + wm geometry $base 322x355+96+172 wm maxsize $base 1009 738 wm minsize $base 1 1 wm overrideredirect $base 0 @@ -1889,32 +2266,35 @@ proc vTclWindow.dw {base} { wm deiconify $base wm title $base "PostgreSQL access" label $base.labframe \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ -relief raised listbox $base.lb \ -background #fefefe \ -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ - -highlightthickness 0 -selectborderwidth 0 \ + -foreground black -highlightthickness 0 -selectborderwidth 0 \ -yscrollcommand {.dw.sb set} bind $base.lb { cmd_Open } button $base.btnnew \ -borderwidth 1 -command cmd_New \ - -padx 9 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ -pady 3 -text New button $base.btnopen \ -borderwidth 1 -command cmd_Open \ - -padx 9 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ -pady 3 -text Open button $base.btndesign \ -borderwidth 1 -command cmd_Design \ - -padx 9 \ - -pady 3 -state disabled -text Design + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ + -pady 3 -text Design label $base.lmask \ -borderwidth 0 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ -relief raised -text { } label $base.label22 \ -borderwidth 1 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ -relief raised menubutton $base.menubutton23 \ -borderwidth 1 \ @@ -1925,9 +2305,10 @@ proc vTclWindow.dw {base} { -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -tearoff 0 $base.menubutton23.01 add command \ \ - -command {set newhost $host -set newpport $pport + -command { Window show .dbod +set newhost $host +set newpport $pport focus .dbod.edbname} \ -label Open $base.menubutton23.01 add command \ @@ -1938,7 +2319,7 @@ set dbname {} set sdbname {}} \ -label Close $base.menubutton23.01 add command \ - -command cmd_Vacuum -label Vacuum + -command vacuum -label Vacuum $base.menubutton23.01 add separator $base.menubutton23.01 add command \ -command {cmd_Import_Export Import} -label {Import table} @@ -1953,9 +2334,11 @@ set sdbname {}} \ save_pref exit} -label Exit label $base.lshost \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ -relief groove -text localhost -textvariable host label $base.lsdbname \ - -anchor w -relief groove -textvariable sdbname + -anchor w -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -relief groove -textvariable sdbname scrollbar $base.sb \ -borderwidth 1 -command {.dw.lb yview} -orient vert menubutton $base.mnob \ @@ -2011,7 +2394,7 @@ exit} -label Exit place $base.lsdbname \ -x 95 -y 335 -width 223 -height 20 -anchor nw -bordermode ignore place $base.sb \ - -x 295 -y 75 -width 18 -height 249 -anchor nw -bordermode ignore + -x 295 -y 73 -width 18 -height 252 -anchor nw -bordermode ignore place $base.mnob \ -x 70 -y 2 -width 44 -height 19 -anchor nw -bordermode ignore place $base.mhelp \ @@ -2036,30 +2419,14 @@ proc vTclWindow.fw {base} { wm overrideredirect $base 0 wm resizable $base 0 0 wm title $base "Function" - label $base.l1 \ - -borderwidth 0 \ - -relief raised -text Name - entry $base.e1 \ - -background #fefefe -borderwidth 1 -highlightthickness 1 \ - -selectborderwidth 0 -textvariable funcname - label $base.l2 \ - -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 { + label $base.l1 -borderwidth 0 -relief raised -text Name + entry $base.e1 -background #fefefe -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable funcname + label $base.l2 -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==""} { show_error "You must supply a name for this function!" } elseif {$funcret==""} { @@ -2068,40 +2435,26 @@ proc vTclWindow.fw {base} { set funcbody [.fw.text1 get 1.0 end] regsub -all "\n" $funcbody " " funcbody if {[sql_exec noquiet "create function $funcname ($funcpar) returns $funcret as '$funcbody' language 'sql'"]} { - Window hide .fw + Window destroy .fw tk_messageBox -title PostgreSQL -message "Function created!" tab_click .dw.tabFunctions } } - } \ - -padx 9 \ - -pady 3 -state disabled -text Define - button $base.cancelbtn \ - -borderwidth 1 -command {Window hide .fw} \ - -padx 9 \ - -pady 3 -text Close + } -padx 9 -pady 3 -state disabled -text Define + button $base.cancelbtn -borderwidth 1 -command {Window destroy .fw} -padx 9 -pady 3 -text Close ################### # SETTING GEOMETRY ################### - place $base.l1 \ - -x 15 -y 18 -anchor nw -bordermode ignore - place $base.e1 \ - -x 95 -y 15 -width 198 -height 22 -anchor nw -bordermode ignore - place $base.l2 \ - -x 15 -y 48 -anchor nw -bordermode ignore - place $base.e2 \ - -x 95 -y 45 -width 198 -height 22 -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 + place $base.l1 -x 15 -y 18 -anchor nw -bordermode ignore + place $base.e1 -x 95 -y 15 -width 198 -height 22 -anchor nw -bordermode ignore + place $base.l2 -x 15 -y 48 -anchor nw -bordermode ignore + place $base.e2 -x 95 -y 45 -width 198 -height 22 -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} { @@ -2122,24 +2475,13 @@ proc vTclWindow.iew {base} { wm overrideredirect $base 0 wm resizable $base 0 0 wm title $base "Import-Export table" - label $base.l1 \ - -borderwidth 0 \ - -relief raised -text {Table name} - entry $base.e1 \ - -background #fefefe -borderwidth 1 -textvariable ie_tablename - label $base.l2 \ - -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==""} { + label $base.l1 -borderwidth 0 -relief raised -text {Table name} + entry $base.e1 -background #fefefe -borderwidth 1 -textvariable ie_tablename + label $base.l2 -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!" } elseif {$ie_filename==""} { show_error "You have to supply a external file name!" @@ -2164,40 +2506,24 @@ proc vTclWindow.iew {base} { if {[sql_exec noquiet $sqlcmd]} { cursor_arrow .iew tk_messageBox -title Information -message "Operation completed!" - Window hide .iew + Window destroy .iew } cursor_arrow .iew -}} \ - -padx 9 \ - -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 +}} -padx 9 -pady 3 -text Export + button $base.cancelbtn -borderwidth 1 -command {Window destroy .iew} -padx 9 -pady 3 -text Cancel + checkbutton $base.oicb -borderwidth 1 -text {with OIDs} -variable oicb ################### # SETTING GEOMETRY ################### - place $base.l1 \ - -x 25 -y 15 -anchor nw -bordermode ignore - place $base.e1 \ - -x 115 -y 10 -anchor nw -bordermode ignore - place $base.l2 \ - -x 25 -y 45 -anchor nw -bordermode ignore - place $base.e2 \ - -x 115 -y 40 -anchor nw -bordermode ignore - place $base.l3 \ - -x 25 -y 75 -height 18 -anchor nw -bordermode ignore - place $base.e3 \ - -x 115 -y 74 -width 33 -height 22 -anchor nw -bordermode ignore - place $base.expbtn \ - -x 60 -y 110 -anchor nw -bordermode ignore - place $base.cancelbtn \ - -x 155 -y 110 -anchor nw -bordermode ignore - place $base.oicb \ - -x 170 -y 75 -anchor nw -bordermode ignore + place $base.l1 -x 25 -y 15 -anchor nw -bordermode ignore + place $base.e1 -x 115 -y 10 -anchor nw -bordermode ignore + place $base.l2 -x 25 -y 45 -anchor nw -bordermode ignore + place $base.e2 -x 115 -y 40 -anchor nw -bordermode ignore + place $base.l3 -x 25 -y 75 -height 18 -anchor nw -bordermode ignore + place $base.e3 -x 115 -y 74 -width 33 -height 22 -anchor nw -bordermode ignore + place $base.expbtn -x 60 -y 110 -anchor nw -bordermode ignore + place $base.cancelbtn -x 155 -y 110 -anchor nw -bordermode ignore + place $base.oicb -x 170 -y 75 -anchor nw -bordermode ignore } proc vTclWindow.mw {base} { @@ -2210,24 +2536,35 @@ proc vTclWindow.mw {base} { ################### # CREATING WIDGETS ################### - toplevel $base -class Toplevel \ - -cursor top_left_arrow + toplevel $base -class Toplevel wm focusmodel $base passive - wm geometry $base 631x452+239+226 + wm geometry $base 550x400+189+228 wm maxsize $base 1009 738 - wm minsize $base 1 1 + wm minsize $base 550 400 wm overrideredirect $base 0 - wm resizable $base 0 0 + wm resizable $base 1 1 + wm deiconify $base wm title $base "Table browser" bind $base { mw_delete_record } - label $base.hoslbl \ - -borderwidth 0 \ - -relief raised -text {Sort field} - button $base.fillbtn \ - -borderwidth 1 \ - -command {set nq $mw(query) + frame $base.f1 -borderwidth 2 -height 75 -relief groove -width 125 + label $base.f1.l1 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -relief raised -text {Sort field} + entry $base.f1.e1 -background #fefefe -borderwidth 1 -width 14 -highlightthickness 1 -textvariable sortfield + label $base.f1.lb1 -borderwidth 0 -relief raised -text { } + label $base.f1.l2 -background #dfdfdf -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -relief raised -text {Filter conditions} + entry $base.f1.e2 -background #fefefe -borderwidth 1 -highlightthickness 1 -textvariable filter + button $base.f1.b1 -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -padx 9 -pady 3 -text Close -command { +if {[mw_save_new_record]} { + .mw.c delete rows + .mw.c delete header + set sortfield {} + set filter {} + Window destroy .mw +} + } + button $base.f1.b2 -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -padx 9 -pady 3 -text Reload -command { +set nq $mw(query) if {($mw(isaquery)) && ("$filter$sortfield"!="")} { show_error "Sorting and filtering not (yet) available from queries!\n\nPlease enter them in the query definition!" set sortfield {} @@ -2243,79 +2580,36 @@ if {($mw(isaquery)) && ("$filter$sortfield"!="")} { } } if {[mw_save_new_record]} {mw_select_records $nq} -} \ - -padx 9 \ - -pady 3 -text Reload - button $base.exitbtn \ - -borderwidth 1 \ - -command { -if {[mw_save_new_record]} { - .mw.c delete rows - .mw.c delete header - set sortfield {} - set filter {} - Window hide .mw -} -} \ - -padx 9 \ - -pady 3 -text Close - canvas $base.c \ - -background #fefefe -borderwidth 2 -height 207 -highlightthickness 0 \ - -relief ridge -selectborderwidth 0 -takefocus 1 -width 295 + } + frame $base.frame20 -borderwidth 2 -height 75 -relief groove -width 125 + button $base.frame20.01 -borderwidth 1 -padx 9 -pady 3 -text < -command {mw_pan_right} + label $base.frame20.02 -anchor w -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -height 1 -relief sunken -text {} -textvariable msg + button $base.frame20.03 -borderwidth 1 -padx 9 -pady 3 -text > -command {mw_pan_left} + canvas $base.c -background #fefefe -borderwidth 2 -height 207 -highlightthickness 0 -relief ridge -selectborderwidth 0 -takefocus 1 -width 295 + scrollbar $base.sb -borderwidth 1 -orient vert -width 12 -command mw_scroll_window bind $base.c { mw_canvas_click %x %y } bind $base.c { if {[mw_exit_edit]} {mw_save_new_record} } - label $base.msglbl \ - -anchor w -borderwidth 1 \ - -relief sunken -textvariable msg - scrollbar $base.sb \ - -borderwidth 1 -command mw_scroll_window -highlightthickness 0 \ - -orient vert - button $base.ert \ - -borderwidth 1 -command mw_pan_left \ - -font -Adobe-Helvetica-Bold-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ - -pady 3 -text > - button $base.dfggfh \ - -borderwidth 1 -command mw_pan_right \ - -font -Adobe-Helvetica-Bold-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ - -pady 3 -text < - entry $base.tbn \ - -background #fefefe -borderwidth 1 -highlightthickness 1 \ - -selectborderwidth 0 -textvariable filter - label $base.tbllbl \ - -borderwidth 0 \ - -relief raised -text {Filter conditions} - entry $base.dben \ - -background #fefefe -borderwidth 1 -highlightthickness 1 \ - -textvariable sortfield ################### # SETTING GEOMETRY ################### - place $base.hoslbl \ - -x 5 -y 5 -anchor nw -bordermode ignore - place $base.fillbtn \ - -x 515 -y 1 -height 25 -anchor nw -bordermode ignore - place $base.exitbtn \ - -x 580 -y 1 -width 49 -height 25 -anchor nw -bordermode ignore - place $base.c \ - -x 5 -y 25 -width 608 -height 405 -anchor nw -bordermode ignore - place $base.msglbl \ - -x 33 -y 430 -width 567 -height 18 -anchor nw -bordermode ignore - place $base.sb \ - -x 612 -y 26 -width 13 -height 404 -anchor nw -bordermode ignore - place $base.ert \ - -x 603 -y 428 -width 25 -height 22 -anchor nw -bordermode ignore - place $base.dfggfh \ - -x 5 -y 428 -width 25 -height 22 -anchor nw -bordermode ignore - place $base.tbn \ - -x 295 -y 3 -width 203 -height 21 -anchor nw -bordermode ignore - place $base.tbllbl \ - -x 200 -y 5 -anchor nw -bordermode ignore - place $base.dben \ - -x 60 -y 3 -width 120 -height 21 -anchor nw -bordermode ignore + pack $base.f1 -in .mw -anchor center -expand 0 -fill x -side top + pack $base.f1.l1 -in .mw.f1 -anchor center -expand 0 -fill none -side left + pack $base.f1.e1 -in .mw.f1 -anchor center -expand 0 -fill none -side left + pack $base.f1.lb1 -in .mw.f1 -anchor center -expand 0 -fill none -side left + pack $base.f1.l2 -in .mw.f1 -anchor center -expand 0 -fill none -side left + pack $base.f1.e2 -in .mw.f1 -anchor center -expand 0 -fill none -side left + pack $base.f1.b1 -in .mw.f1 -anchor center -expand 0 -fill none -side right + pack $base.f1.b2 -in .mw.f1 -anchor center -expand 0 -fill none -side right + pack $base.frame20 -in .mw -anchor s -expand 0 -fill x -side bottom + pack $base.frame20.01 -in .mw.frame20 -anchor center -expand 0 -fill none -side left + pack $base.frame20.02 -in .mw.frame20 -anchor center -expand 1 -fill x -side left + pack $base.frame20.03 -in .mw.frame20 -anchor center -expand 0 -fill none -side right + pack $base.c -in .mw -anchor w -expand 1 -fill both -side left + pack $base.sb -in .mw -anchor e -expand 0 -fill y -side right } proc vTclWindow.nt {base} { @@ -2330,47 +2624,106 @@ proc vTclWindow.nt {base} { ################### toplevel $base -class Toplevel wm focusmodel $base passive - wm geometry $base 633x270+128+209 + wm geometry $base 630x312+148+315 wm maxsize $base 1009 738 wm minsize $base 1 1 wm overrideredirect $base 0 - wm resizable $base 1 1 + wm resizable $base 0 0 + wm deiconify $base wm title $base "Create table" - entry $base.etabn -background #fefefe -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable newtablename + entry $base.etabn \ + -background #fefefe -borderwidth 1 -highlightthickness 1 \ + -selectborderwidth 0 -textvariable newtablename bind $base.etabn { + focus .nt.einh + } + label $base.li \ + -anchor w -borderwidth 0 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -relief raised -text Inherits + entry $base.einh \ + -background #fefefe -borderwidth 1 -highlightthickness 1 \ + -selectborderwidth 0 -textvariable fathername + bind $base.einh { focus .nt.e2 } - entry $base.e2 -background #fefefe -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable fldname + button $base.binh \ + -borderwidth 1 \ + -command {if {[winfo exists .nt.ddf]} { + destroy .nt.ddf +} else { + create_drop_down .nt 95 52 + focus .nt.ddf.sb + foreach tbl [get_tables] {.nt.ddf.lb insert end $tbl} + bind .nt.ddf.lb { + set i [.nt.ddf.lb curselection] + if {$i!=""} {set fathername [.nt.ddf.lb get $i]} + after 50 {destroy .nt.ddf} + if {$i!=""} {focus .nt.e2} + } +}} \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -highlightthickness 0 -padx 9 -pady 3 -takefocus 0 -text v + entry $base.e2 \ + -background #fefefe -borderwidth 1 -highlightthickness 1 \ + -selectborderwidth 0 -textvariable fldname bind $base.e2 { focus .nt.e1 } - entry $base.e1 -background #fefefe -borderwidth 1 -cursor {} -highlightthickness 1 -selectborderwidth 0 -textvariable fldtype - bind $base.e1 { - tk_popup .nt.pop %X %Y - } + entry $base.e1 \ + -background #fefefe -borderwidth 1 -cursor {} -highlightthickness 1 \ + -selectborderwidth 0 -textvariable fldtype bind $base.e1 { focus .nt.e5 } - bind $base.e1 { - tk_popup .nt.pop [expr 150+[winfo rootx .nt]] [expr 65+[winfo rooty .nt]] - } - entry $base.e3 -background #fefefe -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable fldsize + entry $base.e3 \ + -background #fefefe -borderwidth 1 -highlightthickness 1 \ + -selectborderwidth 0 -textvariable fldsize bind $base.e3 { focus .nt.e5 } - entry $base.e5 -background #fefefe -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable defaultval + entry $base.e5 \ + -background #fefefe -borderwidth 1 -highlightthickness 1 \ + -selectborderwidth 0 -textvariable defaultval bind $base.e5 { focus .nt.cb1 } - checkbutton $base.cb1 -borderwidth 1 -offvalue { } -onvalue { NOT NULL} -text {field cannot be null} -variable notnull - label $base.lab1 -borderwidth 0 -relief raised -text {Field type} - label $base.lab2 -borderwidth 0 -relief raised -text {Field name} - label $base.lab3 -borderwidth 0 -relief raised -text {Field size} - label $base.lab4 -borderwidth 0 -relief raised -text {Default value} - 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]}} -padx 9 -pady 3 -text {Delete field} - 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 { + checkbutton $base.cb1 \ + -borderwidth 1 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -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.lab2 \ + -borderwidth 0 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -relief raised -text {Field name} + label $base.lab3 \ + -borderwidth 0 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -relief raised -text {Field size} + label $base.lab4 \ + -borderwidth 0 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -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.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.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.maketbl \ + -borderwidth 1 \ + -command {if {$newtablename==""} then { show_error "You must supply a name for your table!" focus .nt.etabn } elseif {[.nt.lb size]==0} then { @@ -2378,90 +2731,165 @@ proc vTclWindow.nt {base} { focus .nt.e2 } else { set temp "create table $newtablename ([join [.nt.lb get 0 end] ,])" - cursor_watch .nt + if {$fathername!=""} then {set temp "$temp inherits ($fathername)"} + cursor_watch .nt set retval [catch { set pgres [pg_exec $dbc $temp] pg_result $pgres -clear } errmsg ] - cursor_arrow .nt + cursor_arrow .nt if {$retval} { show_error "Error creating table\n$errmsg" } else { .nt.lb delete 0 end - Window hide .nt + Window destroy .nt cmd_Tables } -}} -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} +}} \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -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} bind $base.lb { if {[.nt.lb curselection]!=""} { set fldname [string trim [lindex [split [.nt.lb get [.nt.lb curselection]]] 0]] } } - button $base.exitbtn -borderwidth 1 -command {Window hide .nt} -padx 9 -pady 3 -text Cancel - label $base.l1 -anchor w -borderwidth 1 -relief raised -text {field name} - label $base.l2 -borderwidth 1 -relief raised -text type - label $base.l3 -borderwidth 1 -relief raised -text options - scrollbar $base.sb -borderwidth 1 -command {.nt.lb yview} -orient vert - label $base.l93 -borderwidth 0 -relief raised -text {Table name} - 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 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 char4; if {("char4"=="varchar")||("char4"=="char")} then {.nt.e3 configure -state normal;focus .nt.e3} else {.nt.e3 configure -state disabled;focus .nt.e5} } -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -label char4 - $base.pop add command -command {set fldtype char8; if {("char8"=="varchar")||("char8"=="char")} then {.nt.e3 configure -state normal;focus .nt.e3} else {.nt.e3 configure -state disabled;focus .nt.e5} } -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -label char8 - $base.pop add command -command {set fldtype char16; if {("char16"=="varchar")||("char16"=="char")} then {.nt.e3 configure -state normal;focus .nt.e3} else {.nt.e3 configure -state disabled;focus .nt.e5} } -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -label char16 - $base.pop add command -command {set fldtype varchar; if {("varchar"=="varchar")||("varchar"=="char")} then {.nt.e3 configure -state normal;focus .nt.e3} else {.nt.e3 configure -state disabled;focus .nt.e5} } -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -label varchar - $base.pop add command -command {set fldtype text; if {("text"=="varchar")||("text"=="char")} then {.nt.e3 configure -state normal;focus .nt.e3} else {.nt.e3 configure -state disabled;focus .nt.e5} } -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -label text - $base.pop add command -command {set fldtype int2; if {("int2"=="varchar")||("int2"=="char")} then {.nt.e3 configure -state normal;focus .nt.e3} else {.nt.e3 configure -state disabled;focus .nt.e5} } -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -label int2 - $base.pop add command -command {set fldtype int4; if {("int4"=="varchar")||("int4"=="char")} then {.nt.e3 configure -state normal;focus .nt.e3} else {.nt.e3 configure -state disabled;focus .nt.e5} } -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -label int4 - $base.pop add command -command {set fldtype float4; if {("float4"=="varchar")||("float4"=="char")} then {.nt.e3 configure -state normal;focus .nt.e3} else {.nt.e3 configure -state disabled;focus .nt.e5} } -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -label float4 - $base.pop add command -command {set fldtype float8; if {("float8"=="varchar")||("float8"=="char")} then {.nt.e3 configure -state normal;focus .nt.e3} else {.nt.e3 configure -state disabled;focus .nt.e5} } -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -label float8 - $base.pop add command -command {set fldtype date; if {("date"=="varchar")||("date"=="char")} then {.nt.e3 configure -state normal;focus .nt.e3} else {.nt.e3 configure -state disabled;focus .nt.e5} } -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -label date - $base.pop add command -command {set fldtype datetime; if {("datetime"=="varchar")||("datetime"=="char")} then {.nt.e3 configure -state normal;focus .nt.e3} else {.nt.e3 configure -state disabled;focus .nt.e5} } -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -label datetime - button $base.mvup -borderwidth 1 -command {if {[.nt.lb size]>2} { + button $base.exitbtn \ + -borderwidth 1 -command {Window destroy .nt} \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -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.l2 \ + -borderwidth 1 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -relief raised -text type + label $base.l3 \ + -borderwidth 1 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -relief raised -text options + scrollbar $base.sb \ + -borderwidth 1 -command {.nt.lb yview} -orient vert + label $base.l93 \ + -anchor w -borderwidth 0 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -relief raised -text {Table name} + button $base.mvup \ + -borderwidth 1 \ + -command {if {[.nt.lb size]>2} { set i [.nt.lb curselection] if {($i!="")&&($i>0)} { .nt.lb insert [expr $i-1] [.nt.lb get $i] .nt.lb delete [expr $i+1] .nt.lb selection set [expr $i-1] } -}} -padx 9 -pady 3 -text {Move field up} - button $base.mvdn -borderwidth 1 -command {if {[.nt.lb size]>2} { +}} \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ + -pady 3 -text {Move field up} + button $base.mvdn \ + -borderwidth 1 \ + -command {if {[.nt.lb size]>2} { set i [.nt.lb curselection] if {($i!="")&&($i<[expr [.nt.lb size]-1])} { .nt.lb insert [expr $i+2] [.nt.lb get $i] .nt.lb delete $i .nt.lb selection set [expr $i+1] } -}} -padx 9 -pady 3 -text {Move field down} - label $base.ll -borderwidth 1 -relief sunken +}} \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ + -pady 3 -text {Move field down} + label $base.ll \ + -borderwidth 1 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -relief sunken + button $base.button17 \ + -borderwidth 1 \ + -command {if {[winfo exists .nt.ddf]} { + destroy .nt.ddf +} else { + create_drop_down .nt 95 125 + focus .nt.ddf.sb + .nt.ddf.lb insert end char char2 char4 char8 char16 varchar text int2 int4 float4 float8 date datetime + bind .nt.ddf.lb { + set i [.nt.ddf.lb curselection] + if {$i!=""} {set fldtype [.nt.ddf.lb get $i]} + after 50 {destroy .nt.ddf} + if {$i!=""} {focus .nt.e3} + } +}} \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -highlightthickness 0 -padx 9 -pady 3 -takefocus 0 -text v + label $base.label18 \ + -borderwidth 1 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -relief sunken ################### # SETTING GEOMETRY ################### - place $base.etabn -x 95 -y 7 -anchor nw -bordermode ignore - place $base.e2 -x 95 -y 40 -anchor nw -bordermode ignore - place $base.e1 -x 95 -y 65 -anchor nw -bordermode ignore - place $base.e3 -x 95 -y 90 -anchor nw -bordermode ignore - place $base.e5 -x 95 -y 115 -anchor nw -bordermode ignore - place $base.cb1 -x 95 -y 140 -anchor nw -bordermode ignore - place $base.lab1 -x 10 -y 67 -anchor nw -bordermode ignore - place $base.lab2 -x 10 -y 42 -anchor nw -bordermode ignore - place $base.lab3 -x 10 -y 92 -anchor nw -bordermode ignore - place $base.lab4 -x 10 -y 117 -anchor nw -bordermode ignore - place $base.addfld -x 10 -y 175 -anchor nw -bordermode ignore - place $base.delfld -x 85 -y 175 -width 82 -anchor nw -bordermode ignore - place $base.emptb -x 170 -y 175 -anchor nw -bordermode ignore - place $base.maketbl -x 10 -y 235 -width 156 -height 26 -anchor nw -bordermode ignore - place $base.lb -x 260 -y 25 -width 353 -height 236 -anchor nw -bordermode ignore - place $base.exitbtn -x 170 -y 235 -width 77 -height 26 -anchor nw -bordermode ignore - place $base.l1 -x 261 -y 9 -width 98 -height 18 -anchor nw -bordermode ignore - place $base.l2 -x 360 -y 9 -width 86 -height 18 -anchor nw -bordermode ignore - place $base.l3 -x 446 -y 9 -width 166 -height 18 -anchor nw -bordermode ignore - place $base.sb -x 610 -y 25 -width 18 -height 237 -anchor nw -bordermode ignore - place $base.l93 -x 10 -y 10 -anchor nw -bordermode ignore - place $base.mvup -x 10 -y 205 -width 118 -height 26 -anchor nw -bordermode ignore - place $base.mvdn -x 130 -y 205 -anchor nw -bordermode ignore - place $base.ll -x 12 -y 165 -width 233 -height 2 -anchor nw -bordermode ignore + place $base.etabn \ + -x 95 -y 7 -anchor nw -bordermode ignore + place $base.li \ + -x 10 -y 35 -anchor nw -bordermode ignore + place $base.einh \ + -x 95 -y 32 -anchor nw -bordermode ignore + place $base.binh \ + -x 242 -y 33 -width 16 -height 19 -anchor nw -bordermode ignore + place $base.e2 \ + -x 95 -y 80 -anchor nw -bordermode ignore + place $base.e1 \ + -x 95 -y 105 -anchor nw -bordermode ignore + place $base.e3 \ + -x 95 -y 130 -anchor nw -bordermode ignore + place $base.e5 \ + -x 95 -y 155 -anchor nw -bordermode ignore + place $base.cb1 \ + -x 95 -y 180 -anchor nw -bordermode ignore + place $base.lab1 \ + -x 10 -y 107 -anchor nw -bordermode ignore + place $base.lab2 \ + -x 10 -y 82 -anchor nw -bordermode ignore + place $base.lab3 \ + -x 10 -y 132 -anchor nw -bordermode ignore + place $base.lab4 \ + -x 10 -y 157 -anchor nw -bordermode ignore + place $base.addfld \ + -x 10 -y 220 -anchor nw -bordermode ignore + place $base.delfld \ + -x 85 -y 220 -width 82 -anchor nw -bordermode ignore + place $base.emptb \ + -x 170 -y 220 -anchor nw -bordermode ignore + place $base.maketbl \ + -x 10 -y 280 -width 156 -height 26 -anchor nw -bordermode ignore + place $base.lb \ + -x 260 -y 25 -width 353 -height 281 -anchor nw -bordermode ignore + place $base.exitbtn \ + -x 170 -y 280 -width 77 -height 26 -anchor nw -bordermode ignore + place $base.l1 \ + -x 261 -y 9 -width 98 -height 18 -anchor nw -bordermode ignore + place $base.l2 \ + -x 360 -y 9 -width 86 -height 18 -anchor nw -bordermode ignore + place $base.l3 \ + -x 446 -y 9 -width 166 -height 18 -anchor nw -bordermode ignore + place $base.sb \ + -x 610 -y 25 -width 18 -height 282 -anchor nw -bordermode ignore + place $base.l93 \ + -x 10 -y 10 -anchor nw -bordermode ignore + place $base.mvup \ + -x 10 -y 250 -width 118 -height 26 -anchor nw -bordermode ignore + place $base.mvdn \ + -x 130 -y 250 -height 26 -anchor nw -bordermode ignore + place $base.ll \ + -x 10 -y 210 -width 233 -height 2 -anchor nw -bordermode ignore + place $base.button17 \ + -x 242 -y 106 -width 16 -height 19 -anchor nw -bordermode ignore + place $base.label18 \ + -x 10 -y 65 -width 233 -height 2 -anchor nw -bordermode ignore } proc vTclWindow.pw {base} { @@ -2493,7 +2921,7 @@ proc vTclWindow.pw {base} { tk_messageBox -title Warning -message "A big number of rows displayed in table view will take a lot of memory!" } save_pref -Window hide .pw} -padx 9 -pady 3 -text Ok +Window destroy .pw} -padx 9 -pady 3 -text Ok ################### # SETTING GEOMETRY ################### @@ -2517,24 +2945,18 @@ proc vTclWindow.qb {base} { ################### # CREATING WIDGETS ################### - toplevel $base -class Toplevel \ - -cursor top_left_arrow + toplevel $base -class Toplevel -cursor top_left_arrow wm focusmodel $base passive - wm geometry $base 442x344+277+276 + wm geometry $base 442x344+282+299 wm maxsize $base 1009 738 wm minsize $base 1 1 wm overrideredirect $base 0 wm resizable $base 0 0 + wm deiconify $base wm title $base "Query builder" - label $base.lqn \ - -borderwidth 0 \ - -relief raised -text {Query name} - entry $base.eqn \ - -background #fefefe -borderwidth 1 -highlightthickness 1 \ - -selectborderwidth 0 -textvariable queryname - button $base.savebtn \ - -borderwidth 1 \ - -command {if {$queryname==""} then { + label $base.lqn -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text {Query name} + entry $base.eqn -background #fefefe -borderwidth 1 -foreground #000000 -highlightthickness 1 -selectborderwidth 0 -textvariable queryname + button $base.savebtn -borderwidth 1 -command {if {$queryname==""} then { show_error "You have to supply a name for this query!" focus .qb.eqn } else { @@ -2555,7 +2977,7 @@ proc vTclWindow.qb {base} { show_error "Error defining view\n\n$errmsg" } else { tab_click .dw.tabViews - Window hide .qb + Window destroy .qb } } else { cursor_watch .qb @@ -2576,11 +2998,8 @@ proc vTclWindow.qb {base} { } catch {pg_result $pgres -clear} } -}} \ - -padx 9 -pady 3 -text {Save query definition} - button $base.execbtn \ - -borderwidth 1 \ - -command {Window show .mw +}} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text {Save query definition} + button $base.execbtn -borderwidth 1 -command {Window show .mw set qcmd [.qb.text1 get 0.0 end] regsub -all "\n" $qcmd " " qcmd set mw(layout_name) $queryname @@ -2588,50 +3007,28 @@ mw_load_layout $queryname set mw(query) $qcmd set mw(updatable) 0 set mw(isaquery) 1 -mw_select_records $qcmd} \ - -padx 9 \ - -pady 3 -text {Execute query} - button $base.termbtn \ - -borderwidth 1 \ - -command {.qb.cbv configure -state normal +mw_select_records $qcmd} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text {Execute query} + button $base.termbtn -borderwidth 1 -command {.qb.cbv configure -state normal set cbv 0 set queryname {} .qb.text1 delete 1.0 end -Window hide .qb} \ - -padx 9 \ - -pady 3 -text Close - text $base.text1 \ - -background #fefefe -borderwidth 1 \ - -highlightthickness 1 -wrap word - checkbutton $base.cbv \ - -borderwidth 1 \ - -text {Save this query as a view} -variable cbv - button $base.qlshow \ - -borderwidth 1 \ - -command {Window show .ql +Window destroy .qb} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text Close + text $base.text1 -background #fefefe -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -foreground #000000 -highlightthickness 1 -wrap word + checkbutton $base.cbv -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -text {Save this query as a view} -variable cbv + button $base.qlshow -borderwidth 1 -command {Window show .ql ql_draw_lizzard -focus .ql.entt} \ - -padx 9 \ - -pady 3 -text {Visual designer} +focus .ql.entt} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text {Visual designer} ################### # SETTING GEOMETRY ################### - place $base.lqn \ - -x 5 -y 5 -anchor nw -bordermode ignore - place $base.eqn \ - -x 80 -y 1 -width 355 -height 24 -anchor nw -bordermode ignore - place $base.savebtn \ - -x 5 -y 60 -anchor nw -bordermode ignore - place $base.execbtn \ - -x 150 -y 60 -anchor nw -bordermode ignore - place $base.termbtn \ - -x 375 -y 60 -anchor nw -bordermode ignore - place $base.text1 \ - -x 5 -y 90 -width 430 -height 246 -anchor nw -bordermode ignore - place $base.cbv \ - -x 5 -y 30 -anchor nw -bordermode ignore - place $base.qlshow \ - -x 255 -y 60 -anchor nw -bordermode ignore + place $base.lqn -x 5 -y 5 -anchor nw -bordermode ignore + place $base.eqn -x 80 -y 1 -width 355 -height 24 -anchor nw -bordermode ignore + place $base.savebtn -x 5 -y 60 -anchor nw -bordermode ignore + place $base.execbtn -x 150 -y 60 -anchor nw -bordermode ignore + place $base.termbtn -x 375 -y 60 -anchor nw -bordermode ignore + place $base.text1 -x 5 -y 90 -width 430 -height 246 -anchor nw -bordermode ignore + place $base.cbv -x 5 -y 30 -anchor nw -bordermode ignore + place $base.qlshow -x 255 -y 60 -anchor nw -bordermode ignore } proc vTclWindow.ql {base} { @@ -2646,11 +3043,12 @@ proc vTclWindow.ql {base} { ################### toplevel $base -class Toplevel -cursor top_left_arrow wm focusmodel $base passive - wm geometry $base 759x530+228+154 + wm geometry $base 759x530+233+177 wm maxsize $base 1009 738 wm minsize $base 1 1 wm overrideredirect $base 0 wm resizable $base 1 1 + wm deiconify $base wm title $base "Visual query designer" bind $base { ql_pan %x %y @@ -2665,11 +3063,11 @@ proc vTclWindow.ql {base} { ql_delete_object } canvas $base.c -background #fefefe -borderwidth 2 -height 207 -relief ridge -takefocus 0 -width 295 - button $base.b1 -borderwidth 1 -command ql_add_new_table -padx 9 -pady 3 -text {Add table} - button $base.exitbtn -borderwidth 1 -command {ql_init -Window hide .ql} -padx 9 -pady 3 -text Close - button $base.showbtn -borderwidth 1 -command ql_show_sql -padx 9 -pady 3 -text {Show SQL} - label $base.l12 -borderwidth 0 -relief raised -text Table + button $base.exitbtn -borderwidth 1 -command { +ql_init +Window destroy .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 {Add table} entry $base.entt -background #fefefe -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable qlvar(newtablename) bind $base.entt { ql_add_new_table @@ -2681,24 +3079,38 @@ mw_load_layout $mw(layout_name) set mw(query) $qcmd set mw(updatable) 0 set mw(isaquery) 1 -mw_select_records $qcmd} -padx 9 -pady 3 -text {Execute SQL} +mw_select_records $qcmd} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text {Execute SQL} button $base.stoqb -borderwidth 1 -command {Window show .qb .qb.text1 delete 1.0 end .qb.text1 insert end [ql_compute_sql] -focus .qb} -padx 9 -pady 3 -text {Save to query builder} +focus .qb} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text {Save to query builder} + button $base.bdd -borderwidth 1 -command {if {[winfo exists .ql.ddf]} { + destroy .ql.ddf +} else { + create_drop_down .ql 70 27 + focus .ql.ddf.sb + foreach tbl [get_tables] {.ql.ddf.lb insert end $tbl} + bind .ql.ddf.lb { + set i [.ql.ddf.lb curselection] + if {$i!=""} {set qlvar(newtablename) [.ql.ddf.lb get $i]} + after 50 {destroy .ql.ddf} + if {$i!=""} {ql_add_new_table} + } +}} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -highlightthickness 0 -padx 9 -pady 3 -text v ################### # SETTING GEOMETRY ################### place $base.c -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.exitbtn -x 695 -y 5 -height 26 -anchor nw -bordermode ignore place $base.showbtn -x 367 -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.l12 -x 10 -y 8 -width 53 -height 16 -anchor nw -bordermode ignore + place $base.entt -x 70 -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 + place $base.stoqb -x 550 -y 5 -height 26 -anchor nw -bordermode ignore + place $base.bdd -x 200 -y 7 -width 17 -height 20 -anchor nw -bordermode ignore } + proc vTclWindow.rf {base} { if {$base == ""} { set base .rf @@ -2727,7 +3139,7 @@ proc vTclWindow.rf {base} { if {$retval} { sql_exec quiet "update pga_layout set tablename='$newobjname' where tablename='$oldobjname'" cmd_Tables - Window hide .rf + Window destroy .rf } } elseif {$activetab=="Queries"} { set retval [catch {set pgres [pg_exec $dbc "select * from pga_queries where queryname='$newobjname'"]} errmsg] @@ -2741,11 +3153,11 @@ proc vTclWindow.rf {base} { sql_exec noquiet "update pga_queries set queryname='$newobjname' where queryname='$oldobjname'" sql_exec noquiet "update pga_layout set tablename='$newobjname' where tablename='$oldobjname'" cmd_Queries - Window hide .rf + Window destroy .rf } } } -padx 9 -pady 3 -text Rename - button $base.b2 -borderwidth 1 -command {Window hide .rf} -padx 9 -pady 3 -text Cancel + button $base.b2 -borderwidth 1 -command {Window destroy .rf} -padx 9 -pady 3 -text Cancel ################### # SETTING GEOMETRY ################### @@ -2755,6 +3167,298 @@ proc vTclWindow.rf {base} { place $base.b2 -x 145 -y 65 -width 70 -anchor nw -bordermode ignore } +proc vTclWindow.rb {base} { + if {$base == ""} { + set base .rb + } + if {[winfo exists $base]} { + wm deiconify $base; return + } + ################### + # CREATING WIDGETS + ################### + toplevel $base -class Toplevel + wm focusmodel $base passive + wm geometry $base 652x426+96+160 + wm maxsize $base 1009 738 + wm minsize $base 1 1 + wm overrideredirect $base 0 + wm resizable $base 0 0 + wm deiconify $base + wm title $base "Report builder" + label $base.l1 \ + -borderwidth 1 \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ + -relief raised -text {Report fields} + listbox $base.lb \ + -background #fefefe -borderwidth 1 \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ + -highlightthickness 1 -selectborderwidth 0 \ + -yscrollcommand {.rb.sb set} + bind $base.lb { + rb_add_field + } + canvas $base.c \ + -background #fffeff -borderwidth 2 -height 207 -highlightthickness 0 \ + -relief ridge -takefocus 1 -width 295 + bind $base.c { + rb_dragstart %W %x %y + } + bind $base.c { + rb_dragstop %x %y + } + bind $base.c { + rb_delete_object + } + bind $base.c { + rb_dragit %W %x %y + } + button $base.bt2 \ + -borderwidth 1 \ + -command {if {[tk_messageBox -title Warning -message "All report information will be deleted.\n\nProceed ?" -type yesno -default no]=="yes"} then { +.rb.c delete all +rb_init +rb_draw_regions +}} \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -padx 9 \ + -pady 3 -text {Clear all} + button $base.bt4 \ + -borderwidth 1 -command rb_preview \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -padx 9 \ + -pady 3 -text Preview + button $base.bt5 \ + -borderwidth 1 -command {Window destroy .rb} \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -padx 9 \ + -pady 3 -text Quit + scrollbar $base.sb \ + -borderwidth 1 -command {.rb.lb yview} -orient vert + label $base.lmsg \ + -anchor w -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ + -relief groove -text {Report header} -textvariable rbvar(msg) + entry $base.e2 \ + -background #fefefe -borderwidth 1 -highlightthickness 0 \ + -textvariable rbvar(tablename) + bind $base.e2 { + rb_get_report_fields + } + entry $base.elab \ + -background #fefefe -borderwidth 1 -highlightthickness 0 \ + -textvariable rbvar(labeltext) + button $base.badl \ + -borderwidth 1 -command rb_add_label \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -padx 9 \ + -pady 3 -text {Add label} + label $base.lbold \ + -borderwidth 1 -relief raised -text B + bind $base.lbold { + if {[rb_get_bold]=="Bold"} { + .rb.lbold configure -relief raised +} else { + .rb.lbold configure -relief sunken +} +rb_change_object_font + } + label $base.lita \ + -borderwidth 1 \ + -font -Adobe-Helvetica-Medium-O-Normal--*-120-*-*-*-*-*-* \ + -relief raised -text i + bind $base.lita { + if {[rb_get_italic]=="O"} { + .rb.lita configure -relief raised +} else { + .rb.lita configure -relief sunken +} +rb_change_object_font + } + entry $base.eps \ + -background #fefefe -highlightthickness 0 -relief groove \ + -textvariable rbvar(pointsize) + bind $base.eps { + rb_change_object_font + } + label $base.linfo \ + -anchor w -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ + -relief groove -text {Database field} -textvariable rbvar(info) + label $base.llal \ + -borderwidth 0 \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ + -relief raised -text Align + button $base.balign \ + -borderwidth 0 -command rb_flip_align \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -padx 9 \ + -pady 3 -relief groove -text right + button $base.savebtn \ + -borderwidth 1 -command rb_save_report \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -padx 9 \ + -pady 3 -text Save + label $base.lfn \ + -borderwidth 0 \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ + -relief raised -text Font + button $base.bfont \ + -borderwidth 0 \ + -command {set temp [.rb.bfont cget -text] +if {$temp=="Courier"} then { + .rb.bfont configure -text Helvetica +} else { + .rb.bfont configure -text Courier +} +rb_change_object_font} \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -padx 9 \ + -pady 3 -relief groove -text Courier + button $base.bdd \ + -borderwidth 1 \ + -command {if {[winfo exists .rb.ddf]} { + destroy .rb.ddf +} else { + create_drop_down .rb 405 24 + focus .rb.ddf.sb + foreach tbl [get_tables] {.rb.ddf.lb insert end $tbl} + bind .rb.ddf.lb { + set i [.rb.ddf.lb curselection] + if {$i!=""} {set rbvar(tablename) [.rb.ddf.lb get $i]} + after 50 {destroy .rb.ddf} + rb_get_report_fields + } +}} \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ + -highlightthickness 0 -padx 9 -pady 2 -text v + label $base.lrn \ + -borderwidth 0 \ + -font -Adobe-Helvetica-medium-R-Normal--*-120-*-*-*-*-*-* \ + -relief raised -text {Report name} + entry $base.ern \ + -background #fefefe -borderwidth 1 -highlightthickness 0 \ + -textvariable rbvar(reportname) + bind $base.ern { + rb_load_report + } + label $base.lrs \ + -borderwidth 0 \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ + -relief raised -text {Report source} + label $base.ls \ + -borderwidth 1 -relief raised + entry $base.ef \ + -background #fefefe -borderwidth 1 -highlightthickness 0 \ + -textvariable rbvar(formula) + button $base.baf \ + -borderwidth 1 \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -padx 9 \ + -pady 3 -text {Add formula} + ################### + # SETTING GEOMETRY + ################### + place $base.l1 \ + -x 5 -y 55 -width 131 -height 18 -anchor nw -bordermode ignore + place $base.lb \ + -x 5 -y 70 -width 118 -height 121 -anchor nw -bordermode ignore + place $base.c \ + -x 140 -y 75 -width 508 -height 345 -anchor nw -bordermode ignore + place $base.bt2 \ + -x 5 -y 365 -width 64 -height 26 -anchor nw -bordermode ignore + place $base.bt4 \ + -x 70 -y 365 -width 66 -height 26 -anchor nw -bordermode ignore + place $base.bt5 \ + -x 70 -y 395 -width 66 -height 26 -anchor nw -bordermode ignore + place $base.sb \ + -x 120 -y 70 -width 18 -height 122 -anchor nw -bordermode ignore + place $base.lmsg \ + -x 142 -y 55 -width 151 -height 18 -anchor nw -bordermode ignore + place $base.e2 \ + -x 405 -y 4 -width 129 -height 18 -anchor nw -bordermode ignore + place $base.elab \ + -x 5 -y 225 -width 130 -height 18 -anchor nw -bordermode ignore + place $base.badl \ + -x 5 -y 243 -width 132 -height 26 -anchor nw -bordermode ignore + place $base.lbold \ + -x 535 -y 55 -width 18 -height 18 -anchor nw -bordermode ignore + place $base.lita \ + -x 555 -y 55 -width 18 -height 18 -anchor nw -bordermode ignore + place $base.eps \ + -x 500 -y 55 -width 30 -height 18 -anchor nw -bordermode ignore + place $base.linfo \ + -x 295 -y 55 -width 91 -height 18 -anchor nw -bordermode ignore + place $base.llal \ + -x 575 -y 56 -anchor nw -bordermode ignore + place $base.balign \ + -x 610 -y 54 -width 35 -height 21 -anchor nw -bordermode ignore + place $base.savebtn \ + -x 5 -y 395 -width 64 -height 26 -anchor nw -bordermode ignore + place $base.lfn \ + -x 405 -y 56 -anchor nw -bordermode ignore + place $base.bfont \ + -x 435 -y 54 -width 65 -height 21 -anchor nw -bordermode ignore + place $base.bdd \ + -x 535 -y 4 -width 15 -height 20 -anchor nw -bordermode ignore + place $base.lrn \ + -x 5 -y 5 -anchor nw -bordermode ignore + place $base.ern \ + -x 80 -y 4 -width 219 -height 18 -anchor nw -bordermode ignore + place $base.lrs \ + -x 320 -y 5 -anchor nw -bordermode ignore + place $base.ls \ + -x 5 -y 30 -width 641 -height 2 -anchor nw -bordermode ignore + place $base.ef \ + -x 5 -y 280 -width 130 -height 18 -anchor nw -bordermode ignore + place $base.baf \ + -x 5 -y 298 -width 132 -height 26 -anchor nw -bordermode ignore +} + +proc vTclWindow.rpv {base} { + if {$base == ""} { + set base .rpv + } + if {[winfo exists $base]} { + wm deiconify $base; return + } + ################### + # CREATING WIDGETS + ################### + toplevel $base -class Toplevel + wm focusmodel $base passive + wm geometry $base 495x500+239+165 + wm maxsize $base 1009 738 + wm minsize $base 1 1 + wm overrideredirect $base 0 + wm resizable $base 1 1 + wm title $base "Report preview" + frame $base.fr \ + -borderwidth 2 -height 75 -relief groove -width 125 + canvas $base.fr.c \ + -background #fcfefe -borderwidth 2 -height 207 -relief ridge \ + -scrollregion {0 0 1000 824} -width 295 \ + -yscrollcommand {.rpv.fr.sb set} + scrollbar $base.fr.sb \ + -borderwidth 1 -command {.rpv.fr.c yview} -highlightthickness 0 \ + -orient vert -width 12 + frame $base.f1 \ + -borderwidth 2 -height 75 -width 125 + button $base.f1.button18 \ + -borderwidth 1 -command {if {$rbvar(justpreview)} then {Window destroy .rb} ; Window destroy .rpv} \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -padx 9 \ + -pady 3 -text Close + button $base.f1.button17 \ + -borderwidth 1 -command rb_print_report \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -padx 9 \ + -pady 3 -text Print + ################### + # SETTING GEOMETRY + ################### + pack $base.fr \ + -in .rpv -anchor center -expand 1 -fill both -side top + pack $base.fr.c \ + -in .rpv.fr -anchor center -expand 1 -fill both -side left + pack $base.fr.sb \ + -in .rpv.fr -anchor center -expand 0 -fill y -side right + pack $base.f1 \ + -in .rpv -anchor center -expand 0 -fill none -side top + pack $base.f1.button18 \ + -in .rpv.f1 -anchor center -expand 0 -fill none -side right + pack $base.f1.button17 \ + -in .rpv.f1 -anchor center -expand 0 -fill none -side left +} + proc vTclWindow.sqf {base} { if {$base == ""} { set base .sqf @@ -2806,7 +3510,7 @@ proc vTclWindow.sqf {base} { .sqf.l3 configure -text {Start value} } place .sqf.defbtn -x 40 -y 175 -Window hide .sqf +Window destroy .sqf } -padx 9 -pady 3 -text Close ################### # SETTING GEOMETRY @@ -2825,6 +3529,51 @@ Window hide .sqf place $base.closebtn -x 195 -y 175 -anchor nw -bordermode ignore } +proc vTclWindow.sw {base} { + if {$base == ""} { + set base .sw + } + if {[winfo exists $base]} { + wm deiconify $base; return + } + ################### + # CREATING WIDGETS + ################### + toplevel $base -class Toplevel + wm focusmodel $base passive + wm geometry $base 594x416+248+217 + wm maxsize $base 1009 738 + wm minsize $base 300 300 + wm overrideredirect $base 0 + wm resizable $base 1 1 + wm title $base "Design script" + frame $base.f1 -height 55 -relief groove -width 125 + label $base.f1.l1 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief raised -text {Script name} + entry $base.f1.e1 -background #fefefe -borderwidth 1 -highlightthickness 0 -textvariable scriptname -width 32 + text $base.src -background #fefefe -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -height 2 -highlightthickness 1 -selectborderwidth 0 -width 2 + frame $base.f2 -height 75 -relief groove -width 125 + button $base.f2.b1 -borderwidth 1 -command {Window destroy .sw} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text Cancel + button $base.f2.b2 -borderwidth 1 -command {if {$scriptname==""} { + tk_messageBox -title Warning -message "The script must have a name!" +} else { + sql_exec noquiet "delete from pga_scripts where scriptname='$scriptname'" + regsub -all {\\} [.sw.src get 1.0 end] {\\\\} scriptsource + regsub -all ' $scriptsource \\' scriptsource + sql_exec noquiet "insert into pga_scripts values ('$scriptname','$scriptsource')" + cmd_Scripts +}} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text Save -width 6 + ################### + # SETTING GEOMETRY + ################### + pack $base.f1 -in .sw -anchor center -expand 0 -fill x -pady 2 -side top + pack $base.f1.l1 -in .sw.f1 -anchor center -expand 0 -fill none -ipadx 2 -side left + pack $base.f1.e1 -in .sw.f1 -anchor center -expand 0 -fill none -side left + pack $base.src -in .sw -anchor center -expand 1 -fill both -padx 2 -side top + pack $base.f2 -in .sw -anchor center -expand 0 -fill none -side top + pack $base.f2.b1 -in .sw.f2 -anchor center -expand 0 -fill none -side right + pack $base.f2.b2 -in .sw.f2 -anchor center -expand 0 -fill none -side right +} + proc vTclWindow.tiw {base} { if {$base == ""} { set base .tiw @@ -2843,119 +3592,54 @@ proc vTclWindow.tiw {base} { wm overrideredirect $base 0 wm resizable $base 1 1 wm title $base "Table information" - label $base.l1 \ - -borderwidth 0 \ - -relief raised -text {Table name} - label $base.l2 \ - -anchor w -borderwidth 0 \ - -relief raised -text conturi -textvariable tiw(tablename) - label $base.l3 \ - -borderwidth 0 \ - -relief raised -text Owner - 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 + label $base.l1 -borderwidth 0 -relief raised -text {Table name} + label $base.l2 -anchor w -borderwidth 0 -relief raised -text conturi -textvariable tiw(tablename) + label $base.l3 -borderwidth 0 -relief raised -text Owner + 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 destroy .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 { 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 + 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 ################### - place $base.l1 \ - -x 20 -y 15 -anchor nw -bordermode ignore - place $base.l2 \ - -x 100 -y 14 -width 161 -height 18 -anchor nw -bordermode ignore - place $base.l3 \ - -x 20 -y 35 -anchor nw -bordermode ignore - place $base.l4 \ - -x 100 -y 34 -width 226 -height 18 -anchor nw -bordermode ignore - place $base.lb \ - -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 + place $base.l1 -x 20 -y 15 -anchor nw -bordermode ignore + place $base.l2 -x 100 -y 14 -width 161 -height 18 -anchor nw -bordermode ignore + place $base.l3 -x 20 -y 35 -anchor nw -bordermode ignore + place $base.l4 -x 100 -y 34 -width 226 -height 18 -anchor nw -bordermode ignore + place $base.lb -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 . -- 2.11.0