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