]> git.zerfleddert.de Git - micropolis/blob - res/tcl.tlb
src/tk/makefile: Micropolis build fixes for recent macOS
[micropolis] / res / tcl.tlb
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 }
Impressum, Datenschutz