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