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