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