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