From: Jan Wieck <jwieck@debis.com>

    A few minutes ago I sent down the PL/Tcl  directory  to  this
    list.  Look at it and reuse anything that might help to build
    PL/perl.  I really hope that PL/perl and PL/Tcl appear in the
    6.3 distribution. I'll do whatever I can to make this happen.

diff --git a/src/pl/tcl/modules/README b/src/pl/tcl/modules/README
new file mode 100644 (file)
index 0000000..4a948c5
--- /dev/null
+++ b/src/pl/tcl/modules/README
@@ -0,0 +1,22 @@
+
+    The module support over the unknown command requires, that
+    the PL/Tcl call handler is compiled with -DPLTCL_UNKNOWN_SUPPORT.
+
+    Regular Tcl scripts of any size (over 8K :-) can be loaded into
+    the table pltcl_modules using the pltcl_loadmod script. The script
+    checks the modules that the procedure names don't overwrite
+    existing ones before doing anything. They also check for global
+    variables created at load time.
+
+    All procedures defined in the module files are automatically
+    added to the table pltcl_modfuncs. This table is used by the
+    unknown procedure to determine if an unknown command can be
+    loaded by sourcing a module. In that case the unknonw procedure
+    will silently source in the module and reexecute the original
+    command that invoked unknown.
+
+    I know, thist readme should be more explanatory - but time.
+
+
+Jan
+

