From a00c6681394c19ca9e0115804eae45accc1346df Mon Sep 17 00:00:00 2001 From: "Marc G. Fournier" Date: Fri, 6 Nov 1998 04:11:52 +0000 Subject: [PATCH] Upgrade to 0.91 ... --- src/bin/pgaccess/README.pga | 2 +- src/bin/pgaccess/a_right.gif | Bin 0 -> 207 bytes src/bin/pgaccess/formdemo.sql | 56 +- src/bin/pgaccess/index.html | 4 +- src/bin/pgaccess/pgaccess.tcl | 5098 +++++++++++++++++---------------- 5 files changed, 2645 insertions(+), 2515 deletions(-) create mode 100644 src/bin/pgaccess/a_right.gif diff --git a/src/bin/pgaccess/README.pga b/src/bin/pgaccess/README.pga index 175a983e64..8e5abc0c94 100644 --- a/src/bin/pgaccess/README.pga +++ b/src/bin/pgaccess/README.pga @@ -22,7 +22,7 @@ PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. --------------------------------------------------------------------------- -PGACCESS 0.90 18 September 1998 +PGACCESS 0.91 1 November 1998 ================================ I dedicate this program to my little daughters Ana-Maria and Emilia and to my wife for their understanding. I hope they will forgive me for spending so many diff --git a/src/bin/pgaccess/a_right.gif b/src/bin/pgaccess/a_right.gif new file mode 100644 index 0000000000000000000000000000000000000000..386e27c304feb300eb29248ae887e13fb338bf70 GIT binary patch literal 207 zcmZ?wbhEHb6k!lyc+3C-MrVx}{xjUUb7$Yaefs|Xdfnj#4HNe7-w&2VClr6OFfuT3 zFzA3JKxQzo)CipPT)kEOb#&*o1Azq|&uSwJW9E4YWJQTMOqKj$FlS?wzml^;gYk#7 zhKVU<0(|YR6Fbx

-
  • Download the last version of PgAccess +
  • Download the last version of PgAccess (press shift and click this link).
    • -

    Latest version of PgAccess is 0.90 , 18 September 1998 !
    +

    Latest version of PgAccess is 0.91 , 1 November 1998 !

      NEW * NEW * NEW * NEW * ==== > QUERY PARAMETERS diff --git a/src/bin/pgaccess/pgaccess.tcl b/src/bin/pgaccess/pgaccess.tcl index a21edd072b..78079b39e3 100644 --- a/src/bin/pgaccess/pgaccess.tcl +++ b/src/bin/pgaccess/pgaccess.tcl @@ -23,7 +23,7 @@ global pref; global qlvar; global sdbname; global tablist; -global widget; +global widget; ################################# # USER DEFINED PROCEDURES @@ -56,45 +56,107 @@ set qlvar(newtablename) {} init $argc $argv +proc {sqlw_display} {msg} { + if {![winfo exists .sqlw]} {return} + .sqlw.f.t insert end "$msg\n\n" + .sqlw.f.t see end + set nrlines [lindex [split [.sqlw.f.t index end] .] 0] + if {$nrlines>50} { + .sqlw.f.t delete 1.0 3.0 + } +} + +proc {wpg_exec} {db cmd} { +global pgsql + if {[catch { + sqlw_display $cmd + set pgsql(cmd) $cmd + set pgsql(res) [pg_exec $db $cmd] + set pgsql(status) [pg_result $pgsql(res) -status] + set pgsql(errmsg) [pg_result $pgsql(res) -error] + } tclerrmsg]} { + show_error "Tcl error executing pg_exec $cmd\n\n$tclerrmsg" + return 0 + } + return $pgsql(res) +} -proc {MsgBox} {mesaj} { -tk_messageBox -title Mesaj -message $mesaj +proc {wpg_select} {args} { + sqlw_display "[lindex $args 1]" + uplevel pg_select $args } proc {add_new_field} {} { -global fldname fldtype fldsize defaultval notnull -if {$fldname==""} { - show_error "Enter a field name" - focus .nt.e2 +global ntw +if {$ntw(fldname)==""} { + show_error "Enter a field name" + focus .nt.e2 return } -if {$fldtype==""} { - show_error "The field type is not specified!" +if {$ntw(fldtype)==""} { + show_error "The field type is not specified!" return } -if {(($fldtype=="varchar")||($fldtype=="char"))&&($fldsize=="")} { - focus .nt.e3 - show_error "You must specify field size!" +if {($ntw(fldtype)=="varchar")&&($ntw(fldsize)=="")} { + focus .nt.e3 + show_error "You must specify field size!" return } -if {$fldsize==""} then {set sup ""} else {set sup "($fldsize)"} -if {[regexp $fldtype "varchar2char4char8char16textdatetime"]} {set supc "'"} else {set supc ""} -if {$defaultval==""} then {set sup2 ""} else {set sup2 " DEFAULT $supc$defaultval$supc"} +if {$ntw(fldsize)==""} then {set sup ""} else {set sup "($ntw(fldsize))"} +if {[regexp $ntw(fldtype) "varchartextdatetime"]} {set supc "'"} else {set supc ""} +if {$ntw(defaultval)==""} then {set sup2 ""} else {set sup2 " DEFAULT $supc$ntw(defaultval)$supc"} # Checking for field name collision set inspos end for {set i 0} {$i<[.nt.lb size]} {incr i} { set linie [.nt.lb get $i] - if {$fldname==[lindex [split $linie] 0]} { - if {[tk_messageBox -title Warning -message "There is another field with the same name!\n\nReplace it ?" -type yesno -default yes]=="no"} return + if {$ntw(fldname)==[string trim [string range $linie 2 33]]} { + if {[tk_messageBox -title Warning -message "There is another field with the same name: \"$ntw(fldname)\"!\n\nReplace it ?" -type yesno -default yes]=="no"} return .nt.lb delete $i set inspos $i + break } } -.nt.lb insert $inspos [format "%-17s%-14s%-16s" $fldname $fldtype$sup $sup2$notnull] +.nt.lb insert $inspos [format "%1s %-32.32s %-14s%-16s" $ntw(pk) $ntw(fldname) $ntw(fldtype)$sup $sup2$ntw(notnull)] focus .nt.e2 -set fldname {} -set fldsize {} -set defaultval {} +set ntw(fldname) {} +set ntw(fldsize) {} +set ntw(defaultval) {} +set ntw(pk) " " +} + +proc {create_table} {} { +global dbc ntw +if {$ntw(newtablename)==""} then { + show_error "You must supply a name for your table!" + focus .nt.etabn + return +} +if {[.nt.lb size]==0} then { + show_error "Your table has no fields!" + focus .nt.e2 + return +} +set fl {} +set pkf {} +foreach line [.nt.lb get 0 end] { + set fldname "\"[string trim [string range $line 2 33]]\"" + lappend fl "$fldname [string trim [string range $line 35 end]]" + if {[string range $line 0 0]=="*"} { + lappend pkf "$fldname" + } +} +set temp "create table \"$ntw(newtablename)\" ([join $fl ,]" +if {$ntw(constraint)!=""} then {set temp "$temp, constraint \"$ntw(constraint)\""} +if {$ntw(check)!=""} then {set temp "$temp check ($ntw(check))"} +if {[llength $pkf]>0} then {set temp "$temp, primary key([join $pkf ,])"} +set temp "$temp)" +if {$ntw(fathername)!=""} then {set temp "$temp inherits ($ntw(fathername))"} +cursor_clock +if {[sql_exec noquiet $temp]} { + Window destroy .nt + cmd_Tables +} +cursor_normal } proc {cmd_Delete} {} { @@ -166,39 +228,39 @@ if {[.dw.lb curselection]==""} return; set objname [.dw.lb get [.dw.lb curselection]] set tablename $objname switch $activetab { - Queries {open_query design} - Scripts {design_script $objname} - Forms {fd_load_form $objname design} - Reports { + Queries {open_query design} + Scripts {design_script $objname} + Forms {fd_load_form $objname design} + 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 +cursor_clock .dw.lb delete 0 end catch { - pg_select $dbc "select formname from pga_forms order by formname" rec { - .dw.lb insert end $rec(formname) - } + wpg_select $dbc "select formname from pga_forms order by formname" rec { + .dw.lb insert end $rec(formname) + } } -cursor_arrow .dw +cursor_normal } proc {cmd_Functions} {} { global dbc set maxim 0 set pgid 0 -cursor_watch .dw +cursor_clock catch { - pg_select $dbc "select proowner,count(*) from pg_proc group by proowner" rec { + wpg_select $dbc "select proowner,count(*) from pg_proc group by proowner" rec { if {$rec(count)>$maxim} { set maxim $rec(count) set pgid $rec(proowner) @@ -206,11 +268,11 @@ catch { } .dw.lb delete 0 end catch { - pg_select $dbc "select proname from pg_proc where prolang=14 and proowner<>$pgid order by proname" rec { + wpg_select $dbc "select proname from pg_proc where prolang=14 and proowner<>$pgid order by proname" rec { .dw.lb insert end $rec(proname) } } -cursor_arrow .dw +cursor_normal } } @@ -240,43 +302,43 @@ proc {cmd_New} {} { global dbc activetab queryname queryoid cbv funcpar funcname funcret rbvar if {$dbc==""} return; switch $activetab { - Tables { + Tables { Window show .nt focus .nt.etabn - } - Queries { + } + Queries { Window show .qb set queryoid 0 set queryname {} - set cbv 0 + set cbv 0 .qb.cbv configure -state normal - } - Views { + } + Views { set queryoid 0 set queryname {} - Window show .qb - set cbv 1 - .qb.cbv configure -state disabled - } - Sequences { + Window show .qb + set cbv 1 + .qb.cbv configure -state disabled + } + Sequences { Window show .sqf focus .sqf.e1 - } - Reports { + } + Reports { Window show .rb ; tkwait visibility .rb ; rb_init ; set rbvar(reportname) {} ; set rbvar(justpreview) 0 focus .rb.e2 - } - Forms { - Window show .fd - Window show .fdtb - Window show .fdmenu - Window show .fda - fd_init - } - Scripts { + } + Forms { + Window show .fd + Window show .fdtb + Window show .fdmenu + Window show .fda + fd_init + } + Scripts { design_script {} - } - Functions { + } + Functions { Window show .fw set funcname {} set funcpar {} @@ -286,7 +348,7 @@ switch $activetab { .fw.okbtn configure -text Define .fw.text1 delete 1.0 end focus .fw.e1 - } + } } } @@ -296,14 +358,14 @@ if {$dbc==""} return; set objname [get_dwlb_Selection] if {$objname==""} return; switch $activetab { - 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} - Reports {open_report $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} + Reports {open_report $objname} } } @@ -315,9 +377,9 @@ proc {cmd_Queries} {} { global dbc .dw.lb delete 0 end catch { - pg_select $dbc "select * from pga_queries order by queryname" rec { - .dw.lb insert end $rec(queryname) - } + wpg_select $dbc "select * from pga_queries order by queryname" rec { + .dw.lb insert end $rec(queryname) + } } } @@ -338,83 +400,90 @@ Window show .rf proc {cmd_Reports} {} { global dbc -cursor_watch .dw +cursor_clock catch { - pg_select $dbc "select * from pga_reports order by reportname" rec { + wpg_select $dbc "select * from pga_reports order by reportname" rec { .dw.lb insert end "$rec(reportname)" - } + } } -cursor_arrow .dw +cursor_normal } proc {cmd_Scripts} {} { global dbc -cursor_watch .dw +cursor_clock .dw.lb delete 0 end catch { - pg_select $dbc "select * from pga_scripts order by scriptname" rec { + wpg_select $dbc "select * from pga_scripts order by scriptname" rec { .dw.lb insert end $rec(scriptname) - } + } } -cursor_arrow .dw +cursor_normal } proc {cmd_Sequences} {} { global dbc -cursor_watch .dw +cursor_clock .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) - } + wpg_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 +cursor_normal } proc {cmd_Tables} {} { global dbc -cursor_watch .dw +cursor_clock .dw.lb delete 0 end foreach tbl [get_tables] {.dw.lb insert end $tbl} -cursor_arrow .dw +cursor_normal } proc {cmd_Views} {} { global dbc -cursor_watch .dw +cursor_clock .dw.lb delete 0 end catch { - pg_select $dbc "select * from pg_class where (relname !~ '^pg_') and (relkind='r') and (relhasrules) order by relname" rec { - .dw.lb insert end $rec(relname) - } + wpg_select $dbc "select * from pg_class where (relname !~ '^pg_') and (relkind='r') and (relhasrules) order by relname" rec { + .dw.lb insert end $rec(relname) + } } -cursor_arrow .dw +cursor_normal } -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 {create_drop_down} {base x y w} { +if {[winfo exists $base.ddf]} { + return +} +frame $base.ddf -borderwidth 1 -height 75 -relief raised -width 55 +listbox $base.ddf.lb -background #fefefe -borderwidth 1 -font -*-Clean-medium-R-Normal--*-130-*-*-*-*-*-* -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 $w -height 185 -anchor nw -bordermode ignore +place $base.ddf.lb -x 1 -y 1 -width [expr $w-18] -height 182 -anchor nw -bordermode ignore +place $base.ddf.sb -x [expr $w-15] -y 1 -width 14 -height 183 -anchor nw -bordermode ignore } -proc {cursor_arrow} {w} { -$w configure -cursor top_left_arrow -update idletasks +proc {cursor_normal} {} { + foreach wn [winfo children .] { + catch {$wn configure -cursor top_left_arrow} + } + update ; update idletasks } -proc {cursor_watch} {w} { -$w configure -cursor watch -update idletasks +proc {cursor_clock} {} { + foreach wn [winfo children .] { + catch {$wn configure -cursor watch} + } + update ; update idletasks } proc {delete_function} {objname} { global dbc -pg_select $dbc "select * from pg_proc where proname='$objname'" rec { +wpg_select $dbc "select * from pg_proc where proname='$objname'" rec { set funcpar $rec(proargtypes) set nrpar $rec(pronargs) } @@ -432,8 +501,8 @@ 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) +wpg_select $dbc "select * from pga_scripts where scriptname='$sname'" rec { + .sw.src insert end $rec(scriptsource) } } @@ -441,13 +510,13 @@ proc {drag_it} {w x y} { global draglocation set dlo "" catch { set dlo $draglocation(obj) } - if {$dlo != ""} { - set dx [expr $x - $draglocation(x)] - set dy [expr $y - $draglocation(y)] - $w move $dlo $dx $dy - set draglocation(x) $x - set draglocation(y) $y - } + if {$dlo != ""} { + set dx [expr $x - $draglocation(x)] + set dy [expr $y - $draglocation(y)] + $w move $dlo $dx $dy + set draglocation(x) $x + set draglocation(y) $y + } } proc {drag_start} {w x y} { @@ -466,56 +535,56 @@ proc {drag_stop} {w x y} { global draglocation mw dbc set dlo "" catch { set dlo $draglocation(obj) } - if {$dlo != ""} { + if {$dlo != ""} { .mw.c bind movable {.mw configure -cursor top_left_arrow} .mw configure -cursor top_left_arrow - set ctr [get_tag_info $draglocation(obj) v] - set diff [expr $x-$draglocation(start)] - if {$diff==0} return; - set newcw {} - for {set i 0} {$i<$mw(colcount)} {incr i} { - if {$i==$ctr} { - lappend newcw [expr [lindex $mw(colwidth) $i]+$diff] - } else { - lappend newcw [lindex $mw(colwidth) $i] - } - } - set mw(colwidth) $newcw + set ctr [get_tag_info $draglocation(obj) v] + set diff [expr $x-$draglocation(start)] + if {$diff==0} return; + set newcw {} + for {set i 0} {$i<$mw(colcount)} {incr i} { + if {$i==$ctr} { + lappend newcw [expr [lindex $mw(colwidth) $i]+$diff] + } else { + lappend newcw [lindex $mw(colwidth) $i] + } + } + set mw(colwidth) $newcw .mw.c itemconfigure c$ctr -width [expr [lindex $mw(colwidth) $ctr]-5] - mw_draw_headers + mw_draw_headers mw_draw_hgrid if {$mw(crtrow)!=""} {mw_show_record $mw(crtrow)} - for {set i [expr $ctr+1]} {$i<$mw(colcount)} {incr i} { - .mw.c move c$i $diff 0 - } - cursor_watch .mw - sql_exec quiet "update pga_layout set colwidth='$mw(colwidth)' where tablename='$mw(layout_name)'" - cursor_arrow .mw - } + for {set i [expr $ctr+1]} {$i<$mw(colcount)} {incr i} { + .mw.c move c$i $diff 0 + } + cursor_clock + sql_exec quiet "update pga_layout set colwidth='$mw(colwidth)' where tablename='$mw(layout_name)'" + cursor_normal + } } 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 + 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) + set ss {} + wpg_select $dbc "select * from pga_scripts where scriptname='$scriptname'" rec { + set ss $rec(scriptsource) + } + if {[string length $ss] > 0} { + eval $ss } -# if {[string length $ss] > 0} { - eval $ss -# } } proc {fd_change_coord} {} { @@ -558,52 +627,52 @@ set c $fdobj($i,c) foreach {x1 y1 x2 y2} $c {} .fd.c delete o$i switch $fdobj($i,t) { - button { - fd_draw_rectangle $x1 $y1 $x2 $y2 raised #a0a0a0 o$i - .fd.c create text [expr ($x1+$x2)/2] [expr ($y1+$y2)/2] -text $fdobj($i,l) -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags o$i - } - entry { - fd_draw_rectangle $x1 $y1 $x2 $y2 sunken white o$i - } - label { - .fd.c create text $x1 $y1 -text $fdobj($i,l) -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -anchor nw -tags o$i - } - checkbox { - fd_draw_rectangle [expr $x1+2] [expr $y1+5] [expr $x1+12] [expr $y1+15] raised #a0a0a0 o$i - .fd.c create text [expr $x1+20] [expr $y1+3] -text $fdobj($i,l) -anchor nw -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags o$i - } - radio { - .fd.c create oval [expr $x1+4] [expr $y1+5] [expr $x1+14] [expr $y1+15] -fill white -tags o$i - .fd.c create text [expr $x1+24] [expr $y1+3] -text $fdobj($i,l) -anchor nw -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags o$i - } - query { - .fd.c create oval $x1 $y1 [expr $x1+20] [expr $y1+20] -fill white -tags o$i - .fd.c create text [expr $x1+5] [expr $y1+4] -text Q -anchor nw -font -Adobe-Helvetica-Bold-R-Normal-*-*-120-*-*-*-*-* -tags o$i - } - listbox { - fd_draw_rectangle $x1 $y1 [expr $x2-12] $y2 sunken white o$i - fd_draw_rectangle [expr $x2-11] $y1 $x2 $y2 sunken gray o$i - .fd.c create line [expr $x2-5] $y1 $x2 [expr $y1+10] -fill #808080 -tags o$i - .fd.c create line [expr $x2-10] [expr $y1+9] $x2 [expr $y1+9] -fill #808080 -tags o$i - .fd.c create line [expr $x2-10] [expr $y1+9] [expr $x2-5] $y1 -fill white -tags o$i - .fd.c create line [expr $x2-5] $y2 $x2 [expr $y2-10] -fill #808080 -tags o$i - .fd.c create line [expr $x2-10] [expr $y2-9] $x2 [expr $y2-9] -fill white -tags o$i - .fd.c create line [expr $x2-10] [expr $y2-9] [expr $x2-5] $y2 -fill white -tags o$i - } + button { + fd_draw_rectangle $x1 $y1 $x2 $y2 raised #a0a0a0 o$i + .fd.c create text [expr ($x1+$x2)/2] [expr ($y1+$y2)/2] -text $fdobj($i,l) -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags o$i + } + entry { + fd_draw_rectangle $x1 $y1 $x2 $y2 sunken white o$i + } + label { + .fd.c create text $x1 $y1 -text $fdobj($i,l) -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -anchor nw -tags o$i + } + checkbox { + fd_draw_rectangle [expr $x1+2] [expr $y1+5] [expr $x1+12] [expr $y1+15] raised #a0a0a0 o$i + .fd.c create text [expr $x1+20] [expr $y1+3] -text $fdobj($i,l) -anchor nw -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags o$i + } + radio { + .fd.c create oval [expr $x1+4] [expr $y1+5] [expr $x1+14] [expr $y1+15] -fill white -tags o$i + .fd.c create text [expr $x1+24] [expr $y1+3] -text $fdobj($i,l) -anchor nw -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags o$i + } + query { + .fd.c create oval $x1 $y1 [expr $x1+20] [expr $y1+20] -fill white -tags o$i + .fd.c create text [expr $x1+5] [expr $y1+4] -text Q -anchor nw -font -Adobe-Helvetica-Bold-R-Normal-*-*-120-*-*-*-*-* -tags o$i + } + listbox { + fd_draw_rectangle $x1 $y1 [expr $x2-12] $y2 sunken white o$i + fd_draw_rectangle [expr $x2-11] $y1 $x2 $y2 sunken gray o$i + .fd.c create line [expr $x2-5] $y1 $x2 [expr $y1+10] -fill #808080 -tags o$i + .fd.c create line [expr $x2-10] [expr $y1+9] $x2 [expr $y1+9] -fill #808080 -tags o$i + .fd.c create line [expr $x2-10] [expr $y1+9] [expr $x2-5] $y1 -fill white -tags o$i + .fd.c create line [expr $x2-5] $y2 $x2 [expr $y2-10] -fill #808080 -tags o$i + .fd.c create line [expr $x2-10] [expr $y2-9] $x2 [expr $y2-9] -fill white -tags o$i + .fd.c create line [expr $x2-10] [expr $y2-9] [expr $x2-5] $y2 -fill white -tags o$i + } } .fd.c raise hook } proc {fd_draw_rectangle} {x1 y1 x2 y2 relief color tag} { if {$relief=="raised"} { - set c1 white - set c2 #606060 + set c1 white + set c2 #606060 } else { - set c1 #606060 - set c2 white + set c1 #606060 + set c2 white } if {$color != "none"} { - .fd.c create rectangle $x1 $y1 $x2 $y2 -outline "" -fill $color -tags $tag + .fd.c create rectangle $x1 $y1 $x2 $y2 -outline "" -fill $color -tags $tag } .fd.c create line $x1 $y1 $x2 $y1 -fill $c1 -tags $tag .fd.c create line $x1 $y1 $x1 $y2 -fill $c1 -tags $tag @@ -655,7 +724,7 @@ if {$mode=="design"} { #set fid [open "$name.form" r] #set info [gets $fid] #close $fid -set res [pg_exec $dbc "select * from pga_forms where formname='$fdvar(formname)'"] +set res [wpg_exec $dbc "select * from pga_forms where formname='$fdvar(formname)'"] set info [lindex [pg_result $res -getTuple 0] 1] pg_result $res -clear set fdvar(forminame) [lindex $info 0] @@ -664,16 +733,16 @@ set fdvar(objlist) [lindex $info 2] set fdvar(geometry) [lindex $info 3] set j 0 foreach objinfo [lrange $info 4 end] { - foreach {t n c x l v} $objinfo {} - set i [lindex $fdvar(objlist) $j] - set fdobj($i,t) $t - set fdobj($i,n) $n - set fdobj($i,c) $c - set fdobj($i,l) $l - set fdobj($i,x) $x - set fdobj($i,v) $v - if {$mode=="design"} {fd_draw_object $i} - incr j + foreach {t n c x l v} $objinfo {} + set i [lindex $fdvar(objlist) $j] + set fdobj($i,t) $t + set fdobj($i,n) $n + set fdobj($i,c) $c + set fdobj($i,l) $l + set fdobj($i,x) $x + set fdobj($i,v) $v + if {$mode=="design"} {fd_draw_object $i} + incr j } if {$mode=="design"} {wm geometry .fd $fdvar(geometry)} } @@ -685,8 +754,8 @@ set y [expr 3*int($y/3)] set fdvar(xstart) $x set fdvar(ystart) $y if {$fdvar(tool)=="point"} { - fd_item_click $x $y - return + fd_item_click $x $y + return } set fdvar(oper) draw } @@ -699,17 +768,17 @@ set y [expr 3*int($y/3)] set oper "" catch {set oper $fdvar(oper)} if {$oper=="draw"} { - catch {.fd.c delete curdraw} - .fd.c create rectangle $fdvar(xstart) $fdvar(ystart) $x $y -tags curdraw - return + catch {.fd.c delete curdraw} + .fd.c create rectangle $fdvar(xstart) $fdvar(ystart) $x $y -tags curdraw + return } if {$oper=="move"} { - set dx [expr $x-$fdvar(moveitemx)] - set dy [expr $y-$fdvar(moveitemy)] - .fd.c move o$fdvar(moveitemobj) $dx $dy - .fd.c move hook $dx $dy - set fdvar(moveitemx) $x - set fdvar(moveitemy) $y + set dx [expr $x-$fdvar(moveitemx)] + set dy [expr $y-$fdvar(moveitemy)] + .fd.c move o$fdvar(moveitemobj) $dx $dy + .fd.c move hook $dx $dy + set fdvar(moveitemx) $x + set fdvar(moveitemy) $y } } @@ -718,16 +787,16 @@ global fdvar fdobj set x [expr 3*int($x/3)] set y [expr 3*int($y/3)] if {$fdvar(oper)=="move"} { - set fdvar(moveitem) {} - set fdvar(oper) none - set oc $fdobj($fdvar(moveitemobj),c) - set dx [expr $x - $fdvar(xstart)] - set dy [expr $y - $fdvar(ystart)] - set newcoord [list [expr $dx+[lindex $oc 0]] [expr $dy+[lindex $oc 1]] [expr $dx+[lindex $oc 2]] [expr $dy+[lindex $oc 3]]] - set fdobj($fdvar(moveitemobj),c) $newcoord - fd_show_attributes $fdvar(moveitemobj) - fd_draw_hookers $fdvar(moveitemobj) - return + set fdvar(moveitem) {} + set fdvar(oper) none + set oc $fdobj($fdvar(moveitemobj),c) + set dx [expr $x - $fdvar(xstart)] + set dy [expr $y - $fdvar(ystart)] + set newcoord [list [expr $dx+[lindex $oc 0]] [expr $dy+[lindex $oc 1]] [expr $dx+[lindex $oc 2]] [expr $dy+[lindex $oc 3]]] + set fdobj($fdvar(moveitemobj),c) $newcoord + fd_show_attributes $fdvar(moveitemobj) + fd_draw_hookers $fdvar(moveitemobj) + return } if {$fdvar(oper)!="draw"} return set fdvar(oper) none @@ -759,25 +828,20 @@ proc {fd_save_form} {name} { global fdvar fdobj dbc if {[tk_messageBox -title Warning -message "Do you want to save the form into the database ?" -type yesno -default yes]=="no"} {return 1} if {[string length $fdvar(forminame)]==0} { - tk_messageBox -title Warning -message "Forms need an internal name, only literals, low case" - return 0 + tk_messageBox -title Warning -message "Forms need an internal name, only literals, low case" + return 0 } if {[string length $fdvar(formname)]==0} { tk_messageBox -title Warning -message "Form must have a name" return 0 } -#set fid [open "$name.form" w] set info [list $fdvar(forminame) $fdvar(objnum) $fdvar(objlist) [wm geometry .fd]] foreach i $fdvar(objlist) { - lappend info [list $fdobj($i,t) $fdobj($i,n) $fdobj($i,c) $fdobj($i,x) $fdobj($i,l) $fdobj($i,v)] + lappend info [list $fdobj($i,t) $fdobj($i,n) $fdobj($i,c) $fdobj($i,x) $fdobj($i,l) $fdobj($i,v)] } -#puts $fid $info -#close $fid -set res [pg_exec $dbc "delete from pga_forms where formname='$fdvar(formname)'"] -pg_result $res -clear +sql_exec noquiet "delete from pga_forms where formname='$fdvar(formname)'" regsub -all "'" $info "''" info -set res [pg_exec $dbc "insert into pga_forms values ('$fdvar(formname)','$info')"] -pg_result $res -clear +sql_exec noquiet "insert into pga_forms values ('$fdvar(formname)','$info')" cmd_Forms return 1 } @@ -792,10 +856,10 @@ proc {fd_set_name} {} { global fdvar fdobj set i $fdvar(moveitemobj) foreach k $fdvar(objlist) { - if {($fdobj($k,n)==$fdvar(c_name)) && ($i!=$k)} { - tk_messageBox -title Warning -message "There is another object (a $fdobj($k,t)) with the same name. Please change it!" - return - } + if {($fdobj($k,n)==$fdvar(c_name)) && ($i!=$k)} { + tk_messageBox -title Warning -message "There is another object (a $fdobj($k,t)) with the same name. Please change it!" + return + } } set fdobj($i,n) $fdvar(c_name) fd_show_attributes $i @@ -846,106 +910,106 @@ set name $fdobj($item,n) set wh "-width [expr 3+[lindex $coord 2]-[lindex $coord 0]] -height [expr 3+[lindex $coord 3]-[lindex $coord 1]]" set visual 1 switch $fdobj($item,t) { - button { - set cmd {} - catch {set cmd $fdobj($item,x)} - button $base.$name -borderwidth 1 -padx 0 -pady 0 -text "$fdobj($item,l)" -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -command [subst {$cmd}] - } - checkbox { - checkbutton $base.$name -onvalue t -offvalue f -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -text "$fdobj($item,l)" -variable "$fdobj($item,v)" -borderwidth 1 - set wh {} - } - query { - set visual 0 + button { + set cmd {} + catch {set cmd $fdobj($item,x)} + button $base.$name -borderwidth 1 -padx 0 -pady 0 -text "$fdobj($item,l)" -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -command [subst {$cmd}] + } + checkbox { + checkbutton $base.$name -onvalue t -offvalue f -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -text "$fdobj($item,l)" -variable "$fdobj($item,v)" -borderwidth 1 + set wh {} + } + query { + set visual 0 set datasets($base.$name,sql) $fdobj($item,x) - eval "proc $base.$name:open {} {\ - global dbc datasets tup$basewp$name ;\ - catch {unset tup$basewp$name} ;\ - set wn \[focus\] ; cursor_watch \$wn ;\ - set res \[pg_exec \$dbc \"\$datasets($base.$name,sql)\"\] ;\ - pg_result \$res -assign tup$basewp$name ;\ - set fl {} ;\ - foreach fd \[pg_result \$res -lAttributes\] {lappend fl \[lindex \$fd 0\]} ;\ - set datasets($base.$name,fields) \$fl ;\ - set datasets($base.$name,recno) 0 ;\ - set datasets($base.$name,nrecs) \[pg_result \$res -numTuples\] ;\ - cursor_arrow \$wn ;\ - }" - eval "proc $base.$name:setsql {sqlcmd} {\ - global datasets ;\ - set datasets($base.$name,sql) \$sqlcmd ;\ - }" - eval "proc $base.$name:nrecords {} {\ - global datasets ;\ - return \$datasets($base.$name,nrecs) ;\ - }" - eval "proc $base.$name:crtrecord {} {\ - global datasets ;\ - return \$datasets($base.$name,recno) ;\ - }" - eval "proc $base.$name:moveto {newrecno} {\ - global datasets ;\ - set datasets($base.$name,recno) \$newrecno ;\ - }" - eval "proc $base.$name:close {} { - global tup$basewp$name ;\ - catch {unset tup$basewp$name };\ - }" - eval "proc $base.$name:fields {} {\ - global datasets ;\ - return \$datasets($base.$name,fields) ;\ - }" - eval "proc $base.$name:fill {lb fld} {\ - global datasets tup$basewp$name ;\ - \$lb delete 0 end ;\ - for {set i 0} {\$i<\$datasets($base.$name,nrecs)} {incr i} {\ - \$lb insert end \$tup$basewp$name\(\$i,\$fld\) ;\ - } - }" - eval "proc $base.$name:movefirst {} {global datasets ; set datasets($base.$name,recno) 0}" - eval "proc $base.$name:movenext {} {global datasets ; incr datasets($base.$name,recno) ; if {\$datasets($base.$name,recno)==\[$base.$name:nrecords\]} {$base.$name:movelast}}" - eval "proc $base.$name:moveprevious {} {global datasets ; incr datasets($base.$name,recno) -1 ; if {\$datasets($base.$name,recno)==-1} {$base.$name:movefirst}}" - eval "proc $base.$name:movelast {} {global datasets ; set datasets($base.$name,recno) \[expr \[$base.$name:nrecords\] -1\]}" - eval "proc $base.$name:updatecontrols {} {\ - global datasets tup$basewp$name ;\ - set i \$datasets($base.$name,recno) ;\ - foreach fld \$datasets($base.$name,fields) {\ - catch {\ - upvar $basewp$name\(\$fld\) dbvar ;\ - set dbvar \$tup$basewp$name\(\$i,\$fld\) ;\ - }\ - }\ - }" - eval "proc $base.$name:clearcontrols {} {\ - global datasets ;\ - catch { foreach fld \$datasets($base.$name,fields) {\ - catch {\ - upvar $basewp$name\(\$fld\) dbvar ;\ - set dbvar {} ;\ - }\ - }}\ - }" - } - radio { - radiobutton $base.$name -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -text "$fdobj($item,l)" -variable "$fdobj($item,v)" -value "$name" -borderwidth 1 - set wh {} - } - entry { - set var {} ; catch {set var $fdobj($item,v)} - entry $base.$name -bo 1 -ba white -selectborderwidth 0 -highlightthickness 0 - if {$var!=""} {$base.$name configure -textvar $var} - } - label { - set wh {} - label $base.$name -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -anchor nw -padx 0 -pady 0 -text $fdobj($item,l) + eval "proc $base.$name:open {} {\ + global dbc datasets tup$basewp$name ;\ + catch {unset tup$basewp$name} ;\ + set wn \[focus\] ; cursor_clock ;\ + set res \[wpg_exec \$dbc \"\$datasets($base.$name,sql)\"\] ;\ + pg_result \$res -assign tup$basewp$name ;\ + set fl {} ;\ + foreach fd \[pg_result \$res -lAttributes\] {lappend fl \[lindex \$fd 0\]} ;\ + set datasets($base.$name,fields) \$fl ;\ + set datasets($base.$name,recno) 0 ;\ + set datasets($base.$name,nrecs) \[pg_result \$res -numTuples\] ;\ + cursor_normal ;\ + }" + eval "proc $base.$name:setsql {sqlcmd} {\ + global datasets ;\ + set datasets($base.$name,sql) \$sqlcmd ;\ + }" + eval "proc $base.$name:nrecords {} {\ + global datasets ;\ + return \$datasets($base.$name,nrecs) ;\ + }" + eval "proc $base.$name:crtrecord {} {\ + global datasets ;\ + return \$datasets($base.$name,recno) ;\ + }" + eval "proc $base.$name:moveto {newrecno} {\ + global datasets ;\ + set datasets($base.$name,recno) \$newrecno ;\ + }" + eval "proc $base.$name:close {} { + global tup$basewp$name ;\ + catch {unset tup$basewp$name };\ + }" + eval "proc $base.$name:fields {} {\ + global datasets ;\ + return \$datasets($base.$name,fields) ;\ + }" + eval "proc $base.$name:fill {lb fld} {\ + global datasets tup$basewp$name ;\ + \$lb delete 0 end ;\ + for {set i 0} {\$i<\$datasets($base.$name,nrecs)} {incr i} {\ + \$lb insert end \$tup$basewp$name\(\$i,\$fld\) ;\ + } + }" + eval "proc $base.$name:movefirst {} {global datasets ; set datasets($base.$name,recno) 0}" + eval "proc $base.$name:movenext {} {global datasets ; incr datasets($base.$name,recno) ; if {\$datasets($base.$name,recno)==\[$base.$name:nrecords\]} {$base.$name:movelast}}" + eval "proc $base.$name:moveprevious {} {global datasets ; incr datasets($base.$name,recno) -1 ; if {\$datasets($base.$name,recno)==-1} {$base.$name:movefirst}}" + eval "proc $base.$name:movelast {} {global datasets ; set datasets($base.$name,recno) \[expr \[$base.$name:nrecords\] -1\]}" + eval "proc $base.$name:updatecontrols {} {\ + global datasets tup$basewp$name ;\ + set i \$datasets($base.$name,recno) ;\ + foreach fld \$datasets($base.$name,fields) {\ + catch {\ + upvar $basewp$name\(\$fld\) dbvar ;\ + set dbvar \$tup$basewp$name\(\$i,\$fld\) ;\ + }\ + }\ + }" + eval "proc $base.$name:clearcontrols {} {\ + global datasets ;\ + catch { foreach fld \$datasets($base.$name,fields) {\ + catch {\ + upvar $basewp$name\(\$fld\) dbvar ;\ + set dbvar {} ;\ + }\ + }}\ + }" + } + radio { + radiobutton $base.$name -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -text "$fdobj($item,l)" -variable "$fdobj($item,v)" -value "$name" -borderwidth 1 + set wh {} + } + entry { + set var {} ; catch {set var $fdobj($item,v)} + entry $base.$name -bo 1 -ba white -selectborderwidth 0 -highlightthickness 0 + if {$var!=""} {$base.$name configure -textvar $var} + } + label { + set wh {} + label $base.$name -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -anchor nw -padx 0 -pady 0 -text $fdobj($item,l) set var {} ; catch {set var $fdobj($item,v)} if {$var!=""} {$base.$name configure -textvar $var} - } - listbox { - listbox $base.$name -borderwidth 1 -background white -highlightthickness 0 -selectborderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -yscrollcommand [subst {$base.sb$name set}] + } + listbox { + listbox $base.$name -borderwidth 1 -background white -highlightthickness 0 -selectborderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -yscrollcommand [subst {$base.sb$name set}] scrollbar $base.sb$name -borderwidth 1 -command [subst {$base.$name yview}] -orient vert -highlightthickness 0 eval [subst "place $base.sb$name -x [expr [lindex $coord 2]-14] -y [expr [lindex $coord 1]-1] -width 16 -height [expr 3+[lindex $coord 3]-[lindex $coord 1]] -anchor nw -bordermode ignore"] - } + } } if $visual {eval [subst "place $base.$name -x [expr [lindex $coord 0]-1] -y [expr [lindex $coord 1]-1] -anchor nw $wh -bordermode ignore"]} } @@ -962,7 +1026,7 @@ 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 { +wpg_select $dbc "select typname from pg_type where oid=$oid" rec { set temp $rec(typname) } return $temp @@ -972,9 +1036,9 @@ 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)} - } + wpg_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 } @@ -999,11 +1063,11 @@ if {$retval} { set pref(username) {} set pref(password) {} } else { - while {![eof $fid]} { - set pair [gets $fid] - set pref([lindex $pair 0]) [lindex $pair 1] - } - close $fid + while {![eof $fid]} { + set pair [gets $fid] + set pref([lindex $pair 0]) [lindex $pair 1] + } + close $fid } } @@ -1028,16 +1092,16 @@ if {$mw(errorsavingnew)} return set posx [expr -$mw(leftoffset)] set col 0 foreach cw $mw(colwidth) { - incr posx [expr $cw+2] - if {$x<$posx} break - incr col + 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 - } + if {[get_tag_info $item c]==$col} { + mw_start_edit $item $x $y + break + } } } @@ -1061,14 +1125,14 @@ global mw .mw.c delete header set posx [expr 5-$mw(leftoffset)] for {set i 0} {$i<$mw(colcount)} {incr i} { - set xf [expr $posx+[lindex $mw(colwidth) $i]] - .mw.c create rectangle $posx 1 $xf 22 -fill #CCCCCC -outline "" -width 0 -tags header - .mw.c create text [expr $posx+[lindex $mw(colwidth) $i]*1.0/2] 14 -text [lindex $mw(colnames) $i] -tags header -fill navy -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* - .mw.c create line $posx 22 [expr $xf-1] 22 -fill #AAAAAA -tags header - .mw.c create line [expr $xf-1] 5 [expr $xf-1] 22 -fill #AAAAAA -tags header - .mw.c create line [expr $xf+1] 5 [expr $xf+1] 22 -fill white -tags header - .mw.c create line $xf -15000 $xf 15000 -fill #CCCCCC -tags [subst {header movable v$i}] - set posx [expr $xf+2] + set xf [expr $posx+[lindex $mw(colwidth) $i]] + .mw.c create rectangle $posx 1 $xf 22 -fill #CCCCCC -outline "" -width 0 -tags header + .mw.c create text [expr $posx+[lindex $mw(colwidth) $i]*1.0/2] 14 -text [lindex $mw(colnames) $i] -tags header -fill navy -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* + .mw.c create line $posx 22 [expr $xf-1] 22 -fill #AAAAAA -tags header + .mw.c create line [expr $xf-1] 5 [expr $xf-1] 22 -fill #AAAAAA -tags header + .mw.c create line [expr $xf+1] 5 [expr $xf+1] 22 -fill white -tags header + .mw.c create line $xf -15000 $xf 15000 -fill #CCCCCC -tags [subst {header movable v$i}] + set posx [expr $xf+2] } set mw(r_edge) $posx .mw.c bind movable {drag_start %W %x %y} @@ -1103,14 +1167,14 @@ global mw pref msg set posx 10 set posy [lindex $mw(rowy) $mw(last_rownum)] if {$pref(tvfont)=="helv"} { - set tvfont -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* + set tvfont -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* } else { - set tvfont -*-Clean-Medium-R-Normal-*-*-130-*-*-*-*-* + set tvfont -*-Clean-Medium-R-Normal-*-*-130-*-*-*-*-* } if {$mw(updatable)} { for {set j 0} {$j<$mw(colcount)} {incr j} { - .mw.c create text $posx $posy -text * -tags [subst {r$mw(nrecs) c$j q new unt}] -anchor nw -font $tvfont -width [expr [lindex $mw(colwidth) $j]-5] - incr posx [expr [lindex $mw(colwidth) $j]+2] + .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 .mw.c create line [expr -$mw(leftoffset)] $posy [expr $mw(r_edge)-$mw(leftoffset)] $posy -fill gray -tags [subst {hgrid g$mw(nrecs)}] @@ -1121,15 +1185,15 @@ proc {mw_edit_text} {c k} { global mw msg set bbin [.mw.c bbox r$mw(row_edited)] switch $k { - BackSpace { set dp [expr [.mw.c index $mw(id_edited) insert]-1];if {$dp>=0} {.mw.c dchars $mw(id_edited) $dp $dp; set mw(dirtyrec) 1}} - Home {.mw.c icursor $mw(id_edited) 0} - End {.mw.c icursor $mw(id_edited) end} - Left {.mw.c icursor $mw(id_edited) [expr [.mw.c index $mw(id_edited) insert]-1]} - Delete {} - Right {.mw.c icursor $mw(id_edited) [expr [.mw.c index $mw(id_edited) insert]+1]} - Return {if {[mw_exit_edit]} {.mw.c focus {}}} - Escape {set mw(dirtyrec) 0; .mw.c itemconfigure $mw(id_edited) -text $mw(text_initial_value); .mw.c focus {}} - default {if {[string compare $c " "]>-1} {.mw.c insert $mw(id_edited) insert $c;set mw(dirtyrec) 1}} + BackSpace { set dp [expr [.mw.c index $mw(id_edited) insert]-1];if {$dp>=0} {.mw.c dchars $mw(id_edited) $dp $dp; set mw(dirtyrec) 1}} + Home {.mw.c icursor $mw(id_edited) 0} + End {.mw.c icursor $mw(id_edited) end} + Left {.mw.c icursor $mw(id_edited) [expr [.mw.c index $mw(id_edited) insert]-1]} + Delete {} + Right {.mw.c icursor $mw(id_edited) [expr [.mw.c index $mw(id_edited) insert]+1]} + Return {if {[mw_exit_edit]} {.mw.c focus {}}} + Escape {set mw(dirtyrec) 0; .mw.c itemconfigure $mw(id_edited) -text $mw(text_initial_value); .mw.c focus {}} + default {if {[string compare $c " "]>-1} {.mw.c insert $mw(id_edited) insert $c;set mw(dirtyrec) 1}} } set bbout [.mw.c bbox r$mw(row_edited)] set dy [expr [lindex $bbout 3]-[lindex $bbin 3]] @@ -1153,53 +1217,53 @@ global mw dbc msg tablename # User has edited the text ? if {!$mw(dirtyrec)} { # No, unfocus text - .mw.c focus {} - # For restoring * to the new record position + .mw.c focus {} + # For restoring * to the new record position if {$mw(id_edited)!=""} { - if {[lsearch [.mw.c gettags $mw(id_edited)] new]!=-1} { - .mw.c itemconfigure $mw(id_edited) -text $mw(text_initial_value) - } + if {[lsearch [.mw.c gettags $mw(id_edited)] new]!=-1} { + .mw.c itemconfigure $mw(id_edited) -text $mw(text_initial_value) + } } - set mw(id_edited) {};set mw(text_initial_value) {} - return 1 + set mw(id_edited) {};set mw(text_initial_value) {} + return 1 } # Trimming the spaces set fldval [string trim [.mw.c itemcget $mw(id_edited) -text]] .mw.c itemconfigure $mw(id_edited) -text $fldval if {[string compare $mw(text_initial_value) $fldval]==0} { - set mw(dirtyrec) 0 - .mw.c focus {} - set mw(id_edited) {};set mw(text_initial_value) {} - return 1 + set mw(dirtyrec) 0 + .mw.c focus {} + set mw(id_edited) {};set mw(text_initial_value) {} + return 1 } -cursor_watch .mw +cursor_clock set oid [lindex $mw(keylist) $mw(row_edited)] set fld [lindex $mw(colnames) [get_tag_info $mw(id_edited) c]] set fillcolor black if {$mw(row_edited)==$mw(last_rownum)} { set fillcolor red - set sfp [lsearch $mw(newrec_fields) $fld] + set sfp [lsearch $mw(newrec_fields) "\"$fld\""] if {$sfp>-1} { set mw(newrec_fields) [lreplace $mw(newrec_fields) $sfp $sfp] set mw(newrec_values) [lreplace $mw(newrec_values) $sfp $sfp] } - lappend mw(newrec_fields) $fld + lappend mw(newrec_fields) "\"$fld\"" lappend mw(newrec_values) '$fldval' # Remove the untouched tag from the object .mw.c dtag $mw(id_edited) unt - .mw.c itemconfigure $mw(id_edited) -fill red + .mw.c itemconfigure $mw(id_edited) -fill red set retval 1 } else { - set msg "Updating record ..." - after 1000 {set msg ""} - regsub -all ' $fldval \\' sqlfldval - set retval [sql_exec noquiet "update \"$tablename\" set $fld='$sqlfldval' where oid=$oid"] + set msg "Updating record ..." + after 1000 {set msg ""} + regsub -all ' $fldval \\' sqlfldval + set retval [sql_exec noquiet "update \"$tablename\" set \"$fld\"='$sqlfldval' where oid=$oid"] } -cursor_arrow .mw +cursor_normal if {!$retval} { - set msg "" + set msg "" focus .mw.c - return 0 + return 0 } set mw(dirtyrec) 0 .mw.c focus {} @@ -1209,31 +1273,32 @@ return 1 proc {mw_load_layout} {tablename} { global dbc msg mw -cursor_watch .mw +cursor_clock set mw(layout_name) $tablename catch {unset mw(colcount) mw(colnames) mw(colwidth)} set mw(layout_found) 0 -set retval [catch {set pgres [pg_exec $dbc "select *,oid from pga_layout where tablename='$tablename' order by oid desc"]}] -if {$retval} { - # Probably table pga_layout isn't yet defined - sql_exec noquiet "create table pga_layout (tablename varchar(64),nrcols int2,colnames text,colwidth text)" +set pgres [wpg_exec $dbc "select *,oid from pga_layout where tablename='$tablename' order by oid desc"] +set pgs [pg_result $pgres -status] +if {$pgs!="PGRES_TUPLES_OK"} { + # Probably table pga_layout isn't yet defined + sql_exec noquiet "create table pga_layout (tablename varchar(64),nrcols int2,colnames text,colwidth text)" sql_exec quiet "grant ALL on pga_layout to PUBLIC" } else { set nrlay [pg_result $pgres -numTuples] - if {$nrlay>=1} { - set layoutinfo [pg_result $pgres -getTuple 0] - set mw(colcount) [lindex $layoutinfo 1] - set mw(colnames) [lindex $layoutinfo 2] - set mw(colwidth) [lindex $layoutinfo 3] + if {$nrlay>=1} { + set layoutinfo [pg_result $pgres -getTuple 0] + set mw(colcount) [lindex $layoutinfo 1] + set mw(colnames) [lindex $layoutinfo 2] + set mw(colwidth) [lindex $layoutinfo 3] set goodoid [lindex $layoutinfo 4] - set mw(layout_found) 1 - } - if {$nrlay>1} { - show_error "Multiple ([pg_result $pgres -numTuples]) layout info found\n\nPlease report the bug!" + set mw(layout_found) 1 + } + if {$nrlay>1} { + show_error "Multiple ($nrlay) layout info found\n\nPlease report the bug!" sql_exec quiet "delete from pga_layout where (tablename='$tablename') and (oid<>$goodoid)" - } + } } -catch {pg_result $pgres -clear} +pg_result $pgres -clear } proc {mw_pan_left} {} { @@ -1266,11 +1331,9 @@ 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} { +set pgres [wpg_exec $dbc "insert into \"$tablename\" ([join $mw(newrec_fields) ,]) values ([join $mw(newrec_values) ,])" ] +if {[pg_result $pgres -status]!="PGRES_COMMAND_OK"} { + set errmsg [pg_result $pgres -error] show_error "Error inserting new record\n\n$errmsg" return 0 } @@ -1299,16 +1362,16 @@ 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]} - } + 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))] + set newtop [expr int($par2*$mw(nrecs))] } if {$newtop<0} return; if {$newtop>=[expr $mw(nrecs)-1]} return; @@ -1323,7 +1386,7 @@ mw_set_scrollbar } proc {mw_select_records} {sql} { -global dbc field mw +global dbc field mw pgsql global tablename msg pref set mw(newrec_fields) {} set mw(newrec_values) {} @@ -1337,38 +1400,36 @@ 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] +cursor_clock +set is_error 1 +if {[sql_exec noquiet "BEGIN"]} { + if {[sql_exec noquiet "declare mycursor cursor for $sql"]} { + set pgres [wpg_exec $dbc "fetch $pref(rows) in mycursor"] + if {$pgsql(status)=="PGRES_TUPLES_OK"} { + set is_error 0 + } } } -#set retval [catch {set pgres [pg_exec $dbc $sql]} errmsg] -if {$retval} { +if {$is_error} { 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 + cursor_normal + 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 + 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)'" - } + 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] @@ -1377,13 +1438,13 @@ 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 + 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(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)} { @@ -1392,9 +1453,9 @@ if {$mw(nrecs)>$pref(rows)} { } set tagoid {} if {$pref(tvfont)=="helv"} { - set tvfont -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* + set tvfont -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* } else { - set tvfont -*-Clean-Medium-R-Normal-*-*-130-*-*-*-*-* + set tvfont -*-Clean-Medium-R-Normal-*-*-130-*-*-*-*-* } # Computing column's left edge set posx 10 @@ -1411,16 +1472,16 @@ 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} + 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} } after 3000 {set msg {} } set mw(last_rownum) $i @@ -1431,14 +1492,14 @@ sql_exec quiet "END" set mw(toprec) 0 mw_set_scrollbar if {$mw(updatable)} then { - .mw.c bind q {mw_edit_text %A %K} + .mw.c bind q {mw_edit_text %A %K} } else { .mw.c bind q {} } set mw(dirtyrec) 0 #mw_draw_headers .mw.c raise header -cursor_arrow .mw +cursor_normal } proc {mw_set_scrollbar} {} { @@ -1453,9 +1514,9 @@ set mw(errorsavingnew) 0 if {$mw(newrec_fields)!=""} { if {$row!=$mw(last_rownum)} { if {![mw_save_new_record]} { - set mw(errorsavingnew) 1 - return - } + set mw(errorsavingnew) 1 + return + } } } set y1 [lindex $mw(rowy) $row] @@ -1481,24 +1542,24 @@ focus .mw.c .mw.c focus $id .mw.c icursor $id @$x,$y if {$mw(row_edited)==$mw(nrecs)} { - if {[.mw.c itemcget $id -text]=="*"} { - .mw.c itemconfigure $id -text "" - .mw.c icursor $id 0 - } + if {[.mw.c itemcget $id -text]=="*"} { + .mw.c itemconfigure $id -text "" + .mw.c icursor $id 0 + } } } proc {open_database} {} { global dbc host pport dbname username password newusername newpassword sdbname newdbname newhost newpport pref -catch {cursor_watch .dbod} +cursor_clock if {$newusername!=""} { set connres [catch {set newdbc [pg_connect -conninfo "host=$newhost port=$newpport dbname=$newdbname user=$newusername password=$newpassword"]} msg] } else { set connres [catch {set newdbc [pg_connect $newdbname -host $newhost -port $newpport]} msg] } if {$connres} { - catch {cursor_arrow .dbod} - show_error "Error connecting database\n$msg" + cursor_normal + show_error "Error connecting database\n$msg" } else { catch {pg_disconnect $dbc} set dbc $newdbc @@ -1513,28 +1574,28 @@ if {$connres} { set pref(lastport) $pport set pref(lastusername) $username save_pref - catch {cursor_arrow .dbod; Window hide .dbod} + catch {cursor_normal ; Window hide .dbod} tab_click .dw.tabTables # 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 } - } - # searching for autoexec script - pg_select $dbc "select * from pga_scripts where scriptname ~* '^autoexec$'" recd { - eval $recd(scriptsource) - } + set pgres [wpg_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 } + } + # searching for autoexec script + wpg_select $dbc "select * from pga_scripts where scriptname ~* '^autoexec$'" recd { + eval $recd(scriptsource) + } } } proc {open_form} {formname} { - fd_load_form $formname run - fd_test + fd_load_form $formname run + fd_test } proc {open_function} {objname} { @@ -1543,7 +1604,7 @@ Window show .fw place .fw.okbtn -y 400 .fw.okbtn configure -state disabled .fw.text1 delete 1.0 end -pg_select $dbc "select * from pg_proc where proname='$objname'" rec { +wpg_select $dbc "select * from pg_proc where proname='$objname'" rec { set funcname $objname set temppar $rec(proargtypes) set funcret [get_pgtype $rec(prorettype)] @@ -1576,14 +1637,14 @@ global dbc queryname mw queryoid sortfield filter if {[.dw.lb curselection]==""} return; set queryname [.dw.lb get [.dw.lb curselection]] -if {[catch {set pgres [pg_exec $dbc "select querycommand,querytype,oid from pga_queries where queryname='$queryname'"]}]} then { - show_error "Error retrieving query definition" - return +if {[set pgres [wpg_exec $dbc "select querycommand,querytype,oid from pga_queries where queryname='$queryname'"]]==0} then { + show_error "Error retrieving query definition" + return } if {[pg_result $pgres -numTuples]==0} { - show_error "Query $queryname was not found!" - pg_result $pgres -clear - return + show_error "Query $queryname was not found!" + pg_result $pgres -clear + return } set tuple [pg_result $pgres -getTuple 0] set qcmd [lindex $tuple 0] @@ -1591,26 +1652,26 @@ set qtype [lindex $tuple 1] set queryoid [lindex $tuple 2] pg_result $pgres -clear if {$how=="design"} { - Window show .qb - .qb.text1 delete 0.0 end - .qb.text1 insert end $qcmd + Window show .qb + .qb.text1 delete 0.0 end + .qb.text1 insert end $qcmd } else { - if {$qtype=="S"} then { - set mw(query) [subst $qcmd] - set mw(updatable) 0 - set mw(isaquery) 1 - Window show .mw + if {$qtype=="S"} then { + set mw(query) [subst $qcmd] + set mw(updatable) 0 + set mw(isaquery) 1 + Window show .mw wm title .mw "Query result: $queryname" - mw_load_layout $queryname - mw_select_records $mw(query) - } else { - 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!" - } - } - } + mw_load_layout $queryname + mw_select_records $mw(query) + } else { + 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!" + } + } + } } } @@ -1618,7 +1679,7 @@ proc {open_sequence} {objname} { global dbc seq_name seq_inc seq_start seq_minval seq_maxval Window show .sqf set flag 1 -pg_select $dbc "select * from $objname" rec { +wpg_select $dbc "select * from $objname" rec { set flag 0 set seq_name $objname set seq_inc $rec(increment_by) @@ -1676,9 +1737,9 @@ bind .gpw "set gpw(flag) 1" grab .gpw tkwait variable gpw(flag) if {$gpw(result)} { - return $gpw(var) + return $gpw(var) } else { - return "" + return "" } } @@ -1687,14 +1748,14 @@ global qlvar dbc if {$qlvar(newtablename)==""} return set fldlist {} -cursor_watch .ql -pg_select $dbc "select attnum,attname from pg_class,pg_attribute where (pg_class.relname='$qlvar(newtablename)') and (pg_class.oid=pg_attribute.attrelid) and (attnum>0) order by attnum" rec { - lappend fldlist $rec(attname) +cursor_clock +wpg_select $dbc "select attnum,attname from pg_class,pg_attribute where (pg_class.relname='$qlvar(newtablename)') and (pg_class.oid=pg_attribute.attrelid) and (attnum>0) order by attnum" rec { + lappend fldlist $rec(attname) } -cursor_arrow .ql +cursor_normal if {$fldlist==""} { - show_error "Table $qlvar(newtablename) not found!" - return + show_error "Table $qlvar(newtablename) not found!" + return } set qlvar(tablename$qlvar(ntables)) $qlvar(newtablename) set qlvar(tablestruct$qlvar(ntables)) $fldlist @@ -1714,41 +1775,41 @@ proc {ql_compute_sql} {} { global qlvar set sqlcmd "select " for {set i 0} {$i<[llength $qlvar(resfields)]} {incr i} { - if {$sqlcmd!="select "} {set sqlcmd "$sqlcmd, "} - set sqlcmd "$sqlcmd[lindex $qlvar(restables) $i].[lindex $qlvar(resfields) $i]" + if {$sqlcmd!="select "} {set sqlcmd "$sqlcmd, "} + set sqlcmd "$sqlcmd[lindex $qlvar(restables) $i].[lindex $qlvar(resfields) $i]" } 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)\" $qlvar(tablealias$i)"} + set thename {} + catch {set thename $qlvar(tablename$i)} + if {$thename!=""} {lappend tables "\"$qlvar(tablename$i)\" $qlvar(tablealias$i)"} } set sqlcmd "$sqlcmd from [join $tables ,] " set sup1 {} if {[llength $qlvar(links)]>0} { - set sup1 "where " - foreach link $qlvar(links) { - if {$sup1!="where "} {set sup1 "$sup1 and "} - set sup1 "$sup1 ([lindex $link 0].[lindex $link 1]=[lindex $link 2].[lindex $link 3])" - } + set sup1 "where " + foreach link $qlvar(links) { + if {$sup1!="where "} {set sup1 "$sup1 and "} + set sup1 "$sup1 ([lindex $link 0].[lindex $link 1]=[lindex $link 2].[lindex $link 3])" + } } for {set i 0} {$i<[llength $qlvar(resfields)]} {incr i} { - set crit [lindex $qlvar(rescriteria) $i] - if {$crit!=""} { - if {$sup1==""} {set sup1 "where "} - if {[string length $sup1]>6} {set sup1 "$sup1 and "} - set sup1 "$sup1 ([lindex $qlvar(restables) $i].[lindex $qlvar(resfields) $i] $crit) " - } + set crit [lindex $qlvar(rescriteria) $i] + if {$crit!=""} { + if {$sup1==""} {set sup1 "where "} + if {[string length $sup1]>6} {set sup1 "$sup1 and "} + set sup1 "$sup1 ([lindex $qlvar(restables) $i].[lindex $qlvar(resfields) $i] $crit) " + } } set sqlcmd "$sqlcmd $sup1" set sup2 {} for {set i 0} {$i<[llength $qlvar(ressort)]} {incr i} { - set how [lindex $qlvar(ressort) $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(restables) $i].[lindex $qlvar(resfields) $i] $how " - } + set how [lindex $qlvar(ressort) $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(restables) $i].[lindex $qlvar(resfields) $i] $how " + } } set sqlcmd "$sqlcmd $sup2" set qlvar(sql) $sqlcmd @@ -1763,23 +1824,23 @@ set obj [.ql.c find withtag hili] if {$obj==""} return # Is object a link ? if {[ql_get_tag_info $obj link]=="s"} { - if {[tk_messageBox -title WARNING -icon question -message "Remove link ?" -type yesno -default no]=="no"} return - set linkid [ql_get_tag_info $obj lkid] - set qlvar(links) [lreplace $qlvar(links) $linkid $linkid] - .ql.c delete links - ql_draw_links - return + if {[tk_messageBox -title WARNING -icon question -message "Remove link ?" -type yesno -default no]=="no"} return + set linkid [ql_get_tag_info $obj lkid] + set 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"} { - set col [ql_get_tag_info $obj col] - if {$col==""} return - if {[tk_messageBox -title WARNING -icon question -message "Remove field from result ?" -type yesno -default no]=="no"} return - set qlvar(resfields) [lreplace $qlvar(resfields) $col $col] - set qlvar(restables) [lreplace $qlvar(restables) $col $col] - set qlvar(rescriteria) [lreplace $qlvar(rescriteria) $col $col] - ql_draw_res_panel - return + set col [ql_get_tag_info $obj col] + if {$col==""} return + if {[tk_messageBox -title WARNING -icon question -message "Remove field from result ?" -type yesno -default no]=="no"} return + set qlvar(resfields) [lreplace $qlvar(resfields) $col $col] + set qlvar(restables) [lreplace $qlvar(restables) $col $col] + set qlvar(rescriteria) [lreplace $qlvar(rescriteria) $col $col] + ql_draw_res_panel + return } # Is object a table ? set tablealias [ql_get_tag_info $obj tab] @@ -1787,27 +1848,27 @@ 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} { - if {"$tablename"==[lindex $qlvar(restables) $i]} { - set qlvar(resfields) [lreplace $qlvar(resfields) $i $i] - set qlvar(restables) [lreplace $qlvar(restables) $i $i] - set qlvar(rescriteria) [lreplace $qlvar(rescriteria) $i $i] - } + if {"$tablename"==[lindex $qlvar(restables) $i]} { + set qlvar(resfields) [lreplace $qlvar(resfields) $i $i] + set qlvar(restables) [lreplace $qlvar(restables) $i $i] + set qlvar(rescriteria) [lreplace $qlvar(rescriteria) $i $i] + } } for {set i [expr [llength $qlvar(links)]-1]} {$i>=0} {incr i -1} { - set thelink [lindex $qlvar(links) $i] - if {($tablealias==[lindex $thelink 0]) || ($tablealias==[lindex $thelink 2])} { - set qlvar(links) [lreplace $qlvar(links) $i $i] - } + set thelink [lindex $qlvar(links) $i] + 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"} { - unset qlvar(tablename$i) - unset qlvar(tablestruct$i) - unset qlvar(tablealias$i) - break - } + set temp {} + catch {set temp $qlvar(tablename$i)} + if {"$temp"=="$tablename"} { + unset qlvar(tablename$i) + unset qlvar(tablestruct$i) + unset qlvar(tablealias$i) + break + } } #incr qlvar(ntables) -1 .ql.c delete tab$tablealias @@ -1819,18 +1880,18 @@ ql_draw_res_panel proc {ql_dragit} {w x y} { global draginfo if {"$draginfo(obj)" != ""} { - set dx [expr $x - $draginfo(x)] - set dy [expr $y - $draginfo(y)] - if {$draginfo(is_a_table)} { - set taglist [.ql.c gettags $draginfo(obj)] - set tabletag [lindex $taglist [lsearch -regexp $taglist "^tab"]] - $w move $tabletag $dx $dy - ql_draw_links - } else { - $w move $draginfo(obj) $dx $dy - } - set draginfo(x) $x - set draginfo(y) $y + set dx [expr $x - $draginfo(x)] + set dy [expr $y - $draginfo(y)] + if {$draginfo(is_a_table)} { + set taglist [.ql.c gettags $draginfo(obj)] + set tabletag [lindex $taglist [lsearch -regexp $taglist "^tab"]] + $w move $tabletag $dx $dy + ql_draw_links + } else { + $w move $draginfo(obj) $dx $dy + } + set draginfo(x) $x + set draginfo(y) $y } } @@ -1839,21 +1900,21 @@ global draginfo catch {unset draginfo} set draginfo(obj) [$w find closest $x $y] if {[ql_get_tag_info $draginfo(obj) r]=="ect"} { - # If it'a a rectangle, exit - set draginfo(obj) {} - return + # If it'a a rectangle, exit + set draginfo(obj) {} + return } .ql configure -cursor hand1 .ql.c raise $draginfo(obj) set draginfo(table) 0 if {[ql_get_tag_info $draginfo(obj) table]=="header"} { - set draginfo(is_a_table) 1 - .ql.c itemconfigure [.ql.c find withtag hili] -fill black - .ql.c dtag [.ql.c find withtag hili] hili - .ql.c addtag hili withtag $draginfo(obj) - .ql.c itemconfigure hili -fill blue + set draginfo(is_a_table) 1 + .ql.c itemconfigure [.ql.c find withtag hili] -fill black + .ql.c dtag [.ql.c find withtag hili] hili + .ql.c addtag hili withtag $draginfo(obj) + .ql.c itemconfigure hili -fill blue } else { - set draginfo(is_a_table) 0 + set draginfo(is_a_table) 0 } set draginfo(x) $x set draginfo(y) $y @@ -1877,51 +1938,51 @@ if {$este==""} return .ql.c lower links set qlvar(panstarted) 0 if {$draginfo(is_a_table)} { - set draginfo(obj) {} - .ql.c delete links - ql_draw_links - return + set draginfo(obj) {} + .ql.c delete links + ql_draw_links + return } .ql.c move $draginfo(obj) [expr $draginfo(sx)-$x] [expr $draginfo(sy)-$y] if {($y>$qlvar(yoffs)) && ($x>$qlvar(xoffs))} { - # Drop position : inside the result panel - # Compute the offset of the result panel due to panning - set resoffset [expr [lindex [.ql.c bbox resmarker] 0]-$qlvar(xoffs)] - set newfld [.ql.c itemcget $draginfo(obj) -text] - set tabtag [ql_get_tag_info $draginfo(obj) tab] - set col [expr int(($x-$qlvar(xoffs)-$resoffset)/$qlvar(reswidth))] - set qlvar(resfields) [linsert $qlvar(resfields) $col $newfld] - set qlvar(ressort) [linsert $qlvar(ressort) $col unsorted] - set qlvar(rescriteria) [linsert $qlvar(rescriteria) $col {}] - set qlvar(restables) [linsert $qlvar(restables) $col $tabtag] - ql_draw_res_panel + # Drop position : inside the result panel + # Compute the offset of the result panel due to panning + set resoffset [expr [lindex [.ql.c bbox resmarker] 0]-$qlvar(xoffs)] + set newfld [.ql.c itemcget $draginfo(obj) -text] + set tabtag [ql_get_tag_info $draginfo(obj) tab] + set col [expr int(($x-$qlvar(xoffs)-$resoffset)/$qlvar(reswidth))] + set qlvar(resfields) [linsert $qlvar(resfields) $col $newfld] + set qlvar(ressort) [linsert $qlvar(ressort) $col unsorted] + set qlvar(rescriteria) [linsert $qlvar(rescriteria) $col {}] + set qlvar(restables) [linsert $qlvar(restables) $col $tabtag] + ql_draw_res_panel } else { - # Drop position : in the table panel - set droptarget [.ql.c find overlapping $x $y $x $y] - set targettable {} - foreach item $droptarget { - set targettable [ql_get_tag_info $item tab] - set targetfield [ql_get_tag_info $item f-] - if {($targettable!="") && ($targetfield!="")} { - set droptarget $item - break - } - } - # check if target object isn't a rectangle - if {[ql_get_tag_info $droptarget rec]=="t"} {set targettable {}} - if {$targettable!=""} { - # Target has a table - # See about originate table - set sourcetable [ql_get_tag_info $draginfo(obj) tab] - if {$sourcetable!=""} { - # Source has also a tab .. tag - set sourcefield [ql_get_tag_info $draginfo(obj) f-] - if {$sourcetable!=$targettable} { - lappend qlvar(links) [list $sourcetable $sourcefield $targettable $targetfield $draginfo(obj) $droptarget] - ql_draw_links - } - } - } + # Drop position : in the table panel + set droptarget [.ql.c find overlapping $x $y $x $y] + set targettable {} + foreach item $droptarget { + set targettable [ql_get_tag_info $item tab] + set targetfield [ql_get_tag_info $item f-] + if {($targettable!="") && ($targetfield!="")} { + set droptarget $item + break + } + } + # check if target object isn't a rectangle + if {[ql_get_tag_info $droptarget rec]=="t"} {set targettable {}} + if {$targettable!=""} { + # Target has a table + # See about originate table + set sourcetable [ql_get_tag_info $draginfo(obj) tab] + if {$sourcetable!=""} { + # Source has also a tab .. tag + set sourcefield [ql_get_tag_info $draginfo(obj) f-] + if {$sourcetable!=$targettable} { + lappend qlvar(links) [list $sourcetable $sourcefield $targettable $targetfield $draginfo(obj) $droptarget] + ql_draw_links + } + } + } } # Erase information about onbject beeing dragged set draginfo(obj) {} @@ -1932,33 +1993,33 @@ global qlvar .ql.c delete links set i 0 foreach link $qlvar(links) { - # Compute the source and destination right edge - set sre [lindex [.ql.c bbox tab[lindex $link 0]] 2] - set dre [lindex [.ql.c bbox tab[lindex $link 2]] 2] - # Compute field bound boxes - set sbbox [.ql.c bbox [lindex $link 4]] - set dbbox [.ql.c bbox [lindex $link 5]] - # Compute the auxiliary lines - if {[lindex $sbbox 2] < [lindex $dbbox 0]} { - # Source object is on the left of target object - set x1 $sre - set y1 [expr ([lindex $sbbox 1]+[lindex $sbbox 3])/2] - .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 [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 - set x1 [lindex $sbbox 0] - set y1 [expr ([lindex $sbbox 1]+[lindex $sbbox 3])/2] - .ql.c create line $x1 $y1 [expr $x1-10] $y1 -tags [subst {links lkid$i}] -width 3 - set x2 $dre - set y2 [expr ([lindex $dbbox 1]+[lindex $dbbox 3])/2] - .ql.c create line $x2 $y2 [expr $x2+10] $y2 -width 3 -tags [subst {links lkid$i}] - .ql.c create line [expr $x1-10] $y1 [expr $x2+10] $y2 -tags [subst {links lkid$i}] -width 2 - } - incr i + # Compute the source and destination right edge + set sre [lindex [.ql.c bbox tab[lindex $link 0]] 2] + set dre [lindex [.ql.c bbox tab[lindex $link 2]] 2] + # Compute field bound boxes + set sbbox [.ql.c bbox [lindex $link 4]] + set dbbox [.ql.c bbox [lindex $link 5]] + # Compute the auxiliary lines + if {[lindex $sbbox 2] < [lindex $dbbox 0]} { + # Source object is on the left of target object + set x1 $sre + set y1 [expr ([lindex $sbbox 1]+[lindex $sbbox 3])/2] + .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 [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 + set x1 [lindex $sbbox 0] + set y1 [expr ([lindex $sbbox 1]+[lindex $sbbox 3])/2] + .ql.c create line $x1 $y1 [expr $x1-10] $y1 -tags [subst {links lkid$i}] -width 3 + set x2 $dre + set y2 [expr ([lindex $dbbox 1]+[lindex $dbbox 3])/2] + .ql.c create line $x2 $y2 [expr $x2+10] $y2 -width 3 -tags [subst {links lkid$i}] + .ql.c create line [expr $x1-10] $y1 [expr $x2+10] $y2 -tags [subst {links lkid$i}] -width 2 + } + incr i } .ql.c lower links .ql.c bind links {ql_link_click %x %y} @@ -1969,16 +2030,16 @@ global qlvar .ql.c delete all set posx 20 for {set it 0} {$it<$qlvar(ntables)} {incr it} { - ql_draw_table $it + ql_draw_table $it } .ql.c lower rect .ql.c create line 0 $qlvar(yoffs) 10000 $qlvar(yoffs) -width 3 .ql.c create rectangle 0 $qlvar(yoffs) 10000 5000 -fill #FFFFFF for {set i [expr 15+$qlvar(yoffs)]} {$i<500} {incr i 15} { - .ql.c create line $qlvar(xoffs) $i 10000 $i -fill #CCCCCC -tags {resgrid} + .ql.c create line $qlvar(xoffs) $i 10000 $i -fill #CCCCCC -tags {resgrid} } for {set i $qlvar(xoffs)} {$i<10000} {incr i $qlvar(reswidth)} { - .ql.c create line $i [expr 1+$qlvar(yoffs)] $i 10000 -fill #cccccc -tags {resgrid} + .ql.c create line $i [expr 1+$qlvar(yoffs)] $i 10000 -fill #cccccc -tags {resgrid} } # Make a marker for result panel offset calculations (due to panning) .ql.c create line $qlvar(xoffs) $qlvar(yoffs) $qlvar(xoffs) 500 -tags {resmarker resgrid} @@ -2001,12 +2062,12 @@ global qlvar 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 $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}] - } + .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 $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}] + } } .ql.c raise reshdr .ql.c bind resf {ql_resfield_click %x %y} @@ -2079,13 +2140,13 @@ set dy [expr $y-$qlvar(panstarty)] set qlvar(panstartx) $x set qlvar(panstarty) $y if {$qlvar(panobject)=="tables"} { - .ql.c move mov $dx $dy - .ql.c move links $dx $dy - .ql.c move rect $dx $dy + .ql.c move mov $dx $dy + .ql.c move links $dx $dy + .ql.c move rect $dx $dy } else { - .ql.c move resp $dx 0 - .ql.c move resgrid $dx 0 - .ql.c raise reshdr + .ql.c move resp $dx 0 + .ql.c move resgrid $dx 0 + .ql.c raise reshdr } } @@ -2117,11 +2178,11 @@ set taglist [.ql.c gettags $obj] if {[lsearch $taglist sort]==-1} return set cum [.ql.c itemcget $obj -text] if {$cum=="unsorted"} { - set cum Ascending + set cum Ascending } elseif {$cum=="Ascending"} { - set cum Descending + set cum Descending } else { - set cum unsorted + set cum unsorted } set col [expr int(($x-$qlvar(xoffs))/$qlvar(reswidth))] set qlvar(ressort) [lreplace $qlvar(ressort) $col $col $cum] @@ -2132,29 +2193,29 @@ proc {qlc_click} {x y w} { global qlvar set qlvar(panstarted) 0 if {$w==".ql.c"} { - set canpan 1 - if {$y<$qlvar(yoffs)} { - if {[llength [.ql.c find overlapping $x $y $x $y]]!=0} {set canpan 0} - set qlvar(panobject) tables - } else { - set qlvar(panobject) result - } - if {$canpan} { - .ql configure -cursor hand1 - set qlvar(panstartx) $x - set qlvar(panstarty) $y - set qlvar(panstarted) 1 - } + set canpan 1 + if {$y<$qlvar(yoffs)} { + if {[llength [.ql.c find overlapping $x $y $x $y]]!=0} {set canpan 0} + set qlvar(panobject) tables + } else { + set qlvar(panobject) result + } + if {$canpan} { + .ql configure -cursor hand1 + set qlvar(panstartx) $x + set qlvar(panstarty) $y + set qlvar(panstarted) 1 + } } set isedit 0 catch {set isedit $qlvar(critedit)} # Compute the offset of the result panel due to panning set resoffset [expr [lindex [.ql.c bbox resmarker] 0]-$qlvar(xoffs)] if {$isedit} { - set qlvar(rescriteria) [lreplace $qlvar(rescriteria) $qlvar(critcol) $qlvar(critcol) $qlvar(critval)] - .ql.c delete cr-c$qlvar(critcol)-r$qlvar(critrow) - .ql.c create text [expr $resoffset+4+$qlvar(xoffs)+$qlvar(critcol)*$qlvar(reswidth)] [expr $qlvar(yoffs)+46+15*$qlvar(critrow)] -anchor nw -text $qlvar(critval) -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags [subst {resp cr-c$qlvar(critcol)-r$qlvar(critrow)}] - set qlvar(critedit) 0 + set qlvar(rescriteria) [lreplace $qlvar(rescriteria) $qlvar(critcol) $qlvar(critcol) $qlvar(critval)] + .ql.c delete cr-c$qlvar(critcol)-r$qlvar(critrow) + .ql.c create text [expr $resoffset+4+$qlvar(xoffs)+$qlvar(critcol)*$qlvar(reswidth)] [expr $qlvar(yoffs)+46+15*$qlvar(critrow)] -anchor nw -text $qlvar(critval) -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags [subst {resp cr-c$qlvar(critcol)-r$qlvar(critrow)}] + set qlvar(critedit) 0 } catch {destroy .ql.entc} if {$y<[expr $qlvar(yoffs)+46]} return @@ -2205,21 +2266,21 @@ 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 rbvar(msg) $rbvar(e_$rg) + if {$rbvar(y_$rg)>$y} break; } 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 + 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 } } @@ -2230,19 +2291,19 @@ 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 - } + if {[rb_has_tag $id mov]} { + set obj $id + break + } } 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) {} + set draginfo(region) {} } else { - set draginfo(region) [string range [lindex $taglist $i] 3 64] + set draginfo(region) [string range [lindex $taglist $i] 3 64] } .rb configure -cursor hand1 .rb.c itemconfigure [.rb.c find withtag hili] -fill black @@ -2255,14 +2316,14 @@ 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} + 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} } } @@ -2276,23 +2337,23 @@ 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 - } + 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 + 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 - } + # 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 draginfo(obj) {} unset draginfo @@ -2301,23 +2362,23 @@ unset draginfo 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 + .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 } } 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 + .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 + .rb.balign configure -text left + .rb.c itemconfigure hili -anchor nw + .rb.c move hili [expr [lindex $bb 0]-[lindex $bb 2]+3] 0 } } @@ -2333,11 +2394,11 @@ 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_clock +wpg_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 +#cursor_normal } proc {rb_has_tag} {id tg} { @@ -2365,8 +2426,8 @@ 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) +wpg_select $dbc "select * from pga_reports where reportname='$rbvar(reportname)'" rcd { + eval $rcd(reportbody) } rb_get_report_fields rb_draw_regions @@ -2379,38 +2440,37 @@ Window show .rpv 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 + 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_*]] +} # 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 - } + 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)] +wpg_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}] } @@ -2425,14 +2485,14 @@ 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)" + 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]}" - } + 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')" @@ -2441,9 +2501,9 @@ sql_exec noquiet "insert into pga_reports (reportname,reportsource,reportbody) v proc {save_pref} {} { global pref catch { - set fid [open "~/.pgaccessrc" w] - foreach {opt val} [array get pref] { puts $fid "$opt $val" } - close $fid + set fid [open "~/.pgaccessrc" w] + foreach {opt val} [array get pref] { puts $fid "$opt $val" } + close $fid } } @@ -2461,7 +2521,7 @@ Window show .tiw set tiw(isunique) {} set tiw(isclustered) {} set tiw(indexfields) {} -pg_select $dbc "select attnum,attname,typname,attlen,atttypmod,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 { +wpg_select $dbc "select attnum,attname,typname,attlen,atttypmod,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 fsize1 $rec(atttypmod) set ftype $rec(typname) @@ -2478,25 +2538,28 @@ pg_select $dbc "select attnum,attname,typname,attlen,atttypmod,usename,pg_class. 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) - } +wpg_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) + wpg_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 } { - if {$how != "quiet"} { - show_error "Error executing query\n\n$cmd\n\nPostgreSQL error message:\n$errmsg" - } - return 0 +global dbc pgsql +if {[set pgr [wpg_exec $dbc $cmd]]==0} { + return 0 +} +if {($pgsql(status)=="PGRES_COMMAND_OK") || ($pgsql(status)=="PGRES_TUPLES_OK")} { + pg_result $pgr -clear + return 1 +} +if {$how != "quiet"} { + show_error "Error executing query\n\n$cmd\n\nPostgreSQL error message:\n$pgsql(errmsg)\nPostgreSQL status:$pgsql(status)" } pg_result $pgr -clear -return 1 +return 0 } proc {tab_click} {w} { @@ -2506,8 +2569,8 @@ set curtab [$w cget -text] #if {$activetab==$curtab} return; .dw.btndesign configure -state disabled if {$activetab!=""} { - place .dw.tab$activetab -x 10 - .dw.tab$activetab configure -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* + place .dw.tab$activetab -x 10 + .dw.tab$activetab configure -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* } $w configure -font -Adobe-Helvetica-Bold-R-Normal-*-*-120-*-*-*-*-* place $w -x 7 @@ -2526,47 +2589,40 @@ global tiw dbc set cs [.tiw.ilb curselection] if {$cs==""} return set idxname [.tiw.ilb get $cs] -pg_select $dbc "select pg_index.*,pg_class.oid from pg_index,pg_class where pg_class.relname='$idxname' and pg_class.oid=pg_index.indexrelid" rec { - if {$rec(indisunique)=="t"} { - set tiw(isunique) Yes - } else { - set tiw(isunique) No - } - if {$rec(indisclustered)=="t"} { - set tiw(isclustered) Yes - } else { - set tiw(isclustered) No - } - set tiw(indexfields) {} - foreach field $rec(indkey) { - if {$field!=0} { -# pg_select $dbc "select attname from pg_attribute where attrelid=$tiw(tableoid) and attnum=$field" rec1 { +wpg_select $dbc "select pg_index.*,pg_class.oid from pg_index,pg_class where pg_class.relname='$idxname' and pg_class.oid=pg_index.indexrelid" rec { + if {$rec(indisunique)=="t"} { + set tiw(isunique) Yes + } else { + set tiw(isunique) No + } + if {$rec(indisclustered)=="t"} { + set tiw(isclustered) Yes + } else { + set tiw(isclustered) No + } + set tiw(indexfields) {} + foreach field $rec(indkey) { + if {$field!=0} { +# wpg_select $dbc "select attname from pg_attribute where attrelid=$tiw(tableoid) and attnum=$field" rec1 { # set tiw(indexfields) "$tiw(indexfields) $rec1(attname)" # } - set tiw(indexfields) "$tiw(indexfields) $tiw(f$field)" - } + set tiw(indexfields) "$tiw(indexfields) $tiw(f$field)" + } - } + } } set tiw(indexfields) [string trim $tiw(indexfields)] } proc {vacuum} {} { -global dbc dbname sdbname - +global dbc dbname sdbname pgsql 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 +cursor_clock +set pgres [wpg_exec $dbc "vacuum;"] +catch {pg_result $pgres -clear} +cursor_normal set sdbname $dbname -if {$retval} { - show_error $msg -} } proc {main} {argc argv} { @@ -2595,32 +2651,32 @@ wm protocol .dw WM_DELETE_WINDOW { proc {Window} {args} { global vTcl - set cmd [lindex $args 0] - set name [lindex $args 1] - set newname [lindex $args 2] - set rest [lrange $args 3 end] - if {$name == "" || $cmd == ""} {return} - if {$newname == ""} { - set newname $name - } - set exists [winfo exists $newname] - switch $cmd { - show { - if {$exists == "1" && $name != "."} {wm deiconify $name; return} - if {[info procs vTclWindow(pre)$name] != ""} { - eval "vTclWindow(pre)$name $newname $rest" - } - if {[info procs vTclWindow$name] != ""} { - eval "vTclWindow$name $newname $rest" - } - if {[info procs vTclWindow(post)$name] != ""} { - eval "vTclWindow(post)$name $newname $rest" - } - } - hide { if $exists {wm withdraw $newname; return} } - iconify { if $exists {wm iconify $newname; return} } - destroy { if $exists {destroy $newname; return} } - } + set cmd [lindex $args 0] + set name [lindex $args 1] + set newname [lindex $args 2] + set rest [lrange $args 3 end] + if {$name == "" || $cmd == ""} {return} + if {$newname == ""} { + set newname $name + } + set exists [winfo exists $newname] + switch $cmd { + show { + if {$exists == "1" && $name != "."} {wm deiconify $name; return} + if {[info procs vTclWindow(pre)$name] != ""} { + eval "vTclWindow(pre)$name $newname $rest" + } + if {[info procs vTclWindow$name] != ""} { + eval "vTclWindow$name $newname $rest" + } + if {[info procs vTclWindow(post)$name] != ""} { + eval "vTclWindow(post)$name $newname $rest" + } + } + hide { if $exists {wm withdraw $newname; return} } + iconify { if $exists {wm iconify $newname; return} } + destroy { if $exists {destroy $newname; return} } + } } ################################# @@ -2628,351 +2684,353 @@ global vTcl # proc vTclWindow. {base} { - if {$base == ""} { - set base . - } - ################### - # CREATING WIDGETS - ################### - wm focusmodel $base passive - wm geometry $base 1x1+0+0 - wm maxsize $base 1009 738 - wm minsize $base 1 1 - wm overrideredirect $base 0 - wm resizable $base 1 1 - wm withdraw $base - wm title $base "vt.tcl" - ################### - # SETTING GEOMETRY - ################### + if {$base == ""} { + set base . + } + ################### + # CREATING WIDGETS + ################### + wm focusmodel $base passive + wm geometry $base 1x1+0+0 + wm maxsize $base 1009 738 + wm minsize $base 1 1 + wm overrideredirect $base 0 + wm resizable $base 1 1 + wm withdraw $base + wm title $base "vt.tcl" + ################### + # SETTING GEOMETRY + ################### } proc vTclWindow.about {base} { - if {$base == ""} { - set base .about - } - if {[winfo exists $base]} { - wm deiconify $base; return - } - ################### - # CREATING WIDGETS - ################### - toplevel $base -class Toplevel - wm focusmodel $base passive - wm geometry $base 471x177+168+243 - wm maxsize $base 1009 738 - wm minsize $base 1 1 - 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 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief groove -text {A Tcl/Tk interface to + if {$base == ""} { + set base .about + } + if {[winfo exists $base]} { + wm deiconify $base; return + } + ################### + # CREATING WIDGETS + ################### + toplevel $base -class Toplevel + wm focusmodel $base passive + wm geometry $base 471x177+168+243 + wm maxsize $base 1009 738 + wm minsize $base 1 1 + 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 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief groove -text {A Tcl/Tk interface to PostgreSQL by Constantin Teodorescu} - label $base.l3 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief sunken -text {vers 0.90} - label $base.l4 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief groove -text {You will always get the latest version at: + label $base.l3 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief sunken -text {vers 0.91} + 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 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 + 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 } proc vTclWindow.dbod {base} { - if {$base == ""} { - set base .dbod - } - if {[winfo exists $base]} { - wm deiconify $base; return - } - ################### - # CREATING WIDGETS - ################### - toplevel $base -class Toplevel \ - -cursor top_left_arrow - wm focusmodel $base passive - wm geometry $base 282x180+358+333 - 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 "Open database" - label $base.lhost \ - -borderwidth 0 -relief raised -text Host - entry $base.ehost \ - -background #fefefe -borderwidth 1 -highlightthickness 1 \ - -selectborderwidth 0 -textvariable newhost - bind $base.ehost { - focus .dbod.epport - } - label $base.lport \ - -borderwidth 0 -relief raised -text Port - entry $base.epport \ - -background #fefefe -borderwidth 1 -highlightthickness 1 \ - -selectborderwidth 0 -textvariable newpport - bind $base.epport { - focus .dbod.edbname - } - label $base.ldbname \ - -borderwidth 0 -relief raised -text Database - entry $base.edbname \ - -background #fefefe -borderwidth 1 -highlightthickness 1 \ - -selectborderwidth 0 -textvariable newdbname - bind $base.edbname { - focus .dbod.eusername + if {$base == ""} { + set base .dbod + } + if {[winfo exists $base]} { + wm deiconify $base; return + } + ################### + # CREATING WIDGETS + ################### + toplevel $base -class Toplevel \ + -cursor top_left_arrow + wm focusmodel $base passive + wm geometry $base 282x180+358+333 + 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 "Open database" + label $base.lhost \ + -borderwidth 0 -relief raised -text Host + entry $base.ehost \ + -background #fefefe -borderwidth 1 -highlightthickness 1 \ + -selectborderwidth 0 -textvariable newhost + bind $base.ehost { + focus .dbod.epport + } + label $base.lport \ + -borderwidth 0 -relief raised -text Port + entry $base.epport \ + -background #fefefe -borderwidth 1 -highlightthickness 1 \ + -selectborderwidth 0 -textvariable newpport + bind $base.epport { + focus .dbod.edbname + } + label $base.ldbname \ + -borderwidth 0 -relief raised -text Database + entry $base.edbname \ + -background #fefefe -borderwidth 1 -highlightthickness 1 \ + -selectborderwidth 0 -textvariable newdbname + bind $base.edbname { + focus .dbod.eusername .dbod.eusername selection range 0 end - } - label $base.lusername \ - -borderwidth 0 -relief raised -text Username - entry $base.eusername \ - -background #fefefe -borderwidth 1 -highlightthickness 1 \ - -selectborderwidth 0 -textvariable newusername - bind $base.eusername { - focus .dbod.epassword - } - label $base.lpassword \ - -borderwidth 0 -relief raised -text Password - entry $base.epassword \ - -background #fefefe -borderwidth 1 -highlightthickness 1 \ - -selectborderwidth 0 -textvariable newpassword -show "*" - bind $base.epassword { - focus .dbod.opbtu - } - button $base.opbtu \ - -borderwidth 1 -command open_database -padx 9 -pady 3 -text Open - bind $base.opbtu { - open_database - } - 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.lusername \ - -x 35 -y 82 -anchor nw -bordermode ignore - place $base.eusername \ - -x 100 -y 80 -anchor nw -bordermode ignore - place $base.lpassword \ - -x 35 -y 107 -anchor nw -bordermode ignore - place $base.epassword \ - -x 100 -y 105 -anchor nw -bordermode ignore - place $base.opbtu \ - -x 70 -y 140 -width 60 -height 26 -anchor nw -bordermode ignore - place $base.canbut \ - -x 150 -y 140 -width 60 -height 26 -anchor nw -bordermode ignore + } + label $base.lusername \ + -borderwidth 0 -relief raised -text Username + entry $base.eusername \ + -background #fefefe -borderwidth 1 -highlightthickness 1 \ + -selectborderwidth 0 -textvariable newusername + bind $base.eusername { + focus .dbod.epassword + } + label $base.lpassword \ + -borderwidth 0 -relief raised -text Password + entry $base.epassword \ + -background #fefefe -borderwidth 1 -highlightthickness 1 \ + -selectborderwidth 0 -textvariable newpassword -show "*" + bind $base.epassword { + focus .dbod.opbtu + } + button $base.opbtu \ + -borderwidth 1 -command open_database -padx 9 -pady 3 -text Open + bind $base.opbtu { + open_database + } + 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.lusername \ + -x 35 -y 82 -anchor nw -bordermode ignore + place $base.eusername \ + -x 100 -y 80 -anchor nw -bordermode ignore + place $base.lpassword \ + -x 35 -y 107 -anchor nw -bordermode ignore + place $base.epassword \ + -x 100 -y 105 -anchor nw -bordermode ignore + place $base.opbtu \ + -x 70 -y 140 -width 60 -height 26 -anchor nw -bordermode ignore + place $base.canbut \ + -x 150 -y 140 -width 60 -height 26 -anchor nw -bordermode ignore } proc vTclWindow.dw {base} { - if {$base == ""} { - set base .dw - } - if {[winfo exists $base]} { - wm deiconify $base; return - } - ################### - # CREATING WIDGETS - ################### - toplevel $base -class Toplevel \ - -background #efefef -cursor top_left_arrow - wm focusmodel $base passive - wm geometry $base 322x355+96+172 - wm maxsize $base 1009 738 - wm minsize $base 1 1 - wm overrideredirect $base 0 - wm resizable $base 0 0 - wm deiconify $base - wm title $base "PostgreSQL access" - label $base.labframe \ - -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ - -relief raised - listbox $base.lb \ - -background #fefefe \ - -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ - -foreground black -highlightthickness 0 -selectborderwidth 0 \ - -yscrollcommand {.dw.sb set} - bind $base.lb { - cmd_Open - } - button $base.btnnew \ - -borderwidth 1 -command cmd_New \ - -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ - -pady 3 -text New - button $base.btnopen \ - -borderwidth 1 -command cmd_Open \ - -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ - -pady 3 -text Open - button $base.btndesign \ - -borderwidth 1 -command cmd_Design \ - -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ - -pady 3 -text Design - label $base.lmask \ - -borderwidth 0 \ - -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ - -relief raised -text { } - label $base.label22 \ - -borderwidth 1 \ - -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ - -relief raised - menubutton $base.menubutton23 \ - -borderwidth 1 \ - -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ - -menu .dw.menubutton23.01 -padx 4 -pady 3 -text Database - menu $base.menubutton23.01 \ - -borderwidth 1 -cursor {} \ - -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -tearoff 0 - $base.menubutton23.01 add command \ - \ - -command { + if {$base == ""} { + set base .dw + } + if {[winfo exists $base]} { + wm deiconify $base; return + } + ################### + # CREATING WIDGETS + ################### + toplevel $base -class Toplevel \ + -background #efefef -cursor top_left_arrow + wm focusmodel $base passive + wm geometry $base 322x355+96+172 + wm maxsize $base 1009 738 + wm minsize $base 1 1 + wm overrideredirect $base 0 + wm resizable $base 0 0 + wm deiconify $base + wm title $base "PostgreSQL access" + label $base.labframe \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -relief raised + listbox $base.lb \ + -background #fefefe \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ + -foreground black -highlightthickness 0 -selectborderwidth 0 \ + -yscrollcommand {.dw.sb set} + bind $base.lb { + cmd_Open + } + button $base.btnnew \ + -borderwidth 1 -command cmd_New \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ + -pady 3 -text New + button $base.btnopen \ + -borderwidth 1 -command cmd_Open \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ + -pady 3 -text Open + button $base.btndesign \ + -borderwidth 1 -command cmd_Design \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ + -pady 3 -text Design + label $base.lmask \ + -borderwidth 0 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -relief raised -text { } + label $base.label22 \ + -borderwidth 1 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -relief raised + menubutton $base.menubutton23 \ + -borderwidth 1 \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ + -menu .dw.menubutton23.01 -padx 4 -pady 3 -text Database + menu $base.menubutton23.01 \ + -borderwidth 1 -cursor {} \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -tearoff 0 + $base.menubutton23.01 add command \ + \ + -command { Window show .dbod set newhost $host set newpport $pport focus .dbod.edbname .dbod.edbname selection range 0 end} \ - -label Open - $base.menubutton23.01 add command \ - \ - -command {.dw.lb delete 0 end + -label Open + $base.menubutton23.01 add command \ + \ + -command {.dw.lb delete 0 end set dbc {} set dbname {} set sdbname {}} \ - -label Close - $base.menubutton23.01 add command \ - -command vacuum -label Vacuum - $base.menubutton23.01 add separator - $base.menubutton23.01 add command \ - -command {cmd_Import_Export Import} -label {Import table} - $base.menubutton23.01 add command \ - -command {cmd_Import_Export Export} -label {Export table} - $base.menubutton23.01 add separator - $base.menubutton23.01 add command \ - -command cmd_Preferences -label Preferences - $base.menubutton23.01 add separator - $base.menubutton23.01 add command \ - -command {catch {pg_disconnect $dbc} + -label Close + $base.menubutton23.01 add command \ + -command vacuum -label Vacuum + $base.menubutton23.01 add separator + $base.menubutton23.01 add command \ + -command {cmd_Import_Export Import} -label {Import table} + $base.menubutton23.01 add command \ + -command {cmd_Import_Export Export} -label {Export table} + $base.menubutton23.01 add separator + $base.menubutton23.01 add command \ + -command cmd_Preferences -label Preferences + $base.menubutton23.01 add command \ + -command "Window show .sqlw" -label "SQL window" + $base.menubutton23.01 add separator + $base.menubutton23.01 add command \ + -command {catch {pg_disconnect $dbc} 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 -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 \ - -borderwidth 1 \ - -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ - -menu .dw.mnob.m -padx 4 -pady 3 -text Object - menu $base.mnob.m \ - -borderwidth 1 -cursor {} \ - -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -tearoff 0 - $base.mnob.m add command \ - -command cmd_New -label New - $base.mnob.m add command \ - -command {cmd_Delete } -label Delete - $base.mnob.m add command \ - -command {cmd_Rename } -label Rename - $base.mnob.m add command \ - -command cmd_Information -label Information - menubutton $base.mhelp \ - -borderwidth 1 \ - -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ - -menu .dw.mhelp.m -padx 4 -pady 3 -text Help - menu $base.mhelp.m \ - -borderwidth 1 -cursor {} \ - -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -tearoff 0 - $base.mhelp.m add command \ - -label Contents - $base.mhelp.m add command \ - -label PostgreSQL - $base.mhelp.m add separator - $base.mhelp.m add command \ - -command {Window show .about} -label About - ################### - # SETTING GEOMETRY - ################### - place $base.labframe \ - -x 80 -y 30 -width 236 -height 300 -anchor nw -bordermode ignore - place $base.lb \ - -x 90 -y 75 -width 205 -height 248 -anchor nw -bordermode ignore - place $base.btnnew \ - -x 90 -y 40 -width 60 -height 25 -anchor nw -bordermode ignore - place $base.btnopen \ - -x 165 -y 40 -width 60 -height 25 -anchor nw -bordermode ignore - place $base.btndesign \ - -x 235 -y 40 -width 60 -height 25 -anchor nw -bordermode ignore - place $base.lmask \ - -x 155 -y 45 -width 10 -height 23 -anchor nw -bordermode ignore - place $base.label22 \ - -x 0 -y 0 -width 396 -height 23 -anchor nw -bordermode ignore - place $base.menubutton23 \ - -x 0 -y 3 -width 63 -height 17 -anchor nw -bordermode ignore - place $base.lshost \ - -x 3 -y 335 -width 91 -height 20 -anchor nw -bordermode ignore - place $base.lsdbname \ - -x 95 -y 335 -width 223 -height 20 -anchor nw -bordermode ignore - place $base.sb \ - -x 295 -y 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 \ - -x 280 -y 1 -height 20 -anchor nw -bordermode ignore + label $base.lshost \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -relief groove -text localhost -textvariable host + label $base.lsdbname \ + -anchor w -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -relief groove -textvariable sdbname + scrollbar $base.sb \ + -borderwidth 1 -command {.dw.lb yview} -orient vert + menubutton $base.mnob \ + -borderwidth 1 \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ + -menu .dw.mnob.m -padx 4 -pady 3 -text Object + menu $base.mnob.m \ + -borderwidth 1 -cursor {} \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -tearoff 0 + $base.mnob.m add command \ + -command cmd_New -label New + $base.mnob.m add command \ + -command {cmd_Delete } -label Delete + $base.mnob.m add command \ + -command {cmd_Rename } -label Rename + $base.mnob.m add command \ + -command cmd_Information -label Information + menubutton $base.mhelp \ + -borderwidth 1 \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ + -menu .dw.mhelp.m -padx 4 -pady 3 -text Help + menu $base.mhelp.m \ + -borderwidth 1 -cursor {} \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -tearoff 0 + $base.mhelp.m add command \ + -label Contents + $base.mhelp.m add command \ + -label PostgreSQL + $base.mhelp.m add separator + $base.mhelp.m add command \ + -command {Window show .about} -label About + ################### + # SETTING GEOMETRY + ################### + place $base.labframe \ + -x 80 -y 30 -width 236 -height 300 -anchor nw -bordermode ignore + place $base.lb \ + -x 90 -y 75 -width 205 -height 248 -anchor nw -bordermode ignore + place $base.btnnew \ + -x 90 -y 40 -width 60 -height 25 -anchor nw -bordermode ignore + place $base.btnopen \ + -x 165 -y 40 -width 60 -height 25 -anchor nw -bordermode ignore + place $base.btndesign \ + -x 235 -y 40 -width 60 -height 25 -anchor nw -bordermode ignore + place $base.lmask \ + -x 155 -y 45 -width 10 -height 23 -anchor nw -bordermode ignore + place $base.label22 \ + -x 0 -y 0 -width 396 -height 23 -anchor nw -bordermode ignore + place $base.menubutton23 \ + -x 0 -y 3 -width 63 -height 17 -anchor nw -bordermode ignore + place $base.lshost \ + -x 3 -y 335 -width 91 -height 20 -anchor nw -bordermode ignore + place $base.lsdbname \ + -x 95 -y 335 -width 223 -height 20 -anchor nw -bordermode ignore + place $base.sb \ + -x 295 -y 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 \ + -x 280 -y 1 -height 20 -anchor nw -bordermode ignore } proc vTclWindow.fw {base} { - if {$base == ""} { - set base .fw - } - if {[winfo exists $base]} { - wm deiconify $base; return - } - ################### - # CREATING WIDGETS - ################### - toplevel $base -class Toplevel - wm focusmodel $base passive - wm geometry $base 306x288+233+130 - wm maxsize $base 1009 738 - wm minsize $base 1 1 - 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 { + if {$base == ""} { + set base .fw + } + if {[winfo exists $base]} { + wm deiconify $base; return + } + ################### + # CREATING WIDGETS + ################### + toplevel $base -class Toplevel + wm focusmodel $base passive + wm geometry $base 306x288+233+130 + wm maxsize $base 1009 738 + wm minsize $base 1 1 + 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 { if {$funcname==""} { show_error "You must supply a name for this function!" } elseif {$funcret==""} { show_error "You must supply a return type!" } else { set funcbody [.fw.text1 get 1.0 end] - regsub -all "\n" $funcbody " " funcbody + regsub -all "\n" $funcbody " " funcbody if {[sql_exec noquiet "create function $funcname ($funcpar) returns $funcret as '$funcbody' language 'sql'"]} { Window destroy .fw tk_messageBox -title PostgreSQL -message "Function created!" @@ -2980,50 +3038,50 @@ proc vTclWindow.fw {base} { } } - } -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 + } -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 } proc vTclWindow.iew {base} { - if {$base == ""} { - set base .iew - } - if {[winfo exists $base]} { - wm deiconify $base; return - } - ################### - # CREATING WIDGETS - ################### - toplevel $base -class Toplevel - wm focusmodel $base passive - wm geometry $base 287x151+259+304 - wm maxsize $base 1009 738 - wm minsize $base 1 1 - wm overrideredirect $base 0 - wm resizable $base 0 0 - wm title $base "Import-Export table" - label $base.l1 -borderwidth 0 -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!" + if {$base == ""} { + set base .iew + } + if {[winfo exists $base]} { + wm deiconify $base; return + } + ################### + # CREATING WIDGETS + ################### + toplevel $base -class Toplevel + wm focusmodel $base passive + wm geometry $base 287x151+259+304 + wm maxsize $base 1009 738 + wm minsize $base 1 1 + wm overrideredirect $base 0 + wm resizable $base 0 0 + wm title $base "Import-Export table" + label $base.l1 -borderwidth 0 -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!" + show_error "You have to supply a external file name!" } else { if {$ie_delimiter==""} { set sup "" @@ -3035,71 +3093,70 @@ proc vTclWindow.iew {base} { } else { set oper "TO" } - if {$oicb} { - set sup2 " WITH OIDS " - } else { - set sup2 "" - } + if {$oicb} { + set sup2 " WITH OIDS " + } else { + set sup2 "" + } set sqlcmd "COPY $ie_tablename $sup2 $oper '$ie_filename'$sup" - cursor_watch .iew + cursor_clock if {[sql_exec noquiet $sqlcmd]} { - cursor_arrow .iew tk_messageBox -title Information -message "Operation completed!" Window destroy .iew } - catch {cursor_arrow .iew} + cursor_normal }} -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 + 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 } proc {mw_canvas_paste} {x y} { - global mw - .mw.c insert $mw(id_edited) insert [selection get] - set mw(dirtyrec) 1 + global mw + .mw.c insert $mw(id_edited) insert [selection get] + set mw(dirtyrec) 1 } proc vTclWindow.mw {base} { - if {$base == ""} { - set base .mw - } - if {[winfo exists $base]} { - wm deiconify $base; return - } - ################### - # CREATING WIDGETS - ################### - toplevel $base -class Toplevel - wm focusmodel $base passive - wm geometry $base 550x400+5+5 - wm maxsize $base 1009 738 - wm minsize $base 550 400 - wm overrideredirect $base 0 - wm resizable $base 1 1 - wm deiconify $base - wm title $base "Table browser" - bind $base { - mw_delete_record - } - 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 {$base == ""} { + set base .mw + } + if {[winfo exists $base]} { + wm deiconify $base; return + } + ################### + # CREATING WIDGETS + ################### + toplevel $base -class Toplevel + wm focusmodel $base passive + wm geometry $base 550x400+5+5 + wm maxsize $base 1009 738 + wm minsize $base 550 400 + wm overrideredirect $base 0 + wm resizable $base 1 1 + wm deiconify $base + wm title $base "Table browser" + bind $base { + mw_delete_record + } + 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 @@ -3108,56 +3165,56 @@ if {[mw_save_new_record]} { Window destroy .mw } } - button $base.f1.b2 -borderwidth 1 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -padx 9 -pady 3 -text Reload -command { + 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!" + show_error "Sorting and filtering not (yet) available from queries!\n\nPlease enter them in the query definition!" set sortfield {} set filter {} } else { - if {$filter!=""} { - set nq "$mw(query) where ($filter)" - } else { - set nq $mw(query) - } - if {$sortfield!=""} { - set nq "$nq order by $sortfield" - } + if {$filter!=""} { + set nq "$mw(query) where ($filter)" + } else { + set nq $mw(query) + } + if {$sortfield!=""} { + set nq "$nq order by $sortfield" + } } if {[mw_save_new_record]} {mw_select_records $nq} } - 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 { - mw_canvas_paste %x %y - } - bind $base.c { - if {[mw_exit_edit]} {mw_save_new_record} - } - ################### - # SETTING GEOMETRY - ################### - 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 + 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 { + mw_canvas_paste %x %y + } + bind $base.c { + if {[mw_exit_edit]} {mw_save_new_record} + } + ################### + # SETTING GEOMETRY + ################### + 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} { @@ -3172,16 +3229,16 @@ proc vTclWindow.nt {base} { ################### toplevel $base -class Toplevel wm focusmodel $base passive - wm geometry $base 630x312+100+40 + wm geometry $base 614x392+78+181 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 "Create table" + wm title $base "Create new table" entry $base.etabn \ - -background #fefefe -borderwidth 1 -highlightthickness 1 \ - -selectborderwidth 0 -textvariable newtablename + -background #fefefe -borderwidth 1 -selectborderwidth 0 \ + -textvariable ntw(newtablename) bind $base.etabn { focus .nt.einh } @@ -3190,49 +3247,56 @@ proc vTclWindow.nt {base} { -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ -relief raised -text Inherits entry $base.einh \ - -background #fefefe -borderwidth 1 -highlightthickness 1 \ - -selectborderwidth 0 -textvariable fathername + -background #fefefe -borderwidth 1 -selectborderwidth 0 \ + -textvariable ntw(fathername) bind $base.einh { focus .nt.e2 } button $base.binh \ -borderwidth 1 \ -command {if {[winfo exists .nt.ddf]} { - destroy .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} - } + create_drop_down .nt 378 25 220 + 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!=""} { + if {$ntw(fathername)==""} { + set ntw(fathername) "\"[.nt.ddf.lb get $i]\"" + } else { + set ntw(fathername) "$ntw(fathername),\"[.nt.ddf.lb get $i]\"" + } + } + if {$i!=""} {focus .nt.e2} + destroy .nt.ddf + break + } }} \ -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 + -background #fefefe -borderwidth 1 -selectborderwidth 0 \ + -textvariable ntw(fldname) bind $base.e2 { focus .nt.e1 } entry $base.e1 \ - -background #fefefe -borderwidth 1 -cursor {} -highlightthickness 1 \ - -selectborderwidth 0 -textvariable fldtype + -background #fefefe -borderwidth 1 -selectborderwidth 0 \ + -textvariable ntw(fldtype) bind $base.e1 { focus .nt.e5 } entry $base.e3 \ - -background #fefefe -borderwidth 1 -highlightthickness 1 \ - -selectborderwidth 0 -textvariable fldsize + -background #fefefe -borderwidth 1 -selectborderwidth 0 \ + -textvariable ntw(fldsize) bind $base.e3 { focus .nt.e5 } entry $base.e5 \ - -background #fefefe -borderwidth 1 -highlightthickness 1 \ - -selectborderwidth 0 -textvariable defaultval + -background #fefefe -borderwidth 1 -selectborderwidth 0 \ + -textvariable ntw(defaultval) bind $base.e5 { focus .nt.cb1 } @@ -3240,11 +3304,11 @@ proc vTclWindow.nt {base} { -borderwidth 1 \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ -offvalue { } -onvalue { NOT NULL} -text {field cannot be null} \ - -variable notnull + -variable ntw(notnull) label $base.lab1 \ -borderwidth 0 \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ - -relief raised -text {Field type} + -relief raised -text type label $base.lab2 \ -borderwidth 0 \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ @@ -3252,7 +3316,7 @@ proc vTclWindow.nt {base} { label $base.lab3 \ -borderwidth 0 \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ - -relief raised -text {Field size} + -relief raised -text size label $base.lab4 \ -borderwidth 0 \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ @@ -3270,40 +3334,16 @@ proc vTclWindow.nt {base} { -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 { - show_error "Your table has no fields!" - focus .nt.e2 -} else { - set temp "create table \"$newtablename\" ([join [.nt.lb get 0 end] ,])" - 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 - if {$retval} { - show_error "Error creating table\n$errmsg" - } else { - .nt.lb delete 0 end - Window destroy .nt - cmd_Tables - } -}} \ + -borderwidth 1 -command create_table \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ - -pady 3 -text {Create table} + -pady 3 -text Create listbox $base.lb \ -background #fefefe -borderwidth 1 \ -font -*-Clean-Medium-R-Normal--*-130-*-*-*-*-*-* \ - -highlightthickness 1 -selectborderwidth 0 \ - -yscrollcommand {.nt.sb set} + -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]] + set fldname [string trim [lindex [split [.nt.lb get [.nt.lb curselection]]] 0]] } } button $base.exitbtn \ @@ -3313,7 +3353,7 @@ proc vTclWindow.nt {base} { label $base.l1 \ -anchor w -borderwidth 1 \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ - -relief raised -text {field name} + -relief raised -text { field name} label $base.l2 \ -borderwidth 1 \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ @@ -3330,225 +3370,251 @@ proc vTclWindow.nt {base} { -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] - } + -command {if {[.nt.lb size]>1} { + 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] + } }} \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ - -pady 3 -text {Move field up} + -pady 3 -text {Move 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] - } + -command {if {[.nt.lb size]>1} { + 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] + } }} \ -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 + -pady 3 -text {Move down} button $base.button17 \ -borderwidth 1 \ - -command {if {[winfo exists .nt.ddf]} { - destroy .nt.ddf + -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} - } + create_drop_down .nt 291 80 97 + focus .nt.ddf.sb + .nt.ddf.lb insert end char varchar text int2 int4 serial float4 float8 money abstime date datetime interval reltime time timespan timestamp boolean box circle line lseg path point polygon + bind .nt.ddf.lb { + set i [.nt.ddf.lb curselection] + if {$i!=""} {set ntw(fldtype) [.nt.ddf.lb get $i]} + destroy .nt.ddf + if {$i!=""} {focus .nt.e3} + break + } }} \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ -highlightthickness 0 -padx 9 -pady 3 -takefocus 0 -text v - label $base.label18 \ + label $base.lco \ + -borderwidth 0 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -relief raised -text Constraint + entry $base.eco \ + -background #fefefe -borderwidth 1 -textvariable ntw(constraint) + label $base.lch \ + -borderwidth 0 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -relief raised -text check + entry $base.ech \ + -background #fefefe -borderwidth 1 -textvariable ntw(check) + label $base.ll \ + -borderwidth 1 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -relief raised + checkbutton $base.pk \ + -borderwidth 1 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -offvalue { } -onvalue * -text {primary key} -variable ntw(pk) + label $base.lpk \ -borderwidth 1 \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ - -relief sunken + -relief raised -text K ################### # SETTING GEOMETRY ################### place $base.etabn \ - -x 95 -y 7 -anchor nw -bordermode ignore + -x 85 -y 5 -width 156 -height 20 -anchor nw -bordermode ignore place $base.li \ - -x 10 -y 35 -anchor nw -bordermode ignore + -x 245 -y 7 -width 42 -height 16 -anchor nw -bordermode ignore place $base.einh \ - -x 95 -y 32 -anchor nw -bordermode ignore + -x 290 -y 5 -width 292 -height 20 -anchor nw -bordermode ignore place $base.binh \ - -x 242 -y 33 -width 16 -height 19 -anchor nw -bordermode ignore + -x 582 -y 6 -width 16 -height 19 -anchor nw -bordermode ignore place $base.e2 \ - -x 95 -y 80 -anchor nw -bordermode ignore + -x 85 -y 60 -width 156 -height 20 -anchor nw -bordermode ignore place $base.e1 \ - -x 95 -y 105 -anchor nw -bordermode ignore + -x 291 -y 60 -width 81 -height 20 -anchor nw -bordermode ignore place $base.e3 \ - -x 95 -y 130 -anchor nw -bordermode ignore + -x 445 -y 60 -width 46 -height 20 -anchor nw -bordermode ignore place $base.e5 \ - -x 95 -y 155 -anchor nw -bordermode ignore + -x 85 -y 82 -width 156 -height 20 -anchor nw -bordermode ignore place $base.cb1 \ - -x 95 -y 180 -anchor nw -bordermode ignore + -x 245 -y 83 -width 131 -height 20 -anchor nw -bordermode ignore place $base.lab1 \ - -x 10 -y 107 -anchor nw -bordermode ignore + -x 247 -y 62 -width 26 -height 16 -anchor nw -bordermode ignore place $base.lab2 \ - -x 10 -y 82 -anchor nw -bordermode ignore + -x 4 -y 62 -width 64 -height 16 -anchor nw -bordermode ignore place $base.lab3 \ - -x 10 -y 132 -anchor nw -bordermode ignore + -x 410 -y 62 -width 24 -height 16 -anchor nw -bordermode ignore place $base.lab4 \ - -x 10 -y 157 -anchor nw -bordermode ignore + -x 5 -y 83 -width 76 -height 16 -anchor nw -bordermode ignore place $base.addfld \ - -x 10 -y 220 -anchor nw -bordermode ignore + -x 534 -y 60 -width 75 -height 26 -anchor nw -bordermode ignore place $base.delfld \ - -x 85 -y 220 -width 82 -anchor nw -bordermode ignore + -x 534 -y 190 -width 75 -height 26 -anchor nw -bordermode ignore place $base.emptb \ - -x 170 -y 220 -anchor nw -bordermode ignore + -x 534 -y 220 -width 75 -height 26 -anchor nw -bordermode ignore place $base.maketbl \ - -x 10 -y 280 -width 156 -height 26 -anchor nw -bordermode ignore + -x 534 -y 365 -width 75 -height 26 -anchor nw -bordermode ignore place $base.lb \ - -x 260 -y 25 -width 353 -height 281 -anchor nw -bordermode ignore + -x 4 -y 121 -width 506 -height 269 -anchor nw -bordermode ignore place $base.exitbtn \ - -x 170 -y 280 -width 77 -height 26 -anchor nw -bordermode ignore + -x 534 -y 335 -width 75 -height 26 -anchor nw -bordermode ignore place $base.l1 \ - -x 261 -y 9 -width 98 -height 18 -anchor nw -bordermode ignore + -x 18 -y 105 -width 195 -height 18 -anchor nw -bordermode ignore place $base.l2 \ - -x 360 -y 9 -width 86 -height 18 -anchor nw -bordermode ignore + -x 213 -y 105 -width 88 -height 18 -anchor nw -bordermode ignore place $base.l3 \ - -x 446 -y 9 -width 166 -height 18 -anchor nw -bordermode ignore + -x 301 -y 105 -width 225 -height 18 -anchor nw -bordermode ignore place $base.sb \ - -x 610 -y 25 -width 18 -height 282 -anchor nw -bordermode ignore + -x 509 -y 121 -width 18 -height 269 -anchor nw -bordermode ignore place $base.l93 \ - -x 10 -y 10 -anchor nw -bordermode ignore + -x 4 -y 7 -width 67 -height 16 -anchor nw -bordermode ignore place $base.mvup \ - -x 10 -y 250 -width 118 -height 26 -anchor nw -bordermode ignore + -x 534 -y 120 -width 75 -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 + -x 534 -y 150 -width 75 -height 26 -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 + -x 372 -y 61 -width 16 -height 19 -anchor nw -bordermode ignore + place $base.lco \ + -x 5 -y 28 -width 58 -height 16 -anchor nw -bordermode ignore + place $base.eco \ + -x 85 -y 27 -width 156 -height 20 -anchor nw -bordermode ignore + place $base.lch \ + -x 245 -y 30 -anchor nw -bordermode ignore + place $base.ech \ + -x 290 -y 27 -width 308 -height 22 -anchor nw -bordermode ignore + place $base.ll \ + -x 5 -y 53 -width 591 -height 2 -anchor nw -bordermode ignore + place $base.pk \ + -x 407 -y 83 -width 93 -height 20 -anchor nw -bordermode ignore + place $base.lpk \ + -x 4 -y 105 -width 14 -height 18 -anchor nw -bordermode ignore } proc vTclWindow.pw {base} { - if {$base == ""} { - set base .pw - } - if {[winfo exists $base]} { - wm deiconify $base; return - } - ################### - # CREATING WIDGETS - ################### - toplevel $base -class Toplevel - wm focusmodel $base passive - wm geometry $base 322x167+210+219 - wm maxsize $base 1009 738 - wm minsize $base 1 1 - wm overrideredirect $base 0 - wm resizable $base 1 1 - wm title $base "Preferences" - label $base.l1 -borderwidth 0 -relief raised -text {Max rows displayed in table/query view} - entry $base.e1 -background #fefefe -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable pref(rows) - label $base.l2 -borderwidth 0 -relief raised -text Font - radiobutton $base.tvf -borderwidth 1 -text {fixed (clean)} -value clean -variable pref(tvfont) - radiobutton $base.tvfv -borderwidth 1 -text {proportional (helvetica)} -value helv -variable pref(tvfont) - label $base.ll -borderwidth 1 -relief sunken - checkbutton $base.alcb -borderwidth 1 -text {Auto-load the last opened database at startup} -variable pref(autoload) - button $base.okbtn -borderwidth 1 -command {if {$pref(rows)>200} { + if {$base == ""} { + set base .pw + } + if {[winfo exists $base]} { + wm deiconify $base; return + } + ################### + # CREATING WIDGETS + ################### + toplevel $base -class Toplevel + wm focusmodel $base passive + wm geometry $base 322x167+210+219 + wm maxsize $base 1009 738 + wm minsize $base 1 1 + wm overrideredirect $base 0 + wm resizable $base 1 1 + wm title $base "Preferences" + label $base.l1 -borderwidth 0 -relief raised -text {Max rows displayed in table/query view} + entry $base.e1 -background #fefefe -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable pref(rows) + label $base.l2 -borderwidth 0 -relief raised -text Font + radiobutton $base.tvf -borderwidth 1 -text {fixed (clean)} -value clean -variable pref(tvfont) + radiobutton $base.tvfv -borderwidth 1 -text {proportional (helvetica)} -value helv -variable pref(tvfont) + label $base.ll -borderwidth 1 -relief sunken + checkbutton $base.alcb -borderwidth 1 -text {Auto-load the last opened database at startup} -variable pref(autoload) + button $base.okbtn -borderwidth 1 -command {if {$pref(rows)>200} { tk_messageBox -title Warning -message "A big number of rows displayed in table view will take a lot of memory!" } save_pref Window destroy .pw} -padx 9 -pady 3 -text Ok - ################### - # SETTING GEOMETRY - ################### - place $base.l1 -x 10 -y 20 -anchor nw -bordermode ignore - place $base.e1 -x 245 -y 17 -width 65 -height 24 -anchor nw -bordermode ignore - place $base.l2 -x 10 -y 53 -anchor nw -bordermode ignore - place $base.tvf -x 50 -y 50 -anchor nw -bordermode ignore - place $base.tvfv -x 155 -y 50 -anchor nw -bordermode ignore - place $base.ll -x 10 -y 85 -width 301 -height 2 -anchor nw -bordermode ignore - place $base.alcb -x 10 -y 95 -anchor nw -bordermode ignore - place $base.okbtn -x 125 -y 135 -width 80 -height 26 -anchor nw -bordermode ignore + ################### + # SETTING GEOMETRY + ################### + place $base.l1 -x 10 -y 20 -anchor nw -bordermode ignore + place $base.e1 -x 245 -y 17 -width 65 -height 24 -anchor nw -bordermode ignore + place $base.l2 -x 10 -y 53 -anchor nw -bordermode ignore + place $base.tvf -x 50 -y 50 -anchor nw -bordermode ignore + place $base.tvfv -x 155 -y 50 -anchor nw -bordermode ignore + place $base.ll -x 10 -y 85 -width 301 -height 2 -anchor nw -bordermode ignore + place $base.alcb -x 10 -y 95 -anchor nw -bordermode ignore + place $base.okbtn -x 125 -y 135 -width 80 -height 26 -anchor nw -bordermode ignore } proc vTclWindow.qb {base} { - if {$base == ""} { - set base .qb - } - if {[winfo exists $base]} { - wm deiconify $base; return - } - ################### - # CREATING WIDGETS - ################### - toplevel $base -class Toplevel -cursor top_left_arrow - wm focusmodel $base passive - wm geometry $base 442x344+150+150 - 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 -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 + if {$base == ""} { + set base .qb + } + if {[winfo exists $base]} { + wm deiconify $base; return + } + ################### + # CREATING WIDGETS + ################### + toplevel $base -class Toplevel -cursor top_left_arrow + wm focusmodel $base passive + wm geometry $base 442x344+150+150 + 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 -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 { - set qcmd [.qb.text1 get 1.0 end] - regsub -all "\n" $qcmd " " qcmd - if {$qcmd==""} then { + set qcmd [.qb.text1 get 1.0 end] + regsub -all "\n" $qcmd " " qcmd + if {$qcmd==""} then { show_error "This query has no commands ?" - } else { - if { [lindex [split [string toupper [string trim $qcmd]]] 0] == "SELECT" } { - set qtype S - } else { - set qtype A - } - if {$cbv} { - tk_messageBox -message "create view $queryname as $qcmd" - set retval [catch {set pgres [pg_exec $dbc "create view $queryname as $qcmd"]} errmsg] - if {$retval} { - show_error "Error defining view\n\n$errmsg" - } else { - tab_click .dw.tabViews - Window destroy .qb - } - } else { - regsub -all "'" $qcmd "''" qcmd - cursor_watch .qb - set retval [catch { - if {$queryoid==0} then { - set pgres [pg_exec $dbc "insert into pga_queries values ('$queryname','$qtype','$qcmd')"] - } else { - set pgres [pg_exec $dbc "update pga_queries set queryname='$queryname',querytype='$qtype',querycommand='$qcmd' where oid=$queryoid"] - } - } errmsg] - cursor_arrow .qb - if {$retval} then { - show_error "Error executing query\n$errmsg" + } else { + if { [lindex [split [string toupper [string trim $qcmd]]] 0] == "SELECT" } { + set qtype S } else { - cmd_Queries - if {$queryoid==0} {set queryoid [pg_result $pgres -oid]} + set qtype A } - } - catch {pg_result $pgres -clear} - } + if {$cbv} { + set pgres [wpg_exec $dbc "create view $queryname as $qcmd"] + if {$pgsql(status)!="PGRES_COMMAND_OK"} { + show_error "Error defining view\n\n$pgsql(errmsg)" + } else { + tab_click .dw.tabViews + Window destroy .qb + } + catch {pg_result $pgres -clear} + } else { + regsub -all "'" $qcmd "''" qcmd + cursor_clock + if {$queryoid==0} then { + set pgres [wpg_exec $dbc "insert into pga_queries values ('$queryname','$qtype','$qcmd')"] + } else { + set pgres [wpg_exec $dbc "update pga_queries set queryname='$queryname',querytype='$qtype',querycommand='$qcmd' where oid=$queryoid"] + } + cursor_normal + if {$pgsql(status)!="PGRES_COMMAND_OK"} then { + show_error "Error executing query\n$pgres(errmsg)" + } else { + cmd_Queries + if {$queryoid==0} {set queryoid [pg_result $pgres -oid]} + } + } + catch {pg_result $pgres -clear} + } }} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text {Save query definition} - button $base.execbtn -borderwidth 1 -command { + button $base.execbtn -borderwidth 1 -command { set qcmd [.qb.text1 get 0.0 end] regsub -all "\n" [string trim $qcmd] " " qcmd if {[lindex [split [string toupper $qcmd]] 0]!="SELECT"} { @@ -3565,71 +3631,71 @@ if {[lindex [split [string toupper $qcmd]] 0]!="SELECT"} { mw_select_records $mw(query) } } -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 + button $base.termbtn -borderwidth 1 -command {.qb.cbv configure -state normal set cbv 0 set queryname {} .qb.text1 delete 1.0 end 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 + 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} -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 + ################### + # 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 } proc vTclWindow.ql {base} { - if {$base == ""} { - set base .ql - } - if {[winfo exists $base]} { - wm deiconify $base; return - } - ################### - # CREATING WIDGETS - ################### - toplevel $base -class Toplevel -cursor top_left_arrow - wm focusmodel $base passive - wm geometry $base 759x530+10+13 - 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 - } - bind $base { - qlc_click %x %y %W - } - bind $base { - ql_dragstop %x %y - } - bind $base { - ql_delete_object - } - canvas $base.c -background #fefefe -borderwidth 2 -height 207 -relief ridge -takefocus 0 -width 295 - button $base.exitbtn -borderwidth 1 -command { + if {$base == ""} { + set base .ql + } + if {[winfo exists $base]} { + wm deiconify $base; return + } + ################### + # CREATING WIDGETS + ################### + toplevel $base -class Toplevel -cursor top_left_arrow + wm focusmodel $base passive + wm geometry $base 759x530+10+13 + 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 + } + bind $base { + qlc_click %x %y %W + } + bind $base { + ql_dragstop %x %y + } + bind $base { + ql_delete_object + } + canvas $base.c -background #fefefe -borderwidth 2 -height 207 -relief ridge -takefocus 0 -width 295 + 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 - } - button $base.execbtn -borderwidth 1 -command { + 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 + } + button $base.execbtn -borderwidth 1 -command { set qcmd [ql_compute_sql] set mw(layout_name) nolayoutneeded set mw(query) [subst $qcmd] @@ -3638,58 +3704,61 @@ set mw(isaquery) 1 Window show .mw mw_load_layout $mw(layout_name) mw_select_records $mw(query)} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -pady 3 -text {Execute SQL} - button $base.stoqb -borderwidth 1 -command {Window show .qb + button $base.stoqb -borderwidth 1 -command {Window show .qb .qb.text1 delete 1.0 end .qb.text1 insert end [ql_compute_sql] 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 + 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} - } + create_drop_down .ql 70 27 200 + 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] + ql_add_new_table + } + destroy .ql.ddf + break + } }} -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.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 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.bdd -x 200 -y 7 -width 17 -height 20 -anchor nw -bordermode ignore + ################### + # SETTING GEOMETRY + ################### + place $base.c -x 5 -y 30 -width 748 -height 500 -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 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.bdd -x 200 -y 7 -width 17 -height 20 -anchor nw -bordermode ignore } proc vTclWindow.rf {base} { - if {$base == ""} { - set base .rf - } - if {[winfo exists $base]} { - wm deiconify $base; return - } - ################### - # CREATING WIDGETS - ################### - toplevel $base -class Toplevel - wm focusmodel $base passive - wm geometry $base 272x105+294+262 - wm maxsize $base 1009 738 - wm minsize $base 1 1 - wm overrideredirect $base 0 - wm resizable $base 0 0 - wm title $base "Rename" - label $base.l1 -borderwidth 0 -relief raised -text {New name} - entry $base.e1 -background #fefefe -borderwidth 1 -textvariable newobjname - button $base.b1 -borderwidth 1 -command { + if {$base == ""} { + set base .rf + } + if {[winfo exists $base]} { + wm deiconify $base; return + } + ################### + # CREATING WIDGETS + ################### + toplevel $base -class Toplevel + wm focusmodel $base passive + wm geometry $base 272x105+294+262 + wm maxsize $base 1009 738 + wm minsize $base 1 1 + wm overrideredirect $base 0 + wm resizable $base 0 0 + wm title $base "Rename" + label $base.l1 -borderwidth 0 -relief raised -text {New name} + entry $base.e1 -background #fefefe -borderwidth 1 -textvariable newobjname + button $base.b1 -borderwidth 1 -command { if {$newobjname==""} { show_error "You must give object a new name!" } elseif {$activetab=="Tables"} { @@ -3700,355 +3769,355 @@ proc vTclWindow.rf {base} { Window destroy .rf } } elseif {$activetab=="Queries"} { - set retval [catch {set pgres [pg_exec $dbc "select * from pga_queries where queryname='$newobjname'"]} errmsg] - if {$retval} { - show_error $errmsg + set pgres [wpg_exec $dbc "select * from pga_queries where queryname='$newobjname'"] + if {$pgsql(status)!="PGRES_TUPLES_OK"} { + show_error "Error retrieving from pga_queries\n$pgsql(errmsg)\n$pgsql(status)" } elseif {[pg_result $pgres -numTuples]>0} { - show_error "Query $newobjname already exists!" - pg_result $pgres -clear + show_error "Query \"$newobjname\" already exists!" } else { - pg_result $pgres -clear 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 destroy .rf } + catch {pg_result $pgres -clear} } - } -padx 9 -pady 3 -text Rename - button $base.b2 -borderwidth 1 -command {Window destroy .rf} -padx 9 -pady 3 -text Cancel - ################### - # SETTING GEOMETRY - ################### - place $base.l1 -x 15 -y 28 -anchor nw -bordermode ignore - place $base.e1 -x 100 -y 25 -anchor nw -bordermode ignore - place $base.b1 -x 65 -y 65 -width 70 -anchor nw -bordermode ignore - place $base.b2 -x 145 -y 65 -width 70 -anchor nw -bordermode ignore + } -padx 9 -pady 3 -text Rename + button $base.b2 -borderwidth 1 -command {Window destroy .rf} -padx 9 -pady 3 -text Cancel + ################### + # SETTING GEOMETRY + ################### + place $base.l1 -x 15 -y 28 -anchor nw -bordermode ignore + place $base.e1 -x 100 -y 25 -anchor nw -bordermode ignore + place $base.b1 -x 65 -y 65 -width 70 -anchor nw -bordermode ignore + 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+120 - 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 { + 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+120 + 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"} { + -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"} { + } + 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] + } + 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 + -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 - } + create_drop_down .rb 405 22 200 + 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]} + destroy .rb.ddf + rb_get_report_fields + break + } }} \ - -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 + -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+230+50 - 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 + 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+230+50 + 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 - } - if {[winfo exists $base]} { - wm deiconify $base; return - } - ################### - # CREATING WIDGETS - ################### - toplevel $base -class Toplevel - wm focusmodel $base passive - wm geometry $base 310x223+245+158 - wm maxsize $base 1009 738 - wm minsize $base 1 1 - wm overrideredirect $base 0 - wm resizable $base 0 0 - wm title $base "Sequence" - label $base.l1 -anchor w -borderwidth 0 -relief raised -text {Sequence name} - entry $base.e1 -borderwidth 1 -highlightthickness 1 -textvariable seq_name - label $base.l2 -borderwidth 0 -relief raised -text Increment - entry $base.e2 -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable seq_inc - label $base.l3 -borderwidth 0 -relief raised -text {Start value} - entry $base.e3 -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable seq_start - label $base.l4 -borderwidth 0 -relief raised -text Minvalue - entry $base.e4 -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable seq_minval - label $base.l5 -borderwidth 0 -relief raised -text Maxvalue - entry $base.e5 -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable seq_maxval - button $base.defbtn -borderwidth 1 -command { - if {$seq_name==""} { - show_error "You should supply a name for this sequence" - } else { + if {$base == ""} { + set base .sqf + } + if {[winfo exists $base]} { + wm deiconify $base; return + } + ################### + # CREATING WIDGETS + ################### + toplevel $base -class Toplevel + wm focusmodel $base passive + wm geometry $base 310x223+245+158 + wm maxsize $base 1009 738 + wm minsize $base 1 1 + wm overrideredirect $base 0 + wm resizable $base 0 0 + wm title $base "Sequence" + label $base.l1 -anchor w -borderwidth 0 -relief raised -text {Sequence name} + entry $base.e1 -borderwidth 1 -highlightthickness 1 -textvariable seq_name + label $base.l2 -borderwidth 0 -relief raised -text Increment + entry $base.e2 -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable seq_inc + label $base.l3 -borderwidth 0 -relief raised -text {Start value} + entry $base.e3 -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable seq_start + label $base.l4 -borderwidth 0 -relief raised -text Minvalue + entry $base.e4 -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable seq_minval + label $base.l5 -borderwidth 0 -relief raised -text Maxvalue + entry $base.e5 -borderwidth 1 -highlightthickness 1 -selectborderwidth 0 -textvariable seq_maxval + button $base.defbtn -borderwidth 1 -command { + if {$seq_name==""} { + show_error "You should supply a name for this sequence" + } else { set s1 {};set s2 {};set s3 {};set s4 {}; if {$seq_inc!=""} {set s1 "increment $seq_inc"}; if {$seq_start!=""} {set s2 "start $seq_start"}; @@ -4059,60 +4128,60 @@ proc vTclWindow.sqf {base} { cmd_Sequences tk_messageBox -title Information -message "Sequence created!" } - } - } -padx 9 -pady 3 -text {Define sequence} - button $base.closebtn -borderwidth 1 -command {for {set i 1} {$i<6} {incr i} { - .sqf.e$i configure -state normal - .sqf.e$i delete 0 end - .sqf.defbtn configure -state normal - .sqf.l3 configure -text {Start value} + } + } -padx 9 -pady 3 -text {Define sequence} + button $base.closebtn -borderwidth 1 -command {for {set i 1} {$i<6} {incr i} { + .sqf.e$i configure -state normal + .sqf.e$i delete 0 end + .sqf.defbtn configure -state normal + .sqf.l3 configure -text {Start value} } place .sqf.defbtn -x 40 -y 175 Window destroy .sqf } -padx 9 -pady 3 -text Close - ################### - # SETTING GEOMETRY - ################### - place $base.l1 -x 20 -y 20 -width 111 -height 18 -anchor nw -bordermode ignore - place $base.e1 -x 135 -y 19 -anchor nw -bordermode ignore - place $base.l2 -x 20 -y 50 -anchor nw -bordermode ignore - place $base.e2 -x 135 -y 49 -anchor nw -bordermode ignore - place $base.l3 -x 20 -y 80 -anchor nw -bordermode ignore - place $base.e3 -x 135 -y 79 -anchor nw -bordermode ignore - place $base.l4 -x 20 -y 110 -anchor nw -bordermode ignore - place $base.e4 -x 135 -y 109 -anchor nw -bordermode ignore - place $base.l5 -x 20 -y 140 -anchor nw -bordermode ignore - place $base.e5 -x 135 -y 139 -anchor nw -bordermode ignore - place $base.defbtn -x 40 -y 175 -anchor nw -bordermode ignore - place $base.closebtn -x 195 -y 175 -anchor nw -bordermode ignore + ################### + # SETTING GEOMETRY + ################### + place $base.l1 -x 20 -y 20 -width 111 -height 18 -anchor nw -bordermode ignore + place $base.e1 -x 135 -y 19 -anchor nw -bordermode ignore + place $base.l2 -x 20 -y 50 -anchor nw -bordermode ignore + place $base.e2 -x 135 -y 49 -anchor nw -bordermode ignore + place $base.l3 -x 20 -y 80 -anchor nw -bordermode ignore + place $base.e3 -x 135 -y 79 -anchor nw -bordermode ignore + place $base.l4 -x 20 -y 110 -anchor nw -bordermode ignore + place $base.e4 -x 135 -y 109 -anchor nw -bordermode ignore + place $base.l5 -x 20 -y 140 -anchor nw -bordermode ignore + place $base.e5 -x 135 -y 139 -anchor nw -bordermode ignore + place $base.defbtn -x 40 -y 175 -anchor nw -bordermode ignore + 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+192+152 - 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!" + 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+192+152 + 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 @@ -4120,368 +4189,368 @@ proc vTclWindow.sw {base} { 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 + ################### + # 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 - } - if {[winfo exists $base]} { - wm deiconify $base; return - } - ################### - # CREATING WIDGETS - ################### - toplevel $base -class Toplevel - wm focusmodel $base passive - wm geometry $base 390x460+243+20 - wm maxsize $base 1009 738 - wm minsize $base 1 1 - 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 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 - ################### - # 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 + if {$base == ""} { + set base .tiw + } + if {[winfo exists $base]} { + wm deiconify $base; return + } + ################### + # CREATING WIDGETS + ################### + toplevel $base -class Toplevel + wm focusmodel $base passive + wm geometry $base 390x460+243+20 + wm maxsize $base 1009 738 + wm minsize $base 1 1 + 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 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 + ################### + # 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 } proc vTclWindow.fd {base} { - if {$base == ""} { - set base .fd - } - if {[winfo exists $base]} { - wm deiconify $base; return - } - ################### - # CREATING WIDGETS - ################### - toplevel $base -class Toplevel - wm focusmodel $base passive - wm geometry $base 377x315+103+101 - wm maxsize $base 785 570 - wm minsize $base 1 1 - wm overrideredirect $base 0 - wm resizable $base 1 1 - wm deiconify $base - wm title $base "Form design" - bind $base { - fd_delete_object - } - canvas $base.c \ - -background #828282 -height 207 -highlightthickness 0 -relief ridge \ - -selectborderwidth 0 -width 295 - bind $base.c { - fd_mouse_down %x %y - } - bind $base.c { - fd_mouse_up %x %y - } - bind $base.c { - fd_mouse_move %x %y - } - ################### - # SETTING GEOMETRY - ################### - pack $base.c \ - -in .fd -anchor center -expand 1 -fill both -side top + if {$base == ""} { + set base .fd + } + if {[winfo exists $base]} { + wm deiconify $base; return + } + ################### + # CREATING WIDGETS + ################### + toplevel $base -class Toplevel + wm focusmodel $base passive + wm geometry $base 377x315+103+101 + wm maxsize $base 785 570 + wm minsize $base 1 1 + wm overrideredirect $base 0 + wm resizable $base 1 1 + wm deiconify $base + wm title $base "Form design" + bind $base { + fd_delete_object + } + canvas $base.c \ + -background #828282 -height 207 -highlightthickness 0 -relief ridge \ + -selectborderwidth 0 -width 295 + bind $base.c { + fd_mouse_down %x %y + } + bind $base.c { + fd_mouse_up %x %y + } + bind $base.c { + fd_mouse_move %x %y + } + ################### + # SETTING GEOMETRY + ################### + pack $base.c \ + -in .fd -anchor center -expand 1 -fill both -side top } proc vTclWindow.fda {base} { - if {$base == ""} { - set base .fda - } - if {[winfo exists $base]} { - wm deiconify $base; return - } - ################### - # CREATING WIDGETS - ################### - toplevel $base -class Toplevel - wm focusmodel $base passive - wm geometry $base 225x197+561+0 - wm maxsize $base 785 570 - wm minsize $base 1 1 - wm overrideredirect $base 0 - wm resizable $base 1 1 - wm deiconify $base - wm title $base "Attributes" - label $base.l1 \ - -anchor nw -borderwidth 0 \ - -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ - -justify left -text Name -width 8 - entry $base.e1 \ - -background #fefefe -borderwidth 1 -highlightthickness 0 \ - -selectborderwidth 0 -textvariable fdvar(c_name) - bind $base.e1 { - fd_set_name - } - label $base.l2 \ - -anchor nw -borderwidth 0 \ - -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ - -justify left -text Top -width 8 - entry $base.e2 \ - -background #fefefe -borderwidth 1 -highlightthickness 0 \ - -selectborderwidth 0 -textvariable fdvar(c_top) - bind $base.e2 { - fd_change_coord - } - label $base.l3 \ - -anchor w -borderwidth 0 \ - -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -text Left \ - -width 8 - entry $base.e3 \ - -background #fefefe -borderwidth 1 -highlightthickness 0 \ - -selectborderwidth 0 -textvariable fdvar(c_left) - bind $base.e3 { - fd_change_coord - } - label $base.l4 \ - -anchor w -borderwidth 0 \ - -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -text Width \ - -width 8 - entry $base.e4 \ - -background #fefefe -borderwidth 1 -highlightthickness 0 \ - -selectborderwidth 0 -textvariable fdvar(c_width) - bind $base.e4 { - fd_change_coord - } - label $base.l5 \ - -anchor w -borderwidth 0 \ - -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 0 \ - -text Height -width 8 - entry $base.e5 \ - -background #fefefe -borderwidth 1 -highlightthickness 0 \ - -selectborderwidth 0 -textvariable fdvar(c_height) - bind $base.e5 { - fd_change_coord - } - label $base.l6 \ - -borderwidth 0 \ - -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 0 \ - -text Command - entry $base.e6 \ - -background #fefefe -borderwidth 1 -highlightthickness 0 \ - -selectborderwidth 0 -textvariable fdvar(c_cmd) - bind $base.e6 { - fd_set_command - } - button $base.bcmd \ - -borderwidth 1 \ - -command {Window show .fdcmd + if {$base == ""} { + set base .fda + } + if {[winfo exists $base]} { + wm deiconify $base; return + } + ################### + # CREATING WIDGETS + ################### + toplevel $base -class Toplevel + wm focusmodel $base passive + wm geometry $base 225x197+561+0 + wm maxsize $base 785 570 + wm minsize $base 1 1 + wm overrideredirect $base 0 + wm resizable $base 1 1 + wm deiconify $base + wm title $base "Attributes" + label $base.l1 \ + -anchor nw -borderwidth 0 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -justify left -text Name -width 8 + entry $base.e1 \ + -background #fefefe -borderwidth 1 -highlightthickness 0 \ + -selectborderwidth 0 -textvariable fdvar(c_name) + bind $base.e1 { + fd_set_name + } + label $base.l2 \ + -anchor nw -borderwidth 0 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -justify left -text Top -width 8 + entry $base.e2 \ + -background #fefefe -borderwidth 1 -highlightthickness 0 \ + -selectborderwidth 0 -textvariable fdvar(c_top) + bind $base.e2 { + fd_change_coord + } + label $base.l3 \ + -anchor w -borderwidth 0 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -text Left \ + -width 8 + entry $base.e3 \ + -background #fefefe -borderwidth 1 -highlightthickness 0 \ + -selectborderwidth 0 -textvariable fdvar(c_left) + bind $base.e3 { + fd_change_coord + } + label $base.l4 \ + -anchor w -borderwidth 0 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -text Width \ + -width 8 + entry $base.e4 \ + -background #fefefe -borderwidth 1 -highlightthickness 0 \ + -selectborderwidth 0 -textvariable fdvar(c_width) + bind $base.e4 { + fd_change_coord + } + label $base.l5 \ + -anchor w -borderwidth 0 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 0 \ + -text Height -width 8 + entry $base.e5 \ + -background #fefefe -borderwidth 1 -highlightthickness 0 \ + -selectborderwidth 0 -textvariable fdvar(c_height) + bind $base.e5 { + fd_change_coord + } + label $base.l6 \ + -borderwidth 0 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 0 \ + -text Command + entry $base.e6 \ + -background #fefefe -borderwidth 1 -highlightthickness 0 \ + -selectborderwidth 0 -textvariable fdvar(c_cmd) + bind $base.e6 { + fd_set_command + } + button $base.bcmd \ + -borderwidth 1 \ + -command {Window show .fdcmd .fdcmd.f.txt delete 1.0 end .fdcmd.f.txt insert end $fdvar(c_cmd)} \ - -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 3 \ - -pady 3 -text ... -width 1 - label $base.l7 \ - -anchor w -borderwidth 0 \ - -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ - -text Variable -width 8 - entry $base.e7 \ - -background #fefefe -borderwidth 1 -highlightthickness 0 \ - -selectborderwidth 0 -textvariable fdvar(c_var) - bind $base.e7 { - set fdobj($fdvar(moveitemobj),v) $fdvar(c_var) - } - label $base.l8 \ - -anchor w -borderwidth 0 \ - -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -text Text \ - -width 8 - entry $base.e8 \ - -background #fefefe -borderwidth 1 -highlightthickness 0 \ - -selectborderwidth 0 -textvariable fdvar(c_text) - bind $base.e8 { - fd_set_text - } - label $base.l0 \ - -borderwidth 1 -relief raised -text {checkbox .udf0.checkbox17} \ - -textvariable fdvar(c_info) -width 28 - ################### - # SETTING GEOMETRY - ################### - grid $base.l1 \ - -in .fda -column 0 -row 1 -columnspan 1 -rowspan 1 - grid $base.e1 \ - -in .fda -column 1 -row 1 -columnspan 1 -rowspan 1 -pady 2 - grid $base.l2 \ - -in .fda -column 0 -row 2 -columnspan 1 -rowspan 1 - grid $base.e2 \ - -in .fda -column 1 -row 2 -columnspan 1 -rowspan 1 - grid $base.l3 \ - -in .fda -column 0 -row 3 -columnspan 1 -rowspan 1 - grid $base.e3 \ - -in .fda -column 1 -row 3 -columnspan 1 -rowspan 1 -pady 2 - grid $base.l4 \ - -in .fda -column 0 -row 4 -columnspan 1 -rowspan 1 - grid $base.e4 \ - -in .fda -column 1 -row 4 -columnspan 1 -rowspan 1 - grid $base.l5 \ - -in .fda -column 0 -row 5 -columnspan 1 -rowspan 1 - grid $base.e5 \ - -in .fda -column 1 -row 5 -columnspan 1 -rowspan 1 -pady 2 - grid $base.l6 \ - -in .fda -column 0 -row 6 -columnspan 1 -rowspan 1 - grid $base.e6 \ - -in .fda -column 1 -row 6 -columnspan 1 -rowspan 1 - grid $base.bcmd \ - -in .fda -column 2 -row 6 -columnspan 1 -rowspan 1 - grid $base.l7 \ - -in .fda -column 0 -row 7 -columnspan 1 -rowspan 1 - grid $base.e7 \ - -in .fda -column 1 -row 7 -columnspan 1 -rowspan 1 - grid $base.l8 \ - -in .fda -column 0 -row 8 -columnspan 1 -rowspan 1 - grid $base.e8 \ - -in .fda -column 1 -row 8 -columnspan 1 -rowspan 1 -pady 2 - grid $base.l0 \ - -in .fda -column 0 -row 0 -columnspan 2 -rowspan 1 + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 3 \ + -pady 3 -text ... -width 1 + label $base.l7 \ + -anchor w -borderwidth 0 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -text Variable -width 8 + entry $base.e7 \ + -background #fefefe -borderwidth 1 -highlightthickness 0 \ + -selectborderwidth 0 -textvariable fdvar(c_var) + bind $base.e7 { + set fdobj($fdvar(moveitemobj),v) $fdvar(c_var) + } + label $base.l8 \ + -anchor w -borderwidth 0 \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -text Text \ + -width 8 + entry $base.e8 \ + -background #fefefe -borderwidth 1 -highlightthickness 0 \ + -selectborderwidth 0 -textvariable fdvar(c_text) + bind $base.e8 { + fd_set_text + } + label $base.l0 \ + -borderwidth 1 -relief raised -text {checkbox .udf0.checkbox17} \ + -textvariable fdvar(c_info) -width 28 + ################### + # SETTING GEOMETRY + ################### + grid $base.l1 \ + -in .fda -column 0 -row 1 -columnspan 1 -rowspan 1 + grid $base.e1 \ + -in .fda -column 1 -row 1 -columnspan 1 -rowspan 1 -pady 2 + grid $base.l2 \ + -in .fda -column 0 -row 2 -columnspan 1 -rowspan 1 + grid $base.e2 \ + -in .fda -column 1 -row 2 -columnspan 1 -rowspan 1 + grid $base.l3 \ + -in .fda -column 0 -row 3 -columnspan 1 -rowspan 1 + grid $base.e3 \ + -in .fda -column 1 -row 3 -columnspan 1 -rowspan 1 -pady 2 + grid $base.l4 \ + -in .fda -column 0 -row 4 -columnspan 1 -rowspan 1 + grid $base.e4 \ + -in .fda -column 1 -row 4 -columnspan 1 -rowspan 1 + grid $base.l5 \ + -in .fda -column 0 -row 5 -columnspan 1 -rowspan 1 + grid $base.e5 \ + -in .fda -column 1 -row 5 -columnspan 1 -rowspan 1 -pady 2 + grid $base.l6 \ + -in .fda -column 0 -row 6 -columnspan 1 -rowspan 1 + grid $base.e6 \ + -in .fda -column 1 -row 6 -columnspan 1 -rowspan 1 + grid $base.bcmd \ + -in .fda -column 2 -row 6 -columnspan 1 -rowspan 1 + grid $base.l7 \ + -in .fda -column 0 -row 7 -columnspan 1 -rowspan 1 + grid $base.e7 \ + -in .fda -column 1 -row 7 -columnspan 1 -rowspan 1 + grid $base.l8 \ + -in .fda -column 0 -row 8 -columnspan 1 -rowspan 1 + grid $base.e8 \ + -in .fda -column 1 -row 8 -columnspan 1 -rowspan 1 -pady 2 + grid $base.l0 \ + -in .fda -column 0 -row 0 -columnspan 2 -rowspan 1 } proc vTclWindow.fdcmd {base} { - if {$base == ""} { - set base .fdcmd - } - if {[winfo exists $base]} { - wm deiconify $base; return - } - ################### - # CREATING WIDGETS - ################### - toplevel $base -class Toplevel - wm focusmodel $base passive - wm geometry $base 282x274+504+229 - wm maxsize $base 785 570 - wm minsize $base 1 19 - wm overrideredirect $base 0 - wm resizable $base 1 1 - wm title $base "Command" - frame $base.f \ - -borderwidth 2 -height 75 -relief groove -width 125 - scrollbar $base.f.sb \ - -borderwidth 1 -command {.fdcmd.f.txt yview} -orient vert -width 12 - text $base.f.txt \ - -font -*-Clean-Medium-R-Normal--*-130-*-*-*-*-*-* -height 1 \ - -width 115 -yscrollcommand {.fdcmd.f.sb set} - frame $base.fb \ - -height 75 -width 125 - button $base.fb.b1 \ - -borderwidth 1 \ - -command {set fdvar(c_cmd) [.fdcmd.f.txt get 1.0 "end - 1 chars"] + if {$base == ""} { + set base .fdcmd + } + if {[winfo exists $base]} { + wm deiconify $base; return + } + ################### + # CREATING WIDGETS + ################### + toplevel $base -class Toplevel + wm focusmodel $base passive + wm geometry $base 282x274+504+229 + wm maxsize $base 785 570 + wm minsize $base 1 19 + wm overrideredirect $base 0 + wm resizable $base 1 1 + wm title $base "Command" + frame $base.f \ + -borderwidth 2 -height 75 -relief groove -width 125 + scrollbar $base.f.sb \ + -borderwidth 1 -command {.fdcmd.f.txt yview} -orient vert -width 12 + text $base.f.txt \ + -font -*-Clean-Medium-R-Normal--*-130-*-*-*-*-*-* -height 1 \ + -width 115 -yscrollcommand {.fdcmd.f.sb set} + frame $base.fb \ + -height 75 -width 125 + button $base.fb.b1 \ + -borderwidth 1 \ + -command {set fdvar(c_cmd) [.fdcmd.f.txt get 1.0 "end - 1 chars"] Window hide .fdcmd fd_set_command} \ - -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ - -pady 3 -text Ok -width 5 - button $base.fb.b2 \ - -borderwidth 1 -command {Window hide .fdcmd} \ - -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ - -pady 3 -text Cancel - ################### - # SETTING GEOMETRY - ################### - pack $base.f \ - -in .fdcmd -anchor center -expand 1 -fill both -side top - pack $base.f.sb \ - -in .fdcmd.f -anchor e -expand 1 -fill y -side right - pack $base.f.txt \ - -in .fdcmd.f -anchor center -expand 1 -fill both -side top - pack $base.fb \ - -in .fdcmd -anchor center -expand 0 -fill none -side top - pack $base.fb.b1 \ - -in .fdcmd.fb -anchor center -expand 0 -fill none -side left - pack $base.fb.b2 \ - -in .fdcmd.fb -anchor center -expand 0 -fill none -side top + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ + -pady 3 -text Ok -width 5 + button $base.fb.b2 \ + -borderwidth 1 -command {Window hide .fdcmd} \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ + -pady 3 -text Cancel + ################### + # SETTING GEOMETRY + ################### + pack $base.f \ + -in .fdcmd -anchor center -expand 1 -fill both -side top + pack $base.f.sb \ + -in .fdcmd.f -anchor e -expand 1 -fill y -side right + pack $base.f.txt \ + -in .fdcmd.f -anchor center -expand 1 -fill both -side top + pack $base.fb \ + -in .fdcmd -anchor center -expand 0 -fill none -side top + pack $base.fb.b1 \ + -in .fdcmd.fb -anchor center -expand 0 -fill none -side left + pack $base.fb.b2 \ + -in .fdcmd.fb -anchor center -expand 0 -fill none -side top } proc vTclWindow.fdmenu {base} { - if {$base == ""} { - set base .fdmenu - } - if {[winfo exists $base]} { - wm deiconify $base; return - } - ################### - # CREATING WIDGETS - ################### - toplevel $base -class Toplevel - wm focusmodel $base passive - wm geometry $base 288x70+103+0 - wm maxsize $base 785 570 - wm minsize $base 1 1 - wm overrideredirect $base 0 - wm resizable $base 0 0 - wm deiconify $base - wm title $base "Commands" - button $base.but17 \ - -borderwidth 1 \ - -command {if {[tk_messageBox -title Warning -message "Delete all objects ?" -type yesno -default no]=="no"} return + if {$base == ""} { + set base .fdmenu + } + if {[winfo exists $base]} { + wm deiconify $base; return + } + ################### + # CREATING WIDGETS + ################### + toplevel $base -class Toplevel + wm focusmodel $base passive + wm geometry $base 288x70+103+0 + wm maxsize $base 785 570 + wm minsize $base 1 1 + wm overrideredirect $base 0 + wm resizable $base 0 0 + wm deiconify $base + wm title $base "Commands" + button $base.but17 \ + -borderwidth 1 \ + -command {if {[tk_messageBox -title Warning -message "Delete all objects ?" -type yesno -default no]=="no"} return fd_init} \ - -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ - -pady 3 -text {Delete all} - button $base.but18 \ - -borderwidth 1 -command {set fdvar(geometry) [wm geometry .fd] ; fd_test } \ - -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ - -pady 3 -text {Test form} - button $base.but19 \ - -borderwidth 1 -command {destroy .$fdvar(forminame)} \ - -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ - -pady 3 -text {Close test form} - button $base.bex \ - -borderwidth 1 \ - -command {if {[fd_save_form $fdvar(formname)]==1} { + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ + -pady 3 -text {Delete all} + button $base.but18 \ + -borderwidth 1 -command {set fdvar(geometry) [wm geometry .fd] ; fd_test } \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ + -pady 3 -text {Test form} + button $base.but19 \ + -borderwidth 1 -command {destroy .$fdvar(forminame)} \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ + -pady 3 -text {Close test form} + button $base.bex \ + -borderwidth 1 \ + -command {if {[fd_save_form $fdvar(formname)]==1} { catch {Window destroy .fd} catch {Window destroy .fdtb} catch {Window destroy .fdmenu} @@ -4489,194 +4558,255 @@ catch {Window destroy .fda} catch {Window destroy .fdcmd} catch {Window destroy .$fdvar(forminame)} }} \ - -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ - -pady 3 -text Close - button $base.bload \ - -borderwidth 1 -command {fd_load_form nimic design} \ - -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -padx 9 \ - -pady 3 -text {Load from database} - button $base.button17 \ - -borderwidth 1 -command {fd_save_form nimic} \ - -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -padx 9 \ - -pady 3 -text Save - label $base.l1 \ - -borderwidth 0 \ - -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ - -text {Form name} - entry $base.e1 \ - -background #fefefe -borderwidth 1 -highlightthickness 0 \ - -selectborderwidth 0 -textvariable fdvar(formname) - label $base.l2 \ - -borderwidth 0 \ - -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ - -text {Form's window internal name} - entry $base.e2 \ - -background #fefefe -borderwidth 1 -highlightthickness 0 \ - -selectborderwidth 0 -textvariable fdvar(forminame) - ################### - # SETTING GEOMETRY - ################### - place $base.but17 \ - -x 5 -y 80 -width 62 -height 24 -anchor nw -bordermode ignore - place $base.but18 \ - -x 5 -y 45 -width 62 -height 24 -anchor nw -bordermode ignore - place $base.but19 \ - -x 70 -y 45 -width 94 -height 24 -anchor nw -bordermode ignore - place $base.bex \ - -x 230 -y 45 -height 24 -anchor nw -bordermode ignore - place $base.bload \ - -x 75 -y 80 -width 114 -height 23 -anchor nw -bordermode ignore - place $base.button17 \ - -x 165 -y 45 -width 44 -height 24 -anchor nw -bordermode ignore - place $base.l1 \ - -x 5 -y 5 -anchor nw -bordermode ignore - place $base.e1 \ - -x 75 -y 5 -width 193 -height 17 -anchor nw -bordermode ignore - place $base.l2 \ - -x 5 -y 25 -anchor nw -bordermode ignore - place $base.e2 \ - -x 175 -y 25 -width 60 -height 17 -anchor nw -bordermode ignore + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ + -pady 3 -text Close + button $base.bload \ + -borderwidth 1 -command {fd_load_form nimic design} \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -padx 9 \ + -pady 3 -text {Load from database} + button $base.button17 \ + -borderwidth 1 -command {fd_save_form nimic} \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -padx 9 \ + -pady 3 -text Save + label $base.l1 \ + -borderwidth 0 \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ + -text {Form name} + entry $base.e1 \ + -background #fefefe -borderwidth 1 -highlightthickness 0 \ + -selectborderwidth 0 -textvariable fdvar(formname) + label $base.l2 \ + -borderwidth 0 \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ + -text {Form's window internal name} + entry $base.e2 \ + -background #fefefe -borderwidth 1 -highlightthickness 0 \ + -selectborderwidth 0 -textvariable fdvar(forminame) + ################### + # SETTING GEOMETRY + ################### + place $base.but17 \ + -x 5 -y 80 -width 62 -height 24 -anchor nw -bordermode ignore + place $base.but18 \ + -x 5 -y 45 -width 62 -height 24 -anchor nw -bordermode ignore + place $base.but19 \ + -x 70 -y 45 -width 94 -height 24 -anchor nw -bordermode ignore + place $base.bex \ + -x 230 -y 45 -height 24 -anchor nw -bordermode ignore + place $base.bload \ + -x 75 -y 80 -width 114 -height 23 -anchor nw -bordermode ignore + place $base.button17 \ + -x 165 -y 45 -width 44 -height 24 -anchor nw -bordermode ignore + place $base.l1 \ + -x 5 -y 5 -anchor nw -bordermode ignore + place $base.e1 \ + -x 75 -y 5 -width 193 -height 17 -anchor nw -bordermode ignore + place $base.l2 \ + -x 5 -y 25 -anchor nw -bordermode ignore + place $base.e2 \ + -x 175 -y 25 -width 60 -height 17 -anchor nw -bordermode ignore } proc vTclWindow.gpw {base} { - if {$base == ""} { - set base .gpw - } - if {[winfo exists $base]} { - wm deiconify $base; return - } - ################### - # CREATING WIDGETS - ################### - toplevel $base -class Toplevel - wm focusmodel $base passive - set sw [winfo screenwidth .] - set sh [winfo screenheight .] - set x [expr ($sw - 297)/2] - set y [expr ($sh - 98)/2] - wm geometry $base 297x98+$x+$y - 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 "Input parameter" - label $base.l1 \ - -anchor nw -borderwidth 1 \ - -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ - -justify left -relief sunken -textvariable gpw(msg) -wraplength 200 - entry $base.e1 \ - -background #fefefe -borderwidth 1 -highlightthickness 0 \ - -textvariable gpw(var) - bind $base.e1 { - set gpw(result) 1 + if {$base == ""} { + set base .gpw + } + if {[winfo exists $base]} { + wm deiconify $base; return + } + ################### + # CREATING WIDGETS + ################### + toplevel $base -class Toplevel + wm focusmodel $base passive + set sw [winfo screenwidth .] + set sh [winfo screenheight .] + set x [expr ($sw - 297)/2] + set y [expr ($sh - 98)/2] + wm geometry $base 297x98+$x+$y + 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 "Input parameter" + label $base.l1 \ + -anchor nw -borderwidth 1 \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ + -justify left -relief sunken -textvariable gpw(msg) -wraplength 200 + entry $base.e1 \ + -background #fefefe -borderwidth 1 -highlightthickness 0 \ + -textvariable gpw(var) + bind $base.e1 { + set gpw(result) 1 destroy .gpw - } - bind $base.e1 { - set gpw(result) 1 + } + bind $base.e1 { + set gpw(result) 1 destroy .gpw - } - button $base.bok \ - -borderwidth 1 -command {set gpw(result) 1 + } + button $base.bok \ + -borderwidth 1 -command {set gpw(result) 1 destroy .gpw} -padx 9 \ - -pady 3 -text Ok - button $base.bcanc \ - -borderwidth 1 -command {set gpw(result) 0 + -pady 3 -text Ok + button $base.bcanc \ + -borderwidth 1 -command {set gpw(result) 0 destroy .gpw} -padx 9 \ - -pady 3 -text Cancel - ################### - # SETTING GEOMETRY - ################### - place $base.l1 \ - -x 10 -y 5 -width 201 -height 53 -anchor nw -bordermode ignore - place $base.e1 \ - -x 10 -y 65 -width 200 -height 24 -anchor nw -bordermode ignore - place $base.bok \ - -x 225 -y 5 -width 61 -height 26 -anchor nw -bordermode ignore - place $base.bcanc \ - -x 225 -y 35 -width 61 -height 26 -anchor nw -bordermode ignore + -pady 3 -text Cancel + ################### + # SETTING GEOMETRY + ################### + place $base.l1 \ + -x 10 -y 5 -width 201 -height 53 -anchor nw -bordermode ignore + place $base.e1 \ + -x 10 -y 65 -width 200 -height 24 -anchor nw -bordermode ignore + place $base.bok \ + -x 225 -y 5 -width 61 -height 26 -anchor nw -bordermode ignore + place $base.bcanc \ + -x 225 -y 35 -width 61 -height 26 -anchor nw -bordermode ignore } proc vTclWindow.fdtb {base} { - if {$base == ""} { - set base .fdtb - } - if {[winfo exists $base]} { - wm deiconify $base; return - } - ################### - # CREATING WIDGETS - ################### - toplevel $base -class Toplevel - wm focusmodel $base passive - wm geometry $base 90x152+0+0 - wm maxsize $base 785 570 - wm minsize $base 1 1 - wm overrideredirect $base 0 - wm resizable $base 1 1 - wm deiconify $base - wm title $base "Toolbar" - radiobutton $base.rb1 \ - -anchor w -borderwidth 1 \ - -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ - -highlightthickness 0 -text Point -value point -variable fdvar(tool) \ - -width 9 - radiobutton $base.rb2 \ - -anchor w -borderwidth 1 \ - -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ - -foreground #000000 -highlightthickness 0 -selectcolor #0000ee \ - -text Label -value label -variable fdvar(tool) -width 9 - radiobutton $base.rb3 \ - -anchor w -borderwidth 1 \ - -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ - -highlightthickness 0 -text Entry -value entry -variable fdvar(tool) \ - -width 9 - radiobutton $base.rb4 \ - -anchor w -borderwidth 1 \ - -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ - -highlightthickness 0 -text Button -value button \ - -variable fdvar(tool) -width 9 - radiobutton $base.rb5 \ - -anchor w -borderwidth 1 \ - -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ - -highlightthickness 0 -text {List box} -value listbox \ - -variable fdvar(tool) -width 9 - radiobutton $base.rb6 \ - -anchor w -borderwidth 1 \ - -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ - -highlightthickness 0 -text {Check box} -value checkbox \ - -variable fdvar(tool) -width 9 - radiobutton $base.rb7 \ - -anchor w -borderwidth 1 \ - -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ - -highlightthickness 0 -text {Radio btn} -value radio \ - -variable fdvar(tool) -width 9 - radiobutton $base.rb8 \ - -anchor w -borderwidth 1 \ - -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ - -highlightthickness 0 -text Query -value query -variable fdvar(tool) \ - -width 9 - ################### - # SETTING GEOMETRY - ################### - grid $base.rb1 \ - -in .fdtb -column 0 -row 0 -columnspan 1 -rowspan 1 - grid $base.rb2 \ - -in .fdtb -column 0 -row 1 -columnspan 1 -rowspan 1 - grid $base.rb3 \ - -in .fdtb -column 0 -row 2 -columnspan 1 -rowspan 1 - grid $base.rb4 \ - -in .fdtb -column 0 -row 3 -columnspan 1 -rowspan 1 - grid $base.rb5 \ - -in .fdtb -column 0 -row 4 -columnspan 1 -rowspan 1 - grid $base.rb6 \ - -in .fdtb -column 0 -row 5 -columnspan 1 -rowspan 1 - grid $base.rb7 \ - -in .fdtb -column 0 -row 6 -columnspan 1 -rowspan 1 - grid $base.rb8 \ - -in .fdtb -column 0 -row 7 -columnspan 1 -rowspan 1 + if {$base == ""} { + set base .fdtb + } + if {[winfo exists $base]} { + wm deiconify $base; return + } + ################### + # CREATING WIDGETS + ################### + toplevel $base -class Toplevel + wm focusmodel $base passive + wm geometry $base 90x152+0+0 + wm maxsize $base 785 570 + wm minsize $base 1 1 + wm overrideredirect $base 0 + wm resizable $base 1 1 + wm deiconify $base + wm title $base "Toolbar" + radiobutton $base.rb1 \ + -anchor w -borderwidth 1 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -highlightthickness 0 -text Point -value point -variable fdvar(tool) \ + -width 9 + radiobutton $base.rb2 \ + -anchor w -borderwidth 1 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -foreground #000000 -highlightthickness 0 -selectcolor #0000ee \ + -text Label -value label -variable fdvar(tool) -width 9 + radiobutton $base.rb3 \ + -anchor w -borderwidth 1 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -highlightthickness 0 -text Entry -value entry -variable fdvar(tool) \ + -width 9 + radiobutton $base.rb4 \ + -anchor w -borderwidth 1 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -highlightthickness 0 -text Button -value button \ + -variable fdvar(tool) -width 9 + radiobutton $base.rb5 \ + -anchor w -borderwidth 1 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ + -highlightthickness 0 -text {List box} -value listbox \ + -variable fdvar(tool) -width 9 + radiobutton $base.rb6 \ + -anchor w -borderwidth 1 \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ + -highlightthickness 0 -text {Check box} -value checkbox \ + -variable fdvar(tool) -width 9 + radiobutton $base.rb7 \ + -anchor w -borderwidth 1 \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ + -highlightthickness 0 -text {Radio btn} -value radio \ + -variable fdvar(tool) -width 9 + radiobutton $base.rb8 \ + -anchor w -borderwidth 1 \ + -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ + -highlightthickness 0 -text Query -value query -variable fdvar(tool) \ + -width 9 + ################### + # SETTING GEOMETRY + ################### + grid $base.rb1 \ + -in .fdtb -column 0 -row 0 -columnspan 1 -rowspan 1 + grid $base.rb2 \ + -in .fdtb -column 0 -row 1 -columnspan 1 -rowspan 1 + grid $base.rb3 \ + -in .fdtb -column 0 -row 2 -columnspan 1 -rowspan 1 + grid $base.rb4 \ + -in .fdtb -column 0 -row 3 -columnspan 1 -rowspan 1 + grid $base.rb5 \ + -in .fdtb -column 0 -row 4 -columnspan 1 -rowspan 1 + grid $base.rb6 \ + -in .fdtb -column 0 -row 5 -columnspan 1 -rowspan 1 + grid $base.rb7 \ + -in .fdtb -column 0 -row 6 -columnspan 1 -rowspan 1 + grid $base.rb8 \ + -in .fdtb -column 0 -row 7 -columnspan 1 -rowspan 1 +} + +proc vTclWindow.sqlw {base} { + if {$base == ""} { + set base .sqlw + } + if {[winfo exists $base]} { + wm deiconify $base; return + } + ################### + # CREATING WIDGETS + ################### + toplevel $base -class Toplevel + wm focusmodel $base passive + wm geometry $base 551x408+192+169 + 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 "SQL commands" + frame $base.f \ + -borderwidth 1 -height 392 -relief raised -width 396 + scrollbar $base.f.01 \ + -borderwidth 1 -command {.sqlw.f.t xview} -orient horiz \ + -width 10 + scrollbar $base.f.02 \ + -borderwidth 1 -command {.sqlw.f.t yview} -orient vert -width 10 + text $base.f.t \ + -borderwidth 1 \ + -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*-* \ + -height 200 -width 200 -wrap word \ + -xscrollcommand {.sqlw.f.01 set} \ + -yscrollcommand {.sqlw.f.02 set} + button $base.b1 \ + -borderwidth 1 -command {.sqlw.f.t delete 1.0 end} -padx 9 \ + -pady 3 -text Clean + button $base.b2 \ + -borderwidth 1 -command {destroy .sqlw} -padx 9 -pady 3 -text Close + ################### + # SETTING GEOMETRY + ################### + grid columnconf $base 0 -weight 1 + grid columnconf $base 1 -weight 1 + grid rowconf $base 0 -weight 1 + grid $base.f \ + -in .sqlw -column 0 -row 0 -columnspan 2 -rowspan 1 + grid columnconf $base.f 0 -weight 1 + grid rowconf $base.f 0 -weight 1 + grid $base.f.01 \ + -in .sqlw.f -column 0 -row 1 -columnspan 1 -rowspan 1 -sticky ew + grid $base.f.02 \ + -in .sqlw.f -column 1 -row 0 -columnspan 1 -rowspan 1 -sticky ns + grid $base.f.t \ + -in .sqlw.f -column 0 -row 0 -columnspan 1 -rowspan 1 \ + -sticky nesw + grid $base.b1 \ + -in .sqlw -column 0 -row 1 -columnspan 1 -rowspan 1 + grid $base.b2 \ + -in .sqlw -column 1 -row 1 -columnspan 1 -rowspan 1 } + Window show . Window show .dw -- 2.40.0