Skip to content

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

Upgrade to 0.91 ...

parent e741937b
Show whitespace changes
Inline Side-by-side
Showing with 2645 additions and 2515 deletions
src/bin/pgaccess/README.pga
View file @ a00c6681
...@@ -22,7 +22,7 @@ PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. ...@@ -22,7 +22,7 @@ PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
--------------------------------------------------------------------------- ---------------------------------------------------------------------------
PGACCESS 0.90 18 September 1998 PGACCESS 0.91 1 November 1998
================================ ================================
I dedicate this program to my little daughters Ana-Maria and Emilia and to my I dedicate this program to my little daughters Ana-Maria and Emilia and to my
wife for their understanding. I hope they will forgive me for spending so many wife for their understanding. I hope they will forgive me for spending so many
......
src/bin/pgaccess/formdemo.sql
View file @ a00c6681
CREATE TABLE pga_queries (queryname varchar(64), querytype char(1), querycommand text); CREATE TABLE "pga_queries" ("queryname" varchar(64), "querytype" char(1), "querycommand" "text");
CREATE TABLE pga_forms (formname varchar(64), formsource text); CREATE TABLE "pga_forms" ("formname" varchar(64), "formsource" "text");
CREATE TABLE pga_scripts (scriptname varchar(64), scriptsource text); CREATE TABLE "pga_scripts" ("scriptname" varchar(64), "scriptsource" "text");
CREATE TABLE pga_reports (reportname varchar(64), reportsource text, reportbody text, reportprocs text, reportoptions text); CREATE TABLE "pga_reports" ("reportname" varchar(64), "reportsource" "text", "reportbody" "text", "reportprocs" "text", "reportoptions" "text");
CREATE TABLE phonebook (name varchar(32), phone_nr varchar(16), city varchar(32), company bool, continent char16); CREATE TABLE "phonebook" ("name" varchar(32), "phone_nr" varchar(16), "city" varchar(32), "company" "bool", "continent" char(16));
CREATE TABLE pga_layout (tablename varchar(64), nrcols int2, colnames text, colwidth text); CREATE TABLE "pga_layout" ("tablename" varchar(64), "nrcols" "int2", "colnames" "text", "colwidth" "text");
COPY pga_queries FROM stdin; COPY "pga_queries" FROM stdin;
Query that can be saved as view S select * from phonebook where continent='usa' Query that can be saved as view S select * from phonebook where continent='usa'
\. \.
COPY pga_forms FROM stdin; COPY "pga_forms" FROM stdin;
A simple demo form asdf 14 {1 2 3 4 5 6 7 8 9 10 11 12 13 14} 377x315+170+155 {label label1 {15 36 99 57} {} {Selected color} {}} {entry entry2 {111 36 225 54} {} entry2 color} {radio red {249 21 342 36} {} {Red as cherry} color} {radio green {249 45 342 60} {} {Green as a melon} color} {radio blue {249 69 342 84} {} {Blue as the sky} color} {button button6 {45 69 198 99} {set color spooky} {Set a weird color} {}} {label label7 {24 129 138 147} {} {The checkbox's value} {}} {entry entry8 {162 129 172 147} {} entry8 cbvalue} {checkbox checkbox9 {180 126 279 150} {} {Check me :-)} cbvalue} {button button10 {219 273 366 303} {destroy .asdf} {Close that simple form} {}} {button button11 {219 237 366 267} {open_form "Phone book"} {Open my phone book} {}} {listbox lb {12 192 162 267} {} listbox12 {}} {button button13 {12 156 162 186} {.asdf.lb insert end red green blue cyan white navy black purple maroon violet} {Add some information} {}} {button button14 {12 273 162 303} {.asdf.lb delete 0 end} {Clear this listbox} {}} A simple demo form asdf 14 {1 2 3 4 5 6 7 8 9 10 11 12 13 14} 377x315+170+155 {label label1 {15 36 99 57} {} {Selected color} {}} {entry entry2 {111 36 225 54} {} entry2 color} {radio red {249 21 342 36} {} {Red as cherry} color} {radio green {249 45 342 60} {} {Green as a melon} color} {radio blue {249 69 342 84} {} {Blue as the sky} color} {button button6 {45 69 198 99} {set color spooky} {Set a weird color} {}} {label label7 {24 129 138 147} {} {The checkbox's value} {}} {entry entry8 {162 129 172 147} {} entry8 cbvalue} {checkbox checkbox9 {180 126 279 150} {} {Check me :-)} cbvalue} {button button10 {219 273 366 303} {destroy .asdf} {Close that simple form} {}} {button button11 {219 237 366 267} {open_form "Phone book"} {Open my phone book} {}} {listbox lb {12 192 162 267} {} listbox12 {}} {button button13 {12 156 162 186} {.asdf.lb insert end red green blue cyan white navy black purple maroon violet} {Add some information} {}} {button button14 {12 273 162 303} {.asdf.lb delete 0 end} {Clear this listbox} {}}
Phone book pb 26 {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26} 444x310+284+246 {label label1 {33 12 63 30} {} Name {}} {entry name_entry {87 9 217 30} {} entry2 pbqs(name)} {label label3 {33 39 73 54} {} Phone {}} {entry entry4 {87 36 195 57} {} entry4 pbqs(phone_nr)} {label label5 {33 66 78 84} {} City {}} {entry entry6 {87 63 195 84} {} entry6 pbqs(city)} {query qs {3 6 33 33} {} query7 {}} {button button8 {126 177 198 203} {.pb.qs:setsql "select oid,* from phonebook where name ~* '$what' order by name"\ Phone book pb 26 {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26} 444x310+284+246 {label label1 {33 12 63 30} {} Name {}} {entry name_entry {87 9 217 30} {} entry2 pbqs(name)} {label label3 {33 39 73 54} {} Phone {}} {entry entry4 {87 36 195 57} {} entry4 pbqs(phone_nr)} {label label5 {33 66 78 84} {} City {}} {entry entry6 {87 63 195 84} {} entry6 pbqs(city)} {query qs {3 6 33 33} {} query7 {}} {button button8 {126 177 198 203} {.pb.qs:setsql "select oid,* from phonebook where name ~* '$what' order by name"\
.pb.qs:open\ .pb.qs:open\
...@@ -56,14 +56,14 @@ tk_messageBox -title Information -message "A new record has been added!"\ ...@@ -56,14 +56,14 @@ tk_messageBox -title Information -message "A new record has been added!"\
set pbqs(company) f\ set pbqs(company) f\
focus .pb.name_entry} New {}} {listbox allnames {246 12 432 240} {} listbox26 {}} focus .pb.name_entry} New {}} {listbox allnames {246 12 432 240} {} listbox26 {}}
\. \.
COPY pga_scripts FROM stdin; COPY "pga_scripts" FROM stdin;
How are forms keeped inside ? open_table pga_forms\ How are forms keeped inside ? open_table pga_forms\
\ \
\. \.
COPY pga_reports FROM stdin; COPY "pga_reports" FROM stdin;
\. \.
COPY phonebook FROM stdin; COPY "phonebook" FROM stdin;
IBM 623346234 \N t usa IBM 623346234 \N t usa
John Doe +44 35 2993825 Washington f usa John Doe +44 35 2993825 Washington f usa
Bill Clinton +44 35 9283845 New York f usa Bill Clinton +44 35 9283845 New York f usa
...@@ -81,7 +81,7 @@ Ngbendu Wazabanga 34577345 f africa ...@@ -81,7 +81,7 @@ Ngbendu Wazabanga 34577345 f africa
Victor Ciorbea 634567 Bucuresti f europe Victor Ciorbea 634567 Bucuresti f europe
Mugabe Kandalam 7635745 f africa Mugabe Kandalam 7635745 f africa
\. \.
COPY pga_layout FROM stdin; COPY "pga_layout" FROM stdin;
pga_forms 2 formname formsource 82 713 pga_forms 2 formname formsource 82 713
phonebook 5 name phone_nr city company continent 150 105 80 66 85 phonebook 5 name phone_nr city company continent 150 105 80 66 85
Usaisti 5 name phone_nr city company continent 150 150 150 150 150 Usaisti 5 name phone_nr city company continent 150 150 150 150 150
......
src/bin/pgaccess/index.html
View file @ a00c6681
...@@ -12,10 +12,10 @@ ...@@ -12,10 +12,10 @@
<P> <P>
<HR></P> <HR></P>
<LI><A HREF="pgaccess-0.90.tar.gz">Download the last version of PgAccess <LI><A HREF="pgaccess-0.91.tar.gz">Download the last version of PgAccess
(press shift and click this link)</A>.</LI> (press shift and click this link)</A>.</LI>
<CENTER><P>Latest version of PgAccess is 0.90 , 18 September 1998 ! <BR> <CENTER><P>Latest version of PgAccess is 0.91 , 1 November 1998 ! <BR>
<BR> <BR>
&nbsp; <B><FONT COLOR="#FF0000">NEW * NEW * NEW *</FONT></B> <B><FONT COLOR="#FF0000"> &nbsp; <B><FONT COLOR="#FF0000">NEW * NEW * NEW *</FONT></B> <B><FONT COLOR="#FF0000">
NEW *</FONT></B> ==== &gt; <B><FONT SIZE=+1>QUERY PARAMETERS</FONT></B> NEW *</FONT></B> ==== &gt; <B><FONT SIZE=+1>QUERY PARAMETERS</FONT></B>
......
src/bin/pgaccess/pgaccess.tcl
View file @ a00c6681
...@@ -56,45 +56,107 @@ set qlvar(newtablename) {} ...@@ -56,45 +56,107 @@ set qlvar(newtablename) {}
init $argc $argv init $argc $argv
proc {sqlw_display} {msg} {
if {![winfo exists .sqlw]} {return}
.sqlw.f.t insert end "$msg\n\n"
.sqlw.f.t see end
set nrlines [lindex [split [.sqlw.f.t index end] .] 0]
if {$nrlines>50} {
.sqlw.f.t delete 1.0 3.0
}
}
proc {wpg_exec} {db cmd} {
global pgsql
if {[catch {
sqlw_display $cmd
set pgsql(cmd) $cmd
set pgsql(res) [pg_exec $db $cmd]
set pgsql(status) [pg_result $pgsql(res) -status]
set pgsql(errmsg) [pg_result $pgsql(res) -error]
} tclerrmsg]} {
show_error "Tcl error executing pg_exec $cmd\n\n$tclerrmsg"
return 0
}
return $pgsql(res)
}
proc {MsgBox} {mesaj} { proc {wpg_select} {args} {
tk_messageBox -title Mesaj -message $mesaj sqlw_display "[lindex $args 1]"
uplevel pg_select $args
} }
proc {add_new_field} {} { proc {add_new_field} {} {
global fldname fldtype fldsize defaultval notnull global ntw
if {$fldname==""} { if {$ntw(fldname)==""} {
show_error "Enter a field name" show_error "Enter a field name"
focus .nt.e2 focus .nt.e2
return return
} }
if {$fldtype==""} { if {$ntw(fldtype)==""} {
show_error "The field type is not specified!" show_error "The field type is not specified!"
return return
} }
if {(($fldtype=="varchar")||($fldtype=="char"))&&($fldsize=="")} { if {($ntw(fldtype)=="varchar")&&($ntw(fldsize)=="")} {
focus .nt.e3 focus .nt.e3
show_error "You must specify field size!" show_error "You must specify field size!"
return return
} }
if {$fldsize==""} then {set sup ""} else {set sup "($fldsize)"} if {$ntw(fldsize)==""} then {set sup ""} else {set sup "($ntw(fldsize))"}
if {[regexp $fldtype "varchar2char4char8char16textdatetime"]} {set supc "'"} else {set supc ""} if {[regexp $ntw(fldtype) "varchartextdatetime"]} {set supc "'"} else {set supc ""}
if {$defaultval==""} then {set sup2 ""} else {set sup2 " DEFAULT $supc$defaultval$supc"} if {$ntw(defaultval)==""} then {set sup2 ""} else {set sup2 " DEFAULT $supc$ntw(defaultval)$supc"}
# Checking for field name collision # Checking for field name collision
set inspos end set inspos end
for {set i 0} {$i<[.nt.lb size]} {incr i} { for {set i 0} {$i<[.nt.lb size]} {incr i} {
set linie [.nt.lb get $i] set linie [.nt.lb get $i]
if {$fldname==[lindex [split $linie] 0]} { if {$ntw(fldname)==[string trim [string range $linie 2 33]]} {
if {[tk_messageBox -title Warning -message "There is another field with the same name!\n\nReplace it ?" -type yesno -default yes]=="no"} return if {[tk_messageBox -title Warning -message "There is another field with the same name: \"$ntw(fldname)\"!\n\nReplace it ?" -type yesno -default yes]=="no"} return
.nt.lb delete $i .nt.lb delete $i
set inspos $i set inspos $i
break
} }
} }
.nt.lb insert $inspos [format "%-17s%-14s%-16s" $fldname $fldtype$sup $sup2$notnull] .nt.lb insert $inspos [format "%1s %-32.32s %-14s%-16s" $ntw(pk) $ntw(fldname) $ntw(fldtype)$sup $sup2$ntw(notnull)]
focus .nt.e2 focus .nt.e2
set fldname {} set ntw(fldname) {}
set fldsize {} set ntw(fldsize) {}
set defaultval {} set ntw(defaultval) {}
set ntw(pk) " "
}
proc {create_table} {} {
global dbc ntw
if {$ntw(newtablename)==""} then {
show_error "You must supply a name for your table!"
focus .nt.etabn
return
}
if {[.nt.lb size]==0} then {
show_error "Your table has no fields!"
focus .nt.e2
return
}
set fl {}
set pkf {}
foreach line [.nt.lb get 0 end] {
set fldname "\"[string trim [string range $line 2 33]]\""
lappend fl "$fldname [string trim [string range $line 35 end]]"
if {[string range $line 0 0]=="*"} {
lappend pkf "$fldname"
}
}
set temp "create table \"$ntw(newtablename)\" ([join $fl ,]"
if {$ntw(constraint)!=""} then {set temp "$temp, constraint \"$ntw(constraint)\""}
if {$ntw(check)!=""} then {set temp "$temp check ($ntw(check))"}
if {[llength $pkf]>0} then {set temp "$temp, primary key([join $pkf ,])"}
set temp "$temp)"
if {$ntw(fathername)!=""} then {set temp "$temp inherits ($ntw(fathername))"}
cursor_clock
if {[sql_exec noquiet $temp]} {
Window destroy .nt
cmd_Tables
}
cursor_normal
} }
proc {cmd_Delete} {} { proc {cmd_Delete} {} {
...@@ -182,23 +244,23 @@ switch $activetab { ...@@ -182,23 +244,23 @@ switch $activetab {
proc {cmd_Forms} {} { proc {cmd_Forms} {} {
global dbc global dbc
cursor_watch .dw cursor_clock
.dw.lb delete 0 end .dw.lb delete 0 end
catch { catch {
pg_select $dbc "select formname from pga_forms order by formname" rec { wpg_select $dbc "select formname from pga_forms order by formname" rec {
.dw.lb insert end $rec(formname) .dw.lb insert end $rec(formname)
} }
} }
cursor_arrow .dw cursor_normal
} }
proc {cmd_Functions} {} { proc {cmd_Functions} {} {
global dbc global dbc
set maxim 0 set maxim 0
set pgid 0 set pgid 0
cursor_watch .dw cursor_clock
catch { catch {
pg_select $dbc "select proowner,count(*) from pg_proc group by proowner" rec { wpg_select $dbc "select proowner,count(*) from pg_proc group by proowner" rec {
if {$rec(count)>$maxim} { if {$rec(count)>$maxim} {
set maxim $rec(count) set maxim $rec(count)
set pgid $rec(proowner) set pgid $rec(proowner)
...@@ -206,11 +268,11 @@ catch { ...@@ -206,11 +268,11 @@ catch {
} }
.dw.lb delete 0 end .dw.lb delete 0 end
catch { catch {
pg_select $dbc "select proname from pg_proc where prolang=14 and proowner<>$pgid order by proname" rec { wpg_select $dbc "select proname from pg_proc where prolang=14 and proowner<>$pgid order by proname" rec {
.dw.lb insert end $rec(proname) .dw.lb insert end $rec(proname)
} }
} }
cursor_arrow .dw cursor_normal
} }
} }
...@@ -315,7 +377,7 @@ proc {cmd_Queries} {} { ...@@ -315,7 +377,7 @@ proc {cmd_Queries} {} {
global dbc global dbc
.dw.lb delete 0 end .dw.lb delete 0 end
catch { catch {
pg_select $dbc "select * from pga_queries order by queryname" rec { wpg_select $dbc "select * from pga_queries order by queryname" rec {
.dw.lb insert end $rec(queryname) .dw.lb insert end $rec(queryname)
} }
} }
...@@ -338,83 +400,90 @@ Window show .rf ...@@ -338,83 +400,90 @@ Window show .rf
proc {cmd_Reports} {} { proc {cmd_Reports} {} {
global dbc global dbc
cursor_watch .dw cursor_clock
catch { catch {
pg_select $dbc "select * from pga_reports order by reportname" rec { wpg_select $dbc "select * from pga_reports order by reportname" rec {
.dw.lb insert end "$rec(reportname)" .dw.lb insert end "$rec(reportname)"
} }
} }
cursor_arrow .dw cursor_normal
} }
proc {cmd_Scripts} {} { proc {cmd_Scripts} {} {
global dbc global dbc
cursor_watch .dw cursor_clock
.dw.lb delete 0 end .dw.lb delete 0 end
catch { catch {
pg_select $dbc "select * from pga_scripts order by scriptname" rec { wpg_select $dbc "select * from pga_scripts order by scriptname" rec {
.dw.lb insert end $rec(scriptname) .dw.lb insert end $rec(scriptname)
} }
} }
cursor_arrow .dw cursor_normal
} }
proc {cmd_Sequences} {} { proc {cmd_Sequences} {} {
global dbc global dbc
cursor_watch .dw cursor_clock
.dw.lb delete 0 end .dw.lb delete 0 end
catch { catch {
pg_select $dbc "select * from pg_class where (relname not like 'pg_%') and (relkind='S') order by relname" rec { wpg_select $dbc "select * from pg_class where (relname not like 'pg_%') and (relkind='S') order by relname" rec {
.dw.lb insert end $rec(relname) .dw.lb insert end $rec(relname)
} }
} }
cursor_arrow .dw cursor_normal
} }
proc {cmd_Tables} {} { proc {cmd_Tables} {} {
global dbc global dbc
cursor_watch .dw cursor_clock
.dw.lb delete 0 end .dw.lb delete 0 end
foreach tbl [get_tables] {.dw.lb insert end $tbl} foreach tbl [get_tables] {.dw.lb insert end $tbl}
cursor_arrow .dw cursor_normal
} }
proc {cmd_Views} {} { proc {cmd_Views} {} {
global dbc global dbc
cursor_watch .dw cursor_clock
.dw.lb delete 0 end .dw.lb delete 0 end
catch { catch {
pg_select $dbc "select * from pg_class where (relname !~ '^pg_') and (relkind='r') and (relhasrules) order by relname" rec { wpg_select $dbc "select * from pg_class where (relname !~ '^pg_') and (relkind='r') and (relhasrules) order by relname" rec {
.dw.lb insert end $rec(relname) .dw.lb insert end $rec(relname)
} }
} }
cursor_arrow .dw cursor_normal
} }
proc {create_drop_down} {base x y} { proc {create_drop_down} {base x y w} {
if {[winfo exists $base.ddf]} {
return
}
frame $base.ddf -borderwidth 1 -height 75 -relief raised -width 55 frame $base.ddf -borderwidth 1 -height 75 -relief raised -width 55
listbox $base.ddf.lb -background #fefefe -borderwidth 1 -font -Adobe-Helvetica-medium-R-Normal--*-120-*-*-*-*-*-* -highlightthickness 0 -selectborderwidth 0 -yscrollcommand [subst {$base.ddf.sb set}] listbox $base.ddf.lb -background #fefefe -borderwidth 1 -font -*-Clean-medium-R-Normal--*-130-*-*-*-*-*-* -highlightthickness 0 -selectborderwidth 0 -yscrollcommand [subst {$base.ddf.sb set}]
scrollbar $base.ddf.sb -borderwidth 1 -command [subst {$base.ddf.lb yview}] -highlightthickness 0 -orient vert scrollbar $base.ddf.sb -borderwidth 1 -command [subst {$base.ddf.lb yview}] -highlightthickness 0 -orient vert
place $base.ddf -x $x -y $y -width 220 -height 185 -anchor nw -bordermode ignore place $base.ddf -x $x -y $y -width $w -height 185 -anchor nw -bordermode ignore
place $base.ddf.lb -x 1 -y 1 -width 202 -height 182 -anchor nw -bordermode ignore place $base.ddf.lb -x 1 -y 1 -width [expr $w-18] -height 182 -anchor nw -bordermode ignore
place $base.ddf.sb -x 205 -y 1 -width 14 -height 183 -anchor nw -bordermode ignore place $base.ddf.sb -x [expr $w-15] -y 1 -width 14 -height 183 -anchor nw -bordermode ignore
} }
proc {cursor_arrow} {w} { proc {cursor_normal} {} {
$w configure -cursor top_left_arrow foreach wn [winfo children .] {
update idletasks catch {$wn configure -cursor top_left_arrow}
}
update ; update idletasks
} }
proc {cursor_watch} {w} { proc {cursor_clock} {} {
$w configure -cursor watch foreach wn [winfo children .] {
update idletasks catch {$wn configure -cursor watch}
}
update ; update idletasks
} }
proc {delete_function} {objname} { proc {delete_function} {objname} {
global dbc global dbc
pg_select $dbc "select * from pg_proc where proname='$objname'" rec { wpg_select $dbc "select * from pg_proc where proname='$objname'" rec {
set funcpar $rec(proargtypes) set funcpar $rec(proargtypes)
set nrpar $rec(pronargs) set nrpar $rec(pronargs)
} }
...@@ -432,7 +501,7 @@ Window show .sw ...@@ -432,7 +501,7 @@ Window show .sw
set scriptname $sname set scriptname $sname
.sw.src delete 1.0 end .sw.src delete 1.0 end
if {[string length $sname]==0} return; if {[string length $sname]==0} return;
pg_select $dbc "select * from pga_scripts where scriptname='$sname'" rec { wpg_select $dbc "select * from pga_scripts where scriptname='$sname'" rec {
.sw.src insert end $rec(scriptsource) .sw.src insert end $rec(scriptsource)
} }
} }
...@@ -488,9 +557,9 @@ global draglocation mw dbc ...@@ -488,9 +557,9 @@ global draglocation mw dbc
for {set i [expr $ctr+1]} {$i<$mw(colcount)} {incr i} { for {set i [expr $ctr+1]} {$i<$mw(colcount)} {incr i} {
.mw.c move c$i $diff 0 .mw.c move c$i $diff 0
} }
cursor_watch .mw cursor_clock
sql_exec quiet "update pga_layout set colwidth='$mw(colwidth)' where tablename='$mw(layout_name)'" sql_exec quiet "update pga_layout set colwidth='$mw(colwidth)' where tablename='$mw(layout_name)'"
cursor_arrow .mw cursor_normal
} }
} }
...@@ -510,12 +579,12 @@ set activetab "" ...@@ -510,12 +579,12 @@ set activetab ""
proc {execute_script} {scriptname} { proc {execute_script} {scriptname} {
global dbc global dbc
set ss {} set ss {}
pg_select $dbc "select * from pga_scripts where scriptname='$scriptname'" rec { wpg_select $dbc "select * from pga_scripts where scriptname='$scriptname'" rec {
set ss $rec(scriptsource) set ss $rec(scriptsource)
} }
# if {[string length $ss] > 0} { if {[string length $ss] > 0} {
eval $ss eval $ss
# } }
} }
proc {fd_change_coord} {} { proc {fd_change_coord} {} {
...@@ -655,7 +724,7 @@ if {$mode=="design"} { ...@@ -655,7 +724,7 @@ if {$mode=="design"} {
#set fid [open "$name.form" r] #set fid [open "$name.form" r]
#set info [gets $fid] #set info [gets $fid]
#close $fid #close $fid
set res [pg_exec $dbc "select * from pga_forms where formname='$fdvar(formname)'"] set res [wpg_exec $dbc "select * from pga_forms where formname='$fdvar(formname)'"]
set info [lindex [pg_result $res -getTuple 0] 1] set info [lindex [pg_result $res -getTuple 0] 1]
pg_result $res -clear pg_result $res -clear
set fdvar(forminame) [lindex $info 0] set fdvar(forminame) [lindex $info 0]
...@@ -766,18 +835,13 @@ if {[string length $fdvar(formname)]==0} { ...@@ -766,18 +835,13 @@ if {[string length $fdvar(formname)]==0} {
tk_messageBox -title Warning -message "Form must have a name" tk_messageBox -title Warning -message "Form must have a name"
return 0 return 0
} }
#set fid [open "$name.form" w]
set info [list $fdvar(forminame) $fdvar(objnum) $fdvar(objlist) [wm geometry .fd]] set info [list $fdvar(forminame) $fdvar(objnum) $fdvar(objlist) [wm geometry .fd]]
foreach i $fdvar(objlist) { foreach i $fdvar(objlist) {
lappend info [list $fdobj($i,t) $fdobj($i,n) $fdobj($i,c) $fdobj($i,x) $fdobj($i,l) $fdobj($i,v)] lappend info [list $fdobj($i,t) $fdobj($i,n) $fdobj($i,c) $fdobj($i,x) $fdobj($i,l) $fdobj($i,v)]
} }
#puts $fid $info sql_exec noquiet "delete from pga_forms where formname='$fdvar(formname)'"
#close $fid
set res [pg_exec $dbc "delete from pga_forms where formname='$fdvar(formname)'"]
pg_result $res -clear
regsub -all "'" $info "''" info regsub -all "'" $info "''" info
set res [pg_exec $dbc "insert into pga_forms values ('$fdvar(formname)','$info')"] sql_exec noquiet "insert into pga_forms values ('$fdvar(formname)','$info')"
pg_result $res -clear
cmd_Forms cmd_Forms
return 1 return 1
} }
...@@ -861,15 +925,15 @@ switch $fdobj($item,t) { ...@@ -861,15 +925,15 @@ switch $fdobj($item,t) {
eval "proc $base.$name:open {} {\ eval "proc $base.$name:open {} {\
global dbc datasets tup$basewp$name ;\ global dbc datasets tup$basewp$name ;\
catch {unset tup$basewp$name} ;\ catch {unset tup$basewp$name} ;\
set wn \[focus\] ; cursor_watch \$wn ;\ set wn \[focus\] ; cursor_clock ;\
set res \[pg_exec \$dbc \"\$datasets($base.$name,sql)\"\] ;\ set res \[wpg_exec \$dbc \"\$datasets($base.$name,sql)\"\] ;\
pg_result \$res -assign tup$basewp$name ;\ pg_result \$res -assign tup$basewp$name ;\
set fl {} ;\ set fl {} ;\
foreach fd \[pg_result \$res -lAttributes\] {lappend fl \[lindex \$fd 0\]} ;\ foreach fd \[pg_result \$res -lAttributes\] {lappend fl \[lindex \$fd 0\]} ;\
set datasets($base.$name,fields) \$fl ;\ set datasets($base.$name,fields) \$fl ;\
set datasets($base.$name,recno) 0 ;\ set datasets($base.$name,recno) 0 ;\
set datasets($base.$name,nrecs) \[pg_result \$res -numTuples\] ;\ set datasets($base.$name,nrecs) \[pg_result \$res -numTuples\] ;\
cursor_arrow \$wn ;\ cursor_normal ;\
}" }"
eval "proc $base.$name:setsql {sqlcmd} {\ eval "proc $base.$name:setsql {sqlcmd} {\
global datasets ;\ global datasets ;\
...@@ -962,7 +1026,7 @@ return [.dw.lb get $temp] ...@@ -962,7 +1026,7 @@ return [.dw.lb get $temp]
proc {get_pgtype} {oid} { proc {get_pgtype} {oid} {
global dbc global dbc
set temp "unknown" set temp "unknown"
pg_select $dbc "select typname from pg_type where oid=$oid" rec { wpg_select $dbc "select typname from pg_type where oid=$oid" rec {
set temp $rec(typname) set temp $rec(typname)
} }
return $temp return $temp
...@@ -972,7 +1036,7 @@ proc {get_tables} {} { ...@@ -972,7 +1036,7 @@ proc {get_tables} {} {
global dbc global dbc
set tbl {} set tbl {}
catch { catch {
pg_select $dbc "select * from pg_class where (relname !~ '^pg_') and (relkind='r') and (not relhasrules) order by relname" rec { wpg_select $dbc "select * from pg_class where (relname !~ '^pg_') and (relkind='r') and (not relhasrules) order by relname" rec {
if {![regexp "^pga_" $rec(relname)]} then {lappend tbl $rec(relname)} if {![regexp "^pga_" $rec(relname)]} then {lappend tbl $rec(relname)}
} }
} }
...@@ -1172,18 +1236,18 @@ if {[string compare $mw(text_initial_value) $fldval]==0} { ...@@ -1172,18 +1236,18 @@ if {[string compare $mw(text_initial_value) $fldval]==0} {
set mw(id_edited) {};set mw(text_initial_value) {} set mw(id_edited) {};set mw(text_initial_value) {}
return 1 return 1
} }
cursor_watch .mw cursor_clock
set oid [lindex $mw(keylist) $mw(row_edited)] set oid [lindex $mw(keylist) $mw(row_edited)]
set fld [lindex $mw(colnames) [get_tag_info $mw(id_edited) c]] set fld [lindex $mw(colnames) [get_tag_info $mw(id_edited) c]]
set fillcolor black set fillcolor black
if {$mw(row_edited)==$mw(last_rownum)} { if {$mw(row_edited)==$mw(last_rownum)} {
set fillcolor red set fillcolor red
set sfp [lsearch $mw(newrec_fields) $fld] set sfp [lsearch $mw(newrec_fields) "\"$fld\""]
if {$sfp>-1} { if {$sfp>-1} {
set mw(newrec_fields) [lreplace $mw(newrec_fields) $sfp $sfp] set mw(newrec_fields) [lreplace $mw(newrec_fields) $sfp $sfp]
set mw(newrec_values) [lreplace $mw(newrec_values) $sfp $sfp] set mw(newrec_values) [lreplace $mw(newrec_values) $sfp $sfp]
} }
lappend mw(newrec_fields) $fld lappend mw(newrec_fields) "\"$fld\""
lappend mw(newrec_values) '$fldval' lappend mw(newrec_values) '$fldval'
# Remove the untouched tag from the object # Remove the untouched tag from the object
.mw.c dtag $mw(id_edited) unt .mw.c dtag $mw(id_edited) unt
...@@ -1193,9 +1257,9 @@ if {$mw(row_edited)==$mw(last_rownum)} { ...@@ -1193,9 +1257,9 @@ if {$mw(row_edited)==$mw(last_rownum)} {
set msg "Updating record ..." set msg "Updating record ..."
after 1000 {set msg ""} after 1000 {set msg ""}
regsub -all ' $fldval \\' sqlfldval regsub -all ' $fldval \\' sqlfldval
set retval [sql_exec noquiet "update \"$tablename\" set $fld='$sqlfldval' where oid=$oid"] set retval [sql_exec noquiet "update \"$tablename\" set \"$fld\"='$sqlfldval' where oid=$oid"]
} }
cursor_arrow .mw cursor_normal
if {!$retval} { if {!$retval} {
set msg "" set msg ""
focus .mw.c focus .mw.c
...@@ -1209,12 +1273,13 @@ return 1 ...@@ -1209,12 +1273,13 @@ return 1
proc {mw_load_layout} {tablename} { proc {mw_load_layout} {tablename} {
global dbc msg mw global dbc msg mw
cursor_watch .mw cursor_clock
set mw(layout_name) $tablename set mw(layout_name) $tablename
catch {unset mw(colcount) mw(colnames) mw(colwidth)} catch {unset mw(colcount) mw(colnames) mw(colwidth)}
set mw(layout_found) 0 set mw(layout_found) 0
set retval [catch {set pgres [pg_exec $dbc "select *,oid from pga_layout where tablename='$tablename' order by oid desc"]}] set pgres [wpg_exec $dbc "select *,oid from pga_layout where tablename='$tablename' order by oid desc"]
if {$retval} { set pgs [pg_result $pgres -status]
if {$pgs!="PGRES_TUPLES_OK"} {
# Probably table pga_layout isn't yet defined # Probably table pga_layout isn't yet defined
sql_exec noquiet "create table pga_layout (tablename varchar(64),nrcols int2,colnames text,colwidth text)" sql_exec noquiet "create table pga_layout (tablename varchar(64),nrcols int2,colnames text,colwidth text)"
sql_exec quiet "grant ALL on pga_layout to PUBLIC" sql_exec quiet "grant ALL on pga_layout to PUBLIC"
...@@ -1229,11 +1294,11 @@ if {$retval} { ...@@ -1229,11 +1294,11 @@ if {$retval} {
set mw(layout_found) 1 set mw(layout_found) 1
} }
if {$nrlay>1} { if {$nrlay>1} {
show_error "Multiple ([pg_result $pgres -numTuples]) layout info found\n\nPlease report the bug!" show_error "Multiple ($nrlay) layout info found\n\nPlease report the bug!"
sql_exec quiet "delete from pga_layout where (tablename='$tablename') and (oid<>$goodoid)" sql_exec quiet "delete from pga_layout where (tablename='$tablename') and (oid<>$goodoid)"
} }
} }
catch {pg_result $pgres -clear} pg_result $pgres -clear
} }
proc {mw_pan_left} {} { proc {mw_pan_left} {} {
...@@ -1266,11 +1331,9 @@ if {![mw_exit_edit]} {return 0} ...@@ -1266,11 +1331,9 @@ if {![mw_exit_edit]} {return 0}
if {$mw(newrec_fields)==""} {return 1} if {$mw(newrec_fields)==""} {return 1}
set msg "Saving new record ..." set msg "Saving new record ..."
after 1000 {set msg ""} after 1000 {set msg ""}
set retval [catch { set pgres [wpg_exec $dbc "insert into \"$tablename\" ([join $mw(newrec_fields) ,]) values ([join $mw(newrec_values) ,])" ]
set sqlcmd "insert into \"$tablename\" ([join $mw(newrec_fields) ,]) values ([join $mw(newrec_values) ,])" if {[pg_result $pgres -status]!="PGRES_COMMAND_OK"} {
set pgres [pg_exec $dbc $sqlcmd] set errmsg [pg_result $pgres -error]
} errmsg]
if {$retval} {
show_error "Error inserting new record\n\n$errmsg" show_error "Error inserting new record\n\n$errmsg"
return 0 return 0
} }
...@@ -1323,7 +1386,7 @@ mw_set_scrollbar ...@@ -1323,7 +1386,7 @@ mw_set_scrollbar
} }
proc {mw_select_records} {sql} { proc {mw_select_records} {sql} {
global dbc field mw global dbc field mw pgsql
global tablename msg pref global tablename msg pref
set mw(newrec_fields) {} set mw(newrec_fields) {}
set mw(newrec_values) {} set mw(newrec_values) {}
...@@ -1337,22 +1400,20 @@ set mw(leftoffset) 0 ...@@ -1337,22 +1400,20 @@ set mw(leftoffset) 0
set mw(crtrow) {} set mw(crtrow) {}
set msg {} set msg {}
set msg "Accessing data. Please wait ..." set msg "Accessing data. Please wait ..."
cursor_watch .mw cursor_clock
set retval [catch {set pgres [pg_exec $dbc "BEGIN"]} errmsg] set is_error 1
if {!$retval} { if {[sql_exec noquiet "BEGIN"]} {
pg_result $pgres -clear if {[sql_exec noquiet "declare mycursor cursor for $sql"]} {
set retval [catch {set pgres [pg_exec $dbc "declare mycursor cursor for $sql"]} errmsg] set pgres [wpg_exec $dbc "fetch $pref(rows) in mycursor"]
if {!$retval} { if {$pgsql(status)=="PGRES_TUPLES_OK"} {
pg_result $pgres -clear set is_error 0
set retval [catch {set pgres [pg_exec $dbc "fetch $pref(rows) in mycursor"]} errmsg] }
} }
} }
#set retval [catch {set pgres [pg_exec $dbc $sql]} errmsg] if {$is_error} {
if {$retval} {
sql_exec quiet "END" sql_exec quiet "END"
set msg {} set msg {}
cursor_arrow .mw cursor_normal
show_error "Error executing SQL command\n\n$sql\n\nError message:$errmsg"
set msg "Error executing : $sql" set msg "Error executing : $sql"
return return
} }
...@@ -1438,7 +1499,7 @@ if {$mw(updatable)} then { ...@@ -1438,7 +1499,7 @@ if {$mw(updatable)} then {
set mw(dirtyrec) 0 set mw(dirtyrec) 0
#mw_draw_headers #mw_draw_headers
.mw.c raise header .mw.c raise header
cursor_arrow .mw cursor_normal
} }
proc {mw_set_scrollbar} {} { proc {mw_set_scrollbar} {} {
...@@ -1490,14 +1551,14 @@ if {$mw(row_edited)==$mw(nrecs)} { ...@@ -1490,14 +1551,14 @@ if {$mw(row_edited)==$mw(nrecs)} {
proc {open_database} {} { proc {open_database} {} {
global dbc host pport dbname username password newusername newpassword sdbname newdbname newhost newpport pref global dbc host pport dbname username password newusername newpassword sdbname newdbname newhost newpport pref
catch {cursor_watch .dbod} cursor_clock
if {$newusername!=""} { if {$newusername!=""} {
set connres [catch {set newdbc [pg_connect -conninfo "host=$newhost port=$newpport dbname=$newdbname user=$newusername password=$newpassword"]} msg] set connres [catch {set newdbc [pg_connect -conninfo "host=$newhost port=$newpport dbname=$newdbname user=$newusername password=$newpassword"]} msg]
} else { } else {
set connres [catch {set newdbc [pg_connect $newdbname -host $newhost -port $newpport]} msg] set connres [catch {set newdbc [pg_connect $newdbname -host $newhost -port $newpport]} msg]
} }
if {$connres} { if {$connres} {
catch {cursor_arrow .dbod} cursor_normal
show_error "Error connecting database\n$msg" show_error "Error connecting database\n$msg"
} else { } else {
catch {pg_disconnect $dbc} catch {pg_disconnect $dbc}
...@@ -1513,11 +1574,11 @@ if {$connres} { ...@@ -1513,11 +1574,11 @@ if {$connres} {
set pref(lastport) $pport set pref(lastport) $pport
set pref(lastusername) $username set pref(lastusername) $username
save_pref save_pref
catch {cursor_arrow .dbod; Window hide .dbod} catch {cursor_normal ; Window hide .dbod}
tab_click .dw.tabTables tab_click .dw.tabTables
# Check for pga_ tables # Check for pga_ tables
foreach {table structure} { pga_queries {queryname varchar(64),querytype char(1),querycommand text} pga_forms {formname varchar(64),formsource text} pga_scripts {scriptname varchar(64),scriptsource text} pga_reports {reportname varchar(64),reportsource text,reportbody text,reportprocs text,reportoptions text}} { foreach {table structure} { pga_queries {queryname varchar(64),querytype char(1),querycommand text} pga_forms {formname varchar(64),formsource text} pga_scripts {scriptname varchar(64),scriptsource text} pga_reports {reportname varchar(64),reportsource text,reportbody text,reportprocs text,reportoptions text}} {
set pgres [pg_exec $dbc "select relname from pg_class where relname='$table'"] set pgres [wpg_exec $dbc "select relname from pg_class where relname='$table'"]
if {[pg_result $pgres -numTuples]==0} { if {[pg_result $pgres -numTuples]==0} {
pg_result $pgres -clear pg_result $pgres -clear
sql_exec quiet "create table $table ($structure)" sql_exec quiet "create table $table ($structure)"
...@@ -1526,7 +1587,7 @@ if {$connres} { ...@@ -1526,7 +1587,7 @@ if {$connres} {
catch { pg_result $pgres -clear } catch { pg_result $pgres -clear }
} }
# searching for autoexec script # searching for autoexec script
pg_select $dbc "select * from pga_scripts where scriptname ~* '^autoexec$'" recd { wpg_select $dbc "select * from pga_scripts where scriptname ~* '^autoexec$'" recd {
eval $recd(scriptsource) eval $recd(scriptsource)
} }
} }
...@@ -1543,7 +1604,7 @@ Window show .fw ...@@ -1543,7 +1604,7 @@ Window show .fw
place .fw.okbtn -y 400 place .fw.okbtn -y 400
.fw.okbtn configure -state disabled .fw.okbtn configure -state disabled
.fw.text1 delete 1.0 end .fw.text1 delete 1.0 end
pg_select $dbc "select * from pg_proc where proname='$objname'" rec { wpg_select $dbc "select * from pg_proc where proname='$objname'" rec {
set funcname $objname set funcname $objname
set temppar $rec(proargtypes) set temppar $rec(proargtypes)
set funcret [get_pgtype $rec(prorettype)] set funcret [get_pgtype $rec(prorettype)]
...@@ -1576,7 +1637,7 @@ global dbc queryname mw queryoid sortfield filter ...@@ -1576,7 +1637,7 @@ global dbc queryname mw queryoid sortfield filter
if {[.dw.lb curselection]==""} return; if {[.dw.lb curselection]==""} return;
set queryname [.dw.lb get [.dw.lb curselection]] set queryname [.dw.lb get [.dw.lb curselection]]
if {[catch {set pgres [pg_exec $dbc "select querycommand,querytype,oid from pga_queries where queryname='$queryname'"]}]} then { if {[set pgres [wpg_exec $dbc "select querycommand,querytype,oid from pga_queries where queryname='$queryname'"]]==0} then {
show_error "Error retrieving query definition" show_error "Error retrieving query definition"
return return
} }
...@@ -1618,7 +1679,7 @@ proc {open_sequence} {objname} { ...@@ -1618,7 +1679,7 @@ proc {open_sequence} {objname} {
global dbc seq_name seq_inc seq_start seq_minval seq_maxval global dbc seq_name seq_inc seq_start seq_minval seq_maxval
Window show .sqf Window show .sqf
set flag 1 set flag 1
pg_select $dbc "select * from $objname" rec { wpg_select $dbc "select * from $objname" rec {
set flag 0 set flag 0
set seq_name $objname set seq_name $objname
set seq_inc $rec(increment_by) set seq_inc $rec(increment_by)
...@@ -1687,11 +1748,11 @@ global qlvar dbc ...@@ -1687,11 +1748,11 @@ global qlvar dbc
if {$qlvar(newtablename)==""} return if {$qlvar(newtablename)==""} return
set fldlist {} set fldlist {}
cursor_watch .ql cursor_clock
pg_select $dbc "select attnum,attname from pg_class,pg_attribute where (pg_class.relname='$qlvar(newtablename)') and (pg_class.oid=pg_attribute.attrelid) and (attnum>0) order by attnum" rec { wpg_select $dbc "select attnum,attname from pg_class,pg_attribute where (pg_class.relname='$qlvar(newtablename)') and (pg_class.oid=pg_attribute.attrelid) and (attnum>0) order by attnum" rec {
lappend fldlist $rec(attname) lappend fldlist $rec(attname)
} }
cursor_arrow .ql cursor_normal
if {$fldlist==""} { if {$fldlist==""} {
show_error "Table $qlvar(newtablename) not found!" show_error "Table $qlvar(newtablename) not found!"
return return
...@@ -2333,11 +2394,11 @@ proc {rb_get_report_fields} {} { ...@@ -2333,11 +2394,11 @@ proc {rb_get_report_fields} {} {
global dbc rbvar global dbc rbvar
.rb.lb delete 0 end .rb.lb delete 0 end
if {$rbvar(tablename)==""} return ; if {$rbvar(tablename)==""} return ;
#cursor_watch .ql #cursor_clock
pg_select $dbc "select attnum,attname from pg_class,pg_attribute where (pg_class.relname='$rbvar(tablename)') and (pg_class.oid=pg_attribute.attrelid) and (attnum>0) order by attnum" rec { wpg_select $dbc "select attnum,attname from pg_class,pg_attribute where (pg_class.relname='$rbvar(tablename)') and (pg_class.oid=pg_attribute.attrelid) and (attnum>0) order by attnum" rec {
.rb.lb insert end $rec(attname) .rb.lb insert end $rec(attname)
} }
#cursor_arrow .ql #cursor_normal
} }
proc {rb_has_tag} {id tg} { proc {rb_has_tag} {id tg} {
...@@ -2365,7 +2426,7 @@ rb_draw_regions ...@@ -2365,7 +2426,7 @@ rb_draw_regions
proc {rb_load_report} {} { proc {rb_load_report} {} {
global rbvar dbc global rbvar dbc
.rb.c delete all .rb.c delete all
pg_select $dbc "select * from pga_reports where reportname='$rbvar(reportname)'" rcd { wpg_select $dbc "select * from pga_reports where reportname='$rbvar(reportname)'" rcd {
eval $rcd(reportbody) eval $rcd(reportbody)
} }
rb_get_report_fields rb_get_report_fields
...@@ -2386,7 +2447,6 @@ foreach objid $ol { ...@@ -2386,7 +2447,6 @@ foreach objid $ol {
lappend fields $objid lappend fields $objid
lappend fields [lindex $tags [lsearch -glob $tags t_*]] lappend fields [lindex $tags [lsearch -glob $tags t_*]]
} }
#msgbox $fields
# Parsing page header # Parsing page header
set py 10 set py 10
foreach {field x y objid objtype} $fields { foreach {field x y objid objtype} $fields {
...@@ -2399,7 +2459,7 @@ incr py [expr $rbvar(y_pghdr)-$rbvar(y_rpthdr)] ...@@ -2399,7 +2459,7 @@ incr py [expr $rbvar(y_pghdr)-$rbvar(y_rpthdr)]
set di [lsearch $rbvar(regions) detail] set di [lsearch $rbvar(regions) detail]
set y_hi $rbvar(y_detail) set y_hi $rbvar(y_detail)
set y_lo $rbvar(y_[lindex $rbvar(regions) [expr $di-1]]) set y_lo $rbvar(y_[lindex $rbvar(regions) [expr $di-1]])
pg_select $dbc "select * from \"$rbvar(tablename)\"" rec { wpg_select $dbc "select * from \"$rbvar(tablename)\"" rec {
foreach {field x y objid objtype} $fields { foreach {field x y objid objtype} $fields {
if {($y>=$y_lo) && ($y<=$y_hi)} then { if {($y>=$y_lo) && ($y<=$y_hi)} then {
if {$objtype=="t_f"} { if {$objtype=="t_f"} {
...@@ -2461,7 +2521,7 @@ Window show .tiw ...@@ -2461,7 +2521,7 @@ Window show .tiw
set tiw(isunique) {} set tiw(isunique) {}
set tiw(isclustered) {} set tiw(isclustered) {}
set tiw(indexfields) {} set tiw(indexfields) {}
pg_select $dbc "select attnum,attname,typname,attlen,atttypmod,usename,pg_class.oid from pg_class,pg_user,pg_attribute,pg_type where (pg_class.relname='$tiw(tablename)') and (pg_class.oid=pg_attribute.attrelid) and (pg_class.relowner=pg_user.usesysid) and (pg_attribute.atttypid=pg_type.oid) order by attnum" rec { wpg_select $dbc "select attnum,attname,typname,attlen,atttypmod,usename,pg_class.oid from pg_class,pg_user,pg_attribute,pg_type where (pg_class.relname='$tiw(tablename)') and (pg_class.oid=pg_attribute.attrelid) and (pg_class.relowner=pg_user.usesysid) and (pg_attribute.atttypid=pg_type.oid) order by attnum" rec {
set fsize $rec(attlen) set fsize $rec(attlen)
set fsize1 $rec(atttypmod) set fsize1 $rec(atttypmod)
set ftype $rec(typname) set ftype $rec(typname)
...@@ -2478,25 +2538,28 @@ pg_select $dbc "select attnum,attname,typname,attlen,atttypmod,usename,pg_class. ...@@ -2478,25 +2538,28 @@ pg_select $dbc "select attnum,attname,typname,attlen,atttypmod,usename,pg_class.
set tiw(f$rec(attnum)) $rec(attname) set tiw(f$rec(attnum)) $rec(attname)
} }
set tiw(indexlist) {} set tiw(indexlist) {}
pg_select $dbc "select oid,indexrelid from pg_index where (pg_class.relname='$tiw(tablename)') and (pg_class.oid=pg_index.indrelid)" rec { wpg_select $dbc "select oid,indexrelid from pg_index where (pg_class.relname='$tiw(tablename)') and (pg_class.oid=pg_index.indrelid)" rec {
lappend tiw(indexlist) $rec(oid) lappend tiw(indexlist) $rec(oid)
pg_select $dbc "select relname from pg_class where oid=$rec(indexrelid)" rec1 { wpg_select $dbc "select relname from pg_class where oid=$rec(indexrelid)" rec1 {
.tiw.ilb insert end $rec1(relname) .tiw.ilb insert end $rec1(relname)
} }
} }
} }
proc {sql_exec} {how cmd} { proc {sql_exec} {how cmd} {
global dbc global dbc pgsql
set retval [catch {set pgr [pg_exec $dbc $cmd]} errmsg] if {[set pgr [wpg_exec $dbc $cmd]]==0} {
if { $retval } {
if {$how != "quiet"} {
show_error "Error executing query\n\n$cmd\n\nPostgreSQL error message:\n$errmsg"
}
return 0 return 0
} }
if {($pgsql(status)=="PGRES_COMMAND_OK") || ($pgsql(status)=="PGRES_TUPLES_OK")} {
pg_result $pgr -clear
return 1
}
if {$how != "quiet"} {
show_error "Error executing query\n\n$cmd\n\nPostgreSQL error message:\n$pgsql(errmsg)\nPostgreSQL status:$pgsql(status)"
}
pg_result $pgr -clear pg_result $pgr -clear
return 1 return 0
} }
proc {tab_click} {w} { proc {tab_click} {w} {
...@@ -2526,7 +2589,7 @@ global tiw dbc ...@@ -2526,7 +2589,7 @@ global tiw dbc
set cs [.tiw.ilb curselection] set cs [.tiw.ilb curselection]
if {$cs==""} return if {$cs==""} return
set idxname [.tiw.ilb get $cs] set idxname [.tiw.ilb get $cs]
pg_select $dbc "select pg_index.*,pg_class.oid from pg_index,pg_class where pg_class.relname='$idxname' and pg_class.oid=pg_index.indexrelid" rec { wpg_select $dbc "select pg_index.*,pg_class.oid from pg_index,pg_class where pg_class.relname='$idxname' and pg_class.oid=pg_index.indexrelid" rec {
if {$rec(indisunique)=="t"} { if {$rec(indisunique)=="t"} {
set tiw(isunique) Yes set tiw(isunique) Yes
} else { } else {
...@@ -2540,7 +2603,7 @@ pg_select $dbc "select pg_index.*,pg_class.oid from pg_index,pg_class where pg_c ...@@ -2540,7 +2603,7 @@ pg_select $dbc "select pg_index.*,pg_class.oid from pg_index,pg_class where pg_c
set tiw(indexfields) {} set tiw(indexfields) {}
foreach field $rec(indkey) { foreach field $rec(indkey) {
if {$field!=0} { if {$field!=0} {
# pg_select $dbc "select attname from pg_attribute where attrelid=$tiw(tableoid) and attnum=$field" rec1 { # wpg_select $dbc "select attname from pg_attribute where attrelid=$tiw(tableoid) and attnum=$field" rec1 {
# set tiw(indexfields) "$tiw(indexfields) $rec1(attname)" # set tiw(indexfields) "$tiw(indexfields) $rec1(attname)"
# } # }
set tiw(indexfields) "$tiw(indexfields) $tiw(f$field)" set tiw(indexfields) "$tiw(indexfields) $tiw(f$field)"
...@@ -2552,21 +2615,14 @@ set tiw(indexfields) [string trim $tiw(indexfields)] ...@@ -2552,21 +2615,14 @@ set tiw(indexfields) [string trim $tiw(indexfields)]
} }
proc {vacuum} {} { proc {vacuum} {} {
global dbc dbname sdbname global dbc dbname sdbname pgsql
if {$dbc==""} return; if {$dbc==""} return;
cursor_watch .dw
set sdbname "vacuuming database $dbname ..." set sdbname "vacuuming database $dbname ..."
update; update idletasks cursor_clock
set retval [catch { set pgres [wpg_exec $dbc "vacuum;"]
set pgres [pg_exec $dbc "vacuum;"] catch {pg_result $pgres -clear}
pg_result $pgres -clear cursor_normal
} msg]
cursor_arrow .dw
set sdbname $dbname set sdbname $dbname
if {$retval} {
show_error $msg
}
} }
proc {main} {argc argv} { proc {main} {argc argv} {
...@@ -2669,7 +2725,7 @@ proc vTclWindow.about {base} { ...@@ -2669,7 +2725,7 @@ proc vTclWindow.about {base} {
label $base.l2 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief groove -text {A Tcl/Tk interface to label $base.l2 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief groove -text {A Tcl/Tk interface to
PostgreSQL PostgreSQL
by Constantin Teodorescu} by Constantin Teodorescu}
label $base.l3 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief sunken -text {vers 0.90} label $base.l3 -borderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief sunken -text {vers 0.91}
label $base.l4 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief groove -text {You will always get the latest version at: label $base.l4 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -relief groove -text {You will always get the latest version at:
http://www.flex.ro/pgaccess http://www.flex.ro/pgaccess
...@@ -2867,6 +2923,8 @@ set sdbname {}} \ ...@@ -2867,6 +2923,8 @@ set sdbname {}} \
$base.menubutton23.01 add separator $base.menubutton23.01 add separator
$base.menubutton23.01 add command \ $base.menubutton23.01 add command \
-command cmd_Preferences -label Preferences -command cmd_Preferences -label Preferences
$base.menubutton23.01 add command \
-command "Window show .sqlw" -label "SQL window"
$base.menubutton23.01 add separator $base.menubutton23.01 add separator
$base.menubutton23.01 add command \ $base.menubutton23.01 add command \
-command {catch {pg_disconnect $dbc} -command {catch {pg_disconnect $dbc}
...@@ -3041,13 +3099,12 @@ proc vTclWindow.iew {base} { ...@@ -3041,13 +3099,12 @@ proc vTclWindow.iew {base} {
set sup2 "" set sup2 ""
} }
set sqlcmd "COPY $ie_tablename $sup2 $oper '$ie_filename'$sup" set sqlcmd "COPY $ie_tablename $sup2 $oper '$ie_filename'$sup"
cursor_watch .iew cursor_clock
if {[sql_exec noquiet $sqlcmd]} { if {[sql_exec noquiet $sqlcmd]} {
cursor_arrow .iew
tk_messageBox -title Information -message "Operation completed!" tk_messageBox -title Information -message "Operation completed!"
Window destroy .iew Window destroy .iew
} }
catch {cursor_arrow .iew} cursor_normal
}} -padx 9 -pady 3 -text Export }} -padx 9 -pady 3 -text Export
button $base.cancelbtn -borderwidth 1 -command {Window destroy .iew} -padx 9 -pady 3 -text Cancel button $base.cancelbtn -borderwidth 1 -command {Window destroy .iew} -padx 9 -pady 3 -text Cancel
checkbutton $base.oicb -borderwidth 1 -text {with OIDs} -variable oicb checkbutton $base.oicb -borderwidth 1 -text {with OIDs} -variable oicb
...@@ -3172,16 +3229,16 @@ proc vTclWindow.nt {base} { ...@@ -3172,16 +3229,16 @@ proc vTclWindow.nt {base} {
################### ###################
toplevel $base -class Toplevel toplevel $base -class Toplevel
wm focusmodel $base passive wm focusmodel $base passive
wm geometry $base 630x312+100+40 wm geometry $base 614x392+78+181
wm maxsize $base 1009 738 wm maxsize $base 1009 738
wm minsize $base 1 1 wm minsize $base 1 1
wm overrideredirect $base 0 wm overrideredirect $base 0
wm resizable $base 0 0 wm resizable $base 0 0
wm deiconify $base wm deiconify $base
wm title $base "Create table" wm title $base "Create new table"
entry $base.etabn \ entry $base.etabn \
-background #fefefe -borderwidth 1 -highlightthickness 1 \ -background #fefefe -borderwidth 1 -selectborderwidth 0 \
-selectborderwidth 0 -textvariable newtablename -textvariable ntw(newtablename)
bind $base.etabn <Key-Return> { bind $base.etabn <Key-Return> {
focus .nt.einh focus .nt.einh
} }
...@@ -3190,8 +3247,8 @@ proc vTclWindow.nt {base} { ...@@ -3190,8 +3247,8 @@ proc vTclWindow.nt {base} {
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
-relief raised -text Inherits -relief raised -text Inherits
entry $base.einh \ entry $base.einh \
-background #fefefe -borderwidth 1 -highlightthickness 1 \ -background #fefefe -borderwidth 1 -selectborderwidth 0 \
-selectborderwidth 0 -textvariable fathername -textvariable ntw(fathername)
bind $base.einh <Key-Return> { bind $base.einh <Key-Return> {
focus .nt.e2 focus .nt.e2
} }
...@@ -3200,39 +3257,46 @@ proc vTclWindow.nt {base} { ...@@ -3200,39 +3257,46 @@ proc vTclWindow.nt {base} {
-command {if {[winfo exists .nt.ddf]} { -command {if {[winfo exists .nt.ddf]} {
destroy .nt.ddf destroy .nt.ddf
} else { } else {
create_drop_down .nt 95 52 create_drop_down .nt 378 25 220
focus .nt.ddf.sb focus .nt.ddf.sb
foreach tbl [get_tables] {.nt.ddf.lb insert end $tbl} foreach tbl [get_tables] {.nt.ddf.lb insert end $tbl}
bind .nt.ddf.lb <ButtonRelease-1> { bind .nt.ddf.lb <ButtonRelease-1> {
set i [.nt.ddf.lb curselection] set i [.nt.ddf.lb curselection]
if {$i!=""} {set fathername [.nt.ddf.lb get $i]} if {$i!=""} {
after 50 {destroy .nt.ddf} if {$ntw(fathername)==""} {
set ntw(fathername) "\"[.nt.ddf.lb get $i]\""
} else {
set ntw(fathername) "$ntw(fathername),\"[.nt.ddf.lb get $i]\""
}
}
if {$i!=""} {focus .nt.e2} if {$i!=""} {focus .nt.e2}
destroy .nt.ddf
break
} }
}} \ }} \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
-highlightthickness 0 -padx 9 -pady 3 -takefocus 0 -text v -highlightthickness 0 -padx 9 -pady 3 -takefocus 0 -text v
entry $base.e2 \ entry $base.e2 \
-background #fefefe -borderwidth 1 -highlightthickness 1 \ -background #fefefe -borderwidth 1 -selectborderwidth 0 \
-selectborderwidth 0 -textvariable fldname -textvariable ntw(fldname)
bind $base.e2 <Key-Return> { bind $base.e2 <Key-Return> {
focus .nt.e1 focus .nt.e1
} }
entry $base.e1 \ entry $base.e1 \
-background #fefefe -borderwidth 1 -cursor {} -highlightthickness 1 \ -background #fefefe -borderwidth 1 -selectborderwidth 0 \
-selectborderwidth 0 -textvariable fldtype -textvariable ntw(fldtype)
bind $base.e1 <Key-Return> { bind $base.e1 <Key-Return> {
focus .nt.e5 focus .nt.e5
} }
entry $base.e3 \ entry $base.e3 \
-background #fefefe -borderwidth 1 -highlightthickness 1 \ -background #fefefe -borderwidth 1 -selectborderwidth 0 \
-selectborderwidth 0 -textvariable fldsize -textvariable ntw(fldsize)
bind $base.e3 <Key-Return> { bind $base.e3 <Key-Return> {
focus .nt.e5 focus .nt.e5
} }
entry $base.e5 \ entry $base.e5 \
-background #fefefe -borderwidth 1 -highlightthickness 1 \ -background #fefefe -borderwidth 1 -selectborderwidth 0 \
-selectborderwidth 0 -textvariable defaultval -textvariable ntw(defaultval)
bind $base.e5 <Key-Return> { bind $base.e5 <Key-Return> {
focus .nt.cb1 focus .nt.cb1
} }
...@@ -3240,11 +3304,11 @@ proc vTclWindow.nt {base} { ...@@ -3240,11 +3304,11 @@ proc vTclWindow.nt {base} {
-borderwidth 1 \ -borderwidth 1 \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
-offvalue { } -onvalue { NOT NULL} -text {field cannot be null} \ -offvalue { } -onvalue { NOT NULL} -text {field cannot be null} \
-variable notnull -variable ntw(notnull)
label $base.lab1 \ label $base.lab1 \
-borderwidth 0 \ -borderwidth 0 \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
-relief raised -text {Field type} -relief raised -text type
label $base.lab2 \ label $base.lab2 \
-borderwidth 0 \ -borderwidth 0 \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
...@@ -3252,7 +3316,7 @@ proc vTclWindow.nt {base} { ...@@ -3252,7 +3316,7 @@ proc vTclWindow.nt {base} {
label $base.lab3 \ label $base.lab3 \
-borderwidth 0 \ -borderwidth 0 \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
-relief raised -text {Field size} -relief raised -text size
label $base.lab4 \ label $base.lab4 \
-borderwidth 0 \ -borderwidth 0 \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
...@@ -3270,37 +3334,13 @@ proc vTclWindow.nt {base} { ...@@ -3270,37 +3334,13 @@ proc vTclWindow.nt {base} {
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \
-pady 3 -text {Delete all} -pady 3 -text {Delete all}
button $base.maketbl \ button $base.maketbl \
-borderwidth 1 \ -borderwidth 1 -command create_table \
-command {if {$newtablename==""} then {
show_error "You must supply a name for your table!"
focus .nt.etabn
} elseif {[.nt.lb size]==0} then {
show_error "Your table has no fields!"
focus .nt.e2
} else {
set temp "create table \"$newtablename\" ([join [.nt.lb get 0 end] ,])"
if {$fathername!=""} then {set temp "$temp inherits ($fathername)"}
cursor_watch .nt
set retval [catch {
set pgres [pg_exec $dbc $temp]
pg_result $pgres -clear
} errmsg ]
cursor_arrow .nt
if {$retval} {
show_error "Error creating table\n$errmsg"
} else {
.nt.lb delete 0 end
Window destroy .nt
cmd_Tables
}
}} \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \
-pady 3 -text {Create table} -pady 3 -text Create
listbox $base.lb \ listbox $base.lb \
-background #fefefe -borderwidth 1 \ -background #fefefe -borderwidth 1 \
-font -*-Clean-Medium-R-Normal--*-130-*-*-*-*-*-* \ -font -*-Clean-Medium-R-Normal--*-130-*-*-*-*-*-* \
-highlightthickness 1 -selectborderwidth 0 \ -selectborderwidth 0 -yscrollcommand {.nt.sb set}
-yscrollcommand {.nt.sb set}
bind $base.lb <ButtonRelease-1> { bind $base.lb <ButtonRelease-1> {
if {[.nt.lb curselection]!=""} { if {[.nt.lb curselection]!=""} {
set fldname [string trim [lindex [split [.nt.lb get [.nt.lb curselection]]] 0]] set fldname [string trim [lindex [split [.nt.lb get [.nt.lb curselection]]] 0]]
...@@ -3313,7 +3353,7 @@ proc vTclWindow.nt {base} { ...@@ -3313,7 +3353,7 @@ proc vTclWindow.nt {base} {
label $base.l1 \ label $base.l1 \
-anchor w -borderwidth 1 \ -anchor w -borderwidth 1 \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
-relief raised -text {field name} -relief raised -text { field name}
label $base.l2 \ label $base.l2 \
-borderwidth 1 \ -borderwidth 1 \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
...@@ -3330,7 +3370,7 @@ proc vTclWindow.nt {base} { ...@@ -3330,7 +3370,7 @@ proc vTclWindow.nt {base} {
-relief raised -text {Table name} -relief raised -text {Table name}
button $base.mvup \ button $base.mvup \
-borderwidth 1 \ -borderwidth 1 \
-command {if {[.nt.lb size]>2} { -command {if {[.nt.lb size]>1} {
set i [.nt.lb curselection] set i [.nt.lb curselection]
if {($i!="")&&($i>0)} { if {($i!="")&&($i>0)} {
.nt.lb insert [expr $i-1] [.nt.lb get $i] .nt.lb insert [expr $i-1] [.nt.lb get $i]
...@@ -3339,10 +3379,10 @@ proc vTclWindow.nt {base} { ...@@ -3339,10 +3379,10 @@ proc vTclWindow.nt {base} {
} }
}} \ }} \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \
-pady 3 -text {Move field up} -pady 3 -text {Move up}
button $base.mvdn \ button $base.mvdn \
-borderwidth 1 \ -borderwidth 1 \
-command {if {[.nt.lb size]>2} { -command {if {[.nt.lb size]>1} {
set i [.nt.lb curselection] set i [.nt.lb curselection]
if {($i!="")&&($i<[expr [.nt.lb size]-1])} { if {($i!="")&&($i<[expr [.nt.lb size]-1])} {
.nt.lb insert [expr $i+2] [.nt.lb get $i] .nt.lb insert [expr $i+2] [.nt.lb get $i]
...@@ -3351,93 +3391,121 @@ proc vTclWindow.nt {base} { ...@@ -3351,93 +3391,121 @@ proc vTclWindow.nt {base} {
} }
}} \ }} \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \
-pady 3 -text {Move field down} -pady 3 -text {Move down}
label $base.ll \
-borderwidth 1 \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
-relief sunken
button $base.button17 \ button $base.button17 \
-borderwidth 1 \ -borderwidth 1 \
-command {if {[winfo exists .nt.ddf]} { -command {
if {[winfo exists .nt.ddf]} {
destroy .nt.ddf destroy .nt.ddf
} else { } else {
create_drop_down .nt 95 125 create_drop_down .nt 291 80 97
focus .nt.ddf.sb focus .nt.ddf.sb
.nt.ddf.lb insert end char char2 char4 char8 char16 varchar text int2 int4 float4 float8 date datetime .nt.ddf.lb insert end char varchar text int2 int4 serial float4 float8 money abstime date datetime interval reltime time timespan timestamp boolean box circle line lseg path point polygon
bind .nt.ddf.lb <ButtonRelease-1> { bind .nt.ddf.lb <ButtonRelease-1> {
set i [.nt.ddf.lb curselection] set i [.nt.ddf.lb curselection]
if {$i!=""} {set fldtype [.nt.ddf.lb get $i]} if {$i!=""} {set ntw(fldtype) [.nt.ddf.lb get $i]}
after 50 {destroy .nt.ddf} destroy .nt.ddf
if {$i!=""} {focus .nt.e3} if {$i!=""} {focus .nt.e3}
break
} }
}} \ }} \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
-highlightthickness 0 -padx 9 -pady 3 -takefocus 0 -text v -highlightthickness 0 -padx 9 -pady 3 -takefocus 0 -text v
label $base.label18 \ label $base.lco \
-borderwidth 0 \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
-relief raised -text Constraint
entry $base.eco \
-background #fefefe -borderwidth 1 -textvariable ntw(constraint)
label $base.lch \
-borderwidth 0 \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
-relief raised -text check
entry $base.ech \
-background #fefefe -borderwidth 1 -textvariable ntw(check)
label $base.ll \
-borderwidth 1 \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
-relief raised
checkbutton $base.pk \
-borderwidth 1 \ -borderwidth 1 \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
-relief sunken -offvalue { } -onvalue * -text {primary key} -variable ntw(pk)
label $base.lpk \
-borderwidth 1 \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* \
-relief raised -text K
################### ###################
# SETTING GEOMETRY # SETTING GEOMETRY
################### ###################
place $base.etabn \ place $base.etabn \
-x 95 -y 7 -anchor nw -bordermode ignore -x 85 -y 5 -width 156 -height 20 -anchor nw -bordermode ignore
place $base.li \ place $base.li \
-x 10 -y 35 -anchor nw -bordermode ignore -x 245 -y 7 -width 42 -height 16 -anchor nw -bordermode ignore
place $base.einh \ place $base.einh \
-x 95 -y 32 -anchor nw -bordermode ignore -x 290 -y 5 -width 292 -height 20 -anchor nw -bordermode ignore
place $base.binh \ place $base.binh \
-x 242 -y 33 -width 16 -height 19 -anchor nw -bordermode ignore -x 582 -y 6 -width 16 -height 19 -anchor nw -bordermode ignore
place $base.e2 \ place $base.e2 \
-x 95 -y 80 -anchor nw -bordermode ignore -x 85 -y 60 -width 156 -height 20 -anchor nw -bordermode ignore
place $base.e1 \ place $base.e1 \
-x 95 -y 105 -anchor nw -bordermode ignore -x 291 -y 60 -width 81 -height 20 -anchor nw -bordermode ignore
place $base.e3 \ place $base.e3 \
-x 95 -y 130 -anchor nw -bordermode ignore -x 445 -y 60 -width 46 -height 20 -anchor nw -bordermode ignore
place $base.e5 \ place $base.e5 \
-x 95 -y 155 -anchor nw -bordermode ignore -x 85 -y 82 -width 156 -height 20 -anchor nw -bordermode ignore
place $base.cb1 \ place $base.cb1 \
-x 95 -y 180 -anchor nw -bordermode ignore -x 245 -y 83 -width 131 -height 20 -anchor nw -bordermode ignore
place $base.lab1 \ place $base.lab1 \
-x 10 -y 107 -anchor nw -bordermode ignore -x 247 -y 62 -width 26 -height 16 -anchor nw -bordermode ignore
place $base.lab2 \ place $base.lab2 \
-x 10 -y 82 -anchor nw -bordermode ignore -x 4 -y 62 -width 64 -height 16 -anchor nw -bordermode ignore
place $base.lab3 \ place $base.lab3 \
-x 10 -y 132 -anchor nw -bordermode ignore -x 410 -y 62 -width 24 -height 16 -anchor nw -bordermode ignore
place $base.lab4 \ place $base.lab4 \
-x 10 -y 157 -anchor nw -bordermode ignore -x 5 -y 83 -width 76 -height 16 -anchor nw -bordermode ignore
place $base.addfld \ place $base.addfld \
-x 10 -y 220 -anchor nw -bordermode ignore -x 534 -y 60 -width 75 -height 26 -anchor nw -bordermode ignore
place $base.delfld \ place $base.delfld \
-x 85 -y 220 -width 82 -anchor nw -bordermode ignore -x 534 -y 190 -width 75 -height 26 -anchor nw -bordermode ignore
place $base.emptb \ place $base.emptb \
-x 170 -y 220 -anchor nw -bordermode ignore -x 534 -y 220 -width 75 -height 26 -anchor nw -bordermode ignore
place $base.maketbl \ place $base.maketbl \
-x 10 -y 280 -width 156 -height 26 -anchor nw -bordermode ignore -x 534 -y 365 -width 75 -height 26 -anchor nw -bordermode ignore
place $base.lb \ place $base.lb \
-x 260 -y 25 -width 353 -height 281 -anchor nw -bordermode ignore -x 4 -y 121 -width 506 -height 269 -anchor nw -bordermode ignore
place $base.exitbtn \ place $base.exitbtn \
-x 170 -y 280 -width 77 -height 26 -anchor nw -bordermode ignore -x 534 -y 335 -width 75 -height 26 -anchor nw -bordermode ignore
place $base.l1 \ place $base.l1 \
-x 261 -y 9 -width 98 -height 18 -anchor nw -bordermode ignore -x 18 -y 105 -width 195 -height 18 -anchor nw -bordermode ignore
place $base.l2 \ place $base.l2 \
-x 360 -y 9 -width 86 -height 18 -anchor nw -bordermode ignore -x 213 -y 105 -width 88 -height 18 -anchor nw -bordermode ignore
place $base.l3 \ place $base.l3 \
-x 446 -y 9 -width 166 -height 18 -anchor nw -bordermode ignore -x 301 -y 105 -width 225 -height 18 -anchor nw -bordermode ignore
place $base.sb \ place $base.sb \
-x 610 -y 25 -width 18 -height 282 -anchor nw -bordermode ignore -x 509 -y 121 -width 18 -height 269 -anchor nw -bordermode ignore
place $base.l93 \ place $base.l93 \
-x 10 -y 10 -anchor nw -bordermode ignore -x 4 -y 7 -width 67 -height 16 -anchor nw -bordermode ignore
place $base.mvup \ place $base.mvup \
-x 10 -y 250 -width 118 -height 26 -anchor nw -bordermode ignore -x 534 -y 120 -width 75 -height 26 -anchor nw -bordermode ignore
place $base.mvdn \ place $base.mvdn \
-x 130 -y 250 -height 26 -anchor nw -bordermode ignore -x 534 -y 150 -width 75 -height 26 -anchor nw -bordermode ignore
place $base.ll \
-x 10 -y 210 -width 233 -height 2 -anchor nw -bordermode ignore
place $base.button17 \ place $base.button17 \
-x 242 -y 106 -width 16 -height 19 -anchor nw -bordermode ignore -x 372 -y 61 -width 16 -height 19 -anchor nw -bordermode ignore
place $base.label18 \ place $base.lco \
-x 10 -y 65 -width 233 -height 2 -anchor nw -bordermode ignore -x 5 -y 28 -width 58 -height 16 -anchor nw -bordermode ignore
place $base.eco \
-x 85 -y 27 -width 156 -height 20 -anchor nw -bordermode ignore
place $base.lch \
-x 245 -y 30 -anchor nw -bordermode ignore
place $base.ech \
-x 290 -y 27 -width 308 -height 22 -anchor nw -bordermode ignore
place $base.ll \
-x 5 -y 53 -width 591 -height 2 -anchor nw -bordermode ignore
place $base.pk \
-x 407 -y 83 -width 93 -height 20 -anchor nw -bordermode ignore
place $base.lpk \
-x 4 -y 105 -width 14 -height 18 -anchor nw -bordermode ignore
} }
proc vTclWindow.pw {base} { proc vTclWindow.pw {base} {
...@@ -3519,27 +3587,25 @@ proc vTclWindow.qb {base} { ...@@ -3519,27 +3587,25 @@ proc vTclWindow.qb {base} {
set qtype A set qtype A
} }
if {$cbv} { if {$cbv} {
tk_messageBox -message "create view $queryname as $qcmd" set pgres [wpg_exec $dbc "create view $queryname as $qcmd"]
set retval [catch {set pgres [pg_exec $dbc "create view $queryname as $qcmd"]} errmsg] if {$pgsql(status)!="PGRES_COMMAND_OK"} {
if {$retval} { show_error "Error defining view\n\n$pgsql(errmsg)"
show_error "Error defining view\n\n$errmsg"
} else { } else {
tab_click .dw.tabViews tab_click .dw.tabViews
Window destroy .qb Window destroy .qb
} }
catch {pg_result $pgres -clear}
} else { } else {
regsub -all "'" $qcmd "''" qcmd regsub -all "'" $qcmd "''" qcmd
cursor_watch .qb cursor_clock
set retval [catch {
if {$queryoid==0} then { if {$queryoid==0} then {
set pgres [pg_exec $dbc "insert into pga_queries values ('$queryname','$qtype','$qcmd')"] set pgres [wpg_exec $dbc "insert into pga_queries values ('$queryname','$qtype','$qcmd')"]
} else { } else {
set pgres [pg_exec $dbc "update pga_queries set queryname='$queryname',querytype='$qtype',querycommand='$qcmd' where oid=$queryoid"] set pgres [wpg_exec $dbc "update pga_queries set queryname='$queryname',querytype='$qtype',querycommand='$qcmd' where oid=$queryoid"]
} }
} errmsg] cursor_normal
cursor_arrow .qb if {$pgsql(status)!="PGRES_COMMAND_OK"} then {
if {$retval} then { show_error "Error executing query\n$pgres(errmsg)"
show_error "Error executing query\n$errmsg"
} else { } else {
cmd_Queries cmd_Queries
if {$queryoid==0} {set queryoid [pg_result $pgres -oid]} if {$queryoid==0} {set queryoid [pg_result $pgres -oid]}
...@@ -3645,14 +3711,17 @@ focus .qb} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -p ...@@ -3645,14 +3711,17 @@ focus .qb} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 -p
button $base.bdd -borderwidth 1 -command {if {[winfo exists .ql.ddf]} { button $base.bdd -borderwidth 1 -command {if {[winfo exists .ql.ddf]} {
destroy .ql.ddf destroy .ql.ddf
} else { } else {
create_drop_down .ql 70 27 create_drop_down .ql 70 27 200
focus .ql.ddf.sb focus .ql.ddf.sb
foreach tbl [get_tables] {.ql.ddf.lb insert end $tbl} foreach tbl [get_tables] {.ql.ddf.lb insert end $tbl}
bind .ql.ddf.lb <ButtonRelease-1> { bind .ql.ddf.lb <ButtonRelease-1> {
set i [.ql.ddf.lb curselection] set i [.ql.ddf.lb curselection]
if {$i!=""} {set qlvar(newtablename) [.ql.ddf.lb get $i]} if {$i!=""} {
after 50 {destroy .ql.ddf} set qlvar(newtablename) [.ql.ddf.lb get $i]
if {$i!=""} {ql_add_new_table} ql_add_new_table
}
destroy .ql.ddf
break
} }
}} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -highlightthickness 0 -padx 9 -pady 3 -text v }} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -highlightthickness 0 -padx 9 -pady 3 -text v
################### ###################
...@@ -3700,19 +3769,18 @@ proc vTclWindow.rf {base} { ...@@ -3700,19 +3769,18 @@ proc vTclWindow.rf {base} {
Window destroy .rf Window destroy .rf
} }
} elseif {$activetab=="Queries"} { } elseif {$activetab=="Queries"} {
set retval [catch {set pgres [pg_exec $dbc "select * from pga_queries where queryname='$newobjname'"]} errmsg] set pgres [wpg_exec $dbc "select * from pga_queries where queryname='$newobjname'"]
if {$retval} { if {$pgsql(status)!="PGRES_TUPLES_OK"} {
show_error $errmsg show_error "Error retrieving from pga_queries\n$pgsql(errmsg)\n$pgsql(status)"
} elseif {[pg_result $pgres -numTuples]>0} { } elseif {[pg_result $pgres -numTuples]>0} {
show_error "Query $newobjname already exists!" show_error "Query \"$newobjname\" already exists!"
pg_result $pgres -clear
} else { } else {
pg_result $pgres -clear
sql_exec noquiet "update pga_queries set queryname='$newobjname' where queryname='$oldobjname'" sql_exec noquiet "update pga_queries set queryname='$newobjname' where queryname='$oldobjname'"
sql_exec noquiet "update pga_layout set tablename='$newobjname' where tablename='$oldobjname'" sql_exec noquiet "update pga_layout set tablename='$newobjname' where tablename='$oldobjname'"
cmd_Queries cmd_Queries
Window destroy .rf Window destroy .rf
} }
catch {pg_result $pgres -clear}
} }
} -padx 9 -pady 3 -text Rename } -padx 9 -pady 3 -text Rename
button $base.b2 -borderwidth 1 -command {Window destroy .rf} -padx 9 -pady 3 -text Cancel button $base.b2 -borderwidth 1 -command {Window destroy .rf} -padx 9 -pady 3 -text Cancel
...@@ -3869,14 +3937,15 @@ rb_change_object_font} \ ...@@ -3869,14 +3937,15 @@ rb_change_object_font} \
-command {if {[winfo exists .rb.ddf]} { -command {if {[winfo exists .rb.ddf]} {
destroy .rb.ddf destroy .rb.ddf
} else { } else {
create_drop_down .rb 405 24 create_drop_down .rb 405 22 200
focus .rb.ddf.sb focus .rb.ddf.sb
foreach tbl [get_tables] {.rb.ddf.lb insert end $tbl} foreach tbl [get_tables] {.rb.ddf.lb insert end $tbl}
bind .rb.ddf.lb <ButtonRelease-1> { bind .rb.ddf.lb <ButtonRelease-1> {
set i [.rb.ddf.lb curselection] set i [.rb.ddf.lb curselection]
if {$i!=""} {set rbvar(tablename) [.rb.ddf.lb get $i]} if {$i!=""} {set rbvar(tablename) [.rb.ddf.lb get $i]}
after 50 {destroy .rb.ddf} destroy .rb.ddf
rb_get_report_fields rb_get_report_fields
break
} }
}} \ }} \
-font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \ -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \
...@@ -4677,6 +4746,67 @@ proc vTclWindow.fdtb {base} { ...@@ -4677,6 +4746,67 @@ proc vTclWindow.fdtb {base} {
-in .fdtb -column 0 -row 7 -columnspan 1 -rowspan 1 -in .fdtb -column 0 -row 7 -columnspan 1 -rowspan 1
} }
proc vTclWindow.sqlw {base} {
if {$base == ""} {
set base .sqlw
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
###################
# CREATING WIDGETS
###################
toplevel $base -class Toplevel
wm focusmodel $base passive
wm geometry $base 551x408+192+169
wm maxsize $base 1009 738
wm minsize $base 1 1
wm overrideredirect $base 0
wm resizable $base 1 1
wm deiconify $base
wm title $base "SQL commands"
frame $base.f \
-borderwidth 1 -height 392 -relief raised -width 396
scrollbar $base.f.01 \
-borderwidth 1 -command {.sqlw.f.t xview} -orient horiz \
-width 10
scrollbar $base.f.02 \
-borderwidth 1 -command {.sqlw.f.t yview} -orient vert -width 10
text $base.f.t \
-borderwidth 1 \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*-* \
-height 200 -width 200 -wrap word \
-xscrollcommand {.sqlw.f.01 set} \
-yscrollcommand {.sqlw.f.02 set}
button $base.b1 \
-borderwidth 1 -command {.sqlw.f.t delete 1.0 end} -padx 9 \
-pady 3 -text Clean
button $base.b2 \
-borderwidth 1 -command {destroy .sqlw} -padx 9 -pady 3 -text Close
###################
# SETTING GEOMETRY
###################
grid columnconf $base 0 -weight 1
grid columnconf $base 1 -weight 1
grid rowconf $base 0 -weight 1
grid $base.f \
-in .sqlw -column 0 -row 0 -columnspan 2 -rowspan 1
grid columnconf $base.f 0 -weight 1
grid rowconf $base.f 0 -weight 1
grid $base.f.01 \
-in .sqlw.f -column 0 -row 1 -columnspan 1 -rowspan 1 -sticky ew
grid $base.f.02 \
-in .sqlw.f -column 1 -row 0 -columnspan 1 -rowspan 1 -sticky ns
grid $base.f.t \
-in .sqlw.f -column 0 -row 0 -columnspan 1 -rowspan 1 \
-sticky nesw
grid $base.b1 \
-in .sqlw -column 0 -row 1 -columnspan 1 -rowspan 1
grid $base.b2 \
-in .sqlw -column 1 -row 1 -columnspan 1 -rowspan 1
}
Window show . Window show .
Window show .dw Window show .dw
......
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