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