Skip to content

P
Postgres FD Implementation
Commit 25acbc51 authored by Marc G. Fournier's avatar Marc G. Fournier
Browse files
Options

parent 7737dfd3
Hide whitespace changes
Inline Side-by-side
Showing with 7692 additions and 0 deletions
src/bin/pgaccess/lib/database.tcl 0 → 100644
View file @ 25acbc51
namespace eval Database {
proc {getTablesList} {} {
global CurrentDB PgAcVar
set tlist {}
if {[catch {
wpg_select $CurrentDB "select c.relname,count(c.relname) from pg_class C, pg_rewrite R where (r.ev_class = C.oid) and (r.ev_type = '1') group by relname" rec {
if {$rec(count)!=0} {
set itsaview($rec(relname)) 1
}
}
if {! $PgAcVar(pref,systemtables)} {
wpg_select $CurrentDB "select relname from pg_class where (relname !~ '^pg_') and (relkind='r') order by relname" rec {
if {![regexp "^pga_" $rec(relname)]} then {
if {![info exists itsaview($rec(relname))]} {
lappend tlist $rec(relname)
}
}
}
} else {
wpg_select $CurrentDB "select relname from pg_class where (relkind='r') order by relname" rec {
if {![info exists itsaview($rec(relname))]} {
lappend tlist $rec(relname)
}
}
}
} gterrmsg]} {
showError $gterrmsg
}
return $tlist
}
proc {vacuum} {} {
global PgAcVar CurrentDB
if {$CurrentDB==""} return;
set PgAcVar(statusline,dbname) [format [intlmsg "vacuuming database %s ..."] $PgAcVar(currentdb,dbname)]
setCursor CLOCK
set pgres [wpg_exec $CurrentDB "vacuum;"]
catch {pg_result $pgres -clear}
setCursor DEFAULT
set PgAcVar(statusline,dbname) $PgAcVar(currentdb,dbname)
}
proc {getPgType} {oid} {
global CurrentDB
set temp "unknown"
wpg_select $CurrentDB "select typname from pg_type where oid=$oid" rec {
set temp $rec(typname)
}
return $temp
}
proc {executeUpdate} {sqlcmd} {
global CurrentDB
return [sql_exec noquiet $sqlcmd]
}
}
src/bin/pgaccess/lib/forms.tcl 0 → 100644
View file @ 25acbc51
namespace eval Forms {
proc {new} {} {
global PgAcVar
Window show .pgaw:FormDesign:menu
tkwait visibility .pgaw:FormDesign:menu
Window show .pgaw:FormDesign:toolbar
tkwait visibility .pgaw:FormDesign:toolbar
Window show .pgaw:FormDesign:attributes
tkwait visibility .pgaw:FormDesign:attributes
Window show .pgaw:FormDesign:draft
design:init
}
proc {open} {formname} {
forms:load $formname run
design:run
}
proc {design} {formname} {
forms:load $formname design
}
proc {design:change_coords} {} {
global PgAcVar
set PgAcVar(fdvar,dirty) 1
set i $PgAcVar(fdvar,attributeFrame)
if {$i == 0} {
# it's the form
set errmsg ""
if {[catch {wm geometry .pgaw:FormDesign:draft $PgAcVar(fdvar,c_width)x$PgAcVar(fdvar,c_height)+$PgAcVar(fdvar,c_left)+$PgAcVar(fdvar,c_top)} errmsg] != 0} {
showError $errmsg
}
return
}
set c [list $PgAcVar(fdvar,c_left) $PgAcVar(fdvar,c_top) [expr $PgAcVar(fdvar,c_left)+$PgAcVar(fdvar,c_width)] [expr $PgAcVar(fdvar,c_top)+$PgAcVar(fdvar,c_height)]]
set PgAcVar(fdobj,$i,coord) $c
.pgaw:FormDesign:draft.c delete o$i
design:draw_object $i
design:draw_hookers $i
}
proc {design:delete_object} {} {
global PgAcVar
set i $PgAcVar(fdvar,moveitemobj)
.pgaw:FormDesign:draft.c delete o$i
.pgaw:FormDesign:draft.c delete hook
set j [lsearch $PgAcVar(fdvar,objlist) $i]
set PgAcVar(fdvar,objlist) [lreplace $PgAcVar(fdvar,objlist) $j $j]
set PgAcVar(fdvar,dirty) 1
}
proc {design:draw_hook} {x y} {
.pgaw:FormDesign:draft.c create rectangle [expr $x-2] [expr $y-2] [expr $x+2] [expr $y+2] -fill black -tags hook
}
proc {design:draw_hookers} {i} {
global PgAcVar
foreach {x1 y1 x2 y2} $PgAcVar(fdobj,$i,coord) {}
.pgaw:FormDesign:draft.c delete hook
design:draw_hook $x1 $y1
design:draw_hook $x1 $y2
design:draw_hook $x2 $y1
design:draw_hook $x2 $y2
}
proc {design:draw_grid} {} {
for {set i 0} {$i<100} {incr i} {
.pgaw:FormDesign:draft.c create line 0 [expr {$i*6}] 1000 [expr {$i*6}] -fill #afafaf -tags grid
.pgaw:FormDesign:draft.c create line [expr {$i*6}] 0 [expr {$i*6}] 1000 -fill #afafaf -tags grid
}
}
proc {design:draw_object} {i} {
global PgAcVar
set c $PgAcVar(fdobj,$i,coord)
foreach {x1 y1 x2 y2} $c {}
.pgaw:FormDesign:draft.c delete o$i
set wfont $PgAcVar(fdobj,$i,font)
switch $wfont {
{} {set wfont $PgAcVar(pref,font_normal) ; set PgAcVar(fdobj,$i,font) normal}
normal {set wfont $PgAcVar(pref,font_normal)}
bold {set wfont $PgAcVar(pref,font_bold)}
italic {set wfont $PgAcVar(pref,font_italic)}
fixed {set wfont $PgAcVar(pref,font_fix)}
}
switch $PgAcVar(fdobj,$i,class) {
button {
design:draw_rectangle $x1 $y1 $x2 $y2 $PgAcVar(fdobj,$i,relief) $PgAcVar(fdobj,$i,bcolor) o$i
.pgaw:FormDesign:draft.c create text [expr ($x1+$x2)/2] [expr ($y1+$y2)/2] -fill $PgAcVar(fdobj,$i,fcolor) -text $PgAcVar(fdobj,$i,label) -font $wfont -tags o$i
}
text {
design:draw_rectangle $x1 $y1 $x2 $y2 $PgAcVar(fdobj,$i,relief) $PgAcVar(fdobj,$i,bcolor) o$i
}
entry {
design:draw_rectangle $x1 $y1 $x2 $y2 $PgAcVar(fdobj,$i,relief) $PgAcVar(fdobj,$i,bcolor) o$i
}
label {
set temp $PgAcVar(fdobj,$i,label)
if {$temp==""} {set temp "____"}
design:draw_rectangle $x1 $y1 $x2 $y2 $PgAcVar(fdobj,$i,relief) $PgAcVar(fdobj,$i,bcolor) o$i
.pgaw:FormDesign:draft.c create text [expr {$x1+1}] [expr {$y1+1}] -text $temp -fill $PgAcVar(fdobj,$i,fcolor) -font $wfont -anchor nw -tags o$i
}
checkbox {
design:draw_rectangle [expr $x1+2] [expr $y1+5] [expr $x1+12] [expr $y1+15] raised #a0a0a0 o$i
.pgaw:FormDesign:draft.c create text [expr $x1+20] [expr $y1+3] -text $PgAcVar(fdobj,$i,label) -anchor nw \
-fill $PgAcVar(fdobj,$i,fcolor) -font $wfont -tags o$i
}
radio {
.pgaw:FormDesign:draft.c create oval [expr $x1+4] [expr $y1+5] [expr $x1+14] [expr $y1+15] -fill white -tags o$i
.pgaw:FormDesign:draft.c create text [expr $x1+24] [expr $y1+3] -text $PgAcVar(fdobj,$i,label) -anchor nw \
-fill $PgAcVar(fdobj,$i,fcolor) -font $wfont -tags o$i
}
query {
.pgaw:FormDesign:draft.c create oval $x1 $y1 [expr $x1+20] [expr $y1+20] -fill white -tags o$i
.pgaw:FormDesign:draft.c create text [expr $x1+5] [expr $y1+4] -text Q -anchor nw -font $PgAcVar(pref,font_normal) -tags o$i
}
listbox {
design:draw_rectangle $x1 $y1 [expr $x2-12] $y2 sunken $PgAcVar(fdobj,$i,bcolor) o$i
design:draw_rectangle [expr $x2-11] $y1 $x2 $y2 sunken gray o$i
.pgaw:FormDesign:draft.c create line [expr $x2-5] $y1 $x2 [expr $y1+10] -fill #808080 -tags o$i
.pgaw:FormDesign:draft.c create line [expr $x2-10] [expr $y1+9] $x2 [expr $y1+9] -fill #808080 -tags o$i
.pgaw:FormDesign:draft.c create line [expr $x2-10] [expr $y1+9] [expr $x2-5] $y1 -fill white -tags o$i
.pgaw:FormDesign:draft.c create line [expr $x2-5] $y2 $x2 [expr $y2-10] -fill #808080 -tags o$i
.pgaw:FormDesign:draft.c create line [expr $x2-10] [expr $y2-9] $x2 [expr $y2-9] -fill white -tags o$i
.pgaw:FormDesign:draft.c create line [expr $x2-10] [expr $y2-9] [expr $x2-5] $y2 -fill white -tags o$i
}
}
.pgaw:FormDesign:draft.c raise hook
}
proc {design:draw_rectangle} {x1 y1 x2 y2 relief color tag} {
if {$relief=="raised"} {
set c1 white
set c2 #606060
}
if {$relief=="sunken"} {
set c1 #606060
set c2 white
}
if {$relief=="ridge"} {
design:draw_rectangle $x1 $y1 $x2 $y2 raised none $tag
design:draw_rectangle [expr {$x1+1}] [expr {$y1+1}] [expr {$x2+1}] [expr {$y2+1}] sunken none $tag
design:draw_rectangle [expr {$x1+2}] [expr {$y1+2}] $x2 $y2 flat $color $tag
return
}
if {$relief=="groove"} {
design:draw_rectangle $x1 $y1 $x2 $y2 sunken none $tag
design:draw_rectangle [expr {$x1+1}] [expr {$y1+1}] [expr {$x2+1}] [expr {$y2+1}] raised none $tag
design:draw_rectangle [expr {$x1+2}] [expr {$y1+2}] $x2 $y2 flat $color $tag
return
}
if {$color != "none"} {
.pgaw:FormDesign:draft.c create rectangle $x1 $y1 $x2 $y2 -outline "" -fill $color -tags $tag
}
if {$relief=="flat"} {
return
}
.pgaw:FormDesign:draft.c create line $x1 $y1 $x2 $y1 -fill $c1 -tags $tag
.pgaw:FormDesign:draft.c create line $x1 $y1 $x1 $y2 -fill $c1 -tags $tag
.pgaw:FormDesign:draft.c create line $x1 $y2 $x2 $y2 -fill $c2 -tags $tag
.pgaw:FormDesign:draft.c create line $x2 $y1 $x2 [expr 1+$y2] -fill $c2 -tags $tag
}
proc {design:init} {} {
global PgAcVar
PgAcVar:clean fdvar,*
PgAcVar:clean fdobj,*
catch {.pgaw:FormDesign:draft.c delete all}
# design:draw_grid
set PgAcVar(fdobj,0,name) {f1}
set PgAcVar(fdobj,0,class) form
set PgAcVar(fdobj,0,command) {}
set PgAcVar(fdvar,formtitle) "New form"
set PgAcVar(fdvar,objnum) 0
set PgAcVar(fdvar,objlist) {}
set PgAcVar(fdvar,oper) none
set PgAcVar(fdvar,tool) point
set PgAcVar(fdvar,resizable) 1
set PgAcVar(fdvar,dirty) 0
}
proc {design:item_click} {x y} {
global PgAcVar
set PgAcVar(fdvar,oper) none
set PgAcVar(fdvar,moveitemobj) {}
set il [.pgaw:FormDesign:draft.c find overlapping $x $y $x $y]
.pgaw:FormDesign:draft.c delete hook
if {[llength $il] == 0} {
design:show_attributes 0
return
}
set tl [.pgaw:FormDesign:draft.c gettags [lindex $il 0]]
set i [lsearch -glob $tl o*]
if {$i == -1} return
set objnum [string range [lindex $tl $i] 1 end]
set PgAcVar(fdvar,moveitemobj) $objnum
set PgAcVar(fdvar,moveitemx) $x
set PgAcVar(fdvar,moveitemy) $y
set PgAcVar(fdvar,oper) move
design:show_attributes $objnum
design:draw_hookers $objnum
}
proc {forms:load} {name mode} {
global PgAcVar CurrentDB
design:init
set PgAcVar(fdvar,formtitle) $name
if {$mode=="design"} {
Window show .pgaw:FormDesign:draft
Window show .pgaw:FormDesign:menu
Window show .pgaw:FormDesign:attributes
Window show .pgaw:FormDesign:toolbar
}
set res [wpg_exec $CurrentDB "select * from pga_forms where formname='$PgAcVar(fdvar,formtitle)'"]
set info [lindex [pg_result $res -getTuple 0] 1]
pg_result $res -clear
set PgAcVar(fdobj,0,name) [lindex $info 0]
set PgAcVar(fdvar,objnum) [lindex $info 1]
# check for old format , prior to 0.97 that
# save here the objlist (deprecated)
set temp [lindex $info 2]
if {[lindex $temp 0] == "FS"} {
set PgAcVar(fdobj,0,command) [lindex $temp 1]
} else {
set PgAcVar(fdobj,0,command) {}
}
set PgAcVar(fdvar,objlist) {}
set PgAcVar(fdvar,geometry) [lindex $info 3]
set i 1
foreach objinfo [lrange $info 4 end] {
lappend PgAcVar(fdvar,objlist) $i
set PgAcVar(fdobj,$i,class) [lindex $objinfo 0]
set PgAcVar(fdobj,$i,name) [lindex $objinfo 1]
set PgAcVar(fdobj,$i,coord) [lindex $objinfo 2]
set PgAcVar(fdobj,$i,command) [lindex $objinfo 3]
set PgAcVar(fdobj,$i,label) [lindex $objinfo 4]
set PgAcVar(fdobj,$i,variable) [lindex $objinfo 5]
design:setDefaultReliefAndColor $i
set PgAcVar(fdobj,$i,value) $PgAcVar(fdobj,$i,name)
if {[llength $objinfo] > 6 } {
set PgAcVar(fdobj,$i,value) [lindex $objinfo 6]
set PgAcVar(fdobj,$i,relief) [lindex $objinfo 7]
set PgAcVar(fdobj,$i,fcolor) [lindex $objinfo 8]
set PgAcVar(fdobj,$i,bcolor) [lindex $objinfo 9]
set PgAcVar(fdobj,$i,borderwidth) [lindex $objinfo 10]
set PgAcVar(fdobj,$i,font) [lindex $objinfo 11]
# for space saving purposes we have saved onbly the first letter
switch $PgAcVar(fdobj,$i,font) {
n {set PgAcVar(fdobj,$i,font) normal}
i {set PgAcVar(fdobj,$i,font) italic}
b {set PgAcVar(fdobj,$i,font) bold}
f {set PgAcVar(fdobj,$i,font) fixed}
}
}
if {$mode=="design"} {design:draw_object $i}
incr i
}
if {$mode=="design"} {wm geometry .pgaw:FormDesign:draft $PgAcVar(fdvar,geometry)}
}
proc {design:mouse_down} {x y} {
global PgAcVar
set x [expr 3*int($x/3)]
set y [expr 3*int($y/3)]
set PgAcVar(fdvar,xstart) $x
set PgAcVar(fdvar,ystart) $y
if {$PgAcVar(fdvar,tool)=="point"} {
design:item_click $x $y
return
}
set PgAcVar(fdvar,oper) draw
}
proc {design:mouse_move} {x y} {
global PgAcVar
#set PgAcVar(fdvar,msg) "x=$x y=$y"
set x [expr 3*int($x/3)]
set y [expr 3*int($y/3)]
set oper ""
catch {set oper $PgAcVar(fdvar,oper)}
if {$oper=="draw"} {
catch {.pgaw:FormDesign:draft.c delete curdraw}
.pgaw:FormDesign:draft.c create rectangle $PgAcVar(fdvar,xstart) $PgAcVar(fdvar,ystart) $x $y -tags curdraw
return
}
if {$oper=="move"} {
set dx [expr $x-$PgAcVar(fdvar,moveitemx)]
set dy [expr $y-$PgAcVar(fdvar,moveitemy)]
.pgaw:FormDesign:draft.c move o$PgAcVar(fdvar,moveitemobj) $dx $dy
.pgaw:FormDesign:draft.c move hook $dx $dy
set PgAcVar(fdvar,moveitemx) $x
set PgAcVar(fdvar,moveitemy) $y
set PgAcVar(fdvar,dirty) 1
}
}
proc {design:setDefaultReliefAndColor} {i} {
global PgAcVar
set PgAcVar(fdobj,$i,borderwidth) 1
set PgAcVar(fdobj,$i,relief) flat
set PgAcVar(fdobj,$i,fcolor) {}
set PgAcVar(fdobj,$i,bcolor) {}
set PgAcVar(fdobj,$i,font) normal
switch $PgAcVar(fdobj,$i,class) {
button {
set PgAcVar(fdobj,$i,fcolor) #000000
set PgAcVar(fdobj,$i,bcolor) #d9d9d9
set PgAcVar(fdobj,$i,relief) raised
}
text {
set PgAcVar(fdobj,$i,fcolor) #000000
set PgAcVar(fdobj,$i,bcolor) #fefefe
set PgAcVar(fdobj,$i,relief) sunken
}
entry {
set PgAcVar(fdobj,$i,fcolor) #000000
set PgAcVar(fdobj,$i,bcolor) #fefefe
set PgAcVar(fdobj,$i,relief) sunken
}
label {
set PgAcVar(fdobj,$i,fcolor) #000000
set PgAcVar(fdobj,$i,bcolor) #d9d9d9
set PgAcVar(fdobj,$i,relief) flat
}
checkbox {
set PgAcVar(fdobj,$i,fcolor) #000000
set PgAcVar(fdobj,$i,bcolor) #d9d9d9
set PgAcVar(fdobj,$i,relief) flat
}
radio {
set PgAcVar(fdobj,$i,fcolor) #000000
set PgAcVar(fdobj,$i,bcolor) #d9d9d9
set PgAcVar(fdobj,$i,relief) flat
}
listbox {
set PgAcVar(fdobj,$i,fcolor) #000000
set PgAcVar(fdobj,$i,bcolor) #fefefe
set PgAcVar(fdobj,$i,relief) sunken
}
}
}
proc {design:mouse_up} {x y} {
global PgAcVar
set x [expr 3*int($x/3)]
set y [expr 3*int($y/3)]
if {$PgAcVar(fdvar,oper)=="move"} {
set PgAcVar(fdvar,moveitem) {}
set PgAcVar(fdvar,oper) none
set oc $PgAcVar(fdobj,$PgAcVar(fdvar,moveitemobj),coord)
set dx [expr $x - $PgAcVar(fdvar,xstart)]
set dy [expr $y - $PgAcVar(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 PgAcVar(fdobj,$PgAcVar(fdvar,moveitemobj),coord) $newcoord
design:show_attributes $PgAcVar(fdvar,moveitemobj)
design:draw_hookers $PgAcVar(fdvar,moveitemobj)
return
}
if {$PgAcVar(fdvar,oper)!="draw"} return
set PgAcVar(fdvar,oper) none
.pgaw:FormDesign:draft.c delete curdraw
# Check for x2<x1 or y2<y1
if {$x<$PgAcVar(fdvar,xstart)} {set temp $x ; set x $PgAcVar(fdvar,xstart) ; set PgAcVar(fdvar,xstart) $temp}
if {$y<$PgAcVar(fdvar,ystart)} {set temp $y ; set y $PgAcVar(fdvar,ystart) ; set PgAcVar(fdvar,ystart) $temp}
# Check for too small sizes
if {[expr $x-$PgAcVar(fdvar,xstart)]<20} {set x [expr $PgAcVar(fdvar,xstart)+20]}
if {[expr $y-$PgAcVar(fdvar,ystart)]<10} {set y [expr $PgAcVar(fdvar,ystart)+10]}
incr PgAcVar(fdvar,objnum)
set i $PgAcVar(fdvar,objnum)
lappend PgAcVar(fdvar,objlist) $i
set PgAcVar(fdobj,$i,class) $PgAcVar(fdvar,tool)
set PgAcVar(fdobj,$i,coord) [list $PgAcVar(fdvar,xstart) $PgAcVar(fdvar,ystart) $x $y]
set PgAcVar(fdobj,$i,name) $PgAcVar(fdvar,tool)$i
set PgAcVar(fdobj,$i,label) $PgAcVar(fdvar,tool)$i
set PgAcVar(fdobj,$i,command) {}
set PgAcVar(fdobj,$i,variable) {}
set PgAcVar(fdobj,$i,value) {}
design:setDefaultReliefAndColor $i
design:draw_object $i
design:show_attributes $i
set PgAcVar(fdvar,moveitemobj) $i
design:draw_hookers $i
set PgAcVar(fdvar,tool) point
set PgAcVar(fdvar,dirty) 1
}
proc {design:save} {name} {
global PgAcVar CurrentDB
if {[string length $PgAcVar(fdobj,0,name)]==0} {
tk_messageBox -title [intlmsg Warning] -message [intlmsg "Forms need an internal name, only literals, low case"]
return 0
}
if {[string length $PgAcVar(fdvar,formtitle)]==0} {
tk_messageBox -title [intlmsg Warning] -message [intlmsg "Form must have a name"]
return 0
}
set info [list $PgAcVar(fdobj,0,name) $PgAcVar(fdvar,objnum) [list FS $PgAcVar(fdobj,0,command)] [wm geometry .pgaw:FormDesign:draft]]
foreach i $PgAcVar(fdvar,objlist) {
set wfont $PgAcVar(fdobj,$i,font)
if {[lsearch {normal bold italic fixed} $wfont] != -1} {
set wfont [string range $wfont 0 0]
}
lappend info [list $PgAcVar(fdobj,$i,class) $PgAcVar(fdobj,$i,name) $PgAcVar(fdobj,$i,coord) $PgAcVar(fdobj,$i,command) $PgAcVar(fdobj,$i,label) $PgAcVar(fdobj,$i,variable) $PgAcVar(fdobj,$i,value) $PgAcVar(fdobj,$i,relief) $PgAcVar(fdobj,$i,fcolor) $PgAcVar(fdobj,$i,bcolor) $PgAcVar(fdobj,$i,borderwidth) $wfont]
}
sql_exec noquiet "delete from pga_forms where formname='$PgAcVar(fdvar,formtitle)'"
regsub -all "'" $info "''" info
sql_exec noquiet "insert into pga_forms values ('$PgAcVar(fdvar,formtitle)','$info')"
Mainlib::cmd_Forms
set PgAcVar(fdvar,dirty) 0
return 1
}
proc {design:set_name} {} {
global PgAcVar
set i $PgAcVar(fdvar,moveitemobj)
foreach k $PgAcVar(fdvar,objlist) {
if {($PgAcVar(fdobj,$k,name)==$PgAcVar(fdvar,c_name)) && ($i!=$k)} {
tk_messageBox -title [intlmsg Warning] -message [format [intlmsg "There is another object (a %s) with the same name.\nPlease change it!"] $PgAcVar(fdobj,$k,class)]
return
}
}
set PgAcVar(fdobj,$i,name) $PgAcVar(fdvar,c_name)
design:show_attributes $i
set PgAcVar(fdvar,dirty) 1
}
proc {design:set_text} {} {
global PgAcVar
design:draw_object $PgAcVar(fdvar,moveitemobj)
set PgAcVar(fdvar,dirty) 1
}
proc {design:createAttributesFrame} {i} {
global PgAcVar
# Check if attributes frame is already created for that item
if {[info exists PgAcVar(fdvar,attributeFrame)]} {
if {$PgAcVar(fdvar,attributeFrame) == $i} return
}
set PgAcVar(fdvar,attributeFrame) $i
# Delete old widgets from the frame
foreach wid [winfo children .pgaw:FormDesign:attributes.f] {
destroy $wid
}
set row 0
set base .pgaw:FormDesign:attributes.f
grid columnconf $base 1 -weight 1
set objclass $PgAcVar(fdobj,$i,class)
# if i is zero, then the object is the form
if {$i == 0} {
label $base.l$row \
-borderwidth 0 -text [intlmsg {Startup script}]
entry $base.e$row -textvariable PgAcVar(fdobj,$i,command) \
-background #fefefe -borderwidth 1 -width 200
button $base.b$row \
-borderwidth 1 -padx 1 -pady 0 -text ... -command "
Window show .pgaw:FormDesign:commands
set PgAcVar(fdvar,commandFor) $i
.pgaw:FormDesign:commands.f.txt delete 1.0 end
.pgaw:FormDesign:commands.f.txt insert end \$PgAcVar(fdobj,$i,command)"
grid $base.l$row \
-in $base -column 0 -row $row -columnspan 1 -rowspan 1 -sticky w
grid $base.e$row \
-in $base -column 1 -row $row -columnspan 1 -rowspan 1 -padx 2 \
-sticky w
grid $base.b$row \
-in $base -column 2 -row $row -columnspan 1 -rowspan 1
incr row
}
# does it have a text attribute ?
if {[lsearch {button label radio checkbox} $objclass] > -1} {
label $base.l$row \
-borderwidth 0 -text [intlmsg Text]
entry $base.e$row -textvariable PgAcVar(fdobj,$i,label) \
-background #fefefe -borderwidth 1 -width 200
bind $base.e$row <Key-Return> "Forms::design:set_text"
grid $base.l$row \
-in $base -column 0 -row $row -columnspan 1 -rowspan 1 -sticky w
grid $base.e$row \
-in $base -column 1 -row $row -columnspan 1 -rowspan 1 -padx 2 -sticky w
incr row
}
# does it have a variable attribute ?
if {[lsearch {button label radio checkbox entry} $objclass] > -1} {
label $base.l$row \
-borderwidth 0 -text [intlmsg Variable]
entry $base.e$row -textvariable PgAcVar(fdobj,$i,variable) \
-background #fefefe -borderwidth 1 -width 200
grid $base.l$row \
-in $base -column 0 -row $row -columnspan 1 -rowspan 1 -sticky w
grid $base.e$row \
-in $base -column 1 -row $row -columnspan 1 -rowspan 1 -padx 2 \
-sticky w
incr row
}
# does it have a Command attribute ?
if {[lsearch {button checkbox} $objclass] > -1} {
label $base.l$row \
-borderwidth 0 -text [intlmsg Command]
entry $base.e$row -textvariable PgAcVar(fdobj,$i,command) \
-background #fefefe -borderwidth 1 -width 200
button $base.b$row \
-borderwidth 1 -padx 1 -pady 0 -text ... -command "
Window show .pgaw:FormDesign:commands
set PgAcVar(fdvar,commandFor) $i
.pgaw:FormDesign:commands.f.txt delete 1.0 end
.pgaw:FormDesign:commands.f.txt insert end \$PgAcVar(fdobj,$i,command)"
grid $base.l$row \
-in $base -column 0 -row $row -columnspan 1 -rowspan 1 -sticky w
grid $base.e$row \
-in $base -column 1 -row $row -columnspan 1 -rowspan 1 -padx 2 \
-sticky w
grid $base.b$row \
-in $base -column 2 -row $row -columnspan 1 -rowspan 1
incr row
}
# does it have a value attribute ?
if {[lsearch {radio checkbox} $objclass] > -1} {
label $base.l$row \
-borderwidth 0 -text [intlmsg Value]
entry $base.e$row -textvariable PgAcVar(fdobj,$i,value) \
-background #fefefe -borderwidth 1 -width 200
grid $base.l$row \
-in $base -column 0 -row $row -columnspan 1 -rowspan 1 -sticky w
grid $base.e$row \
-in $base -column 1 -row $row -columnspan 1 -rowspan 1 -padx 2 \
-sticky w
incr row
}
# does it have fonts ?
if {[lsearch {label button entry listbox text checkbox radio} $objclass] > -1} {
label $base.lfont \
-borderwidth 0 -text [intlmsg Font]
grid $base.lfont \
-in $base -column 0 -row $row -columnspan 1 -rowspan 1 -pady 2 -sticky w
entry $base.efont -textvariable PgAcVar(fdobj,$i,font) \
-background #fefefe -borderwidth 1 -width 200
bind $base.efont <Key-Return> "Forms::design:draw_object $i ; set PgAcVar(fdvar,dirty) 1"
grid $base.efont \
-in $base -column 1 -row $row -columnspan 1 -rowspan 1 -padx 2 -sticky w
menubutton $base.mbf \
-borderwidth 1 -menu $base.mbf.m -padx 2 -pady 0 \
-text {...} -font $PgAcVar(pref,font_normal) -relief raised
menu $base.mbf.m \
-borderwidth 1 -cursor {} -tearoff 0 -font $PgAcVar(pref,font_normal)
foreach font {normal bold italic fixed} {
$base.mbf.m add command \
-command "
set PgAcVar(fdobj,$i,font) $font
Forms::design:draw_object $i
set PgAcVar(fdvar,dirty) 1
" -label $font
}
grid $base.mbf \
-in $base -column 2 -row $row -columnspan 1 -rowspan 1 -pady 2 -padx 2 -sticky w
incr row
}
# does it have colors ?
if {[lsearch {label button radio checkbox entry listbox text} $objclass] > -1} {
label $base.lcf \
-borderwidth 0 -text [intlmsg Foreground]
label $base.scf \
-background $PgAcVar(fdobj,$i,fcolor) -borderwidth 1 -relief sunken -width 200
button $base.bcf \
-command "set tempcolor \[tk_chooseColor -initialcolor $PgAcVar(fdobj,$i,fcolor) -title {Choose color}\]
if {\$tempcolor != {}} {
set PgAcVar(fdobj,$i,fcolor) \$tempcolor
$base.scf configure -background \$PgAcVar(fdobj,$i,fcolor)
set PgAcVar(fdvar,dirty) 1
Forms::design:draw_object $i
}" \
-borderwidth 1 -padx 1 -pady 0 -text ...
grid $base.lcf \
-in $base -column 0 -row $row -columnspan 1 -rowspan 1 -sticky w
grid $base.scf \
-in $base -column 1 -row $row -columnspan 1 -rowspan 1 -padx 2 \
-sticky w
grid $base.bcf \
-in $base -column 2 -row $row -columnspan 1 -rowspan 1
incr row
label $base.lcb \
-borderwidth 0 -text Background
label $base.scb \
-background $PgAcVar(fdobj,$i,bcolor) -borderwidth 1 -relief sunken -width 200
button $base.bcb \
-command "set tempcolor \[tk_chooseColor -initialcolor $PgAcVar(fdobj,$i,bcolor) -title {Choose color}\]
if {\$tempcolor != {}} {
set PgAcVar(fdobj,$i,bcolor) \$tempcolor
$base.scb configure -background \$PgAcVar(fdobj,$i,bcolor)
set PgAcVar(fdvar,dirty) 1
Forms::design:draw_object $i
}" \
-borderwidth 1 -padx 1 -pady 0 -text ...
grid $base.lcb \
-in $base -column 0 -row $row -columnspan 1 -rowspan 1 -sticky w
grid $base.scb \
-in $base -column 1 -row $row -columnspan 1 -rowspan 1 -padx 2 -sticky w
grid $base.bcb \
-in $base -column 2 -row $row -columnspan 1 -rowspan 1
incr row
}
# does it have border types ?
if {[lsearch {label button entry listbox text} $objclass] > -1} {
label $base.lrelief \
-borderwidth 0 -text [intlmsg Relief]
grid $base.lrelief \
-in $base -column 0 -row $row -columnspan 1 -rowspan 1 -pady 2 -sticky w
menubutton $base.mb \
-borderwidth 2 -menu $base.mb.m -padx 4 -pady 3 -width 100 -relief $PgAcVar(fdobj,$i,relief) \
-text groove -textvariable PgAcVar(fdobj,$i,relief) \
-font $PgAcVar(pref,font_normal)
menu $base.mb.m \
-borderwidth 1 -cursor {} -tearoff 0 -font $PgAcVar(pref,font_normal)
foreach brdtype {raised sunken ridge groove flat} {
$base.mb.m add command \
-command "
set PgAcVar(fdobj,$i,relief) $brdtype
$base.mb configure -relief \$PgAcVar(fdobj,$i,relief)
Forms::design:draw_object $i
" -label $brdtype
}
grid $base.mb \
-in $base -column 1 -row $row -columnspan 1 -rowspan 1 -pady 2 -padx 2 -sticky w
incr row
}
# is it a DataControl ?
if {$objclass == "query"} {
label $base.l$row \
-borderwidth 0 -text [intlmsg SQL]
entry $base.e$row -textvariable PgAcVar(fdobj,$i,command) \
-background #fefefe -borderwidth 1 -width 200
grid $base.l$row \
-in $base -column 0 -row $row -columnspan 1 -rowspan 1 -sticky w
grid $base.e$row \
-in $base -column 1 -row $row -columnspan 1 -rowspan 1 -padx 2 \
-sticky w
incr row
}
# does it have a borderwidth attribute ?
if {[lsearch {button label radio checkbox entry listbox text} $objclass] > -1} {
label $base.l$row \
-borderwidth 0 -text [intlmsg {Border width}]
entry $base.e$row -textvariable PgAcVar(fdobj,$i,borderwidth) \
-background #fefefe -borderwidth 1 -width 200
grid $base.l$row \
-in $base -column 0 -row $row -columnspan 1 -rowspan 1 -sticky w
grid $base.e$row \
-in $base -column 1 -row $row -columnspan 1 -rowspan 1 -padx 2 \
-sticky w
incr row
}
# The last dummy label
label $base.ldummy -text {} -borderwidth 0
grid $base.ldummy -in $base -column 0 -row 100
grid rowconf $base 100 -weight 1
}
proc {design:show_attributes} {i} {
global PgAcVar
set objclass $PgAcVar(fdobj,$i,class)
set PgAcVar(fdvar,c_class) $objclass
design:createAttributesFrame $i
set PgAcVar(fdvar,c_name) $PgAcVar(fdobj,$i,name)
if {$i == 0} {
# Object 0 is the form
set c [split [winfo geometry .pgaw:FormDesign:draft] x+]
set PgAcVar(fdvar,c_top) [lindex $c 3]
set PgAcVar(fdvar,c_left) [lindex $c 2]
set PgAcVar(fdvar,c_width) [lindex $c 0]
set PgAcVar(fdvar,c_height) [lindex $c 1]
return
}
set c $PgAcVar(fdobj,$i,coord)
set PgAcVar(fdvar,c_top) [lindex $c 1]
set PgAcVar(fdvar,c_left) [lindex $c 0]
set PgAcVar(fdvar,c_width) [expr [lindex $c 2]-[lindex $c 0]]
set PgAcVar(fdvar,c_height) [expr [lindex $c 3]-[lindex $c 1]]
}
proc {design:run} {} {
global PgAcVar CurrentDB DataControlVar
set base .$PgAcVar(fdobj,0,name)
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
wm geometry $base $PgAcVar(fdvar,geometry)
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 $PgAcVar(fdvar,formtitle)
foreach item $PgAcVar(fdvar,objlist) {
set coord $PgAcVar(fdobj,$item,coord)
set name $PgAcVar(fdobj,$item,name)
set wh "-width [expr 3+[lindex $coord 2]-[lindex $coord 0]] -height [expr 3+[lindex $coord 3]-[lindex $coord 1]]"
set visual 1
set wfont $PgAcVar(fdobj,$item,font)
switch $wfont {
{} {set wfont $PgAcVar(pref,font_normal)}
normal {set wfont $PgAcVar(pref,font_normal)}
bold {set wfont $PgAcVar(pref,font_bold)}
italic {set wfont $PgAcVar(pref,font_italic)}
fixed {set wfont $PgAcVar(pref,font_fix)}
}
namespace forget ::DataControl($base.$name)
# Checking if relief ridge or groove has borderwidth 2
if {[lsearch {ridge groove} $PgAcVar(fdobj,$item,relief)] != -1} {
if {$PgAcVar(fdobj,$item,borderwidth) < 2} {
set PgAcVar(fdobj,$item,borderwidth) 2
}
}
# Checking if borderwidth is okay
if {[lsearch {0 1 2 3 4 5} $PgAcVar(fdobj,$item,borderwidth)] == -1} {
set PgAcVar(fdobj,$item,borderwidth) 1
}
set cmd {}
catch {set cmd $PgAcVar(fdobj,$item,command)}
switch $PgAcVar(fdobj,$item,class) {
button {
button $base.$name -borderwidth 1 -padx 0 -pady 0 -text "$PgAcVar(fdobj,$item,label)" \
-fg $PgAcVar(fdobj,$item,fcolor) -bg $PgAcVar(fdobj,$item,bcolor) \
-borderwidth $PgAcVar(fdobj,$item,borderwidth) \
-relief $PgAcVar(fdobj,$item,relief) -font $wfont -command [subst {$cmd}]
if {$PgAcVar(fdobj,$item,variable) != ""} {
$base.$name configure -textvariable $PgAcVar(fdobj,$item,variable)
}
}
checkbox {
checkbutton $base.$name -onvalue t -offvalue f -font $wfont \
-fg $PgAcVar(fdobj,$item,fcolor) \
-borderwidth $PgAcVar(fdobj,$item,borderwidth) \
-command [subst {$cmd}] \
-text "$PgAcVar(fdobj,$item,label)" -variable "$PgAcVar(fdobj,$item,variable)" -borderwidth 1
set wh {}
}
query {
set visual 0
set DataControlVar($base.$name,sql) $PgAcVar(fdobj,$item,command)
namespace eval ::DataControl($base.$name) "proc open {} {
global CurrentDB DataControlVar
variable tuples
catch {unset tuples}
set wn \[focus\] ; setCursor CLOCK
set res \[wpg_exec \$CurrentDB \"\$DataControlVar($base.$name,sql)\"\]
pg_result \$res -assign tuples
set fl {}
foreach fd \[pg_result \$res -lAttributes\] {lappend fl \[lindex \$fd 0\]}
set DataControlVar($base.$name,fields) \$fl
set DataControlVar($base.$name,recno) 0
set DataControlVar($base.$name,nrecs) \[pg_result \$res -numTuples\]
setCursor NORMAL
}"
namespace eval ::DataControl($base.$name) "proc setSQL {sqlcmd} {
global DataControlVar
set DataControlVar($base.$name,sql) \$sqlcmd
}"
namespace eval ::DataControl($base.$name) "proc getRowCount {} {
global DataControlVar
return \$DataControlVar($base.$name,nrecs)
}"
namespace eval ::DataControl($base.$name) "proc getRowIndex {} {
global DataControlVar
return \$DataControlVar($base.$name,recno)
}"
namespace eval ::DataControl($base.$name) "proc moveTo {newrecno} {
global DataControlVar
set DataControlVar($base.$name,recno) \$newrecno
}"
namespace eval ::DataControl($base.$name) "proc close {} {
variable tuples
catch {unset tuples}
}"
namespace eval ::DataControl($base.$name) "proc getFieldList {} {
global DataControlVar
return \$DataControlVar($base.$name,fields)
}"
namespace eval ::DataControl($base.$name) "proc fill {lb fld} {
global DataControlVar
variable tuples
\$lb delete 0 end
for {set i 0} {\$i<\$DataControlVar($base.$name,nrecs)} {incr i} {
\$lb insert end \$tuples\(\$i,\$fld\)
}
}"
namespace eval ::DataControl($base.$name) "proc moveFirst {} {global DataControlVar ; set DataControlVar($base.$name,recno) 0}"
namespace eval ::DataControl($base.$name) "proc moveNext {} {global DataControlVar ; incr DataControlVar($base.$name,recno) ; if {\$DataControlVar($base.$name,recno)==\[getRowCount\]} {moveLast}}"
namespace eval ::DataControl($base.$name) "proc movePrevious {} {global DataControlVar ; incr DataControlVar($base.$name,recno) -1 ; if {\$DataControlVar($base.$name,recno)==-1} {moveFirst}}"
namespace eval ::DataControl($base.$name) "proc moveLast {} {global DataControlVar ; set DataControlVar($base.$name,recno) \[expr \[getRowCount\] -1\]}"
namespace eval ::DataControl($base.$name) "proc updateDataSet {} {\
global DataControlVar
global DataSet
variable tuples
set i \$DataControlVar($base.$name,recno)
foreach fld \$DataControlVar($base.$name,fields) {
catch {
upvar DataSet\($base.$name,\$fld\) dbvar
set dbvar \$tuples\(\$i,\$fld\)
}
}
}"
namespace eval ::DataControl($base.$name) "proc clearDataSet {} {
global DataControlVar
global DataSet
catch { foreach fld \$DataControlVar($base.$name,fields) {
catch {
upvar DataSet\($base.$name,\$fld\) dbvar
set dbvar {}
}
}}
}"
}
radio {
radiobutton $base.$name -font $wfont -text "$PgAcVar(fdobj,$item,label)" \
-fg $PgAcVar(fdobj,$item,fcolor) -bg $PgAcVar(fdobj,$item,bcolor) -variable $PgAcVar(fdobj,$item,variable) \
-value $PgAcVar(fdobj,$item,value) -borderwidth 1
set wh {}
}
entry {
set var {} ; catch {set var $PgAcVar(fdobj,$item,variable)}
entry $base.$name -bg $PgAcVar(fdobj,$item,bcolor) -fg $PgAcVar(fdobj,$item,fcolor) \
-borderwidth $PgAcVar(fdobj,$item,borderwidth) -font $wfont \
-relief $PgAcVar(fdobj,$item,relief) -selectborderwidth 0 -highlightthickness 0
if {$var!=""} {$base.$name configure -textvar $var}
}
text {
text $base.$name -fg $PgAcVar(fdobj,$item,fcolor) -bg $PgAcVar(fdobj,$item,bcolor) \
-relief $PgAcVar(fdobj,$item,relief) -borderwidth $PgAcVar(fdobj,$item,borderwidth) \
-font $wfont
}
label {
# set wh {}
label $base.$name -font $wfont -anchor nw -padx 0 -pady 0 -text $PgAcVar(fdobj,$item,label) \
-borderwidth $PgAcVar(fdobj,$item,borderwidth) \
-relief $PgAcVar(fdobj,$item,relief) -fg $PgAcVar(fdobj,$item,fcolor) -bg $PgAcVar(fdobj,$item,bcolor)
set var {} ; catch {set var $PgAcVar(fdobj,$item,variable)}
if {$var!=""} {$base.$name configure -textvar $var}
}
listbox {
listbox $base.$name -bg $PgAcVar(fdobj,$item,bcolor) -highlightthickness 0 -selectborderwidth 0 \
-borderwidth $PgAcVar(fdobj,$item,borderwidth) -relief $PgAcVar(fdobj,$item,relief) \
-fg $PgAcVar(fdobj,$item,fcolor) -bg $PgAcVar(fdobj,$item,bcolor) -font $wfont -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"]}
}
if {$PgAcVar(fdobj,0,command) != ""} {
uplevel #0 $PgAcVar(fdobj,0,command)
}
}
proc {design:close} {} {
global PgAcVar
if {$PgAcVar(fdvar,dirty)} {
if {[tk_messageBox -title [intlmsg Warning] -message [intlmsg "Do you want to save the form into the database?"] -type yesno -default yes]=="yes"} {
if {[design:save $PgAcVar(fdvar,formtitle)]==0} {return}
}
}
catch {Window destroy .pgaw:FormDesign:draft}
catch {Window destroy .pgaw:FormDesign:toolbar}
catch {Window destroy .pgaw:FormDesign:menu}
catch {Window destroy .pgaw:FormDesign:attributes}
catch {Window destroy .pgaw:FormDesign:commands}
catch {Window destroy .$PgAcVar(fdobj,0,name)}
}
}
proc vTclWindow.pgaw:FormDesign:draft {base} {
if {$base == ""} {
set base .pgaw:FormDesign:draft
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
wm geometry $base 377x315+50+130
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 [intlmsg "Form design"]
bind $base <Key-Delete> {
Forms::design:delete_object
}
bind $base <Key-F1> "Help::load form_design"
canvas $base.c \
-background #a0a0a0 -height 207 -highlightthickness 0 -relief ridge \
-selectborderwidth 0 -width 295
bind $base.c <Button-1> {
Forms::design:mouse_down %x %y
}
bind $base.c <ButtonRelease-1> {
Forms::design:mouse_up %x %y
}
bind $base.c <Motion> {
Forms::design:mouse_move %x %y
}
pack $base.c \
-in .pgaw:FormDesign:draft -anchor center -expand 1 -fill both -side top
}
proc vTclWindow.pgaw:FormDesign:attributes {base} {
if {$base == ""} {
set base .pgaw:FormDesign:attributes
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
wm geometry $base 237x300+461+221
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 [intlmsg "Attributes"]
# The identification frame
frame $base.fi \
-borderwidth 2 -height 75 -relief groove -width 125
label $base.fi.lclass \
-borderwidth 0 -text [intlmsg Class]
entry $base.fi.eclass -textvariable PgAcVar(fdvar,c_class) \
-borderwidth 1 -width 200
label $base.fi.lname \
-borderwidth 0 -text [intlmsg Name]
entry $base.fi.ename -textvariable PgAcVar(fdvar,c_name) \
-background #fefefe -borderwidth 1 -width 200
bind $base.fi.ename <Key-Return> {
Forms::design:set_name
}
# The geometry frame
frame $base.fg \
-borderwidth 2 -height 75 -relief groove -width 125
entry $base.fg.e1 -textvariable PgAcVar(fdvar,c_width) \
-background #fefefe -borderwidth 1 -width 5
entry $base.fg.e2 -textvariable PgAcVar(fdvar,c_height) \
-background #fefefe -borderwidth 1 -width 5
entry $base.fg.e3 -textvariable PgAcVar(fdvar,c_left) \
-background #fefefe -borderwidth 1 -width 5
entry $base.fg.e4 -textvariable PgAcVar(fdvar,c_top) \
-background #fefefe -borderwidth 1 -width 5
bind $base.fg.e1 <Key-Return> {
Forms::design:change_coords
}
bind $base.fg.e2 <Key-Return> {
Forms::design:change_coords
}
bind $base.fg.e3 <Key-Return> {
Forms::design:change_coords
}
bind $base.fg.e4 <Key-Return> {
Forms::design:change_coords
}
label $base.fg.l1 \
-borderwidth 0 -text Width
label $base.fg.l2 \
-borderwidth 0 -text Height
label $base.fg.l3 \
-borderwidth 0 -text Left
label $base.fg.l4 \
-borderwidth 0 -text Top
label $base.fg.lx1 \
-borderwidth 0 -text x
label $base.fg.lp1 \
-borderwidth 0 -text +
label $base.fg.lp2 \
-borderwidth 0 -text +
# The frame for the rest of the attributes (dynamically generated)
frame $base.f \
-borderwidth 2 -height 75 -relief groove -width 125
# Geometry for "identification frame"
place $base.fi \
-x 5 -y 5 -width 230 -height 55 -anchor nw -bordermode ignore
grid columnconf $base.fi 1 -weight 1
grid $base.fi.lclass \
-in $base.fi -column 0 -row 0 -columnspan 1 -rowspan 1 -sticky w
grid $base.fi.eclass \
-in $base.fi -column 1 -row 0 -columnspan 1 -rowspan 1 -padx 2 \
-sticky w
grid $base.fi.lname \
-in $base.fi -column 0 -row 1 -columnspan 1 -rowspan 1 -sticky w
grid $base.fi.ename \
-in $base.fi -column 1 -row 1 -columnspan 1 -rowspan 1 -padx 2 \
-sticky w
# Geometry for "geometry frame"
place $base.fg \
-x 5 -y 60 -width 230 -height 45 -anchor nw -bordermode ignore
grid $base.fg.e1 \
-in $base.fg -column 0 -row 0 -columnspan 1 -rowspan 1
grid $base.fg.e2 \
-in $base.fg -column 2 -row 0 -columnspan 1 -rowspan 1
grid $base.fg.e3 \
-in $base.fg -column 4 -row 0 -columnspan 1 -rowspan 1
grid $base.fg.e4 \
-in $base.fg -column 6 -row 0 -columnspan 1 -rowspan 1
grid $base.fg.l1 \
-in $base.fg -column 0 -row 1 -columnspan 1 -rowspan 1
grid $base.fg.l2 \
-in $base.fg -column 2 -row 1 -columnspan 1 -rowspan 1
grid $base.fg.l3 \
-in $base.fg -column 4 -row 1 -columnspan 1 -rowspan 1
grid $base.fg.l4 \
-in $base.fg -column 6 -row 1 -columnspan 1 -rowspan 1
grid $base.fg.lx1 \
-in $base.fg -column 1 -row 0 -columnspan 1 -rowspan 1
grid $base.fg.lp1 \
-in $base.fg -column 5 -row 0 -columnspan 1 -rowspan 1
grid $base.fg.lp2 \
-in $base.fg -column 3 -row 0 -columnspan 1 -rowspan 1
place $base.f -x 5 -y 105 -width 230 -height 190 -anchor nw
}
proc vTclWindow.pgaw:FormDesign:commands {base} {
global PgAcVar
if {$base == ""} {
set base .pgaw:FormDesign:commands
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
wm geometry $base 640x480+120+100
wm maxsize $base 785 570
wm minsize $base 1 19
wm overrideredirect $base 0
wm resizable $base 1 1
wm title $base [intlmsg "Command"]
frame $base.f \
-borderwidth 2 -height 75 -relief groove -width 125
scrollbar $base.f.sb \
-borderwidth 1 -command {.pgaw:FormDesign:commands.f.txt yview} -orient vert -width 12
text $base.f.txt \
-font $PgAcVar(pref,font_fix) -height 1 -tabs {20 40 60 80 100 120 140 160 180 200} \
-width 200 -yscrollcommand {.pgaw:FormDesign:commands.f.sb set}
frame $base.fb \
-height 75 -width 125
button $base.fb.b1 \
-borderwidth 1 \
-command {
set PgAcVar(fdobj,$PgAcVar(fdvar,commandFor),command) [.pgaw:FormDesign:commands.f.txt get 1.0 "end - 1 chars"]
Window hide .pgaw:FormDesign:commands
set PgAcVar(fdvar,dirty) 1
} -text [intlmsg Save] -width 5
button $base.fb.b2 \
-borderwidth 1 -command {Window hide .pgaw:FormDesign:commands} \
-text [intlmsg Cancel]
pack $base.f \
-in .pgaw:FormDesign:commands -anchor center -expand 1 -fill both -side top
pack $base.f.sb \
-in .pgaw:FormDesign:commands.f -anchor e -expand 1 -fill y -side right
pack $base.f.txt \
-in .pgaw:FormDesign:commands.f -anchor center -expand 1 -fill both -side top
pack $base.fb \
-in .pgaw:FormDesign:commands -anchor center -expand 0 -fill none -side top
pack $base.fb.b1 \
-in .pgaw:FormDesign:commands.fb -anchor center -expand 0 -fill none -side left
pack $base.fb.b2 \
-in .pgaw:FormDesign:commands.fb -anchor center -expand 0 -fill none -side top
}
proc vTclWindow.pgaw:FormDesign:menu {base} {
if {$base == ""} {
set base .pgaw:FormDesign:menu
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
wm geometry $base 432x74+0+0
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 [intlmsg "Form designer"]
frame $base.f1 \
-height 75 -relief groove -width 125
label $base.f1.l1 \
-borderwidth 0 -text "[intlmsg {Form name}] "
entry $base.f1.e1 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(fdvar,formtitle)
frame $base.f2 \
-height 75 -relief groove -width 125
label $base.f2.l \
-borderwidth 0 -text "[intlmsg {Form's window internal name}] "
entry $base.f2.e \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(fdobj,0,name)
frame $base.f3 \
-height 1 -width 125
button $base.f3.b1 \
-command {set PgAcVar(fdvar,geometry) [wm geometry .pgaw:FormDesign:draft] ; Forms::design:run} -padx 1 \
-text [intlmsg {Test form}]
button $base.f3.b2 \
-command {destroy .$PgAcVar(fdobj,0,name)} -padx 1 \
-text [intlmsg {Close test form}]
button $base.f3.b3 \
-command {Forms::design:save nimic} -padx 1 -text [intlmsg Save]
button $base.f3.b4 \
-command {Forms::design:close} \
-padx 1 -text [intlmsg Close]
pack $base.f1 \
-in .pgaw:FormDesign:menu -anchor center -expand 0 -fill x -pady 2 -side top
pack $base.f1.l1 \
-in .pgaw:FormDesign:menu.f1 -anchor center -expand 0 -fill none -side left
pack $base.f1.e1 \
-in .pgaw:FormDesign:menu.f1 -anchor center -expand 1 -fill x -side left
pack $base.f2 \
-in .pgaw:FormDesign:menu -anchor center -expand 0 -fill x -pady 1 -side top
pack $base.f2.l \
-in .pgaw:FormDesign:menu.f2 -anchor center -expand 0 -fill none -side left
pack $base.f2.e \
-in .pgaw:FormDesign:menu.f2 -anchor center -expand 1 -fill x -side left
pack $base.f3 \
-in .pgaw:FormDesign:menu -anchor center -expand 0 -fill x -pady 2 -side bottom
pack $base.f3.b1 \
-in .pgaw:FormDesign:menu.f3 -anchor center -expand 0 -fill none -side left
pack $base.f3.b2 \
-in .pgaw:FormDesign:menu.f3 -anchor center -expand 0 -fill none -side left
pack $base.f3.b3 \
-in .pgaw:FormDesign:menu.f3 -anchor center -expand 0 -fill none -side left
pack $base.f3.b4 \
-in .pgaw:FormDesign:menu.f3 -anchor center -expand 0 -fill none -side right
}
proc vTclWindow.pgaw:FormDesign:toolbar {base} {
global PgAcVar
foreach wid {button frame radiobutton checkbutton label text entry listbox query} {
image create photo "icon_$wid" -file [file join $PgAcVar(PGACCESS_HOME) images icon_$wid.gif]
}
if {$base == ""} {
set base .pgaw:FormDesign:toolbar
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel -menu .pgaw:FormDesign:toolbar.m17
wm focusmodel $base passive
wm geometry $base 29x235+1+130
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 [intlmsg "Toolbar"]
button $base.b1 \
-borderwidth 1 -command {set PgAcVar(fdvar,tool) button} -image icon_button \
-padx 9 -pady 3
button $base.b3 \
-borderwidth 1 -command {set PgAcVar(fdvar,tool) radio} \
-image icon_radiobutton -padx 9 -pady 3
button $base.b4 \
-borderwidth 1 -command {set PgAcVar(fdvar,tool) checkbox} \
-image icon_checkbutton -padx 9 -pady 3
button $base.b5 \
-borderwidth 1 -command {set PgAcVar(fdvar,tool) label} -image icon_label \
-padx 9 -pady 3
button $base.b6 \
-borderwidth 1 -command {set PgAcVar(fdvar,tool) text} -image icon_text \
-padx 9 -pady 3
button $base.b7 \
-borderwidth 1 -command {set PgAcVar(fdvar,tool) entry} -image icon_entry \
-padx 9 -pady 3
button $base.b8 \
-borderwidth 1 -command {set PgAcVar(fdvar,tool) listbox} -image icon_listbox \
-padx 9 -pady 3
button $base.b9 \
-borderwidth 1 -command {set PgAcVar(fdvar,tool) query} -height 21 \
-image icon_query -padx 9 -pady 3 -width 20
grid $base.b1 \
-in .pgaw:FormDesign:toolbar -column 0 -row 2 -columnspan 1 -rowspan 1
grid $base.b3 \
-in .pgaw:FormDesign:toolbar -column 0 -row 4 -columnspan 1 -rowspan 1
grid $base.b4 \
-in .pgaw:FormDesign:toolbar -column 0 -row 5 -columnspan 1 -rowspan 1
grid $base.b5 \
-in .pgaw:FormDesign:toolbar -column 0 -row 0 -columnspan 1 -rowspan 1
grid $base.b6 \
-in .pgaw:FormDesign:toolbar -column 0 -row 6 -columnspan 1 -rowspan 1
grid $base.b7 \
-in .pgaw:FormDesign:toolbar -column 0 -row 1 -columnspan 1 -rowspan 1
grid $base.b8 \
-in .pgaw:FormDesign:toolbar -column 0 -row 7 -columnspan 1 -rowspan 1
grid $base.b9 \
-in .pgaw:FormDesign:toolbar -column 0 -row 8 -columnspan 2 -rowspan 3
}
src/bin/pgaccess/lib/functions.tcl 0 → 100644
View file @ 25acbc51
namespace eval Functions {
proc {new} {} {
global PgAcVar
Window show .pgaw:Function
set PgAcVar(function,name) {}
set PgAcVar(function,nametodrop) {}
set PgAcVar(function,parameters) {}
set PgAcVar(function,returns) {}
set PgAcVar(function,language) {}
.pgaw:Function.fs.text1 delete 1.0 end
focus .pgaw:Function.fp.e1
wm transient .pgaw:Function .pgaw:Main
}
proc {design} {functionname} {
global PgAcVar CurrentDB
Window show .pgaw:Function
.pgaw:Function.fs.text1 delete 1.0 end
wpg_select $CurrentDB "select * from pg_proc where proname='$functionname'" rec {
set PgAcVar(function,name) $functionname
set temppar $rec(proargtypes)
set PgAcVar(function,returns) [Database::getPgType $rec(prorettype)]
set funcnrp $rec(pronargs)
set prolanguage $rec(prolang)
.pgaw:Function.fs.text1 insert end $rec(prosrc)
}
wpg_select $CurrentDB "select lanname from pg_language where oid=$prolanguage" rec {
set PgAcVar(function,language) $rec(lanname)
}
if { $PgAcVar(function,language)=="C" || $PgAcVar(function,language)=="c" } {
wpg_select $CurrentDB "select probin from pg_proc where proname='$functionname'" rec {
.pgaw:Function.fs.text1 delete 1.0 end
.pgaw:Function.fs.text1 insert end $rec(probin)
}
}
set PgAcVar(function,parameters) {}
for {set i 0} {$i<$funcnrp} {incr i} {
lappend PgAcVar(function,parameters) [Database::getPgType [lindex $temppar $i]]
}
set PgAcVar(function,parameters) [join $PgAcVar(function,parameters) ,]
set PgAcVar(function,nametodrop) "$PgAcVar(function,name) ($PgAcVar(function,parameters))"
}
proc {save} {} {
global PgAcVar
if {$PgAcVar(function,name)==""} {
focus .pgaw:Function.fp.e1
showError [intlmsg "You must supply a name for this function!"]
} elseif {$PgAcVar(function,returns)==""} {
focus .pgaw:Function.fp.e3
showError [intlmsg "You must supply a return type!"]
} elseif {$PgAcVar(function,language)==""} {
focus .pgaw:Function.fp.e4
showError [intlmsg "You must supply the function language!"]
} else {
set funcbody [.pgaw:Function.fs.text1 get 1.0 end]
regsub -all "\n" $funcbody " " funcbody
if {$PgAcVar(function,nametodrop) != ""} {
if {! [sql_exec noquiet "drop function $PgAcVar(function,nametodrop)"]} {
return
}
}
if {[sql_exec noquiet "create function $PgAcVar(function,name) ($PgAcVar(function,parameters)) returns $PgAcVar(function,returns) as '$funcbody' language '$PgAcVar(function,language)'"]} {
Window destroy .pgaw:Function
tk_messageBox -title PostgreSQL -parent .pgaw:Main -message [intlmsg "Function saved!"]
Mainlib::tab_click Functions
}
}
}
}
proc vTclWindow.pgaw:Function {base} {
global PgAcVar
if {$base == ""} {
set base .pgaw:Function
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
wm geometry $base 480x330+98+212
wm maxsize $base 1009 738
wm minsize $base 480 330
wm overrideredirect $base 0
wm resizable $base 1 1
wm deiconify $base
wm title $base [intlmsg "Function"]
bind $base <Key-F1> "Help::load functions"
frame $base.fp \
-height 88 -relief groove -width 125
label $base.fp.l1 \
-borderwidth 0 -relief raised -text [intlmsg Name]
entry $base.fp.e1 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(function,name)
bind $base.fp.e1 <Key-Return> {
focus .pgaw:Function.fp.e2
}
label $base.fp.l2 \
-borderwidth 0 -relief raised -text [intlmsg Parameters]
entry $base.fp.e2 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(function,parameters) -width 15
bind $base.fp.e2 <Key-Return> {
focus .pgaw:Function.fp.e3
}
label $base.fp.l3 \
-borderwidth 0 -relief raised -text [intlmsg Returns]
entry $base.fp.e3 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(function,returns)
bind $base.fp.e3 <Key-Return> {
focus .pgaw:Function.fp.e4
}
label $base.fp.l4 \
-borderwidth 0 -relief raised -text [intlmsg Language]
entry $base.fp.e4 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(function,language) -width 15
bind $base.fp.e4 <Key-Return> {
focus .pgaw:Function.fs.text1
}
label $base.fp.lspace \
-borderwidth 0 -relief raised -text { }
frame $base.fs \
-borderwidth 2 -height 75 -relief groove -width 125
text $base.fs.text1 \
-background #fefefe -foreground #000000 -borderwidth 1 -font $PgAcVar(pref,font_fix) -height 16 \
-tabs {20 40 60 80 100 120} -width 43 -yscrollcommand {.pgaw:Function.fs.vsb set}
scrollbar $base.fs.vsb \
-borderwidth 1 -command {.pgaw:Function.fs.text1 yview} -orient vert
frame $base.fb \
-borderwidth 2 -height 75 -width 125
frame $base.fb.fbc \
-borderwidth 2 -height 75 -width 125
button $base.fb.fbc.btnsave -command {Functions::save} \
-borderwidth 1 -padx 9 -pady 3 -text [intlmsg Save]
button $base.fb.fbc.btnhelp -command {Help::load functions} \
-borderwidth 1 -padx 9 -pady 3 -text [intlmsg Help]
button $base.fb.fbc.btncancel \
-borderwidth 1 -command {Window destroy .pgaw:Function} -padx 9 -pady 3 \
-text [intlmsg Cancel]
pack $base.fp \
-in .pgaw:Function -anchor center -expand 0 -fill x -side top
grid $base.fp.l1 \
-in .pgaw:Function.fp -column 0 -row 0 -columnspan 1 -rowspan 1 -sticky w
grid $base.fp.e1 \
-in .pgaw:Function.fp -column 1 -row 0 -columnspan 1 -rowspan 1
grid $base.fp.l2 \
-in .pgaw:Function.fp -column 3 -row 0 -columnspan 1 -rowspan 1 -sticky w
grid $base.fp.e2 \
-in .pgaw:Function.fp -column 4 -row 0 -columnspan 1 -rowspan 1 -pady 2
grid $base.fp.l3 \
-in .pgaw:Function.fp -column 0 -row 4 -columnspan 1 -rowspan 1 -sticky w
grid $base.fp.e3 \
-in .pgaw:Function.fp -column 1 -row 4 -columnspan 1 -rowspan 1
grid $base.fp.l4 \
-in .pgaw:Function.fp -column 3 -row 4 -columnspan 1 -rowspan 1 -sticky w
grid $base.fp.e4 \
-in .pgaw:Function.fp -column 4 -row 4 -columnspan 1 -rowspan 1 -pady 3
grid $base.fp.lspace \
-in .pgaw:Function.fp -column 2 -row 4 -columnspan 1 -rowspan 1
pack $base.fs \
-in .pgaw:Function -anchor center -expand 1 -fill both -side top
pack $base.fs.text1 \
-in .pgaw:Function.fs -anchor center -expand 1 -fill both -side left
pack $base.fs.vsb \
-in .pgaw:Function.fs -anchor center -expand 0 -fill y -side right
pack $base.fb \
-in .pgaw:Function -anchor center -expand 0 -fill x -side bottom
pack $base.fb.fbc \
-in .pgaw:Function.fb -anchor center -expand 0 -fill none -side top
pack $base.fb.fbc.btnsave \
-in .pgaw:Function.fb.fbc -anchor center -expand 0 -fill none -side left
pack $base.fb.fbc.btnhelp \
-in .pgaw:Function.fb.fbc -anchor center -expand 0 -fill none -side left
pack $base.fb.fbc.btncancel \
-in .pgaw:Function.fb.fbc -anchor center -expand 0 -fill none -side right
}
src/bin/pgaccess/lib/help.tcl 0 → 100644
View file @ 25acbc51
namespace eval Help {
proc {findLink} {} {
foreach tagname [.pgaw:Help.f.t tag names current] {
if {$tagname!="link"} {
load $tagname
return
}
}
}
proc {load} {topic args} {
global PgAcVar
if {![winfo exists .pgaw:Help]} {
Window show .pgaw:Help
tkwait visibility .pgaw:Help
}
wm deiconify .pgaw:Help
if {![info exists PgAcVar(help,history)]} {
set PgAcVar(help,history) {}
}
if {[llength $args]==1} {
set PgAcVar(help,current_topic) [lindex $args 0]
set PgAcVar(help,history) [lrange $PgAcVar(help,history) 0 [lindex $args 0]]
} else {
lappend PgAcVar(help,history) $topic
set PgAcVar(help,current_topic) [expr {[llength $PgAcVar(help,history)]-1}]
}
# Limit the history length to 100 topics
if {[llength $PgAcVar(help,history)]>100} {
set PgAcVar(help,history) [lrange $PgAcVar(help,history) 1 end]
}
.pgaw:Help.f.t configure -state normal
.pgaw:Help.f.t delete 1.0 end
.pgaw:Help.f.t tag configure bold -font $PgAcVar(pref,font_bold)
.pgaw:Help.f.t tag configure italic -font $PgAcVar(pref,font_italic)
.pgaw:Help.f.t tag configure large -font {Helvetica -14 bold}
.pgaw:Help.f.t tag configure title -font $PgAcVar(pref,font_bold) -justify center
.pgaw:Help.f.t tag configure link -font {Helvetica -12 underline} -foreground #000080
.pgaw:Help.f.t tag configure code -font $PgAcVar(pref,font_fix)
.pgaw:Help.f.t tag configure warning -font $PgAcVar(pref,font_bold) -foreground #800000
.pgaw:Help.f.t tag bind link <Button-1> {Help::findLink}
set errmsg {}
.pgaw:Help.f.t configure -tabs {30 60 90 120 150 180 210 240 270 300 330 360 390}
catch { source [file join $PgAcVar(PGACCESS_HOME) lib help $topic.hlp] } errmsg
if {$errmsg!=""} {
.pgaw:Help.f.t insert end "Error loading help file [file join $PgAcVar(PGACCESS_HOME) $topic.hlp]\n\n$errmsg" bold
}
.pgaw:Help.f.t configure -state disabled
focus .pgaw:Help.f.sb
}
proc {back} {} {
global PgAcVar
if {![info exists PgAcVar(help,history)]} {return}
if {[llength $PgAcVar(help,history)]==0} {return}
set i $PgAcVar(help,current_topic)
if {$i<1} {return}
incr i -1
load [lindex $PgAcVar(help,history) $i] $i
}
}
proc vTclWindow.pgaw:Help {base} {
global PgAcVar
if {$base == ""} {
set base .pgaw:Help
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
set sw [winfo screenwidth .]
set sh [winfo screenheight .]
set x [expr {($sw - 640)/2}]
set y [expr {($sh - 480)/2}]
wm geometry $base 640x480+$x+$y
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 [intlmsg "Help"]
bind $base <Key-Escape> "Window destroy .pgaw:Help"
frame $base.fb \
-borderwidth 2 -height 75 -relief groove -width 125
button $base.fb.bback \
-command Help::back -padx 9 -pady 3 -text [intlmsg Back]
button $base.fb.bi \
-command {Help::load index} -padx 9 -pady 3 -text [intlmsg Index]
button $base.fb.bp \
-command {Help::load postgresql} -padx 9 -pady 3 -text PostgreSQL
button $base.fb.btnclose \
-command {Window destroy .pgaw:Help} -padx 9 -pady 3 -text [intlmsg Close]
frame $base.f \
-borderwidth 2 -height 75 -relief groove -width 125
text $base.f.t \
-borderwidth 1 -cursor {} -font $PgAcVar(pref,font_normal) -height 2 \
-highlightthickness 0 -state disabled \
-tabs {30 60 90 120 150 180 210 240 270 300 330 360 390} -width 8 \
-wrap word -yscrollcommand {.pgaw:Help.f.sb set}
scrollbar $base.f.sb \
-borderwidth 1 -command {.pgaw:Help.f.t yview} -highlightthickness 0 \
-orient vert
pack $base.fb \
-in .pgaw:Help -anchor center -expand 0 -fill x -side top
pack $base.fb.bback \
-in .pgaw:Help.fb -anchor center -expand 0 -fill none -side left
pack $base.fb.bi \
-in .pgaw:Help.fb -anchor center -expand 0 -fill none -side left
pack $base.fb.bp \
-in .pgaw:Help.fb -anchor center -expand 0 -fill none -side left
pack $base.fb.btnclose \
-in .pgaw:Help.fb -anchor center -expand 0 -fill none -side right
pack $base.f \
-in .pgaw:Help -anchor center -expand 1 -fill both -side top
pack $base.f.t \
-in .pgaw:Help.f -anchor center -expand 1 -fill both -side left
pack $base.f.sb \
-in .pgaw:Help.f -anchor center -expand 0 -fill y -side right
}
src/bin/pgaccess/lib/mainlib.tcl 0 → 100644
View file @ 25acbc51
namespace eval Mainlib {
proc {cmd_Delete} {} {
global PgAcVar CurrentDB
if {$CurrentDB==""} return;
set objtodelete [get_dwlb_Selection]
if {$objtodelete==""} return;
set delmsg [format [intlmsg "You are going to delete\n\n %s \n\nProceed?"] $objtodelete]
if {[tk_messageBox -title [intlmsg "FINAL WARNING"] -parent .pgaw:Main -message $delmsg -type yesno -default no]=="no"} { return }
switch $PgAcVar(activetab) {
Tables {
sql_exec noquiet "drop table \"$objtodelete\""
sql_exec quiet "delete from pga_layout where tablename='$objtodelete'"
cmd_Tables
}
Schema {
sql_exec quiet "delete from pga_schema where schemaname='$objtodelete'"
cmd_Schema
}
Views {
sql_exec noquiet "drop view \"$objtodelete\""
sql_exec quiet "delete from pga_layout where tablename='$objtodelete'"
cmd_Views
}
Queries {
sql_exec quiet "delete from pga_queries where queryname='$objtodelete'"
sql_exec quiet "delete from pga_layout where tablename='$objtodelete'"
cmd_Queries
}
Scripts {
sql_exec quiet "delete from pga_scripts where scriptname='$objtodelete'"
cmd_Scripts
}
Forms {
sql_exec quiet "delete from pga_forms where formname='$objtodelete'"
cmd_Forms
}
Sequences {
sql_exec quiet "drop sequence \"$objtodelete\""
cmd_Sequences
}
Functions {
delete_function $objtodelete
cmd_Functions
}
Reports {
sql_exec noquiet "delete from pga_reports where reportname='$objtodelete'"
cmd_Reports
}
Users {
sql_exec noquiet "drop user \"$objtodelete\""
cmd_Users
}
}
}
proc {cmd_Design} {} {
global PgAcVar CurrentDB
if {$CurrentDB==""} return;
if {[.pgaw:Main.lb curselection]==""} return;
set objname [.pgaw:Main.lb get [.pgaw:Main.lb curselection]]
set tablename $objname
switch $PgAcVar(activetab) {
Tables {
Tables::design $objname
}
Schema {
Schema::open $objname
}
Queries {
Queries::design $objname
}
Views {
Views::design $objname
}
Scripts {
Scripts::design $objname
}
Forms {
Forms::design $objname
}
Functions {
Functions::design $objname
}
Reports {
Reports::design $objname
}
Users {
Users::design $objname
}
}
}
proc {cmd_Forms} {} {
global CurrentDB
setCursor CLOCK
.pgaw:Main.lb delete 0 end
catch {
wpg_select $CurrentDB "select formname from pga_forms order by formname" rec {
.pgaw:Main.lb insert end $rec(formname)
}
}
setCursor DEFAULT
}
proc {cmd_Functions} {} {
global CurrentDB
set maxim 16384
setCursor CLOCK
catch {
wpg_select $CurrentDB "select oid from pg_database where datname='template1'" rec {
set maxim $rec(oid)
}
}
.pgaw:Main.lb delete 0 end
catch {
wpg_select $CurrentDB "select proname from pg_proc where oid>$maxim order by proname" rec {
.pgaw:Main.lb insert end $rec(proname)
}
}
setCursor DEFAULT
}
proc {cmd_Import_Export} {how} {
global PgAcVar CurrentDB
if {$CurrentDB==""} return;
Window show .pgaw:ImportExport
set PgAcVar(impexp,tablename) {}
set PgAcVar(impexp,filename) {}
set PgAcVar(impexp,delimiter) {}
if {$PgAcVar(activetab)=="Tables"} {
set tn [get_dwlb_Selection]
set PgAcVar(impexp,tablename) $tn
if {$tn!=""} {set PgAcVar(impexp,filename) "$tn.txt"}
}
.pgaw:ImportExport.expbtn configure -text [intlmsg $how]
}
proc {cmd_New} {} {
global PgAcVar CurrentDB
if {$CurrentDB==""} return;
switch $PgAcVar(activetab) {
Tables {
Tables::new
}
Schema {
Schema::new
}
Queries {
Queries::new
}
Users {
Users::new
}
Views {
Views::new
}
Sequences {
Sequences::new
}
Reports {
Reports::new
}
Forms {
Forms::new
}
Scripts {
Scripts::new
}
Functions {
Functions::new
}
}
}
proc {cmd_Open} {} {
global PgAcVar CurrentDB
if {$CurrentDB==""} return;
set objname [get_dwlb_Selection]
if {$objname==""} return;
switch $PgAcVar(activetab) {
Tables { Tables::open $objname }
Schema { Schema::open $objname }
Forms { Forms::open $objname }
Scripts { Scripts::open $objname }
Queries { Queries::open $objname }
Views { Views::open $objname }
Sequences { Sequences::open $objname }
Functions { Functions::design $objname }
Reports { Reports::open $objname }
}
}
proc {cmd_Queries} {} {
global CurrentDB
.pgaw:Main.lb delete 0 end
catch {
wpg_select $CurrentDB "select queryname from pga_queries order by queryname" rec {
.pgaw:Main.lb insert end $rec(queryname)
}
}
}
proc {cmd_Rename} {} {
global PgAcVar CurrentDB
if {$CurrentDB==""} return;
if {$PgAcVar(activetab)=="Views"} return;
if {$PgAcVar(activetab)=="Sequences"} return;
if {$PgAcVar(activetab)=="Functions"} return;
if {$PgAcVar(activetab)=="Users"} return;
set temp [get_dwlb_Selection]
if {$temp==""} {
tk_messageBox -title [intlmsg Warning] -parent .pgaw:Main -message [intlmsg "Please select an object first!"]
return;
}
set PgAcVar(Old_Object_Name) $temp
Window show .pgaw:RenameObject
}
proc {cmd_Reports} {} {
global CurrentDB
setCursor CLOCK
catch {
wpg_select $CurrentDB "select reportname from pga_reports order by reportname" rec {
.pgaw:Main.lb insert end "$rec(reportname)"
}
}
setCursor DEFAULT
}
proc {cmd_Users} {} {
global CurrentDB
setCursor CLOCK
.pgaw:Main.lb delete 0 end
catch {
wpg_select $CurrentDB "select * from pg_user order by usename" rec {
.pgaw:Main.lb insert end $rec(usename)
}
}
setCursor DEFAULT
}
proc {cmd_Scripts} {} {
global CurrentDB
setCursor CLOCK
.pgaw:Main.lb delete 0 end
catch {
wpg_select $CurrentDB "select scriptname from pga_scripts order by scriptname" rec {
.pgaw:Main.lb insert end $rec(scriptname)
}
}
setCursor DEFAULT
}
proc {cmd_Sequences} {} {
global CurrentDB
setCursor CLOCK
.pgaw:Main.lb delete 0 end
catch {
wpg_select $CurrentDB "select relname from pg_class where (relname not like 'pg_%') and (relkind='S') order by relname" rec {
.pgaw:Main.lb insert end $rec(relname)
}
}
setCursor DEFAULT
}
proc {cmd_Tables} {} {
global CurrentDB
setCursor CLOCK
.pgaw:Main.lb delete 0 end
foreach tbl [Database::getTablesList] {.pgaw:Main.lb insert end $tbl}
setCursor DEFAULT
}
proc {cmd_Schema} {} {
global CurrentDB
.pgaw:Main.lb delete 0 end
catch {
wpg_select $CurrentDB "select schemaname from pga_schema order by schemaname" rec {
.pgaw:Main.lb insert end $rec(schemaname)
}
}
}
proc {cmd_Views} {} {
global CurrentDB
setCursor CLOCK
.pgaw:Main.lb delete 0 end
catch {
wpg_select $CurrentDB "select c.relname,count(c.relname) from pg_class C, pg_rewrite R where (relname !~ '^pg_') and (r.ev_class = C.oid) and (r.ev_type = '1') group by relname" rec {
if {$rec(count)!=0} {
set itsaview($rec(relname)) 1
}
}
wpg_select $CurrentDB "select relname from pg_class where (relname !~ '^pg_') and (relkind='r') and (relhasrules) order by relname" rec {
if {[info exists itsaview($rec(relname))]} {
.pgaw:Main.lb insert end $rec(relname)
}
}
}
setCursor DEFAULT
}
proc {delete_function} {objname} {
global CurrentDB
wpg_select $CurrentDB "select proargtypes,pronargs from pg_proc where proname='$objname'" rec {
set PgAcVar(function,parameters) $rec(proargtypes)
set nrpar $rec(pronargs)
}
set lispar {}
for {set i 0} {$i<$nrpar} {incr i} {
lappend lispar [Database::getPgType [lindex $PgAcVar(function,parameters) $i]]
}
set lispar [join $lispar ,]
sql_exec noquiet "drop function $objname ($lispar)"
}
proc {draw_tabs} {} {
global PgAcVar
set ypos 85
foreach tab $PgAcVar(tablist) {
label .pgaw:Main.tab$tab -borderwidth 1 -anchor w -relief raised -text [intlmsg $tab]
place .pgaw:Main.tab$tab -x 10 -y $ypos -height 25 -width 82 -anchor nw -bordermode ignore
lower .pgaw:Main.tab$tab
bind .pgaw:Main.tab$tab <Button-1> "Mainlib::tab_click $tab"
incr ypos 25
}
set PgAcVar(activetab) ""
}
proc {get_dwlb_Selection} {} {
set temp [.pgaw:Main.lb curselection]
if {$temp==""} return "";
return [.pgaw:Main.lb get $temp]
}
proc {sqlw_display} {msg} {
if {![winfo exists .pgaw:SQLWindow]} {return}
.pgaw:SQLWindow.f.t insert end "$msg\n\n"
.pgaw:SQLWindow.f.t see end
set nrlines [lindex [split [.pgaw:SQLWindow.f.t index end] .] 0]
if {$nrlines>50} {
.pgaw:SQLWindow.f.t delete 1.0 3.0
}
}
proc {open_database} {} {
global PgAcVar CurrentDB
setCursor CLOCK
if {$PgAcVar(opendb,username)!=""} {
if {$PgAcVar(opendb,host)!=""} {
set connres [catch {set newdbc [pg_connect -conninfo "host=$PgAcVar(opendb,host) port=$PgAcVar(opendb,pgport) dbname=$PgAcVar(opendb,dbname) user=$PgAcVar(opendb,username) password=$PgAcVar(opendb,password)"]} msg]
} else {
set connres [catch {set newdbc [pg_connect -conninfo "dbname=$PgAcVar(opendb,dbname) user=$PgAcVar(opendb,username) password=$PgAcVar(opendb,password)"]} msg]
}
} else {
set connres [catch {set newdbc [pg_connect $PgAcVar(opendb,dbname) -host $PgAcVar(opendb,host) -port $PgAcVar(opendb,pgport)]} msg]
}
if {$connres} {
setCursor DEFAULT
showError [format [intlmsg "Error trying to connect to database '%s' on host %s \n\nPostgreSQL error message:%s"] $PgAcVar(opendb,dbname) $PgAcVar(opendb,host) $msg"]
return $msg
} else {
catch {pg_disconnect $CurrentDB}
set CurrentDB $newdbc
set PgAcVar(currentdb,host) $PgAcVar(opendb,host)
set PgAcVar(currentdb,pgport) $PgAcVar(opendb,pgport)
set PgAcVar(currentdb,dbname) $PgAcVar(opendb,dbname)
set PgAcVar(currentdb,username) $PgAcVar(opendb,username)
set PgAcVar(currentdb,password) $PgAcVar(opendb,password)
set PgAcVar(statusline,dbname) $PgAcVar(currentdb,dbname)
set PgAcVar(pref,lastdb) $PgAcVar(currentdb,dbname)
set PgAcVar(pref,lasthost) $PgAcVar(currentdb,host)
set PgAcVar(pref,lastport) $PgAcVar(currentdb,pgport)
set PgAcVar(pref,lastusername) $PgAcVar(currentdb,username)
Preferences::save
catch {setCursor DEFAULT ; Window hide .pgaw:OpenDB}
tab_click Tables
# Check for pga_ tables
foreach {table structure} {pga_queries {queryname varchar(64),querytype char(1),querycommand text,querytables text,querylinks text,queryresults text,querycomments 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} pga_schema {schemaname varchar(64),schematables text,schemalinks text}} {
set pgres [wpg_exec $CurrentDB "select relname from pg_class where relname='$table'"]
if {$PgAcVar(pgsql,status)!="PGRES_TUPLES_OK"} {
showError "[intlmsg {FATAL ERROR searching for PgAccess system tables}] : $PgAcVar(pgsql,errmsg)\nStatus:$PgAcVar(pgsql,status)"
catch {pg_disconnect $CurrentDB}
exit
} elseif {[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"
} else {
foreach fieldspec [split $structure ,] {
set field [lindex [split $fieldspec] 0]
set pgres [wpg_exec $CurrentDB "select \"$field\" from \"$table\""]
if {$PgAcVar(pgsql,status)!="PGRES_TUPLES_OK"} {
if {![regexp "attribute '$field' not found" $PgAcVar(pgsql,errmsg)]} {
showError "[intlmsg {FATAL ERROR upgrading PgAccess table}] $table: $PgAcVar(pgsql,errmsg)\nStatus:$PgAcVar(pgsql,status)"
catch {pg_disconnect $CurrentDB}
exit
} else {
pg_result $pgres -clear
sql_exec quiet "alter table \"$table\" add column $fieldspec "
}
}
}
}
catch {pg_result $pgres -clear}
}
# searching for autoexec script
wpg_select $CurrentDB "select * from pga_scripts where scriptname ~* '^autoexec$'" recd {
eval $recd(scriptsource)
}
return ""
}
}
proc {tab_click} {tabname} {
global PgAcVar CurrentDB
set w .pgaw:Main.tab$tabname
if {$CurrentDB==""} return;
set curtab $tabname
#if {$PgAcVar(activetab)==$curtab} return;
.pgaw:Main.btndesign configure -state disabled
if {$PgAcVar(activetab)!=""} {
place .pgaw:Main.tab$PgAcVar(activetab) -x 10
.pgaw:Main.tab$PgAcVar(activetab) configure -font $PgAcVar(pref,font_normal)
}
$w configure -font $PgAcVar(pref,font_bold)
place $w -x 7
place .pgaw:Main.lmask -x 80 -y [expr 86+25*[lsearch -exact $PgAcVar(tablist) $curtab]]
set PgAcVar(activetab) $curtab
# Tabs where button Design is enabled
if {[lsearch {Tables Schema Scripts Queries Functions Views Reports Forms Users} $PgAcVar(activetab)]!=-1} {
.pgaw:Main.btndesign configure -state normal
}
.pgaw:Main.lb delete 0 end
cmd_$curtab
}
}
proc vTclWindow.pgaw:Main {base} {
global PgAcVar
if {$base == ""} {
set base .pgaw:Main
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel \
-background #efefef -cursor left_ptr
wm focusmodel $base passive
wm geometry $base 332x390+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"
bind $base <Key-F1> "Help::load index"
label $base.labframe \
-relief raised
listbox $base.lb \
-background #fefefe \
-selectbackground #c3c3c3 \
-foreground black -highlightthickness 0 -selectborderwidth 0 \
-yscrollcommand {.pgaw:Main.sb set}
bind $base.lb <Double-Button-1> {
Mainlib::cmd_Open
}
button $base.btnnew \
-borderwidth 1 -command Mainlib::cmd_New -text [intlmsg New]
button $base.btnopen \
-borderwidth 1 -command Mainlib::cmd_Open -text [intlmsg Open]
button $base.btndesign \
-borderwidth 1 -command Mainlib::cmd_Design -text [intlmsg Design]
label $base.lmask \
-borderwidth 0 \
-text { }
frame $base.fm \
-borderwidth 1 -height 75 -relief raised -width 125
menubutton $base.fm.mndb \
-borderwidth 1 -font $PgAcVar(pref,font_normal) \
-menu .pgaw:Main.fm.mndb.01 -padx 4 -pady 3 -text [intlmsg Database]
menu $base.fm.mndb.01 \
-borderwidth 1 -font $PgAcVar(pref,font_normal) \
-tearoff 0
$base.fm.mndb.01 add command \
-command {
Window show .pgaw:OpenDB
set PgAcVar(opendb,host) $PgAcVar(currentdb,host)
set PgAcVar(opendb,pgport) $PgAcVar(currentdb,pgport)
focus .pgaw:OpenDB.f1.e3
wm transient .pgaw:OpenDB .pgaw:Main
.pgaw:OpenDB.f1.e3 selection range 0 end} \
-label [intlmsg Open] -font $PgAcVar(pref,font_normal)
$base.fm.mndb.01 add command \
-command {.pgaw:Main.lb delete 0 end
set CurrentDB {}
set PgAcVar(currentdb,dbname) {}
set PgAcVar(statusline,dbname) {}} \
-label [intlmsg Close]
$base.fm.mndb.01 add command \
-command Database::vacuum -label [intlmsg Vacuum]
$base.fm.mndb.01 add separator
$base.fm.mndb.01 add command \
-command {Mainlib::cmd_Import_Export Import} -label [intlmsg {Import table}]
$base.fm.mndb.01 add command \
-command {Mainlib::cmd_Import_Export Export} -label [intlmsg {Export table}]
$base.fm.mndb.01 add separator
$base.fm.mndb.01 add command \
-command Preferences::configure -label [intlmsg Preferences]
$base.fm.mndb.01 add command \
-command "Window show .pgaw:SQLWindow" -label [intlmsg "SQL window"]
$base.fm.mndb.01 add separator
$base.fm.mndb.01 add command \
-command {
set PgAcVar(activetab) {}
Preferences::save
catch {pg_disconnect $CurrentDB}
exit} -label [intlmsg Exit]
label $base.lshost \
-relief groove -text localhost -textvariable PgAcVar(currentdb,host)
label $base.lsdbname \
-anchor w \
-relief groove -textvariable PgAcVar(statusline,dbname)
scrollbar $base.sb \
-borderwidth 1 -command {.pgaw:Main.lb yview} -orient vert
menubutton $base.fm.mnob \
-borderwidth 1 \
-menu .pgaw:Main.fm.mnob.m -font $PgAcVar(pref,font_normal) -text [intlmsg Object]
menu $base.fm.mnob.m \
-borderwidth 1 -font $PgAcVar(pref,font_normal) \
-tearoff 0
$base.fm.mnob.m add command \
-command Mainlib::cmd_New -font $PgAcVar(pref,font_normal) -label [intlmsg New]
$base.fm.mnob.m add command \
-command Mainlib::cmd_Delete -label [intlmsg Delete]
$base.fm.mnob.m add command \
-command Mainlib::cmd_Rename -label [intlmsg Rename]
menubutton $base.fm.mnhelp \
-borderwidth 1 \
-menu .pgaw:Main.fm.mnhelp.m -font $PgAcVar(pref,font_normal) -text [intlmsg Help]
menu $base.fm.mnhelp.m \
-borderwidth 1 -font $PgAcVar(pref,font_normal) \
-tearoff 0
$base.fm.mnhelp.m add command \
-label [intlmsg Contents] -command {Help::load index}
$base.fm.mnhelp.m add command \
-label PostgreSQL -command {Help::load postgresql}
$base.fm.mnhelp.m add separator
$base.fm.mnhelp.m add command \
-command {Window show .pgaw:About} -label [intlmsg About]
place $base.labframe \
-x 80 -y 30 -width 246 -height 325 -anchor nw -bordermode ignore
place $base.lb \
-x 90 -y 75 -width 210 -height 272 -anchor nw -bordermode ignore
place $base.btnnew \
-x 89 -y 40 -width 75 -height 25 -anchor nw -bordermode ignore
place $base.btnopen \
-x 166 -y 40 -width 75 -height 25 -anchor nw -bordermode ignore
place $base.btndesign \
-x 243 -y 40 -width 76 -height 25 -anchor nw -bordermode ignore
place $base.lmask \
-x 1550 -y 4500 -width 10 -height 23 -anchor nw -bordermode ignore
place $base.lshost \
-x 3 -y 370 -width 91 -height 20 -anchor nw -bordermode ignore
place $base.lsdbname \
-x 95 -y 370 -width 233 -height 20 -anchor nw -bordermode ignore
place $base.sb \
-x 301 -y 74 -width 18 -height 274 -anchor nw -bordermode ignore
place $base.fm \
-x 1 -y 0 -width 331 -height 25 -anchor nw -bordermode ignore
pack $base.fm.mndb \
-in .pgaw:Main.fm -anchor center -expand 0 -fill none -side left
pack $base.fm.mnob \
-in .pgaw:Main.fm -anchor center -expand 0 -fill none -side left
pack $base.fm.mnhelp \
-in .pgaw:Main.fm -anchor center -expand 0 -fill none -side right
}
proc vTclWindow.pgaw:ImportExport {base} {
if {$base == ""} {
set base .pgaw:ImportExport
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
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 [intlmsg "Import-Export table"]
label $base.l1 -borderwidth 0 -text [intlmsg {Table name}]
entry $base.e1 -background #fefefe -borderwidth 1 -textvariable PgAcVar(impexp,tablename)
label $base.l2 -borderwidth 0 -text [intlmsg {File name}]
entry $base.e2 -background #fefefe -borderwidth 1 -textvariable PgAcVar(impexp,filename)
label $base.l3 -borderwidth 0 -text [intlmsg {Field delimiter}]
entry $base.e3 -background #fefefe -borderwidth 1 -textvariable PgAcVar(impexp,delimiter)
button $base.expbtn -borderwidth 1 -command {if {$PgAcVar(impexp,tablename)==""} {
showError [intlmsg "You have to supply a table name!"]
} elseif {$PgAcVar(impexp,filename)==""} {
showError [intlmsg "You have to supply a external file name!"]
} else {
if {$PgAcVar(impexp,delimiter)==""} {
set sup ""
} else {
set sup " USING DELIMITERS '$PgAcVar(impexp,delimiter)'"
}
if {[.pgaw:ImportExport.expbtn cget -text]=="Import"} {
set oper "FROM"
} else {
set oper "TO"
}
if {$PgAcVar(impexp,withoids)} {
set sup2 " WITH OIDS "
} else {
set sup2 ""
}
set sqlcmd "COPY \"$PgAcVar(impexp,tablename)\" $sup2 $oper '$PgAcVar(impexp,filename)'$sup"
setCursor CLOCK
if {[sql_exec noquiet $sqlcmd]} {
tk_messageBox -title [intlmsg Information] -parent .pgaw:ImportExport -message [intlmsg "Operation completed!"]
Window destroy .pgaw:ImportExport
}
setCursor DEFAULT
}} -text Export
button $base.cancelbtn -borderwidth 1 -command {Window destroy .pgaw:ImportExport} -text [intlmsg Cancel]
checkbutton $base.oicb -borderwidth 1 -text [intlmsg {with OIDs}] -variable PgAcVar(impexp,withoids)
place $base.l1 -x 15 -y 15 -anchor nw -bordermode ignore
place $base.e1 -x 115 -y 10 -height 22 -anchor nw -bordermode ignore
place $base.l2 -x 15 -y 45 -anchor nw -bordermode ignore
place $base.e2 -x 115 -y 40 -height 22 -anchor nw -bordermode ignore
place $base.l3 -x 15 -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 -height 25 -width 75 -anchor nw -bordermode ignore
place $base.cancelbtn -x 155 -y 110 -height 25 -width 75 -anchor nw -bordermode ignore
place $base.oicb -x 170 -y 75 -anchor nw -bordermode ignore
}
proc vTclWindow.pgaw:RenameObject {base} {
if {$base == ""} {
set base .pgaw:RenameObject
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
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 [intlmsg "Rename"]
label $base.l1 -borderwidth 0 -text [intlmsg {New name}]
entry $base.e1 -background #fefefe -borderwidth 1 -textvariable PgAcVar(New_Object_Name)
button $base.b1 -borderwidth 1 -command {
if {$PgAcVar(New_Object_Name)==""} {
showError [intlmsg "You must give object a new name!"]
} elseif {$PgAcVar(activetab)=="Tables"} {
set retval [sql_exec noquiet "alter table \"$PgAcVar(Old_Object_Name)\" rename to \"$PgAcVar(New_Object_Name)\""]
if {$retval} {
sql_exec quiet "update pga_layout set tablename='$PgAcVar(New_Object_Name)' where tablename='$PgAcVar(Old_Object_Name)'"
Mainlib::cmd_Tables
Window destroy .pgaw:RenameObject
}
} elseif {$PgAcVar(activetab)=="Queries"} {
set pgres [wpg_exec $CurrentDB "select * from pga_queries where queryname='$PgAcVar(New_Object_Name)'"]
if {$PgAcVar(pgsql,status)!="PGRES_TUPLES_OK"} {
showError "[intlmsg {Error retrieving from}] pga_queries\n$PgAcVar(pgsql,errmsg)\n$PgAcVar(pgsql,status)"
} elseif {[pg_result $pgres -numTuples]>0} {
showError [format [intlmsg "Query '%s' already exists!"] $PgAcVar(New_Object_Name)]
} else {
sql_exec noquiet "update pga_queries set queryname='$PgAcVar(New_Object_Name)' where queryname='$PgAcVar(Old_Object_Name)'"
sql_exec noquiet "update pga_layout set tablename='$PgAcVar(New_Object_Name)' where tablename='$PgAcVar(Old_Object_Name)'"
Mainlib::cmd_Queries
Window destroy .pgaw:RenameObject
}
catch {pg_result $pgres -clear}
} elseif {$PgAcVar(activetab)=="Forms"} {
set pgres [wpg_exec $CurrentDB "select * from pga_forms where formname='$PgAcVar(New_Object_Name)'"]
if {$PgAcVar(pgsql,status)!="PGRES_TUPLES_OK"} {
showError "[intlmsg {Error retrieving from}] pga_forms\n$PgAcVar(pgsql,errmsg)\n$PgAcVar(pgsql,status)"
} elseif {[pg_result $pgres -numTuples]>0} {
showError [format [intlmsg "Form '%s' already exists!"] $PgAcVar(New_Object_Name)]
} else {
sql_exec noquiet "update pga_forms set formname='$PgAcVar(New_Object_Name)' where formname='$PgAcVar(Old_Object_Name)'"
Mainlib::cmd_Forms
Window destroy .pgaw:RenameObject
}
catch {pg_result $pgres -clear}
} elseif {$PgAcVar(activetab)=="Scripts"} {
set pgres [wpg_exec $CurrentDB "select * from pga_scripts where scriptname='$PgAcVar(New_Object_Name)'"]
if {$PgAcVar(pgsql,status)!="PGRES_TUPLES_OK"} {
showError "[intlmsg {Error retrieving from}] pga_scripts\n$PgAcVar(pgsql,errmsg)\n$PgAcVar(pgsql,status)"
} elseif {[pg_result $pgres -numTuples]>0} {
showError [format [intlmsg "Script '%s' already exists!"] $PgAcVar(New_Object_Name)]
} else {
sql_exec noquiet "update pga_scripts set scriptname='$PgAcVar(New_Object_Name)' where scriptname='$PgAcVar(Old_Object_Name)'"
Mainlib::cmd_Scripts
Window destroy .pgaw:RenameObject
}
catch {pg_result $pgres -clear}
} elseif {$PgAcVar(activetab)=="Schema"} {
set pgres [wpg_exec $CurrentDB "select * from pga_schema where schemaname='$PgAcVar(New_Object_Name)'"]
if {$PgAcVar(pgsql,status)!="PGRES_TUPLES_OK"} {
showError "[intlmsg {Error retrieving from}] pga_schema\n$PgAcVar(pgsql,errmsg)\n$PgAcVar(pgsql,status)"
} elseif {[pg_result $pgres -numTuples]>0} {
showError [format [intlmsg "Schema '%s' already exists!"] $PgAcVar(New_Object_Name)]
} else {
sql_exec noquiet "update pga_schema set schemaname='$PgAcVar(New_Object_Name)' where schemaname='$PgAcVar(Old_Object_Name)'"
Mainlib::cmd_Schema
Window destroy .pgaw:RenameObject
}
catch {pg_result $pgres -clear}
}
} -text [intlmsg Rename]
button $base.b2 -borderwidth 1 -command {Window destroy .pgaw:RenameObject} -text [intlmsg Cancel]
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 55 -y 65 -width 80 -anchor nw -bordermode ignore
place $base.b2 -x 155 -y 65 -width 80 -anchor nw -bordermode ignore
}
proc vTclWindow.pgaw:GetParameter {base} {
if {$base == ""} {
set base .pgaw:GetParameter
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
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 [intlmsg "Input parameter"]
label $base.l1 \
-anchor nw -borderwidth 1 \
-justify left -relief sunken -textvariable PgAcVar(getqueryparam,msg) -wraplength 200
entry $base.e1 \
-background #fefefe -borderwidth 1 -highlightthickness 0 \
-textvariable PgAcVar(getqueryparam,var)
bind $base.e1 <Key-KP_Enter> {
set PgAcVar(getqueryparam,result) 1
destroy .pgaw:GetParameter
}
bind $base.e1 <Key-Return> {
set PgAcVar(getqueryparam,result) 1
destroy .pgaw:GetParameter
}
button $base.bok \
-borderwidth 1 -command {set PgAcVar(getqueryparam,result) 1
destroy .pgaw:GetParameter} -text Ok
button $base.bcanc \
-borderwidth 1 -command {set PgAcVar(getqueryparam,result) 0
destroy .pgaw:GetParameter} -text [intlmsg Cancel]
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.pgaw:SQLWindow {base} {
if {$base == ""} {
set base .pgaw:SQLWindow
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
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 [intlmsg "SQL window"]
frame $base.f \
-borderwidth 1 -height 392 -relief raised -width 396
scrollbar $base.f.01 \
-borderwidth 1 -command {.pgaw:SQLWindow.f.t xview} -orient horiz \
-width 10
scrollbar $base.f.02 \
-borderwidth 1 -command {.pgaw:SQLWindow.f.t yview} -orient vert -width 10
text $base.f.t \
-borderwidth 1 \
-height 200 -width 200 -wrap word \
-xscrollcommand {.pgaw:SQLWindow.f.01 set} \
-yscrollcommand {.pgaw:SQLWindow.f.02 set}
button $base.b1 \
-borderwidth 1 -command {.pgaw:SQLWindow.f.t delete 1.0 end} -text [intlmsg Clean]
button $base.b2 \
-borderwidth 1 -command {destroy .pgaw:SQLWindow} -text [intlmsg Close]
grid columnconf $base 0 -weight 1
grid columnconf $base 1 -weight 1
grid rowconf $base 0 -weight 1
grid $base.f \
-in .pgaw:SQLWindow -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 .pgaw:SQLWindow.f -column 0 -row 1 -columnspan 1 -rowspan 1 -sticky ew
grid $base.f.02 \
-in .pgaw:SQLWindow.f -column 1 -row 0 -columnspan 1 -rowspan 1 -sticky ns
grid $base.f.t \
-in .pgaw:SQLWindow.f -column 0 -row 0 -columnspan 1 -rowspan 1 \
-sticky nesw
grid $base.b1 \
-in .pgaw:SQLWindow -column 0 -row 1 -columnspan 1 -rowspan 1
grid $base.b2 \
-in .pgaw:SQLWindow -column 1 -row 1 -columnspan 1 -rowspan 1
}
proc vTclWindow.pgaw:About {base} {
if {$base == ""} {
set base .pgaw:About
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
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 [intlmsg "About"]
label $base.l1 -borderwidth 3 -font -Adobe-Helvetica-Bold-R-Normal-*-*-180-*-*-*-*-* -relief ridge -text PgAccess
label $base.l2 -relief groove -text [intlmsg "A Tcl/Tk interface to\nPostgreSQL\nby Constantin Teodorescu"]
label $base.l3 -borderwidth 0 -relief sunken -text {v 0.98}
label $base.l4 -relief groove -text "[intlmsg {You will always get the latest version at:}]
http://www.flex.ro/pgaccess
[intlmsg {Suggestions at}] : teo@flex.ro"
button $base.b1 -borderwidth 1 -command {Window destroy .pgaw:About} -text Ok
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.pgaw:OpenDB {base} {
if {$base == ""} {
set base .pgaw:OpenDB
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
wm geometry $base 283x172+119+210
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 [intlmsg "Open database"]
frame $base.f1 \
-borderwidth 2 -height 75 -width 125
label $base.f1.l1 \
-borderwidth 0 -relief raised -text [intlmsg Host]
entry $base.f1.e1 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(opendb,host) -width 200
bind $base.f1.e1 <Key-KP_Enter> {
focus .pgaw:OpenDB.f1.e2
}
bind $base.f1.e1 <Key-Return> {
focus .pgaw:OpenDB.f1.e2
}
label $base.f1.l2 \
-borderwidth 0 -relief raised -text [intlmsg Port]
entry $base.f1.e2 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(opendb,pgport) -width 200
bind $base.f1.e2 <Key-Return> {
focus .pgaw:OpenDB.f1.e3
}
label $base.f1.l3 \
-borderwidth 0 -relief raised -text [intlmsg Database]
entry $base.f1.e3 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(opendb,dbname) -width 200
bind $base.f1.e3 <Key-Return> {
focus .pgaw:OpenDB.f1.e4
}
label $base.f1.l4 \
-borderwidth 0 -relief raised -text [intlmsg Username]
entry $base.f1.e4 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(opendb,username) \
-width 200
bind $base.f1.e4 <Key-Return> {
focus .pgaw:OpenDB.f1.e5
}
label $base.f1.ls2 \
-borderwidth 0 -relief raised -text { }
label $base.f1.l5 \
-borderwidth 0 -relief raised -text [intlmsg Password]
entry $base.f1.e5 \
-background #fefefe -borderwidth 1 -show x -textvariable PgAcVar(opendb,password) \
-width 200
bind $base.f1.e5 <Key-Return> {
focus .pgaw:OpenDB.fb.btnopen
}
frame $base.fb \
-height 75 -relief groove -width 125
button $base.fb.btnopen \
-borderwidth 1 -command Mainlib::open_database -padx 9 \
-pady 3 -text [intlmsg Open]
button $base.fb.btncancel \
-borderwidth 1 -command {Window hide .pgaw:OpenDB} \
-padx 9 -pady 3 -text [intlmsg Cancel]
place $base.f1 \
-x 9 -y 5 -width 265 -height 126 -anchor nw -bordermode ignore
grid columnconf $base.f1 2 -weight 1
grid $base.f1.l1 \
-in .pgaw:OpenDB.f1 -column 0 -row 0 -columnspan 1 -rowspan 1 -sticky w
grid $base.f1.e1 \
-in .pgaw:OpenDB.f1 -column 2 -row 0 -columnspan 1 -rowspan 1 -pady 2
grid $base.f1.l2 \
-in .pgaw:OpenDB.f1 -column 0 -row 2 -columnspan 1 -rowspan 1 -sticky w
grid $base.f1.e2 \
-in .pgaw:OpenDB.f1 -column 2 -row 2 -columnspan 1 -rowspan 1 -pady 2
grid $base.f1.l3 \
-in .pgaw:OpenDB.f1 -column 0 -row 4 -columnspan 1 -rowspan 1 -sticky w
grid $base.f1.e3 \
-in .pgaw:OpenDB.f1 -column 2 -row 4 -columnspan 1 -rowspan 1 -pady 2
grid $base.f1.l4 \
-in .pgaw:OpenDB.f1 -column 0 -row 6 -columnspan 1 -rowspan 1 -sticky w
grid $base.f1.e4 \
-in .pgaw:OpenDB.f1 -column 2 -row 6 -columnspan 1 -rowspan 1 -pady 2
grid $base.f1.ls2 \
-in .pgaw:OpenDB.f1 -column 1 -row 0 -columnspan 1 -rowspan 1
grid $base.f1.l5 \
-in .pgaw:OpenDB.f1 -column 0 -row 7 -columnspan 1 -rowspan 1 -sticky w
grid $base.f1.e5 \
-in .pgaw:OpenDB.f1 -column 2 -row 7 -columnspan 1 -rowspan 1 -pady 2
place $base.fb \
-x 0 -y 135 -width 283 -height 40 -anchor nw -bordermode ignore
grid $base.fb.btnopen \
-in .pgaw:OpenDB.fb -column 0 -row 0 -columnspan 1 -rowspan 1 -padx 5
grid $base.fb.btncancel \
-in .pgaw:OpenDB.fb -column 1 -row 0 -columnspan 1 -rowspan 1 -padx 5
}
src/bin/pgaccess/lib/preferences.tcl 0 → 100644
View file @ 25acbc51
namespace eval Preferences {
proc {load} {} {
global PgAcVar
setDefaultFonts
setGUIPreferences
# Set some default values for preferences
set PgAcVar(pref,rows) 200
set PgAcVar(pref,tvfont) clean
set PgAcVar(pref,autoload) 1
set PgAcVar(pref,systemtables) 0
set PgAcVar(pref,lastdb) {}
set PgAcVar(pref,lasthost) localhost
set PgAcVar(pref,lastport) 5432
set PgAcVar(pref,username) {}
set PgAcVar(pref,password) {}
set PgAcVar(pref,language) english
set retval [catch {set fid [open "~/.pgaccessrc" r]} errmsg]
if {! $retval} {
while {![eof $fid]} {
set pair [gets $fid]
set PgAcVar([lindex $pair 0]) [lindex $pair 1]
}
close $fid
setGUIPreferences
}
# The following preferences values will be ignored from the .pgaccessrc file
set PgAcVar(pref,typecolors) {black red brown #007e00 #004e00 blue orange yellow pink purple cyan magenta lightblue lightgreen gray lightyellow}
set PgAcVar(pref,typelist) {text bool bytea float8 float4 int4 char name int8 int2 int28 regproc oid tid xid cid}
loadInternationalMessages
}
proc {save} {} {
global PgAcVar
catch {
set fid [open "~/.pgaccessrc" w]
foreach key [array names PgAcVar pref,*] { puts $fid "$key {$PgAcVar($key)}" }
close $fid
}
if {$PgAcVar(activetab)=="Tables"} {
Mainlib::tab_click Tables
}
}
proc {configure} {} {
global PgAcVar
Window show .pgaw:Preferences
foreach language [lsort $PgAcVar(AVAILABLE_LANGUAGES)] {.pgaw:Preferences.fpl.flb.llb insert end $language}
wm transient .pgaw:Preferences .pgaw:Main
}
proc {loadInternationalMessages} {} {
global Messages PgAcVar
set PgAcVar(AVAILABLE_LANGUAGES) {english}
foreach filename [glob -nocomplain [file join $PgAcVar(PGACCESS_HOME) lib languages *]] {
lappend PgAcVar(AVAILABLE_LANGUAGES) [file tail $filename]
}
catch { unset Messages }
catch { source [file join $PgAcVar(PGACCESS_HOME) lib languages $PgAcVar(pref,language)] }
}
proc {changeLanguage} {} {
global PgAcVar
set sel [.pgaw:Preferences.fpl.flb.llb curselection]
if {$sel==""} {return}
set desired [.pgaw:Preferences.fpl.flb.llb get $sel]
if {$desired==$PgAcVar(pref,language)} {return}
set PgAcVar(pref,language) $desired
loadInternationalMessages
return
foreach wid [winfo children .pgaw:Main] {
set wtext {}
catch { set wtext [$wid cget -text] }
if {$wtext != ""} {
$wid configure -text [intlmsg $wtext]
}
}
}
proc {setDefaultFonts} {} {
global PgAcVar tcl_platform
if {[string toupper $tcl_platform(platform)]=="WINDOWS"} {
set PgAcVar(pref,font_normal) {"MS Sans Serif" 8}
set PgAcVar(pref,font_bold) {"MS Sans Serif" 8 bold}
set PgAcVar(pref,font_fix) {Terminal 8}
set PgAcVar(pref,font_italic) {"MS Sans Serif" 8 italic}
} else {
set PgAcVar(pref,font_normal) -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*
set PgAcVar(pref,font_bold) -Adobe-Helvetica-Bold-R-Normal-*-*-120-*-*-*-*-*
set PgAcVar(pref,font_italic) -Adobe-Helvetica-Medium-O-Normal-*-*-120-*-*-*-*-*
set PgAcVar(pref,font_fix) -*-Clean-Medium-R-Normal-*-*-130-*-*-*-*-*
}
}
proc {setGUIPreferences} {} {
global PgAcVar
foreach wid {Label Text Button Listbox Checkbutton Radiobutton} {
option add *$wid.font $PgAcVar(pref,font_normal)
}
option add *Entry.background #fefefe
option add *Entry.foreground #000000
option add *Button.BorderWidth 1
}
}
################### END OF NAMESPACE PREFERENCES #################
proc vTclWindow.pgaw:Preferences {base} {
if {$base == ""} {
set base .pgaw:Preferences
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
wm geometry $base 450x360+100+213
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 [intlmsg "Preferences"]
bind $base <Key-Escape> "Window destroy .pgaw:Preferences"
frame $base.fl \
-height 75 -relief groove -width 10
frame $base.fr \
-height 75 -relief groove -width 10
frame $base.f1 \
-height 80 -relief groove -width 125
label $base.f1.l1 \
-borderwidth 0 -relief raised \
-text [intlmsg {Max rows displayed in table/query view}]
entry $base.f1.erows \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(pref,rows) -width 7
frame $base.f2 \
-height 75 -relief groove -width 125
label $base.f2.l \
-borderwidth 0 -relief raised -text [intlmsg {Table viewer font}]
label $base.f2.ls \
-borderwidth 0 -relief raised -text { }
radiobutton $base.f2.pgaw:rb1 \
-borderwidth 1 -text [intlmsg {fixed width}] -value clean \
-variable PgAcVar(pref,tvfont)
radiobutton $base.f2.pgaw:rb2 \
-borderwidth 1 -text [intlmsg proportional] -value helv -variable PgAcVar(pref,tvfont)
frame $base.ff \
-height 75 -relief groove -width 125
label $base.ff.l1 \
-borderwidth 0 -relief raised -text [intlmsg {Font normal}]
entry $base.ff.e1 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(pref,font_normal) \
-width 200
label $base.ff.l2 \
-borderwidth 0 -relief raised -text [intlmsg {Font bold}]
entry $base.ff.e2 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(pref,font_bold) \
-width 200
label $base.ff.l3 \
-borderwidth 0 -relief raised -text [intlmsg {Font italic}]
entry $base.ff.e3 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(pref,font_italic) \
-width 200
label $base.ff.l4 \
-borderwidth 0 -relief raised -text [intlmsg {Font fixed}]
entry $base.ff.e4 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(pref,font_fix) \
-width 200
frame $base.fls \
-borderwidth 1 -height 2 -relief sunken -width 125
frame $base.fal \
-height 75 -relief groove -width 125
checkbutton $base.fal.al \
-borderwidth 1 -text [intlmsg {Auto-load the last opened database at startup}] \
-variable PgAcVar(pref,autoload) -anchor w
checkbutton $base.fal.st \
-borderwidth 1 -text [intlmsg {View system tables}] \
-variable PgAcVar(pref,systemtables) -anchor w
frame $base.fpl \
-height 49 -relief groove -width 125
label $base.fpl.lt \
-borderwidth 0 -relief raised -text [intlmsg {Preferred language}]
frame $base.fpl.flb \
-height 75 -relief sunken -width 125
listbox $base.fpl.flb.llb \
-borderwidth 1 -height 6 -yscrollcommand {.pgaw:Preferences.fpl.flb.vsb set}
scrollbar $base.fpl.flb.vsb \
-borderwidth 1 -command {.pgaw:Preferences.fpl.flb.llb yview} -orient vert
frame $base.fb \
-height 75 -relief groove -width 125
button $base.fb.btnsave \
-command {if {$PgAcVar(pref,rows)>200} {
tk_messageBox -title [intlmsg Warning] -parent .pgaw:Preferences -message [intlmsg "A big number of rows displayed in table view will take a lot of memory!"]
}
Preferences::changeLanguage
Preferences::save
Window destroy .pgaw:Preferences
tk_messageBox -title [intlmsg Warning] -parent .pgaw:Main -message [intlmsg "Changed fonts may appear in the next working session!"]} \
-padx 9 -pady 3 -text [intlmsg Save]
button $base.fb.btncancel \
-command {Window destroy .pgaw:Preferences} -padx 9 -pady 3 -text [intlmsg Cancel]
pack $base.fl \
-in .pgaw:Preferences -anchor center -expand 0 -fill y -side left
pack $base.fr \
-in .pgaw:Preferences -anchor center -expand 0 -fill y -side right
pack $base.f1 \
-in .pgaw:Preferences -anchor center -expand 0 -fill x -pady 5 -side top
pack $base.f1.l1 \
-in .pgaw:Preferences.f1 -anchor center -expand 0 -fill none -side left
pack $base.f1.erows \
-in .pgaw:Preferences.f1 -anchor center -expand 0 -fill none -side left
pack $base.f2 \
-in .pgaw:Preferences -anchor center -expand 0 -fill x -pady 5 -side top
pack $base.f2.l \
-in .pgaw:Preferences.f2 -anchor center -expand 0 -fill none -side left
pack $base.f2.ls \
-in .pgaw:Preferences.f2 -anchor center -expand 0 -fill none -side left
pack $base.f2.pgaw:rb1 \
-in .pgaw:Preferences.f2 -anchor center -expand 0 -fill none -side left
pack $base.f2.pgaw:rb2 \
-in .pgaw:Preferences.f2 -anchor center -expand 0 -fill none -side left
pack $base.ff \
-in .pgaw:Preferences -anchor center -expand 0 -fill x -side top
grid columnconf $base.ff 1 -weight 1
grid $base.ff.l1 \
-in .pgaw:Preferences.ff -column 0 -row 0 -columnspan 1 -rowspan 1 -sticky w
grid $base.ff.e1 \
-in .pgaw:Preferences.ff -column 1 -row 0 -columnspan 1 -rowspan 1 -pady 1
grid $base.ff.l2 \
-in .pgaw:Preferences.ff -column 0 -row 2 -columnspan 1 -rowspan 1 -sticky w
grid $base.ff.e2 \
-in .pgaw:Preferences.ff -column 1 -row 2 -columnspan 1 -rowspan 1 -pady 1
grid $base.ff.l3 \
-in .pgaw:Preferences.ff -column 0 -row 4 -columnspan 1 -rowspan 1 -sticky w
grid $base.ff.e3 \
-in .pgaw:Preferences.ff -column 1 -row 4 -columnspan 1 -rowspan 1 -pady 1
grid $base.ff.l4 \
-in .pgaw:Preferences.ff -column 0 -row 6 -columnspan 1 -rowspan 1 -sticky w
grid $base.ff.e4 \
-in .pgaw:Preferences.ff -column 1 -row 6 -columnspan 1 -rowspan 1 -pady 1
pack $base.fls \
-in .pgaw:Preferences -anchor center -expand 0 -fill x -pady 5 -side top
pack $base.fal \
-in .pgaw:Preferences -anchor center -expand 0 -fill x -side top
pack $base.fal.al \
-in .pgaw:Preferences.fal -anchor center -expand 0 -fill x -side top -anchor w
pack $base.fal.st \
-in .pgaw:Preferences.fal -anchor center -expand 0 -fill x -side top -anchor w
pack $base.fpl \
-in .pgaw:Preferences -anchor center -expand 0 -fill x -side top
pack $base.fpl.lt \
-in .pgaw:Preferences.fpl -anchor center -expand 0 -fill none -side top
pack $base.fpl.flb \
-in .pgaw:Preferences.fpl -anchor center -expand 0 -fill none -side top
pack $base.fpl.flb.llb \
-in .pgaw:Preferences.fpl.flb -anchor center -expand 0 -fill none -side left
pack $base.fpl.flb.vsb \
-in .pgaw:Preferences.fpl.flb -anchor center -expand 0 -fill y -side right
pack $base.fb \
-in .pgaw:Preferences -anchor center -expand 0 -fill none -side bottom
grid $base.fb.btnsave \
-in .pgaw:Preferences.fb -column 0 -row 0 -columnspan 1 -rowspan 1
grid $base.fb.btncancel \
-in .pgaw:Preferences.fb -column 1 -row 0 -columnspan 1 -rowspan 1
}
src/bin/pgaccess/lib/qed 0 → 100755
View file @ 25acbc51
#!/bin/bash
for fisier in *.tcl ; do
echo $fisier ;
sed -e "s/show_error/showError/g" <$fisier >temp
mv temp $fisier
done
src/bin/pgaccess/lib/queries.tcl 0 → 100644
View file @ 25acbc51
namespace eval Queries {
proc {new} {} {
global PgAcVar
Window show .pgaw:QueryBuilder
PgAcVar:clean query,*
set PgAcVar(query,oid) 0
set PgAcVar(query,name) {}
set PgAcVar(query,asview) 0
set PgAcVar(query,tables) {}
set PgAcVar(query,links) {}
set PgAcVar(query,results) {}
.pgaw:QueryBuilder.saveAsView configure -state normal
}
proc {open} {queryname} {
global PgAcVar
if {! [loadQuery $queryname]} return;
if {$PgAcVar(query,type)=="S"} then {
set wn [Tables::getNewWindowName]
set PgAcVar(mw,$wn,query) [subst $PgAcVar(query,sqlcmd)]
set PgAcVar(mw,$wn,updatable) 0
set PgAcVar(mw,$wn,isaquery) 1
Tables::createWindow
wm title $wn "Query result: $PgAcVar(query,name)"
Tables::loadLayout $wn $PgAcVar(query,name)
Tables::selectRecords $wn $PgAcVar(mw,$wn,query)
} else {
set answ [tk_messageBox -title [intlmsg 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!"
}
}
}
}
proc {design} {queryname} {
global PgAcVar
if {! [loadQuery $queryname]} return;
Window show .pgaw:QueryBuilder
.pgaw:QueryBuilder.text1 delete 0.0 end
.pgaw:QueryBuilder.text1 insert end $PgAcVar(query,sqlcmd)
.pgaw:QueryBuilder.text2 delete 0.0 end
.pgaw:QueryBuilder.text2 insert end $PgAcVar(query,comments)
}
proc {loadQuery} {queryname} {
global PgAcVar CurrentDB
set PgAcVar(query,name) $queryname
if {[set pgres [wpg_exec $CurrentDB "select querycommand,querytype,querytables,querylinks,queryresults,querycomments,oid from pga_queries where queryname='$PgAcVar(query,name)'"]]==0} then {
showError [intlmsg "Error retrieving query definition"]
return 0
}
if {[pg_result $pgres -numTuples]==0} {
showError [format [intlmsg "Query '%s' was not found!"] $PgAcVar(query,name)]
pg_result $pgres -clear
return 0
}
set tuple [pg_result $pgres -getTuple 0]
set PgAcVar(query,sqlcmd) [lindex $tuple 0]
set PgAcVar(query,type) [lindex $tuple 1]
set PgAcVar(query,tables) [lindex $tuple 2]
set PgAcVar(query,links) [lindex $tuple 3]
set PgAcVar(query,results) [lindex $tuple 4]
set PgAcVar(query,comments) [lindex $tuple 5]
set PgAcVar(query,oid) [lindex $tuple 6]
pg_result $pgres -clear
return 1
}
proc {visualDesigner} {} {
global PgAcVar
Window show .pgaw:VisualQuery
VisualQueryBuilder::loadVisualLayout
focus .pgaw:VisualQuery.fb.entt
}
proc {save} {} {
global PgAcVar CurrentDB
if {$PgAcVar(query,name)==""} then {
showError [intlmsg "You have to supply a name for this query!"]
focus .pgaw:QueryBuilder.eqn
} else {
set qcmd [.pgaw:QueryBuilder.text1 get 1.0 end]
set PgAcVar(query,comments) [.pgaw:QueryBuilder.text2 get 1.0 end]
regsub -all "\n" $qcmd " " qcmd
if {$qcmd==""} then {
showError [intlmsg "This query has no commands?"]
} else {
if { [lindex [split [string toupper [string trim $qcmd]]] 0] == "SELECT" } {
set qtype S
} else {
set qtype A
}
if {$PgAcVar(query,asview)} {
wpg_select $CurrentDB "select pg_get_viewdef('$PgAcVar(query,name)') as vd" tup {
if {$tup(vd)!="Not a view"} {
if {[tk_messageBox -title [intlmsg Warning] -message [format [intlmsg "View '%s' already exists!\nOverwrite ?"] $PgAcVar(query,name)] -type yesno -default no]=="yes"} {
set pg_res [wpg_exec $CurrentDB "drop view \"$PgAcVar(query,name)\""]
if {$PgAcVar(pgsql,status)!="PGRES_COMMAND_OK"} {
showError "[intlmsg {Error deleting view}] '$PgAcVar(query,name)'"
}
}
}
}
set pgres [wpg_exec $CurrentDB "create view \"$PgAcVar(query,name)\" as $qcmd"]
if {$PgAcVar(pgsql,status)!="PGRES_COMMAND_OK"} {
showError "[intlmsg {Error defining view}]\n\n$PgAcVar(pgsql,errmsg)"
} else {
Mainlib::tab_click Views
Window destroy .pgaw:QueryBuilder
}
catch {pg_result $pgres -clear}
} else {
regsub -all "'" $qcmd "''" qcmd
regsub -all "'" $PgAcVar(query,comments) "''" PgAcVar(query,comments)
regsub -all "'" $PgAcVar(query,results) "''" PgAcVar(query,results)
setCursor CLOCK
if {$PgAcVar(query,oid)==0} then {
set pgres [wpg_exec $CurrentDB "insert into pga_queries values ('$PgAcVar(query,name)','$qtype','$qcmd','$PgAcVar(query,tables)','$PgAcVar(query,links)','$PgAcVar(query,results)','$PgAcVar(query,comments)')"]
} else {
set pgres [wpg_exec $CurrentDB "update pga_queries set queryname='$PgAcVar(query,name)',querytype='$qtype',querycommand='$qcmd',querytables='$PgAcVar(query,tables)',querylinks='$PgAcVar(query,links)',queryresults='$PgAcVar(query,results)',querycomments='$PgAcVar(query,comments)' where oid=$PgAcVar(query,oid)"]
}
setCursor DEFAULT
if {$PgAcVar(pgsql,status)!="PGRES_COMMAND_OK"} then {
showError "[intlmsg {Error executing query}]\n$PgAcVar(pgsql,errmsg)"
} else {
Mainlib::tab_click Queries
if {$PgAcVar(query,oid)==0} {set PgAcVar(query,oid) [pg_result $pgres -oid]}
}
}
catch {pg_result $pgres -clear}
}
}
}
proc {execute} {} {
global PgAcVar
set qcmd [.pgaw:QueryBuilder.text1 get 0.0 end]
regsub -all "\n" [string trim $qcmd] " " qcmd
if {[lindex [split [string toupper $qcmd]] 0]!="SELECT"} {
if {[tk_messageBox -title [intlmsg Warning] -parent .pgaw:QueryBuilder -message [intlmsg "This is an action query!\n\nExecute it?"] -type yesno -default no]=="yes"} {
sql_exec noquiet $qcmd
}
} else {
set wn [Tables::getNewWindowName]
set PgAcVar(mw,$wn,query) [subst $qcmd]
set PgAcVar(mw,$wn,updatable) 0
set PgAcVar(mw,$wn,isaquery) 1
Tables::createWindow
Tables::loadLayout $wn $PgAcVar(query,name)
Tables::selectRecords $wn $PgAcVar(mw,$wn,query)
}
}
proc {close} {} {
global PgAcVar
.pgaw:QueryBuilder.saveAsView configure -state normal
set PgAcVar(query,asview) 0
set PgAcVar(query,name) {}
.pgaw:QueryBuilder.text1 delete 1.0 end
Window destroy .pgaw:QueryBuilder
}
}
proc vTclWindow.pgaw:QueryBuilder {base} {
global PgAcVar
if {$base == ""} {
set base .pgaw:QueryBuilder
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
wm geometry $base 542x364+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 [intlmsg "Query builder"]
bind $base <Key-F1> "Help::load queries"
label $base.lqn -borderwidth 0 -text [intlmsg {Query name}]
entry $base.eqn -background #fefefe -borderwidth 1 -foreground #000000 -highlightthickness 1 -selectborderwidth 0 -textvariable PgAcVar(query,name)
text $base.text1 -background #fefefe -borderwidth 1 -font $PgAcVar(pref,font_normal) -foreground #000000 -highlightthickness 1 -wrap word
label $base.lcomm -borderwidth 0 -text [intlmsg Comments]
text $base.text2 -background #fefefe -borderwidth 1 -font $PgAcVar(pref,font_normal) -foreground #000000 -highlightthickness 1 -wrap word
checkbutton $base.saveAsView -borderwidth 1 -text [intlmsg {Save this query as a view}] -variable PgAcVar(query,asview)
frame $base.frb \
-height 75 -relief groove -width 125
button $base.frb.savebtn -command {Queries::save} \
-borderwidth 1 -text [intlmsg {Save query definition}]
button $base.frb.execbtn -command {Queries::execute} \
-borderwidth 1 -text [intlmsg {Execute query}]
button $base.frb.pgaw:VisualQueryshow -command {Queries::visualDesigner} \
-borderwidth 1 -text [intlmsg {Visual designer}]
button $base.frb.termbtn -command {Queries::close} \
-borderwidth 1 -text [intlmsg Close]
place $base.lqn -x 5 -y 5 -anchor nw -bordermode ignore
place $base.eqn -x 100 -y 1 -width 335 -height 24 -anchor nw -bordermode ignore
place $base.frb \
-x 5 -y 55 -width 530 -height 35 -anchor nw -bordermode ignore
pack $base.frb.savebtn \
-in $base.frb -anchor center -expand 0 -fill none -side left
pack $base.frb.execbtn \
-in $base.frb -anchor center -expand 0 -fill none -side left
pack $base.frb.pgaw:VisualQueryshow \
-in $base.frb -anchor center -expand 0 -fill none -side left
pack $base.frb.termbtn \
-in $base.frb -anchor center -expand 0 -fill none -side right
place $base.text1 -x 5 -y 90 -width 530 -height 160 -anchor nw -bordermode ignore
place $base.lcomm -x 5 -y 255
place $base.text2 -x 5 -y 270 -width 530 -height 86 -anchor nw -bordermode ignore
place $base.saveAsView -x 5 -y 30 -height 25 -anchor nw -bordermode ignore
}
src/bin/pgaccess/lib/reports.tcl 0 → 100644
View file @ 25acbc51
namespace eval Reports {
proc {new} {} {
global PgAcVar
Window show .pgaw:ReportBuilder
tkwait visibility .pgaw:ReportBuilder
init
set PgAcVar(report,reportname) {}
set PgAcVar(report,justpreview) 0
focus .pgaw:ReportBuilder.e2
}
proc {open} {reportname} {
global PgAcVar CurrentDB
Window show .pgaw:ReportBuilder
#tkwait visibility .pgaw:ReportBuilder
Window hide .pgaw:ReportBuilder
Window show .pgaw:ReportPreview
init
set PgAcVar(report,reportname) $reportname
loadReport
tkwait visibility .pgaw:ReportPreview
set PgAcVar(report,justpreview) 1
preview
}
proc {design} {reportname} {
global PgAcVar
Window show .pgaw:ReportBuilder
tkwait visibility .pgaw:ReportBuilder
init
set PgAcVar(report,reportname) $reportname
loadReport
set PgAcVar(report,justpreview) 0
}
proc {drawReportAreas} {} {
global PgAcVar
foreach rg $PgAcVar(report,regions) {
.pgaw:ReportBuilder.c delete bg_$rg
.pgaw:ReportBuilder.c create line 0 $PgAcVar(report,y_$rg) 5000 $PgAcVar(report,y_$rg) -tags [subst {bg_$rg}]
.pgaw:ReportBuilder.c create rectangle 6 [expr $PgAcVar(report,y_$rg)-3] 12 [expr $PgAcVar(report,y_$rg)+3] -fill black -tags [subst {bg_$rg mov reg}]
.pgaw:ReportBuilder.c lower bg_$rg
}
}
proc {toggleAlignMode} {} {
set bb [.pgaw:ReportBuilder.c bbox hili]
if {[.pgaw:ReportBuilder.balign cget -text]=="left"} then {
.pgaw:ReportBuilder.balign configure -text right
.pgaw:ReportBuilder.c itemconfigure hili -anchor ne
.pgaw:ReportBuilder.c move hili [expr [lindex $bb 2]-[lindex $bb 0]-3] 0
} else {
.pgaw:ReportBuilder.balign configure -text left
.pgaw:ReportBuilder.c itemconfigure hili -anchor nw
.pgaw:ReportBuilder.c move hili [expr [lindex $bb 0]-[lindex $bb 2]+3] 0
}
}
proc {getBoldStatus} {} {
if {[.pgaw:ReportBuilder.lbold cget -relief]=="raised"} then {return Medium} else {return Bold}
}
proc {getItalicStatus} {} {
if {[.pgaw:ReportBuilder.lita cget -relief]=="raised"} then {return R} else {return O}
}
proc {toggleBold} {} {
if {[getBoldStatus]=="Bold"} {
.pgaw:ReportBuilder.lbold configure -relief raised
} else {
.pgaw:ReportBuilder.lbold configure -relief sunken
}
setObjectFont
}
proc {toggleItalic} {} {
if {[getItalicStatus]=="O"} {
.pgaw:ReportBuilder.lita configure -relief raised
} else {
.pgaw:ReportBuilder.lita configure -relief sunken
}
setObjectFont
}
proc {setFont} {} {
set temp [.pgaw:ReportBuilder.bfont cget -text]
if {$temp=="Courier"} then {
.pgaw:ReportBuilder.bfont configure -text Helvetica
} else {
.pgaw:ReportBuilder.bfont configure -text Courier
}
setObjectFont
}
proc {getSourceFields} {} {
global PgAcVar CurrentDB
.pgaw:ReportBuilder.lb delete 0 end
if {$PgAcVar(report,tablename)==""} return ;
#setCursor CLOCK
wpg_select $CurrentDB "select attnum,attname from pg_class,pg_attribute where (pg_class.relname='$PgAcVar(report,tablename)') and (pg_class.oid=pg_attribute.attrelid) and (attnum>0) order by attnum" rec {
.pgaw:ReportBuilder.lb insert end $rec(attname)
}
#setCursor DEFAULT
}
proc {hasTag} {id tg} {
if {[lsearch [.pgaw:ReportBuilder.c itemcget $id -tags] $tg]==-1} then {return 0 } else {return 1}
}
proc {init} {} {
global PgAcVar
set PgAcVar(report,xl_auto) 10
set PgAcVar(report,xf_auto) 10
set PgAcVar(report,regions) {rpthdr pghdr detail pgfoo rptfoo}
set PgAcVar(report,y_rpthdr) 30
set PgAcVar(report,y_pghdr) 60
set PgAcVar(report,y_detail) 90
set PgAcVar(report,y_pgfoo) 120
set PgAcVar(report,y_rptfoo) 150
set PgAcVar(report,e_rpthdr) [intlmsg {Report header}]
set PgAcVar(report,e_pghdr) [intlmsg {Page header}]
set PgAcVar(report,e_detail) [intlmsg {Detail record}]
set PgAcVar(report,e_pgfoo) [intlmsg {Page footer}]
set PgAcVar(report,e_rptfoo) [intlmsg {Report footer}]
drawReportAreas
}
proc {loadReport} {} {
global PgAcVar CurrentDB
.pgaw:ReportBuilder.c delete all
wpg_select $CurrentDB "select * from pga_reports where reportname='$PgAcVar(report,reportname)'" rcd {
eval $rcd(reportbody)
}
getSourceFields
drawReportAreas
}
proc {preview} {} {
global PgAcVar CurrentDB
Window show .pgaw:ReportPreview
.pgaw:ReportPreview.fr.c delete all
set ol [.pgaw:ReportBuilder.c find withtag ro]
set fields {}
foreach objid $ol {
set tags [.pgaw:ReportBuilder.c itemcget $objid -tags]
lappend fields [string range [lindex $tags [lsearch -glob $tags f-*]] 2 64]
lappend fields [lindex [.pgaw:ReportBuilder.c coords $objid] 0]
lappend fields [lindex [.pgaw:ReportBuilder.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"} {
.pgaw:ReportPreview.fr.c create text $x [expr $py+$y] -text [.pgaw:ReportBuilder.c itemcget $objid -text] -font [.pgaw:ReportBuilder.c itemcget $objid -font] -anchor nw
}
}
incr py [expr $PgAcVar(report,y_pghdr)-$PgAcVar(report,y_rpthdr)]
# Parsing detail group
set di [lsearch $PgAcVar(report,regions) detail]
set y_hi $PgAcVar(report,y_detail)
set y_lo $PgAcVar(report,y_[lindex $PgAcVar(report,regions) [expr $di-1]])
wpg_select $CurrentDB "select * from \"$PgAcVar(report,tablename)\"" rec {
foreach {field x y objid objtype} $fields {
if {($y>=$y_lo) && ($y<=$y_hi)} then {
if {$objtype=="t_f"} {
.pgaw:ReportPreview.fr.c create text $x [expr $py+$y] -text $rec($field) -font [.pgaw:ReportBuilder.c itemcget $objid -font] -anchor [.pgaw:ReportBuilder.c itemcget $objid -anchor]
}
if {$objtype=="t_l"} {
.pgaw:ReportPreview.fr.c create text $x [expr $py+$y] -text [.pgaw:ReportBuilder.c itemcget $objid -text] -font [.pgaw:ReportBuilder.c itemcget $objid -font] -anchor nw
}
}
}
incr py [expr $PgAcVar(report,y_detail)-$PgAcVar(report,y_pghdr)]
}
.pgaw:ReportPreview.fr.c configure -scrollregion [subst {0 0 1000 $py}]
}
proc {print} {} {
set bb [.pgaw:ReportPreview.fr.c bbox all]
.pgaw:ReportPreview.fr.c postscript -file "pgaccess-report.ps" -width [expr 10+[lindex $bb 2]-[lindex $bb 0]] -height [expr 10+[lindex $bb 3]-[lindex $bb 1]]
tk_messageBox -title Information -parent .pgaw:ReportBuilder -message "The printed image in Postscript is in the file pgaccess-report.ps"
}
proc {save} {} {
global PgAcVar
set prog "set PgAcVar(report,tablename) \"$PgAcVar(report,tablename)\""
foreach region $PgAcVar(report,regions) {
set prog "$prog ; set PgAcVar(report,y_$region) $PgAcVar(report,y_$region)"
}
foreach obj [.pgaw:ReportBuilder.c find all] {
if {[.pgaw:ReportBuilder.c type $obj]=="text"} {
set bb [.pgaw:ReportBuilder.c bbox $obj]
if {[.pgaw:ReportBuilder.c itemcget $obj -anchor]=="nw"} then {set x [expr [lindex $bb 0]+1]} else {set x [expr [lindex $bb 2]-2]}
set prog "$prog ; .pgaw:ReportBuilder.c create text $x [lindex $bb 1] -font [.pgaw:ReportBuilder.c itemcget $obj -font] -anchor [.pgaw:ReportBuilder.c itemcget $obj -anchor] -text {[.pgaw:ReportBuilder.c itemcget $obj -text]} -tags {[.pgaw:ReportBuilder.c itemcget $obj -tags]}"
}
}
sql_exec noquiet "delete from pga_reports where reportname='$PgAcVar(report,reportname)'"
sql_exec noquiet "insert into pga_reports (reportname,reportsource,reportbody) values ('$PgAcVar(report,reportname)','$PgAcVar(report,tablename)','$prog')"
}
proc {addField} {} {
global PgAcVar
set fldname [.pgaw:ReportBuilder.lb get [.pgaw:ReportBuilder.lb curselection]]
set newid [.pgaw:ReportBuilder.c create text $PgAcVar(report,xf_auto) [expr $PgAcVar(report,y_rpthdr)+5] -text $fldname -tags [subst {t_l mov ro}] -anchor nw -font $PgAcVar(pref,font_normal)]
.pgaw:ReportBuilder.c create text $PgAcVar(report,xf_auto) [expr $PgAcVar(report,y_pghdr)+5] -text $fldname -tags [subst {f-$fldname t_f rg_detail mov ro}] -anchor nw -font $PgAcVar(pref,font_normal)
set bb [.pgaw:ReportBuilder.c bbox $newid]
incr PgAcVar(report,xf_auto) [expr 5+[lindex $bb 2]-[lindex $bb 0]]
}
proc {addLabel} {} {
global PgAcVar
set fldname $PgAcVar(report,labeltext)
set newid [.pgaw:ReportBuilder.c create text $PgAcVar(report,xl_auto) [expr $PgAcVar(report,y_rpthdr)+5] -text $fldname -tags [subst {t_l mov ro}] -anchor nw -font $PgAcVar(pref,font_normal)]
set bb [.pgaw:ReportBuilder.c bbox $newid]
incr PgAcVar(report,xl_auto) [expr 5+[lindex $bb 2]-[lindex $bb 0]]
}
proc {setObjectFont} {} {
global PgAcVar
.pgaw:ReportBuilder.c itemconfigure hili -font -Adobe-[.pgaw:ReportBuilder.bfont cget -text]-[getBoldStatus]-[getItalicStatus]-Normal--*-$PgAcVar(report,pointsize)-*-*-*-*-*-*
}
proc {deleteObject} {} {
if {[tk_messageBox -title [intlmsg Warning] -parent .pgaw:ReportBuilder -message "Delete current report object?" -type yesno -default no]=="no"} return;
.pgaw:ReportBuilder.c delete hili
}
proc {dragMove} {w x y} {
global PgAcVar
# Showing current region
foreach rg $PgAcVar(report,regions) {
set PgAcVar(report,msg) $PgAcVar(report,e_$rg)
if {$PgAcVar(report,y_$rg)>$y} break;
}
set temp {}
catch {set temp $PgAcVar(draginfo,obj)}
if {"$temp" != ""} {
set dx [expr $x - $PgAcVar(draginfo,x)]
set dy [expr $y - $PgAcVar(draginfo,y)]
if {$PgAcVar(draginfo,region)!=""} {
set x $PgAcVar(draginfo,x) ; $w move bg_$PgAcVar(draginfo,region) 0 $dy
} else {
$w move $PgAcVar(draginfo,obj) $dx $dy
}
set PgAcVar(draginfo,x) $x
set PgAcVar(draginfo,y) $y
}
}
proc {dragStart} {w x y} {
global PgAcVar
focus .pgaw:ReportBuilder.c
catch {unset draginfo}
set obj {}
# Only movable objects start dragging
foreach id [$w find overlapping $x $y $x $y] {
if {[hasTag $id mov]} {
set obj $id
break
}
}
if {$obj==""} return;
set PgAcVar(draginfo,obj) $obj
set taglist [.pgaw:ReportBuilder.c itemcget $obj -tags]
set i [lsearch -glob $taglist bg_*]
if {$i==-1} {
set PgAcVar(draginfo,region) {}
} else {
set PgAcVar(draginfo,region) [string range [lindex $taglist $i] 3 64]
}
.pgaw:ReportBuilder configure -cursor hand1
.pgaw:ReportBuilder.c itemconfigure [.pgaw:ReportBuilder.c find withtag hili] -fill black
.pgaw:ReportBuilder.c dtag [.pgaw:ReportBuilder.c find withtag hili] hili
.pgaw:ReportBuilder.c addtag hili withtag $PgAcVar(draginfo,obj)
.pgaw:ReportBuilder.c itemconfigure hili -fill blue
set PgAcVar(draginfo,x) $x
set PgAcVar(draginfo,y) $y
set PgAcVar(draginfo,sx) $x
set PgAcVar(draginfo,sy) $y
# Setting font information
if {[.pgaw:ReportBuilder.c type hili]=="text"} {
set fnta [split [.pgaw:ReportBuilder.c itemcget hili -font] -]
.pgaw:ReportBuilder.bfont configure -text [lindex $fnta 2]
if {[lindex $fnta 3]=="Medium"} then {.pgaw:ReportBuilder.lbold configure -relief raised} else {.pgaw:ReportBuilder.lbold configure -relief sunken}
if {[lindex $fnta 4]=="R"} then {.pgaw:ReportBuilder.lita configure -relief raised} else {.pgaw:ReportBuilder.lita configure -relief sunken}
set PgAcVar(report,pointsize) [lindex $fnta 8]
if {[hasTag $obj t_f]} {set PgAcVar(report,info) "Database field"}
if {[hasTag $obj t_l]} {set PgAcVar(report,info) "Label"}
if {[.pgaw:ReportBuilder.c itemcget $obj -anchor]=="nw"} then {.pgaw:ReportBuilder.balign configure -text left} else {.pgaw:ReportBuilder.balign configure -text right}
}
}
proc {dragStop} {x y} {
global PgAcVar
# when click Close, ql window is destroyed but event ButtonRelease-1 is fired
if {![winfo exists .pgaw:ReportBuilder]} return;
.pgaw:ReportBuilder configure -cursor left_ptr
set este {}
catch {set este $PgAcVar(draginfo,obj)}
if {$este==""} return
# Erase information about object beeing dragged
if {$PgAcVar(draginfo,region)!=""} {
set dy 0
foreach rg $PgAcVar(report,regions) {
.pgaw:ReportBuilder.c move rg_$rg 0 $dy
if {$rg==$PgAcVar(draginfo,region)} {
set dy [expr $y-$PgAcVar(report,y_$PgAcVar(draginfo,region))]
}
incr PgAcVar(report,y_$rg) $dy
}
# .pgaw:ReportBuilder.c move det 0 [expr $y-$PgAcVar(report,y_$PgAcVar(draginfo,region))]
set PgAcVar(report,y_$PgAcVar(draginfo,region)) $y
drawReportAreas
} else {
# Check if object beeing dragged is inside the canvas
set bb [.pgaw:ReportBuilder.c bbox $PgAcVar(draginfo,obj)]
if {[lindex $bb 0] < 5} {
.pgaw:ReportBuilder.c move $PgAcVar(draginfo,obj) [expr 5-[lindex $bb 0]] 0
}
}
set PgAcVar(draginfo,obj) {}
PgAcVar:clean draginfo,*
}
proc {deleteAllObjects} {} {
if {[tk_messageBox -title [intlmsg Warning] -parent .pgaw:ReportBuilder -message [intlmsg "All report information will be deleted.\n\nProceed ?"] -type yesno -default no]=="yes"} then {
.pgaw:ReportBuilder.c delete all
init
drawReportAreas
}
}
}
################################################################
proc vTclWindow.pgaw:ReportBuilder {base} {
global PgAcVar
if {$base == ""} {
set base .pgaw:ReportBuilder
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
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 [intlmsg "Report builder"]
label $base.l1 \
-borderwidth 1 \
-relief raised -text [intlmsg {Report fields}]
listbox $base.lb \
-background #fefefe -foreground #000000 -borderwidth 1 \
-selectbackground #c3c3c3 \
-highlightthickness 1 -selectborderwidth 0 \
-yscrollcommand {.pgaw:ReportBuilder.sb set}
bind $base.lb <ButtonRelease-1> {
Reports::addField
}
canvas $base.c \
-background #fffeff -borderwidth 2 -height 207 -highlightthickness 0 \
-relief ridge -takefocus 1 -width 295
bind $base.c <Button-1> {
Reports::dragStart %W %x %y
}
bind $base.c <ButtonRelease-1> {
Reports::dragStop %x %y
}
bind $base.c <Key-Delete> {
Reports::deleteObject
}
bind $base.c <Motion> {
Reports::dragMove %W %x %y
}
button $base.bt2 \
-command Reports::deleteAllObjects \
-text [intlmsg {Delete all}]
button $base.bt4 \
-command Reports::preview \
-text [intlmsg Preview]
button $base.bt5 \
-borderwidth 1 -command {Window destroy .pgaw:ReportBuilder} \
-text [intlmsg Close]
scrollbar $base.sb \
-borderwidth 1 -command {.pgaw:ReportBuilder.lb yview} -orient vert
label $base.lmsg \
-anchor w \
-relief groove -text [intlmsg {Report header}] -textvariable PgAcVar(report,msg)
entry $base.e2 \
-background #fefefe -borderwidth 1 -highlightthickness 0 \
-textvariable PgAcVar(report,tablename)
bind $base.e2 <Key-Return> {
Reports::getSourceFields
}
entry $base.elab \
-background #fefefe -borderwidth 1 -highlightthickness 0 \
-textvariable PgAcVar(report,labeltext)
button $base.badl \
-borderwidth 1 -command Reports::addLabel \
-text [intlmsg {Add label}]
label $base.lbold \
-borderwidth 1 -relief raised -text B
bind $base.lbold <Button-1> {
Reports::toggleBold
}
label $base.lita \
-borderwidth 1 \
-font $PgAcVar(pref,font_italic) \
-relief raised -text i
bind $base.lita <Button-1> {
Reports::toggleItalic
}
entry $base.eps \
-background #fefefe -highlightthickness 0 -relief groove \
-textvariable PgAcVar(report,pointsize)
bind $base.eps <Key-Return> {
Reports::setObjectFont
}
label $base.linfo \
-anchor w \
-relief groove -text {Database field} -textvariable PgAcVar(report,info)
label $base.llal \
-borderwidth 0 -text Align
button $base.balign \
-borderwidth 0 -command Reports::toggleAlignMode \
-relief groove -text right
button $base.savebtn \
-borderwidth 1 -command Reports::save \
-text [intlmsg Save]
label $base.lfn \
-borderwidth 0 -text Font
button $base.bfont \
-borderwidth 0 \
-command Reports::setFont \
-relief groove -text Courier
button $base.bdd \
-borderwidth 1 \
-command {if {[winfo exists .pgaw:ReportBuilder.ddf]} {
destroy .pgaw:ReportBuilder.ddf
} else {
create_drop_down .pgaw:ReportBuilder 405 22 200
focus .pgaw:ReportBuilder.ddf.sb
foreach tbl [Database::getTablesList] {.pgaw:ReportBuilder.ddf.lb insert end $tbl}
bind .pgaw:ReportBuilder.ddf.lb <ButtonRelease-1> {
set i [.pgaw:ReportBuilder.ddf.lb curselection]
if {$i!=""} {set PgAcVar(report,tablename) [.pgaw:ReportBuilder.ddf.lb get $i]}
destroy .pgaw:ReportBuilder.ddf
Reports::getSourceFields
break
}
}} \
-highlightthickness 0 -image dnarw
label $base.lrn \
-borderwidth 0 -text [intlmsg {Report name}]
entry $base.ern \
-background #fefefe -borderwidth 1 -highlightthickness 0 \
-textvariable PgAcVar(report,reportname)
bind $base.ern <Key-F5> {
loadReport
}
label $base.lrs \
-borderwidth 0 -text [intlmsg {Report source}]
label $base.ls \
-borderwidth 1 -relief raised
entry $base.ef \
-background #fefefe -borderwidth 1 -highlightthickness 0 \
-textvariable PgAcVar(report,formula)
button $base.baf \
-borderwidth 1 \
-text [intlmsg {Add formula}]
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.pgaw:ReportPreview {base} {
if {$base == ""} {
set base .pgaw:ReportPreview
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
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 {.pgaw:ReportPreview.fr.sb set}
scrollbar $base.fr.sb \
-borderwidth 1 -command {.pgaw:ReportPreview.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 {$PgAcVar(report,justpreview)} then {Window destroy .pgaw:ReportBuilder} ; Window destroy .pgaw:ReportPreview} \
-text [intlmsg Close]
button $base.f1.button17 \
-borderwidth 1 -command Reports::print \
-text Print
pack $base.fr \
-in .pgaw:ReportPreview -anchor center -expand 1 -fill both -side top
pack $base.fr.c \
-in .pgaw:ReportPreview.fr -anchor center -expand 1 -fill both -side left
pack $base.fr.sb \
-in .pgaw:ReportPreview.fr -anchor center -expand 0 -fill y -side right
pack $base.f1 \
-in .pgaw:ReportPreview -anchor center -expand 0 -fill none -side top
pack $base.f1.button18 \
-in .pgaw:ReportPreview.f1 -anchor center -expand 0 -fill none -side right
pack $base.f1.button17 \
-in .pgaw:ReportPreview.f1 -anchor center -expand 0 -fill none -side left
}
src/bin/pgaccess/lib/schema.tcl 0 → 100644
View file @ 25acbc51
namespace eval Schema {
proc {new} {} {
global PgAcVar
init
Window show .pgaw:Schema
set PgAcVar(schema,oid) 0
set PgAcVar(schema,name) {}
set PgAcVar(schema,tables) {}
set PgAcVar(schema,links) {}
set PgAcVar(schema,results) {}
focus .pgaw:Schema.f.e
}
proc {open} {obj} {
global PgAcVar CurrentDB
init
set PgAcVar(schema,name) $obj
if {[set pgres [wpg_exec $CurrentDB "select schematables,schemalinks,oid from pga_schema where schemaname='$PgAcVar(schema,name)'"]]==0} then {
showError [intlmsg "Error retrieving schema definition"]
return
}
if {[pg_result $pgres -numTuples]==0} {
showError [format [intlmsg "Schema '%s' was not found!"] $PgAcVar(schema,name)]
pg_result $pgres -clear
return
}
set tuple [pg_result $pgres -getTuple 0]
set tables [lindex $tuple 0]
set links [lindex $tuple 1]
set PgAcVar(schema,oid) [lindex $tuple 2]
pg_result $pgres -clear
Window show .pgaw:Schema
foreach {t x y} $tables {
set PgAcVar(schema,newtablename) $t
addNewTable $x $y
}
set PgAcVar(schema,links) $links
drawLinks
}
proc {addNewTable} {{tabx 0} {taby 0}} {
global PgAcVar CurrentDB
if {$PgAcVar(schema,newtablename)==""} return
if {$PgAcVar(schema,newtablename)=="*"} {
set tbllist [Database::getTablesList]
foreach tn [array names PgAcVar schema,tablename*] {
if { [set linkid [lsearch $tbllist $PgAcVar($tn)]] != -1 } {
set tbllist [lreplace $tbllist $linkid $linkid]
}
}
foreach t $tbllist {
set PgAcVar(schema,newtablename) $t
addNewTable
}
return
}
foreach tn [array names PgAcVar schema,tablename*] {
if {$PgAcVar(schema,newtablename)==$PgAcVar($tn)} {
showError [format [intlmsg "Table '%s' already in schema"] $PgAcVar($tn)]
return
}
}
set fldlist {}
setCursor CLOCK
wpg_select $CurrentDB "select attnum,attname,typname from pg_class,pg_attribute,pg_type where (pg_class.relname='$PgAcVar(schema,newtablename)') and (pg_class.oid=pg_attribute.attrelid) and (attnum>0) and (atttypid=pg_type.oid) order by attnum" rec {
lappend fldlist $rec(attname) $rec(typname)
}
setCursor DEFAULT
if {$fldlist==""} {
showError [format [intlmsg "Table '%s' not found!"] $PgAcVar(schema,newtablename)]
return
}
set PgAcVar(schema,tablename$PgAcVar(schema,ntables)) $PgAcVar(schema,newtablename)
set PgAcVar(schema,tablestruct$PgAcVar(schema,ntables)) $fldlist
set PgAcVar(schema,tablex$PgAcVar(schema,ntables)) $tabx
set PgAcVar(schema,tabley$PgAcVar(schema,ntables)) $taby
incr PgAcVar(schema,ntables)
if {$PgAcVar(schema,ntables)==1} {
drawAll
} else {
drawTable [expr $PgAcVar(schema,ntables)-1]
}
lappend PgAcVar(schema,tables) $PgAcVar(schema,newtablename) $PgAcVar(schema,tablex[expr $PgAcVar(schema,ntables)-1]) $PgAcVar(schema,tabley[expr $PgAcVar(schema,ntables)-1])
set PgAcVar(schema,newtablename) {}
focus .pgaw:Schema.f.e
}
proc {drawAll} {} {
global PgAcVar
.pgaw:Schema.c delete all
for {set it 0} {$it<$PgAcVar(schema,ntables)} {incr it} {
drawTable $it
}
.pgaw:Schema.c lower rect
drawLinks
.pgaw:Schema.c bind mov <Button-1> {Schema::dragStart %W %x %y}
.pgaw:Schema.c bind mov <B1-Motion> {Schema::dragMove %W %x %y}
bind .pgaw:Schema.c <ButtonRelease-1> {Schema::dragStop %x %y}
bind .pgaw:Schema <Button-1> {Schema::canvasClick %x %y %W}
bind .pgaw:Schema <B1-Motion> {Schema::canvasPanning %x %y}
bind .pgaw:Schema <Key-Delete> {Schema::deleteObject}
}
proc {drawTable} {it} {
global PgAcVar
if {$PgAcVar(schema,tablex$it)==0} {
set posy $PgAcVar(schema,nexty)
set posx $PgAcVar(schema,nextx)
set PgAcVar(schema,tablex$it) $posx
set PgAcVar(schema,tabley$it) $posy
} else {
set posx [expr int($PgAcVar(schema,tablex$it))]
set posy [expr int($PgAcVar(schema,tabley$it))]
}
set tablename $PgAcVar(schema,tablename$it)
.pgaw:Schema.c create text $posx $posy -text "$tablename" -anchor nw -tags [subst {tab$it f-oid mov tableheader}] -font $PgAcVar(pref,font_bold)
incr posy 16
foreach {fld ftype} $PgAcVar(schema,tablestruct$it) {
if {[set cindex [lsearch $PgAcVar(pref,typelist) $ftype]] == -1} {set cindex 1}
.pgaw:Schema.c create text $posx $posy -text $fld -fill [lindex $PgAcVar(pref,typecolors) $cindex] -anchor nw -tags [subst {f-$fld tab$it mov}] -font $PgAcVar(pref,font_normal)
incr posy 14
}
set reg [.pgaw:Schema.c bbox tab$it]
.pgaw:Schema.c create rectangle [lindex $reg 0] [lindex $reg 1] [lindex $reg 2] [lindex $reg 3] -fill #EEEEEE -tags [subst {rect outer tab$it}]
.pgaw:Schema.c create line [lindex $reg 0] [expr [lindex $reg 1]+15] [lindex $reg 2] [expr [lindex $reg 1]+15] -tags [subst {rect tab$it}]
.pgaw:Schema.c lower tab$it
.pgaw:Schema.c lower rect
set reg [.pgaw:Schema.c bbox tab$it]
set nexty [lindex $reg 1]
set nextx [expr 20+[lindex $reg 2]]
if {$nextx > [winfo width .pgaw:Schema.c] } {
set nextx 10
set allbox [.pgaw:Schema.c bbox rect]
set nexty [expr 20 + [lindex $allbox 3]]
}
set PgAcVar(schema,nextx) $nextx
set PgAcVar(schema,nexty) $nexty
}
proc {deleteObject} {} {
global PgAcVar
# Checking if there
set obj [.pgaw:Schema.c find withtag hili]
if {$obj==""} return
# Is object a link ?
if {[getTagInfo $obj link]=="s"} {
if {[tk_messageBox -title [intlmsg Warning] -icon question -parent .pgaw:Schema -message [intlmsg "Remove link ?"] -type yesno -default no]=="no"} return
set linkid [getTagInfo $obj lkid]
set PgAcVar(schema,links) [lreplace $PgAcVar(schema,links) $linkid $linkid]
.pgaw:Schema.c delete links
drawLinks
return
}
# Is object a table ?
set tablealias [getTagInfo $obj tab]
set tablename $PgAcVar(schema,tablename$tablealias)
if {"$tablename"==""} return
if {[tk_messageBox -title [intlmsg Warning] -icon question -parent .pgaw:Schema -message [format [intlmsg "Remove table %s from query?"] $tablename] -type yesno -default no]=="no"} return
for {set i [expr [llength $PgAcVar(schema,links)]-1]} {$i>=0} {incr i -1} {
set thelink [lindex $PgAcVar(schema,links) $i]
if {($tablealias==[lindex $thelink 0]) || ($tablealias==[lindex $thelink 2])} {
set PgAcVar(schema,links) [lreplace $PgAcVar(schema,links) $i $i]
}
}
for {set i 0} {$i<$PgAcVar(schema,ntables)} {incr i} {
set temp {}
catch {set temp $PgAcVar(schema,tablename$i)}
if {"$temp"=="$tablename"} {
unset PgAcVar(schema,tablename$i)
unset PgAcVar(schema,tablestruct$i)
break
}
}
#incr PgAcVar(schema,ntables) -1
.pgaw:Schema.c delete tab$tablealias
.pgaw:Schema.c delete links
drawLinks
}
proc {dragMove} {w x y} {
global PgAcVar
if {"$PgAcVar(draginfo,obj)" == ""} {return}
set dx [expr $x - $PgAcVar(draginfo,x)]
set dy [expr $y - $PgAcVar(draginfo,y)]
if {$PgAcVar(draginfo,is_a_table)} {
$w move $PgAcVar(draginfo,tabletag) $dx $dy
drawLinks
} else {
$w move $PgAcVar(draginfo,obj) $dx $dy
}
set PgAcVar(draginfo,x) $x
set PgAcVar(draginfo,y) $y
}
proc {dragStart} {w x y} {
global PgAcVar
PgAcVar:clean draginfo,*
set PgAcVar(draginfo,obj) [$w find closest $x $y]
if {[getTagInfo $PgAcVar(draginfo,obj) r]=="ect"} {
# If it'a a rectangle, exit
set PgAcVar(draginfo,obj) {}
return
}
.pgaw:Schema configure -cursor hand1
.pgaw:Schema.c raise $PgAcVar(draginfo,obj)
set PgAcVar(draginfo,table) 0
if {[getTagInfo $PgAcVar(draginfo,obj) table]=="header"} {
set PgAcVar(draginfo,is_a_table) 1
set taglist [.pgaw:Schema.c gettags $PgAcVar(draginfo,obj)]
set PgAcVar(draginfo,tabletag) [lindex $taglist [lsearch -regexp $taglist "^tab\[0-9\]*"]]
.pgaw:Schema.c raise $PgAcVar(draginfo,tabletag)
.pgaw:Schema.c itemconfigure [.pgaw:Schema.c find withtag hili] -fill black
.pgaw:Schema.c dtag [.pgaw:Schema.c find withtag hili] hili
.pgaw:Schema.c addtag hili withtag $PgAcVar(draginfo,obj)
.pgaw:Schema.c itemconfigure hili -fill blue
} else {
set PgAcVar(draginfo,is_a_table) 0
}
set PgAcVar(draginfo,x) $x
set PgAcVar(draginfo,y) $y
set PgAcVar(draginfo,sx) $x
set PgAcVar(draginfo,sy) $y
}
proc {dragStop} {x y} {
global PgAcVar
# when click Close, schema window is destroyed but event ButtonRelease-1 is fired
if {![winfo exists .pgaw:Schema]} return;
.pgaw:Schema configure -cursor left_ptr
set este {}
catch {set este $PgAcVar(draginfo,obj)}
if {$este==""} return
# Re-establish the normal paint order so
# information won't be overlapped by table rectangles
# or link lines
.pgaw:Schema.c lower $PgAcVar(draginfo,obj)
.pgaw:Schema.c lower rect
.pgaw:Schema.c lower links
set PgAcVar(schema,panstarted) 0
if {$PgAcVar(draginfo,is_a_table)} {
set tabnum [getTagInfo $PgAcVar(draginfo,obj) tab]
foreach w [.pgaw:Schema.c find withtag $PgAcVar(draginfo,tabletag)] {
if {[lsearch [.pgaw:Schema.c gettags $w] outer] != -1} {
foreach [list PgAcVar(schema,tablex$tabnum) PgAcVar(schema,tabley$tabnum) x1 y1] [.pgaw:Schema.c coords $w] {}
break
}
}
set PgAcVar(draginfo,obj) {}
.pgaw:Schema.c delete links
drawLinks
return
}
# not a table
.pgaw:Schema.c move $PgAcVar(draginfo,obj) [expr $PgAcVar(draginfo,sx)-$x] [expr $PgAcVar(draginfo,sy)-$y]
set droptarget [.pgaw:Schema.c find overlapping $x $y $x $y]
set targettable {}
foreach item $droptarget {
set targettable $PgAcVar(schema,tablename[getTagInfo $item tab])
set targetfield [getTagInfo $item f-]
if {($targettable!="") && ($targetfield!="")} {
set droptarget $item
break
}
}
# check if target object isn't a rectangle
if {[getTagInfo $droptarget rec]=="t"} {set targettable {}}
if {$targettable!=""} {
# Target has a table
# See about originate table
set sourcetable $PgAcVar(schema,tablename[getTagInfo $PgAcVar(draginfo,obj) tab])
if {$sourcetable!=""} {
# Source has also a tab .. tag
set sourcefield [getTagInfo $PgAcVar(draginfo,obj) f-]
if {$sourcetable!=$targettable} {
lappend PgAcVar(schema,links) [list $sourcetable $sourcefield $targettable $targetfield]
drawLinks
}
}
}
# Erase information about object beeing dragged
set PgAcVar(draginfo,obj) {}
}
proc {drawLinks} {} {
global PgAcVar
.pgaw:Schema.c delete links
set i 0
foreach link $PgAcVar(schema,links) {
set sourcenum -1
set targetnum -1
# Compute the source and destination right edge
foreach t [array names PgAcVar schema,tablename*] {
if {[regexp "^$PgAcVar($t)$" [lindex $link 0] ]} {
set sourcenum [string range $t 16 end]
} elseif {[regexp "^$PgAcVar($t)$" [lindex $link 2] ]} {
set targetnum [string range $t 16 end]
}
}
set sb [findField $sourcenum [lindex $link 1]]
set db [findField $targetnum [lindex $link 3]]
if {($sourcenum == -1 )||($targetnum == -1)||($sb ==-1)||($db==-1)} {
set PgAcVar(schema,links) [lreplace $PgAcVar(schema,links) $i $i]
showError "Link from [lindex $link 0].[lindex $link 1] to [lindex $link 2].[lindex $link 3] not found!"
} else {
set sre [lindex [.pgaw:Schema.c bbox tab$sourcenum] 2]
set dre [lindex [.pgaw:Schema.c bbox tab$targetnum] 2]
# Compute field bound boxes
set sbbox [.pgaw:Schema.c bbox $sb]
set dbbox [.pgaw:Schema.c bbox $db]
# 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]
.pgaw:Schema.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]
.pgaw:Schema.c create line [expr $x2-10] $y2 $x2 $y2 \
-tags [subst {links lkid$i}] -width 3
.pgaw:Schema.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]
.pgaw:Schema.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]
.pgaw:Schema.c create line $x2 $y2 [expr $x2+10] $y2 -width 3 \
-tags [subst {links lkid$i}]
.pgaw:Schema.c create line [expr $x1-10] $y1 [expr $x2+10] $y2 \
-tags [subst {links lkid$i}] -width 2
}
incr i
}
}
.pgaw:Schema.c lower links
.pgaw:Schema.c bind links <Button-1> {Schema::linkClick %x %y}
}
proc {getSchemaTabless} {} {
global PgAcVar
set tablelist {}
foreach key [array names PgAcVar schema,tablename*] {
regsub schema,tablename $key "" num
lappend tablelist $PgAcVar($key) $PgAcVar(schema,tablex$num) $PgAcVar(schema,tabley$num)
}
return $tablelist
}
proc {findField} {alias field} {
foreach obj [.pgaw:Schema.c find withtag f-${field}] {
if {[lsearch [.pgaw:Schema.c gettags $obj] tab$alias] != -1} {return $obj}
}
return -1
}
proc {addLink} {sourcetable sourcefield targettable targetfield} {
global PgAcVar
lappend PgAcVar(schema,links) [list $sourcetable $sourcefield $targettable $targetfield]
}
proc {getTagInfo} {obj prefix} {
set taglist [.pgaw:Schema.c gettags $obj]
set tagpos [lsearch -regexp $taglist "^$prefix"]
if {$tagpos==-1} {return ""}
set thattag [lindex $taglist $tagpos]
return [string range $thattag [string length $prefix] end]
}
proc {init} {} {
global PgAcVar
PgAcVar:clean schema,*
set PgAcVar(schema,nexty) 10
set PgAcVar(schema,nextx) 10
set PgAcVar(schema,links) {}
set PgAcVar(schema,ntables) 0
set PgAcVar(schema,newtablename) {}
}
proc {linkClick} {x y} {
global PgAcVar
set obj [.pgaw:Schema.c find closest $x $y 1 links]
if {[getTagInfo $obj link]!="s"} return
.pgaw:Schema.c itemconfigure [.pgaw:Schema.c find withtag hili] -fill black
.pgaw:Schema.c dtag [.pgaw:Schema.c find withtag hili] hili
.pgaw:Schema.c addtag hili withtag $obj
.pgaw:Schema.c itemconfigure $obj -fill blue
}
proc {canvasPanning} {x y} {
global PgAcVar
set panstarted 0
catch {set panstarted $PgAcVar(schema,panstarted) }
if {!$panstarted} return
set dx [expr $x-$PgAcVar(schema,panstartx)]
set dy [expr $y-$PgAcVar(schema,panstarty)]
set PgAcVar(schema,panstartx) $x
set PgAcVar(schema,panstarty) $y
if {$PgAcVar(schema,panobject)=="tables"} {
.pgaw:Schema.c move mov $dx $dy
.pgaw:Schema.c move links $dx $dy
.pgaw:Schema.c move rect $dx $dy
} else {
.pgaw:Schema.c move resp $dx 0
.pgaw:Schema.c move resgrid $dx 0
.pgaw:Schema.c raise reshdr
}
}
proc print {c} {
set types {
{{Postscript Files} {.ps}}
{{All Files} *}
}
if {[catch {tk_getSaveFile -defaultextension .ps -filetypes $types \
-title "Print to Postscript"} fn] || [string match {} $fn]} return
if {[catch {::open $fn "w" } fid]} {
return -code error "Save Error: Unable to open '$fn' for writing\n$fid"
}
puts $fid [$c postscript -rotate 1]
close $fid
}
proc {canvasClick} {x y w} {
global PgAcVar
set PgAcVar(schema,panstarted) 0
if {$w==".pgaw:Schema.c"} {
set canpan 1
if {[llength [.pgaw:Schema.c find overlapping $x $y $x $y]]!=0} {set canpan 0}
set PgAcVar(schema,panobject) tables
if {$canpan} {
if {[.pgaw:Schema.c find withtag hili]!=""} {
.pgaw:Schema.c itemconfigure [.pgaw:Schema.c find withtag hili] -fill black
.pgaw:Schema.c dtag [.pgaw:Schema.c find withtag hili] hili
}
.pgaw:Schema configure -cursor hand1
set PgAcVar(schema,panstartx) $x
set PgAcVar(schema,panstarty) $y
set PgAcVar(schema,panstarted) 1
}
}
}
}
proc vTclWindow.pgaw:Schema {base} {
global PgAcVar
if {$base == ""} {
set base .pgaw:Schema
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
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 title $base [intlmsg "Visual schema designer"]
bind $base <B1-Motion> {
Schema::canvasPanning %x %y
}
bind $base <Button-1> {
Schema::canvasClick %x %y %W
}
bind $base <ButtonRelease-1> {
Schema::dragStop %x %y
}
bind $base <Key-Delete> {
Schema::deleteObject
}
canvas $base.c -background #fefefe -borderwidth 2 -height 207 -relief ridge -takefocus 0 -width 295
frame $base.f \
-height 75 -relief groove -width 125
label $base.f.l -text [intlmsg {Add table}]
entry $base.f.e \
-background #fefefe -borderwidth 1
bind $base.f.e <Key-Return> {
Schema::addNewTable
}
button $base.f.bdd \
-image dnarw \
-command {if {[winfo exists .pgaw:Schema.ddf]} {
destroy .pgaw:Schema.ddf
} else {
create_drop_down .pgaw:Schema 70 27 200
focus .pgaw:Schema.ddf.sb
foreach tbl [Database::getTablesList] {.pgaw:Schema.ddf.lb insert end $tbl}
bind .pgaw:Schema.ddf.lb <ButtonRelease-1> {
set i [.pgaw:Schema.ddf.lb curselection]
if {$i!=""} {
set PgAcVar(schema,newtablename) [.pgaw:Schema.ddf.lb get $i]
Schema::addNewTable
}
destroy .pgaw:Schema.ddf
break
}
}} \
-padx 1 -pady 1
button $base.f.btnclose \
-command {Schema::init
Window destroy .pgaw:Schema} -padx 2 -pady 3 -text [intlmsg Close]
button $base.f.printbtn \
-command {Schema::print .pgaw:Schema.c} -padx 1 -pady 3 -text [intlmsg Print]
button $base.f.btnsave \
-command {if {$PgAcVar(schema,name)==""} then {
showError [intlmsg "You have to supply a name for this schema!"]
focus .pgaw:Schema.f.esn
} else {
setCursor CLOCK
set tables [Schema::getSchemaTabless]
if {$PgAcVar(schema,oid)==0} then {
set pgres [wpg_exec $CurrentDB "insert into pga_schema values ('$PgAcVar(schema,name)','$tables','$PgAcVar(schema,links)')"]
} else {
set pgres [wpg_exec $CurrentDB "update pga_schema set schemaname='$PgAcVar(schema,name)',schematables='$tables',schemalinks='$PgAcVar(schema,links)' where oid=$PgAcVar(schema,oid)"]
}
setCursor DEFAULT
if {$PgAcVar(pgsql,status)!="PGRES_COMMAND_OK"} then {
showError "[intlmsg {Error executing query}]\n$PgAcVar(pgsql,errmsg)"
} else {
Mainlib::tab_click Schema
if {$PgAcVar(schema,oid)==0} {set PgAcVar(schema,oid) [pg_result $pgres -oid]}
}
catch {pg_result $pgres -clear}
}} \
-padx 2 -pady 3 -text [intlmsg {Save schema}]
label $base.f.ls1 -text { }
entry $base.f.esn \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(schema,name)
label $base.f.lsn -text [intlmsg {Schema name}]
place $base.c -x 5 -y 30 -width 748 -height 500 -anchor nw -bordermode ignore
place $base.f \
-x 5 -y 5 -width 748 -height 25 -anchor nw -bordermode ignore
pack $base.f.l \
-in .pgaw:Schema.f -anchor center -expand 0 -fill none -side left
pack $base.f.e \
-in .pgaw:Schema.f -anchor center -expand 0 -fill none -side left
pack $base.f.bdd \
-in .pgaw:Schema.f -anchor center -expand 0 -fill none -side left
pack $base.f.btnclose \
-in .pgaw:Schema.f -anchor center -expand 0 -fill none -side right
pack $base.f.printbtn \
-in .pgaw:Schema.f -anchor center -expand 0 -fill none -side right
pack $base.f.btnsave \
-in .pgaw:Schema.f -anchor center -expand 0 -fill none -side right
pack $base.f.ls1 \
-in .pgaw:Schema.f -anchor center -expand 0 -fill none -side right
pack $base.f.esn \
-in .pgaw:Schema.f -anchor center -expand 0 -fill none -side right
pack $base.f.lsn \
-in .pgaw:Schema.f -anchor center -expand 0 -fill none -side right
}
src/bin/pgaccess/lib/scripts.tcl 0 → 100644
View file @ 25acbc51
namespace eval Scripts {
proc {new} {} {
design {}
}
proc {open} {scriptname} {
global CurrentDB
set ss {}
wpg_select $CurrentDB "select * from pga_scripts where scriptname='$scriptname'" rec {
set ss $rec(scriptsource)
}
if {[string length $ss] > 0} {
eval $ss
}
}
proc {design} {scriptname} {
global PgAcVar CurrentDB
Window show .pgaw:Scripts
set PgAcVar(script,name) $scriptname
.pgaw:Scripts.src delete 1.0 end
if {[string length $scriptname]==0} return;
wpg_select $CurrentDB "select * from pga_scripts where scriptname='$scriptname'" rec {
.pgaw:Scripts.src insert end $rec(scriptsource)
}
}
proc {execute} {scriptname} {
# a wrap for execute command
open $scriptname
}
proc {save} {} {
global PgAcVar
if {$PgAcVar(script,name)==""} {
tk_messageBox -title [intlmsg Warning] -parent .pgaw:Scripts -message [intlmsg "The script must have a name!"]
} else {
sql_exec noquiet "delete from pga_scripts where scriptname='$PgAcVar(script,name)'"
regsub -all {\\} [.pgaw:Scripts.src get 1.0 end] {\\\\} PgAcVar(script,body)
regsub -all ' $PgAcVar(script,body) \\' PgAcVar(script,body)
sql_exec noquiet "insert into pga_scripts values ('$PgAcVar(script,name)','$PgAcVar(script,body)')"
Mainlib::tab_click Scripts
}
}
}
########################## END OF NAMESPACE SCRIPTS ##################
proc vTclWindow.pgaw:Scripts {base} {
global PgAcVar
if {$base == ""} {
set base .pgaw:Scripts
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
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 [intlmsg "Design script"]
frame $base.f1 -height 55 -relief groove -width 125
label $base.f1.l1 -borderwidth 0 -text [intlmsg {Script name}]
entry $base.f1.e1 -background #fefefe -borderwidth 1 -highlightthickness 0 -textvariable PgAcVar(script,name) -width 32
text $base.src -background #fefefe -foreground #000000 -font $PgAcVar(pref,font_normal) -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 .pgaw:Scripts} -text [intlmsg Cancel]
button $base.f2.b2 -borderwidth 1 -command Scripts::save \
-text [intlmsg Save] -width 6
pack $base.f1 -in .pgaw:Scripts -anchor center -expand 0 -fill x -pady 2 -side top
pack $base.f1.l1 -in .pgaw:Scripts.f1 -anchor center -expand 0 -fill none -ipadx 2 -side left
pack $base.f1.e1 -in .pgaw:Scripts.f1 -anchor center -expand 0 -fill none -side left
pack $base.src -in .pgaw:Scripts -anchor center -expand 1 -fill both -padx 2 -side top
pack $base.f2 -in .pgaw:Scripts -anchor center -expand 0 -fill none -side top
pack $base.f2.b1 -in .pgaw:Scripts.f2 -anchor center -expand 0 -fill none -side right
pack $base.f2.b2 -in .pgaw:Scripts.f2 -anchor center -expand 0 -fill none -side right
}
src/bin/pgaccess/lib/sequences.tcl 0 → 100644
View file @ 25acbc51
namespace eval Sequences {
proc {new} {} {
global PgAcVar
Window show .pgaw:Sequence
set PgAcVar(seq,name) {}
set PgAcVar(seq,incr) 1
set PgAcVar(seq,start) 1
set PgAcVar(seq,minval) 1
set PgAcVar(seq,maxval) 2147483647
focus .pgaw:Sequence.f1.e1
}
proc {open} {seqname} {
global PgAcVar CurrentDB
Window show .pgaw:Sequence
set flag 1
wpg_select $CurrentDB "select * from \"$seqname\"" rec {
set flag 0
set PgAcVar(seq,name) $seqname
set PgAcVar(seq,incr) $rec(increment_by)
set PgAcVar(seq,start) $rec(last_value)
.pgaw:Sequence.f1.l3 configure -text [intlmsg "Last value"]
set PgAcVar(seq,minval) $rec(min_value)
set PgAcVar(seq,maxval) $rec(max_value)
.pgaw:Sequence.fb.btnsave configure -state disabled
}
if {$flag} {
showError [format [intlmsg "Sequence '%s' not found!"] $seqname]
} else {
for {set i 1} {$i<6} {incr i} {
.pgaw:Sequence.f1.e$i configure -state disabled
}
focus .pgaw:Sequence.fb.btncancel
}
}
proc {save} {} {
global PgAcVar
if {$PgAcVar(seq,name)==""} {
showError [intlmsg "You should supply a name for this sequence"]
} else {
set s1 {};set s2 {};set s3 {};set s4 {};
if {$PgAcVar(seq,incr)!=""} {set s1 "increment $PgAcVar(seq,incr)"};
if {$PgAcVar(seq,start)!=""} {set s2 "start $PgAcVar(seq,start)"};
if {$PgAcVar(seq,minval)!=""} {set s3 "minvalue $PgAcVar(seq,minval)"};
if {$PgAcVar(seq,maxval)!=""} {set s4 "maxvalue $PgAcVar(seq,maxval)"};
set sqlcmd "create sequence \"$PgAcVar(seq,name)\" $s1 $s2 $s3 $s4"
if {[sql_exec noquiet $sqlcmd]} {
Mainlib::cmd_Sequences
tk_messageBox -title [intlmsg Information] -parent .pgaw:Sequence -message [intlmsg "Sequence created!"]
}
}
}
}
proc vTclWindow.pgaw:Sequence {base} {
if {$base == ""} {
set base .pgaw:Sequence
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
wm geometry $base 283x172+119+210
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 [intlmsg "Sequence"]
bind $base <Key-F1> "Help::load sequences"
frame $base.f1 \
-borderwidth 2 -height 75 -width 125
label $base.f1.l1 \
-borderwidth 0 -relief raised -text [intlmsg {Sequence name}]
entry $base.f1.e1 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(seq,name) -width 200
bind $base.f1.e1 <Key-KP_Enter> {
focus .pgaw:Sequence.f1.e2
}
bind $base.f1.e1 <Key-Return> {
focus .pgaw:Sequence.f1.e2
}
label $base.f1.l2 \
-borderwidth 0 -relief raised -text [intlmsg Increment]
entry $base.f1.e2 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(seq,incr) -width 200
bind $base.f1.e2 <Key-Return> {
focus .pgaw:Sequence.f1.e3
}
label $base.f1.l3 \
-borderwidth 0 -relief raised -text [intlmsg {Start value}]
entry $base.f1.e3 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(seq,start) -width 200
bind $base.f1.e3 <Key-Return> {
focus .pgaw:Sequence.f1.e4
}
label $base.f1.l4 \
-borderwidth 0 -relief raised -text [intlmsg Minvalue]
entry $base.f1.e4 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(seq,minval) \
-width 200
bind $base.f1.e4 <Key-Return> {
focus .pgaw:Sequence.f1.e5
}
label $base.f1.ls2 \
-borderwidth 0 -relief raised -text { }
label $base.f1.l5 \
-borderwidth 0 -relief raised -text [intlmsg Maxvalue]
entry $base.f1.e5 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(seq,maxval) \
-width 200
bind $base.f1.e5 <Key-Return> {
focus .pgaw:Sequence.fb.btnsave
}
frame $base.fb \
-height 75 -relief groove -width 125
button $base.fb.btnsave \
-borderwidth 1 -command Sequences::save \
-padx 9 -pady 3 -text [intlmsg {Define sequence}]
button $base.fb.btncancel \
-borderwidth 1 -command {Window destroy .pgaw:Sequence} \
-padx 9 -pady 3 -text [intlmsg Close]
place $base.f1 \
-x 9 -y 5 -width 265 -height 126 -anchor nw -bordermode ignore
grid columnconf $base.f1 2 -weight 1
grid $base.f1.l1 \
-in .pgaw:Sequence.f1 -column 0 -row 0 -columnspan 1 -rowspan 1 -sticky w
grid $base.f1.e1 \
-in .pgaw:Sequence.f1 -column 2 -row 0 -columnspan 1 -rowspan 1 -pady 2
grid $base.f1.l2 \
-in .pgaw:Sequence.f1 -column 0 -row 2 -columnspan 1 -rowspan 1 -sticky w
grid $base.f1.e2 \
-in .pgaw:Sequence.f1 -column 2 -row 2 -columnspan 1 -rowspan 1 -pady 2
grid $base.f1.l3 \
-in .pgaw:Sequence.f1 -column 0 -row 4 -columnspan 1 -rowspan 1 -sticky w
grid $base.f1.e3 \
-in .pgaw:Sequence.f1 -column 2 -row 4 -columnspan 1 -rowspan 1 -pady 2
grid $base.f1.l4 \
-in .pgaw:Sequence.f1 -column 0 -row 6 -columnspan 1 -rowspan 1 -sticky w
grid $base.f1.e4 \
-in .pgaw:Sequence.f1 -column 2 -row 6 -columnspan 1 -rowspan 1 -pady 2
grid $base.f1.ls2 \
-in .pgaw:Sequence.f1 -column 1 -row 0 -columnspan 1 -rowspan 1
grid $base.f1.l5 \
-in .pgaw:Sequence.f1 -column 0 -row 7 -columnspan 1 -rowspan 1 -sticky w
grid $base.f1.e5 \
-in .pgaw:Sequence.f1 -column 2 -row 7 -columnspan 1 -rowspan 1 -pady 2
place $base.fb \
-x 0 -y 135 -width 283 -height 40 -anchor nw -bordermode ignore
grid $base.fb.btnsave \
-in .pgaw:Sequence.fb -column 0 -row 0 -columnspan 1 -rowspan 1 -padx 5
grid $base.fb.btncancel \
-in .pgaw:Sequence.fb -column 1 -row 0 -columnspan 1 -rowspan 1 -padx 5
}
src/bin/pgaccess/lib/tables.tcl 0 → 100644
View file @ 25acbc51
namespace eval Tables {
proc {new} {} {
PgAcVar:clean nt,*
Window show .pgaw:NewTable
focus .pgaw:NewTable.etabn
}
proc {open} {tablename {filter ""} {order ""}} {
global PgAcVar
set wn [getNewWindowName]
createWindow
set PgAcVar(mw,$wn,tablename) $tablename
loadLayout $wn $tablename
set PgAcVar(mw,$wn,sortfield) $order
set PgAcVar(mw,$wn,filter) $filter
set PgAcVar(mw,$wn,query) "select oid,\"$tablename\".* from \"$tablename\""
set PgAcVar(mw,$wn,updatable) 1
set PgAcVar(mw,$wn,isaquery) 0
initVariables $wn
refreshRecords $wn
catch {wm title $wn "$tablename"}
}
proc {design} {tablename} {
global PgAcVar CurrentDB
if {$CurrentDB==""} return;
set PgAcVar(tblinfo,tablename) $tablename
refreshTableInformation
}
proc {refreshTableInformation} {} {
global PgAcVar CurrentDB
Window show .pgaw:TableInfo
wm title .pgaw:TableInfo "[intlmsg {Table information}] : $PgAcVar(tblinfo,tablename)"
.pgaw:TableInfo.f1.lb delete 0 end
.pgaw:TableInfo.f2.fl.ilb delete 0 end
.pgaw:TableInfo.f2.fr.lb delete 0 end
.pgaw:TableInfo.f3.plb delete 0 end
set PgAcVar(tblinfo,isunique) {}
set PgAcVar(tblinfo,isclustered) {}
set PgAcVar(tblinfo,indexfields) {}
wpg_select $CurrentDB "select attnum,attname,typname,attlen,attnotnull,atttypmod,usename,usesysid,pg_class.oid,relpages,reltuples,relhaspkey,relhasrules,relacl from pg_class,pg_user,pg_attribute,pg_type where (pg_class.relname='$PgAcVar(tblinfo,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)
if { $fsize=="-1" && $fsize1!="-1" } {
set fsize $rec(atttypmod)
incr fsize -4
}
if { $fsize1=="-1" && $fsize=="-1" } {
set fsize ""
}
if {$rec(attnotnull) == "t"} {
set notnull "NOT NULL"
} else {
set notnull {}
}
if {$rec(attnum)>0} {.pgaw:TableInfo.f1.lb insert end [format "%-33.33s %-14.14s %6.6s %-8.8s" $rec(attname) $ftype $fsize $notnull]}
set PgAcVar(tblinfo,owner) $rec(usename)
set PgAcVar(tblinfo,tableoid) $rec(oid)
set PgAcVar(tblinfo,ownerid) $rec(usesysid)
set PgAcVar(tblinfo,f$rec(attnum)) $rec(attname)
set PgAcVar(tblinfo,numtuples) $rec(reltuples)
set PgAcVar(tblinfo,numpages) $rec(relpages)
set PgAcVar(tblinfo,permissions) $rec(relacl)
if {$rec(relhaspkey)=="t"} {
set PgAcVar(tblinfo,hasprimarykey) [intlmsg Yes]
} else {
set PgAcVar(tblinfo,hasprimarykey) [intlmsg No]
}
if {$rec(relhasrules)=="t"} {
set PgAcVar(tblinfo,hasrules) [intlmsg Yes]
} else {
set PgAcVar(tblinfo,hasrules) [intlmsg No]
}
}
set PgAcVar(tblinfo,indexlist) {}
wpg_select $CurrentDB "select oid,indexrelid from pg_index where (pg_class.relname='$PgAcVar(tblinfo,tablename)') and (pg_class.oid=pg_index.indrelid)" rec {
lappend PgAcVar(tblinfo,indexlist) $rec(oid)
wpg_select $CurrentDB "select relname from pg_class where oid=$rec(indexrelid)" rec1 {
.pgaw:TableInfo.f2.fl.ilb insert end $rec1(relname)
}
}
#
# showing permissions
set temp $PgAcVar(tblinfo,permissions)
regsub "^\{" $temp {} temp
regsub "\}$" $temp {} temp
regsub -all "\"" $temp {} temp
foreach token [split $temp ,] {
set oli [split $token =]
set uname [lindex $oli 0]
set rights [lindex $oli 1]
if {$uname == ""} {set uname PUBLIC}
set r_select " "
set r_update " "
set r_insert " "
set r_rule " "
if {[string first r $rights] != -1} {set r_select x}
if {[string first w $rights] != -1} {set r_update x}
if {[string first a $rights] != -1} {set r_insert x}
if {[string first R $rights] != -1} {set r_rule x}
#
# changing the format of the following line can affect the loadPermissions procedure
# see below
.pgaw:TableInfo.f3.plb insert end [format "%-23.23s %11s %11s %11s %11s" $uname $r_select $r_update $r_insert $r_rule]
}
}
proc {loadPermissions} {} {
global PgAcVar
set sel [.pgaw:TableInfo.f3.plb curselection]
if {$sel == ""} {
bell
return
}
set line [.pgaw:TableInfo.f3.plb get $sel]
set uname [string trim [string range $line 0 22]]
Window show .pgaw:Permissions
wm transient .pgaw:Permissions .pgaw:TableInfo
set PgAcVar(permission,username) $uname
set PgAcVar(permission,select) [expr {"x"==[string range $line 34 34]}]
set PgAcVar(permission,update) [expr {"x"==[string range $line 46 46]}]
set PgAcVar(permission,insert) [expr {"x"==[string range $line 58 58]}]
set PgAcVar(permission,rule) [expr {"x"==[string range $line 70 70]}]
focus .pgaw:Permissions.f1.ename
}
proc {newPermissions} {} {
global PgAcVar
PgAcVar:clean permission,*
Window show .pgaw:Permissions
wm transient .pgaw:Permissions .pgaw:TableInfo
focus .pgaw:Permissions.f1.ename
}
proc {savePermissions} {} {
global PgAcVar
if {$PgAcVar(permission,username) == ""} {
showError [intlmsg "User without name?"]
return
}
sql_exec noquiet "revoke all on \"$PgAcVar(tblinfo,tablename)\" from $PgAcVar(permission,username)"
if {$PgAcVar(permission,select)} {
sql_exec noquiet "GRANT SELECT on \"$PgAcVar(tblinfo,tablename)\" to $PgAcVar(permission,username)"
}
if {$PgAcVar(permission,insert)} {
sql_exec noquiet "GRANT INSERT on \"$PgAcVar(tblinfo,tablename)\" to $PgAcVar(permission,username)"
}
if {$PgAcVar(permission,update)} {
sql_exec noquiet "GRANT UPDATE on \"$PgAcVar(tblinfo,tablename)\" to $PgAcVar(permission,username)"
}
if {$PgAcVar(permission,rule)} {
sql_exec noquiet "GRANT RULE on \"$PgAcVar(tblinfo,tablename)\" to $PgAcVar(permission,username)"
}
refreshTableInformation
}
proc {clusterIndex} {} {
global PgAcVar
set sel [.pgaw:TableInfo.f2.fl.ilb curselection]
if {$sel == ""} {
showError [intlmsg "You have to select an index!"]
return
}
bell
if {[tk_messageBox -title [intlmsg Warning] -parent .pgaw:TableInfo -message [format [intlmsg "You choose to cluster index\n\n %s \n\nAll other indices will be lost!\nProceed?"] [.pgaw:TableInfo.f2.fl.ilb get $sel]] -type yesno -default no]=="no"} {return}
if {[sql_exec noquiet "cluster \"[.pgaw:TableInfo.f2.fl.ilb get $sel]\" on \"$PgAcVar(tblinfo,tablename)\""]} {
refreshTableInformation
}
}
proc {get_tag_info} {wn itemid prefix} {
set taglist [$wn.c itemcget $itemid -tags]
set i [lsearch -glob $taglist $prefix*]
set thetag [lindex $taglist $i]
return [string range $thetag 1 end]
}
proc {dragMove} {w x y} {
global PgAcVar
set dlo ""
catch { set dlo $PgAcVar(draglocation,obj) }
if {$dlo != ""} {
set dx [expr $x - $PgAcVar(draglocation,x)]
set dy [expr $y - $PgAcVar(draglocation,y)]
$w move $dlo $dx $dy
set PgAcVar(draglocation,x) $x
set PgAcVar(draglocation,y) $y
}
}
proc {dragStart} {wn w x y} {
global PgAcVar
PgAcVar:clean draglocation,*
set object [$w find closest $x $y]
if {[lsearch [$wn.c gettags $object] movable]==-1} return;
$wn.c bind movable <Leave> {}
set PgAcVar(draglocation,obj) $object
set PgAcVar(draglocation,x) $x
set PgAcVar(draglocation,y) $y
set PgAcVar(draglocation,start) $x
}
proc {dragStop} {wn w x y} {
global PgAcVar CurrentDB
set dlo ""
catch { set dlo $PgAcVar(draglocation,obj) }
if {$dlo != ""} {
$wn.c bind movable <Leave> "$wn configure -cursor left_ptr"
$wn configure -cursor left_ptr
set ctr [get_tag_info $wn $PgAcVar(draglocation,obj) v]
set diff [expr $x-$PgAcVar(draglocation,start)]
if {$diff==0} return;
set newcw {}
for {set i 0} {$i<$PgAcVar(mw,$wn,colcount)} {incr i} {
if {$i==$ctr} {
lappend newcw [expr [lindex $PgAcVar(mw,$wn,colwidth) $i]+$diff]
} else {
lappend newcw [lindex $PgAcVar(mw,$wn,colwidth) $i]
}
}
set PgAcVar(mw,$wn,colwidth) $newcw
$wn.c itemconfigure c$ctr -width [expr [lindex $PgAcVar(mw,$wn,colwidth) $ctr]-5]
drawHeaders $wn
drawHorizontalLines $wn
if {$PgAcVar(mw,$wn,crtrow)!=""} {showRecord $wn $PgAcVar(mw,$wn,crtrow)}
for {set i [expr $ctr+1]} {$i<$PgAcVar(mw,$wn,colcount)} {incr i} {
$wn.c move c$i $diff 0
}
setCursor CLOCK
sql_exec quiet "update pga_layout set colwidth='$PgAcVar(mw,$wn,colwidth)' where tablename='$PgAcVar(mw,$wn,layout_name)'"
setCursor DEFAULT
}
}
proc {canvasClick} {wn x y} {
global PgAcVar
if {![finishEdit $wn]} return
# Determining row
for {set row 0} {$row<$PgAcVar(mw,$wn,nrecs)} {incr row} {
if {[lindex $PgAcVar(mw,$wn,rowy) $row]>$y} break
}
incr row -1
if {$y>[lindex $PgAcVar(mw,$wn,rowy) $PgAcVar(mw,$wn,last_rownum)]} {set row $PgAcVar(mw,$wn,last_rownum)}
if {$row<0} return
set PgAcVar(mw,$wn,row_edited) $row
set PgAcVar(mw,$wn,crtrow) $row
showRecord $wn $row
if {$PgAcVar(mw,$wn,errorsavingnew)} return
# Determining column
set posx [expr -$PgAcVar(mw,$wn,leftoffset)]
set col 0
foreach cw $PgAcVar(mw,$wn,colwidth) {
incr posx [expr $cw+2]
if {$x<$posx} break
incr col
}
set itlist [$wn.c find withtag r$row]
foreach item $itlist {
if {[get_tag_info $wn $item c]==$col} {
startEdit $wn $item $x $y
break
}
}
}
proc {deleteRecord} {wn} {
global PgAcVar CurrentDB
if {!$PgAcVar(mw,$wn,updatable)} return;
if {![finishEdit $wn]} return;
set taglist [$wn.c gettags hili]
if {[llength $taglist]==0} return;
set rowtag [lindex $taglist [lsearch -regexp $taglist "^r"]]
set row [string range $rowtag 1 end]
set oid [lindex $PgAcVar(mw,$wn,keylist) $row]
if {[tk_messageBox -title [intlmsg "FINAL WARNING"] -icon question -parent $wn -message [intlmsg "Delete current record ?"] -type yesno -default no]=="no"} return
if {[sql_exec noquiet "delete from \"$PgAcVar(mw,$wn,tablename)\" where oid=$oid"]} {
$wn.c delete hili
}
}
proc {drawHeaders} {wn} {
global PgAcVar
$wn.c delete header
set posx [expr 5-$PgAcVar(mw,$wn,leftoffset)]
for {set i 0} {$i<$PgAcVar(mw,$wn,colcount)} {incr i} {
set xf [expr $posx+[lindex $PgAcVar(mw,$wn,colwidth) $i]]
$wn.c create rectangle $posx 1 $xf 22 -fill #CCCCCC -outline "" -width 0 -tags header
$wn.c create text [expr $posx+[lindex $PgAcVar(mw,$wn,colwidth) $i]*1.0/2] 14 -text [lindex $PgAcVar(mw,$wn,colnames) $i] -tags header -fill navy -font $PgAcVar(pref,font_normal)
$wn.c create line $posx 22 [expr $xf-1] 22 -fill #AAAAAA -tags header
$wn.c create line [expr $xf-1] 5 [expr $xf-1] 22 -fill #AAAAAA -tags header
$wn.c create line [expr $xf+1] 5 [expr $xf+1] 22 -fill white -tags header
$wn.c create line $xf -15000 $xf 15000 -fill #CCCCCC -tags [subst {header movable v$i}]
set posx [expr $xf+2]
}
set PgAcVar(mw,$wn,r_edge) $posx
$wn.c bind movable <Button-1> "Tables::dragStart $wn %W %x %y"
$wn.c bind movable <B1-Motion> {Tables::dragMove %W %x %y}
$wn.c bind movable <ButtonRelease-1> "Tables::dragStop $wn %W %x %y"
$wn.c bind movable <Enter> "$wn configure -cursor left_side"
$wn.c bind movable <Leave> "$wn configure -cursor left_ptr"
}
proc {drawHorizontalLines} {wn} {
global PgAcVar
$wn.c delete hgrid
set posx 10
for {set j 0} {$j<$PgAcVar(mw,$wn,colcount)} {incr j} {
set ledge($j) $posx
incr posx [expr [lindex $PgAcVar(mw,$wn,colwidth) $j]+2]
set textwidth($j) [expr [lindex $PgAcVar(mw,$wn,colwidth) $j]-5]
}
incr posx -6
for {set i 0} {$i<$PgAcVar(mw,$wn,nrecs)} {incr i} {
$wn.c create line [expr -$PgAcVar(mw,$wn,leftoffset)] [lindex $PgAcVar(mw,$wn,rowy) [expr $i+1]] [expr $posx-$PgAcVar(mw,$wn,leftoffset)] [lindex $PgAcVar(mw,$wn,rowy) [expr $i+1]] -fill gray -tags [subst {hgrid g$i}]
}
if {$PgAcVar(mw,$wn,updatable)} {
set i $PgAcVar(mw,$wn,nrecs)
set posy [expr 14+[lindex $PgAcVar(mw,$wn,rowy) $PgAcVar(mw,$wn,nrecs)]]
$wn.c create line [expr -$PgAcVar(mw,$wn,leftoffset)] $posy [expr $posx-$PgAcVar(mw,$wn,leftoffset)] $posy -fill gray -tags [subst {hgrid g$i}]
}
}
proc {drawNewRecord} {wn} {
global PgAcVar
set posx [expr 10-$PgAcVar(mw,$wn,leftoffset)]
set posy [lindex $PgAcVar(mw,$wn,rowy) $PgAcVar(mw,$wn,last_rownum)]
if {$PgAcVar(pref,tvfont)=="helv"} {
set tvfont $PgAcVar(pref,font_normal)
} else {
set tvfont $PgAcVar(pref,font_fix)
}
if {$PgAcVar(mw,$wn,updatable)} {
for {set j 0} {$j<$PgAcVar(mw,$wn,colcount)} {incr j} {
$wn.c create text $posx $posy -text * -tags [subst {r$PgAcVar(mw,$wn,nrecs) c$j q new unt}] -anchor nw -font $tvfont -width [expr [lindex $PgAcVar(mw,$wn,colwidth) $j]-5]
incr posx [expr [lindex $PgAcVar(mw,$wn,colwidth) $j]+2]
}
incr posy 14
$wn.c create line [expr -$PgAcVar(mw,$wn,leftoffset)] $posy [expr $PgAcVar(mw,$wn,r_edge)-$PgAcVar(mw,$wn,leftoffset)] $posy -fill gray -tags [subst {hgrid g$PgAcVar(mw,$wn,nrecs)}]
}
}
proc {editMove} { wn {distance 1} {position end} } {
global PgAcVar
# This routine moves the cursor some relative distance
# from one cell being editted to another cell in the table.
# Typical distances are 1, +1, $PgAcVar(mw,$wn,colcount), and
# -$PgAcVar(mw,$wn,colcount). Position is where
# the cursor will be placed within the cell. The valid
# positions are 0 and end.
# get the current row and column
set current_cell_id $PgAcVar(mw,$wn,id_edited)
set tags [$wn.c gettags $current_cell_id]
regexp {r([0-9]+)} $tags match crow
regexp {c([0-9]+)} $tags match ccol
# calculate next row and column
set colcount $PgAcVar(mw,$wn,colcount)
set ccell [expr ($crow * $colcount) + $ccol]
set ncell [expr $ccell + $distance]
set nrow [expr $ncell / $colcount]
set ncol [expr $ncell % $colcount]
# find the row of the next cell
if {$distance < 0} {
set row_increment -1
} else {
set row_increment 1
}
set id_tuple [$wn.c find withtag r$nrow]
# skip over deleted rows...
while {[llength $id_tuple] == 0} {
# case above first row of table
if {$nrow < 0} {
return
# case at or beyond last row of table
} elseif {$nrow >= $PgAcVar(mw,$wn,nrecs)} {
if {![insertNewRecord $wn]} {
set PgAcVar(mw,$wn,errorsavingnew) 1
return
}
set id_tuple [$wn.c find withtag r$nrow]
break
}
incr nrow $row_increment
set id_tuple [$wn.c find withtag r$nrow]
}
# find the widget id of the next cell
set next_cell_id [lindex [lsort -integer $id_tuple] $ncol]
if {[string compare $next_cell_id {}] == 0} {
set next_cell_id [$wn.c find withtag $current_cell_id]
}
# make sure that the new cell is in the visible window
set toprec $PgAcVar(mw,$wn,toprec)
set numscreenrecs [getVisibleRecordsCount $wn]
if {$nrow < $toprec} {
# case nrow above visable window
scrollWindow $wn moveto \
[expr $nrow *[recordSizeInScrollbarUnits $wn]]
} elseif {$nrow > ($toprec + $numscreenrecs - 1)} {
# case nrow below visable window
scrollWindow $wn moveto \
[expr ($nrow - $numscreenrecs + 2) * [recordSizeInScrollbarUnits $wn]]
}
# I need to find a better way to pan -kk
foreach {x1 y1 x2 y2} [$wn.c bbox $next_cell_id] {break}
while {$x1 <= $PgAcVar(mw,$wn,leftoffset)} {
panRight $wn
foreach {x1 y1 x2 y2} [$wn.c bbox $next_cell_id] {break}
}
set rightedge [expr $x1 + [lindex $PgAcVar(mw,$wn,colwidth) $ncol]]
while {$rightedge > ($PgAcVar(mw,$wn,leftoffset) + [winfo width $wn.c])} {
panLeft $wn
}
# move to the next cell
foreach {x1 y1 x2 y2} [$wn.c bbox $next_cell_id] {break}
switch -exact -- $position {
0 {
canvasClick $wn [incr x1 ] [incr y1 ]
}
end -
default {
canvasClick $wn [incr x2 -1] [incr y2 -1]
}
}
}
proc {editText} {wn c k} {
global PgAcVar
set bbin [$wn.c bbox r$PgAcVar(mw,$wn,row_edited)]
switch $k {
BackSpace { set dp [expr [$wn.c index $PgAcVar(mw,$wn,id_edited) insert]-1];if {$dp>=0} {$wn.c dchars $PgAcVar(mw,$wn,id_edited) $dp $dp; set PgAcVar(mw,$wn,dirtyrec) 1}}
Home {$wn.c icursor $PgAcVar(mw,$wn,id_edited) 0}
End {$wn.c icursor $PgAcVar(mw,$wn,id_edited) end}
Left {
set position [expr [$wn.c index $PgAcVar(mw,$wn,id_edited) insert]-1]
if {$position < 0} {
editMove $wn -1 end
return
}
$wn.c icursor $PgAcVar(mw,$wn,id_edited) $position
}
Delete {}
Right {
set position [expr [$wn.c index $PgAcVar(mw,$wn,id_edited) insert]+1]
if {$position > [$wn.c index $PgAcVar(mw,$wn,id_edited) end] } {
editMove $wn 1 0
return
}
$wn.c icursor $PgAcVar(mw,$wn,id_edited) $position
}
Return -
Tab {editMove $wn; return}
ISO_Left_Tab {editMove $wn -1; return}
Up {editMove $wn -$PgAcVar(mw,$wn,colcount); return }
Down {editMove $wn $PgAcVar(mw,$wn,colcount); return }
Escape {set PgAcVar(mw,$wn,dirtyrec) 0; $wn.c itemconfigure $PgAcVar(mw,$wn,id_edited) -text $PgAcVar(mw,$wn,text_initial_value); $wn.c focus {}}
default {if {[string compare $c " "]>-1} {$wn.c insert $PgAcVar(mw,$wn,id_edited) insert $c;set PgAcVar(mw,$wn,dirtyrec) 1}}
}
set bbout [$wn.c bbox r$PgAcVar(mw,$wn,row_edited)]
set dy [expr [lindex $bbout 3]-[lindex $bbin 3]]
if {$dy==0} return
set re $PgAcVar(mw,$wn,row_edited)
$wn.c move g$re 0 $dy
for {set i [expr 1+$re]} {$i<=$PgAcVar(mw,$wn,nrecs)} {incr i} {
$wn.c move r$i 0 $dy
$wn.c move g$i 0 $dy
set rh [lindex $PgAcVar(mw,$wn,rowy) $i]
incr rh $dy
set PgAcVar(mw,$wn,rowy) [lreplace $PgAcVar(mw,$wn,rowy) $i $i $rh]
}
showRecord $wn $PgAcVar(mw,$wn,row_edited)
# Delete is trapped by window interpreted as record delete
# Delete {$wn.c dchars $PgAcVar(mw,$wn,id_edited) insert insert; set PgAcVar(mw,$wn,dirtyrec) 1}
}
proc {finishEdit} {wn} {
global PgAcVar CurrentDB
# User has edited the text ?
if {!$PgAcVar(mw,$wn,dirtyrec)} {
# No, unfocus text
$wn.c focus {}
# For restoring * to the new record position
if {$PgAcVar(mw,$wn,id_edited)!=""} {
if {[lsearch [$wn.c gettags $PgAcVar(mw,$wn,id_edited)] new]!=-1} {
$wn.c itemconfigure $PgAcVar(mw,$wn,id_edited) -text $PgAcVar(mw,$wn,text_initial_value)
}
}
set PgAcVar(mw,$wn,id_edited) {};set PgAcVar(mw,$wn,text_initial_value) {}
return 1
}
# Trimming the spaces
set fldval [string trim [$wn.c itemcget $PgAcVar(mw,$wn,id_edited) -text]]
$wn.c itemconfigure $PgAcVar(mw,$wn,id_edited) -text $fldval
if {[string compare $PgAcVar(mw,$wn,text_initial_value) $fldval]==0} {
set PgAcVar(mw,$wn,dirtyrec) 0
$wn.c focus {}
set PgAcVar(mw,$wn,id_edited) {};set PgAcVar(mw,$wn,text_initial_value) {}
return 1
}
setCursor CLOCK
set oid [lindex $PgAcVar(mw,$wn,keylist) $PgAcVar(mw,$wn,row_edited)]
set fld [lindex $PgAcVar(mw,$wn,colnames) [get_tag_info $wn $PgAcVar(mw,$wn,id_edited) c]]
set fillcolor black
if {$PgAcVar(mw,$wn,row_edited)==$PgAcVar(mw,$wn,last_rownum)} {
set fillcolor red
set sfp [lsearch $PgAcVar(mw,$wn,newrec_fields) "\"$fld\""]
if {$sfp>-1} {
set PgAcVar(mw,$wn,newrec_fields) [lreplace $PgAcVar(mw,$wn,newrec_fields) $sfp $sfp]
set PgAcVar(mw,$wn,newrec_values) [lreplace $PgAcVar(mw,$wn,newrec_values) $sfp $sfp]
}
lappend PgAcVar(mw,$wn,newrec_fields) "\"$fld\""
lappend PgAcVar(mw,$wn,newrec_values) '$fldval'
# Remove the untouched tag from the object
$wn.c dtag $PgAcVar(mw,$wn,id_edited) unt
$wn.c itemconfigure $PgAcVar(mw,$wn,id_edited) -fill red
set retval 1
} else {
set PgAcVar(mw,$wn,msg) "Updating record ..."
after 1000 "set PgAcVar(mw,$wn,msg) {}"
regsub -all ' $fldval \\' sqlfldval
#FIXME rjr 4/29/1999 special case null so it can be entered into tables
#really need to write a tcl sqlquote proc which quotes the string only
#if necessary, so it can be used all over pgaccess, instead of explicit 's
if {$sqlfldval == "null"} {
set retval [sql_exec noquiet "update \"$PgAcVar(mw,$wn,tablename)\" \
set \"$fld\"= null where oid=$oid"]
} else {
set retval [sql_exec noquiet "update \"$PgAcVar(mw,$wn,tablename)\" \
set \"$fld\"='$sqlfldval' where oid=$oid"]
}
}
setCursor DEFAULT
if {!$retval} {
set PgAcVar(mw,$wn,msg) ""
focus $wn.c
return 0
}
set PgAcVar(mw,$wn,dirtyrec) 0
$wn.c focus {}
set PgAcVar(mw,$wn,id_edited) {};set PgAcVar(mw,$wn,text_initial_value) {}
return 1
}
proc {loadLayout} {wn layoutname} {
global PgAcVar CurrentDB
setCursor CLOCK
set PgAcVar(mw,$wn,layout_name) $layoutname
catch {unset PgAcVar(mw,$wn,colcount) PgAcVar(mw,$wn,colnames) PgAcVar(mw,$wn,colwidth)}
set PgAcVar(mw,$wn,layout_found) 0
set pgres [wpg_exec $CurrentDB "select *,oid from pga_layout where tablename='$layoutname' 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 PgAcVar(mw,$wn,colcount) [lindex $layoutinfo 1]
set PgAcVar(mw,$wn,colnames) [lindex $layoutinfo 2]
set PgAcVar(mw,$wn,colwidth) [lindex $layoutinfo 3]
set goodoid [lindex $layoutinfo 4]
set PgAcVar(mw,$wn,layout_found) 1
}
if {$nrlay>1} {
showError "Multiple ($nrlay) layout info found\n\nPlease report the bug!"
sql_exec quiet "delete from pga_layout where (tablename='$PgAcVar(mw,$wn,tablename)') and (oid<>$goodoid)"
}
}
pg_result $pgres -clear
}
proc {panLeft} {wn } {
global PgAcVar
if {![finishEdit $wn]} return;
if {$PgAcVar(mw,$wn,leftcol)==[expr $PgAcVar(mw,$wn,colcount)-1]} return;
set diff [expr 2+[lindex $PgAcVar(mw,$wn,colwidth) $PgAcVar(mw,$wn,leftcol)]]
incr PgAcVar(mw,$wn,leftcol)
incr PgAcVar(mw,$wn,leftoffset) $diff
$wn.c move header -$diff 0
$wn.c move q -$diff 0
$wn.c move hgrid -$diff 0
}
proc {panRight} {wn} {
global PgAcVar
if {![finishEdit $wn]} return;
if {$PgAcVar(mw,$wn,leftcol)==0} return;
incr PgAcVar(mw,$wn,leftcol) -1
set diff [expr 2+[lindex $PgAcVar(mw,$wn,colwidth) $PgAcVar(mw,$wn,leftcol)]]
incr PgAcVar(mw,$wn,leftoffset) -$diff
$wn.c move header $diff 0
$wn.c move q $diff 0
$wn.c move hgrid $diff 0
}
proc {insertNewRecord} {wn} {
global PgAcVar CurrentDB
if {![finishEdit $wn]} {return 0}
if {$PgAcVar(mw,$wn,newrec_fields)==""} {return 1}
set PgAcVar(mw,$wn,msg) "Saving new record ..."
after 1000 "set PgAcVar(mw,$wn,msg) {}"
set pgres [wpg_exec $CurrentDB "insert into \"$PgAcVar(mw,$wn,tablename)\" ([join $PgAcVar(mw,$wn,newrec_fields) ,]) values ([join $PgAcVar(mw,$wn,newrec_values) ,])" ]
if {[pg_result $pgres -status]!="PGRES_COMMAND_OK"} {
set errmsg [pg_result $pgres -error]
showError "[intlmsg {Error inserting new record}]\n\n$errmsg"
return 0
}
set oid [pg_result $pgres -oid]
lappend PgAcVar(mw,$wn,keylist) $oid
pg_result $pgres -clear
# Get bounds of the last record
set lrbb [$wn.c bbox new]
lappend PgAcVar(mw,$wn,rowy) [lindex $lrbb 3]
$wn.c itemconfigure new -fill black
$wn.c dtag q new
# Replace * from untouched new row elements with " "
foreach item [$wn.c find withtag unt] {
$wn.c itemconfigure $item -text " "
}
$wn.c dtag q unt
incr PgAcVar(mw,$wn,last_rownum)
incr PgAcVar(mw,$wn,nrecs)
drawNewRecord $wn
set PgAcVar(mw,$wn,newrec_fields) {}
set PgAcVar(mw,$wn,newrec_values) {}
return 1
}
proc {scrollWindow} {wn par1 args} {
global PgAcVar
if {![finishEdit $wn]} return;
if {$par1=="scroll"} {
set newtop $PgAcVar(mw,$wn,toprec)
if {[lindex $args 1]=="units"} {
incr newtop [lindex $args 0]
} else {
incr newtop [expr [lindex $args 0]*25]
if {$newtop<0} {set newtop 0}
if {$newtop>=[expr $PgAcVar(mw,$wn,nrecs)-1]} {set newtop [expr $PgAcVar(mw,$wn,nrecs)-1]}
}
} elseif {$par1=="moveto"} {
set newtop [expr int([lindex $args 0]*$PgAcVar(mw,$wn,nrecs))]
} else {
return
}
if {$newtop<0} return;
if {$newtop>=[expr $PgAcVar(mw,$wn,nrecs)-1]} return;
set dy [expr [lindex $PgAcVar(mw,$wn,rowy) $PgAcVar(mw,$wn,toprec)]-[lindex $PgAcVar(mw,$wn,rowy) $newtop]]
$wn.c move q 0 $dy
$wn.c move hgrid 0 $dy
set newrowy {}
foreach y $PgAcVar(mw,$wn,rowy) {lappend newrowy [expr $y+$dy]}
set PgAcVar(mw,$wn,rowy) $newrowy
set PgAcVar(mw,$wn,toprec) $newtop
setScrollbar $wn
}
proc {initVariables} {wn} {
global PgAcVar
set PgAcVar(mw,$wn,newrec_fields) {}
set PgAcVar(mw,$wn,newrec_values) {}
}
proc {selectRecords} {wn sql} {
global PgAcVar CurrentDB
if {![finishEdit $wn]} return;
initVariables $wn
$wn.c delete q
$wn.c delete header
$wn.c delete hgrid
$wn.c delete new
set PgAcVar(mw,$wn,leftcol) 0
set PgAcVar(mw,$wn,leftoffset) 0
set PgAcVar(mw,$wn,crtrow) {}
set PgAcVar(mw,$wn,msg) [intlmsg "Accessing data. Please wait ..."]
catch {$wn.f1.b1 configure -state disabled}
setCursor CLOCK
set is_error 1
if {[sql_exec noquiet "BEGIN"]} {
if {[sql_exec noquiet "declare mycursor cursor for $sql"]} {
set pgres [wpg_exec $CurrentDB "fetch $PgAcVar(pref,rows) in mycursor"]
if {$PgAcVar(pgsql,status)=="PGRES_TUPLES_OK"} {
set is_error 0
}
}
}
if {$is_error} {
sql_exec quiet "END"
set PgAcVar(mw,$wn,msg) {}
catch {$wn.f1.b1 configure -state normal}
setCursor DEFAULT
set PgAcVar(mw,$wn,msg) "Error executing : $sql"
return
}
if {$PgAcVar(mw,$wn,updatable)} then {set shift 1} else {set shift 0}
#
# checking at least the numer of fields
set attrlist [pg_result $pgres -lAttributes]
if {$PgAcVar(mw,$wn,layout_found)} then {
if { ($PgAcVar(mw,$wn,colcount) != [expr [llength $attrlist]-$shift]) ||
($PgAcVar(mw,$wn,colcount) != [llength $PgAcVar(mw,$wn,colnames)]) ||
($PgAcVar(mw,$wn,colcount) != [llength $PgAcVar(mw,$wn,colwidth)]) } then {
# No. of columns don't match, something is wrong
# tk_messageBox -title [intlmsg Information] -message "Layout info changed !\nRescanning..."
set PgAcVar(mw,$wn,layout_found) 0
sql_exec quiet "delete from pga_layout where tablename='$PgAcVar(mw,$wn,layout_name)'"
}
}
# Always take the col. names from the result
set PgAcVar(mw,$wn,colcount) [llength $attrlist]
if {$PgAcVar(mw,$wn,updatable)} then {incr PgAcVar(mw,$wn,colcount) -1}
set PgAcVar(mw,$wn,colnames) {}
# In defPgAcVar(mw,$wn,colwidth) prepare PgAcVar(mw,$wn,colwidth) (in case that not layout_found)
set defPgAcVar(mw,$wn,colwidth) {}
for {set i 0} {$i<$PgAcVar(mw,$wn,colcount)} {incr i} {
lappend PgAcVar(mw,$wn,colnames) [lindex [lindex $attrlist [expr {$i+$shift}]] 0]
lappend defPgAcVar(mw,$wn,colwidth) 150
}
if {!$PgAcVar(mw,$wn,layout_found)} {
set PgAcVar(mw,$wn,colwidth) $defPgAcVar(mw,$wn,colwidth)
sql_exec quiet "insert into pga_layout values ('$PgAcVar(mw,$wn,layout_name)',$PgAcVar(mw,$wn,colcount),'$PgAcVar(mw,$wn,colnames)','$PgAcVar(mw,$wn,colwidth)')"
set PgAcVar(mw,$wn,layout_found) 1
}
set PgAcVar(mw,$wn,nrecs) [pg_result $pgres -numTuples]
if {$PgAcVar(mw,$wn,nrecs)>$PgAcVar(pref,rows)} {
set PgAcVar(mw,$wn,msg) "Only first $PgAcVar(pref,rows) records from $PgAcVar(mw,$wn,nrecs) have been loaded"
set PgAcVar(mw,$wn,nrecs) $PgAcVar(pref,rows)
}
set tagoid {}
if {$PgAcVar(pref,tvfont)=="helv"} {
set tvfont $PgAcVar(pref,font_normal)
} else {
set tvfont $PgAcVar(pref,font_fix)
}
# Computing column's left edge
set posx 10
for {set j 0} {$j<$PgAcVar(mw,$wn,colcount)} {incr j} {
set ledge($j) $posx
incr posx [expr {[lindex $PgAcVar(mw,$wn,colwidth) $j]+2}]
set textwidth($j) [expr {[lindex $PgAcVar(mw,$wn,colwidth) $j]-5}]
}
incr posx -6
set posy 24
drawHeaders $wn
set PgAcVar(mw,$wn,updatekey) oid
set PgAcVar(mw,$wn,keylist) {}
set PgAcVar(mw,$wn,rowy) {24}
set PgAcVar(mw,$wn,msg) "Loading maximum $PgAcVar(pref,rows) records ..."
set wupdatable $PgAcVar(mw,$wn,updatable)
for {set i 0} {$i<$PgAcVar(mw,$wn,nrecs)} {incr i} {
set curtup [pg_result $pgres -getTuple $i]
if {$wupdatable} then {lappend PgAcVar(mw,$wn,keylist) [lindex $curtup 0]}
for {set j 0} {$j<$PgAcVar(mw,$wn,colcount)} {incr j} {
$wn.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 [$wn.c bbox r$i]
incr posy [expr {[lindex $bb 3]-[lindex $bb 1]}]
lappend PgAcVar(mw,$wn,rowy) $posy
$wn.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 PgAcVar(mw,$wn,msg) {}"
set PgAcVar(mw,$wn,last_rownum) $i
# Defining position for input data
drawNewRecord $wn
pg_result $pgres -clear
sql_exec quiet "END"
set PgAcVar(mw,$wn,toprec) 0
setScrollbar $wn
if {$PgAcVar(mw,$wn,updatable)} then {
$wn.c bind q <Key> "Tables::editText $wn %A %K"
} else {
$wn.c bind q <Key> {}
}
set PgAcVar(mw,$wn,dirtyrec) 0
$wn.c raise header
catch {$wn.f1.b1 configure -state normal}
setCursor DEFAULT
}
proc recordSizeInScrollbarUnits {wn} {
# record size in scrollbar units
global PgAcVar
return [expr 1.0/$PgAcVar(mw,$wn,nrecs)]
}
proc getVisibleRecordsCount {wn} {
# number of records that fit in the window at its current size
expr [winfo height $wn.c]/14
}
proc {setScrollbar} {wn} {
global PgAcVar
if {$PgAcVar(mw,$wn,nrecs)==0} return;
# Fixes problem of window resizing messing up the scrollbar size.
set record_size [recordSizeInScrollbarUnits $wn];
$wn.sb set [expr $PgAcVar(mw,$wn,toprec)*$record_size] \
[expr ($PgAcVar(mw,$wn,toprec)+[getVisibleRecordsCount $wn])*$record_size]
}
proc {refreshRecords} {wn} {
global PgAcVar
set nq $PgAcVar(mw,$wn,query)
if {($PgAcVar(mw,$wn,isaquery)) && ("$PgAcVar(mw,$wn,filter)$PgAcVar(mw,$wn,sortfield)"!="")} {
showError [intlmsg "Sorting and filtering not (yet) available from queries!\n\nPlease enter them in the query definition!"]
set PgAcVar(mw,$wn,sortfield) {}
set PgAcVar(mw,$wn,filter) {}
} else {
if {$PgAcVar(mw,$wn,filter)!=""} {
set nq "$PgAcVar(mw,$wn,query) where ($PgAcVar(mw,$wn,filter))"
} else {
set nq $PgAcVar(mw,$wn,query)
}
if {$PgAcVar(mw,$wn,sortfield)!=""} {
set nq "$nq order by $PgAcVar(mw,$wn,sortfield)"
}
}
if {[insertNewRecord $wn]} {selectRecords $wn $nq}
}
proc {showRecord} {wn row} {
global PgAcVar
set PgAcVar(mw,$wn,errorsavingnew) 0
if {$PgAcVar(mw,$wn,newrec_fields)!=""} {
if {$row!=$PgAcVar(mw,$wn,last_rownum)} {
if {![insertNewRecord $wn]} {
set PgAcVar(mw,$wn,errorsavingnew) 1
return
}
}
}
set y1 [lindex $PgAcVar(mw,$wn,rowy) $row]
set y2 [lindex $PgAcVar(mw,$wn,rowy) [expr $row+1]]
if {$y2==""} {set y2 [expr $y1+14]}
$wn.c dtag hili hili
$wn.c addtag hili withtag r$row
# Making a rectangle arround the record
set x 3
foreach wi $PgAcVar(mw,$wn,colwidth) {incr x [expr $wi+2]}
$wn.c delete crtrec
$wn.c create rectangle [expr -1-$PgAcVar(mw,$wn,leftoffset)] $y1 [expr $x-$PgAcVar(mw,$wn,leftoffset)] $y2 -fill #EEEEEE -outline {} -tags {q crtrec}
$wn.c lower crtrec
}
proc {startEdit} {wn id x y} {
global PgAcVar
if {!$PgAcVar(mw,$wn,updatable)} return
set PgAcVar(mw,$wn,id_edited) $id
set PgAcVar(mw,$wn,dirtyrec) 0
set PgAcVar(mw,$wn,text_initial_value) [$wn.c itemcget $id -text]
focus $wn.c
$wn.c focus $id
$wn.c icursor $id @$x,$y
if {$PgAcVar(mw,$wn,row_edited)==$PgAcVar(mw,$wn,nrecs)} {
if {[$wn.c itemcget $id -text]=="*"} {
$wn.c itemconfigure $id -text ""
$wn.c icursor $id 0
}
}
}
proc {canvasPaste} {wn x y} {
global PgAcVar
$wn.c insert $PgAcVar(mw,$wn,id_edited) insert [selection get]
set PgAcVar(mw,$wn,dirtyrec) 1
}
proc {getNewWindowName} {} {
global PgAcVar
incr PgAcVar(mwcount)
return .pgaw:$PgAcVar(mwcount)
}
proc {createWindow} {{base ""}} {
global PgAcVar
if {$base == ""} {
set base .pgaw:$PgAcVar(mwcount)
set included 0
} else {
set included 1
}
set wn $base
set PgAcVar(mw,$wn,dirtyrec) 0
set PgAcVar(mw,$wn,id_edited) {}
set PgAcVar(mw,$wn,filter) {}
set PgAcVar(mw,$wn,sortfield) {}
if {! $included} {
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
wm geometry $base 650x400
wm maxsize $base 1009 738
wm minsize $base 650 400
wm overrideredirect $base 0
wm resizable $base 1 1
wm deiconify $base
wm title $base [intlmsg "Table"]
}
bind $base <Key-Delete> "Tables::deleteRecord $wn"
bind $base <Key-F1> "Help::load tables"
if {! $included} {
frame $base.f1 -borderwidth 2 -height 75 -relief groove -width 125
label $base.f1.l1 -borderwidth 0 -text [intlmsg {Sort field}]
entry $base.f1.e1 -background #fefefe -borderwidth 1 -width 14 -highlightthickness 1 -textvariable PgAcVar(mw,$wn,sortfield)
bind $base.f1.e1 <Key-Return> "Tables::refreshRecords $wn"
bind $base.f1.e1 <Key-KP_Enter> "Tables::refreshRecords $wn"
label $base.f1.lb1 -borderwidth 0 -text { }
label $base.f1.l2 -borderwidth 0 -text [intlmsg {Filter conditions}]
entry $base.f1.e2 -background #fefefe -borderwidth 1 -highlightthickness 1 -textvariable PgAcVar(mw,$wn,filter)
bind $base.f1.e2 <Key-Return> "Tables::refreshRecords $wn"
bind $base.f1.e2 <Key-KP_Enter> "Tables::refreshRecords $wn"
button $base.f1.b1 -borderwidth 1 -text [intlmsg Close] -command "
if {\[Tables::insertNewRecord $wn\]} {
$wn.c delete rows
$wn.c delete header
Window destroy $wn
PgAcVar:clean mw,$wn,*
}"
button $base.f1.b2 -borderwidth 1 -text [intlmsg Reload] -command "Tables::refreshRecords $wn"
}
frame $base.frame20 -borderwidth 2 -height 75 -relief groove -width 125
button $base.frame20.01 -borderwidth 1 -text < -command "Tables::panRight $wn"
label $base.frame20.02 -anchor w -borderwidth 1 -height 1 -relief sunken -text {} -textvariable PgAcVar(mw,$wn,msg)
button $base.frame20.03 -borderwidth 1 -text > -command "Tables::panLeft $wn"
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 "Tables::scrollWindow $wn"
bind $base.c <Button-1> "Tables::canvasClick $wn %x %y"
bind $base.c <Button-2> "Tables::canvasPaste $wn %x %y"
bind $base.c <Button-3> "if {[Tables::finishEdit $wn]} \"Tables::insertNewRecord $wn\""
# Prevent Tab from moving focus out of canvas widget
bind $base.c <Tab> break
if {! $included} {
pack $base.f1 -in $wn -anchor center -expand 0 -fill x -side top
pack $base.f1.l1 -in $wn.f1 -anchor center -expand 0 -fill none -side left
pack $base.f1.e1 -in $wn.f1 -anchor center -expand 0 -fill none -side left
pack $base.f1.lb1 -in $wn.f1 -anchor center -expand 0 -fill none -side left
pack $base.f1.l2 -in $wn.f1 -anchor center -expand 0 -fill none -side left
pack $base.f1.e2 -in $wn.f1 -anchor center -expand 0 -fill none -side left
pack $base.f1.b1 -in $wn.f1 -anchor center -expand 0 -fill none -side right
pack $base.f1.b2 -in $wn.f1 -anchor center -expand 0 -fill none -side right
}
pack $base.frame20 -in $wn -anchor s -expand 0 -fill x -side bottom
pack $base.frame20.01 -in $wn.frame20 -anchor center -expand 0 -fill none -side left
pack $base.frame20.02 -in $wn.frame20 -anchor center -expand 1 -fill x -side left
pack $base.frame20.03 -in $wn.frame20 -anchor center -expand 0 -fill none -side right
pack $base.c -in $wn -anchor w -expand 1 -fill both -side left
pack $base.sb -in $wn -anchor e -expand 0 -fill y -side right
}
proc {renameColumn} {} {
global PgAcVar CurrentDB
if {[string length [string trim $PgAcVar(tblinfo,new_cn)]]==0} {
showError [intlmsg "Field name not entered!"]
return
}
set old_name [string trim [string range $PgAcVar(tblinfo,old_cn) 0 31]]
set PgAcVar(tblinfo,new_cn) [string trim $PgAcVar(tblinfo,new_cn)]
if {$old_name == $PgAcVar(tblinfo,new_cn)} {
showError [intlmsg "New name is the same as the old one!"]
return
}
foreach line [.pgaw:TableInfo.f1.lb get 0 end] {
if {[string trim [string range $line 0 31]]==$PgAcVar(tblinfo,new_cn)} {
showError [format [intlmsg {Column name '%s' already exists in this table!}] $PgAcVar(tblinfo,new_cn)]
return
}
}
if {[sql_exec noquiet "alter table \"$PgAcVar(tblinfo,tablename)\" rename column \"$old_name\" to \"$PgAcVar(tblinfo,new_cn)\""]} {
refreshTableInformation
Window destroy .pgaw:RenameField
}
}
proc {addNewIndex} {} {
global PgAcVar
set iflds [.pgaw:TableInfo.f1.lb curselection]
if {$iflds==""} {
showError [intlmsg "You have to select index fields!"]
return
}
set ifldslist {}
foreach i $iflds {lappend ifldslist "\"[string trim [string range [.pgaw:TableInfo.f1.lb get $i] 0 32]]\""}
set PgAcVar(addindex,indexname) $PgAcVar(tblinfo,tablename)_[join $ifldslist _]
# Replace the quotes with underlines
regsub -all {"} $PgAcVar(addindex,indexname) {_} PgAcVar(addindex,indexname)
# Replace the double underlines
while {[regsub -all {__} $PgAcVar(addindex,indexname) {_} PgAcVar(addindex,indexname)]} {}
# Replace the final underline
regsub -all {_$} $PgAcVar(addindex,indexname) {} PgAcVar(addindex,indexname)
set PgAcVar(addindex,indexfields) [join $ifldslist ,]
Window show .pgaw:AddIndex
wm transient .pgaw:AddIndex .pgaw:TableInfo
}
proc {deleteIndex} {} {
global PgAcVar
set sel [.pgaw:TableInfo.f2.fl.ilb curselection]
if {$sel == ""} {
showError [intlmsg "You have to select an index!"]
return
}
if {[tk_messageBox -title [intlmsg Warning] -parent .pgaw:TableInfo -message [format [intlmsg "You choose to delete index\n\n %s \n\nProceed?"] [.pgaw:TableInfo.f2.fl.ilb get $sel]] -type yesno -default no]=="no"} {return}
if {[sql_exec noquiet "drop index \"[.pgaw:TableInfo.f2.fl.ilb get $sel]\""]} {
refreshTableInformation
}
}
proc {createNewIndex} {} {
global PgAcVar
if {$PgAcVar(addindex,indexname)==""} {
showError [intlmsg "Index name cannot be null!"]
return
}
setCursor CLOCK
if {[sql_exec noquiet "CREATE $PgAcVar(addindex,unique) INDEX \"$PgAcVar(addindex,indexname)\" on \"$PgAcVar(tblinfo,tablename)\" ($PgAcVar(addindex,indexfields))"]} {
setCursor DEFAULT
Window destroy .pgaw:AddIndex
refreshTableInformation
}
setCursor DEFAULT
}
proc {showIndexInformation} {} {
global PgAcVar CurrentDB
set cs [.pgaw:TableInfo.f2.fl.ilb curselection]
if {$cs==""} return
set idxname [.pgaw:TableInfo.f2.fl.ilb get $cs]
wpg_select $CurrentDB "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 PgAcVar(tblinfo,isunique) [intlmsg Yes]
} else {
set PgAcVar(tblinfo,isunique) [intlmsg No]
}
if {$rec(indisclustered)=="t"} {
set PgAcVar(tblinfo,isclustered) [intlmsg Yes]
} else {
set PgAcVar(tblinfo,isclustered) [intlmsg No]
}
set PgAcVar(tblinfo,indexfields) {}
.pgaw:TableInfo.f2.fr.lb delete 0 end
foreach field $rec(indkey) {
if {$field!=0} {
# wpg_select $CurrentDB "select attname from pg_attribute where attrelid=$PgAcVar(tblinfo,tableoid) and attnum=$field" rec1 {
# set PgAcVar(tblinfo,indexfields) "$PgAcVar(tblinfo,indexfields) $rec1(attname)"
# }
set PgAcVar(tblinfo,indexfields) "$PgAcVar(tblinfo,indexfields) $PgAcVar(tblinfo,f$field)"
.pgaw:TableInfo.f2.fr.lb insert end $PgAcVar(tblinfo,f$field)
}
}
}
set PgAcVar(tblinfo,indexfields) [string trim $PgAcVar(tblinfo,indexfields)]
}
proc {addNewColumn} {} {
global PgAcVar
if {$PgAcVar(addfield,name)==""} {
showError [intlmsg "Empty field name ?"]
focus .pgaw:AddField.e1
return
}
if {$PgAcVar(addfield,type)==""} {
showError [intlmsg "No field type ?"]
focus .pgaw:AddField.e2
return
}
if {![sql_exec quiet "alter table \"$PgAcVar(tblinfo,tablename)\" add column \"$PgAcVar(addfield,name)\" $PgAcVar(addfield,type)"]} {
showError "[intlmsg {Cannot add column}]\n\n$PgAcVar(pgsql,errmsg)"
return
}
Window destroy .pgaw:AddField
sql_exec quiet "update pga_layout set colnames=colnames || ' {$PgAcVar(addfield,name)}', colwidth=colwidth || ' 150',nrcols=nrcols+1 where tablename='$PgAcVar(tblinfo,tablename)'"
refreshTableInformation
}
proc {newtable:add_new_field} {} {
global PgAcVar
if {$PgAcVar(nt,fieldname)==""} {
showError [intlmsg "Enter a field name"]
focus .pgaw:NewTable.e2
return
}
if {$PgAcVar(nt,fldtype)==""} {
showError [intlmsg "The field type is not specified!"]
return
}
if {($PgAcVar(nt,fldtype)=="varchar")&&($PgAcVar(nt,fldsize)=="")} {
focus .pgaw:NewTable.e3
showError [intlmsg "You must specify field size!"]
return
}
if {$PgAcVar(nt,fldsize)==""} then {set sup ""} else {set sup "($PgAcVar(nt,fldsize))"}
if {[regexp $PgAcVar(nt,fldtype) "varchartextdatetime"]} {set supc "'"} else {set supc ""}
# Don't put the ' arround default value if it contains the now() function
if {([regexp $PgAcVar(nt,fldtype) "datetime"]) && ([regexp now $PgAcVar(nt,defaultval)])} {set supc ""}
# Clear the notnull attribute if field type is serial
if {$PgAcVar(nt,fldtype)=="serial"} {set PgAcVar(nt,notnull) " "}
if {$PgAcVar(nt,defaultval)==""} then {set sup2 ""} else {set sup2 " DEFAULT $supc$PgAcVar(nt,defaultval)$supc"}
# Checking for field name collision
set inspos end
for {set i 0} {$i<[.pgaw:NewTable.lb size]} {incr i} {
set linie [.pgaw:NewTable.lb get $i]
if {$PgAcVar(nt,fieldname)==[string trim [string range $linie 2 33]]} {
if {[tk_messageBox -title [intlmsg Warning] -parent .pgaw:NewTable -message [format [intlmsg "There is another field with the same name: '%s'!\n\nReplace it ?"] $PgAcVar(nt,fieldname)] -type yesno -default yes]=="no"} return
.pgaw:NewTable.lb delete $i
set inspos $i
break
}
}
.pgaw:NewTable.lb insert $inspos [format "%1s %-32.32s %-14s%-16s" $PgAcVar(nt,primarykey) $PgAcVar(nt,fieldname) $PgAcVar(nt,fldtype)$sup $sup2$PgAcVar(nt,notnull)]
focus .pgaw:NewTable.e2
set PgAcVar(nt,fieldname) {}
set PgAcVar(nt,fldsize) {}
set PgAcVar(nt,defaultval) {}
set PgAcVar(nt,primarykey) " "
}
proc {newtable:create} {} {
global PgAcVar CurrentDB
if {$PgAcVar(nt,tablename)==""} then {
showError [intlmsg "You must supply a name for your table!"]
focus .pgaw:NewTable.etabn
return
}
if {[.pgaw:NewTable.lb size]==0} then {
showError [intlmsg "Your table has no fields!"]
focus .pgaw:NewTable.e2
return
}
set fl {}
set pkf {}
foreach line [.pgaw:NewTable.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 \"$PgAcVar(nt,tablename)\" ([join $fl ,]"
if {$PgAcVar(nt,constraint)!=""} then {set temp "$temp, constraint \"$PgAcVar(nt,constraint)\""}
if {$PgAcVar(nt,check)!=""} then {set temp "$temp check ($PgAcVar(nt,check))"}
if {[llength $pkf]>0} then {set temp "$temp, primary key([join $pkf ,])"}
set temp "$temp)"
if {$PgAcVar(nt,inherits)!=""} then {set temp "$temp inherits ($PgAcVar(nt,inherits))"}
setCursor CLOCK
if {[sql_exec noquiet $temp]} {
Window destroy .pgaw:NewTable
Mainlib::cmd_Tables
}
setCursor DEFAULT
}
proc {tabSelect} {i} {
global PgAcVar
set base .pgaw:TableInfo
foreach tab {0 1 2 3} {
if {$i == $tab} {
place $base.l$tab -y 13
place $base.f$tab -x 15 -y 45
$base.l$tab configure -font $PgAcVar(pref,font_bold)
} else {
place $base.l$tab -y 15
place $base.f$tab -x 15 -y 500
$base.l$tab configure -font $PgAcVar(pref,font_normal)
}
}
array set coord [place info $base.l$i]
place $base.lline -x [expr {1+$coord(-x)}]
}
}
#################### END OF NAMESPACE TABLES ####################
proc vTclWindow.pgaw:NewTable {base} {
global PgAcVar
if {$base == ""} {
set base .pgaw:NewTable
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
wm geometry $base 634x392+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 [intlmsg "Create new table"]
bind $base <Key-F1> "Help::load new_table"
entry $base.etabn \
-background #fefefe -borderwidth 1 -selectborderwidth 0 \
-textvariable PgAcVar(nt,tablename)
bind $base.etabn <Key-Return> {
focus .pgaw:NewTable.einh
}
label $base.li \
-anchor w -borderwidth 0 -text [intlmsg Inherits]
entry $base.einh \
-background #fefefe -borderwidth 1 -selectborderwidth 0 \
-textvariable PgAcVar(nt,inherits)
bind $base.einh <Key-Return> {
focus .pgaw:NewTable.e2
}
button $base.binh \
-borderwidth 1 \
-command {if {[winfo exists .pgaw:NewTable.ddf]} {
destroy .pgaw:NewTable.ddf
} else {
create_drop_down .pgaw:NewTable 386 23 220
focus .pgaw:NewTable.ddf.sb
foreach tbl [Database::getTablesList] {.pgaw:NewTable.ddf.lb insert end $tbl}
bind .pgaw:NewTable.ddf.lb <ButtonRelease-1> {
set i [.pgaw:NewTable.ddf.lb curselection]
if {$i!=""} {
if {$PgAcVar(nt,inherits)==""} {
set PgAcVar(nt,inherits) "\"[.pgaw:NewTable.ddf.lb get $i]\""
} else {
set PgAcVar(nt,inherits) "$PgAcVar(nt,inherits),\"[.pgaw:NewTable.ddf.lb get $i]\""
}
}
if {$i!=""} {focus .pgaw:NewTable.e2}
destroy .pgaw:NewTable.ddf
break
}
}} \
-highlightthickness 0 -takefocus 0 -image dnarw
entry $base.e2 \
-background #fefefe -borderwidth 1 -selectborderwidth 0 \
-textvariable PgAcVar(nt,fieldname)
bind $base.e2 <Key-Return> {
focus .pgaw:NewTable.e1
}
entry $base.e1 \
-background #fefefe -borderwidth 1 -selectborderwidth 0 \
-textvariable PgAcVar(nt,fldtype)
bind $base.e1 <Key-Return> {
focus .pgaw:NewTable.e5
}
entry $base.e3 \
-background #fefefe -borderwidth 1 -selectborderwidth 0 \
-textvariable PgAcVar(nt,fldsize)
bind $base.e3 <Key-Return> {
focus .pgaw:NewTable.e5
}
entry $base.e5 \
-background #fefefe -borderwidth 1 -selectborderwidth 0 \
-textvariable PgAcVar(nt,defaultval)
bind $base.e5 <Key-Return> {
focus .pgaw:NewTable.cb1
}
checkbutton $base.cb1 \
-borderwidth 1 \
-offvalue { } -onvalue { NOT NULL} -text [intlmsg {field cannot be null}] \
-variable PgAcVar(nt,notnull)
label $base.lab1 \
-borderwidth 0 -text [intlmsg type]
label $base.lab2 \
-borderwidth 0 -anchor w -text [intlmsg {field name}]
label $base.lab3 \
-borderwidth 0 -text [intlmsg size]
label $base.lab4 \
-borderwidth 0 -anchor w -text [intlmsg {Default value}]
button $base.addfld \
-borderwidth 1 -command Tables::newtable:add_new_field \
-text [intlmsg {Add field}]
button $base.delfld \
-borderwidth 1 -command {catch {.pgaw:NewTable.lb delete [.pgaw:NewTable.lb curselection]}} \
-text [intlmsg {Delete field}]
button $base.emptb \
-borderwidth 1 -command {.pgaw:NewTable.lb delete 0 [.pgaw:NewTable.lb size]} \
-text [intlmsg {Delete all}]
button $base.maketbl \
-borderwidth 1 -command Tables::newtable:create \
-text [intlmsg Create]
listbox $base.lb \
-background #fefefe -foreground #000000 -borderwidth 1 \
-selectbackground #c3c3c3 -font $PgAcVar(pref,font_fix) \
-selectborderwidth 0 -yscrollcommand {.pgaw:NewTable.sb set}
bind $base.lb <ButtonRelease-1> {
if {[.pgaw:NewTable.lb curselection]!=""} {
set fldname [string trim [lindex [split [.pgaw:NewTable.lb get [.pgaw:NewTable.lb curselection]]] 0]]
}
}
button $base.exitbtn \
-borderwidth 1 -command {Window destroy .pgaw:NewTable} \
-text [intlmsg Cancel]
button $base.helpbtn \
-borderwidth 1 -command {Help::load new_table} \
-text [intlmsg Help]
label $base.l1 \
-anchor w -borderwidth 1 \
-relief raised -text " [intlmsg {field name}]"
label $base.l2 \
-borderwidth 1 \
-relief raised -text [intlmsg type]
label $base.l3 \
-borderwidth 1 \
-relief raised -text [intlmsg options]
scrollbar $base.sb \
-borderwidth 1 -command {.pgaw:NewTable.lb yview} -orient vert
label $base.l93 \
-anchor w -borderwidth 0 -text [intlmsg {Table name}]
button $base.mvup \
-borderwidth 1 \
-command {if {[.pgaw:NewTable.lb size]>1} {
set i [.pgaw:NewTable.lb curselection]
if {($i!="")&&($i>0)} {
.pgaw:NewTable.lb insert [expr $i-1] [.pgaw:NewTable.lb get $i]
.pgaw:NewTable.lb delete [expr $i+1]
.pgaw:NewTable.lb selection set [expr $i-1]
}
}} \
-text [intlmsg {Move up}]
button $base.mvdn \
-borderwidth 1 \
-command {if {[.pgaw:NewTable.lb size]>1} {
set i [.pgaw:NewTable.lb curselection]
if {($i!="")&&($i<[expr [.pgaw:NewTable.lb size]-1])} {
.pgaw:NewTable.lb insert [expr $i+2] [.pgaw:NewTable.lb get $i]
.pgaw:NewTable.lb delete $i
.pgaw:NewTable.lb selection set [expr $i+1]
}
}} \
-text [intlmsg {Move down}]
button $base.button17 \
-borderwidth 1 \
-command {
if {[winfo exists .pgaw:NewTable.ddf]} {
destroy .pgaw:NewTable.ddf
} else {
create_drop_down .pgaw:NewTable 291 80 97
focus .pgaw:NewTable.ddf.sb
.pgaw:NewTable.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 .pgaw:NewTable.ddf.lb <ButtonRelease-1> {
set i [.pgaw:NewTable.ddf.lb curselection]
if {$i!=""} {set PgAcVar(nt,fldtype) [.pgaw:NewTable.ddf.lb get $i]}
destroy .pgaw:NewTable.ddf
if {$i!=""} {
if {[lsearch {char varchar} $PgAcVar(nt,fldtype)]==-1} {
set PgAcVar(nt,fldsize) {}
.pgaw:NewTable.e3 configure -state disabled
focus .pgaw:NewTable.e5
} else {
.pgaw:NewTable.e3 configure -state normal
focus .pgaw:NewTable.e3
}
}
break
}
}} \
-highlightthickness 0 -takefocus 0 -image dnarw
label $base.lco \
-borderwidth 0 -anchor w -text [intlmsg Constraint]
entry $base.eco \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(nt,constraint)
label $base.lch \
-borderwidth 0 -text [intlmsg check]
entry $base.ech \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(nt,check)
label $base.ll \
-borderwidth 1 \
-relief raised
checkbutton $base.pk \
-borderwidth 1 \
-offvalue { } -onvalue * -text [intlmsg {primary key}] -variable PgAcVar(nt,primarykey)
label $base.lpk \
-borderwidth 1 \
-relief raised -text K
place $base.etabn \
-x 105 -y 5 -width 136 -height 20 -anchor nw -bordermode ignore
place $base.li \
-x 245 -y 7 -height 16 -anchor nw -bordermode ignore
place $base.einh \
-x 300 -y 5 -width 308 -height 20 -anchor nw -bordermode ignore
place $base.binh \
-x 590 -y 7 -width 16 -height 16 -anchor nw -bordermode ignore
place $base.e2 \
-x 105 -y 60 -width 136 -height 20 -anchor nw -bordermode ignore
place $base.e1 \
-x 291 -y 60 -width 98 -height 20 -anchor nw -bordermode ignore
place $base.e3 \
-x 470 -y 60 -width 46 -height 20 -anchor nw -bordermode ignore
place $base.e5 \
-x 105 -y 82 -width 136 -height 20 -anchor nw -bordermode ignore
place $base.cb1 \
-x 245 -y 83 -height 20 -anchor nw -bordermode ignore
place $base.lab1 \
-x 247 -y 62 -height 16 -anchor nw -bordermode ignore
place $base.lab2 \
-x 4 -y 62 -height 16 -anchor nw -bordermode ignore
place $base.lab3 \
-x 400 -y 62 -height 16 -anchor nw -bordermode ignore
place $base.lab4 \
-x 5 -y 84 -height 16 -anchor nw -bordermode ignore
place $base.addfld \
-x 530 -y 58 -width 100 -height 26 -anchor nw -bordermode ignore
place $base.delfld \
-x 530 -y 190 -width 100 -height 26 -anchor nw -bordermode ignore
place $base.emptb \
-x 530 -y 220 -width 100 -height 26 -anchor nw -bordermode ignore
place $base.maketbl \
-x 530 -y 365 -width 100 -height 26 -anchor nw -bordermode ignore
place $base.lb \
-x 4 -y 121 -width 506 -height 269 -anchor nw -bordermode ignore
place $base.helpbtn \
-x 530 -y 305 -width 100 -height 26 -anchor nw -bordermode ignore
place $base.exitbtn \
-x 530 -y 335 -width 100 -height 26 -anchor nw -bordermode ignore
place $base.l1 \
-x 18 -y 105 -width 195 -height 18 -anchor nw -bordermode ignore
place $base.l2 \
-x 213 -y 105 -width 88 -height 18 -anchor nw -bordermode ignore
place $base.l3 \
-x 301 -y 105 -width 225 -height 18 -anchor nw -bordermode ignore
place $base.sb \
-x 509 -y 121 -width 18 -height 269 -anchor nw -bordermode ignore
place $base.l93 \
-x 4 -y 7 -height 16 -anchor nw -bordermode ignore
place $base.mvup \
-x 530 -y 120 -width 100 -height 26 -anchor nw -bordermode ignore
place $base.mvdn \
-x 530 -y 150 -width 100 -height 26 -anchor nw -bordermode ignore
place $base.button17 \
-x 371 -y 62 -width 16 -height 16 -anchor nw -bordermode ignore
place $base.lco \
-x 5 -y 28 -width 58 -height 16 -anchor nw -bordermode ignore
place $base.eco \
-x 105 -y 27 -width 136 -height 20 -anchor nw -bordermode ignore
place $base.lch \
-x 245 -y 30 -anchor nw -bordermode ignore
place $base.ech \
-x 300 -y 27 -width 308 -height 22 -anchor nw -bordermode ignore
place $base.ll \
-x 5 -y 53 -width 603 -height 2 -anchor nw -bordermode ignore
place $base.pk \
-x 450 -y 83 -height 20 -anchor nw -bordermode ignore
place $base.lpk \
-x 4 -y 105 -width 14 -height 18 -anchor nw -bordermode ignore
}
proc vTclWindow.pgaw:TableInfo {base} {
global PgAcVar
if {$base == ""} {
set base .pgaw:TableInfo
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel \
-background #c7c3c7
wm focusmodel $base passive
wm geometry $base 522x398+152+135
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 [intlmsg "Table information"]
bind $base <Key-F1> "Help::load view_table_structure"
label $base.l0 \
-borderwidth 1 -font $PgAcVar(pref,font_bold) \
-relief raised -text [intlmsg General]
bind $base.l0 <Button-1> {
Tables::tabSelect 0
}
label $base.l1 \
-borderwidth 1 \
-relief raised -text [intlmsg Columns]
bind $base.l1 <Button-1> {
Tables::tabSelect 1
}
label $base.l2 \
-borderwidth 1 \
-relief raised -text [intlmsg Indexes]
bind $base.l2 <Button-1> {
Tables::tabSelect 2
}
label $base.l3 \
-borderwidth 1 \
-relief raised -text [intlmsg Permissions]
bind $base.l3 <Button-1> {
Tables::tabSelect 3
}
label $base.l \
-relief raised
button $base.btnclose \
-borderwidth 1 -command {Window destroy .pgaw:TableInfo} \
-highlightthickness 0 -padx 9 -pady 3 -text [intlmsg Close]
frame $base.f1 \
-borderwidth 2 -height 75 -relief groove -width 125
frame $base.f1.ft \
-height 75 -relief groove -width 125
label $base.f1.ft.t1 \
-relief groove -text [intlmsg {field name}]
label $base.f1.ft.t2 \
-relief groove -text [intlmsg type] -width 12
label $base.f1.ft.t3 \
-relief groove -text [intlmsg size] -width 6
label $base.f1.ft.lnn \
-relief groove -text [intlmsg {not null}] -width 18
label $base.f1.ft.ls \
-borderwidth 0 \
-relief raised -text { }
frame $base.f1.fb \
-height 75 -relief groove -width 125
button $base.f1.fb.addcolbtn \
-borderwidth 1 \
-command {Window show .pgaw:AddField
set PgAcVar(addfield,name) {}
set PgAcVar(addfield,type) {}
wm transient .pgaw:AddField .pgaw:TableInfo
focus .pgaw:AddField.e1} \
-padx 9 -pady 3 -text [intlmsg {Add new column}]
button $base.f1.fb.rencolbtn \
-borderwidth 1 \
-command {
if {[set PgAcVar(tblinfo,col_id) [.pgaw:TableInfo.f1.lb curselection]]==""} then {
bell
} else {
set PgAcVar(tblinfo,old_cn) [.pgaw:TableInfo.f1.lb get [.pgaw:TableInfo.f1.lb curselection]]
set PgAcVar(tblinfo,new_cn) {}
Window show .pgaw:RenameField
tkwait visibility .pgaw:RenameField
wm transient .pgaw:RenameField .pgaw:TableInfo
focus .pgaw:RenameField.e1
}
} \
-padx 9 -pady 3 -text [intlmsg {Rename column}]
button $base.f1.fb.addidxbtn \
-borderwidth 1 -command Tables::addNewIndex \
-padx 9 \
-pady 3 -text [intlmsg {Add new index}]
listbox $base.f1.lb \
-background #fefefe -borderwidth 1 -font $PgAcVar(pref,font_fix) \
-highlightthickness 0 -selectborderwidth 0 \
-selectmode extended \
-yscrollcommand {.pgaw:TableInfo.f1.vsb set}
scrollbar $base.f1.vsb \
-borderwidth 1 -command {.pgaw:TableInfo.f1.lb yview} -orient vert -width 14
frame $base.f2 \
-borderwidth 2 -height 75 -relief groove -width 125
frame $base.f2.fl \
-height 75 -relief groove -width 182
label $base.f2.fl.t \
-relief groove -text [intlmsg {Indexes defined}]
button $base.f2.fl.delidxbtn \
-borderwidth 1 -command Tables::deleteIndex \
-padx 9 \
-pady 3 -text [intlmsg {Delete index}]
listbox $base.f2.fl.ilb \
-background #fefefe -borderwidth 1 \
-highlightthickness 0 -selectborderwidth 0 -width 37 \
-yscrollcommand {.pgaw:TableInfo.f2.fl.vsb set}
bind $base.f2.fl.ilb <ButtonRelease-1> {
Tables::showIndexInformation
}
scrollbar $base.f2.fl.vsb \
-borderwidth 1 -command {.pgaw:TableInfo.f2.fl.ilb yview} -orient vert -width 14
frame $base.f2.fr \
-height 75 -relief groove -width 526
label $base.f2.fr.t \
-relief groove -text [intlmsg {index properties}]
button $base.f2.fr.clusterbtn \
-borderwidth 1 -command Tables::clusterIndex \
-padx 9 -pady 3 -text [intlmsg {Cluster index}]
frame $base.f2.fr.fp \
-borderwidth 2 -height 75 -relief groove -width 125
label $base.f2.fr.fp.lu \
-anchor w -borderwidth 0 \
-relief raised -text [intlmsg {Is unique ?}]
label $base.f2.fr.fp.vu \
-borderwidth 0 -textvariable PgAcVar(tblinfo,isunique) \
-foreground #000096 -relief raised -text {}
label $base.f2.fr.fp.lc \
-borderwidth 0 \
-relief raised -text [intlmsg {Is clustered ?}]
label $base.f2.fr.fp.vc -textvariable PgAcVar(tblinfo,isclustered) \
-borderwidth 0 \
-foreground #000096 -relief raised -text {}
label $base.f2.fr.lic \
-relief groove -text [intlmsg {index columns}]
listbox $base.f2.fr.lb \
-background #fefefe -borderwidth 1 \
-highlightthickness 0 -selectborderwidth 0 \
-yscrollcommand {.pgaw:TableInfo.f2.fr.vsb set}
scrollbar $base.f2.fr.vsb \
-borderwidth 1 -command {.pgaw:TableInfo.f2.fr.lb yview} -orient vert -width 14
frame $base.f3 \
-borderwidth 2 -height 75 -relief groove -width 125
frame $base.f3.ft \
-height 75 -relief groove -width 125
label $base.f3.ft.luser \
-relief groove -text [intlmsg {User name}]
label $base.f3.ft.lselect \
-relief groove -text [intlmsg select] -width 10
label $base.f3.ft.lupdate \
-relief groove -text [intlmsg update] -width 10
label $base.f3.ft.linsert \
-relief groove -text [intlmsg insert] -width 10
label $base.f3.ft.lrule \
-relief groove -text [intlmsg rule] -width 10
label $base.f3.ft.ls \
-borderwidth 0 \
-relief raised -text { }
frame $base.f3.fb \
-height 75 -relief groove -width 125
button $base.f3.fb.adduserbtn \
-borderwidth 1 -command Tables::newPermissions \
-padx 9 -pady 3 -text [intlmsg {Add user}]
button $base.f3.fb.chguserbtn -command Tables::loadPermissions \
-borderwidth 1 -padx 9 -pady 3 -text [intlmsg {Change permissions}]
listbox $base.f3.plb \
-background #fefefe -borderwidth 1 -font $PgAcVar(pref,font_fix) \
-highlightthickness 0 -selectborderwidth 0 \
-yscrollcommand {.pgaw:TableInfo.f3.vsb set}
bind $base.f3.plb <Double-1> Tables::loadPermissions
scrollbar $base.f3.vsb \
-borderwidth 1 -command {.pgaw:TableInfo.f3.plb yview} -orient vert -width 14
label $base.lline \
-borderwidth 0 \
-relief raised -text { }
frame $base.f0 \
-borderwidth 2 -height 75 -relief groove -width 125
frame $base.f0.fi \
-borderwidth 2 -height 75 -relief groove -width 125
label $base.f0.fi.l1 \
-borderwidth 0 \
-relief raised -text [intlmsg {Table name}]
label $base.f0.fi.l2 \
-anchor w -borderwidth 1 \
-relief sunken -text {} -textvariable PgAcVar(tblinfo,tablename) \
-width 200
label $base.f0.fi.l3 \
-borderwidth 0 \
-relief raised -text [intlmsg {Table OID}]
label $base.f0.fi.l4 \
-anchor w -borderwidth 1 \
-relief sunken -text {} -textvariable PgAcVar(tblinfo,tableoid) \
-width 200
label $base.f0.fi.l5 \
-borderwidth 0 \
-relief raised -text [intlmsg Owner]
label $base.f0.fi.l6 \
-anchor w -borderwidth 1 \
-relief sunken -text {} -textvariable PgAcVar(tblinfo,owner) \
-width 200
label $base.f0.fi.l7 \
-borderwidth 0 \
-relief raised -text [intlmsg {Owner ID}]
label $base.f0.fi.l8 \
-anchor w -borderwidth 1 \
-relief sunken -text {} -textvariable PgAcVar(tblinfo,ownerid) \
-width 200
label $base.f0.fi.l9 \
-borderwidth 0 \
-relief raised -text [intlmsg {Has primary key ?}]
label $base.f0.fi.l10 \
-anchor w -borderwidth 1 \
-relief sunken -text {} \
-textvariable PgAcVar(tblinfo,hasprimarykey) -width 200
label $base.f0.fi.l11 \
-borderwidth 0 \
-relief raised -text [intlmsg {Has rules ?}]
label $base.f0.fi.l12 \
-anchor w -borderwidth 1 \
-relief sunken -text {} -textvariable PgAcVar(tblinfo,hasrules) \
-width 200
label $base.f0.fi.last \
-borderwidth 0 \
-relief raised -text { }
frame $base.f0.fs \
-borderwidth 2 -height 75 -relief groove -width 125
label $base.f0.fs.l1 \
-borderwidth 0 \
-relief raised -text [intlmsg {Number of tuples}]
label $base.f0.fs.l2 \
-anchor e -borderwidth 1 \
-relief sunken -text 0 -textvariable PgAcVar(tblinfo,numtuples) \
-width 200
label $base.f0.fs.l3 \
-borderwidth 0 \
-relief raised -text [intlmsg {Number of pages}]
label $base.f0.fs.l4 \
-anchor e -borderwidth 1 \
-relief sunken -text 0 -textvariable PgAcVar(tblinfo,numpages) \
-width 200
label $base.f0.fs.last \
-borderwidth 0 \
-relief raised -text { }
label $base.f0.lstat \
-borderwidth 0 -font $PgAcVar(pref,font_bold) -relief raised \
-text " [intlmsg Statistics] "
label $base.f0.lid \
-borderwidth 0 -font $PgAcVar(pref,font_bold) -relief raised \
-text " [intlmsg Identification] "
place $base.l0 \
-x 15 -y 13 -width 96 -height 23 -anchor nw -bordermode ignore
place $base.l1 \
-x 111 -y 15 -width 96 -height 23 -anchor nw -bordermode ignore
place $base.l2 \
-x 207 -y 15 -width 96 -height 23 -anchor nw -bordermode ignore
place $base.l3 \
-x 303 -y 15 -width 96 -height 23 -anchor nw -bordermode ignore
place $base.l \
-x 5 -y 35 -width 511 -height 357 -anchor nw -bordermode ignore
place $base.btnclose \
-x 425 -y 5 -width 91 -height 26 -anchor nw -bordermode ignore
place $base.f1 \
-x 15 -y 500 -width 490 -height 335 -anchor nw -bordermode ignore
pack $base.f1.ft \
-in .pgaw:TableInfo.f1 -anchor center -expand 0 -fill x -side top
pack $base.f1.ft.t1 \
-in .pgaw:TableInfo.f1.ft -anchor center -expand 1 -fill x -side left
pack $base.f1.ft.t2 \
-in .pgaw:TableInfo.f1.ft -anchor center -expand 0 -fill none -side left
pack $base.f1.ft.t3 \
-in .pgaw:TableInfo.f1.ft -anchor center -expand 0 -fill none -side left
pack $base.f1.ft.lnn \
-in .pgaw:TableInfo.f1.ft -anchor center -expand 0 -fill none -side left
pack $base.f1.ft.ls \
-in .pgaw:TableInfo.f1.ft -anchor center -expand 0 -fill none -side top
pack $base.f1.fb \
-in .pgaw:TableInfo.f1 -anchor center -expand 0 -fill x -side bottom
grid $base.f1.fb.addcolbtn \
-in .pgaw:TableInfo.f1.fb -column 0 -row 0 -columnspan 1 -rowspan 1
grid $base.f1.fb.rencolbtn \
-in .pgaw:TableInfo.f1.fb -column 1 -row 0 -columnspan 1 -rowspan 1
grid $base.f1.fb.addidxbtn \
-in .pgaw:TableInfo.f1.fb -column 2 -row 0 -columnspan 1 -rowspan 1
pack $base.f1.lb \
-in .pgaw:TableInfo.f1 -anchor center -expand 1 -fill both -pady 1 -side left
pack $base.f1.vsb \
-in .pgaw:TableInfo.f1 -anchor center -expand 0 -fill y -side right
place $base.f2 \
-x 15 -y 500 -width 490 -height 335 -anchor nw -bordermode ignore
pack $base.f2.fl \
-in .pgaw:TableInfo.f2 -anchor center -expand 0 -fill both -side left
pack $base.f2.fl.t \
-in .pgaw:TableInfo.f2.fl -anchor center -expand 0 -fill x -pady 1 -side top
pack $base.f2.fl.delidxbtn \
-in .pgaw:TableInfo.f2.fl -anchor center -expand 0 -fill none -side bottom
pack $base.f2.fl.ilb \
-in .pgaw:TableInfo.f2.fl -anchor center -expand 1 -fill both -pady 1 -side left
pack $base.f2.fl.vsb \
-in .pgaw:TableInfo.f2.fl -anchor center -expand 0 -fill y -side right
pack $base.f2.fr \
-in .pgaw:TableInfo.f2 -anchor center -expand 1 -fill both -padx 1 -side right
pack $base.f2.fr.t \
-in .pgaw:TableInfo.f2.fr -anchor center -expand 0 -fill x -pady 1 -side top
pack $base.f2.fr.clusterbtn \
-in .pgaw:TableInfo.f2.fr -anchor center -expand 0 -fill none -side bottom
pack $base.f2.fr.fp \
-in .pgaw:TableInfo.f2.fr -anchor center -expand 0 -fill x -pady 1 -side top
grid $base.f2.fr.fp.lu \
-in .pgaw:TableInfo.f2.fr.fp -column 0 -row 0 -columnspan 1 -rowspan 1 -sticky w
grid $base.f2.fr.fp.vu \
-in .pgaw:TableInfo.f2.fr.fp -column 1 -row 0 -columnspan 1 -rowspan 1 -padx 5 \
-sticky w
grid $base.f2.fr.fp.lc \
-in .pgaw:TableInfo.f2.fr.fp -column 0 -row 2 -columnspan 1 -rowspan 1 -sticky w
grid $base.f2.fr.fp.vc \
-in .pgaw:TableInfo.f2.fr.fp -column 1 -row 2 -columnspan 1 -rowspan 1 -padx 5 \
-sticky w
pack $base.f2.fr.lic \
-in .pgaw:TableInfo.f2.fr -anchor center -expand 0 -fill x -side top
pack $base.f2.fr.lb \
-in .pgaw:TableInfo.f2.fr -anchor center -expand 1 -fill both -pady 1 -side left
pack $base.f2.fr.vsb \
-in .pgaw:TableInfo.f2.fr -anchor center -expand 0 -fill y -side right
place $base.f3 \
-x 15 -y 500 -width 490 -height 335 -anchor nw -bordermode ignore
pack $base.f3.ft \
-in .pgaw:TableInfo.f3 -anchor center -expand 0 -fill x -pady 1 -side top
pack $base.f3.ft.luser \
-in .pgaw:TableInfo.f3.ft -anchor center -expand 1 -fill x -side left
pack $base.f3.ft.lselect \
-in .pgaw:TableInfo.f3.ft -anchor center -expand 0 -fill none -side left
pack $base.f3.ft.lupdate \
-in .pgaw:TableInfo.f3.ft -anchor center -expand 0 -fill none -side left
pack $base.f3.ft.linsert \
-in .pgaw:TableInfo.f3.ft -anchor center -expand 0 -fill none -side left
pack $base.f3.ft.lrule \
-in .pgaw:TableInfo.f3.ft -anchor center -expand 0 -fill none -side left
pack $base.f3.ft.ls \
-in .pgaw:TableInfo.f3.ft -anchor center -expand 0 -fill none -side top
pack $base.f3.fb \
-in .pgaw:TableInfo.f3 -anchor center -expand 0 -fill x -side bottom
grid $base.f3.fb.adduserbtn \
-in .pgaw:TableInfo.f3.fb -column 0 -row 0 -columnspan 1 -rowspan 1
grid $base.f3.fb.chguserbtn \
-in .pgaw:TableInfo.f3.fb -column 1 -row 0 -columnspan 1 -rowspan 1
pack $base.f3.plb \
-in .pgaw:TableInfo.f3 -anchor center -expand 1 -fill both -pady 1 -side left
pack $base.f3.vsb \
-in .pgaw:TableInfo.f3 -anchor center -expand 0 -fill y -side right
place $base.lline \
-x 16 -y 32 -width 94 -height 6 -anchor nw -bordermode ignore
place $base.f0 \
-x 15 -y 45 -width 490 -height 335 -anchor nw -bordermode ignore
place $base.f0.fi \
-x 5 -y 15 -width 300 -height 140 -anchor nw -bordermode ignore
grid columnconf $base.f0.fi 1 -weight 1
grid rowconf $base.f0.fi 6 -weight 1
grid $base.f0.fi.l1 \
-in .pgaw:TableInfo.f0.fi -column 0 -row 0 -columnspan 1 -rowspan 1 -sticky w
grid $base.f0.fi.l2 \
-in .pgaw:TableInfo.f0.fi -column 1 -row 0 -columnspan 1 -rowspan 1 -padx 2 \
-pady 2
grid $base.f0.fi.l3 \
-in .pgaw:TableInfo.f0.fi -column 0 -row 1 -columnspan 1 -rowspan 1 -sticky w
grid $base.f0.fi.l4 \
-in .pgaw:TableInfo.f0.fi -column 1 -row 1 -columnspan 1 -rowspan 1 -padx 2 \
-pady 2
grid $base.f0.fi.l5 \
-in .pgaw:TableInfo.f0.fi -column 0 -row 2 -columnspan 1 -rowspan 1 -sticky w
grid $base.f0.fi.l6 \
-in .pgaw:TableInfo.f0.fi -column 1 -row 2 -columnspan 1 -rowspan 1 -padx 2 \
-pady 2
grid $base.f0.fi.l7 \
-in .pgaw:TableInfo.f0.fi -column 0 -row 3 -columnspan 1 -rowspan 1 -sticky w
grid $base.f0.fi.l8 \
-in .pgaw:TableInfo.f0.fi -column 1 -row 3 -columnspan 1 -rowspan 1 -padx 2 \
-pady 2
grid $base.f0.fi.l9 \
-in .pgaw:TableInfo.f0.fi -column 0 -row 4 -columnspan 1 -rowspan 1 -sticky w
grid $base.f0.fi.l10 \
-in .pgaw:TableInfo.f0.fi -column 1 -row 4 -columnspan 1 -rowspan 1 -padx 2 \
-pady 2
grid $base.f0.fi.l11 \
-in .pgaw:TableInfo.f0.fi -column 0 -row 5 -columnspan 1 -rowspan 1 -sticky w
grid $base.f0.fi.l12 \
-in .pgaw:TableInfo.f0.fi -column 1 -row 5 -columnspan 1 -rowspan 1 -padx 2 \
-pady 2
grid $base.f0.fi.last \
-in .pgaw:TableInfo.f0.fi -column 0 -row 6 -columnspan 1 -rowspan 1
place $base.f0.fs \
-x 310 -y 15 -width 175 -height 50 -anchor nw -bordermode ignore
grid columnconf $base.f0.fs 1 -weight 1
grid rowconf $base.f0.fs 2 -weight 1
grid $base.f0.fs.l1 \
-in .pgaw:TableInfo.f0.fs -column 0 -row 0 -columnspan 1 -rowspan 1 -sticky w
grid $base.f0.fs.l2 \
-in .pgaw:TableInfo.f0.fs -column 1 -row 0 -columnspan 1 -rowspan 1 -padx 2 \
-pady 2 -sticky w
grid $base.f0.fs.l3 \
-in .pgaw:TableInfo.f0.fs -column 0 -row 1 -columnspan 1 -rowspan 1 -sticky w
grid $base.f0.fs.l4 \
-in .pgaw:TableInfo.f0.fs -column 1 -row 1 -columnspan 1 -rowspan 1 -padx 2 \
-pady 2 -sticky w
grid $base.f0.fs.last \
-in .pgaw:TableInfo.f0.fs -column 0 -row 2 -columnspan 1 -rowspan 1
place $base.f0.lstat \
-x 315 -y 5 -height 18 -anchor nw -bordermode ignore
place $base.f0.lid \
-x 10 -y 5 -height 16 -anchor nw -bordermode ignore
}
proc vTclWindow.pgaw:AddIndex {base} {
if {$base == ""} {
set base .pgaw:AddIndex
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
wm geometry $base 334x203+265+266
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 [intlmsg "Add new index"]
frame $base.f \
-borderwidth 2 -height 75 -relief groove -width 125
frame $base.f.fin \
-height 75 -relief groove -width 125
label $base.f.fin.lin \
-borderwidth 0 -relief raised -text [intlmsg {Index name}]
entry $base.f.fin.ein \
-background #fefefe -borderwidth 1 -width 28 -textvariable PgAcVar(addindex,indexname)
checkbutton $base.f.cbunique -borderwidth 1 \
-offvalue { } -onvalue unique -text [intlmsg {Is unique ?}] -variable PgAcVar(addindex,unique)
label $base.f.ls1 \
-anchor w -background #dfdbdf -borderwidth 0 -foreground #000086 \
-justify left -relief raised -textvariable PgAcVar(addindex,indexfields) \
-wraplength 300
label $base.f.lif \
-borderwidth 0 -relief raised -text "[intlmsg {Index fields}]:"
label $base.f.ls2 \
-borderwidth 0 -relief raised -text { }
label $base.f.ls3 \
-borderwidth 0 -relief raised -text { }
frame $base.fb \
-height 75 -relief groove -width 125
button $base.fb.btncreate -command Tables::createNewIndex \
-padx 9 -pady 3 -text [intlmsg Create]
button $base.fb.btncancel \
-command {Window destroy .pgaw:AddIndex} -padx 9 -pady 3 -text [intlmsg Cancel]
pack $base.f \
-in .pgaw:AddIndex -anchor center -expand 1 -fill both -side top
grid $base.f.fin \
-in .pgaw:AddIndex.f -column 0 -row 0 -columnspan 1 -rowspan 1
grid $base.f.fin.lin \
-in .pgaw:AddIndex.f.fin -column 0 -row 0 -columnspan 1 -rowspan 1
grid $base.f.fin.ein \
-in .pgaw:AddIndex.f.fin -column 1 -row 0 -columnspan 1 -rowspan 1
grid $base.f.cbunique \
-in .pgaw:AddIndex.f -column 0 -row 5 -columnspan 1 -rowspan 1
grid $base.f.ls1 \
-in .pgaw:AddIndex.f -column 0 -row 3 -columnspan 1 -rowspan 1
grid $base.f.lif \
-in .pgaw:AddIndex.f -column 0 -row 2 -columnspan 1 -rowspan 1 -sticky w
grid $base.f.ls2 \
-in .pgaw:AddIndex.f -column 0 -row 1 -columnspan 1 -rowspan 1
grid $base.f.ls3 \
-in .pgaw:AddIndex.f -column 0 -row 4 -columnspan 1 -rowspan 1
pack $base.fb \
-in .pgaw:AddIndex -anchor center -expand 0 -fill x -side bottom
grid $base.fb.btncreate \
-in .pgaw:AddIndex.fb -column 0 -row 0 -columnspan 1 -rowspan 1
grid $base.fb.btncancel \
-in .pgaw:AddIndex.fb -column 1 -row 0 -columnspan 1 -rowspan 1
}
proc vTclWindow.pgaw:AddField {base} {
if {$base == ""} {
set base .pgaw:AddField
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
wm geometry $base 302x114+195+175
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 [intlmsg "Add new column"]
label $base.l1 \
-borderwidth 0 -text [intlmsg {Field name}]
entry $base.e1 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(addfield,name)
bind $base.e1 <Key-KP_Enter> {
focus .pgaw:AddField.e2
}
bind $base.e1 <Key-Return> {
focus .pgaw:AddField.e2
}
label $base.l2 \
-borderwidth 0 \
-text [intlmsg {Field type}]
entry $base.e2 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(addfield,type)
bind $base.e2 <Key-KP_Enter> {
Tables::addNewColumn
}
bind $base.e2 <Key-Return> {
Tables::addNewColumn
}
button $base.b1 \
-borderwidth 1 -command Tables::addNewColumn -text [intlmsg {Add field}]
button $base.b2 \
-borderwidth 1 -command {Window destroy .pgaw:AddField} -text [intlmsg Cancel]
place $base.l1 \
-x 25 -y 10 -anchor nw -bordermode ignore
place $base.e1 \
-x 98 -y 7 -width 178 -height 22 -anchor nw -bordermode ignore
place $base.l2 \
-x 25 -y 40 -anchor nw -bordermode ignore
place $base.e2 \
-x 98 -y 37 -width 178 -height 22 -anchor nw -bordermode ignore
place $base.b1 \
-x 70 -y 75 -anchor nw -bordermode ignore
place $base.b2 \
-x 160 -y 75 -anchor nw -bordermode ignore
}
proc vTclWindow.pgaw:RenameField {base} {
if {$base == ""} {
set base .pgaw:RenameField
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
wm geometry $base 215x75+258+213
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 [intlmsg "Rename column"]
label $base.l1 \
-borderwidth 0 -text [intlmsg {New name}]
entry $base.e1 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(tblinfo,new_cn)
bind $base.e1 <Key-KP_Enter> "Tables::renameColumn"
bind $base.e1 <Key-Return> "Tables::renameColumn"
frame $base.f \
-height 75 -relief groove -width 147
button $base.f.b1 \
-borderwidth 1 -command Tables::renameColumn -text [intlmsg Rename]
button $base.f.b2 \
-borderwidth 1 -command {Window destroy .pgaw:RenameField} -text [intlmsg Cancel]
label $base.l2 -borderwidth 0
grid $base.l1 \
-in .pgaw:RenameField -column 0 -row 0 -columnspan 1 -rowspan 1
grid $base.e1 \
-in .pgaw:RenameField -column 1 -row 0 -columnspan 1 -rowspan 1
grid $base.f \
-in .pgaw:RenameField -column 0 -row 4 -columnspan 2 -rowspan 1
grid $base.f.b1 \
-in .pgaw:RenameField.f -column 0 -row 0 -columnspan 1 -rowspan 1
grid $base.f.b2 \
-in .pgaw:RenameField.f -column 1 -row 0 -columnspan 1 -rowspan 1
grid $base.l2 \
-in .pgaw:RenameField -column 0 -row 3 -columnspan 1 -rowspan 1
}
proc vTclWindow.pgaw:Permissions {base} {
if {$base == ""} {
set base .pgaw:Permissions
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
wm geometry $base 273x147+256+266
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 [intlmsg "Permissions"]
frame $base.f1 \
-height 103 -relief groove -width 125
label $base.f1.l \
-borderwidth 0 -relief raised -text [intlmsg {User name}]
entry $base.f1.ename -textvariable PgAcVar(permission,username) \
-background #fefefe -borderwidth 1
label $base.f1.l2 \
-borderwidth 0 -relief raised -text { }
label $base.f1.l3 \
-borderwidth 0 -relief raised -text { }
frame $base.f2 \
-height 75 -relief groove -borderwidth 2 -width 125
checkbutton $base.f2.cb1 -borderwidth 1 -padx 4 -pady 4 \
-text [intlmsg select] -variable PgAcVar(permission,select)
checkbutton $base.f2.cb2 -borderwidth 1 -padx 4 -pady 4 \
-text [intlmsg update] -variable PgAcVar(permission,update)
checkbutton $base.f2.cb3 -borderwidth 1 -padx 4 -pady 4 \
-text [intlmsg insert] -variable PgAcVar(permission,insert)
checkbutton $base.f2.cb4 -borderwidth 1 -padx 4 -pady 4 \
-text [intlmsg rule] -variable PgAcVar(permission,rule)
frame $base.fb \
-height 75 -relief groove -width 125
button $base.fb.btnsave -command Tables::savePermissions \
-padx 9 -pady 3 -text [intlmsg Save]
button $base.fb.btncancel -command {Window destroy .pgaw:Permissions} \
-padx 9 -pady 3 -text [intlmsg Cancel]
pack $base.f1 \
-in .pgaw:Permissions -anchor center -expand 0 -fill none -side top
grid $base.f1.l \
-in .pgaw:Permissions.f1 -column 0 -row 1 -columnspan 1 -rowspan 1
grid $base.f1.ename \
-in .pgaw:Permissions.f1 -column 1 -row 1 -columnspan 1 -rowspan 1 -padx 2
grid $base.f1.l2 \
-in .pgaw:Permissions.f1 -column 0 -row 0 -columnspan 1 -rowspan 1
grid $base.f1.l3 \
-in .pgaw:Permissions.f1 -column 0 -row 2 -columnspan 1 -rowspan 1
pack $base.f2 \
-in .pgaw:Permissions -anchor center -expand 0 -fill none -side top
grid $base.f2.cb1 \
-in .pgaw:Permissions.f2 -column 0 -row 1 -columnspan 1 -rowspan 1 -sticky w
grid $base.f2.cb2 \
-in .pgaw:Permissions.f2 -column 1 -row 1 -columnspan 1 -rowspan 1 -sticky w
grid $base.f2.cb3 \
-in .pgaw:Permissions.f2 -column 0 -row 2 -columnspan 1 -rowspan 1 -sticky w
grid $base.f2.cb4 \
-in .pgaw:Permissions.f2 -column 1 -row 2 -columnspan 1 -rowspan 1 -sticky w
pack $base.fb \
-in .pgaw:Permissions -anchor center -expand 0 -fill none -pady 3 -side bottom
grid $base.fb.btnsave \
-in .pgaw:Permissions.fb -column 0 -row 0 -columnspan 1 -rowspan 1
grid $base.fb.btncancel \
-in .pgaw:Permissions.fb -column 1 -row 0 -columnspan 1 -rowspan 1
}
src/bin/pgaccess/lib/users.tcl 0 → 100644
View file @ 25acbc51
namespace eval Users {
proc {new} {} {
global PgAcVar
Window show .pgaw:User
wm transient .pgaw:User .pgaw:Main
set PgAcVar(user,action) "CREATE"
set PgAcVar(user,name) {}
set PgAcVar(user,password) {}
set PgAcVar(user,createdb) NOCREATEDB
set PgAcVar(user,createuser) NOCREATEUSER
set PgAcVar(user,verifypassword) {}
set PgAcVar(user,validuntil) {}
focus .pgaw:User.e1
}
proc {design} {username} {
global PgAcVar CurrentDB
Window show .pgaw:User
tkwait visibility .pgaw:User
wm transient .pgaw:User .pgaw:Main
wm title .pgaw:User [intlmsg "Change user"]
set PgAcVar(user,action) "ALTER"
set PgAcVar(user,name) $username
set PgAcVar(user,password) {} ; set PgAcVar(user,verifypassword) {}
pg_select $CurrentDB "select *,date(valuntil) as valdata from pg_user where usename='$username'" tup {
if {$tup(usesuper)=="t"} {
set PgAcVar(user,createuser) CREATEUSER
} else {
set PgAcVar(user,createuser) NOCREATEUSER
}
if {$tup(usecreatedb)=="t"} {
set PgAcVar(user,createdb) CREATEDB
} else {
set PgAcVar(user,createdb) NOCREATEDB
}
if {$tup(valuntil)!=""} {
set PgAcVar(user,validuntil) $tup(valdata)
} else {
set PgAcVar(user,validuntil) {}
}
}
.pgaw:User.e1 configure -state disabled
.pgaw:User.b1 configure -text [intlmsg Save]
focus .pgaw:User.e2
}
proc {save} {} {
global PgAcVar CurrentDB
set PgAcVar(user,name) [string trim $PgAcVar(user,name)]
set PgAcVar(user,password) [string trim $PgAcVar(user,password)]
set PgAcVar(user,verifypassword) [string trim $PgAcVar(user,verifypassword)]
if {$PgAcVar(user,name)==""} {
showError [intlmsg "User without name?"]
focus .pgaw:User.e1
return
}
if {$PgAcVar(user,password)!=$PgAcVar(user,verifypassword)} {
showError [intlmsg "Passwords do not match!"]
set PgAcVar(user,password) {} ; set PgAcVar(user,verifypassword) {}
focus .pgaw:User.e2
return
}
set cmd "$PgAcVar(user,action) user \"$PgAcVar(user,name)\""
if {$PgAcVar(user,password)!=""} {
set cmd "$cmd WITH PASSWORD \"$PgAcVar(user,password)\" "
}
set cmd "$cmd $PgAcVar(user,createdb) $PgAcVar(user,createuser)"
if {$PgAcVar(user,validuntil)!=""} {
set cmd "$cmd VALID UNTIL '$PgAcVar(user,validuntil)'"
}
if {[sql_exec noquiet $cmd]} {
Window destroy .pgaw:User
Mainlib::cmd_Users
}
}
}
proc vTclWindow.pgaw:User {base} {
if {$base == ""} {
set base .pgaw:User
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
wm geometry $base 263x220+233+165
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 [intlmsg "Define new user"]
label $base.l1 \
-borderwidth 0 -anchor w -text [intlmsg "User name"]
entry $base.e1 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(user,name)
bind $base.e1 <Key-Return> "focus .pgaw:User.e2"
bind $base.e1 <Key-KP_Enter> "focus .pgaw:User.e2"
label $base.l2 \
-borderwidth 0 -text [intlmsg Password]
entry $base.e2 \
-background #fefefe -borderwidth 1 -show * -textvariable PgAcVar(user,password)
bind $base.e2 <Key-Return> "focus .pgaw:User.e3"
bind $base.e2 <Key-KP_Enter> "focus .pgaw:User.e3"
label $base.l3 \
-borderwidth 0 -text [intlmsg {verify password}]
entry $base.e3 \
-background #fefefe -borderwidth 1 -show * -textvariable PgAcVar(user,verifypassword)
bind $base.e3 <Key-Return> "focus .pgaw:User.cb1"
bind $base.e3 <Key-KP_Enter> "focus .pgaw:User.cb1"
checkbutton $base.cb1 \
-borderwidth 1 -offvalue NOCREATEDB -onvalue CREATEDB \
-text [intlmsg {Allow user to create databases}] -variable PgAcVar(user,createdb)
checkbutton $base.cb2 \
-borderwidth 1 -offvalue NOCREATEUSER -onvalue CREATEUSER \
-text [intlmsg {Allow user to create other users}] -variable PgAcVar(user,createuser)
label $base.l4 \
-borderwidth 0 -anchor w -text [intlmsg {Valid until (date)}]
entry $base.e4 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(user,validuntil)
bind $base.e4 <Key-Return> "focus .pgaw:User.b1"
bind $base.e4 <Key-KP_Enter> "focus .pgaw:User.b1"
button $base.b1 \
-borderwidth 1 -command Users::save -text [intlmsg Create]
button $base.b2 \
-borderwidth 1 -command {Window destroy .pgaw:User} -text [intlmsg Cancel]
place $base.l1 \
-x 5 -y 7 -height 16 -anchor nw -bordermode ignore
place $base.e1 \
-x 109 -y 5 -width 146 -height 20 -anchor nw -bordermode ignore
place $base.l2 \
-x 5 -y 35 -anchor nw -bordermode ignore
place $base.e2 \
-x 109 -y 32 -width 146 -height 20 -anchor nw -bordermode ignore
place $base.l3 \
-x 5 -y 60 -anchor nw -bordermode ignore
place $base.e3 \
-x 109 -y 58 -width 146 -height 20 -anchor nw -bordermode ignore
place $base.cb1 \
-x 5 -y 90 -anchor nw -bordermode ignore
place $base.cb2 \
-x 5 -y 115 -anchor nw -bordermode ignore
place $base.l4 \
-x 5 -y 145 -height 16 -anchor nw -bordermode ignore
place $base.e4 \
-x 110 -y 143 -width 146 -height 20 -anchor nw -bordermode ignore
place $base.b1 \
-x 45 -y 185 -anchor nw -width 70 -height 25 -bordermode ignore
place $base.b2 \
-x 140 -y 185 -anchor nw -width 70 -height 25 -bordermode ignore
}
src/bin/pgaccess/lib/views.tcl 0 → 100644
View file @ 25acbc51
namespace eval Views {
proc {new} {} {
global PgAcVar
set PgAcVar(query,oid) 0
set PgAcVar(query,name) {}
Window show .pgaw:QueryBuilder
set PgAcVar(query,asview) 1
.pgaw:QueryBuilder.saveAsView configure -state disabled
}
proc {open} {viewname} {
global PgAcVar
if {$viewname==""} return;
set wn [Tables::getNewWindowName]
Tables::createWindow
set PgAcVar(mw,$wn,query) "select * from \"$viewname\""
set PgAcVar(mw,$wn,isaquery) 0
set PgAcVar(mw,$wn,updatable) 0
Tables::loadLayout $wn $viewname
Tables::selectRecords $wn $PgAcVar(mw,$wn,query)
}
proc {design} {viewname} {
global PgAcVar CurrentDB
set vd {}
wpg_select $CurrentDB "select pg_get_viewdef('$viewname')as vd" tup {
set vd $tup(vd)
}
if {$vd==""} {
showError "[intlmsg {Error retrieving view definition for}] '$viewname'!"
return
}
Window show .pgaw:QueryBuilder
.pgaw:QueryBuilder.text1 delete 0.0 end
.pgaw:QueryBuilder.text1 insert end $vd
set PgAcVar(query,asview) 1
.pgaw:QueryBuilder.saveAsView configure -state disabled
set PgAcVar(query,name) $viewname
}
}
src/bin/pgaccess/lib/visualqb.tcl 0 → 100644
View file @ 25acbc51
namespace eval VisualQueryBuilder {
# The following array will hold all the local variables
variable vqb
proc {addNewTable} {{tabx 0} {taby 0} {alias -1}} {
global PgAcVar CurrentDB
variable vqb
if {$vqb(newtablename)==""} return
set fldlist {}
setCursor CLOCK
wpg_select $CurrentDB "select attnum,attname from pg_class,pg_attribute where (pg_class.relname='$vqb(newtablename)') and (pg_class.oid=pg_attribute.attrelid) and (attnum>0) order by attnum" rec {
lappend fldlist $rec(attname)
}
setCursor DEFAULT
if {$fldlist==""} {
showError [format [intlmsg "Table '%s' not found!"] $vqb(newtablename)]
return
}
if {$alias==-1} {
set tabnum $vqb(ntables)
} else {
regsub t $alias "" tabnum
}
set vqb(tablename$tabnum) $vqb(newtablename)
set vqb(tablestruct$tabnum) $fldlist
set vqb(tablealias$tabnum) "t$tabnum"
set vqb(ali_t$tabnum) $vqb(newtablename)
set vqb(tablex$tabnum) $tabx
set vqb(tabley$tabnum) $taby
incr vqb(ntables)
if {$vqb(ntables)==1} {
repaintAll
} else {
drawTable [expr $vqb(ntables)-1]
}
set vqb(newtablename) {}
focus .pgaw:VisualQuery.fb.entt
}
proc {computeSQL} {} {
global PgAcVar
variable vqb
set sqlcmd "select "
#rjr 8Mar1999 added logical return state for results
for {set i 0} {$i<[llength $vqb(resfields)]} {incr i} {
if {[lindex $vqb(resreturn) $i]==[intlmsg Yes]} {
if {$sqlcmd!="select "} {set sqlcmd "$sqlcmd, "}
set sqlcmd "$sqlcmd[lindex $vqb(restables) $i].\"[lindex $vqb(resfields) $i]\""
}
}
set tables {}
for {set i 0} {$i<$vqb(ntables)} {incr i} {
set thename {}
catch {set thename $vqb(tablename$i)}
if {$thename!=""} {lappend tables "\"$vqb(tablename$i)\" $vqb(tablealias$i)"}
}
set sqlcmd "$sqlcmd from [join $tables ,] "
set sup1 {}
if {[llength $vqb(links)]>0} {
set sup1 "where "
foreach link $vqb(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 $vqb(resfields)]} {incr i} {
set crit [lindex $vqb(rescriteria) $i]
if {$crit!=""} {
if {$sup1==""} {set sup1 "where "}
if {[string length $sup1]>6} {set sup1 "$sup1 and "}
set sup1 "$sup1 ([lindex $vqb(restables) $i].\"[lindex $vqb(resfields) $i]\" $crit) "
}
}
set sqlcmd "$sqlcmd $sup1"
set sup2 {}
for {set i 0} {$i<[llength $vqb(ressort)]} {incr i} {
set how [lindex $vqb(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 $vqb(restables) $i].\"[lindex $vqb(resfields) $i]\" $how "
}
}
set sqlcmd "$sqlcmd $sup2"
set vqb(qcmd) $sqlcmd
return $sqlcmd
}
proc {deleteObject} {} {
global PgAcVar
variable vqb
# Checking if there is a highlighted object (i.e. is selected)
set obj [.pgaw:VisualQuery.c find withtag hili]
if {$obj==""} return
#
# Is object a link ?
if {[getTagInfo $obj link]=="s"} {
if {[tk_messageBox -title [intlmsg Warning] -icon question -parent .pgaw:VisualQuery -message [intlmsg "Remove link ?"] -type yesno -default no]=="no"} return
set linkid [getTagInfo $obj lkid]
set vqb(links) [lreplace $vqb(links) $linkid $linkid]
.pgaw:VisualQuery.c delete links
drawLinks
return
}
#
# Is object a result field ?
if {[getTagInfo $obj res]=="f"} {
set col [getTagInfo $obj col]
if {$col==""} return
if {[tk_messageBox -title [intlmsg Warning] -icon question -parent .pgaw:VisualQuery -message [intlmsg "Remove field from result ?"] -type yesno -default no]=="no"} return
set vqb(resfields) [lreplace $vqb(resfields) $col $col]
set vqb(ressort) [lreplace $vqb(ressort) $col $col]
set vqb(resreturn) [lreplace $vqb(resreturn) $col $col]
set vqb(restables) [lreplace $vqb(restables) $col $col]
set vqb(rescriteria) [lreplace $vqb(rescriteria) $col $col]
drawResultPanel
return
}
#
# Is object a table ?
set tablealias [getTagInfo $obj tab]
set tablename $vqb(ali_$tablealias)
if {"$tablename"==""} return
if {[tk_messageBox -title [intlmsg Warning] -icon question -parent .pgaw:VisualQuery -message [format [intlmsg "Remove table %s from query?"] $tablename] -type yesno -default no]=="no"} return
for {set i [expr [llength $vqb(restables)]-1]} {$i>=0} {incr i -1} {
if {"$tablealias"==[lindex $vqb(restables) $i]} {
set vqb(resfields) [lreplace $vqb(resfields) $i $i]
set vqb(ressort) [lreplace $vqb(ressort) $i $i]
set vqb(resreturn) [lreplace $vqb(resreturn) $i $i]
set vqb(restables) [lreplace $vqb(restables) $i $i]
set vqb(rescriteria) [lreplace $vqb(rescriteria) $i $i]
}
}
for {set i [expr [llength $vqb(links)]-1]} {$i>=0} {incr i -1} {
set thelink [lindex $vqb(links) $i]
if {($tablealias==[lindex $thelink 0]) || ($tablealias==[lindex $thelink 2])} {
set vqb(links) [lreplace $vqb(links) $i $i]
}
}
for {set i 0} {$i<$vqb(ntables)} {incr i} {
set temp {}
catch {set temp $vqb(tablename$i)}
if {"$temp"=="$tablename"} {
unset vqb(tablename$i)
unset vqb(tablestruct$i)
unset vqb(tablealias$i)
break
}
}
unset vqb(ali_$tablealias)
#incr vqb(ntables) -1
.pgaw:VisualQuery.c delete tab$tablealias
.pgaw:VisualQuery.c delete links
drawLinks
drawResultPanel
}
proc {dragObject} {w x y} {
global PgAcVar
variable vqb
if {"$PgAcVar(draginfo,obj)" == ""} {return}
set dx [expr $x - $PgAcVar(draginfo,x)]
set dy [expr $y - $PgAcVar(draginfo,y)]
if {$PgAcVar(draginfo,is_a_table)} {
$w move $PgAcVar(draginfo,tabletag) $dx $dy
drawLinks
} else {
$w move $PgAcVar(draginfo,obj) $dx $dy
}
set PgAcVar(draginfo,x) $x
set PgAcVar(draginfo,y) $y
}
proc {dragStart} {w x y} {
global PgAcVar
variable vqb
PgAcVar:clean draginfo,*
set PgAcVar(draginfo,obj) [$w find closest $x $y]
if {[getTagInfo $PgAcVar(draginfo,obj) r]=="ect"} {
# If it'a a rectangle, exit
set PgAcVar(draginfo,obj) {}
return
}
.pgaw:VisualQuery configure -cursor hand1
.pgaw:VisualQuery.c raise $PgAcVar(draginfo,obj)
set PgAcVar(draginfo,table) 0
if {[getTagInfo $PgAcVar(draginfo,obj) table]=="header"} {
set PgAcVar(draginfo,is_a_table) 1
set taglist [.pgaw:VisualQuery.c gettags $PgAcVar(draginfo,obj)]
set PgAcVar(draginfo,tabletag) [lindex $taglist [lsearch -regexp $taglist "^tab\[0-9\]*"]]
.pgaw:VisualQuery.c raise $PgAcVar(draginfo,tabletag)
.pgaw:VisualQuery.c itemconfigure [.pgaw:VisualQuery.c find withtag hili] -fill black
.pgaw:VisualQuery.c dtag [.pgaw:VisualQuery.c find withtag hili] hili
.pgaw:VisualQuery.c addtag hili withtag $PgAcVar(draginfo,obj)
.pgaw:VisualQuery.c itemconfigure hili -fill blue
} else {
set PgAcVar(draginfo,is_a_table) 0
}
set PgAcVar(draginfo,x) $x
set PgAcVar(draginfo,y) $y
set PgAcVar(draginfo,sx) $x
set PgAcVar(draginfo,sy) $y
}
proc {dragStop} {x y} {
global PgAcVar
variable vqb
# when click Close, ql window is destroyed but event ButtonRelease-1 is fired
if {![winfo exists .pgaw:VisualQuery]} return;
.pgaw:VisualQuery configure -cursor left_ptr
set este {}
catch {set este $PgAcVar(draginfo,obj)}
if {$este==""} return
# Re-establish the normal paint order so
# information won't be overlapped by table rectangles
# or link lines
.pgaw:VisualQuery.c lower $PgAcVar(draginfo,obj)
.pgaw:VisualQuery.c lower rect
.pgaw:VisualQuery.c lower links
set vqb(panstarted) 0
if {$PgAcVar(draginfo,is_a_table)} {
set tabnum [getTagInfo $PgAcVar(draginfo,obj) tabt]
foreach w [.pgaw:VisualQuery.c find withtag $PgAcVar(draginfo,tabletag)] {
if {[lsearch [.pgaw:VisualQuery.c gettags $w] outer] != -1} {
foreach [list vqb(tablex$tabnum) vqb(tabley$tabnum) x1 y1] [.pgaw:VisualQuery.c coords $w] {}
}
}
set PgAcVar(draginfo,obj) {}
.pgaw:VisualQuery.c delete links
drawLinks
return
}
.pgaw:VisualQuery.c move $PgAcVar(draginfo,obj) [expr $PgAcVar(draginfo,sx)-$x] [expr $PgAcVar(draginfo,sy)-$y]
if {($y>$vqb(yoffs)) && ($x>$vqb(xoffs))} {
# Drop position : inside the result panel
# Compute the offset of the result panel due to panning
set resoffset [expr [lindex [.pgaw:VisualQuery.c bbox resmarker] 0]-$vqb(xoffs)]
set newfld [.pgaw:VisualQuery.c itemcget $PgAcVar(draginfo,obj) -text]
set tabtag [getTagInfo $PgAcVar(draginfo,obj) tab]
set col [expr int(($x-$vqb(xoffs)-$resoffset)/$vqb(reswidth))]
set vqb(resfields) [linsert $vqb(resfields) $col $newfld]
set vqb(ressort) [linsert $vqb(ressort) $col unsorted]
set vqb(rescriteria) [linsert $vqb(rescriteria) $col {}]
set vqb(restables) [linsert $vqb(restables) $col $tabtag]
set vqb(resreturn) [linsert $vqb(resreturn) $col [intlmsg Yes]]
drawResultPanel
} else {
# Drop position : in the table panel
set droptarget [.pgaw:VisualQuery.c find overlapping $x $y $x $y]
set targettable {}
foreach item $droptarget {
set targettable [getTagInfo $item tab]
set targetfield [getTagInfo $item f-]
if {($targettable!="") && ($targetfield!="")} {
set droptarget $item
break
}
}
# check if target object isn't a rectangle
if {[getTagInfo $droptarget rec]=="t"} {set targettable {}}
if {$targettable!=""} {
# Target has a table
# See about originate table
set sourcetable [getTagInfo $PgAcVar(draginfo,obj) tab]
if {$sourcetable!=""} {
# Source has also a tab .. tag
set sourcefield [getTagInfo $PgAcVar(draginfo,obj) f-]
if {$sourcetable!=$targettable} {
lappend vqb(links) [list $sourcetable $sourcefield $targettable $targetfield]
drawLinks
}
}
}
}
# Erase information about onbject beeing dragged
set PgAcVar(draginfo,obj) {}
}
proc {getTableList} {} {
global PgAcVar
variable vqb
set tablelist {}
foreach name [array names vqb tablename*] {
regsub tablename $name "" num
lappend tablelist $vqb($name) $vqb(tablex$num) $vqb(tabley$num) t$num
}
return $tablelist
}
proc {getLinkList} {} {
global PgAcVar
variable vqb
set linklist {}
foreach l $vqb(links) {
lappend linklist [lindex $l 0] [lindex $l 1] [lindex $l 2] [lindex $l 3]
}
return $linklist
}
proc {loadVisualLayout} {} {
global PgAcVar
variable vqb
init
foreach {t x y a} $PgAcVar(query,tables) {set vqb(newtablename) $t; addNewTable $x $y $a}
foreach {t0 f0 t1 f1} $PgAcVar(query,links) {lappend vqb(links) [list $t0 $f0 $t1 $f1]}
foreach {f t s c r} $PgAcVar(query,results) {addResultColumn $f $t $s $c $r}
repaintAll
}
proc {findField} {alias field} {
foreach obj [.pgaw:VisualQuery.c find withtag f-${field}] {
if {[lsearch [.pgaw:VisualQuery.c gettags $obj] tab$alias] != -1} {return $obj}
}
return -1
}
proc {getResultList} {} {
global PgAcVar
variable vqb
set reslist {}
for {set i 0} {$i < [llength $vqb(resfields)]} {incr i} {
lappend reslist [lindex $vqb(resfields) $i]
lappend reslist [lindex $vqb(restables) $i]
lappend reslist [lindex $vqb(ressort) $i]
lappend reslist [lindex $vqb(rescriteria) $i]
lappend reslist [lindex $vqb(resreturn) $i]
}
return $reslist
}
proc {addResultColumn} {f t s c r} {
global PgAcVar
variable vqb
lappend vqb(resfields) $f
lappend vqb(restables) $t
lappend vqb(ressort) $s
lappend vqb(rescriteria) $c
lappend vqb(resreturn) $r
}
proc {drawLinks} {} {
global PgAcVar
variable vqb
.pgaw:VisualQuery.c delete links
set i 0
foreach link $vqb(links) {
# Compute the source and destination right edge
set sre [lindex [.pgaw:VisualQuery.c bbox tab[lindex $link 0]] 2]
set dre [lindex [.pgaw:VisualQuery.c bbox tab[lindex $link 2]] 2]
# Compute field bound boxes
set sbbox [.pgaw:VisualQuery.c bbox [findField [lindex $link 0] [lindex $link 1]]]
set dbbox [.pgaw:VisualQuery.c bbox [findField [lindex $link 2] [lindex $link 3]]]
# 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]
.pgaw:VisualQuery.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]
.pgaw:VisualQuery.c create line [expr $x2-10] $y2 $x2 $y2 -tags [subst {links lkid$i}] -width 3
.pgaw:VisualQuery.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]
.pgaw:VisualQuery.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]
.pgaw:VisualQuery.c create line $x2 $y2 [expr $x2+10] $y2 -width 3 -tags [subst {links lkid$i}]
.pgaw:VisualQuery.c create line [expr $x1-10] $y1 [expr $x2+10] $y2 -tags [subst {links lkid$i}] -width 2
}
incr i
}
.pgaw:VisualQuery.c lower links
.pgaw:VisualQuery.c bind links <Button-1> {VisualQueryBuilder::linkClick %x %y}
}
proc {repaintAll} {} {
global PgAcVar
variable vqb
.pgaw:VisualQuery.c delete all
set posx 20
foreach tn [array names vqb tablename*] {
regsub tablename $tn "" it
drawTable $it
}
.pgaw:VisualQuery.c lower rect
.pgaw:VisualQuery.c create line 0 $vqb(yoffs) 10000 $vqb(yoffs) -width 3
.pgaw:VisualQuery.c create rectangle 0 $vqb(yoffs) 10000 5000 -fill #FFFFFF
for {set i [expr 15+$vqb(yoffs)]} {$i<500} {incr i 15} {
.pgaw:VisualQuery.c create line $vqb(xoffs) $i 10000 $i -fill #CCCCCC -tags {resgrid}
}
for {set i $vqb(xoffs)} {$i<10000} {incr i $vqb(reswidth)} {
.pgaw:VisualQuery.c create line $i [expr 1+$vqb(yoffs)] $i 10000 -fill #cccccc -tags {resgrid}
}
# Make a marker for result panel offset calculations (due to panning)
.pgaw:VisualQuery.c create line $vqb(xoffs) $vqb(yoffs) $vqb(xoffs) 500 -tags {resmarker resgrid}
.pgaw:VisualQuery.c create rectangle 0 $vqb(yoffs) $vqb(xoffs) 5000 -fill #EEEEEE -tags {reshdr}
.pgaw:VisualQuery.c create text 5 [expr 1+$vqb(yoffs)] -text [intlmsg Field] -anchor nw -font $PgAcVar(pref,font_normal) -tags {reshdr}
.pgaw:VisualQuery.c create text 5 [expr 16+$vqb(yoffs)] -text [intlmsg Table] -anchor nw -font $PgAcVar(pref,font_normal) -tags {reshdr}
.pgaw:VisualQuery.c create text 5 [expr 31+$vqb(yoffs)] -text [intlmsg Sort] -anchor nw -font $PgAcVar(pref,font_normal) -tags {reshdr}
.pgaw:VisualQuery.c create text 5 [expr 46+$vqb(yoffs)] -text [intlmsg Criteria] -anchor nw -font $PgAcVar(pref,font_normal) -tags {reshdr}
.pgaw:VisualQuery.c create text 5 [expr 61+$vqb(yoffs)] -text [intlmsg Return] -anchor nw -font $PgAcVar(pref,font_normal) -tags {reshdr}
drawLinks
drawResultPanel
.pgaw:VisualQuery.c bind mov <Button-1> {VisualQueryBuilder::dragStart %W %x %y}
.pgaw:VisualQuery.c bind mov <B1-Motion> {VisualQueryBuilder::dragObject %W %x %y}
bind .pgaw:VisualQuery <ButtonRelease-1> {VisualQueryBuilder::dragStop %x %y}
bind .pgaw:VisualQuery <Button-1> {VisualQueryBuilder::canvasClick %x %y %W}
bind .pgaw:VisualQuery <B1-Motion> {VisualQueryBuilder::panning %x %y}
bind .pgaw:VisualQuery <Key-Delete> {VisualQueryBuilder::deleteObject}
}
proc {drawResultPanel} {} {
global PgAcVar
variable vqb
# Compute the offset of the result panel due to panning
set resoffset [expr [lindex [.pgaw:VisualQuery.c bbox resmarker] 0]-$vqb(xoffs)]
.pgaw:VisualQuery.c delete resp
for {set i 0} {$i<[llength $vqb(resfields)]} {incr i} {
.pgaw:VisualQuery.c create text [expr $resoffset+4+$vqb(xoffs)+$i*$vqb(reswidth)] [expr 1+$vqb(yoffs)] -text [lindex $vqb(resfields) $i] -anchor nw -tags [subst {resf resp col$i}] -font $PgAcVar(pref,font_normal)
.pgaw:VisualQuery.c create text [expr $resoffset+4+$vqb(xoffs)+$i*$vqb(reswidth)] [expr 16+$vqb(yoffs)] -text $vqb(ali_[lindex $vqb(restables) $i]) -anchor nw -tags {resp rest} -font $PgAcVar(pref,font_normal)
.pgaw:VisualQuery.c create text [expr $resoffset+4+$vqb(xoffs)+$i*$vqb(reswidth)] [expr 31+$vqb(yoffs)] -text [lindex $vqb(ressort) $i] -anchor nw -tags {resp sort} -font $PgAcVar(pref,font_normal)
if {[lindex $vqb(rescriteria) $i]!=""} {
.pgaw:VisualQuery.c create text [expr $resoffset+4+$vqb(xoffs)+$i*$vqb(reswidth)] [expr $vqb(yoffs)+46+15*0] -anchor nw -text [lindex $vqb(rescriteria) $i] -font $PgAcVar(pref,font_normal) -tags [subst {resp cr-c$i-r0}]
}
.pgaw:VisualQuery.c create text [expr $resoffset+4+$vqb(xoffs)+$i*$vqb(reswidth)] [expr 61+$vqb(yoffs)] -text [lindex $vqb(resreturn) $i] -anchor nw -tags {resp retval} -font $PgAcVar(pref,font_normal)
}
.pgaw:VisualQuery.c raise reshdr
.pgaw:VisualQuery.c bind resf <Button-1> {VisualQueryBuilder::resultFieldClick %x %y}
.pgaw:VisualQuery.c bind sort <Button-1> {VisualQueryBuilder::toggleSortMode %W %x %y}
.pgaw:VisualQuery.c bind retval <Button-1> {VisualQueryBuilder::toggleReturn %W %x %y}
}
proc {drawTable} {it} {
global PgAcVar
variable vqb
if {$vqb(tablex$it)==0} {
set posy 10
set allbox [.pgaw:VisualQuery.c bbox rect]
if {$allbox==""} {set posx 10} else {set posx [expr 20+[lindex $allbox 2]]}
set vqb(tablex$it) $posx
set vqb(tabley$it) $posy
} else {
set posx [expr int($vqb(tablex$it))]
set posy [expr int($vqb(tabley$it))]
}
set tablename $vqb(tablename$it)
set tablealias $vqb(tablealias$it)
.pgaw:VisualQuery.c create text $posx $posy -text "$tablename" -anchor nw -tags [subst {tab$tablealias f-oid mov tableheader}] -font $PgAcVar(pref,font_bold)
incr posy 16
foreach fld $vqb(tablestruct$it) {
.pgaw:VisualQuery.c create text $posx $posy -text $fld -fill #010101 -anchor nw -tags [subst {f-$fld tab$tablealias mov}] -font $PgAcVar(pref,font_normal)
incr posy 14
}
set reg [.pgaw:VisualQuery.c bbox tab$tablealias]
.pgaw:VisualQuery.c create rectangle [lindex $reg 0] [lindex $reg 1] [lindex $reg 2] [lindex $reg 3] -fill #EEEEEE -tags [subst {rect outer tab$tablealias}]
.pgaw:VisualQuery.c create line [lindex $reg 0] [expr [lindex $reg 1]+15] [lindex $reg 2] [expr [lindex $reg 1]+15] -tags [subst {rect tab$tablealias}]
.pgaw:VisualQuery.c lower tab$tablealias
.pgaw:VisualQuery.c lower rect
}
proc {getTagInfo} {obj prefix} {
variable vqb
set taglist [.pgaw:VisualQuery.c gettags $obj]
set tagpos [lsearch -regexp $taglist "^$prefix"]
if {$tagpos==-1} {return ""}
set thattag [lindex $taglist $tagpos]
return [string range $thattag [string length $prefix] end]
}
proc {init} {} {
global PgAcVar
variable vqb
catch { unset vqb }
set vqb(yoffs) 360
set vqb(xoffs) 50
set vqb(reswidth) 150
set vqb(resfields) {}
set vqb(resreturn) {}
set vqb(ressort) {}
set vqb(rescriteria) {}
set vqb(restables) {}
set vqb(critedit) 0
set vqb(links) {}
set vqb(ntables) 0
set vqb(newtablename) {}
}
proc {linkClick} {x y} {
global PgAcVar
variable vqb
set obj [.pgaw:VisualQuery.c find closest $x $y 1 links]
if {[getTagInfo $obj link]!="s"} return
.pgaw:VisualQuery.c itemconfigure [.pgaw:VisualQuery.c find withtag hili] -fill black
.pgaw:VisualQuery.c dtag [.pgaw:VisualQuery.c find withtag hili] hili
.pgaw:VisualQuery.c addtag hili withtag $obj
.pgaw:VisualQuery.c itemconfigure $obj -fill blue
}
proc {panning} {x y} {
global PgAcVar
variable vqb
set panstarted 0
catch {set panstarted $vqb(panstarted) }
if {!$panstarted} return
set dx [expr $x-$vqb(panstartx)]
set dy [expr $y-$vqb(panstarty)]
set vqb(panstartx) $x
set vqb(panstarty) $y
if {$vqb(panobject)=="tables"} {
.pgaw:VisualQuery.c move mov $dx $dy
.pgaw:VisualQuery.c move links $dx $dy
.pgaw:VisualQuery.c move rect $dx $dy
} else {
.pgaw:VisualQuery.c move resp $dx 0
.pgaw:VisualQuery.c move resgrid $dx 0
.pgaw:VisualQuery.c raise reshdr
}
}
proc {resultFieldClick} {x y} {
global PgAcVar
variable vqb
set obj [.pgaw:VisualQuery.c find closest $x $y]
if {[getTagInfo $obj res]!="f"} return
.pgaw:VisualQuery.c itemconfigure [.pgaw:VisualQuery.c find withtag hili] -fill black
.pgaw:VisualQuery.c dtag [.pgaw:VisualQuery.c find withtag hili] hili
.pgaw:VisualQuery.c addtag hili withtag $obj
.pgaw:VisualQuery.c itemconfigure $obj -fill blue
}
proc {showSQL} {} {
global PgAcVar
variable vqb
set sqlcmd [computeSQL]
.pgaw:VisualQuery.c delete sqlpage
.pgaw:VisualQuery.c create rectangle 0 0 2000 [expr $vqb(yoffs)-1] -fill #ffffff -tags {sqlpage}
.pgaw:VisualQuery.c create text 10 10 -text $sqlcmd -anchor nw -width 550 -tags {sqlpage} -font $PgAcVar(pref,font_normal)
.pgaw:VisualQuery.c bind sqlpage <Button-1> {.pgaw:VisualQuery.c delete sqlpage}
}
proc {toggleSortMode} {w x y} {
global PgAcVar
variable vqb
set obj [$w find closest $x $y]
set taglist [.pgaw:VisualQuery.c gettags $obj]
if {[lsearch $taglist sort]==-1} return
set how [.pgaw:VisualQuery.c itemcget $obj -text]
if {$how=="unsorted"} {
set how Ascending
} elseif {$how=="Ascending"} {
set how Descending
} else {
set how unsorted
}
set col [expr int(($x-$vqb(xoffs))/$vqb(reswidth))]
set vqb(ressort) [lreplace $vqb(ressort) $col $col $how]
.pgaw:VisualQuery.c itemconfigure $obj -text $how
}
#rjr 8Mar1999 toggle logical return state for result
proc {toggleReturn} {w x y} {
global PgAcVar
variable vqb
set obj [$w find closest $x $y]
set taglist [.pgaw:VisualQuery.c gettags $obj]
if {[lsearch $taglist retval]==-1} return
set how [.pgaw:VisualQuery.c itemcget $obj -text]
if {$how==[intlmsg Yes]} {
set how [intlmsg No]
} else {
set how [intlmsg Yes]
}
set col [expr int(($x-$vqb(xoffs))/$vqb(reswidth))]
set vqb(resreturn) [lreplace $vqb(resreturn) $col $col $how]
.pgaw:VisualQuery.c itemconfigure $obj -text $how
}
proc {canvasClick} {x y w} {
global PgAcVar
variable vqb
set vqb(panstarted) 0
if {$w==".pgaw:VisualQuery.c"} {
set canpan 1
if {$y<$vqb(yoffs)} {
if {[llength [.pgaw:VisualQuery.c find overlapping $x $y $x $y]]!=0} {set canpan 0}
set vqb(panobject) tables
} else {
set vqb(panobject) result
}
if {$canpan} {
.pgaw:VisualQuery configure -cursor hand1
set vqb(panstartx) $x
set vqb(panstarty) $y
set vqb(panstarted) 1
}
}
set isedit 0
catch {set isedit $vqb(critedit)}
# Compute the offset of the result panel due to panning
set resoffset [expr [lindex [.pgaw:VisualQuery.c bbox resmarker] 0]-$vqb(xoffs)]
if {$isedit} {
set vqb(rescriteria) [lreplace $vqb(rescriteria) $vqb(critcol) $vqb(critcol) $vqb(critval)]
.pgaw:VisualQuery.c delete cr-c$vqb(critcol)-r$vqb(critrow)
.pgaw:VisualQuery.c create text [expr $resoffset+4+$vqb(xoffs)+$vqb(critcol)*$vqb(reswidth)] [expr $vqb(yoffs)+46+15*$vqb(critrow)] -anchor nw -text $vqb(critval) -font $PgAcVar(pref,font_normal) -tags [subst {resp cr-c$vqb(critcol)-r$vqb(critrow)}]
set vqb(critedit) 0
}
catch {destroy .pgaw:VisualQuery.entc}
if {$y<[expr $vqb(yoffs)+46]} return
if {$x<[expr $vqb(xoffs)+5]} return
set col [expr int(($x-$vqb(xoffs)-$resoffset)/$vqb(reswidth))]
if {$col>=[llength $vqb(resfields)]} return
set nx [expr $col*$vqb(reswidth)+8+$vqb(xoffs)+$resoffset]
set ny [expr $vqb(yoffs)+76]
# Get the old criteria value
set vqb(critval) [lindex $vqb(rescriteria) $col]
entry .pgaw:VisualQuery.entc -textvar VisualQueryBuilder::vqb(critval) -borderwidth 0 -background #FFFFFF -highlightthickness 0 -selectborderwidth 0 -font $PgAcVar(pref,font_normal)
place .pgaw:VisualQuery.entc -x $nx -y $ny -height 14
focus .pgaw:VisualQuery.entc
bind .pgaw:VisualQuery.entc <Button-1> {set VisualQueryBuilder::vqb(panstarted) 0}
set vqb(critcol) $col
set vqb(critrow) 0
set vqb(critedit) 1
}
proc {saveToQueryBuilder} {} {
global PgAcVar
variable vqb
Window show .pgaw:QueryBuilder
.pgaw:QueryBuilder.text1 delete 1.0 end
set vqb(qcmd) [computeSQL]
set PgAcVar(query,tables) [getTableList]
set PgAcVar(query,links) [getLinkList]
set PgAcVar(query,results) [getResultList]
.pgaw:QueryBuilder.text1 insert end $vqb(qcmd)
focus .pgaw:QueryBuilder
}
proc {executeSQL} {} {
global PgAcVar
variable vqb
set vqb(qcmd) [computeSQL]
set wn [Tables::getNewWindowName]
set PgAcVar(mw,$wn,query) [subst $vqb(qcmd)]
set PgAcVar(mw,$wn,updatable) 0
set PgAcVar(mw,$wn,isaquery) 1
Tables::createWindow
Tables::loadLayout $wn nolayoutneeded
Tables::selectRecords $wn $PgAcVar(mw,$wn,query)
}
proc {createDropDown} {} {
global PgAcVar
variable vqb
if {[winfo exists .pgaw:VisualQuery.ddf]} {
destroy .pgaw:VisualQuery.ddf
} else {
create_drop_down .pgaw:VisualQuery 70 27 200
focus .pgaw:VisualQuery.ddf.sb
foreach tbl [Database::getTablesList] {.pgaw:VisualQuery.ddf.lb insert end $tbl}
bind .pgaw:VisualQuery.ddf.lb <ButtonRelease-1> {
set i [.pgaw:VisualQuery.ddf.lb curselection]
if {$i!=""} {
set VisualQueryBuilder::vqb(newtablename) [.pgaw:VisualQuery.ddf.lb get $i]
VisualQueryBuilder::addNewTable
}
destroy .pgaw:VisualQuery.ddf
break
}
}
}
}
proc vTclWindow.pgaw:VisualQuery {base} {
global PgAcVar
if {$base == ""} {
set base .pgaw:VisualQuery
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
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 [intlmsg "Visual query designer"]
bind $base <B1-Motion> {
VisualQueryBuilder::panning %x %y
}
bind $base <Button-1> {
VisualQueryBuilder::canvasClick %x %y %W
}
bind $base <ButtonRelease-1> {
VisualQueryBuilder::dragStop %x %y
}
bind $base <Key-Delete> {
VisualQueryBuilder::deleteObject
}
bind $base <Key-F1> "Help::load visual_designer"
canvas $base.c -background #fefefe -borderwidth 2 -height 207 -relief ridge -takefocus 0 -width 295
frame $base.fb -height 75 -width 125
label $base.fb.l12 -borderwidth 0 -text "[intlmsg {Add table}] "
entry $base.fb.entt -background #fefefe -borderwidth 1 -highlightthickness 1 \
-selectborderwidth 0 -textvariable VisualQueryBuilder::vqb(newtablename)
bind $base.fb.entt <Key-Return> {
VisualQueryBuilder::addNewTable
}
button $base.fb.bdd -borderwidth 1 \
-command VisualQueryBuilder::createDropDown -image dnarw
button $base.fb.showbtn \
-command VisualQueryBuilder::showSQL \
-text [intlmsg {Show SQL}]
button $base.fb.execbtn \
-command VisualQueryBuilder::executeSQL \
-text [intlmsg {Execute SQL}]
button $base.fb.stoqb \
-command VisualQueryBuilder::saveToQueryBuilder \
-text [intlmsg {Save to query builder}]
button $base.fb.exitbtn \
-command {Window destroy .pgaw:VisualQuery} \
-text [intlmsg Close]
place $base.c -x 5 -y 30 -width 750 -height 500 -anchor nw -bordermode ignore
place $base.fb \
-x 5 -y 0 -width 753 -height 31 -anchor nw -bordermode ignore
pack $base.fb.l12 \
-in .pgaw:VisualQuery.fb -anchor center -expand 0 -fill none -side left
pack $base.fb.entt \
-in .pgaw:VisualQuery.fb -anchor center -expand 0 -fill none -side left
pack $base.fb.bdd \
-in .pgaw:VisualQuery.fb -anchor center -expand 0 -fill none -side left
pack $base.fb.exitbtn \
-in .pgaw:VisualQuery.fb -anchor center -expand 0 -fill none -side right
pack $base.fb.stoqb \
-in .pgaw:VisualQuery.fb -anchor center -expand 0 -fill none -side right
pack $base.fb.execbtn \
-in .pgaw:VisualQuery.fb -anchor center -expand 0 -fill none -side right
pack $base.fb.showbtn \
-in .pgaw:VisualQuery.fb -anchor center -expand 0 -fill none -side right
}
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment