From: Bruce Momjian Date: Mon, 20 Sep 1999 22:03:21 +0000 (+0000) Subject: Add new files. X-Git-Tag: REL6_5_3~28 X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=471881788fe4fde3c93aafe966a43644c86298b5;p=thirdparty%2Fpostgresql.git Add new files. --- diff --git a/src/bin/pgaccess/README b/src/bin/pgaccess/README new file mode 100644 index 00000000000..69a920ab679 --- /dev/null +++ b/src/bin/pgaccess/README @@ -0,0 +1,82 @@ +--------------------------------------------------------------------------- + +Copyright (c) 1994-7 Regents of the University of California + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose, without fee, and without a written agreement +is hereby granted, provided that the above copyright notice and this +paragraph and the following two paragraphs appear in all copies. + +IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR +DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES, INCLUDING +LOST PROFITS, ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS +DOCUMENTATION, EVEN IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY +AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS +ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATIONS TO +PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + +--------------------------------------------------------------------------- + + +PGACCESS 0.98 29 August 1999 +================================ +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 +time far from them. + + + +1. How to INSTALL ? + +You will need a Tcl/Tk package, at least Tcl 7.6 and Tk 4.2, recommended +Tcl/Tk 8.x + +For Unix users, unpack the pgaccess-xxx.tar.gz archieve in you preferred +directory (usually /usr/local). + +Check where your "wish" program is and modify (if needed) the file +/usr/local/pgaccess/pgaccess and set variables PGACCESS_HOME and +PATH_TO_WISH to the appropriate directories. + +Include the /usr/local/pgaccess directory into your PATH or make a +symbolic link to it wherever you want (in PATH directories). +Example: + +$ ln -s /usr/local/pgaccess/pgaccess /usr/bin/pgaccess + +You will find also some documentation and FAQ in the doc directory. + + + +2. Usage + +You run it with the command: + + pgaccess [database] + +[database] is optional. + + + +3. Bug reporting + +First of all : operating system, PostgreSQL version,Tcl/Tk version. +A more detailed story of what have you done when error occurred. +Tcl/Tk stops usually with a error message and there is a button there +"Stack Trace" and if you press it, you will see a detailed information +about the procedure containing the error. Please send it to me. +Some information about table structure, no. of fields, records would +be also good. + +=========================================================================== +You would find always the latest version at http://www.flex.ro/pgaccess + +Please feel free to e-mail me with any suggestion or bug description +that will help to improve it. + +Constantin Teodorescu + diff --git a/src/bin/pgaccess/copyright.html b/src/bin/pgaccess/copyright.html new file mode 100644 index 00000000000..d67654b88e7 --- /dev/null +++ b/src/bin/pgaccess/copyright.html @@ -0,0 +1,39 @@ + + + + + PgAccess - Copyright notice + + +--------------------------------------------------------------------------- +
  +
  + +

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

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

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

THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, +
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY +
AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER +IS +
ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATIONS +TO +
PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + + diff --git a/src/bin/pgaccess/doc/html/a_right.gif b/src/bin/pgaccess/doc/html/a_right.gif new file mode 100644 index 00000000000..386e27c304f Binary files /dev/null and b/src/bin/pgaccess/doc/html/a_right.gif differ diff --git a/src/bin/pgaccess/doc/html/addindex.gif b/src/bin/pgaccess/doc/html/addindex.gif new file mode 100644 index 00000000000..2ff0aa2084e Binary files /dev/null and b/src/bin/pgaccess/doc/html/addindex.gif differ diff --git a/src/bin/pgaccess/doc/html/api.html b/src/bin/pgaccess/doc/html/api.html new file mode 100644 index 00000000000..7630fd2054d --- /dev/null +++ b/src/bin/pgaccess/doc/html/api.html @@ -0,0 +1,232 @@ + + + + + + + + +

+PgAccess developer API

+ +
+
Starting with PgAccess 0.98 I am planning to make available a complete +API for the PgAccess developers. I plan to make PgAccess not just an administrative +tool, but also a tool for easy build of small applications. +

That's why PgAccess 0.98 has been internally restructured, every main +module of PgAccess has became a namespace (see Tcl namespaces) in order  +to hide the variables and internal procedures to the user. Also, all the +global variables that have been used before were grouped under a single +big associative array called PgAcVar (PgAccess variables) so they +should not interfere with user defined global variables. +
  +
  +

Global variables available +
  +

+ + + + + + + + + + + + + + + + + + + + + + + +
PgAcVarThe main global associative array that hold together various information +needed by PgAccess. User should NOT +alter it under any circumstances.
CurrentDBThe handler of the current opened database. Can be used for database +operations as selects or command execution.
MessagesThe associative array that holds the translation for the current +language. Loaded from the appropriate language file from lib/languages +directory
PGACCESS_HOMEKeep the system directory of PgAccess root installation
+ +
  +

Window naming convention +

Every toplevel window defined by PgAccess has the following naming convention. +Every window name starts with .pgaw (PgAccess window) followed +by a colon and a name. Example: +

.pgaw:User , .pgaw:About , .pgaw:ImportExport
+Namespaces available +

For every tab from the main database window there is a namespace defined +(Tables, Queries, Views, Functions, Sequences, Reports, Forms, Scripts, +Users, Schema). Every namespace has by default the following  procedures: +

+You can use these procedures if you want to produce the same efects as +clicking on the desired tab and then on the "New", "Open" or "Design" buttons +from the main database window. +
Example: +
Tables::open "customers" +
Queries::open "Invoices received" +
Forms::open "Add new invoice"
+The Tables::open procedure accepts two optional parameters, filter +and order. +
Example: +
Tables::open "phonebook" "name ~* 'joe'" "age desc"
+will open a table view window with predefined filter "name ~* 'joe'" and +ordered by descending age. +

There is also a special namespace called Database.  Here are some +procedures and functions defined for this namespace available to the user: +
  + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
NameParametersTypeReturnsDescription
vacuumnoneprocedurenothingvacuums the current database
getTablesListnonefunctionlistreturns the list of tables from the current database
executeUpdatesqlcmdfunctionintegerexecute the sqlcmd command on the current database returning +1 if no errors ocurred or 0 if the command failed
+ +

Global functions available +
  + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
NameParametersDescription
setCursortypeSet the cursor for all PgAccess windows, type of cursor can +be WAIT or CLOCK or WATCH for the hourglass , anything else (or none) to +return to the normal cursor shape
parametermsgShows a modal input dialog with the msg message, wait for user +to enter the data and returns it as a string
showErrormsgShows a modal dialog window with an error message
+ + + diff --git a/src/bin/pgaccess/doc/html/ball.gif b/src/bin/pgaccess/doc/html/ball.gif new file mode 100644 index 00000000000..02d203471ed Binary files /dev/null and b/src/bin/pgaccess/doc/html/ball.gif differ diff --git a/src/bin/pgaccess/doc/html/contents.html b/src/bin/pgaccess/doc/html/contents.html new file mode 100644 index 00000000000..971f3f43dce --- /dev/null +++ b/src/bin/pgaccess/doc/html/contents.html @@ -0,0 +1,29 @@ + + + + + + + + +What is PgAccess? +
What's new? +
Features +
Screenshots +
FAQ +
Documentation +
To-Do list +
Download +
  +


+

+

+ +

Other links +
PostgreSQL +
Visual Tcl +
Tcl/Tk +
Linux +
vTcLava + + diff --git a/src/bin/pgaccess/doc/html/copyright.html b/src/bin/pgaccess/doc/html/copyright.html new file mode 100644 index 00000000000..d67654b88e7 --- /dev/null +++ b/src/bin/pgaccess/doc/html/copyright.html @@ -0,0 +1,39 @@ + + + + + PgAccess - Copyright notice + + +--------------------------------------------------------------------------- +
  +
  + +

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

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

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

THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, +
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY +
AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER +IS +
ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATIONS +TO +
PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + + diff --git a/src/bin/pgaccess/doc/html/documentation.html b/src/bin/pgaccess/doc/html/documentation.html new file mode 100644 index 00000000000..48d3fa5ec14 --- /dev/null +++ b/src/bin/pgaccess/doc/html/documentation.html @@ -0,0 +1,19 @@ + + + + + + + + +

+Documentation

+ +
+

Still need to be written. Some information can be found in the help +included in the main program. +

Jim Lemon <Jim.Lemon@uts.EDU.AU> has started writing a tutorial. +Thought it is based on earlier versions than 0.98 it is a beginning after +all, isn't it ? + + diff --git a/src/bin/pgaccess/doc/html/download.html b/src/bin/pgaccess/doc/html/download.html new file mode 100644 index 00000000000..efbe7bf50aa --- /dev/null +++ b/src/bin/pgaccess/doc/html/download.html @@ -0,0 +1,42 @@ + + + + + + + + +

+Download

+ +
+
The primary site for PgAccess downloads is: + + +

Another one (just with a little bit faster, try this one first) would +be : +

+ +
  + + diff --git a/src/bin/pgaccess/doc/html/faq.html b/src/bin/pgaccess/doc/html/faq.html new file mode 100644 index 00000000000..f66dd8321ac --- /dev/null +++ b/src/bin/pgaccess/doc/html/faq.html @@ -0,0 +1,85 @@ + + + + + + + + +

+PgAccess - FAQ

