/[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.4 - (hide annotations) (download) (as text)
Fri Jun 1 05:38:48 2001 UTC (18 years, 4 months ago) by tothwolf
Branch: MAIN
Changes since 1.3: +2 -2 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 tothwolf 1.4 ## Copyright (C) 1998-2001 Tothwolf <tothwolf@concentric.net>
41 guppy 1.1 ##
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.4 ## $Id: wolfpack.tcl,v 1.3 2001/05/31 07:26:16 tothwolf 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 tothwolf 1.3 variable moduleDatabaseDataChanged
1016 guppy 1.1
1017     if {[createFile $configData(moddbfile) $verbose "module database file "]} then {
1018     if {[catch {set fd [open $configData(moddbfile) w]} result]} then {
1019     if {$verbose >= 0} then {
1020     wpLog o * "Error: unable to open module database file `$configData(moddbfile)' for writing: $result"
1021     }
1022     } else {
1023     puts $fd "# $moduleDatabaseConfig(header)$moduleDatabaseConfig(version)"
1024     close $fd
1025 tothwolf 1.3 set ret [arraySave moduleDatabaseData $configData(moddbfile) $verbose "module database file " a]
1026     if {$ret} then {
1027     set moduleDatabaseDataChanged 0
1028     }
1029     return $ret
1030 guppy 1.1 }
1031     }
1032     return 0
1033     }
1034    
1035     ##
1036     ## Load module database
1037     ##
1038     ## Args: verbose {-1,0,1}
1039     ## Returns: 1 if successful,
1040     ## 0 otherwise
1041     ##
1042     proc loadModuleDatabase {{verbose 0}} {
1043     variable configData
1044     variable moduleDatabaseConfig
1045     variable moduleDatabaseFormat
1046     variable moduleDatabaseData
1047 tothwolf 1.3 variable moduleDatabaseDataChanged
1048 guppy 1.1
1049     if {![file exists $configData(moddbfile)]} then {
1050     return -1
1051     } else {
1052     if {[catch {set fd [open $configData(moddbfile) r]} result]} then {
1053     if {$verbose >= 0} then {
1054     wpLog o * "Error: unable to open module database file `$configData(moddbfile)' for reading: $result"
1055     }
1056     } else {
1057     set firstline [replaceExpr [gets $fd] "^ "]
1058     if {[regexp -- "^# $moduleDatabaseConfig(header)" $firstline]} then {
1059     regsub -all -- "^# $moduleDatabaseConfig(header)" $firstline "" version
1060     if {![string compare [set version [string trim $version]] $moduleDatabaseConfig(version)]} then {
1061     close $fd
1062     return [arrayLoad moduleDatabaseData $configData(moddbfile) $verbose "module database file "]
1063     } elseif {[info exists moduleDatabaseFormat($version)]} then {
1064     if {[info exists moduleDatabaseData]} then {
1065     unset moduleDatabaseData
1066     }
1067     while {![eof $fd]} {
1068     set line [replaceExpr [gets $fd] "^ "]
1069     if {([string compare "" $line]) && \
1070     (![regexp -- "^#" $line])} then {
1071     set moduleDatabaseData([lindex $line 0]) [dataFormatConvert [join $moduleDatabaseFormat($version)] [join $moduleDatabaseFormat([set moduleDatabaseConfig(version)])] [lindex $line 1]]
1072     }
1073     }
1074     close $fd
1075 tothwolf 1.3 set moduleDatabaseDataChanged 0
1076 guppy 1.1 return 1
1077     } else {
1078     wpLog o * "Error: unknown module database version: $version"
1079     }
1080     } else {
1081     wpLog o * "Error: unknown module database format: [string trimleft $firstline " \t#"]"
1082     }
1083     }
1084     close $fd
1085     }
1086     return 0
1087     }
1088    
1089     ##
1090     ## Compare loaded module database data to module files
1091     ##
1092     ## Args: verbose {-1,0,1}
1093     ## Returns: 1 if data matches,
1094     ## 0 otherwise
1095     ##
1096     proc compareModuleDatabase {{verbose 0}} {
1097     variable configData
1098     variable moduleDatabaseConfig
1099    
1100     foreach path $configData(modulepath) {
1101     set files [findFiles $path $moduleDatabaseConfig(maxdepth) .tcl]
1102     if {[string compare "" $files]} then {
1103     set comparedModules ""
1104     set moduleList [listModules]
1105     # Return early if we don't have any modules listed in the db
1106     if {![string compare "" $moduleList]} then {
1107     return 0
1108     }
1109     foreach file $files {
1110     set shortfile [string trimleft [string range $file [string length $path] end] /]
1111     if {$verbose >= 1} then {
1112     wpLog o * "Comparing file `$shortfile'"
1113     }
1114     if {[catch {set name [lindex [scanModule $file name] 0]} result]} then {
1115     if {$verbose >= 0} then {
1116     wpLog o * "Error: unable to open file `$shortfile' for reading: $result"
1117     }
1118     }
1119     # Process this file if it's a module
1120     if {[string compare "" $name]} then {
1121     # Get module filename from db
1122     set filename [getModuleDatabaseData $name file]
1123     # Compare module filename and make sure it wasn't renamed or moved
1124     if {[string compare $file $filename]} then {
1125     return 0
1126     }
1127     # Compare md5 from module db and sure the module hasn't changed
1128     if {([catch {set md5sum [md5Sum $filename]}]) || \
1129     ([string compare [getModuleDatabaseData $name md5sum] $md5sum])} then {
1130     return 0
1131     }
1132     # Append module name to list of compared modules
1133     lappend comparedModules $name
1134     }
1135     }
1136     # Compare list of compared modules with list of modules from the db
1137     if {[string compare [lsort $comparedModules] $moduleList]} then {
1138     return 0
1139     }
1140     }
1141     }
1142     return 1
1143     }
1144    
1145     ##
1146     ## Rebuild module database
1147     ##
1148     ## Args: verbose {-1,0,1}
1149     ## Returns: nothing
1150     ##
1151     proc rebuildModuleDatabase {{verbose 0}} {
1152     variable configData
1153     variable moduleDatabaseConfig
1154     variable moduleDatabaseFormat
1155     variable moduleDatabaseData
1156    
1157     foreach path $configData(modulepath) {
1158     set files [findFiles $path $moduleDatabaseConfig(maxdepth) .tcl]
1159     set loadIndex [lsearch -exact [join $moduleDatabaseFormat([set moduleDatabaseConfig(version)])] load]
1160     foreach file $files {
1161     set shortfile [string trimleft [string range $file [string length $path] end] /]
1162     if {$verbose >= 1} then {
1163     wpLog o * "Scanning file `$shortfile'"
1164     }
1165     if {[catch {set data [scanModule $file]} result]} then {
1166     if {$verbose >= 0} then {
1167     wpLog o * "Warning: unable to open file `$shortfile' for reading: $result"
1168     }
1169     } else {
1170     set name [lindex $data 0]
1171     if {[string compare "" $name]} then {
1172     if {[moduleExists $name]} then {
1173     set tmp($name) [lreplace [lrange $data 1 end] $loadIndex $loadIndex [lindex $moduleDatabaseData($name) $loadIndex]]
1174     } else {
1175     set tmp($name) [lrange $data 1 end]
1176     }
1177     }
1178     }
1179     }
1180     }
1181     if {[info exists moduleDatabaseData]} then {
1182     unset moduleDatabaseData
1183     }
1184     if {[info exists tmp]} then {
1185     array set moduleDatabaseData [array get tmp]
1186     }
1187     return
1188     }
1189    
1190     ##
1191     ## List all modules in the database
1192     ##
1193     ## Args: none
1194     ## Returns: list of modules in module database
1195     ##
1196     proc listModules {{loaded 0}} {
1197     variable moduleDatabaseData
1198     variable moduleLoadedList
1199    
1200     if {$loaded} then {
1201     return [lsort $moduleLoadedList]
1202     }
1203     return [lsort [array names moduleDatabaseData]]
1204     }
1205    
1206     ##
1207     ## Check if the given module exists
1208     ##
1209     ## Args: module name
1210     ## Returns: 1 if the given module exists
1211     ## 0 otherwise
1212     ##
1213     proc moduleExists {module} {
1214     variable moduleDatabaseData
1215    
1216     if {[info exists moduleDatabaseData($module)]} then {
1217     return 1
1218     }
1219     return 0
1220     }
1221    
1222     ##
1223     ## Check if a module is loaded
1224     ##
1225     ## Args: module name
1226     ## Returns: 1 if the given module is loaded
1227     ## 0 otherwise
1228     ##
1229     proc moduleLoaded {module} {
1230     variable moduleLoadedList
1231    
1232     if {[lsearch -exact $moduleLoadedList $module] != -1} then {
1233     return 1
1234     }
1235     return 0
1236     }
1237    
1238     ##
1239     ## Load a module
1240     ##
1241     ## Args: module name, verbose {-1,0,1}, args {loop detection}
1242     ## Returns: nothing
1243     ## Errors: if unable to load module
1244     ##
1245     proc moduleLoad {module {verbose 0} args} {
1246     variable NamespaceCurrent
1247     variable moduleLoadedList
1248    
1249     if {[lsearch -exact [set loop [lindex $args 0]] $module] == -1} then {
1250     if {[moduleExists $module]} then {
1251     set preload ""
1252     set requires [getModuleDatabaseData $module requires]
1253     foreach required $requires {
1254     set preloadModule [whichModuleCommand $required]
1255     if {[string compare "" $preloadModule]} then {
1256     if {([lsearch -exact $preload $preloadModule] == -1) && \
1257     ([string compare wp $preloadModule]) && \
1258     (![moduleLoaded $preloadModule])} then {
1259     lappend preload $preloadModule
1260     }
1261     } else {
1262     error "required command `$required' not found."
1263     }
1264     }
1265     if {[string compare "" $preload]} then {
1266     foreach premod $preload {
1267     if {[catch {moduleLoad $premod $verbose [concat $loop $module]} result]} then {
1268     error $result
1269     }
1270     }
1271     }
1272     if {[catch {source [getModuleDatabaseData $module file]} result]} then {
1273     error $result
1274     } else {
1275     package forget $module
1276     package provide ${NamespaceCurrent}::${module} [getModuleDatabaseData $module version]
1277     moduleConfig load $module 1
1278     moduleConfig checkdefs $module 1
1279     moduleData load $module 1
1280     # Imported commands '# requires: ...'
1281     if {[string compare "" $requires]} then {
1282     set Eval "namespace eval ${NamespaceCurrent}::${module} \{\n namespace forget *\n namespace import"
1283     foreach required $requires {
1284     if {[string compare "" [set command [whichCommand $required]]]} then {
1285     append Eval " $command"
1286     }
1287     }
1288     append Eval "\n\}"
1289     eval $Eval
1290     }
1291     # Exported commands '# provides: ...'
1292     if {[string compare "" [set provides [getModuleDatabaseData $module provides]]]} then {
1293     set Eval "namespace eval ${NamespaceCurrent}::${module} \{\n namespace export"
1294     foreach provided $provides {
1295     append Eval " $provided"
1296     }
1297     append Eval "\n\}"
1298     eval $Eval
1299     }
1300     if {[string compare "" [info commands ${NamespaceCurrent}::${module}::InitTable]]} then {
1301     ${NamespaceCurrent}::${module}::InitTable load
1302     }
1303     if {[string compare "" [info commands ${NamespaceCurrent}::${module}::TraceTable]]} then {
1304     ${NamespaceCurrent}::${module}::TraceTable variable
1305     }
1306     if {[string compare "" [info commands ${NamespaceCurrent}::${module}::BindTable]]} then {
1307     ${NamespaceCurrent}::${module}::BindTable bind *
1308     }
1309     if {![getModuleDatabaseData $module load]} then {
1310     setModuleDatabaseData $module load 1
1311     }
1312     if {[lsearch -exact $moduleLoadedList $module] == -1} then {
1313     lappend moduleLoadedList $module
1314     if {$verbose >= 1} then {
1315     wpLog o * "Module loaded: $module"
1316     }
1317     }
1318     }
1319     } else {
1320     error "No such module: $module"
1321     }
1322     } else {
1323     regsub -all -- " " $loop " -> " loop
1324     error "Preload endless loop: $loop -> $module"
1325     }
1326     return
1327     }
1328    
1329     ##
1330     ## Unload a module
1331     ##
1332     ## Args: module name, verbose {-1,0,1}
1333     ## Returns: nothing
1334     ## Errors: if unable to completely unload module
1335     ##
1336     proc moduleUnload {module {verbose 0}} {
1337     variable NamespaceCurrent
1338     variable moduleLoadedList
1339    
1340     # FIXME: handle dependant modules and modules that can't be unloaded
1341     if {[moduleExists $module]} then {
1342     if {[string compare "" [info commands ${NamespaceCurrent}::${module}::InitTable]]} then {
1343     ${NamespaceCurrent}::${module}::InitTable unload
1344     }
1345     if {[string compare "" [info commands ${NamespaceCurrent}::${module}::BindTable]]} then {
1346     ${NamespaceCurrent}::${module}::BindTable unbind *
1347     }
1348     if {[string compare "" [info commands ${NamespaceCurrent}::${module}::TraceTable]]} then {
1349     ${NamespaceCurrent}::${module}::TraceTable vdelete
1350     }
1351     moduleConfig save $module 1
1352     moduleData save $module 1
1353     if {[catch {namespace delete ${NamespaceCurrent}::${module}} result]} then {
1354     error $result
1355     } else {
1356     package forget ${NamespaceCurrent}::${module}
1357     if {[getModuleDatabaseData $module load] == 1} then {
1358     setModuleDatabaseData $module load 0
1359     }
1360     set index [lsearch -exact $moduleLoadedList $module]
1361     if {$index != -1} then {
1362     set moduleLoadedList [lreplace $moduleLoadedList $index $index]
1363     if {$verbose >= 1} then {
1364     wpLog o * "Module unloaded: $module"
1365     }
1366     }
1367     }
1368     } else {
1369     error "No such module: $module"
1370     }
1371     return
1372     }
1373    
1374     ##
1375     ## Load / save module config data for a module
1376     ##
1377     ## Args: action {load|save|checkdefs}, module, force {0,1},
1378     ## verbose {-1,0,1}
1379     ## Returns: 1 if successful,
1380     ## 0 otherwise
1381     ##
1382     proc moduleConfig {action module {force 0} {verbose 0}} {
1383     variable NamespaceCurrent
1384     variable configData
1385    
1386     if {([string compare "" \
1387     [set file [getModuleDatabaseData $module config]]]) && \
1388     ([createDir $configData(configpath)])} then {
1389     set cfgfile [file join $configData(configpath) $file]
1390     switch -exact -- $action {
1391     save {
1392     if {([getModuleDatabaseData $module load]) && \
1393     (($force) || \
1394     (![info exists ${NamespaceCurrent}::${module}::configDataChanged]) || \
1395     ([set ${NamespaceCurrent}::${module}::configDataChanged]))} then {
1396     if {[arraySave ${NamespaceCurrent}::${module}::configData $cfgfile 0 "$module configuration file "]} then {
1397     if {$verbose >= 1} then {
1398     wpLog o * "Writing $module config file..."
1399     }
1400     set ${NamespaceCurrent}::${module}::configDataChanged 0
1401     return 1
1402     } elseif {$verbose >= 0} then {
1403     wpLog o * "Error writing $module config file."
1404     }
1405     }
1406     }
1407     load {
1408     if {($force) || \
1409     (![info exists ${NamespaceCurrent}::${module}::configDataChanged]) || \
1410     (![set ${NamespaceCurrent}::${module}::configDataChanged])} then {
1411     if {[arrayLoad ${NamespaceCurrent}::${module}::configData $cfgfile 0 "$module configuration file "]} then {
1412     if {$verbose >= 1} then {
1413     wpLog o * "Loading $module config file..."
1414     }
1415     set ${NamespaceCurrent}::${module}::configDataChanged 0
1416     return 1
1417     } elseif {$verbose >= 0} then {
1418     wpLog o * "Error loading $module config file."
1419     }
1420     }
1421     }
1422     checkdefs {
1423     if {[array exists ${NamespaceCurrent}::${module}::configDataDefaults]} then {
1424     set Changed 0
1425     # Unset unknown variables
1426     foreach name [array names ${NamespaceCurrent}::${module}::configData] {
1427     if {![info exists ${NamespaceCurrent}::${module}::configDataDefaults($name)]} then {
1428     unset ${NamespaceCurrent}::${module}::configData($name)
1429     set Changed 1
1430     }
1431     }
1432     # Set missing variables to defaults
1433     foreach {name data} [array get ${NamespaceCurrent}::${module}::configDataDefaults] {
1434     if {![info exists ${NamespaceCurrent}::${module}::configData($name)]} then {
1435     set ${NamespaceCurrent}::${module}::configData($name) $data
1436     set Changed 1
1437     }
1438     }
1439     if {$Changed} then {
1440     set ${NamespaceCurrent}::${module}::configDataChanged 1
1441     }
1442     return 1
1443     }
1444     }
1445     }
1446     }
1447     return 0
1448     }
1449    
1450     ##
1451     ## Load / save module config data for a list of modules
1452     ##
1453     ## Args: action {load|save}, module list, force {0,1}, verbose {-1,0,1}
1454     ## Returns: nothing
1455     ##
1456     proc moduleConfigList {action modules {force 0} {verbose 0}} {
1457     variable moduleDatabaseData
1458    
1459     if {![string compare * $modules]} then {
1460     set modules [listModules 1]
1461     }
1462     foreach module $modules {
1463     if {([moduleExists $module]) && ([moduleLoaded $module])} then {
1464     moduleConfig $action $module $force $verbose
1465     }
1466     }
1467     return
1468     }
1469    
1470     ##
1471     ## Load / save module data for a module
1472     ##
1473     ## Args: action {load|save|backup}, module, force {0,1},
1474     ## verbose {-1,0,1}
1475     ## Returns: nothing
1476     ##
1477     proc moduleData {action module {force 0} {verbose 0}} {
1478     variable NamespaceCurrent
1479     variable configData
1480    
1481     if {([info exists ${NamespaceCurrent}::${module}::dataOptions]) && \
1482     ([createDir $configData(datapath)])} then {
1483     switch -exact -- $action {
1484     save {
1485     foreach {name data} [array get ${NamespaceCurrent}::${module}::dataOptions] {
1486     foreach {type file desc} $data {break}
1487     if {([info exists type]) && ([info exists file]) && \
1488     ([info exists desc])} then {
1489     set Changed ${NamespaceCurrent}::${module}::${name}Changed
1490     if {($force) || ((![info exists $Changed]) || ([set $Changed]))} then {
1491     if {[${type}Save ${NamespaceCurrent}::${module}::$name [file join $configData(datapath) $file]]} then {
1492     if {$verbose >= 1} then {
1493     wpLog o * $NamespaceCurrent "Writing $desc data file..."
1494     }
1495     set $Changed 0
1496     } elseif {$verbose >= 0} then {
1497     wpLog o * $NamespaceCurrent "Error writing $desc data file!"
1498     }
1499     }
1500     }
1501     }
1502     }
1503     load {
1504     foreach {name data} [array get ${NamespaceCurrent}::${module}::dataOptions] {
1505     foreach {type file desc} $data {break}
1506     if {([info exists type]) && ([info exists file]) && \
1507     ([info exists desc])} then {
1508     set Changed ${NamespaceCurrent}::${module}::${name}Changed
1509     if {($force) || ((![info exists $Changed]) || ([set $Changed]))} then {
1510     if {[${type}Load ${NamespaceCurrent}::${module}::$name [file join $configData(datapath) $file]]} then {
1511     if {$verbose >= 1} then {
1512     wpLog o * $NamespaceCurrent "Reloading $desc data file..."
1513     }
1514     set $Changed 0
1515     } elseif {$verbose >= 0} then {
1516     wpLog o * $NamespaceCurrent "Error reloading $desc data file!"
1517     }
1518     }
1519     }
1520     }
1521     }
1522     backup {
1523     foreach {name data} [array get ${NamespaceCurrent}::${module}::dataOptions] {
1524     foreach {type file desc} $data {break}
1525     if {([info exists type]) && ([info exists file]) && \
1526     ([info exists desc])} then {
1527     if {[backupFile [file join $configData(datapath) $file] $verbose]} then {
1528     if {$verbose >= 1} then {
1529     wpLog o * $NamespaceCurrent "Backing up $desc data file..."
1530     }
1531     } elseif {$verbose >= 0} then {
1532     wpLog o * $NamespaceCurrent "Error backing up $desc data file!"
1533     }
1534     }
1535     }
1536     }
1537     }
1538     }
1539     return
1540     }
1541    
1542     ##
1543     ## Load / save module data for a list of modules
1544     ##
1545     ## Args: action {load|save}, module list, force {0,1}, verbose {-1,0,1}
1546     ## Returns: nothing
1547     ##
1548     proc moduleDataList {action modules {force 0} {verbose 0}} {
1549     variable moduleDatabaseData
1550    
1551     if {![string compare * $modules]} then {
1552     set modules [listModules 1]
1553     }
1554     foreach module $modules {
1555     if {([moduleExists $module]) && ([moduleLoaded $module])} then {
1556     moduleData $action $module $force $verbose
1557     }
1558     }
1559     return
1560     }
1561    
1562     ##
1563     ## Builds command matching table from module database
1564     ##
1565     ## Args: none
1566     ## Returns: nothing
1567     ##
1568     proc buildCommandTable {{verbose 0}} {
1569     variable NamespaceCurrent
1570     variable ExportList
1571     variable commandTable
1572    
1573     foreach command $ExportList {
1574     if {![info exists tmp($command)]} then {
1575     if {$verbose >= 2} then {
1576     wpLog o * "Adding command: `$command' as `${NamespaceCurrent}::$command'"
1577     }
1578     set tmp($command) ${NamespaceCurrent}::$command
1579     } elseif {$verbose >= 0} then {
1580     wpLog o * "Warning: ignoring duplicate command `$command', conflicts with `$tmp($command)'"
1581     }
1582     }
1583     foreach module [listModules] {
1584     if {[string compare "" [set provides [getModuleDatabaseData $module provides]]]} then {
1585     foreach command $provides {
1586     if {![info exists tmp($command)]} then {
1587     if {$verbose >= 2} then {
1588     wpLog o * "Adding command: `$command' as `${NamespaceCurrent}::${module}::$command'"
1589     }
1590     set tmp($command) ${NamespaceCurrent}::${module}::$command
1591     } elseif {$verbose >= 0} then {
1592     wpLog o * "Warning: ignoring duplicate command `$command', conflicts with `$tmp($command)'"
1593     }
1594     }
1595     }
1596     }
1597     if {[info exists commandTable]} then {
1598     unset commandTable
1599     }
1600     array set commandTable [array get tmp]
1601     return
1602     }
1603    
1604     ##
1605     ## Return full namespace path for the given command
1606     ##
1607     ## Args: command
1608     ## Returns: full namespace path for the given command if it exists
1609     ## nothing otherwise
1610     ##
1611     proc whichCommand {command} {
1612     variable commandTable
1613    
1614     if {[info exists commandTable($command)]} then {
1615     return $commandTable($command)
1616     }
1617     return
1618     }
1619    
1620     ##
1621     ## Return full namespace path for the given module
1622     ##
1623     ## Args: module
1624     ## Returns: full namespace path for the given module if it's loaded
1625     ## nothing otherwise
1626     ##
1627     proc whichModule {module} {
1628     variable NamespaceCurrent
1629    
1630     if {![string compare $module [namespace tail $NamespaceCurrent] $module]} then {
1631     return $NamespaceCurrent
1632     } elseif {[moduleLoaded $module]} then {
1633     return ${NamespaceCurrent}::$module
1634     }
1635     return
1636     }
1637    
1638     ##
1639     ## Return module name that provides the given command
1640     ##
1641     ## Args: command
1642     ## Returns: name of module that provides the given command
1643     ## nothing otherwise
1644     ##
1645     proc whichModuleCommand {command} {
1646     variable NamespaceCurrent
1647     variable commandTable
1648    
1649     if {[info exists commandTable($command)]} then {
1650     if {![string compare ${NamespaceCurrent}::$command \
1651     $commandTable($command)]} then {
1652     return [namespace tail $NamespaceCurrent]
1653     }
1654     return [namespace tail [namespace qualifiers $commandTable($command)]]
1655     }
1656     return
1657     }
1658    
1659     ##
1660     ## Compare the given version to eggdrop's version
1661     ##
1662     ## Args: version
1663     ## Returns: 0 if eggdrop's version is older then the given version
1664     ## 1 if eggdrop's version matches the given version
1665     ## 2 if eggdrop's version is newer then the given version
1666     ##
1667     proc compareVersion {version} {
1668     global numversion
1669    
1670     if {[string compare "" $version]} then {
1671     if {([info exists numversion]) || \
1672     (![catch {set numversion}]) || \
1673     ([info exists numversion])} then {
1674     if {[regexp -- \\. $version]} then {
1675     regsub -all -- \\. $version 0 version
1676     set version ${version}00
1677     }
1678     if {![regexp -- \[^0-9\] $version]} then {
1679     if {$numversion > $version} then {
1680     return 2
1681     } elseif {$numversion == $version} then {
1682     return 1
1683     }
1684     }
1685     }
1686     }
1687     return 0
1688     }
1689    
1690     ##
1691     ## Log module information
1692     ##
1693     ## Args: level, channel, args ({<namespace>} {<text>} | {<text>})
1694     ## Returns: nothing
1695     ##
1696     proc wpLog {level channel args} {
1697     if {[llength $args] == 2} then {
1698     if {[string compare wp [set namespace [namespace tail [lindex $args 0]]]]} then {
1699     putloglev $level $channel "Wolfpack: \[$namespace\] [lindex $args 1]"
1700     } else {
1701     putloglev $level $channel "Wolfpack: [lindex $args 1]"
1702     }
1703     } else {
1704     putloglev $level $channel "Wolfpack: [join $args]"
1705     }
1706     return
1707     }
1708    
1709     ##
1710     ## Evaluate command line arguments
1711     ##
1712     ## Args: none
1713     ## Returns: nothing
1714     ##
1715     proc EvalArgs {argc argv argv0} {
1716     variable NamespaceCurrent
1717     variable optionData
1718    
1719     # Make sure defaults are sane
1720     arraySetAll optionData 0
1721     for {set index 0} {$index < $argc} {incr index} {
1722     set option [lindex $argv $index]
1723     switch -regexp -- $option {
1724     (^--config$) {
1725     set optionData(config) 1
1726     }
1727     (^--rebuild$) {
1728     set optionData(rebuild) 1
1729     }
1730     (^--norebuild$) {
1731     set optionData(norebuild) 1
1732     }
1733     (^--time$) {
1734     set optionData(time) 1
1735     }
1736     (^--verbose$) {
1737     incr optionData(verbose)
1738     }
1739     (^--quiet$) {
1740     incr optionData(quiet) -1
1741     }
1742     (^--debug$) {
1743     set optionData(debug) 1
1744     }
1745     (^--help$) {
1746     ShowUsage $argv0
1747     exit
1748     }
1749     (^--version$) {
1750     puts "[file tail $argv0] version [package require ${NamespaceCurrent}]"
1751     exit
1752     }
1753     (^-\[^-\]*$) {
1754     set suboptions [split $option ""]
1755     set sublength [llength [split $suboptions]]
1756     for {set subindex 0} {$subindex < $sublength} {incr subindex} {
1757     set suboption [lindex $suboptions $subindex]
1758     switch -exact -- $suboption {
1759     - {
1760     continue
1761     }
1762     c {
1763     set optionData(config) 1
1764     }
1765     r {
1766     set optionData(rebuild) 1
1767     }
1768     n {
1769     set optionData(norebuild) 1
1770     }
1771     t {
1772     set optionData(time) 1
1773     }
1774     v {
1775     incr optionData(verbose)
1776     }
1777     q {
1778     incr optionData(quiet) -1
1779     }
1780     d {
1781     set optionData(debug) 1
1782     }
1783     default {
1784     if {(![info exists invalidopt]) || \
1785     ($subindex == 1) || \
1786     ([lsearch -exact $invalidopt $option] == -1)} then {
1787     lappend invalidopt $option
1788     }
1789     }
1790     }
1791     }
1792     }
1793     default {
1794     lappend invalidopt $option
1795     }
1796     }
1797     }
1798    
1799     # complain about invalid command line arguments
1800     if {[info exists invalidopt]} then {
1801     foreach option $invalidopt {
1802     puts stderr "[file tail $argv0]: unrecognized option `$option'"
1803     }
1804     exit 1
1805     }
1806     }
1807    
1808     ##
1809     ## Show usage information
1810     ##
1811     ## Args: none
1812     ## Returns: nothing
1813     ##
1814     proc ShowUsage {argv0} {
1815     # FIXME: code missing options
1816     puts "Usage: [file tail $argv0] <options>"
1817     puts " Valid options:"
1818     puts " -c, --config start interactive configuration"
1819     #puts " -u, --update update module database"
1820     puts " -r, --rebuild force rebuild of module database"
1821     puts " -n, --norebuild don't rebuild module database even if it's outdated"
1822     puts " -t, --time time compare and rebuild of module database"
1823     #puts " -i, --include <mod> include `module' when building database"
1824     #puts " -e, --exclude <mod> exclude `module' when building database"
1825     #puts " -m, --module <mod> only update database for `module'"
1826     puts " -v, --verbose use more than once for more verbose operation"
1827     puts " -q, --quiet use more than once for quieter operation"
1828     puts " -d, --debug start in debug mode with tclsh"
1829     puts " --help show this help"
1830     puts " --version show version information"
1831     }
1832    
1833     ##
1834     ## Enter interactive configuration
1835     ##
1836     ## Args: none
1837     ## Returns: nothing
1838     ##
1839     proc Iconfig {} {
1840     variable NamespaceCurrent
1841     variable configDefaults
1842    
1843     fileevent stdin readable ${NamespaceCurrent}::IconfigReadStdin
1844     puts "Entering wolfpack configuration system..."
1845     puts "Type 'help' for help."
1846     puts -nonewline $configDefaults(prompt)
1847     flush stdout
1848     vwait forever
1849     }
1850    
1851     ##
1852     ## Read stdin and process commands
1853     ##
1854     ## Args: none
1855     ## Returns: nothing
1856     ##
1857     proc IconfigReadStdin {} {
1858     variable configDefaults
1859     variable configData
1860    
1861     set exit 0
1862     if {[eof stdin]} {
1863     set exit 1
1864     }
1865     set stdin [string trimright [gets stdin]]
1866     set data [join [lrange [split $stdin] 1 end]]
1867     if {[string compare "" $stdin]} then {
1868     switch -exact -- [lindex [split $stdin] 0] {
1869     set {
1870     IconfigSet $data
1871     }
1872     enable {
1873     IconfigEnable $data
1874     }
1875     disable {
1876     IconfigDisable $data
1877     }
1878     modules {
1879     IconfigModules $data
1880     }
1881     help {
1882     IconfigHelp $data
1883     }
1884     quit {
1885     set exit 1
1886     }
1887     default {
1888     puts "What? You need 'help'"
1889     }
1890     }
1891     }
1892     if {(!$exit) && (![eof stdin])} then {
1893     puts -nonewline $configDefaults(prompt)
1894     flush stdout
1895     } else {
1896     # Save configuration data
1897     arraySave configData $configDefaults(cfgfile) 0 "configuration file "
1898     # Save module database
1899     saveModuleDatabase
1900     puts ""
1901     flush stdout
1902     exit
1903     }
1904     return
1905     }
1906    
1907     ##
1908     ## Set configuration settings
1909     ##
1910     ## Args: data
1911     ## Returns: nothing
1912     ##
1913     proc IconfigSet {data} {
1914     variable configData
1915     variable configDataDesc
1916    
1917     if {![string compare "" $data]} then {
1918     set fmtlen1 [arrayMaxElementDataLength configDataDesc]
1919     if {$fmtlen1 < 13} then {
1920     set fmtlen1 13 ;# 'Description: '
1921     }
1922     set names [array names configData]
1923     set fmtlen2 [listMaxElementLength $names]
1924     if {$fmtlen2 < 8} then {
1925     set fmtlen2 8 ;# 'Option: '
1926     }
1927     puts ""
1928     puts "Current settings:"
1929     puts ""
1930     puts [format " %-${fmtlen1}s %-${fmtlen2}s %s" Description: Option: Value:]
1931     foreach option [lsort $names] {
1932     if {[info exists configDataDesc($option)]} then {
1933     puts [format " %-${fmtlen1}s %-${fmtlen2}s %s" $configDataDesc($option) $option $configData($option)]
1934     } else {
1935     puts [format " %-${fmtlen1}s %-${fmtlen2}s %s" "" $option $configData($option)]
1936     }
1937     }
1938     puts ""
1939     } else {
1940     set option [lindex [split $data] 0]
1941     if {![info exists configData($option)]} then {
1942     puts "Invalid option: $option"
1943     } else {
1944     set value [join [lrange [split $data] 1 end]]
1945     if {![string compare "" $value]} then {
1946     puts "Currently: $configData($option)"
1947     } else {
1948     set configData($option) $value
1949     puts "Set $option to: $value"
1950     }
1951     }
1952     }
1953     return
1954     }
1955    
1956     ##
1957     ## Enable a module
1958     ##
1959     ## Args: data
1960     ## Returns: nothing
1961     ##
1962     proc IconfigEnable {data} {
1963     set module [lindex [split $data] 0]
1964     if {![string compare "" $module]} then {
1965     puts "Usage: enable <module>"
1966     } elseif {[moduleExists $module]} then {
1967     if {![getModuleDatabaseData $module load]} then {
1968     setModuleDatabaseData $module load 1
1969     puts "Enabled module: $module"
1970     } else {
1971     puts "Module `$module' is already enabled."
1972     }
1973     } else {
1974     puts "Invalid module: $module"
1975     }
1976     return
1977     }
1978    
1979     ##
1980     ## Disable a module
1981     ##
1982     ## Args: data
1983     ## Returns: nothing
1984     ##
1985     proc IconfigDisable {data} {
1986     set module [lindex [split $data] 0]
1987     if {![string compare "" $module]} then {
1988     puts "Usage: disable <module>"
1989     } elseif {[moduleExists $module]} then {
1990     if {[getModuleDatabaseData $module load] == 1} then {
1991     setModuleDatabaseData $module load 0
1992     puts "Disabled module: $module"
1993     } else {
1994     puts "Module `$module' is already disabled."
1995     }
1996     } else {
1997     puts "Invalid module: $module"
1998     }
1999     return
2000     }
2001    
2002     ##
2003     ## List modules
2004     ##
2005     ## Args: data
2006     ## returns: nothing
2007     ##
2008     proc IconfigModules {data} {
2009     puts "Modules avaliable:"
2010     foreach module [listModules] {
2011 tothwolf 1.2 puts "$module"
2012     foreach line [splitList [getModuleDatabaseData $module description] 65 " " " "] {
2013     puts " $line"
2014     }
2015 guppy 1.1 }
2016     return
2017     }
2018    
2019     ##
2020     ## Show configuration help
2021     ##
2022     ## Args: data
2023     ## Returns: nothing
2024     ##
2025     proc IconfigHelp {data} {
2026     if {![string compare "" $data]} then {
2027     set data help
2028     }
2029     switch -exact -- $data {
2030     set {
2031     puts "### set \[option\] \[value\]"
2032     puts " Sets an option to what you specify."
2033     puts " Shows current setting for an option if no new value is given."
2034     puts " Shows current settings for all options if no option is given."
2035     }
2036     enable {
2037     puts "### enable <module>"
2038     puts " Enables the given module."
2039     }
2040     disable {
2041     puts "### disable <module>"
2042     puts " Disables the given module."
2043     }
2044     modules {
2045     puts "### modules"
2046     puts " Shows modules avaliable."
2047     }
2048     help {
2049     puts "### Avaliable commands:"
2050     puts " set \[option\] \[value\]"
2051     puts " enable <module>"
2052     puts " disable <module>"
2053     puts " modules"
2054     puts " help \[command\]"
2055     puts " quit"
2056     puts "You can get help on individual commands: 'help <command>'"
2057     }
2058     quit {
2059     puts "### quit"
2060     puts " Quits interactive configuration."
2061     }
2062     default {
2063     puts "No help available on that."
2064     }
2065     }
2066     return
2067     }
2068    
2069     ##
2070     ## Inline startup and init code
2071     ##
2072    
2073     wpLog o * "wolfpack.tcl v[package require $NamespaceCurrent] loading..."
2074    
2075     # Init md5Sum command
2076     if {![md5Init]} then {
2077 tothwolf 1.2 wpLog o * "Error: can't find a usable md5 command!"
2078 guppy 1.1 return 0
2079     }
2080    
2081     # Export commands
2082     eval namespace export [join $ExportList]
2083    
2084     # Set missing variables to default values
2085     if {![info exists configDataChanged]} then {
2086     set configDataChanged 0
2087     }
2088     if {![info exists moduleDatabaseDataChanged]} then {
2089     set moduleDatabaseDataChanged 0
2090     }
2091     if {![info exists moduleLoadedList]} then {
2092     set moduleLoadedList ""
2093     }
2094    
2095     # Load configuration data
2096     arrayLoad configData $configDefaults(cfgfile) 0 "configuration file "
2097    
2098     # Unset unknown configuration variables
2099     foreach name [array names configData] {
2100     if {![info exists configDataDefaults($name)]} then {
2101     unset configData($name)
2102     set configDataChanged 1
2103     }
2104     }
2105    
2106     # Set missing configuration variables to defaults
2107     foreach {name data} [array get configDataDefaults] {
2108     if {![info exists configData($name)]} then {
2109     set configData($name) $data
2110     set configDataChanged 1
2111     }
2112     }
2113    
2114     # Save configuration data if changed
2115     if {$configDataChanged} then {
2116     arraySave configData $configDefaults(cfgfile) 0 "configuration file "
2117     }
2118    
2119     # Eval command line arguments if loading with tclsh
2120     if {[info exists argv0]} then {
2121     EvalArgs $argc $argv $argv0
2122     }
2123    
2124     # Check verbose/quiet options
2125     if {$optionData(quiet)} then {
2126     set Verbose $optionData(quiet)
2127     } elseif {$configData(verbose)} then {
2128     set Verbose $configData(verbose)
2129     } else {
2130     set Verbose $optionData(verbose)
2131     }
2132    
2133     # Check rebuild/norebuild options
2134     if {(!$optionData(norebuild)) && ($optionData(rebuild))} then {
2135     set RebuildDatabase 1
2136     } else {
2137     set RebuildDatabase 0
2138     }
2139    
2140     # Sanity check: old eggdrop versions used [time] for a timestamp command
2141     if {(($optionData(time)) || ($configData(time))) && \
2142     ([catch {time}])} then {
2143     set TimeOk 1
2144     } else {
2145     set TimeOk 0
2146     }
2147    
2148     # Load module database
2149     if {$Verbose >= 0} then {
2150     wpLog o * "Loading module database..."
2151     }
2152    
2153     if {$TimeOk} then {
2154     set LoadTime [time {set LoadResult [loadModuleDatabase $Verbose]}]
2155     } else {
2156     set LoadResult [loadModuleDatabase $Verbose]
2157     }
2158    
2159     if {$LoadResult != -1} then {
2160     if {$Verbose >= 0} then {
2161     if {[info exists LoadTime]} then {
2162     wpLog o * "Done. ([format "%.3f" [expr [lindex $LoadTime 0] / 1000000.0]] seconds elapsed)"
2163     } else {
2164     wpLog o * "Done."
2165     }
2166     }
2167     set CreateDatabase 0
2168     } else {
2169     if {$Verbose >= 0} then {
2170     wpLog o * "Warning: module database does not exist."
2171     }
2172     set CreateDatabase 1
2173     }
2174    
2175     set NeedsRebuild 0
2176    
2177     # Compare module database if we are not going to rebuild or create it
2178     if {(!$RebuildDatabase) && (!$CreateDatabase)} then {
2179     if {$Verbose >= 0} then {
2180     wpLog o * "Comparing module database..."
2181     }
2182     if {![file exists $configData(moddbfile)]} then {
2183     set NeedsRebuild 1
2184     } else {
2185     if {$TimeOk} then {
2186     set CompareTime [time {set CompareResult [compareModuleDatabase $Verbose]}]
2187     } else {
2188     set CompareResult [compareModuleDatabase $Verbose]
2189     }
2190     if {!$CompareResult} then {
2191     set NeedsRebuild 1
2192     }
2193     }
2194    
2195     if {$Verbose >= 0} then {
2196     if {[info exists CompareTime]} then {
2197     wpLog o * "Done. ([format "%.3f" [expr [lindex $CompareTime 0] / 1000000.0]] seconds elapsed)"
2198     } else {
2199     wpLog o * "Done."
2200     }
2201     if {$NeedsRebuild} then {
2202     wpLog o * "Database is outdated."
2203     } else {
2204     wpLog o * "Database is current."
2205     }
2206     }
2207     }
2208    
2209     # Create database if does not exist
2210     # Rebuild database if requested
2211     # Rebuild database if it's outdated and config permits
2212     if {($CreateDatabase) || ($RebuildDatabase) || \
2213     (($NeedsRebuild) && ($configData(rebuild)))} then {
2214    
2215     if {$Verbose >= 0} then {
2216     if {$CreateDatabase} then {
2217     wpLog o * "Creating module database..."
2218     } else {
2219     wpLog o * "Rebuilding module database..."
2220     }
2221     }
2222    
2223     # Rebuild module database
2224     if {$TimeOk} then {
2225     set RebuildTime [time {rebuildModuleDatabase $Verbose}]
2226     } else {
2227     rebuildModuleDatabase $Verbose
2228     }
2229    
2230     if {$Verbose >= 0} then {
2231     if {[info exists RebuildTime]} then {
2232     wpLog o * "Done. ([format "%.3f" [expr [lindex $RebuildTime 0] / 1000000.0]] seconds elapsed)"
2233     } else {
2234     wpLog o * "Done."
2235     }
2236     }
2237    
2238     # Save module database
2239     if {$Verbose >= 0} then {
2240     wpLog o * "Saving module database..."
2241     }
2242    
2243     if {$TimeOk} then {
2244     set SaveTime [time {set SaveResult [saveModuleDatabase $Verbose]}]
2245     } else {
2246     set SaveResult [saveModuleDatabase $Verbose]
2247     }
2248    
2249     if {$Verbose >= 0} then {
2250     if {$SaveResult} then {
2251     if {[info exists SaveTime]} then {
2252     wpLog o * "Done. ([format "%.3f" [expr [lindex $SaveTime 0] / 1000000.0]] seconds elapsed)"
2253     } else {
2254     wpLog o * "Done."
2255     }
2256     } else {
2257     wpLog o * "Error"
2258     }
2259     }
2260    
2261     } elseif {($NeedsRebuild) && ($Verbose >= 0)} then {
2262     wpLog o * "Warning: not rebuilding outdated module database..."
2263     }
2264    
2265     # Enter interactive configuration if loading with tclsh
2266     if {[info exists argv0]} then {
2267     if {$optionData(config)} then {
2268     Iconfig
2269     }
2270     }
2271    
2272     # Build command table
2273     if {(![info exists argv0]) || ($optionData(debug))} then {
2274     if {$Verbose >= 0} then {
2275     wpLog o * "Building command table..."
2276     }
2277     if {$TimeOk} then {
2278     set CommandTime [time {buildCommandTable $Verbose}]
2279     } else {
2280     buildCommandTable $Verbose
2281     }
2282     if {$Verbose >= 0} then {
2283     if {[info exists CommandTime]} then {
2284     wpLog o * "Done. ([format "%.3f" [expr [lindex $CommandTime 0] / 1000000.0]] seconds elapsed)"
2285     } else {
2286     wpLog o * "Done."
2287     }
2288     }
2289    
2290     set loadList ""
2291    
2292     # Load debug module first if not in eggdrop mode
2293     if {([info exists argv0]) && ([moduleExists debug])} then {
2294     lappend loadList debug
2295     }
2296    
2297     # Load other modules next, moduleLoad will preload additional modules
2298     foreach name [lsort [array names moduleDatabaseData]] {
2299     if {[getModuleDatabaseData $name load] == 1} then {
2300     lappend loadList $name
2301     }
2302     }
2303    
2304     wpLog o * "Loading modules..."
2305    
2306     # Load modules
2307     if {$TimeOk} then {
2308     set LoadTime [time {
2309     foreach module $loadList {
2310