home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _4f25b0714d3e41b0364bbd84ce983a81 < prev    next >
Encoding:
Text File  |  2004-06-01  |  1.8 KB  |  94 lines
  1. # Copyright (c) 1995-2003 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.  
  7. use vars qw($VERSION @EXPORT);
  8. $VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Pretty.pm#6 $
  9.  
  10. use base  qw(Exporter);
  11.  
  12. @EXPORT = qw(Pretty PrintArgs);
  13.  
  14. sub pretty_list
  15. {
  16.  join(',',map(&Pretty($_),@_));
  17. }
  18.  
  19. sub Pretty
  20. {
  21.  return pretty_list(@_) if (@_ > 1);
  22.  my $obj = shift;
  23.  return 'undef' unless defined($obj);
  24.  my $type = "$obj";
  25.  return $type if ($type =~ /=HASH/ && exists($obj->{"_Tcl_CmdInfo_\0"}));
  26.  my $result = '';
  27.  if (ref $obj)
  28.   {
  29.    my $class;
  30.    if ($type =~ /^([^=]+)=(.*)$/)
  31.     {
  32.      $class = $1;
  33.      $type  = $2;
  34.      $result .= 'bless(';
  35.     }
  36.    if ($type =~ /^ARRAY/)
  37.     {
  38.      $result .= '[';
  39.      $result .= pretty_list(@$obj);
  40.      $result .= ']';
  41.     }
  42.    elsif ($type =~ /^HASH/)
  43.     {
  44.      $result .= '{';
  45.      if (%$obj)
  46.       {
  47.        my ($key, $value);
  48.        while (($key,$value) = each %$obj)
  49.         {
  50.          $result .= $key . '=>' . Pretty($value) . ',';
  51.         }
  52.        chop($result);
  53.       }
  54.      $result .= '}';
  55.     }
  56.    elsif ($type =~ /^REF/)
  57.     {
  58.      $result .= "\\" . Pretty($$obj);
  59.     }
  60.    elsif ($type =~ /^SCALAR/)
  61.     {
  62.      $result .= Pretty($$obj);
  63.     }
  64.    else
  65.     {
  66.      $result .= $type;
  67.     }
  68.    $result .= ",$class)" if (defined $class);
  69.   }
  70.  else
  71.   {
  72.    if ($obj =~ /^-?[0-9]+(.[0-9]*(e[+-][0-9]+)?)?$/ ||
  73.        $obj =~ /^[A-Z_][A-Za-z_0-9]*$/ ||
  74.        $obj =~ /^[a-z_][A-Za-z_0-9]*[A-Z_][A-Za-z_0-9]*$/
  75.       )
  76.     {
  77.      $result .= $obj;
  78.     }
  79.    else
  80.     {
  81.      $result .= "'" . $obj . "'";
  82.     }
  83.   }
  84.  return $result;
  85. }
  86.  
  87. sub PrintArgs
  88. {
  89.  my $name = (caller(1))[3];
  90.  print "$name(",Pretty(@_),")\n";
  91. }
  92.  
  93. 1;
  94.