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