File Coverage

blib/lib/Data/Dump/Streamer.pm

Criterion	Covered	Total	%
statement	1183	1409	83.9
branch	623	894	69.6
condition	283	465	60.8
subroutine	90	104	86.5
pod	21	33	63.6
total	2200	2905	75.7

package Data::Dump::Streamer;
use strict;
use warnings;
use warnings::register;

use B ();
use B::Deparse ();
use B::Utils ();
use Data::Dumper ();
use DynaLoader ();
use Exporter ();
use IO::File ();
use Symbol ();
use Text::Abbrev ();
use Text::Balanced ();
use overload ();

use Data::Dump::Streamer::_::Printers;

# use overload qw("" printit); # does diabolical stuff.

use vars qw(
             $VERSION
             $XS_VERSION
             $AUTOLOAD
             @ISA
             @EXPORT @EXPORT_OK @EXPORT_FAIL %EXPORT_TAGS
             %Freeze
             %Thaw
             $DEBUG
             $HasPadWalker
           );

$DEBUG=0;
BEGIN{ $HasPadWalker=eval "use PadWalker 0.99; 1"; }

BEGIN {
    $VERSION   ='2.40';
    $XS_VERSION = $VERSION;
    $VERSION = eval $VERSION; # used for beta stuff.
    @ISA       = qw(Exporter DynaLoader);
    @EXPORT=qw(Dump DumpLex DumpVars);
    @EXPORT_OK = qw(
        Dump
        DumpLex
        DumpVars
        Stream
        alias_av
        alias_hv
        alias_ref
        push_alias
        dualvar

        alias_to

        blessed
        reftype
        refaddr
        refcount
        sv_refcount
        looks_like_number
        regex
        readonly
        make_ro
        _make_ro
        reftype_or_glob
        refaddr_or_glob
        globname
        is_numeric

        all_keys
        legal_keys
        hidden_keys
        lock_ref_keys
        lock_keys
        lock_ref_keys_plus
        lock_keys_plus
        SvREADONLY_ref
        SvREFCNT_ref
        isweak
        weaken
        weak_refcount

        readonly_set

        Dumper
        DDumper

        alias
        sqz
        usqz
   );

    %EXPORT_TAGS = (
        undump => [ qw( alias_av alias_hv alias_ref make_ro
                        lock_ref_keys
                        lock_keys
                        lock_ref_keys_plus
                        lock_keys_plus
                        alias_to
                        dualvar
                        weaken
                        usqz
                      )
                  ],
        special=> [ qw( readonly_set ) ],
        all    => [ @EXPORT,@EXPORT_OK ],
        alias  => [ qw( alias_av alias_hv alias_ref push_alias ) ],
        bin    => [ @EXPORT_OK ],
        Dumper => [ qw( Dumper DDumper )],
        util   => [ qw (
                        dualvar
                        blessed reftype refaddr refcount sv_refcount
                        readonly looks_like_number regex is_numeric
                        make_ro readonly_set reftype_or_glob
                        refaddr_or_glob globname
                        weak_refcount isweak weaken
                      )
                  ],

    );


    sub alias_to { return shift }

    #warn $VERSION;
    Data::Dump::Streamer->bootstrap($XS_VERSION);
    if ($]>=5.013010) {
        # As I write this, 5.13.10 doesn't exist so I'm guessing that
        # we can begin using the ordinary core function again.
        eval q[
            use re qw(regexp_pattern is_regexp);
            *regex= *regexp_pattern;
        ] or die $@;
    }
    elsif ($]>=5.013006) {
        # Perl-5.13.6 through perl-5.13.9 began returning modifier
        # flags that weren't yet legal at the time.
        eval q[
            use re qw(regexp_pattern is_regexp);
            sub regex {
                if (wantarray) {
                    my ($pat,$mod) = regexp_pattern($_[0]);
                    if ($mod) {
                        $mod =~ tr/dlua?//d;
                    }
                    return ($pat,$mod);
                }
                else {
                    return scalar regexp_pattern($_[0]);
                }
            }
            1;
        ] or die $@;
    }
    elsif ($]>=5.009004) {
        eval q[
            use re qw(regexp_pattern is_regexp);
            *regex= *regexp_pattern;
            1;
        ] or die $@;
    }
    else {
      eval q[sub is_regexp($) { defined regex($_[0]) }];
    }
    if ($]<=5.008) {
        *hidden_keys=sub(\%)  { return () };
        *legal_keys=sub(\%)   { return keys %{$_[0]} };
        *all_keys=sub(\%\@\@) { @{$_[1]}=keys %{$_[0]}; @$_[2]=(); };
    }
    if ( $]<5.008 ) {
            no strict 'refs';
            foreach my $sub (qw(lock_keys lock_keys_plus )) {
                *$sub=sub(\%;@) {
                    warnings::warn "$sub doesn't do anything before Perl 5.8.0\n";
                    return $_[0];
                }
            }
            foreach my $sub (qw(lock_ref_keys lock_ref_keys_plus )) {
                *$sub=sub($;@) {
                    warnings::warn "$sub doesn't do anything before Perl 5.8.0\n";
                    return $_[0];
                }
            }
    } else {
        eval <<'EO_HU'
        use Hash::Util qw(lock_keys);
        sub lock_ref_keys($;@) {
            my $hash=shift;
            Carp::confess("lock_ref_keys(): Not a ref '$hash'")
                unless ref $hash;
            lock_keys(%$hash,@_);
            $hash
        }
EO_HU
        ;
        *lock_ref_keys_plus=sub($;@){
            my ($hash,@keys)=@_;
            my @delete;
            Internals::hv_clear_placeholders(%$hash);
            foreach my $key (@keys) {
                unless (exists($hash->{$key})) {
                    $hash->{$key}=undef;
                    push @delete,$key;
                }
            }
            SvREADONLY_ref($hash,1);
            delete @{$hash}{@delete};
            $hash
        };
        *lock_keys_plus=sub(\%;@){lock_ref_keys_plus(@_)};
    }
    if ($] <= 5.008008) {
        *disable_overloading = \&SvAMAGIC_off;
        *restore_overloading = sub ($$) {
            SvAMAGIC_on($_[0], undef);

            # Visit all classes we are ISA and fetch the () entry from
            # every stash.
            my %done;
            my %todo = (
                $_[0]     => undef,
                UNIVERSAL => undef,
            );
            no strict 'refs';
            for my $todo_class (keys %todo) {
                delete $todo{$todo_class};
                $done{$todo_class} = undef;
                for my $isa (@{"${todo_class}::ISA"}) {
                    $todo{$isa} = undef unless exists $done{$isa};
                }
            }
        };
    } else {
        *disable_overloading = sub ($) {
            # we use eval because $_[0] might be read-only
            # its a crappy solution, but whatever, it works
            eval { bless $_[0], 'Does::Not::Exist' };
        };
        *restore_overloading = sub ($$) {
            eval { bless $_[0], $_[1] }
        };
    }
    my %fail=map { ( $_ => 1 ) } @EXPORT_FAIL;
    @EXPORT_OK=grep { !$fail{$_} } @EXPORT_OK;
}

sub import {
    my ($pkg) = @_;
    my ($idx, $alias);

    if ($idx = (grep lc($_[$_]) eq 'as', 0..$#_)) {
        #print "found alias at $idx:\n";
        ($idx, $alias) = splice(@_, $idx, 2);
        #print "found alias: $idx => $alias\n";

        no strict 'refs';
        *{$alias.'::'} = *{__PACKAGE__.'::'};
    }
    $pkg->export_to_level(1,@_);
}

# NOTE
# ----
# This module uses the term 'sv' in a way that is misleading.
# It doesn't always mean the same as it would in the core.
#
# 1. data is breadth first traversed first, in the pretty much
# self contained Data() routine which farms out a bit to
# _reg_ref and _reg_scalar which handle "registering" items for
# later use, such as their depth, refcount, "name", etc. But
# ONLY for references and scalars whose refcount is over 2.
# Most real SV's will have a refcount of 2 when we look at them
# (from the perl side) so we actually don't know about them (trust me)
# They _cant_ be referenced twice, and they can't be aliased so we can
# can just ignore them until the second pass.
# 2.Once this has happened Out() is called which starts off a
# normal depth first traverse over the structure. It calls into
# 3._dump_sv which in the case of a reference falls through to _dump_rv.
# Aliasing and a bunch of stuff like that are checked here before we even
# look at the reference type.
# 4.If its a ref we fall through to dumping the reference in _dump_rv.
# Here we handle duplicate refs, and manage depth  checks, blessing, refs
#(which is scary nasty horrible code) and then pass on to _dump_type where
# type is one of 'code', 'qr', 'array' etc. Each of these which have children
# then call back into _dump_sv as required.
# 5. Because of the way perl works, we can't emit anything more than a DAG in a
# single statement, so for more complex structures we need to add in the broken
# links. I call these "fix statements", and they encompass copying reference
# values, creating aliases, or even dumping globs.  When a fix statement is needed
# any of the _dump_foo methods will call _add_fix and add to the list of fixes.
# after every root level _dump_sv call from Out() any fix statements possible to be
# resolved will be emitted and removed from the fix list. This happens in
# _dump_apply_fix, which is another piece of horrible code.
#
# Anyway, its terribly ugly, but for anything I can think to throw at i works.
# demerphq

=encoding utf8

=head1 NAME

Data::Dump::Streamer - Accurately serialize a data structure as Perl code.

=head1 SYNOPSIS

  use Data::Dump::Streamer;
  use DDS;                           # optionally installed alias

  Dump($x,$y);                       # Prints to STDOUT
  Dump($x,$y)->Out();                #   "          "

  my $o=Data::Dump::Streamer->new(); # Returns a new ...
  my $o=Dump();                      # ... uninitialized object.

  my $o=Dump($x,$y);                 # Returns an initialized object
  my $s=Dump($x,$y)->Out();          #  "  a string of the dumped obj
  my @l=Dump($x,$y);                 #  "  a list of code fragments
  my @l=Dump($x,$y)->Out();          #  "  a list of code fragments

  Dump($x,$y)->To(\*STDERR)->Out();  # Prints to STDERR

  Dump($x,$y)->Names('foo','bar')    # Specify Names
             ->Out();

  Dump($x,$y)->Indent(0)->Out();     # No indent

  Dump($x,$y)->To(\*STDERR)          # Output to STDERR
             ->Indent(0)             # ... no indent
             ->Names('foo','bar')    # ... specify Names
             ->Out();                # Print...

  $o->Data($x,$y);                   # OO form of what Dump($x,$y) does.
  $o->Names('Foo','Names');          #  ...
  $o->Out();                         #  ...

=head1 DESCRIPTION

Given a list of scalars or reference variables, writes out
their contents in perl syntax. The references can also be
objects. The contents of each variable is output using the least
number of Perl statements as convenient, usually only one.
Self-referential structures, closures, and objects are output
correctly.

The return value can be evaled to get back an identical copy
of the original reference structure. In some cases this may
require the use of utility subs that
L will optionally
export.

This module is very similar in concept to the core module
L, with the major differences
being that this module is designed to output to a stream
instead of constructing its output in memory (trading speed
for memory), and that the traversal over the data structure
is effectively breadth first versus the depth first
traversal done by the others.

In fact the data structure is scanned twice, first in
breadth first mode to perform structural analysis, and then
in depth first mode to actually produce the output, but
obeying the depth relationships of the first pass.

=head2 Caveats Dumping Closures (CODE Refs)

As of version 1.11 DDS has had the ability to dump closures properly. This
means that the lexicals that are bound to the closure are dumped along
with the subroutine that uses them. This makes it much easier to debug
code that uses closures and to a certain extent provides a persistency
framework for closure based code. The way this works is that DDS figures
out what all the lexicals are that are bound to CODE refs it is dumping
and then pretends that it had originally been called with all of them as
its arguments, (along with the original arguments as well of course.)

One consequence of the way the dumping process works is that all of the
recreated subroutines will be in the same scope. This of course can lead
to collisions as two subroutines can easily be bound to different
variables that have the same name.

The way that DDS resolves these collisions is that it renames one of the
variables with a special name so that presumably there are no collisions.
However this process is very simplistic with no checks to prevent
collisions with other lexicals or other globals that may be used by other
dumped code.  In some situations it may be necessary to change the default
value of the rename template which may be done by using the C
method.

Similarly to the problem of colliding lexicals is the problem of colliding
lexicals and globals. DDS pays no attention to globals when dumping
closures which can potentially result in lexicals being declared that will
eclipse their global namesake. There is currently no way around this other
than to avoid accessing a global and a lexical with the same name from the
subs being dumped. An example is

  my $a = sub { $a++ };
  Dump( sub { $a->() } );

which will not be dumped correctly. Generally speaking this kind of thing
is bad practice anyway, so this should probably be viewed as a "feature".
:-)

Generally if the closures being dumped avoid accessing lexicals and
globals with the same name from out of scope and that all of the CODE
being dumped avoids vars with the C in their names the dumps
should be valid and should eval back into existence properly.

Note that the behaviour of dumping closures is subject to change in future
versions as its possible that I will put some additional effort into more
sophisticated ways of avoiding name collisions in the dump.

=head1 USAGE

While Data::Dump::Streamer is at heart an object oriented module, it is
expected (based on experience with using L)
that the common case will not exploit these features. Nevertheless the
method based approach is convenient and accordingly a compromise hybrid
approach has been provided via the C subroutine. Such as

   Dump($foo);
   $as_string= Dump($foo)->Out();

All attribute methods are designed to be chained together.  This means
that when used as set attribute (called with arguments) they return the
object they were called against. When used as get attributes (called
without arguments) they return the value of the attribute.

From an OO point of view the key methods are the C and C
methods. These correspond to the breadth first and depth first traversal,
and need to be called in this order. Some attributes I be set prior
to the C phase and some need only be set before the C
phase.

Attributes once set last the lifetime of the object, unless explicitly
reset.

=head2 Controlling Object Representation

This module provides hooks to allow objects to override how they are
represented. The basic idea is that a subroutine (or method) is provided
which is responsible for the override. The return of the method governs
how the object will be represented when dumped, and how it will be
restored. The basic calling convention is

    my ( $proxy, $thaw, $postop )= $callback->($obj);
    #or                          = $obj->$method();

The L|/Freezer> method controls what methods to use as a default method
and also allows per class overrides. When dumping an object of a given
class the first time it tries to execute the class specific handler if
it is specified, then the user specific generic handler if its been
specified and then "DDS_freeze". This means that class authors can
implement a C method and their objects will automatically
be serialized as necessary. B that if either the class specific or
generic handler is defined but false C will not be used
even if it is present.

The interface of the L|/Freezer> handler in detail is as follows:

=over 4

=item B>

The object being dumped.

=item B>

This is what will be dumped instead of C<$obj>. It may be one of
the following values:

=over 8

=item I> (first time only)

On the first time a serialization hook is called in a dump it may return
undef or the empty list to indicate that it shouldn't be used again for
this class during this pass. Any other time undef is treated the same
as false.