+ +
+
1. When I run PgAccess I got a message complaining about the crypt +library! What should I do? +
Versions of PostgreSQL prior to 6.5.1 couldn't reliably detect +the presence of the crypt library on RedHat 5.x systems. That's why the +libpgtcl library does not include reference to crypt. You will need to +get a proper copy of libpgtcl.so library or to compile one. Go to the postgresql +source directory into src/interfaces/libpgtcl and edit Makefile adding +-lcrypt to the end of the line SHLIB_LINKS. Make clean and make again. +Your libpgtcl.so is now prepare to run PgAccess. I strongly recommend you +to upgrade to PostgreSQL 6.5.1 where this problem has been solved.
+2. I cannot connect to a database from another machine +
There may be two problems here. First of all, PgAccess running +on the localhost is using two PostgreSQL dependent libraries, libpq and +libpgtcl. Each of them are compiled for a specific PostgreSQL version. +If the PostgreSQL version running on your server is different you might +experience problems. The other problem is related to access rights. On +the PostgreSQL server, in data directory there is a file pg_hba.conf that +will grant access rights to users based on host authentication. Ask your +database administrator to check if your workstation is listed there with +the appropriate access rights. Try for the beginning the 'trust' mode, +allowing full access to the databases.
+3. I am experiencing core dumps when trying to run PgAccess. Is PgAccess +broken? +
No. There were NEVER reported crashes because of PgAccess. +All of them were related to bad libraries usage. The most frequent was +the installing of a new PostgreSQL on a RedHat 5.x server where the postgresql-clients +rpm still exists. So, PgAccess was trying to use the old libpgtcl.so library +suitable for an older version of PostgreSQL. Before installing a new PostgreSQL +(either by compiling it ot by rpm packages) remove ANY TRACE of old PostgreSQL. +PgAccess is fully relying on libpgtcl library in order to get access to +the database so when you are experiencing that kind of problems, double-check +libpq and libpgtcl libraries.
+4. When I try to run PgAccess I get the following error : Application +initialization failed: couldn't connect to display "" +
That kind of error was reported on some Linux RedHat 5.x systems +when user has su - to root and tried to run PgAccess. Some unknown errors +in login scripts are not defining the DISPLAY environment and the wish +application cannot connect to the X display. Try typing export DISPLAY=localhost:0.0 +and run PgAccess again.
+5. Cannot run PgAccess on a Windows machine. +
In order to use PgAccess on Windows you must have installed +two libraries libpq.dll and libpgtcl.dll suitable for your Tcl/Tk package +and your PostgreSQL server. Note that libraries that work with Tcl/Tk 8.0.x +won't work with Tcl/Tk 8.1.x and libraries that work with 6.4.2 backend +won't work with 6.5.x. So, you must properly identify your Tcl/Tk package +version and your PostgreSQL version and download from the Downloads section +(or pick from the win32/dll directory of PgAccess distribution) the right +files. Copy them into your Windows/System directory and try again. Also, +you should be able to access over the network the machine running the PostgreSQL +server (try ping-ing it) and have the proper access rights to the database.
+6. How much costs PgAccess? +
PgAccess is a free tool. You won't have to pay anything in +order to use it. It is protected by the following copyright +as PostgreSQL is. I cannot guarantee technical support but I will try to +answer to your questions as much as I can.
+7. I want to translate PgAccess messages for xxx language. What should +I do? +
In the PgAccess distribution in lib/languages directory there +are files with messages translated for different languages. Copy one of +them and name it after your native language and then start editing it translating +all the messages. Save it into the same directory and that's all. Don't +forget to send me a copy in order to include it into the standard distribution.
+ +


8. I am receiving the following error: message invalid command +name "namespace" while executing "namespace eval Mainlib  ..." +

That means 100% that you have an older version of Tcl/Tk that +don't recognize namespaces command. Please upgrade to Tcl/Tk 8.0.x minimum
+ +
  +
  +
  + + diff --git a/src/bin/pgaccess/doc/html/features.html b/src/bin/pgaccess/doc/html/features.html new file mode 100644 index 00000000000..4531663be38 --- /dev/null +++ b/src/bin/pgaccess/doc/html/features.html @@ -0,0 +1,52 @@ + + + + + + + +Tables +
