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