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