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