File Coverage

lib/Petal/Tiny.pm

Criterion	Covered	Total	%
statement	267	271	98.5
branch	131	150	87.3
condition	34	43	79.0
subroutine	22	22	100.0
pod	0	15	0.0
total	454	501	90.6

package Petal::Tiny;
$Petal::Tiny::VERSION = '1.14';
use warnings;
use strict;
use Carp;

# REX/Perl 1.0
# Robert D. Cameron "REX: XML Shallow Parsing with Regular Expressions",
# Technical Report TR 1998-17, School of Computing Science, Simon Fraser
# University, November, 1998.
# Copyright (c) 1998, Robert D. Cameron.
# The following code may be freely used and distributed provided that
# this copyright and citation notice remains intact and that modifications
# or additions are clearly identified.
my $TextSE = "[^<]+";
my $UntilHyphen = "[^-]*-";
my $Until2Hyphens = "$UntilHyphen(?:[^-]$UntilHyphen)*-";
my $CommentCE = "$Until2Hyphens>?";
my $UntilRSBs = "[^\\]]*](?:[^\\]]+])*]+";
my $CDATA_CE = "$UntilRSBs(?:[^\\]>]$UntilRSBs)*>";
my $S = "[ \\n\\t\\r]+";
my $NameStrt = "[A-Za-z_:]|[^\\x00-\\x7F]";
my $NameChar = "[A-Za-z0-9_:.-]|[^\\x00-\\x7F]";
my $Name = "(?:$NameStrt)(?:$NameChar)*";
my $QuoteSE = "\"[^\"]*\"|'[^']*'";
my $DT_IdentSE = "$S$Name(?:$S(?:$Name|$QuoteSE))*";
my $MarkupDeclCE = "(?:[^\\]\"'><]+|$QuoteSE)*>";
my $S1 = "[\\n\\r\\t ]";
my $UntilQMs = "[^?]*\\?+";
my $PI_Tail = "\\?>|$S1$UntilQMs(?:[^>?]$UntilQMs)*>";
my $DT_ItemSE = "<(?:!(?:--$Until2Hyphens>|[^-]$MarkupDeclCE)|\\?$Name(?:$PI_Tail))|%$Name;|$S";
my $DocTypeCE = "$DT_IdentSE(?:$S)?(?:\\[(?:$DT_ItemSE)*](?:$S)?)?>?";
my $DeclCE = "--(?:$CommentCE)?|\\[CDATA\\[(?:$CDATA_CE)?|DOCTYPE(?:$DocTypeCE)?";
my $PI_CE = "$Name(?:$PI_Tail)?";
my $EndTagCE = "$Name(?:$S)?>?";
my $AttValSE = "\"[^<\"]*\"|'[^<']*'";
my $ElemTagCE = "$Name(?:$S$Name(?:$S)?=(?:$S)?(?:$AttValSE))*(?:$S)?/?>?";
my $ElemTagCE_Mod = "$S($Name)(?:$S)?=(?:$S)?($AttValSE)";
my $MarkupSPE = "<(?:!(?:$DeclCE)?|\\?(?:$PI_CE)?|/(?:$EndTagCE)?|(?:$ElemTagCE)?)";
my $XML_SPE = "$TextSE|$MarkupSPE";
# REX END - thank you Robert for this 26 line XML parser - awesome ...

my $ATTR_RE = qr /$ElemTagCE_Mod/;

my $DEFAULT_NS = 'petal';

sub new {
    my $class = shift;
    $class    = ref $class || $class;
    my $thing = shift;
    my $self  = bless {}, $class;
    if (defined $thing and $thing =~ /(\<|\n|\>)/) {
        $self->{xmldata} = $thing;
    }
    elsif (defined $thing) {
        open my $xmldatafile, "<", $thing or die "cannot read open $thing";
        $self->{xmldata} = join '', <$xmldatafile>;
        close $xmldatafile;
    }
    return $self;
}


sub process {
    my $self    = shift;
    my $context = { @_ };
    my $data    = $self->{xmldata};
    defined $data or return; # empty data, empty result.
    return $self->makeitso($self->xml2nodes($data), $context); # earl grey. hot.
}

