Initial commit of OpenSPARC T2 design and verification files.

[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / site_perl / 5.8.0 / sun4-solaris / Tk / Pretty.pm

# Copyright (c) 1995-1999 Nick Ing-Simmons. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Tk::Pretty;
require Exporter;

use vars qw($VERSION @EXPORT);
$VERSION = '3.013'; # $Id: //depot/Tk8/Tk/Pretty.pm#13 $

use base  qw(Exporter);

@EXPORT = qw(Pretty PrintArgs);

sub pretty_list
{
join(',',map(&Pretty($_),@_));
}

sub Pretty
{
return pretty_list(@_) if (@_ > 1);
my $obj = shift;
return 'undef' unless defined($obj);
my $type = "$obj";
return $type if ($type =~ /=HASH/ && exists($obj->{"_Tcl_CmdInfo_\0"}));
my $result = '';
if (ref $obj)
 {
  my $class;
  if ($type =~ /^([^=]+)=(.*)$/)
   {
    $class = $1;
    $type  = $2;
    $result .= 'bless(';
   }
  if ($type =~ /^ARRAY/)
   {
    $result .= '[';
    $result .= pretty_list(@$obj);
    $result .= ']';
   }
  elsif ($type =~ /^HASH/)
   {
    $result .= '{';
    if (%$obj)
     {
      my ($key, $value);
      while (($key,$value) = each %$obj)
       {
        $result .= $key . '=>' . Pretty($value) . ',';
       }
      chop($result);
     }
    $result .= '}';
   }
  elsif ($type =~ /^REF/)
   {
    $result .= "\\" . Pretty($$obj);
   }
  elsif ($type =~ /^SCALAR/)
   {
    $result .= Pretty($$obj);
   }
  else
   {
    $result .= $type;
   }
  $result .= ",$class)" if (defined $class);
 }
else
 {
  if ($obj =~ /^-?[0-9]+(.[0-9]*(e[+-][0-9]+)?)?$/ ||
      $obj =~ /^[A-Z_][A-Za-z_0-9]*$/ ||
      $obj =~ /^[a-z_][A-Za-z_0-9]*[A-Z_][A-Za-z_0-9]*$/
     )
   {
    $result .= $obj;
   }
  else
   {
    $result .= "'" . $obj . "'";
   }
 }
return $result;
}

sub PrintArgs
{
my $name = (caller(1))[3];
print "$name(",Pretty(@_),")\n";
}

1;