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