sub xml2nodes {
    my ($self, $xml) = @_;

    my @flat = ( $xml =~ /$XML_SPE/og );

    my $top = { _kids => [], _ns => $DEFAULT_NS };
    my @nest = ( $top );
    for my $tag (@flat) {
        my $node = tag2node($tag, $nest[-1]{_ns}); # if ns is not explicitly set, inherit parent ns

        if ($node->{_close}) {
            my $open = pop @nest;
            confess "unbalanced close-tag '{_tag}>'"                  if $open == $top;
            confess "wrong close-tag '{_tag}>' for '<$open->{_tag}>'" if lc($node->{_tag}) ne lc($open->{_tag});
        }
        else {
            push @{ $nest[-1]{_kids} }, $node;
            push @nest, $node unless ($node->{_simple} or $node->{_selfclose});
        }
    }
    confess "Unbalanced tree, more open than close nodes" if @nest > 1;

    my @nodes = @{ $top->{_kids} };

    return \@nodes;
}

sub makeitso {
    my ($self, $nodes, $context) = @_;

    return "" unless @$nodes;

    my @res;
    for my $node (@$nodes) {
        if ($node->{_simple}) {
            push @res, $self->_interpolate_dollar($context, $node->{_elem}, 'resolve_expression');
        }
        else {
            push @res, $self->makeitso_node($node, $context);
        }
    }

    return join "", @res;
}

