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