File Coverage

blib/lib/Pugs/Runtime/Match.pm

Criterion	Covered	Total	%
statement	50	112	44.6
branch	3	22	13.6
condition	1	3	33.3
subroutine	19	33	57.5
pod	0	24	0.0
total	73	194	37.6

package Pugs::Runtime::Match;
# Documentation in the __END__

use 5.006;
use strict;
use warnings;
use Data::Dumper;
#use Class::InsideOut qw( public register id );
use Scalar::Util qw( refaddr blessed );
use Pugs::Runtime::StrPos;

use overload (
    '@{}'    => \&array,
    '%{}'    => \&hash,
    'bool'   => \&bool,
    '&{}'    => \&code,
    '${}'    => \&scalar,
    '""'     => \&flat,
    '0+'     => \&flat,
    fallback => 1,
);

# class method
# ::fail can be called from inside closures
# sub ::fail { $::_V6_SUCCEED = 0 }

my %_data;

sub new {
    my $obj = bless \$_[1], $_[0];
    $_data{ refaddr $obj } = $_[1];
    return $obj;
}

sub DESTROY {
    delete $_data{ refaddr $_[0] };
}

sub data  {    $_data{refaddr $_[0]}           }
sub bool  {  ${$_data{refaddr $_[0]}->{bool}}  }
sub array {    $_data{refaddr $_[0]}->{match}  }

sub from  {

    return ${$_data{refaddr $_[0]}->{from}};

    my $obj = $_data{refaddr $_[0]};
    #return ${$obj->{from}} if blessed ${$obj->{from}};
    Pugs::Runtime::StrPos->from_str_codes( ${$obj->{str}}, ${$obj->{from}} );
}
sub pos   { $_[0]->to } # pugs pos.t - lvalue ???
sub to    {

    return ${$_data{refaddr $_[0]}->{to}};

    my $obj = $_data{refaddr $_[0]};
    #return ${$obj->{to}} if blessed ${$obj->{to}};
    #print "TO: ",${$obj->{to}},"\n";
    Pugs::Runtime::StrPos->from_str_codes( ${$obj->{str}}, ${$obj->{to}} );
}
# "low-level" position defaults to perl5-utf8
sub from_as_codes  {  ${$_data{refaddr $_[0]}->{from}}  }
sub to_as_codes    {  ${$_data{refaddr $_[0]}->{to}}    }

sub hash  {
    my $array = $_data{refaddr $_[0]}->{match};
    my $hash  = $_data{refaddr $_[0]}->{named};
    $hash->{$_} = $array->[$_] for 0 .. $#$array;
    return $hash;

    #my $array = $_data{refaddr $_[0]}->{match};
    #return {
    #    %{ $_data{refaddr $_[0]}->{named} },
    #    (
    #    map { ( $_, $array->[$_] ) }
    #        0 .. $#$array
    #    ),
    #}
}
sub keys   {
    CORE::keys   %{$_data{refaddr $_[0]}->{named}},
    0 .. $#{ $_[0]->array }
}
sub values {
    CORE::values %{$_data{refaddr $_[0]}->{named}},
    @{ $_[0]->array }
}
sub kv {
    map { ( $_, $_[0]->{$_} ) }
        $_[0]->keys
}
sub elems  {
    scalar $_[0]->keys
}

sub chars  { CORE::length $_[0]->str }

sub flat {
    my $obj = $_data{refaddr $_[0]};
    my $cap = $obj->{capture};
    #print ref $cap;
    return $$cap
        if ref $cap eq 'REF'   ||
           ref $cap eq 'SCALAR';
    return '' unless ${$obj->{bool}};

    return '' if $_[0]->from > length( ${$obj->{str}} );

    return substr( ${$obj->{str}}, $_[0]->from, $_[0]->to - $_[0]->from );
}

sub str {
    "" . $_[0]->flat;
}

sub perl {
    local $Data::Dumper::Terse    = 1;
    local $Data::Dumper::Sortkeys = 1;
    local $Data::Dumper::Pad = '  ';
    return __PACKAGE__ . "->new( " . Dumper( $_[0]->data ) . ")\n";
}

sub yaml {
    require YAML::Syck;
    # interoperability with other YAML/Syck bindings:
    $YAML::Syck::ImplicitTyping = 1;
    YAML::Syck::Dump( $_[0] );
}

# for Pugs interoperability
sub dump_hs {
    my $obj;
    if (ref($_[0]) eq 'SCALAR') {
        $obj = ${$_[0]};
    }
    else {
        $obj = $_data{refaddr $_[0]};
    }

    if ($obj) {
        # Ok, this is a genuine Match object.
        return "PGE_Fail" unless ${$obj->{bool}};

        # Now we matched; dump the rest of data
        join(' ', 'PGE_Match', ${$obj->{from}}, ${$obj->{to}},
            ('['.join(', ', map { dump_hs($_) } @{$obj->{match}||[]} ).']'),
            ('['.join(', ', map {
                my $str = $_;
                if ( my $dump = dump_hs($obj->{named}{$_}) ) {
                    $str =~ s/([^ \!\#\$\%\&\x28-\x5B\x5D-\x7E])/'\\'.ord($1)/eg;
                    qq[("$str", $dump)];
                }
                else {
                    ();
                }
            } sort(CORE::keys(%{$obj->{named}||{}})) ).']'),
        )
    }
    elsif (ref($_[0]) eq 'ARRAY') {
        return "PGE_Array [" . join(', ', map { dump_hs($_) } @$obj) . "]"
    }
    elsif (!ref($_[0])) {
        my $str = shift;
        $str =~ s/([^ \!\#\$\%\&\x28-\x5B\x5D-\x7E])/'\\'.ord($1)/eg;
        return "PGE_String \"$str\"";
    }
    else {
        warn "Unrecognized blessed match object: $_[0]";
        return '';
    }
}

# tail() for backwards compatibility
# - doesn't work on failed matches
sub tail {
    return substr( ${$_data{refaddr $_[0]}->{str}}, $_[0]->to );
}

# state() is used for multiple matches and backtracking control
sub state {
    return $_data{refaddr $_[0]}->{state};
}

# return the capture
sub code {
    my $c = $_[0];
    return sub { $c->flat };
}

# return the capture
sub scalar {
    return \( $_[0]->flat );
}

1;

__END__