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