Commit | Line | Data |
---|---|---|
86530b38 AT |
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; |