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