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