XML-ExtOn
view release on metacpan or search on metacpan
lib/XML/ExtOn.pm view on Meta::CPAN
xmlns:ns2="http://example.org/ns2"
demons:variable2="2" ns2:var="ns1"
demons:variable1="1" ns2:raw="2"/>
Delete content of element
if ( $elem->local_name eq 'demo_delete') {
$elem->skip_content
}
XML before:
<?xml version="1.0"?>
<Document>
<demo_delete>
<p>text</p>
</demo_delete>
</Document>
After:
<?xml version="1.0"?>
<Document>
<demo_delete/>
</Document>
Add XML:
$elem->add_content (
$self->mk_from_xml('<custom><p>text</p></custom>')
)
Can add element after current
...
return [ $elem, $self->mk_element("after") ];
}
=head1 DESCRIPTION
XML::ExtOn - SAX Handler designed for funny work with XML. It
provides an easy-to-use interface for XML applications by adding objects.
XML::ExtOn override some SAX events. Each time an SAX event starts,
a method by that name prefixed with `on_' is called with the B<"blessed">
Element object to be processed.
XML::ExtOn implement the following methods:
=over
=item * on_start_document
=item * on_start_prefix_mapping
=item * on_start_element
=item * on_end_element
=item * on_characters
=item * on_cdata
=back
XML::ExtOn put all B<cdata> characters into a single event C<on_cdata>.
It compliant XML namespaces (http://www.w3.org/TR/REC-xml-names/), by support
I<default namespace> and I<namespace scoping>.
XML::ExtOn provide methods for create XML, such as C<mk_element>, C<mk_cdata> ...
=head1 FUNCTIONS
=cut
use strict;
use warnings;
use Carp;
use Data::Dumper;
use XML::SAX::Base;
use XML::ExtOn::Element;
use XML::ExtOn::Context;
use XML::ExtOn::IncXML;
use XML::Filter::SAX1toSAX2;
use XML::ExtOn::SAX12ExtOn;
use XML::Parser::PerlSAX;
use Test::More;
require Exporter;
*import = \&Exporter::import;
@XML::ExtOn::EXPORT_OK = qw( create_pipe split_pipe);
sub _get_end_handler {
my $flt = shift;
my $handler = $flt->get_handler();
return $handler if UNIVERSAL::isa( $handler, 'XML::ExtOn::Writer' );
return $handler if UNIVERSAL::isa( $handler, 'XML::SAX::Writer::XML' );
return $flt unless UNIVERSAL::isa( $handler, 'XML::SAX::Base' );
return &_get_end_handler($handler);
}
=head1 create_pipe "flt_n1",$some_handler, $out_handler
use last arg as handler for out.
return parser ref.
my $h1 = new MyHandler1::;
my $filter = create_pipe( 'MyHandler1', $h1 );
$filter->parse('<root><p>TEST</p></root>');
#also create pipe of pipes
my $filter1 = create_pipe( 'MyHandler1', 'MyHandler2' );
my $h1 = new MyHandler3::;
my $filter2 = create_pipe( $filter1, $h1);
=cut
sub create_pipe {
my @args = reverse @_;
my $out_handler;
foreach my $f (@args) {
unless ( ref($f) ) {
unless ($out_handler) {
$out_handler = $f->new();
}
else {
$out_handler = $f->new( Handler => $out_handler );
}
}
elsif ( UNIVERSAL::isa( $f, 'XML::SAX::Base' ) ) {
unless ($out_handler) {
$out_handler = $f;
}
else {
my $end_handler = &_get_end_handler($f);
$end_handler->set_handler($out_handler);
$out_handler = $f;
}
}
else {
die "$f not SAX Drv";
}
}
return $out_handler;
}
=head1 split_pipe $filter
return ref to array of filters in pipe
use XML::ExtOn qw(split_pipe create_pipe);
my $filter = create_pipe( 'MyHandler1', 'MyHandler2','MyHandler3');
my $ref = @{ split_pipe( $filter) } [-1];
isa_ok $ref, 'MyHandler3', 'check last element';
=cut
sub split_pipe {
my $filter = shift || return [];
my @res = ($filter);
# use SAXed variable see XML::SAX::Base::get_handler()
if ( my $next = $filter->{Handler} ) {
#skip special SAX handlers
unless ( UNIVERSAL::isa( $next, 'XML::SAX::Base::NoHandler' ) ) {
push @res, @{ split_pipe($next) };
}
}
return \@res;
}
use base 'XML::SAX::Base';
use vars qw( $AUTOLOAD);
$XML::ExtOn::VERSION = '0.17';
### install get/set accessors for this object.
for my $key (
qw/ context _objects_stack _cdata_mode _cdata_characters _root_stack /)
{
no strict 'refs';
*{ __PACKAGE__ . "::$key" } = sub {
my $self = shift;
$self->{___EXT_on_attrs}->{$key} = $_[0] if @_;
return $self->{___EXT_on_attrs}->{$key};
}
}
=head1 METHODS
=cut
sub new {
my $class = shift;
my $self = &XML::SAX::Base::new( $class, @_, );
$self->_objects_stack( [] );
$self->_root_stack( [] ); #init incoming stack of start end
$self->_cdata_mode(0);
my $buf;
$self->_cdata_characters( \$buf ); #setup cdata buffer
my $doc_context = new XML::ExtOn::Context::;
$self->context($doc_context);
return $self;
}
=head2 on_start_document $document
Method handle C<start_document> event. Usually override for initialaize default
variables.
sub on_start_document {
my $self = shift;
$self->{_LINKS_ARRAY} = [];
$self->SUPER::on_start_document(@_);
}
=cut
sub on_start_document {
my ( $self, $document ) = @_;
$self->SUPER::start_document($document);
}
sub start_document {
my ( $self, $document ) = @_;
return if $self->{___EXT_on_attrs}->{_skip_start_docs}++;
$self->on_start_document($document);
}
sub end_document {
my $self = shift;
my $var = --$self->{___EXT_on_attrs}->{_skip_start_docs};
return if $var;
$self->SUPER::end_document(@_);
}
=head2 on_start_prefix_mapping prefix1=>ns_uri1[, prefix2=>ns_uri2]
Called on C<start_prefix_mapping> event.
sub on_start_prefix_mapping {
my $self = shift;
my %map = @_;
$self->SUPER::start_prefix_mapping(@_)
}
=cut
sub on_start_prefix_mapping {
my $self = shift;
my %map = @_;
while ( my ( $pref, $ns_uri ) = each %map ) {
$self->add_namespace( $pref, $ns_uri );
$self->SUPER::start_prefix_mapping(
{
Prefix => $pref,
NamespaceURI => $ns_uri
}
);
}
}
#
# { Prefix => 'xlink', NamespaceURI => 'http://www.w3.org/1999/xlink' }
#
sub start_prefix_mapping {
my $self = shift;
#declare namespace for current context
my %map = ();
foreach my $ref (@_) {
my ( $prefix, $ns_uri ) = @{$ref}{qw/Prefix NamespaceURI/};
$map{$prefix} = $ns_uri;
}
$self->on_start_prefix_mapping(%map);
}
=head2 on_start_element $elem
Method handle C<on_start_element> event whith XML::ExtOn::Element object.
Method must return C<$elem> or ref to array of objects.
For example:
sub on_start_element {
my $self = shift;
my $elem = shift;
$elem->add_content( $self->mk_cdata("test"));
return $elem
}
...
return [ $elem, ,$self->mk_element("after_start_elem") ]
return [ $self->mk_element("before_start_elem"), $elem ]
...
=cut
sub on_start_element {
shift;
return [@_];
}
sub __expand_on_start {
my $self = shift;
my $obj = shift || return [];
# warn "before _expand $obj".Dumper($obj) if $obj->local_name eq 'feed';
my $res = $self->on_start_element($obj);
# warn "_expand $obj".Dumper($res , $obj) if $obj->local_name eq 'feed';
my @stack =
$res
? ref($res) eq 'ARRAY'
? @{$res}
: ($res)
: ();
#add self object
push @stack, $obj;
#expand wrap_around and insert_to
# also remove dups for $obj
my %uniq = ();
my @res = ();
foreach my $o (@stack) {
# also remove dups for $obj
next if $uniq{$o}++;
unless ( UNIVERSAL::isa( $o, 'XML::ExtOn::Element' ) ) {
#don'n touch any events
push @res, $o;
}
else {
#convert any object to events (exept $obj)
unless ( $o eq $obj ) {
push @res, $self->mk_start_element($o),
$self->mk_process_stack($o), $self->mk_end_element($o);
}
else {
#expand $insert_to
my $insert_to = $o->_wrap_begin || [];
if ( scalar @{$insert_to} ) {
for ( @{$insert_to} ) {
push @res, $self->mk_start_element($_);
}
lib/XML/ExtOn.pm view on Meta::CPAN
return;
}
}
unless ( $current_obj->is_skip_content ) {
$self->_process_comm($_) for @{ $current_obj->_stack };
$current_obj->_stack( [] );
}
unless ( $current_obj->is_delete_element ) {
# warn "$self: process end ".$current_obj->local_name;
unless ( $self->{__make_self_events} ) {
$self->SUPER::end_element($data);
}
else {
$self->{Handler}->__end_element($data);
}
}
my $changes = $current_obj->ns->get_changes;
my $parent_map = $current_obj->ns->parent->get_map;
for ( keys %$changes ) {
$self->end_prefix_mapping(
{
Prefix => $_,
NamespaceURI => $changes->{$_},
}
);
if ( exists( $parent_map->{$_} ) ) {
$self->start_prefix_mapping(
{
Prefix => $_,
NamespaceURI => $parent_map->{$_},
}
);
}
}
}
}
}
=head2 on_characters( $self->current_element, $data->{Data} )
Must return string for write to stream.
sub on_characters {
my ( $self, $elem, $str ) = @_;
#lowercase all characters
return lc $str;
}
=cut
sub on_characters {
my ( $self, $elem, $str ) = @_;
return $str;
}
=head2 on_cdata ( $current_element, $data )
Must return string for write to stream
sub on_cdata {
my ( $self, $elem, $str ) = @_;
return lc $str;
}
=cut
sub on_cdata {
my ( $self, $elem, $str ) = @_;
return $str;
}
#set flag for cdata content
sub start_cdata {
my $self = shift;
$self->_cdata_mode(1);
return;
}
#set flag to end cdata
sub end_cdata {
my $self = shift;
if ( my $elem = $self->current_element
and defined( my $cdata_buf = ${ $self->_cdata_characters } ) )
{
if ( defined( my $data = $self->on_cdata( $elem, $cdata_buf ) ) ) {
$self->SUPER::start_cdata;
$self->SUPER::characters( { Data => $data } );
$self->SUPER::end_cdata;
}
}
#after all clear cd_data_buffer and reset cd_data mode flag
my $new_buf;
$self->_cdata_characters( \$new_buf );
$self->_cdata_mode(0);
return;
}
sub characters {
my $self = shift;
my ($data) = @_;
# warn "$self do chars" . $data->{Data};
#skip childs elements characters ( > 1 ) and self text ( > 0)
if ( $self->current_element ) {
return if $self->current_element->is_skip_content;
}
else {
#skip characters without element
return;
}
#for cdata section collect characters in buffer
if ( $self->_cdata_mode ) {
# warn "$self do CDATA" . $data->{Data};
# warn " $self CDTATA" . Dumper( [ map { [ caller($_) ] } ( 0 .. 10 ) ] );
# unless defined $data;
${ $self->_cdata_characters } .= $data->{Data};
return;
}
#collect chars fo current element
if (
defined(
my $str =
$self->on_characters( $self->current_element, $data->{Data} )
)
)
{
return $self->SUPER::characters( { Data => $str } );
}
}
=head2 mk_element <tag name>
Return object of element item for include to stream.
=cut
sub mk_element {
my $self = shift;
my $name = shift;
my %args = @_;
if ( my $current_element = $self->current_element ) {
$args{context} = $current_element->ns->sub_context();
}
$args{context} ||= $self->context->sub_context();
my $elem = new XML::ExtOn::Element::
name => $name,
%args;
return $elem;
}
=head2 mk_from_xml <xml string>
Return command for include to stream.
=cut
sub mk_from_xml {
my $self = shift;
my $string = shift;
my $skip_tmp_root =
XML::ExtOn::IncXML->new( Handler => $self, __make_self_events => 1 );
my $sax2_filter = XML::Filter::SAX1toSAX2->new( Handler => $skip_tmp_root );
my $parser = XML::Parser::PerlSAX->new(
{
Handler => $sax2_filter,
Source => { String => "<tmp>$string</tmp>" },
}
);
return $parser;
}
=head2 mk_cdata $string | \$string
return command for insert cdata to stream
=cut
sub mk_cdata {
my $self = shift;
my $string = shift;
return { type => 'CDATA', data => ref($string) ? $string : \$string };
}
=head2 mk_characters $string | \$string
return command for insert characters to stream
=cut
sub mk_characters {
my $self = shift;
my $string = shift;
return { type => 'CHARACTERS', data => ref($string) ? $string : \$string };
}
=head2 mk_start_element <element object>
return command for start element event
=cut
sub mk_start_element {
my $self = shift;
my $elem = shift;
return { type => 'START_ELEMENT', data => $elem };
}
=head2 mk_event_element <element object>
return command for expand stack for element
=cut
sub mk_process_stack {
my $self = shift;
my $elem = shift;
my @objects = @{ $elem->_stack };
$elem->_stack( [] );
return { type => 'STACK', data => $elem, objects => \@objects };
}
=head2 _mk_event_start_element <element object>
return start tag command. (internal)
=cut
sub _mk_event_start_element {
my $self = shift;
my $elem = shift;
return { type => 'EV_START_ELEMENT', data => $elem };
}
=head2 _mk_event_end_element <element object>
return end tag command. (internal)
=cut
lib/XML/ExtOn.pm view on Meta::CPAN
}
=head2 current_element
Return link to current processing element.
=cut
sub current_element {
my $self = shift;
if ( my $stack = $self->_objects_stack() ) {
return $stack->[-1];
}
return;
}
=head2 current_root_element
Return link to current root element in incoming stack.
Used in start_element and end_element methods
=cut
sub current_root_element {
my $self = shift;
if ( my $stack = $self->_root_stack() ) {
return $stack->[-1];
}
return;
}
# Private method for process commands
sub _process_comm {
my $self = shift;
my $comm = shift || return;
if ( UNIVERSAL::isa( $comm, 'XML::Parser::PerlSAX' ) ) {
$comm->parse();
}
elsif ( UNIVERSAL::isa( $comm, 'XML::Parser' ) ) {
warn "parser!";
$comm->parse();
}
elsif ( UNIVERSAL::isa( $comm, 'XML::ExtOn::Element' ) ) {
# warn ref($self)."start ELEMENT " . $comm->local_name;
$self->__start_element($comm);
# while ( my $obj = shift @{ $comm->_stack } ) {
# $self->_process_comm($obj);
# }
$self->__end_element($comm);
# warn ref($self)."end ELEMENT " . $comm->local_name;
; # unless shift; #if exists extra param not end elem
}
elsif ( ref($comm) eq 'HASH' and exists $comm->{type} ) {
if ( $comm->{type} eq 'CDATA' ) {
#warn "$self : DO CDATA!!!";
$self->start_cdata;
$self->characters( { Data => ${ $comm->{data} } } );
$self->end_cdata;
}
elsif ( $comm->{type} eq 'CHARACTERS' ) {
unless ( ref( $comm->{data} ) eq 'SCALAR' ) {
warn "NOT REF" . Dumper $comm;
warn "empty" . Dumper( [ map { [ caller($_) ] } ( 0 .. 16 ) ] );
exit;
}
$self->characters( { Data => ${ $comm->{data} } } );
}
elsif ( $comm->{type} eq 'START_ELEMENT' ) {
my $current_obj = $comm->{data};
$self->__start_element( $comm->{data} );
}
elsif ( $comm->{type} eq 'END_ELEMENT' ) {
my $current_obj = $comm->{data};
$self->__end_element( $comm->{data} );
}
elsif ( $comm->{type} eq 'STACK' ) {
my $stack = $comm->{objects};
my $comm = $comm->{data};
# warn "$self: ",
# $comm->local_name . " stack: " . scalar( @{$stack} ) . Dumper(
# [
# map {
# ref($_) eq 'HASH'
# ? $_->{type} . ":" . '$_->{data}->local_name'
# : $_->local_name
# } @$stack
# ]
# );
# warn ref($self)."START PROCESS STACK ".$comm->local_name;
while ( my $obj = shift @{$stack} ) {
# warn "$self start STACK: ".$obj;
$self->_process_comm($obj);
# warn "$self end STACK: ".$obj;
}
# warn ref($self)."END PROCESS STACK ".$comm->local_name;
}
elsif ( $comm->{type} eq 'EV_START_ELEMENT' ) {
my $current_obj = $comm->{data};
# warn "$self: ev_START".$current_obj->local_name;
#register new namespaces
my $changes = $current_obj->ns->get_changes;
my $parent_map = $current_obj->ns->parent->get_map;
for ( keys %$changes ) {
$self->end_prefix_mapping(
{
Prefix => $_,
NamespaceURI => $parent_map->{$_},
}
) if exists $parent_map->{$_};
( run in 0.455 second using v1.01-cache-2.11-cpan-140bd7fdf52 )