| 1 | # Copyright (c) 1995-1999 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 = '3.013'; # $Id: //depot/Tk8/Tk/Pretty.pm#13 $ |
| 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; |