=item I

A false value for C<$proxy> is taken to mean that it should be ignored.
Its like saying IgnoreClass(ref($obj)); B that undef has a special
meaning when the callback is called the first time.

=item I

A reference that will be dumped instead of the object.

=item I

A string that is to be treated as code and inserted directly into the
dump stream as a proxy for the original. Note that the code must be
able to execute inline or in other words must evaluate to a perl EXPR.
Use C to wrap multistatement code.

=back

=item B>

This values is used to allow extra control over how the object will be
recreated when dumped. It is used for converting the C<$proxy> representation
into the real thing. It is only relevant when C<$proxy> is a reference.

=over 8

=item I

Indicates no thaw action is to be included for this object.

=item I

A string matching C<< /^(->)?((?:\w*::)\w+)(\(\))?$/ >> in which case it
is taken as a sub name when the string ends in () and a method name
when the string doesn't. If the C<< -> >> is present then the sub or method
is called inline. If it is not then the sub or method is called
after the main dump.

=item I

Any other string, in which case the result will be taken as code
which will be emitted after the main dump. It will be wrapped
in a for loop that aliases C<$_> to the variable in question.

=back

=item B>

This is the similar to C<$thaw> but is called in process instead
of being emitted as part of the dump. Any return is ignored.
It is only relevant when C<$proxy> is a reference.

=over 8

=item I

No postdump action is to occur.

=item I

The code ref will be called after serialization is complete
with the object as the argument.

=item I

The method will be called after serialization is complete

=back

=back

An example DDS_freeze method is one I had to put together for an object
which contained a key whose value was a ref to an array tied to the value
of another key. Dumping this got crazy, so I wanted to suppress dumping
the tied array. I did it this way:

    sub DDS_freeze {
        my $self=shift;
        delete $self->{'tie'};
        return ($self,'->fix_tie','fix_tie');
    }

    sub fix_tie {
        my $self=shift;
        if ( ! $self->{'tie'} ) {
            $self->{str}="" unless defined $self->{str};
            tie my @a, 'Tie::Array::PackedC', $self->{str};
            $self->{'tie'} = \@a;
        }
        return $self;
    }

The C<$postop> means the object is relatively unaffected after the
dump, the C<$thaw> says that we should also include the method
inline as we dump. An example dump of an object like this might be

   $Foo1=bless({ str=>'' },'Foo')->fix_tie();

Wheras if we omit the C<< -> >> then we would get:

    $Foo1=bless({ str=>'' },'Foo');
    $Foo1->fix_tie();

In our example it wouldn't actually make a difference, but the former
style can be nicer to read if the object is embedded in another.
However the non arrow notation is slightly more dangerous, in that
its possible that the internals of the object will not be fully linked
when the method is evaluated. The second form guarantees that the object
will be fully linked when the method is evaluated.

See L for a different way
to control the representation of hash based objects.

=head2 Controlling Hash Traversal and Display Order

When dumping a hash you may control the order the keys will be output
and which keys will be included. The basic idea is to specify a subroutine
which takes a hash as an argument and returns a reference to an array
containing the keys to be dumped.

You can use the L routine or the L routine to
specify the sorter to be used.

The routine will be called in the following way:

   ( $key_array, $thaw ) = $sorter->($hash,($pass=0),$addr,$class);
   ( $key_array,)        = $sorter->($hash,($pass=1),$addr,$class);

C<$hash> is the hash to be dumped, C<$addr> is the refaddr() of the
C<$hash>, and C<$class> will be set if the hash has been blessed.

When C<$pass> is 0 the C<$thaw> variable may be supplied as well as the
keyorder. If it is defined then it specifies what thaw action to perform
after dumping the hash. See L|/$thaw> in L
Representation> for details as to how it works.  This allows an object
to define those keys needed to recreate itself properly, and a followup
hook to recreate the rest.

B that if a L method is defined and returns
a L|/$thaw> then the L|/$thaw> returned by the sorter
will override it.

=head2 Controlling Array Presentation and Run Length Encoding

By default Data::Dump::Streamer will "run length encode" array values.
This means that when an array value is simple (ie, its not referenced and
does contain a reference) and is repeated multiple times the output will
be single a list multiplier statement, and not each item output
separately. Thus: L|/Dump> will be output something like

   $ARRAY1 = [ (0) x 4 ];

This is particularly useful when dealing with large arrays that are only
partly filled, and when accidentally the array has been made very large,
such as with the improper use of pseudo-hash notation.

To disable this feature you may set the L property to FALSE, by
default it is enabled and set to TRUE.

=head2 Installing I as a package alias

Its possible to have an alias to Data::Dump::Streamer created and
installed for easier usage in one liners and short scripts.
Data::Dump::Streamer is a bit long to type sometimes. However because this
technically means polluting the root level namespace, and having it listed
on CPAN, I have elected to have the installer not install it by default.
If you wish it to be installed you must explicitly state so when
Build.Pl is run:

  perl Build.Pl DDS [Other Module::Build options]

Then a normal './Build test, ./Build install' invocation will install DDS.

Using DDS is identical to Data::Dump::Streamer.

=head2 use-time package aliasing

You can also specify an alias at use-time, then use that alias in the rest
of your program, thus avoiding the permanent (but modest) namespace
pollution of the previous method.

  use Data::Dumper::Streamer as => 'DDS';

  # or if you prefer
  use Data::Dumper::Streamer;
  import Data::Dumper::Streamer as => 'DDS';

You can use any alias you like, but that doesn't mean you should.. Folks
doing as => 'DBI' will be mercilessly ridiculed.

=head2 PadWalker support

If PadWalker 1.0 is installed you can use DumpLex() to try to
automatically determine the names of the vars being dumped. As
long as the vars being dumped have my or our declarations in scope
the vars will be correctly named. Padwalker will also be used
instead of the B:: modules when dumping closures when it is available.

=head1 INTERFACE

=head2 Data::Dumper Compatibility

For drop in compatibility with the Dumper() usage of Data::Dumper, you may
request that the L method is exported. It will not be exported by
default. In addition the standard Data::Dumper::Dumper() may be exported
on request as C. If you provide the tag C<:Dumper> then both will
be exported.

=over 4

=item Dumper

=item Dumper LIST

A synonym for scalar Dump(LIST)->Out for usage compatibility with
L

=item DDumper

=item DDumper LIST

A secondary export of the actual L
subroutine.

=back

=head2 Constructors

=over 4

=item new

Creates a new Data::Dump::Streamer object. Currently takes no
arguments and simply returns the new object with a default style
configuration.

See C for a better way to do things.

=cut

sub _compressor {
    return "use Data::Dump::Streamer qw(usqz);\n"
        if !@_;
    return sqz($_[0], "usqz('", "')" );
}

sub new {
    my $class = shift;
    my $self = bless {
        style => {
            hashsep      => '=>',    # use this to separate key vals
            arysep       => ',',
            pairsep      => ',',
            optspace     => ' ',
            bless        => 'bless()', # use this to bless objects, needs fixing

            compress     => 0, # if nonzero use compressor to compress strings
                               # longer than this value.
            compressor   => \&_compressor,

            indent       => 2,    # should we indent at all?
            indentkeys   => 1,         # indent keys
            declare      => 0,         # predeclare vars? allows refs to root vars if 0
            sortkeys     => {},
            verbose      => 1,         # use long names and detailed fill ins
            dumpglob     => 1,         # dump glob contents
            deparseglob  => 1,
            deparse      => 1,         # deparse code refs?
            freezer      => 'DDS_freeze',        # default freezer
            freeze_class => {},        # freeze classes

            rle          => 1,         # run length encode arrays
            ignore       => {},        # ignore classes
            indentcols   => 2,         # indent this number of cols
            ro           => 1,         # track readonly vars
            dualvars     => 1,         # dump dualvars
            eclipsename  => "%s_eclipse_%d",

            purity       => 1,         # test

            # use this if deparse is 0
            codestub     => 'sub { Carp::confess "Dumped code stub!" }',
            formatstub   => 'do{ local *F; eval "format F =\nFormat Stub\n.\n"; *F{FORMAT} }',
            # use these opts if deparse is 1
            deparseopts  => ["-sCi2v'Useless const omitted'"],
            special      => 0,

            # not yet implemented
            array_warn  => 10_000,    # warn if an array has more than this number of elements
            array_chop  => 32_767,    # chop arrays over this size
            array_max   => 1_000_000, # die if arrays have more than this size
            smart_array => 1,         # special handling of very large arrays
                                      # with hashes as their 0 index. (pseudo-hash error detection)
        },
        debug => 0,
        cataloged => 0,
        ref_id => 0,
        sv_id => 0
    }, $class;

    return $self;
}

sub _safe_self {
    my $self = shift;
    unless ( ref $self ) {
        $self = $self->new();
    }
    return $self;
}

sub Dumper {
    return scalar Dump(@_)->Out();
}

sub DDumper {
    return Data::Dumper::Dumper(@_);
}

#sub _is_utf8 { length $_[0] != do { use bytes; length $_[0] } }

