git.zerfleddert.de Git - micropolis/blob - 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