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