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