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