Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Support
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
P
Postgres FD Implementation
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
0
Issues
0
List
Boards
Labels
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Abuhujair Javed
Postgres FD Implementation
Commits
cd9b34ed
Commit
cd9b34ed
authored
Aug 30, 1998
by
Bruce Momjian
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Add missing pgaccess file.
parent
e875dfb8
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
529 additions
and
0 deletions
+529
-0
src/bin/pgaccess/qbtclet.tcl
src/bin/pgaccess/qbtclet.tcl
+529
-0
No files found.
src/bin/pgaccess/qbtclet.tcl
0 → 100644
View file @
cd9b34ed
#################################
# GLOBAL VARIABLES
#
global qlvar
;
global widget
;
#################################
# USER DEFINED PROCEDURES
#
proc init
{
argc argv
}
{
global qlvar
set qlvar
(
yoffs
)
360
set qlvar
(
xoffs
)
50
set qlvar
(
reswidth
)
150
}
init $argc $argv
proc main
{
argc argv
}
{
}
proc show_message
{
usrmsg
}
{
global msg
set msg $usrmsg
after 2000
{
set msg
{}}
}
proc ql_delete_object
{}
{
global qlvar
# Checking if there
set obj
[
.c find withtag hili
]
if
{
$obj
==
""
}
return
if
{[
ql_get_tag_info $obj link
]
==
"s"
}
{
# if
{[
tk_messageBox -title WARNING -icon question -message
"Remove link ?"
-type yesno -default no
]
==
"no"
}
return
show_message
"Deleting the link from tables ..."
set linkid
[
ql_get_tag_info $obj lkid
]
set qlvar
(
links
)
[
lreplace $qlvar
(
links
)
$linkid $linkid
]
.c delete links
ql_draw_links
}
else
{
set tablename
[
ql_get_tag_info $obj tab
]
if
{
$tablename
==
""
}
return
# if
{[
tk_messageBox -title WARNING -icon question -message
"Remove table
$tablename
from query ?"
-type yesno -default no
]
==
"no"
}
return
show_message
"Deleting table from query ..."
for
{
set i
[
expr
[
llength $qlvar
(
restables
)]
-1
]}
{
$i
>=0
}
{
incr i -1
}
{
if
{
$tablename
==
[
lindex $qlvar
(
restables
)
$i
]}
{
set qlvar
(
resfields
)
[
lreplace $qlvar
(
resfields
)
$i $i
]
set qlvar
(
restables
)
[
lreplace $qlvar
(
restables
)
$i $i
]
set qlvar
(
rescriteria
)
[
lreplace $qlvar
(
rescriteria
)
$i $i
]
}
}
for
{
set i
[
expr
[
llength $qlvar
(
links
)]
-1
]}
{
$i
>=0
}
{
incr i -1
}
{
set thelink
[
lindex $qlvar
(
links
)
$i
]
if
{(
$tablename
==
[
lindex $thelink 0
])
||
(
$tablename
==
[
lindex $thelink 2
])}
{
set qlvar
(
links
)
[
lreplace $qlvar
(
links
)
$i $i
]
}
}
.c delete tab$tablename
.c delete links
ql_draw_links
ql_draw_res_panel
}
}
proc ql_dragit
{
w x y
}
{
global draginfo
if
{
"
$draginfo
(obj)"
!=
""
}
{
set dx
[
expr $x - $draginfo
(
x
)]
set dy
[
expr $y - $draginfo
(
y
)]
if
{
$draginfo
(
is_a_table
)}
{
set taglist
[
.c gettags $draginfo
(
obj
)]
set tabletag
[
lindex $taglist
[
lsearch -regexp $taglist
"^tab"
]]
$w move $tabletag $dx $dy
ql_draw_links
}
else
{
$w move $draginfo
(
obj
)
$dx $dy
}
set draginfo
(
x
)
$x
set draginfo
(
y
)
$y
}
}
proc ql_dragstart
{
w x y
}
{
global draginfo
catch
{
unset draginfo
}
set draginfo
(
obj
)
[
$w
find closest $x $y
]
if
{[
ql_get_tag_info $draginfo
(
obj
)
r
]
==
"ect"
}
{
# If it'a a rectangle, exit
set draginfo
(
obj
)
{}
return
}
. configure -cursor hand1
.c raise $draginfo
(
obj
)
set draginfo
(
table
)
0
if
{[
ql_get_tag_info $draginfo
(
obj
)
table
]
==
"header"
}
{
set draginfo
(
is_a_table
)
1
.c itemconfigure
[
.c find withtag hili
]
-fill black
.c dtag
[
.c find withtag hili
]
hili
.c addtag hili withtag $draginfo
(
obj
)
.c itemconfigure hili -fill blue
}
else
{
set draginfo
(
is_a_table
)
0
}
set draginfo
(
x
)
$x
set draginfo
(
y
)
$y
set draginfo
(
sx
)
$x
set draginfo
(
sy
)
$y
}
proc ql_dragstop
{
x y
}
{
global draginfo qlvar
. configure -cursor top_left_arrow
set este
{}
catch
{
set este $draginfo
(
obj
)}
if
{
$este
==
""
}
return
# Re-establish the normal paint order so
# information won't be overlapped by table rectangles
# or link linkes
.c lower $draginfo
(
obj
)
.c lower rect
.c lower links
set qlvar
(
panstarted
)
0
if
{
$draginfo
(
is_a_table
)}
{
set draginfo
(
obj
)
{}
.c delete links
ql_draw_links
return
}
.c move $draginfo
(
obj
)
[
expr $draginfo
(
sx
)
-$x
]
[
expr $draginfo
(
sy
)
-$y
]
if
{(
$y
>$qlvar
(
yoffs
))
&&
(
$x
>$qlvar
(
xoffs
))}
{
# Drop position : inside the result panel
# Compute the offset of the result panel due to panning
set resoffset
[
expr
[
lindex
[
.c bbox resmarker
]
0
]
-$qlvar
(
xoffs
)]
set newfld
[
.c itemcget $draginfo
(
obj
)
-text
]
set tabtag
[
ql_get_tag_info $draginfo
(
obj
)
tab
]
set col
[
expr int
((
$x-$qlvar
(
xoffs
)
-$resoffset
)
/$qlvar
(
reswidth
))]
set qlvar
(
resfields
)
[
linsert $qlvar
(
resfields
)
$col $newfld
]
set qlvar
(
ressort
)
[
linsert $qlvar
(
ressort
)
$col unsorted
]
set qlvar
(
rescriteria
)
[
linsert $qlvar
(
rescriteria
)
$col
{}]
set qlvar
(
restables
)
[
linsert $qlvar
(
restables
)
$col $tabtag
]
ql_draw_res_panel
}
else
{
# Drop position : in the table panel
set droptarget
[
.c find overlapping $x $y $x $y
]
set targettable
{}
foreach item $droptarget
{
set targettable
[
ql_get_tag_info $item tab
]
set targetfield
[
ql_get_tag_info $item f-
]
if
{(
$targettable
!=
""
)
&&
(
$targetfield
!=
""
)}
{
set droptarget $item
break
}
}
# check if target object isn't a rectangle
if
{[
ql_get_tag_info $droptarget rec
]
==
"t"
}
{
set targettable
{}}
if
{
$targettable
!=
""
}
{
# Target has a table
# See about originate table
set sourcetable
[
ql_get_tag_info $draginfo
(
obj
)
tab
]
if
{
$sourcetable
!=
""
}
{
# Source has also a tab .. tag
set sourcefield
[
ql_get_tag_info $draginfo
(
obj
)
f-
]
if
{
$sourcetable
!=$targettable
}
{
lappend qlvar
(
links
)
[
list $sourcetable $sourcefield $targettable $targetfield $draginfo
(
obj
)
$droptarget
]
ql_draw_links
}
}
}
}
# Erase information about onbject beeing dragged
set draginfo
(
obj
)
{}
}
proc ql_draw_links
{}
{
global qlvar
.c delete links
set i 0
foreach link $qlvar
(
links
)
{
# Compute the source and destination right edge
set sre
[
lindex
[
.c bbox tab
[
lindex $link 0
]]
2
]
set dre
[
lindex
[
.c bbox tab
[
lindex $link 2
]]
2
]
# Compute field bound boxes
set sbbox
[
.c bbox
[
lindex $link 4
]]
set dbbox
[
.c bbox
[
lindex $link 5
]]
# Compute the auxiliary lines
if
{[
lindex $sbbox 2
]
<
[
lindex $dbbox 0
]}
{
# Source object is on the left of target object
set x1 $sre
set y1
[
expr
([
lindex $sbbox 1
]
+
[
lindex $sbbox 3
])
/2
]
.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
]
.c create line
[
expr $x2-10
]
$y2 $x2 $y2 -tags
{
links
}
-width 3
.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
]
.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
]
.c create line $x2 $y2
[
expr $x2+10
]
$y2 -width 3 -tags
[
subst
{
links lkid$i
}]
.c create line
[
expr $x1-10
]
$y1
[
expr $x2+10
]
$y2 -tags
[
subst
{
links lkid$i
}]
-width 2
}
incr i
}
.c lower links
.c bind links <Button-1>
{
ql_link_click %x %y
}
}
proc ql_draw_lizzard
{}
{
global qlvar
ql_read_struct
.c delete all
set posx 20
for
{
set it 0
}
{
$it
<$qlvar
(
ntables
)}
{
incr it
}
{
ql_draw_table $it
# set posy 10
# set tablename $qlvar
(
tablename$it
)
# .c create text $posx $posy -text $tablename -anchor nw -tags
[
subst
{
tab$tablename f-oid mov tableheader
}]
-font -Adobe-Helvetica-Bold-R-Normal-*-*-120-*-*-*-*-*
# incr posy 16
# foreach fld $qlvar
(
tablestruct$it
)
{
# .c create text $posx $posy -text $fld -anchor nw -tags
[
subst
{
f-$fld tab$tablename mov
}]
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*
# incr posy 14
#
}
# set reg
[
.c bbox tab$tablename
]
# .c create rectangle
[
lindex $reg 0
]
[
lindex $reg 1
]
[
lindex $reg 2
]
[
lindex $reg 3
]
-fill #EEEEEE -tags
[
subst
{
rect tab$tablename
}]
# .c create line
[
lindex $reg 0
]
[
expr
[
lindex $reg 1
]
+15
]
[
lindex $reg 2
]
[
expr
[
lindex $reg 1
]
+15
]
-tags
[
subst
{
rect tab$tablename
}]
# set posx
[
expr $posx+40+
[
lindex $reg 2
]
-
[
lindex $reg 0
]]
}
.c lower rect
.c create line 0 $qlvar
(
yoffs
)
10000 $qlvar
(
yoffs
)
-width 3
.c create rectangle 0 $qlvar
(
yoffs
)
10000 5000 -fill #FFFFFF
for
{
set i
[
expr 15+$qlvar
(
yoffs
)]}
{
$i
<500
}
{
incr i 15
}
{
.c create line $qlvar
(
xoffs
)
$i 10000 $i -fill #CCCCCC -tags
{
resgrid
}
}
for
{
set i $qlvar
(
xoffs
)}
{
$i
<10000
}
{
incr i $qlvar
(
reswidth
)}
{
.c create line $i
[
expr 1+$qlvar
(
yoffs
)]
$i 10000 -fill #cccccc -tags
{
resgrid
}
}
# Make a marker for result panel offset calculations
(
due to panning
)
.c create line $qlvar
(
xoffs
)
$qlvar
(
yoffs
)
$qlvar
(
xoffs
)
500 -tags
{
resmarker resgrid
}
.c create rectangle 0 $qlvar
(
yoffs
)
$qlvar
(
xoffs
)
5000 -fill #EEEEEE -tags
{
reshdr
}
.c create text 5
[
expr 1+$qlvar
(
yoffs
)]
-text Field: -anchor nw -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags
{
reshdr
}
.c create text 5
[
expr 16+$qlvar
(
yoffs
)]
-text Table: -anchor nw -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags
{
reshdr
}
.c create text 5
[
expr 31+$qlvar
(
yoffs
)]
-text Sort: -anchor nw -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags
{
reshdr
}
.c create text 5
[
expr 46+$qlvar
(
yoffs
)]
-text Criteria: -anchor nw -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags
{
reshdr
}
.c bind mov <Button-1>
{
ql_dragstart %W %x %y
}
.c bind mov <B1-Motion>
{
ql_dragit %W %x %y
}
bind . <ButtonRelease-1>
{
ql_dragstop %x %y
}
bind . <Button-1>
{
qlc_click %x %y %W
}
bind . <B1-Motion>
{
ql_pan %x %y
}
bind . <Key-Delete>
{
ql_delete_object
}
set qlvar
(
resfields
)
{}
set qlvar
(
ressort
)
{}
set qlvar
(
rescriteria
)
{}
set qlvar
(
restables
)
{}
set qlvar
(
critedit
)
0
set qlvar
(
links
)
{}
set qlvar
(
linktodelete
)
{}
}
proc ql_draw_res_panel
{}
{
global qlvar
# Compute the offset of the result panel due to panning
set resoffset
[
expr
[
lindex
[
.c bbox resmarker
]
0
]
-$qlvar
(
xoffs
)]
.c delete resp
for
{
set i 0
}
{
$i
<
[
llength $qlvar
(
resfields
)]}
{
incr i
}
{
.c create text
[
expr $resoffset+4+$qlvar
(
xoffs
)
+$i*$qlvar
(
reswidth
)]
[
expr 1+$qlvar
(
yoffs
)]
-text
[
lindex $qlvar
(
resfields
)
$i
]
-anchor nw -fill navy -tags
{
resf resp
}
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*
.c create text
[
expr $resoffset+4+$qlvar
(
xoffs
)
+$i*$qlvar
(
reswidth
)]
[
expr 16+$qlvar
(
yoffs
)]
-text
[
lindex $qlvar
(
restables
)
$i
]
-anchor nw -tags
{
resp rest
}
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*
.c create text
[
expr $resoffset+4+$qlvar
(
xoffs
)
+$i*$qlvar
(
reswidth
)]
[
expr 31+$qlvar
(
yoffs
)]
-text
[
lindex $qlvar
(
ressort
)
$i
]
-anchor nw -tags
{
resp sort
}
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*
if
{[
lindex $qlvar
(
rescriteria
)
$i
]
!=
""
}
{
.c create text
[
expr $resoffset+4+$qlvar
(
xoffs
)
+$i*$qlvar
(
reswidth
)]
[
expr $qlvar
(
yoffs
)
+46+15*0
]
-anchor nw -text
[
lindex $qlvar
(
rescriteria
)
$i
]
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags
[
subst
{
resp cr-c$i-r0
}]
}
}
.c raise reshdr
.c bind sort <Button-1>
{
ql_swap_sort %W %x %y
}
}
proc ql_draw_table
{
it
}
{
global qlvar
set posy 10
set allbox
[
.c bbox rect
]
if
{
$allbox
==
""
}
{
set posx 10
}
else
{
set posx
[
expr 20+
[
lindex $allbox 2
]]}
set tablename $qlvar
(
tablename$it
)
.c create text $posx $posy -text $tablename -anchor nw -tags
[
subst
{
tab$tablename f-oid mov tableheader
}]
-font -Adobe-Helvetica-Bold-R-Normal-*-*-120-*-*-*-*-*
incr posy 16
foreach fld $qlvar
(
tablestruct$it
)
{
.c create text $posx $posy -text $fld -anchor nw -tags
[
subst
{
f-$fld tab$tablename mov
}]
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*
incr posy 14
}
set reg
[
.c bbox tab$tablename
]
.c create rectangle
[
lindex $reg 0
]
[
lindex $reg 1
]
[
lindex $reg 2
]
[
lindex $reg 3
]
-fill #EEEEEE -tags
[
subst
{
rect tab$tablename
}]
.c create line
[
lindex $reg 0
]
[
expr
[
lindex $reg 1
]
+15
]
[
lindex $reg 2
]
[
expr
[
lindex $reg 1
]
+15
]
-tags
[
subst
{
rect tab$tablename
}]
}
proc ql_get_tag_info
{
obj prefix
}
{
set taglist
[
.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 ql_link_click
{
x y
}
{
global qlvar
set obj
[
.c find closest $x $y 1 links
]
if
{[
ql_get_tag_info $obj link
]
!=
"s"
}
return
.c itemconfigure
[
.c find withtag hili
]
-fill black
.c dtag
[
.c find withtag hili
]
hili
.c addtag hili withtag $obj
.c itemconfigure $obj -fill blue
}
proc ql_pan
{
x y
}
{
global qlvar
set panstarted 0
catch
{
set panstarted $qlvar
(
panstarted
)
}
if
{
!$panstarted
}
return
set dx
[
expr $x-$qlvar
(
panstartx
)]
set dy
[
expr $y-$qlvar
(
panstarty
)]
set qlvar
(
panstartx
)
$x
set qlvar
(
panstarty
)
$y
if
{
$qlvar
(
panobject
)
==
"tables"
}
{
.c move mov $dx $dy
.c move links $dx $dy
.c move rect $dx $dy
}
else
{
.c move resp $dx 0
.c move resgrid $dx 0
.c raise reshdr
}
}
proc ql_read_struct
{}
{
global qlvar
set qlvar
(
ntables
)
3
set qlvar
(
tablename0
)
Facturi
set qlvar
(
tablename1
)
Nommat
set qlvar
(
tablename2
)
Incasari
set qlvar
(
tablestruct0
)
[
list factura client valoare tva
]
set qlvar
(
tablestruct1
)
[
list cod denumire pret greutate procent_tva
]
set qlvar
(
tablestruct2
)
[
list data valoare nrdoc referinta
]
}
proc ql_show_sql
{}
{
global qlvar
set sqlcmd
"select "
for
{
set i 0
}
{
$i
<
[
llength $qlvar
(
resfields
)]}
{
incr i
}
{
if
{
$sqlcmd
!=
"select "
}
{
set sqlcmd
"
$sqlcmd
, "
}
set sqlcmd
"
$sqlcmd
[
lindex $qlvar
(
restables
)
$i
]
.
[
lindex $qlvar
(
resfields
)
$i
]
"
}
set tables
{}
for
{
set i 0
}
{
$i
<$qlvar
(
ntables
)}
{
incr i
}
{
lappend tables $qlvar
(
tablename$i
)
}
set sqlcmd
"
$sqlcmd
from
[
join $tables ,
]
"
set sup1
{}
if
{[
llength $qlvar
(
links
)]
>0
}
{
set sup1
"where "
foreach link $qlvar
(
links
)
{
if
{
$sup1
!=
"where "
}
{
set sup1
"
$sup1
and "
}
set sup1
"
$sup1
(
[
lindex $link 0
]
.
[
lindex $link 1
]
=
[
lindex $link 2
]
.
[
lindex $link 3
]
)"
}
}
for
{
set i 0
}
{
$i
<
[
llength $qlvar
(
resfields
)]}
{
incr i
}
{
set crit
[
lindex $qlvar
(
rescriteria
)
$i
]
if
{
$crit
!=
""
}
{
if
{
$sup1
==
""
}
{
set sup1
"where "
}
if
{[
string range $sup1 0 4
]
==
"where"
}
{
set sup1
"
$sup1
and "
}
set sup1
"
$sup1
(
[
lindex $qlvar
(
restables
)
$i
]
.
[
lindex $qlvar
(
resfields
)
$i
]
$crit
) "
}
}
set sqlcmd
"
$sqlcmd
$sup1
"
set sup2
{}
for
{
set i 0
}
{
$i
<
[
llength $qlvar
(
ressort
)]}
{
incr i
}
{
set how
[
lindex $qlvar
(
ressort
)
$i
]
if
{
$how
!=
"unsorted"
}
{
if
{
$how
==
"Ascending"
}
{
set how asc
}
else
{
set how desc
}
if
{
$sup2
==
""
}
{
set sup2
" order by "
}
else
{
set sup2
"
$sup2
,"
}
set sup2
"
$sup2
[
lindex $qlvar
(
resfields
)
$i
]
$how
"
}
}
set sqlcmd
"
$sqlcmd
$sup2
"
set qlvar
(
sql
)
$sqlcmd
#tk_messageBox -message $sqlcmd
.c delete sqlpage
.c create rectangle 0 0 2000
[
expr $qlvar
(
yoffs
)
-1
]
-fill #ffffff -tags
{
sqlpage
}
.c create text 10 10 -text $sqlcmd -anchor nw -width 550 -tags
{
sqlpage
}
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*
.c bind sqlpage <Button-1>
{
.c delete sqlpage
}
}
proc ql_swap_sort
{
w x y
}
{
global qlvar
set obj
[
$w
find closest $x $y
]
set taglist
[
.c gettags $obj
]
if
{[
lsearch $taglist sort
]
==-1
}
return
set cum
[
.c itemcget $obj -text
]
if
{
$cum
==
"unsorted"
}
{
set cum Ascending
}
elseif
{
$cum
==
"Ascending"
}
{
set cum Descending
}
else
{
set cum unsorted
}
set col
[
expr int
((
$x-$qlvar
(
xoffs
))
/$qlvar
(
reswidth
))]
set qlvar
(
ressort
)
[
lreplace $qlvar
(
ressort
)
$col $col $cum
]
.c itemconfigure $obj -text $cum
}
proc qlc_click
{
x y w
}
{
global qlvar
set qlvar
(
panstarted
)
0
if
{
$w
==
".c"
}
{
set canpan 1
if
{
$y
<$qlvar
(
yoffs
)}
{
if
{[
llength
[
.c find overlapping $x $y $x $y
]]
!=0
}
{
set canpan 0
}
set qlvar
(
panobject
)
tables
}
else
{
set qlvar
(
panobject
)
result
}
if
{
$canpan
}
{
. configure -cursor hand1
set qlvar
(
panstartx
)
$x
set qlvar
(
panstarty
)
$y
set qlvar
(
panstarted
)
1
}
}
set isedit 0
catch
{
set isedit $qlvar
(
critedit
)}
# Compute the offset of the result panel due to panning
set resoffset
[
expr
[
lindex
[
.c bbox resmarker
]
0
]
-$qlvar
(
xoffs
)]
if
{
$isedit
}
{
set qlvar
(
rescriteria
)
[
lreplace $qlvar
(
rescriteria
)
$qlvar
(
critcol
)
$qlvar
(
critcol
)
$qlvar
(
critval
)]
.c delete cr-c$qlvar
(
critcol
)
-r$qlvar
(
critrow
)
.c create text
[
expr $resoffset+4+$qlvar
(
xoffs
)
+$qlvar
(
critcol
)
*$qlvar
(
reswidth
)]
[
expr $qlvar
(
yoffs
)
+46+15*$qlvar
(
critrow
)]
-anchor nw -text $qlvar
(
critval
)
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags
[
subst
{
resp cr-c$qlvar
(
critcol
)
-r$qlvar
(
critrow
)}]
set qlvar
(
critedit
)
0
}
catch
{
destroy .entc
}
if
{
$y
<
[
expr $qlvar
(
yoffs
)
+46
]}
return
if
{
$x
<
[
expr $qlvar
(
xoffs
)
+5
]}
return
set col
[
expr int
((
$x-$qlvar
(
xoffs
)
-$resoffset
)
/$qlvar
(
reswidth
))]
if
{
$col
>=
[
llength $qlvar
(
resfields
)]}
return
set nx
[
expr $col*$qlvar
(
reswidth
)
+8+$qlvar
(
xoffs
)
+$resoffset
]
set ny
[
expr $qlvar
(
yoffs
)
+76
]
# Get the old criteria value
set qlvar
(
critval
)
[
lindex $qlvar
(
rescriteria
)
$col
]
entry .entc -textvar qlvar
(
critval
)
-borderwidth 0 -background #FFFFFF -highlightthickness 0 -selectborderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*
place .entc -x $nx -y $ny -height 14
focus .entc
bind .entc <Button-1>
{
set qlvar
(
panstarted
)
0
}
set qlvar
(
critcol
)
$col
set qlvar
(
critrow
)
0
set qlvar
(
critedit
)
1
}
proc Window
{
args
}
{
global vTcl
set cmd
[
lindex $args 0
]
set name
[
lindex $args 1
]
set newname
[
lindex $args 2
]
set rest
[
lrange $args 3 end
]
if
{
$name
==
""
|| $cmd ==
""
}
{
return
}
if
{
$newname
==
""
}
{
set newname $name
}
set exists
[
winfo exists $newname
]
switch $cmd
{
show
{
if
{
$exists
==
"1"
&& $name !=
"."
}
{
wm deiconify $name
;
return
}
if
{[
info procs vTclWindow
(
pre
)
$name
]
!=
""
}
{
eval
"vTclWindow(pre)
$name
$newname
$rest
"
}
if
{[
info procs vTclWindow$name
]
!=
""
}
{
eval
"vTclWindow
$name
$newname
$rest
"
}
if
{[
info procs vTclWindow
(
post
)
$name
]
!=
""
}
{
eval
"vTclWindow(post)
$name
$newname
$rest
"
}
}
hide
{
if $exists
{
wm withdraw $newname
;
return
}
}
iconify
{
if $exists
{
wm iconify $newname
;
return
}
}
destroy
{
if $exists
{
destroy $newname
;
return
}
}
}
}
set base
""
bind $base <B1-Motion>
{
ql_pan %x %y
}
bind $base <Button-1>
{
qlc_click %x %y %W
}
bind $base <ButtonRelease-1>
{
ql_dragstop %x %y
}
bind $base <Key-Delete>
{
ql_delete_object
}
canvas $base.c
\
-background #fefefe -borderwidth 2 -height 207 -relief ridge
\
-takefocus 0 -width 295
label $base.msg -textvar msg -borderwidth 1 -relief sunken
button $base.b2
\
-borderwidth 1 -command ql_draw_lizzard
\
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9
\
-pady 3 -text
{
Paint demo tables
}
button $base.showbtn
\
-borderwidth 1 -command ql_show_sql
\
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9
\
-pady 3 -text
{
Show SQL
}
###################
# SETTING GEOMETRY
###################
place $base.c
\
-x 5 -y 30 -width 578 -height 425 -anchor nw -bordermode ignore
place $base.b2
\
-x 5 -y 5 -height 26 -anchor nw -bordermode ignore
place $base.showbtn
\
-x 130 -y 5 -height 26 -anchor nw -bordermode ignore
place $base.msg
\
-x 5 -y 460 -width 578 -anchor nw
main $argc $argv
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment