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