![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to tcl.tlb CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Micropolis - Activity] / micropolis / res|
Return to tcl.tlb CVS log | Up to [Micropolis - Activity] / micropolis / res |
1.1 root 1:
2: #@package: TclX-ArrayProcedures for_array_keys
3:
4: proc for_array_keys {varName arrayName codeFragment} {
5: upvar $varName enumVar $arrayName enumArray
6:
7: if ![info exists enumArray] {
8: error "\"$arrayName\" isn't an array"
9: }
10:
11: set searchId [array startsearch enumArray]
12: while {[array anymore enumArray $searchId]} {
13: set enumVar [array nextelement enumArray $searchId]
14: uplevel $codeFragment
15: }
16: array donesearch enumArray $searchId
17: }
18:
19: #@package: TclX-assign_fields assign_fields
20:
21: proc assign_fields {list args} {
22: foreach varName $args {
23: set value [lvarpop list]
24: uplevel "set $varName [list $value]"
25: }
26: }
27:
28: #@package: TclX-developer_utils saveprocs edprocs
29:
30: proc saveprocs {fileName args} {
31: set fp [open $fileName w]
32: puts $fp "# tcl procs saved on [fmtclock [getclock]]\n"
33: puts $fp [eval "showprocs $args"]
34: close $fp
35: }
36:
37: proc edprocs {args} {
38: global env
39:
40: set tmpFilename /tmp/tcldev.[id process]
41:
42: set fp [open $tmpFilename w]
43: puts $fp "\n# TEMP EDIT BUFFER -- YOUR CHANGES ARE FOR THIS SESSION ONLY\n"
44: puts $fp [eval "showprocs $args"]
45: close $fp
46:
47: if [info exists env(EDITOR)] {
48: set editor $env(EDITOR)
49: } else {
50: set editor vi
51: }
52:
53: set startMtime [file mtime $tmpFilename]
54: system "$editor $tmpFilename"
55:
56: if {[file mtime $tmpFilename] != $startMtime} {
57: source $tmpFilename
58: echo "Procedures were reloaded."
59: } else {
60: echo "No changes were made."
61: }
62: unlink $tmpFilename
63: return
64: }
65:
66: #@package: TclX-forfile for_file
67:
68: proc for_file {var filename code} {
69: upvar $var line
70: set fp [open $filename r]
71: while {[gets $fp line] >= 0} {
72: uplevel $code
73: }
74: close $fp
75: }
76:
77:
78: #@package: TclX-forrecur for_recursive_glob
79:
80: proc for_recursive_glob {var globlist code {depth 1}} {
81: upvar $depth $var myVar
82: foreach globpat $globlist {
83: foreach file [glob -nocomplain $globpat] {
84: if [file isdirectory $file] {
85: for_recursive_glob $var $file/* $code [expr {$depth + 1}]
86: }
87: set myVar $file
88: uplevel $depth $code
89: }
90: }
91: }
92:
93: #@package: TclX-globrecur recursive_glob
94:
95: proc recursive_glob {globlist} {
96: set result ""
97: foreach pattern $globlist {
98: foreach file [glob -nocomplain $pattern] {
99: lappend result $file
100: if [file isdirectory $file] {
101: set result [concat $result [recursive_glob $file/*]]
102: }
103: }
104: }
105: return $result
106: }
107:
108: #@package: TclX-help help helpcd helppwd apropos
109:
110:
111: proc help:flattenPath {pathName} {
112: set newPath {}
113: foreach element [split $pathName /] {
114: if {"$element" == "."} {
115: continue
116: }
117: if {"$element" == ".."} {
118: if {[llength [join $newPath /]] == 0} {
119: error "Help: name goes above subject directory root"}
120: lvarpop newPath [expr [llength $newPath]-1]
121: continue
122: }
123: lappend newPath $element
124: }
125: set newPath [join $newPath /]
126:
127:
128: if {("$newPath" == "") && [string match "/*" $pathName]} {
129: set newPath "/"}
130:
131: return $newPath
132: }
133:
134:
135: proc help:EvalPath {pathName} {
136: global TCLENV
137:
138: if {![string match "/*" $pathName]} {
139: if {"$pathName" == ""} {
140: return $TCLENV(help:curDir)}
141: if {"$TCLENV(help:curDir)" == "/"} {
142: set pathName "/$pathName"
143: } else {
144: set pathName "$TCLENV(help:curDir)/$pathName"
145: }
146: }
147: set pathName [help:flattenPath $pathName]
148: if {[string match "*/" $pathName] && ($pathName != "/")} {
149: set pathName [csubstr $pathName 0 [expr [length $pathName]-1]]}
150:
151: return $pathName
152: }
153:
154:
155: proc help:Display {line} {
156: global TCLENV
157: if {$TCLENV(help:lineCnt) >= 23} {
158: set TCLENV(help:lineCnt) 0
159: puts stdout ":" nonewline
160: flush stdout
161: gets stdin response
162: if {![lempty $response]} {
163: return 0}
164: }
165: puts stdout $line
166: incr TCLENV(help:lineCnt)
167: }
168:
169:
170: proc help:DisplayFile {filepath} {
171:
172: set inFH [open $filepath r]
173: while {[gets $inFH fileBuf] >= 0} {
174: if {![help:Display $fileBuf]} {
175: break}
176: }
177: close $inFH
178:
179: }
180:
181:
182: proc help:ListDir {dirPath} {
183: set dirList {}
184: set fileList {}
185: if {[catch {set dirFiles [glob $dirPath/*]}] != 0} {
186: error "No files in subject directory: $dirPath"}
187: foreach fileName $dirFiles {
188: if [file isdirectory $fileName] {
189: lappend dirList "[file tail $fileName]/"
190: } else {
191: lappend fileList [file tail $fileName]
192: }
193: }
194: return [list [lsort $dirList] [lsort $fileList]]
195: }
196:
197:
198: proc help:DisplayColumns {nameList} {
199: set count 0
200: set outLine ""
201: foreach name $nameList {
202: if {$count == 0} {
203: append outLine " "}
204: append outLine $name
205: if {[incr count] < 4} {
206: set padLen [expr 17-[clength $name]]
207: if {$padLen < 3} {
208: set padLen 3}
209: append outLine [replicate " " $padLen]
210: } else {
211: if {![help:Display $outLine]} {
212: return}
213: set outLine ""
214: set count 0
215: }
216: }
217: if {$count != 0} {
218: help:Display $outLine}
219: return
220: }
221:
222:
223:
224: proc help {{subject {}}} {
225: global TCLENV
226:
227: set TCLENV(help:lineCnt) 0
228:
229:
230: if {($subject == "help") || ($subject == "?")} {
231: help:DisplayFile "$TCLENV(help:root)/help"
232: return
233: }
234:
235: set request [help:EvalPath $subject]
236: set requestPath "$TCLENV(help:root)$request"
237:
238: if {![file exists $requestPath]} {
239: error "Help:\"$request\" does not exist"}
240:
241: if [file isdirectory $requestPath] {
242: set dirList [help:ListDir $requestPath]
243: set subList [lindex $dirList 0]
244: set fileList [lindex $dirList 1]
245: if {[llength $subList] != 0} {
246: help:Display "\nSubjects available in $request:"
247: help:DisplayColumns $subList
248: }
249: if {[llength $fileList] != 0} {
250: help:Display "\nHelp files available in $request:"
251: help:DisplayColumns $fileList
252: }
253: } else {
254: help:DisplayFile $requestPath
255: }
256: return
257: }
258:
259:
260:
261: proc helpcd {{dir /}} {
262: global TCLENV
263:
264: set request [help:EvalPath $dir]
265: set requestPath "$TCLENV(help:root)$request"
266:
267: if {![file exists $requestPath]} {
268: error "Helpcd: \"$request\" does not exist"}
269:
270: if {![file isdirectory $requestPath]} {
271: error "Helpcd: \"$request\" is not a directory"}
272:
273: set TCLENV(help:curDir) $request
274: return
275: }
276:
277:
278: proc helppwd {} {
279: global TCLENV
280: echo "Current help subject directory: $TCLENV(help:curDir)"
281: }
282:
283:
284: proc apropos {name} {
285: global TCLENV
286:
287: set TCLENV(help:lineCnt) 0
288:
289: set aproposCT [scancontext create]
290: scanmatch -nocase $aproposCT $name {
291: set path [lindex $matchInfo(line) 0]
292: set desc [lrange $matchInfo(line) 1 end]
293: if {![help:Display [format "%s - %s" $path $desc]]} {
294: return}
295: }
296: foreach brief [glob -nocomplain $TCLENV(help:root)/*.brf] {
297: set briefFH [open $brief]
298: scanfile $aproposCT $briefFH
299: close $briefFH
300: }
301: scancontext delete $aproposCT
302: }
303:
304: global TCLENV TCLPATH
305:
306: set TCLENV(help:root) [searchpath $TCLPATH help]
307: set TCLENV(help:curDir) "/"
308: set TCLENV(help:outBuf) {}
309:
310: #@package: TclX-packages packages autoprocs
311:
312: proc packages {{option {}}} {
313: global TCLENV
314: set packList {}
315: foreach key [array names TCLENV] {
316: if {[string match "PKG:*" $key]} {
317: lappend packList [string range $key 4 end]
318: }
319: }
320: if [lempty $option] {
321: return $packList
322: } else {
323: if {$option != "-location"} {
324: error "Unknow option \"$option\", expected \"-location\""
325: }
326: set locList {}
327: foreach pack $packList {
328: set fileId [lindex $TCLENV(PKG:$pack) 0]
329:
330: lappend locList [list $pack [concat $TCLENV($fileId) \
331: [lrange $TCLENV(PKG:$pack) 1 2]]]
332: }
333: return $locList
334: }
335: }
336:
337: proc autoprocs {} {
338: global TCLENV
339: set procList {}
340: foreach key [array names TCLENV] {
341: if {[string match "PROC:*" $key]} {
342: lappend procList [string range $key 5 end]
343: }
344: }
345: return $procList
346: }
347:
348: #@package: TclX-directory_stack pushd popd dirs
349:
350: global TCLENV(dirPushList)
351:
352: set TCLENV(dirPushList) ""
353:
354: proc pushd {args} {
355: global TCLENV
356:
357: if {[llength $args] > 1} {
358: error "bad # args: pushd [dir_to_cd_to]"
359: }
360: set TCLENV(dirPushList) [linsert $TCLENV(dirPushList) 0 [pwd]]
361:
362: if {[llength $args] != 0} {
363: cd [glob $args]
364: }
365: }
366:
367: proc popd {} {
368: global TCLENV
369:
370: if [llength $TCLENV(dirPushList)] {
371: cd [lvarpop TCLENV(dirPushList)]
372: pwd
373: } else {
374: error "directory stack empty"
375: }
376: }
377:
378: proc dirs {} {
379: global TCLENV
380: echo [pwd] $TCLENV(dirPushList)
381: }
382:
383: #@package: TclX-set_functions union intersect intersect3 lrmdups
384:
385: proc union {lista listb} {
386: set full_list [lsort [concat $lista $listb]]
387: set check_element [lindex $full_list 0]
388: set outlist $check_element
389: foreach element [lrange $full_list 1 end] {
390: if {$check_element == $element} continue
391: lappend outlist $element
392: set check_element $element
393: }
394: return $outlist
395: }
396:
397: proc lrmdups {list} {
398: set list [lsort $list]
399: set result [lvarpop list]
400: lappend last $result
401: foreach element $list {
402: if {$last != $element} {
403: lappend result $element
404: set last $element
405: }
406: }
407: return $result
408: }
409:
410:
411: proc intersect3 {list1 list2} {
412: set list1Result ""
413: set list2Result ""
414: set intersectList ""
415:
416: set list1 [lrmdups $list1]
417: set list2 [lrmdups $list2]
418:
419: while {1} {
420: if [lempty $list1] {
421: if ![lempty $list2] {
422: set list2Result [concat $list2Result $list2]
423: }
424: break
425: }
426: if [lempty $list2] {
427: set list1Result [concat $list1Result $list1]
428: break
429: }
430: set compareResult [string compare [lindex $list1 0] [lindex $list2 0]]
431:
432: if {$compareResult < 0} {
433: lappend list1Result [lvarpop list1]
434: continue
435: }
436: if {$compareResult > 0} {
437: lappend list2Result [lvarpop list2]
438: continue
439: }
440: lappend intersectList [lvarpop list1]
441: lvarpop list2
442: }
443: return [list $list1Result $intersectList $list2Result]
444: }
445:
446: proc intersect {list1 list2} {
447: set intersectList ""
448:
449: set list1 [lsort $list1]
450: set list2 [lsort $list2]
451:
452: while {1} {
453: if {[lempty $list1] || [lempty $list2]} break
454:
455: set compareResult [string compare [lindex $list1 0] [lindex $list2 0]]
456:
457: if {$compareResult < 0} {
458: lvarpop list1
459: continue
460: }
461:
462: if {$compareResult > 0} {
463: lvarpop list2
464: continue
465: }
466:
467: lappend intersectList [lvarpop list1]
468: lvarpop list2
469: }
470: return $intersectList
471: }
472:
473:
474:
475: #@package: TclX-show_procedures showproc showprocs
476:
477: proc showproc {procname} {
478: if [lempty [info procs $procname]] {demand_load $procname}
479: set arglist [info args $procname]
480: set nargs {}
481: while {[llength $arglist] > 0} {
482: set varg [lvarpop arglist 0]
483: if [info default $procname $varg defarg] {
484: lappend nargs [list $varg $defarg]
485: } else {
486: lappend nargs $varg
487: }
488: }
489: format "proc %s \{%s\} \{%s\}\n" $procname $nargs [info body $procname]
490: }
491:
492: proc showprocs {args} {
493: if [lempty $args] { set args [info procs] }
494: set out ""
495:
496: foreach i $args {
497: foreach j $i { append out [showproc $j] "\n"}
498: }
499: return $out
500: }
501:
502:
503: #@package: TclX-stringfile_functions read_file write_file
504:
505: proc read_file {fileName {numBytes {}}} {
506: set fp [open $fileName]
507: if {$numBytes != ""} {
508: set result [read $fp $numBytes]
509: } else {
510: set result [read $fp]
511: }
512: close $fp
513: return $result
514: }
515:
516: proc write_file {fileName args} {
517: set fp [open $fileName w]
518: foreach string $args {
519: puts $fp $string
520: }
521: close $fp
522: }
523:
524:
525: #@package: TclX-Compatibility execvp
526:
527: proc execvp {progname args} {
528: execl $progname $args
529: }
530:
531: #@package: TclX-convertlib convert_lib
532:
533: proc convert_lib {tclIndex packageLib {ignore {}}} {
534: if {[file tail $tclIndex] != "tclIndex"} {
535: error "Tail file name numt be `tclIndex': $tclIndex"}
536: set srcDir [file dirname $tclIndex]
537:
538: if {[file extension $packageLib] != ".tlib"} {
539: append packageLib ".tlib"}
540:
541:
542: set tclIndexFH [open $tclIndex r]
543: while {[gets $tclIndexFH line] >= 0} {
544: if {([cindex $line 0] == "#") || ([llength $line] != 2)} {
545: continue}
546: if {[lsearch $ignore [lindex $line 1]] >= 0} {
547: continue}
548: lappend entryTable([lindex $line 1]) [lindex $line 0]
549: }
550: close $tclIndexFH
551:
552: set libFH [open $packageLib w]
553: foreach srcFile [array names entryTable] {
554: set srcFH [open $srcDir/$srcFile r]
555: puts $libFH "#@package: $srcFile $entryTable($srcFile)\n"
556: copyfile $srcFH $libFH
557: close $srcFH
558: }
559: close $libFH
560: buildpackageindex $packageLib
561: }
562:
563: #@package: TclX-profrep profrep
564:
565: proc profrep:summarize {profDataVar stackDepth sumProfDataVar} {
566: upvar $profDataVar profData $sumProfDataVar sumProfData
567:
568: if {(![info exists profData]) || ([catch {array size profData}] != 0)} {
569: error "`profDataVar' must be the name of an array returned by the `profile off' command"
570: }
571: set maxNameLen 0
572: foreach procStack [array names profData] {
573: if {[llength $procStack] < $stackDepth} {
574: set sigProcStack $procStack
575: } else {
576: set sigProcStack [lrange $procStack 0 [expr {$stackDepth - 1}]]
577: }
578: set maxNameLen [max $maxNameLen [clength $sigProcStack]]
579: if [info exists sumProfData($sigProcStack)] {
580: set cur $sumProfData($sigProcStack)
581: set add $profData($procStack)
582: set new [expr [lindex $cur 0]+[lindex $add 0]]
583: lappend new [expr [lindex $cur 1]+[lindex $add 1]]
584: lappend new [expr [lindex $cur 2]+[lindex $add 2]]
585: set $sumProfData($sigProcStack) $new
586: } else {
587: set sumProfData($sigProcStack) $profData($procStack)
588: }
589: }
590: return $maxNameLen
591: }
592:
593: proc profrep:sort {sumProfDataVar sortKey} {
594: upvar $sumProfDataVar sumProfData
595:
596: case $sortKey {
597: {calls} {set keyIndex 0}
598: {real} {set keyIndex 1}
599: {cpu} {set keyIndex 2}
600: default {
601: error "Expected a sort of: `calls', `cpu' or ` real'"}
602: }
603:
604:
605: foreach procStack [array names sumProfData] {
606: set key [format "%016d" [lindex $sumProfData($procStack) $keyIndex]]
607: lappend keyProcList [list $key $procStack]
608: }
609: set keyProcList [lsort $keyProcList]
610:
611:
612: for {set idx [expr [llength $keyProcList]-1]} {$idx >= 0} {incr idx -1} {
613: lappend sortedProcList [lindex [lindex $keyProcList $idx] 1]
614: }
615: return $sortedProcList
616: }
617:
618:
619: proc profrep:print {sumProfDataVar sortedProcList maxNameLen outFile
620: userTitle} {
621: upvar $sumProfDataVar sumProfData
622:
623: if {$outFile == ""} {
624: set outFH stdout
625: } else {
626: set outFH [open $outFile w]
627: }
628:
629:
630: set stackTitle "Procedure Call Stack"
631: set maxNameLen [max $maxNameLen [clength $stackTitle]]
632: set hdr [format "%-${maxNameLen}s %10s %10s %10s" $stackTitle \
633: "Calls" "Real Time" "CPU Time"]
634: if {$userTitle != ""} {
635: puts $outFH [replicate - [clength $hdr]]
636: puts $outFH $userTitle
637: }
638: puts $outFH [replicate - [clength $hdr]]
639: puts $outFH $hdr
640: puts $outFH [replicate - [clength $hdr]]
641:
642:
643: foreach procStack $sortedProcList {
644: set data $sumProfData($procStack)
645: puts $outFH [format "%-${maxNameLen}s %10d %10d %10d" $procStack \
646: [lindex $data 0] [lindex $data 1] [lindex $data 2]]
647: }
648: if {$outFile != ""} {
649: close $outFH
650: }
651: }
652:
653:
654: proc profrep {profDataVar sortKey stackDepth {outFile {}} {userTitle {}}} {
655: upvar $profDataVar profData
656:
657: set maxNameLen [profrep:summarize profData $stackDepth sumProfData]
658: set sortedProcList [profrep:sort sumProfData $sortKey]
659: profrep:print sumProfData $sortedProcList $maxNameLen $outFile $userTitle
660:
661: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.