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