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