File Coverage

lib/Petal/Tiny.pm

Criterion	Covered	Total	%
statement	348	354	98.3
branch	153	172	88.9
condition	49	72	68.0
subroutine	33	33	100.0
pod	0	27	0.0
total	583	658	88.6

package Petal::Tiny;
$Petal::Tiny::VERSION = '1.13';
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.
our $TextSE = "[^<]+";
our $UntilHyphen = "[^-]*-";
our $Until2Hyphens = "$UntilHyphen(?:[^-]$UntilHyphen)*-";
our $CommentCE = "$Until2Hyphens>?";
our $UntilRSBs = "[^\\]]*](?:[^\\]]+])*]+";
our $CDATA_CE = "$UntilRSBs(?:[^\\]>]$UntilRSBs)*>";
our $S = "[ \\n\\t\\r]+";
our $NameStrt = "[A-Za-z_:]|[^\\x00-\\x7F]";
our $NameChar = "[A-Za-z0-9_:.-]|[^\\x00-\\x7F]";
our $Name = "(?:$NameStrt)(?:$NameChar)*";
our $QuoteSE = "\"[^\"]*\"|'[^']*'";
our $DT_IdentSE = "$S$Name(?:$S(?:$Name|$QuoteSE))*";
our $MarkupDeclCE = "(?:[^\\]\"'><]+|$QuoteSE)*>";
our $S1 = "[\\n\\r\\t ]";
our $UntilQMs = "[^?]*\\?+";
our $PI_Tail = "\\?>|$S1$UntilQMs(?:[^>?]$UntilQMs)*>";
our $DT_ItemSE = "<(?:!(?:--$Until2Hyphens>|[^-]$MarkupDeclCE)|\\?$Name(?:$PI_Tail))|%$Name;|$S";
our $DocTypeCE = "$DT_IdentSE(?:$S)?(?:\\[(?:$DT_ItemSE)*](?:$S)?)?>?";
our $DeclCE = "--(?:$CommentCE)?|\\[CDATA\\[(?:$CDATA_CE)?|DOCTYPE(?:$DocTypeCE)?";
our $PI_CE = "$Name(?:$PI_Tail)?";
our $EndTagCE = "$Name(?:$S)?>?";
our $AttValSE = "\"[^<\"]*\"|'[^<']*'";
our $ElemTagCE = "$Name(?:$S$Name(?:$S)?=(?:$S)?(?:$AttValSE))*(?:$S)?/?>?";
our $ElemTagCE_Mod = "$S($Name)(?:$S)?=(?:$S)?($AttValSE)";
our $MarkupSPE = "<(?:!(?:$DeclCE)?|\\?(?:$PI_CE)?|/(?:$EndTagCE)?|(?:$ElemTagCE)?)";
our $XML_SPE = "$TextSE|$MarkupSPE";
# REX END - thank you Robert for this 26 line XML parser - awesome ...


our $RE_1 = qr /$ElemTagCE/;
our $RE_2 = qr /$ElemTagCE_Mod/;
our $VARIABLE_RE_SIMPLE   = qq |\$[A-Za-z_][A-Za-z0-9_\.:\/]+|;
our $VARIABLE_RE_BRACKETS = qq |(?
our $STRING_TOKEN_RE      = "($VARIABLE_RE_SIMPLE|$VARIABLE_RE_BRACKETS)";

our $TAL = 'petal';

our $STOP_RECURSE = 0;


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) {
        $self->{xmldata} = do {
            open my $xmldatafile, "<", $thing or die "cannot read open $thing";
            my $xmldata = join '', <$xmldatafile>;
            close $xmldatafile;
            $xmldata;
        };
    }
    return $self;
}


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


sub makeitso {
    my $self    = shift;
    my $xml     = shift;
    my @xml     = ref $xml ? @{$xml} : ( $xml =~ /$XML_SPE/g );
    my $context = shift || {};
    my @head    = ();
    my @body    = ();
    my @tail    = ();
    while (@xml) {
        my $elem = shift @xml;
        tag_self_close ($elem) and do {
            push @body, $elem;
            @tail = @xml;
            last;
        };
        my $opentag = tag_open ($elem);
        $opentag and do {
            push @body, $elem;
            my $balance = 1;
            while ($balance) {
                @xml or confess "cannot find closing tag for $elem";
                my $elem = shift @xml;
                tag_open  ($elem) and $balance++;
                tag_close ($elem) and $balance--;
                push @body, $elem;
            }
            @tail = @xml;
            last;
        };
        tag_close ($elem) and confess "cannot find opening tag for $elem";

        $elem = $self->_interpolate_dollar($context, $elem, 'resolve_expression');
        push @head, $elem;
    }
    my @res = ();
    push @res, @head                                   if (@head);
    push @res, $self->makeitso_block(\@body, $context) if (@body);
    push @res, $self->makeitso(\@tail, $context)       if (@tail);
    return join '', @res;
}


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

    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 "";
    };

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


