view release on metacpan or  search on metacpan

lib/Data/Printer/Common.pm  view on Meta::CPAN

        my $first_index_to_show = $array_middle - int($max / 2);
        my $last_index_to_show = $first_index_to_show + $max - 1;
        my ($message_begin, $message_end) = ($skip_message, $skip_message);
        $message_begin =~ s/__SKIPPED__/$first_index_to_show/gse;
        my $items_left = $#{$array_ref} - $last_index_to_show;
        $message_end =~ s/__SKIPPED__/$items_left/gs;
        return (
            \$message_begin,
            $first_index_to_show .. $last_index_to_show,
            \$message_end
        );
    }
    else { # $preserve eq 'none'
        my $n_elements = scalar(@$array_ref);
        $skip_message =~ s/__SKIPPED__/$n_elements/g;
        return (\$skip_message);
    }
}

# helpers below strongly inspired by the excellent Package::Stash:
sub _linear_ISA_for {
    my ($class, $ddp) = @_;
    _initialize_mro($ddp) unless $mro_initialized;
    my $isa;
    if ($mro_initialized > 0) {
        $isa = mro::get_linear_isa($class);
    }
    else {
        # minimal fallback in case Class::MRO isn't available
        # (should only matter for perl < 5.009_005):
        $isa = [ $class, _get_superclasses_for($class) ];
    }
    return [@$isa, ($ddp->class->universal ? 'UNIVERSAL' : ())];
}

sub _initialize_mro {
    my ($ddp) = @_;
    my $error = _tryme(sub {
        if ($] < 5.009_005) { require MRO::Compat }
        else { require mro }
        1;
    });
    if ($error && index($error, 'in @INC') != -1 && $mro_initialized == 0) {
        _warn(
            $ddp,
            ($] < 5.009_005 ? 'MRO::Compat' : 'mro') . ' not found in @INC.'
          . ' Objects may display inaccurate/incomplete ISA and method list'
        );
    }
    $mro_initialized = $error ? -1 : 1;
}

sub _get_namespace {
    my ($class_name) = @_;
    my $namespace;
    {
        no strict 'refs';
        $namespace = \%{ $class_name . '::' }
    }
    # before 5.10, stashes don't ever seem to drop to a refcount of zero,
    # so weakening them isn't helpful
    Scalar::Util::weaken($namespace) if $] >= 5.010;

    return $namespace;
}

sub _get_superclasses_for {
    my ($class_name) = @_;
    my $namespace = _get_namespace($class_name);
    my $res = _get_symbol($class_name, $namespace, 'ISA', 'ARRAY');
    return @{ $res || [] };
}

sub _get_symbol {
    my ($class_name, $namespace, $symbol_name, $symbol_kind) = @_;

    if (exists $namespace->{$symbol_name}) {
        my $entry_ref = \$namespace->{$symbol_name};
        if (ref($entry_ref) eq 'GLOB') {
            return *{$entry_ref}{$symbol_kind};
        }
        else {
            if ($symbol_kind eq 'CODE') {
                no strict 'refs';
                return \&{ $class_name . '::' . $symbol_name };
            }
        }
    }
    return;
}

1;