- opening multiple tables for viewing, max. n records (changed by preferences +menu) +
- column resizing, dragging the vertical grid line (better in table +space rather than in the table header) +
- text wrap in cells - layout saved for every table +
- import/export to external files (SDF,CSV) +
- filter capabilities (enter filter like (price>3.14) +
- sort order capabilities (enter manually the sort field(s)) +
- editing in place +
- improved table generator assistant +
- improved field editing +
Queries +
- define , edit and stores "user defined queries" +
- store queries as views +
- execution of queries with optional user input parameters ( select +* from invoices where year=[parameter "Year of selection"] ) +
- viewing of select type queries result +
- query deleting and renaming +
- visual query builder with drag & drop capabilities. For any of +you who had installed the Tcl/Tk plugin for Netscape Navigator, you can +see it at work clicking here +
Sequences +
- defines sequences, delete them and inspect them +
Functions +
- define, inspect and delete functions in SQL, plpgsql and pgtcl languages +
Reports +
- design and display simple reports from tables +
- fields and labels, font changing, style and size +
- saves and loads report description from database +
- show report previews, sample postscript output file +
Forms +
- open user defined forms +
- form design module available +
- query widget available, controls bound to query results +
- click here for a description of forms and +how they can be used +
Scripts +
- define, modify and call user defined scripts +
Users +
- define and modify user information +

PgAccess API for developing small applications +
  + + diff --git a/src/bin/pgaccess/doc/html/formdemo.sql b/src/bin/pgaccess/doc/html/formdemo.sql new file mode 100644 index 00000000000..73bf1c5027f --- /dev/null +++ b/src/bin/pgaccess/doc/html/formdemo.sql @@ -0,0 +1,216 @@ +\connect - teo +CREATE SEQUENCE "cities_id_seq" start 7 increment 1 maxvalue 2147483647 minvalue 1 cache 1 ; +SELECT nextval ('cities_id_seq'); +CREATE TABLE "pga_queries" ( + "queryname" character varying(64), + "querytype" character, + "querycommand" text, + "querytables" text, + "querylinks" text, + "queryresults" text, + "querycomments" text); +CREATE TABLE "pga_forms" ( + "formname" character varying(64), + "formsource" text); +CREATE TABLE "pga_scripts" ( + "scriptname" character varying(64), + "scriptsource" text); +CREATE TABLE "pga_reports" ( + "reportname" character varying(64), + "reportsource" text, + "reportbody" text, + "reportprocs" text, + "reportoptions" text); +CREATE TABLE "phonebook" ( + "name" character varying(32), + "phone_nr" character varying(16), + "city" character varying(32), + "company" bool, + "continent" character varying(16)); +CREATE TABLE "pga_layout" ( + "tablename" character varying(64), + "nrcols" int2, + "colnames" text, + "colwidth" text); +CREATE TABLE "pga_schema" ( + "schemaname" character varying(64), + "schematables" text, + "schemalinks" text); +REVOKE ALL on "pga_schema" from PUBLIC; +GRANT ALL on "pga_schema" to PUBLIC; +CREATE TABLE "cities" ( + "id" int4 DEFAULT nextval('"cities_id_seq"') NOT NULL, + "name" character varying(32) NOT NULL, + "prefix" character varying(16) NOT NULL); +CREATE FUNCTION "getcityprefix" (int4 ) RETURNS varchar AS 'select prefix from cities where id = $1 ' LANGUAGE 'SQL'; +COPY "pga_queries" FROM stdin; +Query that can be saved as view S select * from phonebook where continent='usa' \N \N \N \N +\. +COPY "pga_forms" FROM stdin; +Working with Tables namespace f3 13 {3 4 5 6 7 9 10 11 12 13} 377x263+59+127 {radio usa {36 24 138 36} {} USA selcont} {radio europe {36 45 141 60} {} Europe selcont} {radio africa {36 66 147 81} {} Africa selcont} {label label6 {9 99 339 114} {} {Select one of the above continents and press} {}} {button button7 {270 93 354 117} {Tables::open phonebook "continent='$selcont'" $selorder} {Show them} {}} {button button9 {66 189 312 213} {Tables::design phonebook} {Show me the phonebook table structure} {}} {button button10 {141 228 240 252} {destroy .f3} {Close the form} {}} {button button11 {93 141 282 165} {Tables::open phonebook "company=true"} {Show me only the companies} {}} {radio name {183 24 261 36} {} {Order by name} selorder} {radio phone_nr {183 45 267 57} {} {Order by phone number} selorder} +A simple demo form asdf 14 {FS {set color none}} 370x310+50+75 {label label1 {15 36 99 57} {} {Selected color} {} label1 flat #000000 #d9d9d9 1} {entry entry2 {111 36 225 54} {} entry2 color entry2 sunken #000000 #fefefe 1} {radio red {249 21 342 36} {} {Red as cherry} color red flat #900000 #d9d9d9 1} {radio green {249 45 342 60} {} {Green as a melon} color green flat #008800 #d9d9d9 1} {radio blue {249 69 342 84} {} {Blue as the sky} color blue flat #00008c #d9d9d9 1} {button button6 {45 69 198 99} {set color spooky} {Set a weird color} {} button6 ridge #0000b0 #dfbcdf 2} {label label7 {24 129 149 145} {} {The checkbox's value} {} label7 flat #000000 #d9d9d9 1} {entry entry8 {162 127 172 145} {} entry8 cbvalue entry8 sunken #000000 #fefefe 1} {checkbox checkbox9 {180 126 279 150} {} {Check me :-)} cbvalue checkbox9 flat #000000 #d9d9d9 1} {button button10 {219 273 366 303} {destroy .asdf} {Close that simple form} {} button10 raised #000000 #d9d9d9 1} {button button11 {219 237 366 267} {Forms::open "Phone book"} {Open my phone book} {} button11 raised #000000 #d9d9d9 1} {listbox lb {12 192 162 267} {} listbox12 {} lb sunken #000000 #fefefe 1} {button button13 {12 156 162 186} {.asdf.lb insert end red green blue cyan white navy black purple maroon violet} {Add some information} {} button13 raised #000000 #d9d9d9 1} {button button14 {12 273 162 303} {.asdf.lb delete 0 end} {Clear this listbox} {} button14 raised #000000 #d9d9d9 1} +Working with listboxes f2 5 {FS {set thestudent ""}} 257x263+139+147 {listbox lb {6 6 246 186} {} listbox1 {} lb sunken #000000 #ffffd4 1} {button button2 {9 234 124 258} {# Populate the listbox with some data\ +#\ +\ +foreach student {John Bill Doe Gigi} {\ +\ .f2.lb insert end $student\ +}\ +\ +\ +\ +# Binding the event left button release to the\ +# list box\ +\ +bind .f2.lb {\ +\ set idsel [.f2.lb curselection]\ +\ if {$idsel!=""} {\ +\ \ set thestudent [.f2.lb get $idsel]\ +\ }\ +}\ +\ +# Cleaning the variable thestudent\ +\ +set thestudent {}} {Show students} {} button2 groove #000000 #d9d9d9 2} {button button3 {132 234 247 258} {destroy .f2} {Close the form} {} button3 groove #000000 #d9d9d9 1} {label label4 {9 213 119 228} {} {You have selected} {} label4 flat #000000 #d9d9d9 1} {label label5 {129 213 219 228} {} {} thestudent label5 flat #00009a #d9d9d9 1} +The simplest form mf 5 {FS {set thename {}}} 306x136+82+146 {label label {42 45 99 60} {} Name {} label flat #000000 #d9d9d9 1 {Helvetica 12 bold italic}} {entry ename {120 42 219 63} {} entry2 thename ename sunken #000000 #fefefe 1 n} {button button3 {6 96 108 129} {set thename Teo} {Set the name} {} button3 raised #000000 #d9d9d9 1 n} {button button4 {192 96 300 129} {destroy .mf} {Close the form} {} button4 raised #000000 #d9d9d9 1 n} {button button5 {114 96 186 129} {set thename {}} {Clear it} {} button5 raised #000000 #d9d9d9 1 n} +Full featured form full 21 {FS {set entrydemo {nice}\ +set color {no color selected}}} 377x418+50+130 {label label1 {3 396 165 411} {} {Status line} {} {} sunken #000000 #d9d9d9 2 n} {label label2 {171 396 369 411} {} {Grooved status line} {} {} groove #000098 #d9d9d9 2 f} {label label3 {108 9 270 31} {} { Full featured form} {} {} ridge #000000 #d9d9d9 4 {Times 16 bold italic}} {button button4 {15 210 144 243} {.full.lb insert end {it's} a nice demo form} {Java style button} {} {} groove #6161b6 #d9d9d9 2 b} {label label5 {15 42 115 58} {} {Java style label} {} {} flat #6161b6 #d9d9d9 1 b} {entry entry6 {123 39 279 60} {} entry6 entrydemo {} groove #000000 #fefefe 2 {Courier 13}} {listbox lb {12 69 147 201} {} listbox8 {} {} ridge #000000 #ffffc8 2 n} {button button9 {18 264 39 282} {} 1 {} {} flat #000000 #d9d9d9 1 n} {button button10 {48 264 68 282} {} 2 {} {} flat #000000 #d9d9d9 1 n} {button button11 {78 264 234 282} {} {and other hidden buttons} {} {} flat #000000 #d9d9d9 1 n} {text txt {153 69 372 201} {} text12 {} {} sunken #000000 #d4ffff 1 n} {button button13 {150 210 369 243} {.full.txt tag configure bold -font {Helvetica 12 bold}\ +.full.txt tag configure italic -font {Helvetica 12 italic}\ +.full.txt tag configure large -font {Helvetica -14 bold}\ +.full.txt tag configure title -font {Helvetica 12 bold italic} -justify center\ +.full.txt tag configure link -font {Helvetica -12 underline} -foreground #000080\ +.full.txt tag configure code -font {Courier 13}\ +.full.txt tag configure warning -font {Helvetica 12 bold} -foreground #800000\ +\ +# That't the way help files are written\ +\ +.full.txt delete 1.0 end\ +.full.txt insert end {Centered title} {title} "\ +\ +You can make different " {} "portions of text bold" {bold} " or italic " {italic} ".\ +Some parts of them can be written as follows" {} "\ +SELECT * FROM PHONEBOOK" {code} "\ +You can also change " {} "colors for some words " {warning} "or underline them" {link} } {Old style button} {} {} raised #000000 #d9d9d9 2 n} {checkbox checkbox14 {48 297 153 309} {} different {} {} flat #00009c #d9d9d9 1 b} {checkbox checkbox15 {48 321 156 336} {} {fonts and} {} {} flat #cc0000 #d9d9d9 1 i} {checkbox checkbox16 {48 345 156 360} {} colors {} {} flat #00b600 #dfb2df 1 f} {radio radio17 {207 297 330 315} {} {red , rosu , rouge} color red flat #9c0000 #d9d9d9 1 n} {radio radio18 {207 321 324 333} {} {green , verde , vert} color green flat #009000 #d9d9d9 1 n} {radio radio19 {207 345 327 363} {} {blue , albastru, bleu} color blue flat #000000 #d9d9d9 1 n} {label selcolor {210 369 345 384} {} {} color {} flat #000000 #d9d9d9 1 n} {button button21 {285 258 363 285} {destroy .full} Exit {} {} raised #7c0000 #dfdbb8 1 b} +Phone book pb 28 {FS {}} 444x307+284+246 {label label1 {33 10 68 28} {} Name {} label1 flat #000000 #d9d9d9 1 n} {entry name_entry {87 9 227 27} {} entry2 DataSet(.pb.qs,name) name_entry sunken #000000 #fefefe 1 n} {label label3 {33 37 73 52} {} Phone {} label3 flat #000000 #d9d9d9 1 n} {entry entry4 {87 36 195 54} {} entry4 DataSet(.pb.qs,phone_nr) entry4 sunken #000000 #fefefe 1 n} {label label5 {33 64 78 82} {} City {} label5 flat #000000 #d9d9d9 1 n} {entry entry6 {87 63 195 81} {} entry6 DataSet(.pb.qs,city) entry6 sunken #000000 #fefefe 1 n} {query qs {3 6 33 33} {} query7 {} qs flat {} {} 1 n} {button button8 {174 177 246 203} {namespace eval DataControl(.pb.qs) {\ +\ setSQL "select oid,* from phonebook where name ~* '$what' order by name"\ +\ open\ +\ set nrecs [getRowCount]\ +\ updateDataSet\ +\ fill .pb.allnames name\ +\ bind .pb.allnames {\ +\ set ancr [.pb.allnames curselection]\ +\ if {$ancr!=""} {\ +\ \ DataControl(.pb.qs)::moveTo $ancr\ +\ \ DataControl(.pb.qs)::updateDataSet\ +\ }\ +\ }\ +}} {Start search} {} button8 raised #000000 #d9d9d9 1 n} {button button9 {363 276 433 300} {DataControl(.pb.qs)::close\ +DataControl(.pb.qs)::clearDataSet\ +set nrecs {}\ +set what {}\ +destroy .pb\ +} Exit {} button9 raised #000000 #d9d9d9 2 n} {button button10 {291 237 313 257} {namespace eval DataControl(.pb.qs) {\ +\ moveFirst\ +\ updateDataSet\ +}\ +} |< {} button10 ridge #000092 #d9d9d9 2 n} {button button11 {324 237 346 257} {namespace eval DataControl(.pb.qs) {\ +\ movePrevious\ +\ updateDataSet\ +}\ +} << {} button11 ridge #000000 #d9d9d9 2 n} {button button12 {348 237 370 257} {namespace eval DataControl(.pb.qs) {\ +\ moveNext\ +\ updateDataSet\ +}} >> {} button12 ridge #000000 #d9d9d9 2 n} {button button13 {381 237 403 257} {namespace eval DataControl(.pb.qs) {\ +\ moveLast\ +\ updateDataSet\ +}\ +} >| {} button13 ridge #000088 #d9d9d9 2 n} {checkbox checkbox14 {33 87 126 105} {} {Is it a company ?} DataSet(.pb.qs,company) checkbox14 flat #000000 #d9d9d9 1 n} {radio usa {63 108 201 120} {} U.S.A. DataSet(.pb.qs,continent) usa flat #000000 #d9d9d9 1 n} {radio europe {63 126 204 141} {} Europe DataSet(.pb.qs,continent) europe flat #000000 #d9d9d9 1 n} {radio africa {63 144 210 159} {} Africa DataSet(.pb.qs,continent) africa flat #000000 #d9d9d9 1 n} {entry entry18 {129 180 169 198} {} entry18 what entry18 sunken #000000 #fefefe 1 n} {label label19 {108 219 188 234} {} {records found} {} label19 flat #000000 #d9d9d9 1 n} {label label20 {90 219 105 234} {} { } nrecs label20 flat #000000 #d9d9d9 1 n} {label label21 {3 252 33 267} {} OID= {} label21 flat #000000 #d9d9d9 1 n} {label label22 {39 252 87 267} {} { } pbqs(oid) label22 flat #000000 #d9d9d9 1 n} {button button23 {9 276 79 300} {set oid {}\ +catch {set oid $DataSet(.pb.qs,oid)}\ +if {[string trim $oid]!=""} {\ + sql_exec noquiet "update phonebook set name='$DataSet(.pb.qs,name)', phone_nr='$DataSet(.pb.qs,phone_nr)',city='$DataSet(.pb.qs,city)',company='$DataSet(.pb.qs,company)',continent='$DataSet(.pb.qs,continent)' where oid=$oid"\ +} else {\ + tk_messageBox -title Error -message "No record is displayed!"\ +}\ +\ +} Update {} button23 raised #000000 #d9d9d9 1 n} {button button24 {210 276 280 300} {set thisname $DataSet(.pb.qs,name)\ +if {[string trim $thisname] != ""} {\ +\ sql_exec noquiet "insert into phonebook values (\ +\ \ '$DataSet(.pb.qs,name)',\ +\ \ '$DataSet(.pb.qs,phone_nr)',\ +\ \ '$DataSet(.pb.qs,city)',\ +\ \ '$DataSet(.pb.qs,company)',\ +\ \ '$DataSet(.pb.qs,continent)'\ +\ )"\ +\ tk_messageBox -title Information -message "A new record has been added!"\ +} else {\ +\ tk_messageBox -title Error -message "This one doesn't have a name?"\ +}\ +\ +} {Add record} {} button24 raised #000000 #d9d9d9 1 n} {button button25 {141 276 204 300} {DataControl(.pb.qs)::clearDataSet\ +# clearcontrols stillinitialise\ +# incorectly booleans controls to {}\ +# so I force it to 'f' (false)\ +set DataSet(.pb.qs,company) f\ +focus .pb.name_entry} {Clear all} {} button25 raised #000000 #d9d9d9 1 n} {listbox allnames {249 6 435 231} {} listbox26 {} allnames sunken #000000 #fefefe 1 n} {label label27 {33 252 90 267} {} {} DataSet(.pb.qs,oid) label27 flat #000000 #d9d9d9 1 n} {label label28 {3 182 128 197} {} {Find name containing} {} {} flat #000000 #d9d9d9 1 n} +\. +COPY "pga_scripts" FROM stdin; +How are forms keeped inside ? Tables::open pga_forms\ +\ +\ +\ + +Opening a table with filters Tables::open phonebook "name ~* 'e'" "name desc"\ +\ +\ + +Autoexec Mainlib::tab_click Forms\ +Forms::open {Full featured form}\ +\ +\ + +\. +COPY "pga_reports" FROM stdin; +My phone book phonebook set PgAcVar(report,tablename) "phonebook" ; set PgAcVar(report,y_rpthdr) 21 ; set PgAcVar(report,y_pghdr) 47 ; set PgAcVar(report,y_detail) 66 ; set PgAcVar(report,y_pgfoo) 96 ; set PgAcVar(report,y_rptfoo) 126 ; .pgaw:ReportBuilder.c create text 10 35 -font -Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-* -anchor nw -text {name} -tags {t_l mov ro} ; .pgaw:ReportBuilder.c create text 10 52 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -anchor nw -text {name} -tags {f-name t_f rg_detail mov ro} ; .pgaw:ReportBuilder.c create text 141 36 -font -Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-* -anchor nw -text {city} -tags {t_l mov ro} ; .pgaw:ReportBuilder.c create text 141 51 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -anchor nw -text {city} -tags {f-city t_f rg_detail mov ro} ; .pgaw:ReportBuilder.c create text 231 35 -font -Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-* -anchor nw -text {phone_nr} -tags {t_l mov ro} ; .pgaw:ReportBuilder.c create text 231 51 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -anchor nw -text {phone_nr} -tags {f-phone_nr t_f rg_detail mov ro} \N \N +\. +COPY "phonebook" FROM stdin; +FIAT 623463445 t europe +Gelu Voican 01-32234 Bucuresti f europe +Radu Vasile 01-5523423 Bucuresti f europe +MUGADUMBU SRL +92 534662634 Cairo t africa +Jimmy Page 66323452 f europe +IBM 623346234 \N t usa +John Doe +44 35 2993825 Washington f usa +Bill Clinton +44 35 9283845 New York f usa +Monica Levintchi +44 38 5234526 Dallas f usa +Bill Gates +42 64 4523454 Los Angeles f usa +COMPAQ 623462345 \N t usa +SUN 784563253 \N t usa +DIGITAL 922644516 \N t usa +Frank Zappa 6734567 Montreal f usa +Constantin Teodorescu +40 39 611820 Braila f europe +Ngbendu Wazabanga 34577345 f africa +Mugabe Kandalam 7635745 f africa +Vasile Lupu 52345623 Bucuresti f europe +Gica Farafrica +42 64 4523454 Los Angeles f usa +Victor Ciorbea 634567 Bucuresti f europe +\. +COPY "pga_layout" FROM stdin; +pga_forms 2 formname formsource 82 713 +Usaisti 5 name phone_nr city company continent 150 150 150 150 150 +q1 5 name phone_nr city company continent 150 150 150 150 150 +view_saved_from_that_query 5 name phone_nr city company continent 150 150 150 150 150 +phonebook 5 name phone_nr city company continent 150 105 80 66 104 +Query that can be saved as view 5 name phone_nr city company continent 150 150 150 150 150 +cities 3 id name prefix 150 150 150 +\. +COPY "pga_schema" FROM stdin; +Simple schema cities 10 10 phonebook 201.0 84.0 {cities name phonebook city} +\. +COPY "cities" FROM stdin; +3 Braila 4039 +4 Galati 4036 +5 Dallas 5362 +6 Cairo 9352 +1 Bucuresti 4013 +7 Montreal 5325 +\. +CREATE UNIQUE INDEX "cities_id_key" on "cities" using btree ( "id" "int4_ops" ); diff --git a/src/bin/pgaccess/doc/html/forms.gif b/src/bin/pgaccess/doc/html/forms.gif new file mode 100644 index 00000000000..947d920b04b Binary files /dev/null and b/src/bin/pgaccess/doc/html/forms.gif differ diff --git a/src/bin/pgaccess/doc/html/forms.html b/src/bin/pgaccess/doc/html/forms.html new file mode 100644 index 00000000000..57ecff52fcb --- /dev/null +++ b/src/bin/pgaccess/doc/html/forms.html @@ -0,0 +1,203 @@ + + + + + + + + +

+FORMS

+ +
+

This version (0.97) of PgAccess has changed the form API : variable +handling, query results interface and control bindings naming convention. +Please read it carefully, download the database demo and practice a while +before trying to design your own forms. +

For the moment, it has only some basic widgets : labels, entries, buttons +, listboxes , checkboxes and radiobuttons. +

Also there is a pseudo data control widget that allows you yo have access +to a query results. +

How do you generate widgets : +

    +
  1. +select a widget from the toolbox by clicking the appropriate radiobutton
    2. + +
  2. +move to the canvas , point with the mouse at the desired location and click +the mouse button to begin
    3. + +
  3. +keeping the mouse-button pressed move the mouse in order to draw a rectangle +that will hold the widget
    4. + +
  4. +release the mouse-button
    5. +
+In the rectangle that you have designed it will appear the selected object. +
Move now to the attribute window to change some of its properties. +

Renaming, resizing items are possible (for the moment) only by modifying +appropriate parameters in attribute window. You must press Enter +in the edit field after changing a value in order to be accepted. +

You can also move items by dragging them or delete them by pressing +Del key after selecting them. +

In attribute window, there are some fields named Command +and +Variable. +

The field Command have meaning +only for Button widgets and holds the command that will be invoked when +the button is pressed. +

    The field Variable have +meaning only for EditField , Label widgets , checkboxes and radiobuttons +and it is the name of the global variable that will hold the value for +that widget. For checkboxes the values are t and f (from +true and false) in order to simplify binding to logical data fields (PgAccess +0.82 used 0 and 1). +

    For radiobuttons, it is usual to assign the same +variable to the same radiobuttons within the same group. That variable +will contain the name of the widget of the radiobutton that has been pressed. +Let's presume that you have entered 3 radiobuttons named red, green and +blue, all of them having the same variable named color. If you will press +them, they will assign their names to global variable. +

    In order to make a simple test, put an entry field +and set it's variable to v1 and a button who's command is "set v1 +whisky". Press the button "Test form" and click on the button. In that +entry should appear whisky. +
Another test is defining in Script module a script called "My first +script" having the following commands: +
tk_messageBox -title Warning -message "This is my +first message!" +
and then define a button who's command is execute_script +"My first script". +
  +

+Database manipulation

+Let's presume that our form have the internal name mf (my +form). Don't forget that the Tk window names could not start with +an uppercase letter. +
The window will be referred inside the Tcl/Tk source as .mf +
If you want to close the form in run-time you have to issue the command +destroy +.mf +

Also, any widget created inside this window (form) will have the name +prefixed by .mf ,so we will have .mf.button1 +or .mf.listbox1 . +

We can name the data control widget dc for example. +The fully qualified name for that "virtual widget" will be .mf.dc +then. A new namespace called DataControl(.mf.dc) will be +automatically defined. +
The Command property of the data control widget must +contain the SQL command that will be executed. +
When the form will be in run-time, automatically you will have access +to the following procedures and functions from the namespace: +

open - opens the connection and execute the query (returns +nothing) +
setSQL newsql - set the command query that will be +executed at the next open +
getRowCount - returns the number of records of the +result set +
getRowIndex - returns the current record number inside +the result set +
getFieldList - returns a Tcl list containing the fields +names from the current result set +
moveFirst - move the cursor to the first record in +the recordset +
moveLast , moveNext , movePrevious- +moves the cursor there +
moveTo newrecno - move the cursor to that new record +number (first is 0) +
updateDataSet - update the variables inside the designed +form that have a particular name (I'll explain later) +
clearDataSet - clear the associated DataSet variables +
fill listbox field - fill the named listbox (whole +widget name as .mf.listbox1) with the all the values of +that field from the current result set +
close - close the result set (if +you don't close it, you will loose some memory) +

These procedures and functions should be called in the normal Tcl namespace +mode as in the following example: +

DataControl(.mf.dc)::setSQL "select * from phonebook" +
DataControl(.mf.dc)::open +
set nrecs [DataControl(.mf.dc)::getRowCount] +

If you complaint about writting to many DataControl(...) you can include +many commands into a single namespace eval as in the following example +: +

namespace eval DataControl(.mf.dc) { +
    setSQL "select * from phonebook" +
    open +
    set nrecs [getRowCount] +
    moveLast +
    updateDataSet +
} +

It's no need to close a query-result set if you want to assign it a +new SQL command and open it again. That will be done automatically releasing +the memory used for the last result set. +
Opening a new DataControl will automatically position the current +row index of the result set on the first row (index 0) and will define +a new global associative array named DataSet that will hold data +from the current row. The key into that array will be the fully qualified +name of the data control widget followed by a comma and the name of every +field in the selected rows. +

Example: +
DataSet(.mf.dc,name) +
DataSet(.mf.dc,city) +

If you want to bound some controls to the fields of the recordset, you +will have to name their associate variable like that : +

DataSet(.mf.dc,salary) to get the "salary" field , or +DataSet(.mf.dc,name) to get the "name" field. Using the +data control procedures DataControl(.mf.dc)::moveNext or +movePrevious will automatically update the DataSet(.mf.dc,...) +array so the database information from entries in the form will be refreshed. +
  +

Here it is a dumped sample database +that contains a demo database. What should you do ? +
Shift-click the above URL in order to download that tiny file (4 Kb). +Create a empty database and psql yourdatabase <formdemo.sql +

You should find a single table called "phonebook" a form called "Phone +book" and another "A simple demo form". +

First of all enter and view the phonebook table in table view. Note +the fields and their values. +
Open the "Phone book" form and enter a letter (a, e or i) in the field +to the left of "Find" button then press Find. It's fine to enter one letter +in order to get more records in query result. You will get information +about the number of records selected, in the listbox you will see all the +values of field "name" from the current data set. Use buttons to move to +first, next, previous or last record within the record set. +

In order to add a new record, press the "New" button in order to get +new, clean entries. Fill them with your data and press "Add new" button. +A new phonebook record will be added. Also, if you want to update a record, +change it's values in the displayed fields after finding it and press "Update" +button. The values will be updated in the database BUT NOT IN THE CURRENT +QUERY RESULT . If you want to see them modified, make a new query trying +to find it again. +

Before using the results from a query you should +know that the information that has been retrieved could be found only in +your computer client memory. It has no live connection to the data +from the database. That's why it isn't possible to develop a simple update +function as interface to that query-result widget. More than that : a query +result could be obtained from a SQL command that return a non-updatable +data set !!! For example fields gathered from multiple tables or summary +fields. It isn't just simple to make an automatic update procedure. The +programmer must know how to make the update or the append procedure, sometimes +using key fields to point to the desired record or an OID. There are examples +in the demo database in "Phone book" form. It may be possible that in the +future, I will develop another pseudo-widget describing a table. It would +be more simple than to implement an update or append or even a delete procedure. +

There is in the demo database also another simple form called "A simple +demo form". It will show you how to handle variables from checkboxes, radiobuttons, +how to use listboxes, open another forms and so on. I think they will help +you. +

In order to avoid naming user defined forms with  a particular +name of another PgAccess form, I would recommend naming them as udf0, udf1 +(user defined form 0 , 1 ) +

+

+

Please feel free to send me your opinion at teo@flex.ro on forms +designing and usage. +

KEEP IN MIND !       +THE FORM API MAY CHANGE IN ORDER TO BE MORE SIMPLE AND BETTER! +
SEND ME YOUR WISHES, YOUR IDEAS, YOUR OPINIONS ! +
ALSO ... DON'T BLAME ME IF YOU WILL HAVE TO RE-DESIGN +YOUR OLD FORMS DUE TO SOME INCOMPATIBILITIES WITH NEWER PGACCESS VERSIONS. + + diff --git a/src/bin/pgaccess/doc/html/function.gif b/src/bin/pgaccess/doc/html/function.gif new file mode 100644 index 00000000000..51634e5df9d Binary files /dev/null and b/src/bin/pgaccess/doc/html/function.gif differ diff --git a/src/bin/pgaccess/doc/html/help.gif b/src/bin/pgaccess/doc/html/help.gif new file mode 100644 index 00000000000..f08fee8fd38 Binary files /dev/null and b/src/bin/pgaccess/doc/html/help.gif differ diff --git a/src/bin/pgaccess/doc/html/index.html b/src/bin/pgaccess/doc/html/index.html new file mode 100644 index 00000000000..7ccda192907 --- /dev/null +++ b/src/bin/pgaccess/doc/html/index.html @@ -0,0 +1,11 @@ + + +PgAccess + + + + + + + + diff --git a/src/bin/pgaccess/doc/html/irix.html b/src/bin/pgaccess/doc/html/irix.html new file mode 100644 index 00000000000..b678458569e --- /dev/null +++ b/src/bin/pgaccess/doc/html/irix.html @@ -0,0 +1,133 @@ + + + + PgAccess on Irix + + + + +

INSTALLING PgAccess UNDER IRIX 5.3. +

+ +

This HOWO-TO make PgAccess working under Irix +is written by Stuart Rison

+ +

These are the steps that I had to follow to get pgaccess to run on an +INDIGO2 running postgreSQL 6.3.2 under IRIX 5.3. I make no guarantee whatsoever +that the same step will work for others but at least it should point you +in the right direction. Also, I am a biologist by training so I only got +pgaccess working by fudging (that is, trial and error) this means that +some of the steps may be unnecessary (e.g. compiling $postgreSQL_source/src/interfaces/libpgtcl +as both a shared and static library) and they certainly haven't been optimised +(I know nothing about compiler switches etc.).

+ +

1) Requirements:

+ + + +

2) Installation:

+ +

a) tcl/tk:

+ + + +

b) postgreSQL:

