/[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.43 - (show annotations) (download) (as text)
Sat Apr 3 04:35:31 2004 UTC (15 years, 6 months ago) by tothwolf
Branch: MAIN
Changes since 1.42: +6 -6 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.42 2004/01/12 09:21:10 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 {source [getModuleDatabaseData $module file]} result]} then {
1640 error $result
1641 } else {
1642
1643 # ModulePreInit
1644 if {[string compare "" [info commands ${NamespaceCurrent}::${module}::ModulePreInit]]} then {
1645 ${NamespaceCurrent}::${module}::ModulePreInit
1646 }
1647
1648 set version [getModuleDatabaseData $module version]
1649
1650 # Package management
1651 package forget $module
1652 package provide ${NamespaceCurrent}::${module} $version
1653
1654 # Set standard module variables
1655 set namespaceScript "namespace eval ${NamespaceCurrent}::${module} \{\n"
1656 append namespaceScript " set NamespaceParent \[namespace parent\]\n"
1657 append namespaceScript " set NamespaceCurrent \[namespace current\]\n"
1658 append namespaceScript " set ModuleName $module\n"
1659 append namespaceScript " set ModuleVersion $version\n"
1660 append namespaceScript " namespace forget *\n"
1661
1662 # Imported commands '# requires: ...'
1663 if {[string compare "" $requires]} then {
1664 set namespaceScriptTmp " namespace import"
1665 set count 0
1666 foreach required $requires {
1667 if {[string compare "" [set command [whichCommand $required]]]} then {
1668 append namespaceScriptTmp " $command"
1669 incr count
1670 }
1671 }
1672 if {$count} then {
1673 append namespaceScript "$namespaceScriptTmp\n"
1674 }
1675 }
1676
1677 # Exported commands '# provides: ...'
1678 if {[string compare "" [set provides [getModuleDatabaseData $module provides]]]} then {
1679 set namespaceScriptTmp " namespace export"
1680 set count 0
1681 foreach provided $provides {
1682 append namespaceScriptTmp " $provided"
1683 incr count
1684 }
1685 if {$count} then {
1686 append namespaceScript "$namespaceScriptTmp\n"
1687 }
1688 }
1689
1690 # Close and eval
1691 append namespaceScript "\}"
1692 eval $namespaceScript
1693
1694 # configData and module specific data
1695 moduleConfigLoad $module 1
1696 moduleConfigCheckdefs $module 1
1697 moduleDataLoad $module 1
1698
1699 # ModuleInit
1700 if {[string compare "" [info commands ${NamespaceCurrent}::${module}::ModuleInit]]} then {
1701 ${NamespaceCurrent}::${module}::ModuleInit
1702 }
1703
1704 # FIXME: check for bindings? duplicates?
1705 # Create binds
1706 moduleBindUnbind bind $module
1707
1708 # Flag module as loaded
1709 if {![getModuleDatabaseData $module load]} then {
1710 setModuleDatabaseData $module load 1
1711 }
1712
1713 # Add module to moduleLoadedList
1714 if {[lsearch -exact $moduleLoadedList $module] == -1} then {
1715 lappend moduleLoadedList $module
1716 if {$verbose >= 1} then {
1717 wpLog o * "Module loaded: $module"
1718 }
1719 }
1720 }
1721 } else {
1722 error "No such module: $module"
1723 }
1724 } else {
1725 regsub -all -- " " $loop " -> " loop
1726 error "Preload endless loop: $loop -> $module"
1727 }
1728 return
1729 }
1730
1731 ##
1732 ## Unload a module
1733 ##
1734 ## Args: module name, verbose {-1,0,1}
1735 ## Returns: nothing
1736 ## Errors: if unable to completely unload module
1737 ##
1738 proc moduleUnload {module {verbose 0}} {
1739 variable NamespaceCurrent
1740 variable moduleLoadedList
1741
1742 # FIXME: handle dependant modules and modules that can't be unloaded
1743 if {[moduleExists $module]} then {
1744 if {[string compare "" [info commands ${NamespaceCurrent}::${module}::ModuleDestroy]]} then {
1745 ${NamespaceCurrent}::${module}::ModuleDestroy
1746 }
1747 # FIXME: check for bindings?
1748 moduleBindUnbind unbind $module
1749 moduleConfigSave $module 1
1750 moduleDataSave $module 1
1751
1752 # FIXME: we should kill off stale timer/utimers here somewhere before unloading
1753
1754 if {[catch {namespace delete ${NamespaceCurrent}::${module}} result]} then {
1755 error $result
1756 } else {
1757 package forget ${NamespaceCurrent}::${module}
1758 if {[getModuleDatabaseData $module load] == 1} then {
1759 setModuleDatabaseData $module load 0
1760 }
1761 set index [lsearch -exact $moduleLoadedList $module]
1762 if {$index != -1} then {
1763 set moduleLoadedList [lreplace $moduleLoadedList $index $index]
1764 if {$verbose >= 1} then {
1765 wpLog o * "Module unloaded: $module"
1766 }
1767 }
1768 }
1769 } else {
1770 error "No such module: $module"
1771 }
1772 return
1773 }
1774
1775 ##
1776 ## Save configuration settings for the given module
1777 ##
1778 ## Args: module, force {0,1}, verbose {-1,0,1}
1779 ## Returns: 1 if settings saved
1780 ## 0 otherwise
1781 ##
1782 proc moduleConfigSave {module {force 0} {verbose 0}} {
1783 variable NamespaceCurrent
1784 variable configData
1785
1786 if {([string compare "" \
1787 [set file [getModuleDatabaseData $module config]]]) && \
1788 ([createDir $configData(configpath)])} then {
1789 set cfgfile [file join $configData(configpath) $file]
1790 if {([getModuleDatabaseData $module load]) && \
1791 (($force) || \
1792 (![info exists ${NamespaceCurrent}::${module}::configDataChanged]) || \
1793 ([set ${NamespaceCurrent}::${module}::configDataChanged]))} then {
1794 if {[arraySave ${NamespaceCurrent}::${module}::configData $cfgfile 0 "$module configuration file "]} then {
1795 if {$verbose >= 1} then {
1796 wpLog o * "Writing $module config file..."
1797 }
1798 set ${NamespaceCurrent}::${module}::configDataChanged 0
1799 return 1
1800 } elseif {$verbose >= 0} then {
1801 wpLog o * "Error writing $module config file."
1802 }
1803 }
1804 }
1805 return 0
1806 }
1807
1808 ##
1809 ## Load configuration settings for the given module
1810 ##
1811 ## Args: module, force {0,1}, verbose {-1,0,1}
1812 ## Returns: 1 if settings loaded
1813 ## 0 otherwise
1814 ##
1815 proc moduleConfigLoad {module {force 0} {verbose 0}} {
1816 variable NamespaceCurrent
1817 variable configData
1818
1819 if {([string compare "" \
1820 [set file [getModuleDatabaseData $module config]]]) && \
1821 ([createDir $configData(configpath)])} then {
1822 set cfgfile [file join $configData(configpath) $file]
1823 if {($force) || \
1824 (![info exists ${NamespaceCurrent}::${module}::configDataChanged]) || \
1825 (![set ${NamespaceCurrent}::${module}::configDataChanged])} then {
1826 if {[arrayLoad ${NamespaceCurrent}::${module}::configData $cfgfile 0 "$module configuration file "]} then {
1827 if {$verbose >= 1} then {
1828 wpLog o * "Loading $module config file..."
1829 }
1830 set ${NamespaceCurrent}::${module}::configDataChanged 0
1831 return 1
1832 } elseif {$verbose >= 0} then {
1833 wpLog o * "Error loading $module config file."
1834 }
1835 }
1836 }
1837 return 0
1838 }
1839
1840 ##
1841 ## Check and set default configuration settings for the given module
1842 ##
1843 ## Args: module, force {0,1}, verbose {-1,0,1}
1844 ## Returns: nothing
1845 ##
1846 proc moduleConfigCheckdefs {module {force 0} {verbose 0}} {
1847 variable NamespaceCurrent
1848
1849 if {([array exists ${NamespaceCurrent}::${module}::configDefaults]) && \
1850 ([string compare "" [getModuleDatabaseData $module config]])} then {
1851 set Changed 0
1852 # Unset unknown variables
1853 foreach name [array names ${NamespaceCurrent}::${module}::configData] {
1854 if {![info exists ${NamespaceCurrent}::${module}::configDefaults($name)]} then {
1855 unset ${NamespaceCurrent}::${module}::configData($name)
1856 set Changed 1
1857 }
1858 }
1859 # Set missing variables to defaults
1860 foreach {name data} [array get ${NamespaceCurrent}::${module}::configDefaults] {
1861 if {![info exists ${NamespaceCurrent}::${module}::configData($name)]} then {
1862 set ${NamespaceCurrent}::${module}::configData($name) [lindex $data 1]
1863 set Changed 1
1864 }
1865 }
1866 # FIXME: do this with a trace?
1867 if {$Changed} then {
1868 set ${NamespaceCurrent}::${module}::configDataChanged 1
1869 }
1870 }
1871 return
1872 }
1873
1874 ##
1875 ## Handle config data for a list of modules
1876 ##
1877 ## Args: action {load|save|checkdefs}, module list, force {0,1},
1878 ## verbose {-1,0,1}
1879 ## Returns: nothing
1880 ##
1881 proc moduleConfig {action modules {force 0} {verbose 0}} {
1882 if {![string compare * $modules]} then {
1883 set modules [listModules 1]
1884 }
1885 switch -exact -- $action {
1886 save {
1887 foreach module $modules {
1888 if {([moduleExists $module]) && ([moduleLoaded $module])} then {
1889 moduleConfigSave $module $force $verbose
1890 }
1891 }
1892 }
1893 load {
1894 foreach module $modules {
1895 if {([moduleExists $module]) && ([moduleLoaded $module])} then {
1896 moduleConfigLoad $module $force $verbose
1897 }
1898 }
1899 }
1900 checkdefs {
1901 foreach module $modules {
1902 if {([moduleExists $module]) && ([moduleLoaded $module])} then {
1903 moduleConfigCheckdefs $module $force $verbose
1904 }
1905 }
1906 }
1907 }
1908 return
1909 }
1910
1911 ##
1912 ## Save data for the given module
1913 ##
1914 ## Args: module, force {0,1}, verbose {-1,0,1}
1915 ## Returns: nothing
1916 ##
1917 proc moduleDataSave {module {force 0} {verbose 0}} {
1918 variable NamespaceCurrent
1919 variable configData
1920
1921 if {([info exists ${NamespaceCurrent}::${module}::dataOptions]) && \
1922 ([createDir $configData(datapath)])} then {
1923 foreach {name data} [array get ${NamespaceCurrent}::${module}::dataOptions] {
1924 foreach {type file desc} $data {break}
1925 if {([info exists type]) && ([info exists file]) && \
1926 ([info exists desc])} then {
1927 set Changed ${NamespaceCurrent}::${module}::${name}Changed
1928 if {($force) || ((![info exists $Changed]) || ([set $Changed]))} then {
1929 if {[${type}Save ${NamespaceCurrent}::${module}::$name [file join $configData(datapath) $file]]} then {
1930 if {$verbose >= 1} then {
1931 wpLog o * "Writing $desc data file..."
1932 }
1933 set $Changed 0
1934 } elseif {$verbose >= 0} then {
1935 wpLog o * "Error writing $desc data file!"
1936 }
1937 }
1938 }
1939 }
1940 }
1941 return
1942 }
1943
1944 ##
1945 ## Load data for the given module
1946 ##
1947 ## Args: module, force {0,1}, verbose {-1,0,1}
1948 ## Returns: nothing
1949 ##
1950 proc moduleDataLoad {module {force 0} {verbose 0}} {
1951 variable NamespaceCurrent
1952 variable configData
1953
1954 if {([info exists ${NamespaceCurrent}::${module}::dataOptions]) && \
1955 ([createDir $configData(datapath)])} then {
1956 foreach {name data} [array get ${NamespaceCurrent}::${module}::dataOptions] {
1957 foreach {type file desc} $data {break}
1958 if {([info exists type]) && ([info exists file]) && \
1959 ([info exists desc])} then {
1960 set Changed ${NamespaceCurrent}::${module}::${name}Changed
1961 if {($force) || ((![info exists $Changed]) || ([set $Changed]))} then {
1962 if {[${type}Load ${NamespaceCurrent}::${module}::$name [file join $configData(datapath) $file]]} then {
1963 if {$verbose >= 1} then {
1964 wpLog o * "Reloading $desc data file..."
1965 }
1966 set $Changed 0
1967 } elseif {$verbose >= 0} then {
1968 wpLog o * "Error reloading $desc data file!"
1969 }
1970 }
1971 }
1972 }
1973 }
1974 return
1975 }
1976
1977 ##
1978 ## Backup data for the given module
1979 ##
1980 ## Args: module, force {0,1}, verbose {-1,0,1}
1981 ## Returns: nothing
1982 ##
1983 proc moduleDataBackup {module {force 0} {verbose 0}} {
1984 variable NamespaceCurrent
1985 variable configData
1986
1987 if {([info exists ${NamespaceCurrent}::${module}::dataOptions]) && \
1988 ([createDir $configData(datapath)])} then {
1989 foreach {name data} [array get ${NamespaceCurrent}::${module}::dataOptions] {
1990 foreach {type file desc} $data {break}
1991 if {([info exists type]) && ([info exists file]) && \
1992 ([info exists desc])} then {
1993 if {[set result [backupFile [file join $configData(datapath) $file] $verbose]]} then {
1994 if {($result >= 1) && ($verbose >= 1)} then {
1995 wpLog o * "Backing up $desc data file..."
1996 }
1997 } elseif {$verbose >= 0} then {
1998 wpLog o * "Error backing up $desc data file!"
1999 }
2000 }
2001 }
2002 }
2003 return
2004 }
2005
2006 ##
2007 ## Handle data for a list of modules
2008 ##
2009 ## Args: action {load|save|backup}, module list, force {0,1},
2010 ## verbose {-1,0,1}
2011 ## Returns: nothing
2012 ##
2013 proc moduleData {action modules {force 0} {verbose 0}} {
2014 if {![string compare * $modules]} then {
2015 set modules [listModules 1]
2016 }
2017 switch -exact -- $action {
2018 save {
2019 foreach module $modules {
2020 if {([moduleExists $module]) && ([moduleLoaded $module])} then {
2021 moduleDataSave $module $force $verbose
2022 }
2023 }
2024 }
2025 load {
2026 foreach module $modules {
2027 if {([moduleExists $module]) && ([moduleLoaded $module])} then {
2028 moduleDataLoad $module $force $verbose
2029 }
2030 }
2031 }
2032 backup {
2033 foreach module $modules {
2034 if {([moduleExists $module]) && ([moduleLoaded $module])} then {
2035 moduleDataBackup $module $force $verbose
2036 }
2037 }
2038 }
2039 }
2040 return
2041 }
2042
2043 ##
2044 ## Builds command matching table from module database
2045 ##
2046 ## Args: none
2047 ## Returns: nothing
2048 ##
2049 proc buildCommandTable {{verbose 0}} {
2050 variable NamespaceCurrent
2051 variable ExportList
2052 variable commandTable
2053
2054 foreach command $ExportList {
2055 if {![info exists tmp($command)]} then {
2056 if {$verbose >= 2} then {
2057 wpLog o * "Adding command: `$command' as `${NamespaceCurrent}::$command'"
2058 }
2059 set tmp($command) ${NamespaceCurrent}::$command
2060 } elseif {$verbose >= 0} then {
2061 wpLog o * "Warning: ignoring duplicate command `$command', conflicts with `$tmp($command)'"
2062 }
2063 }
2064 foreach module [listModules] {
2065 if {[string compare "" [set provides [getModuleDatabaseData $module provides]]]} then {
2066 foreach command $provides {
2067 if {![info exists tmp($command)]} then {
2068 if {$verbose >= 2} then {
2069 wpLog o * "Adding command: `$command' as `${NamespaceCurrent}::${module}::$command'"
2070 }
2071 set tmp($command) ${NamespaceCurrent}::${module}::$command
2072 } elseif {$verbose >= 0} then {
2073 wpLog o * "Warning: ignoring duplicate command `$command', conflicts with `$tmp($command)'"
2074 }
2075 }
2076 }
2077 }
2078 if {[info exists commandTable]} then {
2079 unset commandTable
2080 }
2081 array set commandTable [array get tmp]
2082 return
2083 }
2084
2085 ##
2086 ## Return full namespace path for the given command
2087 ##
2088 ## Args: command
2089 ## Returns: full namespace path for the given command if it exists
2090 ## nothing otherwise
2091 ##
2092 proc whichCommand {command} {
2093 variable commandTable
2094
2095 if {[info exists commandTable($command)]} then {
2096 return $commandTable($command)
2097 }
2098 return
2099 }
2100
2101 ##
2102 ## Return full namespace path for the given module
2103 ##
2104 ## Args: module
2105 ## Returns: full namespace path for the given module if it's loaded
2106 ## nothing otherwise
2107 ##
2108 proc whichModule {module} {
2109 variable NamespaceCurrent
2110 variable ModuleName
2111
2112 if {![string compare $ModuleName $module]} then {
2113 return $NamespaceCurrent
2114 } elseif {[moduleLoaded $module]} then {
2115 return ${NamespaceCurrent}::$module
2116 }
2117 return
2118 }
2119
2120 ##
2121 ## Return module name that provides the given command
2122 ##
2123 ## Args: command
2124 ## Returns: name of module that provides the given command
2125 ## nothing otherwise
2126 ##
2127 proc whichModuleCommand {command} {
2128 variable NamespaceCurrent
2129 variable ModuleName
2130 variable commandTable
2131
2132 if {[info exists commandTable($command)]} then {
2133 if {![string compare ${NamespaceCurrent}::$command \
2134 $commandTable($command)]} then {
2135 return $ModuleName
2136 }
2137 return [namespace tail [namespace qualifiers $commandTable($command)]]
2138 }
2139 return
2140 }
2141
2142 ##
2143 ## Check if the given [module] config option exists
2144 ##
2145 ## Args: module, option
2146 ## Returns: 1 if the given module config option exists
2147 ##
2148 proc configExists {module {option ""}} {
2149 variable NamespaceCurrent
2150 variable configData
2151
2152 if {[string compare "" $module]} then {
2153 set where "${NamespaceCurrent}::${module}::"
2154 } else {
2155 set where ""
2156 }
2157 if {[string compare "" $option]} then {
2158 if {[info exists ${where}configData($option)]} then {
2159 return 1
2160 }
2161 } elseif {[info exists ${where}configData]} then {
2162 return 1
2163 }
2164 return 0
2165 }
2166
2167 ##
2168 ## Compare the given version to eggdrop's version
2169 ##
2170 ## Args: version
2171 ## Returns: 0 if eggdrop's version is older then the given version
2172 ## 1 if eggdrop's version matches the given version
2173 ## 2 if eggdrop's version is newer then the given version
2174 ## -1 if the given version is invalid
2175 ##
2176 proc compareVersion {version} {
2177 global numversion
2178
2179 if {([string compare "" $version]) && \
2180 ([info exists numversion])} then {
2181 if {[regexp -- \\. $version]} then {
2182 regsub -all -- \\. $version 0 version
2183 set version ${version}00
2184 }
2185 if {[regexp -- \[^0-9\] $version]} then {
2186 return -1
2187 } elseif {$numversion == $version} then {
2188 return 1
2189 } elseif {$numversion > $version} then {
2190 return 2
2191 }
2192 }
2193 return 0
2194 }
2195
2196 ##
2197 ## Log module information
2198 ##
2199 ## Args: level, channel, text
2200 ## Returns: nothing
2201 ##
2202 proc wpLog {level channel text} {
2203 set module [namespace tail [uplevel 1 {namespace current}]]
2204 if {(![string compare "" $module]) || \
2205 (![string compare wp $module])} then {
2206 putloglev $level $channel "Wolfpack: $text"
2207 } else {
2208 putloglev $level $channel "Wolfpack: \[$module\] $text"
2209 }
2210 return
2211 }
2212
2213 ##
2214 ## Evaluate command line arguments
2215 ##
2216 ## Args: none
2217 ## Returns: nothing
2218 ##
2219 proc EvalArgs {argc argv argv0} {
2220 variable ModuleVersion
2221 variable optionData
2222
2223 for {set index 0} {$index < $argc} {incr index} {
2224 set option [lindex $argv $index]
2225 set nextoption [lindex $argv [expr $index + 1]]
2226
2227 switch -regexp -- $option {
2228 (^--$) {
2229 break
2230 }
2231 (^--cfgfile$) {
2232 if {([string compare "" $nextoption]) && \
2233 (![regexp -- - $nextoption])} then {
2234 set optionData(cfgfile) $nextoption
2235 incr index
2236 } else {
2237 listAppendIf noparms "--cfgfile"
2238 }
2239 }
2240 (^--config$) {
2241 set optionData(config) 1
2242 }
2243 (^--update$) {
2244 set optionData(update) 1
2245 }
2246 (^--noupdate$) {
2247 set optionData(noupdate) 1
2248 }
2249 (^--rebuild$) {
2250 set optionData(rebuild) 1
2251 }
2252 (^--time$) {
2253 set optionData(time) 1
2254 }
2255 (^--include$) {
2256 if {([string compare "" $nextoption]) && \
2257 (![regexp -- - $nextoption])} then {
2258 listAppendIf optionData(include) $nextoption
2259 incr index
2260 } else {
2261 listAppendIf noparms "--include"
2262 }
2263 }
2264 (^--exclude$) {
2265 if {([string compare "" $nextoption]) && \
2266 (![regexp -- - $nextoption])} then {
2267 listAppendIf optionData(exclude) $nextoption
2268 incr index
2269 } else {
2270 listAppendIf noparms "--exclude"
2271 }
2272 }
2273 (^--module$) {
2274 if {([string compare "" $nextoption]) && \
2275 (![regexp -- - $nextoption])} then {
2276 listAppendIf optionData(module) $nextoption
2277 incr index
2278 } else {
2279 listAppendIf noparms "--module"
2280 }
2281 }
2282 (^--verbose$) {
2283 incr optionData(verbose)
2284 }
2285 (^--quiet$) {
2286 incr optionData(quiet) -1
2287 }
2288 (^--debug$) {
2289 set optionData(debug) 1
2290 }
2291 (^--help$) {
2292 ShowUsage $argv0
2293 exit
2294 }
2295 (^--version$) {
2296 puts "[file tail $argv0] version $ModuleVersion"
2297 exit
2298 }
2299 (^-\[^-\]*$) {
2300 set suboptions [split $option ""]
2301 set sublength [llength [split $suboptions]]
2302 for {set subindex 0} {$subindex < $sublength} {incr subindex} {
2303 set suboption [lindex $suboptions $subindex]
2304 switch -exact -- $suboption {
2305 - {
2306 continue
2307 }
2308 f {
2309 # Next arg in argv should be a filename: '-f filename.conf',
2310 # so break out of the suboption loop after this option
2311 if {([string compare "" $nextoption]) && \
2312 (![regexp -- - $nextoption])} then {
2313 set optionData(cfgfile) $nextoption
2314 incr index
2315 break
2316 } else {
2317 listAppendIf noparms "-f"
2318 }
2319 }
2320 c {
2321 set optionData(config) 1
2322 }
2323 u {
2324 set optionData(update) 1
2325 }
2326 n {
2327 set optionData(noupdate) 1
2328 }
2329 r {
2330 set optionData(rebuild) 1
2331 }
2332 t {
2333 set optionData(time) 1
2334 }
2335 i {
2336 # Next arg in argv should be a module: '-i module',
2337 # so break out of the suboption loop after this option
2338 if {([string compare "" $nextoption]) && \
2339 (![regexp -- - $nextoption])} then {
2340 listAppendIf optionData(include) $nextoption
2341 incr index
2342 break
2343 } else {
2344 listAppendIf noparms "-i"
2345 }
2346 }
2347 x {
2348 # Next arg in argv should be a module: '-x module',
2349 # so break out of the suboption loop after this option
2350 if {([string compare "" $nextoption]) && \
2351 (![regexp -- - $nextoption])} then {
2352 listAppendIf optionData(exclude) $nextoption
2353 incr index
2354 break
2355 } else {
2356 listAppendIf noparms "-x"
2357 }
2358 }
2359 m {
2360 # Next arg in argv should be a module: '-m module',
2361 # so break out of the suboption loop after this option
2362 if {([string compare "" $nextoption]) && \
2363 (![regexp -- - $nextoption])} then {
2364 listAppendIf optionData(module) $nextoption
2365 incr index
2366 break
2367 } else {
2368 listAppendIf noparms "-m"
2369 }
2370 }
2371 v {
2372 incr optionData(verbose)
2373 }
2374 q {
2375 incr optionData(quiet) -1
2376 }
2377 d {
2378 set optionData(debug) 1
2379 }
2380 H {
2381 ShowUsage $argv0
2382 exit
2383 }
2384 V {
2385 puts "[file tail $argv0] version $ModuleVersion"
2386 exit
2387 }
2388 default {
2389 listAppendIf invalidopt "-$suboption"
2390 }
2391 }
2392 }
2393 }
2394 default {
2395 listAppendIf invalidopt $option
2396 }
2397 }
2398 }
2399
2400 # Complain about invalid command line arguments
2401 if {[info exists invalidopt]} then {
2402 foreach option $invalidopt {
2403 puts stderr "[file tail $argv0]: unrecognized option `$option'"
2404 }
2405 set exit 1
2406 }
2407
2408 # Complain about missing parameters
2409 if {[info exists noparms]} then {
2410 foreach option $noparms {
2411 puts stderr "[file tail $argv0]: option requires a parameter `$option'"
2412 }
2413 set exit 1
2414 }
2415
2416 if {[info exists exit]} then {
2417 exit 1
2418 }
2419 }
2420
2421 ##
2422 ## Show usage information
2423 ##
2424 ## Args: none
2425 ## Returns: nothing
2426 ##
2427 proc ShowUsage {argv0} {
2428 puts "Usage: [file tail $argv0] <options>"
2429 puts " Valid options:"
2430 puts " -f, --cfgfile <file> use configuration file `file'"
2431 puts " -c, --config start interactive configuration"
2432 puts " -u, --update update module database"
2433 puts " -n, --noupdate don't update module database even if its outdated"
2434 puts " -r, --rebuild force complete rebuild of module database"
2435 puts " -t, --time time compare/update/rebuild of module database"
2436 puts " -i, --include <file> include module `file' when updating database"
2437 puts " -x, --exclude <file> exclude module `file' when updating database"
2438 puts " -m, --module <file> only update database for module `file'"
2439 puts " -v, --verbose use more than once for more verbose operation"
2440 puts " -q, --quiet use more than once for quieter operation"
2441 puts " -d, --debug start debug mode with tclsh"
2442 puts " -H, --help show this help"
2443 puts " -V, --version show version information"
2444 }
2445
2446 ##
2447 ## Build array of module option data
2448 ##
2449 ## Args: verbose
2450 ## Returns: nothing
2451 ##
2452 proc ParseModuleOptionData {{verbose 0}} {
2453 variable configData
2454 variable optionData
2455 variable modulePath
2456 variable moduleOptionData
2457
2458 # Add valid files to the include, exclude, and module lists
2459 foreach option "include exclude module" {
2460 if {[string compare "" $optionData($option)]} then {
2461 if {[string compare "" $moduleOptionData($option)]} then {
2462 set moduleOptionData($option) ""
2463 }
2464
2465 foreach file $optionData($option) {
2466 foreach dir $modulePath {
2467 set fullfile [file join $dir $file]
2468 if {([file exists $fullfile]) && ([file readable $fullfile])} then {
2469 lappend moduleOptionData($option) "$file $fullfile"
2470 break
2471 }
2472 }
2473 }
2474 }
2475 }
2476
2477 # Build list of excluded files
2478 if {[string compare "" $moduleOptionData(exclude)]} then {
2479 set moduleOptionData(excludedfiles) ""
2480
2481 if {[string compare "" $moduleOptionData(include)]} then {
2482 foreach exclude $moduleOptionData(exclude) {
2483 foreach {excludeFile excludeFullFile} $exclude {break}
2484 set found 0
2485 foreach include $moduleOptionData(include) {
2486 foreach {includeFile includeFullFile} $include {break}
2487 if {![string compare $excludeFullFile $includeFullFile]} then {
2488 set found 1
2489 break
2490 }
2491 }
2492 if {!$found} then {
2493 lappend moduleOptionData(excludedfiles) $excludeFullFile
2494 }
2495 }
2496 } else {
2497 foreach exclude $moduleOptionData(exclude) {
2498 foreach {file fullfile} $exclude {break}
2499 lappend moduleOptionData(excludedfiles) $fullfile
2500 }
2501 }
2502 }
2503
2504 # Build list of module files
2505 if {[string compare "" $moduleOptionData(module)]} then {
2506 set moduleOptionData(modulefiles) ""
2507
2508 foreach module $moduleOptionData(module) {
2509 foreach {file fullfile} $module {break}
2510 lappend moduleOptionData(modulefiles) $fullfile
2511 }
2512 }
2513 return
2514 }
2515
2516 ##
2517 ## Enter interactive configuration
2518 ##
2519 ## Args: none
2520 ## Returns: nothing
2521 ##
2522 proc Iconfig {} {
2523 variable NamespaceCurrent
2524 variable SessionData
2525
2526 set SessionData(prompt) "wolfpack> "
2527 fileevent stdin readable ${NamespaceCurrent}::IconfigReadStdin
2528 puts "Entering wolfpack configuration system..."
2529 puts "Type 'help' for help."
2530 puts -nonewline $SessionData(prompt)
2531 flush stdout
2532 vwait forever
2533 }
2534
2535 ##
2536 ## Read stdin and process commands
2537 ##
2538 ## Args: none
2539 ## Returns: nothing
2540 ##
2541 # FIXME: readline-like support?
2542 proc IconfigReadStdin {} {
2543 variable SessionData
2544 variable configData
2545 variable configFile
2546
2547 set exit 0
2548 if {[eof stdin]} {
2549 set exit 1
2550 }
2551 set stdin [string trimright [gets stdin]]
2552 set data [join [lrange [split $stdin] 1 end]]
2553 if {[string compare "" $stdin]} then {
2554 switch -exact -- [lindex [split $stdin] 0] {
2555 set {
2556 IconfigSet $data
2557 }
2558 enable {
2559 IconfigEnable $data
2560 }
2561 disable {
2562 IconfigDisable $data
2563 }
2564 modules {
2565 IconfigModules $data
2566 }
2567 info {
2568 IconfigInfo $data
2569 }
2570 help {
2571 IconfigHelp $data
2572 }
2573 quit {
2574 set exit 1
2575 }
2576 default {
2577 puts "What? You need 'help'"
2578 }
2579 }
2580 }
2581 if {(!$exit) && (![eof stdin])} then {
2582 puts -nonewline $SessionData(prompt)
2583 flush stdout
2584 } else {
2585 # Save configuration data
2586 arraySave configData $configFile 0 "configuration file "
2587 # Save module database
2588 saveModuleDatabase
2589 puts ""
2590 flush stdout
2591 exit
2592 }
2593 return
2594 }
2595
2596 ##
2597 ## Set configuration settings
2598 ##
2599 ## Args: data
2600 ## Returns: nothing
2601 ##
2602 proc IconfigSet {data} {
2603 variable configData
2604 variable configDefaults
2605
2606 if {![string compare "" $data]} then {
2607 set fmtlen1 [arrayMaxElementDataLength configDefaults 3]
2608 if {$fmtlen1 < 13} then {
2609 set fmtlen1 13 ;# 'Description: '
2610 }
2611 set names [array names configData]
2612 set fmtlen2 [listMaxElementLength $names]
2613 if {$fmtlen2 < 8} then {
2614 set fmtlen2 8 ;# 'Option: '
2615 }
2616 puts ""
2617 puts "Current settings:"
2618 puts ""
2619 # FIXME: this needs improvement
2620 puts [format " %-${fmtlen1}s %-${fmtlen2}s %s" Description: Option: Value:]
2621 foreach option [lsort $names] {
2622 if {[info exists configDefaults($option)]} then {
2623 puts [format " %-${fmtlen1}s %-${fmtlen2}s %s" [lindex $configDefaults($option) 3] $option $configData($option)]
2624 } else {
2625 puts [format " %-${fmtlen1}s %-${fmtlen2}s %s" "" $option $configData($option)]
2626 }
2627 }
2628 puts ""
2629 } else {
2630 set option [lindex [split $data] 0]
2631 if {![info exists configData($option)]} then {
2632 puts "Invalid option: $option"
2633 } else {
2634 set value [join [lrange [split $data] 1 end]]
2635 if {![string compare "" $value]} then {
2636 puts "Currently: $configData($option)"
2637 } else {
2638 set configData($option) $value
2639 puts "Set $option to: $value"
2640 }
2641 }
2642 }
2643 return
2644 }
2645
2646 ##
2647 ## Enable a module
2648 ##
2649 ## Args: data
2650 ## Returns: nothing
2651 ##
2652 proc IconfigEnable {data} {
2653 set module [lindex [split $data] 0]
2654 if {![string compare "" $module]} then {
2655 puts "Usage: enable <module>"
2656 } elseif {[moduleExists $module]} then {
2657 if {![getModuleDatabaseData $module load]} then {
2658 setModuleDatabaseData $module load 1
2659 puts "Enabled module: $module"
2660 } else {
2661 puts "Module `$module' is already enabled."
2662 }
2663 } else {
2664 puts "Invalid module: $module"
2665 }
2666 return
2667 }
2668
2669 ##
2670 ## Disable a module
2671 ##
2672 ## Args: data
2673 ## Returns: nothing
2674 ##
2675 proc IconfigDisable {data} {
2676 set module [lindex [split $data] 0]
2677 if {![string compare "" $module]} then {
2678 puts "Usage: disable <module>"
2679 } elseif {[moduleExists $module]} then {
2680 if {[getModuleDatabaseData $module load] == 1} then {
2681 setModuleDatabaseData $module load 0
2682 puts "Disabled module: $module"
2683 } else {
2684 puts "Module `$module' is already disabled."
2685 }
2686 } else {
2687 puts "Invalid module: $module"
2688 }
2689 return
2690 }
2691
2692 ##
2693 ## List modules
2694 ##
2695 ## Args: data
2696 ## returns: nothing
2697 ##
2698 # FIXME: format the list of modules better (proc from texttools?)
2699 proc IconfigModules {data} {
2700 if {[string compare "" [set modules [listModules]]]} then {
2701 set what [lindex [split $data] 0]
2702 if {![string compare "" $what]} then {
2703 set what "all"
2704 }
2705 switch -exact -- $what {
2706 * -
2707 all {
2708 puts "Available modules:"
2709 foreach line [splitList $modules 65 " " " "] {
2710 puts " $line"
2711 }
2712 }
2713 enabled {
2714 set list ""
2715 foreach module $modules {
2716 if {[getModuleDatabaseData $module load]} {
2717 lappend list $module
2718 }
2719 }
2720 if {[llength $list]} then {
2721 puts "Enabled modules:"
2722 foreach line [splitList $list 65 " " " "] {
2723 puts " $line"
2724 }
2725 } else {
2726 puts "No modules enabled"
2727 }
2728 }
2729 disabled {
2730 set list ""
2731 foreach module $modules {
2732 if {![getModuleDatabaseData $module load]} {
2733 lappend list $module
2734 }
2735 }
2736 if {[llength $list]} then {
2737 puts "Disabled modules:"
2738 foreach line [splitList $list 65 " " " "] {
2739 puts " $line"
2740 }
2741 } else {
2742 puts "No modules disabled"
2743 }
2744 }
2745 default {
2746 puts "Error: 'option' must be one of: all, enabled, disabled"
2747 }
2748 }
2749 } else {
2750 puts "Error: No modules available."
2751 }
2752 return
2753 }
2754
2755 ##
2756 ## Show info for the given module
2757 ##
2758 ## Args: data
2759 ## returns: nothing
2760 ##
2761 # FIXME: add multiple module support as in config.tcl and or integrate?
2762 proc IconfigInfo {data} {
2763 set module [lindex [split $data] 0]
2764 if {![string compare "" $module]} then {
2765 puts "Usage: info <module>"
2766 } elseif {[moduleExists $module]} then {
2767 puts "Info for module: $module"
2768 puts ""
2769 puts "Filename: [getModuleDatabaseData $module file]"
2770 puts "MD5: [getModuleDatabaseData $module md5sum]"
2771 puts "Version: [getModuleDatabaseData $module version]"
2772 if {[getModuleDatabaseData $module load]} then {
2773 puts "Enabled: yes"
2774 } else {
2775 puts "Enabled: no"
2776 }
2777 if {[string compare "" [set config [getModuleDatabaseData $module config]]]} then {
2778 puts "Config file: $config"
2779 }
2780 if {[string compare "" [set author [getModuleDatabaseData $module author]]]} then {
2781 puts "Author: $author"
2782 }
2783 if {[string compare "" [set provides [getModuleDatabaseData $module provides]]]} then {
2784 puts "Provided commands:"
2785 foreach line [splitList $provides 65 " " " "] {
2786 puts " $line"
2787 }
2788 }
2789 if {[string compare "" [set requires [getModuleDatabaseData $module requires]]]} then {
2790 puts "Required commands:"
2791 foreach line [splitList $requires 65 " " " "] {
2792 puts " $line"
2793 }
2794 }
2795 puts "Description:"
2796 foreach line [splitList [getModuleDatabaseData $module description] 65 " " " "] {
2797 puts " $line"
2798 }
2799 } else {
2800 puts "Invalid module: $module"
2801 }
2802 return
2803 }
2804
2805 ##
2806 ## Show configuration help
2807 ##
2808 ## Args: data
2809 ## Returns: nothing
2810 ##
2811 proc IconfigHelp {data} {
2812 if {![string compare "" $data]} then {
2813 set data help
2814 }
2815 switch -exact -- $data {
2816 set {
2817 puts "### set \[option\] \[value\]"
2818 puts " Sets an option to what you specify."
2819 puts " Shows current setting for an option if no new value is given."
2820 puts " Shows current settings for all options if no option is given."
2821 }
2822 enable {
2823 puts "### enable <module>"
2824 puts " Enables the given module."
2825 }
2826 disable {
2827 puts "### disable <module>"
2828 puts " Disables the given module."
2829 }
2830 info {
2831 puts "### info <module>"
2832 puts " Show info for the given module."
2833 }
2834 modules {
2835 puts "### modules \[what\]"
2836 puts " Available options: all, enabled, disabled"
2837 puts " all: Shows all available modules"
2838 puts " enabled: Shows enabled modules"
2839 puts " disabled: Shows disabled modules"
2840 }
2841 help {
2842 puts "### Avaliable commands:"
2843 puts " set \[option\] \[value\]"
2844 puts " enable <module>"
2845 puts " disable <module>"
2846 puts " info <module>"
2847 puts " modules \[what\]"
2848 puts " help \[command\]"
2849 puts " quit"
2850 puts "You can get help on individual commands: 'help <command>'"
2851 }
2852 quit {
2853 puts "### quit"
2854 puts " Quits interactive configuration."
2855 }
2856 default {
2857 puts "No help available on that."
2858 }
2859 }
2860 return
2861 }
2862
2863 ##
2864 ## Inline startup and init code
2865 ##
2866
2867 # Eggdrop doesn't currently set argv0, so we use it to detect load type.