sub namespace {
    my $self = shift;
    my $node = shift;
    for my $k (keys %{$node}) {
        $k =~ /^xmlns\:/ or next;
        my $v = $node->{$k};
        if ($v eq 'http://purl.org/petal/1.0/') {
            delete $node->{$k};
            $k =~ s/^xmlns\://;
            return $k;
        }
    }
    return;
}


sub makeitso_block {
    my $self    = shift;
    my $xml     = shift;
    my $context = shift;
    my @xml     = ref $xml ? @{$xml} : ( $xml =~ /$XML_SPE/g );
    my $tag     = shift (@xml);
    my $gat     = pop (@xml);
    my $node    = tag_open ($tag) || tag_self_close ($tag);
    my $ns      = $self->namespace($node);
    local $TAL  = $ns || $TAL;
    if (has_instructions ($node)) {
        $context = { %{$context} };
        return $self->tal_on_error($node, \@xml, $gat, $context);
    }
    else {
        $tag = node2tag ($node) if ($ns);
        if ($gat) { return $tag . $self->makeitso(\@xml, $context) . $gat }
        else      { return $tag                                           } # self-closing tag
    }
}


sub tal_on_error {
    my ($self, $node, $xml, $end, $context) = @_;
    my $stuff   = delete $node->{"$TAL:on-error"};
    defined $stuff or return $self->tal_define($node, $xml, $end, $context);
    my $nodeCopy = { %{$node} };
    my $res = eval { $self->tal_define($node, $xml, $end, $context) };
    if ($@) {
        my @result = ();
        for my $k (keys %{$nodeCopy}) { delete $nodeCopy->{$k} if $k =~ /^$TAL:/ }
        delete $nodeCopy->{_close} and $end = "{_tag}>"; # deal with self closing tags
        push @result, node2tag ($nodeCopy);
        push @result, $self->resolve_expression($stuff, $context);
        push @result, $end;
        return join '', @result;
    }
    else {
        return $res;
    }
}


sub tal_define {
    my ($self, $node, $xml, $end, $context) = @_;
    my $stuff   = delete $node->{"$TAL:define"};
    defined $stuff || return $self->tal_condition($node, $xml, $end, $context);
    my $newContext = { %{$context} };
    my $define  = trim ($stuff);
    for my $def (split /;(?!;)/, $define) {
        $def = trim($def);
        my ($symbol, $expression) = split /\s+/, $def, 2;
        $newContext->{$symbol} = $self->resolve_expression($expression, $newContext);
    }
    return $self->tal_condition($node, $xml, $end, $newContext);
}


sub tal_condition {
    my ($self, $node, $xml, $end, $context) = @_;
    my $stuff   = delete $node->{"$TAL:condition"};
    defined $stuff or return $self->tal_repeat($node, $xml, $end, $context);

    my $condition = trim ($stuff);
    for my $cond (split /;(?!;)/, $condition) {
        $cond = trim($cond);
        $self->resolve_expression($cond, $context) or return '';
    }
    return $self->tal_repeat($node, $xml, $end, $context);
}


sub tal_repeat {
    my ($self, $node, $xml, $end, $context) = @_;
    my $stuff   = delete $node->{"$TAL:repeat"};
    defined $stuff or return $self->tal_content($node, $xml, $end, $context);

    my @loops = split /;/, $stuff;
    my $count = 0;
    return $self->_do_repeat(\$count, 1, \@loops, $node, $xml, $end, { %$context });
}

sub _do_repeat {
    my ($self, $count, $last, $loops_ref, $node, $xml, $end, $context) = @_;

    my @loops = @$loops_ref;
    my $stuff = shift @loops;
    my $repeat = trim ($stuff);
    my ($symbol, $expression) = split /\s+/, $repeat, 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, $xml, $end, $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->tal_content({ %$node }, $xml, $end, $context);
        }
    }
    return join '', @result;
}


sub tal_content {
    my ($self, $node, $xml, $end, $context) = @_;
    my $stuff   = delete $node->{"$TAL:content"};
    defined $stuff or return $self->tal_replace($node, $xml, $end, $context);

    my $res = $self->resolve_expression($stuff, $context);
    $xml    = defined $res ? [ $res ] : [];
    delete $node->{_close} and $end = "{_tag}>"; # deal with self closing tags

    # set the stop recurse flag so that if content contains $foo and $bar,
    # those aren't interpolated as variables.
    local ( $STOP_RECURSE ) = ( 1 );
    return $self->tal_replace($node, $xml, $end, $context);
}


sub tal_replace {
    my ($self, $node, $xml, $end, $context) = @_;
    my $stuff   = delete $node->{"$TAL:replace"};
    defined $stuff or return $self->tal_attributes($node, $xml, $end, $context);
    my $res = $self->resolve_expression($stuff, $context);
    return defined $res ? $res : '';
}


sub tal_attributes {
    my ($self, $node, $xml, $end, $context) = @_;
    my $stuff = delete $node->{"$TAL:attributes"};
    defined $stuff or return $self->tal_omit_tag($node, $xml, $end, $context);

    my $attributes  = trim ($stuff);
    for my $att (split /;(?!;)/, $attributes) {
        $att = trim ($att);
        my ($symbol, $expression) = split /\s+/, $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;
        }
    }
    return $self->tal_omit_tag($node, $xml, $end, $context);
}


