# Copyrights 2008 by Mark Overmeer.
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 1.05.
use warnings;
use strict;
package XML::Rewrite;
use vars '$VERSION';
$VERSION = '0.10';
use base 'XML::Compile::Cache';
use Log::Report 'xml-rewrite', syntax => 'SHORT';
use XML::Compile::Util qw/pack_type type_of_node unpack_type SCHEMA2001/;
use XML::LibXML ();
sub init($)
{ my ($self, $args) = @_;
$args->{any_element} = 'ATTEMPT';
$args->{any_attribute} = 'ATTEMPT';
my $mode = $self->{XR_change} = $args->{change} || 'TRANSFORM';
$mode eq 'REPAIR' || $mode eq 'TRANSFORM'
or error __x"change mode must be either REPAIR or TRANSFORM, not `{got}'"
, got => $mode;
my $blanks = $self->{XR_blanks} = $args->{blanks_before} || 'NONE';
$blanks eq 'ALL' || $blanks eq 'CONTAINERS' || $blanks eq 'ALL'
or error __x"blanks_before must be ALL, CONTAINERS or ALL, not `{got}'"
, got => $blanks;
push @{$args->{opts_rw}}
, mixed_elements => 'STRUCTURAL'
, use_default_namespace => $args->{use_default_namespace}
, key_rewrite => 'PREFIXED';
my @read_hooks = ( {after => 'XML_NODE'} );
foreach ( @{$args->{remove_elems}} )
{ my $type = $self->findName($_) or next;
warn "REMOVE TYPE=$type not yet implemented";
}
my $comments = $args->{comments} || 'KEEP';
if($comments eq 'KEEP')
{ push @read_hooks, {after => \&take_comments_hook};
}
elsif($comments ne 'REMOVE')
{ error __x"comment option either KEEP or REMOVE, not `{got}'"
, got => $comments;
}
push @{$args->{opts_readers}}
, hooks => \@read_hooks
, any_element => ($args->{any_element} || 'CONVERT')
, default_values => 'IGNORE';
my @write_hooks = +{after => sub {$self->nodeDataRelation(@_)}};
push @{$args->{opts_writers}}
, hooks => \@write_hooks
, include_namespaces => 1
, ignore_unused_tags => qr/^_[A-Z_]*$/
, default_values => $args->{defaults_writer};
defined $args->{allow_undeclared}
or $args->{allow_undeclared} = 1;
$self->SUPER::init($args);
$self->{XR_encoding} = $args->{output_encoding};
$self->{XR_version} = $args->{output_version};
$self->{XR_alone} = $args->{output_standalone};
if(my $compr = $self->{XR_compress} = $args->{output_compression})
{ $compr >= -1 && $compr <= 8
or error __x"compression between -1 (off) and 8";
}
$self->{XR_prefixes}
= [ map { $_->{prefix} => $_->{uri} } values %{$self->{XCC_prefix}} ];
$self;
}
sub process($@)
{ my ($self, $xmldata, %args) = @_;
# avoid the schema cache!
my ($xml, %details) = XML::Compile->dataToXML($xmldata);
my $type = $args{type} || type_of_node $xml;
my $mode = $self->{XR_change};
$self->repairXML($type, $xml, \%details)
if $mode eq 'REPAIR';
my $data = $self->reader($type)->($xml);
$self->collectDocInfo($data, $xml);
$self->transformData($type, $data, \%details)
if $mode eq 'TRANSFORM';
($type, $data);
}
sub repairXML($$$)
{ my ($self, $type, $xml, $details) = @_;
trace "repairing XML";
$self->repairNamespaces($xml);
$self;
}
sub repairNamespaces($)
{ my ($self, $top) = @_;
my @kv = @{$self->{XR_prefixes}};
while(@kv)
{ my ($prefix, $uri) = (shift @kv, shift @kv);
$top->setNamespaceDeclURI($prefix, $uri)
or $top->setNamespace($uri, $prefix, 0);
$self->{XCC_prefix}{$uri}{used}++;
}
$self;
}
sub collectDocInfo($$)
{ my ($self, $data, $xml) = @_;
if(my $doc = $xml->ownerDocument)
{ my $info = $data->{_DOC_INFO} ||= {};
$info->{encoding} = $doc->encoding;
$info->{version} = $doc->version;
$info->{standalone} = $doc->standalone;
$info->{compress} = $doc->compression;
}
$data;
}
sub transformData($$$)
{ my ($self, $type, $data, $details) = @_;
trace "transforming data structure";
$self->transformDoc($data);
$data;
}
sub transformDoc($)
{ my ($self, $data) = @_;
my $di = $data->{_DOC_INFO} || {};
$di->{version} = $self->{XR_version} if $self->{XR_version};
$di->{version} ||= '1.0';
$di->{encoding} = $self->{XR_encoding} if $self->{XR_encoding};
$di->{encoding} ||= 'UTF-8';
$di->{compress} = $self->{XR_compress} if $self->{XR_compress};
my $a = defined $self->{XR_alone} ? $self->{XR_alone} : $self->{XR_alone};
if(defined $a)
{ $di->{standalone} = $a eq 'no' || $a eq '0' ? 0 : 1;
}
$self;
}
sub buildDOM($$@)
{ my ($self, $type, $data, %args) = @_;
my $di = $data->{_DOC_INFO} or panic "no doc-info";
my $doc = XML::LibXML::Document->new($di->{version}, $di->{encoding});
$self->{XR_node_data} = [];
my $out = $self->writer($type)->($doc, $data);
$doc->setDocumentElement($out) if $out;
$self->postProcess($doc, $self->{XR_node_data});
$doc->setCompression($di->{compress});
$doc->setStandalone($di->{alone}) if defined $di->{alone};
$doc;
}
sub take_comments_hook($$$)
{ my ($xml, $data, $path) = @_;
my $previous = $xml;
while($previous = $previous->previousSibling)
{ last if $previous->isa('XML::LibXML::Element');
unshift @{$data->{_COMMENT}}, $previous->textContent
if $previous->isa('XML::LibXML::Comment');
}
$data;
}
sub nodeDataRelation($$$$)
{ my ($self, $doc, $node, $path, $data) = @_;
push @{$self->{XR_node_data}}, [ $node, $data ];
$node;
}
sub postProcess($$)
{ my ($self, $doc, $r) = @_;
my $blanks = $self->{XR_blanks};
while(@$r)
{ my ($node, $data) = @{shift @$r};
my $parent = $node->parentNode;
next if $parent->isa('XML::LibXML::DocumentFragment'); # unattached
my $b = $data->{_COMMENT} || [];
my @b = map {$doc->createComment($_)} ref $b eq 'ARRAY' ? @$b : $b;
my $grannie = $parent->parentNode;
my $add_blank
= @b ? 1 # before comments
: exists $data->{_BLANK_LINE} ? $data->{_BLANK_LINE}
: $blanks eq 'NONE' ? 0
: !($grannie && $grannie->isa('XML::LibXML::Document')) ? 0
: $node->hasChildNodes ? 1
: ($blanks eq 'ALL');
unshift @b, $doc->createTextNode('')
if $add_blank;
$parent->insertBefore($_, $node) for @b;
my $a = $data->{_COMMENT_AFTER} || [];
my @a = map {$doc->createComment($_)} ref $a eq 'ARRAY' ? @$a : $a;
$parent->insertAfter($_, $node) for @a;
}
}
1;