/[cvs]/wolfpack/wolfpack.tcl
ViewVC logotype

Annotation of /wolfpack/wolfpack.tcl

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph


Revision 1.1 - (hide annotations) (download) (as text)
Mon Mar 19 04:16:07 2001 UTC (18 years, 3 months ago) by guppy
Branch: MAIN
Branch point for: wolfpack
File MIME type: application/x-tcl
Initial revision

1 guppy 1.1 #! /bin/sh
2     # \
3     # Nice little hack to find latest version of tclsh in PATH \
4     # \
5     # NOTE: backslash and semicolon placements are important! \
6     # \
7     # Search for tclsh[0-9].[0-9] in each valid dir in PATH \
8     for dir in $(echo $PATH | sed 's/:/ /g'); \
9     do \
10     if test -d $dir; \
11     then \
12     files=$(/bin/ls $dir | egrep '^tclsh[0-9]\.[0-9]$'); \
13     if test "$files" != ""; \
14     then \
15     versions="${versions:+$versions }$(echo $files | sed 's/tclsh//g')"; \
16     fi; \
17     fi; \
18     done; \
19     # Loop over each version to find the latest version of tclsh \
20     for ver in $versions; \
21     do \
22     tmpver=$(echo $ver | sed 's/\.//g'); \
23     if test "$lasttmpver" != ""; \
24     then \
25     if test "$tmpver" -gt "$lasttmpver"; \
26     then \
27     lastver=$ver; \
28     lasttmpver=$tmpver; \
29     fi; \
30     else \
31     lastver=$ver; \
32     lasttmpver=$tmpver; \
33     fi; \
34     done; \
35     # Use the latest tclsh version found, otherwise fall back to 'tclsh' \
36     exec tclsh$lastver "$0" "$@"
37     ###############################################################################
38     ##
39     ## Wolfpack - A modular Tcl system for Eggdrop 1.3.0+ with Tcl 8.0+
40     ## Copyright (C) 1998-2000 Tothwolf <tothwolf@concentric.net>
41     ##
42     ## This program is free software; you can redistribute it and/or modify
43     ## it under the terms of the GNU General Public License as published by
44     ## the Free Software Foundation; either version 2 of the License, or
45     ## (at your option) any later version.
46     ##
47     ## This program is distributed in the hope that it will be useful,
48     ## but WITHOUT ANY WARRANTY; without even the implied warranty of
49     ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
50     ## GNU General Public License for more details.
51     ##
52     ## You should have received a copy of the GNU General Public License
53     ## along with this program; if not, write to the Free Software
54     ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
55     ##
56     ###############################################################################
57     ##
58     ## You should not need to edit anything in any of these files.
59     ##
60     ## './wolfpack.tcl -c' will allow you to configure initial settings.
61     ## './wolfpack.tcl --help' will list all avaliable options.
62     ##
63     ## Use '.wpconf' in dcc chat with the bot to set everything else.
64     ##
65     ###############################################################################
66     ##
67     ## $Id: wolfpack.tcl,v 1.109 2000/12/23 02:53:58 tothwolf Exp $
68     ##
69    
70     # make sure Tcl version is compatible with this code (we use namespaces)
71     if {[catch {package require Tcl 8.0}]} then {
72     if {[info exists argv0]} then {
73     puts "Wolfpack: Error: wolfpack requires Tcl 8.0 or later to load."
74     } else {
75     putloglev o * "Wolfpack: Error: wolfpack requires Tcl 8.0 or later to load."
76     }
77     return 0
78     }
79    
80     namespace eval :: {
81    
82     # Eggdrop doesn't currently set argv0, so we use that to detect load type.
83     global argv0
84    
85     if {![info exists argv0]} then {
86     # quick hack for buggy tcl variables in older bots
87     catch {set version}
88     catch {set numversion}
89     # require eggdrop 1.3.0 or later
90     if {(![info exists version]) || (![info exists numversion]) || \
91     ($numversion < 1030000)} then {
92     putloglev o * "Wolfpack: Error: wolfpack requires Eggdrop 1.3.0 or later to load."
93     return 0
94     }
95     } else {
96     # emulate eggdrop's putloglev when loading with tclsh
97     if {![string compare "" [info commands putloglev]]} then {
98     proc putloglev {level channel text} {
99     puts $text
100     }
101     }
102     }
103    
104     ##
105     ## Log tcl messages where they can be seen
106     ##
107     ## Args: text
108     ## Returns: nothing
109     ##
110     proc tclLog {text} {
111     # Tcl's tclLog embeds newlines in it's output
112     if {[string first \n $text] == -1} then {
113     putloglev o * "Wolfpack: \[Tcl\]: $text"
114     } else {
115     foreach line [split $text \n] {
116     putloglev o * "Wolfpack: \[Tcl\]: $line"
117     }
118     }
119     return
120     }
121    
122     } ;# namespace ::
123    
124     namespace eval ::wp {
125    
126     # manage package information
127     package forget ::wp
128     package provide ::wp 1.9.9.0
129    
130     # set namespace variable
131     set NamespaceCurrent [namespace current]
132    
133     ##
134     ## WARNING: If you change these, you may render your module database useless!
135     ##
136    
137     # Max number of lines to scan in a module file
138     set moduleDatabaseConfig(scanlines) 30
139    
140     # Max depth to list directories in module path
141     set moduleDatabaseConfig(maxdepth) 4
142    
143     # Module database version
144     set moduleDatabaseConfig(version) 2.0
145    
146     # Module database header
147     set moduleDatabaseConfig(header) "Wolfpack module database "
148    
149     # Module database defaults
150     set moduleDatabaseConfig(defaults) "{version 0.1} {description {(no description)}} {load 0}"
151    
152     # Versioned module database formats
153     array set moduleDatabaseFormat {
154     2.0 "{version config help description provides requires} {load file md5sum}"
155     }
156    
157     # md5 style, command name and result string index
158     array set md5Format {
159     bsd "md5 3"
160     gnu "md5sum 0"
161     }
162    
163     # Configuration file
164     set configDefaults(cfgfile) wolfpack.conf
165    
166     # Interactive configuration prompt
167     set configDefaults(prompt) "wolfpack> "
168    
169     # Configuration data defaults
170     array set configDataDefaults {
171     modulepath modules/
172     configpath wpconf/
173     datapath wpdata/
174     helppath wphelp/
175     moddbfile wolfpack.db
176     rebuild 1
177     verbose 0
178     time 0
179     }
180    
181     # Configuration data descriptions
182     array set configDataDesc {
183     modulepath "Module path"
184     configpath "Config path"
185     datapath "Data path"
186     helppath "Help path"
187     moddbfile "Module database"
188     rebuild "Automatically rebuild database"
189     verbose "Verbose operation"
190     time "Time database compare and rebuild"
191     }
192    
193     # Command line option defaults
194     array set optionData {
195     config 0
196     rebuild 0
197     norebuild 0
198     time 0
199     verbose 0
200     quiet 0
201     debug 0
202     }
203    
204     # Exported commands
205     set ExportList {
206     md5Sum
207     md5Init
208     replaceExpr
209     listFiles
210     listSubdirs
211     findFiles
212     createFile
213     createDir
214     backupFile
215     listSave
216     listLoad
217     arraySave
218     arrayLoad
219     arraySetAll
220     arrayFindElementName
221     arrayMaxElementDataLength
222     listMaxElementLength
223     arraySearch
224     dataFormatDefault
225     dataFormatValue
226     dataFormatReplace
227     dataFormatBuild
228     dataFormatConvert
229     scanModule
230     getModuleDatabaseData
231     setModuleDatabaseData
232     saveModuleDatabase
233     loadModuleDatabase
234     compareModuleDatabase
235     rebuildModuleDatabase
236     listModules
237     moduleExists
238     moduleLoaded
239     moduleLoad
240     moduleUnload
241     moduleConfig
242     moduleConfigList
243     moduleData
244     moduleDataList
245     buildCommandTable
246     whichCommand
247     whichModule
248     whichModuleCommand
249     compareVersion
250     wpLog
251     }
252    
253     ##
254     ## Create md5 checksum for a file
255     ##
256     ## Args: filename
257     ## Returns: md5 checksum if successful
258     ## Errors: permission denied,
259     ## no such file,
260     ## not a file,
261     ## can't exec md5 command
262     ##
263     proc md5Sum {file} {
264     variable md5Config
265    
266     if {![file exists $file]} then {
267     error "$file: no such file"
268     } else {
269     if {![file isfile $file]} then {
270     error "$file: not a file"
271     } else {
272     if {![file readable $file]} then {
273     error "$file: permission denied"
274     } else {
275     if {[catch {set sum [lindex [exec $md5Config(command) $file] $md5Config(index)]} result]} then {
276     error "$file: $result"
277     } else {
278     return $sum
279     }
280     }
281     }
282     }
283     }
284    
285     ##
286     ## Init md5 command
287     ##
288     ## Args: none
289     ## Returns: 1 if a useable md5 command found
290     ## 0 otherwise
291     ##
292     proc md5Init {} {
293     variable md5Config
294     variable md5Format
295    
296     foreach type [array names md5Format] {
297     foreach {command index} $md5Format($type) {break}
298     if {([catch {exec $command ""} result]) && \
299     (![regexp -- "^couldn't execute" $result])} then {
300     set md5Config(command) $command
301     set md5Config(index) $index
302     return 1
303     }
304     }
305     return 0
306     }
307    
308     ##
309     ## Replace all occurances of an expression in a string with the given text
310     ##
311     ## Args: string, expr, replacement text
312     ## Returns: string
313     ##
314     proc replaceExpr {string expr {replace ""}} {
315     while {[regexp -nocase -- $expr $string]} {
316     regsub -all -- $expr $string $replace string
317     }
318     return $string
319     }
320    
321     ##
322     ## List files in a path
323     ##
324     ## Args: path
325     ## Returns: list of files in the given path,
326     ## nothing if no files in the given path
327     ## Errors: permission denied,
328     ## no such directory,
329     ## not a directory
330     ##
331     proc listFiles {path} {
332     if {![file exists $path]} then {
333     error "$path: no such directory"
334     } else {
335     if {![file isdirectory $path]} then {
336     error "$path: not a directory"
337     } else {
338     if {![file readable $path]} then {
339     error "$path: permission denied"
340     } else {
341     set ret ""
342     foreach name [lsort [glob -nocomplain -- [file join $path *]]] {
343     if {[file isfile $name]} then {
344     lappend ret $name
345     }
346     }
347     return $ret
348     }
349     }
350     }
351     }
352    
353     ##
354     ## List subdirs in a path
355     ##
356     ## Args: path
357     ## Returns: list of subdirs in the given path,
358     ## nothing if no subdirs in the given path
359     ## Errors: permission denied,
360     ## no such directory,
361     ## not a directory
362     ##
363     proc listSubdirs {path} {
364     if {![file exists $path]} then {
365     error "$path: no such directory"
366     } else {
367     if {![file isdirectory $path]} then {
368     error "$path: not a directory"
369     } else {
370     if {![file readable $path]} then {
371     error "$path: permission denied"
372     } else {
373     set ret ""
374     foreach name [lsort [glob -nocomplain -- [file join $path *]]] {
375     if {[file isdirectory $name]} then {
376     lappend ret $name
377     }
378     }
379     return $ret
380     }
381     }
382     }
383     }
384    
385     ##
386     ## List files with a set ext in a path and its subdirs up to a set depth
387     ##
388     ## Args: path, max search depth, file extension
389     ## Returns: list of files with a set ext in the given path and its subdirs,
390     ## nothing if no matching files are found
391     ##
392     proc findFiles {path depth {ext ""}} {
393     set ret ""
394     set foundDirs "$path "
395     set searchDirs $path
396     for {
397     set currentDepth 0
398     } {($currentDepth <= $depth) || (!$depth)} {
399     incr currentDepth
400     } {
401     set subDirs ""
402     foreach dir $searchDirs {
403     if {[catch {set dirList [listSubdirs $dir]} result]} then {
404     wpLog o * "Error: unable to get file listing: $result"
405     } elseif {[string compare "" $dirList]} then {
406     append subDirs $dirList " "
407     }
408     }
409     if {![string compare "" $subDirs]} then {
410     break
411     }
412     append foundDirs $subDirs " "
413     set searchDirs $subDirs
414     }
415     foreach dir $foundDirs {
416     if {[catch {set files [listFiles $dir]} result]} then {
417     wpLog o * "Error: unable to get file listing: $result"
418     } else {
419     if {[string compare "" $ext]} then {
420     foreach file $files {
421     if {![string compare $ext \
422     [string tolower [file extension $file]]]} then {
423     lappend ret $file
424     }
425     }
426     } else {
427     set ret $files
428     }
429     }
430     }
431     return $ret
432     }
433    
434     ##
435     ## Check if a file exists, and create it if not
436     ##
437     ## Args: filename, verbose {-1,0,1}, description, force new file
438     ## Returns: 1 if the file was created successfully
439     ## 0 if the operation failed
440     ## -1 if the file already exists
441     ##
442     proc createFile {file {verbose 0} {desc "file "} {force 0}} {
443     if {($force) || (![file exists $file])} then {
444     if {[catch {set fd [open $file w]} result]} then {
445     if {$verbose >= 0} then {
446     wpLog o * "Error: unable to create ${desc}`[file tail $file]': $result"
447     }
448     } else {
449     if {(!$force) && ($verbose >= 1)} then {
450     wpLog o * "Warning: ${desc}`[file tail $file]' does not exist -- creating"
451     }
452     close $fd
453     return 1
454     }
455     } elseif {[file isfile $file]} then {
456     return -1
457     } elseif {$verbose >= 0} then {
458     wpLog o * "Error: not a file: $file"
459     }
460     return 0
461     }
462    
463     ##
464     ## Check if a directory exists, and create it if not
465     ##
466     ## Args: directory, verbose {-1,0,1}, description
467     ## Returns: 1 if the directory was created successfully
468     ## 0 if the operation failed
469     ## -1 if the directory already exists
470     ##
471     proc createDir {dir {verbose 0} {desc "directory "}} {
472     if {![file exists $dir]} then {
473     if {[catch {file mkdir $dir} result]} then {
474     if {$verbose >= 0} then {
475     wpLog o * "Error: unable to create ${desc}`[file tail $dir]': $result"
476     }
477     } else {
478     if {$verbose >= 1} then {
479     wpLog o * "Warning: ${desc}`[file tail $dir]' does not exist -- creating"
480     }
481     return 1
482     }
483     } elseif {[file isdirectory $dir]} then {
484     return -1
485     } elseif {$verbose >= 0} then {
486     wpLog o * "Error: not a directory: $dir"
487     }
488     return 0
489     }
490    
491     ##
492     ## Create a backup of the given file with an optional suffix
493     ##
494     ## Args: filename, suffix, verbose {-1,0,1}
495     ## Returns: 1 if successful
496     ## 0 otherwise
497     ##
498     proc backupFile {file {verbose 0} {suffix ~bak}} {
499     variable NamespaceCurrent
500    
501     if {[string compare "" $suffix]} then {
502     if {[catch {
503     if {[file size $file]} then {
504     file copy -force $file $file${suffix}
505     }
506     } result]} then {
507     if {$verbose >= 0} then {
508     wpLog o * $NamespaceCurrent "Error: unable to create backup file for `[file tail $file]': $result"
509     }
510     } else {
511     return 1
512     }
513     }
514     return 0
515     }
516    
517     ##
518     ## Save data from a list into a file
519     ##
520     ## Args: list, filename, verbose {-1,0,1}, description, access flag
521     ## Returns: 1 is successful,
522     ## 0 otherwise
523     ##
524     proc listSave {listName file {verbose 0} {desc "file "} {access w}} {
525     upvar 1 $listName list
526    
527     if {[createFile $file $verbose $desc]} then {
528     if {[catch {set fd [open $file $access]} result]} then {
529     if {$verbose >= 0} then {
530     wpLog o * "Error: unable to open ${desc}`$file' for writing: $result"
531     }
532     } else {
533     if {[info exists list]} then {
534     foreach data $list {
535     puts $fd [list $data]
536     }
537     }
538     close $fd
539     return 1
540     }
541     }
542     return 0
543     }
544    
545     ##
546     ## Load data into a list from a file
547     ##
548     ## Args: list, filename, verbose {-1,0,1}, description, ignore regsub
549     ## Returns: 1 if successful,
550     ## 0 otherwise
551     ##
552     proc listLoad {listName file {verbose 0} {desc "file "} {ignore "^#"}} {
553     upvar 1 $listName list
554    
555     if {[createFile $file $verbose $desc]} then {
556     if {[catch {set fd [open $file r]} result]} then {
557     if {$verbose >= 0} then {
558     wpLog o * "Error: unable to open ${desc}`$file' for reading: $result"
559     }
560     } else {
561     if {[info exists list]} then {
562     unset list
563     }
564     while {![eof $fd]} {
565     set line [replaceExpr [gets $fd] "^ "]
566     if {([string compare "" $line]) && \
567     (![regexp -- $ignore $line])} then {
568     append list $line " "
569     }
570     }
571     close $fd
572     return 1
573     }
574     }
575     return 0
576     }
577    
578     ##
579     ## Save data from an array info a file
580     ##
581     ## Args: array, filename, verbose {-1,0,1}, description, access flag
582     ## Returns: 1 is successful,
583     ## 0 otherwise
584     ##
585     proc arraySave {arrayName file {verbose 0} {desc "file "} {access w}} {
586     upvar 1 $arrayName array
587    
588     if {[createFile $file $verbose $desc]} then {
589     if {[catch {set fd [open $file $access]} result]} then {
590     if {$verbose >= 0} then {
591     wpLog o * "Error: unable to open ${desc}`$file' for writing: $result"
592     }
593     } else {
594     if {[array exists array]} then {
595     foreach name [lsort [array names array]] {
596     puts $fd "[list $name] [list $array($name)]"
597     }
598     close $fd
599     return 1
600     } else {
601     close $fd
602     }
603     }
604     }
605     return 0
606     }
607    
608     ##
609     ## Load data into an array from a file
610     ##
611     ## Args: array, filename, verbose {-1,0,1}, description, ignore regsub
612     ## Returns: 1 if successful,
613     ## 0 otherwise
614     ##
615     proc arrayLoad {arrayName file {verbose 0} {desc "file "} {ignore "^#"}} {
616     upvar 1 $arrayName array
617    
618     if {[createFile $file $verbose $desc]} then {
619     if {[catch {set fd [open $file r]} result]} then {
620     if {$verbose >= 0} then {
621     wpLog o * "Error: unable to open ${desc}`$file' for reading: $result"
622     }
623     } else {
624     if {[info exists array]} then {
625     unset array
626     }
627     while {![eof $fd]} {
628     set line [replaceExpr [gets $fd] "^ "]
629     if {([string compare "" $line]) && \
630     (![regexp -- $ignore $line])} then {
631     set array([lindex $line 0]) [lindex $line 1]
632     }
633     }
634     close $fd
635     return 1
636     }
637     }
638     return 0
639     }
640    
641     ##
642     ## Set all elements in the given array the the given value
643     ##
644     ## Args: array name, value
645     ## Returns: 1 if the array exists
646     ## 0 otherwise
647     ##
648     proc arraySetAll {arrayName {value ""}} {
649     upvar 1 $arrayName array
650    
651     if {[array exists array]} then {
652     foreach name [array names array] {
653     set array($name) $value
654     }
655     return 1
656     }
657     return 0
658     }
659    
660     ##
661     ## Find the given element in an array
662     ##
663     ## Args: array name, element name
664     ## Returns: case sensitive element name if found,
665     ## nothing otherwise
666     ##
667     proc arrayFindElementName {array element} {
668     set list [lsort [array names $array]]
669     set index [lsearch -exact [string tolower $list] [string tolower $name]]
670     if {$index != -1} then {
671     return [lindex $list $index]
672     }
673     return
674     }
675    
676     ##
677     ## Return length of longest data in an array
678     ##
679     ## Args: array name
680     ## Returns: length of longest name in an array
681     ##
682     proc arrayMaxElementDataLength {arrayName} {
683     upvar 1 $arrayName array
684    
685     set maxlength 0
686     foreach {name data} [array get array] {
687     set length [string length $data]
688     if {$length > $maxlength} then {
689     set maxlength $length
690     }
691     }
692     return $maxlength
693     }
694    
695     ##
696     ## Return length of the longest element in a list
697     ##
698     ## Args: list
699     ## Returns: length of longest element in the given list
700     ##
701     proc listMaxElementLength {list} {
702     set maxlength 0
703     foreach data $list {
704     set length [string length $data]
705     if {$length > $maxlength} then {
706     set maxlength $length
707     }
708     }
709     return $maxlength
710     }
711    
712     ##
713     ## Search an array for a given word or regexp
714     ##
715     ## Args: array name, word/regexp
716     ## Returns: list of indexes that match the given word/regexp
717     ##
718     proc arraySearch {array word} {
719     set word [string tolower $word]
720     set ret ""
721     foreach {name data} [array get $array] {
722     set string [string tolower $data]
723     if {[lsearch -regexp $string $word] != -1} then {
724     for {
725     set index 0
726     set indexes ""
727     } {
728     if {[regexp -- .*$word $string]} then {
729     lappend indexes $index
730     }
731     } {
732     incr index
733     }
734     lappend ret [list [concat $name $indexes]]
735     }
736     }
737     return $ret
738     }
739    
740     ##
741     ## Find option default for the given option name in a data list
742     ##
743     ## Args: data list, option name
744     ## Returns: option default if found,
745     ## nothing otherwise
746     ##
747     proc dataFormatDefault {list option} {
748     foreach i $list {
749     if {![string compare $option [lindex $i 0]]} then {
750     return [lindex $i 1]
751     }
752     }
753     return
754     }
755    
756     ##
757     ## Find option value for the given option name in a data list
758     ##
759     ## Args: data format, data list, option name
760     ## Returns: option value if found,
761     ## nothing otherwise
762     ##
763     proc dataFormatValue {format data option} {
764     if {[set index [lsearch -exact $format $option]] != -1} then {
765     return [lindex $data $index]
766     }
767     return
768     }
769    
770     ##
771     ## Replace option data in the given data list with a new value
772     ##
773     ## Args: data format, data list, option name, new value
774     ## Returns: data list
775     ##
776     proc dataFormatReplace {format data option value} {
777     if {[set index [lsearch -exact $format $option]] != -1} then {
778     return [lreplace $data $index $index $value]
779     }
780     return $data
781     }
782    
783     ##
784     ## Create a data format list for a givan data format and options
785     ##
786     ## Args: data format list, defaults, options {{option1 value} ...}
787     ## Returns: data format list with options and values in proper order
788     ##
789     proc dataFormatBuild {format defaults args} {
790     set ret ""
791     foreach arg $args {
792     set [lindex $arg 0] [lindex $arg 1]
793     }
794     foreach opt $format {
795     if {[info exists $opt]} then {
796     lappend ret [set $opt]
797     } else {
798     lappend ret [dataFormatDefault $defaults $opt]
799     }
800     }
801     return $ret
802     }
803    
804     ##
805     ## Convert a data list from one format to another
806     ##
807     ## Args: from format, to format, data list
808     ## Returns: data list
809     ##
810     proc dataFormatConvert {fromFormat toFormat data} {
811     set ret ""
812     set index 0
813     foreach opt $fromFormat {
814     set $opt [lindex $data $index]
815     incr index
816     }
817     foreach opt $toFormat {
818     if {[info exists $opt]} then {
819     lappend ret [set $opt]
820     } else {
821     lappend ret [dataFormatDefault $defaults $opt]
822     }
823     }
824     return $ret
825     }
826    
827     ##
828     ## Scan the given file for module options
829     ##
830     ## Args: file, args {only scan for these options}
831     ## Returns: list of module options if the given file is a module,
832     ## nothing otherwise
833     ## Errors: unable to open file for reading
834     ##
835     proc scanModule {file args} {
836     variable moduleDatabaseConfig
837     variable moduleDatabaseFormat
838    
839     if {[catch {set fd [open $file r]} result]} then {
840     error $result
841     } else {
842     set ret ""
843     if {![string compare "" $args]} then {
844     set baseOptions [lindex $moduleDatabaseFormat([set moduleDatabaseConfig(version)]) 0]
845     set extraOptions [lindex $moduleDatabaseFormat([set moduleDatabaseConfig(version)]) 1]
846     set scanOptions "name $baseOptions"
847     set formatOptions "name $baseOptions $extraOptions"
848     } else {
849     set scanOptions $args
850     set formatOptions $args
851     }
852     for {
853     set lineCount 0
854     set optionCount 0
855     set continuedLine 0
856     } {(![eof $fd]) && ($lineCount <= $moduleDatabaseConfig(scanlines))} {
857     incr lineCount
858     } {
859     gets $fd line
860     if {[regexp -- "^# .*:.*" $line]} then {
861     set opt [string trimright [lindex $line 1] :]
862     if {[lsearch -glob $scanOptions $opt] != -1} then {
863     set data [string trimright [string trimleft [string range $line [string first : $line] end] " \t:"] " \t\\"]
864     if {![info exists $opt]} then {
865     set $opt $data
866     } else {
867     append $opt " $data"
868     }
869     }
870     if {[regexp -- \\\\$ $line]} then {
871     set continuedLine 1
872     } else {
873     set continuedLine 0
874     }
875     } elseif {($continuedLine) && ([info exists opt])} then {
876     append $opt " [string trimright [string trimleft $line " \t#"] " \t\\"]"
877     if {![regexp -- \\\\$ $line]} then {
878     set continuedLine 0
879     }
880     }
881     }
882     close $fd
883     if {(![string compare "" $args]) && \
884     ((![info exists name]) || \
885     ([catch {set md5sum [md5Sum $file]}]))} then {
886     return
887     }
888     foreach option $formatOptions {
889     if {![info exists $option]} then {
890     set $option [dataFormatDefault $moduleDatabaseConfig(defaults) $option]
891     }
892     lappend ret [set $option]
893     }
894     return $ret
895     }
896     }
897    
898     ##
899     ## Get data from module db data array
900     ##
901     ## Args: module name, data type
902     ## Returns: data for the given module's data type if it exists,
903     ## nothing otherwise
904     ##
905     proc getModuleDatabaseData {module type} {
906     variable moduleDatabaseConfig
907     variable moduleDatabaseFormat
908     variable moduleDatabaseData
909    
910     if {[moduleExists $module]} then {
911     set index [lsearch -exact [join $moduleDatabaseFormat([set moduleDatabaseConfig(version)])] $type]
912     if {$index != -1} then {
913     return [lindex $moduleDatabaseData($module) $index]
914     }
915     }
916     return
917     }
918    
919     ##
920     ## Set data in module db data array
921     ##
922     ## Args: module name, data type, data
923     ## Returns: 1 if valid module and data type,
924     ## 0 otherwise
925     ##
926     proc setModuleDatabaseData {module type data} {
927     variable moduleDatabaseConfig
928     variable moduleDatabaseFormat
929     variable moduleDatabaseData
930     variable moduleDatabaseDataChanged
931    
932     if {[moduleExists $module]} then {
933     set index [lsearch -exact [join $moduleDatabaseFormat([set moduleDatabaseConfig(version)])] $type]
934     if {$index != -1} then {
935     set moduleDatabaseData($module) [lreplace $moduleDatabaseData($module) $index $index [list $data]]
936     set moduleDatabaseDataChanged 1
937     return 1
938     }
939     }
940     return 0
941     }
942    
943     ##
944     ## Save module database
945     ##
946     ## Args: verbose {-1,0,1}
947     ## Returns: 1 if successful,
948     ## 0 otherwise
949     ##
950     proc saveModuleDatabase {{verbose 0}} {
951     variable configData
952     variable moduleDatabaseConfig
953     variable moduleDatabaseData
954    
955     if {[createFile $configData(moddbfile) $verbose "module database file "]} then {
956     if {[catch {set fd [open $configData(moddbfile) w]} result]} then {
957     if {$verbose >= 0} then {
958     wpLog o * "Error: unable to open module database file `$configData(moddbfile)' for writing: $result"
959     }
960     } else {
961     puts $fd "# $moduleDatabaseConfig(header)$moduleDatabaseConfig(version)"
962     close $fd
963     return [arraySave moduleDatabaseData $configData(moddbfile) $verbose "module database file " a]
964     }
965     }
966     return 0
967     }
968    
969     ##
970     ## Load module database
971     ##
972     ## Args: verbose {-1,0,1}
973     ## Returns: 1 if successful,
974     ## 0 otherwise
975     ##
976     proc loadModuleDatabase {{verbose 0}} {
977     variable configData
978     variable moduleDatabaseConfig
979     variable moduleDatabaseFormat
980     variable moduleDatabaseData
981    
982     if {![file exists $configData(moddbfile)]} then {
983     return -1
984     } else {
985     if {[catch {set fd [open $configData(moddbfile) r]} result]} then {
986     if {$verbose >= 0} then {
987     wpLog o * "Error: unable to open module database file `$configData(moddbfile)' for reading: $result"
988     }
989     } else {
990     set firstline [replaceExpr [gets $fd] "^ "]
991     if {[regexp -- "^# $moduleDatabaseConfig(header)" $firstline]} then {
992     regsub -all -- "^# $moduleDatabaseConfig(header)" $firstline "" version
993     if {![string compare [set version [string trim $version]] $moduleDatabaseConfig(version)]} then {
994     close $fd
995     return [arrayLoad moduleDatabaseData $configData(moddbfile) $verbose "module database file "]
996     } elseif {[info exists moduleDatabaseFormat($version)]} then {
997     if {[info exists moduleDatabaseData]} then {
998     unset moduleDatabaseData
999     }
1000     while {![eof $fd]} {
1001     set line [replaceExpr [gets $fd] "^ "]
1002     if {([string compare "" $line]) && \
1003     (![regexp -- "^#" $line])} then {
1004     set moduleDatabaseData([lindex $line 0]) [dataFormatConvert [join $moduleDatabaseFormat($version)] [join $moduleDatabaseFormat([set moduleDatabaseConfig(version)])] [lindex $line 1]]
1005     }
1006     }
1007     close $fd
1008     return 1
1009     } else {
1010     wpLog o * "Error: unknown module database version: $version"
1011     }
1012     } else {
1013     wpLog o * "Error: unknown module database format: [string trimleft $firstline " \t#"]"
1014     }
1015     }
1016     close $fd
1017     }
1018     return 0
1019     }
1020    
1021     ##
1022     ## Compare loaded module database data to module files
1023     ##
1024     ## Args: verbose {-1,0,1}
1025     ## Returns: 1 if data matches,
1026     ## 0 otherwise
1027     ##
1028     proc compareModuleDatabase {{verbose 0}} {
1029     variable configData
1030     variable moduleDatabaseConfig
1031    
1032     foreach path $configData(modulepath) {
1033     set files [findFiles $path $moduleDatabaseConfig(maxdepth) .tcl]
1034     if {[string compare "" $files]} then {
1035     set comparedModules ""
1036     set moduleList [listModules]
1037     # Return early if we don't have any modules listed in the db
1038     if {![string compare "" $moduleList]} then {
1039     return 0
1040     }
1041     foreach file $files {
1042     set shortfile [string trimleft [string range $file [string length $path] end] /]
1043     if {$verbose >= 1} then {
1044     wpLog o * "Comparing file `$shortfile'"
1045     }
1046     if {[catch {set name [lindex [scanModule $file name] 0]} result]} then {
1047     if {$verbose >= 0} then {
1048     wpLog o * "Error: unable to open file `$shortfile' for reading: $result"
1049     }
1050     }
1051     # Process this file if it's a module
1052     if {[string compare "" $name]} then {
1053     # Get module filename from db
1054     set filename [getModuleDatabaseData $name file]
1055     # Compare module filename and make sure it wasn't renamed or moved
1056     if {[string compare $file $filename]} then {
1057     return 0
1058     }
1059     # Compare md5 from module db and sure the module hasn't changed
1060     if {([catch {set md5sum [md5Sum $filename]}]) || \
1061     ([string compare [getModuleDatabaseData $name md5sum] $md5sum])} then {
1062     return 0
1063     }
1064     # Append module name to list of compared modules
1065     lappend comparedModules $name
1066     }
1067     }
1068     # Compare list of compared modules with list of modules from the db
1069     if {[string compare [lsort $comparedModules] $moduleList]} then {
1070     return 0
1071     }
1072     }
1073     }
1074     return 1
1075     }
1076    
1077     ##
1078     ## Rebuild module database
1079     ##
1080     ## Args: verbose {-1,0,1}
1081     ## Returns: nothing
1082     ##
1083     proc rebuildModuleDatabase {{verbose 0}} {
1084     variable configData
1085     variable moduleDatabaseConfig
1086     variable moduleDatabaseFormat
1087     variable moduleDatabaseData
1088    
1089     foreach path $configData(modulepath) {
1090     set files [findFiles $path $moduleDatabaseConfig(maxdepth) .tcl]
1091     set loadIndex [lsearch -exact [join $moduleDatabaseFormat([set moduleDatabaseConfig(version)])] load]
1092     foreach file $files {
1093     set shortfile [string trimleft [string range $file [string length $path] end] /]
1094     if {$verbose >= 1} then {
1095     wpLog o * "Scanning file `$shortfile'"
1096     }
1097     if {[catch {set data [scanModule $file]} result]} then {
1098     if {$verbose >= 0} then {
1099     wpLog o * "Warning: unable to open file `$shortfile' for reading: $result"
1100     }
1101     } else {
1102     set name [lindex $data 0]
1103     if {[string compare "" $name]} then {
1104     if {[moduleExists $name]} then {
1105     set tmp($name) [lreplace [lrange $data 1 end] $loadIndex $loadIndex [lindex $moduleDatabaseData($name) $loadIndex]]
1106     } else {
1107     set tmp($name) [lrange $data 1 end]
1108     }
1109     }
1110     }
1111     }
1112     }
1113     if {[info exists moduleDatabaseData]} then {
1114     unset moduleDatabaseData
1115     }
1116     if {[info exists tmp]} then {
1117     array set moduleDatabaseData [array get tmp]
1118     }
1119     return
1120     }
1121    
1122     ##
1123     ## List all modules in the database
1124     ##
1125     ## Args: none
1126     ## Returns: list of modules in module database
1127     ##
1128     proc listModules {{loaded 0}} {
1129     variable moduleDatabaseData
1130     variable moduleLoadedList
1131    
1132     if {$loaded} then {
1133     return [lsort $moduleLoadedList]
1134     }
1135     return [lsort [array names moduleDatabaseData]]
1136     }
1137    
1138     ##
1139     ## Check if the given module exists
1140     ##
1141     ## Args: module name
1142     ## Returns: 1 if the given module exists
1143     ## 0 otherwise
1144     ##
1145     proc moduleExists {module} {
1146     variable moduleDatabaseData
1147    
1148     if {[info exists moduleDatabaseData($module)]} then {
1149     return 1
1150     }
1151     return 0
1152     }
1153    
1154     ##
1155     ## Check if a module is loaded
1156     ##
1157     ## Args: module name
1158     ## Returns: 1 if the given module is loaded
1159     ## 0 otherwise
1160     ##
1161     proc moduleLoaded {module} {
1162     variable moduleLoadedList
1163    
1164     if {[lsearch -exact $moduleLoadedList $module] != -1} then {
1165     return 1
1166     }
1167     return 0
1168     }
1169    
1170     ##
1171     ## Load a module
1172     ##
1173     ## Args: module name, verbose {-1,0,1}, args {loop detection}
1174     ## Returns: nothing
1175     ## Errors: if unable to load module
1176     ##
1177     proc moduleLoad {module {verbose 0} args} {
1178     variable NamespaceCurrent
1179     variable moduleLoadedList
1180    
1181     if {[lsearch -exact [set loop [lindex $args 0]] $module] == -1} then {
1182     if {[moduleExists $module]} then {
1183     set preload ""
1184     set requires [getModuleDatabaseData $module requires]
1185     foreach required $requires {
1186     set preloadModule [whichModuleCommand $required]
1187     if {[string compare "" $preloadModule]} then {
1188     if {([lsearch -exact $preload $preloadModule] == -1) && \
1189     ([string compare wp $preloadModule]) && \
1190     (![moduleLoaded $preloadModule])} then {
1191     lappend preload $preloadModule
1192     }
1193     } else {
1194     error "required command `$required' not found."
1195     }
1196     }
1197     if {[string compare "" $preload]} then {
1198     foreach premod $preload {
1199     if {[catch {moduleLoad $premod $verbose [concat $loop $module]} result]} then {
1200     error $result
1201     }
1202     }
1203     }
1204     if {[catch {source [getModuleDatabaseData $module file]} result]} then {
1205     error $result
1206     } else {
1207     package forget $module
1208     package provide ${NamespaceCurrent}::${module} [getModuleDatabaseData $module version]
1209     moduleConfig load $module 1
1210     moduleConfig checkdefs $module 1
1211     moduleData load $module 1
1212     # Imported commands '# requires: ...'
1213     if {[string compare "" $requires]} then {
1214     set Eval "namespace eval ${NamespaceCurrent}::${module} \{\n namespace forget *\n namespace import"
1215     foreach required $requires {
1216     if {[string compare "" [set command [whichCommand $required]]]} then {
1217     append Eval " $command"
1218     }
1219     }
1220     append Eval "\n\}"
1221     eval $Eval
1222     }
1223     # Exported commands '# provides: ...'
1224     if {[string compare "" [set provides [getModuleDatabaseData $module provides]]]} then {
1225     set Eval "namespace eval ${NamespaceCurrent}::${module} \{\n namespace export"
1226     foreach provided $provides {
1227     append Eval " $provided"
1228     }
1229     append Eval "\n\}"
1230     eval $Eval
1231     }
1232     if {[string compare "" [info commands ${NamespaceCurrent}::${module}::InitTable]]} then {
1233     ${NamespaceCurrent}::${module}::InitTable load
1234     }
1235     if {[string compare "" [info commands ${NamespaceCurrent}::${module}::TraceTable]]} then {
1236     ${NamespaceCurrent}::${module}::TraceTable variable
1237     }
1238     if {[string compare "" [info commands ${NamespaceCurrent}::${module}::BindTable]]} then {
1239     ${NamespaceCurrent}::${module}::BindTable bind *
1240     }
1241     if {![getModuleDatabaseData $module load]} then {
1242     setModuleDatabaseData $module load 1
1243     }
1244     if {[lsearch -exact $moduleLoadedList $module] == -1} then {
1245     lappend moduleLoadedList $module
1246     if {$verbose >= 1} then {
1247     wpLog o * "Module loaded: $module"
1248     }
1249     }
1250     }
1251     } else {
1252     error "No such module: $module"
1253     }
1254     } else {
1255     regsub -all -- " " $loop " -> " loop
1256     error "Preload endless loop: $loop -> $module"
1257     }
1258     return
1259     }
1260    
1261     ##
1262     ## Unload a module
1263     ##
1264     ## Args: module name, verbose {-1,0,1}
1265     ## Returns: nothing
1266     ## Errors: if unable to completely unload module
1267     ##
1268     proc moduleUnload {module {verbose 0}} {
1269     variable NamespaceCurrent
1270     variable moduleLoadedList
1271    
1272     # FIXME: handle dependant modules and modules that can't be unloaded
1273     if {[moduleExists $module]} then {
1274     if {[string compare "" [info commands ${NamespaceCurrent}::${module}::InitTable]]} then {
1275     ${NamespaceCurrent}::${module}::InitTable unload
1276     }
1277     if {[string compare "" [info commands ${NamespaceCurrent}::${module}::BindTable]]} then {
1278     ${NamespaceCurrent}::${module}::BindTable unbind *
1279     }
1280     if {[string compare "" [info commands ${NamespaceCurrent}::${module}::TraceTable]]} then {
1281     ${NamespaceCurrent}::${module}::TraceTable vdelete
1282     }
1283     moduleConfig save $module 1
1284     moduleData save $module 1
1285     if {[catch {namespace delete ${NamespaceCurrent}::${module}} result]} then {
1286     error $result
1287     } else {
1288     package forget ${NamespaceCurrent}::${module}
1289     if {[getModuleDatabaseData $module load] == 1} then {
1290     setModuleDatabaseData $module load 0
1291     }
1292     set index [lsearch -exact $moduleLoadedList $module]
1293     if {$index != -1} then {
1294     set moduleLoadedList [lreplace $moduleLoadedList $index $index]
1295     if {$verbose >= 1} then {
1296     wpLog o * "Module unloaded: $module"
1297     }
1298     }
1299     }
1300     } else {
1301     error "No such module: $module"
1302     }
1303     return
1304     }
1305    
1306     ##
1307     ## Load / save module config data for a module
1308     ##
1309     ## Args: action {load|save|checkdefs}, module, force {0,1},
1310     ## verbose {-1,0,1}
1311     ## Returns: 1 if successful,
1312     ## 0 otherwise
1313     ##
1314     proc moduleConfig {action module {force 0} {verbose 0}} {
1315     variable NamespaceCurrent
1316     variable configData
1317    
1318     if {([string compare "" \
1319     [set file [getModuleDatabaseData $module config]]]) && \
1320     ([createDir $configData(configpath)])} then {
1321     set cfgfile [file join $configData(configpath) $file]
1322     switch -exact -- $action {
1323     save {
1324     if {([getModuleDatabaseData $module load]) && \
1325     (($force) || \
1326     (![info exists ${NamespaceCurrent}::${module}::configDataChanged]) || \
1327     ([set ${NamespaceCurrent}::${module}::configDataChanged]))} then {
1328     if {[arraySave ${NamespaceCurrent}::${module}::configData $cfgfile 0 "$module configuration file "]} then {
1329     if {$verbose >= 1} then {
1330     wpLog o * "Writing $module config file..."
1331     }
1332     set ${NamespaceCurrent}::${module}::configDataChanged 0
1333     return 1
1334     } elseif {$verbose >= 0} then {
1335     wpLog o * "Error writing $module config file."
1336     }
1337     }
1338     }
1339     load {
1340     if {($force) || \
1341     (![info exists ${NamespaceCurrent}::${module}::configDataChanged]) || \
1342     (![set ${NamespaceCurrent}::${module}::configDataChanged])} then {
1343     if {[arrayLoad ${NamespaceCurrent}::${module}::configData $cfgfile 0 "$module configuration file "]} then {
1344     if {$verbose >= 1} then {
1345     wpLog o * "Loading $module config file..."
1346     }
1347     set ${NamespaceCurrent}::${module}::configDataChanged 0
1348     return 1
1349     } elseif {$verbose >= 0} then {
1350     wpLog o * "Error loading $module config file."
1351     }
1352     }
1353     }
1354     checkdefs {
1355     if {[array exists ${NamespaceCurrent}::${module}::configDataDefaults]} then {
1356     set Changed 0
1357     # Unset unknown variables
1358     foreach name [array names ${NamespaceCurrent}::${module}::configData] {
1359     if {![info exists ${NamespaceCurrent}::${module}::configDataDefaults($name)]} then {
1360     unset ${NamespaceCurrent}::${module}::configData($name)
1361     set Changed 1
1362     }
1363     }
1364     # Set missing variables to defaults
1365     foreach {name data} [array get ${NamespaceCurrent}::${module}::configDataDefaults] {
1366     if {![info exists ${NamespaceCurrent}::${module}::configData($name)]} then {
1367     set ${NamespaceCurrent}::${module}::configData($name) $data
1368     set Changed 1
1369     }
1370     }
1371     if {$Changed} then {
1372     set ${NamespaceCurrent}::${module}::configDataChanged 1
1373     }
1374     return 1
1375     }
1376     }
1377     }
1378     }
1379     return 0
1380     }
1381    
1382     ##
1383     ## Load / save module config data for a list of modules
1384     ##
1385     ## Args: action {load|save}, module list, force {0,1}, verbose {-1,0,1}
1386     ## Returns: nothing
1387     ##
1388     proc moduleConfigList {action modules {force 0} {verbose 0}} {
1389     variable moduleDatabaseData
1390    
1391     if {![string compare * $modules]} then {
1392     set modules [listModules 1]
1393     }
1394     foreach module $modules {
1395     if {([moduleExists $module]) && ([moduleLoaded $module])} then {
1396     moduleConfig $action $module $force $verbose
1397     }
1398     }
1399     return
1400     }
1401    
1402     ##
1403     ## Load / save module data for a module
1404     ##
1405     ## Args: action {load|save|backup}, module, force {0,1},
1406     ## verbose {-1,0,1}
1407     ## Returns: nothing
1408     ##
1409     proc moduleData {action module {force 0} {verbose 0}} {
1410     variable NamespaceCurrent
1411     variable configData
1412    
1413     if {([info exists ${NamespaceCurrent}::${module}::dataOptions]) && \
1414     ([createDir $configData(datapath)])} then {
1415     switch -exact -- $action {
1416     save {
1417     foreach {name data} [array get ${NamespaceCurrent}::${module}::dataOptions] {
1418     foreach {type file desc} $data {break}
1419     if {([info exists type]) && ([info exists file]) && \
1420     ([info exists desc])} then {
1421     set Changed ${NamespaceCurrent}::${module}::${name}Changed
1422     if {($force) || ((![info exists $Changed]) || ([set $Changed]))} then {
1423     if {[${type}Save ${NamespaceCurrent}::${module}::$name [file join $configData(datapath) $file]]} then {
1424     if {$verbose >= 1} then {
1425     wpLog o * $NamespaceCurrent "Writing $desc data file..."
1426     }
1427     set $Changed 0
1428     } elseif {$verbose >= 0} then {
1429     wpLog o * $NamespaceCurrent "Error writing $desc data file!"
1430     }
1431     }
1432     }
1433     }
1434     }
1435     load {
1436     foreach {name data} [array get ${NamespaceCurrent}::${module}::dataOptions] {
1437     foreach {type file desc} $data {break}
1438     if {([info exists type]) && ([info exists file]) && \
1439     ([info exists desc])} then {
1440     set Changed ${NamespaceCurrent}::${module}::${name}Changed
1441     if {($force) || ((![info exists $Changed]) || ([set $Changed]))} then {
1442     if {[${type}Load ${NamespaceCurrent}::${module}::$name [file join $configData(datapath) $file]]} then {
1443     if {$verbose >= 1} then {
1444     wpLog o * $NamespaceCurrent "Reloading $desc data file..."
1445     }
1446     set $Changed 0
1447     } elseif {$verbose >= 0} then {
1448     wpLog o * $NamespaceCurrent "Error reloading $desc data file!"
1449     }
1450     }
1451     }
1452     }
1453     }
1454     backup {
1455     foreach {name data} [array get ${NamespaceCurrent}::${module}::dataOptions] {
1456     foreach {type file desc} $data {break}
1457     if {([info exists type]) && ([info exists file]) && \
1458     ([info exists desc])} then {
1459     if {[backupFile [file join $configData(datapath) $file] $verbose]} then {
1460     if {$verbose >= 1} then {
1461     wpLog o * $NamespaceCurrent "Backing up $desc data file..."
1462     }
1463     } elseif {$verbose >= 0} then {
1464     wpLog o * $NamespaceCurrent "Error backing up $desc data file!"
1465     }
1466     }
1467     }
1468     }
1469     }
1470     }
1471     return
1472     }
1473    
1474     ##
1475     ## Load / save module data for a list of modules
1476     ##
1477     ## Args: action {load|save}, module list, force {0,1}, verbose {-1,0,1}
1478     ## Returns: nothing
1479     ##
1480     proc moduleDataList {action modules {force 0} {verbose 0}} {
1481     variable moduleDatabaseData
1482    
1483     if {![string compare * $modules]} then {
1484     set modules [listModules 1]
1485     }
1486     foreach module $modules {
1487     if {([moduleExists $module]) && ([moduleLoaded $module])} then {
1488     moduleData $action $module $force $verbose
1489     }
1490     }
1491     return
1492     }
1493    
1494     ##
1495     ## Builds command matching table from module database
1496     ##
1497     ## Args: none
1498     ## Returns: nothing
1499     ##
1500     proc buildCommandTable {{verbose 0}} {
1501     variable NamespaceCurrent
1502     variable ExportList
1503     variable commandTable
1504    
1505     foreach command $ExportList {
1506     if {![info exists tmp($command)]} then {
1507     if {$verbose >= 2} then {
1508     wpLog o * "Adding command: `$command' as `${NamespaceCurrent}::$command'"
1509     }
1510     set tmp($command) ${NamespaceCurrent}::$command
1511     } elseif {$verbose >= 0} then {
1512     wpLog o * "Warning: ignoring duplicate command `$command', conflicts with `$tmp($command)'"
1513     }
1514     }
1515     foreach module [listModules] {
1516     if {[string compare "" [set provides [getModuleDatabaseData $module provides]]]} then {
1517     foreach command $provides {
1518     if {![info exists tmp($command)]} then {
1519     if {$verbose >= 2} then {
1520     wpLog o * "Adding command: `$command' as `${NamespaceCurrent}::${module}::$command'"
1521     }
1522     set tmp($command) ${NamespaceCurrent}::${module}::$command
1523     } elseif {$verbose >= 0} then {
1524     wpLog o * "Warning: ignoring duplicate command `$command', conflicts with `$tmp($command)'"
1525     }
1526     }
1527     }
1528     }
1529     if {[info exists commandTable]} then {
1530     unset commandTable
1531     }
1532     array set commandTable [array get tmp]
1533     return
1534     }
1535    
1536     ##
1537     ## Return full namespace path for the given command
1538     ##
1539     ## Args: command
1540     ## Returns: full namespace path for the given command if it exists
1541     ## nothing otherwise
1542     ##
1543     proc whichCommand {command} {
1544     variable commandTable
1545    
1546     if {[info exists commandTable($command)]} then {
1547     return $commandTable($command)
1548     }
1549     return
1550     }
1551    
1552     ##
1553     ## Return full namespace path for the given module
1554     ##
1555     ## Args: module
1556     ## Returns: full namespace path for the given module if it's loaded
1557     ## nothing otherwise
1558     ##
1559     proc whichModule {module} {
1560     variable NamespaceCurrent
1561    
1562     if {![string compare $module [namespace tail $NamespaceCurrent] $module]} then {
1563     return $NamespaceCurrent
1564     } elseif {[moduleLoaded $module]} then {
1565     return ${NamespaceCurrent}::$module
1566     }
1567     return
1568     }
1569    
1570     ##
1571     ## Return module name that provides the given command
1572     ##
1573     ## Args: command
1574     ## Returns: name of module that provides the given command
1575     ## nothing otherwise
1576     ##
1577     proc whichModuleCommand {command} {
1578     variable NamespaceCurrent
1579     variable commandTable
1580    
1581     if {[info exists commandTable($command)]} then {
1582     if {![string compare ${NamespaceCurrent}::$command \
1583     $commandTable($command)]} then {
1584     return [namespace tail $NamespaceCurrent]
1585     }
1586     return [namespace tail [namespace qualifiers $commandTable($command)]]
1587     }
1588     return
1589     }
1590    
1591     ##
1592     ## Compare the given version to eggdrop's version
1593     ##
1594     ## Args: version
1595     ## Returns: 0 if eggdrop's version is older then the given version
1596     ## 1 if eggdrop's version matches the given version
1597     ## 2 if eggdrop's version is newer then the given version
1598     ##
1599     proc compareVersion {version} {
1600     global numversion
1601    
1602     if {[string compare "" $version]} then {
1603     if {([info exists numversion]) || \
1604     (![catch {set numversion}]) || \
1605     ([info exists numversion])} then {
1606     if {[regexp -- \\. $version]} then {
1607     regsub -all -- \\. $version 0 version
1608     set version ${version}00
1609     }
1610     if {![regexp -- \[^0-9\] $version]} then {
1611     if {$numversion > $version} then {
1612     return 2
1613     } elseif {$numversion == $version} then {
1614     return 1
1615     }
1616     }
1617     }
1618     }
1619     return 0
1620     }
1621    
1622     ##
1623     ## Log module information
1624     ##
1625     ## Args: level, channel, args ({<namespace>} {<text>} | {<text>})
1626     ## Returns: nothing
1627     ##
1628     proc wpLog {level channel args} {
1629     if {[llength $args] == 2} then {
1630     if {[string compare wp [set namespace [namespace tail [lindex $args 0]]]]} then {
1631     putloglev $level $channel "Wolfpack: \[$namespace\] [lindex $args 1]"
1632     } else {
1633     putloglev $level $channel "Wolfpack: [lindex $args 1]"
1634     }
1635     } else {
1636     putloglev $level $channel "Wolfpack: [join $args]"
1637     }
1638     return
1639     }
1640    
1641     ##
1642     ## Evaluate command line arguments
1643     ##
1644     ## Args: none
1645     ## Returns: nothing
1646     ##
1647     proc EvalArgs {argc argv argv0} {
1648     variable NamespaceCurrent
1649     variable optionData
1650    
1651     # Make sure defaults are sane
1652     arraySetAll optionData 0
1653     for {set index 0} {$index < $argc} {incr index} {
1654     set option [lindex $argv $index]
1655     switch -regexp -- $option {
1656     (^--config$) {
1657     set optionData(config) 1
1658     }
1659     (^--rebuild$) {
1660     set optionData(rebuild) 1
1661     }
1662     (^--norebuild$) {
1663     set optionData(norebuild) 1
1664     }
1665     (^--time$) {
1666     set optionData(time) 1
1667     }
1668     (^--verbose$) {
1669     incr optionData(verbose)
1670     }
1671     (^--quiet$) {
1672     incr optionData(quiet) -1
1673     }
1674     (^--debug$) {
1675     set optionData(debug) 1
1676     }
1677     (^--help$) {
1678     ShowUsage $argv0
1679     exit
1680     }
1681     (^--version$) {
1682     puts "[file tail $argv0] version [package require ${NamespaceCurrent}]"
1683     exit
1684     }
1685     (^-\[^-\]*$) {
1686     set suboptions [split $option ""]
1687     set sublength [llength [split $suboptions]]
1688     for {set subindex 0} {$subindex < $sublength} {incr subindex} {
1689     set suboption [lindex $suboptions $subindex]
1690     switch -exact -- $suboption {
1691     - {
1692     continue
1693     }
1694     c {
1695     set optionData(config) 1
1696     }
1697     r {
1698     set optionData(rebuild) 1
1699     }
1700     n {
1701     set optionData(norebuild) 1
1702     }
1703     t {
1704     set optionData(time) 1
1705     }
1706     v {
1707     incr optionData(verbose)
1708     }
1709     q {
1710     incr optionData(quiet) -1
1711     }
1712     d {
1713     set optionData(debug) 1
1714     }
1715     default {
1716     if {(![info exists invalidopt]) || \
1717     ($subindex == 1) || \
1718     ([lsearch -exact $invalidopt $option] == -1)} then {
1719     lappend invalidopt $option
1720     }
1721     }
1722     }
1723     }
1724     }
1725     default {
1726     lappend invalidopt $option
1727     }
1728     }
1729     }
1730    
1731     # complain about invalid command line arguments
1732     if {[info exists invalidopt]} then {
1733     foreach option $invalidopt {
1734     puts stderr "[file tail $argv0]: unrecognized option `$option'"
1735     }
1736     exit 1
1737     }
1738     }
1739    
1740     ##
1741     ## Show usage information
1742     ##
1743     ## Args: none
1744     ## Returns: nothing
1745     ##
1746     proc ShowUsage {argv0} {
1747     # FIXME: code missing options
1748     puts "Usage: [file tail $argv0] <options>"
1749     puts " Valid options:"
1750     puts " -c, --config start interactive configuration"
1751     #puts " -u, --update update module database"
1752     puts " -r, --rebuild force rebuild of module database"
1753     puts " -n, --norebuild don't rebuild module database even if it's outdated"
1754     puts " -t, --time time compare and rebuild of module database"
1755     #puts " -i, --include <mod> include `module' when building database"
1756     #puts " -e, --exclude <mod> exclude `module' when building database"
1757     #puts " -m, --module <mod> only update database for `module'"
1758     puts " -v, --verbose use more than once for more verbose operation"
1759     puts " -q, --quiet use more than once for quieter operation"
1760     puts " -d, --debug start in debug mode with tclsh"
1761     puts " --help show this help"
1762     puts " --version show version information"
1763     }
1764    
1765     ##
1766     ## Enter interactive configuration
1767     ##
1768     ## Args: none
1769     ## Returns: nothing
1770     ##
1771     proc Iconfig {} {
1772     variable NamespaceCurrent
1773     variable configDefaults
1774    
1775     fileevent stdin readable ${NamespaceCurrent}::IconfigReadStdin
1776     puts "Entering wolfpack configuration system..."
1777     puts "Type 'help' for help."
1778     puts -nonewline $configDefaults(prompt)
1779     flush stdout
1780     vwait forever
1781     }
1782    
1783     ##
1784     ## Read stdin and process commands
1785     ##
1786     ## Args: none
1787     ## Returns: nothing
1788     ##
1789     proc IconfigReadStdin {} {
1790     variable configDefaults
1791     variable configData
1792    
1793     set exit 0
1794     if {[eof stdin]} {
1795     set exit 1
1796     }
1797     set stdin [string trimright [gets stdin]]
1798     set data [join [lrange [split $stdin] 1 end]]
1799     if {[string compare "" $stdin]} then {
1800     switch -exact -- [lindex [split $stdin] 0] {
1801     set {
1802     IconfigSet $data
1803     }
1804     enable {
1805     IconfigEnable $data
1806     }
1807     disable {
1808     IconfigDisable $data
1809     }
1810     modules {
1811     IconfigModules $data
1812     }
1813     help {
1814     IconfigHelp $data
1815     }
1816     quit {
1817     set exit 1
1818     }
1819     default {
1820     puts "What? You need 'help'"
1821     }
1822     }
1823     }
1824     if {(!$exit) && (![eof stdin])} then {
1825     puts -nonewline $configDefaults(prompt)
1826     flush stdout
1827     } else {
1828     # Save configuration data
1829     arraySave configData $configDefaults(cfgfile) 0 "configuration file "
1830     # Save module database
1831     saveModuleDatabase
1832     puts ""
1833     flush stdout
1834     exit
1835     }
1836     return
1837     }
1838    
1839     ##
1840     ## Set configuration settings
1841     ##
1842     ## Args: data
1843     ## Returns: nothing
1844     ##
1845     proc IconfigSet {data} {
1846     variable configData
1847     variable configDataDesc
1848    
1849     if {![string compare "" $data]} then {
1850     set fmtlen1 [arrayMaxElementDataLength configDataDesc]
1851     if {$fmtlen1 < 13} then {
1852     set fmtlen1 13 ;# 'Description: '
1853     }
1854     set names [array names configData]
1855     set fmtlen2 [listMaxElementLength $names]
1856     if {$fmtlen2 < 8} then {
1857     set fmtlen2 8 ;# 'Option: '
1858     }
1859     puts ""
1860     puts "Current settings:"
1861     puts ""
1862     puts [format " %-${fmtlen1}s %-${fmtlen2}s %s" Description: Option: Value:]
1863     foreach option [lsort $names] {
1864     if {[info exists configDataDesc($option)]} then {
1865     puts [format " %-${fmtlen1}s %-${fmtlen2}s %s" $configDataDesc($option) $option $configData($option)]
1866     } else {
1867     puts [format " %-${fmtlen1}s %-${fmtlen2}s %s" "" $option $configData($option)]
1868     }
1869     }
1870     puts ""
1871     } else {
1872     set option [lindex [split $data] 0]
1873     if {![info exists configData($option)]} then {
1874     puts "Invalid option: $option"
1875     } else {
1876     set value [join [lrange [split $data] 1 end]]
1877     if {![string compare "" $value]} then {
1878     puts "Currently: $configData($option)"
1879     } else {
1880     set configData($option) $value
1881     puts "Set $option to: $value"
1882     }
1883     }
1884     }
1885     return
1886     }
1887    
1888     ##
1889     ## Enable a module
1890     ##
1891     ## Args: data
1892     ## Returns: nothing
1893     ##
1894     proc IconfigEnable {data} {
1895     set module [lindex [split $data] 0]
1896     if {![string compare "" $module]} then {
1897     puts "Usage: enable <module>"
1898     } elseif {[moduleExists $module]} then {
1899     if {![getModuleDatabaseData $module load]} then {
1900     setModuleDatabaseData $module load 1
1901     puts "Enabled module: $module"
1902     } else {
1903     puts "Module `$module' is already enabled."
1904     }
1905     } else {
1906     puts "Invalid module: $module"
1907     }
1908     return
1909     }
1910    
1911     ##
1912     ## Disable a module
1913     ##
1914     ## Args: data
1915     ## Returns: nothing
1916     ##
1917     proc IconfigDisable {data} {
1918     set module [lindex [split $data] 0]
1919     if {![string compare "" $module]} then {
1920     puts "Usage: disable <module>"
1921     } elseif {[moduleExists $module]} then {
1922     if {[getModuleDatabaseData $module load] == 1} then {
1923     setModuleDatabaseData $module load 0
1924     puts "Disabled module: $module"
1925     } else {
1926     puts "Module `$module' is already disabled."
1927     }
1928     } else {
1929     puts "Invalid module: $module"
1930     }
1931     return
1932     }
1933    
1934     ##
1935     ## List modules
1936     ##
1937     ## Args: data
1938     ## returns: nothing
1939     ##
1940     # FIXME: make this better
1941     proc IconfigModules {data} {
1942     puts "Modules avaliable:"
1943     foreach module [listModules] {
1944     puts "$module [getModuleDatabaseData $module description]"
1945     }
1946     return
1947     }
1948    
1949     ##
1950     ## Show configuration help
1951     ##
1952     ## Args: data
1953     ## Returns: nothing
1954     ##
1955     proc IconfigHelp {data} {
1956     if {![string compare "" $data]} then {
1957     set data help
1958     }
1959     switch -exact -- $data {
1960     set {
1961     puts "### set \[option\] \[value\]"
1962     puts " Sets an option to what you specify."
1963     puts " Shows current setting for an option if no new value is given."
1964     puts " Shows current settings for all options if no option is given."
1965     }
1966     enable {
1967     puts "### enable <module>"
1968     puts " Enables the given module."
1969     }
1970     disable {
1971     puts "### disable <module>"
1972     puts " Disables the given module."
1973     }
1974     modules {
1975     puts "### modules"
1976     puts " Shows modules avaliable."
1977     }
1978     help {
1979     puts "### Avaliable commands:"
1980     puts " set \[option\] \[value\]"
1981     puts " enable <module>"
1982     puts " disable <module>"
1983     puts " modules"
1984     puts " help \[command\]"
1985     puts " quit"
1986     puts "You can get help on individual commands: 'help <command>'"
1987     }
1988     quit {
1989     puts "### quit"
1990     puts " Quits interactive configuration."
1991     }
1992     default {
1993     puts "No help available on that."
1994     }
1995     }
1996     return
1997     }
1998    
1999     ##
2000     ## Inline startup and init code
2001     ##
2002    
2003     wpLog o * "wolfpack.tcl v[package require $NamespaceCurrent] loading..."
2004    
2005     # Init md5Sum command
2006     if {![md5Init]} then {
2007     wpLog o * "Error: can't find a useable md5 command!"
2008     return 0
2009     }
2010    
2011     # Export commands
2012     eval namespace export [join $ExportList]
2013    
2014     # Set missing variables to default values
2015     if {![info exists configDataChanged]} then {
2016     set configDataChanged 0
2017     }
2018     if {![info exists moduleDatabaseDataChanged]} then {
2019     set moduleDatabaseDataChanged 0
2020     }
2021     if {![info exists moduleLoadedList]} then {
2022     set moduleLoadedList ""
2023     }
2024    
2025     # Load configuration data
2026     arrayLoad configData $configDefaults(cfgfile) 0 "configuration file "
2027    
2028     # Unset unknown configuration variables
2029     foreach name [array names configData] {
2030     if {![info exists configDataDefaults($name)]} then {
2031     unset configData($name)
2032     set configDataChanged 1
2033     }
2034     }
2035    
2036     # Set missing configuration variables to defaults
2037     foreach {name data} [array get configDataDefaults] {
2038     if {![info exists configData($name)]} then {
2039     set configData($name) $data
2040     set configDataChanged 1
2041     }
2042     }
2043    
2044     # Save configuration data if changed
2045     if {$configDataChanged} then {
2046     arraySave configData $configDefaults(cfgfile) 0 "configuration file "
2047     }
2048    
2049     # Eval command line arguments if loading with tclsh
2050     if {[info exists argv0]} then {
2051     EvalArgs $argc $argv $argv0
2052     }
2053    
2054     # Check verbose/quiet options
2055     if {$optionData(quiet)} then {
2056     set Verbose $optionData(quiet)
2057     } elseif {$configData(verbose)} then {
2058     set Verbose $configData(verbose)
2059     } else {
2060     set Verbose $optionData(verbose)
2061     }
2062    
2063     # Check rebuild/norebuild options
2064     if {(!$optionData(norebuild)) && ($optionData(rebuild))} then {
2065     set RebuildDatabase 1
2066     } else {
2067     set RebuildDatabase 0
2068     }
2069    
2070     # Sanity check: old eggdrop versions used [time] for a timestamp command
2071     if {(($optionData(time)) || ($configData(time))) && \
2072     ([catch {time}])} then {
2073     set TimeOk 1
2074     } else {
2075     set TimeOk 0
2076     }
2077    
2078     # Load module database
2079     if {$Verbose >= 0} then {
2080     wpLog o * "Loading module database..."
2081     }
2082    
2083     if {$TimeOk} then {
2084     set LoadTime [time {set LoadResult [loadModuleDatabase $Verbose]}]
2085     } else {
2086     set LoadResult [loadModuleDatabase $Verbose]
2087     }
2088    
2089     if {$LoadResult != -1} then {
2090     if {$Verbose >= 0} then {
2091     if {[info exists LoadTime]} then {
2092     wpLog o * "Done. ([format "%.3f" [expr [lindex $LoadTime 0] / 1000000.0]] seconds elapsed)"
2093     } else {
2094     wpLog o * "Done."
2095     }
2096     }
2097     set CreateDatabase 0
2098     } else {
2099     if {$Verbose >= 0} then {
2100     wpLog o * "Warning: module database does not exist."
2101     }
2102     set CreateDatabase 1
2103     }
2104    
2105     set NeedsRebuild 0
2106    
2107     # Compare module database if we are not going to rebuild or create it
2108     if {(!$RebuildDatabase) && (!$CreateDatabase)} then {
2109     if {$Verbose >= 0} then {
2110     wpLog o * "Comparing module database..."
2111     }
2112     if {![file exists $configData(moddbfile)]} then {
2113     set NeedsRebuild 1
2114     } else {
2115     if {$TimeOk} then {
2116     set CompareTime [time {set CompareResult [compareModuleDatabase $Verbose]}]
2117     } else {
2118     set CompareResult [compareModuleDatabase $Verbose]
2119     }
2120     if {!$CompareResult} then {
2121     set NeedsRebuild 1
2122     }
2123     }
2124    
2125     if {$Verbose >= 0} then {
2126     if {[info exists CompareTime]} then {
2127     wpLog o * "Done. ([format "%.3f" [expr [lindex $CompareTime 0] / 1000000.0]] seconds elapsed)"
2128     } else {
2129     wpLog o * "Done."
2130     }
2131     if {$NeedsRebuild} then {
2132     wpLog o * "Database is outdated."
2133     } else {
2134     wpLog o * "Database is current."
2135     }
2136     }
2137     }
2138    
2139     # Create database if does not exist
2140     # Rebuild database if requested
2141     # Rebuild database if it's outdated and config permits
2142     if {($CreateDatabase) || ($RebuildDatabase) || \
2143     (($NeedsRebuild) && ($configData(rebuild)))} then {
2144    
2145     if {$Verbose >= 0} then {
2146     if {$CreateDatabase} then {
2147     wpLog o * "Creating module database..."
2148     } else {
2149     wpLog o * "Rebuilding module database..."
2150     }
2151     }
2152    
2153     # Rebuild module database
2154     if {$TimeOk} then {
2155     set RebuildTime [time {rebuildModuleDatabase $Verbose}]
2156     } else {
2157     rebuildModuleDatabase $Verbose
2158     }
2159    
2160     if {$Verbose >= 0} then {
2161     if {[info exists RebuildTime]} then {
2162     wpLog o * "Done. ([format "%.3f" [expr [lindex $RebuildTime 0] / 1000000.0]] seconds elapsed)"
2163     } else {
2164     wpLog o * "Done."
2165     }
2166     }
2167    
2168     # Save module database
2169     if {$Verbose >= 0} then {
2170     wpLog o * "Saving module database..."
2171     }
2172    
2173     if {$TimeOk} then {
2174     set SaveTime [time {set SaveResult [saveModuleDatabase $Verbose]}]
2175     } else {
2176     set SaveResult [saveModuleDatabase $Verbose]
2177     }
2178    
2179     if {$Verbose >= 0} then {
2180     if {$SaveResult} then {
2181     if {[info exists SaveTime]} then {
2182     wpLog o * "Done. ([format "%.3f" [expr [lindex $SaveTime 0] / 1000000.0]] seconds elapsed)"
2183     } else {
2184     wpLog o * "Done."
2185     }
2186     } else {
2187     wpLog o * "Error"
2188     }
2189     }
2190    
2191     } elseif {($NeedsRebuild) && ($Verbose >= 0)} then {
2192     wpLog o * "Warning: not rebuilding outdated module database..."
2193     }
2194    
2195     # Enter interactive configuration if loading with tclsh
2196     if {[info exists argv0]} then {
2197     if {$optionData(config)} then {
2198     Iconfig
2199     }
2200     }
2201    
2202     # Build command table
2203     if {(![info exists argv0]) || ($optionData(debug))} then {
2204     if {$Verbose >= 0} then {
2205     wpLog o * "Building command table..."
2206     }
2207     if {$TimeOk} then {
2208     set CommandTime [time {buildCommandTable $Verbose}]
2209     } else {
2210     buildCommandTable $Verbose
2211     }
2212     if {$Verbose >= 0} then {
2213     if {[info exists CommandTime]} then {
2214     wpLog o * "Done. ([format "%.3f" [expr [lindex $CommandTime 0] / 1000000.0]] seconds elapsed)"
2215     } else {
2216     wpLog o * "Done."
2217     }
2218     }
2219    
2220     set loadList ""
2221    
2222     # Load debug module first if not in eggdrop mode
2223     if {([info exists argv0]) && ([moduleExists debug])} then {
2224     lappend loadList debug
2225     }
2226    
2227     # Load other modules next, moduleLoad will preload additional modules
2228     foreach name [lsort [array names moduleDatabaseData]] {
2229     if {[getModuleDatabaseData $name load] == 1} then {
2230     lappend loadList $name
2231     }
2232     }
2233    
2234     wpLog o * "Loading modules..."
2235    
2236     # Load modules
2237     if {$TimeOk} then {
2238     set LoadTime [time {
2239     foreach module $loadList {
2240     if {[catch {moduleLoad $module $Verbose} result]} then {
2241     wpLog o * "Error: unable to load module `$module': $result"
2242     }
2243     }
2244     }]
2245     } else {
2246     foreach module $loadList {
2247     if {[catch {moduleLoad $module $Verbose} result]} then {
2248     wpLog o * "Error: unable to load module `$module': $result"
2249     }
2250     }
2251     }
2252    
2253     if {[info exists LoadTime]} then {
2254     wpLog o * "Done. ([format "%.3f" [expr [lindex $LoadTime 0] / 1000000.0]] seconds elapsed)"
2255     } else {
2256     wpLog o * "Done."
2257     }
2258    
2259     set ModuleLoadCount [llength [split $moduleLoadedList]]
2260     set ModuleTotalCount [llength [array names moduleDatabaseData]]
2261     if {$ModuleLoadCount} then {
2262     wpLog o * "Modules loaded ($ModuleLoadCount/$ModuleTotalCount): $moduleLoadedList"
2263     } else {
2264     wpLog o * "No modules loaded."
2265     }
2266    
2267     # Unload modules if started in debug mode
2268     if {$optionData(debug)} then {
2269    
2270     # FIXME: code module dependency stuff first
2271     # wpLog o * "Unloading modules..."
2272    
2273     # Unload all modules except debug
2274     # foreach module $moduleLoadedList {
2275     # if {[string compare $module debug]} then {
2276     # if {[catch {moduleUnload $module $Verbose} result]} then {
2277     # wpLog o * "Error: unable to unload module `$module': $result"
2278     # }
2279     # }
2280     # }
2281    
2282     # Unload debug module last to make it display stats
2283     if {[moduleLoaded debug]} then {
2284     if {[catch {moduleUnload debug} result]} then {
2285     wpLog o * "Error: unable to unload module `debug': $result"
2286     }
2287     }
2288     # wpLog o * "Done."
2289     }
2290     }
2291    
2292     } ;# namespace ::wp
2293    
2294     return

webmaster@eggheads.org
ViewVC Help
Powered by ViewVC 1.1.23