database/postgres
1
0
Fork 0
mirror of https://github.com/postgres/postgres.git synced 2025-08-09 17:03:00 +03:00
Code Activity

Add new files.

Browse Source
This commit is contained in:
Bruce Momjian
1999-09-20 22:03:21 +00:00
parent 20a97d8079
commit 471881788f
55 changed files with 10214 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

82
src/bin/pgaccess/README Normal file
View File

@@ -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 <teo@flex.ro>

39
src/bin/pgaccess/copyright.html Normal file
View File

@@ -0,0 +1,39 @@
<HTML>
<HEAD>
<META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
<META NAME="GENERATOR" CONTENT="Mozilla/4.03 [en] (X11; I; Linux 2.0.30 i586) [Netscape]">
<TITLE>PgAccess - Copyright notice</TITLE>
</HEAD>
<BODY BGCOLOR="#FFFFFF">
<TT>---------------------------------------------------------------------------</TT>
<BR><TT></TT>&nbsp;
<BR><TT></TT>&nbsp;<TT></TT>
<P><TT>Copyright (c) 1994-7 Regents of the University of California</TT><TT></TT>
<P><TT>Permission to use, copy, modify, and distribute this software and
its</TT>
<BR><TT>documentation for any purpose, without fee, and without a written
agreement</TT>
<BR><TT>is hereby granted, provided that the above copyright notice and
this</TT>
<BR><TT>paragraph and the following two paragraphs appear in all copies.</TT><TT></TT>
<P><TT>IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY
PARTY FOR</TT>
<BR><TT>DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES,
INCLUDING</TT>
<BR><TT>LOST PROFITS, ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS</TT>
<BR><TT>DOCUMENTATION, EVEN IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED
OF THE</TT>
<BR><TT>POSSIBILITY OF SUCH DAMAGE.</TT><TT></TT>
<P><TT>THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,</TT>
<BR><TT>INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY</TT>
<BR><TT>AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER
IS</TT>
<BR><TT>ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATIONS
TO</TT>
<BR><TT>PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.</TT>
</BODY>
</HTML>

BIN
src/bin/pgaccess/doc/html/a_right.gif Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 207 B

BIN
src/bin/pgaccess/doc/html/addindex.gif Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 11 KiB

232
src/bin/pgaccess/doc/html/api.html Normal file
View File

@@ -0,0 +1,232 @@
<!doctype html public "-//w3c//dtd html 4.0 transitional//en">
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
<meta name="GENERATOR" content="Mozilla/4.61 [en] (X11; I; Linux 2.2.11 i586) [Netscape]">
</head>
<body bgcolor="#FEFEDF">
<h2>
PgAccess developer API</h2>
<hr>
<br>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.
<p>That's why PgAccess 0.98 has been internally restructured, every main
module of PgAccess has became a namespace (see Tcl namespaces) in order&nbsp;
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 <b>PgAcVar</b> (PgAccess variables) so they
should not interfere with user defined global variables.
<br>&nbsp;
<br>&nbsp;
<p><b><font size=+1>Global variables available</font></b>
<br>&nbsp;
<center><table BORDER=0 WIDTH="100%" NOSAVE >
<tr NOSAVE>
<td ALIGN=LEFT VALIGN=TOP NOSAVE><b>PgAcVar</b></td>
<td>The main global associative array that hold together various information
needed by PgAccess. User should <b><font color="#FF0000">NOT</font></b>
alter it under any circumstances.</td>
</tr>
<tr NOSAVE>
<td VALIGN=TOP NOSAVE><b>CurrentDB</b></td>
<td>The handler of the current opened database. Can be used for database
operations as selects or command execution.</td>
</tr>
<tr NOSAVE>
<td ALIGN=LEFT VALIGN=TOP NOSAVE><b>Messages</b></td>
<td NOSAVE>The associative array that holds the translation for the current
language. Loaded from the appropriate language file from lib/languages
directory</td>
</tr>
<tr NOSAVE>
<td ALIGN=LEFT VALIGN=TOP NOSAVE><b>PGACCESS_HOME</b></td>
<td>Keep the system directory of PgAccess root installation</td>
</tr>
</table></center>
<br>&nbsp;
<p><b><font size=+1>Window naming convention</font></b>
<p>Every toplevel window defined by PgAccess has the following naming convention.
Every window name starts with <tt>.pgaw</tt> (PgAccess window) followed
by a colon and a name. <i>Example:</i>
<blockquote><tt>.pgaw:User , .pgaw:About , .pgaw:ImportExport</tt></blockquote>
<b><font size=+1>Namespaces available</font></b>
<p>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&nbsp; procedures:
<ul>
<li>
<tt>new</tt>&nbsp; , no parameter needed</li>
<li>
<tt>open</tt> , need a single parameter, the object name</li>
<li>
<tt>design</tt> , need a single parameter, the object name</li>
</ul>
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.
<br><i>Example:</i>
<blockquote><tt>Tables::open "customers"</tt>
<br><tt>Queries::open "Invoices received"</tt>
<br><tt>Forms::open "Add new invoice"</tt></blockquote>
The <tt>Tables::open</tt> procedure accepts two optional parameters, filter
and order.
<br><i>Example:</i>
<blockquote><tt>Tables::open "phonebook" "name ~* 'joe'" "age desc"</tt></blockquote>
will open a table view window with predefined filter "name ~* 'joe'" and
ordered by descending age.
<p>There is also a special namespace called Database.&nbsp; Here are some
procedures and functions defined for this namespace available to the user:
<br>&nbsp;
<table BORDER NOSAVE >
<tr BGCOLOR="#FFCCFF" NOSAVE>
<td NOSAVE><b>Name</b></td>
<td NOSAVE><b>Parameters</b></td>
<td><b>Type</b></td>
<td><b>Returns</b></td>
<td NOSAVE><b>Description</b></td>
</tr>
<tr>
<td><b>vacuum</b></td>
<td>none</td>
<td>procedure</td>
<td>nothing</td>
<td>vacuums the current database</td>
</tr>
<tr ALIGN=LEFT VALIGN=TOP NOSAVE>
<td><b>getTablesList</b></td>
<td>none</td>
<td>function</td>
<td>list</td>
<td NOSAVE>returns the list of tables from the current database</td>
</tr>
<tr ALIGN=LEFT VALIGN=TOP NOSAVE>
<td><b>executeUpdate</b></td>
<td>sqlcmd</td>
<td>function</td>
<td>integer</td>
<td NOSAVE>execute the sqlcmd command on the current database returning
1 if no errors ocurred or 0 if the command failed</td>
</tr>
</table>
<p><b><font size=+1>Global functions available</font></b>
<br>&nbsp;
<table BORDER NOSAVE >
<tr BGCOLOR="#99FFCC" NOSAVE>
<td><b>Name</b></td>
<td><b>Parameters</b></td>
<td NOSAVE><b>Description</b></td>
</tr>
<tr ALIGN=LEFT VALIGN=TOP NOSAVE>
<td><b>setCursor</b></td>
<td>type</td>
<td NOSAVE>Set 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</td>
</tr>
<tr ALIGN=LEFT VALIGN=TOP NOSAVE>
<td><b>parameter</b></td>
<td>msg</td>
<td NOSAVE>Shows a modal input dialog with the msg message, wait for user
to enter the data and returns it as a string</td>
</tr>
<tr>
<td><b>showError</b></td>
<td>msg</td>
<td>Shows a modal dialog window with an error message</td>
</tr>
<tr>
<td></td>
<td></td>
<td></td>
</tr>
<tr>
<td></td>
<td></td>
<td></td>
</tr>
<tr>
<td></td>
<td></td>
<td></td>
</tr>
<tr>
<td></td>
<td></td>
<td></td>
</tr>
<tr>
<td></td>
<td></td>
<td></td>
</tr>
<tr>
<td></td>
<td></td>
<td></td>
</tr>
</table>
</body>
</html>

BIN
src/bin/pgaccess/doc/html/ball.gif Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 176 B

29
src/bin/pgaccess/doc/html/contents.html Normal file
View File

@@ -0,0 +1,29 @@
<!doctype html public "-//w3c//dtd html 4.0 transitional//en">
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
<meta name="GENERATOR" content="Mozilla/4.61 [en] (X11; I; Linux 2.2.11 i586) [Netscape]">
<base target="right">
</head>
<body bgcolor="#00FFFF">
<img SRC="ball.gif" ><a href="main.html">What is PgAccess?</a>
<br><img SRC="ball.gif" ><a href="whatsnew.html">What's new?</a>
<br><img SRC="ball.gif" ><a href="features.html">Features</a>
<br><img SRC="ball.gif" ><a href="screenshots.html">Screenshots</a>
<br><img SRC="ball.gif" ><a href="faq.html">FAQ</a>
<br><img SRC="ball.gif" ><a href="documentation.html">Documentation</a>
<br><img SRC="ball.gif" ><a href="todo.html">To-Do list</a>
<br><img SRC="ball.gif" ><a href="download.html">Download</a>
<br>&nbsp;
<p><br>
<center>
<p><a href="http://www.linux.org"><img SRC="linux1.gif" BORDER=0 ></a></center>
<p><b>Other links</b>
<br><img SRC="ball.gif" ><a href="http://www.postgresql.org">PostgreSQL</a>
<br><img SRC="ball.gif" ><a href="http://www.neuron.com/stewart/vtcl/index.html">Visual Tcl</a>
<br><img SRC="ball.gif" ><a href="http://www.scriptics.com">Tcl/Tk</a>
<br><img SRC="ball.gif" ><a href="http://www.linux.org">Linux</a>
<br><img SRC="ball.gif" ><a href="http://www.java.ro/vtclava/index.html">vTcLava</a>
</body>
</html>

39
src/bin/pgaccess/doc/html/copyright.html Normal file
View File

@@ -0,0 +1,39 @@
<HTML>
<HEAD>
<META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
<META NAME="GENERATOR" CONTENT="Mozilla/4.03 [en] (X11; I; Linux 2.0.30 i586) [Netscape]">
<TITLE>PgAccess - Copyright notice</TITLE>
</HEAD>
<BODY BGCOLOR="#FFFFFF">
<TT>---------------------------------------------------------------------------</TT>
<BR><TT></TT>&nbsp;
<BR><TT></TT>&nbsp;<TT></TT>
<P><TT>Copyright (c) 1994-7 Regents of the University of California</TT><TT></TT>
<P><TT>Permission to use, copy, modify, and distribute this software and
its</TT>
<BR><TT>documentation for any purpose, without fee, and without a written
agreement</TT>
<BR><TT>is hereby granted, provided that the above copyright notice and
this</TT>
<BR><TT>paragraph and the following two paragraphs appear in all copies.</TT><TT></TT>
<P><TT>IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY
PARTY FOR</TT>
<BR><TT>DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES,
INCLUDING</TT>
<BR><TT>LOST PROFITS, ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS</TT>
<BR><TT>DOCUMENTATION, EVEN IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED
OF THE</TT>
<BR><TT>POSSIBILITY OF SUCH DAMAGE.</TT><TT></TT>
<P><TT>THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,</TT>
<BR><TT>INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY</TT>
<BR><TT>AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER
IS</TT>
<BR><TT>ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATIONS
TO</TT>
<BR><TT>PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.</TT>
</BODY>
</HTML>

19
src/bin/pgaccess/doc/html/documentation.html Normal file
View File

@@ -0,0 +1,19 @@
<!doctype html public "-//w3c//dtd html 4.0 transitional//en">
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
<meta name="GENERATOR" content="Mozilla/4.61 [en] (X11; I; Linux 2.2.11 i586) [Netscape]">
</head>
<body bgcolor="#FEFEDF">
<h2>
Documentation</h2>
<hr WIDTH="100%">
<p>Still need to be written. Some information can be found in the help
included in the main program.
<p>Jim Lemon &lt;Jim.Lemon@uts.EDU.AU> has started writing a <a href="tutorial/index.html">tutorial</a>.
Thought it is based on earlier versions than 0.98 it is a beginning after
all, isn't it ?
</body>
</html>

42
src/bin/pgaccess/doc/html/download.html Normal file
View File

@@ -0,0 +1,42 @@
<!doctype html public "-//w3c//dtd html 4.0 transitional//en">
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
<meta name="GENERATOR" content="Mozilla/4.61 [en] (X11; I; Linux 2.2.11 i586) [Netscape]">
</head>
<body bgcolor="#FEFEDF">
<h2>
Download</h2>
<hr>
<br>The primary site for PgAccess downloads is:
<ul><a href="ftp://ftp.flex.ro/pub/pgaccess">ftp://ftp.flex.ro/pub/pgaccess</a>
<ul>
<li>
<a href="ftp://ftp.flex.ro/pub/pgaccess/pgaccess-0.98.tar.gz">Unix tar.gz
file</a></li>
<li>
<a href="ftp://ftp.flex.ro/pub/pgaccess/pgaccess-0.98.zip">Windows .zip
file</a></li>
</ul>
</ul>
<p>Another one (just with a little bit faster, try this one first) would
be :
<ul><a href="ftp://speedy.flex.ro/pub/pgaccess">ftp://speedy.flex.ro/pub/pgaccess</a>
<ul>
<li>
<a href="ftp://speedy.flex.ro/pub/pgaccess/pgaccess-0.98.tar.gz">Unix tar.gz
file</a></li>
<li>
<a href="ftp://speedy.flex.ro/pub/pgaccess/pgaccess-0.98.zip">Windows .zip
file</a></li>
</ul>
</ul>
<br>&nbsp;
</body>
</html>

85
src/bin/pgaccess/doc/html/faq.html Normal file
View File

@@ -0,0 +1,85 @@
<!doctype html public "-//w3c//dtd html 4.0 transitional//en">
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
<meta name="GENERATOR" content="Mozilla/4.61 [en] (X11; I; Linux 2.2.12 i586) [Netscape]">
</head>
<body bgcolor="#FEFEDF">
<h2>
PgAccess - FAQ</h2>
<hr>
<br><b>1. When I run PgAccess I got a message complaining about the crypt
library! What should I do?</b>
<blockquote>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.</blockquote>
<b>2. I cannot connect to a database from another machine</b>
<blockquote>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.</blockquote>
<b>3. I am experiencing core dumps when trying to run PgAccess. Is PgAccess
broken?</b>
<blockquote>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.</blockquote>
<b>4. When I try to run PgAccess I get the following error : Application
initialization failed: couldn't connect to display ""</b>
<blockquote>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 <tt>export DISPLAY=localhost:0.0</tt>
and run PgAccess again.</blockquote>
<b>5. Cannot run PgAccess on a Windows machine.</b>
<blockquote>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.</blockquote>
<b>6. How much costs PgAccess?</b>
<blockquote>PgAccess is a free tool. You won't have to pay anything in
order to use it. It is protected by the following <a href="copyright.html">copyright</a>
as PostgreSQL is. I cannot guarantee technical support but I will try to
answer to your questions as much as I can.</blockquote>
<b>7. I want to translate PgAccess messages for xxx language. What should
I do?</b>
<blockquote>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.</blockquote>
<p><br><b>8. I am receiving the following error: <tt>message invalid command
name "namespace" while executing "namespace eval Mainlib</tt>&nbsp; ..."</b>
<blockquote>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</blockquote>
<br>&nbsp;
<br>&nbsp;
<br>&nbsp;
</body>
</html>

52
src/bin/pgaccess/doc/html/features.html Normal file
View File