sub tal_omit_tag {
    my ($self, $node, $xml, $end, $context) = @_;
    my $stuff  = delete $node->{"$TAL:omit-tag"};
    my $omit   = defined $stuff ? do { $stuff eq '' ? 1 : $self->resolve_expression($stuff, $context) } : undef;
    $omit and not $end and return ''; # omit-tag on a self-closing tag means *poof*, nothing left
    my @result = ();
    push @result, node2tag ($node) unless ($omit);
    if ($end) {
        push @result, do { $STOP_RECURSE ? join '', @{$xml} : $self->makeitso($xml, $context) };
        push @result, $end unless ($omit);
    }
    return join '', @result;
}


sub resolve_expression {
    my $self    = shift;
    my $expr    = trim(shift);
    my $context = shift || confess "resolve_expression() : no context";
    $expr =~ s/\;\;/;/g;
    $expr =~ s/\$\$/\$/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    = shift;
    my $expr    = trim(shift);
    my $context = shift || confess "resolve() : no context";
    $expr =~ /:(?!pattern)/ and do {
        my ($mod, $expr) = split /:(?!pattern)/, $expr, 2;
        my $meth = "modifier_$mod";
        $self->can("modifier_$mod") and return $self->$meth($expr, $context);
        confess "unknown modifier $mod";
    };
    $expr =~ /^--/ and do {
      $expr =~ s/^--//;
      return $expr;
    };
    $expr =~ s/\r/ /g;
    my ($what, @args) = split /\s+/, $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 = shift;
    my $arg  = $self->resolve(shift(), shift());
    ref $arg and $self->reftype($arg) eq 'ARRAY' and return @{$arg};
    return $arg ? 1 : 0;
}


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


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


sub node2tag {
    my $node  = shift;
    my $tag   = delete $node->{_tag};
    for (keys %{$node}) { /^($TAL:)/ and delete $node->{$_} }
    my $open  = delete $node->{_open}  || 0;
    my $close = delete $node->{_close} || 0;
    my $att   = join ' ', map { qq|$_="$node->{$_}"| } keys %{$node};
    $open  and $close and return $att ? "<$tag $att />" : "<$tag />";
    $close and return "";
    $open  and return $att ? "<$tag $att>" : "<$tag>";
    die "There is probably a bug somewhere. A tag that's not and open tag and not a close tag?";
}


sub trim {
    my $string = shift;
    $string or return $string;
    $string =~ s/\r//g;
    $string =~ s/\n/ /g;
    $string =~ s/^\s+//;
    $string =~ s/\s+$//;
    return $string;
}


sub has_instructions {
    my $node = shift;
    return grep /^$TAL:/, keys %{$node};
}


sub tag_open {
    my $elem = shift;
    my $node = undef;
    not defined $elem and confess ('undefined elem');

    $elem !~ /^<\!/ and
    $elem !~ /^<\// and
    $elem !~ /\/>$/ and
    $elem !~ /^<\?/ and
    $elem =~ /^
	my %node      = extract_attributes ($elem);
	($node{_tag}) = $elem =~ /.*?([A-Za-z0-9][A-Za-z0-9_:-]*)/;
	$node{_open}  = 1;
	$node{_close} = 0;
	$node = \%node;
    };
    return $node;
}


sub tag_close {
    my $elem = shift;
    my $node = undef;
    $elem !~ /^<\!/ and
    $elem =~ /^<\// and
    $elem !~ /\/>$/ and do {
        my %node      = ();
	($node{_tag}) = $elem =~ /.*?([A-Za-z0-9][A-Za-z0-9_:-]*)/;
	$node{_open}  = 0;
	$node{_close} = 1;
	$node = \%node;
    };
    return $node;
}


sub tag_self_close {
    my $elem = shift;
    my $node = undef;
    $elem !~ /^<\!/ and
    $elem !~ /^<\// and
    $elem =~ /\/>$/ and
    $elem =~ /^
	my %node      = extract_attributes ($elem);
        ($node{_tag}) = $elem =~ /.*?([A-Za-z0-9][A-Za-z0-9_:-]*)/;
	$node{_open}  = 1;
	$node{_close} = 1;
	$node = \%node;
    };
    return $node;
}


sub extract_attributes {
    my $tag = shift;
    my ($tags) = $tag =~ /$RE_1/g;
    my %attr = $tag =~ /$RE_2/g;
    foreach my $key (keys %attr)
    {
        my $val = $attr{$key};
        $val    =~ s/^(\"|\')//;
        $val    =~ s/(\"|\')$//;
        $attr{$key} = $val;
    }

    %attr;
}


sub xmlencode {
    my $string = shift;
    return $string if !$string or ref $string;
    $string =~ s/&/&/g;
    $string =~ s/
    $string =~ s/>/>/g;
    $string =~ s/"/"/g;
    $string =~ s/'/'/g;
    return $string;
}


1;


__END__