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