library/keylpr.tcl

   1 # keylpr --
   2 # Pretty print the contents of a keyed list
   3 #
   4 # Copyright (c) 1996 Christian Werner
   5 #
   6 # See the file "license.terms" for information on usage and redistribution
   7 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
   8
   9
  10 # Internal function which recursively collects the keys in a keyed list.
  11 # Don't remove the blank before "proc", it prevents "auto_mkindex" from
  12 # creating an entry for this procedure.
  13
  14  proc keylpr__ {list keynames prefix} {
  15     upvar 1 $keynames names
  16     upvar 1 $list l
  17     set m [keylkeys l $prefix]
  18     set x [string length $prefix]
  19     foreach k $m {
  20         if $x {
  21             set p ${prefix}.$k
  22         } else {
  23             set p $k
  24         }
  25         if ![keylpr__ l names $p] {
  26             lappend names $p
  27         }
  28     }
  29     return [llength $m]
  30 }
  31
  32 # Keyed list pretty printer, returns string with pretty printed keyed
  33 # list. Parameters
  34 #
  35 #    keylname       name of keyed list variable to be formatted
  36 #    prefix (opt)   component of keyed list to be formatted or empty
  37 #                   to format entire keyed list
  38
  39 proc keylpr {keylname {prefix {}}} {
  40     upvar 1 $keylname keylist
  41     set keys {}
  42     keylpr__ keylist keys $prefix
  43     set maxlength 0
  44     set keys [lsort -ascii $keys]
  45     foreach k $keys {
  46         set l [string length $k]
  47         if {$l > $maxlength} {
  48             set maxlength $l
  49         }
  50     }
  51     set fmt "%-${maxlength}s    %s"
  52     set r {}
  53     set q {}
  54     foreach k $keys {
  55         if ![catch {format $fmt $k [keylget keylist $k]} l] {
  56             append r $q $l
  57             set q "\n"
  58         }
  59     }
  60     return $r
  61 }