/[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.30 - (hide annotations) (download) (as text)
Sun Jan 26 16:21:36 2003 UTC (16 years, 8 months ago) by tothwolf
Branch: MAIN
Changes since 1.29: +36 -3 lines
File MIME type: application/x-tcl
*** empty log message ***

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