+ + + +

c) Compiling libpgtcl:

+ + + +

d) running pgaccess:

+ + + +

e) et voila!

+ +

3) Concluding remarks:

+ + + +

Good luck

+ +

Stuart Rison LICR University College London London W1P 8BT
+stuart@ludwig.ucl.ac.uk

+ + + diff --git a/src/bin/pgaccess/doc/html/linux1.gif b/src/bin/pgaccess/doc/html/linux1.gif new file mode 100644 index 00000000000..b98ac024d73 Binary files /dev/null and b/src/bin/pgaccess/doc/html/linux1.gif differ diff --git a/src/bin/pgaccess/doc/html/maillist.html b/src/bin/pgaccess/doc/html/maillist.html new file mode 100644 index 00000000000..4e0ce850c96 --- /dev/null +++ b/src/bin/pgaccess/doc/html/maillist.html @@ -0,0 +1,43 @@ + + + + + + + + +

The mailing list for PgAccess is :       pgsql-interfaces@postgresql.org

+ +

If you have some questions regarding PgAccess you should mail to this +address. I will also answer to messages addresed directly to me but it +would be better to post your messages here because it might be possible +to get an answer quickly from another user of PgAccess.

+ +

+

+ +

To subscribe please send a mail message to :

+ +

     pgsql-interfaces-request@postgresql.org + 

