Skip to content

Commit

Permalink
wip
Browse files Browse the repository at this point in the history
  • Loading branch information
yanick committed Jul 10, 2010
1 parent 4b9a5b3 commit d5bea38
Show file tree
Hide file tree
Showing 9 changed files with 377 additions and 15 deletions.
62 changes: 54 additions & 8 deletions lib/XML/XSS.pm
@@ -1,5 +1,6 @@
package XML::XSS;


=head1 NAME
XML::XSS - XML Stylesheet System
Expand Down Expand Up @@ -136,17 +137,26 @@ use MooseX::SemiAffordanceAccessor;
use Moose;
use MooseX::AttributeHelpers;
use MooseX::ClassAttribute;
use Moose::Exporter;

use XML::LibXML;

use XML::XSS::Element;
use XML::XSS::Document;
use XML::XSS::Text;
use XML::XSS::Comment;
use XML::XSS::ProcessingInstruction;

no warnings qw/ uninitialized /;

with qw/ MooseX::LogDispatch::Levels /;
with qw/ MooseX::LogDispatch::Levels
XML::XSS::Role::Template
/;

Moose::Exporter->setup_import_methods(
as_is => ['xsst'],
);


has log_dispatch_conf => (
is => 'ro',
Expand All @@ -165,6 +175,15 @@ has log_dispatch_conf => (

has log_level => ( is => 'rw', default => 'info' );

use overload
'.' => '_concat_overload',
'""' => sub { return ref shift };

sub _concat_overload {
my ( $self, $elt ) = @_;
return $self->get($elt);
}

=head1 ATTRIBUTES
=head2 document
Expand Down Expand Up @@ -316,6 +335,13 @@ has 'catchall_element' => (
lazy => 1,
);

has pi => (
is => 'ro',
default => sub {
XML::XSS::ProcessingInstruction->new( stylesheet => $_[0] );
},
);

=head2 stash
The stylesheet has a stash (an hashref) that is accessible to all the
Expand Down Expand Up @@ -366,7 +392,7 @@ Sets attributes for a rendering node.
The C<$name> can be
an XML element name, or one of the special keywords C<#document>,
C<#text>, C<#comment>, C<#processing_instruction> or C<*> (for the
C<#text>, C<#comment>, C<#pi> or C<*> (for the
I<catch-all> element),
which will resolve to the corresponding rendering object.
Expand All @@ -389,17 +415,34 @@ value.
sub set {
my ( $self, $name, $attrs ) = @_;

given ($name) {
when ('#document') {
$self->document->set(%$attrs);
$self->get($name)->set(%$attrs);
}

sub get {
my ( $self, $name ) = @_;

given ( $name ) {
when ( '#document' ) {
return $self->document;
}
when( '#text' ) {
return $self->text;
}
when ('*') {
$self->catchall_element->set( %$attrs );
when( '#comment' ) {
return $self->comment;
}
when( '#pi' ) {
return $self->pi;
}
when( '*' ) {
return $self->catchall_element;
}
default {
$self->element($name)->set(%$attrs);
return $self->element($name);
}
}


}

=head2 render( $xml, \%args )
Expand Down Expand Up @@ -517,6 +560,9 @@ sub resolve {
when ( 'XML::LibXML::Comment' ) {
return $self->comment;
}
when ( 'XML::LibXML::PI' ) {
return $self->pi;
}
default {
die "unknown node type: $type";
}
Expand Down
50 changes: 47 additions & 3 deletions lib/XML/XSS/Element.pm
Expand Up @@ -95,8 +95,11 @@ If set to a true value, the open and closing tags of the xml element are printed
if not, they are omited.
C<showtag> defaults to true
unless the attribute C<pre> is defined. This exception is to accomodate the
common use of C<pre> to replace the tags with something else.
unless either the attribute C<pre> or C<content> is defined.
This exception is to accomodate the
common use of C<pre> to replace the tags with something else, or
when C<content> is used to provide a templated replacement for the
element.
$css->set( 'subsection' => {
pre => '<section level="2">',
Expand Down Expand Up @@ -192,7 +195,8 @@ sub apply {
my $w = XML::Writer->new( OUTPUT => \$output );

my $showtag =
$self->has_showtag ? $self->showtag : $self->has_pre ? 0 : 1;
$self->has_showtag ? $self->showtag
: $self->has_pre || $self->has_content ? 0 : 1;

my $name;
if ($showtag) {
Expand Down Expand Up @@ -237,6 +241,46 @@ sub clone {
return bless {%$self}, ref $self;
}

use overload
'.' => '_concat_overload',
'bool' => sub { 1 };

sub _concat_overload {
my ( $self, $attr ) = @_;

my $magic = bless {
object => $self,
'method' => 'set_' . $attr,
}, 'XML::XSS::Role::RenderAttribute::Sugar';

return $magic;
}

package XML::XSS::Role::RenderAttribute::Sugar;

use XML::XSS;

use overload
'<<=' => '_set_verbatim',
'<<' => '_set_xsst',
'=' => sub { shift },
'bool' => sub { 1 };

sub _set_verbatim {
my ( $self, $value ) = @_;

my $method = $self->{'method'};
my $object = $self->{object};
$object->$method( $value );

return $self;
}

sub _set_xsst {
my ( $self, $value ) = @_;

$self <<= XML::XSS::xsst( $value );
}

1;

21 changes: 21 additions & 0 deletions lib/XML/XSS/ProcessingInstruction.pm
@@ -0,0 +1,21 @@
package XML::XSS::ProcessingInstruction;

use 5.10.0;

use Moose;
use MooseX::SemiAffordanceAccessor;

with 'XML::XSS::Role::Renderer';

no warnings qw/ uninitialized /;

sub apply {
my ( $self, $node, $args ) = @_;
$args ||= {};

return $node->toString;
}

1;


50 changes: 50 additions & 0 deletions lib/XML/XSS/Role/Template.pm
@@ -0,0 +1,50 @@
package XML::XSS::Role::Template;

use Moose::Role;

Moose::Exporter->setup_import_methods(
as_is => ['xsst'],
);

sub xsst($) {
my $template = shift;

my $code = _parse($template);

my $sub = eval <<"END_SUB";
sub {
my ( \$r, \$node, \$args ) = \@_;
local *STDOUT;
my \$output;
open STDOUT, '>', \\\$output or die;
$code;
return \$output;
}
END_SUB

die $@ if $@;

return $sub;
}

sub _parse {
my $template = shift;

my @tokens = split /(<-?%\S*|%-?>)/, $template;

my @pieces;

while( @tokens ) {
if ( $tokens[0] =~ /^<-?%/ ) {
}
else {
push @pieces, [ 1, shift @tokens ];
}
}

$template =~ s/\|/\\\|/g;

return "print q|$template|;"
}

1;
109 changes: 109 additions & 0 deletions parse.pl
@@ -0,0 +1,109 @@
#!/usr/bin/perl

use strict;
use warnings;


<% $x = 3; %>
<%= $i %>
<%~ foo/bar %>
<%@ @text %>
<%# blah blah %>
<%! foo
yadah yadah
%>

sub extract {
my ($self,$stylesheet,@includestack) = @_;

my $filename = $self->{stylesheet_dependencies}[0] || "stylesheet";

my $contents = $self->read_stylesheet( $stylesheet );

my @tokens = split /(<%[-=~#@]*|-?%>)/, $contents;

no warnings qw/ uninitialized /;

my $script;
my $line = 1;
TOKEN:
while ( @tokens ) {
my $token = shift @tokens;

if ( -1 == index $token, '<%' ) {
$line += $token =~ tr/\n//;
$token =~ s/\s+$// if -1 < index $tokens[0], '<%'
and -1 < index $tokens[0], '-';
$token =~ s/\|/\\\|/g;
# check for include
$token =~ s{<!--#include.+file=(['"])(.*?)\1.*?-->}
{ '|);'
. $self->include_file( $2, @includestack)
. 'print(q|'}seg;
$script .= 'print(q|'.$token.'|);' if length $token;

next TOKEN;
}

$script .= "\n#line $line $filename\n";

my $opening_tag = $token;
my $code;
my $closing_tag;
my $level = 1;
while( @tokens ) {
my $t = shift @tokens;
$level++ if -1 < index $t, '<%';
$level-- if -1 < index $t, '%>';
if ( $level == 0 ) {
$closing_tag = $t;
last;
}
$code .= $t;
}

die "stylesheet <% %>s are unbalanced: $opening_tag$code\n"
unless $closing_tag;

$line += $code =~ tr/\n//;

if ( -1 < index $opening_tag, '=' ) {
$script .= 'print( '.$code.' );';
}
elsif ( -1 < index $opening_tag, '~' ) {
$code =~ s/^\s+//;
$code =~ s/\s+$//;
$script .= 'print $processor->apply_templates( qq<'. $code .'> );';
}
elsif( -1 < index $opening_tag, '#' ) {
# do nothing
}
elsif( -1 < index $opening_tag, '@' ) {
$code =~ s/^\s+(\S+).*?\n//; # strip first line
my $tag = $1
or die "tag name missing in <%\@ %> at line $line\n";

my $here_delimiter = 'END_TAG';
while ( $code =~ /$here_delimiter/ ) {
$here_delimiter .= 'x';
}
$script .= <<END_SNIPPET;
\$template->set( $tag => { content => <<'$here_delimiter' } );
$code
$here_delimiter
END_SNIPPET
}
else {
# always add a ';', just in case
$script .= $code . ';';
}

if ( -1 < index $closing_tag, '-' ) {
$tokens[0] =~ s/^\s*//;
my $temp = $&;
$line += $temp =~ tr/\n//;
}
}

return $script;

5 changes: 5 additions & 0 deletions project.vim
Expand Up @@ -5,12 +5,17 @@ lib Files=lib {
XML/XSS/Text.pm
XML/XSS/Comment.pm
XML/XSS/Document.pm
XML/XSS/ProcessingInstruction.pm
XML/XSS/Role/Renderer.pm
XML/XSS/Role/RenderAttribute.pm
XML/XSS/Role/Template.pm
}
test Files=t {
basic.t
text.t
lib/XML/XSSTest.pm
lib/XML/XSS/CommentTest.pm
lib/XML/XSS/TemplateTest.pm
lib/XML/XSS/OverloadTest.pm
}
}

0 comments on commit d5bea38

Please sign in to comment.