sub _interpolate_dollar {
    my ($self, $context, $string, $method) = @_;

    if ($string =~ /\$/) {
        my $subst = sub {
            my $what = shift;
            my $res = $self->$method($what, $context);
            return $res if defined $res;
            carp "'$what' in \$-interpolation resolved to undef";
            return "";
        };

        $string =~ s/(?($1) /xegi;
        $string =~ s/(?($1) /xegi;
        $string =~ s/\$\$/\$/g;
    }
    return $string;
}

sub _deep_copy {
    my $node = shift;
    my %copy = %$node;
    my @kids;
    for my $kid (@{ $node->{_kids} }) {
        push @kids, _deep_copy($kid);
    }
    $copy{_kids} = \@kids;
    return \%copy;
}

sub makeitso_node {
    my ($self, $node, $context) = @_;

    my $TAL = $node->{_ns};

    my $STOP_RECURSE = 0;

    if ($node->{_has_tal}) {
        $node->{_change} = 1;

        if (defined( my $stuff = delete $node->{"$TAL:on-error"} )) {
            my $nodeCopy = { %$node };
            my $res = eval { $self->makeitso_node($node, $context); };
            if ($@) {
                for my $k (keys %$nodeCopy) { delete $nodeCopy->{$k} if $k =~ /^$TAL:/ }
                delete $nodeCopy->{_selfclose};
                $nodeCopy->{_contents} = $self->resolve_expression($stuff, $context);
                return node2txt($nodeCopy);
            }
            return $res;
        }

        $context = { %$context };

        if (defined( my $stuff = delete $node->{"$TAL:define"} )) {
            for my $def (split /;(?!;)/, $stuff) {
                my ($symbol, $expression) = split ' ', $def, 2;
                $context->{$symbol} = $self->resolve_expression($expression, $context);
            }
        }

        if (defined( my $stuff = delete $node->{"$TAL:condition"} )) {
            for my $cond (split /;(?!;)/, $stuff) {
                return '' unless $self->resolve_expression($cond, $context);
            }
        }

        if (defined( my $stuff = delete $node->{"$TAL:repeat"} )) {
            my @loops = split /;(?!;)/, $stuff;
            my $count = 0;
            return join "", $self->_do_repeat(\$count, 1, \@loops, $node, $context);
        }

        if (defined( my $stuff = delete $node->{"$TAL:content"} )) {
            my $res = $self->resolve_expression($stuff, $context);
            $node->{_contents} = defined $res ? $res : "";
            delete $node->{_selfclose};

            # set the stop recurse flag so that if content contains $foo and $bar,
            # those aren't interpolated as variables.
            $STOP_RECURSE = 1;
        }

        if (defined( my $stuff = delete $node->{"$TAL:replace"} )) {
            my $res = $self->resolve_expression($stuff, $context);
            return defined $res ? $res : '';
        }

        if (defined( my $stuff = delete $node->{"$TAL:attributes"} )) {
            for my $att (split /;(?!;)/, $stuff) {
                my ($symbol, $expression) = split ' ', $att, 2;
                my $add = ($symbol =~ s/^\+//);
                my $new = $self->resolve_expression($expression, $context);
                if (defined $new) {
                    if ($add) {
                        my $old = $node->{$symbol};
                        $old = "" unless defined $old;
                        $new = $old . $new;
                    }
                    $node->{$symbol} = $new;
                }
                else {
                    delete $node->{$symbol} unless $add;
                }
            }
        }

        if (defined(my $stuff = delete $node->{"$TAL:omit-tag"})) {
            if ($stuff eq '' or $self->resolve_expression($stuff, $context)) {
                return $node->{_contents} if $STOP_RECURSE;
                return $self->makeitso($node->{_kids}, $context);
            }
        }
    }

    unless ($STOP_RECURSE) {
        $node->{_contents} = $self->makeitso($node->{_kids}, $context);
    }
    return node2txt($node);
}

sub _do_repeat {
    my ($self, $count, $last, $loops_ref, $node, $context) = @_;
    my @loops = @$loops_ref;
    my $stuff = shift @loops;
    my ($symbol, $expression) = split ' ', $stuff, 2;
    my $array  = $self->resolve_expression($expression, $context);
    $array = [ $array ] unless ref $array; # we don't judge
    my @result;
    foreach my $idx (0 .. $#$array) {
        my $item = $array->[$idx];
        $context->{$symbol} = $item;
        if (@loops) {
            push @result, $self->_do_repeat($count, $last && $idx == $#$array, \@loops, $node, $context);
        }
        else {
            $$count++;
            $context->{repeat} = {};
            $context->{repeat}->{index}  = $$count;
            $context->{repeat}->{number} = $$count;
            $context->{repeat}->{even}   = $$count%2 ? 0 : 1;
            $context->{repeat}->{odd}    = $$count%2 ? 1 : 0;
            $context->{repeat}->{start}  = $$count == 1 ? 1 : 0;
            $context->{repeat}->{end}    = $last && $idx == $#$array ? 1 : 0;
            $context->{repeat}->{inner}  = $context->{repeat}->{start} || $context->{repeat}->{end} ? 0 : 1;

            push @result, $self->makeitso_node(_deep_copy($node), $context);
        }
    }
    return @result;
}


sub resolve_expression {
    my ($self, $expr, $context) = @_;

    $expr = "" unless defined $expr;
    $expr =~ s/[\n\r]/ /g;
    $expr =~ s/^\s+//;
    $expr =~ s/\s+$//;

    $expr =~ s/([;\$])\1/$1/g;
    $expr eq 'nothing' and return undef;
    $expr =~ s/^fresh\s+//;
    my $structure = ($expr =~ s/^structure\s+//);
    my $resolved = $self->resolve($expr, $context);
    return $structure ? $resolved : xmlencode($resolved);
}

sub reftype {
    my ($self, $obj) = @_;
    return ref $obj;
}

sub resolve {
    my ($self, $expr, $context) = @_;
    $expr =~ /:(?!pattern)/ and do { # XXX what is :pattern?
        my ($mod, $expr) = split /:(?!pattern)\s*/, $expr, 2;
        my $meth = $self->can("modifier_$mod");
        return $self->$meth($expr, $context) if $meth;
        confess "unknown modifier $mod";
    };
    return $expr if $expr =~ s/^--//;

    my ($what, @args) = split ' ', $expr;
    defined $what or return;

    my (@path)   = split /\//, $what;
    my @resolved;
    my $obj      = $context;
    @args        = map { $self->resolve($_, $context) } @args;
    while (@path) {
        my $attribute_or_method = shift @path;
        push @resolved, $attribute_or_method;
        my $resolved = join '/', @resolved;
        $obj or confess "cannot fetch $what, because $resolved is undefined";
        my $reftype = $self->reftype($obj);
        $reftype or confess "cannot fetch $what, because $resolved is not a reference";

        if ($reftype eq 'ARRAY') {
            $obj = $obj->[$attribute_or_method];
        }
        elsif ($reftype eq 'HASH') {
            $obj = $obj->{$attribute_or_method};
        }
        elsif ($obj->can($attribute_or_method)) {
            if (@path) {
                $obj = $obj->$attribute_or_method();
            }
            else {
                $obj = $obj->$attribute_or_method(@args);
                @args = ();
            }
        }

        # now, check if what we found was a code-ref
        $reftype = $self->reftype($obj);
        if ($reftype eq 'CODE') {
            if (@path) {
                $obj = $obj->();
            }
            else {
                $obj = $obj->(@args);
                @args = ();
            }
        }

        # if we're done with @path and there's a single arg, use it to look up in array/hash
        if (not @path and @args == 1) {
            $reftype = $self->reftype($obj);

            if ($reftype eq 'ARRAY') {
                $obj = $obj->[ $args[0] ];
                last;
            }
            elsif ($reftype eq 'HASH') {
                $obj = $obj->{ $args[0] };
                last;
            }
        }

        not @path and @args and confess "cannot resolve expression $expr";
    }
    return $obj;
}


sub modifier_true {
    my ($self, $expr, $context) = @_;
    my $arg  = $self->resolve($expr, $context);
    ref $arg and $self->reftype($arg) eq 'ARRAY' and return scalar @$arg;
    return $arg ? 1 : 0;
}


sub modifier_false {
    my $self = shift;
    return not $self->modifier_true(@_);
}


sub modifier_string {
    my ($self, $string, $context) = @_;
    $string = $self->_interpolate_dollar($context, $string, 'resolve');
    return $string;
}


sub node2txt {
    my $node  = shift;

    return $node unless ref $node eq 'HASH'; # handle textnodes introduced in makeitso_node
    return $node->{_elem} if $node->{_simple};

    delete $node->{_ns};
    delete $node->{_has_tal};
    delete $node->{_kids};

    my $change   = delete $node->{_change};
    my $elem     = delete $node->{_elem};
    my $tag      = delete $node->{_tag};
    my $close    = delete $node->{_selfclose};
    my $quotes   = delete $node->{_quotes};
    my $contents = delete $node->{_contents};
    my $att      = join ' ', map { my $q = $quotes->{$_} || '"'; qq|$_=$q$node->{$_}$q| } keys %$node;

    if ($close) {
        return $change ? ($att ? "<$tag $att />" : "<$tag />") : $elem;
    }

    my $start = $change ? ($att ? "<$tag $att>" : "<$tag>") : $elem;
    my $end   = "";

    $contents = "" unless defined $contents;

    return $start . $contents . $end;
}

sub tag2node {
    my ($elem, $ns) = @_;

    if ($elem =~ m,^<(/?)([A-Za-z0-9][A-Za-z0-9_:-]+).*?(/?)>$,) {
        my ($has_close, $tag, $has_self_close) = ($1,$2,$3);

        return { _tag => $tag, _close => 1 } if $has_close; # don't waste any time on  nodes, they're just for book-keeping

        my %node          = extract_attributes($elem);
        $node{_ns}      ||= $ns;

        $node{_has_tal}   = exists $node{_ns_prefix}{ $node{_ns} };
        $node{_tag}       = $tag;
        $node{_selfclose} = $has_self_close;
        $node{_elem}      = $elem;
        $node{_kids}      = [];

        delete $node{_ns_prefix};

        return \%node;
    }

    return {
        _elem => $elem,
        _simple => 1,
    };
}

sub extract_attributes {
    my $tag = shift;

    my %attr = $tag =~ /$ATTR_RE/og;

    my (%quotes, %prefix);

    foreach my $key (keys %attr) {
        $attr{$key} =~ s/^(['"])(.*?)\1$/$2/;
        my $q = $1 || '"';

        if ($key =~ /^(.*?):/) {
            if ($1 eq 'xmlns' && $attr{$key} eq 'http://purl.org/petal/1.0/') {
                delete $attr{$key};
                $key           =~ s/^xmlns\://;
                $attr{_ns}     = $key;
                $attr{_change} = 1;
                next;
            }
            $prefix{$1} = 1;
        }
        $quotes{$key} = $q;
    }

    $attr{_quotes} = \%quotes;
    $attr{_ns_prefix} = \%prefix;

    %attr;
}

my %_encode_dict = (
    '&' => '&',
    '<' => '<',
    '>' => '>',
    '"' => '"',
    "'" => ''',
);

sub xmlencode {
    my $string = shift;
    return $string if !$string or ref $string;
    $string =~ s/([&<>"'])/$_encode_dict{$1}/g;
    return $string;
}


1;


__END__