/[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.2 - (hide annotations) (download) (as text)
Thu May 31 05:18:12 2001 UTC (18 years, 4 months ago) by tothwolf
Branch: MAIN
Changes since 1.1: +69 -6 lines
File MIME type: application/x-tcl
*** empty log message ***

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