File Coverage

blib/lib/Heap/Simple/Perl.pm

Criterion	Covered	Total	%
statement	188	188	100.0
branch	74	86	86.0
condition	19	33	57.5
subroutine	72	72	100.0
pod	0	25	0.0
total	353	404	87.3

package Heap::Simple::Perl;
use strict;
use Carp;

use vars qw($VERSION $auto %used);
$VERSION = "0.12";
$auto = "Auto";
%used = ();

use AutoLoader qw(AUTOLOAD);

use constant DEBUG => 0;

sub _use {
    my $name = shift();
    $name =~ s|::|/|g;
    print STDERR "require Heap/Simple/$name.pm\n" if DEBUG;
    return require "Heap/Simple/$name.pm";
}

my %order = ("<"  => "Number",
             ">"  => "NumberReverse",
             "lt" => "String",
             "gt" => "StringReverse",
             );
sub _order {
    my ($heap, $order) = @_;
    # Default order if nothing specified
    $order = "<" unless defined($order) && $order ne "";
    my $name;
    if (ref($order) eq "CODE") {
        $heap->[0]{order} = $order;
        $name = "Less";
    } else {
        $name = $order{lc $order} || croak "Unknown order '$order'";
    }
    $used{$name} ||= _use($name);
    return $name;
}

sub _elements {
    my ($heap, $elements) = @_;
    $elements = ["Scalar"] unless defined($elements);
    $elements = [$elements] if ref($elements) eq "";
    croak "option elements is not an array reference" unless
        ref($elements) eq "ARRAY";
    croak "option elements has no type defined at index 0" unless
        defined($elements->[0]);
    my $name = ucfirst(lc($elements->[0]));
    $name = "Scalar" if $name eq "Key";
    $used{$name} ||= _use($name);
    # $name is passed for the case that Heap::Simple::$name uses inheritance
    return "Heap::Simple::$name"->_elements($heap, $name, $elements);
}

sub _max_count {
    my ($heap, $max_count) = @_;
    return unless defined $max_count;
    $max_count == int($max_count) ||
        croak "max_count should be an integer";
    croak "max_count should not be negative" if $max_count < 0;
    croak "max_count should not be zero" if $max_count == 0;
    return $max_count == 9**9**9 ? () : (Limit => $heap->[0]{max_count} = $max_count);
    # my $name = "Limit";
    # $used{$name} ||= _use($name);
    # return "Heap::Simple::$name"->_max_count($heap, $name, $max_count);
}

sub new {
    croak "Odd number of elements in options" if @_ % 2 == 0;
    my ($class, %options) = @_;
    # note: the array starts at elements 1 to make the subscripting
    # operations (much!) cleaner.
    # So elements 0 is used for associated data
    my $heap = bless [{}], $class;
    # We temporarily bless $heap into $class so you can play OO games with it
    my @max	 = $heap->_max_count(delete $options{max_count});
    my @die	 = delete $options{can_die} ? "Die" : ();
    $heap->[0]{can_die} = 1 if @die;
    my @order    = $heap->_order(delete $options{order});
    my @elements = $heap->_elements(delete $options{elements});
    my $gclass = join("::", $class, $auto, @max, @die, @order, @elements);
    # Pure perl version is never dirty
    $heap->[0]{dirty} = 1 if delete $options{dirty};
    no strict "refs";
    @{"${gclass}::ISA"} = ("Heap::Simple::$elements[0]",
                           "Heap::Simple::$order[0]",
                           $class) unless @{"${gclass}::ISA"};
    print STDERR "Generated class $gclass\n" if DEBUG;
    # Now rebless the result into its final generated class
    bless $heap, $gclass;
    $heap->[0]{infinity} = exists($options{infinity}) ?
        delete $options{infinity} : $heap->_INF;
    $heap->[0]{user_data} = delete $options{user_data} if
        exists $options{user_data};
    croak "Unknown option ", join(", ", map "'$_'", CORE::keys %options) if
        %options;
    return $heap;
}

sub _ELEMENTS_PREPARE {
    return "";
}

sub _ORDER_PREPARE {
    return "";
}

sub _PREPARE {
    my $heap = shift;
    return join("", $heap->_ORDER_PREPARE, $heap->_ELEMENTS_PREPARE);
}

sub _VALUE {
    return $_[1];
}

sub _WRAPPER {
    return $_[2];
}

sub _INF {
    return;
}

sub _CAN_DIE {
    return shift->[0]{can_die} ? shift : @_ > 1 ? $_[1] : "";
}

sub _CANT_DIE {
    return shift->[0]{can_die} ? "" : shift;
}

sub _MAX_COUNT {
    return shift->[0]{max_count} ? shift : @_ > 1 ? $_[1] : "";
}

sub _THE_MAX_COUNT {
    return shift->[0]{max_count} || croak "undefined max_count";
}