@@ -0,0 +1,52 @@
<!doctype html public "-//w3c//dtd html 4.0 transitional//en">
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
<meta name="GENERATOR" content="Mozilla/4.61 [en] (X11; I; Linux 2.2.11 i586) [Netscape]">
</head>
<body bgcolor="#FEFEDF">
<b>Tables</b>
<br>- opening multiple tables for viewing, max. n records (changed by preferences
menu)
<br>- column resizing, dragging the vertical grid line (better in table
space rather than in the table header)
<br>- text wrap in cells - layout saved for every table
<br>- import/export to external files (SDF,CSV)
<br>- filter capabilities (enter filter like (price>3.14)
<br>- sort order capabilities (enter manually the sort field(s))
<br>- editing in place
<br>- improved table generator assistant
<br>- improved field editing
<br><b>Queries</b>
<br>- define , edit and stores "user defined queries"
<br>- store queries as views
<br>- execution of queries with optional user input parameters ( select
* from invoices where year=[parameter "Year of selection"] )
<br>- viewing of select type queries result
<br>- query deleting and renaming
<br>- visual query builder with drag &amp; drop capabilities. For any of
you who had installed the Tcl/Tk plugin for Netscape Navigator, you can
see it at work <a href="qbtclet.html">clicking here</a>
<br><b>Sequences</b>
<br>- defines sequences, delete them and inspect them
<br><b>Functions</b>
<br>- define, inspect and delete functions in SQL, plpgsql and pgtcl languages
<br><b>Reports</b>
<br>- design and display simple reports from tables
<br>- fields and labels, font changing, style and size
<br>- saves and loads report description from database
<br>- show report previews, sample postscript output file
<br><b>Forms</b>
<br>- open user defined forms
<br>- form design module available
<br>- query widget available, controls bound to query results
<br>- <a href="forms.html">click here</a> for a description of forms and
how they can be used
<br><b>Scripts</b>
<br>- define, modify and call user defined scripts
<br><b>Users</b>
<br>- define and modify user information
<p><b><a href="api.html">PgAccess API</a></b> for developing small applications
<br>&nbsp;
</body>
</html>

216
src/bin/pgaccess/doc/html/formdemo.sql Normal file
View File

@@ -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 <ButtonRelease-1> {\
\ 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 <ButtonRelease-1> {\
\ 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" );

BIN
src/bin/pgaccess/doc/html/forms.gif Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 20 KiB

203
src/bin/pgaccess/doc/html/forms.html Normal file
View File

@@ -0,0 +1,203 @@
<!doctype html public "-//w3c//dtd html 4.0 transitional//en">
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
<meta name="GENERATOR" content="Mozilla/4.61 [en] (X11; I; Linux 2.2.11 i586) [Netscape]">
</head>
<body text="#000000" bgcolor="#FEFEDF" link="#0000EF" vlink="#51188E" alink="#FF0000">
<h1>
FORMS</h1>
<hr WIDTH="100%">
<p>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.
<p>For the moment, it has only some basic widgets : labels, entries, buttons
, listboxes , checkboxes and radiobuttons.
<p>Also there is a pseudo data control widget that allows you yo have access
to a query results.
<p><b>How do you generate widgets :</b>
<ol>
<li>
select a widget from the toolbox by clicking the appropriate radiobutton</li>
<li>
move to the canvas , point with the mouse at the desired location and click
the mouse button to begin</li>
<li>
keeping the mouse-button pressed move the mouse in order to draw a rectangle
that will hold the widget</li>
<li>
release the mouse-button</li>
</ol>
In the rectangle that you have designed it will appear the selected object.
<br>Move now to the attribute window to change some of its properties.
<p>Renaming, resizing items are possible (for the moment) only by modifying
appropriate parameters in attribute window. You <b>must </b>press Enter
in the edit field after changing a value in order to be accepted.
<p>You can also move items by dragging them or delete them by pressing
Del key after selecting them.
<p>In attribute window, there are some fields named <b><tt><font size=+1>Command
</font></tt></b>and
<b><tt><font size=+1>Variable</font></tt></b>.
<p>The field <b><tt><font size=+1>Command </font></tt></b>have meaning
only for Button widgets and holds the command that will be invoked when
the button is pressed.
<p>&nbsp;&nbsp;&nbsp; The field <b><tt><font size=+1>Variable </font></tt></b>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 <b>t</b> and <b>f</b> (from
true and false) in order to simplify binding to logical data fields (PgAccess
0.82 used 0 and 1).
<p>&nbsp;&nbsp;&nbsp; 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.
<p>&nbsp;&nbsp;&nbsp; In order to make a simple test, put an entry field
and set it's variable to <b>v1</b> 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.
<br>Another test is defining in Script module a script called "My first
script" having the following commands:
<br><tt><font size=+1>tk_messageBox -title Warning -message "This is my
first message!"</font></tt>
<br>and then define a button who's command is <b><tt><font size=+1>execute_script
"My first script"</font></tt></b>.
<br>&nbsp;
<h2>
Database manipulation</h2>
Let's presume that our form have the internal name <b><tt>mf </tt></b>(<b>m</b>y
<b>f</b>orm). Don't forget that the Tk window names could not start with
an uppercase letter.
<br>The window will be referred inside the Tcl/Tk source as <b><tt>.mf</tt></b>
<br>If you want to close the form in run-time you have to issue the command
<b><tt>destroy
.mf</tt></b>
<p>Also, any widget created inside this window (form) will have the name
prefixed by <b><tt>.mf ,</tt></b>so we will have <b><tt>.mf.button1</tt></b>
or <b><tt>.mf.listbox1</tt></b> .
<p>We can name the data control widget <b><tt>dc</tt></b> for example.
The fully qualified name for that "virtual widget" will be <b><tt>.mf.dc</tt></b>
then. A new namespace called <b><tt>DataControl(.mf.dc)</tt></b> will be
automatically defined.
<br>The <b><tt>Command </tt></b>property of the data control widget must
contain the SQL command that will be executed.
<br>When the form will be in run-time, automatically you will have access
to the following procedures and functions from the namespace:
<p><b><tt>open</tt></b> - opens the connection and execute the query (returns
nothing)
<br><b><tt>setSQL newsql</tt></b> - set the command query that will be
executed at the next <b><tt>open</tt></b>
<br><b><tt>getRowCount</tt></b> - returns the number of records of the
result set
<br><b><tt>getRowIndex </tt></b>- returns the current record number inside
the result set
<br><b><tt>getFieldList</tt></b> - returns a Tcl list containing the fields
names from the current result set
<br><b><tt>moveFirst</tt></b> - move the cursor to the first record in
the recordset
<br><b><tt>moveLast</tt></b><tt> , <b>moveNext</b> , <b>movePrevious</b></tt>-
moves the cursor there
<br><b><tt>moveTo newrecno</tt></b> - move the cursor to that new record
number (first is 0)
<br><b><tt>updateDataSet</tt></b> - update the variables inside the designed
form that have a particular name (I'll explain later)
<br><b><tt>clearDataSet</tt></b> - clear the associated DataSet variables
<br><tt><b>fill listbox field</b> </tt>- fill the named listbox (whole
widget name as <b><tt>.mf.listbox1</tt></b>) with the all the values of
that field from the current result set
<br><b><tt>close</tt></b> - close the result set (<b><font color="#FF0000">if
you don't close it, you will loose some memory</font></b>)
<p>These procedures and functions should be called in the normal Tcl namespace
mode as in the following example:
<p><tt>DataControl(.mf.dc)::setSQL "select * from phonebook"</tt>
<br><tt>DataControl(.mf.dc)::open</tt>
<br><tt>set nrecs [DataControl(.mf.dc)::getRowCount]</tt>
<p>If you complaint about writting to many DataControl(...) you can include
many commands into a single namespace eval as in the following example
:
<p><tt>namespace eval DataControl(.mf.dc) {</tt>
<br><tt>&nbsp;&nbsp;&nbsp; setSQL "select * from phonebook"</tt>
<br><tt>&nbsp;&nbsp;&nbsp; open</tt>
<br><tt>&nbsp;&nbsp;&nbsp; set nrecs [getRowCount]</tt>
<br><tt>&nbsp;&nbsp;&nbsp; moveLast</tt>
<br><tt>&nbsp;&nbsp;&nbsp; updateDataSet</tt>
<br><tt>}</tt>
<p>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.
<br>Opening a new <b>DataControl</b> 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 <b>DataSet</b> 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.
<p><i>Example:</i>
<br><tt>DataSet(.mf.dc,name)</tt>
<br><tt>DataSet(.mf.dc,city)</tt>
<p>If you want to bound some controls to the fields of the recordset, you
will have to name their associate variable like that :
<p><b><tt>DataSet(.mf.dc,salary)</tt></b> to get the "salary" field , or
<b><tt>DataSet(.mf.dc,name)</tt></b> to get the "name" field. Using the
data control procedures <b><tt>DataControl(.mf.dc)::moveNext</tt></b> or
movePrevious will automatically update the <b><tt>DataSet(.mf.dc,...)</tt></b>
array so the database information from entries in the form will be refreshed.
<br>&nbsp;
<p>Here it is a dumped <b><a href="formdemo.sql">sample database</a></b>
that contains a demo database. What should you do ?
<br>Shift-click the above URL in order to download that tiny file (4 Kb).
Create a empty database and <b><tt>psql yourdatabase &lt;formdemo.sql</tt></b>
<p>You should find a single table called "phonebook" a form called "Phone
book" and another "A simple demo form".
<p>First of all enter and view the phonebook table in table view. Note
the fields and their values.
<br>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.
<p>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.
<p><font color="#000080">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 <b>no live connection</b> 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.</font>
<p>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.
<p>In order to avoid naming user defined forms with&nbsp; a particular
name of another PgAccess form, I would recommend naming them as udf0, udf1
(user defined form 0 , 1 )
<p>
<hr WIDTH="25%">
<p>Please feel free to send me your opinion at <b>teo@flex.ro</b> on forms
designing and usage.
<p><b><font size=+1>KEEP IN MIND !&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
THE FORM API MAY CHANGE IN ORDER TO BE MORE SIMPLE AND BETTER!</font></b>
<br><b><font size=+1>SEND ME YOUR WISHES, YOUR IDEAS, YOUR OPINIONS !</font></b>
<br><b><font size=+1>ALSO ... DON'T BLAME ME IF YOU WILL HAVE TO RE-DESIGN
YOUR OLD FORMS DUE TO SOME INCOMPATIBILITIES WITH NEWER PGACCESS VERSIONS.</font></b>
</body>
</html>

BIN
src/bin/pgaccess/doc/html/function.gif Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 9.8 KiB

BIN
src/bin/pgaccess/doc/html/help.gif Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 6.9 KiB

11
src/bin/pgaccess/doc/html/index.html Normal file
View File

@@ -0,0 +1,11 @@
<HTML>
<HEAD>
<TITLE>PgAccess</TITLE>
<FRAMESET COLS="200,*" border=0 framespacing=0 frameborder=no>
<FRAME NAME="left" scrolling="none" src="contents.html">
<FRAME NAME="right" scrolling="nonw" src="main.html">
</FRAMESET>
</HTML>

133
src/bin/pgaccess/doc/html/irix.html Normal file
View File

@@ -0,0 +1,133 @@
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2//EN">
<HTML>
<HEAD>
<TITLE>PgAccess on Irix</TITLE>
<META NAME="GENERATOR" CONTENT="Mozilla/3.04Gold (X11; I; Linux 2.0.33 i586) [Netscape]">
</HEAD>
<BODY TEXT="#000000" BGCOLOR="#FFFFFF" LINK="#0000EF" VLINK="#51188E" ALINK="#FF0000">
<H1>INSTALLING PgAccess UNDER IRIX 5.3.
<HR WIDTH="100%"></H1>
<P><B><FONT COLOR="#000080">This HOWO-TO make PgAccess working under Irix
is written by Stuart Rison</FONT></B></P>
<P>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.).</P>
<P><B>1) Requirements:</B></P>
<UL>
<P>You will need:</P>
<UL>
<LI>postgreSQL source (http://www.postgresql.org)</LI>
<LI>tcl8.0 source (http://www.tclconsortium.org/)</LI>
<LI>tk8.0 source (http://www.tclconsortium.org/)</LI>
<LI>pgaccess source (http://www.flex.ro/pgaccess)</LI>
</UL>
</UL>
<P><B>2) Installation:</B></P>
<P>a) tcl/tk:</P>
<UL>
<P>You must first install tcl and then tk (in that order). I just used
./configure, no switches and gmake. Their installation should be trouble
free. Then you must move headers and libraries to the right places so:</P>
<P>Header files: both tcl and tk have a header file (tcl.h and tk.h). The
tcl.h file is in $tcl_source_dir/generic and the tk.h file is in $tk_source_dir/generic;
both should be copied to /usr/local/include.</P>
<P>Libraries: compilation (with cc) of tcl and tk yield libraries libtcl8.0.a
and libtk8.0.a in $source_dir/unix. Both should be copied to /usr/local/lib.</P>
</UL>
<P>b) postgreSQL:</P>
<UL>
<P>Make sure you have a fully patched postgreSQL source. If your ./configure
says it can't load 'IRIX' settings then you most probably will need to
patch ./configure.</P>
<P>Configure using ./configure with the following switches: ./configure
--with-includes=/usr/local/include</P>
<P>--with-libraries=/usr/local/lib --with-tcl [this and previous line as
one]</P>
<P>Then make, make install as usual</P>
</UL>
<P>c) Compiling libpgtcl:</P>
<UL>
<P>The source for libpgtcl is in $postgreSQL_directory/src/interfaces/libpgsql.</P>
<P>I do this twice. Once with just gmake. This produces a static library
libpgtcl.a which I leave where it is (I don't know what to do with it but
it may just come in handy). The I modify Makefile manually with a text
editor. Essentially I modify two line:</P>
<P>before:</P>
<P># Shared library stuff</P>
<P>install-shlib-dep := shlib :=</P>
<P>after:</P>
<P># Shared library stuff</P>
<P>install-shlib-dep := install-shlib shlib := libpgtcl.so.1</P>
<P>Then gmake -f Makefile_modified. This creates two shared (.so) libraries:
libpgtcl.so and libpgtcl.so.1. I can't tell the difference between them
so I copied them both to /usr/lib/.</P>
</UL>
<P>d) running pgaccess:</P>
<UL>
<P>Uncompress pgaccess (usually with gunzip and tar). So long as 'wish'
(a binary produced when compiling tk8.0) is somewhere in your path, you
should be able to run pgaccess with:</P>
<P>wish -f $pgaccess_dir/pgaccess.tcl [postgreSQL_database_name]</P>
</UL>
<P>e) et voila!</P>
<P><B>3) Concluding remarks:</B></P>
<UL>
<P>As I stated at the start of this document, following the procedure indicated
above worked for me. I am sure, however, that a few of the steps are unnecessary/non-optimised/stupid
etc. If any Unix (IRIX) boffin is reading this and you spot anything you
would like to comment/correct etc. please e-mail me (stuart@ludwig.ucl.ac.uk).
Also, if you just have questions and think I might help, please contact
me at the same e-mail.</P>
<P>Finally, I can accept no responsibility if these steps don't work for
you or if it all goes horribly wrong and you 'damage' your computer trying
them. Let common sense prevail!</P>
</UL>
<P>Good luck</P>
<P>Stuart Rison LICR University College London London W1P 8BT<BR>
<A HREF="mailto:stuart@ludwig.ucl.ac.uk">stuart@ludwig.ucl.ac.uk</A></P>
</BODY>
</HTML>

BIN
src/bin/pgaccess/doc/html/linux1.gif Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 789 B

43
src/bin/pgaccess/doc/html/maillist.html Normal file
View File

@@ -0,0 +1,43 @@
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2//EN">
<HTML>
<HEAD>
<TITLE></TITLE>
<META NAME="GENERATOR" CONTENT="Mozilla/3.04Gold (X11; I; Linux 2.0.32 i586) [Netscape]">
</HEAD>
<BODY TEXT="#000000" BGCOLOR="#FFFFFF" LINK="#0000EF" VLINK="#51188E" ALINK="#FF0000">
<P>The mailing list for PgAccess is : &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<B><TT>pgsql-interfaces@postgresql.org</TT></B></P>
<P>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.</P>
<P>
<HR WIDTH="100%"></P>
<P>To subscribe please send a mail message to&nbsp;:</P>
<P>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<B><TT><FONT SIZE=+1>pgsql-interfaces-request@postgresql.org
</FONT></TT></B>&nbsp;</P>
<P>having a single line in the body message :&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<B><TT><FONT SIZE=+1>subscribe</FONT></TT></B></P>
<P>In a couple of minutes , if everything is ok, you must receive something
like that :</P>
<P>
<HR WIDTH="100%"></P>
<P><TT>Welcome to the pgsql-interfaces mailing list!</TT></P>
<P><TT>Please save this message for future reference. Thank you.</TT></P>
<P><TT>If you ever want to remove yourself from this mailing list, you
can send mail to &lt;Majordomo@hub.org&gt; with the following command in
the body of your email message:</TT></P>
<P><TT>unsubscribe pgsql-interfaces yourname@yourdomain</TT></P>
<TT></TT>
</BODY>
</HTML>

34
src/bin/pgaccess/doc/html/main.html Normal file
View File

@@ -0,0 +1,34 @@
<!doctype html public "-//w3c//dtd html 4.0 transitional//en">
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
<meta name="GENERATOR" content="Mozilla/4.61 [en] (X11; I; Linux 2.2.12 i586) [Netscape]">
</head>
<body bgcolor="#FEFEDF">
<h1>
PgAccess
<hr WIDTH="100%"></h1>
A free graphical database management tool for <a href="http://www.postgresql.org">PostgreSQL</a>.
PgAccess has been written by <a href="mailto:teo@flex.ro">Constantin Teodorescu</a>
using Visual Tcl, the best tool for developing Tcl/Tk applications I've
ever seen.
<p><b>Last version</b>
<br>Last stable version is 0.98 , released on 29 August 1999. Read <a href="whatsnew.html">what's
new</a> in 0.98.
<p><b>Portability issues</b>
<br>PgAccess is available for every platform where PostgreSQL was ported
and where a Tcl/Tk package is available. PgAccess has been reported running
on :
<br>- Linux
<br>- FreeBSD
<br>- Solaris
<br>- HPUX
<br>- Irix
<br>- Windows 95,98,NT
<p>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 <a href="win32.html">here</a>.
<p>PgAccess is protected by the following <a href="copyright.html">copyright</a>.
</body>
</html>

BIN
src/bin/pgaccess/doc/html/mainwindow.gif Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 8.6 KiB

BIN
src/bin/pgaccess/doc/html/newtable.gif Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 9.1 KiB

BIN
src/bin/pgaccess/doc/html/newuser.gif Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 3.9 KiB

143
src/bin/pgaccess/doc/html/old_index.html Normal file
View File