+ +

having a single line in the body message :      subscribe

+ +

In a couple of minutes , if everything is ok, you must receive something +like that :

+ +

+

+ +

Welcome to the pgsql-interfaces mailing list!

+ +

Please save this message for future reference. Thank you.

+ +

If you ever want to remove yourself from this mailing list, you +can send mail to <Majordomo@hub.org> with the following command in +the body of your email message:

+ +

unsubscribe pgsql-interfaces yourname@yourdomain

+ + + diff --git a/src/bin/pgaccess/doc/html/main.html b/src/bin/pgaccess/doc/html/main.html new file mode 100644 index 00000000000..2bddfd61d4a --- /dev/null +++ b/src/bin/pgaccess/doc/html/main.html @@ -0,0 +1,34 @@ + + + + + + + + +

+PgAccess +

+A free graphical database management tool for PostgreSQL. +PgAccess has been written by Constantin Teodorescu +using Visual Tcl, the best tool for developing Tcl/Tk applications I've +ever seen. +

Last version +
Last stable version is 0.98 , released on 29 August 1999. Read what's +new in 0.98. +

Portability issues +
PgAccess is available for every platform where PostgreSQL was ported +and where a Tcl/Tk package is available. PgAccess has been reported running +on : +
- Linux +
- FreeBSD +
- Solaris +
- HPUX +
- Irix +
- Windows 95,98,NT +

PgAccess needs Tcl/Tk versions 8.0.x and higher thought PgAccess. For +win32 platforms there are some special DLL's that have to be downloaded +and installed, more information here. +

PgAccess is protected by the following copyright. + + diff --git a/src/bin/pgaccess/doc/html/mainwindow.gif b/src/bin/pgaccess/doc/html/mainwindow.gif new file mode 100644 index 00000000000..6a48792d194 Binary files /dev/null and b/src/bin/pgaccess/doc/html/mainwindow.gif differ diff --git a/src/bin/pgaccess/doc/html/newtable.gif b/src/bin/pgaccess/doc/html/newtable.gif new file mode 100644 index 00000000000..891d05698f9 Binary files /dev/null and b/src/bin/pgaccess/doc/html/newtable.gif differ diff --git a/src/bin/pgaccess/doc/html/newuser.gif b/src/bin/pgaccess/doc/html/newuser.gif new file mode 100644 index 00000000000..5c56c9ad299 Binary files /dev/null and b/src/bin/pgaccess/doc/html/newuser.gif differ diff --git a/src/bin/pgaccess/doc/html/old_index.html b/src/bin/pgaccess/doc/html/old_index.html new file mode 100644 index 00000000000..4bbf11fcf07 --- /dev/null +++ b/src/bin/pgaccess/doc/html/old_index.html @@ -0,0 +1,143 @@ + + + + + + PgAccess - a Tcl/Tk PostgreSQL interface + + + +

+PgAccess - a free database management tool for PostgreSQL

