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