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