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