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