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