/[cvs]/wolfpack/wolfpack.tcl
ViewVC logotype

Contents of /wolfpack/wolfpack.tcl

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph


Revision 1.56 - (show annotations) (download) (as text)
Sun Jan 2 04:46:48 2005 UTC (14 years, 9 months ago) by tothwolf
Branch: MAIN
Changes since 1.55: +16 -1 lines
File MIME type: application/x-tcl
*** empty log message ***

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 # Check for working 'grep -E' before using 'egrep' \
8 if echo a | (grep -E '(a|b)') >/dev/null 2>&1; \
9 then \
10 egrep="grep -E"; \
11 else \
12 egrep=egrep; \
13 fi; \
14 # Search for tclsh[0-9].[0-9] in each valid dir in PATH \
15 for dir in $(echo $PATH | sed 's/:/ /g'); \
16 do \
17 if test -d $dir; \
18 then \
19 files=$(/bin/ls $dir | $egrep '^tclsh[0-9]\.[0-9]$'); \
20 if test "$files" != ""; \
21 then \
22 versions="${versions:+$versions }$(echo $files | sed 's/tclsh//g')"; \
23 fi; \
24 fi; \
25 done; \
26 # Loop over each version to find the latest version of tclsh \
27 for ver in $versions; \
28 do \
29 tmpver=$(echo $ver | sed 's/\.//g'); \
30 if test "$lasttmpver" != ""; \
31 then \
32 if test "$tmpver" -gt "$lasttmpver"; \
33 then \
34 lastver=$ver; \
35 lasttmpver=$tmpver; \
36 fi; \
37 else \
38 lastver=$ver; \
39 lasttmpver=$tmpver; \
40 fi; \
41 done; \
42 # Use the latest tclsh version found, otherwise fall back to 'tclsh' \
43 exec tclsh$lastver "$0" "$@"
44 ###############################################################################
45 ##
46 ## Wolfpack - A modular Tcl system for Eggdrop 1.3.0+ with Tcl 8.0+
47 ## Copyright (C) 1998-2004 Tothwolf <tothwolf@concentric.net>
48 ##
49 ## This program is free software; you can redistribute it and/or modify
50 ## it under the terms of the GNU General Public License as published by
51 ## the Free Software Foundation; either version 2 of the License, or
52 ## (at your option) any later version.
53 ##
54 ## This program is distributed in the hope that it will be useful,
55 ## but WITHOUT ANY WARRANTY; without even the implied warranty of
56 ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
57 ## GNU General Public License for more details.
58 ##
59 ## You should have received a copy of the GNU General Public License
60 ## along with this program; if not, write to the Free Software
61 ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
62 ##
63 ###############################################################################
64 ##
65 ## You should not need to edit anything in any of these files.
66 ##
67 ## './wolfpack.tcl -c' is used to configure initial settings.
68 ## './wolfpack.tcl --help' will list all avaliable options.
69 ##
70 ## Use '.wpconf' from the bot's partyline to configure everything else.
71 ##
72 ###############################################################################
73 ##
74 ## $Id: wolfpack.tcl,v 1.55 2005/01/01 20:11:28 tothwolf Exp $
75 ##
76
77 # Make sure Tcl version is compatible with this code (we use namespaces)
78 if {[catch {package require Tcl 8.0}]} then {
79 if {[info exists argv0]} then {
80 puts "Wolfpack: Error: wolfpack requires Tcl 8.0 or later to load."
81 } else {
82 putloglev o * "Wolfpack: Error: wolfpack requires Tcl 8.0 or later to load."
83 }
84 return
85 }
86
87 namespace eval :: {
88
89 # Eggdrop doesn't currently set argv0, so we use it to detect load type.
90 if {![info exists argv0]} then {
91 # Fix for buggy Tcl variables in pre 1.3.28 Eggdrop versions
92 catch {set numversion}
93
94 # Require eggdrop 1.3.0 or later
95 if {(![info exists numversion]) || ($numversion < 1030000)} then {
96 putloglev o * "Wolfpack: Error: wolfpack requires Eggdrop 1.3.0 or later to load."
97 return
98 }
99 } else {
100 # Emulate eggdrop's putloglev when loading with tclsh
101 if {![string compare "" [info commands putloglev]]} then {
102 proc putloglev {level channel text} {
103 puts $text
104 }
105 }
106 }
107
108 ##
109 ## Log Tcl messages where they can be seen
110 ##
111 ## Args: text
112 ## Returns: nothing
113 ##
114 proc tclLog {text} {
115 # Tcl's tclLog has embedded newlines in it's output
116 if {[string first \n $text] == -1} then {
117 putloglev o * "Wolfpack: \[Tcl\]: $text"
118 } else {
119 foreach line [split $text \n] {
120 putloglev o * "Wolfpack: \[Tcl\]: $line"
121 }
122 }
123 return
124 }
125
126 } ;# namespace ::
127
128 namespace eval ::wp {
129
130 # Manage package version information
131 package forget ::wp
132 package provide ::wp 1.9.9
133
134 # set namespace variables
135 set NamespaceParent [namespace parent]
136 set NamespaceCurrent [namespace current]
137 set ModuleName [namespace tail $NamespaceCurrent]
138 set ModuleVersion [package require $NamespaceCurrent]
139
140 ##
141 ## WARNING: If you change these, you may render your module database useless!
142 ##
143
144 # Max number of lines to scan in a module file
145 set moduleDatabaseConfig(scanlines) 30
146
147 # Max depth to list directories in module path
148 set moduleDatabaseConfig(maxdepth) 4
149
150 # Module database version
151 set moduleDatabaseConfig(version) 2.0
152
153 # Module database header
154 set moduleDatabaseConfig(header) "Wolfpack module database "
155
156 # Module database defaults
157 set moduleDatabaseConfig(defaults) "{version 0} {description {(no description)}} {load 0}"
158
159 # Versioned module database formats
160 array set moduleDatabaseFormat {
161 2.0 "{version config author license description provides requires} {load file md5sum}"
162 }
163
164 # md5 style, command name and result string index
165 array set md5Format {
166 bsd "md5 3"
167 gnu "md5sum 0"
168 }
169
170 # Configuration defaults, values and descriptions
171 array set configDefaults {
172 modulepath {word modules/ {} {Module path (multiple paths may be separated by a ':')}}
173 configpath {word wpconf/ {} {Config path}}
174 datapath {word wpdata/ {} {Data path}}
175 moddbfile {word wolfpack.db {} {Module database file}}
176 update {{range {0 1}} 1 {} {Automatically update module database}}
177 verbose {{range {0 1}} 0 {} {Verbose operation}}
178 time {{range {0 1}} 0 {} {Time module database compare/update/rebuild}}
179 }
180
181 # Command line option defaults
182 array set optionData {
183 cfgfile ""
184 config 0
185 update 0
186 noupdate 0
187 rebuild 0
188 time 0
189 include ""
190 exclude ""
191 module ""
192 verbose 0
193 quiet 0
194 debug 0
195 }
196
197 array set moduleOptionData {
198 exclude ""
199 include ""
200 module ""
201 excludedfiles ""
202 modulefiles ""
203 }
204
205 # Exported commands
206 set ExportedCommands {
207 md5Sum
208 md5Init
209 replaceExpr
210 listFiles
211 listSubdirs
212 findFiles
213 createFile
214 createDir
215 backupFile
216 shortFile
217 listSave
218 listLoad
219 arraySave
220 arrayLoad
221 arraySetAll
222 arrayUnsetAll
223 arrayFindElementName
224 arrayMaxElementDataLength
225 listAppendIf
226 listMaxElementLength
227 splitStringList
228 expandText
229 arraySearch
230 dataFormatDefault
231 dataFormatValue
232 dataFormatList
233 dataFormatReplace
234 dataFormatBuild
235 dataFormatConvert
236 scanModule
237 getModuleDatabaseData
238 setModuleDatabaseData
239 saveModuleDatabase
240 loadModuleDatabase
241 updateModuleData
242 updateModuleDatabase
243 rebuildModuleDatabase
244 listModules
245 moduleExists
246 moduleLoaded
247 moduleBindUnbind
248 moduleLoad
249 moduleUnload
250 moduleConfigSave
251 moduleConfigLoad
252 moduleConfigCheckdefs
253 moduleConfig
254 moduleDataSave
255 moduleDataLoad
256 moduleDataBackup
257 moduleData
258 buildCommandTable
259 whichCommand
260 whichCommandModule
261 whichModule
262 configExists
263 compareVersion
264 wpLog
265 callTrace
266 listNamespaceChildren
267 qualifyCommandName
268 }
269
270 # Exported wrappers for built-in Eggdrop commands
271 set ExportedWrappers {
272 bind
273 unbind
274 }
275
276 ##
277 ## Create md5 checksum for a file
278 ##
279 ## Args: filename
280 ## Returns: md5 checksum if successful
281 ## Errors: permission denied,
282 ## no such file,
283 ## not a file,
284 ## can't exec md5 command
285 ##
286 proc md5Sum {file} {
287 variable md5Config
288
289 if {![file exists $file]} then {
290 error "$file: no such file"
291 } else {
292 if {![file isfile $file]} then {
293 error "$file: not a file"
294 } else {
295 if {![file readable $file]} then {
296 error "$file: permission denied"
297 } else {
298 if {[catch {set sum [lindex [exec $md5Config(command) $file] $md5Config(index)]} result]} then {
299 error "$file: $result"
300 } else {
301 return $sum
302 }
303 }
304 }
305 }
306 }
307
308 ##
309 ## Init md5 command
310 ##
311 ## Args: none
312 ## Returns: 1 if a useable md5 command found
313 ## 0 otherwise
314 ##
315 proc md5Init {} {
316 variable md5Config
317 variable md5Format
318
319 foreach type [array names md5Format] {
320 foreach {command index} $md5Format($type) {break}
321 if {([catch {exec $command ""} result]) && \
322 (![regexp -- "^couldn't execute" $result])} then {
323 set md5Config(command) $command
324 set md5Config(index) $index
325 return 1
326 }
327 }
328 return 0
329 }
330
331 ##
332 ## Replace all occurances of an expression in a string with the given text
333 ##
334 ## Args: string, expr, replacement text
335 ## Returns: string
336 ##
337 proc replaceExpr {string expr {replace ""}} {
338 while {[regexp -nocase -- $expr $string]} {
339 regsub -all -- $expr $string $replace string
340 }
341 return $string
342 }
343
344 ##
345 ## List files in a path
346 ##
347 ## Args: path
348 ## Returns: list of files in the given path,
349 ## nothing if no files in the given path
350 ## Errors: permission denied,
351 ## no such directory,
352 ## not a directory
353 ##
354 proc listFiles {path} {
355 if {![file exists $path]} then {
356 error "$path: no such directory"
357 } else {
358 if {![file isdirectory $path]} then {
359 error "$path: not a directory"
360 } else {
361 if {![file readable $path]} then {
362 error "$path: permission denied"
363 } else {
364 set ret ""
365 foreach name [lsort [glob -nocomplain -- [file join $path *]]] {
366 if {[file isfile $name]} then {
367 lappend ret $name
368 }
369 }
370 return $ret
371 }
372 }
373 }
374 }
375
376 ##
377 ## List subdirs in a path
378 ##
379 ## Args: path
380 ## Returns: list of subdirs in the given path,
381 ## nothing if no subdirs in the given path
382 ## Errors: permission denied,
383 ## no such directory,
384 ## not a directory
385 ##
386 proc listSubdirs {path} {
387 if {![file exists $path]} then {
388 error "$path: no such directory"
389 } else {
390 if {![file isdirectory $path]} then {
391 error "$path: not a directory"
392 } else {
393 if {![file readable $path]} then {
394 error "$path: permission denied"
395 } else {
396 set ret ""
397 foreach name [lsort [glob -nocomplain -- [file join $path *]]] {
398 if {[file isdirectory $name]} then {
399 lappend ret $name
400 }
401 }
402 return $ret
403 }
404 }
405 }
406 }
407
408 ##
409 ## List files with a set ext in a path and its subdirs up to a set depth
410 ##
411 ## Args: path, max search depth, file extension
412 ## Returns: list of files with a set ext in the given path and its subdirs,
413 ## nothing if no matching files are found
414 ##
415 proc findFiles {path depth {ext ""}} {
416 set ret ""
417 set foundDirs "$path "
418 set searchDirs $path
419 for {
420 set currentDepth 0
421 } {($currentDepth <= $depth) || (!$depth)} {
422 incr currentDepth
423 } {
424 set subDirs ""
425 foreach dir $searchDirs {
426 if {[catch {set dirList [listSubdirs $dir]} result]} then {
427 wpLog o * "Error: unable to get file listing: $result"
428 } elseif {[string compare "" $dirList]} then {
429 append subDirs $dirList " "
430 }
431 }
432 if {![string compare "" $subDirs]} then {
433 break
434 }
435 append foundDirs $subDirs " "
436 set searchDirs $subDirs
437 }
438 foreach dir $foundDirs {
439 if {[catch {set files [listFiles $dir]} result]} then {
440 wpLog o * "Error: unable to get file listing: $result"
441 } else {
442 if {[string compare "" $ext]} then {
443 foreach file $files {
444 if {![string compare $ext \
445 [string tolower [file extension $file]]]} then {
446 lappend ret $file
447 }
448 }
449 } else {
450 set ret $files
451 }
452 }
453 }
454 return $ret
455 }
456
457 ##
458 ## Check if a file exists, and create it if not
459 ##
460 ## Args: filename, verbose {-1,0,1}, description, force new file
461 ## Returns: 1 if the file was created successfully
462 ## 0 if the operation failed
463 ## -1 if the file already exists
464 ##
465 proc createFile {file {verbose 0} {desc "file "} {force 0}} {
466 if {($force) || (![file exists $file])} then {
467 if {[catch {set fd [open $file w]} result]} then {
468 if {$verbose >= 0} then {
469 wpLog o * "Error: unable to create ${desc}`[file tail $file]': $result"
470 }
471 } else {
472 if {(!$force) && ($verbose >= 1)} then {
473 wpLog o * "Warning: ${desc}`[file tail $file]' does not exist -- creating"
474 }
475 close $fd
476 return 1
477 }
478 } elseif {[file isfile $file]} then {
479 return -1
480 } elseif {$verbose >= 0} then {
481 wpLog o * "Error: not a file: $file"
482 }
483 return 0
484 }
485
486 ##
487 ## Check if a directory exists, and create it if not
488 ##
489 ## Args: directory, verbose {-1,0,1}, description
490 ## Returns: 1 if the directory was created successfully
491 ## 0 if the operation failed
492 ## -1 if the directory already exists
493 ##
494 proc createDir {dir {verbose 0} {desc "directory "}} {
495 if {![file exists $dir]} then {
496 if {[catch {file mkdir $dir} result]} then {
497 if {$verbose >= 0} then {
498 wpLog o * "Error: unable to create ${desc}`[file tail $dir]': $result"
499 }
500 } else {
501 if {$verbose >= 1} then {
502 wpLog o * "Warning: ${desc}`[file tail $dir]' does not exist -- creating"
503 }
504 return 1
505 }
506 } elseif {[file isdirectory $dir]} then {
507 return -1
508 } elseif {$verbose >= 0} then {
509 wpLog o * "Error: not a directory: $dir"
510 }
511 return 0
512 }
513
514 ##
515 ## Create a backup of the given file with an optional suffix
516 ##
517 ## Args: filename, suffix, verbose {-1,0,1}
518 ## Returns: 1 if successful
519 ## -1 if file is 0 in size
520 ## 0 otherwise
521 ##
522 proc backupFile {file {verbose 0} {suffix ~bak}} {
523 if {[string compare "" $suffix]} then {
524 if {[file size $file]} then {
525 if {[catch {
526 file copy -force $file $file${suffix}
527 } result]} then {
528 if {$verbose >= 0} then {
529 wpLog o * "Error: unable to create backup file for `[file tail $file]': $result"
530 }
531 } else {
532 return 1
533 }
534 } else {
535 return -1
536 }
537 }
538 return 0
539 }
540
541 ##
542 ## Remove directory component from a filename
543 ##
544 ## Args: file, pathlist
545 ## Returns: file with directory component removed
546 ##
547 proc shortFile {file {pathlist ""}} {
548 if {[string compare "" $pathlist]} then {
549 foreach dir $pathlist {
550 set dirlength [string length $dir]
551 set filedir [string range $file 0 [expr $dirlength - 1]]
552 if {![string compare $dir $filedir]} then {
553 return [string trimleft [string range $file $dirlength end] /]
554 }
555 }
556 }
557 return [string trimleft [string range $file [string last / $file] end] /]
558 }
559
560 ##
561 ## Save data from a list into a file
562 ##
563 ## Args: list, filename, verbose {-1,0,1}, description, access flag
564 ## Returns: 1 is successful,
565 ## 0 otherwise
566 ##
567 proc listSave {listName file {verbose 0} {desc "file "} {access w}} {
568 upvar 1 $listName list
569
570 if {[createFile $file $verbose $desc]} then {
571 if {[catch {set fd [open $file $access]} result]} then {
572 if {$verbose >= 0} then {
573 wpLog o * "Error: unable to open ${desc}`$file' for writing: $result"
574 }
575 } else {
576 if {[info exists list]} then {
577 foreach data $list {
578 puts $fd [list $data]
579 }
580 }
581 close $fd
582 return 1
583 }
584 }
585 return 0
586 }
587
588 ##
589 ## Load data into a list from a file
590 ##
591 ## Args: list, filename, verbose {-1,0,1}, description, ignore regsub
592 ## Returns: 1 if successful,
593 ## 0 otherwise
594 ##
595 proc listLoad {listName file {verbose 0} {desc "file "} {ignore "^#"}} {
596 upvar 1 $listName list
597
598 if {[createFile $file $verbose $desc]} then {
599 if {[catch {set fd [open $file r]} result]} then {
600 if {$verbose >= 0} then {
601 wpLog o * "Error: unable to open ${desc}`$file' for reading: $result"
602 }
603 } else {
604 if {[info exists list]} then {
605 unset list
606 }
607 while {![eof $fd]} {
608 set line [replaceExpr [gets $fd] "^ "]
609 if {([string compare "" $line]) && \
610 (![regexp -- $ignore $line])} then {
611 append list $line " "
612 }
613 }
614 close $fd
615 return 1
616 }
617 }
618 return 0
619 }
620
621 ##
622 ## Save data from an array info a file
623 ##
624 ## Args: array, filename, verbose {-1,0,1}, description, access flag
625 ## Returns: 1 is successful,
626 ## 0 otherwise
627 ##
628 proc arraySave {arrayName file {verbose 0} {desc "file "} {access w}} {
629 upvar 1 $arrayName array
630
631 if {[createFile $file $verbose $desc]} then {
632 if {[catch {set fd [open $file $access]} result]} then {
633 if {$verbose >= 0} then {
634 wpLog o * "Error: unable to open ${desc}`$file' for writing: $result"
635 }
636 } else {
637 if {[array exists array]} then {
638 foreach name [lsort [array names array]] {
639 puts $fd "[list $name] [list $array($name)]"
640 }
641 close $fd
642 return 1
643 } else {
644 close $fd
645 }
646 }
647 }
648 return 0
649 }
650
651 ##
652 ## Load data into an array from a file
653 ##
654 ## Args: array, filename, verbose {-1,0,1}, description, ignore regsub
655 ## Returns: 1 if successful,
656 ## 0 otherwise
657 ##
658 proc arrayLoad {arrayName file {verbose 0} {desc "file "} {ignore "^#"}} {
659 upvar 1 $arrayName array
660
661 if {[createFile $file $verbose $desc]} then {
662 if {[catch {set fd [open $file r]} result]} then {
663 if {$verbose >= 0} then {
664 wpLog o * "Error: unable to open ${desc}`$file' for reading: $result"
665 }
666 } else {
667 if {[info exists array]} then {
668 unset array
669 }
670 while {![eof $fd]} {
671 set line [replaceExpr [gets $fd] "^ "]
672 if {([string compare "" $line]) && \
673 (![regexp -- $ignore $line])} then {
674 set array([lindex $line 0]) [lindex $line 1]
675 }
676 }
677 close $fd
678 return 1
679 }
680 }
681 return 0
682 }
683
684 ##
685 ## Set all elements in the given array the the given value
686 ##
687 ## Args: array name, value
688 ## Returns: 1 if the array exists
689 ## 0 otherwise
690 ##
691 proc arraySetAll {arrayName {value ""}} {
692 upvar 1 $arrayName array
693
694 if {[array exists array]} then {
695 foreach name [array names array] {
696 set array($name) $value
697 }
698 return 1
699 }
700 return 0
701 }
702
703 ##
704 ## Unset all elements in the given array
705 ##
706 ## Args: array name
707 ## Returns: 1 if the array exists
708 ## 0 otherwise
709 ##
710 proc arrayUnsetAll {arrayName} {
711 upvar 1 $arrayName array
712
713 if {[array exists array]} then {
714 foreach name [array names array] {
715 unset array($name)
716 }
717 return 1
718 }
719 return 0
720 }
721
722 ##
723 ## Find the given element in an array
724 ##
725 ## Args: array name, element name
726 ## Returns: case sensitive element name if found,
727 ## nothing otherwise
728 ##
729 proc arrayFindElementName {arrayName element} {
730 upvar 1 $arrayName array
731
732 set list [lsort [array names array]]
733 set index [lsearch -exact [string tolower $list] [string tolower $name]]
734 if {$index != -1} then {
735 return [lindex $list $index]
736 }
737 return
738 }
739
740 ##
741 ## Return length of longest data in an array at index
742 ##
743 ## Args: array name
744 ## Returns: length of longest name in an array
745 ##
746 proc arrayMaxElementDataLength {arrayName index} {
747 upvar 1 $arrayName array
748
749 set maxlength 0
750 foreach {name data} [array get array] {
751 set length [string length [lindex $data $index]]
752 if {$length > $maxlength} then {
753 set maxlength $length
754 }
755 }
756 return $maxlength
757 }
758
759 ##
760 ## Append something to the given list if it is not already in the list
761 ##
762 ## Args: listVar, what
763 ## Returns: list
764 ##
765 proc listAppendIf {listVar {what ""}} {
766 upvar 1 $listVar list
767
768 if {([string compare "" $what]) &&
769 ((![info exists list]) || ([lsearch -exact $list $what] == -1))} then {
770 lappend list $what
771 }
772 return $list
773 }
774
775 ##
776 ## Return length of the longest element in a list
777 ##
778 ## Args: list, index
779 ## Returns: length of longest element in the given list
780 ##
781 proc listMaxElementLength {list {index 0}} {
782 set maxlength 0
783 foreach data $list {
784 set length [string length [lindex $data $index]]
785 if {$length > $maxlength} then {
786 set maxlength $length
787 }
788 }
789 return $maxlength
790 }
791
792 ##
793 ## Split a string into multiple list elements
794 ##
795 ## Args: text, max list length, split char, trim chars
796 ## Returns: split list
797 ##
798 # FIXME: improve this
799 proc splitStringList {text {splitLength 75} {splitChar " "} {trimChars " "}} {
800 # Sanity check splitLength and splitChar
801 if {($splitLength >= 1) && ([string compare "" $splitChar])} then {
802 set elementSplitLength [expr $splitLength - 1]
803 set stringLength [string length $text] ;# Total length of string
804 set subStringLength 0 ;# Text left over
805 set elementLength 0 ;# Element length counter
806 set elementStartIndex 0 ;# Start of split element
807 set elementEndIndex 0 ;# End of split element
808 for {
809 set stringIndex 0
810 } {$stringIndex < $stringLength} {
811 incr stringIndex
812 } {
813 # If element length greater than/equal to split length,
814 # Or element length equal to split length - 1,
815 # And character at current string index is splitChar
816 if {(($elementLength >= $splitLength) ||
817 ($elementLength == $elementSplitLength)) &&
818 (![string compare $splitChar \
819 [string index $text $stringIndex]])} then {
820 # Split substring element from text
821 set string [string range $text $elementStartIndex $elementEndIndex]
822 # Append substring element list to list
823 lappend list [string trim $string $trimChars]
824 # Reset element length counter
825 set elementLength 0
826 # Start split of next element at the end + 1 of the current one
827 set elementStartIndex [expr $elementEndIndex + 1]
828 # Reset end of next element to the start of the next element
829 set elementEndIndex $elementStartIndex
830 # Track remaining text length
831 set subStringLength [expr $subStringLength + [string length $string]]
832 } else {
833 # Increment element length
834 incr elementLength
835 # Increment end of next element
836 incr elementEndIndex
837 }
838 }
839 # Append any left over text as a new element
840 if {$stringLength > $subStringLength} then {
841 lappend list [string trim [string range $text $subStringLength end] $trimChars]
842 }
843 # Whew...that was alot of work!
844 if {[info exists list]} then {
845 return $list
846 }
847 }
848 return
849 }
850
851 ##
852 ## Expand the given text with a list
853 ##
854 ## Args: text, list, elementIndex, resultVar
855 ## Returns: 0 if text not found
856 ## 1 if text is exactly matched
857 ## 2 if text is matched
858 ## -1 if text is ambiguous
859 ##
860 proc expandText {text list elementIndex resultVar} {
861 upvar 1 $resultVar result
862
863 set found 0
864 set ambiguous 0
865 set lowerText [string tolower $text]
866 foreach listElement $list {
867 set compareElement [lindex $listElement $elementIndex]
868
869 # Exact match
870 if {![string compare $text $compareElement]} then {
871 set result $listElement
872 return 1
873
874 # Partial match
875 } elseif {[string match "$lowerText*" [string tolower $compareElement]]} then {
876 if {!$found} then {
877 set result $listElement
878 set found 1
879 } else {
880 set ambiguous 1
881 }
882 }
883 }
884 if {$ambiguous} then {
885 return -1
886 } elseif {$found} then {
887 return 2
888 }
889 return 0
890 }
891
892 ##
893 ## Search an array for a given word or regexp
894 ##
895 ## Args: array name, word/regexp
896 ## Returns: list of indexes that match the given word/regexp
897 ##
898 proc arraySearch {arrayName word} {
899 upvar 1 $arrayName array
900
901 set word [string tolower $word]
902 set ret ""
903 foreach {name data} [array get $array] {
904 set string [string tolower $data]
905 if {[lsearch -regexp $string $word] != -1} then {
906 for {
907 set index 0
908 set indexes ""
909 } {
910 if {[regexp -- .*$word $string]} then {
911 lappend indexes $index
912 }
913 } {
914 incr index
915 }
916 lappend ret [list [concat $name $indexes]]
917 }
918 }
919 return $ret
920 }
921
922 ##
923 ## Find option default for the given option name in a data list
924 ##
925 ## Args: data list, option name
926 ## Returns: option default if found,
927 ## nothing otherwise
928 ##
929 proc dataFormatDefault {list option} {
930 foreach i $list {
931 if {![string compare $option [lindex $i 0]]} then {
932 return [lindex $i 1]
933 }
934 }
935 return
936 }
937
938 ##
939 ## Find option value for the given option name in a data list
940 ##
941 ## Args: data format, data list, option name
942 ## Returns: option value if found,
943 ## nothing otherwise
944 ##
945 proc dataFormatValue {format data option} {
946 if {[set index [lsearch -exact $format $option]] != -1} then {
947 return [lindex $data $index]
948 }
949 return
950 }
951
952 ##
953 ## Build list of data from the given options
954 ##
955 ## Args: data format, data list, option names
956 ## Returns: list of data from the given options
957 ##
958 proc dataFormatList {format data options} {
959 set ret ""
960 foreach option $options {
961 if {[set index [lsearch -exact $format $option]] != -1} then {
962 lappend ret [lindex $data $index]
963 }
964 }
965 return $ret
966 }
967
968 ##
969 ## Replace option data in the given data list with a new value
970 ##
971 ## Args: data format, data list, option name, new value
972 ## Returns: data list
973 ##
974 proc dataFormatReplace {format data option value} {
975 if {[set index [lsearch -exact $format $option]] != -1} then {
976 return [lreplace $data $index $index $value]
977 }
978 return $data
979 }
980
981 ##
982 ## Create a data format list for a given data format and options
983 ##
984 ## Args: data format list, options {{option1 value} ...}
985 ## Returns: data format list with options and values in proper order
986 ##
987 proc dataFormatBuild {format args} {
988 set ret ""
989 foreach arg $args {
990 set [lindex $arg 0] [lindex $arg 1]
991 }
992 foreach opt $format {
993 if {[info exists $opt]} then {
994 lappend ret [set $opt]
995 } else {
996 lappend ret [dataFormatDefault $format $opt]
997 }
998 }
999 return $ret
1000 }
1001
1002 ##
1003 ## Convert a data list from one format to another
1004 ##
1005 ## Args: from format, to format, data list
1006 ## Returns: data list
1007 ##
1008 proc dataFormatConvert {fromFormat toFormat data} {
1009 set ret ""
1010 set index 0
1011 foreach opt $fromFormat {
1012 set $opt [lindex $data $index]
1013 incr index
1014 }
1015 foreach opt $toFormat {
1016 if {[info exists $opt]} then {
1017 lappend ret [set $opt]
1018 } else {
1019 lappend ret [dataFormatDefault $toFormat $opt]
1020 }
1021 }
1022 return $ret
1023 }
1024
1025 ##
1026 ## Scan the given file for module options
1027 ##
1028 ## Args: file, args {only scan for these options}
1029 ## Returns: list of module options if the given file is a module,
1030 ## nothing otherwise
1031 ## Errors: unable to open file for reading
1032 ##
1033 proc scanModule {file args} {
1034 variable moduleDatabaseConfig
1035 variable moduleDatabaseFormat
1036
1037 if {[catch {set fd [open $file r]} result]} then {
1038 error $result
1039 } else {
1040 set ret ""
1041 if {![string compare "" $args]} then {
1042 set baseOptions [lindex $moduleDatabaseFormat([set moduleDatabaseConfig(version)]) 0]
1043 set extraOptions [lindex $moduleDatabaseFormat([set moduleDatabaseConfig(version)]) 1]
1044 set scanOptions "name $baseOptions"
1045 set formatOptions "name $baseOptions $extraOptions"
1046 } else {
1047 set scanOptions $args
1048 set formatOptions $args
1049 }
1050 for {
1051 set lineCount 0
1052 set optionCount 0
1053 set continuedLine 0
1054 } {(![eof $fd]) && ($lineCount <= $moduleDatabaseConfig(scanlines))} {
1055 incr lineCount
1056 } {
1057 gets $fd line
1058 if {[regexp -- "^# .*:.*" $line]} then {
1059 set opt [string trimright [lindex $line 1] :]
1060 if {[lsearch -glob $scanOptions $opt] != -1} then {
1061 set data [string trimright [string trimleft [string range $line [string first : $line] end] " \t:"] " \t\\"]
1062 if {![info exists $opt]} then {
1063 set $opt $data
1064 } else {
1065 append $opt " $data"
1066 }
1067 }
1068 if {[regexp -- \\\\$ $line]} then {
1069 set continuedLine 1
1070 } else {
1071 set continuedLine 0
1072 }
1073 } elseif {($continuedLine) && ([info exists opt])} then {
1074 append $opt " [string trimright [string trimleft $line " \t#"] " \t\\"]"
1075 if {![regexp -- \\\\$ $line]} then {
1076 set continuedLine 0
1077 }
1078 }
1079 }
1080 close $fd
1081 if {(![string compare "" $args]) && \
1082 ((![info exists name]) || \
1083 ([catch {set md5sum [md5Sum $file]}]))} then {
1084 return
1085 }
1086 foreach option $formatOptions {
1087 if {(![info exists $option]) || \
1088 (![string compare "" [set $option]])} then {
1089 set $option [dataFormatDefault $moduleDatabaseConfig(defaults) $option]
1090 }
1091 lappend ret [set $option]
1092 }
1093 return $ret
1094 }
1095 }
1096
1097 ##
1098 ## Get data from module db data array
1099 ##
1100 ## Args: module name, data type
1101 ## Returns: data for the given module's data type if it exists,
1102 ## nothing otherwise
1103 ##
1104 proc getModuleDatabaseData {module type} {
1105 variable moduleDatabaseConfig
1106 variable moduleDatabaseFormat
1107 variable moduleDatabaseData
1108
1109 if {[moduleExists $module]} then {
1110 set index [lsearch -exact [join $moduleDatabaseFormat([set moduleDatabaseConfig(version)])] $type]
1111 if {$index != -1} then {
1112 return [lindex $moduleDatabaseData($module) $index]
1113 }
1114 }
1115 return
1116 }
1117
1118 ##
1119 ## Set data in module db data array
1120 ##
1121 ## Args: module name, data type, data
1122 ## Returns: 1 if valid module and data type,
1123 ## 0 otherwise
1124 ##
1125 proc setModuleDatabaseData {module type data} {
1126 variable moduleDatabaseConfig
1127 variable moduleDatabaseFormat
1128 variable moduleDatabaseData
1129 variable moduleDatabaseDataChanged
1130
1131 if {[moduleExists $module]} then {
1132 set index [lsearch -exact [join $moduleDatabaseFormat([set moduleDatabaseConfig(version)])] $type]
1133 if {$index != -1} then {
1134 set moduleDatabaseData($module) [lreplace $moduleDatabaseData($module) $index $index [list $data]]
1135 set moduleDatabaseDataChanged 1
1136 return 1
1137 }
1138 }
1139 return 0
1140 }
1141
1142 ##
1143 ## Save module database
1144 ##
1145 ## Args: verbose {-1,0,1}
1146 ## Returns: 1 if successful,
1147 ## 0 otherwise
1148 ##
1149 proc saveModuleDatabase {{verbose 0}} {
1150 variable configData
1151 variable moduleDatabaseConfig
1152 variable moduleDatabaseData
1153 variable moduleDatabaseDataChanged
1154
1155 if {[createFile $configData(moddbfile) $verbose "module database file "]} then {
1156 if {[catch {set fd [open $configData(moddbfile) w]} result]} then {
1157 if {$verbose >= 0} then {
1158 wpLog o * "Error: unable to open module database file `$configData(moddbfile)' for writing: $result"
1159 }
1160 } else {
1161 puts $fd "# $moduleDatabaseConfig(header)$moduleDatabaseConfig(version)"
1162 close $fd
1163 set ret [arraySave moduleDatabaseData $configData(moddbfile) $verbose "module database file " a]
1164 if {$ret} then {
1165 set moduleDatabaseDataChanged 0
1166 }
1167 return $ret
1168 }
1169 }
1170 return 0
1171 }
1172
1173 ##
1174 ## Load module database
1175 ##
1176 ## Args: verbose {-1,0,1}
1177 ## Returns: 1 if successful,
1178 ## 0 otherwise
1179 ##
1180 proc loadModuleDatabase {{verbose 0}} {
1181 variable configData
1182 variable moduleDatabaseConfig
1183 variable moduleDatabaseFormat
1184 variable moduleDatabaseData
1185 variable moduleDatabaseDataChanged
1186
1187 if {![file exists $configData(moddbfile)]} then {
1188 return -1
1189 } else {
1190 if {[catch {set fd [open $configData(moddbfile) r]} result]} then {
1191 if {$verbose >= 0} then {
1192 wpLog o * "Error: unable to open module database file `$configData(moddbfile)' for reading: $result"
1193 }
1194 } else {
1195 set firstline [replaceExpr [gets $fd] "^ "]
1196 if {[regexp -- "^# $moduleDatabaseConfig(header)" $firstline]} then {
1197 regsub -all -- "^# $moduleDatabaseConfig(header)" $firstline "" version
1198 if {![string compare [set version [string trim $version]] $moduleDatabaseConfig(version)]} then {
1199 close $fd
1200 return [arrayLoad moduleDatabaseData $configData(moddbfile) $verbose "module database file "]
1201 } elseif {[info exists moduleDatabaseFormat($version)]} then {
1202 if {[info exists moduleDatabaseData]} then {
1203 unset moduleDatabaseData
1204 }
1205 while {![eof $fd]} {
1206 set line [replaceExpr [gets $fd] "^ "]
1207 if {([string compare "" $line]) && \
1208 (![regexp -- "^#" $line])} then {
1209 set moduleDatabaseData([lindex $line 0]) [dataFormatConvert [join $moduleDatabaseFormat($version)] [join $moduleDatabaseFormat([set moduleDatabaseConfig(version)])] [lindex $line 1]]
1210 }
1211 }
1212 close $fd
1213 # FIXME: should this be set to 1 when converting database?
1214 set moduleDatabaseDataChanged 0
1215 return 1
1216 } else {
1217 wpLog o * "Error: unknown module database version: $version"
1218 }
1219 } else {
1220 wpLog o * "Error: unknown module database format: [string trimleft $firstline " \t#"]"
1221 }
1222 }
1223 close $fd
1224 }
1225 return 0
1226 }
1227
1228 ##
1229 ## Add module data to the module database
1230 ##
1231 ## Args: file
1232 ## Returns: nothing
1233 ## Errors: if can't open file for reading
1234 ##
1235 proc updateModuleData {file} {
1236 variable moduleDatabaseConfig
1237 variable moduleDatabaseFormat
1238 variable moduleDatabaseData
1239 variable moduleDatabaseDataChanged
1240
1241 if {[catch {set data [scanModule $file]} result]} then {
1242 error $result
1243 } else {
1244 set name [lindex $data 0]
1245 if {[string compare "" $name]} then {
1246 if {[moduleExists $name]} then {
1247 set loadIndex [lsearch -exact [join $moduleDatabaseFormat([set moduleDatabaseConfig(version)])] load]
1248 set moduleDatabaseData($name) [lreplace [lrange $data 1 end] $loadIndex $loadIndex [lindex $moduleDatabaseData($name) $loadIndex]]
1249 } else {
1250 set moduleDatabaseData($name) [lrange $data 1 end]
1251 }
1252 set moduleDatabaseDataChanged 1
1253 }
1254 }
1255 return
1256 }
1257
1258 ##
1259 ## Update module database
1260 ##
1261 ## Args: verbose {-1,0,1}
1262 ## Returns: nothing
1263 ##
1264 proc updateModuleDatabase {{verbose 0}} {
1265 variable modulePath
1266 variable moduleDatabaseConfig
1267 variable moduleDatabaseData
1268 variable moduleDatabaseDataChanged
1269 variable moduleOptionData
1270
1271 set moduleList [listModules]
1272
1273 set foundFiles "" ;# List of '.tcl' files found in module path
1274 set comparedFiles "" ;# List of compared module files
1275
1276 # Only update the given module(s) when the '-m <file>' option is used.
1277 if {[string compare "" $moduleOptionData(modulefiles)]} then {
1278 set fullSearch 0
1279 set foundFiles $moduleOptionData(modulefiles)
1280 } else {
1281 set fullSearch 1
1282
1283 # Build up file list
1284 foreach dir $modulePath {
1285 foreach file [findFiles $dir $moduleDatabaseConfig(maxdepth) .tcl] {
1286 lappend foundFiles $file
1287 }
1288 }
1289 }
1290
1291 # Find removed files
1292 foreach module $moduleList {
1293 set file [getModuleDatabaseData $module file]
1294
1295 # Only update the given modules if the '-m' option was used
1296 if {($fullSearch) ||
1297 ([lsearch -exact $moduleOptionData(modulefiles) $file] != -1)} then {
1298 set shortfile [shortFile $file $modulePath]
1299
1300 # Remove any invalid module data
1301 if {[lsearch -exact $foundFiles $file] == -1} then {
1302 if {([lsearch -exact $moduleOptionData(excludedfiles) $file] != -1)} then {
1303 if {$verbose >= 1} then {
1304 wpLog o * "Not removing module data for excluded missing file `$shortfile' ($module)"
1305 }
1306 } else {
1307 if {$verbose >= 1} then {
1308 wpLog o * "Removing module data for missing file `$shortfile' ($module)"
1309 }
1310 unset moduleDatabaseData($module)
1311 set moduleDatabaseDataChanged 1
1312 }
1313
1314 # Compare existing valid modules
1315 } else {
1316 if {([lsearch -exact $moduleOptionData(excludedfiles) $file] != -1)} then {
1317 if {$verbose >= 1} then {
1318 wpLog o * "Not comparing excluded file `$shortfile'"
1319 }
1320 } else {
1321 if {$verbose >= 1} then {
1322 wpLog o * "Comparing file `$shortfile'"
1323 }
1324
1325 # Compare md5 from module db and make sure the module hasn't changed
1326 if {([catch {set md5sum [md5Sum $file]}]) || \
1327 ([string compare [getModuleDatabaseData $module md5sum] $md5sum])} then {
1328 if {$verbose >= 1} then {
1329 wpLog o * "Updating module information for file `$shortfile'"
1330 }
1331 if {[catch {updateModuleData $file} result]} then {
1332 if {$verbose >= 0} then {
1333 wpLog o * "Warning: unable to open file `$shortfile' for reading: $result"
1334 }
1335 }
1336 }
1337 }
1338 lappend comparedFiles $file
1339 }
1340 }
1341 }
1342
1343 # Find new module files
1344 foreach file $foundFiles {
1345
1346 # Only update the given modules if the '-m' option was used
1347 if {($fullSearch) ||
1348 ([lsearch -exact $moduleOptionData(modulefiles) $file] != -1)} then {
1349 set shortfile [shortFile $file $modulePath]
1350
1351 if {[lsearch -exact $comparedFiles $file] == -1} then {
1352 if {([lsearch -exact $moduleOptionData(excludedfiles) $file] != -1)} then {
1353 if {$verbose >= 1} then {
1354 wpLog o * "Not adding module information for excluded file `$shortfile'"
1355 }
1356 } else {
1357 if {$verbose >= 1} then {
1358 wpLog o * "Adding module information for file `$shortfile'"
1359 }
1360 if {[catch {updateModuleData $file} result]} then {
1361 if {$verbose >= 0} then {
1362 wpLog o * "Warning: unable to open file `$shortfile' for reading: $result"
1363 }
1364 }
1365 }
1366 }
1367 }
1368 }
1369 return
1370 }
1371
1372 ##
1373 ## Rebuild module database
1374 ##
1375 ## Args: verbose {-1,0,1}
1376 ## Returns: nothing
1377 ##
1378 proc rebuildModuleDatabase {{verbose 0}} {
1379 variable modulePath
1380 variable moduleDatabaseConfig
1381 variable moduleDatabaseFormat
1382 variable moduleDatabaseData
1383
1384 # Copy database data for later use
1385 if {[info exists moduleDatabaseData]} then {
1386 set mergeLoad 1
1387 array set moduleDatabaseDataTmp [array get moduleDatabaseData]
1388 unset moduleDatabaseData
1389 } else {
1390 set mergeLoad 0
1391 }
1392
1393 foreach dir $modulePath {
1394 foreach file [findFiles $dir $moduleDatabaseConfig(maxdepth) .tcl] {
1395 set shortfile [shortFile $file $modulePath]
1396
1397 if {$verbose >= 1} then {
1398 wpLog o * "Scanning file `$shortfile'"
1399 }
1400 if {[catch {updateModuleData $file} result]} then {
1401 if {$verbose >= 0} then {
1402 wpLog o * "Warning: unable to open file `$shortfile' for reading: $result"
1403 }
1404 }
1405 }
1406 }
1407
1408 # Merge load data into new database
1409 if {$mergeLoad} then {
1410 set loadIndex [lsearch -exact [join $moduleDatabaseFormat([set moduleDatabaseConfig(version)])] load]
1411
1412 foreach module [listModules] {
1413 set moduleDatabaseData($module) [lreplace $moduleDatabaseData($module) $loadIndex $loadIndex [lindex $moduleDatabaseDataTmp($module) $loadIndex]]
1414 }
1415 # Note: Not modifying moduleDatabaseDataChanged here, since
1416 # 'updateModuleData' will have already done so.
1417 }
1418 return
1419 }
1420
1421 ##
1422 ## List all modules in the database
1423 ##
1424 ## Args: none
1425 ## Returns: list of modules in module database
1426 ##
1427 proc listModules {{loaded 0}} {
1428 variable moduleDatabaseData
1429 variable moduleLoadedList
1430
1431 if {$loaded} then {
1432 return [lsort $moduleLoadedList]
1433 }
1434 return [lsort [array names moduleDatabaseData]]
1435 }
1436
1437 ##
1438 ## Check if the given module exists
1439 ##
1440 ## Args: module name
1441 ## Returns: 1 if the given module exists
1442 ## 0 otherwise
1443 ##
1444 proc moduleExists {module} {
1445 variable moduleDatabaseData
1446
1447 if {[info exists moduleDatabaseData($module)]} then {
1448 return 1
1449 }
1450 return 0
1451 }
1452
1453 ##
1454 ## Check if a module is loaded
1455 ##
1456 ## Args: module name
1457 ## Returns: 1 if the given module is loaded
1458 ## 0 otherwise
1459 ##
1460 proc moduleLoaded {module} {
1461 variable moduleLoadedList
1462
1463 if {[lsearch -exact $moduleLoadedList $module] != -1} then {
1464 return 1
1465 }
1466 return 0
1467 }
1468
1469 ##
1470 ## Add/remove bindings for a given module
1471 ##
1472 ## Args: mode {bind|unbind}, module,
1473 ## args {{type ...} {option ...} {cmdsub ...} {regsub ...}}
1474 ## Returns: nothing
1475 ##
1476 ## Important variables:
1477 ## argTypes "dcc msg pub ..."
1478 ## argOptions "noauto cmdchr ..."
1479 ## argCmdsub(regexp) "command"
1480 ## argRegsub(regexp) "with"
1481 ## optCmdsub(regexp) "command"
1482 ## optRegsub(regexp) "with"
1483 ##
1484 proc moduleBindUnbind {mode module args} {
1485 variable NamespaceCurrent
1486
1487 if {[info exists ${NamespaceCurrent}::${module}::bindDefaults]} then {
1488 # These are for use in calling this proc directly.
1489 # bindDefaults options are further below
1490 set argTypes ""
1491 set argOptions ""
1492 foreach arg $args {
1493 switch -exact -- [lindex $arg 0] {
1494 type {
1495 # Specific types to match against
1496 # dcc msg pub ...
1497 set argTypes [lrange $arg 1 end]
1498 }
1499 option {
1500 # Specific options to match against
1501 # noauto cmdchr ...
1502 set argOptions [lrange $arg 1 end]
1503 }
1504 cmdsub {
1505 # Replace 'regexp' with result of 'command'
1506 # NOTE: 'command' will eventually be processed in calling stack
1507 foreach {command regexp} [lindex $arg 1] {break}
1508 # FIXME: better fix for leading '+/$'
1509 regsub -- "\[\\+|\\$\]" $regexp "\\\\&" regexp
1510 # FIXME: can't do this:
1511 #regsub -- {([][\\\*\+\?\{\}\,\(\)\:\.\^\$\=\!\|])} $regexp {\\\1} regexp
1512 # Try to find 'command' in 'module' namespace
1513 if {[string compare "" [info commands ${NamespaceCurrent}::${module}::[lindex $command 0]]]} then {
1514 # Command is module specific or imported
1515 set argCmdsub($regexp) ${NamespaceCurrent}::${module}::$command
1516 } else {
1517 # Must be a global command
1518 set argCmdsub($regexp) $command
1519 }
1520 }
1521 regsub {
1522 # Replace regexp 'rwhat' with 'rwith'
1523 foreach {rwhat rwith} [lindex $arg 1] {break}
1524 # FIXME: better fix for leading '+/$'
1525 regsub -- "\[\\+|\\$\]" $rwhat "\\\\&" rwhat
1526 set argRegsub($rwhat) $rwith
1527 }
1528 }
1529 }
1530 foreach {proc data} [array get ${NamespaceCurrent}::${module}::bindDefaults] {
1531 foreach bind $data {
1532 foreach {type flags mask options help} $bind {break}
1533 # Continue if a specific bind type is requested and not matched
1534 if {([string compare "" $argTypes]) && \
1535 ([lsearch -exact $argTypes $type] == -1)} then {
1536 continue
1537 }
1538 # Sanity check!
1539 # Continue if argOptions specified and bind options don't exist
1540 if {([string compare "" $argOptions]) && \
1541 (![string compare "" $options])} then {
1542 continue
1543 }
1544 # These _must_ be clean since they are reused for multiple binds
1545 set continue 0
1546 if {[info exists optCmdsub]} then {
1547 unset optCmdsub
1548 }
1549 if {[info exists optRegsub]} then {
1550 unset optRegsub
1551 }
1552 # Process bind specific options
1553 foreach option $options {
1554 set optcmd [lindex $option 0]
1555 # Search 'argOptions' for 'optcmd'
1556 # Abort bind and continue with next if not found
1557 if {[string compare "" $argOptions]} then {
1558 set found 0
1559 foreach argoption $argOptions {
1560 if {![string compare $optcmd [lindex $argoption 0]]} then {
1561 set found 1
1562 }
1563 }
1564 if {!$found} then {
1565 set continue 1
1566 break
1567 }
1568 }
1569 switch -exact -- $optcmd {
1570 noauto {
1571 # Search for noauto override in argOptions
1572 if {[lsearch -exact $argOptions noauto] == -1} then {
1573 # noauto matched and not overriden
1574 set continue 1
1575 break
1576 }
1577 }
1578 cmdsub {
1579 # Replace 'regexp' with result of 'command'
1580 # NOTE: 'command' will eventually be processed in calling stack
1581 foreach {command regexp} [lindex $option 1] {break}
1582 # FIXME: better fix for leading '+/$'
1583 regsub -- "\[\\+|\\$\]" $regexp "\\\\&" regexp
1584 # Try to find 'command' in 'module' namespace
1585 if {[string compare "" [info commands ${NamespaceCurrent}::${module}::[lindex $command 0]]]} then {
1586 # Command is module specific or imported
1587 set optCmdsub($regexp) ${NamespaceCurrent}::${module}::$command
1588 } else {
1589 # Must be a global command
1590 set optCmdsub($regexp) $command
1591 }
1592 }
1593 regsub {
1594 # Replace regexp 'rwhat' with 'rwith'
1595 foreach {rwhat rwith} [lindex $option 1] {break}
1596 # FIXME: better fix for leading '+/$'
1597 regsub -- "\[\\+|\\$\]" $rwhat "\\\\&" rwhat
1598 set optRegsub($rwhat) $rwith
1599 }
1600 }
1601 }
1602 # Abort this bind and continue with the next
1603 if {$continue} then {
1604 continue
1605 }
1606 # Make optCmdsub regexp substitutions on mask
1607 if {[array exists optCmdsub]} then {
1608 foreach {regexp command} [array get optCmdsub] {
1609 # Process 'command' in calling stack
1610 regsub -all -- $regexp $mask [uplevel 1 $command] mask
1611 }
1612 }
1613 # Make optRegsub regexp substitutions on mask
1614 if {[array exists optRegsub]} then {
1615 foreach {replacewhat replacewith} [array get optRegsub] {
1616 regsub -all -- $replacewhat $mask $replacewith mask
1617 }
1618 }
1619 # Make argCmdsub regexp substitutions on mask
1620 if {[array exists argCmdsub]} then {
1621 foreach {regexp command} [array get argCmdsub] {
1622 # Process 'command' in calling stack
1623 regsub -all -- $regexp $mask [uplevel 1 $command] mask
1624 }
1625 }
1626 # Make argRegsub regexp substitutions on mask
1627 if {[array exists argRegsub]} then {
1628 foreach {replacewhat replacewith} [array get argRegsub] {
1629 regsub -all -- $replacewhat $mask $replacewith mask
1630 }
1631 }
1632 # Finally! bind/unbind ($mode == 'bind' or 'unbind')
1633 # FIXME: do this inside of a 'namespace eval'
1634 if {[catch {
1635 $mode $type $flags $mask ${NamespaceCurrent}::${module}::$proc
1636 } result]} then {
1637 wpLog d * "Error: ${mode}ing $type for $mask: $result"
1638 }
1639 }
1640 }
1641 }
1642 return
1643 }
1644
1645 ##
1646 ## Load a module
1647 ##
1648 ## Args: module name, verbose {-1,0,1}, args {loop detection}
1649 ## Returns: nothing
1650 ## Errors: if unable to load module
1651 ##
1652 proc moduleLoad {module {verbose 0} args} {
1653 variable NamespaceCurrent
1654 variable ExportedWrappers
1655 variable moduleLoadedList
1656
1657 if {[lsearch -exact [set loop [lindex $args 0]] $module] == -1} then {
1658 if {[moduleExists $module]} then {
1659 set preload ""
1660 set requires [getModuleDatabaseData $module requires]
1661 foreach required $requires {
1662 set preloadModule [whichCommandModule $required]
1663 if {[string compare "" $preloadModule]} then {
1664 if {([lsearch -exact $preload $preloadModule] == -1) && \
1665 ([string compare wp $preloadModule]) && \
1666 (![moduleLoaded $preloadModule])} then {
1667 lappend preload $preloadModule
1668 }
1669 } else {
1670 error "required command `$required' not found."
1671 }
1672 }
1673 if {[string compare "" $preload]} then {
1674 foreach premod $preload {
1675 if {[catch {moduleLoad $premod $verbose [concat $loop $module]} result]} then {
1676 error $result
1677 }
1678 }
1679 }
1680 if {[catch {
1681
1682 # Load module into its own namespace
1683 set namespaceScript "namespace eval ${NamespaceCurrent}::${module} \{\n"
1684 append namespaceScript " source \"[getModuleDatabaseData $module file]\"\n"
1685 append namespaceScript "\}"
1686 eval $namespaceScript
1687
1688 } result]} then {
1689 error $result
1690 } else {
1691
1692 # ModulePreInit
1693 if {[string compare "" [info commands ${NamespaceCurrent}::${module}::ModulePreInit]]} then {
1694 ${NamespaceCurrent}::${module}::ModulePreInit
1695 }
1696
1697 set version [getModuleDatabaseData $module version]
1698
1699 # FIXME: do this elsewhere?
1700 # Build list of command wrappers
1701 set commandWrappers ""
1702 foreach wrapper $ExportedWrappers {
1703 append commandWrappers " ${NamespaceCurrent}::$wrapper"
1704 }
1705
1706 # Package version management
1707 package forget $module
1708 package provide ${NamespaceCurrent}::${module} $version
1709
1710 # Set standard module variables
1711 set namespaceScript "namespace eval ${NamespaceCurrent}::${module} \{\n"
1712 append namespaceScript " set NamespaceParent \[namespace parent\]\n"
1713 append namespaceScript " set NamespaceCurrent \[namespace current\]\n"
1714 append namespaceScript " set ModuleName $module\n"
1715 append namespaceScript " set ModuleVersion $version\n"
1716 append namespaceScript " namespace forget *\n"
1717
1718 # Install command wrappers in module namespace
1719 if {[string compare "" $commandWrappers]} then {
1720 append namespaceScript " namespace import $commandWrappers\n"
1721 }
1722
1723 # Imported commands '# requires: ...'
1724 if {[string compare "" $requires]} then {
1725 set namespaceScriptTmp ""
1726 foreach required $requires {
1727 if {[string compare "" [set command [whichCommand $required]]]} then {
1728 append namespaceScriptTmp " $command"
1729 } else {
1730 # FIXME: unknown command
1731 }
1732 }
1733 if {[string compare "" $namespaceScriptTmp]} then {
1734 append namespaceScript " namespace import $namespaceScriptTmp\n"
1735 }
1736 }
1737
1738 # Exported commands '# provides: ...'
1739 if {[string compare "" [set provides [getModuleDatabaseData $module provides]]]} then {
1740 set namespaceScriptTmp ""
1741 foreach provided $provides {
1742 append namespaceScriptTmp " $provided"
1743 }
1744 if {[string compare "" $namespaceScriptTmp]} then {
1745 append namespaceScript "namespace export $namespaceScriptTmp\n"
1746 }
1747 }
1748
1749 # Close and eval
1750 append namespaceScript "\}"
1751 eval $namespaceScript
1752
1753 # Install command wrappers in all child namespaces
1754 if {[string compare "" $commandWrappers]} then {
1755 foreach namespaceChild [listNamespaceChildren ${NamespaceCurrent}::${module}] {
1756 set namespaceScript "namespace eval $namespaceChild \{\n"
1757 append namespaceScript " namespace import $commandWrappers\n"
1758 append namespaceScript "\}"
1759 eval $namespaceScript
1760 }
1761 }
1762
1763 # configData and module specific data
1764 moduleConfigLoad $module 1
1765 moduleConfigCheckdefs $module 1
1766 moduleDataLoad $module 1
1767
1768 # ModuleInit
1769 if {[string compare "" [info commands ${NamespaceCurrent}::${module}::ModuleInit]]} then {
1770 ${NamespaceCurrent}::${module}::ModuleInit
1771 }
1772
1773 # FIXME: check for bindings? duplicates?
1774 # Create binds
1775 moduleBindUnbind bind $module
1776
1777 # Flag module as loaded
1778 if {![getModuleDatabaseData $module load]} then {
1779 setModuleDatabaseData $module load 1
1780 }
1781
1782 # Add module to moduleLoadedList
1783 if {[lsearch -exact $moduleLoadedList $module] == -1} then {
1784 lappend moduleLoadedList $module
1785 if {$verbose >= 1} then {
1786 wpLog o * "Module loaded: $module"
1787 }
1788 }
1789 }
1790 } else {
1791 error "No such module: $module"
1792 }
1793 } else {
1794 regsub -all -- " " $loop " -> " loop
1795 error "Preload endless loop: $loop -> $module"
1796 }
1797 return
1798 }
1799
1800 ##
1801 ## Unload a module
1802 ##
1803 ## Args: module name, verbose {-1,0,1}
1804 ## Returns: nothing
1805 ## Errors: if unable to completely unload module
1806 ##
1807 proc moduleUnload {module {verbose 0}} {
1808 variable NamespaceCurrent
1809 variable moduleLoadedList
1810
1811 # FIXME: handle dependant modules and modules that can't be unloaded
1812 if {[moduleExists $module]} then {
1813 if {[string compare "" [info commands ${NamespaceCurrent}::${module}::ModuleDestroy]]} then {
1814 ${NamespaceCurrent}::${module}::ModuleDestroy
1815 }
1816 # FIXME: check for bindings?
1817 moduleBindUnbind unbind $module
1818 moduleConfigSave $module 1
1819 moduleDataSave $module 1
1820
1821 # FIXME: we should kill off stale timer/utimers here somewhere before unloading
1822
1823 if {[catch {namespace delete ${NamespaceCurrent}::${module}} result]} then {
1824 error $result
1825 } else {
1826 package forget ${NamespaceCurrent}::${module}
1827 if {[getModuleDatabaseData $module load] == 1} then {
1828 setModuleDatabaseData $module load 0
1829 }
1830 set index [lsearch -exact $moduleLoadedList $module]
1831 if {$index != -1} then {
1832 set moduleLoadedList [lreplace $moduleLoadedList $index $index]
1833 if {$verbose >= 1} then {
1834 wpLog o * "Module unloaded: $module"
1835 }
1836 }
1837 }
1838 } else {
1839 error "No such module: $module"
1840 }
1841 return
1842 }
1843
1844 ##
1845 ## Save configuration settings for the given module
1846 ##
1847 ## Args: module, force {0,1}, verbose {-1,0,1}
1848 ## Returns: 1 if settings saved
1849 ## 0 otherwise
1850 ##
1851 proc moduleConfigSave {module {force 0} {verbose 0}} {
1852 variable NamespaceCurrent
1853 variable configData
1854
1855 if {([string compare "" \
1856 [set file [getModuleDatabaseData $module config]]]) && \
1857 ([createDir $configData(configpath)])} then {
1858 set cfgfile [file join $configData(configpath) $file]
1859 if {([getModuleDatabaseData $module load]) && \
1860 (($force) || \
1861 (![info exists ${NamespaceCurrent}::${module}::configDataChanged]) || \
1862 ([set ${NamespaceCurrent}::${module}::configDataChanged]))} then {
1863 if {[arraySave ${NamespaceCurrent}::${module}::configData $cfgfile 0 "$module configuration file "]} then {
1864 if {$verbose >= 1} then {
1865 wpLog o * "Writing $module config file..."
1866 }
1867 set ${NamespaceCurrent}::${module}::configDataChanged 0
1868 return 1
1869 } elseif {$verbose >= 0} then {
1870 wpLog o * "Error writing $module config file."
1871 }
1872 }
1873 }
1874 return 0
1875 }
1876
1877 ##
1878 ## Load configuration settings for the given module
1879 ##
1880 ## Args: module, force {0,1}, verbose {-1,0,1}
1881 ## Returns: 1 if settings loaded
1882 ## 0 otherwise
1883 ##
1884 proc moduleConfigLoad {module {force 0} {verbose 0}} {
1885 variable NamespaceCurrent
1886 variable configData
1887
1888 if {([string compare "" \
1889 [set file [getModuleDatabaseData $module config]]]) && \
1890 ([createDir $configData(configpath)])} then {
1891 set cfgfile [file join $configData(configpath) $file]
1892 if {($force) || \
1893 (![info exists ${NamespaceCurrent}::${module}::configDataChanged]) || \
1894 (![set ${NamespaceCurrent}::${module}::configDataChanged])} then {
1895 if {[arrayLoad ${NamespaceCurrent}::${module}::configData $cfgfile 0 "$module configuration file "]} then {
1896 if {$verbose >= 1} then {
1897 wpLog o * "Loading $module config file..."
1898 }
1899 set ${NamespaceCurrent}::${module}::configDataChanged 0
1900 return 1
1901 } elseif {$verbose >= 0} then {
1902 wpLog o * "Error loading $module config file."
1903 }
1904 }
1905 }
1906 return 0
1907 }
1908
1909 ##
1910 ## Check and set default configuration settings for the given module
1911 ##
1912 ## Args: module, force {0,1}, verbose {-1,0,1}
1913 ## Returns: nothing
1914 ##
1915 proc moduleConfigCheckdefs {module {force 0} {verbose 0}} {
1916 variable NamespaceCurrent
1917
1918 if {([array exists ${NamespaceCurrent}::${module}::configDefaults]) && \
1919 ([string compare "" [getModuleDatabaseData $module config]])} then {
1920 set Changed 0
1921 # Unset unknown variables
1922 foreach name [array names ${NamespaceCurrent}::${module}::configData] {
1923 if {![info exists ${NamespaceCurrent}::${module}::configDefaults($name)]} then {
1924 unset ${NamespaceCurrent}::${module}::configData($name)
1925 set Changed 1
1926 }
1927 }
1928 # Set missing variables to defaults
1929 foreach {name data} [array get ${NamespaceCurrent}::${module}::configDefaults] {
1930 if {![info exists ${NamespaceCurrent}::${module}::configData($name)]} then {
1931 set ${NamespaceCurrent}::${module}::configData($name) [lindex $data 1]
1932 set Changed 1
1933 }
1934 }
1935 # FIXME: do this with a trace?
1936 if {$Changed} then {
1937 set ${NamespaceCurrent}::${module}::configDataChanged 1
1938 }
1939 }
1940 return
1941 }
1942
1943 ##
1944 ## Handle config data for a list of modules
1945 ##
1946 ## Args: action {load|save|checkdefs}, module list, force {0,1},
1947 ## verbose {-1,0,1}
1948 ## Returns: nothing
1949 ##
1950 proc moduleConfig {action modules {force 0} {verbose 0}} {
1951 if {![string compare * $modules]} then {
1952 set modules [listModules 1]
1953 }
1954 switch -exact -- $action {
1955 save {
1956 foreach module $modules {
1957 if {([moduleExists $module]) && ([moduleLoaded $module])} then {
1958 moduleConfigSave $module $force $verbose
1959 }
1960 }
1961 }
1962 load {
1963 foreach module $modules {
1964 if {([moduleExists $module]) && ([moduleLoaded $module])} then {
1965 moduleConfigLoad $module $force $verbose
1966 }
1967 }
1968 }
1969 checkdefs {
1970 foreach module $modules {
1971 if {([moduleExists $module]) && ([moduleLoaded $module])} then {
1972 moduleConfigCheckdefs $module $force $verbose
1973 }
1974 }
1975 }
1976 }
1977 return
1978 }
1979
1980 ##
1981 ## Save data for the given module
1982 ##
1983 ## Args: module, force {0,1}, verbose {-1,0,1}
1984 ## Returns: nothing
1985 ##
1986 proc moduleDataSave {module {force 0} {verbose 0}} {
1987 variable NamespaceCurrent
1988 variable configData
1989
1990 if {([info exists ${NamespaceCurrent}::${module}::dataOptions]) && \
1991 ([createDir $configData(datapath)])} then {
1992 foreach {name data} [array get ${NamespaceCurrent}::${module}::dataOptions] {
1993 foreach {type file desc} $data {break}
1994 if {([info exists type]) && ([info exists file]) && \
1995 ([info exists desc])} then {
1996 set Changed ${NamespaceCurrent}::${module}::${name}Changed
1997 if {($force) || ((![info exists $Changed]) || ([set $Changed]))} then {
1998 if {[${type}Save ${NamespaceCurrent}::${module}::$name [file join $configData(datapath) $file]]} then {
1999 if {$verbose >= 1} then {
2000 wpLog o * "Writing $desc data file..."
2001 }
2002 set $Changed 0
2003 } elseif {$verbose >= 0} then {
2004 wpLog o * "Error writing $desc data file!"
2005 }
2006 }
2007 }
2008 }
2009 }
2010 return
2011 }
2012
2013 ##
2014 ## Load data for the given module
2015 ##
2016 ## Args: module, force {0,1}, verbose {-1,0,1}
2017 ## Returns: nothing
2018 ##
2019 proc moduleDataLoad {module {force 0} {verbose 0}} {
2020 variable NamespaceCurrent
2021 variable configData
2022
2023 if {([info exists ${NamespaceCurrent}::${module}::dataOptions]) && \
2024 ([createDir $configData(datapath)])} then {
2025 foreach {name data} [array get ${NamespaceCurrent}::${module}::dataOptions] {
2026 foreach {type file desc} $data {break}
2027 if {([info exists type]) && ([info exists file]) && \
2028 ([info exists desc])} then {
2029 set Changed ${NamespaceCurrent}::${module}::${name}Changed
2030 if {($force) || ((![info exists $Changed]) || ([set $Changed]))} then {
2031 if {[${type}Load ${NamespaceCurrent}::${module}::$name [file join $configData(datapath) $file]]} then {
2032 if {$verbose >= 1} then {
2033 wpLog o * "Reloading $desc data file..."
2034 }
2035 set $Changed 0
2036 } elseif {$verbose >= 0} then {
2037 wpLog o * "Error reloading $desc data file!"
2038 }
2039 }
2040 }
2041 }
2042 }
2043 return
2044 }
2045
2046 ##
2047 ## Backup data for the given module
2048 ##
2049 ## Args: module, force {0,1}, verbose {-1,0,1}
2050 ## Returns: nothing
2051 ##
2052 proc moduleDataBackup {module {force 0} {verbose 0}} {
2053 variable NamespaceCurrent
2054 variable configData
2055
2056 if {([info exists ${NamespaceCurrent}::${module}::dataOptions]) && \
2057 ([createDir $configData(datapath)])} then {
2058 foreach {name data} [array get ${NamespaceCurrent}::${module}::dataOptions] {
2059 foreach {type file desc} $data {break}
2060 if {([info exists type]) && ([info exists file]) && \
2061 ([info exists desc])} then {
2062 if {[set result [backupFile [file join $configData(datapath) $file] $verbose]]} then {
2063 if {($result >= 1) && ($verbose >= 1)} then {
2064 wpLog o * "Backing up $desc data file..."
2065 }
2066 } elseif {$verbose >= 0} then {
2067 wpLog o * "Error backing up $desc data file!"
2068 }
2069 }
2070 }
2071 }
2072 return
2073 }
2074
2075 ##
2076 ## Handle data for a list of modules
2077 ##
2078 ## Args: action {load|save|backup}, module list, force {0,1},
2079 ## verbose {-1,0,1}
2080 ## Returns: nothing
2081 ##
2082 proc moduleData {action modules {force 0} {verbose 0}} {
2083 if {![string compare * $modules]} then {
2084 set modules [listModules 1]
2085 }
2086 switch -exact -- $action {
2087 save {
2088 foreach module $modules {
2089 if {([moduleExists $module]) && ([moduleLoaded $module])} then {
2090 moduleDataSave $module $force $verbose
2091 }
2092 }
2093 }
2094 load {
2095 foreach module $modules {
2096 if {([moduleExists $module]) && ([moduleLoaded $module])} then {
2097 moduleDataLoad $module $force $verbose
2098 }
2099 }
2100 }
2101 backup {
2102 foreach module $modules {
2103 if {([moduleExists $module]) && ([moduleLoaded $module])} then {
2104 moduleDataBackup $module $force $verbose
2105 }
2106 }
2107 }
2108 }
2109 return
2110 }
2111
2112 ##
2113 ## Builds command matching table from module database
2114 ##
2115 ## Args: none
2116 ## Returns: nothing
2117 ##
2118 proc buildCommandTable {{verbose 0}} {
2119 variable NamespaceCurrent
2120 variable ModuleName
2121 variable ExportedCommands
2122 variable commandTable
2123
2124 foreach command $ExportedCommands {
2125 set arrayIndexName $ModuleName,$command
2126
2127 if {![info exists tmp($arrayIndexName)]} then {
2128 if {$verbose >= 2} then {
2129 wpLog o * "Adding command: `$command' from `$NamespaceCurrent'"
2130 }
2131 set tmp($arrayIndexName) ${NamespaceCurrent}::$command
2132 # Shouldn't happen...
2133 } elseif {$verbose >= 0} then {
2134 wpLog o * "Warning: ignoring duplicate command `$arrayIndexName', conflicts with `$tmp($arrayIndexName)'"
2135 }
2136 }
2137 foreach module [listModules] {
2138 if {[string compare "" [set provides [getModuleDatabaseData $module provides]]]} then {
2139 foreach command $provides {
2140 set arrayIndexName $module,$command
2141
2142 if {![info exists tmp($arrayIndexName)]} then {
2143 if {$verbose >= 2} then {
2144 wpLog o * "Adding command: `$command' from `${NamespaceCurrent}::${module}'"
2145 }
2146 set tmp($arrayIndexName) ${NamespaceCurrent}::${module}::$command
2147 } elseif {$verbose >= 0} then {
2148 wpLog o * "Warning: ignoring duplicate command `$arrayIndexName', conflicts with `$tmp($arrayIndexName)'"
2149 }
2150 }
2151 }
2152 }
2153 if {[info exists commandTable]} then {
2154 unset commandTable
2155 }
2156 array set commandTable [array get tmp]
2157 return
2158 }
2159
2160 ##
2161 ## Return full namespace path for the given command
2162 ##
2163 ## Args: command
2164 ## Returns: full namespace path for the given command if it exists
2165 ## nothing otherwise
2166 ##
2167 proc whichCommand {command} {
2168 variable NamespaceCurrent
2169 variable commandTable
2170
2171 # Search for 'module::command'
2172 if {([regexp "(.*)::(.*)" $command "" tmpModule tmpCommand]) &&
2173 ([info exists $tmpModule]) &&
2174 ([info exists $tmpCommand]) &&
2175 ([info exits commandTable($tmpModule,$tmpCommand)])} then {
2176 return $commandTable($tmpModule,$tmpCommand)
2177 # Search for 'module,command'
2178 } elseif {([regexp -- "," $command]) &&
2179 ([info exists commandTable($command)])} then {
2180 return $commandTable($command)
2181 } else {
2182 set names [array names commandTable *,$command]
2183 if {[llength $names] == 1} then {
2184 return $commandTable($names)
2185 } else {
2186
2187 # FIXME: multiple matches ...
2188
2189 }
2190 }
2191 return
2192 }
2193
2194 ##
2195 ## Return module name that provides the given command
2196 ##
2197 ## Args: command
2198 ## Returns: name of module that provides the given command
2199 ## nothing otherwise
2200 ##
2201 proc whichCommandModule {command} {
2202 variable NamespaceCurrent
2203 variable ModuleName
2204 variable commandTable
2205
2206 # Search for 'module::command'
2207 if {([regexp "(.*)::(.*)" $command "" tmpModule tmpCommand]) &&
2208 ([info exists $tmpModule]) &&
2209 ([info exists $tmpCommand]) &&
2210 ([info exits commandTable($tmpModule,$tmpCommand)])} then {
2211 set lookup $commandTable($tmpModule,$tmpCommand)
2212 } else {
2213 set names [array names commandTable *,$command]
2214 if {[llength $names] == 1} then {
2215 set lookup $commandTable($names)
2216 } else {
2217
2218 # FIXME: multiple matches ...
2219
2220 }
2221 }
2222 if {[info exists lookup]} then {
2223 if {![string compare ${NamespaceCurrent}::$command $lookup]} then {
2224 return $ModuleName
2225 }
2226 return [namespace tail [namespace qualifiers $lookup]]
2227 }
2228 return
2229 }
2230
2231 ##
2232 ## Return full namespace path for the given module
2233 ##
2234 ## Args: module
2235 ## Returns: full namespace path for the given module if it's loaded
2236 ## nothing otherwise
2237 ##
2238 proc whichModule {module} {
2239 variable NamespaceCurrent
2240 variable ModuleName
2241
2242 if {![string compare $ModuleName $module]} then {
2243 return $NamespaceCurrent
2244 } elseif {[moduleLoaded $module]} then {
2245 return ${NamespaceCurrent}::$module
2246 }
2247 return
2248 }
2249
2250 ##
2251 ## Check if the given [module] config option exists
2252 ##
2253 ## Args: module, option
2254 ## Returns: 1 if the given module config option exists
2255 ##
2256 proc configExists {module {option ""}} {
2257 variable NamespaceCurrent
2258 variable configData
2259
2260 if {[string compare "" $module]} then {
2261 set where "${NamespaceCurrent}::${module}::"
2262 } else {
2263 set where ""
2264 }
2265 if {[string compare "" $option]} then {
2266 if {[info exists ${where}configData($option)]} then {
2267 return 1
2268 }
2269 } elseif {[info exists ${where}configData]} then {
2270 return 1
2271 }
2272 return 0
2273 }
2274
2275 ##
2276 ## Compare the given version to eggdrop's version
2277 ##
2278 ## Args: version
2279 ## Returns: 0 if eggdrop's version is older then the given version
2280 ## 1 if eggdrop's version matches the given version
2281 ## 2 if eggdrop's version is newer then the given version
2282 ## -1 if the given version is invalid
2283 ##
2284 proc compareVersion {version} {
2285 global numversion
2286
2287 if {([string compare "" $version]) && \
2288 ([info exists numversion])} then {
2289 if {[regexp -- \\. $version]} then {
2290 regsub -all -- \\. $version 0 version
2291 set version ${version}00
2292 }
2293 if {[regexp -- \[^0-9\] $version]} then {
2294 return -1
2295 } elseif {$numversion == $version} then {
2296 return 1
2297 } elseif {$numversion > $version} then {
2298 return 2
2299 }
2300 }
2301 return 0
2302 }
2303
2304 ##
2305 ## Log module information
2306 ##
2307 ## Args: level, channel, text
2308 ## Returns: nothing
2309 ##
2310 proc wpLog {level channel text} {
2311 set module [namespace tail [uplevel 1 {namespace current}]]
2312 if {(![string compare "" $module]) || \
2313 (![string compare wp $module])} then {
2314 putloglev $level $channel "Wolfpack: $text"
2315 } else {
2316 putloglev $level $channel "Wolfpack: \[$module\] $text"
2317 }
2318 return
2319 }
2320
2321 ##
2322 ## Log Tcl call trace
2323 ##
2324 ## Args: none
2325 ## Returns: nothing
2326 ##
2327 proc callTrace {} {
2328 wpLog o * "Tcl Call Trace"
2329 for {set x [expr [info level] - 1]} {$x > 0} {incr x -1} {
2330 wpLog o * "$x: [info level $x]"
2331 }
2332 return
2333 }
2334
2335 ##
2336 ## Build list of children namespace for the given namespace
2337 ##
2338 ## Args: namespace
2339 ## Returns: list of child namespaces
2340 ##
2341 proc listNamespaceChildren {namespace} {
2342 set children [namespace children $namespace]
2343 foreach child $children {
2344 append children " [listNamespaceChildren $child]"
2345 }
2346 return $children
2347 }
2348
2349 ##
2350 ## Add namespace qualifier onto the given command name
2351 ##
2352 ## Args: command
2353 ## Returns: fully qualified command if found
2354 ##
2355 proc qualifyCommandName {command} {
2356 set qualified [uplevel [expr [info level] - 1] "namespace which $command"]
2357 # set qualified [namespace which $command]
2358 if {[string compare "" $qualified]} then {
2359 return $qualified
2360 }
2361 return $command
2362 }
2363
2364 # FIXME: eliminate 'bind' and 'unbind' with '[namespace code ...]' ?
2365
2366 ##
2367 ## Wrapper for Eggdrop's bind command that adds
2368 ## a fully qualified namespace to the given proc
2369 ##
2370 ## Args: type, flags, mask, {proc ""}
2371 ## Returns: result of global 'bind' command
2372 ##
2373 proc bind {type flags mask {proc ""}} {
2374 if {[string compare "" $proc]} then {
2375 return [::bind $type $flags $mask [qualifyCommandName $proc]]
2376 }
2377 return [::bind $type $flags $mask]
2378 }
2379
2380 ##
2381 ## Wrapper for Eggdrop's unbind command that adds
2382 ## a fully qualified namespace to the given proc
2383 ##
2384 ## Args: type, flags, mask, proc
2385 ## Returns: result of global 'unbind' command
2386 ##
2387 proc unbind {type flags mask proc} {
2388 return [::unbind $type $flags $mask [qualifyCommandName $proc]]
2389 }
2390
2391 ##
2392 ## Evaluate command line arguments
2393 ##
2394 ## Args: none
2395 ## Returns: nothing
2396 ##
2397 proc EvalArgs {argc argv argv0} {
2398 variable ModuleVersion
2399 variable optionData
2400
2401 for {set index 0} {$index < $argc} {incr index} {
2402 set option [lindex $argv $index]
2403 set nextoption [lindex $argv [expr $index + 1]]
2404
2405 switch -regexp -- $option {
2406 (^--$) {
2407 break
2408 }
2409 (^--cfgfile$) {
2410 if {([string compare "" $nextoption]) && \
2411 (![regexp -- - $nextoption])} then {
2412 set optionData(cfgfile) $nextoption
2413 incr index
2414 } else {
2415 listAppendIf noparms "--cfgfile"
2416 }
2417 }
2418 (^--config$) {
2419 set optionData(config) 1
2420 }
2421 (^--update$) {
2422 set optionData(update) 1
2423 }
2424 (^--noupdate$) {
2425 set optionData(noupdate) 1
2426 }
2427 (^--rebuild$) {
2428 set optionData(rebuild) 1
2429 }
2430 (^--time$) {
2431 set optionData(time) 1
2432 }
2433 (^--include$) {
2434 if {([string compare "" $nextoption]) && \
2435 (![regexp -- - $nextoption])} then {
2436 listAppendIf optionData(include) $nextoption
2437 incr index
2438 } else {
2439 listAppendIf noparms "--include"
2440 }
2441 }
2442 (^--exclude$) {
2443 if {([string compare "" $nextoption]) && \
2444 (![regexp -- - $nextoption])} then {
2445 listAppendIf optionData(exclude) $nextoption
2446 incr index
2447 } else {
2448 listAppendIf noparms "--exclude"
2449 }
2450 }
2451 (^--module$) {
2452 if {([string compare "" $nextoption]) && \
2453 (![regexp -- - $nextoption])} then {
2454 listAppendIf optionData(module) $nextoption
2455 incr index
2456 } else {
2457 listAppendIf noparms "--module"
2458 }
2459 }
2460 (^--verbose$) {
2461 incr optionData(verbose)
2462 }
2463 (^--quiet$) {
2464 incr optionData(quiet) -1
2465 }
2466 (^--debug$) {
2467 set optionData(debug) 1
2468 }
2469 (^--help$) {
2470 ShowUsage $argv0
2471 exit
2472 }
2473 (^--version$) {
2474 puts "[file tail $argv0] version $ModuleVersion"
2475 exit
2476 }
2477 (^-\[^-\]*$) {
2478 set suboptions [split $option ""]
2479 set sublength [llength [split $suboptions]]
2480 for {set subindex 0} {$subindex < $sublength} {incr subindex} {
2481 set suboption [lindex $suboptions $subindex]
2482 switch -exact -- $suboption {
2483 - {
2484 continue
2485 }
2486 f {
2487 # Next arg in argv should be a filename: '-f filename.conf',
2488 # so break out of the suboption loop after this option
2489 if {([string compare "" $nextoption]) && \
2490 (![regexp -- - $nextoption])} then {
2491 set optionData(cfgfile) $nextoption
2492 incr index
2493 break
2494 } else {
2495 listAppendIf noparms "-f"
2496 }
2497 }
2498 c {
2499 set optionData(config) 1
2500 }
2501 u {
2502 set optionData(update) 1
2503 }
2504 n {
2505 set optionData(noupdate) 1
2506 }
2507 r {
2508 set optionData(rebuild) 1
2509 }
2510 t {
2511 set optionData(time) 1
2512 }
2513 i {
2514 # Next arg in argv should be a module: '-i module',
2515 # so break out of the suboption loop after this option
2516 if {([string compare "" $nextoption]) && \
2517 (![regexp -- - $nextoption])} then {
2518 listAppendIf optionData(include) $nextoption
2519 incr index
2520 break
2521 } else {
2522 listAppendIf noparms "-i"
2523 }
2524 }
2525 x {
2526 # Next arg in argv should be a module: '-x module',
2527 # so break out of the suboption loop after this option
2528 if {([string compare "" $nextoption]) && \
2529 (![regexp -- - $nextoption])} then {
2530 listAppendIf optionData(exclude) $nextoption
2531 incr index
2532 break
2533 } else {
2534 listAppendIf noparms "-x"
2535 }
2536 }
2537 m {
2538 # Next arg in argv should be a module: '-m module',
2539 # so break out of the suboption loop after this option
2540 if {([string compare "" $nextoption]) && \
2541 (![regexp -- - $nextoption])} then {
2542 listAppendIf optionData(module) $nextoption
2543 incr index
2544 break
2545 } else {
2546 listAppendIf noparms "-m"
2547 }
2548 }
2549 v {
2550 incr optionData(verbose)
2551 }
2552 q {
2553 incr optionData(quiet) -1
2554 }
2555 d {
2556 set optionData(debug) 1
2557 }
2558 H {
2559 ShowUsage $argv0
2560 exit
2561 }
2562 V {
2563 puts "[file tail $argv0] version $ModuleVersion"
2564 exit
2565 }
2566 default {
2567 listAppendIf invalidopt "-$suboption"
2568 }
2569 }
2570 }
2571 }
2572 default {
2573 listAppendIf invalidopt $option
2574 }
2575 }
2576 }
2577
2578 # Complain about invalid command line arguments
2579 if {[info exists invalidopt]} then {
2580 foreach option $invalidopt {
2581 puts stderr "[file tail $argv0]: unrecognized option `$option'"
2582 }
2583 set exit 1
2584 }
2585
2586 # Complain about missing parameters
2587 if {[info exists noparms]} then {
2588 foreach option $noparms {
2589 puts stderr "[file tail $argv0]: option requires a parameter `$option'"
2590 }
2591 set exit 1
2592 }
2593
2594 if {[info exists exit]} then {
2595 exit 1
2596 }
2597 }
2598
2599 ##
2600 ## Show usage information
2601 ##
2602 ## Args: none
2603 ## Returns: nothing
2604 ##
2605 proc ShowUsage {argv0} {
2606 puts "Usage: [file tail $argv0] <options>"
2607 puts " Valid options:"
2608 puts " -f, --cfgfile <file> use configuration file `file'"
2609 puts " -c, --config start interactive configuration"
2610 puts " -u, --update update module database"
2611 puts " -n, --noupdate don't update module database even if its outdated"
2612 puts " -r, --rebuild force complete rebuild of module database"
2613 puts " -t, --time time compare/update/rebuild of module database"
2614 puts " -i, --include <file> include module `file' when updating database"
2615 puts " -x, --exclude <file> exclude module `file' when updating database"
2616 puts " -m, --module <file> only update database for module `file'"
2617 puts " -v, --verbose use more than once for more verbose operation"
2618 puts " -q, --quiet use more than once for quieter operation"
2619 puts " -d, --debug start debug mode with tclsh"
2620 puts " -H, --help show this help"
2621 puts " -V, --version show version information"
2622 }
2623
2624 ##
2625 ## Build array of module option data
2626 ##
2627 ## Args: verbose
2628 ## Returns: nothing
2629 ##
2630 proc ParseModuleOptionData {{verbose 0}} {
2631 variable configData
2632 variable optionData
2633 variable modulePath
2634 variable moduleOptionData
2635
2636 # Add valid files to the include, exclude, and module lists
2637 foreach option "include exclude module" {
2638 if {[string compare "" $optionData($option)]} then {
2639 if {[string compare "" $moduleOptionData($option)]} then {
2640 set moduleOptionData($option) ""
2641 }
2642
2643 foreach file $optionData($option) {
2644 foreach dir $modulePath {
2645 set fullfile [file join $dir $file]
2646 if {([file exists $fullfile]) && ([file readable $fullfile])} then {
2647 lappend moduleOptionData($option) "$file $fullfile"
2648 break
2649 }
2650 }
2651 }
2652 }
2653 }
2654
2655 # Build list of excluded files
2656 if {[string compare "" $moduleOptionData(exclude)]} then {
2657 set moduleOptionData(excludedfiles) ""
2658
2659 if {[string compare "" $moduleOptionData(include)]} then {
2660 foreach exclude $moduleOptionData(exclude) {
2661 foreach {excludeFile excludeFullFile} $exclude {break}
2662 set found 0
2663 foreach include $moduleOptionData(include) {
2664 foreach {includeFile includeFullFile} $include {break}
2665 if {![string compare $excludeFullFile $includeFullFile]} then {
2666 set found 1
2667 break
2668 }
2669 }
2670 if {!$found} then {
2671 lappend moduleOptionData(excludedfiles) $excludeFullFile
2672 }
2673 }
2674 } else {
2675 foreach exclude $moduleOptionData(exclude) {
2676 foreach {file fullfile} $exclude {break}
2677 lappend moduleOptionData(excludedfiles) $fullfile
2678 }
2679 }
2680 }
2681
2682 # Build list of module files
2683 if {[string compare "" $moduleOptionData(module)]} then {
2684 set moduleOptionData(modulefiles) ""
2685
2686 foreach module $moduleOptionData(module) {
2687 foreach {file fullfile} $module {break}
2688 lappend moduleOptionData(modulefiles) $fullfile
2689 }
2690 }
2691 return
2692 }
2693
2694 ##
2695 ## Enter interactive configuration
2696 ##
2697 ## Args: none
2698 ## Returns: nothing
2699 ##
2700 proc Iconfig {} {
2701 variable NamespaceCurrent
2702 variable SessionData
2703
2704 set SessionData(prompt) "wolfpack> "
2705 fileevent stdin readable ${NamespaceCurrent}::IconfigReadStdin
2706 puts "Entering wolfpack configuration system..."
2707 puts "Type 'help' for help."
2708 puts -nonewline $SessionData(prompt)
2709 flush stdout
2710 vwait forever
2711 }
2712
2713 ##
2714 ## Read stdin and process commands
2715 ##
2716 ## Args: none
2717 ## Returns: nothing
2718 ##
2719 # FIXME: readline-like support?
2720 proc IconfigReadStdin {} {
2721 variable SessionData
2722 variable configData
2723 variable configFile
2724
2725 set exit 0
2726 if {[eof stdin]} {
2727 set exit 1
2728 }
2729 set stdin [string trimright [gets stdin]]
2730 set data [join [lrange [split $stdin] 1 end]]
2731 if {[string compare "" $stdin]} then {
2732 switch -exact -- [lindex [split $stdin] 0] {
2733 set {
2734 IconfigSet $data
2735 }
2736 enable {
2737 IconfigEnable $data
2738 }
2739 disable {
2740 IconfigDisable $data
2741 }
2742 modules {
2743 IconfigModules $data
2744 }
2745 info {
2746 IconfigInfo $data
2747 }
2748 help {
2749 IconfigHelp $data
2750 }
2751 quit {
2752 set exit 1
2753 }
2754 default {
2755 puts "What? You need 'help'"
2756 }
2757 }
2758 }
2759 if {(!$exit) && (![eof stdin])} then {
2760 puts -nonewline $SessionData(prompt)
2761 flush stdout
2762 } else {
2763 # Save configuration data
2764 arraySave configData $configFile 0 "configuration file "
2765 # Save module database
2766 saveModuleDatabase
2767 puts ""
2768 flush stdout
2769 exit
2770 }
2771 return
2772 }
2773
2774 ##
2775 ## Set configuration settings
2776 ##
2777 ## Args: data
2778 ## Returns: nothing
2779 ##
2780 proc IconfigSet {data} {
2781 variable configData
2782 variable configDefaults
2783
2784 if {![string compare "" $data]} then {
2785 set fmtlen1 [arrayMaxElementDataLength configDefaults 3]
2786 if {$fmtlen1 < 13} then {
2787 set fmtlen1 13 ;# 'Description: '
2788 }
2789 set names [array names configData]
2790 set fmtlen2 [listMaxElementLength $names]
2791 if {$fmtlen2 < 8} then {
2792 set fmtlen2 8 ;# 'Option: '
2793 }
2794 puts ""
2795 puts "Current settings:"
2796 puts ""
2797 # FIXME: this needs improvement
2798 puts [format " %-${fmtlen1}s %-${fmtlen2}s %s" Description: Option: Value:]
2799 foreach option [lsort $names] {
2800 if {[info exists configDefaults($option)]} then {
2801 puts [format " %-${fmtlen1}s %-${fmtlen2}s %s" [lindex $configDefaults($option) 3] $option $configData($option)]
2802 } else {
2803 puts [format " %-${fmtlen1}s %-${fmtlen2}s %s" "" $option $configData($option)]
2804 }
2805 }
2806 puts ""
2807 } else {
2808 set option [lindex [split $data] 0]
2809 if {![info exists configData($option)]} then {
2810 puts "Invalid option: $option"
2811 } else {
2812 set value [join [lrange [split $data] 1 end]]
2813 if {![string compare "" $value]} then {
2814 puts "Currently: $configData($option)"
2815 } else {
2816 set configData($option) $value
2817 puts "Set $option to: $value"
2818 }
2819 }
2820 }
2821 return
2822 }
2823
2824 ##
2825 ## Enable a module
2826 ##
2827 ## Args: data
2828 ## Returns: nothing
2829 ##
2830 proc IconfigEnable {data} {
2831 set module [lindex [split $data] 0]
2832 if {![string compare "" $module]} then {
2833 puts "Usage: enable <module>"
2834 } elseif {[moduleExists $module]} then {
2835 if {![getModuleDatabaseData $module load]} then {
2836 setModuleDatabaseData $module load 1
2837 puts "Enabled module: $module"
2838 } else {
2839 puts "Module `$module' is already enabled."
2840 }
2841 } else {
2842 puts "Invalid module: $module"
2843 }
2844 return
2845 }
2846
2847 ##
2848 ## Disable a module
2849 ##
2850 ## Args: data
2851 ## Returns: nothing
2852 ##
2853 proc IconfigDisable {data} {
2854 set module [lindex [split $data] 0]
2855 if {![string compare "" $module]} then {
2856 puts "Usage: disable <module>"
2857 } elseif {[moduleExists $module]} then {
2858 if {[getModuleDatabaseData $module load] == 1} then {
2859 setModuleDatabaseData $module load 0
2860 puts "Disabled module: $module"
2861 } else {
2862 puts "Module `$module' is already disabled."
2863 }
2864 } else {
2865 puts "Invalid module: $module"
2866 }
2867 return
2868 }
2869
2870 ##
2871 ## List modules
2872 ##
2873 ## Args: data
2874 ## returns: nothing
2875 ##
2876 # FIXME: format the list of modules better (proc from texttools?)
2877 proc IconfigModules {data} {
2878 if {[string compare "" [set modules [listModules]]]} then {
2879 set what [lindex [split $data] 0]
2880 if {![string compare "" $what]} then {
2881 set what "all"
2882 }
2883 switch -exact -- $what {
2884 * -
2885 all {
2886 puts "Available modules:"
2887 foreach line [splitStringList $modules 65 " " " "] {
2888 puts " $line"
2889 }
2890 }
2891 enabled {
2892 set list ""
2893 foreach module $modules {
2894 if {[getModuleDatabaseData $module load]} {
2895 lappend list $module
2896 }
2897 }
2898 if {[llength $list]} then {
2899 puts "Enabled modules:"
2900 foreach line [splitStringList $list 65 " " " "] {
2901 puts " $line"
2902 }
2903 } else {
2904 puts "No modules enabled"
2905 }
2906 }
2907 disabled {
2908 set list ""
2909 foreach module $modules {
2910 if {![getModuleDatabaseData $module load]} {
2911 lappend list $module
2912 }
2913 }
2914 if {[llength $list]} then {
2915 puts "Disabled modules:"
2916 foreach line [splitStringList $list 65 " " " "] {
2917 puts " $line"
2918 }
2919 } else {
2920 puts "No modules disabled"
2921 }
2922 }
2923 default {
2924 puts "Error: 'option' must be one of: all, enabled, disabled"
2925 }
2926 }
2927 } else {
2928 puts "Error: No modules available."
2929 }
2930 return
2931 }
2932
2933 ##
2934 ## Show info for the given module
2935 ##
2936 ## Args: data
2937 ## returns: nothing
2938 ##
2939 # FIXME: add multiple module support as in config.tcl and or integrate?
2940 proc IconfigInfo {data} {
2941 set module [lindex [split $data] 0]
2942 if {![string compare "" $module]} then {
2943 puts "Usage: info <module>"
2944 } elseif {[moduleExists $module]} then {
2945 puts "Info for module: $module"
2946 puts ""
2947 puts "Filename: [getModuleDatabaseData $module file]"
2948 puts "MD5: [getModuleDatabaseData $module md5sum]"
2949 puts "Version: [getModuleDatabaseData $module version]"
2950 if {[getModuleDatabaseData $module load]} then {
2951 puts "Enabled: yes"
2952 } else {
2953 puts "Enabled: no"
2954 }
2955 if {[string compare "" [set config [getModuleDatabaseData $module config]]]} then {
2956