BEGIN {
    my $numeric_rex=qr/\A-?(?:0|[1-9]\d*)(\.\d+(?

    # used by _qquote below
    my %esc = (
        "\a" => "\\a",
        "\b" => "\\b",
        "\t" => "\\t",
        "\n" => "\\n",
        "\f" => "\\f",
        "\r" => "\\r",
        "\e" => "\\e",
    );

    # Taken from Data::Dumper::qquote() 2.12.
    # Changed utf8 handling from that version
    # put a string value in double quotes
    # Fixes by [ysth]
    sub _qquote {
        my $str = shift;
        my @ret;
        while (length($str)) {
            local($_)=substr($str,0,72,"");
            s/([\\\"\@\$])/\\$1/g;

            unless (/[^ !""\#\$%&''()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~]/) {
                push @ret,qq("$_"); # fast exit
                next;
            }


            s/([\a\b\t\n\f\r\e])/$esc{$1}/g;

            if ( ord('^') == 94 ) {
                # ascii / utf8
                # no need for 3 digits in escape if followed by a digit
                s/([\0-\037])(?!\d) / sprintf '\\%o',    ord($1)/xeg;
                s/([\0-\037\177])   / sprintf '\\%03o',  ord($1)/xeg;

                if (length $_ != do { use bytes; length $_ }) {
                    use utf8; #perl 5.6.1 needs this, 5.9.2 doesn't. sigh
                    s/([\200-\377]) / sprintf '\\%03o',  ord($1)/xeg;
                    s/([^\040-\176])/ sprintf '\\x{%x}', ord($1)/xeg;
                } else {
                    # must not be under "use utf8" for 5.6.x
                    s/([\200-\377]) / sprintf '\\%03o',  ord($1)/xeg;
                }
            } else {
                # ebcdic
                s{([^ !""\#\$%&''()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])(?!\d)}
                 {
                    my $v = ord($1); '\\'.sprintf(($v <= 037 ? '%o' : '%03o'), $v)
                 }eg;
                s{([^ !""\#\$%&''()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])}
                   {'\\'.sprintf('%03o',ord($1))}eg;
            }

            push @ret,qq("$_");
        }
        return join ".\n\t",@ret;
    }


    # single quote
    sub _quote {
        my $v = join "", @_;
        if ($v=~$numeric_rex) {
            return $v;
        } elsif ($v!~/[^\x20-\x7E]/) {
            $v =~ s/([\\''])/\\$1/g;
            return "'$v'";
        }
        return _qquote($v);
    }

    # quote a key
    sub _quotekey {
        my $key = shift;
        if (!defined($key) or $key eq '') {
            return '""'
        } elsif ($key=~$numeric_rex or $key =~ /\A-?[A-Za-z_]\w*\z/) {
            return $key
        } else {
            _qquote($key);
        }
    }
}

my %ttrans = (
    reftype( {} )      => '%',
    reftype( [] )      => '@',
    reftype( \ 'foo' ) => '$',
    reftype( \\'foo' ) => '$', # REF
    reftype( sub{} )   => '&',
    ''                 => '$',
);


sub _make_name {
    my ( $self, $obj, $indx ) = @_;
    #warn Dumper($self->{unames})."'$self->{unames}'
    # : @{$self->{unames}||[]} @{[defined $indx ? $indx : '-']}";
    my $uname = ( $self->{unames} || [] )->[ $indx || 0 ];

    unless ($uname) {
        my $name = blessed($_[1])
                  || reftype($_[1])
                  || ((readonly($_[1]) && (\$_[1] != \undef)) ? "RO" : "VAR");
        unless ($self->{style}{verbose}) {
            my $n=1;
            (my $abr=$name)=~s/(\w)\w*::/$1/g;
            $self->{type_abrv}{$name}||=$name;
            while ($n<=length($abr) and
                   $self->{type_abrv}{substr($abr,0,$n)} and
                   $self->{type_abrv}{substr($abr,0,$n)} ne $name) {
                $n++;
            }
            if ($n<=length($abr)) {
                $self->{type_abrv}{substr($abr,0,$n)}=$name;
                return '$' .
                       substr($abr,0,$n) .
                       ( ++$self->{type_ids}{$name} );
            }
        }
        $name =~ s/::/_/g;
        ($name)=$name=~/(\w+)/; #take the first word;
        return '$' . $name . ( ++$self->{type_ids}{$name} );
    } elsif ( $uname =~ /^[-*]/ ) {
        my $type = reftype( $_[1] ) || '';
        $uname =~ s//$ttrans{$type}/;
        $uname;
    } else {
        return '$' . $uname;
    }
}

#=item diag
#
#Outputs to STDOUT a list of all values that have been identified of being
#worth of study. For development/debugging purposes only at this point.
#
#=cut

sub diag {
    my $self=shift;
    my $handle=shift || \*STDOUT;
    print $handle "+---+\n";

    my $oidx;
    foreach my $idx (1..$self->{sv_id}) {
        print $handle $self->diag_sv_idx($idx);
    }
    print "-----\n" if $self->{ref_id} and $self->{sv_id};
    foreach my $idx (1..($self->{ref_id}||0)) {
        print $handle $self->diag_ref_idx($idx);

    }
    print $handle "+---+\n";
    $self;
}

sub remove_deref {
    my $var=shift;

    my ($brace,$rest,$sigil);
    if ($var=~s/^([\@\%\$])(?=\$)//) {
        ($sigil,$brace)=($1,$var)
    } else {
        local $@;
        ($brace,$rest,$sigil)= Text::Balanced::extract_bracketed( $var, '{q}',qr/[\@\%\$]/ );
    }
    if ($brace and !$rest) {
        $brace=~s/^\{(.*)\}$/$1/;
        return wantarray ? ($sigil,$brace) : $brace;
    } else {
        return;
    }
}

my %tname=qw(HASH % ARRAY @ SCALAR $ REF $);

sub _build_name {
    my ( $self, $name, $type, $val ) = @_;

    $DEBUG>1 and print STDOUT "  _build_name( $name '$type' => ";
    $type=$tname{$type} if $tname{$type};
    if ($type=~/[[{]/) {

        $name=~s/[\@\%]\$/\$/;
        my ($sigil,$brace)=remove_deref($name);
        if ( $name =~ /^([\@\%\$])(\w+)$/ or $sigil
             or $name=~/^\*.*\{(?:SCALAR|HASH|ARRAY)\}$/
           )
        {

            $name .= '->' if !($name =~ s/^[\@\%]/\$/)
                          or $sigil;
            $name=~s/^\$(\$.*)->$/\$\{$1\}->/;
        }

        $DEBUG>1 and print STDOUT "$name => ";

        if ( $type eq '[' ) {
            $name .= "[$val]";
        } elsif ( $type eq '{' ) {
            $name .= "{" . _quotekey($val) . "}";
        } else {
            Carp::confess "Fallen off the end of the world...";
        }
    } elsif ( $type =~ /^[\@\%\$]$/ ) {
        $name = "{$name}"
           if $name =~ /[\[\{]/ or $name=~/^\*/;
        $name = $type . $name
          unless substr( $name, 0, 1 ) eq $type and $type ne '$';

    } else {
        no warnings; # XXX - why is this here? Yves
        Carp::confess "unimplemented _build_name";
    }
    $DEBUG>1 and print "$name )\n";
    $name;
}

sub _reset {
    my $self=shift;
    foreach my $key (keys %$self) {
        next unless $key=~/^(sv|ref|fix|cat|type|names|reqs|cache)/;
        delete $self->{$key};
    }
    $self->{sv_id}=$self->{ref_id}=0;
    $self;
}

sub diag_sv_idx {
    my $self=shift;
    my $idx=shift;
    my $prefix=shift||'';
    my $oidx=$self->{ref}{$self->{sva}[$idx]};
    my $ret=$prefix.
    sprintf "S%s%2d : %#x(c%2d|%2d) Dp:%2d %s Du:%s => %s %s %s %s\n",
        ($self->{special}{$idx} ? '*' : ' '),$idx,
        (map { $self->{$_}[$idx] } qw( sva svc svt svd )),
        ($self->{svro}[$idx] ? 'RO ' : 'RW'),
        (!$self->{svdu}[$idx]
          ? '-'
          : defined ${$self->{svdu}[$idx]}
            ? ${$self->{svdu}[$idx]}
            : '?'),
        $self->{svn}[$idx],
        (defined $self->{unames}[$idx-1] ? "($self->{unames}[$idx-1])" : ""),
        (($oidx) ? "< $self->{refn}[$oidx] >" : ""),
        ($self->{svon}{$idx} ? ": $self->{svon}{$idx}" : "")
        ;
    if ($prefix and $oidx) {
        $ret.=$prefix.$self->diag_ref_idx($oidx);
    }
    $ret;
}

sub diag_ref_idx {
    my $self=shift;
    my $idx=shift;
    my $oidx=$self->{sv}{$self->{refa}[$idx]};
    sprintf "R %2d : %#x(c%2d|%2d) Dp:%2d    Du:%s => %s %s\n",
        $idx,
        (map {
            defined $self->{$_}[$idx] ?  $self->{$_}[$idx] : -1
         } qw(refa refc reft refd )),
        (!$self->{refdu}[$idx]
         ? '-'
         : defined ${$self->{refdu}[$idx]}
           ? ${$self->{refdu}[$idx]}
           : '?'),
        $self->{refn}[$idx],
        (($oidx) ? " < $self->{svn}[$oidx] >" : "")
        ;
}


=item Dump

=item Dump VALUES

Smart non method based constructor.

This routine behaves very differently depending on the context it is
called in and whether arguments are provided.

If called with no arguments it is exactly equivalent to calling

  Data::Dump::Streamer->new()

which means it returns an object reference.

If called with arguments and in scalar context it is equivalent to calling

  Data::Dump::Streamer->new()->Data(@vals)

except that the actual depth first traversal is I until C
is called.  This means that options that must be provided before the
C phase can be provided after the call to C.  Again, it
returns a object reference.

If called with arguments and in void or list context it is equivelent to
calling

  Data::Dump::Streamer->new()->Data(@vals)->Out()

The reason this is true in list context is to make
C do the right thing. And also that combined with
method chaining options can be added or removed as required quite easily
and naturally.

So to put it short:

  my $obj=Dump($x,$y);         # Returns an object
  my $str=Dump($x,$y)->Out();  # Returns a string of the dump.
  my @code=Dump($x,$y);        # Returns a list of the dump.

  Dump($x,$y);                 # prints the dump.
  print Dump($x,$y);           # prints the dump.

It should be noted that the setting of C<$\> will affect the behaviour of
both of

  Dump($x,$y);
  print Dump($x,$y);

but it will not affect the behaviour of

  print scalar Dump($x,$y);

B As of 1.11 Dump also works as a method, with identical properties
as when called as a subroutine, with the exception that when called with
no arguments it is a synonym for C. Thus

  $obj->Dump($foo)->Names('foo')->Out();

will work fine, as will the odd looking:

  $obj->Dump($foo)->Names('foo')->Dump();

which are both the same as

  $obj->Names('foo')->Data($foo)->Out();

Hopefully this should make method use more or less DWIM.

=cut

my %args_insideout;

sub DESTROY {
    my $self=shift;
    delete $args_insideout{Data::Dump::Streamer::refaddr $self} if $self;
}

sub Dump {
    my $obj;
    if ( blessed($_[0]) and blessed($_[0]) eq __PACKAGE__ ) {
        $obj=shift;
    }
    if (@_) {
        if ( defined wantarray and !wantarray ) {
            $obj ||= __PACKAGE__->new();
            $obj->_make_args(@_);
            return $obj;
        } else {
            $obj||=__PACKAGE__;
            return $obj->Data(@_)->Out();
        }
    } else {
        if ($obj) {
            return $obj->Out();
        } else {
            return __PACKAGE__->new();
        }
    }
}


=item DumpLex VALUES

DumpLex is similar to Dump except it will try to automatically determine
the names to use for the variables being dumped by using PadWalker to
have a poke around the calling lexical scope to see what is declared. If
a name for a var can't be found then it will be named according to the
normal scheme. When PadWalker isn't installed this is just a wrapper for
L.

Thanks to Ovid for the idea of this. See L for a
similar wrapper around L.

=cut


sub DumpLex {
    if ( ! $HasPadWalker ) {
        #warn( "Can't use DumpLex without ".
        #    "PadWalker v1.0 or later installed.");
        goto &Dump;
    }
    my $obj;
    if ( blessed($_[0]) and blessed($_[0]) eq __PACKAGE__ ) {
        $obj=shift;
    }
    my @names;
    # = map {
    #        PadWalker::var_name(1,\$_)
    #        || PadWalker::var_name(1,\$_)
    #        (ref $_ && PadWalker::var_name(1,$_));
    #                $str
    #          } @_;
    #if ( !@names && @_ ) {

    my %pad_vars;
    foreach my $pad ( PadWalker::peek_my(1),
        PadWalker::peek_our(1)
    ){
        while (my ($var,$ref) = each %$pad) {
            $pad_vars{ refaddr $ref } ||= $var;
        }
    }
    foreach (@_) {
        my $name;
        INNER:foreach ( \$_, $_ ) {
            $name=$pad_vars{refaddr $_}
                and last INNER;
        }
        push @names, $name;
    }
    if ( defined wantarray and !wantarray ) {
        $obj ||= __PACKAGE__->new();
        $obj->_make_args(@_);
        $obj->Names(@names);
        return $obj;
    } else {
        $obj||=__PACKAGE__;
        return $obj->Names(@names)->Data(@_)->Out();
    }
}

=item DumpVars PAIRS

This is wrapper around L which expect to receive
a list of name=>value pairs instead of a list of values.
Otherwise behaves like L. Note that names starting
with a '-' are treated the same as those starting with '*' when
passed to L.

=cut


sub DumpVars {
    my $obj;
    if ( blessed($_[0]) and blessed($_[0]) eq __PACKAGE__ ) {
        $obj=shift;
    }
    if (@_ % 2) {
        warnings::warnif "Odd number of arguments in DumpVars";
        pop @_;
    }
    my @names;
    my @args;
    for ( 0 .. $#_/2 ) {
        $names[$_]=$_[$_*2];
        $args[$_]=$_*2+1;
    }
    #die "@_:@names|@args";
    if ( defined wantarray and !wantarray ) {
        $obj ||= __PACKAGE__->new();
        $obj->_make_args(@_[@args]);
        $obj->Names(@names);
        return $obj;
    } else {
        $obj||=__PACKAGE__;
        return $obj->Data(@_[@args])->Names(@names)->Out();
    }
}


sub _reg_ref {
    my ($self,$item,$depth,$name,$cnt,$arg)=@_;

    warn "_ref_ref($depth,$name,$cnt)\n" if $DEBUG;

    my $addr=refaddr $item;
    $arg->{raddr}=$addr if $arg;
    my $idx;
    unless ($idx=$self->{ref}{$addr}) {
        $idx=$self->{ref}{$addr}=++$self->{ref_id};
        $arg->{ridx}=$idx if $arg;
        $self->{refn}[$idx]=$name;
        $self->{refd}[$idx]=$depth;
        $self->{refa}[$idx]=$addr;
        $self->{refc}[$idx]=$cnt;
        return wantarray ? ($idx,0) : $idx
    }
    $self->{reft}[$idx]++;
    $arg->{ridx}=$idx if $arg;
    return wantarray ? ($idx,1) : undef;
}


sub _reg_scalar {
    my ($self,$item,$depth,$cnt,$ro,$name,$arg)=@_;
    Carp::cluck $name if $name=~/^\$\*/;
    my $addr=refaddr \$_[1];
    my $idx;
    $arg->{addr}=$addr if $arg;
    unless ($idx=$self->{sv}{$addr}) {
        $idx=$self->{sv}{$addr}=++$self->{sv_id};
        $self->{svd}[$idx]=$depth;
        $self->{sva}[$idx]=$addr;
        $self->{svro}[$idx]=$ro;
        $self->{svc}[$idx]=$cnt;
        $self->{svw}{$addr}=!0
            if isweak($_[1]);
        ($self->{svn}[$idx]=$name)=~s/^[\@\%\&]/\$/;
        if ($self->{svn}[$idx] ne $name) {
            $self->{svn}[$idx].="_"; #XXX
            #warn "$self->{svn}[$idx] ne $name"
            $self->{svon}{$idx}=$name;
        }

    } else{
        if ($DEBUG>9) {
            print $self->diag_sv_idx($idx);
           print "$name is already registered as $self->{svn}[$idx] ".
                 "Depth ($self->{svd}[$idx]) $depth\n";
        }
        if ($self->{svn}[$idx]=~/^\$\{?\$/ and $name!~/^\$\{?\$/) {
            $self->{svn}[$idx]=$name;
        }
    }
    $self->{svt}[$idx]++;
    $arg->{idx}=$idx if $arg;
    Carp::confess "Dupe name!" if $self->{svrt}{$name};
    $self->{svrt}{$name}=$idx;
    return $name;
}

*Precise=\&Dump;

# we make an array of hashes containing useful info about the arguments
sub _make_args {
    my $self=shift;
    $args_insideout{refaddr $self}= [
                map {
                        {
                                item   => \$_[$_],
                                ro     => readonly($_[$_]),
                                refcnt => sv_refcount($_[$_]),
                        }
                    } 0..$#_
            ];
    return $args_insideout{refaddr $self}
}

=back

=head2 Methods

=over 4

=item Data

=item Data LIST

Analyzes a list of variables in breadth first order.

If called with arguments then the internal object state is reset before
scanning the list of arguments provided.

If called with no arguments then whatever arguments were provided to C
will be scanned.

Returns $self.

=cut


sub _add_queue {
    my ($self,$queue,$type,$item,$depth,$name,$rcount,$arg)=@_;
    if (substr($type,0,1) ne '*') {
        push @$queue,[\$item,$depth,$name,$rcount,$arg];
    } elsif($self->{style}{dumpglob}) {
        local @_;
        foreach my $t ($self->_glob_slots('FORMAT')) {

            #warn $type.":$t\n";
            #register?
            #$self->_reg_scalar(*$item{$t},$depth+1,sv_refcount(*$item{$t}),
            # readonly(*$item{$t}),'*'.$name."{$t}");

            my $v=*$item{$t};
            next unless defined $v;
            next if $t eq 'SCALAR' and !defined($$v);
            push @$queue,[
                \*$item{$t},
                $depth+1,
                $type."{$t}",
                refcount(\*$item{$t})
            ];
        }
    }
    #use Scalar::Util qw(weaken);
    $self;
}

sub Data {
    my $self=shift->_safe_self;
    my $args;
    print "Data(".scalar(@_)." vars)\n"
        if $DEBUG;
    if (@_) {
        $self->_reset;
        $self->_make_args(@_);
    } elsif ( $self->{cataloged} ) {
        $self->_reset;
    }
    $args= $args_insideout{refaddr $self}
        || Carp::carp "No arguments!";
    my $pass=1;
PASS:{
        my @queue;
        my $idx=0;
        foreach my $arg (@$args) {
            #($self,$item,$depth,$cnt,$ro,$name)
            my $make_name=$self->_make_name(${ $arg->{item} },$idx++);
            my $name=$self->_reg_scalar(
                ${ $arg->{item} },
                1,
                $arg->{refcnt},
                $arg->{ro},
                $make_name,
                $arg
            );
            $arg->{name}=$name;
            if (my $type=reftype_or_glob ${ $arg->{item} }) {
                $self->_add_queue(\@queue, $type, ${ $arg->{item} }, 2,
                   $name, refcount ${ $arg->{item} },$arg)
            }
        }

        my %lex_addr;
        my %lex_addr2name;
        my %lex_name;
        my %lex_special;

        while (@queue) {
            # If the scalar (container) is of any interest it is
            # already registered by the time we see it here.
            # at this point we only care about the contents, not the
            # container.
            print Data::Dumper->new([\@queue],['*queue'])->Maxdepth(3)->Dump
                if $DEBUG>=10;

            my ($ritem,
                $cdepth,
                $cname,
                $rcnt,
                $arg)=@{shift @queue};



            my ($frozen,$item,$raddr,$class);
            DEQUEUE:{
                $item=$$ritem;
                $raddr=refaddr($item);
                $class=blessed($item);

                if ($self->{ref_fz}{$raddr}) {
                    print "Skipping frozen element $raddr\n" if $DEBUG;
                    next;
                }

                $DEBUG and
                print "Q-> $item $cdepth $cname $rcnt ($raddr)\n";

                unless ($raddr) {
                    $DEBUG and
                    print "  Skipping '$cname' as it isn't a reference.\n";
                    next;
                }

                last DEQUEUE if $frozen;
                $frozen=1;
                if ($self->{style}{ignore}{"#$raddr"} || ($class&& $self->{style}{ignore}{".$class"})) {
                    $DEBUG and
                    print "Ignoring '$cname' as its class ($class) in ".
                          "our ignore list.\n";
                    next;
                } elsif ($class && !$self->{"cache_skip_freeze"}{$class}) {
                    my $freezer= $self->{cache_freeze_class}{$class};
                    my ( $proxy, $thaw, $postop );
                    if (! defined $freezer ) {
                        for ( $self->{style}{freeze_class}{$class},
                              $self->{style}{freezer},
                              'DDS_freeze' )
                        {
                            $freezer= $_;
                            if ( $freezer ) {
                                if (ref $freezer) {
                                    eval {
                                        ($proxy,$thaw,$postop)= $freezer->($$ritem);
                                    };
                                    last if !$@;
                                } elsif ( $class->can($freezer) ) {
                                    eval {
                                        ($proxy,$thaw,$postop)= ${$ritem}->$freezer();
                                    };
                                    last if !$@;
                                }
                            } elsif ( defined $freezer ) {
                                last;
                            }
                        }
                        if (! defined $proxy) {
                            $self->{"cache_skip_freeze"}{$class}=1;
                        } else {
                            $self->{cache_freeze_class}{$class}= $freezer;
                        }

                    } elsif (ref $freezer) {
                        ($proxy,$thaw)= $freezer->($$ritem);
                    } else {
                        ($proxy,$thaw)= ${$ritem}->$freezer();
                    }
                    if ( $thaw ) {
                        $self->{ref_thaw}{$raddr}= $thaw;
                    }
                    if ( $postop ) {
                        $self->{ref_postop}{$raddr}= $postop;
                    }
                    if ( refaddr($proxy) != $raddr ) {
                        $self->{ref_fz}{$raddr}= $proxy;
                        $ritem= \$proxy;
                        if (ref $proxy) {
                            redo DEQUEUE;
                        } else {
                            next;
                        }
                    }
                }

            }

            my ($idx,$dupe)=$self->_reg_ref($item,$cdepth,$cname,$rcnt,$arg);
            $DEBUG and print "  Skipping '$cname' as it is a dupe of ".
                             "$self->{refn}[$idx]\n"
                if $dupe;

            $DEBUG>9 and $self->diag;
            next if $dupe;


            my $reftype=reftype $item;
            my $cnt=refcount($item);
            my $overloaded=undef;
            my $isoverloaded=0;
            if (defined $class and overload::Overloaded($item)) {
                disable_overloading( $item );
                $overloaded= $class;
                $isoverloaded= 1;
            }


            if ( $reftype eq 'SCALAR' or
                 $reftype eq 'REF' or
                 $reftype eq 'GLOB' )
            {
                my $name=$self->_build_name($cname,'$');
                my $cnt=sv_refcount($$item);
                if ($cnt>1) {
                    $self->_reg_scalar($$item,$cdepth+1,$cnt,
                      readonly($$item),$name);
                }
                if (my $type=reftype_or_glob $$item) {
                    $self->_add_queue(\@queue,$type,$$item,
                       $cdepth+2,$name,$cnt)
                }

            } elsif ($reftype eq 'ARRAY') {
                foreach my $idx (0..$#$item) {
                    my $name=$self->_build_name($cname,'[',$idx);
                    my $cnt=sv_refcount($item->[$idx]);
                    if ($cnt>1) {
                        print "refcount($name)==$cnt\n"
                            if $DEBUG>9;
                        $self->_reg_scalar($item->[$idx],$cdepth+1,$cnt,
                           readonly($item->[$idx]),$name);
                    }
                    if (my $type=reftype_or_glob $item->[$idx]) {
                        $self->_add_queue(\@queue,$type,$item->[$idx],
                           $cdepth+2,$name,$cnt)
                    }
                }
            } elsif ($reftype eq 'HASH') {
                my $ik=$self->{style}{indentkeys};
                my ($keyary, $thaw)= $self->_get_keys($item,0,$raddr,$class);
                if ($thaw) {
                    $self->{ref_thaw}{$raddr}= $thaw;
                }
                my $key_len=0;
                my $key_sum=0;
                my $key_count=0;
                die reftype $keyary if $keyary && reftype($keyary) ne 'ARRAY';

                while ( defined( my $key =
                  defined $keyary ? $keyary->[$key_count] : each %$item
                ))
               {
                    if ($ik) {
                        my $qk=_quotekey($key);
                        $key_sum+=length($qk);
                        $key_len=length($qk) if $key_len
                    }
                    $key_count++;
                    my $name=$self->_build_name($cname,'{',$key);
                    my $cnt=sv_refcount($item->{$key});
                    if ($cnt>1) {
                        $self->_reg_scalar($item->{$key},$cdepth+1,$cnt,
                            readonly($item->{$key}),$name);
                    }
                    if (my $type=reftype_or_glob $item->{$key}) {
                        $self->_add_queue(\@queue,$type,$item->{$key},
                            $cdepth+2,$name,$cnt);
                    }
                }
                my $avg=$key_count>0 ? $key_sum/$key_count : 0;
                $self->{ref_hklen}{$raddr}=($key_len>8 && (2/3*$key_len)>$avg)
                                           ? int(0.5+$avg) : $key_len;
                $self->{ref_hkcnt}{$raddr}=$key_count;
                #warn "$raddr => $key_count";

            } elsif ($reftype eq 'CODE') {
                if ($pass == 1) {

                    my $used=_get_lexicals($item);

                    foreach my $name (keys %$used) {
                        next unless $name=~/\D/;
                        my $addr=refaddr($used->{$name});
                        if ( !$lex_addr{$addr} ) {
                            $lex_addr{$addr}=$used->{$name};
                            if ( $lex_name{$name} ) {
                                my $tmpname=sprintf "%s".$self->{style}{eclipsename},
                                             substr($name,0,1),
                                             $self->{style}{eclipsename}=~/^[^%]*%s/
                                              ? ( substr($name,1),
                                                  ++$lex_special{$name}, )
                                              : ( ++$lex_special{$name},
                                                  substr($name,1), );
                                $lex_name{$tmpname}=$addr;
                                $lex_addr2name{$addr}=$tmpname;
                                $self->_add_queue(\@queue,reftype_or_glob $used->{$name},
                                    $used->{$name},$cdepth+1,$tmpname,2);
                            } else {
                                $lex_name{$name}=$addr;
                                $lex_addr2name{$addr}=$name;
                                $self->_add_queue(\@queue,reftype_or_glob $used->{$name},
                                    $used->{$name},$cdepth+1,$name,2);
                            }
                        }
                    }
                }
            } elsif ($reftype eq 'FORMAT') {
                # Code similar to that of CODE should go here I think.
            } else {
                # IO?
                Carp::confess "Data() can't handle '$reftype' objects yet ($item)\n :-(\n"
                    if $ENV{DDS_STRICT};
            }
            if ($isoverloaded) {
                restore_overloading( $item, $overloaded );
            }
        }
        if ( $pass++ == 1 ) {

            my %items;
            for my $idx ( 0..$#{$args_insideout{refaddr $self}} ) {
                my $item=$args_insideout{refaddr $self}[$idx];
                $items{ refaddr $item->{item} } = $idx;
            }

            my @add;
            my $added=0;
            if (0) {
                @add=keys %lex_addr;
            } else {
                for my $addr (keys %lex_addr) {
                    if ( exists $items{$addr} ) {
                        my $idx = $items{$addr};
                        if ( !$self->{unames}[$idx] ){
                            for ($self->{unames}[$idx] = $lex_addr2name{$addr}) {
                                s/^[^\$]/*/; s/^\$//;
                            }
                            $added++;
                        } else {
                            my $new=$self->{unames}[$idx];
                            my $old=$lex_addr2name{$addr};
                            $new=~s/^(\*)?/substr($old,0,1)/e;
                            delete $lex_name{$lex_addr2name{$addr}};
                            $lex_addr2name{$addr}=$new;
                            $lex_name{$self->{unames}[$idx]} = $addr;  # xxx
                        }
                    } else {
                        push @add,$addr;
                    }
                }
            }
            @add=sort {$lex_addr2name{$a} cmp $lex_addr2name{$b}} @add;

            $self->{lexicals}={
                               a2n => \%lex_addr2name,
                               name => \%lex_name
                              };

            if (@add) {
                unshift @{$args_insideout{refaddr $self}},
                   map {
                            my $rt=reftype($lex_addr{$_});
                            my $item;
                            if ($rt ne 'SCALAR' and $rt ne 'GLOB' and $rt ne 'REF') {
                                $item=\$lex_addr{$_};
                            } else {
                                $item=$lex_addr{$_};
                            }
                            {
                                    item   => $item,
                                    usemy  => 1,
                                    ro     => 0,
                                    refcnt => refcount($lex_addr{$_}),
                            }
                        } @add;
                $self->{lexicals}{added}={ map { $lex_addr2name{$_} => 1 } @add };
                unshift @{$self->{unames}},
                    map {
                            (my $n=$lex_addr2name{$_})=~s/^[^\$]/*/;
                            $n=~s/^\$//;
                            $n
                        } @add;
                $self->_reset;
                redo PASS;
            } elsif ($added) {
                $self->_reset;
                redo PASS;
            }
        }
    }
    $self->{cataloged}=1;
    return $self;
}

sub _add_fix {
    my ($self,@args)=@_;
    # 'var','glob','method call','lock','ref','sv','#'
    # TODO
    # add a fix statement to the list of fixes.
    my $fix=@args==1 ? shift @args : [@args];
    unless ($fix->[0]=~/^(var|glob|thaw|ref|sv|#|sub call|lock|bless)$/) {
        Carp::confess "Unknown variant:".Dumper($fix);
    }
    if ($args[0] eq 'var') {
        unshift @{$self->{fix}},$fix;
    }   else {
        push @{$self->{fix}},$fix;
    }
}

sub _glob_slots {
    my ($self,$inc_format)=@_;
    # $inc_format is for a special case.
    return (
            qw(SCALAR HASH ARRAY),
             (($self->{style}{deparse} && $self->{style}{deparseglob})
                ? 'CODE' : ()),
             (($inc_format && $self->{style}{deparse} && $self->{style}{deparseglob})
                ? 'FORMAT' : () )
           );
}

sub _dump_apply_fix { #handle fix statements and GLOB's here.
    my ($self,$isfinal)=@_;
    # go through the fix statements and out any that are
    # now fully dumped.
    # currently the following types are grokked:
    # 'var','glob','method call','tlock','ref','sv','#'

    my @globs;
    GLOB:{
        @globs=();
        @{$self->{fix}}=grep {
            my $keep=1;
            my $fix=$_;
            if (ref $fix) {
                my ($type,$lhs,$rhs,$class)=@$fix;

                if ($type eq '#') {
                    $self->{fh}->print(map "# $_\n",@$fix[0..$#$fix]);
                    $keep=0;
                } elsif ($type eq 'bless') {
                    if ($isfinal) { # $self->{"refdu"}[$lhs]
                        $lhs=$self->{"refn"}[$lhs];
                        $self->{fh}->print(
                            substr($self->{style}{bless},0,-1)," ",$lhs,", ",
                           _quote($rhs)," ",substr($self->{style}{bless},-1),
                           ";\n");
                        $keep=0;
                    }
                } elsif ($type eq 'sv') {

                    my $dref=$_->[-1];
                    if ($self->{$type."du"}[$rhs] and ${$self->{$type."du"}[$rhs]}) {
                        $rhs=$self->{$type."n"}[$rhs];
                        my ($sigil,$var)=remove_deref($lhs);
                        if ($sigil) {
                            $rhs="\\".$rhs;
                            $lhs=$var;
                        }
                        $self->{fh}->print("$lhs = $rhs;\n");
                        $$dref=1 if ref $dref;
                        $keep=0
                    }
                } elsif ($type eq 'ref') {

                    if ($self->{$type."du"}[$rhs] and ${$self->{$type."du"}[$rhs]}) {

                        $rhs=$self->{$type."n"}[$rhs];

                        if ($rhs=~/^[\@\%\&]/) {
                            $rhs="\\".$rhs;
                            $rhs="bless( $rhs, "._quote($class).' )'
                                if $class;
                        } # Warn if
                        $self->{fh}->print("$lhs = $rhs;\n");
                        $keep=0
                    }
                } elsif ($type eq 'lock') {
                    if ($self->{refdu}[$lhs] and ${$self->{"refdu"}[$lhs]}) {
                        $lhs=$self->{"refn"}[$lhs];
                        $self->{fh}->print(@$rhs ? "lock_keys_plus( $lhs, "
                                             : "lock_keys( $lhs ",
                                        join(", ",map{ _quote($_) } @$rhs),
                                        ");\n");
                        $keep=0;
                    }
                } elsif ($type eq 'thaw') {
                    # these have to happen at the end.
                    if ($isfinal) {
                        #if ($self->{refdu}[$lhs] and ${$self->{"refdu"}[$lhs]}) {
                        ${$self->{refdu}[$lhs]}=1;
                        $lhs=$self->{"refn"}[$lhs];
                        my @args=@$_[3..$#$_];
                        if ($rhs=~/^(->)?((?:\w*::)*\w+)(\(\))?$/) {
                            if ($3) {
                                $self->{fh}->print("$2( ".join(", ",$lhs,@args)." );\n");
                            } else {
                                $self->{fh}->print("$lhs->$2(".join(", ",@args).");\n");
                            }
                        } else {
                            $rhs=~s/^\t//mg;
                            $self->{fh}->print("for ($lhs) {\n$rhs\n}\n");
                        }
                        $keep=0;
                    }
                } elsif ($type eq 'glob') {
                    push @globs,$_;
                    $keep=0;
                } elsif ($type eq 'var') {
                    $rhs="\\".$rhs;
                    $rhs="bless( $rhs, "._quote($class).' )'
                        if $class;
                    $self->{fh}->print(($self->{style}{declare} ? 'my ' : ""),"$lhs = $rhs;\n");
                    $keep=0;
                }  elsif ($type eq 'sub call') {
                    my @r=grep { ref $_ and (!$self->{svdu}[$$_] or !${$self->{svdu}[$$_]}) } @$fix;
                    unless (@r) {
                        my ($type,$sub,@args)=map { ref $_ ? $self->{svn}[$$_] : $_ } @$fix;
                        $self->{fh}->print("$sub(",join(", ",@args),");\n");
                        $keep=0;
                    }
                } else {
                    die "Bad fix: ",Dumper($fix);
                }

            }
            $keep;
        } @{$self->{fix}};
        foreach my $glob (@globs) {
            my ($type,$lhs,$rhs,$depth,$name)=@$glob;
            print "Symbol: $name\n" if $DEBUG and $name;
            local @_;
            $name=$name ? '*'.$name : $rhs;
            my $overloaded=undef;
            my $isoverloaded=0;
            if (defined( blessed $lhs ) and
                overload::Overloaded( $lhs ) )
            {
                $overloaded=blessed $lhs;
                disable_overloading( $lhs );
                $isoverloaded=1;
            }
            foreach my $t ($self->_glob_slots(''))
            {
                my $v=*$lhs{$t};

                if ( not(defined $v) or
                    ($t eq 'SCALAR' and !defined($$v)))
                {
                    next;
                }


                my $dumped=0;


                my $gaddr=refaddr(*$lhs{$t});
                my $gidx=$self->{ref}{$gaddr};
                unless ($gidx) {
                    next
                } elsif ($self->{refd}[$gidx]<$depth+1) {
                    $self->_add_fix('ref',$name,$gidx,blessed(*$lhs{$t}));
                    next;
                }

                $self->{fh}->print("$name = ");
                my $ret=$self->_dump_sv(*$lhs{$t},$depth,\$dumped,$name,length($name)+3);
                Carp::confess "\nUnhandled alias value '$ret' returned to _dump_apply_fix()!"
                    if $ret;
                $self->{fh}->print(";\n");
                $dumped=1;
            }

            if ($self->{style}{deparse} && $self->{style}{deparseglob}
                #and defined *$lhs{FORMAT}
            ) {
                # from link from [ysth]: http://groups.google.com/groups?selm=laUs8gzkgOlT092yn%40efn.org
                # translate arg (or reference to it) into a B::* object

                # To work-around perl commit
                # 2acc3314e31a9342e325f35c5b592967c9850c9b, keep the
                # value \*$lhs alive while we inspect it as a B object
                # or else it'll be reaped while we're using it.
                my $lhs_glob = \*$lhs;
                my $Bobj = B::svref_2object($lhs_glob);

                # if passed a glob or globref, get the format
                $Bobj = B::GV::FORM($Bobj) if ref $Bobj eq 'B::GV';

                if (ref $Bobj eq 'B::FM') {
                    (my $cleaned=$name)=~s/^\*(::)?//;
                    $self->{fh}->print("format $cleaned =\n");
                    my $deparser = Data::Dump::Streamer::Deparser->new();
                    $self->{fh}->print(
                        $deparser->indent($deparser->deparse_format($Bobj))
                    );
                    $self->{fh}->print("\n");
                }
            }
            if ($isoverloaded) {
                restore_overloading( $lhs, $overloaded );
            }


        }
        redo GLOB if @globs;
    }
}

=item Out

=item Out VALUES

Prints out a set of values to the appropriate location. If provided a list
of values then the values are first scanned with C and then
printed, if called with no values then whatever was scanned last with
C or C is printed.

If the C attribute was provided then will dump to whatever object
was specified there (any object, including filehandles that accept the
print() method), and will always return $self.

If the C attribute was not provided then will use an internal
printing object, returning either a list or scalar or printing to STDOUT
in void context.

This routine is virtually always called without arguments as the last
method in the method chain.

 Dump->Arguments(1)->Out(@vars);
 $obj->Data(@vars)->Out();
 Dump(@vars)->Out;
 Data::Dump::Streamer->Out(@vars);

All should DWIM.

=cut

#
# Out is just a wrapper. The overall dumping process works like this:
#
# Out
#   foreach root value
#     _dump_sv
#       _dump_rv if ref
#         (optionally one of)
#         _dump_array
#         _dump_hash
#         _dump_code
#         _dump_qr
#     _dump_apply_fix
#       (which may call)
#       _dump_sv
#
# _dump_array, _dump_hash, _dump_rv  if needed may also call _dump_sv
#
# essentially _dump_sv and _dump_rv handle uniqueness checks for scalars,
# and refs. _dump_sv handles the SV's containers and _dump_rv
# handles the things that the SV contains a reference to. _dump_sv also
# handles simple values and globs, and works with _dump_rv to handle
# references to scalars correctly. If "fix" statements are required
# to complete the definition of the structure (self referential structures)
# then _add_fix adds them to the list, and _dump_apply_fix pulls them off.
# note that _dump_apply_fix can also call _dump_sv if needed (to handle globs),
# and will also emit fix statements as early as possible. no require/use
# logic is currently in place. its the evalers responsibility to use the mod
# w/the right tags for now...

sub Out {
    local($\,$",$,)=("","",""); # prevent globals from messing with our output via print
    my $self = shift->_safe_self;
    print "Out(".scalar(@_)." vars)\n"
        if $DEBUG;
    if ( !$self->{in_printit} and (@_ or !$self->{cataloged} )) {
        $self->Data(@_);
    }

    my $fh;
    unless ( $self->{fh} ) {
        print "  no filehandle using "
            if $DEBUG;
        if (defined wantarray) {
            my $class= __PACKAGE__ . (wantarray ? "::_::ListPrinter" : "::_::StringPrinter");
            print $class,"\n"
                if $DEBUG;
            $fh = $class->new()
              or Carp::confess "$class failed to build!";
            $self->{'return'} = $fh;
        } else {
            print "STDOUT\n" if $DEBUG;
            $fh = \*STDOUT;
        }
        $self->{fh} = $fh;
    }
    # loop over the list
    # and dump out each one in turn
    # handling any potential fixes after
    # each definition is complete
    $self->{out_names}=[];
    $self->{declare}=[];
    $self->{special}={};
    $DEBUG>9 and $self->diag;

    my @items=@{$args_insideout{refaddr $self}};

    my $namestr="";

    push @{$self->{out_names}},map{$_->{name}}@items; #must
    push @{$self->{declare}},map{$_->{name}}@items;

    if ($self->{style}{special}) {

        warn DDumper(\@items) if $DEBUG;

        $namestr="# (".join (", ",@{$self->{out_names}}).")\n";

        @items=sort { $self->{svc}[$b->{idx}] <=> $self->{svc}[$a->{idx}]||
                  ($b->{raddr} ? $self->{refc}[$b->{ridx}] : 0)
                   <=>
                  ($a->{raddr} ? $self->{refc}[$a->{ridx}] : 0)
            } @items;




        warn DDumper(\@items) if $DEBUG;
    }

    if ($self->{style}{compress} && $self->{style}{compressor}) {
        my $prelude=$self->{style}{compressor}->();
        $self->{fh}->print($prelude) if $prelude;
    }

    $self->{fh}->print("my (",join(",",sort keys %{$self->{lexicals}{added}}),");\n")
        if $self->{lexicals}{added};

    foreach my $item (@items) {
        my $dumped=0;
        my $ret=$self->_dump_sv(${$item->{item}},1,\$dumped,$item->{name});
        Carp::confess "\nUnhandled alias value '$ret' returned to Out()!"
            if $ret;
        $self->{fh}->print(";\n");
        $dumped=1;
        $self->_dump_apply_fix();
    }
    $self->_dump_apply_fix('final');
    $self->{fh}->print($namestr) if $namestr;

    $self->diag if $DEBUG;
    #warn "@{$self->{out_names}}";
    if ( $self->{return} and defined wantarray) {
        my $r = delete $self->{return};
        delete $self->{fh};
        return $r->value;
    } else {
        return $self;
    }

}


sub print_token {
    my ($self, $str)=@_;
    $self->{fh}->print($str);
}
sub print_quoted {
    my ( $self, $str )=@_;
    $self->{fh}->print($str);
}

# sqz(str,begin,end)
sub sqz {
    require Compress::Zlib;
    require MIME::Base64;
    my $res= Compress::Zlib::compress($_[0],9);
    return $_[1]
          ? $_[1]
            . MIME::Base64::encode($res,"")
            . $_[2]
          : MIME::Base64::encode($res,"");
}

# usqz(str)
sub usqz {
    return Compress::Zlib::uncompress(
            MIME::Base64::decode($_[0])
           );
}



sub _dump_sv {
    my ($self,$item,$depth,$dumped,$name,$indent,$is_ref)=@_;

    $self->{do_nl}=0;

    my $addr=refaddr(\$_[1]);
    my $idx=$self->{sv}{$addr};
    my $ro;
    $DEBUG and printf "_dump_sv %d %s %#x - %d\n",$depth, $name,$addr,$idx||0;


    $name||=$self->{svn}[$idx];
    (my $clean_name=$name)=~s/^[\@\%\&](\w+)/\$${1}_/; # XXX
    my $optspace=$self->{style}{optspace};
    if ($idx) {

        # Its a monitored scalar.

        my $pre_dumped=$self->{svdu}[$idx];
        my $name_diff=(
                           $self->{svd}[$idx]==$depth
                       and $self->{svn}[$idx] ne $clean_name
                       and $clean_name!~/\*/
                       and $name!~/^\&/
                      );

        #print "Idx: $idx Special keys:",join("-",keys %{$self->{special}}),"\n"
        #    if $DEBUG and keys %{$self->{special}};

        print "sv_dump Monitored:\n",$self->diag_sv_idx($idx,"  ") if $DEBUG;


        if (( $pre_dumped and !$self->{svon}{$idx})
           or (!$self->{svon}{$idx} ? ($self->{svd}[$idx]<$depth or $name_diff) : undef) )
        {

            print "PREDUMPED: $self->{svon}{$idx}\n"
                if $DEBUG and $self->{svon}{$idx} and $pre_dumped and $$pre_dumped;

            # We've seen it before.
            # Unless its a ref it must be an alias
            print(($name_diff ? "Name diff" : "No name diff"), " $name, $clean_name","\n")
                if $DEBUG;

            my ($str,$ret)=('',undef);

            if ($is_ref) {
                if ($self->{svd}[$idx]==1 && !$self->{style}{declare}
                    || ($pre_dumped && $$pre_dumped)
                ) {
                    $str="\\$self->{svn}[$idx]";
                } else {
                    #see the 'Many refs' tests in t\dump.t for
                    #why this is here. basically we need to
                    #ensure the ref is modifiable. If its two $'s
                    #then its modifiable anyway, more and it wont be.
                    # $ref=\\$x; $ref=RW $$ref=RO $$$ref=$x=RW
                    unless ($self->{style}{purity}) {
                        $str="\\$self->{svn}[$idx]";
                    } else {
                        my $need_do=($name=~/^\$\$\$+/);
                        if ($need_do) {
                            $str.=join($optspace,qw( do { my $f = ),'');
                        }

                        $str.=!$self->{style}{verbose}
                               ? "'R'" : _quote($DEBUG ? 'SR: ' : 'R: ',
                                                "$self->{svn}[$idx]");
                        $ret=\do{my $nope=0};
                        $self->_add_fix('sv',$name,$idx,$ret);

                        $str.="$optspace}" if ($need_do)
                    }
                }
            } else {
                if ($depth==1) {
                    if ($self->{style}{declare}) {
                        $str.="my $name;\n";
                    }
                    #push @{$self->{out_names}},$name;
                    #push @{$self->{declare}},$name;
                    $str.="alias_ref(\\$name,\\$self->{svn}[$idx])";
                } elsif ($self->{style}{purity}) {
                    $str.=!$self->{style}{verbose} ? "'A'" : _quote("A: ",$self->{svn}[$idx]);
                    $ret=\$idx;
                } else {
                    $str.="alias_to($self->{svn}[$idx])";
                    $ret='';
                }
            }
            $self->{buf}+=length($str);
            $self->{buf}=length($1) if $str=~/\n([^\n]*)\s*\z/;
            $self->{fh}->print($str);
            return $ret ? $ret : ()
        } else {
            # we've never seen it before and we need to dump it.
            $self->{svdu}[$idx]||=$dumped;

            print "Defining Special:".$self->diag_sv_idx($idx)
                if $DEBUG and $self->{special}{$idx};

            $self->{svn}[$idx]=$name if $self->{special}{$idx};
            $self->{svd}[$idx]=$depth if $self->{special}{$idx};

        }
        $ro=$self->{svro}[$idx];
    } else {
        $ro=readonly $_[1] unless defined $ro;
    }
    print "sv_dump: Postindexed\n" if $DEBUG;
    if ($depth==1) {
        # root level object. declare it
        if ($name ne $clean_name and $name!~/^\*/ and $self->{svc}[$idx]>1) {

                print "Special $name\n" if $DEBUG;
                my $oidx=$self->{ref}{$self->{sva}[$idx]};
                if ($oidx) {
                    #theres a ref to us out there
                    my $name=$self->_build_name($self->{refn}[$oidx],'$');
                    $self->{svn}[$idx]=$name;
                    print "Oindex! $oidx $name\n" if $DEBUG;
                    #$self->{svd}[$idx]=$self->{refd}[$idx]+1;
                }

                #$self->{special}{$idx}++;
                $self->{svdu}[$idx]=undef;

                print $self->diag_sv_idx($idx,1) if $DEBUG;
        }
        #push @{$self->{out_names}},$name; #must
        #push @{$self->{declare}},$name;
        unless ($name=~/^\&/) { # XXX
            my $str=(($self->{style}{declare} && $name!~/^\*/
                     && !$self->{lexicals}{added}{$name}
                     ) ? "my$optspace" : ""
                     )."$name$optspace=$optspace";
            $self->{fh}->print($str);
            $indent=length($str);
            $self->{buf}=0;
        } else {
            $indent=0;
        }
        print "toplevel\n" if $DEBUG;
    }

    my $iaddr=refaddr $item;

    $self->{fh}->print("\\")
        if $is_ref;

    my $glob=globname $item;
    my $add_do=$self->{style}{purity}
               && !$ro
               && $is_ref
               && !blessed($_[1])
               && !$glob
               && do {
                    my $rtype= reftype($_[1]);
                    $rtype eq "" or
                    ($rtype eq "SCALAR" and ( $] < 5.020 or !readonly(${ $_[1] }) ) )
                  }
    ;


    if ($add_do) {
        #warn "\n!$ro && $is_ref && !blessed($_[1]) && !$glob";
        $self->{fh}->print(join $optspace,qw(do { my $v = ),'');
        $self->{buf}+=13;
    }

    unless ($iaddr) {
        print "iaddr $glob\n" if $DEBUG;
        unless (defined $item) {
            $self->{fh}->print('undef');
            $self->{buf}+=5;
        } else {
            my $is_ro=($self->{style}{ro} && $ro && !$is_ref);
            if ($is_ro and !$self->{style}{purity}) {
                $self->{fh}->print("make_ro($optspace");
            }
            if ($glob) {
                if ($glob=~/^\*Symbol::GEN/) {
                    $self->_dump_symbol($_[1],$name,$glob,'deref',$depth);
                } else
                {
                    $self->{buf}+=length($glob);
                    $self->{fh}->print($glob);
                    if ($self->{style}{dumpglob} and
                        !$self->{sv_glob_du}{$glob}++) {
                        $self->_add_fix('glob',$_[1],$glob,$depth+1);
                    }
                }
            } else {
                my $quoted;
                if ($self->{style}{dualvars}) {
                    no warnings 'numeric'; # XXX: is this required?
                    if (_could_be_dualvar($item) && 0+$item ne $item && "$item" != $item ) {
                        $quoted="dualvar( ".join(",$optspace",0+$item,_quote("$item"))."$optspace)";
                    }
                }
                # XXX main scalar output here!
                if ( ! $quoted ) {
                    my $style= $self->{style};

                    if ( $style->{compress} &&
                        $style->{compressor} &&
                        length($_[1]) > $style->{compress}
                    ){
                        $quoted= $style->{compressor}->($_[1],$self);
                    } else {
                        $quoted=_quote($item);
                    }

                }
                $self->{buf}+=length($quoted);
                $self->{buf}=length($1) if $quoted=~/\n([^\n]*)\s*\z/;
                $self->{fh}->print($quoted); #;
            }
            if ($is_ro && $self->{style}{purity}) {
                $self->_add_fix('sub call','make_ro',$name);
            } elsif ($is_ro) {
                $self->{fh}->print("$optspace)");
            }
            #return
        }
        $self->{do_nl}=0;
    } else {
        $self->{do_nl}=1;
        $self->_dump_rv($item,$depth+1,$dumped,$name,$indent,$is_ref && !$add_do);
    }
    $self->{fh}->print("$optspace}")
            if $add_do;
    $self->_add_fix('sub call','weaken',$name)
            if $self->{svw}{$addr};
    return
}

sub _brace {
    my ($self,$name,$type,$cond,$indent,$child)=@_;
    my $open=$type=~/[\{\[\(]/;

    my $brace= $name !~ /^[%@]/
             ? $type
             : $type =~ /[\{\[\(]/
                ? '('
                : ')';
    $child= $child ? $self->{style}{optspace} : "";
    if ( $cond ) {
        $_[-2] += $open ? $self->{style}{indentcols}
                        : -$self->{style}{indentcols};
        $self->{fh}->print($open ? "" : "\n".(" " x $_[-2]),
                           $brace,
                           $open ? "\n".(" " x $_[-2]) : "");
    } else {
        $self->{fh}->print($open ? "" : $child ,
                           $brace,
                           $open ? $child : "");
    }
    return
}

sub _dump_qr {
    my ($self,$pat,$mod)=@_;
    my %counts;
    $counts{$_}++ foreach split //,$pat;
    my ($quotes,$best)=('',length($pat)+1);
    foreach my $char (qw( / ! % & <> {} " ),'#') { #"
        my $bad=0;
        $bad+=$counts{$_}||0 for split //,$char;
        ($quotes,$best)=($char,$bad) if $bad<$best;
        last unless $best;
    }
    $pat=~s/(?!\\)([$quotes])/\\$1/g
        if $best;
    {
    use utf8;
    #$pat=~s/([^\x00-\x7f])/sprintf '\\x{%x}',ord $1/ge;
    $pat=~s/([^\040-\176])/sprintf "\\x{%x}", ord($1)/ge;
    }
    $self->{fh}->print('qr',substr($quotes,0,1),$pat,substr($quotes,-1),$mod);
    return
}

=for uedit32
sub _default_key_sorters{}

=cut

my %default_key_sorters= (
    numeric => sub  { [ sort {$a <=> $b} keys %{$_[0]} ] },
    lexical => sub { [ sort keys %{$_[0]} ] },
    smart => sub  {
        [
            map { $_->[-1] }
            sort {
                ( $a->[2] <=> $b->[2] )
                ||
                (  defined($a->[0])
                    ? $a->[0] <=> $b->[0] || ($a->[1] cmp $b->[1])
                    : $a->[1] cmp $b->[1] )
                ||
                ( $a->[-1] cmp $b->[-1] )
            }
            map {
                    my $chars=lc($_);
                    my $num;
                    $num=$1 if $chars=~
                        s/\A(-?(?:0|[1-9]\d{0,8})(?:\.\d{0,15})?)(?!\d)//;
                    $chars=~s/\W//g;
                    [ $num, $chars, !defined $num ? 2 :
                        # length($chars) ? 1 :
                        0, $_ ]
            }  keys %{$_[0]}
        ]
    },
    'each'=>sub { undef },
);
$default_key_sorters{alphabetical}=$default_key_sorters{lexical};
$default_key_sorters{intelligent}=$default_key_sorters{smart};
for my $h (\%default_key_sorters) {
    my $abr=Text::Abbrev::abbrev(keys %$h);
    foreach my $short (keys %$abr) {
        $h->{$short}=$h->{$abr->{$short}};
    }
}


sub _get_keys {
    my ($self,$item,$pass,$addr,$class)=@_;

    my $sorter;
    $class= "" if ! defined $class;

    $sorter=   $self->{style}{sortkeys}{"#$addr"}
            || $self->{cache_sorter}{$class};
    if ( ! $sorter ) {
        $sorter= $self->{style}{sortkeys}{".$class"}
                || ($class && $class->can("DDS_sortkeys") )
                || $self->{style}{sortkeys}{"."};
        ;
        $self->{cache_sorter}{$class}=
            ($sorter ||= $default_key_sorters{smart});
    }
    my ($ary,$thaw)=$sorter->( $item, $pass, $addr, $class );
    die "$item:$pass:$addr:$class:$ary:$thaw"
         if $ary and reftype($ary) ne "ARRAY";
    return ($ary,$thaw);
}


sub _dump_hash {
    my ($self,$item,$depth,$dumped,$name,$indent,$addr,$class)=@_;

    #Carp::confess "$name" unless defined $self->{ref_hkcnt}{$addr};

    my ($keyary)= $self->_get_keys($item,1,$addr,$class);
    if ($keyary and $DEBUG) {
        warn "Keys: $keyary : @$keyary"
    }

    my $full_indent=$self->{style}{indent}>1;
    my $ind=($self->{style}{indent}) &&
            (!defined($self->{ref_hkcnt}{$addr}) or $self->{ref_hkcnt}{$addr}>1);

    $self->_brace($name,'{',$ind,$indent,$self->{ref_hkcnt}{$addr}) ;

    my $indkey=($ind && $self->{style}{indentkeys}) ? $self->{ref_hklen}{$addr} : 0;

    my $cindent= $indent;
    my $style= $self->{style};
    my $optspace= $style->{optspace};
    my $sep= $optspace . $self->{style}{hashsep} . $optspace;
    my $pairsep= $self->{style}{pairsep};
    if ($indkey) {
        $cindent+= $indkey + length($sep);
    }
    $DEBUG==10 and print "Indent $ind $indkey $cindent\n";
    my ($kc,$ix)=(0,0);
    my $last_n=0;
    my $ind_str=" " x $indent;

    while (defined(my $k=defined $keyary ? $keyary->[$ix++] : each %$item)) {
       $last_n=0 if ref $item->{$k};
        if ( $kc ) {
            my $do_ind=$ind && !$last_n ;
            $self->{fh}->print($pairsep, $do_ind ? "\n$ind_str" : $optspace);
            $self->{buf}++;
            if ($do_ind) {
                $self->{buf}=0;
            } elsif (!$do_ind && !$optspace && $self->{buf} > 1024 ) {
                $self->{fh}->print("\n");
                $self->{buf}=0;
            }
        } else {
            #$self->{fh}->print("\n$ind_str") if !$last_n;
            $kc=1;
        }
        if ($indkey) {
            my $qk=_quotekey($k);
            my $str=$indkey>=length($qk)
                ? join "",$qk," " x ($indkey-length($qk)), $sep
                : join "",$qk,"\n$ind_str"," " x $indkey, $sep
            ;

            $self->{buf}+=length($str);
            $self->{fh}->print($str);
        } else {
            my $str=_quotekey($k).$sep;
            $self->{buf}+=length($str);
            $self->{fh}->print($str);
        }
        my $alias=$self->_dump_sv($item->{$k},$depth+1,$dumped,
                            $self->_build_name($name,'{',$k),
                            $cindent
        );
        if (!$full_indent and !$self->{do_nl} and $self->{buf}<60) {
            #warn "$self->{buf}\n";
            $last_n++;
        } else {
            #warn "$self->{buf}\n";
            $last_n=0;
        }
        if ($alias) {
            $self->_add_fix('sub call','alias_hv',
                            $self->_build_name($name,'%'),
                            _quote($k),
                            $alias
            );
        }
    }
    $self->_brace($name,'}',$ind,$indent,$self->{ref_hkcnt}{$addr});
    return
}

sub _dump_array {
    my ($self,$item,$depth,$dumped,$name,$indent)=@_;
    my $full_indent=$self->{style}{indent}>1;
    my $ind=$self->{style}{indent} && @$item>1;

    $self->_brace($name,'[',$ind,$indent,scalar @$item);
    my $last_n=0;
    my $ind_str=(" " x $indent);
    my ($optspace,$sep)=@{$self->{style}}{qw(optspace arysep)};
    unless ($self->{style}{rle} ) {
        foreach my $k (0..$#$item) {
            my $do_ind=$ind && (!$last_n || ref $item->[$k]);
            if ($k) {
                $self->{fh}->print($sep, $do_ind ? "\n$ind_str" : $optspace);
                if ($do_ind) {
                    $self->{buf}=0;
                } elsif (!$do_ind && !$optspace && $self->{buf} > 1024 ) {
                    $self->{fh}->print("\n");
                    $self->{buf}=0;
                }
            }


            my $alias=$self->_dump_sv($item->[$k],$depth+1,$dumped,
                                $self->_build_name($name,'[',$k),
                                $indent
            );

            if (!$full_indent and !$self->{do_nl} and $self->{buf}<60) {
                #warn "$last_n\n";
                $last_n++;
            } else {
                $last_n=0;
            }
            if ($alias) {
                $self->_add_fix('sub call','alias_av',
                                $self->_build_name($name,'@'),
                                $k,
                                $alias
                );
            }
        }
    } else {
        # this is evil and must be changed.
        # ... evil ... totally evil... blech
        for ( my $k = 0 ; $k <= $#$item ; ) {
            my $v     = $item->[$k];
            my $count = 1;
            if (!refaddr($item->[$k]) and !readonly($item->[$k])
                and (!$self->{sv}{refaddr(\$item->[$k])} or
                $self->{svt}[$self->{sv}{refaddr(\$item->[$k])}]==1)
            )
            {
                COUNT:while (
                        $k + $count <= $#$item

                    and !refaddr($item->[ $k + $count ])

                    and !readonly($item->[ $k + $count ])

                    and (!$self->{sv}{refaddr(\$item->[$k + $count])} or
                         $self->{svt}[$self->{sv}{refaddr(\$item->[$k + $count])}]==1)

                    and !$v == !$item->[ $k + $count ]

                    and defined($v) == defined($item->[ $k + $count ])
                )

                {
                    if (!defined( $item->[ $k + $count ] )) {
                        last COUNT if defined($v);
                    } else {
                        last COUNT if
                            $v ne overload::StrVal( $item->[ $k + $count ] )
                    }
                    $count++;
                }
            }

            my $do_ind=$ind && (!$last_n || ref $item->[$k]);
            $self->{fh}->print($sep, $do_ind ? "\n$ind_str" : $optspace)
                if $k;
            $self->{buf}=0 if $do_ind and $k;
            if ($count>1){
                $self->{fh}->print("($optspace");
                $self->{buf}+=2;
            }
            my $alias=$self->_dump_sv($item->[$k],$depth+1,$dumped,
                                $self->_build_name($name,'[',$k),
                                $indent
            );
            if (!$full_indent and !$self->{do_nl} and $self->{buf}<60) {
                $last_n++;
            } else {
                $last_n=0;
            }
            if ($alias) {
                $self->_add_fix('sub call','alias_av',
                                $self->_build_name($name,'@'),
                                $k,
                                $alias
                );
            }
            if ($count>1) {
                my $str=join $optspace,'',')','x',$count;
                $self->{buf}+=length($str);
                $self->{fh}->print($str);
            }
            $k += $count;

        }
    }
    $self->_brace($name,']',$ind,$indent,scalar @$item);
    return
}

sub __vstr {
    my ($v,@v);
    unless (@_) {
        $v=$];
    } elsif (@_==1) {
        $v=shift;
    } else {
        @v=@_;
    }
    return join ".", @v ? (@v,(0) x 3)[0..2]
                        : map { $v * 1000**$_ % 1000 } 0..2
}

sub _dump_code {
    my ($self,$item,$name,$indent,$class)=@_;
    unless ($self->{style}{deparse}) {
        $self->{fh}->print($self->{style}{codestub});
    } else { #deparseopts
        my $cv=B::svref_2object($item);

        if (ref($cv->ROOT)=~/NULL/) {
            my $gv=$cv->GV;
            $self->{fh}->print("\\&",$gv->STASH->NAME,"::",$gv->SAFENAME);
            return;
        }

        my $deparser=Data::Dump::Streamer::Deparser->new(@{$self->{style}{deparseopts}});

        my $used= _get_lexicals($item);
        my %targ;
        foreach my $targ (keys %$used) {
            next if $targ=~/\D/;
            my $addr=refaddr($used->{$targ});
            $targ{$targ}=$self->{lexicals}{a2n}{$addr}
                if $self->{lexicals}{a2n}{$addr};
        }

        # we added this method, its not a normal method. see bottom of file.
        $deparser->dds_usenames(\%targ);

        my $bless=undef;
        my $code;
        DEPARSE:{
            $bless=($class,bless($item,$bless))[0] if defined $bless;
            eval { $code=$deparser->coderef2text($item) };
            bless $item,$bless if defined $bless;
            if (!defined $bless and $@ and
                $@ =~ /^\QUsage: ->coderef2text(CODEREF)\E/)
            {
                $bless='CODE';
                redo DEPARSE;
            } elsif ($@) {
                warnings::warnif "Using CODE stub for $name as ".
                 "B::Deparse->coderef2text (v$B::Deparse::VERSION".
                 " on v@{[__vstr]}) failed. Message was:\n $@";
                $self->{fh}->print($self->{style}{codestub});
                return;
            }
        }

        #$self->{fh}->print("\n#",join " ",keys %$used,"\n");

        #$code=~s/^\s*(\([^)]+\)|)\s*/sub$1\n/;

        $code=~s/(\%\{)(\s*\{\}\s*)/$1;$2/g;

        $code="sub".($code=~/^\s*\(/ ? "" : " ").$code;
        if ($self->{style}{indent}) {
            $code=~s/\n/"\n"." " x $indent/meg;
        }
        #warn $name;
        if ($name=~s/^\&//) {
            $code=~s/sub(\s)?/sub $name$1/;
        }
        $self->{fh}->print("$code");
    }
    return
}

sub _dump_format {
    # from link from [ysth]: http://groups.google.com/groups?selm=laUs8gzkgOlT092yn%40efn.org
    # translate arg (or reference to it) into a B::* object
    my ($self,$item,$name,$indent)=@_;


    if ($self->{style}{deparse}) {
        my $Bobj = B::svref_2object($item);
        # if passed a glob or globref, get the format
        $Bobj = B::GV::FORM($Bobj) if ref $Bobj eq 'B::GV';
        if (ref $Bobj eq 'B::FM') {
            my $format;
            eval {
              my $deparser = Data::Dump::Streamer::Deparser->new();
              $format=$deparser->indent($deparser->deparse_format($Bobj));
            };
            if ($@) {
                warnings::warnif "B::Deparse (v$B::Deparse::VERSION on v@{[__vstr]}) failed FORMAT ref deparse.\n";
                $format="B::Deparse (v$B::Deparse::VERSION on v@{[__vstr]}) failed FORMAT ref deparse.\n.\n";
            }
            my $ind=$self->{style}{indent} ? ' ' x $indent : '';
            $format="format F =\n$format";
            $format=~s/^/${ind}# /gm;

            my $end='_EOF_FORMAT_';
            $end=~s/T(\d*)_/sprintf "T%02d_",($1||0)+1/e
                    while $format=~/$end/;

            $self->{fh}->print("do{ local *F; my \$F=<<'$end'; \$F=~s/^\\s+# //mg; eval \$F; die \$F.\$@ if \$@; *F{FORMAT};\n$format\n$end\n$ind}");
            return
        }
    }

    $self->{fh}->print($self->{style}{formatstub});


}

sub _dump_symbol {
    my ($self,$item,$name,$glob,$deref,$depth)=@_;

    my $ret="Symbol::gensym";
    $ret="do{ require Symbol; $ret }"
        unless $self->{reqs}{Symbol}++;
    $ret="*{ $ret }"
        if $deref;
    $self->{fh}->print( $ret );
    if ($self->{style}{dumpglob} and !$self->{sv_glob_du}{$glob}++) {
        $self->_add_fix('glob',$_[1],$glob,$depth+1,$name);
    }
}

sub _dump_rv {
    my ($self,$item,$depth,$dumped,$name,$indent,$add_do)=@_;

    my ($addr,$idx,$type,$class,$is_frozen_replacement,$overloaded,
        $raddr);
    GETITEM: {
        $addr=refaddr($item) or Carp::confess "$name : $item";
        $idx=$self->{ref}{$addr};
        $type=reftype($item);
        $class=blessed($item);
        $class=undef if $class and $class eq 'Regexp' and is_regexp $item;

        $DEBUG and
        printf "_dump_rv %d %s %#x\n",$depth,$name,$addr;

        my $ignore=0;
        if ($self->{ref_fz}{$addr}) {
            $item= $self->{ref_fz}{$addr};
            if ( ! $item ) {
                $ignore=1;
            } elsif (ref $item) {
                $is_frozen_replacement=1;
                $dumped= \do{my $d};
                $raddr=$addr;
                redo GETITEM;
            } else {
                $self->{buf}+=length($item);
                $self->{fh}->print($item);
                return
            }
        }
        if ($ignore or $self->{style}{ignore}{"#".($raddr||$addr)} or
            (defined $class and $self->{style}{ignore}{".$class"} )
        ){
            my $str= _quote("Ignored Obj [".overload::StrVal($item)."]");
            $self->{buf} += length($str);
            $self->{fh}->print($str);
            return
        }
    }


    unless ($idx) {
        #Carp::confess "Unhandled address $addr $name\n";
        # this should only happen for localized globs.
        ($idx)=$self->_reg_ref($item,$depth,$name,refcount($item));
    }
    my $optspace=$self->{style}{optspace};
    if ($idx) {
        my $pre_dumped=$self->{refdu}[$idx];
        my $str="";
        if ($pre_dumped and $$pre_dumped) {
            # its been dumped totally
            $DEBUG and print "  predumped $self->{refn}[$idx]\n";
            if ($self->{refn}[$idx]=~/^[\@\%\&]/) {
                if (SvREADONLY_ref($item)) {
                    my @hidden_keys=sort(hidden_keys(%$item));
                    $self->_add_fix('lock',$idx,\@hidden_keys);
                }
                $str=join "",($class ? "bless($optspace" : ''),
                                   '\\'.$self->{refn}[$idx],
                                   ($class ? ",$optspace"._quote($class)."$optspace)" : '');
            } else {
                $str=$self->{refn}[$idx];
            }
            $self->{buf}+=length($str);
            $self->{fh}->print($str);
            return
        } elsif ($pre_dumped or $self->{refd}[$idx] < $depth) {
            $DEBUG and print "  inprocess or depth violation: $self->{refd}[$idx] < $depth\n";
            # we are in the process of dumping it
            # output a place holder and add a fix statement
            # XXX is this sigil test correct? why not $?
            if ($self->{refn}[$idx]=~/^[\@\%\&]/ and (!$self->{style}{declare})) {
                $str=join"",( $class ? "bless($optspace" : '' ),
                               '\\'.$self->{refn}[$idx],
                               ( $class ? ",$optspace"._quote($class)."$optspace)" : '' );
            } else {
                if ($self->{style}{purity}) {
                    $str=join"",$add_do ? join($optspace,qw(do { my $v = ),'') : '',
                        !$self->{style}{verbose} ? "'V'" : _quote("V: ",$self->{refn}[$idx]),
                        $add_do ? $optspace."}" : '';

                    #Carp::cluck "$name $self->{refd}[$idx] < $depth" if $name=~/\*/;
                    $self->_add_fix('ref',$name,$idx,$class);
                } else {
                    $str=$self->{refn}[$idx];
                }
            }
            $self->{buf}+=length($str);
            $self->{fh}->print($str);
            return
        }
        $self->{refdu}[$idx]||=$dumped;
        #$name=$self->{refn}[$idx]; # override inherited names. ??? maybe not needed
    } else {
        Carp::confess "Unhandled object '$item'\n";
    }
    my $isoverloaded=0;
    if (defined $class and overload::Overloaded($item)) {
        disable_overloading( $item );
        $overloaded= $class;
        $isoverloaded= 1;
    }
    my $thaw= $self->{ref_thaw}{$raddr||$addr};
    my ($inline,$thawtype);
    if ( $thaw ) {
        if ($thaw =~ /[^\w:>()-]/) {
           $thawtype= "code";
        }  else{
            $inline= $thaw=~s/^->//;
            $thawtype= $thaw=~s/\(\)$// ? "sub" : "method";
        }
        if ($inline && $thawtype eq 'sub') {
            $self->{buf}+=length($thaw)+1;
            $self->{fh}->print($thaw."(${optspace}");
        }
    }
    $self->{do_nl}=1;
    my $add_lock=($type eq 'HASH') && SvREADONLY_ref($item);
    my $fix_lock=0;
    my @hidden_keys=$add_lock ? sort(hidden_keys(%$item)) : ();
    if ($add_lock) {
        #warn "$name\n";
        if ($name!~/^\$/) {
            $fix_lock=1;
            $add_lock=0;
        } else  {
            $self->{fh}->print("lock_ref_keys",
                           @hidden_keys ? '_plus' : '',
                           "(${optspace}"
                          );
        }
    }


    my $add_bless=defined($class) && ($name!~/^[\@\%\&]/);
    if ($add_bless && !$overloaded) {
        $self->{fh}->print(substr($self->{style}{bless},0,-1),$optspace);
    }

    $DEBUG and print "  $type : Start typecheck\n";
    if ($type eq 'SCALAR' or $type eq 'REF' or $type eq 'GLOB') {
        my ($pat,$mod)=$type eq 'SCALAR' ? regex($item) : ();
        my $glob=$type eq 'GLOB' ? globname $$item : '';
        if ($glob=~/^\*Symbol::GEN/) {
            $self->_dump_symbol($_[1],$name,$glob,0,$depth);
        } elsif (defined $pat) {
            # its a regex
            $self->_dump_qr($pat,$mod);
        } else {
            my $ret=$self->_dump_sv($$item,$depth+1,$dumped,
                                $self->_build_name($name,'$'),
                                $indent,'is_ref'
            );
            $self->{refdu}[$idx]=$ret if $ret;
        }
    } elsif ($type eq 'ARRAY') {
        $self->_dump_array($item,$depth,$dumped,$name,$indent);
    } elsif ($type eq 'HASH') {
        $self->_dump_hash($item,$depth,$dumped,$name,$indent,$addr,$class);
    } elsif ($type eq 'CODE') {
        $self->_dump_code($item,$name,$indent,$class);
    } elsif ($type eq 'FORMAT') {
        #$self->_dump_code($item,$name,$indent,$class); #muwhahahah
        $self->_dump_format($item,$name,$indent);
    } elsif ($type eq 'IO') {
        $self->{fh}->print("*{Symbol::gensym()}{IO}");
    } elsif ($type eq 'ORANGE' || $type eq 'Regexp' || $type eq 'REGEXP') {
        my ($pat,$mod)=regex($item);
        $self->_dump_qr($pat,$mod);
    } else {
         Carp::confess "_dump_rv() can't handle '$type' objects yet\n :-(\n";
    }
    if ($add_bless) {
        unless ( defined $overloaded ) {
            $self->{fh}->print(",${optspace}",_quote($class),$optspace,substr($self->{style}{bless},-1))
        } else {
            $self->_add_fix('bless',$idx,$overloaded);
        }
        if ($isoverloaded) {
            restore_overloading( $item, $overloaded );
        }
    }
    if ($fix_lock && !defined($class)) {
        $self->_add_fix('lock',$idx,\@hidden_keys);
    }
    if ($add_lock) {
        if (@hidden_keys) {
            $self->{fh}->print(",${optspace}",join(",${optspace}",map {_quote($_)} @hidden_keys));
        }
        $self->{fh}->print("${optspace})");
    }
    if ( $thaw ) {
        if ($inline) {
            if ($thawtype eq 'sub') {
                $self->{fh}->print("${optspace})");
            } elsif ($thawtype eq 'method') {
                $self->{fh}->print("->$thaw()");
            }
            #$$dumped=1;
        } else {
            $self->_add_fix('thaw', $idx, $thaw.($thawtype eq 'sub' ? "()" :"" ));
        }
    }
    if ( my $postop=$self->{ref_postop}{$raddr||$addr} ) {
        if (ref $postop) {
            $postop->($_[1]);
        } else {
            $_[1]->$postop();
        }
    }
    $self->{do_nl}=1;

    return
}

=item Names

=item Names LIST

=item Names ARRAYREF

Takes a list of strings or a reference to an array of strings to use for
var names for the objects dumped. The names may be prefixed by a *
indicating the variable is to be dumped as its dereferenced type if it is
an array, hash or code ref. Otherwise the star is ignored. Other sigils
may be prefixed but they will be silently converted to *'s.

If no names are provided then names are generated automatically based on
the type of object being dumped, with abbreviations applied to compound
class names.

If called with arguments then returns the object itself, otherwise in list
context returns the list of names in use, or in scalar context a reference
or undef. In void context with no arguments the names are cleared.

B
Must be called before C is called.

=cut

sub Names {
    my $self = shift->_safe_self;
    if (@_) {
        my $v=(@_==1 and reftype $_[0] eq 'ARRAY') ? shift @_ : \@_;
        $self->{unames} = [
            map {
                ( my $s = $_ ) =~ s/^[\@\%\&-]/*/;
                $s=~s/^\$//;
                Carp::confess "Bad name '$_'"
                   if $s && $s!~/^\*?\w+$/;
                $s
            } grep {defined} @$v ];
        return $self;
    } elsif (! defined wantarray ) {
        $self->{unames}=[];
    }
    #elsif ( eval { require PadWalker; 1 } ) {
    #    print DDumper(PadWalker::peek_my(1));
    #    return $self;
    #}

    return wantarray ? @{$self->{unames}||[]} : $self->{unames}
}

=for UEDIT
sub Purity {}

=item Purity

=item Purity BOOL

This option can be used to set the level of purity in the output. It
defaults to TRUE, which results in the module doing its best to ensure
that the resulting dump when eval()ed is precisely the same as the input.
However, at times such as debugging this can be tedious, resulting in
extremely long dumps with many "fix" statements involved.  By setting
Purity to FALSE the resulting output won't necessarily be legal Perl, but
it will be more legible. In this mode the output is broadly similar to
that of the default setting of Data::Dumper (Purity(0)). When set to TRUE
the behaviour is likewise similar to Data::Dumper in Purity(1) but more
accurate.

When Purity() is set to FALSE aliases will be output with a function call
wrapper of 'alias_to' whose argument will be the value the item is an
alias to. This wrapper does nothing, and is only there as a visual cue.
Likewise, 'make_ro' will be output when the value was readonly, and again
the effect is cosmetic only.

=item To

=item To STREAMER

Specifies the object to print to. Data::Dump::Streamer can stream its
output to any object supporting the print method. This is primarily meant
for streaming to a filehandle, however any object that supports the method
will do.

If a filehandle is specified then it is used until it is explicitly
changed, or the object is destroyed.

=cut

sub To {
    my $self = shift->_safe_self;
    if (@_) {
        $self->{fh} = shift;
        return $self;
    }
    return $self->{fh};
}

=for UEDIT
sub Declare     {}

=item Declare

=item Declare BOOL

If Declare is True then each object is dumped with 'my' declarations
included, and all rules that follow are obeyed. (Ie, not referencing an
undeclared variable). If Declare is False then all objects are expected to
be previously defined and references to top level objects can be made at
any time.

Defaults to False.

=cut

sub Indent {
    my $self=shift->_safe_self();
    if (@_) {
        my $val=shift;

        if ( $val == 0 && length $self->{style}{optspace} ) {
            $self->{style}{last_optspace}= $self->{style}{optspace};
            $self->{style}{optspace}= "";
        } elsif( !$self->{style}{indent} && ! length $self->{style}{optspace} )
        {
            $self->{style}{optspace}= $self->{style}{last_optspace};
        }
        $self->{style}{indent}= $val;
        return $self
    } else {
        return $self->{style}{indent}
    }
}

=item Indent

=item Indent INT

If Indent is True then data is output in an indented and fairly neat
fashion. If the value is 2 then hash key/value pairs and array values each
on their own line. If the value is 1 then a "smart" indenting mode is
activated where multiple key/value or values may be printed to the same
line. The heuristics for this mode are still experimental so it may
occasional not indent very nicely.

Default is Indent(2)

If indent is False then no indentation is done, and all optional whitespace.
is omitted. See  for more details.

Defaults to True.

Newlines are appended to each statement regardless of this value.

=for UEDIT
sub IndentKeys      {}

=item Indentkeys

=item Indentkeys BOOL

If Indent() and Indentkeys are True then hashes with more than one key
value pair are dumped such that the keys and values line up. Note however
this means each key has to be quoted twice. Not advised for very large
data structures. Additional logic may enhance this feature soon.

Defaults to True.

B
Must be set before C is called.

=for UEDIT
sub OptSpace      {}

=item OptSpace

=item OptSpace STR

Normally DDS emits a lot of whitespace in between tokens that it
emits. Using this method you can control how much whitespace it
will emit, or even if some other string should be used.

If Indent is set to 0 then this value is automatically set to
the empty string. When Indent is set back to a non zero value
the old value will be restored if it has not been changed from
the empty string in the intervening time.

=for UEDIT
sub Keyorder      {}

=item KeyOrder TYPE_OR_OBJ

=item KeyOrder TYPE_OR_OBJ, VALUE

Sets or returns the key order to for use for a given type or object.

TYPE_OR_OBJ may be a string representing a class, or "" for representing
unblessed objects, or it maybe a reference to a hash.

VALUE may be a string representing one of built in sort mechanisms, or
it may be a reference to a subroutine, or a method name if TYPE_OR_OBJ
is not an object.

The built in sort mechanisms are 'aphabetical'/'lexical', 'numeric',
'smart'/'intelligent' and 'each'.

If VALUE is omitted returns the current value for the given type.

If TYPE_OR_OBJ is omitted or FALSE it defaults to "" which represents
unblessed hashes.

See L<"Controlling Hash Traversal and Display Order"> for more details.

=item SortKeys

=item SortKeys VALUE

This is a wrapper for KeyOrder. It allows only the generic hash
sort order to be specified a little more elegantly than via KeyOrder().
It is syntactically equivalent to

  $self->KeyOrder( "", @_ );

=for UEDIT
sub Verbose      {}

=item Verbose

=item Verbose BOOL

If Verbose is True then when references that cannot be resolved in a
single statement are encountered the reference is substituted for a
descriptive tag saying what type of forward reference it is, and to what
is being referenced. The type is provided through a prefix, "R:" for
reference, and "A:" for alias, "V:" for a value and then the name of the
var in a string. Automatically generated var names are also reduced to
the shortest possible unique abbreviation, with some tricks thrown in
for Long::Class::Names::Like::This (which would abbreviate most likely
to LCNLT1)

If Verbose if False then a simple placeholder saying 'A' or 'R' is
provided. (In most situations perl requires a placeholder, and as such
one is always provided, even if technically it could be omitted.)

This setting does not change the followup statements that fix up the
structure, and does not result in a loss of accuracy, it just makes it a
little harder to read. OTOH, it means dumps can be quite a bit smaller
and less noisy.

Defaults to True.

B
Must be set before C is called.

=for UEDIT
sub DumpGlob {}

=item DumpGlob

=item DumpGlob BOOL

If True then globs will be followed and fully defined, otherwise the globs
will still be referenced but their current value will not be set.

Defaults to True

B
Must be set before C is called.

=for UEDIT
sub Deparse {}

=item Deparse

=item Deparse BOOL

If True then CODE refs will be deparsed use L and
included in the dump. If it is False the a stub subroutine reference will
be output as per the setting of C.

Caveat Emptor, dumping subroutine references is hardly a secure act, and
it is provided here only for convenience.

Note using this routine is at your own risk as of DDS 1.11, how it
interacts with the newer advanced closure dumping process is undefined.

=for UEDIT
sub EclipseName {}

=item EclipseName

=item EclipseName SPRINTF_FORMAT

When necessary DDS will rename vars output during deparsing with this
value. It is a sprintf format string that should contain only and both of
the "%s" and a "%d" formats in any order along with whatever other literal
text you want in the name. No checks are performed on the validity of this
value so be careful. It defaults to

  "%s_eclipse_%d"

where the "%s" represents the name of the var being eclipsed, and the "%d"
a counter to ensure all such mappings are unique.

=for UEDIT
sub DeparseOpts {}

=item DeparseOpts

=item DeparseOpts LIST

=item DeparseOpts ARRAY

If Deparse is True then these options will be passed to B::Deparse->new()
when dumping a CODE ref. If passed a list of scalars the list is used as
the arguments. If passed an array reference then this array is assumed to
contain a list of arguments. If no arguments are provided returns a an
array ref of arguments in scalar context, and a list of arguments in list
context.

Note using this routine is at your own risk as of DDS 1.11, how it
interacts with the newer advanced closure dumping process is undefined.

=for UEDIT
sub CodeStub {}

=item CodeStub

=item CodeStub STRING

If Deparse is False then this string will be used in place of CODE
references. Its the users responsibility to make sure its compilable and
blessable.

Defaults to 'sub { Carp::confess "Dumped code stub!" }'

=for UEDIT
sub FormatStub {}

=item FormatStub

=item FormatStub STRING

If Deparse is False then this string will be used in place of FORMAT
references. Its the users responsibility to make sure its compilable and
blessable.

Defaults to 'do{ local *F; eval "format F =\nFormat Stub\n.\n"; *F{FORMAT} }'

=for UEDIT
sub DeparseGlob {}

=item DeparseGlob

=item DeparseGlob BOOL

If Deparse is TRUE then this style attribute will determine if subroutines
and FORMAT's contained in globs that are dumped will be deparsed or not.

Defaults to True.

=for UEDIT
sub DualVars {}
sub Dualvars {}

=item Dualvars

=item Dualvars BOOL

=item Dualvars

=item Dualvars BOOL

If TRUE then dualvar checking will occur and the required statements
emitted to recreate dualvars when they are encountered, otherwise items
will be dumped in their stringified form always. It defaults to TRUE.

=for UEDIT
sub Rle {}
sub RLE {}

=item Rle

=item Rle BOOL

=item RLE

=item RLE BOOL

If True then arrays will be run length encoded using the C operator.
What this means is that if an array contains repeated elements then
instead of outputting each and every one a list multiplier will be output.
This means that considerably less space is taken to dump redundant data.

=item Freezer

=item Freezer ACTION

=item Freezer CLASS, ACTION

This method can be used to override the DDS_freeze hook for a
specific class. If CLASS is omitted then the ACTION applies to
all blessed object.

If ACTION is false it indicates that the given CLASS should not
have any serilization hooks called.

If ACTION is a string then it is taken to be the method name that
will be executed to freeze the object. CLASS->can(METHOD) must return
true or the setting will be ignored.

If ACTION is a code ref it is executed with the object as the argument.

When called with no arguments returns in scalar context the generic
serialization method (defaults to 'DDS_freeze'), in list context
returns the generic serialization method followed by a list of pairs
of Classname=>ACTION.

If the action executes a sub or method it is expected to return
a list of three values:

   ( $proxy, $thaw, $postdump )=$obj->DDS_Freeze();

See L for more details.

B
Must be set before C is called.

=cut

sub Freezer {
    my $self= shift;
    if ( @_==1 ) {
        $self->{style}{freezer}= shift;
        return $self;
    } elsif ( @_==2 ) {
        my ( $class, $action )= @_;
        $self->{style}{freeze_class}{$class}= $action;
        return $self;
    }
    return wantarray ? ($self->{style}{freezer},
                        map { $_ => $self->{style}{freeze_class}{$_} }
                        keys %{$self->{style}{freeze_class}} )
                     : $self->{style}{freezer};
}

sub ResetFreezer {
    my $self=shift;
    $self->{style}{freezer}='DDS_freeze';
    $self->{style}{freeze_class}={};
    return $self;
}

=item Ignore

=item Ignore OBJ_OR_CLASS

=item Ignore OBJ_OR_CLASS, BOOL

Allows a given object or class to be ignored, and replaced with
a string containing the name of the item ignored.

If called with no args returns a list of items ignored (using the refaddr
to represent objects). If called with a single argument returns whether
that argument is ignored. If called with more than one arguments then
expects a list of pairs of object => is_ignored.

Returns $self when setting.

B
Must be set before C is called.

=cut

sub Ignore {
    my $self=shift;
     if (@_==0) {
        return map { s/^.//; $_ } keys %{$self->{style}{ignore}};
    }
    Carp::confess("Must have an even number of arguments in Ignore()")
        if @_>1 && @_ %2;
    while (@_) {
        my $item=shift;
        if ( ref $item ) {
            $item="#".refaddr($item);
        } else {
            $item=".$item";
        }
        if ( ! @_ ) {
            return $self->{style}{ignore}{$item};
        }
        if ( shift ) {
            $self->{style}{ignore}{$item}= 1;
        } else {
            delete $self->{style}{ignore}{$item};
        }
    }
    return $self;
}

=for UEDIT
sub Compress {}

=item Compress

=item Compress SIZE

Controls compression of string values (not keys). If this value
is nonzero and a string to be dumped is longer than its value then
the L if defined is used to compress
the string.  Setting size to -1 will cause all strings to be
processed, setting size to 0 will cause no strings to be processed.

=for UEDIT
sub Compressor {}

=item Compressor

=item Compressor CODE

This attribute is used to control the compression of strings.
It is expected to be a reference to a subroutine with the following
interface:

  my $prelude_code=$compressor->(); # no arguments.
  my $code=$compressor->('string'); # string argument

The sub will be called with no arguments at the beginning of the
dump to allow any require statements or similar to be added. During
the dump the sub will be called with a single argument when
compression is required. The code returned in this case is expected
to be an EXPR that will evaluate back to the original string.

By default DDS will use L in conjunction with
L to do compression and encoding, and exposes the
'usqz' subroutine for handling the decoding and decompression.

The abbreviated name was chosen as when using the default compressor
every string will be represented by a string like

   usqz('....')

Meaning that eight characters are required without considering the
data itself. Likewise Base64 was chosen because it is a representation
that is high-bit safe, compact and easy to quote. Escaped strings are
much less efficient for storing binary data.

=cut

# weird styling here deliberate.
sub
DeparseOpts
{
    my $self=shift;
    if (@_) {
        if (ref $_[0]) {
            $self->{style}{deparseopts}=shift;
        } else {
            $self->{style}{deparseopts}=[@_];
        }
        return $self;
    } else {
        return wantarray ? @{$self->{style}{deparseopts}}
                         : $self->{style}{deparseopts};
    }
}

sub KeyOrder {
    my $self= shift;
    Carp::croak("KeyOrder() Must have an even number of arguments if doing a multiple set.")
        if @_>2 and @_ % 2;

    while (@_) {
        my $obj= shift;
        my $name;
        if (ref $obj) {
            $name= "#"  .refaddr($obj)
        } else {
            $name= "" if ! defined $obj;
            $name= ".$obj";
        }
        if ( ! @_ ) {
            return $self->{style}{sortkeys_string}{$name}||
                   $self->{style}{sortkeys}{$name};
        }
        my $val= shift;
        if ( ! defined $val ) {
            delete $self->{style}{sortkeys}{$name};
            delete $self->{style}{sortkeys_string}{$name};
        } else {
            if ( ! ref $val ) {
                my $subref= $default_key_sorters{$val};
                Carp::confess("Unblessed or per object Sortkeys() must be coderefs:'$val'\n")
                        if (!$subref or $name eq "." )
                        and reftype($subref) ne "CODE";
                $subref ||= $obj->can($val);
                die "Unknown sortkeys '$val', and "
                    .  (ref($obj)||$obj)." doesn't know how to do it.\n"
                    if !$subref;
                $self->{style}{sortkeys_string}{$name}=$val;
                $val= $subref;
            } elsif ( reftype($val) eq 'ARRAY' ) {
                my $aryref= $val;
                $val= sub{ return $aryref; };
            } elsif ( reftype($val) ne 'CODE' ) {
                Carp::confess("Can't use '$val' as KeyOrder() value");
            }
            $self->{style}{sortkeys}{$name}= $val;
        }
    }
    return $self;
}
*Keyorder=*KeyOrder;
sub SortKeys {
    my $self=shift;
    $self->KeyOrder("",@_);
}
*Sortkeys= *SortKeys;
*HashKeys = *Hashkeys = *KeyOrder;

my %scalar_meth=map{ $_ => lc($_)}
      qw(Declare Indent IndentCols IndentKeys
        Verbose DumpGlob Deparse DeparseGlob DeparseFormat CodeStub
        FormatStub Rle RLE Purity DualVars Dualvars EclipseName
        Compress Compressor OptSpace);

sub AUTOLOAD {
    (my $meth=$AUTOLOAD)=~s/^((?:\w+::)+)//;
    my $name;
    if (defined($name=$scalar_meth{$meth})) {
        $DEBUG and print "AUTLOADING scalar meth $meth ($name)\n";
        eval '
        sub '.$meth.' {
            my $self=shift->_safe_self();
            if (@_) {
                $self->{style}{'.$name.'}=shift;
                return $self
            } else {
                return $self->{style}{'.$name.'}
            }
        }
        ';
        $@ and die "$meth:$@\n";
        goto &$meth;
    } elsif ($meth=~/[^A-Z]/) {
        Carp::confess "Unhandled method/subroutine call $AUTOLOAD";
    }
}

sub _get_lexicals {
    my $cv=shift;

    if ($HasPadWalker) {
        my ($names,$targs)=PadWalker::closed_over($cv);
        if ($PadWalker::VERSION < 1) {
            $names->{$_}=$names->{$targs->{$_}} for keys %$targs;
        } else {
            %$names=(%$names,%$targs);
        }
        return $names;
    }

    my $svo=B::svref_2object($cv);
    my @pl_array = eval { $svo->PADLIST->ARRAY };
    my @name_obj = eval { $pl_array[0]->ARRAY };

    my %named;
    for my $i ( 0..$#name_obj ) {
        if ( ref($name_obj[$i])!~/SPECIAL/) {
            $named{$i} = $name_obj[$i]->PV;
        }
    }

    my %inited;
    my %used;
    B::Utils::walkoptree_filtered(
            $svo->ROOT,
            sub { B::Utils::opgrep { name => [ qw[ padsv padav padhv ] ] }, @_ },
            sub {
                my ( $op, @items )=@_;
                my $targ = $op->targ;
                my $name = $named{$targ}
                    or return;

                $inited{$name}++
                    if $op->private & 128;

                if ( !$inited{$name} ) {
                    $used{$name} = $pl_array[1]->ARRAYelt($targ)->object_2svref;
                    $used{$targ} = $used{$name};
                    $inited{$name}++;
                }
            }
    );
    return \%used;
}

package Data::Dump::Streamer::Deparser;
use B::Deparse;
our @ISA=qw(B::Deparse);
my %cache;

our $VERSION = '2.40';
$VERSION= eval $VERSION;
if ( $VERSION ne $Data::Dump::Streamer::VERSION ) {
    die "Incompatible Data::Dump::Streamer::Deparser v$VERSION vs Data::Dump::Streamer v$Data::Dump::Streamer::VERSION";
}

sub dds_usenames {
    my $self=shift;
    my $names=shift;
    $cache{Data::Dump::Streamer::refaddr $self}=$names;
}

sub padname {
    my $self = shift;
    my $targ = shift;
    if ( $cache{Data::Dump::Streamer::refaddr $self} and $cache{Data::Dump::Streamer::refaddr $self}{$targ} ) {
        return $cache{Data::Dump::Streamer::refaddr $self}{$targ}
    }
    return $self->padname_sv($targ)->PVX;
}

sub DESTROY {
    my $self=shift;
    delete $cache{Data::Dump::Streamer::refaddr $self};
}

unless (B::AV->can('ARRAYelt')) {
    eval <<'    EOF_EVAL';
        sub B::AV::ARRAYelt {
            my ($obj,$idx)=@_;
            my @array=$obj->ARRAY;
            return $array[$idx];
        }
    EOF_EVAL
}

1;
__END__