# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::Dumper
#   Author: Scott Beck 
#   CVS Info :                          
#   $Id: Dumper.pm,v 1.38 2005/02/18 04:44:33 jagerman 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;

$EOL     = "\n";
$VERSION = sprintf "%d.%03d", q$Revision: 1.38 $ =~ /(\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 $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};
    if ($obj =~ /ARRAY\(/)                      { $self->_dump_array($level + 2, \@{$obj}, $ret) }
    elsif ($obj =~ /HASH\(/)                    { $self->_dump_hash( $level + 2, \%{$obj}, $ret) }
    elsif ($obj =~ /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.38 2005/02/18 04:44:33 jagerman Exp $

=cut
