File Coverage

blib/lib/Data/Printer/Object.pm

Criterion	Covered	Total	%
statement	363	412	88.1
branch	114	172	66.2
condition	54	101	53.4
subroutine	62	64	96.8
pod	15	15	100.0
total	608	764	79.5

use strict;
use warnings;
use Data::Printer::Common;

package # hide from pause
    Data::Printer::Object::ClassOptions;
    sub parents            { $_[0]->{'parents'}            }
    sub linear_isa         { $_[0]->{'linear_isa'}         }
    sub universal          { $_[0]->{'universal'}          }
    sub expand             { $_[0]->{'expand'}             }
    sub stringify          { $_[0]->{'stringify'}          }
    sub show_reftype       { $_[0]->{'show_reftype'}       }
    sub show_overloads     { $_[0]->{'show_overloads'}     }
    sub show_methods       { $_[0]->{'show_methods'}       }
    sub sort_methods       { $_[0]->{'sort_methods'}       }
    sub show_wrapped       { $_[0]->{'show_wrapped'}       }
    sub inherited          { $_[0]->{'inherited'}          }
    sub format_inheritance { $_[0]->{'format_inheritance'} }
    sub parent_filters     { $_[0]->{'parent_filters'}     }
    sub internals          { $_[0]->{'internals'}          }
    sub new {
        my ($class, $params) = @_;
        my $self = {
            'linear_isa'     => Data::Printer::Common::_fetch_scalar_or_default($params, 'linear_isa', 'auto'),
            'show_reftype'   => Data::Printer::Common::_fetch_scalar_or_default($params, 'show_reftype', 0),
            'show_overloads' => Data::Printer::Common::_fetch_scalar_or_default($params, 'show_overloads', 1),
            'stringify'      => Data::Printer::Common::_fetch_scalar_or_default($params, 'stringify', 1),
            'expand'         => Data::Printer::Common::_fetch_scalar_or_default($params, 'expand', 1),
            'show_methods'   => Data::Printer::Common::_fetch_anyof(
                $params, 'show_methods', 'all', [qw(none all private public)]
            ),
            'inherited' => Data::Printer::Common::_fetch_anyof(
                $params, 'inherited', 'public', [qw(none all private public)]
            ),
            'format_inheritance' => Data::Printer::Common::_fetch_anyof(
                $params, 'format_inheritance', 'lines', [qw(string lines)]
            ),
            'parent_filters' => Data::Printer::Common::_fetch_scalar_or_default($params, 'parent_filters', 1),
            'universal'    => Data::Printer::Common::_fetch_scalar_or_default($params, 'universal', 0),
            'sort_methods' => Data::Printer::Common::_fetch_scalar_or_default($params, 'sort_methods', 1),
            'show_wrapped' => Data::Printer::Common::_fetch_scalar_or_default($params, 'show_wrapped', 1),
            'internals'    => Data::Printer::Common::_fetch_scalar_or_default($params, 'internals', 1),
            'parents'      => Data::Printer::Common::_fetch_scalar_or_default($params, 'parents', 1),
        };
        return bless $self, $class;
    }
1;

package Data::Printer::Object;
use Scalar::Util ();
use Data::Printer::Theme;
use Data::Printer::Filter::SCALAR; # also implements LVALUE
use Data::Printer::Filter::ARRAY;
use Data::Printer::Filter::HASH;
use Data::Printer::Filter::REF;
use Data::Printer::Filter::VSTRING;
use Data::Printer::Filter::GLOB;
use Data::Printer::Filter::FORMAT;
use Data::Printer::Filter::Regexp;
use Data::Printer::Filter::CODE;
use Data::Printer::Filter::GenericClass;

# create our basic accessors:
my @method_names =qw(
    name show_tainted show_unicode show_readonly show_lvalue show_refcount
    show_memsize memsize_unit print_escapes scalar_quotes escape_chars
    caller_info caller_message caller_message_newline caller_message_position
    string_max string_overflow string_preserve resolve_scalar_refs
    array_max array_overflow array_preserve hash_max hash_overflow
    hash_preserve unicode_charnames colored theme show_weak
    max_depth index separator end_separator class_method class hash_separator
    align_hash sort_keys quote_keys deparse return_value show_dualvar show_tied
    warnings arrows coderef_stub coderef_undefined
);
foreach my $method_name (@method_names) {
    no strict 'refs';
    *{__PACKAGE__ . "::$method_name"} = sub {
        $_[0]->{$method_name} = $_[1] if @_ > 1;
        return $_[0]->{$method_name};
    }
}
sub extra_config { $_[0]->{extra_config} }

