/[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.46 - (hide annotations) (download) (as text)
Wed May 26 02:17:09 2004 UTC (15 years, 5 months ago) by tothwolf
Branch: MAIN
Changes since 1.45: +8 -2 lines
File MIME type: application/x-tcl
* egrep fix for tclsh hack.

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