]> git.zerfleddert.de Git - micropolis/blob - src/tclx/tclsrc/showproc.tcl
33e9c85bee2c84903458202edac7d6ce4e1a04ca
[micropolis] / src / tclx / tclsrc / showproc.tcl
1 #
2 # showprocs.tcl --
3 #
4 # Display procedure headers and bodies.
5 #------------------------------------------------------------------------------
6 # Copyright 1992 Karl Lehenbauer and Mark Diekhans.
7 #
8 # Permission to use, copy, modify, and distribute this software and its
9 # documentation for any purpose and without fee is hereby granted, provided
10 # that the above copyright notice appear in all copies. Karl Lehenbauer and
11 # Mark Diekhans make no representations about the suitability of this
12 # software for any purpose. It is provided "as is" without express or
13 # implied warranty.
14 #------------------------------------------------------------------------------
15 # $Id: showprocs.tcl,v 2.0 1992/10/16 04:52:11 markd Rel $
16 #------------------------------------------------------------------------------
17 #
18
19 #@package: TclX-show_procedures showproc showprocs
20
21 proc showproc {procname} {
22 if [lempty [info procs $procname]] {demand_load $procname}
23 set arglist [info args $procname]
24 set nargs {}
25 while {[llength $arglist] > 0} {
26 set varg [lvarpop arglist 0]
27 if [info default $procname $varg defarg] {
28 lappend nargs [list $varg $defarg]
29 } else {
30 lappend nargs $varg
31 }
32 }
33 format "proc %s \{%s\} \{%s\}\n" $procname $nargs [info body $procname]
34 }
35
36 proc showprocs {args} {
37 if [lempty $args] { set args [info procs] }
38 set out ""
39
40 foreach i $args {
41 foreach j $i { append out [showproc $j] "\n"}
42 }
43 return $out
44 }
45
Impressum, Datenschutz