/[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.45 - (show annotations) (download) (as text)
Sat Apr 24 08:45:19 2004 UTC (15 years, 5 months ago) by tothwolf
Branch: MAIN
Changes since 1.44: +94 -32 lines
File MIME type: application/x-tcl
*** empty log message ***

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