view release on metacpan or  search on metacpan

lib/AxKit2/XSP/SimpleTaglib.pm  view on Meta::CPAN

package AxKit2::XSP::SimpleTaglib;
require 5.006;
use strict;
use base 'AxKit2::Transformer::XSP';
use Data::Dumper;
eval { require WeakRef; };
eval { require XML::Smart; };
use attributes;
our $VERSION = 0.3;

# utility functions

sub makeSingleQuoted($) { $_ = shift; s/([\\%])/\\$1/g; 'q%'.$_.'%'; }
sub _makeAttributeQuoted(@) { $_ = join(',',@_); s/([\\()])/\\$1/g; '('.$_.')'; }
sub makeVariableName($) { $_ = shift; s/[^a-zA-Z0-9]/_/g; $_; }

my $dumper = new Data::Dumper([]);
$dumper->Quotekeys(0);
$dumper->Terse(1);
$dumper->Indent(0);

# perl attribute handlers

my %handlerAttributes;

use constant PLAIN => 0;
use constant EXPR => 1;
use constant EXPRORNODE => 2;
use constant NODE => 3;
use constant EXPRORNODELIST => 4;
use constant NODELIST => 5;
use constant STRUCT => 6;

# Memory leak ahead! The '&' construct may create circular references, which perl
# can't clean up. But this has only an effect if a taglib is reloaded, which shouldn't
# happen on production machines. Moreover, '&' is rather unusual.
# If you have the WeakRef module installed, this warning does not apply.
sub parseChildStructSpec {
    my ($specs, $refs) = @_;
    for my $spec ($_[0]) {
        my $result = {};
        while (length($spec)) {
            $spec = substr($spec,1), return $result if (substr($spec,0,1) eq '}');
            (my ($type, $token, $next) = ($spec =~ m/^([!\&\@\*\$]?)([^ {}]+)(.|$)/))
                 || die("childStruct specification invalid. Parse error at: '$spec'");
            substr($spec,0,length($token)+1+($type?1:0)) = '';
            #warn("type: $type, token: $token, next: $next, spec: $spec");
            my ($realtoken, $params);
            if ((($realtoken,$params) = ($token =~ m/^([^\(]+)((?:\([^ \)]+\))+)$/))) {
                my $i = 0;
                $token = $realtoken;
                $$result{$token}{'param'} = { map { $_ => $i++ } ($params =~ m/\(([^ )]+)\)/g) };
            }
            if ($type eq '&') {
                ($$result{$token} = $$refs{$token})
                    || die("childStruct specification invalid. '&' reference not found.");
                die("childStruct specification invalid. '&' cannot be used on '*' nodes.")
                    if ($$result{$token}{'type'} eq '*');
                die("childStruct specification invalid. '&' may only take a reference.")
                    if $$result{'param'};
                eval { WeakRef::weaken($$result{$token}) };
                return $result if (!$next || $next eq '}');
                next;
            }
            $$result{$token}{'type'} = $type || '$';
            die("childStruct specification invalid. '${type}' cannot be used with '{'.")
                if ($next eq '{' and ($type eq '*' || $type eq '!'));
            die("childStruct specification invalid. '${type}' cannot be used with '(,,,)'.")
                if ($$result{$token}{'param'} and ($type eq '*' || $type eq '!'));
            die("childStruct specification invalid. '**' is not supported.")
                if ($token eq '*' and $type eq '*');
            $$result{''}{'name'} = $token if ($type eq '*');
            $$result{$token}{'name'} = $token;
            return $result if (!$next || $next eq '}');
            ($$result{$token}{'sub'} = parseChildStructSpec($spec, { %$refs, $token => $$result{$token} })) || return undef if $next eq '{';
        }
        return $result;
    }
}

sub serializeChildStructSpec {
    my ($struct, $refs) = @_;
    my $result = '';
    my $first = 1;
    foreach my $token (keys %$struct) {
        next unless length($token);
        $result .= ' ' unless $first;
        undef $first;
        if (exists $$refs{$$struct{$token}}) {
            $result .= '&'.$token;
            next;
        }
        $result .= $$struct{$token}{'type'};
        $result .= $token;
        if (exists $$struct{$token}{'param'}) {
            my %keys = reverse %{$$struct{$token}{'param'}};
            $result .= '('.join(')(',@keys{0..(scalar(%keys)-1)}).')'
        }
        $result .= '{'.serializeChildStructSpec($$struct{$token}{'sub'},{ %$refs, $$struct{$token} => undef }).'}'
            if exists $$struct{$token}{'sub'};
    }
    return $result;
}

sub MODIFY_CODE_ATTRIBUTES {
    my ($pkg,$sub,@attr) = @_;
    return unless defined $sub;
    my @rest;
    $handlerAttributes{$sub} ||= {};
    my $handlerAttributes = $handlerAttributes{$sub};
    foreach my $a (@attr) {
        #warn("attr: $a");
        my ($attr,$param) = ($a =~ m/([^(]*)(?:\((.*)\))?$/);
        my $warn = 0;
        $attr =~ s/^XSP_// || $warn++;
        $param = (defined $param?eval "q($param)":"");
        my @param = split(/,/,$param);

        if ($attr eq 'expr') {
            $$handlerAttributes{'result'} = EXPR;
        } elsif ($attr eq 'node') {