900 changed files with 194271 additions and 38914 deletions
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,5 @@
|
||||
# |
||||
# Tcl package index file |
||||
# |
||||
package ifneeded tzint 1.1.1 \ |
||||
[list load [file join $dir tzint111.dll] [string totitle tzint 0 0]] |
||||
Binary file not shown.
|
After Width: | Height: | Size: 277 KiB |
@ -0,0 +1,62 @@
|
||||
MaterialIcons 0.2 |
||||
================= |
||||
|
||||
A Tcl/Tk package wrapping the |
||||
[Material Design Icons](https://material.io/tools/icons). |
||||
|
||||
License |
||||
------- |
||||
|
||||
BSD |
||||
|
||||
Dependencies |
||||
------------ |
||||
|
||||
package require Tk |
||||
package require tdom |
||||
package require tksvg |
||||
|
||||
Usage |
||||
----- |
||||
|
||||
package require MaterialIcons |
||||
MaterialIcons names ?pattern? |
||||
MaterialIcons svg name ?color? ?opacity? ?stroke? ?strokewidth? |
||||
MaterialIcons image name ?size? ?color? ?opacity? |
||||
MaterialIcons image_nc name ?size? ?color? ?opacity? |
||||
MaterialIcons image_ncg name imgname ?options? |
||||
MaterialIcons flush |
||||
MaterialIcons rebuild |
||||
|
||||
Method `names` returns an alphabetically sorted list of icon names |
||||
matching the given `pattern`, or all, if `pattern` is omitted. |
||||
|
||||
Method `svg` returns an SVG string for the icon `name` with optional fill |
||||
color `color` (defaults to black), optional fill opacity `opacity` |
||||
(defaults to 1.0), optional stroke color `stroke` (defaults to none), |
||||
and optional stroke width `strokewidth` (defaults to 1.0). |
||||
|
||||
Method `image` creates and returns a photo image for the icon `name` with |
||||
optional fill color `color` (defaults to black) and optional fill opacity |
||||
`opacity` (defaults to 1.0). The `size` option specifies the integer icon |
||||
size. If it is negative, the size is in pixels, otherwise in points. The |
||||
default value for `size` is 16 points. The photo image is kept in an image |
||||
cache for later re-use. |
||||
|
||||
Method `image_nc` is similar to method `image` except that no caching is |
||||
performed, i.e. a newly created image is returned. |
||||
|
||||
Method `image_ncg` is similar to method `image_nc` but allows to provide |
||||
a specific image name and render options as keyword arguments `-size`, |
||||
`-fill`, `-opacity`, `-stroke`, and `-strokewidth`. Size and stroke width |
||||
can be specified as floating point numbers with an optional unit suffix: |
||||
d (density points), p (points), or m (millimeters). The stroke width is |
||||
scaled unless a unit suffix is used or a negative number is given. |
||||
|
||||
Method `flush` deletes all cached icon photo images. |
||||
|
||||
Method `rebuild` recreates all cached icon photo images which have a size |
||||
in points. This is useful when the tk scaling factor is changed at runtime. |
||||
|
||||
A utility script named `show.tcl` demonstrates the usage of this package |
||||
and displays all icons in a canvas widget. |
||||
@ -0,0 +1,240 @@
|
||||
# Module to on-demand render MaterialIcons-Regular.svg |
||||
# into photo images using tksvg. |
||||
# |
||||
# chw January 2019 |
||||
# image_ncg contributed by dzach May/July 2019 |
||||
|
||||
package require Tk |
||||
package require tdom |
||||
package require tksvg |
||||
|
||||
namespace eval ::MaterialIcons { |
||||
|
||||
variable glyph ;# SVG glyph cache |
||||
array set glyph {} ;# indexed by glyph name |
||||
|
||||
variable viewbox ;# common viewBox {x y w h} for glyphs |
||||
|
||||
variable icache ;# image cache indexed by glyph name, size, |
||||
array set icache {} ;# opacity, color, e.g. "zoom_out,24,1.0,black" |
||||
|
||||
variable template ;# SVG template for a glyph |
||||
|
||||
# Module initializer: parse and cache the SVG file. |
||||
|
||||
proc _init {file} { |
||||
variable glyph |
||||
variable viewbox |
||||
variable template |
||||
set f [open $file] |
||||
set doc [dom parse -channel $f] |
||||
close $f |
||||
set root [$doc documentElement] |
||||
foreach node [$root getElementsByTagName glyph] { |
||||
if {[$node hasAttribute glyph-name] && [$node hasAttribute d]} { |
||||
set d [$node getAttribute d] |
||||
if {$d eq "M0 0z"} { |
||||
# skip empty icon |
||||
continue |
||||
} |
||||
set glyph([$node getAttribute glyph-name]) $d |
||||
} |
||||
} |
||||
foreach node [$root getElementsByTagName font-face] { |
||||
if {[$node hasAttribute bbox]} { |
||||
set bbox [$node getAttribute bbox] |
||||
# keep only first bbox |
||||
break |
||||
} |
||||
} |
||||
$doc delete |
||||
if {![info exists bbox]} { |
||||
return -code error "no bbox attribute found" |
||||
} |
||||
set template0 { |
||||
<?xml version="1.0" encoding="UTF-8" standalone="no"?> |
||||
<svg id="%%s" width="%g" height="%g" viewBox="%s" version="1.1"> |
||||
<g> |
||||
<path fill="%%s" fill-opacity="%%g" |
||||
stroke="%%s" stroke-width="%%g" |
||||
transform="rotate(%%g,256,256) scale(1,-1) translate(0,%g)" |
||||
d="%%s"/> |
||||
</g> |
||||
</svg> |
||||
} |
||||
lassign $bbox x1 y1 x2 y2 |
||||
set w [expr {$x2 - $x1}] |
||||
set h [expr {$y2 - $y1}] |
||||
set viewbox [list $x1 $y1 $w $h] |
||||
set template [format $template0 $w $h $viewbox [expr {0 - $y2 - $y1}]] |
||||
} |
||||
|
||||
# Invoke and release initializer. |
||||
|
||||
_init [file join [file dirname [info script]] MaterialIcons-Regular.svg] |
||||
rename _init {} |
||||
|
||||
# Return list of icon (glyph) names which can be rendered. |
||||
|
||||
proc names {{pattern *}} { |
||||
variable glyph |
||||
tailcall lsort [array names glyph $pattern] |
||||
} |
||||
|
||||
# Return SVG for named icon with optional fill color and opacity. |
||||
|
||||
proc svg {name {color black} {opacity 1.0} |
||||
{stroke none} {strokewidth 1.0} {angle 0}} { |
||||
variable glyph |
||||
variable template |
||||
if {![info exists glyph($name)]} { |
||||
return -code error "glyph $name does not exist" |
||||
} |
||||
tailcall format $template $name $color $opacity \ |
||||
$stroke $strokewidth $angle $glyph($name) |
||||
} |
||||
|
||||
# Return photo image for named icon with optional size, fill color, |
||||
# and opacity. If size is negative, it specifies pixels, else points |
||||
# taking the current tk scaling into account. |
||||
|
||||
proc image {name {size 16} {color black} {opacity 1.0}} { |
||||
variable icache |
||||
set fullname ${name},${size},${opacity},${color} |
||||
if {[info exists icache($fullname)]} { |
||||
if {![catch {::image inuse $icache($fullname)}]} { |
||||
return $icache($fullname) |
||||
} |
||||
unset icache($fullname) |
||||
} |
||||
set icache($fullname) [image_nc $name $size $color $opacity] |
||||
return $icache($fullname) |
||||
} |
||||
|
||||
# Like the "image" method above but without caching. |
||||
|
||||
proc image_nc {name {size 16} {color black} {opacity 1.0}} { |
||||
variable viewbox |
||||
if {![string is integer $size]} { |
||||
return -code error "expect integer size" |
||||
} |
||||
if {$size == 0} { |
||||
return -code error "invalid size" |
||||
} |
||||
lassign $viewbox x y w h |
||||
if {$size < 0} { |
||||
set size [expr {-1.0 * $size}] |
||||
} else { |
||||
set dpi [expr {72.0 * [tk scaling]}] |
||||
set size [expr {$dpi * $size / 72.0}] |
||||
} |
||||
set scale [expr {1.0 * $size / $w}] |
||||
tailcall ::image create photo -format [list svg -scale $scale] \ |
||||
-data [svg $name $color $opacity] |
||||
} |
||||
|
||||
# Flush image cache. |
||||
|
||||
proc flush {} { |
||||
variable icache |
||||
foreach fullname [array names icache] { |
||||
catch {::image delete $icache($fullname)} |
||||
unset icache($fullname) |
||||
} |
||||
} |
||||
|
||||
# Rebuild image cache; useful when tk scaling has changed. |
||||
|
||||
proc rebuild {} { |
||||
variable icache |
||||
variable viewbox |
||||
set dpi [expr {72.0 * [tk scaling]}] |
||||
lassign $viewbox x y w h |
||||
foreach fullname [array names icache] { |
||||
if {[scan $fullname {%[^,],%d,%g,%s} name size opacity color] == 4 |
||||
&& $size > 0} { |
||||
set size [expr {$dpi * $size / 72.0}] |
||||
set scale [expr {1.0 * $size / $w}] |
||||
if {[catch {::image inuse $icache($fullname)}]} { |
||||
set this [::image create photo \ |
||||
-format [list svg -scale $scale] \ |
||||
-data [svg $name $color $opacity]] |
||||
set icache($fullname) $this |
||||
} else { |
||||
$icache($fullname) configure -width 1 -height 1 |
||||
$icache($fullname) configure -width 0 -height 0 |
||||
$icache($fullname) configure \ |
||||
-format [list svg -scale $scale] |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Convert a display size including optional unit to pixels. |
||||
# Valid unit suffixes are d (density points), p (points), |
||||
# and m (millimeters), and without unit suffix, pixels. |
||||
|
||||
proc val2px {val} { |
||||
set dval "" |
||||
if {[scan $val "%g" dval] == 1} { |
||||
if {[string match "*d" $val]} { |
||||
set val [expr {[tk scaling] * 72.0 / 160.0 * $dval}] |
||||
} elseif {[string match "*p" $val]} { |
||||
set val [expr {[tk scaling] * $dval}] |
||||
} elseif {[string match "*m" $val]} { |
||||
set val [expr {[tk scaling] * 72.0 / 25.4 * $dval}] |
||||
} |
||||
} |
||||
if {![string is double $val]} { |
||||
return -code error "expect number for size" |
||||
} elseif {$val < 0} { |
||||
set val [expr {-1.0 * $val}] |
||||
} |
||||
return $val |
||||
} |
||||
|
||||
# Like the "image_nc" method but accepting many options: |
||||
# name glyph name to be rendered |
||||
# imgname name of photo image |
||||
# -size S size with optional unit suffix |
||||
# -fill C fill color |
||||
# -opacity O fill opacity |
||||
# -stroke C stroke color |
||||
# -strokewidth S stroke width with optional unit suffix |
||||
# -angle A angle in degrees |
||||
|
||||
proc image_ncg {name imgname args} { |
||||
variable viewbox |
||||
array set opts { |
||||
-size 24d -fill black -opacity 1.0 -stroke none |
||||
-strokewidth 1.0 -angle 0 |
||||
} |
||||
array set opts $args |
||||
lassign $viewbox x y w h |
||||
set size [val2px $opts(-size)] |
||||
if {$size == 0} { |
||||
return -code error "invalid size" |
||||
} |
||||
set scale [expr {1.0 * $size / $w}] |
||||
# if stroke width has units or is negative, don't scale it |
||||
if {![string is double -strict $opts(-strokewidth)] || |
||||
$opts(-strokewidth) < 0} { |
||||
# reverse the scale |
||||
set opts(-strokewidth) \ |
||||
[expr {abs([val2px $opts(-strokewidth)] / $scale)}] |
||||
} |
||||
tailcall ::image create photo $imgname \ |
||||
-format [list svg -scale $scale] \ |
||||
-data [svg $name $opts(-fill) $opts(-opacity) $opts(-stroke) \ |
||||
$opts(-strokewidth) $opts(-angle)] |
||||
} |
||||
|
||||
# Make some procs visible in MaterialIcons ensemble. |
||||
|
||||
namespace ensemble create -subcommands { |
||||
names svg image image_nc flush rebuild image_ncg |
||||
} |
||||
|
||||
} |
||||
|
||||
package provide MaterialIcons 0.2 |
||||
@ -0,0 +1,2 @@
|
||||
package ifneeded MaterialIcons 0.2 \ |
||||
[list source [file join $dir materialicons.tcl]] |
||||
@ -0,0 +1,109 @@
|
||||
# Simple viewer for MaterialIcons package. |
||||
# |
||||
# chw January 2019 |
||||
# search facility: dzach May 2019 |
||||
|
||||
package require Tk |
||||
package require MaterialIcons |
||||
package require tooltip |
||||
|
||||
wm title . "MaterialIcons" |
||||
|
||||
proc showname {flag} { |
||||
if {$flag} { |
||||
set ::name [lindex [.v gettags current] 1] |
||||
} else { |
||||
set ::name "" |
||||
} |
||||
} |
||||
|
||||
proc putclipboard {} { |
||||
if {$::name eq ""} { |
||||
return |
||||
} |
||||
clipboard clear |
||||
clipboard append -type STRING -- $::name |
||||
} |
||||
|
||||
proc showicons {{isconf 0}} { |
||||
if {![winfo exists .v]} { |
||||
set ::pattern * |
||||
frame .f |
||||
label .f.s -text "Search: " |
||||
entry .f.e -textvariable ::pattern -width 30 |
||||
pack .f.s .f.e -side left |
||||
grid .f -row 0 -column 0 -padx 4 -pady 4 -columnspan 2 -sticky w |
||||
canvas .v -yscrollcommand {.y set} -xscrollcommand {.x set} -bg white |
||||
grid .v -row 1 -column 0 -sticky news |
||||
ttk::scrollbar .y -orient vertical -command {.v yview} |
||||
grid .y -row 1 -column 1 -sticky ns |
||||
ttk::scrollbar .x -orient horizontal -command {.v xview} |
||||
grid .x -row 2 -column 0 -sticky ew |
||||
label .l -textvariable name |
||||
grid .l -row 3 -column 0 -sticky ew |
||||
grid rowconfigure . 1 -weight 1 |
||||
grid columnconfigure . 0 -weight 1 |
||||
bind .f.e <Return> {showicons ; break} |
||||
bind .f.e <KP_Enter> {showicons ; break} |
||||
bind . <Configure> { |
||||
after cancel {showicons 1} |
||||
after idle {showicons 1} |
||||
break |
||||
} |
||||
.f.e icursor end |
||||
.v bind _icons <Enter> {showname 1} |
||||
.v bind _icons <Leave> {showname 0} |
||||
.v bind _icons <1> putclipboard |
||||
} else { |
||||
if {$isconf && |
||||
[winfo width .] == $::dim(w) && |
||||
[winfo height .] == $::dim(h)} { |
||||
return |
||||
} |
||||
.v delete all |
||||
tooltip::tooltip .v -items {} {} |
||||
} |
||||
|
||||
set ::name "" |
||||
set x 20 |
||||
set y 20 |
||||
set xmax [winfo width .] |
||||
if {$xmax == 1} { |
||||
set ::dim(w) [winfo reqwidth .] |
||||
set ::dim(h) [winfo reqheight .] |
||||
set xmax [expr {[winfo reqwidth .v] + [winfo reqwidth .y]}] |
||||
} else { |
||||
set ::dim(w) [winfo width .] |
||||
set ::dim(h) [winfo height .] |
||||
} |
||||
set xmax [expr {$xmax - 64}] |
||||
if {$xmax < 200} { |
||||
set xmax 200 |
||||
} |
||||
|
||||
foreach n [MaterialIcons names $::pattern] { |
||||
set i [MaterialIcons image $n 20] |
||||
set c [.v create image $x $y -anchor nw -image $i \ |
||||
-tags [list _icons $n]] |
||||
lassign [.v bbox $c] x1 y1 x2 y2 |
||||
if {$x1 > $xmax} { |
||||
set y [expr {$y2 + 10}] |
||||
set x 20 |
||||
.v coords $c $x $y |
||||
lassign [.v bbox $c] x1 y1 x2 y2 |
||||
} |
||||
set x [expr {$x2 + 10}] |
||||
tooltip::tooltip .v -items $c $n |
||||
} |
||||
|
||||
set bbox [.v bbox _icons] |
||||
if {[llength $bbox]} { |
||||
lassign [.v bbox _icons] x1 y1 x2 y2 |
||||
.v configure -scrollregion [list [expr {$x1 - 20}] [expr {$y1 - 20}] \ |
||||
[expr {$x2 + 20}] [expr {$y2 + 20}]] |
||||
} else { |
||||
.v configure -scrollregion {} |
||||
} |
||||
} |
||||
|
||||
showicons |
||||
@ -0,0 +1,29 @@
|
||||
This is the copyright notice and license for pgin.tcl. |
||||
The wording is from the Tcl and Tcllib licenses, and is |
||||
essentially equivalent to the Berkeley/BSD license. |
||||
----------------------------------------------------------------------- |
||||
This software is Copyright (c) 1998-2017 L Bayuk |
||||
|
||||
The authors hereby grant permission to use, copy, modify, distribute, |
||||
and license this software and its documentation for any purpose, provided |
||||
that existing copyright notices are retained in all copies and that this |
||||
notice is included verbatim in any distributions. No written agreement, |
||||
license, or royalty fee is required for any of the authorized uses. |
||||
Modifications to this software may be copyrighted by their authors |
||||
and need not follow the licensing terms described here, provided that |
||||
the new terms are clearly indicated on the first page of each file where |
||||
they apply. |
||||
|
||||
IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY |
||||
FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES |
||||
ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY |
||||
DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE |
||||
POSSIBILITY OF SUCH DAMAGE. |
||||
|
||||
THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, |
||||
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, |
||||
FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE |
||||
IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE |
||||
NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR |
||||
MODIFICATIONS. |
||||
----------------------------------------------------------------------------- |
||||
@ -0,0 +1,456 @@
|
||||
This is pgintcl/INTERNALS, notes on internal implementation of pgintcl. |
||||
Last updated for pgintcl-3.4.0 on 2011-09-19 |
||||
The project home page is: http://sourceforge.net/projects/pgintcl/ |
||||
----------------------------------------------------------------------------- |
||||
INTERNAL IMPLEMENTATION NOTES: |
||||
|
||||
This information is provided for maintenance, test, and debugging. |
||||
|
||||
A connection handle is just a Tcl socket channel. The application using |
||||
pgin.tcl must not read from or write to this channel. |
||||
|
||||
Internal procedures, result structures, and other data are stored in a |
||||
namespace called "pgtcl". The following namespace variables apply to |
||||
all connections: |
||||
|
||||
pgtcl::debug A debug flag, default 0 (no debugging) |
||||
pgtcl::version pgin.tcl version string |
||||
pgtcl::rn Result number counter |
||||
pgtcl::fnoids Function OID cache; see FAST-PATH FUNCTION CALLS |
||||
pgtcl::errnames Constant array of error message field names |
||||
|
||||
The following arrays are indexed by connection handle, and contain data |
||||
applying only to that connection: |
||||
|
||||
pgtcl::notice() Command to execute when receiving a Notice |
||||
pgtcl::xstate() Transaction state |
||||
pgtcl::notify() Notifications; see NOTIFICATIONS |
||||
pgtcl::notifopt() Notification optionss; see NOTIFICATION |
||||
pgtcl::std_str() For pg_escape_string etc; see ESCAPING |
||||
pgtcl::bepid() Backend process ID (PID) |
||||
|
||||
Additional namespace variables are described in the sections below. |
||||
Result structure variables are described next. |
||||
|
||||
----------------------------------------------------------------------------- |
||||
RESULT STRUCTURES: |
||||
|
||||
A result structure is implemented as a variable result$N in the pgtcl |
||||
namespace, where N is an integer. (The value of N is stored in pgtcl::rn |
||||
and is incremented each time a new result structure is needed.) The result |
||||
handle is passed back to the caller as $N, just the integer. The result |
||||
structure is an array which stores all the meta-information about the |
||||
result as well as the result values. |
||||
|
||||
The result structure array indexes in use are: |
||||
|
||||
Variables describing the overall result: |
||||
result(conn) The connection handle (the socket channel) |
||||
result(nattr) Number of attributes (columns) |
||||
result(ntuple) Number of tuples (rows) |
||||
result(status) PostgreSQL status code, e.g. PGRES_TUPLES_OK |
||||
result(error) Error message if status is PGRES_FATAL_ERROR |
||||
result(complete) Command completion status, e.g. "SELECT 10" |
||||
result(error,C) Error message field C if status is PGRES_FATAL_ERROR. |
||||
C is one of the codes for extended error message fields. |
||||
|
||||
Variables describing the attributes (columns) in the result: |
||||
result(attrs) A list of the name of each attribute |
||||
result(types) A list of the type OID for each attribute |
||||
result(sizes) A list of attribute byte lengths or -1 if variable |
||||
result(modifs) A list of the size modifier for each attributes |
||||
result(formats) A list of the data format for each attributes |
||||
result(tbloids) A list of the table OIDs for each attribute |
||||
|
||||
Variables describing prepared query parameters in the result: |
||||
result(nparams) The number of prepared statement parameters |
||||
result(paramtypes) List of prepared statement parameter type OIDs |
||||
|
||||
Variables storing the query result values: |
||||
result($irow,$icol) Data value for result |
||||
result(null,$irow,$icol) NULL flag for result |
||||
|
||||
The pg_exec and pg_exec_prepared commands create and return a new result |
||||
structure. The pg_result command retrieves information from the result |
||||
structure and also frees the result structure with the -clear option. |
||||
(Other commands, notably pg_select and pg_execute, use pg_exec, so they |
||||
also make a result structure, but it stays internal to the command and the |
||||
caller never sees it.) The result structure innards are also directly |
||||
accessed by some other routines, such as pg_select and pg_execute. Result |
||||
structure arrays are unset (freed) by pg_result -clear, and any left-over |
||||
result structures associated with a connection handle are freed when the |
||||
connection handle is closed by pg_disconnect. |
||||
|
||||
The query result values are stored in result($irow,$icol) where $irow is |
||||
the tuple (row) number, between 0 and $result(ntuples)-1 inclusive, and |
||||
$icol is the attribute (column) number, between 0 and $result(nattr)-1 |
||||
inclusive. If the value returned by the database is NULL, then |
||||
$result($irow,$icol) is set to an empty string, and |
||||
$result(null,$irow,$icol) is also set to an empty string for this row and |
||||
column. For non-NULL values, $result(null,$irow,$icol) is not set at all. |
||||
The "null,*,*" indexes are used only by pg_result -getNull if it is |
||||
necessary for the application to distinguish NULL from empty string - both |
||||
of which are stored as empty strings in result($irow,$icol) and return an |
||||
empty string with any of the pg_result access methods. There is no way to |
||||
distinguish NULL from empty string with pg_select, pg_execute, or |
||||
pg_exec_prepared. |
||||
|
||||
The entire result of a query is stored before anything else happens (that |
||||
is, before pg_exec and pg_exec_prepared return, and before pg_execute and |
||||
pg_select process the first row). This is also true of libpq and pgtcl-ng |
||||
(in their synchronous mode), but Tcl can be slower. |
||||
|
||||
Extended error message fields are new with PostgreSQL-7.4. Individual parts |
||||
of a received error message are stored in the result array indexed by |
||||
(error,$c) where $c is the one-letter code used in the protocol. See the |
||||
pgin.tcl documentation for "pg_result -errorField" for more information. |
||||
(As of 2.2.0, pg_result -errorField is the same as pg_result -error: both |
||||
take an optional field name or code argument to return an extended error |
||||
message field, rather than the full message.) |
||||
|
||||
----------------------------------------------------------------------------- |
||||
BUFFERING |
||||
|
||||
PostgreSQL protocol version 3 (PostgreSQL-7.4) uses a message-based |
||||
protocol. To read messages from the backend, pgin.tcl implements a |
||||
per-connection buffer using several Tcl variables in the pgtcl namespace. |
||||
The name of the connection handle (the socket name) is part of the variable |
||||
name, represented by $c below. |
||||
|
||||
pgtcl::buf_$c The buffer holding a message from the backend. |
||||
pgtcl::bufi_$c Index of the next byte to be processed from buf_$c |
||||
pgtcl::bufn_$c Total number of bytes in the buffer buf_$c. |
||||
|
||||
For example, if the connection handle is "sock3", the variables are |
||||
pgtcl::buf_sock3, pgtcl::bufi_sock3, and pgtcl::bufn_sock3. |
||||
|
||||
A few tests determined that the fastest way to fetch data from the buffers |
||||
in Tcl was to use [string index] and [string range], although this might |
||||
not seem intuitive. |
||||
|
||||
----------------------------------------------------------------------------- |
||||
PARAMETERS |
||||
|
||||
The PostgreSQL backend can notify a front-end client about some parameters, |
||||
and pgin.tcl stores these in the following variable in the pgtcl namespace: |
||||
|
||||
pgtcl::param_$c Array of parameter values, indexed by parameter name |
||||
|
||||
where $c is the connection handle (socket name). |
||||
|
||||
Access to these parameters is through the pg_parameter_status command, |
||||
a pgin.tcl extension. |
||||
|
||||
----------------------------------------------------------------------------- |
||||
PROTOCOL ISSUES |
||||
|
||||
This version of pgin.tcl speaks only to a Protocol Version 3 PostgreSQL |
||||
backend (7.4 or later). There is one concession made to Version 2, and |
||||
that is reading an error message. If a Version 2 error message is read, |
||||
pgin.tcl will recognize it and pretend it got a Version 3 message. This |
||||
is for use during the connection stage, to allow it to fail with a |
||||
proper message if connecting to a Version 2-only backend. |
||||
|
||||
----------------------------------------------------------------------------- |
||||
NOTIFICATIONS |
||||
|
||||
An array pgtcl::notify keeps track of notifications you want. The array is |
||||
indexed as pgtcl::notify(connection,name) where connection is the |
||||
connection handle (socket name) and name is the parameter used in |
||||
pg_listen. The value of an array element is the command to execute on |
||||
notification. This can be a procedure name, or a procedure name with |
||||
leading arguments. It must be a proper Tcl list. |
||||
|
||||
Starting with PostgreSQL-9.0.0, a 'payload' string can be provided with the |
||||
SQL NOTIFY command. Starting with pgin.tcl-3.2.0, this payload (if not empty) |
||||
will be passed as an additional argument to the command. The command is taken |
||||
as a list, and the payload is appended as in lappend. The resulting list is |
||||
the command to execute. If there is no payload, or it is empty, or the server |
||||
is older than PostgreSQL-9.0.0, no additional argument will be passed to the |
||||
command. The command should therefore always accept an optional argument. |
||||
|
||||
Starting with pgintcl-3.4.0, there is an additional array pgtcl::notifopt() |
||||
to store options for the notification. This array is indexed the same way |
||||
as pgtcl::notif(), and holds integer values. The value is 0 if there are no |
||||
options for this notification. The value is 1 if the notification listener |
||||
should get the notifying backend process ID as an argument, as indicated by |
||||
the -pid option to pg_listen. No other options are defined. |
||||
|
||||
----------------------------------------------------------------------------- |
||||
NOTICES |
||||
|
||||
Notice and warning message handling can be customized using the |
||||
pg_notice_handler command. By default, the notice handler is |
||||
puts -nonewline stderr |
||||
and this string will be returned the first time pg_notice_handler is |
||||
called. A notice handler should be defined as a proc with one or more |
||||
arguments. Leading arguments are supplied when the handler is set with |
||||
pg_notice_handler, and the final argument is the notice or warning message. |
||||
|
||||
----------------------------------------------------------------------------- |
||||
LARGE OBJECTS |
||||
|
||||
The large object commands are implemented using the PostgreSQL "fast-path" |
||||
function call interface (same as libpq). See the next section for more |
||||
information on fast-path. |
||||
|
||||
The pg_lo_creat command takes a mode argument. According to the PostgreSQL |
||||
libpq documentation, lo_creat should take "INV_READ", "INV_WRITE", or |
||||
"INV_READ|INV_WRITE". (pgin.tcl accepts "r", "w", and "rw" as equivalent |
||||
to those respectively, but this is not compatible with pgtcl-ng.) It isn't |
||||
clear why you would ever create a large object with other than |
||||
"INV_READ|INV_WRITE". |
||||
|
||||
The pg_lo_open command also takes a mode argument. According to the |
||||
PostgreSQL libpq documentation, lo_open takes the same mode values as |
||||
lo_creat. But in libpgtcl the pg_lo_open command takes "r", "w", or "rw" |
||||
for the mode, for some reason. pgin.tcl accepts either form for mode, |
||||
but to be compatible with libpgtcl you should use "r", "w", or "rw" |
||||
with pg_lo_open instead of INV_READ, INV_WRITE, or INV_READ|INV_WRITE. |
||||
|
||||
|
||||
----------------------------------------------------------------------------- |
||||
FAST-PATH FUNCTION CALLS |
||||
|
||||
Access to the PostgreSQL "Fast-path function call" interface is available |
||||
in pgin.tcl. This was written to implement the large object command, and |
||||
general use is discouraged. See the libpq documentation for more details on |
||||
what this interface is and how to use it. |
||||
|
||||
It is expected that the Fast-path function call interface in PostgreSQL |
||||
will be deprecated in favor of using the Extended Protocol to do |
||||
separate Prepare, Bind, and Execute steps. See PREPARE/BIND/EXECUTE. |
||||
|
||||
Internally, backend functions are called by their PostgreSQL OID, but |
||||
pgin.tcl handles the mapping of function name to OID for you. The |
||||
fast-path function interface in pgin.tcl uses an array pgtcl::fnoids to |
||||
cache object IDs of the PostgreSQL functions. One instance of this array |
||||
is shared among all connections, under the assumption that these OIDs are |
||||
common to all databases. (It is possible that if you have simultaneous |
||||
connections to multiple database servers running different versions of |
||||
PostgreSQL this could break.) The index to pgtcl::fnoids is the name |
||||
of the function, or the function plus argument type list, as supplied |
||||
to the pgin.tcl fast-path function call commands. The value of each |
||||
array index is the OID of the function. |
||||
|
||||
PostgreSQL supports overloaded functions (same name, different number |
||||
and/or argument types). You can call overloaded functions with pgin.tcl by |
||||
specifying the argument type list after the function name. See examples |
||||
below. You must specify the argument list exactly like psql "\df" does - as |
||||
a list of correct type names, separated by a single comma and space. There |
||||
is currently no provision to distinguish functions by their return type. It |
||||
doesn't seem like there are any PostgreSQL functions which differ only by |
||||
return type. |
||||
|
||||
Before PostgreSQL-7.4, certain errors in fast-path calls (such as supplying |
||||
the wrong number of arguments to the backend function) would cause the |
||||
back-end and front-end to lose synchronization, and the channel would be |
||||
closed. This was true about libpq as well. This has been fixed with the |
||||
new protocol in PostgreSQL-7.4. |
||||
|
||||
|
||||
Commands: |
||||
|
||||
pg_callfn $db "fname" result "arginfo" arg... |
||||
|
||||
Call a PostgreSQL backend function and store the result. |
||||
Returns the size of the result in bytes. |
||||
|
||||
Parameters: |
||||
|
||||
$db is the connection handle. |
||||
|
||||
"fname" is the PostgreSQL function name. This is either a simple |
||||
name, like "encode", or a name followed by a parenthesized |
||||
argument type list, like "like(text, text)". The second form |
||||
is needed to specify which of several overloaded functions you want |
||||
to call. |
||||
|
||||
"result" is the name of a variable where the PostgreSQL backend |
||||
function returned value is to be stored. The number of bytes |
||||
stored in "result" is returned as the value of pg_callfn. |
||||
|
||||
"arginfo" is a list of argument descriptors. Each list element is |
||||
one of the following: |
||||
I An integer32 argument is expected. |
||||
S A Tcl string argument is expected. The length of the |
||||
string is used (remember Tcl strings can contain null bytes). |
||||
n (an integer > 0) |
||||
A Tcl string argument is expected, and exactly this many |
||||
bytes of the string argument are passed (padding with null |
||||
bytes if needed). |
||||
|
||||
arg... Zero or more arguments to the PostgreSQL function follow. |
||||
The number of arguments must match the number of elements |
||||
in the "arginfo" list. The values are passed to the backend |
||||
function according to the corresponding descriptor in |
||||
"arginfo". |
||||
|
||||
For PostgreSQL backend functions which return a single integer32 argument, |
||||
the following simplified interface is available: |
||||
|
||||
pg_callfn_int $db "fname" "arginfo" arg... |
||||
|
||||
The db, fname, arginfo, and other arguments are the same as |
||||
for pg_callfn. The return value from pg_callfn_int is the |
||||
integer32 value returned by the PostgreSQL backend function. |
||||
|
||||
Examples: |
||||
Note: These examples demonstrate the command, but in both of these |
||||
cases you would be better off using an SQL query instead. |
||||
|
||||
set n [pg_callfn $db version result ""] |
||||
This calls the backend function version() and stores the return |
||||
value in $result and the result length in $n. |
||||
|
||||
pg_callfn $db encode result {S S} $str base64 |
||||
This calls the backend function encode($str, "base64") with 2 |
||||
string arguments and stores the result in $result. |
||||
|
||||
pg_callfn_int $db length(text) S "This is a test" |
||||
This calls the backend function length("This is a test"). Because |
||||
there are multiple functions called length(), the argument type |
||||
list "(text)" must be given after the function name. The length |
||||
of the string (14) is returned by the function. |
||||
|
||||
----------------------------------------------------------------------------- |
||||
PREPARE/BIND/EXECUTE |
||||
|
||||
Starting with PostgreSQL-7.4, access to separate Parse, Bind, and Execute |
||||
steps are provided by the protocol. The Parse step can be replaced by an |
||||
SQL PREPARE command. pgin.tcl provides support for this extended query |
||||
protocol with pg_exec_prepared (introduced in pgin.tcl-2.0.0), and |
||||
pg_exec_params (introduced in pgin.tcl-2.1.0). There is also a variation of |
||||
pg_exec which provides a simplified interface to pg_exec_params. |
||||
|
||||
The main advantage of the extended query protocol is separation of |
||||
parameters from the query text string. This avoids the need to quote and |
||||
escape parameters, and may prevent SQL injection attacks. pg_exec_prepared |
||||
also offers some performance advantages if a query can be prepared, parsed, |
||||
and stored once and then execute multiple times without re-parsing. |
||||
|
||||
In addition to working with text parameters and results, the |
||||
pg_exec_prepared and pg_exec_params commands support sending unescaped |
||||
binary data to the server. (Fast-path function calls also support this.) |
||||
These commands also support returning binary data to the client. (This can |
||||
also be done with binary cursors.) Although the protocol definition and |
||||
pgin.tcl commands support mixed text and binary results, libpq requires all |
||||
result columns to be text, or all binary. Using mixed binary/text result |
||||
columns will make your application incompatible with libpq-based versions |
||||
of this interface. |
||||
|
||||
pg_exec_prepared is for execution of pre-prepared SQL statements after |
||||
binding parameters. A named SQL statement must be prepared using the SQL |
||||
"PREPARE" command before using pg_exec_prepared. An advantage of |
||||
pg_exec_prepared is that the protocol-level Parse step requires the client |
||||
to translate parameter types to OIDs, but using PREPARE lets the server |
||||
determine the parameter argument types. pg_exec_prepared is modeled after |
||||
the Libpq call: PQexecPrepared(). |
||||
|
||||
pg_exec_params does all three steps of the extended query protocol: parse, |
||||
bind, and execute. Parameter types can be specified by type OID, or parameters |
||||
can be based as text to be interpreted by the server as it does for any |
||||
untyped literal string. To find the type OID of a PostgreSQL type '<T>', |
||||
you need to query the server like this: |
||||
SELECT oid FROM pg_type where typname='<T>' |
||||
pg_exec_params is modeled after the Libpq call: PQexecParams(). |
||||
|
||||
A limitation of both pg_exec_prepared and pg_exec_params is lack of support |
||||
for NULLs as parameter values. There is no way to pass a NULL parameter to |
||||
the prepared statement. This is not a protocol or database limitation, but |
||||
just lack of a good idea on how to implement the command interface to |
||||
support NULLs without needlessly complication the more common case without |
||||
NULLs. |
||||
|
||||
|
||||
----------------------------------------------------------------------------- |
||||
MD5 AUTHENTICATION |
||||
|
||||
MD5 authentication was added at PostgreSQL-7.2. This is a |
||||
challenge/response protocol which avoids having clear-text passwords passed |
||||
over the network. To activate this, the PostgreSQL administrator puts "md5" |
||||
in the pg_hba.conf file instead of "password". Pgin.tcl supports this |
||||
transparently; that is, if the backend requests MD5 authentication during |
||||
the connection, pg_connect will use this protocol. The MD5 implementation |
||||
was coded by the original author of pgin.tcl. It does not use the tcllib |
||||
implementation, which is significantly faster but much more complex. |
||||
|
||||
----------------------------------------------------------------------------- |
||||
ENCODING |
||||
|
||||
Character set encoding was added to pgin.tcl-3.0.0. More information can be |
||||
found in the README and REFERENCE files. |
||||
|
||||
The following are converted to Unicode before being sent to PostgreSQL: |
||||
|
||||
+ Query strings (pg_exec, and all higher-level commands which use it) |
||||
+ TEXT-format query parameters in pg_exec_prepared/pg_exec_params |
||||
+ All parameter arguments in pg_exec when query parameters are used |
||||
+ Prepared statement name in pg_exec_prepared |
||||
+ COPY table FROM STDIN data sent using pg_copy_write |
||||
|
||||
The following are converted from Unicode when received from PostgreSQL: |
||||
|
||||
+ Query result column data when TEXT-format (not when BINARY-format) |
||||
+ All Error and Notice response strings |
||||
+ Parameter names and values |
||||
+ Notification messages |
||||
+ Command completion message |
||||
+ Query result field names (column names) |
||||
+ COPY table TO STDOUT data received using pg_copy_read |
||||
|
||||
Conversion of data to Unicode for sending to PostgreSQL occurs in 5 places |
||||
in the code: pg_exec and pg_exec_params query strings, pg_exec_prepared |
||||
statement name, pg_exec_prepared text format parameters, and when writing |
||||
COPY FROM data in pg_copy_write. |
||||
|
||||
Conversion of Unicode data from PostgreSQL occurs in 3 places in the code: |
||||
when receiving a protocol message "string" type (which covers various |
||||
messages, parameters, and field names), when reading TEXT mode tuple data, |
||||
and when reading COPY TO data in pg_copy_read. |
||||
|
||||
There is no Unicode conversion for the connection parameters username, |
||||
database-name, or password. PostgreSQL seems to store these using the |
||||
encoding of the database cluster/template1 database, which may differ from |
||||
the encoding of the database to which the client is connected. It is |
||||
unclear how to recode these characters. At this time, it is wise to avoid |
||||
non-ASCII characters in database names, usernames, and passwords. This may |
||||
be fixed in the future. |
||||
|
||||
The fast-path function call interface treats all its arguments as binary |
||||
data and does not encode or decode them. The fast-path function calls |
||||
were implemented primarily for large object support, and large object |
||||
support is not affected by Unicode encoding because it is all binary |
||||
data. It is unlikely that encoding support will be added to fast-path |
||||
function calls, since parameterized queries are the preferred replacement. |
||||
|
||||
----------------------------------------------------------------------------- |
||||
ESCAPING |
||||
|
||||
An array pgtcl::std_str() is used to store the per-connection setting for |
||||
the PostgreSQL setting standard_conforming_strings. This was added in |
||||
Pgin.tcl-3.1.0 to support the versions of pg_escape_string, pg_quote, and |
||||
pg_escape_bytea which accept an optional $conn argument. |
||||
|
||||
If the array value indexed by $conn is 1, then standard conforming strings |
||||
is on for that database connection, and the backslash (\) is not considered |
||||
special in SQL quoted string constants. In this case, pg_escape_string and |
||||
pg_quote will not double backslashes. pg_escape_bytea will omit one level |
||||
of backslashes when escaping backslash and octal values. |
||||
|
||||
If the array value indexed by $conn is 0, then standard conforming strings |
||||
is off for that database and connection, and the backslash (\) is special |
||||
in SQL quoted string constants. In that case, pg_escape_string and pg_quote |
||||
will double backslashes. pg_escape_bytea will use 4 backslashes for a single |
||||
backslash, and 2 backslashes in an octal value. |
||||
|
||||
There is also an array index "_default_" which is used when no $conn |
||||
argument is supplied to the escape commands. Just as in libpq, the |
||||
_default_ value is set any time a Set Parameter message for |
||||
standard_conforming_strings is received over any open database connection. |
||||
If you are using a single connection, or multiple connections with the same |
||||
value for standard_conforming_strings, you will get correct escaping |
||||
behavior even without using the $conn argument when escaping strings. |
||||
|
||||
|
||||
----------------------------------------------------------------------------- |
||||
@ -0,0 +1,423 @@
|
||||
This is pgintcl/NEWS, release notes and change information for pgintcl. |
||||
The project home page is: http://sourceforge.net/projects/pgintcl/ |
||||
----------------------------------------------------------------------------- |
||||
|
||||
* 2017-11-12 Released version 3.5.1 |
||||
|
||||
This version contains a small fix for PostgreSQL-10.x. |
||||
|
||||
+ The pg_server_version command now works with the new 2-part version |
||||
numbers used starting with PostgreSQL-10.0, as well as with the 3-part |
||||
version numbers in older releases. Note that the PostgreSQL-10.1 version |
||||
number as an integer is 100001, not 100100. See the PostgreSQL-10.x libpq |
||||
documentation for PQserverVersion for an explanation. |
||||
|
||||
* 2013-10-06 Released version 3.5.0 |
||||
|
||||
This version adds 5 new commands, new pg_connect options, and new error |
||||
field codes for pg_result. |
||||
|
||||
+ New commands pg_escape_literal, which is an alternative to pg_quote, and |
||||
pg_escape_identifier, for escaping SQL identifiers. [Feature Request #5] |
||||
|
||||
+ New connection options are available in pg_connect. This command now |
||||
supports a "-connlist {list}" form for option parameters. (The syntax |
||||
is from Flightaware Pgtcl, but the implementation is new, and not |
||||
completely compatible.) The advantage of using this form is that |
||||
it does not require quoting or escaping, especially for the password. |
||||
|
||||
Also, pg_connect now accepts a URI for a connection string, as described |
||||
in the PostgreSQL manual, for example: |
||||
pg_connect -conninfo postgresql://myuser:secretd@host.example.com/dbname |
||||
Note: pgintcl does not support options in URI connection strings. |
||||
[Feature Request #3] |
||||
|
||||
+ New commands for 64-bit Large Object offsets: pg_lo_lseek64, |
||||
pg_lo_tell64, and pg_lo_truncate64. These only work when connected to |
||||
a PostgreSQL-9.3.0 or higher server. [Feature Request #2] |
||||
|
||||
+ pg_result -error and -errorField now support 5 new field codes, which |
||||
were added in PostgreSQL-9.3.0 (and only return data when connected to |
||||
a PostgreSQL-9.3.0 or higher server). These provide access to the |
||||
schema, table, column, and constraint name. [Feature Request #4] |
||||
|
||||
Compatibility Warning: |
||||
|
||||
PostgreSQL-9.2.0 started using lower case letters as the value of the |
||||
new PG_DIAG_* symbols. This conflicts with case insensitive field codes |
||||
in previous versions of pgintcl. Starting with pgintcl-3.5.0, field code |
||||
single-character abbreviations are now case sensitive. This will require |
||||
changes to scripts, if they used single-character lower case letters |
||||
as field codes. The full field code names remain case insensitive. |
||||
For example: |
||||
Both of these worked before, and continue to work: |
||||
pg_result $res -errorField SEVERITY |
||||
pg_result $res -errorField severity |
||||
The single-character code for SEVERITY is 'S'. Starting with this |
||||
release, an upper case 'S' must be used, as 's' is now used for |
||||
SCHEMA_NAME. |
||||
pg_result $res -errorField s |
||||
Returned the error severity in previous releases. |
||||
Returns the error object schema name in this release. |
||||
|
||||
|
||||
This release was tested with Tcl-8.6.0 and PostgreSQL-9.3.0, as well as |
||||
several older versions. |
||||
|
||||
|
||||
* 2011-09-17 Released version 3.4.0 |
||||
|
||||
This version adds 2 new commands and 1 new command option, and fixes 1 bug. |
||||
+ New command pg_backend_pid to get the backend process ID. |
||||
+ New command pg_server_version to get the server version as an intger. |
||||
+ New -pid option to pg_listen, to pass the notifying client's backend |
||||
process ID to the notification callback. |
||||
+ Bug fix: fold the notification name in pg_listen (also called channel name) |
||||
to lower case, unless it is in double quotes (which are stripped off). |
||||
This now works the same as SQL and pgtclng, but is not compatible with |
||||
previous releases of pgintcl if pg_listen was used with a mixed-case or |
||||
quoted name. For maximum compatibility, use unquoted lower case names in |
||||
notifications, both with SQL and pgintcl. |
||||
|
||||
In addition to Tcl-8.4.x and Tcl-8.5.x, pgin.tcl was tested with Tcl-8.6 |
||||
(which is currently in beta). It was also tested with the just-released |
||||
PostgreSQL-9.1 |
||||
|
||||
|
||||
* 2011-03-21 Released version 3.3.0 |
||||
|
||||
This version adds one new feature: pg_result $r -dict, which returns the |
||||
query result as a Tcl dictionary. The idea for this feature came from |
||||
the pgfoundry.org 'pgtcl' project. This feature requires Tcl-8.5 or higher. |
||||
|
||||
pgin.tcl now requires Tcl-8.4 or higher. Previous versions claimed to |
||||
require Tcl-8.3 or higher, but were no longer tested with Tcl-8.3. |
||||
|
||||
|
||||
* 2010-10-11 Released version 3.2.1 |
||||
|
||||
This version fixes bug #1010929, "pg_unescape_bytea fails with |
||||
PostgreSQL-9.0". pg_unescape_bytea now handles 'hex' mode decoding, as well |
||||
as 'escape' mode, for bytea types. It no longer fails to decode a bytea |
||||
value selected from a PostgreSQL-9.0 server which has the default |
||||
bytea_output=hex configuration setting. |
||||
|
||||
Note: Pgintcl-3.2.0 was withdrawn soon after release because of this |
||||
problem, although 3.2.0 did not introduce the problem. The problem exists |
||||
with all releases of all interfaces, and is caused by PostgreSQL-9.0 |
||||
defaulting to the new "hex" mode encoding in bytea type output. This is |
||||
incompatible with all interfaces designed pre-9.0. So the same problem |
||||
exists with all previous versions of Pgintcl, as well as any libpq-based |
||||
interface built with pre-9.0 libpq. However, since pgintcl-3.2.0 was |
||||
supposed to be a release for use with PostgreSQL-9.0, it was felt that |
||||
this problem needed to be fixed before allowing a release. |
||||
|
||||
|
||||
* 2010-10-10 Released version 3.2.0 (Note: release withdrawn - see note above.) |
||||
|
||||
This version has one new feature and one change for PostgreSQL-9.0.0: |
||||
|
||||
+ Notification messages can now include a payload, which is passed to |
||||
the notification listener callback proc. For example: |
||||
Given (in one session): |
||||
pg_listen $db my_channel my_callback_proc |
||||
|
||||
Then (possibly in another session): |
||||
SQL> NOTIFY my_channel, 'the payload' |
||||
This will result in execution of: my_callback_proc "the payload" |
||||
in the original session. |
||||
|
||||
And: |
||||
SQL> NOTIFY my_channel |
||||
or: SQL> NOTIFY my_channel, '' |
||||
This will result in execution of: my_callback_proc |
||||
in the original session. |
||||
|
||||
Compatibility Warning: |
||||
This applies only if you use pg_listen to set up a notification listener |
||||
callback procedure. |
||||
|
||||
Your listener callback should be defined to accept an optional argument |
||||
for the payload, for example: proc listen_handler {{payload ""}} { ... } |
||||
Starting with version 3.2.0, pgin.tcl will pass a payload argument to the |
||||
handler if a non-empty payload is provided in the SQL command. If an empty |
||||
payload is provided, or no payload (including any usage with a PostgreSQL |
||||
server older than 9.0.0), pgin.tcl will not supply the argument to the |
||||
handler. This is intended to improve compatibility with older scripts that |
||||
would throw an error if provided an unexpected argument. |
||||
|
||||
If you do not update your listener callback to have an optional argument, |
||||
and you never include a payload in the notification SQL, your script will |
||||
not have any problems. However, note that anyone who can connect to the |
||||
database can send a notification (if they know the 'channel' name used |
||||
in the pg_listen command), and they can include a payload. If your listener |
||||
callback does not expect a payload argument, it will throw a background |
||||
error (which may or may not terminate the script) if it receives such a |
||||
payload argument. |
||||
|
||||
+ Change in pg_result $result_handle -cmdTuples: |
||||
It seems that starting with PostgreSQL-9.0, the function that this |
||||
emulates (libpq PQcmdTuples) was extended to return the number of |
||||
rows returned by SELECT. (Prior to this change, an empty string was |
||||
returned for SELECT.) pgin.tcl was modified to work that way, and now |
||||
returns row counts for -cmdTuples after SELECT and other commands. |
||||
However, it is recommended to use -numTuples for SELECT and -cmdTuples |
||||
for commands that modify tables. |
||||
|
||||
* 2009-09-10 Released version 3.1.0 |
||||
|
||||
This version contains four new commands: |
||||
+ pg_encrypt_password to encrypt a password for certain SQL commands |
||||
+ pg_lo_truncate to truncate a large object |
||||
+ pg_describe_cursor to return information about a cursor (portal) |
||||
+ pg_describe_prepared to return information about a prepared statement. |
||||
|
||||
This version adds two options to pg_result, for use with |
||||
pg_describe_prepared to return information about a prepared statement. |
||||
The options are -numParams and -paramTypes. |
||||
|
||||
In this release, pg_escape_string, pg_quote, and pg_escape_bytea |
||||
accept an optional connection parameter, which allows pgin.tcl to |
||||
use connection-specific information to properly handle string escaping. |
||||
For more information, see the REFERENCE file. |
||||
|
||||
This is the first release that can properly escape strings and bytea's |
||||
if standard_conforming_strings is ON (thus backslashes should not be |
||||
doubled). This works as long as the client either: uses a single database |
||||
connection, or uses multiple database connections all of which have the |
||||
same setting for standard_conforming_strings, or always supplies the |
||||
connection parameter to pg_escape_string, pg_quote, and pg_escape_bytea. |
||||
|
||||
The procedure that implements the backend reply protocol has been |
||||
rewritten to more completely check that only expected messages are |
||||
received, depending on the processing mode. |
||||
|
||||
Fixed error handling in pg_lo_import and pg_lo_export, to make sure |
||||
the file is closed if an error occurs. |
||||
|
||||
|
||||
* 2008-04-26 Released version 3.0.2 |
||||
|
||||
This version contains a bug fix in executing prepared queries with |
||||
extended (non-ASCII) character query parameters. |
||||
+ Fix pg_exec_prepared to use the parameter length after encoding. |
||||
Thanks to giorgio_v -at- mac.com for finding the bug. |
||||
|
||||
* 2006-08-30 Released version 3.0.1 |
||||
|
||||
This is the first release on pgfoundry.org. Previous releases were on |
||||
gborg.postgresql.org. The release documentation was changed to reflect |
||||
the new URL. |
||||
|
||||
+ Fix/Change: pg_escape_bytea was changed to match a change in the |
||||
PostgreSQL-8.1 libpq library function PQescapeBytea. For a single |
||||
quote in the argument string, it now returns two quotes ('') instead |
||||
of backslash-quote (\'). |
||||
|
||||
|
||||
* 2005-04-16 Released beta version 3.0.0 |
||||
|
||||
This is a beta release which adds character set encoding/decoding to fix |
||||
misbehavior of pgin.tcl when used with non-ASCII character sets. Like |
||||
Pgtcl, pgtcl-ng, and libpgtcl, pgin.tcl now sets PostgreSQL |
||||
client_encoding to Unicode, and sends/receives UTF-8 encoded text |
||||
strings to/from PostgreSQL. Pgin.tcl also recodes COPY data, which |
||||
the libpq-based Tcl interfaces do not correctly handle at this time. |
||||
|
||||
(Thanks to pfm developer Willem Herremans, who first convinced me that |
||||
encoding was broken in pgin.tcl, then provided the understanding of how |
||||
Tcl and PostgreSQL handle character set conversions and how to get them |
||||
to play nicely together.) |
||||
|
||||
There are no changes to the pgin.tcl command usage from 2.2.0. |
||||
|
||||
At this time, it hasn't been decided if there will be two versions of |
||||
pgin.tcl - one for Unicode, and one without - or if only the Unicode |
||||
encoding version will suffice. |
||||
|
||||
|
||||
* 2004-11-11 Released version 2.2.0 |
||||
|
||||
+ New commands: pg_escape_bytea and pg_unescape_bytea, which emulate the |
||||
libpq functions PQescapeBytea() and PQunescapeBytea(). These were |
||||
suggest by J. Levan, with a fast implementation of pg_unescape_bytea |
||||
provided by B. Riefenstahl. Note however that pg_escape_bytea is slow. |
||||
(If possible, use prepared queries in binary mode for bytea types, |
||||
not escape/unescape.) Also note that pg_unescape_bytea only produces |
||||
valid results for data formated by the PostgreSQL backend bytea |
||||
output function; it is not an accurate emulation of PQunescapeBytea(). |
||||
|
||||
+ Compatibility fixes for extended error codes. |
||||
The Gborg pgtcl project (Karl Lehenbauer) release 1.4 contains a way to |
||||
fetch extended error field values which is different from the way |
||||
pgin.tcl and pgtclng already did it, but better. They extended |
||||
pg_result -error, where I added a new subcommand pg_result -errorField. |
||||
For compatibility, pg_result -error and pg_result -errorField are now |
||||
identical. If an optional code is supplied, that error field value |
||||
will be returned. Also added variations on the code names that Gborg |
||||
pgtcl uses. |
||||
|
||||
* Performance fix for prepared queries: As found by Nigel J. Andrews, |
||||
prepared queries were slower than they should be. The fix was to |
||||
allow Tcl to buffer up the multiple messages making up a prepared |
||||
query execution; for some reason this avoids a TCP/IP delay. |
||||
|
||||
|
||||
* 2004-06-01 Released version 2.1.0 |
||||
|
||||
+ New command: pg_exec_params, parse/bind/execute extended query protocol. |
||||
This complements pg_exec_prepared, which works with a pre-prepared |
||||
statement. Both are binary safe. |
||||
|
||||
+ pg_exec can take optional arguments which makes it a parameterized |
||||
query like pg_exec_params, but with all text parameters and results. |
||||
(idea from karl's implementation in Gborg pgtcl CVS). |
||||
|
||||
+ New command: pg_quote, to quote and escape a string (from karl's |
||||
implementation in Gborg pgtcl CVS), variation on pg_escape_string (which |
||||
unfortunately was removed from Gborg pgtcl CVS, breaking compatibility). |
||||
pgin.tcl will support both pg_escape_string and pg_quote. |
||||
|
||||
+ Bug fix (GBorg #802) Fix typo in error return if pg_execute script throws |
||||
an error (from n.j.andrews-at-investsystems.co.uk). Testing found |
||||
another problem here; fixed error value returned. |
||||
|
||||
|
||||
* 2004-02-25 Version 2.0.1 (not released to Gborg) |
||||
|
||||
+ New command option: pg_result $res -cmdStatus (suggested by levanj) |
||||
Returns the command status tag, e.g. "INSERT 10020", for the result $res. |
||||
|
||||
|
||||
* 2004-02-14 Released version 2.0.0 |
||||
|
||||
Changes since beta release 2.0b1: |
||||
|
||||
+ Pgin.tcl can now be installed as a Tcl package. |
||||
|
||||
The package name is 'pgintcl'. (Not 'pgtcl', which is used by libpgtcl. |
||||
Since pgintcl is not 100% compatible, I didn't want to use the same name. |
||||
Also the version numbers of the two interfaces do not track.) |
||||
This means if you install pgin.tcl and pkgIndex.tcl into your package |
||||
directories, you can use {package require pgintcl} to load it. |
||||
|
||||
|
||||
+ Removed feature: Fetch all parameters with {pg_parameter_status $db} |
||||
|
||||
Libpq does not support this, so to be compatible with future libpq-based |
||||
versions of the pgtcl interface, this feature was removed. You must supply |
||||
pg_parameter_status with a parameter name. |
||||
|
||||
|
||||
+ Documented incompatibility: pg_exec_prepared mixed text/binary return types |
||||
|
||||
Although the pg_exec_prepared command in pgin.tcl supports mixing text and |
||||
binary return types, libpq does not, so libpq based versions of the pgtcl |
||||
interface will not work with these queries. This has now been noted in the |
||||
documentation, but support for these queries was not removed from pgin.tcl. |
||||
|
||||
|
||||
+ Incompatible feature change: Dealing with NULL values |
||||
|
||||
Previous versions of pgin.tcl supported a command to set the string to be |
||||
returned if a database value was NULL: { pg_configure $db nulls "string" }. |
||||
This proved to be very inefficient to implement in the libpq-based version |
||||
of the pgtcl interface. It could slow down all queries, just to support a |
||||
feature that would be rarely used, so it was removed. Instead, pgin.tcl |
||||
now only provides a way to determine if a database value is NULL: |
||||
pg_result $res -getTuple $n |
||||
This returns a list of 1s and 0s indicating if each column in tuple $n |
||||
is NULL or not. |
||||
|
||||
|
||||
+ Command name change: Setting notice handler |
||||
|
||||
In previous versions of pgin.tcl you could set the notice handler with: |
||||
pg_configure $db notice ?command? |
||||
A new command is now used instead: |
||||
pg_notice_handler $db ?command? |
||||
The pg_configure command is retained for compatibility but should not be |
||||
used. |
||||
|
||||
|
||||
+ Large Object Error Handling 'fixed' |
||||
|
||||
Several of the Large Object calls had undefined or unclear error behavior, |
||||
and most were not documented in the PostgreSQL manual. Now pgin.tcl will |
||||
throw a Tcl error if any error occurs in any large object calls except for |
||||
pg_lo_read and pg_lo_write. Those two were already defined to return -1 on |
||||
error, so I left them that way even though I would prefer they threw errors. |
||||
|
||||
|
||||
|
||||
* 2003-10-30 Released beta version 2.0b1: |
||||
|
||||
This is a major rewrite for PostgreSQL-7.4 using the new V3 FE/BE protocol. |
||||
|
||||
New commands for new features in the V3 protocol: |
||||
pg_parameter_status => Get backend-supplied parameter value |
||||
pg_transaction_status => Get current transaction/error state |
||||
pg_exec_prepared => Execute prepared SQL statement |
||||
pg_result -errorField => Show extended error code values |
||||
pg_result -lxAttributes => Show extended field attribute information |
||||
|
||||
Changed commands: pg_configure no longer ignores the connection handle; |
||||
nulls and notice settings are now per-connection, not global to all |
||||
connections. |
||||
|
||||
Change (incompatible): COPY FROM/TO must use the pg_copy_read and |
||||
pg_copy_write commands, and can not read / write the socket directly. |
||||
These calls were introduced in pgin.tcl-1.5.0, but were optional in that |
||||
version. Changes to the PostgreSQL protocol now makes it impossible for |
||||
pgin.tcl to support COPY with direct reading and writing the socket, so use |
||||
of these commands is not required. See REFERENCE for more information. |
||||
|
||||
The included sample tkpsql program has been updated in this release to be |
||||
more schema-aware, while still supporting pre-PostgreSQL-7.3 databases |
||||
(untested). Some new special queries were added. |
||||
|
||||
|
||||
* 2003-06-30 Released version 1.5.0 |
||||
|
||||
Change: default user name for connection now checks environment variable |
||||
USERNAME (for WindowsNT) after PGUSER, USER, and LOGNAME. |
||||
|
||||
Fix: Tkpsql properly gets initial focus on startup on Windows. |
||||
|
||||
Bug fix: Wrong data was returned by pg_result -getTuple, -list, or -llist |
||||
when the query contained duplicate column names. (For example: |
||||
SELECT a.id, a.s, b.s FROM a, b WHERE a.id=b.id; |
||||
returns two columns named "s", and pg_result -getTuple incorrectly stored |
||||
the value from table "b" column "s" twice.) pgin.tcl now internally stores |
||||
values indexed by column number, not name, and will correctly store and |
||||
return all the values when those access methods are used. Note that other |
||||
access methods such as pg_result -assign, -tupleArray, pg_select, and |
||||
pg_execute use the column name as an array index, so they are not |
||||
compatible with queries returning duplicate column names. Also note you |
||||
really should use column name aliases when a query generates duplicate |
||||
column names. [gborg bug id #503] |
||||
|
||||
New function: pg_escape_string to escape strings for SQL constants. This is |
||||
in the libpgtcl CVS. |
||||
|
||||
Bug fixes for empty query. Previously threw an error, now properly handles |
||||
an empty query return and sets status to PGRES_EMPTY_QUERY. |
||||
|
||||
Change: pg_result -cmdTuples returns "", not 0, for any SQL other than |
||||
Insert/Update/Delete, this apparently being the correct behavior per libpq. |
||||
|
||||
Add support for overloaded fast-path function calls (same function name but |
||||
with different argument types). |
||||
|
||||
Fix: pg_execute now handles empty query, COPY FROM, and COPY TO correctly. |
||||
|
||||
New I/O routines for COPY FROM/TO: pg_copy_read and pg_copy_write. There is |
||||
no need to use these yet; you can just read and write from the connection |
||||
handle. I put them in for testing compatibility with the future PostgreSQL |
||||
FE/BE Protocol Version 3 pgin.tcl, where reading/writing from the connection |
||||
handle will not work. |
||||
|
||||
|
||||
* 2003-02-13 Released version 1.3.9 |
||||
|
||||
This is the first public release. |
||||
@ -0,0 +1,227 @@
|
||||
This is pgintcl/README, describing pgintcl: A PostgreSQL interface in Tcl |
||||
Last updated for pgintcl-3.5.1 on 2017-11-12 |
||||
The project home page is: http://sourceforge.net/projects/pgintcl/ |
||||
----------------------------------------------------------------------------- |
||||
|
||||
OVERVIEW: |
||||
|
||||
This is a pure-Tcl interface to the PostgreSQL Database Management System. |
||||
It implements almost all the commands in the original libpgtcl, the Tcl |
||||
interface which was bundled with PostgreSQL until release 8.0, plus it |
||||
has many extensions. But it is written entirely in Tcl, so does not |
||||
require compilation for a specific platform or any additional components. |
||||
|
||||
I originally wrote this to be able to use Tcl/Tk database clients on |
||||
platforms where the PostgreSQL client library (libpq) and the Tcl interface |
||||
(libpgtcl) were not available, or were too much trouble to build. |
||||
|
||||
pgin.tcl uses the Tcl binary data and TCP socket features to communicate |
||||
directly with a PostgreSQL database server, using the internal PostgreSQL |
||||
frontend/backend protocol. Therefore, pgin.tcl is dependent on the |
||||
protocol, rather than being protected from its details as are libpq-based |
||||
applications. This version of pgin.tcl uses version 3 of the PostgreSQL |
||||
protocol, and only communicates with PostgreSQL-7.4 and higher servers. |
||||
|
||||
pgin.tcl is also highly compatible with pgtcl-ng, the "Next Generation" |
||||
libpq-based implementation of the pgtcl interface. pgtcl-ng can be found at |
||||
http://sourceforge.net/projects/pgtclng/ |
||||
The same test suite is used to verify both interfaces. |
||||
|
||||
Version 3 of pgin.tcl added Unicode character set encoding and decoding. |
||||
It was tested with LATIN1 and UTF8 database encodings, as well as |
||||
SQL_ASCII. (Note SQL_ASCII encoded databases are meant for 7-bit ASCII |
||||
characters only. Do not use SQL_ASCII databases if your data includes |
||||
non-ASCII characters.) It should work with any PostgreSQL database |
||||
encoding, but user testing is encouraged. (The previous version 2 of |
||||
pgin.tcl does not include character set encoding handling. It may only work |
||||
properly with SQL_ASCII encoded databases.) |
||||
|
||||
|
||||
REQUIREMENTS: |
||||
|
||||
Tcl-8.4.4 or higher, with the latest 8.6.x recommended. |
||||
PostgreSQL-9.1.x or higher, with the latest 10.x or 9.6.x recommended. |
||||
|
||||
Recent testing used the following: |
||||
Database server: PostgreSQL-9.6.6 and 10.1. |
||||
Client on Linux: Tcl-8.6.5. |
||||
Client on Windows XP: ActiveState Tcl-8.6.0 and Tcl-8.5.14 |
||||
(Older version of PostgreSQL and Tcl might work but are no longer tested.) |
||||
Pgin.tcl should be usable on all platforms with Tcl, however current |
||||
testing is limited to 32-bit Linux and Windows platforms. |
||||
|
||||
CONTENTS: |
||||
|
||||
Documentation: |
||||
Note: In the zip file distribution only, these documentation |
||||
files have a ".txt" extension and MS-DOS line endings. |
||||
README ........... This file |
||||
COPYING .......... The license for pgin.tcl (BSD/Berkeley Open Source) |
||||
NEWS ............. Release information and change history |
||||
REFERENCE ........ Reference documentation for programmers using pgin.tcl |
||||
INTERNALS ........ Some information about the innards of pgin.tcl |
||||
|
||||
Scripts: |
||||
|
||||
pgin.tcl ......... This is the complete implementation of the interface. |
||||
pkgIndex.tcl ..... Package index file |
||||
tkpsql.tcl ....... An example wish script for interactive database querying |
||||
|
||||
|
||||
FEATURES: |
||||
|
||||
+ Written completely in Tcl |
||||
+ Implements virtually all the standard (original, bundled) libpgtcl commands |
||||
+ Supports large object manipulation commands |
||||
+ Supports listen/notify |
||||
+ Supports passing a payload with NOTIFY (PostgreSQL-9.0.0 and higher) |
||||
+ Supports replacing the notice handler |
||||
+ Supports pg_execute command |
||||
+ Supports PostgreSQL MD5 challenge/response authentication |
||||
+ pg_result -cmdTuples returns the number of tuples affected by an |
||||
INSERT, DELETE, or UPDATE |
||||
+ Supports distinguishing NULL database values from empty strings |
||||
+ Implements pg_result -list, and pg_result -llist |
||||
+ Implements pg_escape_string, pg_quote, pg_escape_literal [New: 3.5.0], and |
||||
pg_escape_identifier [New: 3.5.0] for escaping strings. |
||||
+ Execute prepared statements with: pg_exec_prepared, including sending |
||||
and receiving un-escaped binary data |
||||
+ Get PostgreSQL parameters with: pg_parameter_status |
||||
+ Get transaction status with: pg_transaction_status |
||||
+ Access expanded error message fields with: pg_result -errorField |
||||
This was extended [at 2.2.0] to also apply to pg_result -error |
||||
for compatibility with pgtcl. More fields were added at 3.5.0. |
||||
+ Access extended attribute information with: pg_result -lxAttributes |
||||
+ Get command status tag with pg_result -cmdStatus [New: 2.0.1] |
||||
+ Separate parse and execute with: pg_exec_params, binary safe [New: 2.1.0] |
||||
+ Escape/unescape bytea with: pg_escape_bytea, pg_unescape_bytea [New: 2.2.0] |
||||
+ Return query results as a dictionary with pg_result -dict [New: 3.3.0] |
||||
+ Access to process ID (PID) of backend and in notifications [New: 3.4.0] |
||||
+ Connect via postgresql:// URI, or keyword/value Tcl list [New: 3.5.0] |
||||
+ Supports 64-bit offsets in large objects [New: 3.5.0, PostgreSQL-9.3.0 and up] |
||||
|
||||
|
||||
LIMITATIONS and DIFFERENCES: |
||||
|
||||
+ pg_connect does not support the older method using a separate dbname plus |
||||
options for host, port. |
||||
+ Does not support $HOME/.pgpass password file. |
||||
+ Only talks to v3 backend (PostgreSQL 7.4 or higher required). |
||||
+ Uses only TCP/IP sockets (defaults host to localhost, PostgreSQL server must |
||||
be listening on TCP sockets). Does not support Unix Domain sockets. |
||||
+ Notification messages are only received while reading query results. |
||||
+ Performance isn't great, especially when retrieving large amounts of data. |
||||
+ The values of connection handles and result handles are of a different |
||||
format than other implementations, but nobody should be relying on these. |
||||
+ No pg_on_connection_loss (New at PostgreSQL 7.3). |
||||
+ No asynchronous query commands (found in pgtcl and pgtcl-ng). |
||||
+ Support for COPY FROM/TO is not compatible with other versions of the |
||||
interface - must use pg_copy_read and pg_copy_write, no I/O directly to |
||||
connection handle. |
||||
+ With other pgtcl's, you can have up to 128 active result structures (so leaks |
||||
can be caught). pgin.tcl has no limits and will not catch result structure |
||||
leaks. |
||||
+ [Added at 2.1.0] Do not use "return -code N" (for N>4) in the script |
||||
body for pg_select or pg_execute, because the effect is not well defined. |
||||
You can safely use return, break, continue, and error (either directly |
||||
or via return -code). |
||||
+ [Added at 2.2.0] pg_escape_bytea (and pg_unescape_bytea, to a |
||||
lesser extent) is quite slow. Using it on large bytea objects is not |
||||
recommended; you should use binary prepared queries instead. |
||||
+ [Added at 3.1.0] Whether or not you use the $conn argument to the string |
||||
and bytea escape routines, pgin.tcl does not use encoding-aware escaping. |
||||
This also applies to pg_escape_literal and pg_escape_identifier [at 3.5.0]. |
||||
+ [Added at 3.2.0] pg_escape_bytea always uses the older 'escape' encoding |
||||
in the returned result, never the newer 'hex' encoding. |
||||
|
||||
|
||||
RELEASE ISSUES: |
||||
|
||||
Version 3.5.0 added new commands based on more recent Libpq functions, but |
||||
some of these will only work when connected to a PostgreSQL-9.3.0 server. This |
||||
includes 64-bit Large Object offset commands, and new error field codes. |
||||
Also starting with this release, single-character error field codes in |
||||
"pg_result -error" and "pg_result -errorField" are now case sensitive. This |
||||
incompatible change was necessary due to changes in PostgreSQL-9.3.0. |
||||
|
||||
Versions 3.4.0 and up handle notification names (also known as channel |
||||
names) in pg_listen differently from previous versions. This can result in |
||||
compatibility problems if you used mixed-case names in pg_listen. Starting |
||||
with version 3.4.0, pgintcl folds the channel name to lower case unless it |
||||
is in double quotes. This now matches the behavior of pgtcl-ng. See the |
||||
REFERENCE file and pgintcl bug #2 (old #3410251) for more details. |
||||
|
||||
Versions 3.3.0 and up require Tcl 8.4 or higher. Previous versions checked |
||||
for Tcl 8.3 or higher, but were not actually tested with Tcl 8.3. |
||||
|
||||
Versions 3.2.0 and up pass a payload argument to a notification listener handler |
||||
procedure if a non-empty payload was provided in the SQL NOTIFY command. |
||||
See the NEWS file for more information and compatibility issues. |
||||
|
||||
Version 3 does encoding and decoding of character data, as described in |
||||
the REFERENCE file. It also sets the PostgreSQL parameter |
||||
CLIENT_ENCODING to UNICODE when a connection is opened to the server. This |
||||
is the same behavior as Pgtcl and pgtcl-ng. This informs PostgreSQL that |
||||
UNICODE data (encoded as UTF-8) will be sent and received. |
||||
|
||||
Note that the client application using pgin.tcl can have any encoding |
||||
which Tcl supports. Tcl converts between the client encoding and Unicode, |
||||
and the PostgreSQL server converts between Unicode and the database |
||||
encoding. This assumes the database encoding is other than SQL_ASCII. |
||||
|
||||
* * * CAUTION * * * |
||||
|
||||
Do not store non-ASCII characters in character or text fields in a |
||||
PostgreSQL database which was created with encoding SQL_ASCII. |
||||
The SQL_ASCII encoding provides no information to PostgreSQL on |
||||
how to translate characters, so the server will be unable to |
||||
translate. Applications using a Tcl interface, including |
||||
pgin.tcl, will encode these characters using UTF-8 for storage |
||||
in the database, but PostgreSQL will not know it due to the |
||||
SQL_ASCII encoding setting. The result is that it may be |
||||
impossible to access the data correctly from other applications. |
||||
Always use the correct encoding when creating a database: for |
||||
example, LATIN1 or Unicode. |
||||
|
||||
Pgin.tcl-2.x and older do not convert to/from Unicode and do not set |
||||
client_encoding at all. These older versions may not work with non-ASCII |
||||
characters in any database encoding. |
||||
|
||||
At this time, Pgin.tcl does not recode the connection string parameters |
||||
such as Username, Database Name, or Password. Non-ASCII characters in these |
||||
fields will probably not work. |
||||
|
||||
|
||||
Older Information: |
||||
|
||||
There are some incompatibilities between this release and pre-2.0.0 releases: |
||||
+ pg_parameter_status can no longer fetch all parameters at once; |
||||
+ "pg_configure nulls" option is no longer available. The only way |
||||
to distinguish NULL from empty string now is with pg_result -getNull. |
||||
+ Changes in large object call error handling. |
||||
+ COPY FROM/TO must use pg_copy_read/pg_copy_write; you cannot read or |
||||
write copy data from the connection. |
||||
You will have to change your application if it relies on behavior which |
||||
changed. See the file NEWS for more information. |
||||
|
||||
|
||||
INSTALLATION AND USAGE: |
||||
|
||||
There is no install script. Just copy the script "pgin.tcl" anywhere your |
||||
application can access it. In your application, insert "source .../pgin.tcl" |
||||
at the top level, where ... is the directory. This must be run at the top |
||||
level, so if you need it inside a proc use uplevel as shown below. |
||||
|
||||
Optionally, you can install and use pgin.tcl as a Tcl package. You should |
||||
copy pgin.tcl and pkgIndex.tcl into a sub-directory of your Tcl |
||||
installation package library root directory (or you can extend auto_path: |
||||
see the Tcl documentation for the 'package' and 'pkgMkIndex' commands). |
||||
Then your application can load pgin.tcl with the following: |
||||
package require pgintcl |
||||
|
||||
|
||||
You can use the included "tkpsql.tcl" script to try it out. This is a |
||||
simple interactive GUI program to issue database queries, vaguely like the |
||||
Sybase ASA "dbisql" program. On **ix systems, type "wish tkpsql.tcl" to |
||||
start it; under Windows you should be able to double click on it from |
||||
Explorer. You need to press F1 or click on the Run button after each query. |
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,880 @@
|
||||
# $Id: tkpsql.tcl 515 2011-09-17 19:18:53Z lbayuk $ |
||||
# tkpsql - Interactive PostgreSQL SQL Interface |
||||
# Copyright 2003-2008 by L Bayuk |
||||
# May be freely distributed with or without modification; must retain this |
||||
# notice; provided with no warranties. |
||||
# See the file COPYING for complete information on usage and redistribution |
||||
# of this file, and for a disclaimer of all warranties. |
||||
|
||||
# Global variables: |
||||
# version - Our version string. |
||||
# widgets() - Main widget pathnames : input output status |
||||
# n_history - Number of history elements |
||||
# history() - History array 1:n_history |
||||
# history_p - Index in history where next command will be stored |
||||
# history_q - Index in history where next command will be recalled from |
||||
# db - Handle to open database, if empty there is no connection. |
||||
# dbinfo() - Remembers db conection info: host, user, dbname, port, password |
||||
# dbinfo(has_schema) Flag: Database has schemas (PostgreSQL >=7.3) |
||||
# form_status - Temporary flag for waiting on a popup |
||||
# pwd - Starting directory for file open/save |
||||
# option() - Array of options |
||||
# " (outstyle) - Output style, "wide" or "narrow" |
||||
# " (debug) - Debug flag, 0 for none |
||||
# " (maxlook) - Max. result rows to examine for column widths |
||||
# " (clear) - Clear output pad before each command results |
||||
# special() - SQL for special database queries, index by code. |
||||
# special_title() - Titles for special queries, indexed by code. |
||||
# special_codes - A list of special*() indexes, ordered as they should |
||||
# be displayed in the popup. |
||||
|
||||
set version 1.2.1 |
||||
package require Tk |
||||
|
||||
# ===== Utility Routines ===== |
||||
|
||||
# Initialization: |
||||
proc initialize {} { |
||||
global n_history history history_p history_q |
||||
global db pwd option |
||||
|
||||
array set option { |
||||
debug 0 |
||||
outstyle wide |
||||
maxlook 20 |
||||
clear 1 |
||||
} |
||||
|
||||
# Initialize the history list: |
||||
set n_history 25 |
||||
for {set i 1} {$i <= $n_history} {incr i} { |
||||
set history($i) {} |
||||
} |
||||
set history_p 1 |
||||
set history_q 1 |
||||
|
||||
set db {} |
||||
set pwd [pwd] |
||||
dbms_load |
||||
font create monofont -family Courier |
||||
font create boldfont -family Courier -weight bold |
||||
} |
||||
|
||||
# Initialize the array of special database queries. |
||||
# This has to be done after connecting to the database, so we know if |
||||
# the schema-aware versions should be used. It can be called again as needed. |
||||
# special(c) contains the SQL for code 'c'. |
||||
# special_title(c) contains the displayed title for code 'c'. |
||||
# The index values 'c' are arbitrary codes. |
||||
# The list special_codes contains the ordered list of indexes. |
||||
# |
||||
# I mostly copied the SQL queries from psql. The 'schema-aware' queries are |
||||
# based on PostgreSQL-7.3.4; the 'non-schema' versions are from some older |
||||
# version. But in some cases, I took advantage of the special views. |
||||
# |
||||
# Note: The pre-7.3 queries are no longer updated/maintained because I don't |
||||
# have pre-7.3 server to test them on. |
||||
# |
||||
proc init_special {} { |
||||
global dbinfo special special_title special_codes |
||||
catch {unset special_codes special_title special} |
||||
|
||||
if {$dbinfo(has_schema)} init_special_new init_special_old |
||||
} |
||||
|
||||
# Initialize special queries for PostgreSQL-7.3 and higher. |
||||
# See comments for init_special |
||||
proc init_special_new {} { |
||||
global special special_title special_codes |
||||
|
||||
# This is the ordered list of codes whose titles will be displayed. |
||||
set special_codes { dbs tables views index rules seqs rights user group } |
||||
|
||||
set special_title(dbs) "List Databases" |
||||
set special(dbs) { |
||||
select datname as "Database Name", usename as "Owner" |
||||
from pg_database, pg_user |
||||
where datdba=usesysid order by datname |
||||
} |
||||
|
||||
set special_title(tables) "List Tables" |
||||
set special(tables) { |
||||
select schemaname as "Schema", tablename as "Table", tableowner as "Owner" |
||||
from pg_catalog.pg_tables |
||||
where schemaname not in ('pg_catalog', 'pg_toast', 'information_schema') |
||||
order by 1,2 |
||||
} |
||||
|
||||
set special_title(views) "List Views" |
||||
set special(views) { |
||||
select schemaname as "Schema", viewname as "View", viewowner as "Owner", |
||||
definition as "Definition" |
||||
from pg_catalog.pg_views |
||||
where schemaname not in ('pg_catalog', 'pg_toast', 'information_schema') |
||||
order by 1,2 |
||||
} |
||||
|
||||
set special_title(index) "List Indexes" |
||||
set special(index) { |
||||
select schemaname as "Schema", indexname as "Index-Name", |
||||
tablename as "Base-Table", indexdef as "Definition" |
||||
from pg_catalog.pg_indexes |
||||
where schemaname not in ('pg_catalog', 'pg_toast', 'information_schema') |
||||
order by 1,2 |
||||
} |
||||
|
||||
set special_title(rules) "List Rules" |
||||
set special(rules) { |
||||
select schemaname as "Schema", rulename as "Rule", |
||||
definition as "Definition" |
||||
from pg_catalog.pg_rules |
||||
where schemaname not in ('pg_catalog', 'pg_toast', 'information_schema') |
||||
order by 1,2 |
||||
} |
||||
|
||||
# Sequences - no special view, so do it manually. |
||||
set special_title(seqs) "List Sequences" |
||||
set special(seqs) { |
||||
select n.nspname as "Schema", c.relname as "Sequence", |
||||
u.usename as "Owner" |
||||
from pg_namespace n, pg_class c, pg_user u |
||||
where n.oid = c.relnamespace and c.relowner = u.usesysid |
||||
and relkind = 'S' |
||||
and n.nspname not in ('pg_catalog', 'pg_toast', 'information_schema') |
||||
order by 1, 2 |
||||
} |
||||
|
||||
set special_title(rights) "Show Permissions" |
||||
set special(rights) { |
||||
select n.nspname as "Schema", c.relname as "Relation", |
||||
u.usename as "Owner", c.relacl as "Access Control List" |
||||
from pg_class c, pg_user u, pg_namespace n |
||||
where c.relowner = u.usesysid and c.relnamespace = n.oid |
||||
and c.relkind in ('r', 'v', 'S') |
||||
and pg_catalog.pg_table_is_visible(c.oid) |
||||
and n.nspname not in ('pg_catalog', 'pg_toast', 'information_schema') |
||||
order by 1, 2 |
||||
} |
||||
|
||||
set special_title(user) "List Users" |
||||
set special(user) { |
||||
select usename as "Username", usesysid as "User-ID", |
||||
trim (leading ' ' from |
||||
trim (trailing ',' from |
||||
case when usesuper then ' Superuser,' else '' end |
||||
|| case when usecreatedb then ' Create Database,' else '' end |
||||
|| case when usecatupd then ' Update Catalogs,' else '' end)) |
||||
as "Rights" |
||||
from pg_user order by usename |
||||
} |
||||
|
||||
set special_title(group) "List Groups" |
||||
set special(group) { |
||||
select groname as "Groupname", grosysid as "Group-ID", |
||||
grolist as "Member-IDs" |
||||
from pg_group order by groname |
||||
} |
||||
} |
||||
|
||||
# Initialize special queries for PostgreSQL older than 7.3. |
||||
# See comments for init_special. This is UNMAINTAINED. |
||||
proc init_special_old {} { |
||||
global special special_title special_codes |
||||
|
||||
# This is the ordered list of codes whose titles will be displayed. |
||||
set special_codes { dbs tables index rights user group } |
||||
|
||||
set special_title(dbs) "List Databases" |
||||
set special(dbs) { |
||||
select datname as "Database Name", usename as "Owner" |
||||
from pg_database, pg_user |
||||
where datdba=usesysid order by datname |
||||
} |
||||
|
||||
set special_title(tables) "List Tables" |
||||
set special(tables) { |
||||
select usename as username, relname as table, relkind as kind |
||||
from pg_class, pg_user where relkind = 'r' and relname !~ '^pg_' |
||||
and usesysid=relowner order by relname |
||||
} |
||||
|
||||
set special_title(index) "List Indexes/Sequences" |
||||
set special(index) { |
||||
select usename as username, relname as name, relkind as kind |
||||
from pg_class, pg_user where (relkind='i' or relkind='S') and |
||||
relname !~ '^pg_' and usesysid=relowner order by relname |
||||
} |
||||
|
||||
set special_title(rights) "Show Table/Sequence Rights" |
||||
set special(rights) { |
||||
select relname as table, usename as owner, relacl as acl from |
||||
pg_class, pg_user where (relkind = 'r' or relkind = 'S') and |
||||
relname !~ '^pg_' and usesysid=relowner order by relname |
||||
} |
||||
|
||||
set special_title(user) "List Users" |
||||
set special(user) { |
||||
select usename as "Username", usesysid as "User-ID", |
||||
usecreatedb as "Create-DB?", |
||||
usesuper as "Superuser?", |
||||
usecatupd as "Update-Catalogs?" |
||||
from pg_user order by usename |
||||
} |
||||
|
||||
set special_title(group) "List Groups" |
||||
set special(group) { |
||||
select groname as "Groupname", grosysid as "Group-ID", |
||||
grolist as "Member-IDs" |
||||
from pg_group order by groname |
||||
} |
||||
} |
||||
|
||||
|
||||
# Initialize after connecting to a database |
||||
# If an error occurs querying the database, ignore the error and don't |
||||
# report it. (Will only report errors from user-issued queries.) |
||||
# This also inializes the special queries. |
||||
proc init_post_connect {} { |
||||
global db dbinfo |
||||
|
||||
# Determine if the database supports schemas. |
||||
set dbinfo(has_schema) 0 |
||||
if {![catch {pg_exec $db "select nspname from pg_namespace limit 1"} r]} { |
||||
if {[pg_result $r -status] == "PGRES_TUPLES_OK"} { |
||||
set dbinfo(has_schema) 1 |
||||
} |
||||
pg_result $r -clear |
||||
} |
||||
debug_puts "has_schema: $dbinfo(has_schema)" |
||||
init_special |
||||
} |
||||
|
||||
# Pluralization |
||||
proc plural {n {s "s"}} { |
||||
if {$n == 1} { return ""} else { return $s } |
||||
} |
||||
|
||||
# Assign respective list elements to named variables: |
||||
proc setlist {list args} { |
||||
foreach val $list var $args { |
||||
upvar $var v |
||||
set v $val |
||||
} |
||||
} |
||||
|
||||
# Output some text if debugging is on: |
||||
proc debug_puts {s} { |
||||
global option |
||||
if {$option(debug)} { |
||||
puts "+debug: $s" |
||||
} |
||||
} |
||||
|
||||
# Load PostgreSQL support with library or emulator: |
||||
proc dbms_load {} { |
||||
# If it is already loaded; e.g. running under pgtksh, nothing to do. |
||||
if {[info commands pg_connect] != ""} return |
||||
# Use my pgin.tcl interface library from the same directory: |
||||
set cmd [list source [file join [file dirname [info script]] pgin.tcl]] |
||||
if {[catch {uplevel #0 $cmd} msg]} { |
||||
error "Error: Unable to load database support. $msg" |
||||
} |
||||
} |
||||
|
||||
# ===== GUI / Window Utilities ===== |
||||
|
||||
# Center a window over another window. |
||||
# $win : Window to center |
||||
# $over : What to center it over: |
||||
# "ROOT" => center over the screen. |
||||
# "PARENT" => center over $win's parent window. |
||||
# Otherwise $over is the name of a window to center $win over. |
||||
# On return, the window will be mapped (de-iconified). |
||||
proc center_window {win over} { |
||||
wm withdraw $win |
||||
update |
||||
if {$over == "ROOT"} { |
||||
set base_x 0 |
||||
set base_y 0 |
||||
set base_w [winfo screenwidth $win] |
||||
set base_h [winfo screenheight $win] |
||||
} else { |
||||
if {$over == "PARENT"} { |
||||
set overwin [winfo parent $win] |
||||
} else { |
||||
set overwin $over |
||||
} |
||||
set base_x [winfo rootx $overwin] |
||||
set base_y [winfo rooty $overwin] |
||||
set base_w [winfo width $overwin] |
||||
set base_h [winfo height $overwin] |
||||
} |
||||
set win_w [winfo reqwidth $win] |
||||
set win_h [winfo reqheight $win] |
||||
if {[set win_x [expr {$base_x + int(($base_w - $win_w) / 2)}]] < 0} { |
||||
set win_x 0 |
||||
} |
||||
if {[set win_y [expr {$base_y + int(($base_h - $win_h) / 2)}]] < 0} { |
||||
set win_y 0 |
||||
} |
||||
wm geometry $win +$win_x+$win_y |
||||
wm deiconify $win |
||||
} |
||||
|
||||
# Make a top-level window and return its name: |
||||
proc mk_window {name title} { |
||||
catch {destroy $name} |
||||
toplevel $name |
||||
wm title $name $title |
||||
wm transient $name . |
||||
return $name |
||||
} |
||||
|
||||
# Position and wait for grabbed popup window. |
||||
# Change with care; MS-Win is very sensitive to the command order. |
||||
proc window_wait {win focus_to varname} { |
||||
global $varname |
||||
set save_focus [focus] |
||||
center_window $win PARENT |
||||
focus $focus_to |
||||
grab set $win |
||||
tkwait variable $varname |
||||
destroy $win |
||||
catch {focus $save_focus} |
||||
} |
||||
|
||||
# Build a button with key binding(s) and command. Returns widget name. |
||||
proc mk_button {widget label key command} { |
||||
button $widget -text "$label $key" -command $command |
||||
bind . $key "$widget invoke" |
||||
return $widget |
||||
} |
||||
|
||||
# Make a 'buttons' frame with OK and Cancel buttons. |
||||
proc mk_buttons {toplevel {ok_action {set form_status 1}}} { |
||||
set f $toplevel.buttons |
||||
frame $f |
||||
button $f.ok -text OK -default active -command $ok_action |
||||
bind $toplevel <Return> "$f.ok invoke" |
||||
button $f.cancel -text Cancel -default normal -command {set form_status 0} |
||||
bind $toplevel <Escape> "$f.cancel invoke" |
||||
pack $f.ok $f.cancel -side left -padx 3 -pady 3 |
||||
} |
||||
|
||||
# ===== UI Support Routines ===== |
||||
|
||||
# Append a line to the output window: |
||||
proc oputs {s {tag ""}} { |
||||
global widgets |
||||
$widgets(output) insert end "$s\n" $tag |
||||
$widgets(output) see end |
||||
} |
||||
|
||||
# Clear the output window: |
||||
proc clear_output {} { |
||||
global widgets |
||||
$widgets(output) delete 1.0 end |
||||
} |
||||
|
||||
# Display some text in the status window: |
||||
proc show_status {s} { |
||||
global widgets |
||||
$widgets(status) configure -text $s |
||||
update |
||||
} |
||||
|
||||
# Clear the input window and put the focus there; also clears the status. |
||||
# This is used when returning from a command so no update is needed. |
||||
proc clear_input {} { |
||||
global widgets |
||||
$widgets(input) delete 1.0 end |
||||
focus $widgets(input) |
||||
$widgets(status) configure -text {} |
||||
} |
||||
|
||||
# Utility function used by build_format to update max lengths |
||||
proc max_list {max_name list} { |
||||
upvar $max_name max |
||||
set i 0 |
||||
foreach s $list { |
||||
set slen [string length $s] |
||||
if {$slen > $max($i)} { |
||||
set max($i) $slen |
||||
} |
||||
incr i |
||||
} |
||||
} |
||||
|
||||
# Create a format for output of query results. This decides how much space |
||||
# should be given to each column, and builds a format for {format} and |
||||
# returns it. $qr is the pgtcl query result handle. We look at the column |
||||
# headers and up to $option(maxlook) rows to find the longest field values. |
||||
# The result is a format string like {%-ns %-ns... %s}. |
||||
proc build_format {nrow ncol qr} { |
||||
global option |
||||
|
||||
if {$nrow > $option(maxlook)} { |
||||
set nrow $option(maxlook) |
||||
} |
||||
for {set i 0} {$i < $ncol} {incr i} { |
||||
set max($i) 0 |
||||
} |
||||
max_list max [pg_result $qr -attributes] |
||||
for {set i 0} {$i < $nrow} {incr i} { |
||||
max_list max [pg_result $qr -getTuple $i] |
||||
} |
||||
# Don't use the last column's width, just do "%s" for it. |
||||
set fmt {} |
||||
for {set i 0} {$i < $ncol-1} {incr i} { |
||||
append fmt "%-$max($i)s " |
||||
} |
||||
append fmt "%s" |
||||
debug_puts "build_format=$fmt" |
||||
return $fmt |
||||
} |
||||
|
||||
# Display query results in "narrow" format (one field per line): |
||||
proc show_results_narrow {nrow ncol qr} { |
||||
set headers [pg_result $qr -attributes] |
||||
for {set r 0} {$r < $nrow} {incr r} { |
||||
foreach name $headers value [pg_result $qr -getTuple $r] { |
||||
oputs "$name: $value" |
||||
} |
||||
if {$r % 10 == 0} { |
||||
show_status "Reading reply...$r" |
||||
} |
||||
oputs "" |
||||
} |
||||
} |
||||
|
||||
# Display query results in "wide" format (one record per line): |
||||
proc show_results_wide {nrow ncol qr} { |
||||
# Calculate field widths for output: |
||||
set fmt [build_format $nrow $ncol $qr] |
||||
|
||||
# Output the column headers: |
||||
oputs [eval format {$fmt} [pg_result $qr -attributes]] under |
||||
|
||||
# Output all of the rows: |
||||
for {set r 0} {$r < $nrow} {incr r} { |
||||
oputs [eval format {$fmt} [pg_result $qr -getTuple $r]] |
||||
if {$r % 10 == 0} { |
||||
show_status "Reading reply...$r" |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Send SQL to the backend and display the results. Optional title is |
||||
# displayed instead of the actual SQL (used for special queries). |
||||
proc run_sql {sql {title ""}} { |
||||
global db option |
||||
|
||||
if {$db == ""} { |
||||
tk_messageBox -title tkpsql -icon error -type ok \ |
||||
-message "Not connected to database" |
||||
return |
||||
} |
||||
debug_puts "SQL: $sql" |
||||
|
||||
if {$option(clear)} clear_output |
||||
|
||||
if {$title != ""} { |
||||
oputs $title bold |
||||
} else { |
||||
oputs $sql bold |
||||
} |
||||
show_status "Sending query..." |
||||
# Run the SQL, catch a backend or connection failure. |
||||
if {[catch {pg_exec $db $sql} reply]} { |
||||
oputs "ERROR executing SQL:" bold |
||||
oputs $reply bold |
||||
return |
||||
} |
||||
set status [pg_result $reply -status] |
||||
debug_puts "Query status $status" |
||||
show_status "" |
||||
if {$status == "PGRES_COMMAND_OK"} { |
||||
# Command completed with no tuples (e.g. insert, update, etc.). |
||||
# Show the OID, if available. (Not available should be 0, but there was |
||||
# some confusion early about this and it might be an empty string.) |
||||
set show OK |
||||
if {[set oid [pg_result $reply -oid]] != 0 && $oid != ""} { |
||||
append show ", OID=$oid" |
||||
} |
||||
# Show affected tuple count. Not all pgtcl's support this. |
||||
if {![catch {pg_result $reply -cmdTuples} n] && $n != ""} { |
||||
append show ", $n row[plural $n] affected" |
||||
} |
||||
oputs $show bold |
||||
clear_input |
||||
} elseif {$status != "PGRES_TUPLES_OK"} { |
||||
# Generally this will be PGRES_FATAL_ERROR, but any other status |
||||
# is also considered an error. |
||||
set errmsg [pg_result $reply -error] |
||||
oputs "ERROR ($status):" bold |
||||
oputs $errmsg bold |
||||
} else { |
||||
# Result was PGRES_TUPLES_OK, so there are tuples to show. |
||||
set ncol [pg_result $reply -numAttrs] |
||||
set nrow [pg_result $reply -numTuples] |
||||
oputs "OK with $nrow row[plural $nrow] and $ncol column[plural $ncol]." bold |
||||
oputs "" |
||||
show_status "Reading reply..." |
||||
show_results_$option(outstyle) $nrow $ncol $reply |
||||
clear_input |
||||
show_status "" |
||||
} |
||||
pg_result $reply -clear |
||||
oputs "" |
||||
} |
||||
|
||||
# Return the string properly escaped for conninfo quoting: |
||||
proc conninfo_quote {s} { |
||||
regsub -all {\\} $s {\\\\} s |
||||
regsub -all {'} $s {\\'} s |
||||
return $s |
||||
} |
||||
|
||||
# Call-back for do_connect on OK. Check the form values and try to connect. |
||||
# If it worked, set form_status to 1 to finish window_wait; else raise an |
||||
# error and return with the connection dialog still up. |
||||
proc do_connect_done {toplevel} { |
||||
global form_status dbinfo db |
||||
if {$dbinfo(dbname) == "" || $dbinfo(user) == "" || $dbinfo(password) == ""} { |
||||
tk_messageBox -title tkpsql -icon error -type ok \ |
||||
-parent $toplevel \ |
||||
-message "Missing information: must supply dbname, user, password" |
||||
return |
||||
} |
||||
|
||||
# Connect to the database: |
||||
# Only password can contain spaces, and only strings with spaces must |
||||
# be escape-quoted. |
||||
set conninfo "dbname=$dbinfo(dbname) user=$dbinfo(user)\ |
||||
password='[conninfo_quote $dbinfo(password)]'" |
||||
# Host is optional, because blank host means use localhost. |
||||
# Apply port only if host is used, although technically it can be used |
||||
# without a host over UDS. |
||||
if {$dbinfo(host) != ""} { |
||||
append conninfo " host=$dbinfo(host) port=$dbinfo(port)" |
||||
} |
||||
show_status "Connecting to $dbinfo(dbname)@$dbinfo(host)..." |
||||
|
||||
if {[catch {pg_connect -conninfo $conninfo} result]} { |
||||
show_status "" |
||||
tk_messageBox -title tkpsql -icon error -type ok \ |
||||
-parent $toplevel \ |
||||
-message "Failed to connect to database: $result" |
||||
return |
||||
} |
||||
set db $result |
||||
show_status "Connected to database $dbinfo(dbname)@$dbinfo(host)" |
||||
init_post_connect |
||||
set form_status 1 |
||||
} |
||||
|
||||
# Run special queries. See do_special and init_special. |
||||
proc run_special {code} { |
||||
global form_status special special_title |
||||
# Close the special query popup: |
||||
set form_status 1 |
||||
update |
||||
run_sql $special($code) $special_title($code) |
||||
} |
||||
|
||||
# ===== Menu Command Routines ===== |
||||
|
||||
# Manage the history list. |
||||
# If op is + or -, step the history pointer, and replace the input |
||||
# window contents with the history value (if not empty). If op is |
||||
# something else, enter it into the history table. |
||||
# When storing into the history list, synchronize the read and write |
||||
# indexes. |
||||
proc do_history {op} { |
||||
global history history_p history_q n_history |
||||
global widgets |
||||
if {$op == ""} return |
||||
debug_puts "do_history '$op' p=$history_p q=$history_q" |
||||
if {$op == "+"} { |
||||
set n $history_q |
||||
incr n |
||||
if {$n > $n_history} { |
||||
set n 1 |
||||
} |
||||
if {$history($n) == ""} return |
||||
set history_q $n |
||||
clear_input |
||||
$widgets(input) insert 1.0 $history($history_q) |
||||
} elseif {$op == "-"} { |
||||
set n $history_q |
||||
incr n -1 |
||||
if {$n < 1} { |
||||
set n $n_history |
||||
} |
||||
if {$history($n) == ""} return |
||||
set history_q $n |
||||
clear_input |
||||
$widgets(input) insert 1.0 $history($history_q) |
||||
} else { |
||||
# Delete trailing newlines to keep it neat. |
||||
set history($history_p) [string trimright $op] |
||||
incr history_p |
||||
if {$history_p > $n_history} { |
||||
set history_p 1 |
||||
} |
||||
set history_q $history_p |
||||
} |
||||
} |
||||
|
||||
# Connect to database: |
||||
proc do_connect {} { |
||||
global db dbinfo form_status |
||||
|
||||
if {$db != ""} do_disconnect |
||||
|
||||
# Initialize if never done. pg_conndefaults returns list of {key - - - value} |
||||
if {![info exists dbinfo(user)]} { |
||||
array set dbinfo {user {} host {} dbname {} port {} password {}} |
||||
foreach default [pg_conndefaults] { |
||||
setlist $default key unused1 unused2 unused3 value |
||||
if {[info exists dbinfo($key)]} { |
||||
set dbinfo($key) $value |
||||
} |
||||
} |
||||
} |
||||
# Build the Connect to Database popup: |
||||
set t [mk_window .dbconnect "Connect to DBMS"] |
||||
set f $t.entry |
||||
frame $f |
||||
label $f.host_l -text "Database Host:" |
||||
entry $f.host -width 24 -textvariable dbinfo(host) |
||||
label $f.port_l -text "Database Port:" |
||||
entry $f.port -width 12 -textvariable dbinfo(port) |
||||
label $f.dbname_l -text "Database Name:" |
||||
entry $f.dbname -width 16 -textvariable dbinfo(dbname) |
||||
label $f.user_l -text "Username:" |
||||
entry $f.user -width 12 -textvariable dbinfo(user) |
||||
label $f.password_l -text "Password:" |
||||
entry $f.password -width 24 -textvariable dbinfo(password) -show * |
||||
foreach field {host port dbname user password} { |
||||
grid $f.${field}_l $f.$field |
||||
grid configure $f.${field}_l -sticky e |
||||
grid configure $f.${field} -sticky w |
||||
} |
||||
mk_buttons $t "do_connect_done $t" |
||||
pack $t.entry $t.buttons -side top -fill x |
||||
set form_status -1 |
||||
window_wait $t $t.entry.host form_status |
||||
# At this point $form_status is 1 on OK, 0 on Cancel, but we really |
||||
# don't care because do_connect_done did all the work on OK. |
||||
} |
||||
|
||||
# Disconnect from the database: |
||||
proc do_disconnect {} { |
||||
global db dbinfo |
||||
if {$db == ""} return |
||||
pg_disconnect $db |
||||
show_status "Disconnected from database $dbinfo(dbname)@$dbinfo(host)" |
||||
set db {} |
||||
} |
||||
|
||||
# Load a file into the input window: |
||||
proc do_loadin {} { |
||||
global widgets pwd |
||||
|
||||
set fname [tk_getOpenFile -initialdir $pwd -title "Load input window"] |
||||
if {$fname == ""} return |
||||
set pwd [file dirname $fname] |
||||
if {[catch {open $fname} f]} { |
||||
tk_messageBox -title tkpsql -icon error -type ok \ |
||||
-message "Failed to open $fname: $f" |
||||
return |
||||
} |
||||
clear_input |
||||
$widgets(input) insert end [read -nonewline $f] |
||||
close $f |
||||
} |
||||
|
||||
# Save Input or Output text areas to a file. |
||||
proc do_save {which} { |
||||
global widgets pwd |
||||
|
||||
set fname [tk_getSaveFile -initialdir $pwd -title "Save $which window"] |
||||
if {$fname == ""} return |
||||
set pwd [file dirname $fname] |
||||
if {[catch {open $fname w} f]} { |
||||
tk_messageBox -title tkpsql -icon error -type ok \ |
||||
-message "Failed to open $fname: $f" |
||||
return |
||||
} |
||||
show_status "Saving text..." |
||||
puts -nonewline $f [$widgets($which) get 1.0 end] |
||||
close $f |
||||
show_status "" |
||||
} |
||||
|
||||
# Exit the program: |
||||
proc do_exit {} { |
||||
do_disconnect |
||||
exit |
||||
} |
||||
|
||||
# Run the SQL in the input window. First, remove any trailing newlines, |
||||
# spaces and ';' chars. |
||||
proc do_run {} { |
||||
global widgets |
||||
set sql [string trimright [$widgets(input) get 1.0 end] " \n;"] |
||||
do_history $sql |
||||
run_sql $sql |
||||
} |
||||
|
||||
# Clear the input and output boxes: |
||||
proc do_clear {} { |
||||
clear_input |
||||
clear_output |
||||
} |
||||
|
||||
# Display options dialog: |
||||
proc do_options {} { |
||||
global form_status option |
||||
# Save the current options to be restored if the form is Cancelled. |
||||
array set copy_option [array get option] |
||||
# Build the Options popup: |
||||
set t [mk_window .options "Set Options"] |
||||
set f $t.opt |
||||
frame $f |
||||
label $f.outstyle -text "Output Style:" |
||||
radiobutton $f.outstyle1 -text Narrow -variable option(outstyle) -value narrow |
||||
radiobutton $f.outstyle2 -text Wide -variable option(outstyle) -value wide |
||||
label $f.maxlook_l -text "Max rows to look at for column widths:" |
||||
entry $f.maxlook -width 5 -textvariable option(maxlook) |
||||
checkbutton $f.clear -text "Clear output before results" -variable option(clear) |
||||
checkbutton $f.debug -text Debug -variable option(debug) |
||||
|
||||
grid $f.outstyle $f.outstyle1 $f.outstyle2 |
||||
grid $f.maxlook_l - $f.maxlook |
||||
grid $f.clear - x |
||||
grid $f.debug x x |
||||
mk_buttons $t |
||||
|
||||
pack $t.opt $t.buttons -side top -fill x |
||||
set form_status -1 |
||||
window_wait $t $t.buttons.ok form_status |
||||
|
||||
# Restore the options on Cancel: |
||||
if {!$form_status} { |
||||
array set option [array get copy_option] |
||||
} |
||||
if {$option(debug)} { |
||||
parray option |
||||
} |
||||
} |
||||
|
||||
# Special queries. See init_special for the data which drives this. |
||||
proc do_special {} { |
||||
global form_status special special_title special_codes |
||||
|
||||
set t [mk_window .special "Special Queries"] |
||||
set packme {} |
||||
# Generate all the special query buttons: |
||||
foreach code $special_codes { |
||||
button $t.$code -text $special_title($code) -command "run_special $code" |
||||
lappend packme $t.$code |
||||
} |
||||
button $t.cancel -text Cancel -command "set form_status 0" |
||||
bind $t <Escape> "set form_status 0" |
||||
eval pack $packme $t.cancel -side top -fill x -padx 2 -pady 2 |
||||
set form_status -1 |
||||
window_wait $t $t.cancel form_status |
||||
} |
||||
|
||||
# ===== Main Window UI ===== |
||||
|
||||
# Build the main user interface: |
||||
proc build_ui {} { |
||||
global widgets version |
||||
|
||||
set f .buttons |
||||
frame $f |
||||
set buttons [list \ |
||||
[mk_button $f.run Run <F1> do_run] \ |
||||
[mk_button $f.clear Clear <F2> do_clear] \ |
||||
[mk_button $f.next_hist {History Next} <F3> {do_history +}] \ |
||||
[mk_button $f.prev_hist {History Prev} <F4> {do_history -}] \ |
||||
[mk_button $f.loadin {Load Input} <F5> do_loadin] \ |
||||
[mk_button $f.savein {Save Input} <F6> {do_save input}] \ |
||||
[mk_button $f.saveout {Save Output} <F7> {do_save output}] \ |
||||
[mk_button $f.connect Connect <F8> do_connect] \ |
||||
[mk_button $f.disconn Disconnect <F9> do_disconnect] \ |
||||
[mk_button $f.options Options <F10> do_options] \ |
||||
[mk_button $f.special Special <F11> do_special] \ |
||||
[mk_button $f.quit Exit <F12> do_exit] \ |
||||
] |
||||
eval pack $buttons -side top -fill x -padx 2 -pady 4 |
||||
|
||||
# Alternate bindings for keyboard without F11 or F12: |
||||
bind . <Alt-s> do_special |
||||
bind . <Alt-q> do_exit |
||||
# Forget bogus binding of F10 on unix platforms to traverse menus: |
||||
bind all <F10> {} |
||||
|
||||
# Frame .r holds the right-hand side with input, output, and status. |
||||
set f .r |
||||
frame $f |
||||
|
||||
# Output text area with horizontal and vertical scrollers: |
||||
# Must use monospace font so columns line up. |
||||
set widgets(output) $f.output |
||||
text $widgets(output) -relief sunken -borderwidth 2 -height 16 -width 64 \ |
||||
-wrap none -setgrid 1 -font monofont \ |
||||
-yscrollcommand "$f.oyscroll set" -xscrollcommand "$f.oxscroll set" |
||||
scrollbar $f.oyscroll -command "$f.output yview" |
||||
scrollbar $f.oxscroll -orient horizontal -command "$f.output xview" |
||||
# Tags for output area for special text display: |
||||
$widgets(output) tag configure under -underline on |
||||
$widgets(output) tag configure bold -font boldfont |
||||
|
||||
# Input text area: vertical scroller only, word wrap. |
||||
set widgets(input) $f.input |
||||
text $widgets(input) -relief sunken -borderwidth 2 -height 5 -width 64 \ |
||||
-wrap word \ |
||||
-yscrollcommand "$f.iyscroll set" |
||||
scrollbar $f.iyscroll -command "$f.input yview" |
||||
|
||||
# Status area: |
||||
set widgets(status) $f.status |
||||
label $widgets(status) -relief sunken -borderwidth 1 -anchor w |
||||
|
||||
# Grid up the output, input, and status with scroll bars: |
||||
grid $f.output $f.oyscroll |
||||
grid $f.oxscroll x |
||||
grid $f.input $f.iyscroll |
||||
grid $f.status - |
||||
# ... Set stickiness: |
||||
grid configure $f.input $f.output -sticky nsew |
||||
grid configure $f.oxscroll $f.status -sticky ew |
||||
grid configure $f.oyscroll $f.iyscroll -sticky ns |
||||
# ... Indicate that the output and input rows expand: |
||||
grid rowconfigure $f 0 -weight 3 |
||||
grid rowconfigure $f 2 -weight 1 |
||||
grid columnconfigure $f 0 -weight 1 |
||||
|
||||
pack .buttons .r -side left -fill both |
||||
pack configure .r -expand 1 |
||||
|
||||
# Main window setup: |
||||
wm title . "tkpsql $version" |
||||
wm iconname . tkpsql |
||||
wm protocol . WM_DELETE_WINDOW do_exit |
||||
center_window . ROOT |
||||
|
||||
focus $widgets(input) |
||||
# Needed on Windows, for some strange reason: |
||||
raise . |
||||
} |
||||
|
||||
# ===== Main program ===== |
||||
|
||||
initialize |
||||
build_ui |
||||
do_connect |
||||
@ -0,0 +1,7 @@
|
||||
PUBLISHER is a tclOO-class providing a general facility for implementing |
||||
the publisher-subscribers pattern. |
||||
|
||||
See |
||||
USERGUIDE.txt |
||||
and |
||||
REFERENCE.txt |
||||
@ -0,0 +1,75 @@
|
||||
publisher - 2.0 |
||||
|
||||
NAME |
||||
==== |
||||
publisher - publisher-subscribers pattern |
||||
|
||||
SYNOPSIS |
||||
======== |
||||
package require publisher |
||||
|
||||
::publisher new |
||||
pubName declare ?_event_ ...? |
||||
pubName notify _event_ ?data ...? |
||||
pubName destroy |
||||
|
||||
pubName register _event_ _tag_ _callback_ |
||||
pubName unregister _event_ _tag_ |
||||
pubName events ?pattern? |
||||
|
||||
Description |
||||
=========== |
||||
The *publisher* package provides a general facility for implementing the publisher-subscribers pattern. |
||||
|
||||
A publisher is an object usually attached to a master-object (e.g. a complex data structure such a list, a graph, a table, a database ...) that can raise events of public interest. |
||||
These events usually occur when something in the master-object changes. |
||||
The master-object knows nothing about its potentials subscribers; it simply tells the publisher to notify some events to all the (dynamically) registered subscribers. |
||||
|
||||
Subscribers (also referred as observers) are clients interested about changes occurring on that particular master-object. They inform the publisher they are interested on some events and give it a callback, i.e. a command that publisher should call every time events are generated. |
||||
Events may have parameters that will be passed to subscribers' callbacks. |
||||
|
||||
|
||||
COMMANDS |
||||
======== |
||||
|
||||
::publisher new |
||||
--------------- |
||||
Creates a new publisher object and returns its unique name (pubName). |
||||
|
||||
pubName declare ?_event_ ...? |
||||
------------------------------ |
||||
Adds one or more events to the list of declared events. |
||||
This list of declared events is a sort of mini-interface that subscribers may query. |
||||
|
||||
pubName notify _event_ ?data ...? |
||||
--------------------------------- |
||||
Causes all the registered callback to be independently called, with zero or more event-data. |
||||
|
||||
pubName destroy |
||||
--------------- |
||||
Destroys the publisher. A "!destroyed" event (with no event-data) is generated. |
||||
|
||||
pubName register _event_ _tag_ _callback_ |
||||
----------------------------------------- |
||||
Registers a _callback_ for a specific _event_ . |
||||
Each subscriber should provide a different string _tag_ . |
||||
|
||||
pubName unregister _event_ _tag_ |
||||
-------------------------------- |
||||
Un-registers the callback previously set for the {_event_ _tag_) pair. |
||||
_event_ may be "*" or any other glob-style pattern. |
||||
|
||||
pubName events ?_pattern_? |
||||
------------------------ |
||||
If _pattern_ is not specified, then lists all the declared events. |
||||
Else lists all the *registered* glob-style matching events with their tag and callbacks |
||||
e.g. |
||||
{!ev1 tag1 {callback1 callback2} !ev1 tag2 callback3 !evX tagY callbackZ } |
||||
|
||||
|
||||
CREDITS and COPYRIGHT |
||||
===================== |
||||
publisher - Copyright(c) 2012-2022 <Irrational Numbers> : <aldo.w.buratti@gmail.com> |
||||
|
||||
This package is free software; you can use, modify, and redistribute it for any purpose, provided that existing copyright notices are retained in all copies and that this notice is included verbatim in any distributions. |
||||
|
||||
@ -0,0 +1,112 @@
|
||||
PUBLISHER |
||||
========= |
||||
|
||||
PUBLISHER is a tclOO-class providing a general facility for implementing |
||||
the publisher-subscribers pattern. |
||||
|
||||
A publisher is an object usually attached to a master-object (e.g. a complex data structure such a list, a graph, a table, a database ...) that can raise events of public interest. |
||||
These events usually occur when something in the master-object changes. |
||||
The master-object knows nothing about its potentials subscribers; it simply tells the publisher to notify some events to all the (dynamically) registered subscribers. |
||||
|
||||
Subscribers (also referred as observers) are clients interested about changes occurring on that particular master-object. They inform the publisher they are interested on some events and give it a callback, i.e. a command that publisher should call every time events are generated. |
||||
Events may have parameters that will be passed to subscribers' callbacks. |
||||
|
||||
|
||||
RECOMMENDED NAMING CONVENTIONS |
||||
------------------------------ |
||||
These naming conventions are not mandatory. You are encouraged to follow them - or any other coherent set of conventions - just because they help to write a more readable code (without the need of extra "comments"). |
||||
|
||||
* Each *event-name* has a leading "!" (e.g !ev1 !alert ...) |
||||
* Each event may carry details (*event's data*) as a list of key-values; Keys have a leading "-" (e.g. -color blue -temperature 100.0 .... ) |
||||
* Each different *subscriber* must be identified by a different "id". |
||||
If subscriber is a widget, "id" could be the widget-name |
||||
If subscriber is a (snit) object, "id" could be its name |
||||
Otherwise, you should choose an "id", provided it is unique among all possible subscribers (of the same publisher) |
||||
* Each *callback* name should be "On!event" (e.g. On!alert ) |
||||
|
||||
|
||||
How to interact with a publisher (subscribers-side) |
||||
-------------------------------------------------- |
||||
Let's suppose we have a publisher ($pub) attached to a master-object and some observers wishing to be informed whenever a change in the master-object occur. |
||||
The folllowing command lists all the possible events |
||||
$pub events ;# --> { !configure !alert !full !evXYZ !destroyed } |
||||
Then an observer (whose "id" is "$obsA") interested on event "!evXYZ" should |
||||
1) setup a callback |
||||
proc On!evXYZ {args} { |
||||
array set param $args |
||||
.. do something with param(-color), param(-x) param(-y) .... |
||||
} |
||||
2) tell the publisher to call its callback for all the next notifications. |
||||
$pub register !evXYZ $obsA On!evXYZ |
||||
|
||||
Of course each different event may provide different details (event-data), and it is the subscriber's responsibility to setup a conformant callback. |
||||
|
||||
|
||||
When an observer ($obsA) is no more interested in publisher's notifications it must revoke the subscription |
||||
$pub unregister !evXYZ $obsA ;# revoke subscription for event !evXYZ |
||||
or |
||||
$pub unregister * $obsA ;# revoke ALL its-own subscriptions |
||||
|
||||
Note that an observer MUST revoke ALL its subscriptions before being destroyed, or the publisher will send all next events to a no-more-existing client. |
||||
|
||||
** Universal callback ** |
||||
For testing purpose with just few lines of code, you can setup an universal callback, able to print every detail, catching all possible events: |
||||
# Universal-callback; note the first two "fixed" parameters ... |
||||
proc On!EveryEvent {ev pub args} { |
||||
puts "event ($ev) from ($pub)" |
||||
foreach {key val} $args { |
||||
puts "\tkey: ($key) -- ($val)" |
||||
} |
||||
} |
||||
# register for all events |
||||
foreach ev [$pub events] { |
||||
$pub register $ev $obsA [list On!EveryEvent $ev $pub] |
||||
} |
||||
Note that the first two parameters of the callback are fixed at "register-time"; the publisher only "appends" events-data (as the usual key-value list) to a command with two "pre-fixed" parameters. |
||||
|
||||
|
||||
|
||||
How to interact with subscribers (publisher--side) |
||||
-------------------------------------------------- |
||||
When a master-object needs to interact with several observers, it must create its own publisher for handling such interactions. |
||||
|
||||
First, master-object creates a publisher: |
||||
set pub [publisher new] |
||||
or |
||||
set pub [publisher create _name_] |
||||
Then it declares the names of events it will provide |
||||
$pub declare !evA !evB !evC |
||||
or |
||||
$pub declare !evA ; $pub declare !evB !evC |
||||
|
||||
Other than the explicitelly declared event-names, all publishers always provide a standard event named "!destroyed" informing the subscribers that it has been .. destroyed (usually by the master-object). |
||||
This standard event doesn't need to be declared. |
||||
The !destroyed event carries no event-data. |
||||
|
||||
Note that (currently) when declaring events there is no way to declare the parameters (event-data). |
||||
It's just a matter of good documentation practice: each publishers should document all its events, their meanings, and their parameters. |
||||
|
||||
*** It is strongly recommended that parameters always be transmitted as an unordered list of key-value pairs. |
||||
This key-value convention allows to upgrade the publisher-part ( e.g. adding a parameter "-speed" for a given event), without the need to rewrite the previous subscribers callbacks. (Of course non-upgraded subscribers will simply ignore the new parameter). *** |
||||
|
||||
|
||||
|
||||
When a change in the master-object occur, the master-object must tell to its publisher to notify the event. |
||||
$pub notify !itemRemoved -id 42342 |
||||
$pub notify !itemAdded -id 12312 -parent 1239866 |
||||
$pub notify !itemConfigured -id 23452 -color blue -rank "A" |
||||
|
||||
Note that master-object knows nothing about its currently registered subscribers; that's the publisher's job! |
||||
|
||||
When a master-object deletes its publisher, the publisher implicitely trasmits a last event |
||||
$pub notify !destroyed |
||||
Subscribers should simply 'forget' the publisher, without the need to unregister their callback (in fact, they can't unregister, because there is no publisher to contact!) |
||||
|
||||
|
||||
=== Publisher-Subscribers vs. Tk-events ======================================= |
||||
|
||||
The main difference to the event system built into the Tcl/Tk core is that the latter can generate only virtual events, and only for Tk-widgets. |
||||
It is not possible to use the builtin facilities to bind to events on arbitrary (non-Tk-)objects, nor is it able to generate events for such. |
||||
|
||||
Moreover, even for widgets, the bind-event system is rather clumsy when multiple callbacks should be independently attached (bind) to an event, and indipendently detached. |
||||
The publisher-subscribers system can be used in a coherent way both for Tk-widgets and for arbitrary objects. |
||||
@ -1,13 +1,14 @@
|
||||
# Tcl package index file, version 1.1 |
||||
# This file is generated by the "pkg_mkIndex" command |
||||
# and sourced either when an application starts up or |
||||
# by a "package unknown" script. It invokes the |
||||
# "package ifneeded" command to set up package-related |
||||
# information so that packages will be loaded automatically |
||||
# in response to "package require" commands. When this |
||||
# script is sourced, the variable $dir must contain the |
||||
# full path name of this file's directory. |
||||
|
||||
if { ![package vsatisfies [package provide Tcl] 8.4-] } { return } |
||||
package ifneeded history 0.1 [list source [file join $dir history.tcl]] |
||||
|
||||
# Tcl package index file, version 1.0 |
||||
# This file is generated by the "pkg_mkIndex" command |
||||
# and sourced either when an application starts up or |
||||
# by a "package unknown" script. It invokes the |
||||
# "package ifneeded" command to set up package-related |
||||
# information so that packages will be loaded automatically |
||||
# in response to "package require" commands. When this |
||||
# script is sourced, the variable $dir must contain the |
||||
# full path name of this file's directory. |
||||
|
||||
|
||||
package ifneeded publisher 2.0 \ |
||||
[list source [file join $dir publisher.tcl]] |
||||
|
||||
@ -0,0 +1,117 @@
|
||||
## publisher.tcl |
||||
|
||||
## publisher - publisher-subscribers pattern |
||||
## |
||||
## Copyright (c) 2012-2020 <Irrational Numbers> : <aldo.w.buratti@gmail.com> |
||||
## |
||||
## |
||||
## This library is free software; you can use, modify, and redistribute it |
||||
## for any purpose, provided that existing copyright notices are retained |
||||
## in all copies and that this notice is included verbatim in any |
||||
## distributions. |
||||
## |
||||
## This software is distributed WITHOUT ANY WARRANTY; without even the |
||||
## implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. |
||||
## |
||||
|
||||
# |
||||
# How to use 'publisher': |
||||
# Read "publisher.txt" for detailed info. |
||||
# |
||||
|
||||
package provide publisher 2.0 |
||||
|
||||
oo::class create publisher { |
||||
variable myEvents myCallbacks |
||||
|
||||
constructor {} { |
||||
set myEvents {} |
||||
array set myCallbacks {} |
||||
# all publishers provide a "!destroyed" event |
||||
my declare !destroyed |
||||
} |
||||
|
||||
destructor { |
||||
my notify !destroyed |
||||
} |
||||
|
||||
# Publisher-side method |
||||
# |
||||
# Declare all the provided events. |
||||
# NOTE: declaring an event twice, is not an error, it's only stupid. |
||||
# On the subscribers-side, a subscribe can inspects all the provided events |
||||
# with the 'events' method. |
||||
method declare {args} { |
||||
eval lappend myEvents $args |
||||
# remove duplicated events |
||||
set myEvents [lsort -unique $myEvents] |
||||
} |
||||
|
||||
# an invalid tag (subscriber-id) is a tag containing "glob" chars (*?) |
||||
method IsInvalidTag {tag} { |
||||
expr [regexp -- {[*?]} $tag] |
||||
} |
||||
|
||||
# Subscribers-side method |
||||
# |
||||
# register a callback for a given event. |
||||
# 'tag' is simply an id denoting the caller (it should be used for unregister-ing). |
||||
# 'tag' should not contain "glob" chars (?*) |
||||
method register { ev tag callback } { |
||||
if { [lsearch -exact $myEvents $ev] == -1 } { |
||||
error "event \"$ev\" not available" |
||||
} |
||||
if { [my IsInvalidTag $tag] } { |
||||
error "tag \"$tag\" is not valid." |
||||
} |
||||
lappend myCallbacks($ev,$tag) $callback |
||||
} |
||||
|
||||
# Subscribers-side method |
||||
# |
||||
# Unregister all the callbacks associated with a given tag |
||||
# for a single event or an evPattern. |
||||
# evPattern : event-name or "*" (or any string with "glob" chars) |
||||
# tag: just a tag |
||||
# Notes: |
||||
# It's not an error if there's no registered event associated with tag. |
||||
# Raise an error if tag contains special glob chars (*?) |
||||
method unregister {evPattern tag} { |
||||
if { [my IsInvalidTag $tag] } { |
||||
error "tag \"$tag\" contains disallowed chars." |
||||
} |
||||
array unset myCallbacks $evPattern,$tag |
||||
} |
||||
|
||||
# Publisher-side method |
||||
# |
||||
# Send an event-notification to all subscribers. |
||||
# The effect is to execute *synchronously* all the registered callbacks |
||||
# for that event. |
||||
# Any error raised during the callback run is silently ignored. |
||||
method notify {ev args} { |
||||
foreach { key hList } [array get myCallbacks $ev,*] { |
||||
foreach func $hList { |
||||
catch { uplevel #0 $func $args } |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Subscribers-side method |
||||
# |
||||
# events --> lists all events |
||||
# events * --> lists all registered events with their tag and callback |
||||
# e.g. {!ev1 tag1 {cb1 cb2} !ev1 tag2 cb3 !evX tagY cbZ } |
||||
# events !a* --> same as above, limited to events matching "!a*" |
||||
method events { {evPattern {}} } { |
||||
if { $evPattern == {} } { |
||||
return $myEvents |
||||
} |
||||
set L {} |
||||
foreach { key hList } [array get myCallbacks $evPattern,*] { |
||||
lassign [split $key ","] ev tag |
||||
lappend L $ev $tag $hList |
||||
} |
||||
return $L |
||||
} |
||||
} |
||||
@ -1,9 +0,0 @@
|
||||
# pkgIndex.tcl -- |
||||
# |
||||
# Copyright (c) 2003 ActiveState Corporation. |
||||
# All rights reserved. |
||||
# |
||||
# RCS: @(#) $Id: pkgIndex.tcl,v 1.11 2011/10/05 00:10:46 hobbs Exp $ |
||||
|
||||
package ifneeded ico 0.3.2 [list source [file join $dir ico0.tcl]] |
||||
package ifneeded ico 1.1 [list source [file join $dir ico.tcl]] |
||||
@ -1,105 +0,0 @@
|
||||
#notifywindow.tcl: provides routines for posting a Growl-style "notification window" in the upper right corner of the screen, fading in and out in an unobtrusive fashion |
||||
|
||||
#(c) 2015-2019 Kevin Walzer/WordTech Communications LLC. License: standard Tcl license, http://www.tcl.tk/software/tcltk/license.html |
||||
|
||||
package provide notifywindow 1.0 |
||||
|
||||
namespace eval notifywindow { |
||||
|
||||
#Main procedure for window |
||||
|
||||
proc notifywindow {msg img} { |
||||
set w [toplevel ._notify] |
||||
if {[tk windowingsystem] eq "aqua"} { |
||||
::tk::unsupported::MacWindowStyle style $w utility {hud |
||||
closeBox resizable} |
||||
wm title $w "Alert" |
||||
} |
||||
if {[tk windowingsystem] eq "win32"} { |
||||
wm attributes $w -toolwindow true |
||||
wm title $w "Alert" |
||||
} |
||||
if {[lsearch [image names] $img] > -1} { |
||||
label $w.l -bg gray30 -fg white -image $img |
||||
pack $w.l -fill both -expand yes -side left |
||||
} |
||||
message $w.message -aspect 150 -bg gray30 -fg white -aspect 150 -text $msg -width 280 |
||||
pack $w.message -side right -fill both -expand yes |
||||
if {[tk windowingsystem] eq "x11"} { |
||||
wm overrideredirect $w true |
||||
} |
||||
wm attributes $w -alpha 0.0 |
||||
puts [winfo reqwidth $w] |
||||
set xpos [expr [winfo screenwidth $w] - 325] |
||||
wm geometry $w +$xpos+30 |
||||
notifywindow::fade_in $w |
||||
after 3000 notifywindow::fade_out $w |
||||
} |
||||
|
||||
#Fade and destroy window |
||||
proc fade_out {w} { |
||||
catch { |
||||
set prev_degree [wm attributes $w -alpha] |
||||
set new_degree [expr $prev_degree - 0.05] |
||||
set current_degree [wm attributes $w -alpha $new_degree] |
||||
if {$new_degree > 0.0 && $new_degree != $prev_degree} { |
||||
after 10 [list notifywindow::fade_out $w] |
||||
} else { |
||||
destroy $w |
||||
} |
||||
|
||||
} |
||||
} |
||||
|
||||
#Fade the window into view |
||||
proc fade_in {w} { |
||||
catch { |
||||
raise $w |
||||
wm attributes $w -topmost 1 |
||||
set prev_degree [wm attributes $w -alpha] |
||||
set new_degree [expr $prev_degree + 0.05] |
||||
set current_degree [wm attributes $w -alpha $new_degree] |
||||
focus -force $w |
||||
if {$new_degree < 0.9 && $new_degree != $prev_degree} { |
||||
after 10 [list notifywindow::fade_in $w] |
||||
} else { |
||||
return |
||||
} |
||||
} |
||||
} |
||||
|
||||
#The obligatory demo |
||||
proc demo {} { |
||||
|
||||
image create photo flag -data { |
||||
R0lGODlhFAAUAPcAAAAAAIAAAACAAICAAAAAgIAAgACAgMDAwMDcwKbK8P/w1Pjisd/UjtHJ |
||||
a8O4SL2qJcWqAK+SAJN6AGJiAEpKADIyAP/j1P/Hsf+rjv+Pa/9zSP9XJf9VANxJALk9AJYx |
||||
AHMlAFAZAP/U1P+xsf+Ojv9ra/9ISP8lJf4AANwAALkAAJYAAHMAAFAAAP/U4/+xx/+Oq/9r |
||||
j/9Ic/8lV/8AVdwASbkAPZYAMXMAJVAAGf/U8P+x4v+O1P9rxv9IuP8lqv8AqtwAkrkAepYA |
||||
YnMASlAAMv/U//+x//+O//9r//9I//8l//4A/twA3LkAuZYAlnMAc1AAUPDU/+Kx/9SO/8Zr |
||||
/7hI/6ol/6oA/5IA3HoAuWIAlkoAczIAUOPU/8ex/6uO/49r/3NI/1cl/1UA/0kA3D0AuTEA |
||||
liUAcxkAUNTU/7Gx/46O/2tr/0hI/yUl/wAA/gAA3AAAuQAAlgAAcwAAUNTj/7HH/46r/2uP |
||||
/0hz/yVX/wBV/wBJ3AA9uQAxlgAlcwAZUNTw/7Hi/47U/2vG/0i4/yWq/wCq/wCS3AB6uQBi |
||||
lgBKcwAyUNT//7H//47//2v//0j//yX//wD+/gDc3AC5uQCWlgBzcwBQUNT/8LH/4o7/1Gv/ |
||||
xkj/uCX/qgD/qgDckgC5egCWYgBzSgBQMtT/47H/x47/q2v/j0j/cyX/VwD/VQDcSQC5PQCW |
||||
MQBzJQBQGdT/1LH/sY7/jmv/a0j/SCX/JQD+AADcAAC5AACWAABzAABQAOP/1Mf/sav/jo// |
||||
a3P/SFf/JVX/AEncAD25ADGWACVzABlQAPD/1OL/sdT/jsb/a7j/SKr/Jar/AJLcAHq5AGKW |
||||
AEpzADJQAP//1P//sf//jv//a///SP//Jf7+ANzcALm5AJaWAHNzAFBQAPLy8ubm5tra2s7O |
||||
zsLCwra2tqqqqp6enpKSkoaGhnp6em5ubmJiYlZWVkpKSj4+PjIyMiYmJhoaGg4ODv/78KCg |
||||
pICAgP8AAAD/AP//AAAA//8A/wD//////yH5BAEAAAEALAAAAAAUABQAAAiZAAMIHEhQoLqD |
||||
CAsqFAigIQB3Dd0tNKjOXSxXrmABWBABgLqCByECuAir5EYJHimKvOgqFqxXrzZ2lBhgJUaY |
||||
LV/GOpkSIqybOF3ClPlQIEShMF/lfLVzAcqPRhsKXRqTY1GCFaUy1ckTKkiRGhtapTkxa82u |
||||
ExUSJZs2qtOUbQ2ujTsQ4luvbdXNpRtA712+UeEC7ou3YEAAADt= |
||||
} |
||||
|
||||
notifywindow::notifywindow "Man page for Message\n\nSpecifies a non-negative integer value indicating desired aspect ratio for the text. The aspect ratio is specified as 100*width/height. 100 means the text should be as wide as it is tall, 200 means the text should be twice as wide as it is tall, 50 means the text should be twice as tall as it is wide, and so on. Used to choose line length for text if -width option is not specified. Defaults to 150." flag |
||||
|
||||
} |
||||
|
||||
namespace export * |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@ -1,2 +0,0 @@
|
||||
if {![package vsatisfies [package provide Tcl] 8.5-]} {return} |
||||
package ifneeded ntext 1.0b6 [list source [file join $dir ntext.tcl]] |
||||
@ -1,2 +0,0 @@
|
||||
package ifneeded shtmlview::shtmlview 1.1.0 [list source [file join $dir shtmlview.tcl]] |
||||
package ifneeded shtmlview::doctools 0.1 [list source [file join $dir shtmlview-doctools.tcl]] |
||||
@ -1,3 +0,0 @@
|
||||
# Package index file created with stooop version 4.4.1 for stooop packages |
||||
|
||||
package ifneeded tkpiechart 6.6 [list source [file join $dir tkpiechart.tcl]] |
||||
@ -1,32 +0,0 @@
|
||||
# Tcl Package Index File 1.0 |
||||
if {![llength [info commands ::tcl::pkgindex]]} { |
||||
proc ::tcl::pkgindex {dir bundle bundlev packages} { |
||||
set allpkgs [list] |
||||
foreach {pkg ver file} $packages { |
||||
lappend allpkgs [list package require $pkg $ver] |
||||
package ifneeded $pkg $ver [list source [file join $dir $file]] |
||||
} |
||||
if {$bundle != ""} { |
||||
lappend allpkgs [list package provide $bundle $bundlev] |
||||
package ifneeded $bundle $bundlev [join $allpkgs \n] |
||||
} |
||||
return |
||||
} |
||||
} |
||||
if {![package vsatisfies [package provide Tcl] 8.4-]} {return} |
||||
::tcl::pkgindex $dir widget::all 1.2.4 { |
||||
widget 3.1 widget.tcl |
||||
widget::arrowbutton 1.0 arrowb.tcl |
||||
widget::calendar 1.0.1 calendar.tcl |
||||
widget::dateentry 0.96 dateentry.tcl |
||||
widget::dialog 1.3.1 dialog.tcl |
||||
widget::menuentry 1.0.1 mentry.tcl |
||||
widget::panelframe 1.1 panelframe.tcl |
||||
widget::ruler 1.1 ruler.tcl |
||||
widget::screenruler 1.2 ruler.tcl |
||||
widget::scrolledtext 1.0 stext.tcl |
||||
widget::scrolledwindow 1.2.1 scrollw.tcl |
||||
widget::statusbar 1.2.1 statusbar.tcl |
||||
widget::superframe 1.0.1 superframe.tcl |
||||
widget::toolbar 1.2.1 toolbar.tcl |
||||
} |
||||
@ -0,0 +1,51 @@
|
||||
# *- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
# Copyright (c) 2014 andreas Kupries, Arjen Markus |
||||
# OLL licensed (http://wiki.tcl.tk/10892). |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.5- |
||||
package require Tk 8.5- |
||||
package require pdf4tcl |
||||
package require fileutil |
||||
|
||||
namespace eval ::canvas {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Implementation. |
||||
|
||||
proc ::canvas::pdf {canvas} { |
||||
#raise [winfo toplevel $canvas] |
||||
#update |
||||
|
||||
set tmp [fileutil::tempfile canvas_pdf_] |
||||
|
||||
# Note: The paper dimensions are hardcoded. A bit less than A7, |
||||
# looks like. This looks to be something which could be improved |
||||
# on. |
||||
|
||||
# Note 2: We go through a temp file to write the pdf, and load it |
||||
# back into memory for the caller to use. |
||||
|
||||
set pdf [::pdf4tcl::new %AUTO% -paper {9.5c 6.0c}] |
||||
$pdf canvas $canvas -width 9.2c |
||||
$pdf write -file $tmp |
||||
$pdf destroy |
||||
|
||||
set data [fileutil::cat $tmp] |
||||
file delete $tmp |
||||
|
||||
return $data |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Helper commands. Internal. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide canvas::pdf 1.0.1 |
||||
return |
||||
@ -1,3 +1,3 @@
|
||||
if { ![package vsatisfies [package provide Tcl] 8.4-] } { return } |
||||
package ifneeded ipentry 0.3 [list source [file join $dir ipentry.tcl]] |
||||
package ifneeded history 0.3 [list source [file join $dir history.tcl]] |
||||
|
||||
@ -0,0 +1,7 @@
|
||||
# pkgIndex.tcl -- |
||||
# |
||||
# Copyright (c) 2003 ActiveState Corporation. |
||||
# All rights reserved. |
||||
|
||||
package ifneeded ico 0.3.5 [list source [file join $dir ico0.tcl]] |
||||
package ifneeded ico 1.1.3 [list source [file join $dir ico.tcl]] |
||||
@ -0,0 +1,3 @@
|
||||
if { ![package vsatisfies [package provide Tcl] 8.4-] } { return } |
||||
package ifneeded ipentry 0.3.2 [list source [file join $dir ipentry.tcl]] |
||||
|
||||
@ -0,0 +1 @@
|
||||
package ifneeded khim 1.0.3 [list source [file join $dir khim.tcl]] |
||||
@ -0,0 +1,229 @@
|
||||
## -*- tcl -*- |
||||
# # ## ### ##### ######## ############# ###################### |
||||
## (c) 2022 Andreas Kupries |
||||
|
||||
# @@ Meta Begin |
||||
# Package map::area::display 0.1 |
||||
# Meta author {Andreas Kupries} |
||||
# Meta location https://core.tcl.tk/tklib |
||||
# Meta platform tcl |
||||
# Meta summary Widget to display a single area definition |
||||
# Meta description Widget to display the information of a single area definition |
||||
# Meta subject {area display, tabular} |
||||
# Meta subject {tabular, area display} |
||||
# Meta require {Tcl 8.6-} |
||||
# Meta require {Tk 8.6-} |
||||
# Meta require debug |
||||
# Meta require debug::caller |
||||
# Meta require {map::slippy 0.8} |
||||
# Meta require scrollutil |
||||
# Meta require snit |
||||
# Meta require tablelist |
||||
# @@ Meta End |
||||
|
||||
## TODO / focus - active vertex / row map ... |
||||
|
||||
package provide map::area::display 0.1 |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## API |
||||
# |
||||
## <class> OBJ |
||||
# |
||||
## <obj> set AREA -> VOID Show this area, or nothing, if empty |
||||
# |
||||
## -on-selection Report changes to the vertext selection |
||||
# |
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Requirements |
||||
|
||||
package require Tcl 8.6- |
||||
package require Tk 8.6- |
||||
# ;# Tcllib |
||||
package require debug ;# - Narrative Tracing |
||||
package require debug::caller ;# |
||||
package require map::slippy 0.8 ;# - Map utilities |
||||
package require snit ;# - OO system |
||||
# ;# Tklib |
||||
package require scrollutil ;# - Scroll framework |
||||
package require tablelist ;# - Tabular display |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
## Ensemble setup. |
||||
|
||||
namespace eval map { namespace export area ; namespace ensemble create } |
||||
namespace eval map::area { namespace export display ; namespace ensemble create } |
||||
|
||||
debug level tklib/map/area/display |
||||
debug prefix tklib/map/area/display {<[pid]> [debug caller] | } |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
|
||||
snit::widget ::map::area::display { |
||||
# . . .. ... ..... ........ ............. ..................... |
||||
# User configuration |
||||
|
||||
option -on-selection -default {} |
||||
|
||||
# . . .. ... ..... ........ ............. ..................... |
||||
## State |
||||
|
||||
variable myspec {} ;# Table data derived from the area specification |
||||
variable myparts ;# Area statistics: Number of parts |
||||
variable myperimeter ;# Area statistics: Perimeter |
||||
variable mydiameter ;# Area statistics: Diameter |
||||
variable myclat ;# Area statistics: Center Latitude |
||||
variable myclon ;# Area statistics: Center Longitude |
||||
|
||||
# . . .. ... ..... ........ ............. ..................... |
||||
## Lifecycle |
||||
|
||||
constructor {args} { |
||||
debug.tklib/map/area/display {} |
||||
|
||||
$self configurelist $args |
||||
|
||||
label $win.lcenter -text Center |
||||
label $win.clat -textvariable [myvar myclat] |
||||
label $win.clon -textvariable [myvar myclon] |
||||
label $win.lparts -text Parts |
||||
label $win.parts -textvariable [myvar myparts] |
||||
label $win.llength -text Perimeter |
||||
label $win.length -textvariable [myvar myperimeter] |
||||
label $win.ldiameter -text Diameter |
||||
label $win.diameter -textvariable [myvar mydiameter] |
||||
|
||||
scrollutil::scrollarea $win.sa |
||||
tablelist::tablelist $win.sa.table -width 60 \ |
||||
-columntitles {\# Latitude Longitude Distance Total} |
||||
$win.sa setwidget $win.sa.table |
||||
|
||||
pack $win.sa -in $win -side bottom -fill both -expand 1 |
||||
|
||||
pack $win.lcenter -in $win -side left |
||||
pack $win.clat -in $win -side left |
||||
pack $win.clon -in $win -side left |
||||
pack $win.lparts -in $win -side left |
||||
pack $win.parts -in $win -side left |
||||
pack $win.llength -in $win -side left |
||||
pack $win.length -in $win -side left |
||||
pack $win.ldiameter -in $win -side left |
||||
pack $win.diameter -in $win -side left |
||||
|
||||
$win.sa.table configure -listvariable [myvar myspec] |
||||
|
||||
bind $win.sa.table <<TablelistSelect>> [mymethod SelectionChanged] |
||||
return |
||||
} |
||||
|
||||
destructor { |
||||
debug.tklib/map/area/display {} |
||||
return |
||||
} |
||||
|
||||
# . . .. ... ..... ........ ............. ..................... |
||||
## API |
||||
|
||||
method focus {index} { |
||||
debug.tklib/map/area/display {} |
||||
|
||||
$win.sa.table selection clear 0 end |
||||
$win.sa.table selection set $index |
||||
$win.sa.table see $index |
||||
return |
||||
} |
||||
|
||||
method set {geos} { |
||||
debug.tklib/map/area/display {} |
||||
|
||||
if {![llength $geos]} { |
||||
set myspec {} |
||||
set mydiameter n/a |
||||
set myperimeter n/a |
||||
set myparts n/a |
||||
set myclat n/a |
||||
set myclon n/a |
||||
return |
||||
} |
||||
|
||||
set parts [llength $geos] ; if {$parts < 3} { incr parts -1 } |
||||
set diameter [map slippy geo diameter-list $geos] |
||||
set center [map slippy geo center-list $geos] |
||||
lassign [map slippy geo limit $center] clat clon |
||||
|
||||
# Assemble table data |
||||
|
||||
set last {} |
||||
set total 0 |
||||
set rows [lmap g $geos { |
||||
set dd {} |
||||
set dt {} |
||||
if {$last ne {}} { |
||||
set d [map slippy geo distance $last $g] |
||||
set total [expr {$total + $d}] |
||||
# Format for display |
||||
set dd [map slipp pretty-distance $d] |
||||
set dt [map slipp pretty-distance $total] |
||||
} |
||||
|
||||
lassign [map slippy geo limit $g] lat lon |
||||
set last $g |
||||
|
||||
set data {} |
||||
lappend data [incr rowid] |
||||
lappend data $lat |
||||
lappend data $lon |
||||
lappend data $dd |
||||
lappend data $dt |
||||
set data |
||||
}] |
||||
|
||||
# A last line to close the perimeter |
||||
set d [map slippy geo distance $last [lindex $geos 0]] |
||||
set total [expr {$total + $d}] |
||||
# Format for display |
||||
set dd [map slipp pretty-distance $d] |
||||
set dt [map slipp pretty-distance $total] |
||||
|
||||
lappend rows [list 1 {} {} $dd $dt] |
||||
|
||||
# ... and commit |
||||
set myparts $parts |
||||
set myperimeter $dt |
||||
set mydiameter [map slippy pretty-distance $diameter] |
||||
set myspec $rows |
||||
set myclat $clat |
||||
set myclon $clon |
||||
return |
||||
} |
||||
|
||||
# . . .. ... ..... ........ ............. ..................... |
||||
# Internal |
||||
|
||||
method SelectionChanged {} { |
||||
debug.tklib/map/area/display {} |
||||
|
||||
after idle [mymethod ReportSelectionChange] |
||||
return |
||||
} |
||||
|
||||
method ReportSelectionChange {} { |
||||
debug.tklib/map/area/display {} |
||||
|
||||
if {![llength $options(-on-selection)]} return |
||||
|
||||
set row [$win.sa.table curselection] |
||||
if {$row eq {}} return |
||||
|
||||
set row [lindex $myspec $row 0] |
||||
incr row -1 |
||||
|
||||
uplevel #0 [list {*}$options(-on-selection) $row] |
||||
return |
||||
} |
||||
|
||||
# . . .. ... ..... ........ ............. ..................... |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ###################### |
||||
return |
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in new issue