+ +
+
  • +Download the last version of PgAccess (press +shift and click this link) (tar.gz file)  or   this +one (zip file for Windows)
    • + +
    +


    Latest stable version of PgAccess is 0.97 , released 16 August 1999 +! +

    PgAccess 0.93 and higher will not work from the beginning +with PostgreSQL 6.3.x !! +
    Read here how to apply a +simple patch in order to make it work !

    + +
    + + + + + + + + + + + +
    NEWInternational version +(english, french, italian, romanian)
    NEWContext sensitive Help
    + +
    +

    Precompiled libpgtcl and libpq binaries and dll's for i386 are here +!!!

    + +

    +Installation problems

    + + + +

    +What does PgAccess now!

    +Here are some screenshots from PgAccess windows : Main +window , table builder , table(query) +view , visual query builder . +

    Tables +
    - opening multiple tables for viewing, max. n records (changed by preferences +menu) +
    - column resizing, dragging the vertical grid line (better in table +space rather than in the table header) +
    - text wrap in cells - layout saved for every table +
    - import/export to external files (SDF,CSV) +
    - filter capabilities (enter filter like (price>3.14) +
    - sort order capabilities (enter manually the sort field(s)) +
    - editing in place +
    - improved table generator assistant +
    - improved field editing +
    Queries +
    - define , edit and stores "user defined queries" +
    - store queries as views +
    - execution of queries with optional user input parameters ( select +* from invoices where year=[parameter "Year of selection"] ) +
    - viewing of select type queries result +
    - query deleting and renaming +
    - visual query builder with drag & drop capabilities. For any of +you who had installed the Tcl/Tk plugin for Netscape Navigator, you can +see it at work clicking here +
    Sequences +
    - defines sequences, delete them and inspect them +
    Functions +
    - define, inspect and delete functions in SQL, plpgsql and pgtcl languages +
    Reports +
    - design and display simple reports from tables +
    - fields and labels, font changing, style and size +
    - saves and loads report description from database +
    - show report previews, sample postscript output file +
    Forms +
    - open user defined forms +
    - form design module available +
    - query widget available, controls bound to query results +
    - click here for a description of forms and +how they can be used +
    Scripts +
    - define, modify and call user defined scripts +
    Users +
    - define and modify user information +

    Here is a special section concerning forms and +scripts . +

    This program is protected by the following copyright +

    If you have any comment, suggestion for improvements, please feel free +to e-mail to : teo@flex.ro +

    Mailing list for PgAccess Here +you will find how to subscribe to this mailing list. +

    +

    +

    +More information about libpgtcl - downloads

    +     Also, you will need the PostgreSQL to Tcl interface +library, lined as a Tcl/Tk 'load'-able module. It is called libpgtcl and +the source is located in the PostgreSQL directory /src/interfaces/libpgtcl. +Specifically, you will need a libpgtcl library that is 'load'-able from +Tcl/Tk.      This is technically different from +an ordinary PostgreSQL loadable object file, because libpgtcl is a collection +of object files. Under Linux, this is called libpgtcl.so. +

         One of the solutions is to remove from the +source the line containing load libpgtcl.so and to load pgaccess.tcl +not with wish, but with pgwish (or wishpg) that wish that was linked with +libpgtcl library! I do not recommend this one. +

         If you have installed RedHat 5.x, you should +get the last distribution kit of PostgreSQL and compile it from scratch. +RedHat 5.x is using some new versions of libraries and you have to compile +and install again at least libpq and libpgtcl libraries. +

        PostgreSQL 6.4 release has a minor bug. I does not +include by default the crypt lib when compiling libpgtcl. So, you will +need to manually add a -lcrypt to SHLIB line in Makefile in src/interfaces/libpgtcl +and then make clean and make again. The new libpgtcl.so library is properly +configured to run pgaccess. +
      + + diff --git a/src/bin/pgaccess/doc/html/permissions.gif b/src/bin/pgaccess/doc/html/permissions.gif new file mode 100644 index 00000000000..06c43491e07 Binary files /dev/null and b/src/bin/pgaccess/doc/html/permissions.gif differ diff --git a/src/bin/pgaccess/doc/html/pg93patch.html b/src/bin/pgaccess/doc/html/pg93patch.html new file mode 100644 index 00000000000..4c77bfac61b --- /dev/null +++ b/src/bin/pgaccess/doc/html/pg93patch.html @@ -0,0 +1,25 @@ + + + + + + + + +

    +PgAccess 0.93 patch to make it work with PostgreSQL 6.3.x +

    + +


    PgAccess 0.93 is working fine with PostgreSQL 6.4.x due to some +changes in libpgtcl ! +

    There is a small patch that you have to make in order to make it work +with 6.3.x ! +

    Replace in procedure wpg_exec the following line: +

    set pgsql(errmsg) [pg_result $pgsql(res) -error] +

    with this one : +

    set pgsql(errmsg) "NO ERROR INFORMATION SUPPLIED" +

    And it will work fine! In some error cases, you will not get the appropriate +error message from libpgtcl. +

     Back + + diff --git a/src/bin/pgaccess/doc/html/pga-rad.html b/src/bin/pgaccess/doc/html/pga-rad.html new file mode 100644 index 00000000000..7564cf7b553 --- /dev/null +++ b/src/bin/pgaccess/doc/html/pga-rad.html @@ -0,0 +1,65 @@ + + + + + + + +

    +PgAccess - Scripts and Forms  +

    +Beginning with 0.70 version, I have introduced in PgAccess two new modules +for operating with scripts and forms. + +

       This would give to PgAccess the power of creating application +directly into PgAccess, defining new modules, procedures, forms and possibly +making it a rapid development tool for PostgreSQL. The "scripts" and "forms" +modules are using two new tables called pga_forms and pga_scripts. PgAccess +take care of creating them if user is opening a new database and grant +ALL permissions on them to PUBLIC. +
      +
       Of course, when Designing a script, a simple text editor +is opened and text is saved as is in pga_scripts table. When "designing" +a form, a "form editor" that would be very similar with "Visual Tcl" is +invoked. + +

       This mechanism and the extremely versatile scripting mode +of Tcl/Tk would give PgAccess a great power for creating end user application +using PostgreSQL. The most important thing is that the user could call +procedures and functions that I have used for building up PgAccess ! +

    +Forms

    +   Forms are used for creating windows and placing widgets inside +it. When PgAccess interpret them, a new window appear, with buttons as +defined that could call "user defined scripts", "user defined procedures" +or "internal PgAccess procedures". +
       Forms can hold all the widgets allowed in Tcl/Tk , buttons, +check-boxes, radio-buttons, list-boxes, frames, canvases, etc. With these +forms, you can control your application so PgAccess would become just a +"shell", a startup point for you applications. See the  special +section concerning forms. +

    +Scripts

    +   Scripts are normal Tcl/Tk code that is interpreted by Tcl/Tk. +You can define your own procedures inside a script called "Library" for +example. You can call your procedures from within another script, from +another procedure. +
       The most important thing is that you have total access +to the PgAccess core of functions and procedures used by me in building +PgAccess as an application. Just write open_table +"Your sample table" and you'll see the result. +
       If you are writing a script called "Autoexec" then it +will be executed every time the database is opened. You can put inside +different commands that you want to be executed such as : running scripts +that would define your own procedures such as execute_script +"My own procedure library" or open a form with open_form +"Main window with menu buttons" , and so on. + +

    +

    +
    Remember : I'm waiting your messages at teo@flex.ro + +

    +

    + + diff --git a/src/bin/pgaccess/doc/html/qbtclet.html b/src/bin/pgaccess/doc/html/qbtclet.html new file mode 100644 index 00000000000..b990c0f15c3 --- /dev/null +++ b/src/bin/pgaccess/doc/html/qbtclet.html @@ -0,0 +1,45 @@ + + + Visual Query Builder in Tcl/Tk + +

    Visual Query Builder

    +
    +This visual query builder is included in +PgAccess, a visual interface to + PostgreSQL written entirely in +vTcl , (Visual Tcl). + + +

    + + + +

    + +
    + + +Visual Query Designer demo
    +Click here to download the source +created by Constantin Teodorescu with vTcl (visual Tcl), teo@flex.ro +
    +Facitilies
    + - drag and drop selection of fields
    + - drag and drop fields from a table to another do create links
    + - move table position by dragging
    + - point and click any link or table then press delete to delete them
    + - modify sort order by clicking on (unsorted)
    + - enter filter conditions as criteria (>2000 , ='item')
    + - easy panning of table and result panels
    + - show SQL command
    +
    +If you want to use it for your database, modify ql_read_struct in order to read + your table structure. +
    +Feel free to use, modify or copy this software for non-commercial purposes.
    +In any other case, please contact me. +
    +FLEX Consulting Braila, ROMANIA is able to deliver high end interfaces +and any other commercial products written in Tcl/Tk just like that you have seen. + + diff --git a/src/bin/pgaccess/doc/html/qbtclet.tcl b/src/bin/pgaccess/doc/html/qbtclet.tcl new file mode 100644 index 00000000000..9d086a33900 --- /dev/null +++ b/src/bin/pgaccess/doc/html/qbtclet.tcl @@ -0,0 +1,529 @@ +################################# +# 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 {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 {ql_dragstart %W %x %y} +.c bind mov {ql_dragit %W %x %y} +bind . {ql_dragstop %x %y} +bind . {qlc_click %x %y %W} +bind . {ql_pan %x %y} +bind . {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 {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 {.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 {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 { + ql_pan %x %y + } + bind $base { + qlc_click %x %y %W + } + bind $base { + ql_dragstop %x %y + } + bind $base { + ql_delete_object + } + canvas $base.c \ + -background #fefefe -borderwidth 2 -height 207 -relief ridge \ + -takefocus 0 -width 295 + 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 diff --git a/src/bin/pgaccess/doc/html/screenshots.html b/src/bin/pgaccess/doc/html/screenshots.html new file mode 100644 index 00000000000..0cf3ac6b65b --- /dev/null +++ b/src/bin/pgaccess/doc/html/screenshots.html @@ -0,0 +1,43 @@ + + + + + + + + +

    +Image gallery +

    + + + + + diff --git a/src/bin/pgaccess/doc/html/specialchars.html b/src/bin/pgaccess/doc/html/specialchars.html new file mode 100644 index 00000000000..b6b82f2336a --- /dev/null +++ b/src/bin/pgaccess/doc/html/specialchars.html @@ -0,0 +1,47 @@ + + + + Special locale characters + + + + +

    Special locale characters and PgAccess +

    + +

    The problem is related with some special characters used in different +countries because PgAccess did not use fonts with `-ISO8859-1' encoding +--

    + +

    The sollution was proposed by H.P.Heidinger ( hph@hphbbs.ruhr.de) and +it's very simple.

    + +

    If you look into PgAccess, you will find fonts declared as follows :

    + +

    $ grep -e '-font' -i pgaccess.tcl
    +-font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \
    +-font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \
    +-font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \
    +-font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \

    + +

    It should be something like: -adobe-helvetica-medium-r-normal-*-*-120-*-*-*-*-iso8859-1

    + +

    You can achieve this by running the following script :

    + +

    #!/bin/sh
    +cp pgaccess.tcl pgaccess.tcl-org
    +cat pgaccess.tcl |\
    +sed -e's/\-\*\-\*\ /\-iso8859\-1\ /g' |\
    +sed -e's/\-\*\-\*\}/\-iso8859\-1}/g' |\
    +sed -e's/\-\*\-\*\]/\-iso8859\-1]/g' |\
    +sed -e's/\-\*\-\*$/\-iso8859\-1/g' |\
    +sed -e's/\-Clean\-/\-Fixed\-/g' |\
    +sed -e's/clean/fixed/g' >pgaccess.iso
    +mv pgaccess.iso pgaccess.tcl
    +chmod +x pgaccess.tcl

    + +

    The final version of PgAccess (1.0) will let the user decide what fonts +will be used through a "preferences" dialog window.

    + + + diff --git a/src/bin/pgaccess/doc/html/todo.html b/src/bin/pgaccess/doc/html/todo.html new file mode 100644 index 00000000000..f19b61ab90c --- /dev/null +++ b/src/bin/pgaccess/doc/html/todo.html @@ -0,0 +1,11 @@ + + +

    ToDo List

    + - Finish the report generator module
    + - Enhance the form designer
    + - Enhance the scripts module
    + - Translations in other languages
    +
    +Please send any suggestions by mail to Constantin Teodorescu. + + diff --git a/src/bin/pgaccess/doc/html/vdesigner.gif b/src/bin/pgaccess/doc/html/vdesigner.gif new file mode 100644 index 00000000000..71349e6daf4 Binary files /dev/null and b/src/bin/pgaccess/doc/html/vdesigner.gif differ diff --git a/src/bin/pgaccess/doc/html/whatsnew.html b/src/bin/pgaccess/doc/html/whatsnew.html new file mode 100644 index 00000000000..f2faede0153 --- /dev/null +++ b/src/bin/pgaccess/doc/html/whatsnew.html @@ -0,0 +1,50 @@ + + + + + + + +29 August 1999 - PgAccess 0.98 has been released! +
      +
    • +international version (romanian, french, italian translations available) +in separate files (japanese translation now possible)
      • + +
    • +context sensitive help, complete help for SQL commands
      • + +
    • +geometry changes for many forms
      • + +
    • +form designer enhancements (widget icons , new attribute window style, +form startup script)
      • + +
    • +ability to inspect PostgreSQL system tables (preferences)
      • + +
    • +enhanced table design window, table permissions
      • + +
    • +distribution archive changes
      • + +
    • +unified internal global variables
      • + +
    • +unified internal window naming conventions
      • + +
    • +usage of Tcl namespaces for all modules
      • + +
    • +PgAccess developer API
      • + +
    • +web site enhancements
      • +
    + + + diff --git a/src/bin/pgaccess/doc/html/win32.html b/src/bin/pgaccess/doc/html/win32.html new file mode 100644 index 00000000000..368eb9990eb --- /dev/null +++ b/src/bin/pgaccess/doc/html/win32.html @@ -0,0 +1,45 @@ + + + + + + + + +

    +PgAccess on Win32

    + +
    In order to run PgAccess on a Win32 workstation you should follow the +following steps: +
      +
    1. +download and install a Tcl/Tk package from Scriptics +(8.0.x or 8.1.x)
      2. + +
    2. +install PgAccess package
      3. + +
    3. +check the Tcl/Tk version that you have
      4. + +
    4. +check the PostgreSQL version installed on your database server machine
      5. + +
    5. +get from win32/dll directory the appropriate libraries suitable for your +Tcl/Tk version and PostgreSQL version and copy them into your Windows/System +directory renaming them as libpq.dll and libpgtcl.dll
      6. + +
    6. +check if your win32 workstation is able to see your database server (ping +yourdatabaseserver)
      7. + +
    7. +ask your database administrator to verify if your win32 workstation has +access rights to the database (pg_hba.conf)
      8. +
    + +


    You should be able to run PgAccess. +
      + + diff --git a/src/bin/pgaccess/lib/database.tcl b/src/bin/pgaccess/lib/database.tcl new file mode 100644 index 00000000000..828baf09920 --- /dev/null +++ b/src/bin/pgaccess/lib/database.tcl @@ -0,0 +1,61 @@ +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] +} + +} diff --git a/src/bin/pgaccess/lib/forms.tcl b/src/bin/pgaccess/lib/forms.tcl new file mode 100644 index 00000000000..631c3537c72 --- /dev/null +++ b/src/bin/pgaccess/lib/forms.tcl @@ -0,0 +1,1263 @@ +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 -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 "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 "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 { + Forms::design:delete_object + } + bind $base "Help::load form_design" + canvas $base.c \ + -background #a0a0a0 -height 207 -highlightthickness 0 -relief ridge \ + -selectborderwidth 0 -width 295 + bind $base.c { + Forms::design:mouse_down %x %y + } + bind $base.c { + Forms::design:mouse_up %x %y + } + bind $base.c { + 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 { + 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 { + Forms::design:change_coords + } + bind $base.fg.e2 { + Forms::design:change_coords + } + bind $base.fg.e3 { + Forms::design:change_coords + } + bind $base.fg.e4 { + 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 +} + diff --git a/src/bin/pgaccess/lib/functions.tcl b/src/bin/pgaccess/lib/functions.tcl new file mode 100644 index 00000000000..96e48605926 --- /dev/null +++ b/src/bin/pgaccess/lib/functions.tcl @@ -0,0 +1,181 @@ +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 "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 { + 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 { + 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 { + 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 { + 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 +} + diff --git a/src/bin/pgaccess/lib/help.tcl b/src/bin/pgaccess/lib/help.tcl new file mode 100644 index 00000000000..87f65703f89 --- /dev/null +++ b/src/bin/pgaccess/lib/help.tcl @@ -0,0 +1,127 @@ +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 {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 "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 +} + diff --git a/src/bin/pgaccess/lib/mainlib.tcl b/src/bin/pgaccess/lib/mainlib.tcl new file mode 100644 index 00000000000..b4379a4f831 --- /dev/null +++ b/src/bin/pgaccess/lib/mainlib.tcl @@ -0,0 +1,987 @@ +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 "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 "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 { + 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 { + set PgAcVar(getqueryparam,result) 1 +destroy .pgaw:GetParameter + } + bind $base.e1 { + 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 { + focus .pgaw:OpenDB.f1.e2 + } + bind $base.f1.e1 { + 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 { + 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 { + 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 { + 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 { + 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 +} + + diff --git a/src/bin/pgaccess/lib/preferences.tcl b/src/bin/pgaccess/lib/preferences.tcl new file mode 100644 index 00000000000..c752e03ba4a --- /dev/null +++ b/src/bin/pgaccess/lib/preferences.tcl @@ -0,0 +1,273 @@ +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 "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 +} + diff --git a/src/bin/pgaccess/lib/qed b/src/bin/pgaccess/lib/qed new file mode 100755 index 00000000000..4db7a0148d5 --- /dev/null +++ b/src/bin/pgaccess/lib/qed @@ -0,0 +1,7 @@ +#!/bin/bash +for fisier in *.tcl ; do + echo $fisier ; + sed -e "s/show_error/showError/g" <$fisier >temp + mv temp $fisier +done + diff --git a/src/bin/pgaccess/lib/queries.tcl b/src/bin/pgaccess/lib/queries.tcl new file mode 100644 index 00000000000..b25ec70ac1f --- /dev/null +++ b/src/bin/pgaccess/lib/queries.tcl @@ -0,0 +1,228 @@ +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 "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 +} + diff --git a/src/bin/pgaccess/lib/reports.tcl b/src/bin/pgaccess/lib/reports.tcl new file mode 100644 index 00000000000..c526ca9b569 --- /dev/null +++ b/src/bin/pgaccess/lib/reports.tcl @@ -0,0 +1,599 @@ +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 { + Reports::addField + } + canvas $base.c \ + -background #fffeff -borderwidth 2 -height 207 -highlightthickness 0 \ + -relief ridge -takefocus 1 -width 295 + bind $base.c { + Reports::dragStart %W %x %y + } + bind $base.c { + Reports::dragStop %x %y + } + bind $base.c { + Reports::deleteObject + } + bind $base.c { + 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 { + 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 { + Reports::toggleBold + } + label $base.lita \ + -borderwidth 1 \ + -font $PgAcVar(pref,font_italic) \ + -relief raised -text i + bind $base.lita { + Reports::toggleItalic + } + entry $base.eps \ + -background #fefefe -highlightthickness 0 -relief groove \ + -textvariable PgAcVar(report,pointsize) + bind $base.eps { + 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 { + 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 { + 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 +} diff --git a/src/bin/pgaccess/lib/schema.tcl b/src/bin/pgaccess/lib/schema.tcl new file mode 100644 index 00000000000..d3e40ef1363 --- /dev/null +++ b/src/bin/pgaccess/lib/schema.tcl @@ -0,0 +1,585 @@ +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 {Schema::dragStart %W %x %y} + .pgaw:Schema.c bind mov {Schema::dragMove %W %x %y} + bind .pgaw:Schema.c {Schema::dragStop %x %y} + bind .pgaw:Schema {Schema::canvasClick %x %y %W} + bind .pgaw:Schema {Schema::canvasPanning %x %y} + bind .pgaw:Schema {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 {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 { + Schema::canvasPanning %x %y + } + bind $base { + Schema::canvasClick %x %y %W + } + bind $base { + Schema::dragStop %x %y + } + bind $base { + 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 { + 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 { + 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 + +} + + diff --git a/src/bin/pgaccess/lib/scripts.tcl b/src/bin/pgaccess/lib/scripts.tcl new file mode 100644 index 00000000000..0302e1fec14 --- /dev/null +++ b/src/bin/pgaccess/lib/scripts.tcl @@ -0,0 +1,88 @@ +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 +} + diff --git a/src/bin/pgaccess/lib/sequences.tcl b/src/bin/pgaccess/lib/sequences.tcl new file mode 100644 index 00000000000..834eaab22cc --- /dev/null +++ b/src/bin/pgaccess/lib/sequences.tcl @@ -0,0 +1,159 @@ +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 "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 { + focus .pgaw:Sequence.f1.e2 + } + bind $base.f1.e1 { + 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 { + 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 { + 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 { + 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 { + 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 +} + diff --git a/src/bin/pgaccess/lib/tables.tcl b/src/bin/pgaccess/lib/tables.tcl new file mode 100644 index 00000000000..857231236ff --- /dev/null +++ b/src/bin/pgaccess/lib/tables.tcl @@ -0,0 +1,2158 @@ +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 {} + 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 "$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 "Tables::dragStart $wn %W %x %y" + $wn.c bind movable {Tables::dragMove %W %x %y} + $wn.c bind movable "Tables::dragStop $wn %W %x %y" + $wn.c bind movable "$wn configure -cursor left_side" + $wn.c bind movable "$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 "Tables::editText $wn %A %K" +} else { + $wn.c bind q {} +} +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 "Tables::deleteRecord $wn" + bind $base "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 "Tables::refreshRecords $wn" + bind $base.f1.e1 "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 "Tables::refreshRecords $wn" + bind $base.f1.e2 "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 "Tables::canvasClick $wn %x %y" + bind $base.c "Tables::canvasPaste $wn %x %y" + bind $base.c "if {[Tables::finishEdit $wn]} \"Tables::insertNewRecord $wn\"" + + # Prevent Tab from moving focus out of canvas widget + bind $base.c 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 "Help::load new_table" + entry $base.etabn \ + -background #fefefe -borderwidth 1 -selectborderwidth 0 \ + -textvariable PgAcVar(nt,tablename) + bind $base.etabn { + 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 { + 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 { + 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 { + focus .pgaw:NewTable.e1 + } + entry $base.e1 \ + -background #fefefe -borderwidth 1 -selectborderwidth 0 \ + -textvariable PgAcVar(nt,fldtype) + bind $base.e1 { + focus .pgaw:NewTable.e5 + } + entry $base.e3 \ + -background #fefefe -borderwidth 1 -selectborderwidth 0 \ + -textvariable PgAcVar(nt,fldsize) + bind $base.e3 { + focus .pgaw:NewTable.e5 + } + entry $base.e5 \ + -background #fefefe -borderwidth 1 -selectborderwidth 0 \ + -textvariable PgAcVar(nt,defaultval) + bind $base.e5 { + 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 { + 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 { + 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 "Help::load view_table_structure" + label $base.l0 \ + -borderwidth 1 -font $PgAcVar(pref,font_bold) \ + -relief raised -text [intlmsg General] + bind $base.l0 { + Tables::tabSelect 0 + } + label $base.l1 \ + -borderwidth 1 \ + -relief raised -text [intlmsg Columns] + bind $base.l1 { + Tables::tabSelect 1 + } + label $base.l2 \ + -borderwidth 1 \ + -relief raised -text [intlmsg Indexes] + bind $base.l2 { + Tables::tabSelect 2 + } + label $base.l3 \ + -borderwidth 1 \ + -relief raised -text [intlmsg Permissions] + bind $base.l3 { + 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 { + 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 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 { + focus .pgaw:AddField.e2 + } + bind $base.e1 { + 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 { + Tables::addNewColumn + } + bind $base.e2 { + 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 "Tables::renameColumn" + bind $base.e1 "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 +} diff --git a/src/bin/pgaccess/lib/users.tcl b/src/bin/pgaccess/lib/users.tcl new file mode 100644 index 00000000000..18204e0f722 --- /dev/null +++ b/src/bin/pgaccess/lib/users.tcl @@ -0,0 +1,155 @@ +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 "focus .pgaw:User.e2" + bind $base.e1 "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 "focus .pgaw:User.e3" + bind $base.e2 "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 "focus .pgaw:User.cb1" + bind $base.e3 "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 "focus .pgaw:User.b1" + bind $base.e4 "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 +} + diff --git a/src/bin/pgaccess/lib/views.tcl b/src/bin/pgaccess/lib/views.tcl new file mode 100644 index 00000000000..dc520a5b746 --- /dev/null +++ b/src/bin/pgaccess/lib/views.tcl @@ -0,0 +1,45 @@ +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 +} + + +} diff --git a/src/bin/pgaccess/lib/visualqb.tcl b/src/bin/pgaccess/lib/visualqb.tcl new file mode 100644 index 00000000000..dc4189efc95 --- /dev/null +++ b/src/bin/pgaccess/lib/visualqb.tcl @@ -0,0 +1,776 @@ +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 {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 {VisualQueryBuilder::dragStart %W %x %y} +.pgaw:VisualQuery.c bind mov {VisualQueryBuilder::dragObject %W %x %y} +bind .pgaw:VisualQuery {VisualQueryBuilder::dragStop %x %y} +bind .pgaw:VisualQuery {VisualQueryBuilder::canvasClick %x %y %W} +bind .pgaw:VisualQuery {VisualQueryBuilder::panning %x %y} +bind .pgaw:VisualQuery {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 {VisualQueryBuilder::resultFieldClick %x %y} +.pgaw:VisualQuery.c bind sort {VisualQueryBuilder::toggleSortMode %W %x %y} +.pgaw:VisualQuery.c bind retval {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 {.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 {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 { + 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 { + VisualQueryBuilder::panning %x %y + } + bind $base { + VisualQueryBuilder::canvasClick %x %y %W + } + bind $base { + VisualQueryBuilder::dragStop %x %y + } + bind $base { + VisualQueryBuilder::deleteObject + } + bind $base "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 { + 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 +} + diff --git a/src/bin/pgaccess/main.tcl b/src/bin/pgaccess/main.tcl new file mode 100644 index 00000000000..1a3d84e7eb1 --- /dev/null +++ b/src/bin/pgaccess/main.tcl @@ -0,0 +1,250 @@ +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" "$@" + +image create bitmap dnarw -data { +#define down_arrow_width 15 +#define down_arrow_height 15 +static char down_arrow_bits[] = { + 0x00,0x80,0x00,0x80,0x00,0x80,0x00,0x80, + 0x00,0x80,0xf8,0x8f,0xf0,0x87,0xe0,0x83, + 0xc0,0x81,0x80,0x80,0x00,0x80,0x00,0x80, + 0x00,0x80,0x00,0x80,0x00,0x80 + } +} + + +proc {intlmsg} {msg} { +global PgAcVar Messages + if {$PgAcVar(pref,language)=="english"} { return $msg } + if { ! [array exists Messages] } { return $msg } + if { ! [info exists Messages($msg)] } { return $msg } + return $Messages($msg) +} + +proc {PgAcVar:clean} {prefix} { +global PgAcVar + foreach key [array names PgAcVar $prefix] { + set PgAcVar($key) {} + unset PgAcVar($key) + } +} + + +proc {find_PGACCESS_HOME} {} { +global PgAcVar env + if {! [info exists env(PGACCESS_HOME)]} { + set home [file dirname [info script]] + switch [file pathtype $home] { + absolute {set env(PGACCESS_HOME) $home} + relative {set env(PGACCESS_HOME) [file join [pwd] $home]} + volumerelative { + set curdir [pwd] + cd $home + set env(PGACCESS_HOME) [file join [pwd] [file dirname [file join [lrange [file split $home] 1 end]]]] + cd $curdir + } + } + } + if {![file isdir $env(PGACCESS_HOME)]} { + set PgAcVar(PGACCESS_HOME) [pwd] + } else { + set PgAcVar(PGACCESS_HOME) $env(PGACCESS_HOME) + } +} + + +proc init {argc argv} { +global PgAcVar CurrentDB + find_PGACCESS_HOME + # Loading all defined namespaces + foreach module {mainlib database tables queries visualqb forms views functions reports scripts users sequences schema help preferences} { + source [file join $PgAcVar(PGACCESS_HOME) lib $module.tcl] + } + set PgAcVar(currentdb,host) localhost + set PgAcVar(currentdb,pgport) 5432 + set CurrentDB {} + set PgAcVar(tablist) [list Tables Queries Views Sequences Functions Reports Forms Scripts Users Schema] + set PgAcVar(activetab) {} + set PgAcVar(query,tables) {} + set PgAcVar(query,links) {} + set PgAcVar(query,results) {} + set PgAcVar(mwcount) 0 + Preferences::load +} + +proc {wpg_exec} {db cmd} { +global PgAcVar + set PgAcVar(pgsql,cmd) "never executed" + set PgAcVar(pgsql,status) "no status yet" + set PgAcVar(pgsql,errmsg) "no error message yet" + if {[catch { + Mainlib::sqlw_display $cmd + set PgAcVar(pgsql,cmd) $cmd + set PgAcVar(pgsql,res) [pg_exec $db $cmd] + set PgAcVar(pgsql,status) [pg_result $PgAcVar(pgsql,res) -status] + set PgAcVar(pgsql,errmsg) [pg_result $PgAcVar(pgsql,res) -error] + } tclerrmsg]} { + showError [format [intlmsg "Tcl error executing pg_exec %s\n\n%s"] $cmd $tclerrmsg] + return 0 + } + return $PgAcVar(pgsql,res) +} + + +proc {wpg_select} {args} { + Mainlib::sqlw_display "[lindex $args 1]" + uplevel pg_select $args +} + + +proc {create_drop_down} {base x y w} { +global PgAcVar + if {[winfo exists $base.ddf]} return; + frame $base.ddf -borderwidth 1 -height 75 -relief raised -width 55 + listbox $base.ddf.lb -background #fefefe -foreground #000000 -selectbackground #c3c3c3 -borderwidth 1 -font $PgAcVar(pref,font_normal) -highlightthickness 0 -selectborderwidth 0 -yscrollcommand [subst {$base.ddf.sb set}] + scrollbar $base.ddf.sb -borderwidth 1 -command [subst {$base.ddf.lb yview}] -highlightthickness 0 -orient vert + place $base.ddf -x $x -y $y -width $w -height 185 -anchor nw -bordermode ignore + place $base.ddf.lb -x 1 -y 1 -width [expr $w-18] -height 182 -anchor nw -bordermode ignore + place $base.ddf.sb -x [expr $w-15] -y 1 -width 14 -height 183 -anchor nw -bordermode ignore +} + + +proc {setCursor} {{type NORMAL}} { + if {[lsearch -exact "CLOCK WAIT WATCH" [string toupper $type]] != -1} { + set type watch + } else { + set type left_ptr + } + foreach wn [winfo children .] { + catch {$wn configure -cursor $type} + } + update ; update idletasks +} + + +proc {parameter} {msg} { +global PgAcVar + Window show .pgaw:GetParameter + focus .pgaw:GetParameter.e1 + set PgAcVar(getqueryparam,var) "" + set PgAcVar(getqueryparam,flag) 0 + set PgAcVar(getqueryparam,msg) $msg + bind .pgaw:GetParameter "set PgAcVar(getqueryparam,flag) 1" + grab .pgaw:GetParameter + tkwait variable PgAcVar(getqueryparam,flag) + if {$PgAcVar(getqueryparam,result)} { + return $PgAcVar(getqueryparam,var) + } else { + return "" + } +} + + +proc {showError} {emsg} { + bell ; tk_messageBox -title [intlmsg Error] -icon error -message $emsg +} + + +proc {sql_exec} {how cmd} { +global PgAcVar CurrentDB + if {[set pgr [wpg_exec $CurrentDB $cmd]]==0} { + return 0 + } + if {($PgAcVar(pgsql,status)=="PGRES_COMMAND_OK") || ($PgAcVar(pgsql,status)=="PGRES_TUPLES_OK")} { + pg_result $pgr -clear + return 1 + } + if {$how != "quiet"} { + showError [format [intlmsg "Error executing query\n\n%s\n\nPostgreSQL error message:\n%s\nPostgreSQL status:%s"] $cmd $PgAcVar(pgsql,errmsg) $PgAcVar(pgsql,status)] + } + pg_result $pgr -clear + return 0 +} + + + +proc {main} {argc argv} { +global PgAcVar CurrentDB tcl_platform + load libpgtcl[info sharedlibextension] + catch {Mainlib::draw_tabs} + set PgAcVar(opendb,username) {} + set PgAcVar(opendb,password) {} + if {$argc>0} { + set PgAcVar(opendb,dbname) [lindex $argv 0] + set PgAcVar(opendb,host) localhost + set PgAcVar(opendb,pgport) 5432 + Mainlib::open_database + } elseif {$PgAcVar(pref,autoload) && ($PgAcVar(pref,lastdb)!="")} { + set PgAcVar(opendb,dbname) $PgAcVar(pref,lastdb) + set PgAcVar(opendb,host) $PgAcVar(pref,lasthost) + set PgAcVar(opendb,pgport) $PgAcVar(pref,lastport) + catch {set PgAcVar(opendb,username) $PgAcVar(pref,lastusername)} + if {[set openmsg [Mainlib::open_database]]!=""} { + if {[regexp "no password supplied" $openmsg]} { + Window show .pgaw:OpenDB + focus .pgaw:OpenDB.f1.e5 + wm transient .pgaw:OpenDB .pgaw:Main + } + } + + } + wm protocol .pgaw:Main WM_DELETE_WINDOW { + catch {pg_disconnect $CurrentDB} + exit + } +} + + +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} } + } +} + +proc vTclWindow. {base} { + if {$base == ""} { + set base . + } + wm focusmodel $base passive + wm geometry $base 1x1+0+0 + wm maxsize $base 1009 738 + wm minsize $base 1 1 + wm overrideredirect $base 0 + wm resizable $base 1 1 + wm withdraw $base + wm title $base "vt.tcl" +} + + +init $argc $argv + +Window show . +Window show .pgaw:Main + +main $argc $argv + diff --git a/src/bin/pgaccess/pgaccess b/src/bin/pgaccess/pgaccess new file mode 100755 index 00000000000..41fd5cae16f --- /dev/null +++ b/src/bin/pgaccess/pgaccess @@ -0,0 +1,10 @@ +#!/bin/sh + +PATH_TO_WISH=/usr/bin/wish +PGACCESS_HOME=/usr/local/pgaccess + +export PATH_TO_WISH +export PGACCESS_HOME + +exec ${PATH_TO_WISH} ${PGACCESS_HOME}/main.tcl "$@" +