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