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