387 lines
12 KiB
Perl
387 lines
12 KiB
Perl
# ==================================================================
|
|
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
|
#
|
|
# GT::Dumper
|
|
# Author: Scott Beck
|
|
# CVS Info : 087,071,086,086,085
|
|
# $Id: Dumper.pm,v 1.39 2007/02/10 15:59:02 sbeck Exp $
|
|
#
|
|
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
# ==================================================================
|
|
#
|
|
# Description:
|
|
# Implements a data dumper, useful for converting complex Perl
|
|
# data structures to strings, which can then be eval()ed back to
|
|
# the original value.
|
|
#
|
|
|
|
package GT::Dumper;
|
|
# ===============================================================
|
|
use strict;
|
|
use vars qw /$DEBUG $ATTRIBS $VERSION @EXPORT @ISA $EOL/;
|
|
use GT::Base;
|
|
use Exporter;
|
|
use overload;
|
|
|
|
$EOL = "\n";
|
|
$VERSION = sprintf "%d.%03d", q$Revision: 1.39 $ =~ /(\d+)\.(\d+)/;
|
|
$ATTRIBS = {
|
|
var => '$VAR',
|
|
data => undef,
|
|
sort => 1,
|
|
order => undef,
|
|
compress => undef,
|
|
structure => undef,
|
|
tab => ' '
|
|
};
|
|
@EXPORT = qw/Dumper/;
|
|
@ISA = qw/Exporter GT::Base/;
|
|
|
|
sub Dumper {
|
|
# -----------------------------------------------------------
|
|
# Dumper acts similar to Dumper in Data::Dumper when called as a
|
|
# class method. If called as a instance method it assumes you
|
|
# have set the options for the dump and does not change them.
|
|
# It only takes a single argument - the variable to dump.
|
|
#
|
|
my $self;
|
|
if (@_ == 2 and UNIVERSAL::isa($_[0], __PACKAGE__)) {
|
|
$self = shift;
|
|
$self->{data} = shift;
|
|
}
|
|
elsif (@_ == 1) {
|
|
$self = GT::Dumper->new(data => shift);
|
|
}
|
|
else {
|
|
die "Bad args to Dumper()";
|
|
}
|
|
return $self->dump;
|
|
}
|
|
|
|
sub dump {
|
|
# -----------------------------------------------------------
|
|
# my $dump = $class->dump(%opts);
|
|
# --------------------------------
|
|
# Returns the data structure specified in %opts flatened.
|
|
# %opts is optional if you have created an object with the
|
|
# options.
|
|
#
|
|
my $this = shift;
|
|
|
|
# See if options were passed in
|
|
my $self;
|
|
if (!ref $this) {
|
|
$self = $this->new(@_);
|
|
}
|
|
else {
|
|
$self = $this;
|
|
if (@_) {
|
|
my $data = $self->common_param(@_) or return $self->fatal(BADARGS => '$dumper->dump(%opts)');
|
|
$self->set($data);
|
|
}
|
|
}
|
|
|
|
my $level = 0;
|
|
my $ret = '';
|
|
if ($self->{var} and not $self->{structure}) {
|
|
$ret .= ($self->{compress} ? "$self->{var}=" : "$self->{var} = ");
|
|
}
|
|
$self->_dump_value($level + 1, $self->{data}, \$ret);
|
|
$ret .= ';' unless $self->{structure};
|
|
$ret .= $EOL unless $self->{structure} or $self->{compress};
|
|
|
|
return $ret ? $ret : 1;
|
|
}
|
|
|
|
sub dump_structure {
|
|
my ($self, $data) = @_;
|
|
return $self->dump(structure => 1, data => $data);
|
|
}
|
|
|
|
sub _dump_value {
|
|
# -----------------------------------------------------------
|
|
# Internal method to decide what to dump.
|
|
#
|
|
my ($self, $level, $val, $ret, $n) = @_;
|
|
my $was;
|
|
my $ref = ref $val;
|
|
if ($ref and overload::StrVal($val) =~ /=/) { $self->_dump_obj( $level + 1, $val, $ret) }
|
|
elsif ($ref eq 'HASH') { $self->_dump_hash( $level + 1, $val, $ret) }
|
|
elsif ($ref eq 'ARRAY') { $self->_dump_array($level + 1, $val, $ret) }
|
|
elsif ($ref eq 'SCALAR' or $ref eq 'REF' or $ref eq 'LVALUE') {
|
|
$self->_dump_scalar($level, $val, $ret)
|
|
}
|
|
elsif ($ref eq 'CODE') { $$ret .= 'sub { () }' }
|
|
else { $$ret .= _escape($val) }
|
|
return 1;
|
|
}
|
|
|
|
sub _dump_scalar {
|
|
# -----------------------------------------------------------
|
|
# Dump a scalar reference.
|
|
#
|
|
my ($self, $level, $val, $ret, $n) = @_;
|
|
my $v = $$val;
|
|
$$ret .= '\\';
|
|
$self->_dump_value($level, $v, $ret, 1);
|
|
return 1;
|
|
}
|
|
|
|
sub _dump_hash {
|
|
# -----------------------------------------------------------
|
|
# Internal method to for through a hash and dump it.
|
|
#
|
|
my ($self, $level, $hash_ref, $ret) = @_;
|
|
$$ret .= '{';
|
|
my $lines;
|
|
if ($self->{sort}) {
|
|
for (sort { ref($self->{order}) eq 'CODE' ? $self->{order}->($a, $b, $hash_ref->{$a}, $hash_ref->{$b}) : $a cmp $b } keys %{$hash_ref}) {
|
|
$$ret .= "," if $lines++;
|
|
$$ret .= $EOL . ($self->{tab} x ($level / 2)) unless $self->{compress};
|
|
my $key = _escape($_);
|
|
$$ret .= $self->{compress} ? "$key," : "$key => ";
|
|
$self->_dump_value($level + 1, $hash_ref->{$_}, $ret, 1);
|
|
}
|
|
}
|
|
else {
|
|
for (keys %{$hash_ref}) {
|
|
$$ret .= "," if $lines++;
|
|
$$ret .= $EOL . ($self->{tab} x ($level / 2)) unless $self->{compress};
|
|
my $key = _escape($_);
|
|
$$ret .= $self->{compress} ? "$key," : "$key => ";
|
|
$self->_dump_value($level + 1, $hash_ref->{$_}, $ret, 1);
|
|
}
|
|
}
|
|
$$ret .= $EOL if $lines and not $self->{compress};
|
|
$$ret .= ($lines and not $self->{compress}) ? (($self->{tab} x (($level - 1) / 2)) . "}") : "}";
|
|
return 1;
|
|
}
|
|
|
|
sub _dump_array {
|
|
# -----------------------------------------------------------
|
|
# Internal method to for through an array and dump it.
|
|
#
|
|
my ($self, $level, $array_ref, $ret) = @_;
|
|
$$ret .= "[";
|
|
my $lines;
|
|
for (@{$array_ref}) {
|
|
$$ret .= "," if $lines++;
|
|
$$ret .= $EOL.($self->{tab} x ($level / 2)) unless $self->{compress};
|
|
$self->_dump_value($level + 1, $_, $ret, 1);
|
|
}
|
|
$$ret .= ($lines and not $self->{compress}) ? $EOL.(($self->{tab} x (($level - 1) / 2)) . "]") : "]";
|
|
return 1;
|
|
}
|
|
|
|
sub _dump_obj {
|
|
# -----------------------------------------------------------
|
|
# Internal method to dump an object.
|
|
#
|
|
my ($self, $level, $obj, $ret) = @_;
|
|
my $class = ref $obj;
|
|
$$ret .= "bless(";
|
|
$$ret .= $EOL.($self->{tab} x ($level / 2)) unless $self->{compress};
|
|
my $strval = overload::StrVal($obj);
|
|
if ($strval =~ /ARRAY\(/) { $self->_dump_array($level + 2, \@{$obj}, $ret) }
|
|
elsif ($strval =~ /HASH\(/) { $self->_dump_hash( $level + 2, \%{$obj}, $ret) }
|
|
elsif ($strval =~ /SCALAR\(/ or $obj =~ /REF\(/ or $obj =~ /LVALUE\(/)
|
|
{ $self->_dump_value($level + 2, $$obj, $ret) }
|
|
$$ret .= ",";
|
|
$$ret .= $EOL.($self->{tab} x ($level / 2)) unless $self->{compress};
|
|
$$ret .= _escape($class);
|
|
$$ret .= $EOL.($self->{tab} x (($level - 1) / 2)) unless $self->{compress};
|
|
$$ret .= ")";
|
|
return 1;
|
|
}
|
|
|
|
|
|
sub _escape {
|
|
# -----------------------------------------------------------
|
|
# Internal method to escape a dumped value.
|
|
my ($val) = @_;
|
|
defined($val) or return 'undef';
|
|
$val =~ s/('|\\(?=['\\]|$))/\\$1/g;
|
|
return "'$val'";
|
|
}
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
GT::Dumper - Convert Perl data structures into a string.
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use GT::Dumper;
|
|
print Dumper($complex_var);
|
|
print GT::Dumper->dump ( var => '$MYVAR', data => $complex_var);
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
GT::Dumper by default exports a method Dumper() which will
|
|
behave similar to Data::Dumper's Dumper(). It differs in that
|
|
it will only take a single argument, and the variable dumped
|
|
will be $VAR instead of $VAR1. Also, to provide easier control
|
|
to change the variable name that gets dumped, you can use:
|
|
|
|
GT::Dumper->dump ( var => string, data => yourdata );
|
|
|
|
and the dump will start with string = instead of $VAR = .
|
|
|
|
=head1 EXAMPLE
|
|
|
|
use GT::Dumper;
|
|
my %foo;
|
|
my @bar = (1, 2, 3);
|
|
$foo{alpha} = \@bar;
|
|
$foo{beta} = 'a string';
|
|
print Dumper(\%foo);
|
|
|
|
This will print:
|
|
|
|
$VAR = {
|
|
'beta' => 'a string',
|
|
'alpha' => [
|
|
'1',
|
|
'2',
|
|
'3',
|
|
],
|
|
};
|
|
|
|
=head1 METHODS/FUNCTIONS
|
|
|
|
=head2 Dumper
|
|
|
|
Dumper() is exported by default when using GT::Dumper. It takes a single
|
|
variable and returns a string representation of the variable. The string can
|
|
then be eval()'ed back into the same data structure.
|
|
|
|
It takes only one argument - the variable to dump. The return is a string of
|
|
the form:
|
|
|
|
$VAR = DATA
|
|
|
|
where 'DATA' is the actual data structure of the variable. A more powerful and
|
|
customizable dumping method is the L</"dump"> method.
|
|
|
|
=head2 dump
|
|
|
|
dump() provides a more customizable method to dumping a data structure. Through
|
|
the various options available, listed below, the output of a data structure
|
|
dump can be formatted in several different ways.
|
|
|
|
The options are as follows. Only the L</"data"> option is required.
|
|
|
|
=over 4
|
|
|
|
=item * data
|
|
|
|
The data option takes a data structure to dump. It is required.
|
|
|
|
=item * var
|
|
|
|
By default, a dump is output as an assignment to C<$VAR>. For example, dumping
|
|
the string C<foo> would return: C<$VAR = 'foo'>. You can change and even omit
|
|
the assignment using the C<var> option. To specify a different variable, you
|
|
simply specify it as the value here. To have 'foo' dump as just C<'foo'>
|
|
instead of C<$VAR = 'foo'>, specify var as an empty string, or undef.
|
|
|
|
=item * tab
|
|
|
|
When indenting for complex data structures (array refs, hash refs, etc.) an
|
|
indent is used. By default, the indent is 4 spaces, however you can change this
|
|
by using the C<tab> option.
|
|
|
|
=item * sort
|
|
|
|
The C<sort> option enables hash key sorting. It is not on by default - to
|
|
enable, simply specify the sort option with 1 as the value. The default sort
|
|
method is case-sensitive alphabetical. See the L</"order"> option for
|
|
specifying your own sort order.
|
|
|
|
=item * order
|
|
|
|
When sorting, it is sometimes desirable to use a custom sort order rather than
|
|
the default case-sensitive alphabetical sort. The C<order> option takes a code
|
|
reference and enables custom sort ordering. The code reference will be passed 4
|
|
variables. The first and second are the two items being compared - $a and $b in
|
|
Perl's sort mechanism. The third and fourth are the values in the hash being
|
|
sorted. The code reference, like a Perl sort routine, should return -1 if $a
|
|
should come before $b, 0 if $a and $b are equivelant in your sort order, and 1
|
|
if $b should come before $a. Because of scoping and package issues in Perl, it
|
|
is not possible to directly use $a and $b.
|
|
|
|
=item * compress
|
|
|
|
The default dump method is to use ' => ' between hash key and value, to use
|
|
indenting, and to add a line break after each dumped element. You can turn all
|
|
of these off by using the compress option.
|
|
|
|
Compression removes all non-essential characters from the output, thus reducing
|
|
data size, however also generally making the dump very difficult to read. If
|
|
enabled, the dumping behaviour is changed as follows:
|
|
|
|
=over 4
|
|
|
|
=item * assignment
|
|
|
|
If using a var (ie. C<$VAR = DATA>), the spaces around the = will be stripped.
|
|
The output will look like: C<$VAR=DATA>
|
|
|
|
=item * hash keys
|
|
|
|
Instead of placing the 4 characters ' => ' between hash keys and values, a
|
|
single ',' will be used.
|
|
|
|
=item * tabs
|
|
|
|
Tabs will not be used.
|
|
|
|
=item * newlines
|
|
|
|
Normally, a newline character is added after each dumped element. Compress
|
|
turns this off.
|
|
|
|
=back
|
|
|
|
=item * structure
|
|
|
|
The structure option causes the dump to be a valid perl structure rather than a
|
|
valid perl statement. This differs in two ways - for one, the C<var> option is
|
|
ignored - it is treated as if a blank C<var> was entered, thereby not returning
|
|
an assignment. The other difference is that an an ordinary dump adds a
|
|
semicolon and newline at the end of the dump, but these are not added when the
|
|
structure option is enabled.
|
|
|
|
=back
|
|
|
|
=head2 dump_structure
|
|
|
|
This is a quick method to do a structure dump. It takes one argument - the data
|
|
to dump. Calling:
|
|
$class->dump_structure($DATA);
|
|
is identical to calling:
|
|
$class->dump(data => $DATA, structure => 1);
|
|
See the L</"structure"> option.
|
|
|
|
=head1 SEE ALSO
|
|
|
|
L<Data::Dumper>
|
|
|
|
=head1 MAINTAINER
|
|
|
|
Jason Rhinelander
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
http://www.gossamer-threads.com/
|
|
|
|
=head1 VERSION
|
|
|
|
Revision: $Id: Dumper.pm,v 1.39 2007/02/10 15:59:02 sbeck Exp $
|
|
|
|
=cut
|