@@ -0,0 +1,143 @@
<!doctype html public "-//w3c//dtd html 4.0 transitional//en">
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
<meta name="GENERATOR" content="Mozilla/4.61 [en] (X11; I; Linux 2.2.11 i586) [Netscape]">
<title>PgAccess - a Tcl/Tk PostgreSQL interface</title>
</head>
<body bgcolor="#FFFFFF">
<h1>
PgAccess - a free database management tool for <a href="http://www.postgreSQL.org">PostgreSQL</a></h1>
<hr>
<li>
Download the last version of PgAccess <a href="pgaccess-0.96.tar.gz">(press
shift and click this link) (tar.gz file)</a>&nbsp; or&nbsp;&nbsp; <a href="pgaccess.zip">this
one (zip file for Windows)</a></li>
<center>
<p><br>Latest stable version of PgAccess is 0.97 , released 16 August 1999
!
<p><font size=+2>PgAccess 0.93 and higher will not work from the beginning
with PostgreSQL 6.3.x !!</font>
<br><font size=+2>Read <a href="pg93patch.html">here</a> how to apply a
simple patch in order to make it work !</font></center>
<b><font color="#000000"><font size=+2></font></font></b>
<center><table BORDER=2 NOSAVE >
<tr NOSAVE>
<td NOSAVE><b><font color="#FF0000"><font size=+2>NEW</font></font></b></td>
<td NOSAVE><b><font color="#000000"><font size=+2>International version
(english, french, italian, romanian)</font></font></b></td>
</tr>
<tr NOSAVE>
<td NOSAVE><b><font color="#FF0000"><font size=+2>NEW</font></font></b></td>
<td><b><font size=+2>Context sensitive Help</font></b></td>
</tr>
</table></center>
<center>
<p>Precompiled libpgtcl and libpq binaries and dll's for i386 are <a href="ftp://ftp.flex.ro/pub/pgaccess">here
</a>!!!</center>
<h3>
<font color="#000080">Installation problems</font></h3>
<ul>
<li>
Some problems related with locale special characters could be solved by
this <a href="specialchars.html">simple patch</a></li>
<li>
I think that there were some problems loading libpgtcl library. I invite
you to read a <a href="index.html#libpgtcl">special section concerning
libpgtcl</a></li>
<li>
For Silicon Graphics Indigo computers, Irix operating system, there is
a <a href="irix.html">HOWTO make PgAccess to work</a></li>
</ul>
<h3>
<font color="#191970">What does PgAccess now!</font></h3>
Here are some screenshots from PgAccess windows : <a href="pic-pga-1.gif">Main
window </a>, <a href="pic-pga-2.gif">table builder </a>, <a href="pic-pga-4.gif">table(query)
view </a>, <a href="pic-pga-3.gif">visual query builder </a>.
<p><b>Tables</b>
<br>- opening multiple tables for viewing, max. n records (changed by preferences
menu)
<br>- column resizing, dragging the vertical grid line (better in table
space rather than in the table header)
<br>- text wrap in cells - layout saved for every table
<br>- import/export to external files (SDF,CSV)
<br>- filter capabilities (enter filter like (price>3.14)
<br>- sort order capabilities (enter manually the sort field(s))
<br>- editing in place
<br>- improved table generator assistant
<br>- improved field editing
<br><b>Queries</b>
<br>- define , edit and stores "user defined queries"
<br>- store queries as views
<br>- execution of queries with optional user input parameters ( select
* from invoices where year=[parameter "Year of selection"] )
<br>- viewing of select type queries result
<br>- query deleting and renaming
<br>- visual query builder with drag &amp; drop capabilities. For any of
you who had installed the Tcl/Tk plugin for Netscape Navigator, you can
see it at work <a href="qbtclet.html">clicking here</a>
<br><b>Sequences</b>
<br>- defines sequences, delete them and inspect them
<br><b>Functions</b>
<br>- define, inspect and delete functions in SQL, plpgsql and pgtcl languages
<br><b>Reports</b>
<br>- design and display simple reports from tables
<br>- fields and labels, font changing, style and size
<br>- saves and loads report description from database
<br>- show report previews, sample postscript output file
<br><b>Forms</b>
<br>- open user defined forms
<br>- form design module available
<br>- query widget available, controls bound to query results
<br>- <a href="forms.html">click here</a> for a description of forms and
how they can be used
<br><b>Scripts</b>
<br>- define, modify and call user defined scripts
<br><b>Users</b>
<br>- define and modify user information
<p>Here is <a href="pga-rad.html">a special section concerning forms and
scripts</a> .
<p>This program is protected by the following <a href="copyright.html">copyright</a>
<p>If you have any comment, suggestion for improvements, please feel free
to e-mail to : <a href="mailto:teo@flex.ro">teo@flex.ro</a>
<p><b><font color="#FF1493"><font size=+2>Mailing list for PgAccess </font></font></b><a href="maillist.html">Here
you will find how to subscribe to this mailing list</a>.
<p>
<hr>
<h1>
More information about libpgtcl - downloads</h1>
&nbsp;&nbsp;&nbsp;&nbsp; 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.&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; 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.
<p>&nbsp;&nbsp;&nbsp;&nbsp; One of the solutions is to remove from the
source the line containing <b>load libpgtcl.so </b>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.
<p>&nbsp;&nbsp;&nbsp;&nbsp; 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 <b>libpq </b>and <b><tt>libpgtcl </tt></b>libraries.
<p>&nbsp;&nbsp;&nbsp; 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.
<br>&nbsp;
</body>
</html>

BIN
src/bin/pgaccess/doc/html/permissions.gif Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 10 KiB

25
src/bin/pgaccess/doc/html/pg93patch.html Normal file
View File

@@ -0,0 +1,25 @@
<!doctype html public "-//w3c//dtd html 4.0 transitional//en">
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
<meta name="GENERATOR" content="Mozilla/4.5 [en] (X11; I; Linux 2.0.36 i586) [Netscape]">
</head>
<body text="#000000" bgcolor="#FFFFFF" link="#0000FF" vlink="#FF0000" alink="#000088">
<h1>
PgAccess 0.93 patch to make it work with PostgreSQL 6.3.x
<hr WIDTH="100%"></h1>
<p><br>PgAccess 0.93 is working fine with PostgreSQL 6.4.x due to some
changes in libpgtcl !
<p>There is a small patch that you have to make in order to make it work
with 6.3.x !
<p>Replace in procedure <tt>wpg_exec</tt> the following line:
<p><tt>set pgsql(errmsg) [pg_result $pgsql(res) -error]</tt>
<p>with this one :
<p><tt>set pgsql(errmsg) "NO ERROR INFORMATION SUPPLIED"</tt>
<p>And it will work fine! In some error cases, you will not get the appropriate
error message from libpgtcl.
<p>&nbsp;<a href="index.html">Back</a>
</body>
</html>

65
src/bin/pgaccess/doc/html/pga-rad.html Normal file
View File

@@ -0,0 +1,65 @@
<HTML>
<HEAD>
<META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
<META NAME="GENERATOR" CONTENT="Mozilla/4.04 [en] (X11; I; Linux 2.0.32 i586) [Netscape]">
</HEAD>
<BODY TEXT="#000000" BGCOLOR="#FFFFFF" LINK="#0000EF" VLINK="#51188E" ALINK="#FF0000">
<H1>
PgAccess - Scripts and Forms&nbsp;
<HR WIDTH="100%"></H1>
Beginning with 0.70 version, I have introduced in PgAccess two new modules
for operating with scripts and forms.
<P>&nbsp;&nbsp; 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.
<BR>&nbsp;
<BR>&nbsp;&nbsp; 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.
<P>&nbsp;&nbsp; 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 !
<H3>
Forms</H3>
&nbsp;&nbsp; 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".
<BR>&nbsp;&nbsp; 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&nbsp; <A HREF="forms.html">special
section concerning forms.</A>
<H3>
Scripts</H3>
&nbsp;&nbsp; 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.
<BR>&nbsp;&nbsp; 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 <B><TT><FONT COLOR="#000080">open_table
"Your sample table"</FONT></TT></B> and you'll see the result.
<BR>&nbsp;&nbsp; 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 <B><TT><FONT COLOR="#000080">execute_script
"My own procedure library"</FONT></TT></B> or open a form with <B><TT><FONT COLOR="#000080">open_form
"Main window with menu buttons"</FONT></TT></B> , and so on.
<P>
<HR WIDTH="100%">
<BR>Remember : I'm waiting your messages at <A HREF="mailto:teo@flex.ro">teo@flex.ro</A>
<P>
<HR WIDTH="50%">
</BODY>
</HTML>

45
src/bin/pgaccess/doc/html/qbtclet.html Normal file
View File

@@ -0,0 +1,45 @@
<html>
<title> Visual Query Builder in Tcl/Tk </title>
<body bgcolor=white>
<h1> Visual Query Builder</h1>
<hr>
This visual query builder is included in <a href='http://www.flex.ro/pgaccess'>
PgAccess</a>, a visual interface to
<a href='http://www.postgreSQL.org'> PostgreSQL</a> written entirely in
vTcl , (Visual Tcl).
<p align="center">
<embed src="qbtclet.tcl" width=590 height=485>
</p>
<br>
Visual Query Designer demo<br>
Click <a href='qbtclet.tar.gz'>here</a> to download the source </a>
created by Constantin Teodorescu with vTcl (visual Tcl), teo@flex.ro
<hr>
Facitilies<br>
- drag and drop selection of fields<br>
- drag and drop fields from a table to another do create links<br>
- move table position by dragging<br>
- point and click any link or table then press delete to delete them<br>
- modify sort order by clicking on (unsorted)<br>
- enter filter conditions as criteria (>2000 , ='item')<br>
- easy panning of table and result panels<br>
- show SQL command<br>
<br>
If you want to use it for your database, modify ql_read_struct in order to read
your table structure.
<br>
Feel free to use, modify or copy this software for non-commercial purposes.<br>
In any other case, please contact me.
<br>
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.
</body>
</html>

529
src/bin/pgaccess/doc/html/qbtclet.tcl Normal file
View File

@@ -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 <Button-1> {ql_link_click %x %y}
}
proc ql_draw_lizzard {} {
global qlvar
ql_read_struct
.c delete all
set posx 20
for {set it 0} {$it<$qlvar(ntables)} {incr it} {
ql_draw_table $it
# set posy 10
# set tablename $qlvar(tablename$it)
# .c create text $posx $posy -text $tablename -anchor nw -tags [subst {tab$tablename f-oid mov tableheader}] -font -Adobe-Helvetica-Bold-R-Normal-*-*-120-*-*-*-*-*
# incr posy 16
# foreach fld $qlvar(tablestruct$it) {
# .c create text $posx $posy -text $fld -anchor nw -tags [subst {f-$fld tab$tablename mov}] -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*
# incr posy 14
# }
# set reg [.c bbox tab$tablename]
# .c create rectangle [lindex $reg 0] [lindex $reg 1] [lindex $reg 2] [lindex $reg 3] -fill #EEEEEE -tags [subst {rect tab$tablename}]
# .c create line [lindex $reg 0] [expr [lindex $reg 1]+15] [lindex $reg 2] [expr [lindex $reg 1]+15] -tags [subst {rect tab$tablename}]
# set posx [expr $posx+40+[lindex $reg 2]-[lindex $reg 0]]
}
.c lower rect
.c create line 0 $qlvar(yoffs) 10000 $qlvar(yoffs) -width 3
.c create rectangle 0 $qlvar(yoffs) 10000 5000 -fill #FFFFFF
for {set i [expr 15+$qlvar(yoffs)]} {$i<500} {incr i 15} {
.c create line $qlvar(xoffs) $i 10000 $i -fill #CCCCCC -tags {resgrid}
}
for {set i $qlvar(xoffs)} {$i<10000} {incr i $qlvar(reswidth)} {
.c create line $i [expr 1+$qlvar(yoffs)] $i 10000 -fill #cccccc -tags {resgrid}
}
# Make a marker for result panel offset calculations (due to panning)
.c create line $qlvar(xoffs) $qlvar(yoffs) $qlvar(xoffs) 500 -tags {resmarker resgrid}
.c create rectangle 0 $qlvar(yoffs) $qlvar(xoffs) 5000 -fill #EEEEEE -tags {reshdr}
.c create text 5 [expr 1+$qlvar(yoffs)] -text Field: -anchor nw -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags {reshdr}
.c create text 5 [expr 16+$qlvar(yoffs)] -text Table: -anchor nw -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags {reshdr}
.c create text 5 [expr 31+$qlvar(yoffs)] -text Sort: -anchor nw -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags {reshdr}
.c create text 5 [expr 46+$qlvar(yoffs)] -text Criteria: -anchor nw -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags {reshdr}
.c bind mov <Button-1> {ql_dragstart %W %x %y}
.c bind mov <B1-Motion> {ql_dragit %W %x %y}
bind . <ButtonRelease-1> {ql_dragstop %x %y}
bind . <Button-1> {qlc_click %x %y %W}
bind . <B1-Motion> {ql_pan %x %y}
bind . <Key-Delete> {ql_delete_object}
set qlvar(resfields) {}
set qlvar(ressort) {}
set qlvar(rescriteria) {}
set qlvar(restables) {}
set qlvar(critedit) 0
set qlvar(links) {}
set qlvar(linktodelete) {}
}
proc ql_draw_res_panel {} {
global qlvar
# Compute the offset of the result panel due to panning
set resoffset [expr [lindex [.c bbox resmarker] 0]-$qlvar(xoffs)]
.c delete resp
for {set i 0} {$i<[llength $qlvar(resfields)]} {incr i} {
.c create text [expr $resoffset+4+$qlvar(xoffs)+$i*$qlvar(reswidth)] [expr 1+$qlvar(yoffs)] -text [lindex $qlvar(resfields) $i] -anchor nw -fill navy -tags {resf resp} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*
.c create text [expr $resoffset+4+$qlvar(xoffs)+$i*$qlvar(reswidth)] [expr 16+$qlvar(yoffs)] -text [lindex $qlvar(restables) $i] -anchor nw -tags {resp rest} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*
.c create text [expr $resoffset+4+$qlvar(xoffs)+$i*$qlvar(reswidth)] [expr 31+$qlvar(yoffs)] -text [lindex $qlvar(ressort) $i] -anchor nw -tags {resp sort} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*
if {[lindex $qlvar(rescriteria) $i]!=""} {
.c create text [expr $resoffset+4+$qlvar(xoffs)+$i*$qlvar(reswidth)] [expr $qlvar(yoffs)+46+15*0] -anchor nw -text [lindex $qlvar(rescriteria) $i] -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags [subst {resp cr-c$i-r0}]
}
}
.c raise reshdr
.c bind sort <Button-1> {ql_swap_sort %W %x %y}
}
proc ql_draw_table {it} {
global qlvar
set posy 10
set allbox [.c bbox rect]
if {$allbox==""} {set posx 10} else {set posx [expr 20+[lindex $allbox 2]]}
set tablename $qlvar(tablename$it)
.c create text $posx $posy -text $tablename -anchor nw -tags [subst {tab$tablename f-oid mov tableheader}] -font -Adobe-Helvetica-Bold-R-Normal-*-*-120-*-*-*-*-*
incr posy 16
foreach fld $qlvar(tablestruct$it) {
.c create text $posx $posy -text $fld -anchor nw -tags [subst {f-$fld tab$tablename mov}] -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*
incr posy 14
}
set reg [.c bbox tab$tablename]
.c create rectangle [lindex $reg 0] [lindex $reg 1] [lindex $reg 2] [lindex $reg 3] -fill #EEEEEE -tags [subst {rect tab$tablename}]
.c create line [lindex $reg 0] [expr [lindex $reg 1]+15] [lindex $reg 2] [expr [lindex $reg 1]+15] -tags [subst {rect tab$tablename}]
}
proc ql_get_tag_info {obj prefix} {
set taglist [.c gettags $obj]
set tagpos [lsearch -regexp $taglist "^$prefix"]
if {$tagpos==-1} {return ""}
set thattag [lindex $taglist $tagpos]
return [string range $thattag [string length $prefix] end]
}
proc ql_link_click {x y} {
global qlvar
set obj [.c find closest $x $y 1 links]
if {[ql_get_tag_info $obj link]!="s"} return
.c itemconfigure [.c find withtag hili] -fill black
.c dtag [.c find withtag hili] hili
.c addtag hili withtag $obj
.c itemconfigure $obj -fill blue
}
proc ql_pan {x y} {
global qlvar
set panstarted 0
catch {set panstarted $qlvar(panstarted) }
if {!$panstarted} return
set dx [expr $x-$qlvar(panstartx)]
set dy [expr $y-$qlvar(panstarty)]
set qlvar(panstartx) $x
set qlvar(panstarty) $y
if {$qlvar(panobject)=="tables"} {
.c move mov $dx $dy
.c move links $dx $dy
.c move rect $dx $dy
} else {
.c move resp $dx 0
.c move resgrid $dx 0
.c raise reshdr
}
}
proc ql_read_struct {} {
global qlvar
set qlvar(ntables) 3
set qlvar(tablename0) Facturi
set qlvar(tablename1) Nommat
set qlvar(tablename2) Incasari
set qlvar(tablestruct0) [list factura client valoare tva]
set qlvar(tablestruct1) [list cod denumire pret greutate procent_tva]
set qlvar(tablestruct2) [list data valoare nrdoc referinta]
}
proc ql_show_sql {} {
global qlvar
set sqlcmd "select "
for {set i 0} {$i<[llength $qlvar(resfields)]} {incr i} {
if {$sqlcmd!="select "} {set sqlcmd "$sqlcmd, "}
set sqlcmd "$sqlcmd[lindex $qlvar(restables) $i].[lindex $qlvar(resfields) $i]"
}
set tables {}
for {set i 0} {$i<$qlvar(ntables)} {incr i} {
lappend tables $qlvar(tablename$i)
}
set sqlcmd "$sqlcmd from [join $tables ,] "
set sup1 {}
if {[llength $qlvar(links)]>0} {
set sup1 "where "
foreach link $qlvar(links) {
if {$sup1!="where "} {set sup1 "$sup1 and "}
set sup1 "$sup1 ([lindex $link 0].[lindex $link 1]=[lindex $link 2].[lindex $link 3])"
}
}
for {set i 0} {$i<[llength $qlvar(resfields)]} {incr i} {
set crit [lindex $qlvar(rescriteria) $i]
if {$crit!=""} {
if {$sup1==""} {set sup1 "where "}
if {[string range $sup1 0 4]=="where"} {set sup1 "$sup1 and "}
set sup1 "$sup1 ([lindex $qlvar(restables) $i].[lindex $qlvar(resfields) $i]$crit) "
}
}
set sqlcmd "$sqlcmd $sup1"
set sup2 {}
for {set i 0} {$i<[llength $qlvar(ressort)]} {incr i} {
set how [lindex $qlvar(ressort) $i]
if {$how!="unsorted"} {
if {$how=="Ascending"} {set how asc} else {set how desc}
if {$sup2==""} {set sup2 " order by "} else {set sup2 "$sup2,"}
set sup2 "$sup2 [lindex $qlvar(resfields) $i] $how "
}
}
set sqlcmd "$sqlcmd $sup2"
set qlvar(sql) $sqlcmd
#tk_messageBox -message $sqlcmd
.c delete sqlpage
.c create rectangle 0 0 2000 [expr $qlvar(yoffs)-1] -fill #ffffff -tags {sqlpage}
.c create text 10 10 -text $sqlcmd -anchor nw -width 550 -tags {sqlpage} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*
.c bind sqlpage <Button-1> {.c delete sqlpage}
}
proc ql_swap_sort {w x y} {
global qlvar
set obj [$w find closest $x $y]
set taglist [.c gettags $obj]
if {[lsearch $taglist sort]==-1} return
set cum [.c itemcget $obj -text]
if {$cum=="unsorted"} {
set cum Ascending
} elseif {$cum=="Ascending"} {
set cum Descending
} else {
set cum unsorted
}
set col [expr int(($x-$qlvar(xoffs))/$qlvar(reswidth))]
set qlvar(ressort) [lreplace $qlvar(ressort) $col $col $cum]
.c itemconfigure $obj -text $cum
}
proc qlc_click {x y w} {
global qlvar
set qlvar(panstarted) 0
if {$w==".c"} {
set canpan 1
if {$y<$qlvar(yoffs)} {
if {[llength [.c find overlapping $x $y $x $y]]!=0} {set canpan 0}
set qlvar(panobject) tables
} else {
set qlvar(panobject) result
}
if {$canpan} {
. configure -cursor hand1
set qlvar(panstartx) $x
set qlvar(panstarty) $y
set qlvar(panstarted) 1
}
}
set isedit 0
catch {set isedit $qlvar(critedit)}
# Compute the offset of the result panel due to panning
set resoffset [expr [lindex [.c bbox resmarker] 0]-$qlvar(xoffs)]
if {$isedit} {
set qlvar(rescriteria) [lreplace $qlvar(rescriteria) $qlvar(critcol) $qlvar(critcol) $qlvar(critval)]
.c delete cr-c$qlvar(critcol)-r$qlvar(critrow)
.c create text [expr $resoffset+4+$qlvar(xoffs)+$qlvar(critcol)*$qlvar(reswidth)] [expr $qlvar(yoffs)+46+15*$qlvar(critrow)] -anchor nw -text $qlvar(critval) -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags [subst {resp cr-c$qlvar(critcol)-r$qlvar(critrow)}]
set qlvar(critedit) 0
}
catch {destroy .entc}
if {$y<[expr $qlvar(yoffs)+46]} return
if {$x<[expr $qlvar(xoffs)+5]} return
set col [expr int(($x-$qlvar(xoffs)-$resoffset)/$qlvar(reswidth))]
if {$col>=[llength $qlvar(resfields)]} return
set nx [expr $col*$qlvar(reswidth)+8+$qlvar(xoffs)+$resoffset]
set ny [expr $qlvar(yoffs)+76]
# Get the old criteria value
set qlvar(critval) [lindex $qlvar(rescriteria) $col]
entry .entc -textvar qlvar(critval) -borderwidth 0 -background #FFFFFF -highlightthickness 0 -selectborderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*
place .entc -x $nx -y $ny -height 14
focus .entc
bind .entc <Button-1> {set qlvar(panstarted) 0}
set qlvar(critcol) $col
set qlvar(critrow) 0
set qlvar(critedit) 1
}
proc Window {args} {
global vTcl
set cmd [lindex $args 0]
set name [lindex $args 1]
set newname [lindex $args 2]
set rest [lrange $args 3 end]
if {$name == "" || $cmd == ""} {return}
if {$newname == ""} {
set newname $name
}
set exists [winfo exists $newname]
switch $cmd {
show {
if {$exists == "1" && $name != "."} {wm deiconify $name; return}
if {[info procs vTclWindow(pre)$name] != ""} {
eval "vTclWindow(pre)$name $newname $rest"
}
if {[info procs vTclWindow$name] != ""} {
eval "vTclWindow$name $newname $rest"
}
if {[info procs vTclWindow(post)$name] != ""} {
eval "vTclWindow(post)$name $newname $rest"
}
}
hide { if $exists {wm withdraw $newname; return} }
iconify { if $exists {wm iconify $newname; return} }
destroy { if $exists {destroy $newname; return} }
}
}
set base ""
bind $base <B1-Motion> {
ql_pan %x %y
}
bind $base <Button-1> {
qlc_click %x %y %W
}
bind $base <ButtonRelease-1> {
ql_dragstop %x %y
}
bind $base <Key-Delete> {
ql_delete_object
}
canvas $base.c \
-background #fefefe -borderwidth 2 -height 207 -relief ridge \
-takefocus 0 -width 295
label $base.msg -textvar msg -borderwidth 1 -relief sunken
button $base.b2 \
-borderwidth 1 -command ql_draw_lizzard \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \
-pady 3 -text {Paint demo tables}
button $base.showbtn \
-borderwidth 1 -command ql_show_sql \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \
-pady 3 -text {Show SQL}
###################
# SETTING GEOMETRY
###################
place $base.c \
-x 5 -y 30 -width 578 -height 425 -anchor nw -bordermode ignore
place $base.b2 \
-x 5 -y 5 -height 26 -anchor nw -bordermode ignore
place $base.showbtn \
-x 130 -y 5 -height 26 -anchor nw -bordermode ignore
place $base.msg \
-x 5 -y 460 -width 578 -anchor nw
main $argc $argv

43
src/bin/pgaccess/doc/html/screenshots.html Normal file
View File

@@ -0,0 +1,43 @@
<!doctype html public "-//w3c//dtd html 4.0 transitional//en">
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
<meta name="GENERATOR" content="Mozilla/4.61 [en] (X11; I; Linux 2.2.12 i586) [Netscape]">
</head>
<body bgcolor="#FEFEDF">
<h3>
Image gallery
<hr WIDTH="100%"></h3>
<ul>
<li>
&nbsp;<a href="mainwindow.gif">Main window</a> 9 Kb</li>
<li>
&nbsp;<a href="newtable.gif">Creating a new table</a> 9 Kb</li>
<li>
&nbsp;<a href="permissions.gif">Table access control</a> 10 Kb</li>
<li>
&nbsp;<a href="addindex.gif">Adding a new index</a> 12 Kb</li>
<li>
&nbsp;<a href="vdesigner.gif">The visual query designer</a> 16 Kb</li>
<li>
&nbsp;<a href="function.gif">Working with functions</a> 10 Kb</li>
<li>
&nbsp;<a href="forms.gif">Form designer</a> 19 Kb</li>
<li>
&nbsp;<a href="newuser.gif">User management</a> 4 Kb</li>
<li>
&nbsp;<a href="help.gif">Help</a> 7 Kb</li>
</ul>
</body>
</html>

47
src/bin/pgaccess/doc/html/specialchars.html Normal file
View File

