This file is sourced in most of the advanced applications of this book. It provides applications with a remote call procedures, Web Fusion database procedures, and a fetchURL facility similar to the HTTP package of Tcl 8.0. It can be used to run applications under Tcl 7.6 that would normally only run under Tcl 8.0 without its help.
You can copy the Spynergy procedures that you need into the source code of your Tcl/Tk applications, instead of sourcing the entire file. The groups of procedures are named.
Source code for the Spynergy Toolkit: (You do not need to copy the source on this Web page, the file spynergy.tcl is available in the examples directory)
################################################################ # spynergy.tcl -- The Spynergy(TM) Toolkit # by Eolas Technologies Incorporated -- http://www.eolas.com # # Copyright © 1994-1997 Eolas Technologies Inc. # Copyright © 1995 Steven B. Wahl # Copyright © 1995 Jeffrey Hobbs # Copyright © 1995 Sean Halliday # Copyright © 1990-1994 The Regents of the University of California. # Copyright © 1994-1997 Sun Microsystems, Inc. # # This software is copyrighted by Eolas Technologies Inc., # the Regents of the University of California, Sun Microsystems, Inc. and other # parties. The following terms apply to all files associated with the # software unless explicitly disclaimed in individual files. # # 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, that the name of this file # continue to be called "spynergy.tcl" 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. # # GOVERNMENT USE: If you are acquiring this software on behalf of the # U.S. government, the Government shall have only "Restricted Rights" # in the software and related documentation as defined in the Federal # Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you # are acquiring the software on behalf of the Department of Defense, the # software shall be classified as "Commercial Computer Software" and the # Government shall have only "Restricted Rights" as defined in Clause # 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the # authors grant the U.S. Government and others acting in its behalf # permission to use and distribute the software in accordance with the # terms specified in this license. # # Permission is granted to use the name "spynergy.tcl" in copies of this file. For any other # use of the Spynergy trademark, prior permission must be obtained from Eolas Technologies Inc. # Spynergy is a trademark of Eolas Technologies Incorporated, Chicago, IL ################################################################# ############### # start defaults.tcl section ############### proc set_option_pattern {{pat "*"} {overrideflag 0}} { global tcl_platform courierfont if {$pat == ""} { set $pat "*" } else { if {$pat != "*"} { if {[string index $pat 0] == "."} { set pat [string range $pat 1 end] } if {[string index $pat 0] != "*"} {set pat "*$pat*"} } } if {$tcl_platform(platform) == "windows" && $overrideflag == 0} { set courierfont {{Courier New} 11 {normal}} option add ${pat}Button*font {{MS Sans Serif} 8 {normal}} option add ${pat}Button*padX 0 option add ${pat}Button*padY 0 option add ${pat}Radiobutton*font {{MS Sans Serif} 8 {normal}} option add ${pat}Radiobutton*padX 0 option add ${pat}Radiobutton*padY 0 option add ${pat}Checkbutton*font {{MS Sans Serif} 8 {normal}} option add ${pat}Checkbutton*padX 0 option add ${pat}Checkbutton*padY 0 option add ${pat}Entry*font {{Courier New} 11 {normal}} option add ${pat}Label*font {{MS Sans Serif} 8 {normal}} option add ${pat}Label*borderWidth 0 option add ${pat}Label*padX 1m option add ${pat}Label*padY 0 option add ${pat}Listbox*font {{MS Sans Serif} 8 {normal}} option add ${pat}Listbox*selectBorderWidth 0 option add ${pat}Menu*font {{MS Sans Serif} 8 {normal}} option add ${pat}Menubutton*font {{MS Sans Serif} 8 {normal}} option add ${pat}Menubutton*padX 0 option add ${pat}Menubutton*padY 0 option add ${pat}Message*font {{MS Sans Serif} 8 {normal}} option add ${pat}Message*borderWidth 0 option add ${pat}Message*padX 0 option add ${pat}Message*padY 0 option add ${pat}Scale*font {{MS Sans Serif} 8 {normal}} option add ${pat}Scale*width 10 option add ${pat}Scrollbar*width 10 option add ${pat}Text*font {{Courier New} 11 {normal}} } else { set courierfont "courier" option add ${pat}Button*font -Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-* option add ${pat}Button*padX 3m option add ${pat}Button*padY 1m option add ${pat}Radiobutton*font -Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-* option add ${pat}Radiobutton*padX 1 option add ${pat}Radiobutton*padY 1 option add ${pat}Checkbutton*font -Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-* option add ${pat}Checkbutton*padX 1 option add ${pat}Checkbutton*padY 1 option add ${pat}Entry*font -Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-* option add ${pat}Label*font -Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-* option add ${pat}Label*borderWidth 1 option add ${pat}Label*padX 1 option add ${pat}Label*padY 1 option add ${pat}Listbox*font -Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-* option add ${pat}Listbox*selectBorderWidth 0 option add ${pat}Menu*font -Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-* option add ${pat}Menubutton*font -Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-* option add ${pat}Menubutton*padX 4p option add ${pat}Menubutton*padY 3p option add ${pat}Message*font -Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-* option add ${pat}Message*borderWidth 1 option add ${pat}Message*padX -1 option add ${pat}Message*padY -1 option add ${pat}Scale*font -Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-* option add ${pat}Scale*width 15 option add ${pat}Scrollbar*width 15 option add ${pat}Text*font -*-Courier-Medium-R-Normal--*-120-*-*-*-*-*-* } } ############### # end defaults.tcl section ############### ###############============================================================= # start fileutil.tcl section ############### # # Implements a portable file manipulation library for both Windows # and assorted flavors of UNIX, allowing Tcl scripts to become much # more portable. These functions should migrate into the core Tcl # library at some point, but probably with a different API. # # Thanks especially to the following for bug reports & code ideas: # Jeff Hobbs# #--------------------------------------------------------------------------- # Added commands, and added command options: # # file copy|cp # Copy a file or set of files to destination # # file delete|del|rm ? ...? # Deletes all files that match the patterns (glob style) of # of file paths. # # file dirlist|dir|ls ??-all|-full|-long?...? ?? ?...? # Returns a sorted list of all files that match the file path # pattern(s) (defaults to all files in current working directory) # -all returns "." prefixed filenames too # -full returns files with directory names having "/" # appended, and symbolic links having "@" appended # -long returns one file per line with Unix style # permissions, size in bytes, last modification # date and time, filename. # (Thanks to Jeff Hobbs for this code) # # file move|mv|rename # Move and/or rename a file or set of files # # file where # Returns the path(s) of the file(s) to match the pattern # (glob style) by searching the directories given in env(PATH) in # sequence. This may return multiple list items if the pattern # is found in more than one place. Returns empty string if # nothing is found to match the pattern. # # sleep # Suspend execution (without blocking other processes) for # given number of seconds (may be fractional second value) # # shell ?-pipe? command ??arg?...? # Execute an external program in appropriate command shell # environment including those built-in command accessible only # within the command shell. # -pipe returns file descriptor of command pipe rather than # results of the program # NOTE: wildcards are passed to the shell to evaluate, thus under # UNIX, "shell ls -la *.txt" will bypass "glob" for wildcard # expansion. This command selects the appropriate shell # to run for the operating system: # $env(SHELL) or "sh -c " for UNIX # $env(COMSPEC) or # "command.com /c " for Win32s (Windows 3.1) # "cmd.exe /c " for Windows 95 and Windows NT # Examples: # set dirlist [shell cat $env(TK_LIBRARY)/*.tcl > /tmp/all.tcl] # set attributes [shell attrib *.txt] # #=========================================================================== # -- validate execution environment if {[catch "info tclversion" tclversion] || $tclversion < 7.5} { error "fileutil.tcl requires at least the stable version of Tcl7.5/Tk4.1" } # -- figure out the platform, OS, and appropriate shell global tcl_platform tcl_version env sort_type set tcl_platform(shell) {} set tcl_platform(pathsepchar) ":" set sort_type "-dictionary" if {[info exists tcl_version] == 0 || $tcl_version < 8.0} { set sort_type "-ascii" } if {"$tcl_platform(platform)" == "unix"} { if {[info exists env(SHELL)]} { set tcl_platform(shell) $env(SHELL) } else { set tcl_platform(shell) "/bin/sh" } } elseif {"$tcl_platform(platform)" == "windows"} { set tcl_platform(pathsepchar) ";" if {[info exists env(COMSPEC)]} { regsub -all {\\} $env(COMSPEC) {\\\\} tcl_platform(shell) } else { switch -exact -- $tcl_platform(os) { "Windows 95" - "Windows NT" {set tcl_platform(shell) "cmd.exe"} "Win32s" {set tcl_platform(shell) "command.com"} } } } # -- figure path environment variable, create bogus one if not found set ind [lsearch -exact [string tolower [array names env]] "path"] if {-1 == $ind} { set env(PATH) {} set tcl_platform(pathelem) "PATH" } else { set tcl_platform(pathelem) [lindex [array names env] $ind] } unset ind proc _dir {{arg *}} { global sort_type return [lsort $sort_type [glob -nocomplain -- $arg]] } #---------- # -- rename an existing Tcl command that we augment if {[info commands Tcl_file] == ""} { rename file Tcl_file } #---------- # -- "file" command replacement proc file {args} { global env tcl_platform sort_type if {[llength $args] >= 1} { set subcmd [lindex $args 0] } else { error "usage: file option name ?arg arg ...?" } switch -glob -- $subcmd { cp - copy { # -- "file copy" command regsub -all {\\} $args "/" args if {[llength $args] != 3} { error "usage: file copy " } set fromfilelist [_dir [lindex $args 1]] set tofile [lindex $args 2] set sep [string trim [Tcl_file join . .] .] if {[Tcl_file isdir $tofile]} { set topath $tofile set tofile "" } else { set topath [Tcl_file dirname $tofile] set tofile [Tcl_file tail $tofile] } foreach fromfile $fromfilelist { if {"$tofile" == ""} { set outfile "$topath$sep[Tcl_file tail $fromfile]" } else { set outfile "$topath$sep$tofile" } if {[catch "open [list "$fromfile"] r" infd]} { error "file copy: unable to open \"$fromfile\"" } if {[catch "fconfigure $infd -translation lf"]} { error "file copy: unable to configure \"$fromfile\"" } if {[catch "open [list "$outfile"] w" outfd]} { error "file copy: unable to open \"$outfile\"" } if {[catch "fconfigure $outfd -translation lf"]} { error "file copy: unable to configure \"$tofile\"" } if {"" != [info commands "fcopy"]} { if {[catch "fcopy [list "$infd"] [list "$outfd"]"]} { error "file copy: error encountered copying file \"$infile\"" } } elseif {"" != [info commands "unsupported0"]} { if {[catch "unsupported0 [list "$infd"] [list "$outfd"]"]} { error "file copy: error encountered copying file \"$infile\"" } } else { error "file copy: cannot find \"unsupported0\"/\"fcopy\" command" } catch "close $infd" catch "flush $outfd" catch "close $outfd" } return "" } rm - del* { # -- file delete if {[llength $args] < 2} { error "usage: file delete ? ?" } # -- exec under windows 95 doesn't work if {$tcl_platform(os) == "Windows 95"} {return} # immediately deal with any backslash directory separators regsub -all {\\} $args "/" args if {[string tolower $tcl_platform(platform)] == "unix"} { set rm [lindex [file where rm] 0] if {$rm == ""} { set rm "/bin/rm" } foreach pattern [lrange $args 1 end] { foreach f [glob -nocomplain $pattern] { if {[catch "exec $rm $f" result]} { error "file delete $f: $result" } } } } elseif {[string tolower $tcl_platform(platform)] == "windows"} { foreach pattern [lrange $args 1 end] { foreach f [glob -nocomplain $pattern] { regsub -all {/} $f {\\\\} f set qflag "" if {[string tolower $tcl_platform(os)] != "win32s"} { set qflag "/q" } set cmd "exec $tcl_platform(shell) /c del $qflag \"$f\"" catch "eval [list "$cmd"]" } } } return "" } dir - ls - dirlist { set res {} set args [lrange $args 1 end] array set s { all 0 full 0 long 0 0 --- 1 --x 2 -w- 3 -wx 4 r-- 5 r-x 6 rw- 7 rwx } while {[string match \-* [lindex $args 0]]} { set str [lindex $args 0] set args [lreplace $args 0 0] switch -glob -- $str { -a* {set s(all) 1} -f* {set s(full) 1} -l* {set s(long) 1} -- break default { error "file dir unknown arg $str, should be one of: -all, -full, -long" } } } set sep [string trim [Tcl_file join . .] .] if [string match {} $args] { set args [list [pwd]] } foreach arg $args { if {[Tcl_file isdir $arg]} { if $s(all) { lappend out [list $arg [concat [_dir $arg$sep.*] [_dir $arg$sep*]]] } else { lappend out [list $arg [_dir $arg$sep*]] } } else { lappend out [list [Tcl_file dirname $arg] [_dir $arg]] } } if $s(long) { set old [clock scan {1 year ago}] set fmt "%s%9d %s %s\n" foreach o $out { set d [lindex $o 0] append res $d:\n foreach f [lindex $o 1] { Tcl_file lstat $f st set f [Tcl_file tail $f] if $s(full) { switch -glob $st(type) { d* { append f $sep } l* { append f "@ -> [Tcl_file readlink $d$sep$f]" } } } if [string match "file" "$st(type)"] { set mode - } else { set mode [string index $st(type) 0] } foreach j [split [format %o [expr $st(mode)&0777]] {}] { append mode $s($j) } if {$st(mtime) > $old} { set time [clock format $st(mtime) -format {%b %d %H:%M}] } else { set time [clock format $st(mtime) -format {%b %d %Y}] } append res [format $fmt $mode $st(size) $time $f] } } } else { foreach o $out { set d [lindex $o 0] foreach f [lindex $o 1] { set f [Tcl_file tail $f] if $s(full) { switch -glob [Tcl_file type $d$sep$f] { d* { append f $sep } l* { append f @ } } } append res "$f " } } } return [string trimr $res] } mv - rename - move { # file move / file mv / file rename regsub -all {\\} $args "/" args if {[llength $args] != 3} { error "usage: file move " } set fromfilelist [_dir [lindex $args 1]] set tofile [lindex $args 2] set sep [string trim [Tcl_file join . .] .] if {[Tcl_file isdir $tofile]} { set topath $tofile set tofile "" } else { set topath [Tcl_file dirname $tofile] set tofile [Tcl_file tail $tofile] } foreach fromfile $fromfilelist { if {"$tofile" == ""} { set outfile "$topath$sep[Tcl_file tail $fromfile]" } else { set outfile "$topath$sep$tofile" } if {[catch "file copy [list "$fromfile"] [list "$outfile"]"]} { error "file move: unable to relocation \"$fromfile\" to \"$outfile\"" } if {[catch "file delete [list "$fromfile"]"]} { error "file move: unable to relocation \"$fromfile\" to \"$outfile\"" } } return "" } where { # -- file where if {[llength $args] != 2} { error "usage: file where " } set pattern [list [lindex $args 1]] set pattern "[lindex "$pattern" 0]" if {[llength "$pattern"] > 1} {set pattern "$pattern"} # -- immediately deal with any DOS backslash directory separators regsub -all {\\} $env($tcl_platform(pathelem)) "/" paths set dirs [split $paths $tcl_platform(pathsepchar)] set result {} foreach dir $dirs { if {"$dir" == ""} {set dir [pwd]} set dir "[lindex "$dir" 0]" if {"/" != [string index "$dir" [expr [string length "$dir"] - 1]]} { set item "$dir/$pattern" } else { set item "${dir}${pattern}" } set items [lsort $sort_type [glob -nocomplain "$item"]] if {"$items" != ""} {append result "$items "} } return "$result" } default {return [uplevel #0 Tcl_file $args]} } } #---------- # sleep command - non-blocking sleep function proc sleep {{seconds 1}} { global _sleep_wait_var set _sleep_wait_var 0 if {[catch "expr int($seconds * 1000)" millisec]} { error "usage: sleep " } after $millisec {uplevel #0 set _sleep_wait_var 1} vwait _sleep_wait_var unset _sleep_wait_var return "" } #---------- # shell command - replacement for exec that takes care of os shell issues proc shell {args} { global tcl_platform set pipeflag 0 if {[llength $args] < 1} { error "usage: shell \[-pipe\] command ??arg?..arg?" } if {[lindex $args 0] == "-pipe"} { set pipeflag 1 set args [lrange $args 1 end] } set result "" switch -exact -- [string tolower $tcl_platform(platform)] { unix { # protect shell wildcards regsub -all {\[} $args {\[} args regsub -all {\]} $args {\]} args regsub -all {\$} $args {\$} args regsub -all {\{} $args {} args regsub -all {\}} $args {} args regsub -all {\"} $args {\"} args if {!$pipeflag} { set cmd "exec $tcl_platform(shell) -c \"$args\"" if {[catch $cmd result]} { error "shell: $result" } } else { set cmd [list "|$tcl_platform(shell) -c \"$args\""] set cmd "$cmd r" if {[catch "open $cmd" result]} { error "shell: $result" } } } windows { # -- exec under windows 95 is broken if {$tcl_platform(os) == "Windows 95"} {return ""} if {!$pipeflag} { set cmd "exec $tcl_platform(shell) /c $args" if {[catch $cmd result]} { error "shell: $result" } } else { set cmd [list "|$tcl_platform(shell) /c $args" r] if {[catch "open $cmd" result]} { error "shell: $result" } } } } return $result } ############### # end fileutil.tcl section ############### ###############============================================================= # start fetchURL.tcl section ############### # # Implements a fetchURL remote html document retrieval function from # atop the Tcl 7.5 socket command. Binary transfers are supported # with the "-outfile" option. # options: # -url -- url to retrieve # -outfile -- place output in named file rather # than returning it from this # procedure # -timeout -- timeout between I/O buffers # before implying a connection # closure (default 5 seconds) # -initialtimeout -- timeout to wait for initial # connection establishment and # 1st buffer retrieval (default # 30 seconds) # #--------------------------------------------------------------------------- # -- validate appropriate execution environment if {[catch "info tclversion" tclversion] || $tclversion < 7.5} { error "fetchURL.tcl requires Tcl7.5 / Tk4.1 or later releases" } else {unset tclversion} global sizevar set sizevar "" if {[catch "info tclversion" tclversion] || $tclversion > 7.6} { set sizevar " -size " } # -- find and rename binary copy command if {[info commands "unsupported0"] == "unsupported0"} { rename unsupported0 fcopy } if {[info commands "fcopy"] == ""} { error "fetchURL.tcl requires use of fcopy command - not found" } #---------- # -- set up for transferring url proc Http_Copy {url {locfile ""} {chunk 4096}} { global http array set http { state header mime {} copyDone 0 copySize 0 document {} all {} protocol {} host {} p {} port {} what {} key {} ext {} name {} type "text/html" length 0 code 0 location {} timeoutid {} } # -- parse the URL set http(full) $url set http(urllist) [parseurl $url] set http(protocol) [lindex $http(urllist) 0] set http(host) [lindex $http(urllist) 1] set http(port) [lindex $http(urllist) 2] set http(what) [lindex $http(urllist) 3] set http(ext) [lindex $http(urllist) 4] set http(tag) [lindex $http(urllist) 5] set http(key) [lindex $http(urllist) 6] if {"$http(port)" == ""} {set http(port) "80"} if {"$http(host)" == ""} {set http(host) [info hostname]} if {"$http(what)" == ""} {set http(what) "/"} # -- remove leading "/" if first this is dos drive specifier if {[string index $http(what) 0] == "/" && \ [string index $http(what) 2] == ":" && \ [string index $http(what) 3] == "/"} { set http(what) [string range $http(what) 1 end] } set out -1 if {"$locfile" != ""} { if {[catch "open [list "$locfile"] w" out]} { puts stderr "fetchURL: unable to open local destination file: $locfile" return 0 } if {[catch "fconfigure $out -translation lf"]} { catch "close $out" puts stderr "fetchURL: unable to configure local destination file descriptor" return 0 } } # -- handle "file" protocol here if {$http(protocol) == "" || [string tolower $http(protocol)] == "file"} { if {(![file exists $http(what)]) || (![file readable $http(what)])} { set http(code) 404 return [error404 $http(full)] } if {[file isdirectory $http(what)]} { if {"/" != [string index $http(what) [expr [string length $http(what)] - 1]]} { append http(what) "/" append http(full) "/" } append http(what) "index.html" if {(![file exists $http(what)]) || (![file readable $http(what)])} { set http(code) 404 return [error404 "$http(full)index.html"] } } if {[catch "open [list "$http(what)"] r" in]} { set http(code) 403 return [error403 $http(full)] } catch "fconfigure $in -translation lf" if {-1 != $out} { fcopy $in $out close $in close $out return 1 } else { set buf "[read $in]" close $in return "$buf" } } set http(timeoutid) [after $http(inittimeoutlen) "HttpTimeout -1 $out"] set s [HttpOpen] if {"$s" == ""} {return 0} fileevent $s readable [list HttpCopy $s $out $chunk] vwait http(copyDone) catch "after cancel $http(timeoutid)" if {"$s" != -1} { catch "fileevent $s readable {}" catch "close $s" } if {"$out" != "-1"} { catch "close $out" return 1 } else { return "$http(document)" } } #---------- # -- Open a connection to the http server proc HttpOpen {} { global http set http(connectDone) 0 set http(type) text/html if {[catch "socket $http(host) $http(port)" s]} { error "fetchURL: could not open connection to $http(host) at port $http(port)" } if {[catch "fileevent $s writable [list "HttpConnect $s"]"]} { puts stderr "fetchURL: unable to set up writable event handler" catch "fileevent $s writable {}" catch "close $s" return "" } vwait http(connectDone) if {[catch "eof $s" eofflag] || $eofflag} { puts stderr "fetchURL: remote connection prematurely closed by server" catch "fileevent $s writable {}" catch "close $s" return "" } if {[catch "fconfigure $s -translation crlf"]} { puts stderr "fetchURL: unable to set line protocol for MIME header" catch "fileevent $s writable {}" catch "close $s" return "" } set what $http(what) append what $http(key) catch "puts $s [list "GET $what HTTP/1.0"]" catch "puts $s [list "Accept: */*"]" catch "puts $s [list "User-Agent: Spynergy Geturl"]" catch "puts $s {}" if {[catch "flush $s"]} { puts stderr "fetchURL: unable to write MIME header for request" catch "fileevent $s writable {}" catch "close $s" return "" } # -- Put this back because the server may or may not use crlf # -- in the headers if {[catch "fconfigure $s -translation auto"]} { puts stderr "fetchURL: unable to set line protocol for document body" catch "fileevent $s writable {}" catch "close $s" return "" } return $s } #---------- # -- Callback made when connection is established proc HttpConnect {s} { global http set http(connectDone) 1 catch "fileevent $s writable {}" } #---------- # -- Procedure invoked when a timeout is hit proc HttpTimeout {s outfd} { global http catch "after cancel $http(timeoutid)" set http(copyDone) 1 if {$outfd != -1} {catch "close $outfd"} } #---------- # -- Process buffers received from server proc HttpCopy {s outfd chunksize} { global http sizevar after cancel $http(timeoutid) set http(timeoutid) [after $http(timeoutlen) "HttpTimeout $s $outfd"] if {$http(state) == "header"} { if {[catch "gets $s line" n]} {set n -1} if {[catch "eof $s" eofflag] || $eofflag} {set n -1} if {$n < 0} { set http(copyDone) 1 } elseif {$n == 0} { set http(state) "body" if {"$http(type)" == "text/html" || \ "$http(type)" == "application/tcl" || \ "$http(type)" == "application/x-spynergy" || \ "$http(type)" == "application/weblet"} { catch "fconfigure $s -translation auto" } else { catch "fconfigure $s -translation lf" } if {$http(code) == 301 || $http(code) == 302} { after cancel $http(timeoutid) set http(copyDone) 1 } } else { # n > 0 if {"content-type:" == "[lindex [string tolower $line] 0]"} { set http(type) "[lindex [string tolower $line] 1]" } if {"content-length:" == "[lindex [string tolower $line] 0]"} { set http(length) "[lindex [string tolower $line] 1]" } if {"http/1.0" == "[lindex [string tolower $line] 0]"} { set http(code) "[lindex [string tolower $line] 1]" } if {"location:" == "[lindex [string tolower $line] 0]"} { set http(location) "[lindex [string tolower $line] 1]" } append http(mime) "$line\n" } } else { if {$outfd != "-1"} { if {[catch "fcopy $s $outfd $sizevar $chunksize" n]} {set n -1} } else { if {[catch "read $s $chunksize" line]} { set n -1 } else { set n [string length "$line"] } if {$n > 0} {append http(document) "$line"} } if {[catch "eof $s" eofflag] || $eofflag} {set n -1} if {$n <= 0} { set http(copyDone) 1 } else { incr http(copySize) $n if {$http(length) != 0 && $http(copySize) >= $http(length)} {set http(copyDone) 1} } } } #---------- # -- wrapper procedure to get arguments and start things up proc fetchURL {args} { global http set l [llength $args] set url "" set outfile "" set http(timeoutlen) 5000 set http(inittimeoutlen) 30000 for {set i 0} {$i < $l} {incr i} { set a [lindex $args $i] if {"[string tolower $a]" == "-url"} { incr i set url "[lindex $args $i]" } elseif {"[string tolower $a]" == "-outfile"} { incr i set outfile "[lindex $args $i]" } elseif {"[string tolower $a]" == "-timeout"} { incr i set timeout "[lindex $args $i]" if {[catch "expr int($timeout * 1000)" timeout]} { error "fetchURL: timeout value must be numeric" } set http(timeoutlen) $timeout } elseif {"[string tolower $a]" == "-initialtimeout"} { incr i set inittimeout "[lindex $args $i]" if {[catch "expr int($inittimeout * 1000)" inittimeout]} { error "fetchURL: inittimeout value must be numeric" } set http(inittimeoutlen) $inittimeout } else { set url "$a" } } set x "[Http_Copy $url $outfile]" if {$http(code) == 301 || $http(code) == 302} { if {$http(location) != ""} { if {$outfile == ""} { return "[fetchURL -url $http(location)]" } else { return "[fetchURL -url $http(location) -outfile $outfile]" } } else { return "$x" } } else { return "$x" } } #---------- # -- procedure to call if local file is not found proc error404 {url} { set doc " 404 Not Found 404 Not Found
The requested URL: \"$url\" was not found. " return $doc } #---------- # -- procedure to call if local file access had errors proc error403 {url} { set doc "403 Forbidden 403 Forbidden
Obtaining the requested URL: \"$url\" was denied. " return $doc } #---------- # -- report background errors on the server if {[info procs bgerror] == ""} { proc bgerror {args} { global errorInfo errorCode puts stderr "Background error: $args" puts stderr "\t$errorInfo" puts stderr "errorCode = \[$errorCode\]" return "" } } #============================================================================ # urlutil.tcl -- # Procedures for parsing and manipulating URLs # # parseurl: # Breaks a URL into its components, returning these components in # a list: # index value: # 0 protocol name (lowercase) # 1 host name # 2 port number # 3 path # 4 extension/MIME type ("." followed by lowercase) # 5 tag found after "#" # 6 key, including "?" # # mergeurls: # takes two urls and merges their paths. The first argument # should be the current absolute path. The second argument # can be any valid url or relative path. The result is # an absolute url to the second argument. # # extracttagkey: # given an absolute URL, returns a list of three items: # absolute url without tag or key value # tag # key # #--------------------------------------------------------------------------- proc parseurl {url} { set protocol "" set host "" set port "" set path "" set ext "" set tag "" set key "" set full $url set i [string first "://" $url] if {$i != -1} { # -- parse out protocol set protocol [string tolower [string range $url 0 [expr $i - 1]]] set url [string range $url [expr $i + 3] end] # -- parse out host foreach c [split $url ""] { if {$c == "/" || $c == ":"} {break} append host $c set url [string range $url 1 end] } # -- parse out port number if {[string index $url 0] == ":"} { set url [string range $url 1 end] foreach c [split $url ""] { if {$c == "/"} {break} append port $c set url [string range $url 1 end] } } } # -- parse out path foreach c [split $url ""] { if {$c == "#" || $c == "?"} {break} append path $c set url [string range $url 1 end] } # -- parse out extension from path for {set i [expr [string length $path] - 1]} {$i>0} {incr i -1} { set c [string index $path $i] if {$c == "/"} {break} if {$c == "."} { set ext [string tolower [string range $path $i end]] break } } # -- parse out tag if {[string index $url 0] == "#"} { set url [string range $url 1 end] foreach c [split $url ""] { if {$c == "?"} {break} append tag $c set url [string range $url 1 end] } } # -- whatever remains must be a key set key $url return [list "$protocol" "$host" "$port" "$path" "$ext" "$tag" "$key"] } #---------- # -- merge urls into an absolute url proc mergeurls {u1 u2} { set u1l [parseurl $u1] set u2l [parseurl $u2] set out "" # -- handle the case where u2 is absolute if {[lindex $u2l 0] != "" || [lindex $u2l 1] != "" || \ [lindex $u2l 2] != ""} { if {[lindex $u2l 0] != ""} { append out "[lindex $u2l 0]://" } append out [lindex $u2l 1] if {[lindex $u2l 2] != ""} { append out ":[lindex $u2l 2]" } if {[string index [lindex $u2l 3] 0] != "/"} { append out "/" } append out [lindex $u2l 3] if {[lindex $u2l 5] != ""} { append out "#[lindex $u2l 5]" } if {[lindex $u2l 6] != ""} { append out [lindex $u2l 6] } return $out } # -- build URL prefix from the 1st URL if {[lindex $u1l 0] != ""} { append out "[lindex $u1l 0]://" } append out [lindex $u1l 1] if {[lindex $u1l 2] != ""} { append out ":[lindex $u1l 2]" } # -- merge the paths set p1 [lindex $u1l 3] set p2 [lindex $u2l 3] if {[string index $u2 0] == "#"} { # -- handle special case that relative link is only a tag append out [lindex $u1l 3] append out "#[lindex $u2l 5]" if {[lindex $u2l 6] != ""} { append out [lindex $u2l 6] } return $out } if {[string index $p1 [expr [string length $p1] - 1]] == "/"} { append p1 "xyz" } if {[string index $p2 0] == "/"} { set p1 $p2 } else { set outp "" set p1 [split [file dirname $p1] "/"] set p1last [expr [llength $p1] - 1] set p2 [split $p2 "/"] set p2last [expr [llength $p2] - 1] foreach item $p2 { switch -exact -- $item { .. { incr p1last -1 if {$p1last < -1} { set p1last -1 set p1 "" } else { set p1 [lrange $p1 0 $p1last] } } . { } default { incr p1last lappend p1 $item } } } if {[llength $p1] > 0 && [lindex $p1 0] != ""} { set p1 "{} $p1" } set p1 [join $p1 "/"] regsub -all {//} $p1 "/" p1 regsub -all {//} $p1 "/" p1 if {$p1 == ""} {set p1 "/"} } append out $p1 if {[lindex $u2l 5] != ""} { append out "#[lindex $u2l 5]" } if {[lindex $u2l 6] != ""} { append out [lindex $u2l 6] } return $out } #---------- # -- extract tag and key from absolute url proc extracttagkey {url} { set l [parseurl $url] if {[lindex $l 5] == "" && [lindex $l 6] == ""} { return [list "$url" "" ""] } set out "" if {[lindex $l 0] != ""} { append out "[lindex $l 0]://" } append out [lindex $l 1] if {[lindex $l 2] != ""} { append out ":[lindex $l 2]" } append out [lindex $l 3] return [list "$out" "[lindex $l 5]" "[lindex $l 6]"] } ############### # end fetchURL.tcl section ############### ############### # start htmllib.tcl section ############### # HTML display library # # See the file "LICENSE.TXT" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # To use this package, create a text widget (say, .text) # and set a variable full of html, (say $html), and issue: # HMinit_win .text # HMparse_html $html "HMrender .text" # You also need to supply the routine: # proc HMlink_callback {win href} { ...} # win: The name of the text widget # href The name of the link # which will be called anytime the user "clicks" on a link. # The supplied version just prints the link to stdout. # In addition, if you wish to use embedded images, you will need to write # proc HMset_image {handle src} # handle an arbitrary handle (not really) # src The name of the image # Which calls # HMgot_image $handle $image # with the TK image. # # To return a "used" text widget to its initialized state, call: # HMreset_win .text # ################################################################## ############################################ # mapping of html tags to text tag properties # properties beginning with "T" map directly to text tags # These are Defined in HTML 2.0 global HMtag_map set HMtag_map(b) {weight bold} set HMtag_map(blockquote) {style i indent 1 Trindent rindent} set HMtag_map(bq) {style i indent 1 Trindent rindent} set HMtag_map(cite) {style i} set HMtag_map(code) {family courier} set HMtag_map(dfn) {style i} set HMtag_map(dir) {indent 1} set HMtag_map(dl) {indent 1} set HMtag_map(em) {style i} set HMtag_map(h1) {size 24 weight bold} set HMtag_map(h2) {size 22} set HMtag_map(h3) {size 20} set HMtag_map(h4) {size 18} set HMtag_map(h5) {size 16} set HMtag_map(h6) {style i} set HMtag_map(i) {style i} set HMtag_map(kbd) {family courier weight bold} set HMtag_map(menu) {indent 1} set HMtag_map(ol) {indent 1} set HMtag_map(pre) {fill 0 family courier Tnowrap nowrap} set HMtag_map(samp) {family courier} set HMtag_map(strong) {weight bold} set HMtag_map(tt) {family courier} set HMtag_map(u) {Tunderline underline} set HMtag_map(ul) {indent 1} set HMtag_map(var) {style i} # These are in common(?) use, but not defined in html2.0 set HMtag_map(center) {Tcenter center} set HMtag_map(strike) {Tstrike strike} set HMtag_map(u) {Tunderline underline} # initial values set HMtag_map(hmstart) { family times weight medium style r size 14 Tcenter "" Tlink "" Tnowrap "" Tunderline "" list list fill 1 indent "" counter 0 adjust 0 } # html tags that insert white space global HMinsert_map array set HMinsert_map { blockquote "\n\n" /blockquote "\n" br "\n" dd "\n" /dd "\n" dl "\n" /dl "\n" dt "\n" form "\n" /form "\n" h1 "\n\n" /h1 "\n" h2 "\n\n" /h2 "\n" h3 "\n\n" /h3 "\n" h4 "\n" /h4 "\n" h5 "\n" /h5 "\n" h6 "\n" /h6 "\n" li "\n" /dir "\n" /ul "\n" /ol "\n" /menu "\n" p "\n\n" pre "\n" /pre "\n" } # tags that are list elements, that support "compact" rendering global HMlist_elements array set HMlist_elements { ol 1 ul 1 menu 1 dl 1 dir 1 } ############################################ # initialize the window and stack state proc HMinit_win {win} { global HM$win upvar #0 HM$win var HMinit_state $win $win tag configure underline -underline 1 $win tag configure center -justify center $win tag configure nowrap -wrap none $win tag configure rindent -rmargin $var(S_tab)c $win tag configure strike -overstrike 1 $win tag configure mark -foreground red ;# list markers $win tag configure list -spacing1 3p -spacing3 3p ;# regular lists $win tag configure compact -spacing1 0p ;# compact lists $win tag configure link -borderwidth 2 -foreground blue ;# hypertext links HMset_indent $win $var(S_tab) $win configure -wrap word # configure the text insertion point $win mark set $var(S_insert) 1.0 # for horizontal rules $win tag configure thin -font [HMx_font times 2 medium r] $win tag configure hr -relief sunken -borderwidth 2 -wrap none \ -tabs [winfo width $win] bind $win{ %W tag configure hr -tabs %w %W tag configure last -spacing3 %h } # generic link enter callback $win tag bind link <1> "HMlink_hit $win %x %y" } # set the indent spacing (in cm) for lists # TK uses a "weird" tabbing model that causes \t to insert a single # space if the current line position is past the tab setting proc HMset_indent {win cm} { set tabs [expr $cm / 2.0] $win configure -tabs ${tabs}c foreach i {1 2 3 4 5 6 7 8 9} { set tab [expr $i * $cm] $win tag configure indent$i -lmargin1 ${tab}c -lmargin2 ${tab}c \ -tabs "[expr $tab + $tabs]c [expr $tab + 2*$tabs]c" } } # reset the state of window - get ready for the next page # remove all but the font tags, and remove all form state proc HMreset_win {win} { global HM$win upvar #0 HM$win var regsub -all { +[^L ][^ ]*} " [$win tag names] " {} tags catch "$win tag delete $tags" eval $win mark unset [$win mark names] $win delete 0.0 end $win tag configure hr -tabs [winfo width $win] # configure the text insertion point $win mark set $var(S_insert) 1.0 # remove form state. If any check/radio buttons still exists, # their variables will be magically re-created, and never get # cleaned up. catch unset [info globals HM$win.form*] HMinit_state $win return HM$win } # initialize the window's state array # Parameters beginning with S_ are NOT reset # adjust_size: global font size adjuster # unknown: character to use for unknown entities # tab: tab stop (in cm) # stop: enabled to stop processing # update: how many tags between update calls # tags: number of tags processed so far # symbols: Symbols to use on un-ordered lists proc HMinit_state {win} { global HM$win upvar #0 HM$win var array set tmp [array get var S_*] catch {unset var} array set var { stop 0 tags 0 fill 0 list list S_adjust_size 0 S_tab 1.0 S_unknown \xb7 S_update 10 S_symbols O*=+-o\xd7\xb0>:\xb7 S_insert Insert } array set var [array get tmp] } # alter the parameters of the text state # this allows an application to over-ride the default settings # it is called as: HMset_state -param value -param value ... global HMparam_map array set HMparam_map { -update S_update -tab S_tab -unknown S_unknown -stop S_stop -size S_adjust_size -symbols S_symbols -insert S_insert } proc HMset_state {win args} { global HM$win upvar #0 HM$win var global HMparam_map set bad 0 if {[catch {array set params $args}]} {return 0} foreach i [array names params] { incr bad [catch {set var($HMparam_map($i)) $params($i)}] } return [expr $bad == 0] } ############################################ # manage the display of html # HMrender gets called for every html tag # win: The name of the text widget to render into # tag: The html tag (in arbitrary case) # not: a "/" or the empty string # param: The un-interpreted parameter list # text: The plain text until the next html tag proc HMrender {win tag not param text} { global HM$win upvar #0 HM$win var if {$var(stop)} return global HMtag_map HMinsert_map HMlist_elements set tag [string tolower $tag] set text [HMmap_esc $text] # manage compact rendering of lists if {[info exists HMlist_elements($tag)]} { set list "list [expr {[HMextract_param $param compact] ? "compact" : "list"}]" } else { set list "" } # Allow text to be diverted to a different window (for tables) # this is not currently used if {[info exists var(divert)]} { set win $var(divert) global HM$win upvar #0 HM$win var } # adjust (push or pop) tag state catch {HMstack $win $not "$HMtag_map($tag) $list"} # insert white space (with current font) # adding white space can get a bit tricky. This isn't quite right set bad [catch {$win insert $var(S_insert) $HMinsert_map($not$tag) "space $var(font)"}] if {!$bad && [lindex $var(fill) end]} { set text [string trimleft $text] } # to fill or not to fill if {[lindex $var(fill) end]} { set text [HMzap_white $text] } # generic mark hook catch {HMmark $not$tag $win $param text} err # do any special tag processing catch {HMtag_$not$tag $win $param text} msg # add the text with proper tags set tags [HMcurrent_tags $win] $win insert $var(S_insert) $text $tags # We need to do an update every so often to insure interactive response. # This can cause us to re-enter the event loop, and cause recursive # invocations of HMrender, so we need to be careful. if {!([incr var(tags)] % $var(S_update))} { update } } # html tags requiring special processing # Procs of the form HMtag_ or HMtag_ get called just before # the text for this tag is displayed. These procs are called inside a # "catch" so it is OK to fail. # win: The name of the text widget to render into # param: The un-interpreted parameter list # text: A pass-by-reference name of the plain text until the next html tag # Tag commands may change this to affect what text will be inserted # next. # A pair of pseudo tags are added automatically as the 1st and last html # tags in the document. The default isand . # Append enough blank space at the end of the text widget while # rendering so HMgoto can place the target near the top of the page, # then remove the extra space when done rendering. proc HMtag_hmstart {win param text} { global HM$win upvar #0 HM$win var $win mark gravity $var(S_insert) left $win insert end "\n " last $win mark gravity $var(S_insert) right } proc HMtag_/hmstart {win param text} { $win delete last.first end } # put the document title in the window banner, and remove the title text # from the document proc HMtag_title {win param text} { upvar $text data wm title [winfo toplevel $win] $data set data "" } proc HMtag_hr {win param text} { global HM$win upvar #0 HM$win var $win insert $var(S_insert) "\n" space "\n" thin "\t" "thin hr" "\n" thin } # list element tags proc HMtag_ol {win param text} { global HM$win upvar #0 HM$win var set var(count$var(level)) 0 } proc HMtag_ul {win param text} { global HM$win upvar #0 HM$win var catch {unset var(count$var(level))} } proc HMtag_menu {win param text} { global HM$win upvar #0 HM$win var set var(menu) -> set var(compact) 1 } proc HMtag_/menu {win param text} { global HM$win upvar #0 HM$win var catch {unset var(menu)} catch {unset var(compact)} } proc HMtag_dt {win param text} { global HM$win upvar #0 HM$win var upvar $text data set level $var(level) incr level -1 $win insert $var(S_insert) "$data" \ "hi [lindex $var(list) end] indent$level $var(font)" set data {} } proc HMtag_li {win param text} { global HM$win upvar #0 HM$win var set level $var(level) incr level -1 set x [string index $var(S_symbols)+-+-+-+-" $level] catch {set x [incr var(count$level)]} catch {set x $var(menu)} $win insert $var(S_insert) \t$x\t "mark [lindex $var(list) end] indent$level $var(font)" } # Manage hypertext "anchor" links. A link can be either a source (href) # a destination (name) or both. If its a source, register it via a callback, # and set its default behavior. If its a destination, check to see if we need # to go there now, as a result of a previous HMgoto request. If so, schedule # it to happen with the closing tag, so we can highlight the text up to # the . proc HMtag_a {win param text} { global HM$win upvar #0 HM$win var # a source if {[HMextract_param $param href]} { set var(Tref) [list L:$href] HMstack $win "" "Tlink link" HMlink_setup $win $href } # a destination if {[HMextract_param $param name]} { set var(Tname) [list N:$name] HMstack $win "" "Tanchor anchor" $win mark set N:$name "$var(S_insert) - 1 chars" $win mark gravity N:$name left if {[info exists var(goto)] && $var(goto) == $name} { unset var(goto) set var(going) $name } } } # The application should call here with the fragment name # to cause the display to go to this spot. # If the target exists, go there (and do the callback), # otherwise schedule the goto to happen when we see the reference. proc HMgoto {win where {callback HMwent_to}} { global HM$win upvar #0 HM$win var if {-1 != [lsearch [$win mark names] N:$where]} { $win see N:$where update eval $callback $win [list $where] return 1 } else { set var(goto) $where return 0 } } # We actually got to the spot, so highlight it! # This should/could be replaced by the application # We'll flash it orange a couple of times. proc HMwent_to {win where {count 0} {color orange}} { global HM$win upvar #0 HM$win var if {$count > 5} return catch {$win tag configure N:$where -foreground $color} update after 200 [list HMwent_to $win $where [incr count] \ [expr {$color=="orange" ? "" : "orange"}]] } proc HMtag_/a {win param text} { global HM$win upvar #0 HM$win var if {[info exists var(Tref)]} { unset var(Tref) HMstack $win / "Tlink link" } # goto this link, then invoke the call-back. if {[info exists var(going)]} { $win yview N:$var(going) update HMwent_to $win $var(going) unset var(going) } if {[info exists var(Tname)]} { unset var(Tname) HMstack $win / "Tanchor anchor" } } # Inline Images # This interface is subject to change # Most of the work is getting around a limitation of TK that prevents # setting the size of a label to a widthxheight in pixels # # Images have the following parameters: # align: top,middle,bottom # alt: alternate text # ismap: A clickable image map # src: The URL link # Netscape supports (and so do we) # width: A width hint (in pixels) # height: A height hint (in pixels) # border: The size of the window border proc HMtag_img {win param text} { global HM$win upvar #0 HM$win var # get alignment array set align_map {top top middle center bottom bottom} set align bottom ;# The spec isn't clear what the default should be HMextract_param $param align catch {set align $align_map([string tolower $align])} # get alternate text set alt "" HMextract_param $param alt set alt [HMmap_esc $alt] # get the border width set border 1 HMextract_param $param border # see if we have an image size hint # If so, make a frame the "hint" size to put the label in # otherwise just make the label set item $win.$var(tags) # catch {destroy $item} if {[HMextract_param $param width] && [HMextract_param $param height]} { frame $item -width $width -height $height pack propagate $item 0 set label $item.label label $label pack $label -expand 1 -fill both } else { set label $item label $label } $label configure -relief ridge -fg orange -text $alt catch {$label configure -bd $border} $win window create $var(S_insert) -align $align -window $item -pady 2 -padx 2 # add in all the current tags (this is overkill) set tags [HMcurrent_tags $win] foreach tag $tags { $win tag add $tag $item } # set imagemap callbacks if {[HMextract_param $param ismap]} { # regsub -all {[^L]*L:([^ ]*).*} $tags {\1} link set link [lindex $tags [lsearch -glob $tags L:*]] regsub L: $link {} link global HMevents regsub -all {%} $link {%%} link2 foreach i [array names HMevents] { bind $label <$i> "catch \{%W configure $HMevents($i)\}" } bind $label <1> "+HMlink_callback $win $link2?%x,%y" } else { # regsub -all {[^L]*L:([^ ]*).*} $tags {\1} link set link [lindex $tags [lsearch -glob $tags L:*]] regsub L: $link {} link global HMevents regsub -all {%} $link {%%} link2 foreach i [array names HMevents] { bind $label <$i> "catch \{%W configure $HMevents($i)\}" } if {$link2 != ""} {bind $label <1> "+HMlink_callback $win $link2"} } # now callback to the application set src "" HMextract_param $param src HMset_image $win $label $src return $label ;# used by the forms package for input_image types } # The app needs to supply one of these if {[info procs HMset_image] == ""} { proc HMset_image {win handle src} { HMgot_image $handle "can't get\n$src" } } # When the image is available, the application should call back here. # If we have the image, put it in the label, otherwise display the error # message. If we don't get a callback, the "alt" text remains. # if we have a clickable image, arrange for a callback proc HMgot_image {win image_error} { # if we're in a frame turn on geometry propogation if {[winfo name $win] == "label"} { pack propagate [winfo parent $win] 1 } if {[catch {$win configure -image $image_error}]} { $win configure -image {} $win configure -text $image_error } } # Sample hypertext link callback routine - should be replaced by app # This proc is called once for each tag. # Applications can overwrite this procedure, as required, or # replace the HMevents array # win: The name of the text widget to render into # href: The HREF link for this tag. global HMevents array set HMevents { Enter {-borderwidth 2 -relief raised } Leave {-borderwidth 2 -relief flat } 1 {-borderwidth 2 -relief sunken} ButtonRelease-1 {-borderwidth 2 -relief raised} } # We need to escape any %'s in the href tag name so the bind command # doesn't try to substitute them. proc HMlink_setup {win href} { global HMevents regsub -all {%} $href {%%} href2 foreach i [array names HMevents] { eval {$win tag bind L:$href <$i>} \ \{$win tag configure \{L:$href2\} $HMevents($i)\} } } # generic link-hit callback # This gets called upon button hits on hypertext links # Applications are expected to supply ther own HMlink_callback routine # win: The name of the text widget to render into # x,y: The cursor position at the "click" proc HMlink_hit {win x y} { set tags [$win tag names @$x,$y] set link [lindex $tags [lsearch -glob $tags L:*]] # regsub -all {[^L]*L:([^ ]*).*} $tags {\1} link regsub L: $link {} link HMlink_callback $win $link } # replace this! # win: The name of the text widget to render into # href: The HREF link for this tag. if {[info procs HMlink_callback] == ""} { proc HMlink_callback {win href} { puts "Got hit on $win, link $href" } } # extract a value from parameter list (this needs a re-do) # returns "1" if the keyword is found, "0" otherwise # param: A parameter list. It should alredy have been processed to # remove any entity references # key: The parameter name # val: The variable to put the value into (use key as default) proc HMextract_param {param key {val ""}} { if {$val == ""} { upvar $key result } else { upvar $val result } set ws " \n\r" # look for name=value combinations. Either (') or (") are valid delimeters if { [regsub -nocase [format {.*%s[%s]*=[%s]*"([^"]*).*} $key $ws $ws] $param {\1} value] || [regsub -nocase [format {.*%s[%s]*=[%s]*'([^']*).*} $key $ws $ws] $param {\1} value] || [regsub -nocase [format {.*%s[%s]*=[%s]*([^%s]+).*} $key $ws $ws $ws] $param {\1} value] } { set result $value return 1 } # now look for valueless names # I should strip out name=value pairs, so we don't end up with "name" # inside the "value" part of some other key word - some day set bad \[^a-zA-Z\]+ if {[regexp -nocase "$bad$key$bad" -$param-]} { return 1 } else { return 0 } } # These next two routines manage the display state of the page. # Push or pop tags to/from stack. # Each orthogonal text property has its own stack, stored as a list. # The current (most recent) tag is the last item on the list. # Push is {} for pushing and {/} for popping proc HMstack {win push list} { global HM$win upvar #0 HM$win var array set tags $list if {$push == ""} { foreach tag [array names tags] { lappend var($tag) $tags($tag) } } else { foreach tag [array names tags] { # set cnt [regsub { *[^ ]+$} $var($tag) {} var($tag)] set var($tag) [lreplace $var($tag) end end] } } } # extract set of current text tags # tags starting with T map directly to text tags, all others are # handled specially. There is an application callback, HMset_font # to allow the application to do font error handling proc HMcurrent_tags {win} { global HM$win upvar #0 HM$win var set font font foreach i {family size weight style} { #if {![info exists var($i)]} {set var($i) ""} set $i [lindex $var($i) end] append font :[set $i] } set xfont [HMx_font $family $size $weight $style $var(S_adjust_size)] HMset_font $win $font $xfont #if {![info exists var(indent)]} {set var(indent) ""} set indent [llength $var(indent)] incr indent -1 lappend tags $font indent$indent foreach tag [array names var T*] { lappend tags [lindex $var($tag) end] ;# test } set var(font) $font set var(xfont) [$win tag cget $font -font] set var(level) $indent return $tags } # allow the application to do do better font management # by overriding this procedure proc HMset_font {win tag font} { catch {$win tag configure $tag -font $font} msg } # generate an X font name proc HMx_font {family size weight style {adjust_size 0}} { catch {incr size $adjust_size} return "-*-$family-$weight-$style-normal-*-*-${size}0-*-*-*-*-*-*" } # Optimize HMrender (hee hee) # This is experimental proc HMoptimize {} { regsub -all "\n\[ \]*#\[^\n\]*" [info body HMrender] {} body regsub -all ";\[ \]*#\[^\n]*" $body {} body regsub -all "\n\n+" $body \n body proc HMrender {win tag not param text} $body } ############################################ # Turn HTML into TCL commands # html A string containing an html document # cmd A command to run for each html tag found # start The name of the dummy html start/stop tags proc HMparse_html {html {cmd HMtest_parse} {start hmstart}} { regsub -all \{ $html {\&ob;} html regsub -all \} $html {\&cb;} html set w " \t\r\n" ;# white space proc HMcl x {return "\[$x\]"} set exp <(/?)([HMcl ^$w>]+)[HMcl $w]*([HMcl ^>]*)> set sub "\}\n$cmd {\\2} {\\1} {\\3} \{" regsub -all $exp $html $sub html eval "$cmd {$start} {} {} \{ $html \}" eval "$cmd {$start} / {} {}" } proc HMtest_parse {command tag slash text_after_tag} { puts "==> $command $tag $slash $text_after_tag" } # Convert multiple white space into a single space proc HMzap_white {data} { regsub -all "\[ \t\r\n\]+" $data " " data return $data } # find HTML escape characters of the form &xxx; proc HMmap_esc {text} { if {![regexp & $text]} {return $text} regsub -all {([][$\\])} $text {\\\1} new regsub -all {([0-9][0-9]?[0-9]?);?} \ $new {[format %c [scan \1 %d tmp;set tmp]]} new regsub -all {&([a-zA-Z]+);?} $new {[HMdo_map \1]} new return [subst $new] } # convert an HTML escape sequence into character proc HMdo_map {text {unknown ?}} { global HMesc_map set result $unknown catch {set result $HMesc_map($text)} return $result } # table of escape characters (ISO latin-1 esc's are in a different table) global HMesc_map array set HMesc_map { lt < gt > amp & quot \" copy \xa9 reg \xae ob \x7b cb \x7d nbsp \xa0 } ############################################################# # ISO Latin-1 escape codes array set HMesc_map { nbsp \xa0 iexcl \xa1 cent \xa2 pound \xa3 curren \xa4 yen \xa5 brvbar \xa6 sect \xa7 uml \xa8 copy \xa9 ordf \xaa laquo \xab not \xac shy \xad reg \xae hibar \xaf deg \xb0 plusmn \xb1 sup2 \xb2 sup3 \xb3 acute \xb4 micro \xb5 para \xb6 middot \xb7 cedil \xb8 sup1 \xb9 ordm \xba raquo \xbb frac14 \xbc frac12 \xbd frac34 \xbe iquest \xbf Agrave \xc0 Aacute \xc1 Acirc \xc2 Atilde \xc3 Auml \xc4 Aring \xc5 AElig \xc6 Ccedil \xc7 Egrave \xc8 Eacute \xc9 Ecirc \xca Euml \xcb Igrave \xcc Iacute \xcd Icirc \xce Iuml \xcf ETH \xd0 Ntilde \xd1 Ograve \xd2 Oacute \xd3 Ocirc \xd4 Otilde \xd5 Ouml \xd6 times \xd7 Oslash \xd8 Ugrave \xd9 Uacute \xda Ucirc \xdb Uuml \xdc Yacute \xdd THORN \xde szlig \xdf agrave \xe0 aacute \xe1 acirc \xe2 atilde \xe3 auml \xe4 aring \xe5 aelig \xe6 ccedil \xe7 egrave \xe8 eacute \xe9 ecirc \xea euml \xeb igrave \xec iacute \xed icirc \xee iuml \xef eth \xf0 ntilde \xf1 ograve \xf2 oacute \xf3 ocirc \xf4 otilde \xf5 ouml \xf6 divide \xf7 oslash \xf8 ugrave \xf9 uacute \xfa ucirc \xfb uuml \xfc yacute \xfd thorn \xfe yuml \xff } ########################################################## # html forms management commands # As each form element is located, it is created and rendered. Additional # state is stored in a form specific global variable to be processed at # the end of the form, including the "reset" and "submit" options. # Remember, there can be multiple forms existing on multiple pages. When # HTML tables are added, a single form could be spread out over multiple # text widgets, which makes it impractical to hang the form state off the # HM$win structure. We don't need to check for the existance of required # parameters, we just "fail" and get caught in HMrender # This causes line breaks to be preserved in the inital values # of text areas array set HMtag_map { textarea {fill 0} } ########################################################## # html isindex tag. Although not strictly forms, they're close enough # to be in this file # is-index forms # make a frame with a label, entry, and submit button proc HMtag_isindex {win param text} { global HM$win upvar #0 HM$win var set item $win.$var(tags) if {[winfo exists $item]} { destroy $item } frame $item -relief ridge -bd 3 set prompt "Enter search keywords here" HMextract_param $param prompt label $item.label -text [HMmap_esc $prompt] -font $var(xfont) entry $item.entry bind $item.entry "$item.submit invoke" button $item.submit -text search -font $var(xfont) -command \ [format {HMsubmit_index %s {%s} [HMmap_reply [%s get]]} \ $win $param $item.entry] pack $item.label -side top pack $item.entry $item.submit -side left # insert window into text widget $win insert $var(S_insert) \n isindex HMwin_install $win $item $win insert $var(S_insert) \n isindex bind $item {focus %W.entry} } # This is called when the isindex form is submitted. # The default version calls HMlink_callback. Isindex tags should either # be deprecated, or fully supported (e.g. they need an href parameter) proc HMsubmit_index {win param text} { HMlink_callback $win ?$text } # initialize form state. All of the state for this form is kept # in a global array whose name is stored in the form_id field of # the main window array. # Parameters: ACTION, METHOD, ENCTYPE proc HMtag_form {win param text} { global HM$win upvar #0 HM$win var # create a global array for the form set id HM$win.form$var(tags) upvar #0 $id form # missing /form tag, simulate it if {[info exists var(form_id)]} { puts "Missing end-form tag !!!! $var(form_id)" HMtag_/form $win {} {} } catch {unset form} set var(form_id) $id set form(param) $param ;# form initial parameter list set form(reset) "" ;# command to reset the form set form(reset_button) "" ;# list of all reset buttons set form(submit) "" ;# command to submit the form set form(submit_button) "" ;# list of all submit buttons } # Where we're done try to get all of the state into the widgets so # we can free up the form structure here. Unfortunately, we can't! proc HMtag_/form {win param text} { global HM$win upvar #0 HM$win var upvar #0 $var(form_id) form # make submit button entries for all radio buttons foreach name [array names form radio_*] { regsub radio_ $name {} name lappend form(submit) [list $name \$form(radio_$name)] } # process the reset button(s) foreach item $form(reset_button) { $item configure -command $form(reset) } # no submit button - add one if {$form(submit_button) == ""} { HMinput_submit $win {} } # process the "submit" command(s) # each submit button could have its own name,value pair foreach item $form(submit_button) { set submit $form(submit) catch {lappend submit $form(submit_$item)} $item configure -command \ [list HMsubmit_button $win $var(form_id) $form(param) \ $submit] } # unset all unused fields here unset form(reset) form(submit) form(reset_button) form(submit_button) unset var(form_id) } ################################################################### # handle form input items # each item type is handled in a separate procedure # Each "type" procedure needs to: # - create the window # - initialize it # - add the "submit" and "reset" commands onto the proper Q's # "submit" is subst'd # "reset" is eval'd proc HMtag_input {win param text} { global HM$win upvar #0 HM$win var set type text ;# the default HMextract_param $param type set type [string tolower $type] if {[catch {HMinput_$type $win $param} err]} { puts stderr $err } } # input type=text # parameters NAME (reqd), MAXLENGTH, SIZE, VALUE proc HMinput_text {win param {show {}}} { global HM$win upvar #0 HM$win var upvar #0 $var(form_id) form # make the entry HMextract_param $param name ;# required set item $win.input_text,$var(tags) set size 20; HMextract_param $param size set maxlength 0; HMextract_param $param maxlength entry $item -width $size -show $show # set the initial value set value ""; HMextract_param $param value $item insert 0 $value # insert the entry HMwin_install $win $item # set the "reset" and "submit" commands append form(reset) ";$item delete 0 end;$item insert 0 [list $value]" lappend form(submit) [list $name "\[$item get]"] # handle the maximum length (broken - no way to cleanup bindtags state) if {$maxlength} { bindtags $item "[bindtags $item] max$maxlength" bind max$maxlength "%W delete $maxlength end" } } # password fields - same as text, only don't show data # parameters NAME (reqd), MAXLENGTH, SIZE, VALUE proc HMinput_password {win param} { HMinput_text $win $param * } # checkbuttons are missing a "get" option, so we must use a global # variable to store the value. # Parameters NAME, VALUE, (reqd), CHECKED proc HMinput_checkbox {win param} { global HM$win upvar #0 HM$win var upvar #0 $var(form_id) form HMextract_param $param name HMextract_param $param value # Set the global variable, don't use the "form" alias as it is not # defined in the global scope of the button set variable $var(form_id)(check_$var(tags)) set item $win.input_checkbutton,$var(tags) checkbutton $item -variable $variable -off {} -on $value -text " " if {[HMextract_param $param checked]} { $item select append form(reset) ";$item select" } else { append form(reset) ";$item deselect" } HMwin_install $win $item lappend form(submit) [list $name \$form(check_$var(tags))] } # radio buttons. These are like check buttons, but only one can be selected proc HMinput_radio {win param} { global HM$win upvar #0 HM$win var upvar #0 $var(form_id) form HMextract_param $param name HMextract_param $param value set first [expr ![info exists form(radio_$name)]] set variable $var(form_id)(radio_$name) set variable $var(form_id)(radio_$name) set item $win.input_radiobutton,$var(tags) radiobutton $item -variable $variable -value $value -text " " HMwin_install $win $item if {$first || [HMextract_param $param checked]} { $item select append form(reset) ";$item select" } else { append form(reset) ";$item deselect" } # do the "submit" actions in /form so we only end up with 1 per button grouping # contributing to the submission } # hidden fields, just append to the "submit" data # params: NAME, VALUE (reqd) proc HMinput_hidden {win param} { global HM$win upvar #0 HM$win var upvar #0 $var(form_id) form HMextract_param $param name HMextract_param $param value lappend form(submit) [list $name $value] } # handle input images. The spec isn't very clear on these, so I'm not # sure its quite right # Use std image tag, only set up our own callbacks # (e.g. make sure ismap isn't set) # params: NAME, SRC (reqd) ALIGN proc HMinput_image {win param} { global HM$win upvar #0 HM$win var upvar #0 $var(form_id) form HMextract_param $param name set name ;# barf if no name is specified set item [HMtag_img $win $param {}] $item configure -relief raised -bd 2 -bg blue # make a dummy "submit" button, and invoke it to send the form. # We have to get the %x,%y in the value somehow, so calculate it during # binding, and save it in the form array for later processing set submit $win.dummy_submit,$var(tags) if {[winfo exists $submit]} { destroy $submit } button $submit -takefocus 0;# this never gets mapped! lappend form(submit_button) $submit set form(submit_$submit) [list $name $name.\$form(X).\$form(Y)] $item configure -takefocus 1 bind $item "catch \{$win see $item\}" bind $item <1> "$item configure -relief sunken" bind $item " set $var(form_id)(X) 0 set $var(form_id)(Y) 0 $submit invoke " bind $item " set $var(form_id)(X) %x set $var(form_id)(Y) %y $item configure -relief raised $submit invoke " } # Set up the reset button. Wait for the /form to attach # the -command option. There could be more that 1 reset button # params VALUE proc HMinput_reset {win param} { global HM$win upvar #0 HM$win var upvar #0 $var(form_id) form set value reset HMextract_param $param value set item $win.input_reset,$var(tags) button $item -text [HMmap_esc $value] HMwin_install $win $item lappend form(reset_button) $item } # Set up the submit button. Wait for the /form to attach # the -command option. There could be more that 1 submit button # params: NAME, VALUE proc HMinput_submit {win param} { global HM$win upvar #0 HM$win var upvar #0 $var(form_id) form HMextract_param $param name set value submit HMextract_param $param value set item $win.input_submit,$var(tags) button $item -text [HMmap_esc $value] -fg blue HMwin_install $win $item lappend form(submit_button) $item # need to tie the "name=value" to this button # save the pair and do it when we finish the submit button catch {set form(submit_$item) [list $name $value]} } ######################################################################### # selection items # They all go into a list box. We don't what to do with the listbox until # we know how many items end up in it. Gather up the data for the "options" # and finish up in the /select tag # params: NAME (reqd), MULTIPLE, SIZE proc HMtag_select {win param text} { global HM$win upvar #0 HM$win var upvar #0 $var(form_id) form HMextract_param $param name set size 5; HMextract_param $param size set form(select_size) $size set form(select_name) $name set form(select_values) "" ;# list of values to submit if {[HMextract_param $param multiple]} { set mode multiple } else { set mode single } set item $win.select,$var(tags) frame $item set form(select_frame) $item listbox $item.list -selectmode $mode -width 0 -exportselection 0 HMwin_install $win $item } # select options # The values returned in the query may be different from those # displayed in the listbox, so we need to keep a separate list of # query values. # form(select_default) - contains the default query value # form(select_frame) - name of the listbox's containing frame # form(select_values) - list of query values # params: VALUE, SELECTED proc HMtag_option {win param text} { global HM$win upvar #0 HM$win var upvar #0 $var(form_id) form upvar $text data set frame $form(select_frame) # set default option (or options) if {[HMextract_param $param selected]} { lappend form(select_default) [$form(select_frame).list size] } set value [string trimright $data " \n"] $frame.list insert end $value HMextract_param $param value lappend form(select_values) $value set data "" } # do most of the work here! # if SIZE>1, make the listbox. Otherwise make a "drop-down" # listbox with a label in it # If the # of items > size, add a scroll bar # This should probably be broken up into callbacks to make it # easier to override the "look". proc HMtag_/select {win param text} { global HM$win upvar #0 HM$win var upvar #0 $var(form_id) form set frame $form(select_frame) set size $form(select_size) set items [$frame.list size] # set the defaults and reset button append form(reset) ";$frame.list selection clear 0 $items" if {[info exists form(select_default)]} { foreach i $form(select_default) { $frame.list selection set $i append form(reset) ";$frame.list selection set $i" } } else { $frame.list selection set 0 append form(reset) ";$frame.list selection set 0" } # set up the submit button. This is the general case. For single # selections we could be smarter for {set i 0} {$i < $size} {incr i} { set value [format {[expr {[%s selection includes %s] ? {%s} : {}}]} \ $frame.list $i [lindex $form(select_values) $i]] lappend form(submit) [list $form(select_name) $value] } # show the listbox - no scroll bar if {$size > 1 && $items <= $size} { $frame.list configure -height $items pack $frame.list # Listbox with scrollbar } elseif {$size > 1} { scrollbar $frame.scroll -command "$frame.list yview" \ -orient v -takefocus 0 $frame.list configure -height $size \ -yscrollcommand "$frame.scroll set" pack $frame.list $frame.scroll -side right -fill y # This is a joke! } else { scrollbar $frame.scroll -command "$frame.list yview" \ -orient h -takefocus 0 $frame.list configure -height 1 \ -yscrollcommand "$frame.scroll set" pack $frame.list $frame.scroll -side top -fill x } # cleanup foreach i [array names form select_*] { unset form($i) } } # do a text area (multi-line text) # params: COLS, NAME, ROWS (all reqd, but default rows and cols anyway) proc HMtag_textarea {win param text} { global HM$win upvar #0 HM$win var upvar #0 $var(form_id) form upvar $text data set rows 5; HMextract_param $param rows set cols 30; HMextract_param $param cols HMextract_param $param name set item $win.textarea,$var(tags) frame $item text $item.text -width $cols -height $rows -wrap none \ -yscrollcommand "$item.scroll set" -padx 3 -pady 3 scrollbar $item.scroll -command "$item.text yview" -orient v $item.text insert 1.0 $data HMwin_install $win $item pack $item.text $item.scroll -side right -fill y lappend form(submit) [list $name "\[$item.text get 0.0 end]"] append form(reset) ";$item.text delete 1.0 end; \ $item.text insert 1.0 [list $data]" set data "" } # procedure to install windows into the text widget # - win: name of the text widget # - item: name of widget to install proc HMwin_install {win item} { global HM$win upvar #0 HM$win var $win window create $var(S_insert) -window $item -align bottom $win tag add indent$var(level) $item set focus [expr {[winfo class $item] != "Frame"}] $item configure -takefocus $focus bind $item "$win see $item" } ##################################################################### # Assemble and submit the query # each list element in "stuff" is a name/value pair # - The names are the NAME parameters of the various fields # - The values get run through "subst" to extract the values # - We do the user callback with the list of name value pairs proc HMsubmit_button {win form_id param stuff} { global HM$win upvar #0 HM$win var upvar #0 $form_id form set query "" foreach pair $stuff { set value [subst [lindex $pair 1]] if {$value != ""} { set item [lindex $pair 0] lappend query $item $value } } # this is the user callback. HMsubmit_form $win $param $query } # sample user callback for form submission # should be replaced by the application # Sample version generates a string suitable for http proc HMsubmit_form {win param query} { set result "" set sep "" foreach i $query { append result $sep [HMmap_reply $i] if {$sep != "="} {set sep =} {set sep &} } puts $result } # do x-www-urlencoded character mapping # The spec says: "non-alphanumeric characters are replaced by '%HH'" global HMalphanumeric set HMalphanumeric a-zA-Z0-9 ;# definition of alphanumeric character class for {set i 1} {$i <= 256} {incr i} { set c [format %c $i] if {![string match \[$HMalphanumeric\] $c]} { set HMform_map($c) %[format %.2x $i] } } # These are handled specially array set HMform_map { " " + \n %0d%0a } # 1 leave alphanumerics characters alone # 2 Convert every other character to an array lookup # 3 Escape constructs that are "special" to the tcl parser # 4 "subst" the result, doing all the array substitutions proc HMmap_reply {string} { global HMform_map HMalphanumeric regsub -all \[^$HMalphanumeric\] $string {$HMform_map(&)} string regsub -all \n $string {\\n} string regsub -all \t $string {\\t} string regsub -all {[][{})\\]\)} $string {\\&} string return [subst $string] } # convert a x-www-urlencoded string int a a list of name/value pairs # 1 convert a=b&c=d... to {a} {b} {c} {d}... # 2, convert + to " " # 3, convert %xx to char equiv proc HMcgiDecode {data} { set data [split $data "&="] foreach i $data { lappend result [cgiMap $i] } return $result } proc HMcgiMap {data} { regsub -all {\+} $data " " data if {[regexp % $data]} { regsub -all {([][$\\])} $data {\\\1} data regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data {[format %c 0x\1]} data return [subst $data] } else { return $data } } # There is a bug in the tcl library focus routines that prevents focus # from every reaching an un-viewable window. Use our *own* # version of the library routine, until the bug is fixed, make sure we # over-ride the library version, and not the otherway around auto_load tkFocusOK proc tkFocusOK w { set code [catch {$w cget -takefocus} value] if {($code == 0) && ($value != "")} { if {$value == 0} { return 0 } elseif {$value == 1} { return 1 } else { set value [uplevel #0 $value $w] if {$value != ""} { return $value } } } set code [catch {$w cget -state} value] if {($code == 0) && ($value == "disabled")} { return 0 } regexp Key|Focus "[bind $w] [bind [winfo class $w]]" } ############### # end htmllib.tcl section ############### ############### # start htmlbrow.tcl section ############### # -- return path to text window from any widget in HTMLbrowser path proc HB_textwin {w} { global level set path "" set i [string first $level(2) $w] if {-1 != $i} { return "[string range $w 0 [expr $i + [string length $level(1)] - 1]].txt.win" } else { set i [string first $level(3) $w] if {$i == -1} { error "HB_textwin: could not figure out text widget for $w" } return "[string range $w 0 [expr $i - 1]]$level(4)" } } # -- build absolute path from url (relative/absolute/local) proc HB_resolve_url {win url {dummy ""}} { global _url env set win $_url(textwidget) if {$_url($win~~lasturl) != "*"} { set _url($win~~url) [mergeurls $_url($win~~lasturl) $url] } else { set _url($win~~url) $url } return [extracttagkey $_url($win~~url)] } # -- display link url in entry when pointer is over it proc HB_highlight_link {win href} { global _url HB_init $win set win $_url(textwidget) set _url($win~~savedentry) [$_url($win~~entrywidget) get] $_url($win~~entrywidget) delete 0 end $_url($win~~entrywidget) insert end "$href" $_url($win~~entrywidget) configure -fg blue update } # -- restore url in entry when pointer leaves link proc HB_unhighlight_link {win} { global _url HB_init $win set win $_url(textwidget) if {![info exists _url($win~~savedentry)]} { set text "" } else { set text $_url($win~~savedentry) } $_url($win~~entrywidget) delete 0 end $_url($win~~entrywidget) insert end "$text" $_url($win~~entrywidget) configure -fg black update } # -- main load URL procedure proc HB_load_url {win url {tag ""} {force 0}} { global _url env http HB_init $win set win $_url(textwidget) if {$url == "" && $tag == ""} {return} if {$_url($win~~lasturl) != "*"} { set url [mergeurls $_url($win~~lasturl) $url] } # -- get the status label widget if {"$tag" != ""} { $_url($win~~statuslabel) configure -text "fetching $url#$tag" } else { $_url($win~~statuslabel) configure -text "fetching $url" } set _url($win~~stopflag) 0 $_url($win~~stopbut) configure -state normal update # -- for now assume anything that gets here is text or html # -- retrieve the URL to a local variable $win configure -cursor watch # -- put a final sanity check against getting .gif files if {[string last ".gif" $url] != -1} {return} # -- fetch the document if {$_url($win~~lasturl) != $url} {set force 1} set _url($win~~lasturl) $url if {$force} { set _url($win~~rawtext) [fetchURL -url $url] # -- reset url in case fetchURL was redirected set url $http(full) } $_url($win~~statuslabel) configure -text "" update # -- clear the window if {$url != $_url($win~~lasturl) || $force} { HMreset_win $win } # -- check for a stop prior to rendering if {$_url($win~~stopflag)} { $_url($win~~statuslabel) configure -text "Stopped" -fg red update after 1000 "$_url($win~~statuslabel) configure -text {} -fg White; update" $win configure -cursor arrow return } # -- update status label, entry area, and button for rendering time $_url($win~~statuslabel) configure -text "rendering $url" $_url($win~~entrywidget) delete 0 end if {$tag == ""} { $_url($win~~entrywidget) insert end "$url" } else { $_url($win~~entrywidget) insert end "$url#$tag" } $_url($win~~entrywidget) configure -fg black $_url($win~~statuslabel) configure -text "" $_url($win~~gobut) configure -state normal $_url($win~~homebut) configure -state normal if {$_url($win~~histidx) < [expr [llength $_url($win~~history)] - 1]} { $_url($win~~backbut) configure -state normal } else { $_url($win~~backbut) configure -state disabled } if {$_url($win~~histidx) == 0} { $_url($win~~forwardbut) configure -state disabled } else { $_url($win~~forwardbut) configure -state normal } update # -- render only if a new document or forced to if {$force} { # -- loop through the rendering of the rawtext until done # -- find the start tag set start hmstart HMparse_html $_url($win~~rawtext) "HMrender $win" $_url($win~~stopbut) configure -state disabled update } # -- rendering done, jump to any internal link specified if {$tag != ""} { HMgoto $win "$tag" } else { # -- ensure that we're at top of window if no link jump performed tkTextSetCursor $win 1.0 } # -- update history incr _url($win~~histidx) if {$tag != ""} { set _url($win~~history) [join "$url#$tag $_url($win~~history)"] } else { set _url($win~~history) [join "$url $_url($win~~history)"] } incr _url($win~~histlen) $_url($win~~entrywidget) delete 0 end if {$tag == ""} { $_url($win~~entrywidget) insert end "$url" } else { $_url($win~~entrywidget) insert end "$url#$tag" } $_url($win~~entrywidget) configure -fg black update # -- convert cursor back to arrow to show operation is complete $win configure -cursor arrow return } # -- initialize proc HB_init {win} { global _url env set _url(textwidget) $win if {[info exists _url($win~~inited)]} {return} set _url($win~~inited) 1 set _url($win~~history) "" set _url($win~~histidx) -1 set _url($win~~histlen) 0 set _url($win~~lasturl) "*" if {[info exists env(TEMP)]} { set _url($win~~cachedir) "[eval file join [file split $env(TEMP)]]" } elseif {[info exists env(TMP)]} { set _url($win~~cachedir) "[eval file join [file split $env(TMP)]]" } elseif {[file exists "/tmp"]} { set _url($win~~cachedir) "/tmp" } elseif {[file exists "/temp"]} { set _url($win~~cachedir) "/temp" } elseif {[file exists "/usr/tmp"]} { set _url($win~~cachedir) "/usr/tmp" } else { set _url($win~~cachedir) "[pwd]" } set env(TEMP) $_url($win~~cachedir) if {![info exists _url($win~~statuslabel)]} { set _url($win~~statuslabel) ".rouser.main.top.buttons.status" set _url($win~~entrywidget) ".rouser.main.top.ubar.url" set _url($win~~backbut) ".rouser.main.top.buttons.back" set _url($win~~forwardbut) ".rouser.main.top.buttons.forward" set _url($win~~homebut) ".rouser.main.top.buttons.home" set _url($win~~gobut) ".rouser.main.top.buttons.go" set _url($win~~stopbut) ".rouser.main.top.buttons.stop" } # -- initialize GUI elements $_url($win~~statuslabel) configure -text "" $_url($win~~entrywidget) delete 0 end $_url($win~~entrywidget) configure -fg black $_url($win~~backbut) configure -state disabled $_url($win~~forwardbut) configure -state disabled $_url($win~~gobut) configure -state disabled $_url($win~~stopbut) configure -state disabled # -- setup entry widget bindings bind $_url($win~~entrywidget) { global _url set win $_url(textwidget) HB_init $win set _url($win~~histidx) -1 set _url($win~~lasturl) "*" set urllist [HB_resolve_url $win [$_url($win~~entrywidget) get]] set turl "[lindex $urllist 0][lindex $urllist 2]" HB_load_url $win $turl [lindex $urllist 1] } bind $_url($win~~entrywidget) {tkEntryBackspace %W} bind $_url($win~~entrywidget) { if {[%W selection present]} { %W delete sel.first sel.last } else { %W delete insert } } HMinit_win $win } #---------- proc HB_go_form {win} { global _url env set win $_url(textwidget) HB_init $win catch "destroy .history" if {[llength $_url($win~~history)] == 0} {return} toplevel .history wm title .history {top0} wm geometry .history 400x400+[winfo pointerx $win]+[winfo pointery $win] wm minsize .history 1 1 set Name .history.f3 frame $Name -background lightgray -borderwidth 2 -height 50 -highlightbackground lightgray -relief raised -width 50 place $Name -x 0 -relx 0 -y -1 -rely 0 -width 392 -relwidth 0 -height 360 -relheight 0 -anchor nw set Name .history.f3.f17 frame $Name -background lightgray -height 50 -highlightbackground lightgray -width 50 pack $Name -anchor center -expand 1 -fill both -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top set Name .history.f3.f17.lb18 listbox $Name -background gray92 -foreground black -highlightbackground lightgray -selectbackground lightblue -selectforeground black -xscrollcommand ".history.f3.sb20 set" -yscrollcommand ".history.f3.f17.sb13 set" pack $Name -anchor center -expand 1 -fill both -ipadx 0 -ipady 0 -padx 5 -pady 5 -side left set Name .history.f3.f17.sb13 scrollbar $Name -activebackground gray92 -background lightgray -command ".history.f3.f17.lb18 yview" -highlightbackground lightgray -troughcolor gray92 pack $Name -anchor center -expand 0 -fill y -ipadx 0 -ipady 0 -padx 5 -pady 5 -side right set Name .history.f3.f19 frame $Name -background lightgray -height 10 -highlightbackground lightgray -width 15 pack $Name -anchor se -expand 0 -fill none -ipadx 0 -ipady 0 -padx 5 -pady 5 -side right set Name .history.f3.sb20 scrollbar $Name -activebackground gray92 -background lightgray -command ".history.f3.f17.lb18 xview" -highlightbackground lightgray -orient horizontal -troughcolor gray92 pack $Name -anchor center -expand 0 -fill both -ipadx 0 -ipady 0 -padx 5 -pady 5 -side bottom set Name .history.b2 button $Name -text Close -command {catch {wm withdraw .history}} place $Name -x 0 -relx 0.3778 -y 0 -rely 0.9111 -width {} -relwidth {} -height {} -relheight {} -anchor nw update bind .history.f3.f17.lb18 "HB_hist_select $win" foreach h $_url($win~~history) { .history.f3.f17.lb18 insert end $h } update } #-------- proc HB_hist_select {win} { global _url HB_Stop $win set win $_url(textwidget) catch "lindex [.history.f3.f17.lb18 curselection] 0" _url($win~~histidx) catch "wm withdraw .history" catch "HB_load_history $win" } #---------- proc HB_home {win} { global _url HB_Stop $win set win $_url(textwidget) HB_init $win set _url($win~~histidx) [expr [llength $_url($win~~history)] - 1] $_url($win~~backbut) configure -state disabled update HB_load_history $win } #---------- proc HB_back {win} { global _url HB_Stop $win set win $_url(textwidget) HB_init $win set last [expr [llength $_url($win~~history)] - 1] if {$_url($win~~histidx) >= $last} { $_url($win~~backbut) configure -state disabled update return } incr _url($win~~histidx) HB_load_history $win } #---------- proc HB_forward {win} { global _url HB_Stop $win set win $_url(textwidget) HB_init $win if {$_url($win~~histidx) <= 0} { $_url($win~~forwardbut) configure -state disabled update return } incr _url($win~~histidx) -1 HB_load_history $win } #---------- proc HB_Stop {win} { global _url set win $_url(textwidget) upvar HM$win var set _url($win~~stopflag) 1 set var(stop) 1 } #---------- proc HB_load_history {win} { global _url set win $_url(textwidget) HB_init $win set last [expr [llength $_url($win~~history)] - 1] if {$last < 0} {return} if {$_url($win~~histidx) < 0} {set _url($win~~histidx) 0} if {$_url($win~~histidx) > $last} {set _url($win~~histidx) $last} set url [lindex $_url($win~~history) $_url($win~~histidx)] set urllist [HB_resolve_url $win $url] $_url($win~~entrywidget) delete 0 end $_url($win~~entrywidget) insert end $url $_url($win~~entrywidget) configure -fg black $_url($win~~gobut) configure -state normal $_url($win~~homebut) configure -state normal if {$_url($win~~histidx) == 0} { $_url($win~~forwardbut) configure -state disabled } else { $_url($win~~forwardbut) configure -state normal } if {$_url($win~~histidx) < [expr [llength $_url($win~~history)] - 1]} { $_url($win~~backbut) configure -state normal } else { $_url($win~~backbut) configure -state disabled } update HB_load_url $win [lindex $urllist 0] [lindex $urllist 1] } #------------------------------------------------------------------- # Replacement procedures for the html_library.tcl 0.3 # -- called when a link within a document is clicked on proc HMlink_callback {win href} { # win: text widget # href: URL to link to global _url if {[string index $href 0] == "#"} { } HB_Stop $win set win $_url(textwidget) # -- one last bit of tinkering for name only relative links set urllist [HB_resolve_url $win $href] set url "[lindex $urllist 0][lindex $urllist 2]" set tag [lindex $urllist 1] # -- load the URL global _url set win $_url(textwidget) $_url($win~~forwardbut) configure -state disabled $_url($win~~backbut) configure -state normal $_url($win~~homebut) configure -state normal $_url($win~~gobut) configure -state normal $_url($win~~statuslabel) configure -text "" $_url($win~~entrywidget) delete 0 end if {$tag == ""} { $_url($win~~entrywidget) insert end $url } else { $_url($win~~entrywidget) insert end "$url#$tag" } $_url($win~~entrywidget) configure -fg black update set _url($win~~histidx) -1 if {[catch "HB_load_url $win $url $tag"]} {return} } # -- set up bindings for / events to a link within a document proc HMlink_setup {win href} { global _url set win $_url(textwidget) # -- escape "%" in url so that bind doesn't interpret it regsub -all {%} $href {%%} href2 $win tag bind L:$href "catch [list "HB_highlight_link $win $href2"]" $win tag bind L:$href "catch [list "HB_unhighlight_link $win"]" } # -- called to let applet know that a form has been reset proc HMreset_form {win form_id} { global _url # -- no-op for now } # -- called when a font is to be loaded proc HMset_font {win tag font} { global _url set win $_url(textwidget) if {![info exists _url($font)]} { set _url($font) 1 $_url($win~~statuslabel) configure -text "downloading font $font" update } if {[catch {$win tag configure $tag -font $font} fonterr]} { $_url($win~~statuslabel) configure -text "$fonterr" -fg red after 1000 "$_url($win~~statuslabel) configure -text {} -fg White; update" } else { $win tag lower $tag mark $_url($win~~statuslabel) configure -text {} update } } # -- obtain an image and load it proc HMset_image {win handle src} { global _url set win $_url(textwidget) $_url($win~~statuslabel) configure -text "fetching image $src" update # -- resolve image relative to current page if {$_url($win~~lasturl) != "*"} { set url [mergeurls $_url($win~~lasturl) $src] } else { set url $src } if {[string first "$url" "[image names]"] != -1} { HMgot_image $handle $url $_url($win~~statuslabel) configure -text "" } else { # -- image is remote, fetch it to a local file set urllist [parseurl $url] if {[lindex $urllist 0] == "http"} { set tempfile [HBuniquefile ".gif"] catch "fetchURL -url $url -outfile $tempfile" } else { # -- local file set tempfile [lindex $urllist 3] # -- check for dos drive specifier and get rid of any leading slash set clist [split $tempfile ""] if {[string index $tempfile 0] == "/" && \ [string index $tempfile 2] == ":" && \ [string index $tempfile 3] == "/"} { set tempfile [string range $tempfile 1 end] } } set type "photo" if {[file extension $url] == ".bmp"} {set type "bitmap"} catch "image create $type $url -file $tempfile" image HMgot_image $handle $image } update } # -- form submission callback proc HMsubmit_form {win form_id param query} { global _url # -- no-op for now } proc HBuniquefile {{ext ".txt"}} { global _url env if {![info exists _url(uniquenum)]} { set _url(uniquenum) [pid] } # incr _url(uniquenum) set f [join "SP $_url(uniquenum) $ext" ""] set f [eval file join [file split $env(TEMP)] $f] return $f } ############### # end htmlbrow.tcl section ############### ###############============================================================= # start rpc.tcl section ############### # # Implements a tclDP compatible portable RPC library atop of the # Tcl ver. >= 7.5 socket command. # #--------------------------------------------------------------------------- # -- validate appropriate execution environment if {[catch "info tclversion" tclversion] || $tclversion < 7.5} { error "rpc.tcl requires Tcl7.5 / Tk4.1 or later releases" } else {unset tclversion} #---------- # -- create a client RPC connection proc dp_MakeRPCClient {host port {cmdCheckProc ""}} { global _rpc if {[catch "socket $host $port" sock]} { error "dp_MakeRPCClient: $sock" } set _rpc($sock~~state) idle set _rpc($sock~~closehooks) "" set _rpc($sock~~checkhook) "" set _rpc($sock~~isClient) 1 set _rpc($sock~~isServer) 0 catch "fconfigure $sock -blocking no -buffering full" set ipaddr [dp_RPC $sock set _rpc([dp_RPC $sock rpcFile]~~clientip)] set loginproc [dp_RPC $sock set _rpc(listen$port~~loginProc)] if {[catch {dp_RPC $sock $loginproc $ipaddr} result]} { return -code error $result } return $sock } #---------- # -- create an RPC server and make it available for client connections proc dp_MakeRPCServer {{port 0} {loginProc "dp_CheckHost"} {checkcmd ""} {retfile 0} {exitcmd ""}} { global _rpc if {$port == ""} {set port 0} if {$retfile == ""} {set retfile 0} if {[catch "socket -server [list "_myrpc_accept $port"] $port" sock]} { error "dp_MakeRPCServer: $sock" } if {$checkcmd == "none"} {set checkcmd ""} set _rpc($sock~~port) $port set _rpc($sock~~closehooks) "" set _rpc(listen$port~~checkhook) $checkcmd set _rpc(listen$port~~loginProc) $loginProc if {"$exitcmd" != ""} {dp_atclose $sock append $exitcmd} if {$port == 0} { set port [lindex [fconfigure $sock -sockname] 2] dp_atclose_really_close $sock _myrpc_removesock $sock foreach n [array names _rpc listen0~~*] {unset _rpc($n)} return [dp_MakeRPCServer $port $loginProc $checkcmd $retfile $exitcmd] } if {$retfile != 0} { return "$port $sock" } return $port } #---------- # -- send an asynchronous RPC Tcl command (don't wait for result) proc dp_RDO {sock args} { global _rpc set args "\{$args\}" set len [string length "$args"] if {$_rpc($sock~~checkhook) != ""} { if {[catch {eval $_rpc($sock~~checkhook) $args} result]} { return -code error $result } } if {[catch "eof $sock" eofflag] || $eofflag} { catch "fileevent $sock readable {}" catch "close $sock" error "dp_RDO: socket $sock is not open (#1)" } if {[catch {puts -nonewline $sock [format "RPC%08d" $len]}]} { catch "fileevent $sock readable {}" catch "close $sock" error "dp_RDO: error - could not write header" } if {[catch "flush $sock"]} { catch "fileevent $sock readable {}" catch "close $sock" error "dp_RDO: error - could not write header" } if {[catch "eof $sock" eofflag] || $eofflag} { catch "fileevent $sock readable {}" catch "close $sock" error "dp_RDO: socket $sock is not open (#2)" } set _rpc($sock~~done) 0 set _rpc($sock~~bytesleft) $len set _rpc($sock~~towrite) 4096 if {$_rpc($sock~~bytesleft) < 4096} { set _rpc($sock~~towrite) $_rpc($sock~~bytesleft) } set _rpc($sock~~buffer) "$args" set _rpc($sock~~needhandshake) 1 fconfigure $sock -blocking no -buffering full catch "fileevent $sock readable [list "_myrpc_writecmd $sock"]" # -- wait until command has been received by server vwait _rpc($sock~~done) fileevent $sock readable {} set _rpc($sock~~buffer) "" set _rpc($sock~~done) 0 set _rpc($sock~~state) "header" set _rpc($sock~~code) 0 set _rpc($sock~~toread) 80 set _rpc($sock~~bytesleft) 80 fconfigure $sock -blocking no -buffering full catch "fileevent $sock readable [list "_myrpc_readresult $sock"]" # -- wait until the result has been received from server vwait _rpc($sock~~done) fileevent $sock readable {} #fconfigure $sock -blocking yes return "" } #---------- # -- send a Tcl command to remote server, retrieve result of remote execution proc dp_RPC {sock args} { global _rpc set args "\{$args\}" set len [string length "$args"] if {$_rpc($sock~~checkhook) != ""} { if {[catch {eval $_rpc($sock~~checkhook) $args} result]} { return -code error $result } } if {[catch "eof $sock" eofflag] || $eofflag} { catch "fileevent $sock readable {}" catch "close $sock" error "dp_RPC: socket $sock is not open (#1)" } if {[catch {puts -nonewline $sock [format "RPC%08d" $len]}]} { catch "fileevent $sock readable {}" catch "close $sock" error "dp_RPC: error - could not write header" } if {[catch "flush $sock"]} { catch "fileevent $sock readable {}" catch "close $sock" error "dp_RPC: error - could not write header" } if {[catch "eof $sock" eofflag] || $eofflag} { catch "fileevent $sock readable {}" catch "close $sock" error "dp_RPC: socket $sock is not open (#2)" } set _rpc($sock~~done) 0 set _rpc($sock~~bytesleft) $len set _rpc($sock~~towrite) 4096 if {$_rpc($sock~~bytesleft) < 4096} { set _rpc($sock~~towrite) $_rpc($sock~~bytesleft) } set _rpc($sock~~buffer) "$args" set _rpc($sock~~needhandshake) 1 fconfigure $sock -blocking no -buffering full catch "fileevent $sock readable [list "_myrpc_writecmd $sock"]" # -- wait until command has been received by server vwait _rpc($sock~~done) fileevent $sock readable {} set _rpc($sock~~buffer) "" set _rpc($sock~~done) 0 set _rpc($sock~~state) "header" set _rpc($sock~~code) 0 set _rpc($sock~~toread) 80 set _rpc($sock~~bytesleft) 80 fconfigure $sock -blocking no -buffering full catch "fileevent $sock readable [list "_myrpc_readresult $sock"]" # -- wait until the result has been received from server vwait _rpc($sock~~done) fileevent $sock readable {} #fconfigure $sock -blocking yes # -- handle placeholder for an empty return if {[string length "$_rpc($sock~~buffer)"] == 1 && $_rpc($sock~~buffer) == "\377"} { set _rpc($sock~~buffer) "" } if {$_rpc($sock~~code)} { return -code error $_rpc($sock~~buffer) } else { return $_rpc($sock~~buffer) } } #---------- # -- cleanly close an RPC_connection on both sides from the client proc dp_CloseRPC {sock} { catch "close $sock" } #---------- # -- client cancels pending RPC operations at server end proc dp_Cancel {sock} { set _rpc($sock~~cancelflag) 1 } #---------- # -- set a command to check incoming Tcl command requests of the server proc dp_SetCheckCmd {sock args} { global _rpc if {[catch "eof $sock" eofflag] || $eofflag} { catch "close $sock" error "dp_SetCheckCmd: socket $sock is not open" } set _rpc($sock~~checkhook) $args } #---------- # -- server function to maintain access control list proc dp_Host {host} { global _rpc # -- validate host argument as being well formed IP address set opcode [string index $host 0] if {$opcode != "+" && $opcode != "-"} { error "dp_Host usage: dp_Host \[+\|-\]ipaddress" } if {[string length $host] == 1} {append host "*.*.*.*"} set iplist [string range $host 1 [expr [string length $host] - 1]] set iplist [split $iplist "."] if {[llength $iplist] != 4} { # -- assume non-ip hostname given...can't handle it so return return "" } foreach ipitem $iplist { if {$ipitem != "*"} { if {[catch "expr $ipitem * 1"] || $ipitem > 255} { # -- assume non-ip hostname given,..can't handle so return return "" } } } # -- create the acl list, enable universal access, add modifier if {![info exists _rpc(acl)]} { lappend _rpc(acl) [list + * * * *] } lappend _rpc(acl) "$opcode $iplist" return "" } #---------- # -- validate this connection is authorized proc dp_CheckHost {ipaddr} { global _rpc if {[info exists _rpc(acl)] && [llength $_rpc(acl)] > 1} { set cip [split $ipaddr "."] set allowed 1 foreach ip $_rpc(acl) { set opcode [lindex $ip 0] set ip [lrange $ip 1 4] set j 0 for {set i 0} {$i<4} {incr i} { if {[lindex $ip $i] == "*" || \ [lindex $ip $i] == [lindex $cip $i]} { incr j } } if {$j == 4} { if {$opcode == "-"} { set allowed 0 } else { set allowed 1 } } } if {!$allowed} { # -- find the socket for this IP address set sock "" foreach name [array names _rpc *~~clientip] { if {$ipaddr == $_rpc($name)} { set sock [lindex [split $name ":"] 0] break } } after 2000 "close $sock" return -code error "dp_CheckHost: connection to server refused - host not authorized" } } return "" } #---------- # -- define commands to be executed just prior to really exiting proc dp_atexit {option args} { global _rpc if {![info exists _rpc(atexit)]} { # -- create exit callbacks, replace exit command to invoke them rename exit dp_atexit_really_exit set _rpc(atexit) "" uplevel #0 {proc exit {{code 0}} { global _rpc while {1} { if {[catch "set _rpc(atexit)" _rpc(atexit)]} {break} if {[llength $_rpc(atexit)] <= 0} {break} set callback [lindex $_rpc(atexit) 0] set _rpc(atexit) [lrange $_rpc(atexit) 1 end] catch {uplevel #0 "$callback"} } catch "unset _rpc(atexit)" catch "dp_atexit_really_exit $code" } } } switch -exact -- $option { set {set _rpc(atexit) "$args"} appendUnique {lappend _rpc(atexit) "$args"} append {lappend _rpc(atexit) "$args"} prepend {set _rpc(atexit) "[list $args] $_rpc(atexit)"} insert {set _rpc(atexit) "[list $args] $_rpc(atexit)"} delete {} clear {set _rpc(atexit) ""} list {return $_rpc(atexit)} default {error "dp_atexit: unrecognized option \[$option\]"} } return $_rpc(atexit) } #---------- # -- register callbacks to RPC channel to execute just before channel closes proc dp_atclose {sock option args} { global _rpc if {![info exists _rpc($sock~~isClient)]} {return} if {[catch "eof $sock" eofflag] || $eofflag} { catch "fileevent $sock readable {}" catch "close $sock" error "dp_atclose: socket $sock is not open" } switch -exact -- $option { set {set _rpc($sock~~closehooks) "$args"} append {lappend _rpc($sock~~closehooks) "$args"} appendUnique {lappend _rpc($sock~~closehooks) "$args"} prepend {set _rpc($sock~~closehooks) "[list $args] $_rpc($sock~~closehooks)"} insert {set _rpc($sock~~closehooks) "[list $args] $_rpc($sock~~closehooks)"} delete {} clear {set _rpc($sock~~closehooks) ""} list {return $_rpc($sock~~closehooks)} default {error "dp_atclose: unrecognized option \[$option\]"} } return $_rpc($sock~~closehooks) } # -- replacement close function to ensure RPC close callbacks are run if {[info commands dp_atclose_really_close] == ""} { rename close dp_atclose_really_close proc close {sock} { global _rpc if {"" == [array names _rpc $sock~~*]} { catch "dp_atclose_really_close $sock" return "" } foreach i $_rpc($sock~~closehooks) { catch {uplevel #0 $i} } if {$_rpc($sock~~isClient)} { set rsock [dp_RPC $sock rpcFile] catch "dp_RDO $sock after 2000 [list "close $rsock"]" } catch "fileevent $sock readable {}" _myrpc_removesock $sock catch "dp_atclose_really_close $sock" return "" } } #---------- # -- return RPC channel identifier proc rpcFile {} { global myrpc_channel if {[info exists myrpc_channel]} { return $myrpc_channel } else { return "" } } #---------- # -- INTERNAL: Server accepts a client connection proc _myrpc_accept {listener sock addr port} { global _rpc set _rpc($sock~~state) idle set _rpc($sock~~closehooks) "" set _rpc($sock~~checkhook) $_rpc(listen$listener~~checkhook) set _rpc($sock~~listener) $listener set _rpc($sock~~clientip) $addr set _rpc($sock~~ipport) $port set _rpc($sock~~isClient) 0 set _rpc($sock~~isServer) 1 if {[eof $sock]} { catch "fileevent $sock readable {}" catch "close $sock" error "dp_MakeRPCServer: socket $sock is not open" } #catch "fconfigure $sock -blocking no" catch "fileevent $sock readable [list "_myrpc_readable $sock"]" } #---------- # -- INTERNAL: Client or Server interupt processing for new data on the # RPC channel proc _myrpc_readable {sock} { global _rpc if {[catch "eof $sock" eofflag] || $eofflag} { catch "fileevent $sock readable {}" catch "close $sock" return } switch $_rpc($sock~~state) { "idle" { set _rpc($sock~~state) readhdr set _rpc($sock~~buffer) "" set _rpc($sock~~toread) 11 _myrpc_readhdr $sock } "readhdr" { _myrpc_readhdr $sock } "readmsg" { _myrpc_readmsg $sock } "writemsg" { _myrpc_writemsg $sock } } } #---------- # -- INTERNAL: read metadata component of message received over RPC channel proc _myrpc_readhdr {sock} { global _rpc if {[catch "eof $sock" eofflag] || $eofflag} { catch "fileevent $sock readable {}" catch "close $sock" puts stderr "_myrpc_readhdr: eof 1 hit" return } if {[catch "read $sock $_rpc($sock~~toread)" result]} { catch "fileevent $sock readable {}" catch "close $sock" puts stderr "_myrpc_readhdr: error during read" return } if {$result == ""} { # close $sock puts stderr "_myrpc_readhdr: empty non-eof read" return } append _rpc($sock~~buffer) $result incr _rpc($sock~~toread) [expr -[string length $result]] if {$_rpc($sock~~toread)==0} { set prefix [string range $_rpc($sock~~buffer) 0 2] if {$prefix == "RDO" || $prefix == "RPC"} { set _rpc($sock~~state) readmsg set _rpc($sock~~type) "RPC" scan [string range $_rpc($sock~~buffer) 3 end] "%d" len set _rpc($sock~~toread) $len if {$len > 4096} {set _rpc($sock~~toread) 4096} set _rpc($sock~~bytesleft) $len set _rpc($sock~~buffer) "" if {$prefix == "RDO"} { set _rpc($sock~~type) "RDO" } else { set _rpc($sock~~type) "RPC" } catch {puts -nonewline $sock "1"} catch {flush $sock} } else { set _rpc($sock~~state) idle } } if {[catch "eof $sock" eofflag] || $eofflag} { catch "fileevent $sock readable {}" catch "close $sock" puts stderr "_myrpc_readhdr: eof 2 hit" return } } #---------- # -- INTERNAL: read/check/execute Tcl command/result component of message # received over RPC channel proc _myrpc_readmsg {sock} { global _rpc global myrpc_channel if {[catch "read $sock $_rpc($sock~~toread)" result]} { catch "fileevent $sock readable {}" catch "close $sock" puts stderr "_myrpc_readmsg: error during read" return } if {$result == ""} { # close $sock puts stderr "_myrpc_readmsg: empty read" return } append _rpc($sock~~buffer) $result set len [expr -[string length "$result"]] incr _rpc($sock~~toread) $len incr _rpc($sock~~bytesleft) $len if {$_rpc($sock~~toread)<=0} { if {$_rpc($sock~~bytesleft) > 0} { # -- set up for next buffer, send handshake for buffer if {$_rpc($sock~~bytesleft) > 4096} { set _rpc($sock~~toread) 4096 } else { set _rpc($sock~~toread) $_rpc($sock~~bytesleft) } catch {puts -nonewline $sock "1"} catch {flush $sock} } else { # -- entire command received, process it set myrpc_channel $sock set _rpc($sock~~state) idle set cmd [lindex "$_rpc($sock~~buffer)" 0] # -- if no checking proc or checking proc does not error out, eval # -- the command set status 1 set _rpc($sock~~outdone) 0 if {($_rpc($sock~~checkhook)=="") || ([catch "$_rpc($sock~~checkhook) $sock $cmd" cmdoutput] == 0)} { if {[catch "uplevel #0 $cmd" _rpc($sock~~outbuf)]} { set status 1 } else { set status 0 } set _rpc($sock~~outlen) [string length "$_rpc($sock~~outbuf)"] } else { # -- unauthorized command given set _rpc($sock~~outbuf) "RPC error: server command is not available \[$cmd\]" set _rpc($sock~~outlen) [string length "$_rpc($sock~~outbuf)"] set status 1 } if {$_rpc($sock~~type) == "RDO"} { set _rpc($sock~~outbuf) "" set _rpc($sock~~outlen) 0 set status 0 } if {$_rpc($sock~~outlen) == 0} { # -- for empty returns, return character 255 alone set _rpc($sock~~outbuf) \377 set _rpc($sock~~outlen) 1 } set hdr [format "%80s" "$status $_rpc($sock~~outlen)"] if {[catch "eof $sock" eofflag] || $eofflag} { catch "fileevent $sock readable {}" catch "close $sock" puts stderr "_myrpc_readmsg: eof 1 hit" } if {[catch "puts -nonewline $sock [list "$hdr"]"]} { catch "fileevent $sock readable {}" catch "close $sock" puts stderr "_myrpc_readmsg: write error" } if {[catch "flush $sock"]} { catch "fileevent $sock readable {}" catch "close $sock" puts stderr "_myrpc_readmsg: flush error" } if {[catch "eof $sock" eofflag] || $eofflag} { catch "fileevent $sock readable {}" catch "close $sock" puts stderr "_myrpc_readmsg: eof 1 hit" } set _rpc($sock~~needhandshake) 1 set _rpc($sock~~state) "writemsg" } } } #---------- # -- write result of command back to client 4K at a time, waiting for handshake proc _myrpc_writemsg {sock} { global _rpc if {$_rpc($sock~~needhandshake)} { set packet "" catch "read $sock 1" packet if {[string length "$packet"] == 0} {return} # -- test for cancel here... set _rpc($sock~~needhandshake) 0 } if {$_rpc($sock~~outlen) > 4096} { set len 4096 } else { set len $_rpc($sock~~outlen) } set packet "[string range $_rpc($sock~~outbuf) 0 [expr $len - 1]]" set _rpc($sock~~outbuf) "[string range $_rpc($sock~~outbuf) $len [expr $_rpc($sock~~outlen) - 1]]" incr _rpc($sock~~outlen) [expr -[set len]] if {[catch "eof $sock" eofflag] || $eofflag} { catch "fileevent $sock readable {}" catch "close $sock" puts stderr "_myrpc_writeresult: eof 1 hit" return } if {[catch "puts -nonewline $sock [list "$packet"]"]} { catch "fileevent $sock readable {}" catch "close $sock" puts stderr "_myrpc_writeresult: error during write" return } if {[catch "flush $sock"]} { catch "fileevent $sock readable {}" catch "close $sock" puts stderr "_myrpc_writeresult: error during flush" return } if {[catch "eof $sock" eofflag] || $eofflag} { catch "fileevent $sock readable {}" catch "close $sock" puts stderr "_myrpc_writeresult: eof 2 hit" return } update idletasks if {$_rpc($sock~~outlen) <= 0} { catch {unset myrpc_channel} set _rpc($sock~~state) idle set _rpc($sock~~done) 1 } else { set _rpc($sock~~needhandshake) 1 } } #---------- # -- write remote command to server 4K at a time, waiting for handshake proc _myrpc_writecmd {sock} { global _rpc if {$_rpc($sock~~needhandshake)} { set packet "" catch "read $sock 1" packet if {[string length "$packet"] == 0} {return} # -- test for cancel here... set _rpc($sock~~needhandshake) 0 } if {$_rpc($sock~~bytesleft) > 4096} { set len 4096 } else { set len $_rpc($sock~~bytesleft) } set packet "[string range $_rpc($sock~~buffer) 0 [expr $len - 1]]" set _rpc($sock~~buffer) "[string range $_rpc($sock~~buffer) $len end]" incr _rpc($sock~~bytesleft) [expr -[set len]] if {[catch "eof $sock" eofflag] || $eofflag} { catch "fileevent $sock readable {}" catch "close $sock" puts stderr "_myrpc_writecmd: eof 1 hit" return } if {[catch "puts -nonewline $sock [list "$packet"]"]} { catch "fileevent $sock readable {}" catch "close $sock" puts stderr "_myrpc_writecmd: error during write" return } if {[catch "flush $sock"]} { catch "fileevent $sock readable {}" catch "close $sock" puts stderr "_myrpc_writecmd: error during flush" return } if {[catch "eof $sock" eofflag] || $eofflag} { catch "fileevent $sock readable {}" catch "close $sock" puts stderr "_myrpc_writecmd: eof 2 hit" return } update idletasks if {$_rpc($sock~~bytesleft) <= 0} { set _rpc($sock~~state) idle set _rpc($sock~~done) 1 } else { set _rpc($sock~~needhandshake) 1 } } #------------ # -- accumulate results from an RPC operation proc _myrpc_readresult {sock} { global _rpc set packet "" if {$_rpc($sock~~state) == "header"} { catch "read $sock $_rpc($sock~~toread)" packet append _rpc($sock~~buffer) "$packet" incr _rpc($sock~~toread) [expr -[string length "$packet"]] if {$_rpc($sock~~toread) <= 0} { set _rpc($sock~~state) "body" set _rpc($sock~~code) [lindex $_rpc($sock~~buffer) 0] set _rpc($sock~~bytesleft) [lindex $_rpc($sock~~buffer) 1] if {$_rpc($sock~~bytesleft) > 4096} { set _rpc($sock~~toread) 4096 } else { set _rpc($sock~~toread) $_rpc($sock~~bytesleft) } set _rpc($sock~~buffer) "" catch {puts -nonewline $sock "1"} catch {flush $sock} } } else { catch "read $sock $_rpc($sock~~toread)" packet append _rpc($sock~~buffer) "$packet" incr _rpc($sock~~toread) [expr -[string length "$packet"]] incr _rpc($sock~~bytesleft) [expr -[string length "$packet"]] if {$_rpc($sock~~toread) <= 0} { if {$_rpc($sock~~bytesleft) > 0} { catch {puts -nonewline $sock "1"} catch {flush $sock} set _rpc($sock~~toread) $_rpc($sock~~bytesleft) if {$_rpc($sock~~toread) > 4096} {set _rpc($sock~~toread) 4096} } else { set _rpc($sock~~done) 1 } } } } #---------- # -- get rid of a socket's entry proc _myrpc_removesock {sock} { global _rpc foreach item [array names _rpc "$sock~~*"] { catch "unset _rpc($item)" } } #---------- # -- report background errors on the server if {[info procs bgerror] == ""} { proc bgerror {args} { global errorInfo errorCode set e "Background error: $args\n" append e "\t$errorInfo\n" append e "errorCode = \[$errorCode\]" puts stderr $e return -code error $e } } ############### # end rpc.tcl section ############### ###############========================================================== # start fusion.tcl section ############### # # Copyright (c) 1996 Eolas Technologies Incorporated # Copyright (c) 1995,1996 Steven B. Wahl # #======================================================================== if {[info tclversion] < 7.5} { error "WebFusion v1.2 requires Tcl 7.5, at a minimum" } #catch "auto_load file" #if {[info procs file] == "" || [info commands Tcl_file] == ""} { # error "WebFusion v1.2 requires that the fileutil.tcl functions exist in tclIndex - installation error" #} #---------------- # dbCreate -- create, define, and open a new table for a database proc dbCreate {path var tablename fieldnames args} { global $var # -- basic sanity checking stuff if {![file isdirectory $path]} { error "dbCreate: database directory \"$path\" does not exist." } if {![file writable $path]} { error "dbCreate: database directory \"$path\" is not writeable by you." } set tablename [string range $tablename 0 7] if {[file exists $path/$tablename.idx]} { error "dbCreate: \"$path/$tablename\" already exists...canceled." } set dummylen 25 set dummyname "DUMMY" foreach option [dbiOptions $args] { switch -glob -- [string tolower [lindex $option 0]] { -pad { set dummylen [lindex $option 1] set dummyname "DUMMY[format "%03d" $dummylen]" } } } # -- seed the index file and the table file set fd [open $path/$tablename.idx w] fconfigure $fd -translation lf puts $fd "00000000 0" close $fd set fldnames [concat seqno $fieldnames $dummyname] set fd [open $path/$tablename.tbl w] fconfigure $fd -translation lf puts $fd "$fldnames" close $fd # -- if the database variable is that of a real open database, # -- close it and use the dbOpen to initialize everything nicely if {[info exists ${var}(lockhitproc)]} { dbClose $var } set ${var}(isopen) 0 dbOpen $path $var return 1 } #---------------- # dbOpen -- open up a database based upon path to database directory # set all interesting information in global variable var proc dbOpen {path var} { global $var # -- puts stderr "dbOpen: path=\[$path\] var=\[$var\]" if {![info exists ${var}(isopen)]} {set ${var}(isopen) 0} if {[set ${var}(isopen)]} {return 0} # -- basic sanity checking stuff if {![file isdirectory $path]} { error "dbOpen: database directory \"$path\" does not exist." } if {![file writable $path]} { error "dbOpen: database directory \"$path\" is not writeable by you." } if {[catch {glob $path/*.tbl} tablepaths]} { error "dbOpen: no database exists at \"$path\". Use dbCreate first." } # -- initialize the database global array, open table and # -- index files set ${var}(path) $path set ${var}(tablenames) {} set ${var}(lockhitproc) {} set ${var}(modnowriteproc) {} set ${var}(tablenames) {} set ${var}(version) 1.2 foreach tablepath $tablepaths { set tablename [file tail [file rootname $tablepath]] lappend ${var}(tablenames) $tablename # -- initialize per table information set ${var}($tablename,indexhandle) {} set ${var}($tablename,tablehandle) {} set ${var}($tablename,fieldnames) {} set ${var}($tablename,tablefilepath) {} set ${var}($tablename,indexfilepath) {} set ${var}($tablename,lastseqno) 0 set ${var}($tablename,nexttblpos) 0 set ${var}($tablename,curseqno) 0 set ${var}($tablename,currowlen) 0 set ${var}($tablename,currowpos) 0 set ${var}($tablename,rowdirty) 0 set ${var}($tablename,tablelock) 0 set ${var}($tablename,eofflag) 1 set ${var}($tablename,getcount) 0 set ${var}($tablename,delcount) 0 set ${var}($tablename,newcount) 0 set ${var}($tablename,modcount) 0 set ${var}($tablename,lckcount) 0 set ${var}($tablename,stscount) 0 set ${var}($tablename,stsmax) 0 set ${var}($tablename,dascount) 0 set ${var}($tablename,dasmax) 0 set ${var}($tablename,nuscount) 0 set ${var}($tablename,nusmax) 0 # -- now start filling in per table values set ${var}($tablename,tablefilepath) "[set ${var}(path)]/$tablename.tbl" set ${var}($tablename,indexfilepath) "[set ${var}(path)]/$tablename.idx" set ${var}($tablename,tablehandle) [open [set ${var}($tablename,tablefilepath)] r+] fconfigure [set ${var}($tablename,tablehandle)] -translation lf set ${var}($tablename,indexhandle) [open [set ${var}($tablename,indexfilepath)] r+] fconfigure [set ${var}($tablename,indexhandle)] -translation lf seek [set ${var}($tablename,tablehandle)] 0 start # -- parse size of dummy field from its name, reset name to "DUMMY" set fieldnames [gets [set ${var}($tablename,tablehandle)]] set lastnameidx [expr [llength $fieldnames] - 1] set dummyname [lindex $fieldnames $lastnameidx] set ${var}($tablename,dummylen) 25 if {$dummyname != "DUMMY"} { scan [string range $dummyname 5 7] "%03d" \ ${var}($tablename,dummylen) set fieldnames \ [lreplace $fieldnames $lastnameidx $lastnameidx "DUMMY"] } set ${var}($tablename,dummystring) \ [format "%[set ${var}($tablename,dummylen)]s" " "] set ${var}($tablename,fieldnames) $fieldnames foreach fieldname [set ${var}($tablename,fieldnames)] { # -- create a template value for the DUMMY fields set ${var}($tablename,$fieldname) {} } set indexfilesize [file size [set ${var}($tablename,indexfilepath)]] set ${var}($tablename,lastseqno) [expr ($indexfilesize / 11) - 1] set ${var}($tablename,nexttblpos) \ [expr [file size [set ${var}($tablename,tablefilepath)]] - 0] dbiRowTraceOff $var $tablename } if {![info exists ${var}(modnowriteproc)]} {set ${var}(modnowriteproc) {}} if {![info exists ${var}(lockhitproc)]} {set ${var}(lockhitproc) {}} set ${var}(isopen) 1 return 1 } #---------------- # dbCleanup -- compress voids and resequence table files proc dbCleanup {var {tpath ""}} { global $var # -- puts stderr "dbCleanup: var=\[$var\] tpath=\[$tpath\]" # -- create a temporary database variable set tvar "${var}_tmp" global $tvar # -- define location of cleanup database (default is original location) set path [set ${var}(path)] if {$tpath == {}} { set ${tvar}(path) $path set tpath $path } else { set ${tvar}(path) $tpath } # -- capture the database table names set tablenames [set ${var}(tablenames)] # -- basic sanity checking stuff if {![file isdirectory [set ${tvar}(path)]]} { error "dbCleanup: database directory \"$tpath\" does not exist." } if {![file writable [set ${tvar}(path)]]} { error "dbCreate: database directory \"$tpath\" is not writeable by you." } # -- create a mirror database definition foreach tablename $tablenames { set tablenamet "${tablename}_T" if {[string length $tablenamet] > 8} { set end [expr [string length $tablenamet] - 1] set start [expr $end - 7] set tablenamet [string range $tablenamet $start $end] } # -- handle lenth of row padding set pad [set ${var}($tablename,dummylen)] # -- build a list of field names for the table (without seqno, DUMMY) set last [expr [llength [set ${var}($tablename,fieldnames)]] - 2] set fieldnames [lrange [set ${var}($tablename,fieldnames)] 1 $last] # -- create the table files if {$pad == 25} { dbCreate $tpath $tvar $tablenamet $fieldnames } else { dbCreate $tpath $tvar $tablenamet $fieldnames -pad $pad } # -- now walk through the original rows of the table # -- and write them to the temporary database (if they exist) set seqno [dbFirstRow $var $tablename] while {![dbEOF $var $tablename]} { dbNewRow $tvar $tablenamet $seqno foreach fieldname $fieldnames { set ${tvar}($tablenamet,$fieldname) \ [set ${var}($tablename,$fieldname)] } dbPutRow $tvar $tablenamet set seqno [dbNextRow $var $tablename] } } dbClose $tvar dbClose $var # -- copy the temporary table files to the current database # -- location and name, then delete the temporary table files foreach tablename $tablenames { set tablenamet "${tablename}_T" if {[string length $tablenamet] > 8} { set end [expr [string length $tablenamet] - 1] set start [expr $end - 7] set tablenamet [string range $tablenamet $start $end] } file copy $tpath/${tablenamet}.idx $path/${tablename}.idx file copy $tpath/${tablenamet}.tbl $path/${tablename}.tbl file delete $tpath/${tablenamet}.idx file delete $tpath/${tablenamet}.tbl } dbOpen $path $var } #---------------- # dbClose -- close a database proc dbClose {var} { global $var # -- puts stderr "dbClose: var=\[$var\]" if {![set ${var}(isopen)]} {return} foreach tablename [set ${var}(tablenames)] { if {[set ${var}($tablename,rowdirty)]} { if {[string length [set ${var}(modnowriteproc)]] > 0} { if {[eval [set ${var}(modnowriteproc)] $var $tablename ""]} { dbPutRow $var $tablename } } else { set ${var}($tablename,rowdirty) 0 } } close [set ${var}($tablename,tablehandle)] close [set ${var}($tablename,indexhandle)] } if {![info exists DEBUGDB]} { unset $var } set ${var}(isopen) 0 } #---------------- # dbGetRow -- fetch a row from a table by its sequence number # -- return "1" if row exists, "0" otherwise proc dbGetRow {var tablename seqno} { global $var # -- puts stderr "dbGetRow: var=\[$var\] tablename=\[$tablename\] seqno=\[$seqno\]" set ${var}($tablename,eofflag) 1 # -- test if we have uncommitted changes to current row if {[set ${var}($tablename,rowdirty)]} { if {[string length [set ${var}(modnowriteproc)]] > 0} { if {[eval [set ${var}(modnowriteproc)] $var $tablename ""]} { dbPutRow $var $tablename } } else { set ${var}($tablename,rowdirty) 0 } } dbiRowTraceOff $var $tablename # -- if row is outside of range, act as if a deleted row if {$seqno <= 0} { error "dbGetRow: bad sequence number \"$seqno\" in table: $tablename" } set indexfilesize [file size [set ${var}($tablename,indexfilepath)]] set ${var}($tablename,lastseqno) [expr ($indexfilesize / 11) - 1] if {$seqno > [set ${var}($tablename,lastseqno)]} { dbNewRow $var $tablename $seqno set ${var}($tablename,eofflag) 0 return 0 } set tbloffset [dbiRowLockOn $var $tablename $seqno] if {$tbloffset != 0} { # -- datafull row, get the data seek [set ${var}($tablename,tablehandle)] $tbloffset start set irow [gets [set ${var}($tablename,tablehandle)]] set ${var}($tablename,currowlen) [string length $irow] set ${var}($tablename,curseqno) $seqno set ${var}($tablename,currowpos) $tbloffset # -- convert newline markers to newlines, remove any trailing newlines regsub -all { } $irow \n trow set row [string trimright $trow] set i 0 foreach fieldname [set ${var}($tablename,fieldnames)] { set db($tablename,$fieldname) [lindex $row $i] incr i } } else { # -- this is a previously deleted row, clear some stuff set ${var}($tablename,currowlen) 0 set ${var}($tablename,currowpos) 0 set ${var}($tablename,seqno) $seqno set ${var}($tablename,curseqno) $seqno # -- clear the contents of the current row fields foreach fieldname [set ${var}($tablename,fieldnames)] { if {!($fieldname == "seqno" || $fieldname == "DUMMY")} { set ${var}($tablename,$fieldname) {} } } set ${var}($tablename,DUMMY) [set ${var}($tablename,dummystring)] } set ${var}($tablename,eofflag) 0 set ${var}($tablename,rowdirty) 0 dbiRowLockOff $var $tablename $seqno $tbloffset dbiRowTraceOn $var $tablename incr ${var}($tablename,getcount) if {$tbloffset != 0} { return 1 } return 0 } #---------------- # dbPutRow -- write current row into database proc dbPutRow {var tablename} { global $var # -- puts stderr "dbPutRow: var=\[$var\] tablename=\[$tablename\]" # -- if no changes to the fields in the row, simply return if {0 >= [set ${var}($tablename,curseqno)] || \ 1 == [set ${var}($tablename,eofflag)]} { puts stderr "dbPutRow: table=$tablename - no current row or eof, no action taken" return 0 } if {0 == [set ${var}($tablename,rowdirty)]} { return 0 } dbiRowTraceOff $var $tablename set ${var}($tablename,eofflag) 0 # -- create output record of all fields appended into a list set row "" set rowlen 0 foreach fieldname [set ${var}($tablename,fieldnames)] { if {$fieldname != "seqno" && $fieldname != "DUMMY"} { set slen [string length [set ${var}($tablename,$fieldname)]] incr slen -1 set field [string trimright [set ${var}($tablename,$fieldname)]] regsub -all \n $field ofld lappend row $ofld incr rowlen [string length $ofld] } else { set slen [string length [set ${var}($tablename,$fieldname)]] incr slen -1 lappend row [set ${var}($tablename,$fieldname)] } } # -- if the row was empty, and is empty now, return if {$rowlen == 0 && [set ${var}($tablename,currowlen)] == 0} { dbiRowTraceOn $var $tablename return 0 } # -- if the row in the database was non-empty, but is now empty, # -- delete the row and return if {$rowlen == 0 && [set ${var}($tablename,currowlen)] > 0} { dbiRowTraceOn $var $tablename dbDelRow $var $tablename return [set ${var}($tablename,curseqno)] } # -- get info on row length, and DUMMY field padding set dummylen [string length [set ${var}($tablename,DUMMY)]] set rowlen [string length $row] set rowdiff [expr $rowlen - [set ${var}($tablename,currowlen)]] # -- get a lock on the row and its offset in the table file set tbloffset [dbiRowLockOn $var $tablename] set newflag 0 if {$tbloffset == 0} { set ${var}($tablename,nexttblpos) \ [file size [set ${var}($tablename,tablefilepath)]] set tbloffset [set ${var}($tablename,nexttblpos)] incr ${var}($tablename,nexttblpos) [expr $rowlen + 1] set newflag 1 } set ${var}($tablename,currowpos) $tbloffset # -- handle the special case that this is a new row or a # -- previously deleted row set tbllock 0 if {$newflag} { # -- get a table lock dbiTableLockOn $var $tablename set tbllock 1 set ${var}($tablename,currowpos) [set ${var}($tablename,nexttblpos)] set ${var}($tablename,currowlen) $rowlen incr ${var}($tablename,nexttblpos) [expr 1 + $rowlen] # -- setup to fall through to actual table write of row set rowdiff 0 } elseif {[expr [set ${var}($tablename,currowpos)] + \ [set ${var}($tablename,currowlen)] + 1] == \ [set ${var}($tablename,nexttblpos)]} { # -- special case that this is the last physical row in # -- table, always expand/contract in place. # -- index entry is ok at this point. # -- if contracting, expand dummy field to size. if {$rowdiff < 0} { set ${var}($tablename,DUMMY) \ [format "%[expr $dummylen + abs($rowdiff)]s" " "] set lastelem [expr [llength $row] - 1] set row [lreplace $row $lastelem $lastelem [set ${var}($tablename,DUMMY)]] set rowlen [string length $row] } elseif {$rowdiff > 0} { # -- get a table lock dbiTableLockOn $var $tablename set tbllock 1 # -- ensure that padding field is maximum size set ${var}($tablename,DUMMY) [set ${var}($tablename,dummystring)] set dummylen [string length [set ${var}($tablename,DUMMY)]] set lastelem [expr [llength $row] - 1] set row [lreplace $row $lastelem $lastelem [set ${var}($tablename,DUMMY)]] set rowlen [string length $row] } # -- set up to fall through to actual table write set rowdiff 0 } if {$rowdiff < 0} { # -- row will fit in place with adjustment to dummy pad area set ${var}($tablename,DUMMY) [format "%[expr $dummylen + abs($rowdiff)]s" " "] set lastelem [expr [llength $row] - 1] set row [lreplace $row $lastelem $lastelem [set ${var}($tablename,DUMMY)]] set rowlen [string length $row] } elseif {$rowdiff > 0} { # -- see if the row will fit in place by reducing DUMMY if {$rowdiff < $dummylen} { set ${var}($tablename,DUMMY) [format "%[expr $dummylen - $rowdiff]s" " "] set lastelem [expr [llength $row] - 1] set row [lreplace $row $lastelem $lastelem [set ${var}($tablename,DUMMY)]] set rowlen [string length $row] } else { # -- not enough space in current table position, move row # -- to end of table file # -- first, clear the current entry in the table file. set blank [format "%[set ${var}($tablename,currowlen)]s" " "] seek [set ${var}($tablename,tablehandle)] [set ${var}($tablename,currowpos)] start puts [set ${var}($tablename,tablehandle)] $blank # -- reexpand DUMMY field, if necessary if {$dummylen != 25} { set ${var}($tablename,DUMMY) [set ${var}($tablename,dummystring)] set lastelem [expr [llength $row] - 1] set row [lreplace $row $lastelem $lastelem [set ${var}($tablename,DUMMY)]] set rowlen [string length $row] } # -- set a lock on the table if {!$tbllock} { dbiTableLockOn $var $tablename set tbllock 1 } # -- now update the index file row offset (row still locked) set ${var}($tablename,nexttblpos) \ [file size [set ${var}($tablename,tablefilepath)]] set ${var}($tablename,currowpos) [set ${var}($tablename,nexttblpos)] # -- now setup to write row to end of table file set ${var}($tablename,currowlen) $rowlen set ${var}($tablename,currowpos) [set ${var}($tablename,nexttblpos)] incr ${var}($tablename,nexttblpos) [expr 1 + $rowlen] } } # -- write the row to the tablespace file seek [set ${var}($tablename,tablehandle)] [set ${var}($tablename,currowpos)] start puts [set ${var}($tablename,tablehandle)] $row flush [set ${var}($tablename,tablehandle)] # -- if the table was locked, free it if {$tbllock} { set ${var}($tablename,nexttblpos) \ [file size [set ${var}($tablename,tablefilepath)]] dbiTableLockOff $var $tablename } set ${var}($tablename,currowlen) $rowlen # -- update the index and free the row lock dbiRowLockOff $var $tablename [set ${var}($tablename,curseqno)] \ [set ${var}($tablename,currowpos)] # -- reset row dirty flag and turn field mod trace back on set ${var}($tablename,rowdirty) 0 dbiRowTraceOn $var $tablename # -- increment the row write counter for session incr ${var}($tablename,modcount) return [set ${var}($tablename,curseqno)] } #---------------- # dbClearRow -- clear the contents of the current row, don't modify database proc dbClearRow {var tablename {seqno ""}} { global $var if {$seqno != ""} { if {0 == [dbGetRow $var $tablename $seqno]} {return} } # -- puts stderr "dbClearRow: var=\[$var\] tablename=\[$tablename\]" # -- test if we have uncommitted changes to current row dbiRowTraceOff $var $tablename if {[set ${var}($tablename,rowdirty)]} { if {[string length [set ${var}(modnowriteproc)]] > 0} { if {[eval [set ${var}(modnowriteproc)] $var $tablename ""]} { dbPutRow $var $tablename } } else { set ${var}($tablename,rowdirty) 0 } } foreach fieldname [set ${var}($tablename,fieldnames)] { set ${var}($tablename,$fieldname) {} } set ${var}($tablename,DUMMY) [set ${var}($tablename,dummystring)] set ${var}($tablename,seqno) [set ${var}($tablename,curseqno)] dbiRowTraceOn $var $tablename } #---------------- # dbNewRow -- create a new row in a table (may specify seqno) # return the seqno of the newly created row proc dbNewRow {var tablename {seqno ""}} { global $var # -- puts stderr "dbNewRow: var=\[$var\] tablename=\[$tablename\]" # -- test if we have uncommitted changes to current row if {[set ${var}($tablename,rowdirty)]} { if {[string length [set ${var}(modnowriteproc)]] > 0} { if {[eval [set ${var}(modnowriteproc)] $var $tablename]} { dbPutRow $var $tablename } } else { set ${var}($tablename,rowdirty) 0 } } set indexfilesize [file size [set ${var}($tablename,indexfilepath)]] set ${var}($tablename,lastseqno) [expr ($indexfilesize / 11) - 1] if {$seqno == ""} { dbiRowTraceOff $var $tablename # -- add a row to the end of the table dbiTableLockOn $var $tablename incr ${var}($tablename,lastseqno) set ${var}($tablename,curseqno) [set ${var}($tablename,lastseqno)] dbClearRow $var $tablename set ${var}($tablename,currowpos) 0 set ${var}($tablename,seqno) [set ${var}($tablename,curseqno)] # -- update the index for the new record via a row unlock dbiRowLockOff $var $tablename [set ${var}($tablename,curseqno)] 0 dbiTableLockOff $var $tablename set ${var}($tablename,rowdirty) 0 dbiRowTraceOn $var $tablename incr ${var}($tablename,newcount) set ${var}($tablename,eofflag) 0 } elseif {$seqno > [set ${var}($tablename,lastseqno)]} { # -- add multiple rows to end of table until desired row created while {[set ${var}($tablename,lastseqno)] < $seqno} { dbNewRow $var $tablename } } else { # -- get the specified row and clear it dbGetRow $var $tablename $seqno dbClearRow $var $tablename } return [set ${var}($tablename,curseqno)] } #---------------- # dbDelRow -- delete current (or specified) row from a table proc dbDelRow {var tablename {seqno ""}} { global $var # -- puts stderr "dbDelRow: var=\[$var\] tablename=\[$tablename\]" if {$seqno != ""} { if {0 == [dbGetRow $var $tablename $seqno]} {return} } set seqno [set ${var}($tablename,curseqno)] set pos [set ${var}($tablename,currowpos)] set ${var}($tablename,eofflag) 0 # -- test if row has already been deleted if {$pos == 0} {return} dbiRowTraceOff $var $tablename set tbloffset [dbiRowLockOn $var $tablename] # -- if there was data in table file, then # -- overwrite the row data with an empty line of equal size if {$tbloffset != 0} { set len [set ${var}($tablename,currowlen)] set blanks [format "%${len}s" " "] seek [set ${var}($tablename,tablehandle)] $pos start puts -nonewline [set ${var}($tablename,tablehandle)] $blanks flush [set ${var}($tablename,tablehandle)] } # -- update the index file for this row to show no row data offset dbiRowLockOff $var $tablename $seqno 0 foreach fieldname [set ${var}($tablename,fieldnames)] { set ${var}($tablename,$fieldname) {} } set ${var}($tablename,DUMMY) [set ${var}($tablename,dummystring)] set ${var}($tablename,seqno) [set ${var}($tablename,curseqno)] set ${var}($tablename,rowdirty) 0 incr ${var}($tablename,delcount) dbiRowTraceOn $var $tablename } #---------------- # dbFirstRow -- position to first row from table # return seqno if valid row found, "0" otherwise proc dbFirstRow {var tablename} { global $var set indexfilesize [file size [set ${var}($tablename,indexfilepath)]] set ${var}($tablename,lastseqno) [expr ($indexfilesize / 11) - 1] set lastseqno [set ${var}($tablename,lastseqno)] set ${var}($tablename,eofflag) 1 if {$lastseqno == 0} {return 0} # -- test if we have uncommitted changes to current row if {[set ${var}($tablename,rowdirty)]} { if {[string length [set ${var}(modnowriteproc)]] > 0} { if {[eval [set ${var}(modnowriteproc)] $var $tablename ""]} { dbPutRow $var $tablename } } else { set ${var}($tablename,rowdirty) 0 } } set seqno 1 while {0 == [dbGetRow $var $tablename $seqno]} { incr seqno if {$seqno > $lastseqno} { set ${var}($tablename,eofflag) 1 return 0 } } set ${var}($tablename,eofflag) 0 return $seqno } #---------------- # dbLastRow -- position to last row in table # return seqno if valid row found, "0" otherwise proc dbLastRow {var tablename} { global $var set indexfilesize [file size [set ${var}($tablename,indexfilepath)]] set ${var}($tablename,lastseqno) [expr ($indexfilesize / 11) - 1] set lastseqno [set ${var}($tablename,lastseqno)] set ${var}($tablename,eofflag) 1 if {$lastseqno == 0} {return 0} # -- test if we have uncommitted changes to current row if {[set ${var}($tablename,rowdirty)]} { if {[string length [set ${var}(modnowriteproc)]] > 0} { if {[eval [set ${var}(modnowriteproc)] $var $tablename ""]} { dbPutRow $var $tablename } } else { set ${var}($tablename,rowdirty) 0 } } set seqno [set ${var}($tablename,lastseqno)] while {0 == [dbGetRow $var $tablename $seqno]} { incr seqno -1 if {$seqno <= 0} { set ${var}($tablename,eofflag) 1 return 0 } } set ${var}($tablename,eofflag) 0 return $seqno } #---------------- # dbNextRow -- position to next row in table # return seqno if valid row found, "0" otherwise proc dbNextRow {var tablename} { global $var set indexfilesize [file size [set ${var}($tablename,indexfilepath)]] set ${var}($tablename,lastseqno) [expr ($indexfilesize / 11) - 1] set lastseqno [set ${var}($tablename,lastseqno)] set ${var}($tablename,eofflag) 1 if {$lastseqno == 0} {return 0} # -- test if we have uncommitted changes to current row if {[set ${var}($tablename,rowdirty)]} { if {[string length [set ${var}(modnowriteproc)]] > 0} { if {[eval [set ${var}(modnowriteproc)] $var $tablename ""]} { dbPutRow $var $tablename } } else { set ${var}($tablename,rowdirty) 0 } } set seqno [expr [set ${var}($tablename,curseqno)] + 1] if {$seqno > $lastseqno} {return 0} while {0 == [dbGetRow $var $tablename $seqno]} { incr seqno if {$seqno > $lastseqno} { set ${var}($tablename,eofflag) 1 return 0 } } set ${var}($tablename,eofflag) 0 return $seqno } #---------------- # dbPrevRow -- position to previous row in table # return "1" if valid row found, "0" otherwise proc dbPrevRow {var tablename} { global $var set indexfilesize [file size [set ${var}($tablename,indexfilepath)]] set ${var}($tablename,lastseqno) [expr ($indexfilesize / 11) - 1] set lastseqno [set ${var}($tablename,lastseqno)] set ${var}($tablename,eofflag) 1 if {$lastseqno == 0} {return 0} # -- test if we have uncommitted changes to current row if {[set ${var}($tablename,rowdirty)]} { if {[string length [set ${var}(modnowriteproc)]] > 0} { if {[eval [set ${var}(modnowriteproc)] $var $tablename ""]} { dbPutRow $var $tablename } } else { set ${var}($tablename,rowdirty) 0 } } set seqno [expr [set ${var}($tablename,curseqno)] - 1] if {$seqno <= 0} {return 0} while {0 == [dbGetRow $var $tablename $seqno]} { incr seqno -1 if {$seqno <= 0} { set ${var}($tablename,eofflag) 1 return 0 } } if {$seqno <= 0} { set ${var}($tablename,eofflag) 1 return 0 } set ${var}($tablename,eofflag) 0 return $seqno } #--------------------- # dbSetProc -- register procedure to call for following conditions: # 1) if the row desired is locked # USE: dbSetProc var lock procname # The "procname" procedure needs to have the argument list: # proc procname var tablename # and return a "0" if the lock is to be freed, or "1" if # the lock is to be retained. # 2) if the current row has been modified and not written # to the database. # USE: dbSetProc var mod procname # The "procname" procedure need to have the argument list: # proc procname var tablename # and return a "1" if the current row should be written # to the database, or a "0" if the new row contents discarded. # proc dbSetProc {var function procname} { global $var switch -glob -- [string tolower $function] { loc* {set ${var}(lockhitproc) $procname} mod* {set ${var}(modnowriteproc) $procname} } } #--------------------- # dbEOF -- return 1 if beyond the limits of a table, 0 otherwise proc dbEOF {var tablename} { # -- puts stderr "dbEOF: var=\[$var\] tablename=\[$tablename\]" global $var return [set ${var}($tablename,eofflag)] } #====================== INTERNAL PROCEDURES =============================== #------------------ # dbiMarkRow -- mark the current row as modified proc dbiMarkRow {var element unused} { global $var # -- puts stderr "dbiMarkRow: var=\[$var\] element=\[$element\] unused=\[$unused\]" set tablename [lindex [split $element ","] 0] set ${var}($tablename,rowdirty) 1 } #------------------ # dbiRowTraceOn -- set a trace on the current row for any modifications proc dbiRowTraceOn {var tablename} { global $var # -- puts stderr "dbiRowTraceOn: var=\[$var\] tablename=\[$tablename\]" foreach fieldname [set ${var}($tablename,fieldnames)] { set t "${var}($tablename,$fieldname)" trace variable $t w dbiMarkRow } } #------------------ # dbiRowTraceOff -- free a trace previously placed on the current row # for any modifications made to it. proc dbiRowTraceOff {var tablename} { global $var # -- puts stderr "dbiRowTraceOff: var=\[$var\] tablename=\[$tablename\]" foreach fieldname [set ${var}($tablename,fieldnames)] { set t "${var}($tablename,$fieldname)" trace vdelete $t w dbiMarkRow } } #---------------------- # dbiRowLockOn -- set an exclusive lock on (current) row proc dbiRowLockOn {var tablename {seqno ""}} { global $var # -- puts stderr "dbiRowLockOn: var=\[$var\] tablename=\[$tablename\] seqno=\[$seqno\]" if {$seqno == ""} { set seqno [set ${var}($tablename,curseqno)] } set ioffset [expr $seqno * 11] set ifd [set ${var}($tablename,indexhandle)] seek $ifd $ioffset start scan [gets $ifd] "%x %s" tbloffset lock while {$lock} { # -- give it one second to free up on its own incr ${var}($tablename,lckcount) sleep 1 seek $ifd $ioffset start scan [gets $ifd] "%x %s" tbloffset lock if {$lock} { # -- still locked, call user's proc or handle default way # -- which is to spin on the lock 5 times, then clear it if {[set ${var}(lockhitproc)] != ""} { set lock [eval [set ${var}(lockhitproc)] $var $tablename] } else { set spin 0 while {$lock && $spin < 5} { sleep 1 seek $ifd $ioffset start scan [gets $ifd] "%x %s" tbloffset lock incr spin if {$lock} { puts stderr "dbiRowLockOn: freeing preexisting persistent row lock in $tablename at row $seqno" set lock 0 } } } } } # -- set the row lock seek $ifd $ioffset start puts $ifd [format "%08x 1" $tbloffset] flush $ifd return $tbloffset } #---------------------- # dbiRowLockOff -- free an exclusive lock on (current) row # can be used to set the data offset position for a row proc dbiRowLockOff {var tablename {seqno ""} {rowpos ""}} { global $var # -- puts stderr "dbiRowLockOff: var=\[$var\] tablename=\[$tablename\] seqno=\[$seqno\] rowpos=\[$rowpos\]" if {$seqno == ""} { set seqno [set ${var}($tablename,curseqno)] } seek [set ${var}($tablename,indexhandle)] [expr $seqno * 11] start if {$rowpos == ""} { set idxrec [gets [set ${var}($tablename,indexhandle)]] scan $idxrec "%x %s" rowpos lock seek [set ${var}($tablename,indexhandle)] [expr $seqno * 11] start } puts [set ${var}($tablename,indexhandle)] [format "%08x 0" $rowpos] flush [set ${var}($tablename,indexhandle)] } #---------------------- # dbiTableLockOn -- obtain a lock on a table to grow it proc dbiTableLockOn {var tablename} { global $var # -- puts stderr "dbiTableLockOn: var=\[$var\] tablename=\[$tablename\]" # -- lock the table by locking seqno 0 set x [dbiRowLockOn $var $tablename 0] set ${var}($tablename,tablelock) 1 # -- recalibrate the table variables set ${var}($tablename,nexttblpos) \ [expr [file size [set ${var}($tablename,tablefilepath)]] - 0] set idxsize [file size [set ${var}($tablename,indexfilepath)]] set ${var}($tablename,lastseqno) [expr ($idxsize / 11) - 1] set ${var}($tablename,nexttblpos) [file size [set ${var}($tablename,tablefilepath)]] } #---------------------- # dbiTableLockOff -- free a lock on a table proc dbiTableLockOff {var tablename} { global $var # -- puts stderr "dbiTableLockOff: var=\[$var\] tablename=\[$tablename\]" dbiRowLockOff $var $tablename 0 set ${var}($tablename,tablelock) 0 } #---------------------- # dbiOptions -- process a list of options to a command proc dbiOptions {list} { # -- take a command option list and parse into sublists set result {} set sublist {} # -- see if the argument list was given as a string rather than list if {[llength $list] == 1} { if {[regexp {\ |\t|\n} $list]} { set list [lindex $list 0] } } foreach item $list { # -- find option name if {[string index $item 0] == "-"} { if {$sublist != ""} { lappend result $sublist set sublist {} } } lappend sublist $item } if {$sublist != ""} { lappend result $sublist } return $result } #------------------ # dbuDateFromTs -- return date string from timestamp value proc dbuDateFromTs {ts} { set modays(norm) "0 31 59 90 120 151 181 212 243 273 304 334 365" set modays(leap) "0 31 60 91 121 152 182 213 244 274 305 335 366" set monthnames "Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec" set year [expr 1970 + ($ts / 31557600)] set yrtype norm if {[expr $year % 4] == 0} {set yrtype leap} set ts [expr $ts % 31557600] set day [expr 1 + ($ts / 86400)] set month "Jan" set mostart 0 set day [expr $day - $mostart] for {set i 0} {$i < 13} {incr i} { if {$day <= [lindex $modays($yrtype) $i]} { set month [lindex $monthnames [expr $i - 1]] set mostart [lindex $modays($yrtype) [expr $i - 1]] set day [expr $day - $mostart] break } } return "$month $day, $year" } #------------------ # dbuDateToTs -- return timestamp value from a date string proc dbuDateToTs {date} { if {[catch {scan [lrange $date 0 2] "%3s %d, %d" mon day yr}]} {return 0} set ts [expr ($yr - 1970) * 31557600] set yrtype "norm" if {[catch {expr "$day + 0"}]} {return 0} if {[catch {expr "$yr + 0"}]} {return 0} if {$day < 1 || $day > 31} {return 0} if {$yr < 1970 || $yr > 2100} {return 0} if {[expr $yr%4] == 0} {set yrtype leap} set modays(norm) "0 31 59 90 120 151 181 212 243 273 304 334" set modays(leap) "0 31 60 91 121 152 182 213 244 274 305 335" set monthnames "Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec" set moidx [lsearch $monthnames $mon] if {$moidx == -1} {return 0} set yrday [expr [lindex $modays($yrtype) $moidx] + $day - 1] set yrday [expr $yrday * 86400] return [expr $ts + $yrday + 3600] } #------------------ # dbuDateToday -- return today's date as a string proc dbuDateToday {} { return [clock format [clock seconds] -format "%h %d, 19%y"] } #---------------- # return a list of seqno from a table who have a field matching glob # search string proc dbuSearchString {var tablename fieldname searchstring} { global $var if {[set ${var}($tablename,lastseqno)] == 0} { incr ${var}($tablename,stscount) return {} } if {[string length $searchstring] == 0} {return {}} set searchstring [string tolower "*${searchstring}*"] set result "" if {-1 == [lsearch [set ${var}($tablename,fieldnames)] $fieldname]} { error "dbuSearchString: field name $fieldname does not \ exist in table $tablename." } set seqno [dbFirstRow $var $tablename] while {![dbEOF $var $tablename]} { set fstring [string tolower [set ${var}($tablename,$fieldname)]] if {[string match $searchstring $fstring]} { lappend result $seqno } set seqno [dbNextRow $var $tablename] } incr ${var}($tablename,stscount) set resultsize [llength $result] if {$resultsize > [set ${var}($tablename,stsmax)]} { set ${var}($tablename,stsmax) $resultsize } return $result } #---------------- # return a list of seqnos from a table who have a date field between # or matching a date in the date range proc dbuSearchDate {var tablename fieldname date1 date2} { global $var if {[set ${var}($tablename,lastseqno)] == 0} { incr ${var}($tablename,dascount) return {} } set ts1 [dbuDateToTs $date1] set ts2 [dbuDateToTs $date2] if {$ts1 == 0 || $ts2 == 0} {return {}} set result {} if {-1 == [lsearch [set ${var}($tablename,fieldnames)] $fieldname]} { error "dbuSearchString: field name $fieldname does not \ exist in table $tablename." } set seqno [dbFirstRow $var $tablename] while {![dbEOF $var $tablename]} { set tts [dbuDateToTs [set ${var}($tablename,$fieldname)]] if {$ts1 <= $tts && $tts <= $ts2} { lappend result $seqno } set seqno [dbNextRow $var $tablename] } incr ${var}($tablename,dascount) set resultsize [llength $result] if {$resultsize > [set ${var}($tablename,dasmax)]} { set ${var}($tablename,dasmax) $resultsize } return $result } #---------------- # return a list of seqnos from a table who have a numeric value # between or matching values in a numeric range proc dbuSearchValue {var tablename fieldname num1 num2} { global $var if {[set ${var}($tablename,lastseqno)] == 0} { incr ${var}($tablename,nuscount) return {} } if {[catch {expr "($num1 + $num2) * 1.0"}]} { puts stderr "dbuSearchValue $num1 or $num2 are not valid numbers." return {} } if {-1 == [lsearch [set ${var}($tablename,fieldnames)] $fieldname]} { error "dbuSearchString: field name $fieldname does not \ exist in table $tablename." } set seqno [dbFirstRow $var $tablename] while {![dbEOF $var $tablename]} { set value [set ${var}($tablename,$fieldname)] if {![catch "expr $value * 1.0"]} { if {$num1 <= $value && $value <= $num2} { lappend result $seqno } } set seqno [dbNextRow $var $tablename] } incr ${var}($tablename,nuscount) set resultsize [llength $result] if {$resultsize > [set ${var}($tablename,nusmax)]} { set ${var}($tablename,nusmax) $resultsize } return $result } #---------- # dbuSort -- return a list of seqnos from a sort on a field proc dbuSort {var tablename fieldname args} { global $var # -- process arguments set ascending "-increasing" set type "-command [list "dbuiStringCompare $var $tablename $fieldname"]" set seqnolist "" if {[llength args] > 0} { set aidx 0 while {$aidx < [llength $args]} { set keyword [string tolower [lindex $args $aidx]] switch -glob -- $keyword { -as* {set ascending "-increasing"} -des* {set ascending "-decreasing"} -nu* {set type "-command [list "dbuiNumericCompare $var $tablename $fieldname"]"} -st* {set type "-command [list "dbuiStringCompare $var $tablename $fieldname"]"} -da* {set type "-command [list "dbuiDateCompare $var $tablename $fieldname"]"} -pr* {incr aidx; set type "-command [list "[lindex $args $aidx] $var $tablename $fieldname"]" } -se* {incr aidx; set seqnolist [lindex $args $aidx]} } incr aidx } } # -- if no input seqno list provided, build one for the table if {$seqnolist == ""} { set seqnolist [dbFirstRow $var $tablename] if {$seqnolist == 0} {return ""} while {![dbEOF $var $tablename]} { set seqno [dbNextRow $var $tablename] if {$seqno != 0} {lappend seqnolist $seqno} } } # -- perform the sort return [eval "lsort $ascending $type [list "$seqnolist"]"] } #---------- # dbuiStringCompare -- [internal] sort two seqnos based on field # string comparision proc dbuiStringCompare {var tablename fieldname seqno1 seqno2} { global $var # -- get the fields associated with the seqnos dbGetRow $var $tablename $seqno1 set field1 [set ${var}($tablename,$fieldname)] dbGetRow $var $tablename $seqno2 set field2 [set ${var}($tablename,$fieldname)] return [string compare $field1 $field2] } #---------- # dbuiNumericCompare -- [internal] sort two seqnos based on field # numeric comparison proc dbuiNumericCompare {var tablename fieldname seqno1 seqno2} { global $var # -- get the fields associated with the seqnos dbGetRow $var $tablename $seqno1 set field1 [set ${var}($tablename,$fieldname)] if {$field1 == ""} {set field1 0.0} dbGetRow $var $tablename $seqno2 set field2 [set ${var}($tablename,$fieldname)] if {$field2 == ""} {set field2 0.0} if {$field1 < $field2} {return -1} if {$field1 > $field2} {return 1} return 0 } #---------- # dbuiDateCompare -- [internal] sort two seqnos based on field # data comparison proc dbuiDateCompare {var tablename fieldname seqno1 seqno2} { global $var # -- get the fields associated with the seqnos dbGetRow $var $tablename $seqno1 set field1 [set ${var}($tablename,$fieldname)] if {$field1 == ""} {set field1 "Jan 1, 1970"} set ts1 [dbuDateToTs $field1] dbGetRow $var $tablename $seqno2 set field2 [set ${var}($tablename,$fieldname)] if {$field2 == ""} {set field2 "Jan 1, 1970"} set ts2 [dbuDateToTs $field2] if {$ts1 < $ts2} {return -1} if {$ts1 > $ts2} {return 1} return 0 } ############### # end fusion.tcl section ############### ###############======================================================== # start tkvsform.tcl section ############### # general-purpose forms facility for Tk4.X # version: 1.0 beta 1 # # Copyright (C) 1996 Eolas Technologies Incorporated. All rights reserved. # Copyright (C) 1995,1996 Steven B. Wahl # See the file LICENSE.TXT for license details. # #===================================================================== # # ---- Public Procedures ---- #=================== form composition procedures ==================== # formBEGIN fvar [title] [pos] [wtoposto] ["MAIN"] # begin composition of a new form # # formGROUP fvar # start a new grouping of lines on the form # # formNEWLINE fvar # start a new line of items on the form # # formCHECK fvar statetag prompt var [elem] ["tkopts"] # create checkbox # # formRADIO fvar statetag prompt var [elem] ["tkopts"] # create a radio button # # formBUTTON fvar statetag prompt cmd [cmdargs] [width] ["tkopts"] # create a button # # formLABEL fvar statetag prompt [var] [elem] [width] ["tkopts"] # create a fixed string label, or prompt plus updateable string # # formMESSAGE fvar statetag var [elem] ["tkopts"] # create a message area # # formENTRY fvar statetag var [elem] [width] [cmd] [cmdargs] ["tkopts"] # create a type-in entry widget # # formPASSWORD fvar statetag var [elem] [width] [cmd] [cmdargs] ["tkopts"] # same as formENTRY, but echo "*" in place of characters # # formTEXT fvar statetag var [elem] [width] [height] ["tkopts"] # create a scrollable text area, associate with a variable # # formLIST fvar statetag invar inelem outvar [outelem] [width] [height] \ # ["tkopts"] # create a scrollable, single-selection list # # formEND fvar ["on" | "off"] [focuseditempath] ["hardfocus"] # completed form definition, display it (or not), set exclusive # focus when displayed # #=================== runtime form management procedures ================= # # formSHOW fvar ["on" | "off"] # display a form or withdraw it from view # # formDIE fvar # destroy a form # # formPATHS fvar [pattern] # return widget paths list for widget paths meeting a glob-style # pattern # # formSTATE fvar statetag ["on" | "off"] # make active or inactive (grayed out, non-selectable) all form # widgets associated with "statetag" name # # formCURSOR fvar ["normal" | "busy" | "alt"] [altcursorname] # make cursor over form normal, hourglass, or some alternative # # formREFRESH fvar # update a form, specifically its LIST and TEXT widgets, if their # data sources have changed # # formTEXTREFRESH fvar # update the contents of all TEXT widgets from their associated # variables for a form # # formTEXTTRACE fvar ["on" | "off"] # turn on/off two-way updating between TEXT widgets and their # associated data source variables # # formLISTCLEAR fvar [listitempath] # clear the contents of a LIST widget # # formLISTUPDATE fvar [listitempath] [var] [elem] # update the contents of a LIST widget or all LIST widgets # # ===================== internal use only procedures ====================== # formiMARK fvar itempath # mark a form widget as having been modified # # formiUPDATEVAR fvar itempath # update the variable associated with a form widget # # formiUPDATETEXT fvar itempath var elem optype # trace a variable associated with text widget and update form # # formiLISTSELBEGIN w y # list selection initializer # # formiLISTSELMOVE w y # list selection motion # # formiLISTSELEND vflag fvar w y ivar ielem ovar oelem # list selection completion, perform update of selection # # formiLISTSELKEYEND vflag fvar w ivar ielem ovar oelem # list selection via completion, perform update of selection # # ----------------- form widget naming conventions ---------------------- # # NOTES: # path naming structure # .$fvar top level form window # .$fvar.g# frame for a group # .$fvar.g#.s# frame for a line of items # .$fvar.g#.s#.if# frame for an item # .$fvar.g#.s#.if#.itemtype# frame for subitem where "itemtype" is: # CHK RAD BUT LAB MSG ENT TXT LST # # example: # .f.g1.s1.if1.BUT1 first item (Button) in first line in first group # .f.g3.s4.if3.ENT3 3rd item (Entry) in 4th linee in 3rd group # #========================================================================= # Procedures: #========================================================================= # formBEGIN -- create a new toplevel form, set its title and position proc formBEGIN {fvar {title ""} {pos "+100+100"} {wtoposto ""} \ {main "NOTMAIN"}} { global $fvar # -- initialize path name counters and other lists set ${fvar}(version) "1.0b1" set ${fvar}(labfont) "-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*" set ${fvar}(msgfont) "-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*" set ${fvar}(gcnt) 0 set ${fvar}(scnt) 0 set ${fvar}(icnt) 0 set ${fvar}(first) {} set ${fvar}(items) "" set ${fvar}(stripelist) {} # -- general form state information set ${fvar}(visible) 0 set ${fvar}(focusitem) "" set ${fvar}(focustype) "soft" # -- initialize traced elements set ${fvar}(textitems) "" set ${fvar}(listitems) "" set ${fvar}(listitemsivflag) "" set ${fvar}(listitemsinvar) "" set ${fvar}(listitemsinelem) "" # -- create the toplevel window if {$main == "MAIN" && [wm state .] != "withdrawn"} { #wm withdraw . } toplevel .$fvar wm title .$fvar $title if {$wtoposto != ""} { if {[info commands ".$wtoposto"] != ""} { if {[catch "set relx [lindex [split $pos "+"] 1]" relx]} { set relx 0 } if {[catch "set rely [lindex [split $pos "+"] 2]" rely]} { set rely 0 } set x [expr [winfo x .$wtoposto] + $relx] set y [expr [winfo y .$wtoposto] + [winfo height .$wtoposto] \ + $rely] set pos "+${x}+${y}" } } wm geometry .$fvar $pos wm withdraw .$fvar # -- reminder, do something with relative positioning later... } #----------------- # formGROUP -- create a new group of logically associated widgets proc formGROUP {fvar} { global $fvar # -- see if previous line needs packing if {[string length [set ${fvar}(stripelist)]] > 0} { set a "pack [set ${fvar}(stripelist)] -side left -padx 1m -pady 1" eval $a set ${fvar}(stripelist) {} } incr ${fvar}(gcnt) set ${fvar}(scnt) 0 set ${fvar}(icnt) 0 set path ".$fvar.g[set ${fvar}(gcnt)]" frame $path -relief ridge -bd 3 pack $path -side top -fill x # -- reminder, do something with fvarGroup title later... return $path } #----------------- # formNEWLINE -- create a new horizontal band of widgets in the current group proc formNEWLINE {fvar} { global $fvar # -- see if previous line needs to be packed if {[string length [set ${fvar}(stripelist)]] > 0} { set a "pack [set ${fvar}(stripelist)] -side left -padx 1m -pady 1" eval $a set ${fvar}(stripelist) {} } incr ${fvar}(scnt) set ${fvar}(icnt) 0 set path ".$fvar.g[set ${fvar}(gcnt)].s[set ${fvar}(scnt)]" frame $path pack $path -side top -fill x -expand yes return $path } #----------------- # formCHECK -- create a checkbox widget on current line proc formCHECK {fvar statetag prompt var {elem ""} {tkopts ""}} { global $fvar $var # -- increment item count, create a path and an item frame incr ${fvar}(icnt) 1 set fpath \ ".$fvar.g[set ${fvar}(gcnt)].s[set ${fvar}(scnt)].if[set ${fvar}(icnt)]" frame $fpath # -- set the item name in the widget path set path "${fpath}.chk" set tvar $var if {$elem != {}} {set tvar "${var}($elem)"} if {$tvar == {}} { error "formCHECK error: must specify "var" argument for $path" } checkbutton $path -text "$prompt" -variable "$tvar" -anchor w pack $path lappend ${fvar}(items) $path bind $path {focus %W} set ${fvar}(state,$path) 1 if {$statetag != ""} {lappend ${fvar}($statetag) $path} set ${fvar}(type,$path) "CHECK" if {$tkopts != ""} {eval "$path configure $tkopts"} lappend ${fvar}(stripelist) $fpath if {$statetag != ""} {set ${fvar}($statetag,state) 1} if {[set ${fvar}(first)] == {}} {set ${fvar}(first) $path} return $path } #--------------------- # formRADIO -- create a radio button on current line proc formRADIO {fvar statetag prompt var {elem ""} {tkopts ""}} { global $fvar $var # -- increment item count, create a path and an item frame incr ${fvar}(icnt) 1 set fpath \ ".$fvar.g[set ${fvar}(gcnt)].s[set ${fvar}(scnt)].if[set ${fvar}(icnt)]" frame $fpath # -- set the item name in the widget path set path "${fpath}.rad" set tvar $var if {$elem != {}} {set tvar "${var}($elem)"} if {$tvar == {}} { error "formRADIO error: must specify "var" argument for $path" } radiobutton $path -text "$prompt" -variable "$tvar" \ -value "$prompt" -anchor w pack $path lappend ${fvar}(items) $path set ${fvar}(state,$path) 1 if {$statetag != ""} {lappend ${fvar}($statetag) $path} set ${fvar}(type,$path) "RADIO" bind $path "$path invoke" bind $path {focus %W} if {$tkopts != ""} {eval "$path configure $tkopts"} lappend ${fvar}(stripelist) $fpath if {$statetag != ""} {set ${fvar}($statetag,state) 1} if {[set ${fvar}(first)] == {}} {set ${fvar}(first) $path} return $path } #--------------------- # formBUTTON -- create a button on current line proc formBUTTON {fvar statetag prompt cmd {cmdargs ""} {width ""} {tkopts ""}} { global $fvar # -- increment item count, create a path and an item frame incr ${fvar}(icnt) 1 set fpath \ ".$fvar.g[set ${fvar}(gcnt)].s[set ${fvar}(scnt)].if[set ${fvar}(icnt)]" frame $fpath # -- set the item name in the widget path set path "${fpath}.but" if {$width == ""} {set width [string length "$prompt"]} button $path -text "$prompt" -width $width -command "$cmd [concat $cmdargs]" # bind $path "$path flash; $path invoke;" bind $path "$path flash;" bind $path <1> "$path flash;" bind $path {focus %W} set bt [bindtags $path] bindtags $path [list \ [lindex $bt 1] [lindex $bt 0] [lindex $bt 2] [lindex $bt 3]] pack $path lappend ${fvar}(items) $path if {$statetag != ""} {lappend ${fvar}($statetag) $path} set ${fvar}(state,$path) 1 set ${fvar}(type,$path) BUTTON if {$tkopts != ""} {eval "$path configure $tkopts"} lappend ${fvar}(stripelist) $fpath if {$statetag != ""} {set ${fvar}($statetag,state) 1} if {[set ${fvar}(first)] == {}} {set ${fvar}(first) $path} return $path } #--------------------- # formLABEL -- create a label (text string) on the current line proc formLABEL {fvar statetag prompt {var ""} {elem ""} {width ""} \ {tkopts ""}} { global $fvar if {$var!=""} {global $var} # -- increment item count, create a path and an item frame incr ${fvar}(icnt) 1 set fpath \ ".$fvar.g[set ${fvar}(gcnt)].s[set ${fvar}(scnt)].if[set ${fvar}(icnt)]" frame $fpath # -- set the item name in the widget path set path "${fpath}.lab" if {$width == ""} {set width [string length "$prompt"]} set tvar $var if {$elem != ""} {set tvar "${var}($elem)"} if {$width == ""} {set width 25} if {$prompt != ""} { label $fpath.prompt -text "$prompt" -anchor w if {$statetag != ""} {lappend ${fvar}($statetag) $fpath.prompt} pack $fpath.prompt -side left lappend ${fvar}(items) $fpath.prompt set ${fvar}(state,$fpath.prompt) "ON" set ${fvar}(type,$fpath.prompt) "LABEL" } if {$var != ""} { label $path -textvariable "$tvar" -width $width \ -anchor w \ -font [set ${fvar}(labfont)] pack $path -side left lappend ${fvar}(items) $path if {$statetag != ""} {lappend ${fvar}($statetag) $path} set ${fvar}(state,$path) "ON" set ${fvar}(type,$path) "LABEL" } if {$tkopts != ""} {eval "$path configure $tkopts"} lappend ${fvar}(stripelist) $fpath if {$statetag != ""} {set ${fvar}($statetag,state) 1} return $path } #------------------ # formMESSAGE -- create a message area (multiline label) on current line proc formMESSAGE {fvar statetag var {elem ""} {tkopts ""}} { set type 0 global $fvar set tvar $var if {[llength $var] == 1} {global $var} if {[info exists $var]} { set type 1 if {$elem != ""} {set tvar "${var}($elem)"} } if {$var == ""} { error "Item: (MESSAGE widget) must specify variable for $path" } # -- increment item count, create a path and an item frame incr ${fvar}(icnt) 1 set fpath \ ".$fvar.g[set ${fvar}(gcnt)].s[set ${fvar}(scnt)].if[set ${fvar}(icnt)]" frame $fpath # -- set the item name in the widget path set path "${fpath}.msg" if {$type == 1} { message $path -textvariable "$tvar" \ -justify left -aspect 1000 -anchor w \ -font [set ${fvar}(msgfont)] } else { message $path -text "$tvar" \ -justify left -aspect 1000 -anchor w \ -font [set ${fvar}(msgfont)] } pack $path -side left lappend ${fvar}(items) $path if {$statetag != ""} {lappend ${fvar}($statetag) $path} set ${fvar}(state,$path) "ON" set ${fvar}(type,$path) "MESSAGE" if {$tkopts != ""} {eval "$path configure $tkopts"} lappend ${fvar}(stripelist) $fpath if {$statetag != ""} {set ${fvar}($statetag,state) 1} return $path } #------------------ # formENTRY -- create a type-in entry widget on current line proc formENTRY {fvar statetag var {elem ""} {width ""} {cmd ""} \ {cmdargs ""} {tkopts ""}} { global $fvar if {$var!=""} {global $var} # -- increment item count, create a path and an item frame incr ${fvar}(icnt) 1 set fpath \ ".$fvar.g[set ${fvar}(gcnt)].s[set ${fvar}(scnt)].if[set ${fvar}(icnt)]" frame $fpath # -- set the item name in the widget path set path "${fpath}.ent" if {$width == ""} {set width 25} set tvar $var if {$elem != ""} {set tvar "${var}($elem)"} if {$var == ""} { error "Item: (ENTRY widget) must specify variable for $path" } entry $path -textvariable "$tvar" -width $width -relief sunken -bd 2 pack $path -side left lappend ${fvar}(items) $path if {$cmd != ""} { bind $path \ "focus [tk_focusNext $path]; eval [list $cmd $fvar $path $var $elem $cmdargs]; break" } else { bind $path {focus [tk_focusNext %W]; break} } bind $path {focus %W} if {$statetag != ""} {lappend ${fvar}($statetag) $path} set ${fvar}(state,$path) "ON" set ${fvar}(type,$path) "ENTRY" if {$tkopts != ""} {eval "$path configure $tkopts"} lappend ${fvar}(stripelist) $fpath if {$statetag != ""} {set ${fvar}($statetag,state) 1} if {[set ${fvar}(first)] == {}} {set ${fvar}(first) $path} return $path } #------------------ # formPASSWORD -- create a type-in password widget on current line proc formPASSWORD {fvar statetag var {elem ""} {width ""} {cmd ""} \ {cmdargs ""} {tkopts ""}} { global $fvar if {$var!=""} {global $var} # -- increment item count, create a path and an item frame incr ${fvar}(icnt) 1 set fpath \ ".$fvar.g[set ${fvar}(gcnt)].s[set ${fvar}(scnt)].if[set ${fvar}(icnt)]" frame $fpath # -- set the item name in the widget path set path "${fpath}.ent" if {$width == ""} {set width 25} set tvar $var if {$elem != ""} {set tvar "${var}($elem)"} if {$var == ""} { error "Item: (PASSWORD widget) must specify variable for $path" } entry $path -textvariable "$tvar" -show "*" -width $width \ -relief sunken -bd 2 pack $path -side left lappend ${fvar}(items) $path if {$cmd != ""} { bind $path \ "focus [tk_focusNext $path]; eval [list $cmd $fvar $path $var $elem $cmdargs]; break" } else { bind $path {focus [tk_focusNext %W]; break} } bind $path {focus %W} if {$statetag != ""} {lappend ${fvar}($statetag) $path} set ${fvar}(state,$path) "ON" set ${fvar}(type,$path) "ENTRY" if {$tkopts != ""} {eval "$path configure $tkopts"} lappend ${fvar}(stripelist) $fpath if {$statetag != ""} {set ${fvar}($statetag,state) 1} if {[set ${fvar}(first)] == {}} {set ${fvar}(first) $path} return $path } #----------------- # formTEXT -- create a scrollable text area widget proc formTEXT {fvar statetag var {elem ""} {width ""} {height ""} \ {tkopts ""}} { global $fvar if {$var!=""} {global $var} # -- increment item count, create a path and an item frame incr ${fvar}(icnt) 1 set fpath \ ".$fvar.g[set ${fvar}(gcnt)].s[set ${fvar}(scnt)].if[set ${fvar}(icnt)]" frame $fpath # -- set the item name in the widget path set path "${fpath}.txt" if {$width == ""} {set width 45} if {$height == ""} {set height 8} set tvar $var if {$elem != ""} {set tvar "${var}($elem)"} if {$var == ""} { error "Item: (TEXT widget) must specify variable for $path" } text $path -relief sunken -bd 2 -yscrollcommand "$fpath.vscroll set" \ -width $width -height $height -wrap word pack $path -side left if {$statetag != ""} {lappend ${fvar}($statetag) $path} scrollbar $fpath.vscroll -relief sunken -command "$path yview" pack $fpath.vscroll -side right -fill y if {$statetag != ""} {lappend ${fvar}($statetag) $fpath.vscroll} bind $fpath "focus $path" $path delete 1.0 end $path insert end [set $tvar] bind $path "focus %W" bind $path "formiUPDATEVAR $fvar %W" bind $path {focus [tk_focusNext %W]; break} bind $path {focus [tk_focusPrev %W]; break} bind $path "focus %W;" bind $path "formiUPDATEVAR $fvar %W;" bind $path "formiMARK $fvar %W;" bindtags $path [linsert [bindtags $path] 0 $path] trace variable $tvar w "formiUPDATETEXT $fvar $path" lappend ${fvar}(textitems) $path lappend ${fvar}(items) $path lappend ${fvar}(items) $fpath.vscroll set ${fvar}(state,$fpath.vscroll) "ON" set ${fvar}(type,$fpath.vscroll) "SCROLL" set ${fvar}(state,$path) "ON" set ${fvar}(type,$path) "TEXT" set ${fvar}(dirty,$path) 0 set ${fvar}(var,$path) $var set ${fvar}(elem,$path) $elem if {$tkopts != ""} {eval "$path configure $tkopts"} lappend ${fvar}(stripelist) $fpath if {$statetag != ""} {set ${fvar}($statetag,state) 1} if {[set ${fvar}(first)] == {}} {set ${fvar}(first) $path} return $path } #--------------------- # formLIST -- add a scrollable single-selection list widget to line # formLIST fvar statetag invar inelem outvar outelem width height ["tkopts"] proc formLIST {fvar statetag invar inelem outvar {outelem ""} {width ""} \ {height ""} {tkopts ""}} { global $fvar if {$invar != ""} {global $invar} if {$outvar != ""} {global $outvar} # -- increment item count, create a path and an item frame incr ${fvar}(icnt) 1 set fpath \ ".$fvar.g[set ${fvar}(gcnt)].s[set ${fvar}(scnt)].if[set ${fvar}(icnt)]" frame $fpath # -- set the item name in the widget path set path "${fpath}.lst" if {$width == ""} {set width 15} if {$height == ""} {set height 5} set tvar $invar if {$inelem != ""} {set tvar "${invar}($inelem)"} if {$invar == ""} { error "Item: (LIST widget) must specify list source for $path" } if {$outvar == ""} { error "Item: (LIST widget) must specify output variable for $path" } set vflag 0 if {[info exists $invar]} {set vflag 1} set inproc "" if {[info procs $invar] != ""} { set vflag 2 set inproc $invar set inprocarg $inelem set outproc $outvar set outprocarg $outelem } set ovflag 0 if {[info procs $outvar] != ""} { set ovflag 2 } elseif {[info exists $outvar]} { set ovflag 1 } # -- implement listbox here... # -- create and pack and bind listbox widgets eval [list listbox $path \ -yscrollcommand [list $fpath.vscroll set] \ -xscrollcommand [list $fpath.p.hscroll set] \ -width $width -height $height -setgrid true \ -selectmode browse] lappend ${fvar}(items) $path lappend ${fvar}(listitems) $path lappend ${fvar}(listitemsivflag) $vflag lappend ${fvar}(listitemsinvar) $invar lappend ${fvar}(listitemsinelem) $inelem set ${fvar}(state,$path) "ON" set ${fvar}(type,$path) "LIST" scrollbar $fpath.vscroll -orient vertical \ -command [list $path yview] frame $fpath.p scrollbar $fpath.p.hscroll -orient horizontal \ -command [list $path xview] set pad [expr [$fpath.vscroll cget -width] + 2 * \ ([$fpath.vscroll cget -bd] + \ [$fpath.vscroll cget -highlightthickness])] frame $fpath.p.it -width $pad -height $pad pack $fpath.p -side bottom -fill x pack $fpath.p.it -side right pack $fpath.p.hscroll -side bottom -fill x pack $fpath.vscroll -side right -fill y pack $path -side left -fill both -expand true if {$statetag != ""} { lappend ${fvar}($statetag) $path lappend ${fvar}($statetag) $fpath.p.hscroll lappend ${fvar}($statetag) $fpath.vscroll } lappend ${fvar}(items) $fpath.vscroll set ${fvar}(state,$fpath.vscroll) "ON" set ${fvar}(type,$fpath.vscroll) "SCROLL" lappend ${fvar}(items) $fpath.p.hscroll set ${fvar}(state,$fpath.p.hscroll) "ON" set ${fvar}(type,$fpath.p.hscroll) "SCROLL" bind $path {formiLISTSELBEGIN %W %y} # bind $path {formiLISTSELMOVE %W %y} # bind $path {formiLISTSELMOVE %W %y} # bind $path {formiLISTSELMOVE %W %y} bind $path {formiLISTSELBEGIN %W %y} bind $path \ [list formiLISTSELEND $fvar %W %y $vflag $invar $inelem $ovflag $outvar $outelem] bind $path \ [list formiLISTSELKEYEND $fvar %W $vflag $invar $inelem $ovflag $outvar $outelem] bind $path { tkCancelRepeat tkListboxBeginSelect %W [%W index active] %W activate [%W index active] } bind $path { # tkListboxUpDown %W 1 tkCancelRepeat tkListboxBeginSelect %W [%W index active] %W activate [%W index active] } bind $path {focus %W} # -- Insert choises into list if {$vflag == 2} { # -- make note of special list insertion handler formLISTUPDATE $fvar $path $inproc $inprocarg set ${fvar}(listinproc,$path) $inproc lappend ${fvar}(listinprocs) $path set ${fvar}(listoutproc,$path) $outproc lappend ${fvar}(listoutprocs) $path } else { formLISTUPDATE $fvar $path $invar $inelem } set ${fvar}(dirty,path) 0 if {$tkopts != ""} {eval "$path configure $tkopts"} lappend ${fvar}(stripelist) $fpath if {$statetag != ""} {set ${fvar}($statetag,state) 1} if {[set ${fvar}(first)] == {}} {set ${fvar}(first) $path} return $path } #----------------- # formEND -- close definition of the form, display it # proc formEND {fvar {showit "on"} {focusitem ""} {focustype ""}} { global $fvar # -- see if previous stripe needs to be packed if {[string length [set ${fvar}(stripelist)]] > 0} { set a "pack [set ${fvar}(stripelist)] -side left -padx 1m -pady 1" eval $a set ${fvar}(stripelist) {} } # -- if a focus item was provide, set focus to it set ${fvar}(focusitem) $focusitem if {$focusitem != ""} { focus -force $focusitem } else { if {[info exists ${fvar}(first)]} { focus [set ${fvar}(first)] } } set ${fvar}(focustype) $focustype update if {$showit == "on"} { wm deiconify .$fvar tkwait visibility .$fvar set ${fvar}(visibility) 1 if {$focustype == "lockinput"} { grab -global .$fvar } } else { set ${fvar}(visibility) 0 } } #---------------- # formDIE -- delete the form, free resources, delete control variable proc formDIE {fvar} { global $fvar grab release .$fvar wm withdraw .$fvar formTEXTTRACE $fvar off destroy .$fvar unset $fvar } #----------------- # formSHOW -- display or withdraw a form (non-destructive) proc formSHOW {fvar {showit "on"}} { global $fvar if {$showit == "on"} { if {[set ${fvar}(focusitem)] != ""} { focus [set ${fvar}(focusitem)] } else { if {![info exists ${fvar}(first)]} { focus [set ${fvar}(first)] } } wm deiconify .$fvar tkwait visibility .$fvar set ${fvar}(visibility) 1 if {[set ${fvar}(focustype)] == "hardfocus"} { grab -global .$fvar } } else { set ${fvar}(visibility) 0 grab release .$fvar wm withdraw .$fvar } } #---------------- # formPATHS -- return all widget paths matching path pattern proc formPATHS {fvar {pattern "*"}} { global $fvar set l [set ${fvar}(items)] set r "" foreach x $l { if {[string match $pattern $x]} { lappend r $x } } return [lsort $r] } #---------------- # formSTATE -- activate / deactivate all widgets associated with statetag # proc formSTATE {fvar statetag {opcode "on"}} { global $fvar foreach i [set ${fvar}($statetag)] { if {$opcode == "on"} { switch [set ${fvar}(type,$i)] { BUTTON - RADIO - CHECK { $i configure -state normal $i configure -takefocus 1 } ENTRY - LIST { $i configure -foreground black $i configure -takefocus 1 } TEXT { $i configure -foreground black $i configure -state normal $i configure -takefocus 1 } MESSAGE - LABEL { $i configure -foreground black } SCROLL { $i configure -activebackground black $i configure -takefocus 0 } default {} } } else { switch [set ${fvar}(type,$i)] { BUTTON - RADIO - CHECK { $i configure -state disabled $i configure -takefocus 0 } ENTRY - LIST { $i configure -foreground gray75 $i configure -takefocus 0 } TEXT { $i configure -foreground gray75 $i configure -state disabled $i configure -takefocus 0 } MESSAGE - LABEL { $i configure -foreground gray75 } SCROLL { $i configure -activebackground gray75 $i configure -takefocus 0 } default {} } } } } #----------------- # formCURSOR -- set the cursor appearance when over the form proc formCURSOR {fvar {type "normal"} {altcursor ""}} { global $fvar switch $type { normal { .$fvar configure -cursor {} } busy { .$fvar configure -cursor watch } alt { if {$altcursor != ""} { .$fvar configure -cursor $altcursor } } default { } } update update idletasks } #----------------- # formREFRESH -- update the form contents (everything but lists and # text done automatically, so update only them) proc formREFRESH {fvar} { global $fvar formTEXTREFRESH $fvar formLISTUPDATE $fvar } #----------------- # formTEXTTRACE -- turn on or off watching variables for change for variables # associated with text widgets on form proc formTEXTTRACE {fvar {opcode "on"}} { global $fvar # -- if fvar has TEXT widgets, set/unset traces if {[info exists ${fvar}(textitems)]} { foreach p [set ${fvar}(textitems)] { set var [set ${fvar}(var,$p)] global $var set elem [set ${fvar}(elem,$p)] if {$elem != ""} {set var "${var}($elem)"} if {$opcode == "on"} { trace variable $var w "formiUPDATETEXT $fvar $p" } else { trace vdelete $var w "formiUPDATETEXT $fvar $p" } } } } #----------------- # formTEXTREFRESH -- update display of in text widgets from associated # variable data source proc formTEXTREFRESH {fvar} { global $fvar if {[info exists ${fvar}(textitems)]} { foreach titem [set ${fvar}(textitems)] { set var [set ${fvar}(var,$titem)] set elem [set ${fvar}(elem,$titem)] global $var if {$elem != {}} {set var "${var}($elem)"} trace vdelete $var w "formiUPDATETEXT $fvar $titem" $titem delete 1.0 end $titem insert end [set $var] trace variable $var w "formiUPDATETEXT $fvar $titem" set ${fvar}(dirty,$titem) 0 } } } #----------------- # formLISTCLEAR -- clears the contents of a (or all) scrollable list # widget(s) on form proc formLISTCLEAR {fvar {path ""}} { global $fvar if {$path != ""} { $path delete 0 end } else { foreach item [set ${fvar}(listpaths)] { $item delete 0 end } } } #----------------- # formLISTUPDATE -- update list items for a/all scrollable list on the form # proc formLISTUPDATE {fvar {path {}} {var {}} {elem {}}} { global $fvar if {$path == ""} { set pathlist [set ${fvar}(listitems)] set ivflaglist [set ${fvar}(listitemsivflag)] set invarlist [set ${fvar}(listitemsinvar)] set inelemlist [set ${fvar}(listitemsinelem)] } else { if {[llength $var] == 1} {global $var} set pathlist [list $path] set invarlist [list $var] set inelemlist [list $elem] set ivflaglist [list 0] if {[info exists $var]} { set ivflaglist [list 1] } elseif {[info procs $var] != ""} { set ivflaglist [list 1] } } set i 0 set listlen [llength $pathlist] while {$i < $listlen} { set path [lindex $pathlist $i] set vflag [lindex $ivflaglist $i] set var [lindex $invarlist $i] set elem [lindex $inelemlist $i] formLISTCLEAR $fvar $path if {$vflag == 0} { # -- insert literal list given in var foreach item $var {$path insert end $item} } elseif {$vflag == 1} { global $var # -- insert values from a variable set tvar $var if {$elem != ""} {set tvar "${tvar}($elem)"} foreach item [set $tvar] {$path insert end $item} } elseif {$vflag == 2} { # -- insert values from list returned from procedure if {$elem == {}} { set tlist [eval [concat $var $fvar $path]] } else { set tlist [eval [concat $var $fvar $path $elem]] } foreach item $tlist {$path insert end $item} } incr i } } #================= # INTERNAL PROCEDURES #----------------- #----------------- # formiMARK -- mark a TEXT widget associated with an external # variable as modified proc formiMARK {fvar path} { global $path $fvar set ${fvar}(dirty,$path) 1 } #----------------- # formiUPDATEVAR -- update a variable a TEXT widget on the form # with the contents of the TEXT item proc formiUPDATEVAR {fvar path} { global $fvar $path set var [set ${fvar}(var,$path)] set elem [set ${fvar}(elem,$path)] set dirty [set ${fvar}(dirty,$path)] global $var if {$dirty} { if {$elem == {}} { set ${var} [$path get 1.0 end] } else { set ${var}($elem) [$path get 1.0 end] } } set ${fvar}(dirty,$path) 0 } #----------------- # formiUPDATETEXT -- update a TEXT widget with the new contents of its # associated variable (via trace) proc formiUPDATETEXT {fvar path var elem op} { global $fvar $path $var if {$elem != {}} {set var "${var}($elem)"} trace vdelete $var w "formiUPDATETEXT $fvar $path" $path delete 1.0 end $path insert end "[set $var]" trace variable $var w "formiUPDATETEXT $fvar $path" set ${fvar}(dirty,$path) 0 } #----------------- # formiLISTSELBEGIN -- initiate a LIST selection proc formiLISTSELBEGIN {w y} { $w select anchor [$w nearest $y] } #----------------- # formiLISTSELMOVE -- handle movement during LIST selection proc formiLISTSELMOVE {w y} { $w select set anchor [$w nearest $y] } #----------------- # formiLISTSELEND -- finalize a LIST selection proc formiLISTSELEND {fvar w y ivflag ivar ielem ovflag ovar oelem} { global $fvar $w select set anchor [$w nearest $y] set selindex [lindex [$w curselection] 0] if {$ivflag == 0} { if {$ovflag == 1} { global $ovar if {$oelem != ""} {set ovar "${ovar}($oelem)"} set $ovar [lindex $ivar $selindex] } elseif {$ovflag == 2} { if {$oelem != ""} { catch "eval [list $ovar $fvar $selindex "[list [lindex $ivar $selindex]]" $oelem]" } else { catch "eval [list $ovar $fvar $selindex "[list [lindex $ivar $selindex]]"]" } } } if {$ivflag == 1} { global $ivar if {$ielem != ""} {set ivar "${ivar}($ielem)"} if {$ovflag == 1} { global $ovar if {$oelem != ""} {set ovar "${ovar}($oelem)"} set $ovar [lindex [set $ivar] $selindex] } elseif {$ovflag == 2} { if {$oelem != ""} { catch "eval [list $ovar $fvar $selindex "[list [lindex [set $ivar] $selindex]]" $oelem]" } else { catch "eval [list $ovar $fvar $selindex "[list [lindex [set $ivar] $selindex]]"]" } } } if {$ivflag == 2} { set tmp "" if {$ielem == ""} { catch "eval $ivar" tmp } else { catch "eval $ivar $ielem" tmp } if {$ovflag == 1} { global $ovar if {$oelem != ""} {set ovar "${ovar}($oelem)"} set $ovar [lindex $tmp $selindex] } elseif {$ovflag == 2} { if {$oelem != ""} { catch "eval [list $ovar $fvar [list [lindex $tmp $selindex]]]" } else { catch "eval [list $ovar $fvar [list [lindex $tmp $selindex]] $oelem]" } } } } #----------------- # formiLISTSELKEYEND -- finalize a LIST selection performed by proc formiLISTSELKEYEND {fvar w ivflag ivar ielem ovflag ovar oelem} { global $fvar if {[$w curselection] == ""} { $w selection set 0 0 } set selindex [lindex [$w curselection] 0] if {$ivflag == 0} { if {$ovflag == 1} { global $ovar if {$oelem != ""} {set ovar "${ovar}($oelem)"} set $ovar [lindex $ivar $selindex] } elseif {$ovflag == 2} { if {$oelem != ""} { catch "eval [list $ovar $fvar $selindex "[list [lindex $ivar $selindex]]" $oelem]" } else { catch "eval [list $ovar $fvar $selindex "[list [lindex $ivar $selindex]]"]" } } } if {$ivflag == 1} { global $ivar if {$ielem != ""} {set ivar "${ivar}($ielem)"} if {$ovflag == 1} { global $ovar if {$oelem != ""} {set ovar "${ovar}($oelem)"} set $ovar [lindex [set $ivar] $selindex] } elseif {$ovflag == 2} { if {$oelem != ""} { catch "eval [list $ovar $fvar $selindex "[list [lindex [set $ivar] $selindex]]" $oelem]" } else { catch "eval [list $ovar $fvar $selindex "[list [lindex [set $ivar] $selindex]]"]" } } } if {$ivflag == 2} { set tmp "" if {$ielem == ""} { catch "eval $ivar" tmp } else { catch "eval $ivar $ielem" tmp } if {$ovflag == 1} { global $ovar if {$oelem != ""} {set ovar "${ovar}($oelem)"} set $ovar [lindex $tmp $selindex] } elseif {$ovflag == 2} { if {$oelem != ""} { catch "eval [list $ovar $fvar [list [lindex $tmp $selindex]]]" } else { catch "eval [list $ovar $fvar [list [lindex $tmp $selindex]] $oelem]" } } } } ############### # end tkvsform.tcl section ############### ############### # start common.tcl section ############### global theParent set theParent "kjadlkjflajdf" proc get_widget_value {w v} { global theParent set RET "" set A [catch "$w configure -$v" err] if {$A == 1 && [lindex $err 0] == "-$v"} { set A 0 set list $err } elseif {$A == 0} { set list [$w configure -$v] } if {$A == 0} { set val [lindex $list 4] set val [try_sub $val $theParent] if {[llength $val] != 1} {return \{$val\}} return $val } return {} } proc try_sub {v p} { set nv {} foreach i $v { if {"[string range $i 0 [expr [string length $p] -1]]" == "$p"} { if {$nv != ""} { set nv "$nv \$Parent[string range $i [string length $p] end]" } else { set nv "\$Parent[string range $i [string length $p] end]" } } else { if {$nv != ""} { set nv "$nv $i" } else { set nv $i } } } return $nv } proc for_array_keys {item arr body} { upvar $item i upvar $arr a foreach i [array names a] { uplevel $body } } proc csubstr {s f l} { return [string range $s $f $l] } proc clength {s} { return [string length $s] } proc lvarpop {v} { upvar $v l set tmp $l set l [lrange $l 1 end] return [lindex $tmp 0] } proc isset {var} { set body "return \[info exists $var\]" uplevel $body } proc is_packed w { if {[catch "pack info $w"]==0} {return 1} return 0 } proc is_aligned w { if {[align info $w]!=""} {return 1} return 0 } proc is_placed w { if [is_aligned $w] {return 0} if {[place info $w]!=""} {return 1} return 0 } proc is_blt_table w { if {[catch "blt_table info $w"]==0} {return 1} return 0 } proc use_shape {w s marker} { global pp_shape selected set n [winfo name $w] if {[is_gui_widget $w]==0} { if {$s=="align" && [is_aligned $w]} return if {$s=="pack" && [is_packed $w]} return if {$s=="place" && [is_placed $w]} return if {$s=="blt_table" && [is_blt_table $w]} return } if {$s == "pack"} { catch "pack forget .gui_edit$n.frame2" catch "pack forget .gui_edit$n.frame2b" catch "pack forget .gui_edit$n.frame2c" catch "pack .gui_edit$n.frame2a -fill x -expand 1" } elseif {$s == "place"} { #echo here catch "pack forget .gui_edit$n.frame2a" catch "pack forget .gui_edit$n.frame2b" catch "pack forget .gui_edit$n.frame2c" catch "pack .gui_edit$n.frame2 -fill x -expand 1" } elseif {$s == "blt_table"} { catch "pack forget .gui_edit$n.frame2" catch "pack forget .gui_edit$n.frame2a" catch "pack forget .gui_edit$n.frame2c" catch "pack .gui_edit$n.frame2b -fill x -expand 1" } elseif {$s == "align"} { catch "pack forget .gui_edit$n.frame2" catch "pack forget .gui_edit$n.frame2a" catch "pack forget .gui_edit$n.frame2b" catch "pack .gui_edit$n.frame2c -fill x -expand 1" } set pp_shape($w) $s if ![is_gui_widget $w] { if {$s == "pack"} { catch "place forget $w" catch "align forget $w" catch "blt_table forget $w" pack $w } elseif {$s == "place"} { catch "pack forget $w" catch "align forget $w" catch "blt_table forget $w" place $w -x 0 -y 0 } elseif {$s == "blt_table"} { catch "pack forget $w" catch "align forget $w" catch "place forget $w" blt_table [winfo parent $w] $w [get_free_index [winfo parent $w]] } elseif {$s == "align"} { catch "pack forget $w" catch "blt_table forget $w" align $w } } else { foreach wi [make_widget_list] { if {[isset selected($wi)]==0} continue if {$selected($wi) == $marker} { set pp_shape($wi) $s set n [winfo name $wi] if {$s == "pack"} { catch "place forget $wi" catch "blt_table forget $wi" catch "pack $wi" catch "pack forget .gui_edit$n.frame2" catch "pack forget .gui_edit$n.frame2b" catch "pack forget .gui_edit$n.frame2c" catch "pack .gui_edit$n.frame2a -fill x -expand 1" } elseif {$s == "place"} { catch "pack forget $wi" catch "blt_table forget $wi" catch "place $wi -x 0 -y 0" catch "pack forget .gui_edit$n.frame2a" catch "pack forget .gui_edit$n.frame2b" catch "pack forget .gui_edit$n.frame2c" catch "pack .gui_edit$n.frame2 -fill x -expand 1" } elseif {$s == "blt_table"} { catch "pack forget .gui_edit$n.frame2a" catch "pack forget .gui_edit$n.frame2" catch "pack forget .gui_edit$n.frame2c" catch "blt_table [winfo parent $wi] $wi [get_free_index [winfo parent $wi]]" catch "pack .gui_edit$n.frame2b -fill x -expand 1" } elseif {$s == "align"} { catch "pack forget .gui_edit$n.frame2a" catch "pack forget .gui_edit$n.frame2" catch "pack forget .gui_edit$n.frame2b" catch "pack .gui_edit$n.frame2c -fill x -expand 1" catch "align $wi" } } } } } proc pack_val {w val} { global tk_version if {$tk_version >=4} { if {[catch "pack info $w"]==1} {set w .guiBUILDER.f2.f2.f2.lb1} set l [pack info $w] } else { if {[catch "pack info $w"]==1} {set w .guiBUILDER.f2.f2.f2.lb1} set l [pack info $w] } set i [lsearch $l $val] set i [expr $i + 1] return [lindex $l $i] } proc make_menu {w cmd args} { catch "destroy $w.m" if {[llength $args] == 1} {eval "set args $args"} #eval "menu $w.m -takefocus 1 $args" eval "menu $w.m $args" for {set i 0} {$i < [llength $cmd]} {set i [expr $i+1]} { set line [lindex $cmd $i] if {"[lindex $line 0]" == "separator" } { set CMD "$w.m add separator [lrange $line 1 end]" eval $CMD } elseif {"[lindex $line 0]" == "tearoff" } { } else { if {"[lindex $line 1]" == "menu" } { set CMD "$w.m add cascade -label \"[lindex $line 0]\" -menu [make_menu $w.m [lindex $line 2] [lrange $line 3 end]]" eval $CMD } else { set CMD "$w.m add [lindex $line 1] -label \"[lindex $line 0]\" -command \"[lindex $line 2]\" [lrange $line 3 end]" eval $CMD } } } return $w.m } #Begin Ted Dunning's code # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # generic bindings for emacs like behavior bind Entry "entry_insert %W %A" bind Entry "entry_insert %W %A" bind Entry "nop" bind Entry "nop" bind Entry "nop" proc nop {} {} proc entry_insert {w key} { catch {$w delete sel.first sel.last} $w insert insert $key } bind Entry {%W icursor 0} bind Entry {%W icursor end} bind Entry {%W icursor [expr [%W index insert]+1]} bind Entry {%W icursor [expr [%W index insert]-1]} bind Entry {%W delete [%W index insert] end} bind Entry { } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # normal motif style pasting bind Entry {catch {%W insert insert [selection get]}} bind Entry {%W select from 0 ; %W select to end} bind Entry {handle_backspace %W} bind Entry {handle_backspace %W} bind Entry {handle_backspace %W} proc handle_backspace w { if {[catch {$w delete sel.first sel.last}]} { set pos [expr [$w index insert]-1] $w delete $pos $pos } } #End Ted Dunning's code. ############################################################################# # the following was the extensions.tcl file ############################################################################# global align_rec redo_align place_info align_maxX align_maxY wait_conf global align_list set align_list "" proc group {m} { global selected top pp_shape stretchX stretchY moveX moveY set upx 10000 set upy 10000 set lowx -1 set lowy -1 set par "" for_array_keys s selected { if {$selected($s)==$m} { if {$par == ""} {set par [winfo parent $s]} if {$par != [winfo parent $s]} { error "All widgets must have same parent." return } set w_upx [winfo x $s] set w_upy [winfo y $s] set w_lowx [expr $w_upx + [winfo width $s]] set w_lowy [expr $w_upy + [winfo height $s]] if {$w_upx < $upx} {set upx $w_upx} if {$w_upy < $upy} {set upy $w_upy} if {$w_lowx > $lowx} {set lowx $w_lowx} if {$w_lowy > $lowy} {set lowy $w_lowy} } } if {$lowx != -1} { for_array_keys s selected { if {$selected($s)==$m} { if {$pp_shape($s) == "place"} { set oldSX $stretchX($s) set oldSY $stretchY($s) set oldMX $moveX($s) set oldMY $moveY($s) set stretchX($s) 0 set stretchY($s) 0 set moveX($s) 0 set moveY($s) 0 set nx [expr [my_winfo x $s]-$upx] set ny [expr [my_winfo y $s]-$upy] set_position $s $nx $ny set_size $s [winfo width $s] [winfo height $s] set stretchX($s) $oldSX set stretchY($s) $oldSY set moveX($s) $oldMX set moveY($s) $oldMY } } } set W [unique $par.group] frame $W -width [expr ($lowx-$upx)+4] \ -height [expr ($lowy-$upy)+4] \ -relief raised -border 2 place $W -x $upx -y $upy bind_widget $W get_placement_info $W reparent $W $m #update foreach s [winfo child $W] { if {$pp_shape($s) == "place"} { set_position $s [my_winfo x $s] [my_winfo y $s] set_size $s [winfo width $s] [winfo height $s] } } } } proc last_elm {a} { return [lindex $a [expr [llength $a]-1]] } #set align_list "" set align_rec 0 proc lremove {list elem} { upvar $list L #echo $L $elem set ix [lsearch $L $elem] if {$ix > -1} { set L "[lrange $L 0 [expr $ix-1]] [lrange $L [expr $ix+1] end]" } } proc to_side {a} { if {$a == "T"} {return top} if {$a == "B"} {return bottom} if {$a == "M"} {return middle} if {$a == "L"} {return left} if {$a == "R"} {return right} if {$a == "C"} {return centre} if {$a == "N"} {return none} } proc change_fill {w but} { global alignment if {[info exists alignment($w,F)]} { if {$alignment($w,F) == "X"} { set alignment($w,F) Y } elseif {$alignment($w,F) == "Y"} { set alignment($w,F) B } elseif {$alignment($w,F) == "B"} { set alignment($w,F) N } elseif {$alignment($w,F) == "N"} { set alignment($w,F) X } } else { set alignment($w,F) X } align $w -fill $alignment($w,F) $but config -text "Fill $alignment($w,F)" } proc to_info {a} { if {[llength $a] > 1} { set w [lindex $a 0] set a [lindex $a 1] return [list [to_side $a] $w] } return "[to_side $a] parent" } proc align {w args} { #error "usage: align widget ?-side side? ?widget?" winfo exists $w global redo_align align_rec wait_conf place_info set redo_align 1 #set align_rec 0 #set wait_conf 0 global align_list global alignment set opt [lvarpop args] if {$w == "forget"} { lremove align_list $opt #catch "place forget $w" unset place_info($opt\ -x) unset place_info($opt\ -y) unset place_info($opt\ -height) unset place_info($opt\ -width) unset alignment($opt,T) unset alignment($opt,L) unset alignment($opt,R) unset alignment($opt,B) unset alignment($opt,M) unset alignment($opt,C) unset alignment($opt,F) unset alignment($opt,X) unset alignment($opt,Y) return } if {$w == "info"} { if ![winfo exists $opt] return if ![isset alignment($opt,T)] return return "\ -top [to_info $alignment($opt,T)] \ -bottom [to_info $alignment($opt,B)]\ -middle [to_info $alignment($opt,M)]\ -left [to_info $alignment($opt,L)]\ -right [to_info $alignment($opt,R)]\ -centre [to_info $alignment($opt,C)]\ -fill $alignment($opt,F)\ -xpad $alignment($opt,X)\ -ypad $alignment($opt,Y)" } if [catch "place $w -anchor nw"] { error "Can not align this type of widget $w of class [winfo class $w]" return } set place_info($w\ -x) NULL set place_info($w\ -y) NULL set place_info($w\ -height) NULL set place_info($w\ -width) NULL set cmd "place $w -x [Winfo x $w] -y [Winfo y $w]" place forget $w eval $cmd set side [lvarpop args] #echo opt = $opt, side = $side, W = $W if {$opt == ""} { if {$align_list == ""} { set alignment($w,T) N set alignment($w,L) N set alignment($w,R) N set alignment($w,B) N set alignment($w,M) N set alignment($w,C) N set alignment($w,F) N set alignment($w,X) 0 set alignment($w,Y) 0 } else { set alignment($w,T) N set alignment($w,L) N set alignment($w,R) N set alignment($w,B) N set alignment($w,M) N set alignment($w,C) N set alignment($w,F) N set alignment($w,X) 0 set alignment($w,Y) 0 } } else { if {$side == ""} { error "usage: align widget | align widget -side side ?widget?" return } set pad $side set side [string toupper [csubstr $side 0 0]] set opt [string toupper [csubstr $opt 1 1]] if ![isset alignment($w,T)] { set alignment($w,T) N set alignment($w,B) N set alignment($w,R) N set alignment($w,L) N set alignment($w,M) N set alignment($w,C) N set alignment($w,F) N set alignment($w,X) 0 set alignment($w,Y) 0 } if {$opt == "F"} { set alignment($w,$opt) $side if {$args != ""} {eval "align $w $args"} } elseif {$opt == "X" || $opt == "Y"} { set alignment($w,$opt) $pad if {$args != ""} {eval "align $w $args"} } else { set W [lvarpop args] if {$W == "" || $W == "-" || $W == "parent"} { #echo set alignment($w,$opt) $side set alignment($w,$opt) $side if {$args != ""} {eval "align $w $args"} } else { set alignment($w,$opt) [list $W $side] if {$args != ""} {eval "align $w $args"} } } } lremove align_list $w lappend align_list $w process_align_list 1 } set redo_align 1 proc Winfo {v w {par 0}} { global place_info alignment if {[info exist alignment($w,X)]} { set padx $alignment($w,X) set pady $alignment($w,Y) } else { set padx 0;set pady 0 } if {[info exist place_info($w\ -$v)] && $place_info($w\ -$v)!= "NULL"} { if {$v == "x"} { return [expr $place_info($w\ -$v)] } elseif {$v == "y"} { return [expr $place_info($w\ -$v)] } elseif {$v == "height"} { return [expr $place_info($w\ -$v)] } elseif {$v == "width"} { return [expr $place_info($w\ -$v)] } } else { if {($v == "x" || $v == "y")} { set bw [expr [get_widget_value [winfo parent $w] borderwidth]] } elseif {$par == 1 && ($v == "height" || $v == "width")} { set bw [expr 2*[get_widget_value $w borderwidth]] } else { set bw 0 } if {($v == "height" || $v == "width") && [lsearch [place info $w] -$v] == -1 && [winfo $v $w]==1} { set v req$v } #echo RETURNING [expr [winfo $v $w]-$bw] as $v for $w if {$v == "x"} { return [expr [winfo $v $w]-$bw] } elseif {$v == "y"} { return [expr [winfo $v $w]-$bw] } elseif {$v == "height" || $v == "reqheight"} { return [expr [winfo $v $w]-$bw+2*$pady] } elseif {$v == "width" || $v == "reqwidth"} { return [expr [winfo $v $w]-$bw+2*$padx] } } } set place_info(1) null unset place_info(1) proc resize_parent {w x y} { global align_maxX align_maxY set p [winfo parent $w] if [info exists align_maxX($p)] { if {$x > $align_maxX($p)} {set align_maxX($p) $x} if {$y > $align_maxY($p)} {set align_maxY($p) $y} } else { set align_maxX($p) $x set align_maxY($p) $y } } set align_maxX(1) 1 unset align_maxX(1) set align_maxY(1) 1 unset align_maxY(1) proc Update {} { global place_info alignment align_maxX align_maxY global place_info set old_w "" set cmd "" for_array_keys w align_maxX { if {$align_maxX($w) != 0} { if {[winfo class $w] != "Toplevel"} { $w config -width [expr $align_maxX($w)+2*[get_widget_value $w borderwidth]] set align_maxX($w) 0 } } if {$align_maxY($w) != 0} { if {[winfo class $w] != "Toplevel"} { $w config -height [expr $align_maxY($w)+2*[get_widget_value $w borderwidth]] set align_maxY($w) 0 } } } for_array_keys p place_info { set w [lindex $p 0] if {[info exist alignment($w,X)]} { set padx $alignment($w,X) set pady $alignment($w,Y) } else { set padx 0;set pady 0 } if ![winfo exists $w] continue set v [lindex $p 1] set pl [place info $w] set ix [lsearch $pl $v] if {$old_w != $w} { if {[llength $cmd] > 2} { eval $cmd update } set cmd "place $w" } set old_w $w set old "" if {$ix > -1} { set old [lindex $pl [expr $ix +1]] } if {$pl == "" || $old != $place_info($w\ $v)} { if {$v == "-x"} { if {$place_info($w\ $v) == "NULL"} { #echo NULL $w $v #lappend cmd $v [expr [Winfo x $w]+2] } else { lappend cmd $v [expr $place_info($w\ $v)+$padx] } } elseif {$v == "-y"} { if {$place_info($w\ $v) == "NULL"} { #echo NULL $w $v #lappend cmd $v [expr [Winfo y $w]+2] } else { lappend cmd $v [expr $place_info($w\ $v)+$pady] } } elseif {$v == "-height"} { if {$place_info($w\ $v) == "NULL"} { #echo NULL $w $v #lappend cmd $v [expr [Winfo height $w]-2] } else { lappend cmd $v [expr $place_info($w\ $v)-2*$pady] } } elseif {$v == "-width"} { if {$place_info($w\ $v) == "NULL"} { #echo NULL $w $v #lappend cmd $v [expr [Winfo width $w]-2] } else { lappend cmd $v [expr $place_info($w\ $v)-2*$padx] } } } } if {[llength $cmd] > 2} { eval $cmd update } } proc a_place {w opt val} { set old "" global redo_align place_info align_rec if [info exists place_info($w\ $opt)] { set old $place_info($w\ $opt) } else { set pl [place info $w] set ix [lsearch $pl $opt] if {$ix > -1} {set old [lindex $pl [expr $ix +1]]} if {$pl == ""} { set place_info($w\ $opt) $val place $w $opt $val set redo_align 1 #place $w $opt $val return } } if {$old != $val} { set place_info($w\ $opt) $val #place $w $opt $val set redo_align 1 } else { set pl [place info $w] set ix [lsearch $pl $opt] #place $w $opt $val } } set wait_conf 0 bind all { #lsearch $align_list %W global wait_conf if {$wait_conf==0} { #echo $wait_conf after 0 process_align_list 1 } } proc process_align_list {{check 0}} { global align_list global alignment redo_align align_rec global wait_conf if {$check == 1 && $wait_conf != 0} { return } set wait_conf 1 set r [process_alist] if {$redo_align == 1 || $r} { incr align_rec if {$align_rec > 200} { error "Alignment called over 200 times." } else { #echo recursion enter $align_rec set redo_align 0 process_align_list #echo recursion leave $align_rec } } else { Update } if {$align_rec != 0} {incr align_rec -1} set wait_conf 0 } proc get_next_left {w} { global alignment if ![isset alignment($w,R)] {return ""} if {$w == "N"} {return ""} set wi [lindex $alignment($w,R) 0] set side [lindex $alignment($w,R) 1] if {$side != "L"} {return ""} if {[isset alignment($wi,L)] && [lindex $alignment($wi,L) 0] == $w \ && ($alignment($wi,F) == "X" || $alignment($wi,F) == "B")} { return [lindex $wi 0] } return [get_next_left $wi] } proc get_next_top {w} { global alignment if ![isset alignment($w,B)] {return ""} if {$w == "N"} {return ""} set wi [lindex $alignment($w,B) 0] set side [lindex $alignment($w,B) 1] if {$side != "T"} {return ""} if {[isset alignment($wi,T)] && [lindex $alignment($wi,T) 0] == $w \ && ($alignment($wi,F) == "Y" || $alignment($wi,F) == "B")} { return [lindex $wi 0] } return [get_next_top $wi] } proc process_alist {} { global align_list global alignment redo_align align_rec set prev "" foreach w $align_list { if ![winfo exists $w] {lremove align_list $w; continue} set aT $alignment($w,T) set aB $alignment($w,B) set aL $alignment($w,L) set aR $alignment($w,R) set aM $alignment($w,M) set aC $alignment($w,C) #echo >> $w t= $aT b= $aB r= $aR l= $aL set positioned 0 if {$aT == "T"} { a_place $w -y 0 set positioned T } elseif {$aT == "B"} { set positioned T set par [winfo parent $w] a_place $w -y [Winfo height $par 1] } elseif {$aT == "M"} { set positioned T set par [winfo parent $w] a_place $w -y [expr [Winfo height $par 1]/2] } elseif {$aT == "N"} { } else { set wi [lvarpop aT] set wi [to_widget $wi $w] if ![winfo exists $wi] {set aT N} if {$aT == "T"} { set positioned T a_place $w -y [Winfo y $wi] } elseif {$aT == "B"} { set positioned T a_place $w -y [expr [Winfo y $wi]+[Winfo height $wi]] } elseif {$aT == "M"} { set positioned T a_place $w -y [expr [Winfo y $wi]+[Winfo height $wi]/2] } } if {$positioned == 0} { set par [winfo parent $w] if {$aM == "M"} { a_place $w -y [expr [Winfo height $par 1]/2-[Winfo height $w]/2] set positioned M } elseif {$aM == "T"} { set positioned M a_place $w -y -[expr [Winfo height $w]/2] } elseif {$aM == "B"} { set positioned M a_place $w -y [expr [Winfo height $par 1]-[Winfo height $w]/2] } elseif {$aM == "N"} { } else { set wi [lvarpop aM] set wi [to_widget $wi $w] if ![winfo exists $wi] {set aM N} if {$aM == "M"} { set positioned M a_place $w -y [expr ([Winfo y $wi]+[Winfo height $wi]/2)-[Winfo height $w]/2] } elseif {$aM == "B"} { set positioned M a_place $w -y [expr ([Winfo y $wi]+[Winfo height $wi])-[Winfo height $w]/2] } elseif {$aM == "T"} { set positioned M a_place $w -y [expr [Winfo y $wi]-[Winfo height $w]/2] } } } if {$positioned == 0} { set par [winfo parent $w] if {$aB == "B"} { a_place $w -y [expr [Winfo height $par 1]-[Winfo height $w]] set positioned B } elseif {$aB == "T"} { set positioned B a_place $w -y -[Winfo height $w] } elseif {$aB == "M"} { set positioned B a_place $w -y [expr [Winfo height $par 1]/2-[Winfo height $w]/2] } elseif {$aB == "N"} { } else { set wi [lvarpop aB] set wi [to_widget $wi $w] if ![winfo exists $wi] {set aB N} if {$aB == "B"} { set positioned B a_place $w -y [expr [Winfo y $wi]+[Winfo height $wi]-[Winfo height $w]] } elseif {$aB == "T"} { set positioned B a_place $w -y [expr [Winfo y $wi]-[Winfo height $w]] } elseif {$aB == "M"} { set positioned B a_place $w -y [expr [Winfo y $wi]-[Winfo height $w]+[Winfo height $wi]/2] } } } set shaped 0 if {$positioned != "B" && ($alignment($w,F) == "N" || $alignment($w,F) == "X")} { #echo resize_parent $w 0 [expr [Winfo y $w]+[Winfo height $w]] if {$aB == "B"} { resize_parent $w 0 [expr [Winfo y $w]+[Winfo height $w]] } } elseif {$positioned != "B"} { #update set par [winfo parent $w] if {$aB == "B"} { set shaped B a_place $w -height [expr [Winfo height $par 1]-[Winfo y $w]] } elseif {$aB == "T"} { set shaped B a_place $w -height 0 } elseif {$aB == "M"} { set shaped B a_place $w -height [expr [Winfo height $par 1]/2-[Winfo y $w]] } elseif {$aB == "N"} { } else { set wi [lvarpop aB] set wi [to_widget $wi $w] if ![winfo exists $wi] {set aB N} if {$aB == "B"} { set shaped B a_place $w -height [expr [Winfo y $wi]+[Winfo height $wi]-[Winfo y $w]] } elseif {$aB == "T"} { set shaped B if {$alignment($w,F) == "B" || $alignment($w,F) == "Y"} { set wl [get_next_top $w] } else { set wl "" } if {$wl != ""} { #echo here ar = l $w $wl a_place $w -height [expr ([Winfo height $wl]+[Winfo height $w])/2] } elseif {$alignment($w,F) == "Y" || $alignment($w,F) == "B"} { a_place $w -height [expr [Winfo y $wi]-[Winfo y $w]] } else { #echo fixed $w #a_place $w -height [winfo reqheight $w] } } elseif {$aB == "M"} { set shaped B a_place $w -height [expr [Winfo y $wi]-[Winfo y $w]+[Winfo height $wi]/2] } } } if {$positioned != "M" && $shaped != "B"} { #update set par [winfo parent $w] if {$aM == "M"} { set shaped M a_place $w -height [expr [Winfo height $par 1]-[Winfo y $w]*2] } elseif {$aM == "T"} { set shaped M a_place $w -height 0 } elseif {$aM == "B"} { set shaped M a_place $w -height [expr ([Winfo height $par 1]-[Winfo y $w])*2] } elseif {$aM == "N"} { } else { set wi [lvarpop aM] set wi [to_widget $wi $w] if ![winfo exists $wi] {set aM N} if {$aM == "B"} { set shaped M a_place $w -height [expr ([Winfo y $wi]+[Winfo height $wi]-[Winfo y $w])*2] } elseif {$aM == "T"} { set shaped M a_place $w -height [expr ([Winfo y $wi]-[Winfo y $w])*2] } elseif {$aM == "M"} { set shaped M a_place $w -height [expr ([Winfo y $wi]-[Winfo y $w]+[Winfo height $wi]/2)*2] } } } set positioned 0 set shaped 0 if {$aL == "L"} { set positioned L a_place $w -x 0 } elseif {$aL == "R"} { set par [winfo parent $w] set positioned L a_place $w -x [Winfo width $par 1] } elseif {$aL == "C"} { set par [winfo parent $w] set positioned L a_place $w -x [expr [Winfo width $par 1]/2] } elseif {$aL == "N"} { } else { #echo $aL set wi [lvarpop aL] set wi [to_widget $wi $w] if ![winfo exists $wi] {set aL N} if {$aL == "L"} { set positioned L a_place $w -x [Winfo x $wi] } elseif {$aL == "R"} { set positioned L a_place $w -x [expr [Winfo x $wi]+[Winfo width $wi]] } elseif {$aL == "C"} { set positioned L a_place $w -x [expr [Winfo x $wi]+[Winfo width $wi]/2] } } if {$positioned == 0} { set par [winfo parent $w] if {$aC == "C"} { set positioned C a_place $w -x [expr [Winfo width $par 1]/2-[Winfo width $w]/2] } elseif {$aC == "L"} { set positioned C a_place $w -x -[expr [Winfo width $w]/2] } elseif {$aC == "R"} { set positioned C a_place $w -x [expr [Winfo width $par 1]-[Winfo width $w]/2] } elseif {$aC == "N"} { } else { set wi [lvarpop aC] set wi [to_widget $wi $w] if ![winfo exists $wi] {set aC N} if {$aC == "C"} { set positioned C a_place $w -x [expr ([Winfo x $wi]+[Winfo width $wi]/2)-[Winfo width $w]/2] } elseif {$aC == "R"} { set positioned C a_place $w -x [expr ([Winfo x $wi]+[Winfo width $wi])-[Winfo width $w]/2] } elseif {$aC == "L"} { set positioned C a_place $w -x [expr [Winfo x $wi]+[Winfo width $wi]/2] } } } if {$positioned == 0} { set par [winfo parent $w] if {$aR == "R"} { a_place $w -x [expr [Winfo width $par 1]-[Winfo width $w]] set positioned R } elseif {$aR == "L"} { set positioned R a_place $w -x -[Winfo width $w] } elseif {$aR == "C"} { set positioned R a_place $w -x [expr [Winfo width $par 1]/2-[Winfo width $w]/2] } elseif {$aR == "N"} { } else { set wi [lvarpop aR] set wi [to_widget $wi $w] if ![winfo exists $wi] {set aR N} if {$aR == "R"} { set positioned R a_place $w -x [expr [Winfo x $wi]+[Winfo width $wi]-[Winfo width $w]] } elseif {$aR == "L"} { set positioned R a_place $w -x [expr [Winfo x $wi]-[Winfo width $w]] } elseif {$aR == "C"} { set positioned R a_place $w -x [expr [Winfo x $wi]-[Winfo width $w]+[Winfo width $wi]/2] } } } if {$positioned != "R" && ($alignment($w,F) == "N" || $alignment($w,F) == "Y")} { if {$aR == "R"} {resize_parent $w [expr [Winfo x $w]+[Winfo width $w]] 0} } elseif {$positioned != "R"} { #update set par [winfo parent $w] if {$aR == "R"} { set shaped R a_place $w -width [expr [Winfo width $par 1]-[Winfo x $w]] } elseif {$aR == "L"} { set shaped R a_place $w -width 0 } elseif {$aR == "C"} { set shaped R a_place $w -width [expr [Winfo width $par 1]/2-[Winfo x $w]] } elseif {$aR == "N"} { set shaped R } else { set wi [lvarpop aR] set wi [to_widget $wi $w] if ![winfo exists $wi] {set aR N} if {$aR == "R"} { set shaped R a_place $w -width [expr [Winfo x $wi]+[Winfo width $wi]-[Winfo x $w]] } elseif {$aR == "L"} { set shaped R if {$alignment($w,F) == "B" || $alignment($w,F) == "X"} { set wl [get_next_left $w] } else {set wl ""} if {$wl != ""} { #echo here ar = l $w $wl a_place $w -width [expr ([Winfo width $wl]+[Winfo width $w])/2] } elseif {$alignment($w,F) == "X" || $alignment($w,F) == "B"} { a_place $w -width [expr [Winfo x $wi]-[Winfo x $w]] } else { #echo fixed $w #a_place $w -width [winfo reqwidth $w] } } elseif {$aR == "C"} { set shaped R a_place $w -width [expr [Winfo x $wi]-[Winfo x $w]+[Winfo width $wi]/2] } } } else { #update set par [winfo parent $w] if {$aC == "C"} { set shaped C a_place $w -width [expr [Winfo width $par 1]-[Winfo x $w]*2] } elseif {$aC == "L"} { set shaped C a_place $w -width 0 } elseif {$aC == "R"} { set shaped C a_place $w -width [expr ([Winfo width $par 1]-[Winfo x $w])*2] } elseif {$aC == "N"} { } else { set wi [lvarpop aC] set wi [to_widget $wi $w] if ![winfo exists $wi] {set aC N} if ![winfo exists $wi] {set alignment($w,C) N; return 1} if {$aC == "R"} { set shaped C a_place $w -width [expr ([Winfo x $wi]+[Winfo width $wi]-[Winfo x $w])*2] } elseif {$aC == "C"} { set shaped C a_place $w -width [expr [Winfo x $wi]-[Winfo x $w]] } elseif {$aC == "L"} { set shaped C a_place $w -width [expr ([Winfo x $wi]-[Winfo x $w])*2] } } } update } return 0 } proc show_edge {x y} { set w [winfo containing $x $y] if {$w == ""} {return "$w N"} set x [expr $x-[winfo rootx $w]] set y [expr $y-[winfo rooty $w]] set W4 [expr [winfo width $w]-4] set H4 [expr [winfo height $w]-4] if {[expr abs([winfo width $w]/2-$x)]<2 && ($y < 4 || $H4 < $y)} { return "$w C" } if {[expr abs([winfo height $w]/2-$y)]<2 && ($x < 4 || $W4 < $x)} { return "$w M" } if {$x < 4} {return "$w L"} if {$W4 < $x} {return "$w R"} if {$y < 4} {return "$w T"} if {$H4 < $y} {return "$w B"} return "$w N" } proc do_align {e1 e2} { echo $e1 $e2 set w1 [lvarpop e1] set w2 [lvarpop e2] if {[winfo parent $w2] == [winfo parent $w1]} { align $w1 -$e1 $e2 $w2 align info $w1 } elseif {[winfo parent $w1] == $w2} { align $w1 -$e1 $e2 align info $w1 } else { error "Bad widgets to align" } } proc get_edge {} { catch "destroy .showfeedback" menu .showfeedback set T .showfeedback.top toplevel $T wm geom $T +0-0 message $T.mes -text "Use mouse button one to select window edge.\nUse mouse button two to select where edge will align to.\nUse mouse button three to finish." -aspect 800 pack $T.mes label .showfeedback.l -text N -width 20 -relief raised pack .showfeedback.l .showfeedback post 0 0 grab .showfeedback set edge1 "" set edge2 "" bind .showfeedback { %W.l config -text [show_edge %X %Y] } bind .showfeedback <1> { set edge1 [show_edge %X %Y] } bind .showfeedback <2> { set edge2 [show_edge %X %Y] do_align $edge1 $edge2 } bind .showfeedback <3> { grab release .showfeedback catch "destroy .showfeedback" #do_align $edge1 $edge2 } } proc auto_align {w} { global Mx My set top .gui_m.aa catch "destroy $top" toplevel $top wm title $top "Auto Align" wm geom $top +$Mx+$My frame $top.f label $top.l -text "Select widgets to check" listbox $top.f.lb -width 10 -height 20 -yscroll "$top.f.sb set" bind $top.f.lb "do_flash %W" scrollbar $top.f.sb -command "$top.f.lb yview" $top.f.lb insert end "[winfo parent $w] [winfo class [winfo parent $w]]" foreach sib [winfo child [winfo parent $w]] { if {$sib == $w} continue $top.f.lb insert end "$sib [winfo class $sib]" } button $top.do -text "Do it." -command "auto_align_cb $w $top.f.lb" button $top.can -text "Cancel" -command "destroy $top" pack $top.l -fill x pack $top.f.lb -side left pack $top.f.sb -side right -fill y pack $top.f -fill both pack $top.can -fill x -side bottom pack $top.do -fill x -side bottom } proc auto_align_cb {w lb} { set sibs "" foreach wi [$lb curselection] { lappend sibs [lindex [$lb get $wi] 0] } do_auto_align $w $sibs } proc do_auto_align {w sibs} { global alignment set old_align [align info $w] set old_place [place info $w] set old_x [Winfo x $w] set old_y [Winfo y $w] set old_w [Winfo width $w] set old_h [Winfo height $w] set set_x 0 set set_y 0 set set_w 0 set set_h 0 set bg [get_widget_value $w background] $w configure -bg red update foreach sib $sibs { if {$sib == $w} continue if {$sib == [winfo parent $w]} {set sib ""} foreach e1 {T} { foreach e2 {T B M} { eval "place forget $w" eval "place $w $old_place" eval "align $w $old_align" eval "align $w -$e1 $e2 $sib" if {[expr abs([Winfo y $w]-$old_y)]<4} { echo align $w -$e1 $e2 $sib set set_y "align $w -$e1 $e2 $sib" set old_place [place info $w] set old_align [align info $w] set old_y [Winfo y $w] } } } eval "place forget $w" eval "place $w $old_place" eval "align $w $old_align" foreach e1 {B} { foreach e2 {T B M} { eval "place forget $w" eval "place $w $old_place" eval "align $w $old_align" eval "align $w -$e1 $e2 $sib" if {$set_y == 0} { if {[expr abs([Winfo y $w]-$old_y)]<4} { echo align $w -$e1 $e2 $sib set set_y "align $w -$e1 $e2 $sib" set old_place [place info $w] set old_align [align info $w] set old_y [Winfo y $w] } } else { if {$alignment($w,F)=="N" || $alignment($w,F)=="X"} continue if {[expr abs([Winfo height $w]-$old_h)]<4} { echo align $w -$e1 $e2 $sib set set_h "align $w -$e1 $e2 $sib" set old_place [place info $w] set old_align [align info $w] set old_h [Winfo height $w] } } } } eval "place forget $w" eval "place $w $old_place" eval "align $w $old_align" update if {$set_y == 0 || $set_h == 0} { foreach e1 {M} { foreach e2 {T B M} { eval "place forget $w" eval "place $w $old_place" eval "align $w $old_align" eval "align $w -$e1 $e2 $sib" if {$set_y == 0} { if {[expr abs([Winfo y $w]-$old_y)]<4} { echo align $w -$e1 $e2 $sib set set_y "align $w -$e1 $e2 $sib" set old_place [place info $w] set old_align [align info $w] set old_y [Winfo y $w] } } else { if {$alignment($w,F)=="N" || $alignment($w,F)=="X"} continue if {[expr abs([Winfo height $w]-$old_h)]<4} { echo align $w -$e1 $e2 $sib set set_h "align $w -$e1 $e2 $sib" set old_place [place info $w] set old_align [align info $w] set old_h [Winfo height $w] } } } } } eval "place forget $w" eval "place $w $old_place" eval "align $w $old_align" update foreach e1 {L} { foreach e2 {L R C} { eval "place forget $w" eval "place $w $old_place" eval "align $w $old_align" eval "align $w -$e1 $e2 $sib" if {[expr abs([Winfo x $w]-$old_x)]<4} { echo align $w -$e1 $e2 $sib set set_x "align $w -$e1 $e2 $sib" set old_place [place info $w] set old_align [align info $w] set old_x [Winfo x $w] } } } eval "place forget $w" eval "place $w $old_place" eval "align $w $old_align" update foreach e1 {R} { foreach e2 {L R C} { eval "place forget $w" eval "place $w $old_place" eval "align $w $old_align" eval "align $w -$e1 $e2 $sib" if {$set_x == 0} { if {[expr abs([Winfo x $w]-$old_x)]<4} { echo align $w -$e1 $e2 $sib set set_x "align $w -$e1 $e2 $sib" set old_place [place info $w] set old_align [align info $w] set old_x [Winfo x $w] } } else { if {$alignment($w,F)=="N" || $alignment($w,F)=="Y"} continue if {[expr abs([Winfo width $w]-$old_w)]<4} { echo align $w -$e1 $e2 $sib set set_w "align $w -$e1 $e2 $sib" set old_place [place info $w] set old_align [align info $w] set old_w [Winfo width $w] } } } } eval "place forget $w" eval "place $w $old_place" eval "align $w $old_align" update if {$set_x == 0 || $set_w == 0} { foreach e1 {C} { foreach e2 {L R C} { eval "place forget $w" eval "place $w $old_place" eval "align $w $old_align" eval "align $w -$e1 $e2 $sib" if {$set_x == 0} { if {[expr abs([Winfo x $w]-$old_x)]<4} { echo align $w -$e1 $e2 $sib set set_x "align $w -$e1 $e2 $sib" set old_place [place info $w] set old_align [align info $w] set old_x [Winfo x $w] } } else { if {$alignment($w,F)=="N" || $alignment($w,F)=="Y"} continue if {[expr abs([Winfo width $w]-$old_w)]<4} { echo align $w -$e1 $e2 $sib set set_w "align $w -$e1 $e2 $sib" set old_place [place info $w] set old_align [align info $w] set old_w [Winfo width $w] } } } } } } eval "place forget $w" eval "place $w $old_place" eval "align $w $old_align" $w configure -bg $bg } proc widest {args} { set max 0 set maxw [lindex $args 0] foreach w $args { if ![winfo exists $w] continue set wid [expr [Winfo width $w]+[Winfo x $w]] if {$wid > $max} { set max $wid set maxw $w } } return $maxw } proc lowest {args} { set max 0 set maxw [lindex $args 0] foreach w $args { if ![winfo exists $w] continue set wid [expr [Winfo height $w]+[Winfo y $w]] if {$wid > $max} { set max $wid set maxw $w } } return $maxw } proc to_widget {wi sib} { if ![winfo exists $wi] { set try [winfo parent $sib].$wi if [winfo exists $try] {return $try} set try [winfo parent $sib]$wi if [winfo exists $try] {return $try} #echo $wi if {[catch "set try \[$wi\]"]==0} {return $try} return "N" } return $wi } ############### # end common.tcl section ############### ############### # begin httpd.tcl section ############### #---------- # httpd_start - initiate the httpd server proc httpd_start {} { global HTTPD # -- create/overwrite the pid file set pidfd [open $HTTPD(pid_file) w] puts $pidfd "[pid]" flush $pidfd close $pidfd set outfd "dummy" # -- create a listening socket if {[catch "socket -server [list "httpd_accept $HTTPD(serversocket)"] $HTTPD(serversocket)" outfd]} { puts stderr "webservr: Unable to open a server socket" catch "close $outfd" exit 1 } if {[string range $outfd 0 3] != "sock"} { puts stderr "webservr: Unable to open a server socket" catch "close $outfd" exit 1 } } #---------- # httpd_accept -- accepts a client connection to http server proc httpd_accept {listener sock addr port} { global HTTPD set HTTPD(serverfd) $sock set HTTPD($sock~~clientipaddr) $addr incr HTTPD(activesessions) # -- open log files, append write mode if {$HTTPD(use_log_files)} { set HTTPD($sock~~errorfd) [open $HTTPD(error_log) a] set HTTPD($sock~~accessfd) [open $HTTPD(access_log) a] set HTTPD($sock~~agentfd) [open $HTTPD(agent_log) a] } if {[catch "fconfigure $sock -translation auto"]} { httpd_log_error $sock "$sock connection abnormally terminated in httpd_accept" httpd_cleanup_connection $sock catch "fileevent $sock readable {}" catch "close $sock" } if {[catch "fileevent $sock readable [list "httpd_process_request $sock"]"]} { httpd__error $sock "$sock connection abnormally terminated in httpd_accept" httpd_cleanup_connection $sock } } #---------- # httpd_cleanup_connection -- clean up internal state, remove handlers proc httpd_cleanup_connection {sock} { global HTTPD incr HTTPD(activesessions) -1 if {$HTTPD(use_log_files)} { close $HTTPD($sock~~errorfd) close $HTTPD($sock~~agentfd) close $HTTPD($sock~~accessfd) } foreach element [array names HTTPD $sock~~*] { unset HTTPD($element) } } #---------- # httpd_process_request -- manage the server side conversion to a client proc httpd_process_request {sock} { global HTTPD set HTTPD($sock~~headf) 0 # -- read and process the client's request set done 0 set request "" while {!$done} { if {[catch "gets $sock" line]} { httpd__error $sock "$sock connection abnormally terminated in httpd_process_request" httpd_cleanup_connection $sock catch "fileevent $sock readable {}" catch "close $sock" } if {[string length "$line"] == 0} { set done 1 } else { append request "$line\n" } } foreach line [split $request "\n"] { switch -glob -- [string tolower [lindex $line 0]] { get { set HTTPD($sock~~headf) 0 set url [lindex $line 1] set path [split $url "/"] if {[lindex $path 0] == ""} {set path [lrange $path 1 end]} # -- handle request for a WRB instead of from file if {[string tolower [lindex $path 0]] != "wrb"} { set path [lrange $path 0 end] set HTTPD($sock~~file) [eval file join [file split $HTTPD(webdir)] $path] if {[file isdirectory $HTTPD($sock~~file)]} { set HTTPD($sock~~file) [eval file join [file split $HTTPD($sock~~file)] "index.html"] } # -- see if the file exists and can be read if {(![file exists $HTTPD($sock~~file)]) || \ (![file readable $HTTPD($sock~~file)]) || \ ([file isdirectory $HTTPD($sock~~file)])} { httpd_log_access $sock $HTTPD($sock~~clientipaddr) "$line" 404 0 httpd_log_error $sock "access to $url failed for $HTTPD($sock~~clientipaddr), reason: No valid filename matching URL: $url from -" httpd_not_found $sock "$line" if {[catch "flush $sock"]} { httpd__error $sock "$sock connection abnormally terminated in httpd_process_request" httpd_cleanup_connection $sock catch "fileevent $sock readable {}" catch "close $sock" } catch "fileevent $sock readable {}" catch "close $sock" httpd_cleanup_connection $sock return } # -- see if the file goes outside of the webdir path set path [file split [eval file join [file split $HTTPD(webdir)] [file split $HTTPD($sock~~file)]]] set outpath "" foreach item $path { switch -exact -- $item { . {} .. { set outpath [lrange $outpath 0 [expr [llength $outpath] - 2]] } default {lappend outpath $item} } } set HTTPD($sock~~file) [eval file join [split $outpath " "]] # -- prohibit the fetching of the log files set filename [lindex [file split $HTTPD($sock~~file)] end] if {$filename == "access.log" || \ $filename == "error.log" || \ $filename == "agent.log"} { httpd_log_access $sock $HTTPD($sock~~clientipaddr) "$line" 404 0 httpd_log_error $sock "access to $url failed for $HTTPD($sock~~clientipaddr), reason: No valid filename matching URL: $url from -" httpd_not_found $sock "$line" if {[catch "flush $sock"]} { httpd__error $sock "$sock connection abnormally terminated in httpd_process_request" httpd_cleanup_connection $sock catch "fileevent $sock readable {}" catch "close $sock" } catch "fileevent $sock readable {}" catch "close $sock" httpd_cleanup_connection $sock return } if {[string first $HTTPD(webdir) $HTTPD($sock~~file)] == -1} { # -- the path specified goes outside of the hierarchy httpd_log_access $sock $HTTPD($sock~~clientipaddr) "$line" 404 0 httpd_log_error $sock "access to $url failed for $HTTPD($sock~~clientipaddr), reason: No valid filename matching URL: $url from -" httpd_not_found $sock "$line" if {[catch "flush $sock"]} { httpd__error $sock "$sock connection abnormally terminated in httpd_process_request" httpd_cleanup_connection $sock catch "fileevent $sock readable {}" catch "close $sock" } catch "fileevent $sock readable {}" catch "close $sock" httpd_cleanup_connection $sock return } set text "" httpd_log_access $sock $HTTPD($sock~~clientipaddr) "$line" 200 [string length "$text"] httpd_send_it $sock $HTTPD($sock~~file) "" } else { set HTTPD($sock~~file) "" if {[string last "/" $url]} {set url "/$url"} set key [string range $url [expr [string last "/" $url] + 1] \ [expr [string length $url] - 1]] if {"$key" == ""} {set key "index.html"} set text "[WRBgetsource "$key"]" if {[lsearch [WRBkeylist] "$key"] == -1 || "$text" == ""} { httpd_log_access $sock $HTTPD($sock~~clientipaddr) "$line" 404 0 httpd_log_error $sock "access to $url failed for $HTTPD($sock~~clientipaddr), reason: No keyname matching URL: $url from -" httpd_not_found $sock "$line" if {[catch "flush $sock"]} { httpd__error $sock "$sock connection abnormally terminated in httpd_process_request" httpd_cleanup_connection $sock catch "fileevent $sock readable {}" catch "close $sock" } catch "fileevent $sock readable {}" catch "close $sock" httpd_cleanup_connection $sock return } httpd_log_access $sock $HTTPD($sock~~clientipaddr) "$line" 200 [string length "$text"] httpd_send_it $sock $key $text } } head { set HTTPD($sock~~headf) 1 set url [lindex $line 1] if {[string last "/" $url]} {set url "/$url"} set key [string range $url [expr [string last "/" $url] + 1] \ [expr [string length $url] - 1]] if {"$key" == ""} {set key "index.html"} set text "[WRBgetsource "$key"]" if {[lsearch [WRBkeylist] "$key"] == -1 || "$text" == ""} { httpd_log_access $sock $HTTPD($sock~~clientipaddr) "$line" 404 0 httpd_log_error $sock "access to $url failed for $HTTPD($sock~~clientipaddr), reason: No keyname matching URL: $url from -" httpd_not_found $sock "$url" if {[catch "flush $sock"]} { httpd__error $sock "$sock connection abnormally terminated in httpd_process_request" httpd_cleanup_connection $sock catch "fileevent $sock readable {}" catch "close $sock" } catch "fileevent $sock readable {}" catch "close $sock" httpd_cleanup_connection $sock return } httpd_log_access $sock $HTTPD($sock~~clientipaddr) "$line" 200 [string length "$text"] httpd_send_it $sock $key "$text" } user-agent: { httpd_log_agent $sock "[lrange $line 1 end]" } default {} } } close $sock httpd_cleanup_connection $sock } #---------- # httpd_not_found -- return item not found message proc httpd_not_found {sock item} { set d [clock format [clock seconds] -gmt 1] catch "fconfigure $sock -translation crlf -buffering full" catch "puts $sock [list "HTTP/1.0 404 Not Found"]" catch "puts $sock [list "Date: $d"]" catch "puts $sock [list "Server: webservr/1.0"]" catch "puts $sock [list "Content-type: text/html"]" catch "puts $sock {}" catch "puts $sock [list " 404 Not Found "]" catch "puts $sock [list "404 Not Found
"]" catch "puts $sock [list "The requested URL $item was not found on this server."]" catch "puts $sock [list ""]" if {[catch "flush $sock"]} { httpd__error $sock "$sock connection abnormally terminated in httpd_process_request" httpd_cleanup_connection $sock catch "fileevent $sock readable {}" catch "close $sock" } } #---------- # httpd_bad_request -- return bad request message proc httpd_bad_request {sock item} { set d [clock format [clock seconds] -gmt 1] catch "fconfigure $sock -translation crlf -buffering full" catch "puts $sock [list "HTTP/1.0 400 Bad Request"]" catch "puts $sock [list "Date: $d"] catch "puts $sock [list "Server: webservr/1.0"]" catch "puts $sock [list "Content-type: text/html"]" catch "puts $sock {}" catch "puts $sock [list "400 Bad Request "]" catch "puts $sock [list "400 Bad Request
"]" catch "puts $sock [list "Your client sent a query that this server could"]" catch "puts $sock [list "not understand."]" catch "puts $sock [list "Reason: Invalid or unsupported method.
"]" catch "puts $sock [list ""]" if {[catch "flush $sock"]} { httpd__error $sock "$sock connection abnormally terminated in httpd_process_request" httpd_cleanup_connection $sock catch "fileevent $sock readable {}" catch "close $sock" } } #---------- # httpd_send_it -- send the requested item to the client proc httpd_send_it {sock key item} { global HTTPD if {$HTTPD($sock~~file) != "" && "$item" == ""} { # -- file processing set HTTPD($sock~~itemlen) [file size $HTTPD($sock~~file)] set HTTPD($sock~~item) "" } else { set HTTPD($sock~~item) "[lindex $item 0]" set HTTPD($sock~~itemlen) [string length "$HTTPD($sock~~item)"] } set d [clock format [clock seconds] -gmt 1] catch "fconfigure $sock -translation crlf -buffering full" catch "puts $sock [list "HTTP/1.0 200 Document follows"]" catch "puts $sock [list "Date: $d"]" catch "puts $sock [list "Server: webservr/1.0"]" set ext [string tolower [string range [file extension $key] 1 end]] if {[info exists HTTPD(mime~~$ext)]} { catch "puts $sock [list "Content-type: $HTTPD(mime~~$ext)"]" } else { catch "puts $sock [list "Content-type: text/html"]" } catch "puts $sock [list "Last-modified: $d"]" catch "puts $sock [list "Content-length: $HTTPD($sock~~itemlen)"]" catch "puts $sock {}" if {[catch "flush $sock"]} { httpd__error $sock "$sock connection abnormally terminated in httpd_process_request" httpd_cleanup_connection $sock catch "fileevent $sock readable {}" catch "close $sock" } #--------- Open and read the file and copy it to the socket ----------- if {!$HTTPD($sock~~headf)} { if {$HTTPD($sock~~file) == $key && $item == ""} { catch "fconfigure $sock -translation binary -buffering full -blocking 1" catch "open $HTTPD($sock~~file) r" fd catch "fconfigure $fd -translation binary -buffering full -blocking 1" if {[catch {fcopy $fd $sock} oops]} { httpd__error $sock "$sock connection abnormally terminated in httpd_process_request" httpd_cleanup_connection $sock catch "fileevent $sock readable {}" catch "close $sock" } catch "close $fd" set HTTPD($sock~~donef) 1 } else { # -- send the requested WRB item in 4K chunks set HTTPD($sock~~donef) 0 catch "fconfigure $sock -translation lf" catch "fconfigure $sock -buffering full" while {$HTTPD($sock~~itemlen) > 0} { httpd_send_buf $sock } } unset HTTPD($sock~~donef) unset HTTPD($sock~~item) unset HTTPD($sock~~itemlen) unset HTTPD($sock~~headf) } } #---------- # httpd_send_buf -- transmit a buffer when the channel is writable proc httpd_send_buf {sock} { global HTTPD if {$HTTPD($sock~~itemlen) > 0} { if {$HTTPD($sock~~itemlen) > 32768} { set last 32767 } else { set last [expr $HTTPD($sock~~itemlen) - 1] } set buf "[string range "$HTTPD($sock~~item)" 0 $last]" catch "puts -nonewline $sock [list "$buf"]" if {[catch "flush $sock"]} { httpd__error $sock "$sock connection abnormally terminated in httpd_process_request" httpd_cleanup_connection $sock catch "fileevent $sock readable {}" catch "close $sock" } set HTTPD($sock~~item) "[string range $HTTPD($sock~~item) [expr $last + 1] [expr $HTTPD($sock~~itemlen) - 1]]" incr HTTPD($sock~~itemlen) -[expr $last + 1] if {$HTTPD($sock~~itemlen) <= 0} { set HTTPD($sock~~donef) 1 } } } #---------- # httpd_log_error - put an error message in the error log file proc httpd_log_error {sock message} { global HTTPD set d [clock format [clock seconds] -gmt 1] if {$HTTPD(use_log_files)} { puts $HTTPD($sock~~errorfd) "\[$d\] webservr: $message" flush $HTTPD($sock~~errorfd) } else { puts stderr "\[$d\] webservr: $message" } } #---------- # httpd_log_access - put an access entry into the access log proc httpd_log_access {sock ip getmessage code length} { global HTTPD set d [clock format [clock seconds] -gmt 1] if {$HTTPD(use_log_files)} { puts $HTTPD($sock~~accessfd) "$ip - - \[$d\] \"$getmessage\" $code $length" flush $HTTPD($sock~~accessfd) } } #---------- # httpd_log_agent - put an entry into the agent log proc httpd_log_agent {sock agent} { global HTTPD if {$HTTPD(use_log_files)} { puts $HTTPD($sock~~agentfd) "$agent" flush $HTTPD($sock~~agentfd) } } ############### # end httpd.tcl section ###############