home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / Pretty.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  1.8 KB  |  89 lines
  1. # Copyright (c) 1995-1997 Nick Ing-Simmons. All rights reserved.
  2. # This program is free software; you can redistribute it and/or
  3. # modify it under the same terms as Perl itself.
  4. package Tk::Pretty;
  5. require Exporter;
  6. @ISA = qw(Exporter);
  7.  
  8. @EXPORT = qw(Pretty PrintArgs);
  9.  
  10. sub pretty_list
  11. {
  12.  join(',',map(&Pretty($_),@_));
  13. }
  14.  
  15. sub Pretty
  16. {
  17.  return pretty_list(@_) if (@_ > 1);
  18.  my $obj = shift;
  19.  return "undef" unless defined($obj);
  20.  my $type = "$obj";
  21.  return $type if ($type =~ /=HASH/ && exists($obj->{"_Tcl_CmdInfo_\0"}));
  22.  my $result = "";
  23.  if (ref $obj)
  24.   {
  25.    my $class;    
  26.    if ($type =~ /^([^=]+)=(.*)$/)
  27.     {            
  28.      $class = $1;
  29.      $type  = $2;
  30.      $result .= "bless(";
  31.     }            
  32.    if ($type =~ /^ARRAY/)
  33.     {            
  34.      $result .= "[";
  35.      $result .= pretty_list(@$obj);
  36.      $result .= "]";
  37.     }            
  38.    elsif ($type =~ /^HASH/)
  39.     {            
  40.      $result .= "{";
  41.      if (%$obj)
  42.       {
  43.        while (($key,$value) = each %$obj)
  44.         {            
  45.          $result .= $key . "=>" . Pretty($value) . ",";
  46.         }            
  47.        chop($result);
  48.       }
  49.      $result .= "}";
  50.     }            
  51.    elsif ($type =~ /^REF/)
  52.     {            
  53.      $result .= "\\" . Pretty($$obj);
  54.     }            
  55.    elsif ($type =~ /^SCALAR/)
  56.     {            
  57.      $result .= Pretty($$obj);
  58.     }            
  59.    else          
  60.     {            
  61.      $result .= $type;
  62.     }            
  63.    $result .= ",$class)" if (defined $class);
  64.   }
  65.  else
  66.   {
  67.    if ($obj =~ /^-?[0-9]+(.[0-9]*(e[+-][0-9]+)?)?$/ ||
  68.        $obj =~ /^[A-Z_][A-Za-z_0-9]*$/ ||
  69.        $obj =~ /^[a-z_][A-Za-z_0-9]*[A-Z_][A-Za-z_0-9]*$/
  70.       )
  71.     {
  72.      $result .= $obj;
  73.     }
  74.    else
  75.     {
  76.      $result .= "'" . $obj . "'";
  77.     }
  78.   }
  79.  return $result;
  80. }
  81.  
  82. sub PrintArgs
  83. {
  84.  my $name = (caller(1))[3];
  85.  print "$name(",Pretty(@_),")\n";
  86. }
  87.  
  88. 1;
  89.