sub current_depth { $_[0]->{_depth}   }
sub indent        { $_[0]->{_depth}++ }
sub outdent       { $_[0]->{_depth}-- }

sub newline {
    my ($self) = @_;
    return $self->{_linebreak}
         . (' ' x ($self->{_depth} * $self->{_current_indent}))
         . (' ' x $self->{_array_padding})
         ;
}

sub current_name {
    my ($self, $new_value) = @_;
    if (defined $new_value) {
        $self->{_current_name} = $new_value;
    }
    else {
        $self->{_current_name} = $self->name unless defined $self->{_current_name};
    }
    return $self->{_current_name};
}

sub _init {
    my $self = shift;
    my $props = { @_ == 1 ? %{$_[0]} : @_ };

    $self->{'_linebreak'} = "\n";
    $self->{'_depth'} = 0;
    $self->{'_position'} = 0; # depth is for indentation only!
    $self->{'_array_padding'} = 0;
    $self->{'_seen'} = {};
    $self->{_refcount_base} = 3;
    $self->{'warnings'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'warning', 1);
    $self->{'indent'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'indent', 4);
    $self->{'index'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'index', 1);
    $self->{'name'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'name', 'var');
    $self->{'arrows'} = Data::Printer::Common::_fetch_anyof(
        $props,
        'arrows',
        'none',
        [qw(none first all)]
    );

    $self->{'show_tainted'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'show_tainted', 1);
    $self->{'show_tied'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'show_tied', 1);
    $self->{'show_weak'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'show_weak', 1);
    $self->{'show_unicode'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'show_unicode', 0);
    $self->{'show_readonly'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'show_readonly', 1);
    $self->{'show_lvalue'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'show_lvalue', 1);
    $self->{'show_refcount'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'show_refcount', 0);
    $self->{'show_memsize'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'show_memsize', 0);
    $self->{'memsize_unit'} = Data::Printer::Common::_fetch_anyof(
                                $props,
                                'memsize_unit',
                                'auto',
                                [qw(auto b k m)]
                            );
    $self->{'print_escapes'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'print_escapes', 0);
    $self->{'scalar_quotes'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'scalar_quotes', q("));
    $self->{'escape_chars'} = Data::Printer::Common::_fetch_anyof(
                            $props,
                            'escape_chars',
                            'none',
                            [qw(none nonascii nonlatin1 all)]
                        );
    $self->{'caller_info'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'caller_info', 0);
    $self->{'caller_message'} = Data::Printer::Common::_fetch_scalar_or_default(
                            $props,
                            'caller_message',
                            'Printing in line __LINE__ of __FILENAME__:'
                        );
    $self->{'caller_message_newline'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'caller_message_newline', 1);
    $self->{'caller_message_position'} = Data::Printer::Common::_fetch_anyof($props, 'caller_message_position', 'before', [qw(before after)]);
    $self->{'resolve_scalar_refs'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'resolve_scalar_refs', 0);
    $self->{'string_max'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'string_max', 4096);
    $self->{'string_preserve'} = Data::Printer::Common::_fetch_anyof(
                             $props,
                             'string_preserve',
                             'begin',
                             [qw(begin end middle extremes none)]
                         );
    $self->{'string_overflow'} = Data::Printer::Common::_fetch_scalar_or_default(
                                $props,
                                'string_overflow',
                                '(...skipping __SKIPPED__ chars...)'
                            );
    $self->{'array_max'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'array_max', 100);
    $self->{'array_preserve'} = Data::Printer::Common::_fetch_anyof(
                             $props,
                             'array_preserve',
                             'begin',
                             [qw(begin end middle extremes none)]
                         );
    $self->{'array_overflow'} = Data::Printer::Common::_fetch_scalar_or_default(
                                $props,
                                'array_overflow',
                                '(...skipping __SKIPPED__ items...)'
                        );
    $self->{'hash_max'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'hash_max', 100);
    $self->{'hash_preserve'} = Data::Printer::Common::_fetch_anyof(
                             $props,
                             'hash_preserve',
                             'begin',
                             [qw(begin end middle extremes none)]
                       );
    $self->{'hash_overflow'} = Data::Printer::Common::_fetch_scalar_or_default(
                                $props,
                                'hash_overflow',
                                '(...skipping __SKIPPED__ keys...)'
                       );
    $self->{'unicode_charnames'} = Data::Printer::Common::_fetch_scalar_or_default(
                               $props,
                               'unicode_charnames',
                               0
                           );
    $self->{'colored'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'colored', 'auto');
    $self->{'max_depth'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'max_depth', 0);
    $self->{'separator'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'separator', ',');
    $self->{'end_separator'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'end_separator', 0);
    $self->{'class_method'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'class_method', '_data_printer');
    $self->{'class'} = Data::Printer::Object::ClassOptions->new($props->{'class'});
    $self->{'hash_separator'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'hash_separator', '   ');
    $self->{'align_hash'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'align_hash', 1);
    $self->{'sort_keys'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'sort_keys', 1);
    $self->{'quote_keys'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'quote_keys', 'auto');
    $self->{'deparse'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'deparse', 0);
    $self->{'coderef_stub'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'coderef_stub', 'sub { ... }');
    $self->{'coderef_undefined'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'coderef_undefined', '');
    $self->{'return_value'} = Data::Printer::Common::_fetch_anyof(
                             $props,
                             'return_value',
                             'pass',
                             [qw(pass dump void)]
                       );
    $self->{'show_dualvar'} = Data::Printer::Common::_fetch_anyof(
        $props,
        'show_dualvar',
        'lax',
        [qw(lax strict off)]
    );

    if (exists $props->{as}) {
        my $msg = Data::Printer::Common::_fetch_scalar_or_default($props, 'as', '');
        $self->{caller_info} = 1;
        $self->{caller_message} = $msg;
    }

    $self->multiline(
        Data::Printer::Common::_fetch_scalar_or_default($props, 'multiline', 1)
    );

    $self->fulldump(
        Data::Printer::Common::_fetch_scalar_or_default($props, 'fulldump', 0)
    );

    $self->output(defined $props->{output} ? $props->{output} : 'stderr');
    $self->_load_colors($props);
    $self->_load_filters($props);

    my %extra_config;
    my %core_options = map { $_ => 1 }
        (@method_names, qw(as multiline output colors filters));
    foreach my $key (keys %$props) {
        $extra_config{$key} = $props->{$key} unless exists $core_options{$key};
    }
    $self->{extra_config} = \%extra_config;

    return $self;
}

sub output {
    my ($self, $new_output) = @_;
    if (@_ > 1) {
        $self->_load_output_handle($new_output);
    }
    return $self->{output};
}

sub _load_output_handle {
    my ($self, $output) = @_;
    my %targets = ( stdout => *STDOUT, stderr => *STDERR );
    my $error;
    my $ref = ref $output;
    if (!$ref and exists $targets{ lc $output }) {
        $self->{output} = lc $output;
        $self->{output_handle} = $targets{ $self->{output} };
    }
    elsif ( ( $ref and $ref eq 'GLOB')
         or (!$ref and \$output =~ /GLOB\([^()]+\)$/)
    ) {
        $self->{output} = 'handle';
        $self->{output_handle} = $output;
    }
    elsif (!$ref or $ref eq 'SCALAR') {
        if (open my $fh, '>>', $output) {
            $self->{output} = 'file';
            $self->{output_handle} = $fh;
        }
        else {
            $error = "file '$output': $!";
        }
    }
    else {
        $error = 'unknown output data';
    }
    if ($error) {
        Data::Printer::Common::_warn($self, "error opening custom output handle: $error");
        $self->{output_handle} = $targets{'stderr'}
    }
    return;
}

sub new {
    my $class = shift;
    my $self = bless {}, $class;
    return $self->_init(@_);
}

sub multiline {
    my ($self, $value) = @_;
    if (defined $value) {
        $self->{multiline} = !!$value;
        if ($value) {
            $self->{_linebreak} = "\n";
            $self->{_current_indent} = $self->{indent};
            $self->index( $self->{_original_index} )
                if exists $self->{_original_index};
            $self->hash_separator( $self->{_original_separator} )
                if exists $self->{_original_separator};
            $self->array_overflow( $self->{_original_array_overflow} )
                if exists $self->{_original_array_overflow};
            $self->hash_overflow( $self->{_original_hash_overflow} )
                if exists $self->{_original_hash_overflow};
            $self->string_overflow( $self->{_original_string_overflow} )
                if exists $self->{_original_string_overflow};
        }
        else {
            $self->{_original_index} = $self->index;
            $self->index(0);
            $self->{_original_separator} = $self->hash_separator;
            $self->hash_separator(':');
            $self->{_original_array_overflow} = $self->array_overflow;
            $self->array_overflow('(...)');
            $self->{_original_hash_overflow} = $self->hash_overflow;
            $self->hash_overflow('(...)');
            $self->{_original_string_overflow} = $self->string_overflow;
            $self->string_overflow('(...)');
            $self->{_linebreak} = ' ';
            $self->{_current_indent} = 0;
        }
    }
    return $self->{multiline};
}

sub fulldump {
    my ($self, $value) = @_;
    if (defined $value) {
        $self->{fulldump} = !!$value;
        if ($value) {
            $self->{_original_string_max} = $self->string_max;
            $self->string_max(0);
            $self->{_original_array_max} = $self->array_max;
            $self->array_max(0);
            $self->{_original_hash_max} = $self->hash_max;
            $self->hash_max(0);
        }
        else {
            $self->string_max($self->{_original_string_max})
                if exists $self->{_original_string_max};
            $self->array_max($self->{_original_array_max})
                if exists $self->{_original_array_max};
            $self->hash_max($self->{_original_hash_max})
                if exists $self->{_original_hash_max};
        }
    }
}

sub _load_filters {
    my ($self, $props) = @_;

    # load our core filters (LVALUE is under the 'SCALAR' filter module)
    my @core_filters = qw(SCALAR ARRAY HASH REF VSTRING GLOB FORMAT Regexp CODE GenericClass);
    foreach my $class (@core_filters) {
        $self->_load_external_filter($class);
    }
    my @filters;
    # load any custom filters provided by the user
    if (exists $props->{filters}) {
        if (ref $props->{filters} eq 'HASH') {
            Data::Printer::Common::_warn(
                $self,
                'please update your code: filters => { ... } is now filters => [{ ... }]'
            );
            push @filters, $props->{filters};
        }
        elsif (ref $props->{filters} eq 'ARRAY') {
            @filters = @{ $props->{filters} };
        }
        else {
            Data::Printer::Common::_warn($self, 'filters must be an ARRAY reference');
        }
    }
    foreach my $filter (@filters) {
        my $filter_reftype = Scalar::Util::reftype($filter);
        if (!defined $filter_reftype) {
            $self->_load_external_filter($filter);
        }
        elsif ($filter_reftype eq 'HASH') {
            foreach my $k (keys %$filter) {
                if ($k eq '-external') {
                    Data::Printer::Common::_warn(
                        $self,
                        'please update your code: '
                      . 'filters => { -external => [qw(Foo Bar)}'
                      . ' is now filters => [qw(Foo Bar)]'
                    );
                    next;
                }
                if (Scalar::Util::reftype($filter->{$k}) eq 'CODE') {
                    my $type = Data::Printer::Common::_filter_category_for($k);
                    unshift @{ $self->{$type}{$k} }, $filter->{$k};
                }
                else {
                    Data::Printer::Common::_warn(
                        $self,
                        'hash filters must point to a CODE reference'
                    );
                }
            }
        }
        else {
            Data::Printer::Common::_warn($self, 'filters must be a name or { type => sub {...} }');
        }
    }
    return;
}

sub _load_external_filter {
    my ($self, $class) = @_;
    my $module = "Data::Printer::Filter::$class";
    my $error = Data::Printer::Common::_tryme("use $module; 1;");
    if ($error) {
        Data::Printer::Common::_warn($self, "error loading filter '$class': $error");
        return;
    }
    my $from_module = $module->_filter_list;
    foreach my $kind (keys %$from_module) {
        foreach my $name (keys %{$from_module->{$kind}}) {
            unshift @{ $self->{$kind}{$name} }, @{ $from_module->{$kind}{$name} };
        }
    }
    return;
}

sub _detect_color_level {
    my ($self) = @_;
    my $colored = $self->colored;
    my $color_level;

    # first we honour ANSI_COLORS_DISABLED, colored and writing to files
    if (   !$colored
        || ($colored eq 'auto'
            && (exists $ENV{ANSI_COLORS_DISABLED}
                || $self->output eq 'handle'
                || $self->output eq 'file'
            )
        )
    ) {
        $color_level = 0;
    }
    else {
        # NOTE: we could try `tput colors` but it may not give
        # the proper result, so instead we do what most terminals
        # currently do and rely on environment variables.
        if ($ENV{COLORTERM} && $ENV{COLORTERM} eq 'truecolor') {
            $color_level = 3;
        }
        elsif ($ENV{TERM_PROGRAM} && $ENV{TERM_PROGRAM} eq 'iTerm.app') {
            my $major_version = substr($ENV{TERM_PROGRAM_VERSION} || '0', 0, 1);
            $color_level = $major_version >= 3 ? 3 : 2;
        }
        elsif ($ENV{TERM_PROGRAM} && $ENV{TERM_PROGRAM} eq 'Apple_Terminal') {
            $color_level= 2;
        }
        elsif ($ENV{TERM} && $ENV{TERM} =~ /\-256(?:color)?\z/i) {
            $color_level = 2;
        }
        elsif ($ENV{TERM}
            && ($ENV{TERM} =~ /\A(?:screen|xterm|vt100|rxvt)/i
                || $ENV{TERM} =~ /color|ansi|cygwin|linux/i)
        ) {
            $color_level = 1;
        }
        elsif ($ENV{COLORTERM}) {
            $color_level = 1;
        }
        else {
            $color_level = $colored eq 'auto' ? 0 : 1;
        }
    }
    return $color_level;
}

sub _load_colors {
    my ($self, $props) = @_;

    $self->{_output_color_level} = $self->_detect_color_level;

    my $theme_object;
    my $default_theme = 'Material';
    my $theme_name    = Data::Printer::Common::_fetch_scalar_or_default($props, 'theme', $default_theme);
    $theme_object = Data::Printer::Theme->new(
        name            => $theme_name,
        color_overrides => $props->{colors},
        color_level     => $self->{_output_color_level},
        ddp             => $self,
    );
    if (!$theme_object) {
        if ($theme_name ne $default_theme) {
            $theme_object = Data::Printer::Theme->new(
                name            => $default_theme,
                color_overrides => $props->{colors},
                color_level     => $self->{_output_color_level},
                ddp             => $self,
            );
        }
        Data::Printer::Common::_die("Unable to load default theme. This should never happen - please contact the author") unless $theme_object;
    }
    $self->{theme} = $theme_object;
}

sub _filters_for_type {
    my ($self, $type) = @_;
    return exists $self->{type_filters}{$type} ? @{ $self->{type_filters}{$type} } : ();
}

sub _filters_for_class {
    my ($self, $type) = @_;
    return exists $self->{class_filters}{$type} ? @{ $self->{class_filters}{$type} } : ();
}

sub _filters_for_data {
    my ($self, $data) = @_;

    # we favour reftype() over ref() because you could have
    # a HASH.pm (or ARRAY.pm or whatever) blessing any variable.
    my $ref_kind = Scalar::Util::reftype($data);
    $ref_kind = 'SCALAR' unless $ref_kind;

    # ref() returns 'Regexp' but reftype() returns 'REGEXP', so we picked one:
    $ref_kind = 'Regexp' if $ref_kind eq 'REGEXP';

    my @potential_filters;

    # first, try class name + full inheritance for a specific name.
    my $class = Scalar::Util::blessed($data);

    # a regular regexp is blessed, but in that case we want a
    # regexp filter, not a class filter.
    if (defined $class && $class eq 'Regexp') {
        if ($ref_kind eq 'Regexp' || ($] < 5.011 && $ref_kind eq 'SCALAR')) {
            $ref_kind = 'Regexp';
            undef $class;
        }
    }
    if (defined $class) {
        if ($self->class->parent_filters) {
            my $linear_ISA = Data::Printer::Common::_linear_ISA_for($class, $self);
            foreach my $candidate_class (@$linear_ISA) {
                push @potential_filters, $self->_filters_for_class($candidate_class);
            }
        }
        else {
            push @potential_filters, $self->_filters_for_class($class);
        }
        # next, let any '-class' filters have a go:
        push @potential_filters, $self->_filters_for_class('-class');
    }

    # then, try regular data filters
    push @potential_filters, $self->_filters_for_type($ref_kind);

    # finally, if it's neither a class nor a known core type,
    # we must be in a future perl with some type we're unaware of:
    push @potential_filters, $self->_filters_for_class('-unknown');

    return @potential_filters;
}

# _see($data): marks data as seen if it was never seen it before.
# if we are showing refcounts, we return those. Initially we had
# this funcionallity separated, but refcounts increase as we find
# them again and because of that we were seeing weird refcounting.
# So now instead we store the refcount of the variable when we
# first see it.
# Finally, if we have already seen the data, we return its stringified
# position, like "var", "var{foo}[7]", etc. UNLESS $options{seen_override}
# is set. Why seen_override? Sometimes we want to print the same data
# twice, like the GenericClass filter, which prints the object's metadata
# via parse() and then the internal structure via parse_as(). But if we
# simply do that, we'd get the "seen" version (because we have already
# visited it!) The refcount is still calculated only once though :)
sub _see {
    my ($self, $data, %options) = @_;
    return {} unless ref $data;
    my $id = pack 'J', Scalar::Util::refaddr($data);
    if (!exists $self->{_seen}{$id}) {
        $self->{_seen}{$id} = {
            name     => $self->current_name,
            refcount => ($self->show_refcount ? $self->_refcount($data) : 0),
        };
        return { refcount => $self->{_seen}{$id}->{refcount} };
    }
    return { refcount => $self->{_seen}{$id}->{refcount} } if $options{seen_override};
    return $self->{_seen}{$id};
}

sub seen {
    my ($self, $data) = @_;
    my $id = pack 'J', Scalar::Util::refaddr($data);
    return exists $self->{_seen}{$id};
}

sub unsee {
    my ($self, $data) = @_;
    return unless ref $data && keys %{$self->{_seen}};

    my $id = pack 'J', Scalar::Util::refaddr($data);
    delete $self->{_seen}{$id};
    return;
}

sub _refcount {
    my ($self, $data) = @_;

    require B;
    my $count;
    my $rv = B::svref_2object(\$data)->RV;
    if (ref($data) eq 'REF' && ref($$data)) {
        $rv = B::svref_2object($data)->RV;
    }

    # some SV's are special (represented by B::SPECIAL)
    # and don't have a ->REFCNT (e.g. \undef)
    return 0 unless $rv->can( 'REFCNT' );

    # 3 is our magical number: so we return the actual reference count
    # minus the references we added as we were traversing:
    return $rv->REFCNT - $self->{_refcount_base};
}

sub parse_as {
    my ($self, $type, $data) = @_;
    return $self->parse($data, force_type => $type, seen_override => 1);
}

# parse() must always receive a reference, never a regular copy, because
# that's the only way we are able to figure whether the source data
# is a weak ref or not.
sub parse {
    my $self = shift;
    my $str_weak = $self->_check_weak( $_[0] );

    my ($data, %options) = @_;
    my $parsed_string = '';

    # if we've seen this structure before, we return its location
    # instead of going through it again. This avoids infinite loops
    # when parsing circular references:
    my $seen = $self->_see($data, %options);
    if (my $name = $seen->{name}) {
        $parsed_string .= $self->maybe_colorize(
            ((ref $data eq 'SCALAR' && $self->resolve_scalar_refs)
                ? $$data
                : $name
            ),
            'repeated'
        );
        # on repeated references, the only extra data we put
        # is whether this reference is weak or not.
        $parsed_string .= $str_weak;
        return $parsed_string;
    }
    $self->{_position}++;

    # Each filter type provides an array of potential parsers.
    # Once we find the right kind, we go through all of them,
    # from most precise match to most generic.
    # The first filter that returns a defined value "wins"
    # (even if it's an empty string)
    foreach my $filter (
        exists $options{force_type}
          ? $self->_filters_for_type($options{force_type})
          : $self->_filters_for_data($data)
    ) {
        if (defined (my $result = $filter->($data, $self))) {
            $parsed_string .= $result;
            last;
        }
    }

    # FIXME: because of prototypes, p(@data) becomes a ref (that we don't care about)
    # to the data (that we do care about). So we should not show refcounts, memsize
    # or readonly status for something guaranteed to be ephemeral.
    $parsed_string .= $self->_check_readonly($data);
    $parsed_string .= $str_weak if ref($data) ne 'REF';
    $parsed_string .= $self->_check_memsize($data);

    if ($self->show_refcount && ref($data) ne 'SCALAR' && $seen->{refcount} > 1 ) {
        $parsed_string .= ' (refcount: ' . $seen->{refcount} .')';
    }

    if (--$self->{'_position'} == 0) {
        $self->{'_seen'} = {};
        $self->{'_refcount_base'} = 3;
        $self->{'_position'} = 0;
    }

    return $parsed_string;
}

sub _check_memsize {
    my ($self, $data) = @_;
    return '' unless $self->show_memsize
                  && (   $self->show_memsize eq 'all'
                      || $self->show_memsize >= $self->{_position});
    my $size;
    my $unit;
    my $error = Data::Printer::Common::_tryme(sub {
        require Devel::Size;
        $size = Devel::Size::total_size($data);
        $unit = uc $self->memsize_unit;
        if ($unit eq 'M' || ($unit eq 'AUTO' && $size > 1024*1024)) {
            $size = $size / (1024*1024);
            $unit = 'M';
        }
        elsif ($unit eq 'K' || ($unit eq 'AUTO' && $size > 1024)) {
            $size = $size / 1024;
            $unit = 'K';
        }
        else {
            $unit = 'B';
        }
    });
    if ($error) {
        if ($error =~ m{locate Devel/Size.pm}) {
            Data::Printer::Common::_warn($self, "Devel::Size not found, show_memsize will be ignored")
                if $self->{_position} == 1;
        }
        else {
            Data::Printer::Common::_warn($self, "error fetching memory usage: $error");
        }
        return '';
    }
    return '' unless $size;
    my $string = ' (' . ($size < 0 ? sprintf("%.2f", $size) : int($size)) . $unit . ')';
    return $self->maybe_colorize($string, 'memsize');
}

sub _check_weak {
    my ($self) = shift;
    return '' unless $self->show_weak;

    my $realtype = Scalar::Util::reftype($_[0]);
    my $isweak;
    if ($realtype && ($realtype eq 'REF' || $realtype eq 'SCALAR')) {
        $isweak = Scalar::Util::isweak($_[0]);
    }
    else {
        $isweak = Scalar::Util::isweak($_[0]);
    }
    return '' unless $isweak;
    return ' ' . $self->maybe_colorize('(weak)', 'weak');
}

sub _write_label {
    my ($self) = @_;
    return '' unless $self->caller_info;
    my @caller = caller 1;

    my $message = $self->caller_message;

    $message =~ s/\b__PACKAGE__\b/$caller[0]/g;
    $message =~ s/\b__FILENAME__\b/$caller[1]/g;
    $message =~ s/\b__LINE__\b/$caller[2]/g;

    my $separator = $self->caller_message_newline ? "\n" : ' ';
    $message = $self->maybe_colorize($message, 'caller_info');
    $message = $self->caller_message_position eq 'before'
        ? $message . $separator
        : $separator . $message
        ;
    return $message;
}

sub maybe_colorize {
    my ($self, $output, $color_type, $default_color, $end_color) = @_;

    if ($self->{_output_color_level} && defined $color_type) {
        my $theme = $self->theme;
        my $sgr_color = $theme->sgr_color_for($color_type);
        if (!defined $sgr_color && defined $default_color) {
            $sgr_color = $theme->_parse_color($default_color);
        }
        if ($sgr_color) {
            $output = $sgr_color
                . $output
                . (defined $end_color
                    ? $theme->sgr_color_for($end_color)
                    : $theme->color_reset
                );
        }
    }
    return $output;
}

sub _check_readonly {
    my ($self) = @_;
    return ' (read-only)' if $self->show_readonly && &Internals::SvREADONLY($_[1]);
    return '';
}

42;
__END__