sub _REAL_KEY {
    return shift->_KEY(@_);
}

sub _REAL_ELEMENTS_PREPARE {
    return shift->_ELEMENTS_PREPARE(@_);
}

sub _REAL_PREPARE {
    my $heap = shift;
    return join("", $heap->_ORDER_PREPARE, $heap->_REAL_ELEMENTS_PREPARE);
}

# Returning "-" means it should not get used
# (should cause a syntax error on accidental use)
sub _QUICK_KEY {
    return "-";
}

sub _COMMA {
    return ",";
}

my %stringify =
    ("\"" => "\\\"",
     "\\" => "\\\\",
     "\$" => "\\\$",
     "\@" => "\\\@",
     "\n" => "\\n",
     "\r" => "\\r");

# currently loses utf8 when the resulting string gets used
sub _stringify {
    defined(my $str = shift) || croak "undefined access";
    $str =~ s/([\"\\\n\r\$\@])/$stringify{$1}/g;	# "
    return qq("$str");
}

my ($balanced, $sequence);
# String with balanced parenthesis (but not balanced {}. We use that)
$balanced = qr{[^()\[\],]*(?:(?:\((??{$sequence})\)|\[(??{$sequence})\])[^()\[\],]*)*};
$sequence = qr{$balanced(?:,$balanced)*};

sub _make {
    # Use $_self so there is less chance of the eval using $heap and surviving
    my $_self  = shift;
    die "Cannot determine caller class from '$_self'" unless ref($_self);
    my $subroutine = (caller(1))[3];
    $subroutine =~ s/.*:://s || die "Cannot parse caller '$subroutine'";
    my $package = ref($_self);

    my $string = "package $package;\n" . shift;
    # Very simple macro expander, but ignore literal strings
    my $f = "a";
    # 1 while $string =~ s{(\b_[A-Z_]+)\(($sequence)\)}{$f=$1; $_self->$f($2 =~ /($balanced),?/g)}eg;
    # Previous line ought to work but actually fails on perl 5.6.2 because
    # the return value from s///e cannot be trusted
    $f="",$string =~ s{(\b_[A-Z_]+)\(($sequence)\)}{$f=$1; $_self->$f($2 =~ /($balanced),?/g)}eg while $f;
    if ($string =~ /\bmy\s+\$(\w+)\s*=\s*shift;/g) {
        my $var = $1;
        $string =~ /\$$var\b/g || croak "$_self uses \$$var only once ($string)";
        unless ($string =~ /\$$var\b/g) {
            # Should also check for extra shifts really
            croak "Candidate uses $1:\n$string" if $string =~ /(\$_\[[^\]]\])/;
            # main::diag("Candidate: $string");
            $string =~ s/\bmy\s+\$$var\s*=\s*shift;(?:\s*\n)?(.*)\$$var\b/$1shift/s;
            # main::diag("Now: $string");
        }
    }
    # $string =~ s/(sub\s+\w+)\s*{.*\bCarp::croak\b\s*(\"[^\"]+\");.*}/$1 { Carp::croak $2 }/s; # "
    # Important that these are last one since they can expand to something
    # that contain the others
    $string =~ s{\b_(LITERAL|STRING)\b}{
        $1 eq "LITERAL" ?
            defined $_self->[0]{index} ? $_self->[0]{index} : croak("undefined access") :
            _stringify($_self->[0]{index})}eg;
    $string
        =~ s/^([^\S\n]*sub\s+(\w+)\s*\{)/#line 1 "${package}::$2"\n$1/mg;
    print STDERR "Code:\n$string\n" if DEBUG;
    my $err = $@;
    eval $string;
    die $@ if $@;
    $@ = $err;
}

sub count {
    return $#{+shift};
}

sub extract_all {
    my $heap = shift;
    return map $heap->extract_top, 2..@$heap;
}

sub clear {
    $#{+shift} = 0;
}

sub absorb {
    my $heap = shift;
    $_->_absorb($heap) for @_;
}

sub key_absorb{
    my $heap = shift;
    $_->_key_absorb($heap) for @_;
}

sub wrapped {
    return;
}

sub max_count {
    return shift->[0]{max_count} || 9**9**9;
}

sub dirty {
    return shift->[0]{dirty} || (wantarray() ? () : !1);
}

sub can_die {
    return shift->[0]{can_die} || (wantarray() ? () : !1);
}

sub key_index {
    croak "Heap elements are not of type 'Array'";
}

sub key_name {
    croak "Heap elements are not of type 'Hash'";
}

sub key_method {
    croak "Heap elements are not of type 'Method' or 'Object'";
}

sub key_function {
    croak "Heap elements are not of type 'Function' or 'Any'";
}

sub key_insert {
    croak "This heap type does not support key_insert";
}

sub _key_insert {
    croak "This heap type does not support _key_insert";
}

sub implementation() {
    return __PACKAGE__;
}

1;

__END__