Revision: 119
Author: matt
Date: 2006-08-24 00:06:56 +0000 (Thu, 24 Aug 2006)
Log Message:
-----------
Oopsie - forgot to check these into SVN
Added Paths:
-----------
trunk/lib/AxKit2/XSP/
trunk/lib/AxKit2/XSP/SimpleTaglib.pm
trunk/lib/AxKit2/XSP/TaglibHelper.pm
Added: trunk/lib/AxKit2/XSP/SimpleTaglib.pm
===================================================================
--- trunk/lib/AxKit2/XSP/SimpleTaglib.pm 2006-08-24 00:05:52 UTC (rev
118)
+++ trunk/lib/AxKit2/XSP/SimpleTaglib.pm 2006-08-24 00:06:56 UTC (rev
119)
@@ -0,0 +1,1342 @@
+# Copyright 2001-2006 The Apache Software Foundation
+#
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+#
+# http://www.apache.org/licenses/LICENSE-2.0
+#
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+#
+
+# Apache::AxKit::XSP::Language::SimpleTaglib - alternate taglib helper code
+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/^([!\&[EMAIL
PROTECTED])([^ {}]+)(.|$)/))
+ || 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') {
+ $$handlerAttributes{'result'} = NODE;
+ $$handlerAttributes{'nodename'} = $param[0] || 'value';
+ } elsif ($attr eq 'exprOrNode') {
+ $$handlerAttributes{'result'} = EXPRORNODE;
+ $$handlerAttributes{'nodename'} = $param[0] || 'value';
+ $$handlerAttributes{'resultparam'} = $param[1] || 'as';
+ $$handlerAttributes{'resultnode'} = $param[2] || 'node';
+ } elsif ($attr eq 'nodelist') {
+ $$handlerAttributes{'result'} = NODELIST;
+ $$handlerAttributes{'nodename'} = $param[0] || 'value';
+ } elsif ($attr eq 'exprOrNodelist') {
+ $$handlerAttributes{'result'} = EXPRORNODELIST;
+ $$handlerAttributes{'nodename'} = $param[0] || 'value';
+ $$handlerAttributes{'resultparam'} = $param[1] || 'as';
+ $$handlerAttributes{'resultnode'} = $param[2] || 'node';
+ } elsif ($attr eq 'struct') {
+ $$handlerAttributes{'result'} = STRUCT;
+ $$handlerAttributes{'namespace'} = $param[0];
+ } elsif ($attr eq 'stack') {
+ $$handlerAttributes{'stack'} = $param[0];
+ } elsif ($attr eq 'smart') {
+ $$handlerAttributes{'smart'} = 1;
+ $$handlerAttributes{'capture'} = 1;
+ } elsif ($attr eq 'nodeAttr') {
+ my %namespace;
+ while (@param > 1) {
+ my ($ns, $prefix, $name) = parse_namespace($param[0]);
+ $namespace{$prefix} = $ns if $ns and $prefix;
+ $param[0] = "{$namespace{$prefix}}$prefix:$name" if $prefix;
+ $$handlerAttributes{'resultattr'}{$param[0]} = $param[1];
+ shift @param; shift @param;
+ }
+ } elsif ($attr eq 'attrib') {
+ foreach my $param (@param) {
+ $$handlerAttributes{'attribs'}{$param} = undef;
+ }
+ } elsif ($attr eq 'child') {
+ foreach my $param (@param) {
+ $$handlerAttributes{'children'}{$param} = undef;
+ }
+ } elsif ($attr eq 'attribOrChild') {
+ foreach my $param (@param) {
+ $$handlerAttributes{'attribs'}{$param} = undef;
+ $$handlerAttributes{'children'}{$param} = undef;
+ }
+ } elsif ($attr eq 'childStruct') {
+ my $spec = $param[0];
+ #warn("parsing $spec");
+ $spec =~ s/\s+/ /g;
+ $spec =~ s/ ?{ ?/{/g;
+ $spec =~ s/ ?} ?/}/g;
+ $$handlerAttributes{'struct'} = parseChildStructSpec($spec,{});
+ #warn("parsed $param[0], got
".serializeChildStructSpec($$handlerAttributes{'struct'}));
+ die("childStruct parse error") unless
$$handlerAttributes{'struct'};
+ } elsif ($attr eq 'keepWhitespace') {
+ $$handlerAttributes{'keepWS'} = 1;
+ } elsif ($attr eq 'captureContent') {
+ $$handlerAttributes{'capture'} = 1;
+ } elsif ($attr eq 'compile') {
+ $$handlerAttributes{'compile'} = 1;
+ } elsif ($attr eq 'XSP' && $warn) {
+ $warn = 0;
+ $$handlerAttributes{'xsp'} = 1;
+ } else {
+ push @rest, $a;
+ $warn = 0;
+ }
+ warn("Please prefix your XSP attributes with 'XSP_' (${pkg}::${sub} :
$attr)") if $warn;
+ }
+ delete $handlerAttributes{$sub} if not keys %$handlerAttributes;
+ return @rest;
+}
+
+sub FETCH_CODE_ATTRIBUTES {
+ my ($pkg,$sub) = @_;
+ my @attr;
+ my $handlerAttributes = $handlerAttributes{$sub};
+ return () if !defined $handlerAttributes;
+ if (exists $$handlerAttributes{'result'}) {
+ if ($$handlerAttributes{'result'} == NODELIST) {
+ push @attr,
'XSP_nodelist'._makeAttributeQuoted($$handlerAttributes{'nodename'});
+ } elsif ($$handlerAttributes{'result'} == EXPRORNODELIST) {
+ push @attr,
'XSP_exprOrNodelist'._makeAttributeQuoted($$handlerAttributes{'nodename'},$$handlerAttributes{'resultparam'},$$handlerAttributes{'resultnode'});
+ } elsif ($$handlerAttributes{'result'} == NODE) {
+ push @attr,
'XSP_node'._makeAttributeQuoted($$handlerAttributes{'nodename'});
+ } elsif ($$handlerAttributes{'result'} == EXPRORNODE) {
+ push @attr,
'XSP_exprOrNode'._makeAttributeQuoted($$handlerAttributes{'nodename'},$$handlerAttributes{'resultparam'},$$handlerAttributes{'resultnode'});
+ } elsif ($$handlerAttributes{'result'} == EXPR) {
+ push @attr, 'XSP_expr';
+ } elsif ($$handlerAttributes{'result'} == STRUCT) {
+ push @attr, 'XSP_struct';
+ $attr[-1] .= _makeAttributeQuoted($$handlerAttributes{'namespace'})
+ if defined $$handlerAttributes{'namespace'};
+ }
+ }
+ push @attr,
'XSP_nodeAttr'._makeAttributeQuoted(%{$$handlerAttributes{'resultattr'}}) if
$$handlerAttributes{'resultattr'};
+ push @attr, 'XSP_stack'._makeAttributeQuoted($$handlerAttributes{'stack'})
if $$handlerAttributes{'stack'};
+ push @attr, 'XSP_smart' if $$handlerAttributes{'smart'};
+ push @attr, 'XSP_keepWhitespace' if $$handlerAttributes{'keepWS'};
+ push @attr, 'XSP_captureContent' if $$handlerAttributes{'capture'};
+ push @attr, 'XSP_compile' if $$handlerAttributes{'compile'};
+
+ push @attr,
'XSP_childStruct'._makeAttributeQuoted(serializeChildStructSpec($$handlerAttributes{'struct'},{}))
+ if ($$handlerAttributes{'struct'});
+
+ my (@attribs, @children, @both);
+ foreach my $param (keys %{$$handlerAttributes{'attribs'}}) {
+ if (exists $$handlerAttributes{'children'}{$param}) {
+ push @both, $param;
+ } else {
+ push @attribs, $param;
+ }
+ }
+ foreach my $param (keys %{$$handlerAttributes{'children'}}) {
+ if (!exists $$handlerAttributes{'attribs'}{$param}) {
+ push @children, $param;
+ }
+ }
+ push @attr, 'XSP_attrib'._makeAttributeQuoted(@attribs) if @attribs;
+ push @attr, 'XSP_child'._makeAttributeQuoted(@children) if @children;
+ push @attr, 'XSP_attribOrChild'._makeAttributeQuoted(@both) if @both;
+ push @attr, 'XSP' if [EMAIL PROTECTED];
+ return @attr;
+}
+
+sub import {
+ my $pkg = caller;
+ #warn("making $pkg a SimpleTaglib");
+ {
+ no strict 'refs';
+ *{$pkg.'::Handlers::MODIFY_CODE_ATTRIBUTES'} =
\&MODIFY_CODE_ATTRIBUTES;
+ *{$pkg.'::Handlers::FETCH_CODE_ATTRIBUTES'} = \&FETCH_CODE_ATTRIBUTES;
+ push @{$pkg.'::ISA'}, 'AxKit2::XSP::SimpleTaglib';
+
+ }
+ return undef;
+}
+
+# companions to start_expr
+
+sub start_expr {
+ my $e = shift;
+ my $cur = $e->{Current_Element};
+ my $rc = $e->start_expr(@_);
+ $e->{Current_Element} = $cur;
+ return $rc;
+}
+
+sub start_elem {
+ my ($e, $nodename, $attribs, $default_prefix, $default_ns) = @_;
+ my($ns, $prefix, $name) = parse_namespace($nodename);
+ #$prefix = $e->generate_nsprefix($ns) if $ns and not $prefix;
+ if (not defined $ns and not defined $prefix) {
+ $ns = $default_ns; $prefix = $default_prefix;
+ }
+ $name = $prefix.':'.$name if $prefix;
+ if ($ns) {
+ $e->append_to_script('{ my $elem =
$document->createElementNS('.makeSingleQuoted($ns).','.makeSingleQuoted($name).');');
+ }
+ else {
+ $e->append_to_script('{ my $elem =
$document->createElement('.makeSingleQuoted($name).');');
+ }
+ $e->append_to_script('$parent->appendChild($elem); $parent = $elem; }' .
"\n");
+ if ($attribs) {
+ while (my ($key, $value) = each %$attribs) {
+ start_attr($e, $key); $e->append_to_script('.'.$value);
end_attr($e);
+ }
+ }
+ $e->manage_text(0);
+}
+
+sub end_elem {
+ my ($e) = @_;
+ $e->append_to_script('$parent = $parent->getParentNode;'."\n");
+}
+
+sub start_attr {
+ my ($e, $attrname, $default_prefix, $default_ns) = @_;
+ my($ns, $prefix, $name) = parse_namespace($attrname);
+ #$prefix = $e->generate_nsprefix($ns) if $ns and not $prefix;
+ if (not defined $ns and not defined $prefix) {
+ $ns = $default_ns; $prefix = $default_prefix;
+ }
+ $name = $prefix.':'.$name if $prefix;
+
+ if ($ns and defined $prefix) {
+
$e->append_to_script('$parent->setAttributeNS('.makeSingleQuoted($ns).','.makeSingleQuoted($name).',
""');
+ }
+ else {
+
$e->append_to_script('$parent->setAttribute('.makeSingleQuoted($name).', ""');
+ }
+ $e->manage_text(0);
+}
+
+sub end_attr {
+ my ($e) = @_;
+ $e->append_to_script(');'."\n");
+}
+
+# global variables
+# FIXME - put into $e (are we allowed to?)
+
+my %structStack = ();
+my %frame = ();
+my @globalframe = ();
+my $structStack;
+my %stacklevel = ();
+my %stackcur = ();
+
+# generic tag handler subs
+
+sub set_attribOrChild_value__open {
+ my ($e, $tag) = @_;
+ $globalframe[0]{'capture'} = 1;
+ return '$attr_'.makeVariableName($tag).' = ""';
+}
+
+sub set_attribOrChild_value : XSP_keepWhitespace {
+ return '; ';
+}
+
+my @ignore;
+sub set_childStruct_value__open {
+ my ($e, $tag, %attribs) = @_;
+ my $var = '$_{'.makeSingleQuoted($tag).'}';
+ if ($$structStack[0][0]{'param'} && exists
$$structStack[0][0]{'param'}{$tag}) {
+ $e->append_to_script('.do {
$param_'.$$structStack[0][0]{'param'}{$tag}.' = ""');
+ $globalframe[0]{'capture'} = 1;
+ return '';
+ }
+ my $desc = $$structStack[0][0]{'sub'}{$tag};
+ if (!$desc) {
+ $desc = $$structStack[0][0]{'sub'}{'*'};
+ #warn("$tag desc: ".Data::Dumper::Dumper($desc));
+ }
+ die("Tag $tag not found in childStruct specification.") if (!$desc);
+ push(@ignore, 1), return '' if ($$desc{'type'} eq '!');
+ push @ignore, 0;
+ unshift @{$$structStack[0]},$desc;
+ if ($$desc{'param'}) {
+ $e->append_to_script("{ \n");
+ foreach my $key (keys %{$$desc{'param'}}) {
+ $_ = $$desc{'param'}{$key};
+ $e->append_to_script("my \$param_$_; ");
+ $e->append_to_script("\$param_$_ =
".makeSingleQuoted($attribs{$key}).'; ')
+ if exists $attribs{$key};
+ }
+ $e->append_to_script('local ($_) = ""; ');
+ $var = '$_';
+ }
+ if ($$desc{'type'} eq '@') {
+ $e->append_to_script("$var ||= []; push [EMAIL PROTECTED], ");
+ } else {
+ $e->append_to_script("$var = ");
+ }
+ if ($$desc{'sub'}) {
+ $e->append_to_script('do {');
+ $e->append_to_script('local (%_) = (); ');
+ foreach my $attrib (keys %attribs) {
+ next if $$desc{'sub'}{$attrib}{'type'} eq '%';
+ $e->append_to_script('$_{'.makeSingleQuoted($attrib).'} = ');
+ $e->append_to_script('[ ') if $$desc{'sub'}{$attrib}{'type'} eq
'@';
+ $e->append_to_script(makeSingleQuoted($attribs{$attrib}));
+ $e->append_to_script(' ]') if $$desc{'sub'}{$attrib}{'type'} eq
'@';
+ $e->append_to_script('; ');
+ }
+ my $textname = $$desc{'sub'}{''}{'name'};
+ if ($textname) {
+ $e->append_to_script(' $_{'.makeSingleQuoted($textname).'} = ""');
+ $globalframe[0]{'capture'} = 1;
+ }
+ } else {
+ $e->append_to_script('""');
+ $globalframe[0]{'capture'} = 1;
+ }
+ return '';
+}
+
+sub set_childStruct_value {
+ my ($e, $tag) = @_;
+ if ($$structStack[0][0]{'param'} && exists
$$structStack[0][0]{'param'}{$tag}) {
+ $e->append_to_script('; }');
+ return '';
+ }
+ my $desc = $$structStack[0][0];
+ my $ignore = pop @ignore;
+ return '' if ($ignore);
+ shift @{$$structStack[0]};
+ if ($$desc{'sub'}) {
+ $e->append_to_script(' \%_; }; ');
+ }
+ if ($$desc{'param'}) {
+ my $var = '$_{'.makeSingleQuoted($tag).'}';
+ for (0..(scalar(%{$$desc{'param'}})-1)) {
+ $var .= "{\$param_$_}";
+ }
+ if ($$desc{'type'} eq '@') {
+ $e->append_to_script("$var ||= []; push [EMAIL PROTECTED], [EMAIL
PROTECTED];");
+ } else {
+ $e->append_to_script("$var = \$_;");
+ }
+ $e->append_to_script(" }\n");
+ }
+ return '';
+}
+
+sub set_XmlSmart_value__open {
+ my ($e, $tag, %attribs) = @_;
+ $dumper->Values([\%attribs]);
+ return
'XML::Smart::Tree::_Start($xml_subtree_parser,'.makeSingleQuoted($tag).','.$dumper->Dumpxs().');'."\n";
+}
+
+sub set_XmlSmart_value : XSP_captureContent {
+ my ($e, $tag) = @_;
+ return 'XML::Smart::Tree::_Char($xml_subtree_parser,$_) if
(length($_));'."\n".
+
'XML::Smart::Tree::_End($xml_subtree_parser,'.makeSingleQuoted($tag).');"";'."\n";
+}
+
+
+# code called from compiled XSP scripts
+sub parse_namespace {
+ local( $_ ) = shift;
+
+ # These forms will return ns and prefix as follows:
+ # *1. {ns}prefix:name => ns specified, prefix specified (fully specified)
+ # *2a. {ns}name => ns specified, prefix undefined (generate prefix)
+ # 2b. {ns}:name => ns specified, prefix undefined (generate prefix)
+ # *3a. prefix:name => ns undefined, prefix specified (lookup ns)
+ # 3b. {}prefix:name => ns undefined, prefix specified (lookup ns)
+ # *4a. {}name => ns is '', prefix is '' (no ns)
+ # 4b. {}:name => ns is '', prefix is '' (no ns)
+ # 4c. :name => ns is '', prefix is '' (no ns)
+ # *5. name => ns undefined, prefix undefined (default ns)
+ # The canonical forms are starred.
+ # (Note that neither a ns of '0' nor a prefix of '0' is allowed;
+ # they will be treated as empty strings.)
+
+ # The following tests can be used:
+ # if $ns and $prefix => fully specified
+ # if $ns and not $prefix => generate prefix
+ # if not $ns and $prefix => lookup ns
+ # if not $ns and defined $ns => no ns
+ # if not defined $ns and not defined $prefix => default ns
+
+ # This pattern match will almost give the desired results:
+ my ($ns, $prefix, $name) = m/^(?:{(.*)})? (?:([^:]*):)? (.*)$/x;
+
+ # These cases are fine with the pattern match:
+ # 1. {ns}prefix:name => ns specified, prefix specified
+ # 2a. {ns}name => ns specified, prefix undefined
+ # 3a. prefix:name => ns undefined, prefix specified
+ # 4b. {}:name => ns is '', prefix is ''
+ # 5. name => ns undefined, prefix undefined
+
+ # These cases need to be adjusted:
+
+ # 2b. {ns}:name => ns specified, prefix '' <= actual result
+ # 2b. {ns}:name => ns specified, prefix undefined <= desired result
+ $prefix = undef if $ns and not $prefix;
+
+ # 3b. {}prefix:name => ns '', prefix specified <= actual result
+ # 3b. {}prefix:name => ns undefined, prefix specified <= desired result
+ $ns = undef if not $ns and $prefix;
+
+ # 4a. {}name, => ns is '', prefix undefined <= actual result
+ # 4a. {}name, => ns is '', prefix is '' <= desired result
+ $prefix = '' if not $prefix and defined $ns and $ns eq '';
+
+ # 4c. :name => ns undefined, prefix is '' <= actual result
+ # 4c. :name => ns is '', prefix is '' <= desired result
+ $ns = '' if not $ns and defined $prefix and $prefix eq '';
+
+ ($ns, $prefix, $name);
+}
+
+sub _lookup_prefix {
+ my ($ns, $namespaces) = @_;
+ my $i = 0;
+ foreach my $namespace (@$namespaces) {
+ my ($nsprefix, $nsuri) = @$namespace;
+ ++$i;
+ next unless $nsuri eq $ns;
+ #$nsprefix = "stlns$i" if $nsprefix eq '' and $nsuri ne '';
+ return $nsprefix;
+ }
+ #return "stlns$i";
+ return "";
+}
+
+sub _lookup_ns {
+ my ($prefix, $namespaces) = @_;
+ $prefix ||= '';
+ my $i = 0;
+ foreach my $namespace (@$namespaces) {
+ my ($nsprefix, $nsuri) = @$namespace;
+ #++$i;
+ next unless $nsprefix eq $prefix;
+ #$nsprefix = "stlns$i" if $nsprefix eq '' and $nsuri ne '';
+ return wantarray ? ($nsuri, $nsprefix) : $nsuri;
+ }
+ my ($nsprefix, $nsuri) = @{$namespaces->[-1]}; # default namespace
+ return wantarray ? ($nsuri, $nsprefix) : $nsuri;
+}
+
+
+sub xmlize {
+ my ($document, $parent, $namespaces, @data) = @_;
+ foreach my $data (@data) {
+ if (UNIVERSAL::isa($data,'XML::LibXML::Document')) {
+ $data = $data->getDocumentElement();
+ }
+ if (UNIVERSAL::isa($data,'XML::LibXML::Node')) {
+ $document->importNode($data);
+ $parent->appendChild($data);
+ next;
+ }
+ die 'data is not a hash ref or DOM fragment!' unless ref($data) eq
'HASH';
+ while (my ($key, $val) = each %$data) {
+ my $outer_namespaces_added = 0;
+ if (substr($key,0,1) eq '@') {
+ $key = substr($key,1);
+ die 'attribute value is not a simple scalar!' if ref($val);
+ next if $key =~ m/^xmlns(?::|$)/; # already processed these
+ my ($ns, $prefix, $name) = parse_namespace($key);
+ #$prefix = _lookup_prefix($ns, $namespaces) if $ns and not
$prefix;
+ $ns = _lookup_ns($prefix, $namespaces) if not $ns and $prefix;
+ $name = $prefix.':'.$name if $prefix;
+ if ($ns and $prefix) {
+ $parent->setAttributeNS($ns,$name,$val);
+ } else {
+ $parent->setAttribute($name,$val);
+ }
+ next;
+ }
+
+ my ($ns, $prefix, $name) = parse_namespace($key);
+ $prefix = _lookup_prefix($ns, $namespaces) if $ns and not $prefix;
+ if (defined $ns) {
+ unshift @$namespaces, [ $prefix => $ns ];
+ $outer_namespaces_added++;
+ }
+ my @data = ref($val) eq 'ARRAY'? @$val:$val;
+ foreach my $data (@data) {
+ my $namespaces_added = 0;
+ if (ref($data) and ref($data) eq 'HASH') {
+ # search for namespace declarations in attributes
+ while (my ($key, $val) = each %$data) {
+ if ($key =~ m/[EMAIL PROTECTED](?::|$)(.*)/) {
+ unshift @$namespaces, [ $1 => $val ];
+ $namespaces_added++;
+ }
+ }
+ }
+
+ my $elem;
+ if (length($key)) {
+ my($nsuri, $nsprefix, $local) = ($ns, $prefix, $name);
+ ($nsuri, $nsprefix) = _lookup_ns($nsprefix, $namespaces)
if not defined $nsuri;
+ $local = $nsprefix.':'.$local if $nsprefix;
+ if ($nsuri) {
+ $elem = $document->createElementNS($nsuri,$local);
+ } else {
+ $elem = $document->createElement($local);
+ }
+ $parent->appendChild($elem);
+ } else {
+ $elem = $parent;
+ }
+
+ if (ref($data)) {
+ xmlize($document, $elem, $namespaces, $data);
+ } else {
+ my $tn = $document->createTextNode($data);
+ $elem->appendChild($tn);
+ }
+ splice(@$namespaces, 0, $namespaces_added) if
$namespaces_added; # remove added namespaces
+ }
+ splice(@$namespaces, 0, $outer_namespaces_added) if
$outer_namespaces_added; # remove added namespaces
+ }
+ }
+}
+
+# event handlers
+
+sub characters {
+ my ($e, $node) = @_;
+ my $text = $node->{'Data'};
+ if ($globalframe[0]{'ignoreWS'}) {
+ $text =~ s/^\s*//;
+ $text =~ s/\s*$//;
+ }
+ return '' if $text eq '';
+ return '.'.makeSingleQuoted($text);
+}
+
+sub start_element
+{
+ my ($e, $element) = @_;
+ my %attribs = map { $_->{'Name'} => $_->{'Value'} }
@{$element->{'Attributes'}};
+ my $tag = $element->{'Name'};
+ #warn("Element: ".join(",",map { "$_ => ".$$element{$_} } keys %$element));
+ my $ns = $element->{'NamespaceURI'};
+ my $frame = ($frame{$ns} ||= []);
+ $structStack = ($structStack{$ns} ||= []);
+ my $rtpkg = $AxKit2::Transformer::XSP::tag_lib{$ns};
+ my $pkg = $rtpkg."::Handlers";
+ my ($sub, $subOpen, $rtsub, $rtsubOpen);
+ my $attribs = {};
+ my $longtag;
+ #warn("full struct:
".serializeChildStructSpec($$structStack[0][$#{$$structStack[0]}]{'sub'})) if
$$structStack[0];
+ #warn("current node: ".$$structStack[0][0]{'name'}) if $$structStack[0];
+ #warn("rest struct:
".serializeChildStructSpec($$structStack[0][0]{'sub'})) if $$structStack[0];
+ if ($$structStack[0][0]{'param'} && exists
$$structStack[0][0]{'param'}{$tag}) {
+ $sub = \&set_childStruct_value;
+ $subOpen = \&set_childStruct_value__open;
+ } elsif ($$structStack[0][0]{'sub'} && (exists
$$structStack[0][0]{'sub'}{$tag} || exists $$structStack[0][0]{'sub'}{'*'})) {
+ my $tkey = $tag;
+ $tkey = '*' if (!exists $$structStack[0][0]{'sub'}{$tag});
+ if ($$structStack[0][0]{'sub'}{$tkey}{'sub'}) {
+ foreach my $key (keys %{$$structStack[0][0]{'sub'}{$tkey}{'sub'}})
{
+ $$attribs{$key} = $attribs{$key} if exists $attribs{$key};
+ }
+ }
+ if ($$structStack[0][0]{'sub'}{$tkey}{'param'}) {
+ foreach my $key (keys
%{$$structStack[0][0]{'sub'}{$tkey}{'param'}}) {
+ $$attribs{$key} = $attribs{$key} if exists $attribs{$key};
+ }
+ }
+ $sub = \&set_childStruct_value;
+ $subOpen = \&set_childStruct_value__open;
+ } else {
+ for my $i (0..$#{$frame}) {
+ if (exists $$frame[$i]{'vars'}{$tag}) {
+ #warn("variable: $tag");
+ $sub = \&set_attribOrChild_value;
+ $subOpen = \&set_attribOrChild_value__open;
+ last;
+ }
+ }
+ if (!$sub) {
+ my @backframes = (reverse(map{ ${$_}{'name'} } @{$frame}),$tag);
+ #warn("frames: "[EMAIL PROTECTED]", backframes:
".join(",",@backframes));
+ my $i = @backframes+1;
+ while ($i) {
+ $longtag = join('___', @backframes) || '_default';
+ shift @backframes;
+ $i--;
+ #warn("checking for $longtag");
+ if ($sub = $pkg->can(makeVariableName($longtag))) {
+ $subOpen = $pkg->can(makeVariableName($longtag)."__open");
+ }
+ if ($handlerAttributes{$rtsub} and $rtsub =
$rtpkg->can(makeVariableName($longtag))) {
+ $rtsubOpen =
$rtpkg->can(makeVariableName($longtag)."__open");
+ }
+ die("Simultaneous run-time and compile-time handlers for one
tag not supported") if $sub and $rtsub;
+ last if $sub or $rtsub;
+ }
+ }
+ }
+ if (((!$sub && !$rtsub) || $longtag eq '_default') && $frame{smart}) {
+ $sub = &set_XmlSmart_value;
+ $subOpen = &set_XmlSmart_value__open;
+ }
+ die "invalid tag: $tag (namespace: $ns, package $pkg, parents ".join(",
",map{ ${$_}{'name'} } @{$frame}).")" unless $sub or $rtsub;
+
+ my $handlerAttributes = $handlerAttributes{$sub || $rtsub};
+ if ($$handlerAttributes{'compile'}) {
+ $sub = $rtsub;
+ undef $rtsub;
+ $subOpen = $rtsubOpen;
+ undef $rtsubOpen;
+ }
+
+ if ($$handlerAttributes{'result'} == STRUCT ||
!$$handlerAttributes{'result'} ||
+ $$handlerAttributes{'result'} == NODELIST ||
+ ($$handlerAttributes{'result'} == EXPRORNODELIST &&
+ $attribs{$$handlerAttributes{'resultparam'}} eq
+ $$handlerAttributes{'resultnode'})) {
+
+ # FIXME: this can give problems with non-SimpleTaglib-taglib
interaction
+ # it must autodetect whether to use '.do' or not like xsp:expr, but as
+ # that one doesn't work reliably neither, it probably doesn't make any
+ # difference
+ $e->append_to_script('.') if ($globalframe[0]{'capture'});
+ $e->append_to_script('do { ') if ($element->{Parent});
+
+ } elsif ($$handlerAttributes{'result'} == NODE ||
+ ($$handlerAttributes{'result'} == EXPRORNODE
+ && $attribs{$$handlerAttributes{'resultparam'}} eq
+ $$handlerAttributes{'resultnode'})) {
+
+ $e->append_to_script('.') if ($globalframe[0]{'capture'});
+ $e->append_to_script('do { ');
+
start_elem($e,$$handlerAttributes{'nodename'},$$handlerAttributes{'resultattr'},$element->{'Prefix'},$ns);
+ start_expr($e,$tag);
+ } else {
@@ Diff output truncated at 30000 characters. @@