diff --git a/src/pl/tcl/modules/pltcl_delmod b/src/pl/tcl/modules/pltcl_delmod
new file mode 100755 (executable)
index 0000000..79be7e5
--- /dev/null
+++ b/src/pl/tcl/modules/pltcl_delmod
@@ -0,0 +1,116 @@
+#!/bin/sh
+# Start tclsh \
+exec tclsh "$0" $@
+
+#
+# Code still has to be documented
+#
+
+#load /usr/local/pgsql/lib/libpgtcl.so
+package require Pgtcl
+
+
+#
+# Check for minimum arguments
+#
+if {$argc < 1} {
+    puts stderr ""
+    puts stderr "usage: pltcl_delmod dbname \[options\] modulename \[...\]"
+    puts stderr ""
+    puts stderr "options:"
+    puts stderr "    -host hostname"
+    puts stderr "    -port portnumber"
+    puts stderr ""
+    exit 1
+}
+
+#
+# Remember database name and initialize options
+#
+set dbname [lindex $argv 0]
+set options ""
+set errors 0
+set opt ""
+set val ""
+
+set i 1
+while {$i < $argc} {
+    if {[string compare [string index [lindex $argv $i] 0] "-"] != 0} {
+        break;
+    }
+
+    set opt [lindex $argv $i]
+    incr i
+    if {$i >= $argc} {
+        puts stderr "no value given for option $opt"
+       incr errors
+       continue
+    }
+    set val [lindex $argv $i]
+    incr i
+
+    switch -- $opt {
+        -host {
+           append options "-host \"$val\" "
+       }
+       -port {
+           append options "-port $val "
+       }
+       default {
+           puts stderr "unknown option '$opt'"
+           incr errors
+       }
+    }
+}
+
+#
+# Final syntax check
+#
+if {$i >= $argc || $errors > 0} {
+    puts stderr ""
+    puts stderr "usage: pltcl_delmod dbname \[options\] modulename \[...\]"
+    puts stderr ""
+    puts stderr "options:"
+    puts stderr "    -host hostname"
+    puts stderr "    -port portnumber"
+    puts stderr ""
+    exit 1
+}
+
+proc delmodule {conn modname} {
+    set xname $modname
+    regsub -all {\\} $xname {\\} xname
+    regsub -all {'}  $xname {''} xname
+
+    set found 0
+    pg_select $conn "select * from pltcl_modules where modname = '$xname'" \
+    MOD {
+        set found 1
+       break;
+    }
+
+    if {!$found} {
+        puts "Module $modname not found in pltcl_modules"
+       puts ""
+       return
+    }
+
+    pg_result \
+        [pg_exec $conn "delete from pltcl_modules where modname = '$xname'"] \
+       -clear
+    pg_result \
+        [pg_exec $conn "delete from pltcl_modfuncs where modname = '$xname'"] \
+       -clear
+
+    puts "Module $modname removed"
+}
+
+set conn [eval pg_connect $dbname $options]
+
+while {$i < $argc} {
+    delmodule $conn [lindex $argv $i]
+    incr i
+}
+
+pg_disconnect $conn
+

diff --git a/src/pl/tcl/modules/pltcl_listmod b/src/pl/tcl/modules/pltcl_listmod
new file mode 100755 (executable)
index 0000000..92de363
--- /dev/null
+++ b/src/pl/tcl/modules/pltcl_listmod
@@ -0,0 +1,122 @@
+#!/bin/sh
+# Start tclsh \
+exec tclsh "$0" $@
+
+#
+# Code still has to be documented
+#
+
+#load /usr/local/pgsql/lib/libpgtcl.so
+package require Pgtcl
+
+
+#
+# Check for minimum arguments
+#
+if {$argc < 1} {
+    puts stderr ""
+    puts stderr "usage: pltcl_listmod dbname \[options\] \[modulename \[...\]\]"
+    puts stderr ""
+    puts stderr "options:"
+    puts stderr "    -host hostname"
+    puts stderr "    -port portnumber"
+    puts stderr ""
+    exit 1
+}
+
+#
+# Remember database name and initialize options
+#
+set dbname [lindex $argv 0]
+set options ""
+set errors 0
+set opt ""
+set val ""
+
+set i 1
+while {$i < $argc} {
+    if {[string compare [string index [lindex $argv $i] 0] "-"] != 0} {
+        break;
+    }
+
+    set opt [lindex $argv $i]
+    incr i
+    if {$i >= $argc} {
+        puts stderr "no value given for option $opt"
+       incr errors
+       continue
+    }
+    set val [lindex $argv $i]
+    incr i
+
+    switch -- $opt {
+        -host {
+           append options "-host \"$val\" "
+       }
+       -port {
+           append options "-port $val "
+       }
+       default {
+           puts stderr "unknown option '$opt'"
+           incr errors
+       }
+    }
+}
+
+#
+# Final syntax check
+#
+if {$errors > 0} {
+    puts stderr ""
+    puts stderr "usage: pltcl_listmod dbname \[options\] \[modulename \[...\]\]"
+    puts stderr ""
+    puts stderr "options:"
+    puts stderr "    -host hostname"
+    puts stderr "    -port portnumber"
+    puts stderr ""
+    exit 1
+}
+
+proc listmodule {conn modname} {
+    set xname $modname
+    regsub -all {\\} $xname {\\} xname
+    regsub -all {'}  $xname {''} xname
+
+    set found 0
+    pg_select $conn "select * from pltcl_modules where modname = '$xname'" \
+    MOD {
+        set found 1
+       break;
+    }
+
+    if {!$found} {
+        puts "Module $modname not found in pltcl_modules"
+       puts ""
+       return
+    }
+
+    puts "Module $modname defines procedures:"
+    pg_select $conn "select funcname from pltcl_modfuncs \
+           where modname = '$xname' order by funcname" FUNC {
+        puts "    $FUNC(funcname)"
+    }
+    puts ""
+}
+
+set conn [eval pg_connect $dbname $options]
+
+if {$i == $argc} {
+    pg_select $conn "select distinct modname from pltcl_modules        \
+               order by modname"       \
+               MOD {
+        listmodule $conn $MOD(modname)
+    }
+} else {
+    while {$i < $argc} {
+        listmodule $conn [lindex $argv $i]
+       incr i
+    }
+}
+
+pg_disconnect $conn
+

diff --git a/src/pl/tcl/modules/pltcl_loadmod b/src/pl/tcl/modules/pltcl_loadmod
new file mode 100755 (executable)
index 0000000..d437f76
--- /dev/null
+++ b/src/pl/tcl/modules/pltcl_loadmod
@@ -0,0 +1,502 @@
+#!/bin/sh
+# Start tclsh \
+exec tclsh "$0" $@
+
+#
+# Code still has to be documented
+#
+
+#load /usr/local/pgsql/lib/libpgtcl.so
+package require Pgtcl
+
+
+#
+# Check for minimum arguments
+#
+if {$argc < 2} {
+    puts stderr ""
+    puts stderr "usage: pltcl_loadmod dbname \[options\] file \[...\]"
+    puts stderr ""
+    puts stderr "options:"
+    puts stderr "    -host hostname"
+    puts stderr "    -port portnumber"
+    puts stderr ""
+    exit 1
+}
+
+#
+# Remember database name and initialize options
+#
+set dbname [lindex $argv 0]
+set options ""
+set errors 0
+set opt ""
+set val ""
+
+set i 1
+while {$i < $argc} {
+    if {[string compare [string index [lindex $argv $i] 0] "-"] != 0} {
+        break;
+    }
+
+    set opt [lindex $argv $i]
+    incr i
+    if {$i >= $argc} {
+        puts stderr "no value given for option $opt"
+       incr errors
+       continue
+    }
+    set val [lindex $argv $i]
+    incr i
+
+    switch -- $opt {
+        -host {
+           append options "-host \"$val\" "
+       }
+       -port {
+           append options "-port $val "
+       }
+       default {
+           puts stderr "unknown option '$opt'"
+           incr errors
+       }
+    }
+}
+
+#
+# Final syntax check
+#
+if {$i >= $argc || $errors > 0} {
+    puts stderr ""
+    puts stderr "usage: pltcl_loadmod dbname \[options\] file \[...\]"
+    puts stderr ""
+    puts stderr "options:"
+    puts stderr "    -host hostname"
+    puts stderr "    -port portnumber"
+    puts stderr ""
+    exit 1
+}
+
+
+proc __PLTcl_loadmod_check_table {conn tabname expnames exptypes} {
+    set attrs [expr [llength $expnames] - 1]
+    set error 0
+    set found 0
+
+    pg_select $conn "select C.relname, A.attname, A.attnum, T.typname  \
+               from pg_class C, pg_attribute A, pg_type T              \
+               where C.relname = '$tabname'                            \
+                 and A.attrelid = C.oid                                \
+                 and A.attnum > 0                                      \
+                 and T.oid = A.atttypid                                \
+               order by attnum" tup {
+
+       incr found
+       set i $tup(attnum)
+
+       if {$i > $attrs} {
+           puts stderr "Table $tabname has extra field '$tup(attname)'"
+           incr error
+           continue
+       }
+
+       set xname [lindex $expnames $i]
+       set xtype [lindex $exptypes $i]
+
+       if {[string compare $tup(attname) $xname] != 0} {
+           puts stderr "Attribute $i of $tabname has wrong name"
+           puts stderr "    got '$tup(attname)' expected '$xname'"
+           incr error
+       }
+       if {[string compare $tup(typname) $xtype] != 0} {
+           puts stderr "Attribute $i of $tabname has wrong type"
+           puts stderr "    got '$tup(typname)' expected '$xtype'"
+           incr error
+       }
+    }
+
+    if {$found == 0} {
+        return 0
+    }
+
+    if {$found < $attrs} {
+       incr found
+       set miss [lrange $expnames $found end]
+        puts "Table $tabname doesn't have field(s) $miss"
+       incr error
+    }
+
+    if {$error > 0} {
+        return 2
+    }
+
+    return 1
+}
+
+
+proc __PLTcl_loadmod_check_tables {conn} {
+    upvar #0   __PLTcl_loadmod_status  status
+
+    set error 0
+
+    set names {{} modname modseq modsrc}
+    set types {{} name int2 text}
+
+    switch [__PLTcl_loadmod_check_table $conn pltcl_modules $names $types] {
+        0 {
+           set status(create_table_modules) 1
+       }
+       1 {
+           set status(create_table_modules) 0
+       }
+       2 {
+           puts "Error(s) in table pltcl_modules"
+           incr error
+       }
+    }
+
+    set names {{} funcname modname}
+    set types {{} name name}
+
+    switch [__PLTcl_loadmod_check_table $conn pltcl_modfuncs $names $types] {
+        0 {
+           set status(create_table_modfuncs) 1
+       }
+       1 {
+           set status(create_table_modfuncs) 0
+       }
+       2 {
+           puts "Error(s) in table pltcl_modfuncs"
+           incr error
+       }
+    }
+
+    if {$status(create_table_modfuncs) && !$status(create_table_modules)} {
+        puts stderr "Table pltcl_modfuncs doesn't exist but pltcl_modules does"
+       puts stderr "Either both tables must be present or none."
+       incr error
+    }
+
+    if {$status(create_table_modules) && !$status(create_table_modfuncs)} {
+        puts stderr "Table pltcl_modules doesn't exist but pltcl_modfuncs does"
+       puts stderr "Either both tables must be present or none."
+       incr error
+    }
+
+    if {$error} {
+        puts stderr ""
+       puts stderr "Abort"
+       exit 1
+    }
+
+    if {!$status(create_table_modules)} {
+        __PLTcl_loadmod_read_current $conn
+    }
+}
+
+
+proc __PLTcl_loadmod_read_current {conn} {
+    upvar #0   __PLTcl_loadmod_status          status
+    upvar #0   __PLTcl_loadmod_modsrc          modsrc
+    upvar #0   __PLTcl_loadmod_funclist        funcs
+    upvar #0   __PLTcl_loadmod_globlist        globs
+
+    set errors 0
+
+    set curmodlist ""
+    pg_select $conn "select distinct modname from pltcl_modules" mtup {
+       set mname $mtup(modname);
+        lappend curmodlist $mname
+    }
+
+    foreach mname $curmodlist {
+       set srctext ""
+        pg_select $conn "select * from pltcl_modules           \
+               where modname = '$mname'                        \
+               order by modseq" tup {
+           append srctext $tup(modsrc)
+        }
+
+       if {[catch {
+               __PLTcl_loadmod_analyze                         \
+                       "Current $mname"                        \
+                       $mname                                  \
+                       $srctext new_globals new_functions
+           }]} {
+           incr errors
+        }
+       set modsrc($mname) $srctext
+       set funcs($mname) $new_functions
+       set globs($mname) $new_globals
+    }
+
+    if {$errors} {
+        puts stderr ""
+        puts stderr "Abort"
+       exit 1
+    }
+}
+
+
+proc __PLTcl_loadmod_analyze {modinfo modname srctext v_globals v_functions} {
+    upvar 1    $v_globals new_g
+    upvar 1    $v_functions new_f
+    upvar #0   __PLTcl_loadmod_allfuncs        allfuncs
+    upvar #0   __PLTcl_loadmod_allglobs        allglobs
+
+    set errors 0
+
+    set old_g [info globals]
+    set old_f [info procs]
+    set new_g ""
+    set new_f ""
+
+    if {[catch {
+           uplevel #0 "$srctext"
+        } msg]} {
+        puts "$modinfo: $msg"
+       incr errors
+    }
+
+    set cur_g [info globals]
+    set cur_f [info procs]
+
+    foreach glob $cur_g {
+        if {[lsearch -exact $old_g $glob] >= 0} {
+           continue
+       }
+       if {[info exists allglobs($glob)]} {
+           puts stderr "$modinfo: Global $glob previously used in module $allglobs($glob)"
+           incr errors
+       } else {
+           set allglobs($glob) $modname
+       }
+       lappend new_g $glob
+       uplevel #0 unset $glob
+    }
+    foreach func $cur_f {
+        if {[lsearch -exact $old_f $func] >= 0} {
+           continue
+       }
+       if {[info exists allfuncs($func)]} {
+           puts stderr "$modinfo: Function $func previously defined in module $allfuncs($func)"
+           incr errors
+       } else {
+           set allfuncs($func) $modname
+       }
+       lappend new_f $func
+       rename $func {}
+    }
+
+    if {$errors} {
+        return -code error
+    }
+    #puts "globs in $modname: $new_g"
+    #puts "funcs in $modname: $new_f"
+}
+
+
+proc __PLTcl_loadmod_create_tables {conn} {
+    upvar #0   __PLTcl_loadmod_status  status
+
+    if {$status(create_table_modules)} {
+        if {[catch {
+               set res [pg_exec $conn                          \
+                   "create table pltcl_modules (               \
+                       modname name,                           \
+                       modseq  int2,                           \
+                       modsrc  text);"]
+           } msg]} {
+           puts stderr "Error creating table pltcl_modules"
+           puts stderr "    $msg"
+           exit 1
+       }
+        if {[catch {
+               set res [pg_exec $conn                          \
+                   "create index pltcl_modules_i               \
+                       on pltcl_modules using btree            \
+                       (modname name_ops);"]
+           } msg]} {
+           puts stderr "Error creating index pltcl_modules_i"
+           puts stderr "    $msg"
+           exit 1
+       }
+       puts "Table pltcl_modules created"
+       pg_result $res -clear
+    }
+
+    if {$status(create_table_modfuncs)} {
+        if {[catch {
+               set res [pg_exec $conn                          \
+                   "create table pltcl_modfuncs (              \
+                       funcname name,                          \
+                       modname  name);"]
+           } msg]} {
+           puts stderr "Error creating table pltcl_modfuncs"
+           puts stderr "    $msg"
+           exit 1
+       }
+        if {[catch {
+               set res [pg_exec $conn                          \
+                   "create index pltcl_modfuncs_i              \
+                       on pltcl_modfuncs using hash            \
+                       (funcname name_ops);"]
+           } msg]} {
+           puts stderr "Error creating index pltcl_modfuncs_i"
+           puts stderr "    $msg"
+           exit 1
+       }
+       puts "Table pltcl_modfuncs created"
+       pg_result $res -clear
+    }
+}
+
+
+proc __PLTcl_loadmod_read_new {conn} {
+    upvar #0   __PLTcl_loadmod_status          status
+    upvar #0   __PLTcl_loadmod_modsrc          modsrc
+    upvar #0   __PLTcl_loadmod_funclist        funcs
+    upvar #0   __PLTcl_loadmod_globlist        globs
+    upvar #0   __PLTcl_loadmod_allfuncs        allfuncs
+    upvar #0   __PLTcl_loadmod_allglobs        allglobs
+    upvar #0   __PLTcl_loadmod_modlist         modlist
+
+    set errors 0
+
+    set new_modlist ""
+    foreach modfile $modlist {
+        set modname [file rootname [file tail $modfile]]
+       if {[catch {
+               set fid [open $modfile "r"]
+           } msg]} {
+           puts stderr $msg
+           incr errors
+           continue
+        }
+       set srctext [read $fid]
+       close $fid
+
+       if {[info exists modsrc($modname)]} {
+           if {[string compare $modsrc($modname) $srctext] == 0} {
+               puts "Module $modname unchanged - ignored"
+               continue
+           }
+           foreach func $funcs($modname) {
+               unset allfuncs($func)
+           }
+           foreach glob $globs($modname) {
+               unset allglobs($glob)
+           }
+           unset funcs($modname)
+           unset globs($modname)
+           set modsrc($modname) $srctext
+           lappend new_modlist $modname
+       } else {
+           set modsrc($modname) $srctext
+           lappend new_modlist $modname
+       }
+
+       if {[catch {
+               __PLTcl_loadmod_analyze "New/updated $modname"  \
+                       $modname $srctext new_globals new_funcs
+           }]} {
+           incr errors
+       }
+
+       set funcs($modname) $new_funcs
+       set globs($modname) $new_globals
+    }
+
+    if {$errors} {
+        puts stderr ""
+        puts stderr "Abort"
+       exit 1
+    }
+
+    set modlist $new_modlist
+}
+
+
+proc __PLTcl_loadmod_load_modules {conn} {
+    upvar #0   __PLTcl_loadmod_modsrc          modsrc
+    upvar #0   __PLTcl_loadmod_funclist        funcs
+    upvar #0   __PLTcl_loadmod_modlist         modlist
+
+    set errors 0
+
+    foreach modname $modlist {
+       set xname [__PLTcl_loadmod_quote $modname]
+
+        pg_result [pg_exec $conn "begin;"] -clear
+
+       pg_result [pg_exec $conn                                \
+               "delete from pltcl_modules where modname = '$xname'"] -clear
+       pg_result [pg_exec $conn                                \
+               "delete from pltcl_modfuncs where modname = '$xname'"] -clear
+
+       foreach func $funcs($modname) {
+           set xfunc [__PLTcl_loadmod_quote $func]
+           pg_result [                                                 \
+               pg_exec $conn "insert into pltcl_modfuncs values (      \
+                       '$xfunc', '$xname')"                            \
+           ] -clear
+       }
+       set i 0
+       set srctext $modsrc($modname)
+       while {[string compare $srctext ""] != 0} {
+           set xpart [string range $srctext 0 3999]
+           set xpart [__PLTcl_loadmod_quote $xpart]
+           set srctext [string range $srctext 4000 end]
+
+           pg_result [                                                 \
+               pg_exec $conn "insert into pltcl_modules values (       \
+                       '$xname', $i, '$xpart')"                        \
+           ] -clear
+       }
+
+        pg_result [pg_exec $conn "commit;"] -clear
+
+       puts "Successfully loaded/updated module $modname"
+    }
+}
+
+
+proc __PLTcl_loadmod_quote {s} {
+    regsub -all {\\} $s {\\\\} s
+    regsub -all {'}  $s {''} s
+    return $s
+}
+
+
+set __PLTcl_loadmod_modlist [lrange $argv $i end]
+set __PLTcl_loadmod_modsrc(dummy) ""
+set __PLTcl_loadmod_funclist(dummy) ""
+set __PLTcl_loadmod_globlist(dummy) ""
+set __PLTcl_loadmod_allfuncs(dummy) ""
+set __PLTcl_loadmod_allglobs(dummy) ""
+
+unset __PLTcl_loadmod_modsrc(dummy)
+unset __PLTcl_loadmod_funclist(dummy)
+unset __PLTcl_loadmod_globlist(dummy)
+unset __PLTcl_loadmod_allfuncs(dummy)
+unset __PLTcl_loadmod_allglobs(dummy)
+
+
+puts ""
+
+set __PLTcl_loadmod_conn [eval pg_connect $dbname $options]
+
+unset i dbname options errors opt val
+
+__PLTcl_loadmod_check_tables $__PLTcl_loadmod_conn
+
+__PLTcl_loadmod_read_new $__PLTcl_loadmod_conn
+
+__PLTcl_loadmod_create_tables $__PLTcl_loadmod_conn
+__PLTcl_loadmod_load_modules $__PLTcl_loadmod_conn
+
+pg_disconnect $__PLTcl_loadmod_conn
+
+puts ""
+
+

diff --git a/src/pl/tcl/modules/unknown.pltcl b/src/pl/tcl/modules/unknown.pltcl
new file mode 100644 (file)
index 0000000..830ee25
--- /dev/null
+++ b/src/pl/tcl/modules/unknown.pltcl
@@ -0,0 +1,65 @@
+#---------------------------------------------------------------------
+# Support for unknown command
+#---------------------------------------------------------------------
+
+proc unknown {proname args} {
+    upvar #0   __PLTcl_unknown_support_plan_modname    p_mod
+    upvar #0   __PLTcl_unknown_support_plan_modsrc     p_src
+
+    #-----------------------------------------------------------
+    # On first call prepare the plans
+    #-----------------------------------------------------------
+    if {![info exists p_mod]} {
+        set p_mod [SPI_prepare                                         \
+               "select modname from pltcl_modfuncs             \
+                where funcname = \$1" name]
+        set p_src [SPI_prepare                                 \
+               "select modseq, modsrc from pltcl_modules       \
+                where modname = \$1                            \
+                order by modseq" name]
+    }
+
+    #-----------------------------------------------------------
+    # Lookup the requested function in pltcl_modfuncs
+    #-----------------------------------------------------------
+    set n [SPI_execp -count 1 $p_mod [list [quote $proname]]]
+    if {$n != 1} {
+       #-----------------------------------------------------------
+       # Not found there either - now it's really unknown
+       #-----------------------------------------------------------
+        return -code error "unknown command '$proname'"
+    }
+
+    #-----------------------------------------------------------
+    # Collect the source pieces from pltcl_modules
+    #-----------------------------------------------------------
+    set src ""
+    SPI_execp $p_src [list [quote $modname]] {
+        append src $modsrc
+    }
+
+    #-----------------------------------------------------------
+    # Load the source into the interpreter
+    #-----------------------------------------------------------
+    if {[catch {
+            uplevel #0 "$src"
+        } msg]} {
+       elog NOTICE "pltcl unknown: error while loading module $modname"
+       elog WARN $msg
+    }
+
+    #-----------------------------------------------------------
+    # This should never happen
+    #-----------------------------------------------------------
+    if {[catch {info args $proname}]} {
+        return -code error \
+           "unknown command '$proname' (still after loading module $modname)"
+    }
+
+    #-----------------------------------------------------------
+    # Finally simulate the initial procedure call
+    #-----------------------------------------------------------
+    return [uplevel 1 $proname $args]
+}
+
+