@@ -0,0 +1,47 @@
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2//EN">
<HTML>
<HEAD>
<TITLE>Special locale characters</TITLE>
<META NAME="GENERATOR" CONTENT="Mozilla/3.04Gold (X11; I; Linux 2.0.32 i586) [Netscape]">
</HEAD>
<BODY TEXT="#000000" BGCOLOR="#FFFFFF" LINK="#0000EF" VLINK="#51188E" ALINK="#FF0000">
<H1>Special locale characters and PgAccess
<HR WIDTH="100%"></H1>
<P>The problem is related with some special characters used in different
countries because PgAccess did not use fonts with `-ISO8859-1' encoding
-- </P>
<P>The sollution was proposed by H.P.Heidinger ( hph@hphbbs.ruhr.de) and
it's very simple.</P>
<P>If you look into PgAccess, you will find fonts declared as follows :</P>
<P><TT>$ grep -e '-font' -i pgaccess.tcl<BR>
-font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \<BR>
-font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \<BR>
-font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \<BR>
-font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* \</TT></P>
<P>It should be something like: -adobe-helvetica-medium-r-normal-*-*-120-*-*-*-*-iso8859-1</P>
<P>You can achieve this by running the following script :</P>
<P><TT>#!/bin/sh<BR>
cp pgaccess.tcl pgaccess.tcl-org<BR>
cat pgaccess.tcl |\<BR>
sed -e's/\-\*\-\*\ /\-iso8859\-1\ /g' |\<BR>
sed -e's/\-\*\-\*\}/\-iso8859\-1}/g' |\<BR>
sed -e's/\-\*\-\*\]/\-iso8859\-1]/g' |\<BR>
sed -e's/\-\*\-\*$/\-iso8859\-1/g' |\<BR>
sed -e's/\-Clean\-/\-Fixed\-/g' |\<BR>
sed -e's/clean/fixed/g' &gt;pgaccess.iso<BR>
mv pgaccess.iso pgaccess.tcl<BR>
chmod +x pgaccess.tcl</TT></P>
<P>The final version of PgAccess (1.0) will let the user decide what fonts
will be used through a &quot;preferences&quot; dialog window.</P>
</BODY>
</HTML>

11
src/bin/pgaccess/doc/html/todo.html Normal file
View File

@@ -0,0 +1,11 @@
<html>
<body bgcolor="#FEFEDF">
<h2>ToDo List</h2><hr>
- Finish the report generator module<br>
- Enhance the form designer<br>
- Enhance the scripts module<br>
- Translations in other languages<br>
<br>
Please send any suggestions by mail to <a href="mailto:teo@flex.ro">Constantin Teodorescu</a>.
</body>
</html>

BIN
src/bin/pgaccess/doc/html/vdesigner.gif Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 16 KiB

50
src/bin/pgaccess/doc/html/whatsnew.html Normal file
View File

@@ -0,0 +1,50 @@
<!doctype html public "-//w3c//dtd html 4.0 transitional//en">
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
<meta name="GENERATOR" content="Mozilla/4.61 [en] (X11; I; Linux 2.2.11 i586) [Netscape]">
</head>
<body bgcolor="#FEFEDF">
<b>29 August 1999</b> - PgAccess 0.98 has been released!
<ul>
<li>
international version (romanian, french, italian translations available)
in separate files (japanese translation now possible)</li>
<li>
context sensitive help, complete help for SQL commands</li>
<li>
geometry changes for many forms</li>
<li>
form designer enhancements (widget icons , new attribute window style,
form startup script)</li>
<li>
ability to inspect PostgreSQL system tables (preferences)</li>
<li>
enhanced table design window, table permissions</li>
<li>
distribution archive changes</li>
<li>
unified internal global variables</li>
<li>
unified internal window naming conventions</li>
<li>
usage of Tcl namespaces for all modules</li>
<li>
PgAccess developer <a href="api.html">API</a></li>
<li>
web site enhancements</li>
</ul>
</body>
</html>

45
src/bin/pgaccess/doc/html/win32.html Normal file
View File

@@ -0,0 +1,45 @@
<!doctype html public "-//w3c//dtd html 4.0 transitional//en">
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
<meta name="GENERATOR" content="Mozilla/4.61 [en] (X11; I; Linux 2.2.11 i586) [Netscape]">
</head>
<body bgcolor="#FEFEDF">
<h2>
PgAccess on Win32</h2>
<hr>In order to run PgAccess on a Win32 workstation you should follow the
following steps:
<ol>
<li>
download and install a Tcl/Tk package from <a href="http://www.scriptics.com">Scriptics</a>
(8.0.x or 8.1.x)</li>
<li>
install PgAccess package</li>
<li>
check the Tcl/Tk version that you have</li>
<li>
check the PostgreSQL version installed on your database server machine</li>
<li>
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</li>
<li>
check if your win32 workstation is able to see your database server (ping
yourdatabaseserver)</li>
<li>
ask your database administrator to verify if your win32 workstation has
access rights to the database (pg_hba.conf)</li>
</ol>
<p><br>You should be able to run PgAccess.
<br>&nbsp;
</body>
</html>

61
src/bin/pgaccess/lib/database.tcl Normal file
View File

@@ -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]
}
}

1263
src/bin/pgaccess/lib/forms.tcl Normal file
View File

File diff suppressed because it is too large Load Diff

181
src/bin/pgaccess/lib/functions.tcl Normal file
View File

@@ -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 <Key-F1> "Help::load functions"
frame $base.fp \
-height 88 -relief groove -width 125
label $base.fp.l1 \
-borderwidth 0 -relief raised -text [intlmsg Name]
entry $base.fp.e1 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(function,name)
bind $base.fp.e1 <Key-Return> {
focus .pgaw:Function.fp.e2
}
label $base.fp.l2 \
-borderwidth 0 -relief raised -text [intlmsg Parameters]
entry $base.fp.e2 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(function,parameters) -width 15
bind $base.fp.e2 <Key-Return> {
focus .pgaw:Function.fp.e3
}
label $base.fp.l3 \
-borderwidth 0 -relief raised -text [intlmsg Returns]
entry $base.fp.e3 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(function,returns)
bind $base.fp.e3 <Key-Return> {
focus .pgaw:Function.fp.e4
}
label $base.fp.l4 \
-borderwidth 0 -relief raised -text [intlmsg Language]
entry $base.fp.e4 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(function,language) -width 15
bind $base.fp.e4 <Key-Return> {
focus .pgaw:Function.fs.text1
}
label $base.fp.lspace \
-borderwidth 0 -relief raised -text { }
frame $base.fs \
-borderwidth 2 -height 75 -relief groove -width 125
text $base.fs.text1 \
-background #fefefe -foreground #000000 -borderwidth 1 -font $PgAcVar(pref,font_fix) -height 16 \
-tabs {20 40 60 80 100 120} -width 43 -yscrollcommand {.pgaw:Function.fs.vsb set}
scrollbar $base.fs.vsb \
-borderwidth 1 -command {.pgaw:Function.fs.text1 yview} -orient vert
frame $base.fb \
-borderwidth 2 -height 75 -width 125
frame $base.fb.fbc \
-borderwidth 2 -height 75 -width 125
button $base.fb.fbc.btnsave -command {Functions::save} \
-borderwidth 1 -padx 9 -pady 3 -text [intlmsg Save]
button $base.fb.fbc.btnhelp -command {Help::load functions} \
-borderwidth 1 -padx 9 -pady 3 -text [intlmsg Help]
button $base.fb.fbc.btncancel \
-borderwidth 1 -command {Window destroy .pgaw:Function} -padx 9 -pady 3 \
-text [intlmsg Cancel]
pack $base.fp \
-in .pgaw:Function -anchor center -expand 0 -fill x -side top
grid $base.fp.l1 \
-in .pgaw:Function.fp -column 0 -row 0 -columnspan 1 -rowspan 1 -sticky w
grid $base.fp.e1 \
-in .pgaw:Function.fp -column 1 -row 0 -columnspan 1 -rowspan 1
grid $base.fp.l2 \
-in .pgaw:Function.fp -column 3 -row 0 -columnspan 1 -rowspan 1 -sticky w
grid $base.fp.e2 \
-in .pgaw:Function.fp -column 4 -row 0 -columnspan 1 -rowspan 1 -pady 2
grid $base.fp.l3 \
-in .pgaw:Function.fp -column 0 -row 4 -columnspan 1 -rowspan 1 -sticky w
grid $base.fp.e3 \
-in .pgaw:Function.fp -column 1 -row 4 -columnspan 1 -rowspan 1
grid $base.fp.l4 \
-in .pgaw:Function.fp -column 3 -row 4 -columnspan 1 -rowspan 1 -sticky w
grid $base.fp.e4 \
-in .pgaw:Function.fp -column 4 -row 4 -columnspan 1 -rowspan 1 -pady 3
grid $base.fp.lspace \
-in .pgaw:Function.fp -column 2 -row 4 -columnspan 1 -rowspan 1
pack $base.fs \
-in .pgaw:Function -anchor center -expand 1 -fill both -side top
pack $base.fs.text1 \
-in .pgaw:Function.fs -anchor center -expand 1 -fill both -side left
pack $base.fs.vsb \
-in .pgaw:Function.fs -anchor center -expand 0 -fill y -side right
pack $base.fb \
-in .pgaw:Function -anchor center -expand 0 -fill x -side bottom
pack $base.fb.fbc \
-in .pgaw:Function.fb -anchor center -expand 0 -fill none -side top
pack $base.fb.fbc.btnsave \
-in .pgaw:Function.fb.fbc -anchor center -expand 0 -fill none -side left
pack $base.fb.fbc.btnhelp \
-in .pgaw:Function.fb.fbc -anchor center -expand 0 -fill none -side left
pack $base.fb.fbc.btncancel \
-in .pgaw:Function.fb.fbc -anchor center -expand 0 -fill none -side right
}

127
src/bin/pgaccess/lib/help.tcl Normal file
View File

@@ -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 <Button-1> {Help::findLink}
set errmsg {}
.pgaw:Help.f.t configure -tabs {30 60 90 120 150 180 210 240 270 300 330 360 390}
catch { source [file join $PgAcVar(PGACCESS_HOME) lib help $topic.hlp] } errmsg
if {$errmsg!=""} {
.pgaw:Help.f.t insert end "Error loading help file [file join $PgAcVar(PGACCESS_HOME) $topic.hlp]\n\n$errmsg" bold
}
.pgaw:Help.f.t configure -state disabled
focus .pgaw:Help.f.sb
}
proc {back} {} {
global PgAcVar
if {![info exists PgAcVar(help,history)]} {return}
if {[llength $PgAcVar(help,history)]==0} {return}
set i $PgAcVar(help,current_topic)
if {$i<1} {return}
incr i -1
load [lindex $PgAcVar(help,history) $i] $i
}
}
proc vTclWindow.pgaw:Help {base} {
global PgAcVar
if {$base == ""} {
set base .pgaw:Help
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
set sw [winfo screenwidth .]
set sh [winfo screenheight .]
set x [expr {($sw - 640)/2}]
set y [expr {($sh - 480)/2}]
wm geometry $base 640x480+$x+$y
wm maxsize $base 1009 738
wm minsize $base 1 1
wm overrideredirect $base 0
wm resizable $base 1 1
wm deiconify $base
wm title $base [intlmsg "Help"]
bind $base <Key-Escape> "Window destroy .pgaw:Help"
frame $base.fb \
-borderwidth 2 -height 75 -relief groove -width 125
button $base.fb.bback \
-command Help::back -padx 9 -pady 3 -text [intlmsg Back]
button $base.fb.bi \
-command {Help::load index} -padx 9 -pady 3 -text [intlmsg Index]
button $base.fb.bp \
-command {Help::load postgresql} -padx 9 -pady 3 -text PostgreSQL
button $base.fb.btnclose \
-command {Window destroy .pgaw:Help} -padx 9 -pady 3 -text [intlmsg Close]
frame $base.f \
-borderwidth 2 -height 75 -relief groove -width 125
text $base.f.t \
-borderwidth 1 -cursor {} -font $PgAcVar(pref,font_normal) -height 2 \
-highlightthickness 0 -state disabled \
-tabs {30 60 90 120 150 180 210 240 270 300 330 360 390} -width 8 \
-wrap word -yscrollcommand {.pgaw:Help.f.sb set}
scrollbar $base.f.sb \
-borderwidth 1 -command {.pgaw:Help.f.t yview} -highlightthickness 0 \
-orient vert
pack $base.fb \
-in .pgaw:Help -anchor center -expand 0 -fill x -side top
pack $base.fb.bback \
-in .pgaw:Help.fb -anchor center -expand 0 -fill none -side left
pack $base.fb.bi \
-in .pgaw:Help.fb -anchor center -expand 0 -fill none -side left
pack $base.fb.bp \
-in .pgaw:Help.fb -anchor center -expand 0 -fill none -side left
pack $base.fb.btnclose \
-in .pgaw:Help.fb -anchor center -expand 0 -fill none -side right
pack $base.f \
-in .pgaw:Help -anchor center -expand 1 -fill both -side top
pack $base.f.t \
-in .pgaw:Help.f -anchor center -expand 1 -fill both -side left
pack $base.f.sb \
-in .pgaw:Help.f -anchor center -expand 0 -fill y -side right
}

987
src/bin/pgaccess/lib/mainlib.tcl Normal file
View File

@@ -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 <Button-1> "Mainlib::tab_click $tab"
incr ypos 25
}
set PgAcVar(activetab) ""
}
proc {get_dwlb_Selection} {} {
set temp [.pgaw:Main.lb curselection]
if {$temp==""} return "";
return [.pgaw:Main.lb get $temp]
}
proc {sqlw_display} {msg} {
if {![winfo exists .pgaw:SQLWindow]} {return}
.pgaw:SQLWindow.f.t insert end "$msg\n\n"
.pgaw:SQLWindow.f.t see end
set nrlines [lindex [split [.pgaw:SQLWindow.f.t index end] .] 0]
if {$nrlines>50} {
.pgaw:SQLWindow.f.t delete 1.0 3.0
}
}
proc {open_database} {} {
global PgAcVar CurrentDB
setCursor CLOCK
if {$PgAcVar(opendb,username)!=""} {
if {$PgAcVar(opendb,host)!=""} {
set connres [catch {set newdbc [pg_connect -conninfo "host=$PgAcVar(opendb,host) port=$PgAcVar(opendb,pgport) dbname=$PgAcVar(opendb,dbname) user=$PgAcVar(opendb,username) password=$PgAcVar(opendb,password)"]} msg]
} else {
set connres [catch {set newdbc [pg_connect -conninfo "dbname=$PgAcVar(opendb,dbname) user=$PgAcVar(opendb,username) password=$PgAcVar(opendb,password)"]} msg]
}
} else {
set connres [catch {set newdbc [pg_connect $PgAcVar(opendb,dbname) -host $PgAcVar(opendb,host) -port $PgAcVar(opendb,pgport)]} msg]
}
if {$connres} {
setCursor DEFAULT
showError [format [intlmsg "Error trying to connect to database '%s' on host %s \n\nPostgreSQL error message:%s"] $PgAcVar(opendb,dbname) $PgAcVar(opendb,host) $msg"]
return $msg
} else {
catch {pg_disconnect $CurrentDB}
set CurrentDB $newdbc
set PgAcVar(currentdb,host) $PgAcVar(opendb,host)
set PgAcVar(currentdb,pgport) $PgAcVar(opendb,pgport)
set PgAcVar(currentdb,dbname) $PgAcVar(opendb,dbname)
set PgAcVar(currentdb,username) $PgAcVar(opendb,username)
set PgAcVar(currentdb,password) $PgAcVar(opendb,password)
set PgAcVar(statusline,dbname) $PgAcVar(currentdb,dbname)
set PgAcVar(pref,lastdb) $PgAcVar(currentdb,dbname)
set PgAcVar(pref,lasthost) $PgAcVar(currentdb,host)
set PgAcVar(pref,lastport) $PgAcVar(currentdb,pgport)
set PgAcVar(pref,lastusername) $PgAcVar(currentdb,username)
Preferences::save
catch {setCursor DEFAULT ; Window hide .pgaw:OpenDB}
tab_click Tables
# Check for pga_ tables
foreach {table structure} {pga_queries {queryname varchar(64),querytype char(1),querycommand text,querytables text,querylinks text,queryresults text,querycomments text} pga_forms {formname varchar(64),formsource text} pga_scripts {scriptname varchar(64),scriptsource text} pga_reports {reportname varchar(64),reportsource text,reportbody text,reportprocs text,reportoptions text} pga_schema {schemaname varchar(64),schematables text,schemalinks text}} {
set pgres [wpg_exec $CurrentDB "select relname from pg_class where relname='$table'"]
if {$PgAcVar(pgsql,status)!="PGRES_TUPLES_OK"} {
showError "[intlmsg {FATAL ERROR searching for PgAccess system tables}] : $PgAcVar(pgsql,errmsg)\nStatus:$PgAcVar(pgsql,status)"
catch {pg_disconnect $CurrentDB}
exit
} elseif {[pg_result $pgres -numTuples]==0} {
pg_result $pgres -clear
sql_exec quiet "create table $table ($structure)"
sql_exec quiet "grant ALL on $table to PUBLIC"
} else {
foreach fieldspec [split $structure ,] {
set field [lindex [split $fieldspec] 0]
set pgres [wpg_exec $CurrentDB "select \"$field\" from \"$table\""]
if {$PgAcVar(pgsql,status)!="PGRES_TUPLES_OK"} {
if {![regexp "attribute '$field' not found" $PgAcVar(pgsql,errmsg)]} {
showError "[intlmsg {FATAL ERROR upgrading PgAccess table}] $table: $PgAcVar(pgsql,errmsg)\nStatus:$PgAcVar(pgsql,status)"
catch {pg_disconnect $CurrentDB}
exit
} else {
pg_result $pgres -clear
sql_exec quiet "alter table \"$table\" add column $fieldspec "
}
}
}
}
catch {pg_result $pgres -clear}
}
# searching for autoexec script
wpg_select $CurrentDB "select * from pga_scripts where scriptname ~* '^autoexec$'" recd {
eval $recd(scriptsource)
}
return ""
}
}
proc {tab_click} {tabname} {
global PgAcVar CurrentDB
set w .pgaw:Main.tab$tabname
if {$CurrentDB==""} return;
set curtab $tabname
#if {$PgAcVar(activetab)==$curtab} return;
.pgaw:Main.btndesign configure -state disabled
if {$PgAcVar(activetab)!=""} {
place .pgaw:Main.tab$PgAcVar(activetab) -x 10
.pgaw:Main.tab$PgAcVar(activetab) configure -font $PgAcVar(pref,font_normal)
}
$w configure -font $PgAcVar(pref,font_bold)
place $w -x 7
place .pgaw:Main.lmask -x 80 -y [expr 86+25*[lsearch -exact $PgAcVar(tablist) $curtab]]
set PgAcVar(activetab) $curtab
# Tabs where button Design is enabled
if {[lsearch {Tables Schema Scripts Queries Functions Views Reports Forms Users} $PgAcVar(activetab)]!=-1} {
.pgaw:Main.btndesign configure -state normal
}
.pgaw:Main.lb delete 0 end
cmd_$curtab
}
}
proc vTclWindow.pgaw:Main {base} {
global PgAcVar
if {$base == ""} {
set base .pgaw:Main
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel \
-background #efefef -cursor left_ptr
wm focusmodel $base passive
wm geometry $base 332x390+96+172
wm maxsize $base 1009 738
wm minsize $base 1 1
wm overrideredirect $base 0
wm resizable $base 0 0
wm deiconify $base
wm title $base "PostgreSQL access"
bind $base <Key-F1> "Help::load index"
label $base.labframe \
-relief raised
listbox $base.lb \
-background #fefefe \
-selectbackground #c3c3c3 \
-foreground black -highlightthickness 0 -selectborderwidth 0 \
-yscrollcommand {.pgaw:Main.sb set}
bind $base.lb <Double-Button-1> {
Mainlib::cmd_Open
}
button $base.btnnew \
-borderwidth 1 -command Mainlib::cmd_New -text [intlmsg New]
button $base.btnopen \
-borderwidth 1 -command Mainlib::cmd_Open -text [intlmsg Open]
button $base.btndesign \
-borderwidth 1 -command Mainlib::cmd_Design -text [intlmsg Design]
label $base.lmask \
-borderwidth 0 \
-text { }
frame $base.fm \
-borderwidth 1 -height 75 -relief raised -width 125
menubutton $base.fm.mndb \
-borderwidth 1 -font $PgAcVar(pref,font_normal) \
-menu .pgaw:Main.fm.mndb.01 -padx 4 -pady 3 -text [intlmsg Database]
menu $base.fm.mndb.01 \
-borderwidth 1 -font $PgAcVar(pref,font_normal) \
-tearoff 0
$base.fm.mndb.01 add command \
-command {
Window show .pgaw:OpenDB
set PgAcVar(opendb,host) $PgAcVar(currentdb,host)
set PgAcVar(opendb,pgport) $PgAcVar(currentdb,pgport)
focus .pgaw:OpenDB.f1.e3
wm transient .pgaw:OpenDB .pgaw:Main
.pgaw:OpenDB.f1.e3 selection range 0 end} \
-label [intlmsg Open] -font $PgAcVar(pref,font_normal)
$base.fm.mndb.01 add command \
-command {.pgaw:Main.lb delete 0 end
set CurrentDB {}
set PgAcVar(currentdb,dbname) {}
set PgAcVar(statusline,dbname) {}} \
-label [intlmsg Close]
$base.fm.mndb.01 add command \
-command Database::vacuum -label [intlmsg Vacuum]
$base.fm.mndb.01 add separator
$base.fm.mndb.01 add command \
-command {Mainlib::cmd_Import_Export Import} -label [intlmsg {Import table}]
$base.fm.mndb.01 add command \
-command {Mainlib::cmd_Import_Export Export} -label [intlmsg {Export table}]
$base.fm.mndb.01 add separator
$base.fm.mndb.01 add command \
-command Preferences::configure -label [intlmsg Preferences]
$base.fm.mndb.01 add command \
-command "Window show .pgaw:SQLWindow" -label [intlmsg "SQL window"]
$base.fm.mndb.01 add separator
$base.fm.mndb.01 add command \
-command {
set PgAcVar(activetab) {}
Preferences::save
catch {pg_disconnect $CurrentDB}
exit} -label [intlmsg Exit]
label $base.lshost \
-relief groove -text localhost -textvariable PgAcVar(currentdb,host)
label $base.lsdbname \
-anchor w \
-relief groove -textvariable PgAcVar(statusline,dbname)
scrollbar $base.sb \
-borderwidth 1 -command {.pgaw:Main.lb yview} -orient vert
menubutton $base.fm.mnob \
-borderwidth 1 \
-menu .pgaw:Main.fm.mnob.m -font $PgAcVar(pref,font_normal) -text [intlmsg Object]
menu $base.fm.mnob.m \
-borderwidth 1 -font $PgAcVar(pref,font_normal) \
-tearoff 0
$base.fm.mnob.m add command \
-command Mainlib::cmd_New -font $PgAcVar(pref,font_normal) -label [intlmsg New]
$base.fm.mnob.m add command \
-command Mainlib::cmd_Delete -label [intlmsg Delete]
$base.fm.mnob.m add command \
-command Mainlib::cmd_Rename -label [intlmsg Rename]
menubutton $base.fm.mnhelp \
-borderwidth 1 \
-menu .pgaw:Main.fm.mnhelp.m -font $PgAcVar(pref,font_normal) -text [intlmsg Help]
menu $base.fm.mnhelp.m \
-borderwidth 1 -font $PgAcVar(pref,font_normal) \
-tearoff 0
$base.fm.mnhelp.m add command \
-label [intlmsg Contents] -command {Help::load index}
$base.fm.mnhelp.m add command \
-label PostgreSQL -command {Help::load postgresql}
$base.fm.mnhelp.m add separator
$base.fm.mnhelp.m add command \
-command {Window show .pgaw:About} -label [intlmsg About]
place $base.labframe \
-x 80 -y 30 -width 246 -height 325 -anchor nw -bordermode ignore
place $base.lb \
-x 90 -y 75 -width 210 -height 272 -anchor nw -bordermode ignore
place $base.btnnew \
-x 89 -y 40 -width 75 -height 25 -anchor nw -bordermode ignore
place $base.btnopen \
-x 166 -y 40 -width 75 -height 25 -anchor nw -bordermode ignore
place $base.btndesign \
-x 243 -y 40 -width 76 -height 25 -anchor nw -bordermode ignore
place $base.lmask \
-x 1550 -y 4500 -width 10 -height 23 -anchor nw -bordermode ignore
place $base.lshost \
-x 3 -y 370 -width 91 -height 20 -anchor nw -bordermode ignore
place $base.lsdbname \
-x 95 -y 370 -width 233 -height 20 -anchor nw -bordermode ignore
place $base.sb \
-x 301 -y 74 -width 18 -height 274 -anchor nw -bordermode ignore
place $base.fm \
-x 1 -y 0 -width 331 -height 25 -anchor nw -bordermode ignore
pack $base.fm.mndb \
-in .pgaw:Main.fm -anchor center -expand 0 -fill none -side left
pack $base.fm.mnob \
-in .pgaw:Main.fm -anchor center -expand 0 -fill none -side left
pack $base.fm.mnhelp \
-in .pgaw:Main.fm -anchor center -expand 0 -fill none -side right
}
proc vTclWindow.pgaw:ImportExport {base} {
if {$base == ""} {
set base .pgaw:ImportExport
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
wm geometry $base 287x151+259+304
wm maxsize $base 1009 738
wm minsize $base 1 1
wm overrideredirect $base 0
wm resizable $base 0 0
wm title $base [intlmsg "Import-Export table"]
label $base.l1 -borderwidth 0 -text [intlmsg {Table name}]
entry $base.e1 -background #fefefe -borderwidth 1 -textvariable PgAcVar(impexp,tablename)
label $base.l2 -borderwidth 0 -text [intlmsg {File name}]
entry $base.e2 -background #fefefe -borderwidth 1 -textvariable PgAcVar(impexp,filename)
label $base.l3 -borderwidth 0 -text [intlmsg {Field delimiter}]
entry $base.e3 -background #fefefe -borderwidth 1 -textvariable PgAcVar(impexp,delimiter)
button $base.expbtn -borderwidth 1 -command {if {$PgAcVar(impexp,tablename)==""} {
showError [intlmsg "You have to supply a table name!"]
} elseif {$PgAcVar(impexp,filename)==""} {
showError [intlmsg "You have to supply a external file name!"]
} else {
if {$PgAcVar(impexp,delimiter)==""} {
set sup ""
} else {
set sup " USING DELIMITERS '$PgAcVar(impexp,delimiter)'"
}
if {[.pgaw:ImportExport.expbtn cget -text]=="Import"} {
set oper "FROM"
} else {
set oper "TO"
}
if {$PgAcVar(impexp,withoids)} {
set sup2 " WITH OIDS "
} else {
set sup2 ""
}
set sqlcmd "COPY \"$PgAcVar(impexp,tablename)\" $sup2 $oper '$PgAcVar(impexp,filename)'$sup"
setCursor CLOCK
if {[sql_exec noquiet $sqlcmd]} {
tk_messageBox -title [intlmsg Information] -parent .pgaw:ImportExport -message [intlmsg "Operation completed!"]
Window destroy .pgaw:ImportExport
}
setCursor DEFAULT
}} -text Export
button $base.cancelbtn -borderwidth 1 -command {Window destroy .pgaw:ImportExport} -text [intlmsg Cancel]
checkbutton $base.oicb -borderwidth 1 -text [intlmsg {with OIDs}] -variable PgAcVar(impexp,withoids)
place $base.l1 -x 15 -y 15 -anchor nw -bordermode ignore
place $base.e1 -x 115 -y 10 -height 22 -anchor nw -bordermode ignore
place $base.l2 -x 15 -y 45 -anchor nw -bordermode ignore
place $base.e2 -x 115 -y 40 -height 22 -anchor nw -bordermode ignore
place $base.l3 -x 15 -y 75 -height 18 -anchor nw -bordermode ignore
place $base.e3 -x 115 -y 74 -width 33 -height 22 -anchor nw -bordermode ignore
place $base.expbtn -x 60 -y 110 -height 25 -width 75 -anchor nw -bordermode ignore
place $base.cancelbtn -x 155 -y 110 -height 25 -width 75 -anchor nw -bordermode ignore
place $base.oicb -x 170 -y 75 -anchor nw -bordermode ignore
}
proc vTclWindow.pgaw:RenameObject {base} {
if {$base == ""} {
set base .pgaw:RenameObject
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
wm geometry $base 272x105+294+262
wm maxsize $base 1009 738
wm minsize $base 1 1
wm overrideredirect $base 0
wm resizable $base 0 0
wm title $base [intlmsg "Rename"]
label $base.l1 -borderwidth 0 -text [intlmsg {New name}]
entry $base.e1 -background #fefefe -borderwidth 1 -textvariable PgAcVar(New_Object_Name)
button $base.b1 -borderwidth 1 -command {
if {$PgAcVar(New_Object_Name)==""} {
showError [intlmsg "You must give object a new name!"]
} elseif {$PgAcVar(activetab)=="Tables"} {
set retval [sql_exec noquiet "alter table \"$PgAcVar(Old_Object_Name)\" rename to \"$PgAcVar(New_Object_Name)\""]
if {$retval} {
sql_exec quiet "update pga_layout set tablename='$PgAcVar(New_Object_Name)' where tablename='$PgAcVar(Old_Object_Name)'"
Mainlib::cmd_Tables
Window destroy .pgaw:RenameObject
}
} elseif {$PgAcVar(activetab)=="Queries"} {
set pgres [wpg_exec $CurrentDB "select * from pga_queries where queryname='$PgAcVar(New_Object_Name)'"]
if {$PgAcVar(pgsql,status)!="PGRES_TUPLES_OK"} {
showError "[intlmsg {Error retrieving from}] pga_queries\n$PgAcVar(pgsql,errmsg)\n$PgAcVar(pgsql,status)"
} elseif {[pg_result $pgres -numTuples]>0} {
showError [format [intlmsg "Query '%s' already exists!"] $PgAcVar(New_Object_Name)]
} else {
sql_exec noquiet "update pga_queries set queryname='$PgAcVar(New_Object_Name)' where queryname='$PgAcVar(Old_Object_Name)'"
sql_exec noquiet "update pga_layout set tablename='$PgAcVar(New_Object_Name)' where tablename='$PgAcVar(Old_Object_Name)'"
Mainlib::cmd_Queries
Window destroy .pgaw:RenameObject
}
catch {pg_result $pgres -clear}
} elseif {$PgAcVar(activetab)=="Forms"} {
set pgres [wpg_exec $CurrentDB "select * from pga_forms where formname='$PgAcVar(New_Object_Name)'"]
if {$PgAcVar(pgsql,status)!="PGRES_TUPLES_OK"} {
showError "[intlmsg {Error retrieving from}] pga_forms\n$PgAcVar(pgsql,errmsg)\n$PgAcVar(pgsql,status)"
} elseif {[pg_result $pgres -numTuples]>0} {
showError [format [intlmsg "Form '%s' already exists!"] $PgAcVar(New_Object_Name)]
} else {
sql_exec noquiet "update pga_forms set formname='$PgAcVar(New_Object_Name)' where formname='$PgAcVar(Old_Object_Name)'"
Mainlib::cmd_Forms
Window destroy .pgaw:RenameObject
}
catch {pg_result $pgres -clear}
} elseif {$PgAcVar(activetab)=="Scripts"} {
set pgres [wpg_exec $CurrentDB "select * from pga_scripts where scriptname='$PgAcVar(New_Object_Name)'"]
if {$PgAcVar(pgsql,status)!="PGRES_TUPLES_OK"} {
showError "[intlmsg {Error retrieving from}] pga_scripts\n$PgAcVar(pgsql,errmsg)\n$PgAcVar(pgsql,status)"
} elseif {[pg_result $pgres -numTuples]>0} {
showError [format [intlmsg "Script '%s' already exists!"] $PgAcVar(New_Object_Name)]
} else {
sql_exec noquiet "update pga_scripts set scriptname='$PgAcVar(New_Object_Name)' where scriptname='$PgAcVar(Old_Object_Name)'"
Mainlib::cmd_Scripts
Window destroy .pgaw:RenameObject
}
catch {pg_result $pgres -clear}
} elseif {$PgAcVar(activetab)=="Schema"} {
set pgres [wpg_exec $CurrentDB "select * from pga_schema where schemaname='$PgAcVar(New_Object_Name)'"]
if {$PgAcVar(pgsql,status)!="PGRES_TUPLES_OK"} {
showError "[intlmsg {Error retrieving from}] pga_schema\n$PgAcVar(pgsql,errmsg)\n$PgAcVar(pgsql,status)"
} elseif {[pg_result $pgres -numTuples]>0} {
showError [format [intlmsg "Schema '%s' already exists!"] $PgAcVar(New_Object_Name)]
} else {
sql_exec noquiet "update pga_schema set schemaname='$PgAcVar(New_Object_Name)' where schemaname='$PgAcVar(Old_Object_Name)'"
Mainlib::cmd_Schema
Window destroy .pgaw:RenameObject
}
catch {pg_result $pgres -clear}
}
} -text [intlmsg Rename]
button $base.b2 -borderwidth 1 -command {Window destroy .pgaw:RenameObject} -text [intlmsg Cancel]
place $base.l1 -x 15 -y 28 -anchor nw -bordermode ignore
place $base.e1 -x 100 -y 25 -anchor nw -bordermode ignore
place $base.b1 -x 55 -y 65 -width 80 -anchor nw -bordermode ignore
place $base.b2 -x 155 -y 65 -width 80 -anchor nw -bordermode ignore
}
proc vTclWindow.pgaw:GetParameter {base} {
if {$base == ""} {
set base .pgaw:GetParameter
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
set sw [winfo screenwidth .]
set sh [winfo screenheight .]
set x [expr ($sw - 297)/2]
set y [expr ($sh - 98)/2]
wm geometry $base 297x98+$x+$y
wm maxsize $base 1009 738
wm minsize $base 1 1
wm overrideredirect $base 0
wm resizable $base 0 0
wm deiconify $base
wm title $base [intlmsg "Input parameter"]
label $base.l1 \
-anchor nw -borderwidth 1 \
-justify left -relief sunken -textvariable PgAcVar(getqueryparam,msg) -wraplength 200
entry $base.e1 \
-background #fefefe -borderwidth 1 -highlightthickness 0 \
-textvariable PgAcVar(getqueryparam,var)
bind $base.e1 <Key-KP_Enter> {
set PgAcVar(getqueryparam,result) 1
destroy .pgaw:GetParameter
}
bind $base.e1 <Key-Return> {
set PgAcVar(getqueryparam,result) 1
destroy .pgaw:GetParameter
}
button $base.bok \
-borderwidth 1 -command {set PgAcVar(getqueryparam,result) 1
destroy .pgaw:GetParameter} -text Ok
button $base.bcanc \
-borderwidth 1 -command {set PgAcVar(getqueryparam,result) 0
destroy .pgaw:GetParameter} -text [intlmsg Cancel]
place $base.l1 \
-x 10 -y 5 -width 201 -height 53 -anchor nw -bordermode ignore
place $base.e1 \
-x 10 -y 65 -width 200 -height 24 -anchor nw -bordermode ignore
place $base.bok \
-x 225 -y 5 -width 61 -height 26 -anchor nw -bordermode ignore
place $base.bcanc \
-x 225 -y 35 -width 61 -height 26 -anchor nw -bordermode ignore
}
proc vTclWindow.pgaw:SQLWindow {base} {
if {$base == ""} {
set base .pgaw:SQLWindow
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
wm geometry $base 551x408+192+169
wm maxsize $base 1009 738
wm minsize $base 1 1
wm overrideredirect $base 0
wm resizable $base 1 1
wm deiconify $base
wm title $base [intlmsg "SQL window"]
frame $base.f \
-borderwidth 1 -height 392 -relief raised -width 396
scrollbar $base.f.01 \
-borderwidth 1 -command {.pgaw:SQLWindow.f.t xview} -orient horiz \
-width 10
scrollbar $base.f.02 \
-borderwidth 1 -command {.pgaw:SQLWindow.f.t yview} -orient vert -width 10
text $base.f.t \
-borderwidth 1 \
-height 200 -width 200 -wrap word \
-xscrollcommand {.pgaw:SQLWindow.f.01 set} \
-yscrollcommand {.pgaw:SQLWindow.f.02 set}
button $base.b1 \
-borderwidth 1 -command {.pgaw:SQLWindow.f.t delete 1.0 end} -text [intlmsg Clean]
button $base.b2 \
-borderwidth 1 -command {destroy .pgaw:SQLWindow} -text [intlmsg Close]
grid columnconf $base 0 -weight 1
grid columnconf $base 1 -weight 1
grid rowconf $base 0 -weight 1
grid $base.f \
-in .pgaw:SQLWindow -column 0 -row 0 -columnspan 2 -rowspan 1
grid columnconf $base.f 0 -weight 1
grid rowconf $base.f 0 -weight 1
grid $base.f.01 \
-in .pgaw:SQLWindow.f -column 0 -row 1 -columnspan 1 -rowspan 1 -sticky ew
grid $base.f.02 \
-in .pgaw:SQLWindow.f -column 1 -row 0 -columnspan 1 -rowspan 1 -sticky ns
grid $base.f.t \
-in .pgaw:SQLWindow.f -column 0 -row 0 -columnspan 1 -rowspan 1 \
-sticky nesw
grid $base.b1 \
-in .pgaw:SQLWindow -column 0 -row 1 -columnspan 1 -rowspan 1
grid $base.b2 \
-in .pgaw:SQLWindow -column 1 -row 1 -columnspan 1 -rowspan 1
}
proc vTclWindow.pgaw:About {base} {
if {$base == ""} {
set base .pgaw:About
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
wm geometry $base 471x177+168+243
wm maxsize $base 1009 738
wm minsize $base 1 1
wm overrideredirect $base 0
wm resizable $base 1 1
wm title $base [intlmsg "About"]
label $base.l1 -borderwidth 3 -font -Adobe-Helvetica-Bold-R-Normal-*-*-180-*-*-*-*-* -relief ridge -text PgAccess
label $base.l2 -relief groove -text [intlmsg "A Tcl/Tk interface to\nPostgreSQL\nby Constantin Teodorescu"]
label $base.l3 -borderwidth 0 -relief sunken -text {v 0.98}
label $base.l4 -relief groove -text "[intlmsg {You will always get the latest version at:}]
http://www.flex.ro/pgaccess
[intlmsg {Suggestions at}] : teo@flex.ro"
button $base.b1 -borderwidth 1 -command {Window destroy .pgaw:About} -text Ok
place $base.l1 -x 10 -y 10 -width 196 -height 103 -anchor nw -bordermode ignore
place $base.l2 -x 10 -y 115 -width 198 -height 55 -anchor nw -bordermode ignore
place $base.l3 -x 145 -y 80 -anchor nw -bordermode ignore
place $base.l4 -x 215 -y 10 -width 246 -height 103 -anchor nw -bordermode ignore
place $base.b1 -x 295 -y 130 -width 105 -height 28 -anchor nw -bordermode ignore
}
proc vTclWindow.pgaw:OpenDB {base} {
if {$base == ""} {
set base .pgaw:OpenDB
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
wm geometry $base 283x172+119+210
wm maxsize $base 1009 738
wm minsize $base 1 1
wm overrideredirect $base 0
wm resizable $base 0 0
wm deiconify $base
wm title $base [intlmsg "Open database"]
frame $base.f1 \
-borderwidth 2 -height 75 -width 125
label $base.f1.l1 \
-borderwidth 0 -relief raised -text [intlmsg Host]
entry $base.f1.e1 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(opendb,host) -width 200
bind $base.f1.e1 <Key-KP_Enter> {
focus .pgaw:OpenDB.f1.e2
}
bind $base.f1.e1 <Key-Return> {
focus .pgaw:OpenDB.f1.e2
}
label $base.f1.l2 \
-borderwidth 0 -relief raised -text [intlmsg Port]
entry $base.f1.e2 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(opendb,pgport) -width 200
bind $base.f1.e2 <Key-Return> {
focus .pgaw:OpenDB.f1.e3
}
label $base.f1.l3 \
-borderwidth 0 -relief raised -text [intlmsg Database]
entry $base.f1.e3 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(opendb,dbname) -width 200
bind $base.f1.e3 <Key-Return> {
focus .pgaw:OpenDB.f1.e4
}
label $base.f1.l4 \
-borderwidth 0 -relief raised -text [intlmsg Username]
entry $base.f1.e4 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(opendb,username) \
-width 200
bind $base.f1.e4 <Key-Return> {
focus .pgaw:OpenDB.f1.e5
}
label $base.f1.ls2 \
-borderwidth 0 -relief raised -text { }
label $base.f1.l5 \
-borderwidth 0 -relief raised -text [intlmsg Password]
entry $base.f1.e5 \
-background #fefefe -borderwidth 1 -show x -textvariable PgAcVar(opendb,password) \
-width 200
bind $base.f1.e5 <Key-Return> {
focus .pgaw:OpenDB.fb.btnopen
}
frame $base.fb \
-height 75 -relief groove -width 125
button $base.fb.btnopen \
-borderwidth 1 -command Mainlib::open_database -padx 9 \
-pady 3 -text [intlmsg Open]
button $base.fb.btncancel \
-borderwidth 1 -command {Window hide .pgaw:OpenDB} \
-padx 9 -pady 3 -text [intlmsg Cancel]
place $base.f1 \
-x 9 -y 5 -width 265 -height 126 -anchor nw -bordermode ignore
grid columnconf $base.f1 2 -weight 1
grid $base.f1.l1 \
-in .pgaw:OpenDB.f1 -column 0 -row 0 -columnspan 1 -rowspan 1 -sticky w
grid $base.f1.e1 \
-in .pgaw:OpenDB.f1 -column 2 -row 0 -columnspan 1 -rowspan 1 -pady 2
grid $base.f1.l2 \
-in .pgaw:OpenDB.f1 -column 0 -row 2 -columnspan 1 -rowspan 1 -sticky w
grid $base.f1.e2 \
-in .pgaw:OpenDB.f1 -column 2 -row 2 -columnspan 1 -rowspan 1 -pady 2
grid $base.f1.l3 \
-in .pgaw:OpenDB.f1 -column 0 -row 4 -columnspan 1 -rowspan 1 -sticky w
grid $base.f1.e3 \
-in .pgaw:OpenDB.f1 -column 2 -row 4 -columnspan 1 -rowspan 1 -pady 2
grid $base.f1.l4 \
-in .pgaw:OpenDB.f1 -column 0 -row 6 -columnspan 1 -rowspan 1 -sticky w
grid $base.f1.e4 \
-in .pgaw:OpenDB.f1 -column 2 -row 6 -columnspan 1 -rowspan 1 -pady 2
grid $base.f1.ls2 \
-in .pgaw:OpenDB.f1 -column 1 -row 0 -columnspan 1 -rowspan 1
grid $base.f1.l5 \
-in .pgaw:OpenDB.f1 -column 0 -row 7 -columnspan 1 -rowspan 1 -sticky w
grid $base.f1.e5 \
-in .pgaw:OpenDB.f1 -column 2 -row 7 -columnspan 1 -rowspan 1 -pady 2
place $base.fb \
-x 0 -y 135 -width 283 -height 40 -anchor nw -bordermode ignore
grid $base.fb.btnopen \
-in .pgaw:OpenDB.fb -column 0 -row 0 -columnspan 1 -rowspan 1 -padx 5
grid $base.fb.btncancel \
-in .pgaw:OpenDB.fb -column 1 -row 0 -columnspan 1 -rowspan 1 -padx 5
}

273
src/bin/pgaccess/lib/preferences.tcl Normal file
View File

@@ -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 <Key-Escape> "Window destroy .pgaw:Preferences"
frame $base.fl \
-height 75 -relief groove -width 10
frame $base.fr \
-height 75 -relief groove -width 10
frame $base.f1 \
-height 80 -relief groove -width 125
label $base.f1.l1 \
-borderwidth 0 -relief raised \
-text [intlmsg {Max rows displayed in table/query view}]
entry $base.f1.erows \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(pref,rows) -width 7
frame $base.f2 \
-height 75 -relief groove -width 125
label $base.f2.l \
-borderwidth 0 -relief raised -text [intlmsg {Table viewer font}]
label $base.f2.ls \
-borderwidth 0 -relief raised -text { }
radiobutton $base.f2.pgaw:rb1 \
-borderwidth 1 -text [intlmsg {fixed width}] -value clean \
-variable PgAcVar(pref,tvfont)
radiobutton $base.f2.pgaw:rb2 \
-borderwidth 1 -text [intlmsg proportional] -value helv -variable PgAcVar(pref,tvfont)
frame $base.ff \
-height 75 -relief groove -width 125
label $base.ff.l1 \
-borderwidth 0 -relief raised -text [intlmsg {Font normal}]
entry $base.ff.e1 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(pref,font_normal) \
-width 200
label $base.ff.l2 \
-borderwidth 0 -relief raised -text [intlmsg {Font bold}]
entry $base.ff.e2 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(pref,font_bold) \
-width 200
label $base.ff.l3 \
-borderwidth 0 -relief raised -text [intlmsg {Font italic}]
entry $base.ff.e3 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(pref,font_italic) \
-width 200
label $base.ff.l4 \
-borderwidth 0 -relief raised -text [intlmsg {Font fixed}]
entry $base.ff.e4 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(pref,font_fix) \
-width 200
frame $base.fls \
-borderwidth 1 -height 2 -relief sunken -width 125
frame $base.fal \
-height 75 -relief groove -width 125
checkbutton $base.fal.al \
-borderwidth 1 -text [intlmsg {Auto-load the last opened database at startup}] \
-variable PgAcVar(pref,autoload) -anchor w
checkbutton $base.fal.st \
-borderwidth 1 -text [intlmsg {View system tables}] \
-variable PgAcVar(pref,systemtables) -anchor w
frame $base.fpl \
-height 49 -relief groove -width 125
label $base.fpl.lt \
-borderwidth 0 -relief raised -text [intlmsg {Preferred language}]
frame $base.fpl.flb \
-height 75 -relief sunken -width 125
listbox $base.fpl.flb.llb \
-borderwidth 1 -height 6 -yscrollcommand {.pgaw:Preferences.fpl.flb.vsb set}
scrollbar $base.fpl.flb.vsb \
-borderwidth 1 -command {.pgaw:Preferences.fpl.flb.llb yview} -orient vert
frame $base.fb \
-height 75 -relief groove -width 125
button $base.fb.btnsave \
-command {if {$PgAcVar(pref,rows)>200} {
tk_messageBox -title [intlmsg Warning] -parent .pgaw:Preferences -message [intlmsg "A big number of rows displayed in table view will take a lot of memory!"]
}
Preferences::changeLanguage
Preferences::save
Window destroy .pgaw:Preferences
tk_messageBox -title [intlmsg Warning] -parent .pgaw:Main -message [intlmsg "Changed fonts may appear in the next working session!"]} \
-padx 9 -pady 3 -text [intlmsg Save]
button $base.fb.btncancel \
-command {Window destroy .pgaw:Preferences} -padx 9 -pady 3 -text [intlmsg Cancel]
pack $base.fl \
-in .pgaw:Preferences -anchor center -expand 0 -fill y -side left
pack $base.fr \
-in .pgaw:Preferences -anchor center -expand 0 -fill y -side right
pack $base.f1 \
-in .pgaw:Preferences -anchor center -expand 0 -fill x -pady 5 -side top
pack $base.f1.l1 \
-in .pgaw:Preferences.f1 -anchor center -expand 0 -fill none -side left
pack $base.f1.erows \
-in .pgaw:Preferences.f1 -anchor center -expand 0 -fill none -side left
pack $base.f2 \
-in .pgaw:Preferences -anchor center -expand 0 -fill x -pady 5 -side top
pack $base.f2.l \
-in .pgaw:Preferences.f2 -anchor center -expand 0 -fill none -side left
pack $base.f2.ls \
-in .pgaw:Preferences.f2 -anchor center -expand 0 -fill none -side left
pack $base.f2.pgaw:rb1 \
-in .pgaw:Preferences.f2 -anchor center -expand 0 -fill none -side left
pack $base.f2.pgaw:rb2 \
-in .pgaw:Preferences.f2 -anchor center -expand 0 -fill none -side left
pack $base.ff \
-in .pgaw:Preferences -anchor center -expand 0 -fill x -side top
grid columnconf $base.ff 1 -weight 1
grid $base.ff.l1 \
-in .pgaw:Preferences.ff -column 0 -row 0 -columnspan 1 -rowspan 1 -sticky w
grid $base.ff.e1 \
-in .pgaw:Preferences.ff -column 1 -row 0 -columnspan 1 -rowspan 1 -pady 1
grid $base.ff.l2 \
-in .pgaw:Preferences.ff -column 0 -row 2 -columnspan 1 -rowspan 1 -sticky w
grid $base.ff.e2 \
-in .pgaw:Preferences.ff -column 1 -row 2 -columnspan 1 -rowspan 1 -pady 1
grid $base.ff.l3 \
-in .pgaw:Preferences.ff -column 0 -row 4 -columnspan 1 -rowspan 1 -sticky w
grid $base.ff.e3 \
-in .pgaw:Preferences.ff -column 1 -row 4 -columnspan 1 -rowspan 1 -pady 1
grid $base.ff.l4 \
-in .pgaw:Preferences.ff -column 0 -row 6 -columnspan 1 -rowspan 1 -sticky w
grid $base.ff.e4 \
-in .pgaw:Preferences.ff -column 1 -row 6 -columnspan 1 -rowspan 1 -pady 1
pack $base.fls \
-in .pgaw:Preferences -anchor center -expand 0 -fill x -pady 5 -side top
pack $base.fal \
-in .pgaw:Preferences -anchor center -expand 0 -fill x -side top
pack $base.fal.al \
-in .pgaw:Preferences.fal -anchor center -expand 0 -fill x -side top -anchor w
pack $base.fal.st \
-in .pgaw:Preferences.fal -anchor center -expand 0 -fill x -side top -anchor w
pack $base.fpl \
-in .pgaw:Preferences -anchor center -expand 0 -fill x -side top
pack $base.fpl.lt \
-in .pgaw:Preferences.fpl -anchor center -expand 0 -fill none -side top
pack $base.fpl.flb \
-in .pgaw:Preferences.fpl -anchor center -expand 0 -fill none -side top
pack $base.fpl.flb.llb \
-in .pgaw:Preferences.fpl.flb -anchor center -expand 0 -fill none -side left
pack $base.fpl.flb.vsb \
-in .pgaw:Preferences.fpl.flb -anchor center -expand 0 -fill y -side right
pack $base.fb \
-in .pgaw:Preferences -anchor center -expand 0 -fill none -side bottom
grid $base.fb.btnsave \
-in .pgaw:Preferences.fb -column 0 -row 0 -columnspan 1 -rowspan 1
grid $base.fb.btncancel \
-in .pgaw:Preferences.fb -column 1 -row 0 -columnspan 1 -rowspan 1
}

7
src/bin/pgaccess/lib/qed Executable file
View File

@@ -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

228
src/bin/pgaccess/lib/queries.tcl Normal file
View File

@@ -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 <Key-F1> "Help::load queries"
label $base.lqn -borderwidth 0 -text [intlmsg {Query name}]
entry $base.eqn -background #fefefe -borderwidth 1 -foreground #000000 -highlightthickness 1 -selectborderwidth 0 -textvariable PgAcVar(query,name)
text $base.text1 -background #fefefe -borderwidth 1 -font $PgAcVar(pref,font_normal) -foreground #000000 -highlightthickness 1 -wrap word
label $base.lcomm -borderwidth 0 -text [intlmsg Comments]
text $base.text2 -background #fefefe -borderwidth 1 -font $PgAcVar(pref,font_normal) -foreground #000000 -highlightthickness 1 -wrap word
checkbutton $base.saveAsView -borderwidth 1 -text [intlmsg {Save this query as a view}] -variable PgAcVar(query,asview)
frame $base.frb \
-height 75 -relief groove -width 125
button $base.frb.savebtn -command {Queries::save} \
-borderwidth 1 -text [intlmsg {Save query definition}]
button $base.frb.execbtn -command {Queries::execute} \
-borderwidth 1 -text [intlmsg {Execute query}]
button $base.frb.pgaw:VisualQueryshow -command {Queries::visualDesigner} \
-borderwidth 1 -text [intlmsg {Visual designer}]
button $base.frb.termbtn -command {Queries::close} \
-borderwidth 1 -text [intlmsg Close]
place $base.lqn -x 5 -y 5 -anchor nw -bordermode ignore
place $base.eqn -x 100 -y 1 -width 335 -height 24 -anchor nw -bordermode ignore
place $base.frb \
-x 5 -y 55 -width 530 -height 35 -anchor nw -bordermode ignore
pack $base.frb.savebtn \
-in $base.frb -anchor center -expand 0 -fill none -side left
pack $base.frb.execbtn \
-in $base.frb -anchor center -expand 0 -fill none -side left
pack $base.frb.pgaw:VisualQueryshow \
-in $base.frb -anchor center -expand 0 -fill none -side left
pack $base.frb.termbtn \
-in $base.frb -anchor center -expand 0 -fill none -side right
place $base.text1 -x 5 -y 90 -width 530 -height 160 -anchor nw -bordermode ignore
place $base.lcomm -x 5 -y 255
place $base.text2 -x 5 -y 270 -width 530 -height 86 -anchor nw -bordermode ignore
place $base.saveAsView -x 5 -y 30 -height 25 -anchor nw -bordermode ignore
}

599
src/bin/pgaccess/lib/reports.tcl Normal file
View File

@@ -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 <ButtonRelease-1> {
Reports::addField
}
canvas $base.c \
-background #fffeff -borderwidth 2 -height 207 -highlightthickness 0 \
-relief ridge -takefocus 1 -width 295
bind $base.c <Button-1> {
Reports::dragStart %W %x %y
}
bind $base.c <ButtonRelease-1> {
Reports::dragStop %x %y
}
bind $base.c <Key-Delete> {
Reports::deleteObject
}
bind $base.c <Motion> {
Reports::dragMove %W %x %y
}
button $base.bt2 \
-command Reports::deleteAllObjects \
-text [intlmsg {Delete all}]
button $base.bt4 \
-command Reports::preview \
-text [intlmsg Preview]
button $base.bt5 \
-borderwidth 1 -command {Window destroy .pgaw:ReportBuilder} \
-text [intlmsg Close]
scrollbar $base.sb \
-borderwidth 1 -command {.pgaw:ReportBuilder.lb yview} -orient vert
label $base.lmsg \
-anchor w \
-relief groove -text [intlmsg {Report header}] -textvariable PgAcVar(report,msg)
entry $base.e2 \
-background #fefefe -borderwidth 1 -highlightthickness 0 \
-textvariable PgAcVar(report,tablename)
bind $base.e2 <Key-Return> {
Reports::getSourceFields
}
entry $base.elab \
-background #fefefe -borderwidth 1 -highlightthickness 0 \
-textvariable PgAcVar(report,labeltext)
button $base.badl \
-borderwidth 1 -command Reports::addLabel \
-text [intlmsg {Add label}]
label $base.lbold \
-borderwidth 1 -relief raised -text B
bind $base.lbold <Button-1> {
Reports::toggleBold
}
label $base.lita \
-borderwidth 1 \
-font $PgAcVar(pref,font_italic) \
-relief raised -text i
bind $base.lita <Button-1> {
Reports::toggleItalic
}
entry $base.eps \
-background #fefefe -highlightthickness 0 -relief groove \
-textvariable PgAcVar(report,pointsize)
bind $base.eps <Key-Return> {
Reports::setObjectFont
}
label $base.linfo \
-anchor w \
-relief groove -text {Database field} -textvariable PgAcVar(report,info)
label $base.llal \
-borderwidth 0 -text Align
button $base.balign \
-borderwidth 0 -command Reports::toggleAlignMode \
-relief groove -text right
button $base.savebtn \
-borderwidth 1 -command Reports::save \
-text [intlmsg Save]
label $base.lfn \
-borderwidth 0 -text Font
button $base.bfont \
-borderwidth 0 \
-command Reports::setFont \
-relief groove -text Courier
button $base.bdd \
-borderwidth 1 \
-command {if {[winfo exists .pgaw:ReportBuilder.ddf]} {
destroy .pgaw:ReportBuilder.ddf
} else {
create_drop_down .pgaw:ReportBuilder 405 22 200
focus .pgaw:ReportBuilder.ddf.sb
foreach tbl [Database::getTablesList] {.pgaw:ReportBuilder.ddf.lb insert end $tbl}
bind .pgaw:ReportBuilder.ddf.lb <ButtonRelease-1> {
set i [.pgaw:ReportBuilder.ddf.lb curselection]
if {$i!=""} {set PgAcVar(report,tablename) [.pgaw:ReportBuilder.ddf.lb get $i]}
destroy .pgaw:ReportBuilder.ddf
Reports::getSourceFields
break
}
}} \
-highlightthickness 0 -image dnarw
label $base.lrn \
-borderwidth 0 -text [intlmsg {Report name}]
entry $base.ern \
-background #fefefe -borderwidth 1 -highlightthickness 0 \
-textvariable PgAcVar(report,reportname)
bind $base.ern <Key-F5> {
loadReport
}
label $base.lrs \
-borderwidth 0 -text [intlmsg {Report source}]
label $base.ls \
-borderwidth 1 -relief raised
entry $base.ef \
-background #fefefe -borderwidth 1 -highlightthickness 0 \
-textvariable PgAcVar(report,formula)
button $base.baf \
-borderwidth 1 \
-text [intlmsg {Add formula}]
place $base.l1 \
-x 5 -y 55 -width 131 -height 18 -anchor nw -bordermode ignore
place $base.lb \
-x 5 -y 70 -width 118 -height 121 -anchor nw -bordermode ignore
place $base.c \
-x 140 -y 75 -width 508 -height 345 -anchor nw -bordermode ignore
place $base.bt2 \
-x 5 -y 365 -width 64 -height 26 -anchor nw -bordermode ignore
place $base.bt4 \
-x 70 -y 365 -width 66 -height 26 -anchor nw -bordermode ignore
place $base.bt5 \
-x 70 -y 395 -width 66 -height 26 -anchor nw -bordermode ignore
place $base.sb \
-x 120 -y 70 -width 18 -height 122 -anchor nw -bordermode ignore
place $base.lmsg \
-x 142 -y 55 -width 151 -height 18 -anchor nw -bordermode ignore
place $base.e2 \
-x 405 -y 4 -width 129 -height 18 -anchor nw -bordermode ignore
place $base.elab \
-x 5 -y 225 -width 130 -height 18 -anchor nw -bordermode ignore
place $base.badl \
-x 5 -y 243 -width 132 -height 26 -anchor nw -bordermode ignore
place $base.lbold \
-x 535 -y 55 -width 18 -height 18 -anchor nw -bordermode ignore
place $base.lita \
-x 555 -y 55 -width 18 -height 18 -anchor nw -bordermode ignore
place $base.eps \
-x 500 -y 55 -width 30 -height 18 -anchor nw -bordermode ignore
place $base.linfo \
-x 295 -y 55 -width 91 -height 18 -anchor nw -bordermode ignore
place $base.llal \
-x 575 -y 56 -anchor nw -bordermode ignore
place $base.balign \
-x 610 -y 54 -width 35 -height 21 -anchor nw -bordermode ignore
place $base.savebtn \
-x 5 -y 395 -width 64 -height 26 -anchor nw -bordermode ignore
place $base.lfn \
-x 405 -y 56 -anchor nw -bordermode ignore
place $base.bfont \
-x 435 -y 54 -width 65 -height 21 -anchor nw -bordermode ignore
place $base.bdd \
-x 535 -y 4 -width 15 -height 20 -anchor nw -bordermode ignore
place $base.lrn \
-x 5 -y 5 -anchor nw -bordermode ignore
place $base.ern \
-x 80 -y 4 -width 219 -height 18 -anchor nw -bordermode ignore
place $base.lrs \
-x 320 -y 5 -anchor nw -bordermode ignore
place $base.ls \
-x 5 -y 30 -width 641 -height 2 -anchor nw -bordermode ignore
place $base.ef \
-x 5 -y 280 -width 130 -height 18 -anchor nw -bordermode ignore
place $base.baf \
-x 5 -y 298 -width 132 -height 26 -anchor nw -bordermode ignore
}
proc vTclWindow.pgaw:ReportPreview {base} {
if {$base == ""} {
set base .pgaw:ReportPreview
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
wm geometry $base 495x500+230+50
wm maxsize $base 1009 738
wm minsize $base 1 1
wm overrideredirect $base 0
wm resizable $base 1 1
wm title $base "Report preview"
frame $base.fr \
-borderwidth 2 -height 75 -relief groove -width 125
canvas $base.fr.c \
-background #fcfefe -borderwidth 2 -height 207 -relief ridge \
-scrollregion {0 0 1000 824} -width 295 \
-yscrollcommand {.pgaw:ReportPreview.fr.sb set}
scrollbar $base.fr.sb \
-borderwidth 1 -command {.pgaw:ReportPreview.fr.c yview} -highlightthickness 0 \
-orient vert -width 12
frame $base.f1 \
-borderwidth 2 -height 75 -width 125
button $base.f1.button18 \
-borderwidth 1 -command {if {$PgAcVar(report,justpreview)} then {Window destroy .pgaw:ReportBuilder} ; Window destroy .pgaw:ReportPreview} \
-text [intlmsg Close]
button $base.f1.button17 \
-borderwidth 1 -command Reports::print \
-text Print
pack $base.fr \
-in .pgaw:ReportPreview -anchor center -expand 1 -fill both -side top
pack $base.fr.c \
-in .pgaw:ReportPreview.fr -anchor center -expand 1 -fill both -side left
pack $base.fr.sb \
-in .pgaw:ReportPreview.fr -anchor center -expand 0 -fill y -side right
pack $base.f1 \
-in .pgaw:ReportPreview -anchor center -expand 0 -fill none -side top
pack $base.f1.button18 \
-in .pgaw:ReportPreview.f1 -anchor center -expand 0 -fill none -side right
pack $base.f1.button17 \
-in .pgaw:ReportPreview.f1 -anchor center -expand 0 -fill none -side left
}

585
src/bin/pgaccess/lib/schema.tcl Normal file
View File

@@ -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 <Button-1> {Schema::dragStart %W %x %y}
.pgaw:Schema.c bind mov <B1-Motion> {Schema::dragMove %W %x %y}
bind .pgaw:Schema.c <ButtonRelease-1> {Schema::dragStop %x %y}
bind .pgaw:Schema <Button-1> {Schema::canvasClick %x %y %W}
bind .pgaw:Schema <B1-Motion> {Schema::canvasPanning %x %y}
bind .pgaw:Schema <Key-Delete> {Schema::deleteObject}
}
proc {drawTable} {it} {
global PgAcVar
if {$PgAcVar(schema,tablex$it)==0} {
set posy $PgAcVar(schema,nexty)
set posx $PgAcVar(schema,nextx)
set PgAcVar(schema,tablex$it) $posx
set PgAcVar(schema,tabley$it) $posy
} else {
set posx [expr int($PgAcVar(schema,tablex$it))]
set posy [expr int($PgAcVar(schema,tabley$it))]
}
set tablename $PgAcVar(schema,tablename$it)
.pgaw:Schema.c create text $posx $posy -text "$tablename" -anchor nw -tags [subst {tab$it f-oid mov tableheader}] -font $PgAcVar(pref,font_bold)
incr posy 16
foreach {fld ftype} $PgAcVar(schema,tablestruct$it) {
if {[set cindex [lsearch $PgAcVar(pref,typelist) $ftype]] == -1} {set cindex 1}
.pgaw:Schema.c create text $posx $posy -text $fld -fill [lindex $PgAcVar(pref,typecolors) $cindex] -anchor nw -tags [subst {f-$fld tab$it mov}] -font $PgAcVar(pref,font_normal)
incr posy 14
}
set reg [.pgaw:Schema.c bbox tab$it]
.pgaw:Schema.c create rectangle [lindex $reg 0] [lindex $reg 1] [lindex $reg 2] [lindex $reg 3] -fill #EEEEEE -tags [subst {rect outer tab$it}]
.pgaw:Schema.c create line [lindex $reg 0] [expr [lindex $reg 1]+15] [lindex $reg 2] [expr [lindex $reg 1]+15] -tags [subst {rect tab$it}]
.pgaw:Schema.c lower tab$it
.pgaw:Schema.c lower rect
set reg [.pgaw:Schema.c bbox tab$it]
set nexty [lindex $reg 1]
set nextx [expr 20+[lindex $reg 2]]
if {$nextx > [winfo width .pgaw:Schema.c] } {
set nextx 10
set allbox [.pgaw:Schema.c bbox rect]
set nexty [expr 20 + [lindex $allbox 3]]
}
set PgAcVar(schema,nextx) $nextx
set PgAcVar(schema,nexty) $nexty
}
proc {deleteObject} {} {
global PgAcVar
# Checking if there
set obj [.pgaw:Schema.c find withtag hili]
if {$obj==""} return
# Is object a link ?
if {[getTagInfo $obj link]=="s"} {
if {[tk_messageBox -title [intlmsg Warning] -icon question -parent .pgaw:Schema -message [intlmsg "Remove link ?"] -type yesno -default no]=="no"} return
set linkid [getTagInfo $obj lkid]
set PgAcVar(schema,links) [lreplace $PgAcVar(schema,links) $linkid $linkid]
.pgaw:Schema.c delete links
drawLinks
return
}
# Is object a table ?
set tablealias [getTagInfo $obj tab]
set tablename $PgAcVar(schema,tablename$tablealias)
if {"$tablename"==""} return
if {[tk_messageBox -title [intlmsg Warning] -icon question -parent .pgaw:Schema -message [format [intlmsg "Remove table %s from query?"] $tablename] -type yesno -default no]=="no"} return
for {set i [expr [llength $PgAcVar(schema,links)]-1]} {$i>=0} {incr i -1} {
set thelink [lindex $PgAcVar(schema,links) $i]
if {($tablealias==[lindex $thelink 0]) || ($tablealias==[lindex $thelink 2])} {
set PgAcVar(schema,links) [lreplace $PgAcVar(schema,links) $i $i]
}
}
for {set i 0} {$i<$PgAcVar(schema,ntables)} {incr i} {
set temp {}
catch {set temp $PgAcVar(schema,tablename$i)}
if {"$temp"=="$tablename"} {
unset PgAcVar(schema,tablename$i)
unset PgAcVar(schema,tablestruct$i)
break
}
}
#incr PgAcVar(schema,ntables) -1
.pgaw:Schema.c delete tab$tablealias
.pgaw:Schema.c delete links
drawLinks
}
proc {dragMove} {w x y} {
global PgAcVar
if {"$PgAcVar(draginfo,obj)" == ""} {return}
set dx [expr $x - $PgAcVar(draginfo,x)]
set dy [expr $y - $PgAcVar(draginfo,y)]
if {$PgAcVar(draginfo,is_a_table)} {
$w move $PgAcVar(draginfo,tabletag) $dx $dy
drawLinks
} else {
$w move $PgAcVar(draginfo,obj) $dx $dy
}
set PgAcVar(draginfo,x) $x
set PgAcVar(draginfo,y) $y
}
proc {dragStart} {w x y} {
global PgAcVar
PgAcVar:clean draginfo,*
set PgAcVar(draginfo,obj) [$w find closest $x $y]
if {[getTagInfo $PgAcVar(draginfo,obj) r]=="ect"} {
# If it'a a rectangle, exit
set PgAcVar(draginfo,obj) {}
return
}
.pgaw:Schema configure -cursor hand1
.pgaw:Schema.c raise $PgAcVar(draginfo,obj)
set PgAcVar(draginfo,table) 0
if {[getTagInfo $PgAcVar(draginfo,obj) table]=="header"} {
set PgAcVar(draginfo,is_a_table) 1
set taglist [.pgaw:Schema.c gettags $PgAcVar(draginfo,obj)]
set PgAcVar(draginfo,tabletag) [lindex $taglist [lsearch -regexp $taglist "^tab\[0-9\]*"]]
.pgaw:Schema.c raise $PgAcVar(draginfo,tabletag)
.pgaw:Schema.c itemconfigure [.pgaw:Schema.c find withtag hili] -fill black
.pgaw:Schema.c dtag [.pgaw:Schema.c find withtag hili] hili
.pgaw:Schema.c addtag hili withtag $PgAcVar(draginfo,obj)
.pgaw:Schema.c itemconfigure hili -fill blue
} else {
set PgAcVar(draginfo,is_a_table) 0
}
set PgAcVar(draginfo,x) $x
set PgAcVar(draginfo,y) $y
set PgAcVar(draginfo,sx) $x
set PgAcVar(draginfo,sy) $y
}
proc {dragStop} {x y} {
global PgAcVar
# when click Close, schema window is destroyed but event ButtonRelease-1 is fired
if {![winfo exists .pgaw:Schema]} return;
.pgaw:Schema configure -cursor left_ptr
set este {}
catch {set este $PgAcVar(draginfo,obj)}
if {$este==""} return
# Re-establish the normal paint order so
# information won't be overlapped by table rectangles
# or link lines
.pgaw:Schema.c lower $PgAcVar(draginfo,obj)
.pgaw:Schema.c lower rect
.pgaw:Schema.c lower links
set PgAcVar(schema,panstarted) 0
if {$PgAcVar(draginfo,is_a_table)} {
set tabnum [getTagInfo $PgAcVar(draginfo,obj) tab]
foreach w [.pgaw:Schema.c find withtag $PgAcVar(draginfo,tabletag)] {
if {[lsearch [.pgaw:Schema.c gettags $w] outer] != -1} {
foreach [list PgAcVar(schema,tablex$tabnum) PgAcVar(schema,tabley$tabnum) x1 y1] [.pgaw:Schema.c coords $w] {}
break
}
}
set PgAcVar(draginfo,obj) {}
.pgaw:Schema.c delete links
drawLinks
return
}
# not a table
.pgaw:Schema.c move $PgAcVar(draginfo,obj) [expr $PgAcVar(draginfo,sx)-$x] [expr $PgAcVar(draginfo,sy)-$y]
set droptarget [.pgaw:Schema.c find overlapping $x $y $x $y]
set targettable {}
foreach item $droptarget {
set targettable $PgAcVar(schema,tablename[getTagInfo $item tab])
set targetfield [getTagInfo $item f-]
if {($targettable!="") && ($targetfield!="")} {
set droptarget $item
break
}
}
# check if target object isn't a rectangle
if {[getTagInfo $droptarget rec]=="t"} {set targettable {}}
if {$targettable!=""} {
# Target has a table
# See about originate table
set sourcetable $PgAcVar(schema,tablename[getTagInfo $PgAcVar(draginfo,obj) tab])
if {$sourcetable!=""} {
# Source has also a tab .. tag
set sourcefield [getTagInfo $PgAcVar(draginfo,obj) f-]
if {$sourcetable!=$targettable} {
lappend PgAcVar(schema,links) [list $sourcetable $sourcefield $targettable $targetfield]
drawLinks
}
}
}
# Erase information about object beeing dragged
set PgAcVar(draginfo,obj) {}
}
proc {drawLinks} {} {
global PgAcVar
.pgaw:Schema.c delete links
set i 0
foreach link $PgAcVar(schema,links) {
set sourcenum -1
set targetnum -1
# Compute the source and destination right edge
foreach t [array names PgAcVar schema,tablename*] {
if {[regexp "^$PgAcVar($t)$" [lindex $link 0] ]} {
set sourcenum [string range $t 16 end]
} elseif {[regexp "^$PgAcVar($t)$" [lindex $link 2] ]} {
set targetnum [string range $t 16 end]
}
}
set sb [findField $sourcenum [lindex $link 1]]
set db [findField $targetnum [lindex $link 3]]
if {($sourcenum == -1 )||($targetnum == -1)||($sb ==-1)||($db==-1)} {
set PgAcVar(schema,links) [lreplace $PgAcVar(schema,links) $i $i]
showError "Link from [lindex $link 0].[lindex $link 1] to [lindex $link 2].[lindex $link 3] not found!"
} else {
set sre [lindex [.pgaw:Schema.c bbox tab$sourcenum] 2]
set dre [lindex [.pgaw:Schema.c bbox tab$targetnum] 2]
# Compute field bound boxes
set sbbox [.pgaw:Schema.c bbox $sb]
set dbbox [.pgaw:Schema.c bbox $db]
# Compute the auxiliary lines
if {[lindex $sbbox 2] < [lindex $dbbox 0]} {
# Source object is on the left of target object
set x1 $sre
set y1 [expr ([lindex $sbbox 1]+[lindex $sbbox 3])/2]
.pgaw:Schema.c create line $x1 $y1 [expr $x1+10] $y1 \
-tags [subst {links lkid$i}] -width 3
set x2 [lindex $dbbox 0]
set y2 [expr ([lindex $dbbox 1]+[lindex $dbbox 3])/2]
.pgaw:Schema.c create line [expr $x2-10] $y2 $x2 $y2 \
-tags [subst {links lkid$i}] -width 3
.pgaw:Schema.c create line [expr $x1+10] $y1 [expr $x2-10] $y2 \
-tags [subst {links lkid$i}] -width 2
} else {
# source object is on the right of target object
set x1 [lindex $sbbox 0]
set y1 [expr ([lindex $sbbox 1]+[lindex $sbbox 3])/2]
.pgaw:Schema.c create line $x1 $y1 [expr $x1-10] $y1 \
-tags [subst {links lkid$i}] -width 3
set x2 $dre
set y2 [expr ([lindex $dbbox 1]+[lindex $dbbox 3])/2]
.pgaw:Schema.c create line $x2 $y2 [expr $x2+10] $y2 -width 3 \
-tags [subst {links lkid$i}]
.pgaw:Schema.c create line [expr $x1-10] $y1 [expr $x2+10] $y2 \
-tags [subst {links lkid$i}] -width 2
}
incr i
}
}
.pgaw:Schema.c lower links
.pgaw:Schema.c bind links <Button-1> {Schema::linkClick %x %y}
}
proc {getSchemaTabless} {} {
global PgAcVar
set tablelist {}
foreach key [array names PgAcVar schema,tablename*] {
regsub schema,tablename $key "" num
lappend tablelist $PgAcVar($key) $PgAcVar(schema,tablex$num) $PgAcVar(schema,tabley$num)
}
return $tablelist
}
proc {findField} {alias field} {
foreach obj [.pgaw:Schema.c find withtag f-${field}] {
if {[lsearch [.pgaw:Schema.c gettags $obj] tab$alias] != -1} {return $obj}
}
return -1
}
proc {addLink} {sourcetable sourcefield targettable targetfield} {
global PgAcVar
lappend PgAcVar(schema,links) [list $sourcetable $sourcefield $targettable $targetfield]
}
proc {getTagInfo} {obj prefix} {
set taglist [.pgaw:Schema.c gettags $obj]
set tagpos [lsearch -regexp $taglist "^$prefix"]
if {$tagpos==-1} {return ""}
set thattag [lindex $taglist $tagpos]
return [string range $thattag [string length $prefix] end]
}
proc {init} {} {
global PgAcVar
PgAcVar:clean schema,*
set PgAcVar(schema,nexty) 10
set PgAcVar(schema,nextx) 10
set PgAcVar(schema,links) {}
set PgAcVar(schema,ntables) 0
set PgAcVar(schema,newtablename) {}
}
proc {linkClick} {x y} {
global PgAcVar
set obj [.pgaw:Schema.c find closest $x $y 1 links]
if {[getTagInfo $obj link]!="s"} return
.pgaw:Schema.c itemconfigure [.pgaw:Schema.c find withtag hili] -fill black
.pgaw:Schema.c dtag [.pgaw:Schema.c find withtag hili] hili
.pgaw:Schema.c addtag hili withtag $obj
.pgaw:Schema.c itemconfigure $obj -fill blue
}
proc {canvasPanning} {x y} {
global PgAcVar
set panstarted 0
catch {set panstarted $PgAcVar(schema,panstarted) }
if {!$panstarted} return
set dx [expr $x-$PgAcVar(schema,panstartx)]
set dy [expr $y-$PgAcVar(schema,panstarty)]
set PgAcVar(schema,panstartx) $x
set PgAcVar(schema,panstarty) $y
if {$PgAcVar(schema,panobject)=="tables"} {
.pgaw:Schema.c move mov $dx $dy
.pgaw:Schema.c move links $dx $dy
.pgaw:Schema.c move rect $dx $dy
} else {
.pgaw:Schema.c move resp $dx 0
.pgaw:Schema.c move resgrid $dx 0
.pgaw:Schema.c raise reshdr
}
}
proc print {c} {
set types {
{{Postscript Files} {.ps}}
{{All Files} *}
}
if {[catch {tk_getSaveFile -defaultextension .ps -filetypes $types \
-title "Print to Postscript"} fn] || [string match {} $fn]} return
if {[catch {::open $fn "w" } fid]} {
return -code error "Save Error: Unable to open '$fn' for writing\n$fid"
}
puts $fid [$c postscript -rotate 1]
close $fid
}
proc {canvasClick} {x y w} {
global PgAcVar
set PgAcVar(schema,panstarted) 0
if {$w==".pgaw:Schema.c"} {
set canpan 1
if {[llength [.pgaw:Schema.c find overlapping $x $y $x $y]]!=0} {set canpan 0}
set PgAcVar(schema,panobject) tables
if {$canpan} {
if {[.pgaw:Schema.c find withtag hili]!=""} {
.pgaw:Schema.c itemconfigure [.pgaw:Schema.c find withtag hili] -fill black
.pgaw:Schema.c dtag [.pgaw:Schema.c find withtag hili] hili
}
.pgaw:Schema configure -cursor hand1
set PgAcVar(schema,panstartx) $x
set PgAcVar(schema,panstarty) $y
set PgAcVar(schema,panstarted) 1
}
}
}
}
proc vTclWindow.pgaw:Schema {base} {
global PgAcVar
if {$base == ""} {
set base .pgaw:Schema
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
wm geometry $base 759x530+10+13
wm maxsize $base 1009 738
wm minsize $base 1 1
wm overrideredirect $base 0
wm resizable $base 1 1
wm title $base [intlmsg "Visual schema designer"]
bind $base <B1-Motion> {
Schema::canvasPanning %x %y
}
bind $base <Button-1> {
Schema::canvasClick %x %y %W
}
bind $base <ButtonRelease-1> {
Schema::dragStop %x %y
}
bind $base <Key-Delete> {
Schema::deleteObject
}
canvas $base.c -background #fefefe -borderwidth 2 -height 207 -relief ridge -takefocus 0 -width 295
frame $base.f \
-height 75 -relief groove -width 125
label $base.f.l -text [intlmsg {Add table}]
entry $base.f.e \
-background #fefefe -borderwidth 1
bind $base.f.e <Key-Return> {
Schema::addNewTable
}
button $base.f.bdd \
-image dnarw \
-command {if {[winfo exists .pgaw:Schema.ddf]} {
destroy .pgaw:Schema.ddf
} else {
create_drop_down .pgaw:Schema 70 27 200
focus .pgaw:Schema.ddf.sb
foreach tbl [Database::getTablesList] {.pgaw:Schema.ddf.lb insert end $tbl}
bind .pgaw:Schema.ddf.lb <ButtonRelease-1> {
set i [.pgaw:Schema.ddf.lb curselection]
if {$i!=""} {
set PgAcVar(schema,newtablename) [.pgaw:Schema.ddf.lb get $i]
Schema::addNewTable
}
destroy .pgaw:Schema.ddf
break
}
}} \
-padx 1 -pady 1
button $base.f.btnclose \
-command {Schema::init
Window destroy .pgaw:Schema} -padx 2 -pady 3 -text [intlmsg Close]
button $base.f.printbtn \
-command {Schema::print .pgaw:Schema.c} -padx 1 -pady 3 -text [intlmsg Print]
button $base.f.btnsave \
-command {if {$PgAcVar(schema,name)==""} then {
showError [intlmsg "You have to supply a name for this schema!"]
focus .pgaw:Schema.f.esn
} else {
setCursor CLOCK
set tables [Schema::getSchemaTabless]
if {$PgAcVar(schema,oid)==0} then {
set pgres [wpg_exec $CurrentDB "insert into pga_schema values ('$PgAcVar(schema,name)','$tables','$PgAcVar(schema,links)')"]
} else {
set pgres [wpg_exec $CurrentDB "update pga_schema set schemaname='$PgAcVar(schema,name)',schematables='$tables',schemalinks='$PgAcVar(schema,links)' where oid=$PgAcVar(schema,oid)"]
}
setCursor DEFAULT
if {$PgAcVar(pgsql,status)!="PGRES_COMMAND_OK"} then {
showError "[intlmsg {Error executing query}]\n$PgAcVar(pgsql,errmsg)"
} else {
Mainlib::tab_click Schema
if {$PgAcVar(schema,oid)==0} {set PgAcVar(schema,oid) [pg_result $pgres -oid]}
}
catch {pg_result $pgres -clear}
}} \
-padx 2 -pady 3 -text [intlmsg {Save schema}]
label $base.f.ls1 -text { }
entry $base.f.esn \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(schema,name)
label $base.f.lsn -text [intlmsg {Schema name}]
place $base.c -x 5 -y 30 -width 748 -height 500 -anchor nw -bordermode ignore
place $base.f \
-x 5 -y 5 -width 748 -height 25 -anchor nw -bordermode ignore
pack $base.f.l \
-in .pgaw:Schema.f -anchor center -expand 0 -fill none -side left
pack $base.f.e \
-in .pgaw:Schema.f -anchor center -expand 0 -fill none -side left
pack $base.f.bdd \
-in .pgaw:Schema.f -anchor center -expand 0 -fill none -side left
pack $base.f.btnclose \
-in .pgaw:Schema.f -anchor center -expand 0 -fill none -side right
pack $base.f.printbtn \
-in .pgaw:Schema.f -anchor center -expand 0 -fill none -side right
pack $base.f.btnsave \
-in .pgaw:Schema.f -anchor center -expand 0 -fill none -side right
pack $base.f.ls1 \
-in .pgaw:Schema.f -anchor center -expand 0 -fill none -side right
pack $base.f.esn \
-in .pgaw:Schema.f -anchor center -expand 0 -fill none -side right
pack $base.f.lsn \
-in .pgaw:Schema.f -anchor center -expand 0 -fill none -side right
}

88
src/bin/pgaccess/lib/scripts.tcl Normal file
View File

@@ -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
}

159
src/bin/pgaccess/lib/sequences.tcl Normal file
View File

@@ -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 <Key-F1> "Help::load sequences"
frame $base.f1 \
-borderwidth 2 -height 75 -width 125
label $base.f1.l1 \
-borderwidth 0 -relief raised -text [intlmsg {Sequence name}]
entry $base.f1.e1 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(seq,name) -width 200
bind $base.f1.e1 <Key-KP_Enter> {
focus .pgaw:Sequence.f1.e2
}
bind $base.f1.e1 <Key-Return> {
focus .pgaw:Sequence.f1.e2
}
label $base.f1.l2 \
-borderwidth 0 -relief raised -text [intlmsg Increment]
entry $base.f1.e2 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(seq,incr) -width 200
bind $base.f1.e2 <Key-Return> {
focus .pgaw:Sequence.f1.e3
}
label $base.f1.l3 \
-borderwidth 0 -relief raised -text [intlmsg {Start value}]
entry $base.f1.e3 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(seq,start) -width 200
bind $base.f1.e3 <Key-Return> {
focus .pgaw:Sequence.f1.e4
}
label $base.f1.l4 \
-borderwidth 0 -relief raised -text [intlmsg Minvalue]
entry $base.f1.e4 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(seq,minval) \
-width 200
bind $base.f1.e4 <Key-Return> {
focus .pgaw:Sequence.f1.e5
}
label $base.f1.ls2 \
-borderwidth 0 -relief raised -text { }
label $base.f1.l5 \
-borderwidth 0 -relief raised -text [intlmsg Maxvalue]
entry $base.f1.e5 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(seq,maxval) \
-width 200
bind $base.f1.e5 <Key-Return> {
focus .pgaw:Sequence.fb.btnsave
}
frame $base.fb \
-height 75 -relief groove -width 125
button $base.fb.btnsave \
-borderwidth 1 -command Sequences::save \
-padx 9 -pady 3 -text [intlmsg {Define sequence}]
button $base.fb.btncancel \
-borderwidth 1 -command {Window destroy .pgaw:Sequence} \
-padx 9 -pady 3 -text [intlmsg Close]
place $base.f1 \
-x 9 -y 5 -width 265 -height 126 -anchor nw -bordermode ignore
grid columnconf $base.f1 2 -weight 1
grid $base.f1.l1 \
-in .pgaw:Sequence.f1 -column 0 -row 0 -columnspan 1 -rowspan 1 -sticky w
grid $base.f1.e1 \
-in .pgaw:Sequence.f1 -column 2 -row 0 -columnspan 1 -rowspan 1 -pady 2
grid $base.f1.l2 \
-in .pgaw:Sequence.f1 -column 0 -row 2 -columnspan 1 -rowspan 1 -sticky w
grid $base.f1.e2 \
-in .pgaw:Sequence.f1 -column 2 -row 2 -columnspan 1 -rowspan 1 -pady 2
grid $base.f1.l3 \
-in .pgaw:Sequence.f1 -column 0 -row 4 -columnspan 1 -rowspan 1 -sticky w
grid $base.f1.e3 \
-in .pgaw:Sequence.f1 -column 2 -row 4 -columnspan 1 -rowspan 1 -pady 2
grid $base.f1.l4 \
-in .pgaw:Sequence.f1 -column 0 -row 6 -columnspan 1 -rowspan 1 -sticky w
grid $base.f1.e4 \
-in .pgaw:Sequence.f1 -column 2 -row 6 -columnspan 1 -rowspan 1 -pady 2
grid $base.f1.ls2 \
-in .pgaw:Sequence.f1 -column 1 -row 0 -columnspan 1 -rowspan 1
grid $base.f1.l5 \
-in .pgaw:Sequence.f1 -column 0 -row 7 -columnspan 1 -rowspan 1 -sticky w
grid $base.f1.e5 \
-in .pgaw:Sequence.f1 -column 2 -row 7 -columnspan 1 -rowspan 1 -pady 2
place $base.fb \
-x 0 -y 135 -width 283 -height 40 -anchor nw -bordermode ignore
grid $base.fb.btnsave \
-in .pgaw:Sequence.fb -column 0 -row 0 -columnspan 1 -rowspan 1 -padx 5
grid $base.fb.btncancel \
-in .pgaw:Sequence.fb -column 1 -row 0 -columnspan 1 -rowspan 1 -padx 5
}

2158
src/bin/pgaccess/lib/tables.tcl Normal file
View File

File diff suppressed because it is too large Load Diff

155
src/bin/pgaccess/lib/users.tcl Normal file
View File

@@ -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 <Key-Return> "focus .pgaw:User.e2"
bind $base.e1 <Key-KP_Enter> "focus .pgaw:User.e2"
label $base.l2 \
-borderwidth 0 -text [intlmsg Password]
entry $base.e2 \
-background #fefefe -borderwidth 1 -show * -textvariable PgAcVar(user,password)
bind $base.e2 <Key-Return> "focus .pgaw:User.e3"
bind $base.e2 <Key-KP_Enter> "focus .pgaw:User.e3"
label $base.l3 \
-borderwidth 0 -text [intlmsg {verify password}]
entry $base.e3 \
-background #fefefe -borderwidth 1 -show * -textvariable PgAcVar(user,verifypassword)
bind $base.e3 <Key-Return> "focus .pgaw:User.cb1"
bind $base.e3 <Key-KP_Enter> "focus .pgaw:User.cb1"
checkbutton $base.cb1 \
-borderwidth 1 -offvalue NOCREATEDB -onvalue CREATEDB \
-text [intlmsg {Allow user to create databases}] -variable PgAcVar(user,createdb)
checkbutton $base.cb2 \
-borderwidth 1 -offvalue NOCREATEUSER -onvalue CREATEUSER \
-text [intlmsg {Allow user to create other users}] -variable PgAcVar(user,createuser)
label $base.l4 \
-borderwidth 0 -anchor w -text [intlmsg {Valid until (date)}]
entry $base.e4 \
-background #fefefe -borderwidth 1 -textvariable PgAcVar(user,validuntil)
bind $base.e4 <Key-Return> "focus .pgaw:User.b1"
bind $base.e4 <Key-KP_Enter> "focus .pgaw:User.b1"
button $base.b1 \
-borderwidth 1 -command Users::save -text [intlmsg Create]
button $base.b2 \
-borderwidth 1 -command {Window destroy .pgaw:User} -text [intlmsg Cancel]
place $base.l1 \
-x 5 -y 7 -height 16 -anchor nw -bordermode ignore
place $base.e1 \
-x 109 -y 5 -width 146 -height 20 -anchor nw -bordermode ignore
place $base.l2 \
-x 5 -y 35 -anchor nw -bordermode ignore
place $base.e2 \
-x 109 -y 32 -width 146 -height 20 -anchor nw -bordermode ignore
place $base.l3 \
-x 5 -y 60 -anchor nw -bordermode ignore
place $base.e3 \
-x 109 -y 58 -width 146 -height 20 -anchor nw -bordermode ignore
place $base.cb1 \
-x 5 -y 90 -anchor nw -bordermode ignore
place $base.cb2 \
-x 5 -y 115 -anchor nw -bordermode ignore
place $base.l4 \
-x 5 -y 145 -height 16 -anchor nw -bordermode ignore
place $base.e4 \
-x 110 -y 143 -width 146 -height 20 -anchor nw -bordermode ignore
place $base.b1 \
-x 45 -y 185 -anchor nw -width 70 -height 25 -bordermode ignore
place $base.b2 \
-x 140 -y 185 -anchor nw -width 70 -height 25 -bordermode ignore
}

45
src/bin/pgaccess/lib/views.tcl Normal file
View File

@@ -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
}
}

776
src/bin/pgaccess/lib/visualqb.tcl Normal file
View File

@@ -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 <Button-1> {VisualQueryBuilder::linkClick %x %y}
}
proc {repaintAll} {} {
global PgAcVar
variable vqb
.pgaw:VisualQuery.c delete all
set posx 20
foreach tn [array names vqb tablename*] {
regsub tablename $tn "" it
drawTable $it
}
.pgaw:VisualQuery.c lower rect
.pgaw:VisualQuery.c create line 0 $vqb(yoffs) 10000 $vqb(yoffs) -width 3
.pgaw:VisualQuery.c create rectangle 0 $vqb(yoffs) 10000 5000 -fill #FFFFFF
for {set i [expr 15+$vqb(yoffs)]} {$i<500} {incr i 15} {
.pgaw:VisualQuery.c create line $vqb(xoffs) $i 10000 $i -fill #CCCCCC -tags {resgrid}
}
for {set i $vqb(xoffs)} {$i<10000} {incr i $vqb(reswidth)} {
.pgaw:VisualQuery.c create line $i [expr 1+$vqb(yoffs)] $i 10000 -fill #cccccc -tags {resgrid}
}
# Make a marker for result panel offset calculations (due to panning)
.pgaw:VisualQuery.c create line $vqb(xoffs) $vqb(yoffs) $vqb(xoffs) 500 -tags {resmarker resgrid}
.pgaw:VisualQuery.c create rectangle 0 $vqb(yoffs) $vqb(xoffs) 5000 -fill #EEEEEE -tags {reshdr}
.pgaw:VisualQuery.c create text 5 [expr 1+$vqb(yoffs)] -text [intlmsg Field] -anchor nw -font $PgAcVar(pref,font_normal) -tags {reshdr}
.pgaw:VisualQuery.c create text 5 [expr 16+$vqb(yoffs)] -text [intlmsg Table] -anchor nw -font $PgAcVar(pref,font_normal) -tags {reshdr}
.pgaw:VisualQuery.c create text 5 [expr 31+$vqb(yoffs)] -text [intlmsg Sort] -anchor nw -font $PgAcVar(pref,font_normal) -tags {reshdr}
.pgaw:VisualQuery.c create text 5 [expr 46+$vqb(yoffs)] -text [intlmsg Criteria] -anchor nw -font $PgAcVar(pref,font_normal) -tags {reshdr}
.pgaw:VisualQuery.c create text 5 [expr 61+$vqb(yoffs)] -text [intlmsg Return] -anchor nw -font $PgAcVar(pref,font_normal) -tags {reshdr}
drawLinks
drawResultPanel
.pgaw:VisualQuery.c bind mov <Button-1> {VisualQueryBuilder::dragStart %W %x %y}
.pgaw:VisualQuery.c bind mov <B1-Motion> {VisualQueryBuilder::dragObject %W %x %y}
bind .pgaw:VisualQuery <ButtonRelease-1> {VisualQueryBuilder::dragStop %x %y}
bind .pgaw:VisualQuery <Button-1> {VisualQueryBuilder::canvasClick %x %y %W}
bind .pgaw:VisualQuery <B1-Motion> {VisualQueryBuilder::panning %x %y}
bind .pgaw:VisualQuery <Key-Delete> {VisualQueryBuilder::deleteObject}
}
proc {drawResultPanel} {} {
global PgAcVar
variable vqb
# Compute the offset of the result panel due to panning
set resoffset [expr [lindex [.pgaw:VisualQuery.c bbox resmarker] 0]-$vqb(xoffs)]
.pgaw:VisualQuery.c delete resp
for {set i 0} {$i<[llength $vqb(resfields)]} {incr i} {
.pgaw:VisualQuery.c create text [expr $resoffset+4+$vqb(xoffs)+$i*$vqb(reswidth)] [expr 1+$vqb(yoffs)] -text [lindex $vqb(resfields) $i] -anchor nw -tags [subst {resf resp col$i}] -font $PgAcVar(pref,font_normal)
.pgaw:VisualQuery.c create text [expr $resoffset+4+$vqb(xoffs)+$i*$vqb(reswidth)] [expr 16+$vqb(yoffs)] -text $vqb(ali_[lindex $vqb(restables) $i]) -anchor nw -tags {resp rest} -font $PgAcVar(pref,font_normal)
.pgaw:VisualQuery.c create text [expr $resoffset+4+$vqb(xoffs)+$i*$vqb(reswidth)] [expr 31+$vqb(yoffs)] -text [lindex $vqb(ressort) $i] -anchor nw -tags {resp sort} -font $PgAcVar(pref,font_normal)
if {[lindex $vqb(rescriteria) $i]!=""} {
.pgaw:VisualQuery.c create text [expr $resoffset+4+$vqb(xoffs)+$i*$vqb(reswidth)] [expr $vqb(yoffs)+46+15*0] -anchor nw -text [lindex $vqb(rescriteria) $i] -font $PgAcVar(pref,font_normal) -tags [subst {resp cr-c$i-r0}]
}
.pgaw:VisualQuery.c create text [expr $resoffset+4+$vqb(xoffs)+$i*$vqb(reswidth)] [expr 61+$vqb(yoffs)] -text [lindex $vqb(resreturn) $i] -anchor nw -tags {resp retval} -font $PgAcVar(pref,font_normal)
}
.pgaw:VisualQuery.c raise reshdr
.pgaw:VisualQuery.c bind resf <Button-1> {VisualQueryBuilder::resultFieldClick %x %y}
.pgaw:VisualQuery.c bind sort <Button-1> {VisualQueryBuilder::toggleSortMode %W %x %y}
.pgaw:VisualQuery.c bind retval <Button-1> {VisualQueryBuilder::toggleReturn %W %x %y}
}
proc {drawTable} {it} {
global PgAcVar
variable vqb
if {$vqb(tablex$it)==0} {
set posy 10
set allbox [.pgaw:VisualQuery.c bbox rect]
if {$allbox==""} {set posx 10} else {set posx [expr 20+[lindex $allbox 2]]}
set vqb(tablex$it) $posx
set vqb(tabley$it) $posy
} else {
set posx [expr int($vqb(tablex$it))]
set posy [expr int($vqb(tabley$it))]
}
set tablename $vqb(tablename$it)
set tablealias $vqb(tablealias$it)
.pgaw:VisualQuery.c create text $posx $posy -text "$tablename" -anchor nw -tags [subst {tab$tablealias f-oid mov tableheader}] -font $PgAcVar(pref,font_bold)
incr posy 16
foreach fld $vqb(tablestruct$it) {
.pgaw:VisualQuery.c create text $posx $posy -text $fld -fill #010101 -anchor nw -tags [subst {f-$fld tab$tablealias mov}] -font $PgAcVar(pref,font_normal)
incr posy 14
}
set reg [.pgaw:VisualQuery.c bbox tab$tablealias]
.pgaw:VisualQuery.c create rectangle [lindex $reg 0] [lindex $reg 1] [lindex $reg 2] [lindex $reg 3] -fill #EEEEEE -tags [subst {rect outer tab$tablealias}]
.pgaw:VisualQuery.c create line [lindex $reg 0] [expr [lindex $reg 1]+15] [lindex $reg 2] [expr [lindex $reg 1]+15] -tags [subst {rect tab$tablealias}]
.pgaw:VisualQuery.c lower tab$tablealias
.pgaw:VisualQuery.c lower rect
}
proc {getTagInfo} {obj prefix} {
variable vqb
set taglist [.pgaw:VisualQuery.c gettags $obj]
set tagpos [lsearch -regexp $taglist "^$prefix"]
if {$tagpos==-1} {return ""}
set thattag [lindex $taglist $tagpos]
return [string range $thattag [string length $prefix] end]
}
proc {init} {} {
global PgAcVar
variable vqb
catch { unset vqb }
set vqb(yoffs) 360
set vqb(xoffs) 50
set vqb(reswidth) 150
set vqb(resfields) {}
set vqb(resreturn) {}
set vqb(ressort) {}
set vqb(rescriteria) {}
set vqb(restables) {}
set vqb(critedit) 0
set vqb(links) {}
set vqb(ntables) 0
set vqb(newtablename) {}
}
proc {linkClick} {x y} {
global PgAcVar
variable vqb
set obj [.pgaw:VisualQuery.c find closest $x $y 1 links]
if {[getTagInfo $obj link]!="s"} return
.pgaw:VisualQuery.c itemconfigure [.pgaw:VisualQuery.c find withtag hili] -fill black
.pgaw:VisualQuery.c dtag [.pgaw:VisualQuery.c find withtag hili] hili
.pgaw:VisualQuery.c addtag hili withtag $obj
.pgaw:VisualQuery.c itemconfigure $obj -fill blue
}
proc {panning} {x y} {
global PgAcVar
variable vqb
set panstarted 0
catch {set panstarted $vqb(panstarted) }
if {!$panstarted} return
set dx [expr $x-$vqb(panstartx)]
set dy [expr $y-$vqb(panstarty)]
set vqb(panstartx) $x
set vqb(panstarty) $y
if {$vqb(panobject)=="tables"} {
.pgaw:VisualQuery.c move mov $dx $dy
.pgaw:VisualQuery.c move links $dx $dy
.pgaw:VisualQuery.c move rect $dx $dy
} else {
.pgaw:VisualQuery.c move resp $dx 0
.pgaw:VisualQuery.c move resgrid $dx 0
.pgaw:VisualQuery.c raise reshdr
}
}
proc {resultFieldClick} {x y} {
global PgAcVar
variable vqb
set obj [.pgaw:VisualQuery.c find closest $x $y]
if {[getTagInfo $obj res]!="f"} return
.pgaw:VisualQuery.c itemconfigure [.pgaw:VisualQuery.c find withtag hili] -fill black
.pgaw:VisualQuery.c dtag [.pgaw:VisualQuery.c find withtag hili] hili
.pgaw:VisualQuery.c addtag hili withtag $obj
.pgaw:VisualQuery.c itemconfigure $obj -fill blue
}
proc {showSQL} {} {
global PgAcVar
variable vqb
set sqlcmd [computeSQL]
.pgaw:VisualQuery.c delete sqlpage
.pgaw:VisualQuery.c create rectangle 0 0 2000 [expr $vqb(yoffs)-1] -fill #ffffff -tags {sqlpage}
.pgaw:VisualQuery.c create text 10 10 -text $sqlcmd -anchor nw -width 550 -tags {sqlpage} -font $PgAcVar(pref,font_normal)
.pgaw:VisualQuery.c bind sqlpage <Button-1> {.pgaw:VisualQuery.c delete sqlpage}
}
proc {toggleSortMode} {w x y} {
global PgAcVar
variable vqb
set obj [$w find closest $x $y]
set taglist [.pgaw:VisualQuery.c gettags $obj]
if {[lsearch $taglist sort]==-1} return
set how [.pgaw:VisualQuery.c itemcget $obj -text]
if {$how=="unsorted"} {
set how Ascending
} elseif {$how=="Ascending"} {
set how Descending
} else {
set how unsorted
}
set col [expr int(($x-$vqb(xoffs))/$vqb(reswidth))]
set vqb(ressort) [lreplace $vqb(ressort) $col $col $how]
.pgaw:VisualQuery.c itemconfigure $obj -text $how
}
#rjr 8Mar1999 toggle logical return state for result
proc {toggleReturn} {w x y} {
global PgAcVar
variable vqb
set obj [$w find closest $x $y]
set taglist [.pgaw:VisualQuery.c gettags $obj]
if {[lsearch $taglist retval]==-1} return
set how [.pgaw:VisualQuery.c itemcget $obj -text]
if {$how==[intlmsg Yes]} {
set how [intlmsg No]
} else {
set how [intlmsg Yes]
}
set col [expr int(($x-$vqb(xoffs))/$vqb(reswidth))]
set vqb(resreturn) [lreplace $vqb(resreturn) $col $col $how]
.pgaw:VisualQuery.c itemconfigure $obj -text $how
}
proc {canvasClick} {x y w} {
global PgAcVar
variable vqb
set vqb(panstarted) 0
if {$w==".pgaw:VisualQuery.c"} {
set canpan 1
if {$y<$vqb(yoffs)} {
if {[llength [.pgaw:VisualQuery.c find overlapping $x $y $x $y]]!=0} {set canpan 0}
set vqb(panobject) tables
} else {
set vqb(panobject) result
}
if {$canpan} {
.pgaw:VisualQuery configure -cursor hand1
set vqb(panstartx) $x
set vqb(panstarty) $y
set vqb(panstarted) 1
}
}
set isedit 0
catch {set isedit $vqb(critedit)}
# Compute the offset of the result panel due to panning
set resoffset [expr [lindex [.pgaw:VisualQuery.c bbox resmarker] 0]-$vqb(xoffs)]
if {$isedit} {
set vqb(rescriteria) [lreplace $vqb(rescriteria) $vqb(critcol) $vqb(critcol) $vqb(critval)]
.pgaw:VisualQuery.c delete cr-c$vqb(critcol)-r$vqb(critrow)
.pgaw:VisualQuery.c create text [expr $resoffset+4+$vqb(xoffs)+$vqb(critcol)*$vqb(reswidth)] [expr $vqb(yoffs)+46+15*$vqb(critrow)] -anchor nw -text $vqb(critval) -font $PgAcVar(pref,font_normal) -tags [subst {resp cr-c$vqb(critcol)-r$vqb(critrow)}]
set vqb(critedit) 0
}
catch {destroy .pgaw:VisualQuery.entc}
if {$y<[expr $vqb(yoffs)+46]} return
if {$x<[expr $vqb(xoffs)+5]} return
set col [expr int(($x-$vqb(xoffs)-$resoffset)/$vqb(reswidth))]
if {$col>=[llength $vqb(resfields)]} return
set nx [expr $col*$vqb(reswidth)+8+$vqb(xoffs)+$resoffset]
set ny [expr $vqb(yoffs)+76]
# Get the old criteria value
set vqb(critval) [lindex $vqb(rescriteria) $col]
entry .pgaw:VisualQuery.entc -textvar VisualQueryBuilder::vqb(critval) -borderwidth 0 -background #FFFFFF -highlightthickness 0 -selectborderwidth 0 -font $PgAcVar(pref,font_normal)
place .pgaw:VisualQuery.entc -x $nx -y $ny -height 14
focus .pgaw:VisualQuery.entc
bind .pgaw:VisualQuery.entc <Button-1> {set VisualQueryBuilder::vqb(panstarted) 0}
set vqb(critcol) $col
set vqb(critrow) 0
set vqb(critedit) 1
}
proc {saveToQueryBuilder} {} {
global PgAcVar
variable vqb
Window show .pgaw:QueryBuilder
.pgaw:QueryBuilder.text1 delete 1.0 end
set vqb(qcmd) [computeSQL]
set PgAcVar(query,tables) [getTableList]
set PgAcVar(query,links) [getLinkList]
set PgAcVar(query,results) [getResultList]
.pgaw:QueryBuilder.text1 insert end $vqb(qcmd)
focus .pgaw:QueryBuilder
}
proc {executeSQL} {} {
global PgAcVar
variable vqb
set vqb(qcmd) [computeSQL]
set wn [Tables::getNewWindowName]
set PgAcVar(mw,$wn,query) [subst $vqb(qcmd)]
set PgAcVar(mw,$wn,updatable) 0
set PgAcVar(mw,$wn,isaquery) 1
Tables::createWindow
Tables::loadLayout $wn nolayoutneeded
Tables::selectRecords $wn $PgAcVar(mw,$wn,query)
}
proc {createDropDown} {} {
global PgAcVar
variable vqb
if {[winfo exists .pgaw:VisualQuery.ddf]} {
destroy .pgaw:VisualQuery.ddf
} else {
create_drop_down .pgaw:VisualQuery 70 27 200
focus .pgaw:VisualQuery.ddf.sb
foreach tbl [Database::getTablesList] {.pgaw:VisualQuery.ddf.lb insert end $tbl}
bind .pgaw:VisualQuery.ddf.lb <ButtonRelease-1> {
set i [.pgaw:VisualQuery.ddf.lb curselection]
if {$i!=""} {
set VisualQueryBuilder::vqb(newtablename) [.pgaw:VisualQuery.ddf.lb get $i]
VisualQueryBuilder::addNewTable
}
destroy .pgaw:VisualQuery.ddf
break
}
}
}
}
proc vTclWindow.pgaw:VisualQuery {base} {
global PgAcVar
if {$base == ""} {
set base .pgaw:VisualQuery
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
toplevel $base -class Toplevel
wm focusmodel $base passive
wm geometry $base 759x530+10+13
wm maxsize $base 1009 738
wm minsize $base 1 1
wm overrideredirect $base 0
wm resizable $base 1 1
wm deiconify $base
wm title $base [intlmsg "Visual query designer"]
bind $base <B1-Motion> {
VisualQueryBuilder::panning %x %y
}
bind $base <Button-1> {
VisualQueryBuilder::canvasClick %x %y %W
}
bind $base <ButtonRelease-1> {
VisualQueryBuilder::dragStop %x %y
}
bind $base <Key-Delete> {
VisualQueryBuilder::deleteObject
}
bind $base <Key-F1> "Help::load visual_designer"
canvas $base.c -background #fefefe -borderwidth 2 -height 207 -relief ridge -takefocus 0 -width 295
frame $base.fb -height 75 -width 125
label $base.fb.l12 -borderwidth 0 -text "[intlmsg {Add table}] "
entry $base.fb.entt -background #fefefe -borderwidth 1 -highlightthickness 1 \
-selectborderwidth 0 -textvariable VisualQueryBuilder::vqb(newtablename)
bind $base.fb.entt <Key-Return> {
VisualQueryBuilder::addNewTable
}
button $base.fb.bdd -borderwidth 1 \
-command VisualQueryBuilder::createDropDown -image dnarw
button $base.fb.showbtn \
-command VisualQueryBuilder::showSQL \
-text [intlmsg {Show SQL}]
button $base.fb.execbtn \
-command VisualQueryBuilder::executeSQL \
-text [intlmsg {Execute SQL}]
button $base.fb.stoqb \
-command VisualQueryBuilder::saveToQueryBuilder \
-text [intlmsg {Save to query builder}]
button $base.fb.exitbtn \
-command {Window destroy .pgaw:VisualQuery} \
-text [intlmsg Close]
place $base.c -x 5 -y 30 -width 750 -height 500 -anchor nw -bordermode ignore
place $base.fb \
-x 5 -y 0 -width 753 -height 31 -anchor nw -bordermode ignore
pack $base.fb.l12 \
-in .pgaw:VisualQuery.fb -anchor center -expand 0 -fill none -side left
pack $base.fb.entt \
-in .pgaw:VisualQuery.fb -anchor center -expand 0 -fill none -side left
pack $base.fb.bdd \
-in .pgaw:VisualQuery.fb -anchor center -expand 0 -fill none -side left
pack $base.fb.exitbtn \
-in .pgaw:VisualQuery.fb -anchor center -expand 0 -fill none -side right
pack $base.fb.stoqb \
-in .pgaw:VisualQuery.fb -anchor center -expand 0 -fill none -side right
pack $base.fb.execbtn \
-in .pgaw:VisualQuery.fb -anchor center -expand 0 -fill none -side right
pack $base.fb.showbtn \
-in .pgaw:VisualQuery.fb -anchor center -expand 0 -fill none -side right
}

250
src/bin/pgaccess/main.tcl Normal file
View File

@@ -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 <Destroy> "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

10
src/bin/pgaccess/pgaccess Executable file
View File

@@ -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 "$@"