openkylin
/
libxml-twig-perl
mirror of https://gitee.com/openkylin/libxml-twig-perl.git
9
0
Fork 0
Code Issues Projects Releases Wiki Activity

Import Upstream version 3.52

This commit is contained in:
denghao 2022-10-10 04:41:10 +03:00
commit 72d8f9c98e
251 changed files with 49419 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1650
Changes Normal file
View File

File diff suppressed because it is too large Load Diff

251
MANIFEST Normal file
View File

@ -0,0 +1,251 @@
MANIFEST
Makefile.PL
README
Changes
Twig_pm.slow
Twig.pm
Twig/XPath.pm
speedup
filter_for_5.005
check_optional_modules
tools/xml_pp/xml_pp
tools/xml_grep/xml_grep
tools/xml_spellcheck/xml_spellcheck
tools/xml_split/xml_split
tools/xml_merge/xml_merge
t/latin1_accented_char.iso-8859-1
t/test1.t
t/test2.t
t/test2_1.exp
t/test2_1.res
t/test2_1.xml
t/test2_2.dtd
t/test2_2.exp
t/test2_2.res
t/test2_2.xml
t/test2_3.res
t/test3.t
t/test4.t
t/test5.t
t/is_field.t
t/test_nav.t
t/test_additional.t
t/test_class_methods.t
t/test_class_selector.t
t/test_with_lwp.t
t/test_with_lwp.xml
t/test_with_lwp_not_wf.xml
t/test_attregexp_cond.t
t/test_xpath_cond.t
t/test_erase.t
t/test_even_more_coverage.t
t/test_keep_atts_order.t
t/test_mark.t
t/test_ignore_elts.t
t/test_cdata.t
t/test_twig_roots.t
t/test_spaces.t
t/test_simplify.t
t/test_entities.t
t/test_pi_handler.t
t/test_comment_handler.t
t/test_pos.t
t/test_variables.t
t/test_drop_comments.t
t/test_unique_xpath.t
t/dummy.dtd
t/xmlxpath_01basic.t
t/xmlxpath_02descendant.t
t/xmlxpath_03star.t
t/xmlxpath_04pos.t
t/xmlxpath_05attrib.t
t/xmlxpath_06attrib_val.t
t/xmlxpath_07count.t
t/xmlxpath_08name.t
t/xmlxpath_09a_string_length.t
t/xmlxpath_09string_length.t
t/xmlxpath_10pipe.t
t/xmlxpath_12axisdescendant.t
t/xmlxpath_13axisparent.t
t/xmlxpath_14axisancestor.t
t/xmlxpath_15axisfol_sib.t
t/xmlxpath_16axisprec_sib.t
t/xmlxpath_17axisfollowing.t
t/xmlxpath_18axispreceding.t
t/xmlxpath_19axisd_or_s.t
t/xmlxpath_20axisa_or_s.t
t/xmlxpath_21allnodes.t
t/xmlxpath_22name_select.t
t/xmlxpath_23func.t
t/xmlxpath_24namespaces.t
t/xmlxpath_25scope.t
t/xmlxpath_26predicate.t
t/xmlxpath_28ancestor2.t
t/xmlxpath_29desc_with_predicate.t
t/xmlxpath_30lang.t
t/xmlxpath_31vars.t
t/xmlxpath_test_with_handlers.t
t/xmlxpath_xpath_cond.t
t/xmlxpath_additional.t
t/xmlxpath_test_twig_roots.t
t/xmlxpath_nav.t
t/xmlxpath_test1.t
t/xmlxpath_tools.pm
t/test_errors.t
t/test_safe_encode.t
t/pod.t
t/pod_coverage.t
t/test_expand_external_entities.t
t/test_expand_external_entities.xml
t/test_expand_external_entities.dtd
t/test_need_io_scalar.t
t/test_need_use_bytes.t
t/test_need_3_args_open.t
t/test_bugs_3_15.t
t/test_bugs_3_18.t
t/test_bugs_3_19.t
t/test_bugs_3_21.t
t/test_bugs_3_22.t
t/test_error_with_unicode_layer
t/test_new_features_3_15.t
t/test_new_features_3_16.t
t/test_new_features_3_18.t
t/test_new_features_3_22.t
t/test_new_features_3_22.xml
t/test_new_features_3_22.html
t/tests_3_23.t
t/test_3_24.t
t/test_3_26.t
t/test_3_27.t
t/test_3_30.t
t/test_3_32.t
t/test_3_35.t
t/test_3_36.t
t/test_3_38.t
t/test_3_39.t
t/test_3_40.t
t/test_3_41.t
t/test_3_42.t
t/test_3_44.t
t/test_3_45.t
t/test_3_47.t
t/test_3_48.t
t/test_3_50.t
t/test_changes.t
t/test_memory.t
t/test_wrapped.t
t/test_xml_split.t
t/test_xml_split_g.t
t/test_xml_split.xml
t/test_xml_split_entities.xml
t/test_xml_split_w_decl.xml
t/test_xml_split/test_xml_split_expected-1-00.xml
t/test_xml_split/test_xml_split_expected-1-01.xml
t/test_xml_split/test_xml_split_expected-1-02.xml
t/test_xml_split/test_xml_split_expected-1-03.xml
t/test_xml_split/test_xml_split_expected-1-04.xml
t/test_xml_split/test_xml_split_expected-1-05.xml
t/test_xml_split/test_xml_split_expected-2-00.xml
t/test_xml_split/test_xml_split_expected-2-01.xml
t/test_xml_split/test_xml_split_expected-2-02.xml
t/test_xml_split/test_xml_split_expected-2-03.xml
t/test_xml_split/test_xml_split_expected-2-04.xml
t/test_xml_split/test_xml_split_expected-2-05.xml
t/test_xml_split/test_xml_split_expected-3-00.xml
t/test_xml_split/test_xml_split_expected-3-01.xml
t/test_xml_split/test_xml_split_expected-3-02.xml
t/test_xml_split/test_xml_split_expected-3-03.xml
t/test_xml_split/test_xml_split_expected-3-04.xml
t/test_xml_split/test_xml_split_expected-3-05.xml
t/test_xml_split/test_xml_split_expected-3-06.xml
t/test_xml_split/test_xml_split_expected-3-07.xml
t/test_xml_split/test_xml_split_expected-3-08.xml
t/test_xml_split/test_xml_split_expected-3-09.xml
t/test_xml_split/test_xml_split_expected-4-00.xml
t/test_xml_split/test_xml_split_expected-4-01.xml
t/test_xml_split/test_xml_split_expected-4-02.xml
t/test_xml_split/test_xml_split_expected-4-03.xml
t/test_xml_split/test_xml_split_expected-4-04.xml
t/test_xml_split/test_xml_split_expected-4-05.xml
t/test_xml_split/test_xml_split_expected-4-06.xml
t/test_xml_split/test_xml_split_expected-4-07.xml
t/test_xml_split/test_xml_split_expected-4-08.xml
t/test_xml_split/test_xml_split_expected-4-09.xml
t/test_xml_split/test_xml_split_expected-5-00.xml
t/test_xml_split/test_xml_split_expected-5-01.xml
t/test_xml_split/test_xml_split_expected-5-02.xml
t/test_xml_split/test_xml_split_expected-5-03.xml
t/test_xml_split/test_xml_split_expected-6-00.xml
t/test_xml_split/test_xml_split_expected-6-01.xml
t/test_xml_split/test_xml_split_expected-6-02.xml
t/test_xml_split/test_xml_split_expected-6-03.xml
t/test_xml_split/test_xml_split_expected-7-00.xml
t/test_xml_split/test_xml_split_expected-7-01.xml
t/test_xml_split/test_xml_split_expected-7-02.xml
t/test_xml_split/test_xml_split_expected-8-00.xml
t/test_xml_split/test_xml_split_expected-8-01.xml
t/test_xml_split/test_xml_split_expected-8-02.xml
t/test_xml_split/test_xml_split_expected-9-00.xml
t/test_xml_split/test_xml_split_expected-9-01.xml
t/test_xml_split/test_xml_split_expected-9-02.xml
t/test_xml_split/test_xml_split_expected-9-03.xml
t/test_xml_split/test_xml_split_expected-9-04.xml
t/test_xml_split/test_xml_split_expected-9-05.xml
t/test_xml_split/test_xml_split_expected-10-00.xml
t/test_xml_split/test_xml_split_expected-10-01.xml
t/test_xml_split/test_xml_split_expected-10-02.xml
t/test_xml_split/test_xml_split_expected-10-03.xml
t/test_xml_split/test_xml_split_expected-10-04.xml
t/test_xml_split/test_xml_split_expected-10-05.xml
t/test_xml_split/test_xml_split_expected-11-00.xml
t/test_xml_split/test_xml_split_expected-11-01.xml
t/test_xml_split/test_xml_split_expected-12-00.xml
t/test_xml_split/test_xml_split_expected-12-01.xml
t/test_xml_split/test_xml_split_expected-13-00.xml
t/test_xml_split/test_xml_split_expected-13-01.xml
t/test_xml_split/test_xml_split_expected-13-02.xml
t/test_xml_split/test_xml_split_expected-14-00.xml
t/test_xml_split/test_xml_split_expected-14-01.xml
t/test_xml_split/test_xml_split_expected-14-02.xml
t/test_xml_split/test_xml_split_expected-15-00.xml
t/test_xml_split/test_xml_split_expected-15-01.xml
t/test_xml_split/test_xml_split_expected-15-02.xml
t/test_xml_split/test_xml_split_expected-16-00.xml
t/test_xml_split/test_xml_split_expected-16-01.xml
t/test_xml_split/test_xml_split_expected-16-02.xml
t/test_xml_split/test_xml_split_expected-16-03.xml
t/test_xml_split/test_xml_split_expected-16-04.xml
t/test_xml_split/test_xml_split_expected-16-05.xml
t/test_xml_split/test_xml_split_expected-17-00.xml
t/test_xml_split/test_xml_split_expected-17-01.xml
t/test_xml_split/test_xml_split_expected-17-02.xml
t/test_xml_split/test_xml_split_expected-17-03.xml
t/test_xml_split/test_xml_split_expected-17-04.xml
t/test_xml_split/test_xml_split_expected-17-05.xml
t/test_xml_split/test_xml_split_expected-17-06.xml
t/test_xml_split/test_xml_split_expected-17-07.xml
t/test_xml_split/test_xml_split_expected-17-08.xml
t/test_xml_split/test_xml_split_expected-17-09.xml
t/test_xml_split/test_xml_split_expected-18-00.xml
t/test_xml_split/test_xml_split_expected-18-01.xml
t/test_xml_split/test_xml_split_expected-18-02.xml
t/test_xml_split/test_xml_split_expected-18-03.xml
t/test_xml_split/test_xml_split_expected-19-00.xml
t/test_xml_split/test_xml_split_expected-19-01.xml
t/test_xml_split/test_xml_split_expected-19-02.xml
t/test_xml_split/test_xml_split_expected-19-03.xml
t/test_xml_split/test_xml_split_expected-19-04.xml
t/test_xml_split/test_xml_split_expected-19-05.xml
t/test_xml_split/test_xml_split_expected-20-00.xml
t/test_xml_split/test_xml_split_expected-20-01.xml
t/test_xml_split/test_xml_split_expected-21-00.xml
t/test_xml_split/test_xml_split_expected-21-01.xml
t/test_xml_split/test_xml_split_expected-21-02.xml
t/test_xml_split/test_xml_split_expected-21-03.xml
t/test_autoencoding_conversion.t
t/tools.pm
t/zz_dump_config.t
t/test_kwalitee.t
t/test_meta_json.t
META.yml Module YAML meta-data (added by MakeMaker)
META.json Module JSON meta-data (added by MakeMaker)

47
META.json Normal file
View File

@ -0,0 +1,47 @@
{
"abstract" : "XML, The Perl Way",
"author" : [
"Michel Rodriguez <mirod@cpan.org>"
],
"dynamic_config" : 1,
"generated_by" : "ExtUtils::MakeMaker version 7.1001, CPAN::Meta::Converter version 2.150005",
"license" : [
"perl_5"
],
"meta-spec" : {
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
"version" : "2"
},
"name" : "XML-Twig",
"no_index" : {
"directory" : [
"t",
"inc"
]
},
"prereqs" : {
"build" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"configure" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"runtime" : {
"requires" : {
"XML::Parser" : "2.23"
}
}
},
"release_status" : "stable",
"resources" : {
"repository" : {
"url" : "http://github.com/mirod/xmltwig"
}
},
"version" : "3.52",
"x_serialization_backend" : "JSON::PP version 2.27300"
}

25
META.yml Normal file
View File

@ -0,0 +1,25 @@
---
abstract: 'XML, The Perl Way'
author:
- 'Michel Rodriguez <mirod@cpan.org>'
build_requires:
ExtUtils::MakeMaker: '0'
configure_requires:
ExtUtils::MakeMaker: '0'
dynamic_config: 1
generated_by: 'ExtUtils::MakeMaker version 7.1001, CPAN::Meta::Converter version 2.150005'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: '1.4'
name: XML-Twig
no_index:
directory:
- t
- inc
requires:
XML::Parser: '2.23'
resources:
repository: http://github.com/mirod/xmltwig
version: '3.52'
x_serialization_backend: 'CPAN::Meta::YAML version 0.018'

170
Makefile.PL Normal file
View File

@ -0,0 +1,170 @@
# $Id: /xmltwig/trunk/Makefile.PL 33 2008-04-30T08:03:41.004487Z mrodrigu $
# tool installation part shamelessly lifted from YAML's Makefile.PL
use ExtUtils::MakeMaker;
my @prompts=(
[ xml_pp => y => "XML pretty printer" ],
[ xml_grep => y => "XML grep - grep XML files using XML::Twig's subset of XPath" ],
[ xml_split => y => "split big XML files" ],
[ xml_merge => y => "merge back files created by xml_split" ],
[ xml_spellcheck => y => "spellcheck XML files skipping tags" ],
);
my @programs;
my $opt= $ARGV[0] ? $ARGV[0] : '';
if( $opt eq "-n")
{ @programs=(); }
elsif( $opt eq "-y")
{ @programs= map { $_->[0] } @prompts; }
elsif( $opt eq "-d")
{ @programs= map { $_->[0] if( $_->[1] eq 'y') } @prompts; }
elsif( $ENV{AUTOMATED_TESTING} || $ENV{NONINTERACTIVE_TESTING})
{ @programs=(); }
else
{ print "run 'perl Makefile.PL -y' to install all tools,\n",
" 'perl Makefile.PL -n' to skip installation\n";
foreach my $prompt (@prompts)
{ my ($program, $default, $description) = @$prompt;
if( prompt("Do you want to install '$program' ($description)?", $default) =~ /^y/i)
{ push(@programs, $program); }
}
}
MyWriteMakefile(
META_MERGE => {
resources => {
repository => 'http://github.com/mirod/xmltwig',
},
},
META_ADD => {
prereqs => {
build => {
requires => {
'ExtUtils::MakeMaker' => "0",
}
},
configure => {
requires => {
'ExtUtils::MakeMaker' => "0",
}
},
test => {
recommends => {
'Test' => '1.25_02',
'IO::Scalar' => '2.110',
'IO::CaptureOutput' => '1.1102',
},
suggests => {
'Test::Pod' => '1.45',
'XML::Simple' => '2.18',
'XML::Handler::YAWriter' => '0.23',
'XML::SAX::Writer' => '0.53',
'XML::Filter::BufferText' => '1.01',
},
},
runtime => {
requires => {
'XML::Parser' => '2.23',
},
recommends => {
'Scalar::Util' => '1.23',
'Encode' => '2.42_01',
'XML::XPathEngine' => '0.13',
},
suggests => {
'LWP' => '6.04',
'HTML::TreeBuilder' => '4.2',
'HTML::Entities::Numbered' => '0.04',
'HTML::Tidy' => '1.50',
'HTML::Entities' => '3.69',
'Tie::IxHash' => '1.22',
'Text::Wrap' => '2009.0305',
},
}
}
},
#BUILD_REQUIRES => {
#},
NAME => 'XML::Twig',
ABSTRACT => 'XML, The Perl Way',
AUTHOR => 'Michel Rodriguez <mirod@cpan.org>',
LICENSE => 'perl',
EXE_FILES => [ map {"tools/$_/$_"} @programs],
VERSION_FROM => 'Twig.pm',
PREREQ_PM => { 'XML::Parser' => '2.23' },
dist => { COMPRESS => 'gzip -9f',
SUFFIX => 'gz',
},
depend => { 'Twig.pm' => "FORCE\n\t\$(PERL) speedup Twig_pm.slow > Twig.pm\n\t\$(PERL) -i_bak -p filter_for_5.005 Twig.pm Twig/XPath.pm\n\t\$(PERL) check_optional_modules",
'FORCE' => '',
},
);
sub MyWriteMakefile { #Written by Alexandr Ciornii, version 0.21. Added by eumm-upgrade.
my %params=@_;
my $eumm_version=$ExtUtils::MakeMaker::VERSION;
$eumm_version=eval $eumm_version;
die "EXTRA_META is deprecated" if exists $params{EXTRA_META};
die "License not specified" if not exists $params{LICENSE};
if ($params{BUILD_REQUIRES} and $eumm_version < 6.5503) {
#EUMM 6.5502 has problems with BUILD_REQUIRES
$params{PREREQ_PM}={ %{$params{PREREQ_PM} || {}} , %{$params{BUILD_REQUIRES}} };
delete $params{BUILD_REQUIRES};
}
delete $params{CONFIGURE_REQUIRES} if $eumm_version < 6.52;
delete $params{MIN_PERL_VERSION} if $eumm_version < 6.48;
delete $params{META_MERGE} if $eumm_version < 6.46;
delete $params{META_ADD} if $eumm_version < 6.46;
delete $params{LICENSE} if $eumm_version < 6.31;
delete $params{AUTHOR} if $] < 5.005;
delete $params{ABSTRACT_FROM} if $] < 5.005;
delete $params{BINARY_LOCATION} if $] < 5.005;
WriteMakefile(%params);
add_prereqs_to_mymeta( $params{META_ADD}->{prereqs});
}
sub add_prereqs_to_mymeta
{ my $prereqs= shift;
my $MYJSON= 'MYMETA.json';
my $MYYAML= 'MYMETA.yml';
my $JSON = 'META.json';
my $YAML = 'META.yml';
rename $MYYAML, $YAML;
if( eval { require JSON; })
{ my $json= JSON->new()->pretty->canonical;
if( my $meta= eval { $json->decode( slurp( -s $MYJSON ? $MYJSON : $JSON )); })
{ $meta->{prereqs}= $prereqs;
spit( $JSON, $json->encode( $meta));
warn "updated prereqs in $JSON\n";
}
}
}
sub slurp
{ my( $file)= @_;
my $in;
open( $in, "<$file") or return ''; # can't use fancy open so this works in 5.005
local undef $/;
return <$in>;
}
sub spit
{ my $file= shift;
my $out;
open( $out, ">$file") or ( warn "cannot update $file: $!" && return);
print {$out} @_;
}

107
README Normal file
View File

@ -0,0 +1,107 @@
NAME
XML::Twig - Tree interface to XML documents allowing processing chunk
by chunk of huge documents.
SUMMARY (see perldoc XML::Twig for full details)
XML::Twig is (yet another!) XML transformation module.
Its strong points: can be used to process huge documents while still
being in tree mode; not bound by DOM or SAX, so it is very perlish and
offers a very comprehensive set of methods; simple to use; DWIMs as
much as possible
What it doesn't offer: full SAX support (it can export SAX, but only
reads XML), full XPath support (unless you use XML::Twig::XPath), nor
DOM support.
Other drawbacks: it is a big module, and with over 500 methods available
it can be a bit overwhelming. A good starting point is the tutorial at
http://xmltwig.org/xmltwig/tutorial/index.html. In fact the whole
XML::Twig page at http://xmltwig.org/xmltwig/ has plenty of information
to get you started with XML::Twig
TOOLS
XML::Twig comes with a few tools built on top of it:
xml_pp XML pretty printer
xml_grep XML grep - grep XML files using XML::Twig's subset of XPath
xml_split split big XML files
xml_merge merge back files created by xml_split
xml_spellcheck spellcheck XML files skipping tags
Running perl Makefile.PL will prompt you for each tool installation.
perl Makefile.PL -y will install all of the tools without prompt
perl Makefile.PL -n will skip the installation of the tools
SYNOPSYS
single-tree mode
my $t= XML::Twig->new();
$t->parsefile( 'doc.xml');
$t->print;
chunk mode
# print the document, at most one full section is loaded in memory
my $t= XML::Twig->new( twig_handlers => { section => \&flush});
$t->parsefile( 'doc.xml');
$t->flush;
sub flush { (my $twig, $section)= @_; $twig->flush; }
sub-tree mode
# print all section title's in the document,
# all other elements are ignored (and not stored)
my $t= XML::Twig->new(
twig_roots => { 'section/title' => sub { $_->print, "\n" } }
);
$t->parsefile( 'doc.xml');
INSTALLATION
perl Makefile.PL
make
make test
make install
DEPENDENCIES
XML::Twig needs XML::Parser (and the expat library) installed
Modules that can enhance XML::Twig are:
Scalar::Util or WeakRef
to avoid memory leaks
Encode or Text::Iconv or Unicode::Map8 and Unicode::Strings
to do encoding conversions
Tie::IxHash
to use the keep_atts_order option
XML::XPathEngine
to use XML::Twig::XPath
LWP
to use parseurl
HTML::Entities
to use the html_encode filter
HTML::TreeBuilder
to process HTML instead of XML
CHANGES
See the Changes file
AUTHOR
Michel Rodriguez (mirod@cpan.org)
The Twig page is at http://www.xmltwig.org/xmltwig
git project repository: http://github.com/mirod/xmltwig
See the XML::Twig tutorial at http://www.xmltwig.org/xmltwig/tutorial/index.html
COPYRIGHT
Copyright (c) 1999-2012, Michel Rodriguez. All Rights Reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

14352
Twig.pm Normal file
View File

File diff suppressed because it is too large Load Diff

260
Twig/XPath.pm Normal file
View File

@ -0,0 +1,260 @@
# $Id: /xmltwig/trunk/Twig/XPath.pm 32 2008-01-18T13:11:52.128782Z mrodrigu $
package XML::Twig::XPath;
use strict;
use warnings;
use XML::Twig;
my $XPATH; # XPath engine (XML::XPath or XML::XPathEngine);
my $XPATH_NUMBER; # <$XPATH>::Number, the XPath number class
BEGIN
{ foreach my $xpath_engine ( qw( XML::XPathEngine XML::XPath) )
{ if( XML::Twig::_use( $xpath_engine) ) { $XPATH= $xpath_engine; last; } }
unless( $XPATH) { die "cannot use XML::Twig::XPath: neither XML::XPathEngine 0.09+ nor XML::XPath are available"; }
$XPATH_NUMBER= "${XPATH}::Number";
}
use vars qw($VERSION);
$VERSION="0.02";
BEGIN
{ package # hide from PAUSE
XML::XPath::NodeSet;
no warnings; # to avoid the "Subroutine sort redefined" message
# replace the native sort routine by a Twig'd one
sub sort
{ my $self = CORE::shift;
@$self = CORE::sort { $a->node_cmp( $b) } @$self;
return $self;
}
package # hide from PAUSE
XML::XPathEngine::NodeSet;
no warnings; # to avoid the "Subroutine sort redefined" message
# replace the native sort routine by a Twig'd one
sub sort
{ my $self = CORE::shift;
@$self = CORE::sort { $a->node_cmp( $b) } @$self;
return $self;
}
}
package XML::Twig::XPath;
use base 'XML::Twig';
my $XP; # the global xp object;
sub to_number { return $XPATH_NUMBER->new( $_[0]->root->text); }
sub new
{ my $class= shift;
my $t= XML::Twig->new( elt_class => 'XML::Twig::XPath::Elt', @_);
$t->{twig_xp}= $XPATH->new();
bless $t, $class;
return $t;
}
sub set_namespace { my $t= shift; $t->{twig_xp}->set_namespace( @_); }
sub set_strict_namespaces { my $t= shift; $t->{twig_xp}->set_strict_namespaces( @_); }
sub node_cmp($$) { return $_[1] == $_[0] ? 0 : -1; } # document is before anything but itself
sub isElementNode { 0 }
sub isAttributeNode { 0 }
sub isTextNode { 0 }
sub isProcessingInstructionNode { 0 }
sub isPINode { 0 }
sub isCommentNode { 0 }
sub isNamespaceNode { 0 }
sub getAttributes { [] }
sub getValue { return $_[0]->root->text; }
sub findnodes { my( $t, $path)= @_; return $t->{twig_xp}->findnodes( $path, $t); }
sub findnodes_as_string { my( $t, $path)= @_; return $t->{twig_xp}->findnodes_as_string( $path, $t); }
sub findvalue { my( $t, $path)= @_; return $t->{twig_xp}->findvalue( $path, $t); }
sub exists { my( $t, $path)= @_; return $t->{twig_xp}->exists( $path, $t); }
sub find { my( $t, $path)= @_; return $t->{twig_xp}->find( $path, $t); }
sub matches { my( $t, $path, $node)= @_; $node ||= $t; return $t->{twig_xp}->matches( $node, $path, $t) || 0; }
sub getNamespaces { $_[0]->root->getNamespaces(); }
#TODO: it would be nice to be able to pass in any object in this
#distribution and cast it to the proper $XPATH class to use as a
#variable (via 'nodes' argument or something)
sub set_var {
my ($t, $name, $value) = @_;
if( ! ref $value) { $value= $t->findnodes( qq{"$value"}); }
$t->{twig_xp}->set_var($name, $value);
}
1;
# adds the appropriate methods to XML::Twig::Elt so XML::XPath can be used as the XPath engine
package XML::Twig::XPath::Elt;
use base 'XML::Twig::Elt';
*getLocalName= *XML::Twig::Elt::local_name;
*getValue = *XML::Twig::Elt::text;
sub isAttributeNode { 0 }
sub isNamespaceNode { 0 }
sub to_number { return $XPATH_NUMBER->new( $_[0]->text); }
sub getAttributes
{ my $elt= shift;
my $atts= $elt->atts;
# alternate, faster but less clean, way
my @atts= map { bless( { name => $_, value => $atts->{$_}, elt => $elt },
'XML::Twig::XPath::Attribute')
}
sort keys %$atts;
# my @atts= map { XML::Twig::XPath::Attribute->new( $elt, $_) } sort keys %$atts;
return wantarray ? @atts : \@atts;
}
sub getNamespace
{ my $elt= shift;
my $prefix= shift() || $elt->ns_prefix;
if( my $expanded= $elt->namespace( $prefix))
{ return XML::Twig::XPath::Namespace->new( $prefix, $expanded); }
else
{ return XML::Twig::XPath::Namespace->new( $prefix, ''); }
}
# returns namespaces declared in the element
sub getNamespaces #_get_namespaces
{ my( $elt)= @_;
my @namespaces;
foreach my $att ($elt->att_names)
{ if( $att=~ m{^xmlns(?::(\w+))?$})
{ my $prefix= $1 || '';
my $expanded= $elt->att( $att);
push @namespaces, XML::Twig::XPath::Namespace->new( $prefix, $expanded);
}
}
return wantarray() ? @namespaces : \@namespaces;
}
sub node_cmp($$)
{ my( $a, $b)= @_;
if( UNIVERSAL::isa( $b, 'XML::Twig::XPath::Elt'))
{ # 2 elts, compare them
return $a->cmp( $b);
}
elsif( UNIVERSAL::isa( $b, 'XML::Twig::XPath::Attribute'))
{ # elt <=> att, compare the elt to the att->{elt}
# if the elt is the att->{elt} (cmp return 0) then -1, elt is before att
return ($a->cmp( $b->{elt}) ) || -1 ;
}
elsif( UNIVERSAL::isa( $b, 'XML::Twig::XPath'))
{ # elt <=> document, elt is after document
return 1;
}
else
{ die "unknown node type ", ref( $b); }
}
sub getParentNode
{ return $_[0]->_parent
|| $_[0]->twig;
}
sub findnodes { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->findnodes( $path, $elt); }
sub findnodes_as_string { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->findnodes_as_string( $path, $elt); }
sub findvalue { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->findvalue( $path, $elt); }
sub exists { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->exists( $path, $elt); }
sub find { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->find( $path, $elt); }
sub matches { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->matches( $elt, $path, $elt->getParentNode) || 0; }
1;
# this package is only used to allow XML::XPath as the XPath engine, otherwise
# attributes are just attached to their parent element and are not considered objects
package XML::Twig::XPath::Attribute;
sub new
{ my( $class, $elt, $att)= @_;
return bless { name => $att, value => $elt->att( $att), elt => $elt }, $class;
}
sub getValue { return $_[0]->{value}; }
sub getName { return $_[0]->{name} ; }
sub getLocalName { (my $name= $_[0]->{name}) =~ s{^.*:}{}; $name; }
sub string_value { return $_[0]->{value}; }
sub to_number { return $XPATH_NUMBER->new( $_[0]->{value}); }
sub isElementNode { 0 }
sub isAttributeNode { 1 }
sub isNamespaceNode { 0 }
sub isTextNode { 0 }
sub isProcessingInstructionNode { 0 }
sub isPINode { 0 }
sub isCommentNode { 0 }
sub toString { return qq{$_[0]->{name}="$_[0]->{value}"}; }
sub getNamespace
{ my $att= shift;
my $prefix= shift();
if( ! defined( $prefix))
{ if($att->{name}=~ m{^(.*):}) { $prefix= $1; }
else { $prefix=''; }
}
if( my $expanded= $att->{elt}->namespace( $prefix))
{ return XML::Twig::XPath::Namespace->new( $prefix, $expanded); }
}
sub node_cmp($$)
{ my( $a, $b)= @_;
if( UNIVERSAL::isa( $b, 'XML::Twig::XPath::Attribute'))
{ # 2 attributes, compare their elements, then their name
return ($a->{elt}->cmp( $b->{elt}) ) || ($a->{name} cmp $b->{name});
}
elsif( UNIVERSAL::isa( $b, 'XML::Twig::XPath::Elt'))
{ # att <=> elt : compare the att->elt and the elt
# if att->elt is the elt (cmp returns 0) then 1 (elt is before att)
return ($a->{elt}->cmp( $b) ) || 1 ;
}
elsif( UNIVERSAL::isa( $b, 'XML::Twig::XPath'))
{ # att <=> document, att is after document
return 1;
}
else
{ die "unknown node type ", ref( $b); }
}
*cmp=*node_cmp;
1;
package XML::Twig::XPath::Namespace;
sub new
{ my( $class, $prefix, $expanded)= @_;
bless { prefix => $prefix, expanded => $expanded }, $class;
}
sub isNamespaceNode { 1; }
sub getPrefix { $_[0]->{prefix}; }
sub getExpanded { $_[0]->{expanded}; }
sub getValue { $_[0]->{expanded}; }
sub getData { $_[0]->{expanded}; }
sub node_cmp($$)
{ my( $a, $b)= @_;
if( UNIVERSAL::isa( $b, 'XML::Twig::XPath::Namespace'))
{ # 2 attributes, compare their elements, then their name
return $a->{prefix} cmp $b->{prefix};
}
else
{ die "unknown node type ", ref( $b); }
}
*cmp=*node_cmp;
1

14352
Twig_pm.slow Normal file
View File

File diff suppressed because it is too large Load Diff

33
check_optional_modules Normal file
View File

@ -0,0 +1,33 @@
#!/bin/perl -w
# $Id: /xmltwig/trunk/check_optional_modules 4 2007-03-16T12:16:25.259192Z mrodrigu $
use strict;
exit if( $] >= 5.008);
if( $] >= 5.0060)
{ unless( eval 'require Scalar::Util' or eval 'require WeakRef' )
{ warn "Neither Scalar::Util nor WeakRef is installed. ",
"Installing one of these modules would improve ",
"XML::Twig memory management and eliminate memory ",
"leaks when re-using twigs.\n";
}
else
{ warn "weaken is available\n"; }
}
unless( eval 'require Text::Iconv')
{ my $version= `iconv -V` || '';
if($version)
{ warn "The iconv library was found on your system ",
"but the Text::Iconv module is not installed. ",
"Installing Text::Iconv would make character ",
"encoding translations fast and efficient.\n";
}
else
{ warn "Did not find iconv\n"; }
}
else
{ warn "Text::Iconv is installed\n"; }

3
filter_for_5.005 Normal file
View File

@ -0,0 +1,3 @@
# $Id: /xmltwig/trunk/filter_for_5.005 4 2007-03-16T12:16:25.259192Z mrodrigu $
if( $] < 5.006) { s{^(\s*)no warnings;}{$1# no warnings;}; }
else { s{^(\s*)# no warnings; }{$1no warnings;}; }

98
speedup Normal file
View File

@ -0,0 +1,98 @@
#!/usr/bin/perl
my $FIELD = join( '|', qw( parent first_child last_child prev_sibling next_sibling pcdata cdata ent data target cdata pcdata comment flushed));
my $PRIVATE = join( '|', qw( parent first_child last_child prev_sibling next_sibling pcdata cdata comment
extra_data_in_pcdata extra_data_before_end_tag
)
); # _$private is inlined
my $FORMER = join( '|', qw( parent prev_sibling next_sibling)); # former_$former is inlined
my $SET_FIELD = join( '|', qw( first_child next_sibling ent data pctarget comment flushed));
my $SET_NOT_EMPTY= join( '|', qw( pcdata cdata comment)); # set the field
# depending on the version of perl use either qr or ""
print STDERR "perl version is $]\n";
my $var= '(\$[a-z_]+(?:\[\d\])?|\$t(?:wig)?->root|\$t(?:wig)?->twig_current|\$t(?:wig)?->\{\'?twig_root\'?\}|\$t(?:wig)?->\{\'?twig_current\'?\})';
my $set_to = '(?:undef|\$\w+|\$\w+->\{\w+\}|\$\w+->\w+|\$\w+->\w+\([^)]+\))';
my $elt = '\$(?:elt|new_elt|child|cdata|ent|_?parent|twig_current|next_sibling|first_child|prev_sibling|last_child|ref|elt->_parent)';
my %gi2index=( '', 0, PCDATA => 1, CDATA => 2, PI => 3, COMMENT => 4, ENT => 5);
(my $version= $])=~ s{\.}{}g;
while( <>)
{
if( $] <= 5.005) { s{qr/(.*?)/}{"$1"} };
# when finding a comment # perl > 5.8 or # perl < 5.5, process accordingly
if( my( $op, $v, $mv)= m{#\s*(>|<|>=|<=)\s*perl\s*5\.(\d+)(?:\.(\d+))?\s*})
{ $v= sprintf( "5%03d%03d", $v, $mv || 0);
my $comp= "$version $op $v";
if( ! eval $comp) { print "#$_"; next; }
else { s{#[^#]*\n}{\n} if m{^=encoding}; }
}
if( /=/)
{ s/$var->_children/do { my \$elt= $1; my \@children=(); my \$child= \$elt->_first_child; while( \$child) { push \@children, \$child; \$child= \$child->_next_sibling; } \@children; }/; }
s/$var->set_gi\(\s*(PCDATA|CDATA|PI|COMMENT|ENT)\s*\)/$1\->{gi}= $gi2index{$2}/;
s/$var->del_(twig_current)/delete $1\->{'$2'}/g;
s/$var->set_(twig_current)/$1\->{'$2'}=1/g;
s/$var->_del_(flushed)/delete $1\->{'$2'}/g;
s/$var->_set_(flushed)/$1\->{'$2'}=1/g;
s/$var->_(flushed)/$1\->{'$2'}/g;
s/$var->set_($SET_FIELD)\(([^)]*)\)/$1\->\{$2\}= $3/g;
s/$var->($FIELD)\b(?!\()/$1\->\{$2\}/g;
#s/$var->_($PRIVATE)\b(?!\()/$1\->\{$2\}/g;
s/$var->_($PRIVATE)\b(\s*\(\s*\))?(?!\s*\()/$1\->\{$2\}/g;
s{($elt)->former_($FORMER)}{($1\->{former} && $1\->{former}\->{$2})}g;
s{($elt)->set_(parent|prev_sibling)\(\s*($set_to)\s*\)}{$1\->\{$2\}=$3; if( \$XML::Twig::weakrefs) { weaken( $1\->\{$2\});} }g;
s{($elt)->set_(first_child)\(\s*($set_to)\s*\)}{ $1\->set_not_empty; $1\->\{$2\}=$3; }g;
s{($elt)->set_(next_sibling)\(\s*($set_to)\s*\)}{ $1\->\{$2\}=$3; }g;
s{($elt)->set_(last_child)\(\s*($set_to)\s*\)}{ $1\->set_not_empty; $1\->\{$2\}=$3; if( \$XML::Twig::weakrefs) { weaken( $1\->\{$2\});} }g;
s/$var->atts/$1\->{att}/g;
s/$var->append_(pcdata|cdata)\(([^)]*)\)/$1\->\{$2\}.= $3/g;
s/$var->set_($SET_NOT_EMPTY)\(([^)]*)\)/$1\->\{$2\}= (delete $1->\{empty\} || 1) && $3/g;
s/$var->_set_($SET_NOT_EMPTY)\s*\(([^)]*)\)/$1\->{$2}= $3/g;
s/(\$[a-z][a-z_]*(?:\[\d\])?)->gi/\$XML::Twig::index2gi\[$1\->{'gi'}\]/g;
s/$var->id/$1\->{'att'}->{\$ID}/g;
s/$var->att\(\s*([^)]+)\)/$1\->{'att'}->\{$2\}/g;
s/(\$[a-z][a-z_]*(?:\[\d\])?)->is_pcdata/(exists $1\->{'pcdata'})/g;
s/(\$[a-z][a-z_]*(?:\[\d\])?)->is_cdata/(exists $1\->{'cdata'})/g;
s/$var->is_pi/(exists $1\->{'target'})/g;
s/$var->is_comment/(exists $1\->{'comment'})/g;
s/$var->is_ent/(exists $1\->{'ent'})/g;
s/(\$,a-z][a-z_]*(?:\[\d\])?)->is_text/((exists $1\->{'pcdata'}) || (exists $1\->{'cdata'}))/g;
s/$var->is_empty/$1\->{'empty'}/g;
s/$var->set_empty(?:\(([^)]*)\))?(?!_)/"$1\->{empty}= " . ($2 || 1)/ge;
s/$var->set_not_empty/delete $1\->{empty}/g;
#s/$var->set_not_empty/delete $1\->{empty}/g;
s/$var->_is_private/( (substr( \$XML::Twig::index2gi\[$1\->{'gi'}\], 0, 1) eq '#') && (substr( \$XML::Twig::index2gi\[$1\->{'gi'}\], 0, 9) ne '#default:') )/g;
#s/_is_private_name\(\s*$var\s*\)/( (substr( $1, 0, 1) eq '#') && (substr( $1, 0, 9) ne '#default:') )/g;
s/_is_private_name\(\s*$var\s*\)/( $1=~ m{^#(?!default:)} )/g;
s{_is_fh\(\s*$var\)}{isa( $1, 'GLOB') || isa( $1, 'IO::Scalar')}g;
# $var->set_gi( $gi): set the gi, but if it doesn't exist, call the original set_gi
s/$var->set_gi\s*\(\s*([^)]*)\s*\)/$1\->{gi}=\$XML::Twig::gi2index{$2} or $1->set_gi( $2)/g;
s/$var->xml_string/$1->sprint( 1)/g;
print $_ ;
}

9
t/dummy.dtd Normal file
View File

@ -0,0 +1,9 @@
<!ELEMENT doc (elt1|elt2|elt3)*>
<!ELEMENT elt1 (#PCDATA)>
<!ELEMENT elt2 (#PCDATA)>
<!ELEMENT elt3 (#PCDATA)>
<!ENTITY ent1 "[text of ent1]">
<!ENTITY ent2 "[text of ent2]">
<!ENTITY ent3 "[text of ent3]">
<!ENTITY ent4 "[text of ent4]">
<!ENTITY ent5 "[text of ent5]">

58
t/is_field.t Executable file
View File

@ -0,0 +1,58 @@
#!/usr/bin/perl -w
use strict;
use XML::Twig;
$|=1;
my $i=1;
my $TMAX=43; # do not forget to update!
print "1..$TMAX\n";
print "ok $i\n"; # loading
$i++;
my $t= XML::Twig->new();
$t->parse( \*DATA);
foreach my $elt ($t->descendants)
{ if( ($elt->tag eq 'field') && !$elt->is_field)
{ print "not ok $i ";
warn $elt->id, " not recognized as field\n";
}
elsif( ($elt->tag ne 'field') && $elt->is_field)
{ print "not ok $i ";
my $elt_id= $elt->id || $elt->text;
warn " $elt_id recognized as field\n";
}
else
{ print "ok $i\n"; }
$i++;
}
exit 0;
__DATA__
<not_field id="n1">
<field id="f1"> field 1 </field>
<not_field id="n2"> <field id="f2"/></not_field>
<not_field id="n3"> text 1 <field id="f3"/> text 2</not_field>
<not_field id="n4"> text 3 <field id="f4">field 2</field> text 4</not_field>
<not_field id="n5"> text 5<field id="f5">field</field></not_field>
<field id="f6"> field 3 </field>
<not_field id="n6"><field id="f7">field 4</field></not_field>
<not_field id="n7"><field id="f8">field 5</field><field id="f9">field 6</field></not_field>
<not_field id="n8">
<not_field id="n9"><field id="f10">field 7</field></not_field>
<field id="f11">field 8</field>
</not_field>
<field id="f12">field 9</field>
<field id="f13">0</field>
<field id="f14"><!-- still a field --></field>
<field id="f15">a <!-- still a field --> field 10</field>
</not_field>

1
t/latin1_accented_char.iso-8859-1 Normal file
View File

@ -0,0 +1 @@
<EFBFBD>

13
t/pod.t Executable file
View File

@ -0,0 +1,13 @@
#!/usr/bin/perl
use strict;
use warnings;
if( ! $ENV{TEST_AUTHOR} ) { print "1..1\nok 1\n"; warn "Author test. Set \$ENV{TEST_AUTHOR} to a true value to run.\n"; exit; }
eval "use Test::Pod 1.00";
if( $@) { print "1..1\nok 1\n"; warn "skipping, Test::Pod required\n"; }
else { all_pod_files_ok( ); }
exit 0;

14
t/pod_coverage.t Executable file
View File

@ -0,0 +1,14 @@
#!/usr/bin/perl
use strict;
use warnings;
if( ! $ENV{TEST_AUTHOR} ) { print "1..1\nok 1\n"; warn "Author test. Set \$ENV{TEST_AUTHOR} to a true value to run.\n"; exit; }
eval "use Test::Pod::Coverage 1.00 tests => 1";
if( $@)
{ print "1..1\nok 1\n";
warn "Test::Pod::Coverage 1.00 required for testing POD coverage";
exit;
}
pod_coverage_ok( "XML::Twig", { trustme => [ 'isa' ] });

369
t/test1.t Executable file
View File

@ -0,0 +1,369 @@
#!/usr/bin/perl -w
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,'t');
use tools;
# This just tests a complete twig, no callbacks
$|=1;
use XML::Twig;
my $doc='<?xml version="1.0" standalone="no"?>
<!DOCTYPE doc [
<!NOTATION gif PUBLIC "gif">
<!ENTITY e1 SYSTEM "e1.gif" NDATA gif>
<!ENTITY e2 SYSTEM "e2.gif" NDATA gif>
<!ENTITY e3 \'internal entity\'>
]>
<doc id="doc1">
<section id="section1">
<intro id="intro1">
<para id="paraintro1">S1 I1</para>
<para id="paraintro2">S1 I2</para>
</intro>
<title no="1" id="title1">S1 Title</title>
<para id="para1">S1 P1</para>
<para id="para2">S2 P2</para>
<note id="note1">
<para id="paranote1">Note P1</para>
</note>
<para id="para3">S1 <xref refid="section2"/>para 3</para>
</section>
<section id="section2">
<intro id="intro2">
<para id="paraintro3">S2 intro</para>
</intro>
<title no="2" id="title2">S2 Title</title>
<para id="para4">S2 P1</para>
<para id="para5">S2 P2</para>
<para id="para6">S2 P3</para>
</section>
<annex id="annex1">
<title no="A" id="titleA">Annex Title</title>
<para id="paraannex1">Annex P1</para>
<para id="paraannex2">Annex P2</para>
</annex>
</doc>';
my $TMAX=97; # don't forget to update!
print "1..$TMAX\n";
# test twig creation
my $t= new XML::Twig();
ok( $t, 'twig creation');
# test parse
$t->parse( $doc, ErrorContext=>2);
ok( $t, 'parse');
# test the root
my $root= $t->root;
etest( $t->root, 'doc', 'doc1', 'root');
# print in a file
open( TMP, '>tmp');
select TMP;
$t->print();
$root->print();
select STDOUT;
$t->print( \*TMP);
$root->print( \*TMP);
ok( 'ok', "print");
# test the element root and twig functions on the root
ok( $root->twig, 'root->twig');
etest( $root->root,
'doc', 'doc1', 'root->root');
# navigation
my $section1=
etest( $root->first_child,
'section', 'section1', 'first_child');
my $annex=
etest( $root->first_child( 'annex'),
'annex', 'annex1', 'first_child( annex)');
etest( $root->last_child,
'annex', 'annex1', 'last_child');
my $section2=
etest( $root->last_child( 'section'),
'section', 'section2', 'last_child( section)');
etest( $section2->prev_sibling,
'section', 'section1', 'prev_sibling');
etest( $section1->next_sibling,
'section', 'section2', 'next_sibling');
my $note=
etest( $root->next_elt( 'note'),
'note', 'note1', 'next_elt( note)');
etest( $note->root,
'doc', 'doc1', 'root');
ok( $note->twig, 'twig');
etest( $note->twig->root,
'doc', 'doc1', 'twig->root');
# playing with next_elt and prev_elt
my $para2=
etest( $note->prev_sibling,
'para', 'para2', 'prev_sibling');
etest( $note->prev_elt( 'para'),
'para', 'para2', 'prev_elt( para)');
my $para3=
etest( $note->next_sibling,
'para', 'para3', 'next_sibling');
my $paranote1=
etest( $note->next_elt( 'para'),
'para', 'paranote1', 'next_elt( para)');
etest( $paranote1->next_elt( 'para'),
'para', 'para3', 'next_elt( para)');
# difference between next_sibling and next_sibling( gi)
etest( $para2->next_sibling,
'note', 'note1', 'next_sibling');
etest( $para2->next_sibling( 'para'),
'para', 'para3', 'next_sibling( para)');
# testing in/parent/in_context
ok( $paranote1->in( $note), 'in');
ok( $paranote1->in( $section1), 'in');
ok( !$paranote1->in( $section2), 'not in');
ok( $paranote1->in_context( 'note'), 'in_context');
ok( $paranote1->in_context( 'section'), 'in_context');
ok( !$paranote1->in_context( 'intro'), 'not in_context');
etest( $paranote1->parent,
'note', 'note1', 'parent');
# testing list methods (ancestors/children)
stest( (join ":", map { $_->id} $paranote1->ancestors),
'note1:section1:doc1', 'ancestors');
stest( (join ":", map { $_->id} $paranote1->ancestors('section')),
'section1', 'ancestors( section)');
stest( (join ":", map { $_->id} $section1->children),
'intro1:title1:para1:para2:note1:para3', 'children');
stest( (join ":", map { $_->id} $section1->children( 'para')),
'para1:para2:para3', 'children( para)');
stest( $paranote1->level, 3, 'level');
# testing attributes
my $title1=
etest( $root->next_elt( 'title'),
'title', 'title1', 'next_elt( title)');
stest( $title1->id, 'title1', 'id');
stest( $title1->att('id'), 'title1', 'att( id)');
stest( $title1->att('no'), '1', 'att( no)');
$title1->set_att('no', 'Auto');
stest( $title1->att('no'), 'Auto', 'set att( no)');
$title1->set_att('no', '1');
$title1->set_att('newatt', 'newval');
stest( $title1->att('newatt'), 'newval', 'set att( newval)');
$title1->del_att('newatt');
stest( stringifyh( %{$title1->atts}), 'id:title1:no:1', 'del_att');
$title1->set_att('id', 'newid');
stest( $title1->id, 'newid', 'set_att(id)');
stest( $title1->att( 'id'), 'newid', 'set_att(id)');
$title1->set_id( 'title1');
stest( $title1->id, 'title1', 'set_id');
stest( $title1->att( 'id'), 'title1', 'set_id');
stest( stringifyh( %{$title1->atts}), 'id:title1:no:1', 'atts');
$title1->del_atts;
stest( $title1->att( 'id'), '', 'del_atts');
$title1->set_atts( { 'no' => '1', 'id' => 'newtitleid'});
stest( stringifyh( %{$title1->atts}), 'id:newtitleid:no:1', 'set_atts');
stest( $title1->id, 'newtitleid', 'id');
stest( $title1->att('id'), 'newtitleid', 'att( id)');
$title1->set_id( 'title1');
# now let's cut and paste
$title1->cut;
stest( (join ":", map { $_->id} $section1->children),
'intro1:para1:para2:note1:para3', 'cut (1)');
my $intro1= $section1->first_child( 'intro');
$intro1->cut;
stest( (join ":", map { $_->id} $section1->children),
'para1:para2:note1:para3', 'cut (2)');
$intro1->paste( $section1);
stest( (join ":", map { $_->id} $section1->children),
'intro1:para1:para2:note1:para3', 'paste');
$title1->paste( 'first_child', $section2, );
stest( (join ":", map { $_->id} $section2->children),
'title1:intro2:title2:para4:para5:para6', 'paste( first_child)');
$title1->cut;
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:para4:para5:para6', 'paste');
$title1->paste( $section2);
stest( (join ":", map { $_->id} $section2->children),
'title1:intro2:title2:para4:para5:para6', 'paste');
$title1->cut;
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:para4:para5:para6', 'cut (3)');
$title1->paste( 'last_child', $section2);
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:para4:para5:para6:title1', 'paste( last_child)');
$title1->cut;
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:para4:para5:para6', 'cut(4)');
my $intro2=
etest( $section2->first_child( 'intro'),
'intro', 'intro2', 'first_sibling( intro)');
$title1->paste( 'after', $intro2);
stest( (join ":", map { $_->id} $section2->children),
'intro2:title1:title2:para4:para5:para6', 'paste( after)');
$title1->cut;
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:para4:para5:para6', 'cut (5)');
$title1->paste( 'before', $intro2);
stest( (join ":", map { $_->id} $section2->children),
'title1:intro2:title2:para4:para5:para6', 'paste( before)');
$title1->cut;
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:para4:para5:para6', 'cut (6)');
my $para4= etest( $t->elt_id( 'para4'), 'para', 'para4', 'elt_id');
$title1->paste( 'after', $para4);
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:para4:title1:para5:para6', 'paste( after)');
$title1->cut;
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:para4:para5:para6', 'cut (7)');
$title1->paste( 'before', $para4);
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:title1:para4:para5:para6', 'paste( before)');
$title1->cut;
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:para4:para5:para6', 'cut (8)');
# now let's mess up the document
# let's erase that pesky intro
$intro2->erase;
stest( (join ":", map { $_->id} $section2->children),
'paraintro3:title2:para4:para5:para6', 'erase');
$para4->delete;
stest( (join ":", map { $_->id} $section2->children),
'paraintro3:title2:para5:para6', 'delete');
$t->change_gi( 'paraintro', 'para');
stest( (join ":", map { $_->gi} $section2->children),
'para:title:para:para', 'change_gi');
$para3= etest( $t->elt_id( 'para3'), 'para', 'para3', 'elt_id');
$para3->cut;
stest( $section1->text, 'S1 I1S1 I2S1 P1S2 P2Note P1', 'text');
stest( $section1->sprint,
'<section id="section1"><intro id="intro1"><para id="paraintro1">S1 I1</para><para id="paraintro2">S1 I2</para></intro><para id="para1">S1 P1</para><para id="para2">S2 P2</para><note id="note1"><para id="paranote1">Note P1</para></note></section>',
'sprint');
# let's have a look at those entities
# first their names
stest( join( ':', $t->entity_names), 'e1:e2:e3', 'entity_list');
# let's look at their content
my $e1= $t->entity( 'e1');
stest( $e1->text, '<!ENTITY e1 SYSTEM "e1.gif" NDATA gif>', 'e1 text');
my $e2= $t->entity( 'e2');
stest( $e2->text, '<!ENTITY e2 SYSTEM "e2.gif" NDATA gif>', 'e2 text');
my $e3= $t->entity( 'e3');
stest( $e3->text, '<!ENTITY e3 "internal entity">', 'e3 text');
# additionnal erase test
$section1= $root->first_child;
stest( (join ":", map { $_->id} $section1->children),
'intro1:para1:para2:note1', 'erase (2)');
$intro1= $section1->first_child( 'intro');
$intro1->erase;
stest( (join ":", map { $_->id} $section1->children),
'paraintro1:paraintro2:para1:para2:note1', 'erase (3)');
# new elt test
my $new_elt= new XML::Twig::Elt;
stest( ref $new_elt, 'XML::Twig::Elt', "new");
my $new_elt1= new XML::Twig::Elt( 'subclass');
stest( ref $new_elt, 'XML::Twig::Elt', "new subclass");
my $new_elt2= new XML::Twig::Elt;
stest( ref $new_elt2, 'XML::Twig::Elt', "create no gi");
my $new_elt3= new XML::Twig::Elt( 'elt3');
$new_elt3->set_id( 'elt3');
etest( $new_elt3, 'elt3', 'elt3', "create with gi");
my $new_elt4= new XML::Twig::Elt( 'elt4', 'text of elt4');
ttest( $new_elt4, 'text of elt4', "create with gi and text");
my $new_elt5= new XML::Twig::Elt( 'elt5', 'text of elt5 ', $new_elt4);
ttest( $new_elt5, 'text of elt5 text of elt4', "create with gi and content");
my $new_elt6= new XML::Twig::Elt( PCDATA, 'text of elt6');
ttest( $new_elt6, 'text of elt6', "create PCDATA");
# test CDATA
my $st1='<doc><![CDATA[<br><b>bold</b>]]></doc>';
my $t1= new XML::Twig;
$t1->parse( $st1);
sttest( $t1->root, $st1, "CDATA Section");
my $st2='<doc>text <![CDATA[<br><b>bold</b>]]> more text</doc>';
my $t2= new XML::Twig;
$t2->parse( $st2);
sttest( $t2->root, $st2, "CDATA Section");
my $st3='<doc><![CDATA[<br><b>bold</b>]]> text</doc>';
my $t3= new XML::Twig;
$t3->parse( $st3);
sttest( $t3->root, $st3, "CDATA Section");
my $st4='<doc><el>text</el><![CDATA[<br><b>bold</b>]]><el>more text</el></doc>';
my $t4= new XML::Twig;
$t4->parse( $st4);
sttest( $t4->root, $st4, "CDATA Section");
my $st5='<doc>text <![CDATA[ text ]]&lt; ]]><el>more text</el></doc>';
my $t5= new XML::Twig;
$t5->parse( $st5);
sttest( $t5->root, $st5, "CDATA Section with ]]&lt;");
# test prefix
my $st6='<doc><el1>text</el1><el2>more text</el2></doc>';
my $t6= new XML::Twig;
$t6->parse( $st6);
$doc= $t6->root;
$doc->prefix( 'p1:');
sttest( $t6->root,'<doc>p1:<el1>text</el1><el2>more text</el2></doc>',
"prefix doc");
my $el1= $doc->first_child( 'el1');
$el1->prefix( 'p2:');
sttest( $t6->root,'<doc>p1:<el1>p2:text</el1><el2>more text</el2></doc>',
"prefix el1");
my $el2= $doc->first_child( 'el2');
my $pcdata= $el2->first_child( PCDATA);
$pcdata->prefix( 'p3:');
sttest( $t6->root,'<doc>p1:<el1>p2:text</el1><el2>p3:more text</el2></doc>',
"prefix pcdata");
exit 0;
__END__

99
t/test2.t Executable file
View File

@ -0,0 +1,99 @@
#!/usr/bin/perl -w
use strict;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
# This tests the doctype and DTD access functions
$|=1;
use XML::Twig;
use Cwd;
$0 =~ s!\\!/!g;
my ($DIR,$PROG) = $0 =~ m=^(.*/)?([^/]+)$=;
$DIR =~ s=/$== || chop($DIR = cwd());
chdir $DIR;
my $i=0;
my $failed=0;
my $TMAX=15; # don't forget to update!
print "1..$TMAX\n";
# test twig creation
my $t= new XML::Twig();
ok( $t, 'twig creation');
# first test an internal DTD
my $in_file= "test2_1.xml";
my $res_file= "test2_1.res";
my $exp_file= "test2_1.exp";
# test parse no dtd info required
$t->parsefile( $in_file, ErrorContext=>2);
ok( $t, 'parse');
open( RES, ">$res_file") or die "cannot open $res_file:$!";
$t->print( \*RES);
close RES;
ok( $res_file, $exp_file, "flush");
$res_file= 'test2_2.res';
$exp_file= 'test2_2.exp';
open( RES, ">$res_file") or die "cannot open $res_file:$!";
$t->print( \*RES, Update_DTD => 1);
close RES;
ok( $res_file, $exp_file, "flush");
$t= new XML::Twig();
ok( $t, 'twig creation');
$in_file= "test2_2.xml";
$res_file= "test2_3.res";
$exp_file= "test2_3.exp";
$t->parsefile( $in_file, ErrorContext=>2);
ok( $t, 'parse');
open( RES, ">$res_file") or die "cannot open $res_file:$!";
my $e2=new XML::Twig::Entity( 'e2', 'entity2');
my $entity_list= $t->entity_list;
$entity_list->add( $e2);
my $e3=new XML::Twig::Entity( 'e3', undef, 'pic.jpeg', 'JPEG');
$entity_list= $t->entity_list;
$entity_list->add( $e3);
$t->print( \*RES, Update_DTD => 1);
close RES;
ok( $res_file, $exp_file, "flush");
my $dtd= $t->dtd;
ok( !$dtd, 'dtd exits');
$t= new XML::Twig(LoadDTD=>1);
ok( $t, 'twig creation');
$t->parsefile( $in_file, ErrorContext=>2, );
$dtd= $t->dtd;
ok( $dtd, 'dtd not found');
my @model= sort keys %{$dtd->{model}};
stest( stringify( @model), 'doc:intro:note:para:section:title', 'element list');
stest( $t->model( 'title'), '(#PCDATA)', 'title model');
mtest( $t->model( 'section'), '\(intro\?,\s*title,\s*\(para|note\)+\)', 'section model');
stest( $t->dtd->{att}->{section}->{id}->{type}, 'ID', 'section id type');
stest( $t->dtd->{att}->{section}->{id}->{default}, '#IMPLIED', 'section id default');
exit 0;

20
t/test2_1.exp Normal file
View File

@ -0,0 +1,20 @@
<?xml version="1.0" standalone="yes"?>
<!DOCTYPE doc[
<!ELEMENT doc (section+, annex*)>
<!ATTLIST doc id ID #IMPLIED>
<!ELEMENT section (intro?, title, (para|note)+)>
<!ATTLIST section id ID #IMPLIED>
<!ELEMENT intro (para+)>
<!ATTLIST intro id ID #IMPLIED>
<!ELEMENT note (para+)>
<!ATTLIST note id ID #IMPLIED>
<!ELEMENT para (#PCDATA)>
<!ATTLIST para id ID #IMPLIED>
<!ELEMENT title (#PCDATA)>
<!ATTLIST title id ID #IMPLIED>
<!NOTATION gif PUBLIC "gif">
<!ENTITY e1 SYSTEM "e1.gif" NDATA gif>
]>
<doc id="doc1"><section id="section1"><intro id="intro1"><para id="paraintro1">S1 I1</para><para id="paraintro2">S1 I2</para></intro><title id="title1" no="1">S1 Title</title><para id="para1">S1 P1</para><para id="para2">S2 P2</para><note id="note1"><para id="paranote1">Note P1</para></note><para id="para3">S1 <xref refid="section2"/>para 3</para></section><section id="section2"><intro id="intro2"><para id="paraintro3">S2 intro</para></intro><title id="title2" no="2">S2 Title</title><para id="para4">S2 P1</para><para id="para5">S2 P2</para><para id="para6">S2 P3</para></section><annex id="annex1"><title id="titleA" no="A">Annex Title</title><para id="paraannex1">Annex P1</para><para id="paraannex2">Annex P2</para></annex></doc>

19
t/test2_1.res Normal file
View File

@ -0,0 +1,19 @@
<?xml version="1.0" standalone="yes"?>
<!DOCTYPE doc [
<!ELEMENT doc (section+,annex*)>
<!ATTLIST doc id ID #IMPLIED>
<!ELEMENT section (intro?,title,(para|note)+)>
<!ATTLIST section id ID #IMPLIED>
<!ELEMENT intro (para+)>
<!ATTLIST intro id ID #IMPLIED>
<!ELEMENT note (para+)>
<!ATTLIST note id ID #IMPLIED>
<!ELEMENT para (#PCDATA)>
<!ATTLIST para id ID #IMPLIED>
<!ELEMENT title (#PCDATA)>
<!ATTLIST title id ID #IMPLIED>
<!NOTATION gif PUBLIC "gif">
<!ENTITY e1 SYSTEM "e1.gif" NDATA gif>
]>
<doc id="doc1"><section id="section1"><intro id="intro1"><para id="paraintro1">S1 I1</para><para id="paraintro2">S1 I2</para></intro><title id="title1" no="1">S1 Title</title><para id="para1">S1 P1</para><para id="para2">S2 P2</para><note id="note1"><para id="paranote1">Note P1</para></note><para id="para3">S1 <xref refid="section2"/>para 3</para></section><section id="section2"><intro id="intro2"><para id="paraintro3">S2 intro</para></intro><title id="title2" no="2">S2 Title</title><para id="para4">S2 P1</para><para id="para5">S2 P2</para><para id="para6">S2 P3</para></section><annex id="annex1"><title id="titleA" no="A">Annex Title</title><para id="paraannex1">Annex P1</para><para id="paraannex2">Annex P2</para></annex></doc>

50
t/test2_1.xml Normal file
View File

@ -0,0 +1,50 @@
<?xml version="1.0" standalone="yes"?>
<!DOCTYPE doc [
<!ELEMENT doc (section+, annex*)>
<!ATTLIST doc id ID #IMPLIED>
<!ELEMENT section (intro?, title, (para|note)+)>
<!ATTLIST section id ID #IMPLIED>
<!ELEMENT intro (para+)>
<!ATTLIST intro id ID #IMPLIED>
<!ELEMENT note (para+)>
<!ATTLIST note id ID #IMPLIED>
<!ELEMENT para (#PCDATA)>
<!ATTLIST para id ID #IMPLIED>
<!ELEMENT title (#PCDATA)>
<!ATTLIST title id ID #IMPLIED>
<!NOTATION gif PUBLIC "gif">
<!ENTITY e1 SYSTEM "e1.gif" NDATA gif>
]>
<doc id="doc1">
<section id="section1">
<intro id="intro1">
<para id="paraintro1">S1 I1</para>
<para id="paraintro2">S1 I2</para>
</intro>
<title no="1" id="title1">S1 Title</title>
<para id="para1">S1 P1</para>
<para id="para2">S2 P2</para>
<note id="note1">
<para id="paranote1">Note P1</para>
</note>
<para id="para3">S1 <xref refid="section2"/>para 3</para>
</section>
<section id="section2">
<intro id="intro2">
<para id="paraintro3">S2 intro</para>
</intro>
<title no="2" id="title2">S2 Title</title>
<para id="para4">S2 P1</para>
<para id="para5">S2 P2</para>
<para id="para6">S2 P3</para>
</section>
<annex id="annex1">
<title no="A" id="titleA">Annex Title</title>
<para id="paraannex1">Annex P1</para>
<para id="paraannex2">Annex P2</para>
</annex>
</doc>

14
t/test2_2.dtd Normal file
View File

@ -0,0 +1,14 @@
<!ELEMENT doc (section+, annex*)>
<!ATTLIST doc id ID #IMPLIED>
<!ELEMENT section (intro?, title, (para|note)+)>
<!ATTLIST section id ID #IMPLIED>
<!ELEMENT intro (para+)>
<!ATTLIST intro id ID #IMPLIED>
<!ELEMENT note (para+)>
<!ATTLIST note id ID #IMPLIED>
<!ELEMENT para (#PCDATA)>
<!ATTLIST para id ID #IMPLIED>
<!ELEMENT title (#PCDATA)>
<!ATTLIST title id ID #IMPLIED>
<!NOTATION gif PUBLIC "gif">

29
t/test2_2.exp Normal file
View File

@ -0,0 +1,29 @@
<?xml version="1.0" standalone="yes"?>
<!DOCTYPE doc[
<!ELEMENT doc (section+, annex*)>
<!ATTLIST doc
id ID #IMPLIED
>
<!ELEMENT section (intro?, title, (para|note)+)>
<!ATTLIST section
id ID #IMPLIED
>
<!ELEMENT intro (para+)>
<!ATTLIST intro
id ID #IMPLIED
>
<!ELEMENT note (para+)>
<!ATTLIST note
id ID #IMPLIED
>
<!ELEMENT para (#PCDATA)>
<!ATTLIST para
id ID #IMPLIED
>
<!ELEMENT title (#PCDATA)>
<!ATTLIST title
id ID #IMPLIED
>
<!ENTITY e1 SYSTEM "e1.gif" NDATA gif>
]>
<doc id="doc1"><section id="section1"><intro id="intro1"><para id="paraintro1">S1 I1</para><para id="paraintro2">S1 I2</para></intro><title id="title1" no="1">S1 Title</title><para id="para1">S1 P1</para><para id="para2">S2 P2</para><note id="note1"><para id="paranote1">Note P1</para></note><para id="para3">S1 <xref refid="section2"/>para 3</para></section><section id="section2"><intro id="intro2"><para id="paraintro3">S2 intro</para></intro><title id="title2" no="2">S2 Title</title><para id="para4">S2 P1</para><para id="para5">S2 P2</para><para id="para6">S2 P3</para></section><annex id="annex1"><title id="titleA" no="A">Annex Title</title><para id="paraannex1">Annex P1</para><para id="paraannex2">Annex P2</para></annex></doc>

17
t/test2_2.res Normal file
View File

@ -0,0 +1,17 @@
<?xml version="1.0" standalone="yes"?>
<!DOCTYPE doc[
<!ELEMENT doc (section+,annex*)>
<!ATTLIST doc id ID #IMPLIED>
<!ELEMENT section (intro?,title,(para|note)+)>
<!ATTLIST section id ID #IMPLIED>
<!ELEMENT intro (para+)>
<!ATTLIST intro id ID #IMPLIED>
<!ELEMENT note (para+)>
<!ATTLIST note id ID #IMPLIED>
<!ELEMENT para (#PCDATA)>
<!ATTLIST para id ID #IMPLIED>
<!ELEMENT title (#PCDATA)>
<!ATTLIST title id ID #IMPLIED>
<!ENTITY e1 SYSTEM "e1.gif" NDATA gif><!NOTATION gif PUBLIC "gif">]>
<doc id="doc1"><section id="section1"><intro id="intro1"><para id="paraintro1">S1 I1</para><para id="paraintro2">S1 I2</para></intro><title id="title1" no="1">S1 Title</title><para id="para1">S1 P1</para><para id="para2">S2 P2</para><note id="note1"><para id="paranote1">Note P1</para></note><para id="para3">S1 <xref refid="section2"/>para 3</para></section><section id="section2"><intro id="intro2"><para id="paraintro3">S2 intro</para></intro><title id="title2" no="2">S2 Title</title><para id="para4">S2 P1</para><para id="para5">S2 P2</para><para id="para6">S2 P3</para></section><annex id="annex1"><title id="titleA" no="A">Annex Title</title><para id="paraannex1">Annex P1</para><para id="paraannex2">Annex P2</para></annex></doc>

36
t/test2_2.xml Normal file
View File

@ -0,0 +1,36 @@
<?xml version="1.0" standalone="no"?>
<!DOCTYPE doc SYSTEM "test2_2.dtd" [
<!ENTITY e1 SYSTEM "e1.gif" NDATA gif>
]>
<doc id="doc1">
<section id="section1">
<intro id="intro1">
<para id="paraintro1">S1 I1</para>
<para id="paraintro2">S1 I2</para>
</intro>
<title no="1" id="title1">S1 Title</title>
<para id="para1">S1 P1</para>
<para id="para2">S2 P2</para>
<note id="note1">
<para id="paranote1">Note P1</para>
</note>
<para id="para3">S1 <xref refid="section2"/>para 3</para>
</section>
<section id="section2">
<intro id="intro2">
<para id="paraintro3">S2 intro</para>
</intro>
<title no="2" id="title2">S2 Title</title>
<para id="para4">S2 P1</para>
<para id="para5">S2 P2</para>
<para id="para6">S2 P3</para>
</section>
<annex id="annex1">
<title no="A" id="titleA">Annex Title</title>
<para id="paraannex1">Annex P1</para>
<para id="paraannex2">Annex P2</para>
</annex>
</doc>

6
t/test2_3.res Normal file
View File

@ -0,0 +1,6 @@
<?xml version="1.0" standalone="no"?>
<!DOCTYPE doc SYSTEM "test2_2.dtd"[
<!ENTITY e1 SYSTEM "e1.gif" NDATA gif>
<!ENTITY e2 "entity2">
<!ENTITY e3 PUBLIC "JPEG" "pic.jpeg">]>
<doc id="doc1"><section id="section1"><intro id="intro1"><para id="paraintro1">S1 I1</para><para id="paraintro2">S1 I2</para></intro><title id="title1" no="1">S1 Title</title><para id="para1">S1 P1</para><para id="para2">S2 P2</para><note id="note1"><para id="paranote1">Note P1</para></note><para id="para3">S1 <xref refid="section2"/>para 3</para></section><section id="section2"><intro id="intro2"><para id="paraintro3">S2 intro</para></intro><title id="title2" no="2">S2 Title</title><para id="para4">S2 P1</para><para id="para5">S2 P2</para><para id="para6">S2 P3</para></section><annex id="annex1"><title id="titleA" no="A">Annex Title</title><para id="paraannex1">Annex P1</para><para id="paraannex2">Annex P2</para></annex></doc>

110
t/test3.t Executable file
View File

@ -0,0 +1,110 @@
#!/usr/bin/perl -w
use strict;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
# This just tests a complete twig, no callbacks
# additional tests for element creation/parse and
# space policy
# plus test for the is_pcdata method
$|=1;
use XML::Twig;
my $i=0;
my $failed=0;
my $TMAX=23; # do not forget to update!
print "1..$TMAX\n";
my $p1= XML::Twig::Elt->new( 'para', 'p1');
$p1->set_id( 'p1');
etest( $p1, 'para', 'p1', 'Element creation');
my $p2= XML::Twig::Elt->parse( '<para id="p2">para2</para>');
etest( $p2, 'para', 'p2', 'Element parse');
my $s1= parse XML::Twig::Elt( '<section id="s1"><title id="t1">title1</title><para id="p3">para 3</para></section>');
etest( $s1, 'section', 's1', 'Element parse (complex)');
my $p3= $s1->first_child( 'para');
etest( $p3, 'para', 'p3', 'Element parse (sub-element)');
my $string= "<doc>\n<p>para</p><p>\n</p>\n</doc>";
my $t1= new XML::Twig( DiscardSpacesIn => [ 'doc']);
$t1->parse( $string);
sttest( $t1->root, "<doc><p>para</p><p>\n</p></doc>", 'DiscardSpacesIn');
my $t2= new XML::Twig( DiscardSpacesIn => [ 'doc', 'p']);
$t2->parse( $string);
sttest( $t2->root, "<doc><p>para</p><p></p></doc>", 'DiscardSpacesIn');
my $t3= new XML::Twig( KeepSpaces =>1);
$t3->parse( $string);
sttest( $t3->root, $string, 'KeepSpaces');
my $t4= new XML::Twig( KeepSpacesIn =>[ 'p']);
$t4->parse( $string);
sttest( $t4->root, "<doc><p>para</p><p>\n</p></doc>", 'KeepSpacesIn');
my $p4= XML::Twig::Elt->parse( $string, KeepSpaces => 1);
sttest( $p4, $string, 'KeepSpaces');
my $p5= XML::Twig::Elt->parse( $string, DiscardSpaces => 1);
sttest( $p5, '<doc><p>para</p><p></p></doc>', "DiscardSpaces");
$p5= XML::Twig::Elt->parse( $string);
sttest( $p5, '<doc><p>para</p><p></p></doc>', "DiscardSpaces (def)");
my $p6= XML::Twig::Elt->parse( $string, KeepSpacesIn => ['p']);
sttest( $p6, "<doc><p>para</p><p>\n</p></doc>", "KeepSpacesIn 1");
my $p7= XML::Twig::Elt->parse( $string, KeepSpacesIn => [ 'doc', 'p']);
sttest( $p7, "<doc>\n<p>para</p><p>\n</p>\n</doc>", "KeepSpacesIn 2");
my $p8= XML::Twig::Elt->parse( $string, DiscardSpacesIn => ['doc']);
sttest( $p8, "<doc><p>para</p><p>\n</p></doc>", "DiscardSpacesIn 1 ");
my $p9= XML::Twig::Elt->parse( $string, DiscardSpacesIn => [ 'doc', 'p']);
sttest( $p9, "<doc><p>para</p><p></p></doc>", "DiscardSpacesIn 2");
my $string2= "<p>para <b>bold</b> end of para</p>";
my $p10= XML::Twig::Elt->parse( $string2,);
sttest( $p10, '<p>para <b>bold</b> end of para</p>', "mixed content");
my $string3= "<doc>\n<p>para</p>\n<p>\n</p>\n</doc>";
my $p11= XML::Twig::Elt->parse( $string3, KeepSpaces => 1);
sttest( $p4, $string, 'KeepSpaces');
my $p12= XML::Twig::Elt->parse( $string3, KeepSpacesIn => [ 'doc']);
sttest( $p12, "<doc>\n<p>para</p>\n<p></p>\n</doc>", 'KeepSpacesIn');
my $p13= XML::Twig::Elt->parse( $string3, KeepSpaces => 1);
sttest( $p13, "<doc>\n<p>para</p>\n<p>\n</p>\n</doc>", 'KeepSpaces');
my $p14= XML::Twig::Elt->parse( $string2);
my $is_pcdata= $p14->is_pcdata;
ok( $is_pcdata ? 0 : 1, "is_pcdata on a <para>");
my $pcdata= $p14->first_child( PCDATA);
$is_pcdata= $pcdata->is_pcdata;
ok( $pcdata->is_pcdata, "is_pcdata on PCDATA");
my $erase_string='<?xml version="1.0"?><doc><elt id="elt1"><selt id="selt1"
>text 1</selt><selt id="selt2"><selt id="selt3"> text 2</selt></selt
><selt id="selt4"><selt id="selt5"> text 3</selt> text 4</selt
></elt></doc>';
my $er_t= new XML::Twig( TwigHandlers => { selt => sub { $_[1]->erase; } });
$er_t->parse( $erase_string);
sttest( $er_t->root, '<doc><elt id="elt1">text 1 text 2 text 3 text 4</elt></doc>',
"erase");
# test whether Twig packs strings
my $br_pcdata= "line 1\nline 2\nline 3\n";
my $doc_br_pcdata= "<doc>$br_pcdata</doc>";
my $t_br_pcdata= new XML::Twig();
$t_br_pcdata->parse( $doc_br_pcdata);
$pcdata= $t_br_pcdata->root->first_child->pcdata;
stest( $pcdata, $br_pcdata, "multi-line pcdata");
exit 0;

215
t/test4.t Executable file
View File

@ -0,0 +1,215 @@
#!/usr/bin/perl -w
use strict;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
$|=1;
use XML::Twig;
my $TMAX=19; # do not forget to update!
print "1..$TMAX\n";
my $s='<doc>
<section id="s1">
<title id="t1">Title <b>bold</b></title>
<p id="p1">para1</p>
<p id="p2">para2</p>
</section>
<section id="s2">
<title id="t2">Title</title>
<p id="p3">para2</p>
<p id="p3">para3</p>
</section>
</doc>';
my @toc;
my $t= new XML::Twig( TwigHandlers => { title => sub { push @toc, $_[1]->text; } });
$t->parse( $s);
my $toc= join ':', @toc;
stest( $toc, "Title bold:Title", "text method");
undef @toc;
$t= new XML::Twig( TwigHandlers => { title => sub { push @toc, $_[1]->sprint( 1); } });
$t->parse( $s);
$toc= join ':', @toc;
stest( $toc, "Title <b>bold</b>:Title", "sprint method");
undef @toc;
$t= new XML::Twig( TwigHandlers => { title => sub { push @toc, $_[1]->sprint( 1);
$_[0]->purge; } });
$t->parse( $s);
$toc= join ':', @toc;
stest( $toc, "Title <b>bold</b>:Title", "sprint method with purge");
my $purged_doc= $t->sprint;
stest( $purged_doc, '<doc><section id="s2"><p id="p3">para2</p><p id="p3">para3</p></section></doc>', "sprint purged doc");
$t= new XML::Twig( TwigRoots => { title => 1});
$t->parse( $s);
my $doc= $t->sprint;
stest( $doc, '<doc><title id="t1">Title <b>bold</b></title><title id="t2">Title</title></doc>', "using title as TwigRoots");
$t= new XML::Twig( TwigHandlers => { doc => sub { $_[1]->set_att( mod => "yes"); } },
TwigRoots => { title => 1});
$t->parse( $s);
$doc= $t->sprint;
stest( $doc, '<doc mod="yes"><title id="t1">Title <b>bold</b></title><title id="t2">Title</title></doc>', "using title as TwigRoots (with doc handler)");
$s='<doc>
<section id="s1">
<title id="t1">t1 <b>b1</b></title>
<p id="p5">para1</p>
<section id="ss1">
<title id="ts1">ts1 <b>b2</b></title>
<p2 id="p1">para1</p2>
<p id="p2">para2</p>
</section>
</section>
<section id="s2">
<title id="t2">t2</title>
<p id="p3">para3</p>
<p2 id="p4">para4</p2>
<section id="ss2">
<title id="ts2">ts2</title>
<p id="p6">para6</p>
<p id="p7">para7</p>
</section>
</section>
</doc>';
$t= new XML::Twig( TwigHandlers => { doc => sub { $_[1]->set_att( mod => "yes"); } },
TwigRoots => { title => 1});
$t->parse( $s);
$doc= $t->sprint;
stest( $doc, '<doc mod="yes"><title id="t1">t1 <b>b1</b></title><title id="ts1">ts1 <b>b2</b></title><title id="t2">t2</title><title id="ts2">ts2</title></doc>', "using title as TwigRoots (with doc handler)");
$t= new XML::Twig( TwigHandlers => { doc => sub { $_[1]->set_att( mod => "yes"); } },
TwigRoots => { title => 1, p2 => 1});
$t->parse( $s);
$doc= $t->sprint;
stest( $doc, '<doc mod="yes"><title id="t1">t1 <b>b1</b></title><title id="ts1">ts1 <b>b2</b></title><p2 id="p1">para1</p2><title id="t2">t2</title><p2 id="p4">para4</p2><title id="ts2">ts2</title></doc>', "using title, p2 as TwigRoots (with doc handler)");
$s="<doc>string with ' here</doc>";
$t= new XML::Twig();
$t->parse( $s);
$doc= $t->sprint;
stest( $doc, "<doc>string with ' here</doc>", "apos without KeepEncoding");
$t= new XML::Twig( KeepEncoding => 1);
$t->parse( $s);
$doc= $t->sprint;
stest( $doc, "<doc>string with ' here</doc>", "apos WITH KeepEncoding");
$s="<doc>string with &quot; here</doc>";
$t= new XML::Twig();
$t->parse( $s);
$doc= $t->sprint;
stest( $doc, "<doc>string with \" here</doc>", "quote without KeepEncoding");
$t= new XML::Twig( KeepEncoding => 1);
$t->parse( $s);
$doc= $t->sprint;
stest( $doc, '<doc>string with &quot; here</doc>', "quote WITH KeepEncoding");
$s="<doc>string with &amp; here</doc>";
$t= new XML::Twig();
$t->parse( $s);
$doc= $t->sprint;
stest( $doc, $s, "&amp; in text");
$s='<doc att="val &amp; tut">string</doc>';
$t= new XML::Twig();
$t->parse( $s);
$doc= $t->sprint;
stest( $doc, $s, "&amp; in attribute");
$s="<doc>string with &lt; here</doc>";
$t= new XML::Twig();
$t->parse( $s);
$doc= $t->sprint;
stest( $doc, $s, "&lt; in text");
$s='<doc att="val &lt; tut">string</doc>';
$t= new XML::Twig();
$t->parse( $s);
$doc= $t->sprint;
stest( $doc, $s, "&lt; in attribute");
$s="<doc>string with &quot; here</doc>";
$t= new XML::Twig();
$t->parse( $s);
$doc= $t->sprint;
stest( $doc, '<doc>string with " here</doc>', "&quot; in text");
$s='<doc att="val &lt; tut">string</doc>';
$t= new XML::Twig();
$t->parse( $s);
$doc= $t->sprint;
stest( $doc, $s, "&quot; in attribute");
#$s='<doc att="val &#130; tut">string</doc>';
#$t= new XML::Twig();
#$t->parse( $s);
#$doc= $t->sprint;
#stest( $doc, $s, "&#130; in attribute");
#$s="<doc>string with ‰ here</doc>";
#$t= new XML::Twig();
#$t->parse( $s);
#$doc= $t->sprint;
#stest( $doc, "<doc>string with &#130; here</doc>", "eacute without KeepEncoding");
#$t= new XML::Twig( KeepEncoding => 1);
#$t->parse( $s);
#$doc= $t->sprint;
#stest( $doc, '<doc>string with ‰ here</doc>', "eacute WITH KeepEncoding");
#$s='<doc>string with &#130; here</doc>';
#$t= new XML::Twig();
#$t->parse( $s);
#$doc= $t->sprint;
#stest( $doc, "<doc>string with &#130; here</doc>", "&#130; without KeepEncoding");
#$t= new XML::Twig( KeepEncoding => 1);
#$t->parse( $s);
#$doc= $t->sprint;
#stest( $doc, '<doc>string with &#130; here</doc>', "&#130; WITH KeepEncoding");
#$s='<doc><?PI text?><elt>text</elt></doc>';
#$t= new XML::Twig();
#$t->parse( $s);
#$doc= $t->sprint;
#stest( $doc, $s, "PI");
if( $] > 5.008)
{ my (@called);
my $t= XML::Twig->new(
twig_handlers =>
{ a => sub { push @called, 'a'; 1; },
'b/a' => sub { push @called, 'b/a'; 1; },
'/b/a' => sub { push @called, '/b/a'; 1; },
'/a' => sub { push @called, '/a'; 1; },
},
);
$t->parse( '<b><a/></b>');
my $calls= join( ':', @called);
my $expected= "/b/a:b/a:a";
if( $calls eq $expected) { print "ok 19\n"; }
else { print "not ok 19\n"; warn "\n[$calls] instead of [$expected]\n"; }
}
else
{ warn "skipped for perl < 5.8\n"; print "ok 19\n"; }
exit 0;

554
t/test5.t Executable file
View File

@ -0,0 +1,554 @@
#!/usr/bin/perl -w
use strict;
use XML::Twig;
$|=1;
my $doc= '<doc>
<elt1>
<elt2 id="elt1">
<elt3 id="elt2">
</elt3>
</elt2>
<elt2 id="elt3">
</elt2>
</elt1>
<p1 id="p1_1"><p2 id="p2_1">p2 (/doc/p1/p2) </p2>
<p3 id="p3_1"><p2 id="p2_2">p2 (/doc/p1/p3/p2) </p2></p3>
</p1>
<p2 id="p2_3">p2 (/doc/p2) </p2>
<p2 id="p2_4">p2 (/doc/p2) </p2>
<p4><p2 id="p2_5">p2 (/doc/p2) </p2></p4>
<p4><p2 id="p2_6">p2 (/doc/p2) </p2></p4>
<p3 id="p3_2"><p2 id="p2_7">p2 (/doc/p3/p2) </p2></p3>
</doc>
';
my $TMAX=80; # do not forget to update
print "1..$TMAX\n";
my $t= new XML::Twig;
$t->parse( $doc);
my $elt1= $t->elt_id( 'elt1');
my $elt2= $t->elt_id( 'elt2');
my $elt3= $t->elt_id( 'elt3');
my $root= $t->root;
# testing before and after
my $res= $elt1->before( $elt2);
if( $res) { print "ok 1\n"; } else { print "not ok 1\n"; }
$res= $elt2->before( $elt3);
if( $res) { print "ok 2\n"; } else { print "not ok 2\n"; }
$res= $elt1->before( $elt3);
if( $res) { print "ok 3\n"; } else { print "not ok 3\n"; }
$res= $elt3->before( $elt2);
unless( $res) { print "ok 4\n"; } else { print "not ok 4\n"; }
$res= $elt1->after( $elt2);
unless( $res) { print "ok 5\n"; } else { print "not ok 5\n"; }
$res= $elt1->after( $elt3);
unless( $res) { print "ok 6\n"; } else { print "not ok 6\n"; }
$res= $elt3->after( $elt2);
if( $res) { print "ok 7\n"; } else { print "not ok 7\n"; }
$res= $elt1->before( $root);
unless( $res) { print "ok 8\n"; } else { print "not ok 8\n"; }
$res= $root->before( $elt1);
if( $res) { print "ok 9\n"; } else { print "not ok 9\n"; }
# testing path capabilities
my $path= $elt1->path;
my $exp_path= '/doc/elt1/elt2';
if( $path eq $exp_path)
{ print "ok 10\n"; } else { print "not ok 10\n"; print "$path instead\n"; warn "of $exp_path\n"; }
$path= $elt2->path;
$exp_path= '/doc/elt1/elt2/elt3';
if( $path eq $exp_path)
{ print "ok 11\n"; } else { print "not ok 11\n"; warn "$path instead of $exp_path\n"; }
$path= $elt3->path;
$exp_path= '/doc/elt1/elt2';
if( $path eq $exp_path)
{ print "ok 12\n"; } else { print "not ok 12\n"; warn "$path instead of $exp_path\n"; }
$path= $root->path;
$exp_path= '/doc';
if( $path eq $exp_path)
{ print "ok 13\n"; } else { print "not ok 13\n"; warn "$path instead of $exp_path\n"; }
my $id1=''; my $exp_id1= 'p2_1';
my $id2=''; my $exp_id2= 'p2_3p2_4';
my $id3=''; my $exp_id3= 'p2_2p2_7';
my $id4=''; my $exp_id4= 'p2_5p2_6';
my $path_error='';
my $t2= new XML::Twig( TwigHandlers =>
{ '/doc/p1/p2' => sub { $id1.= $_[1]->id; return; },
'/doc/p2' => sub { $id2.= $_[1]->id; return; },
'p3/p2' => sub { $id3.= $_[1]->id; return; },
'p2' => sub { $id4.= $_[1]->id; return; },
_all_ => sub { my( $t, $elt)= @_;
my $gi= $elt->gi;
my $tpath= $t->path( $gi); my $epath= $elt->path;
unless( $tpath eq $epath)
{ $path_error.= " $tpath <> $epath\n"; }
}
}
);
$t2->parse( $doc);
if( $id1 eq $exp_id1)
{ print "ok 14\n"; } else { print "not ok 14\n"; warn "$id1 instead of $exp_id1\n"; }
if( $id2 eq $exp_id2)
{ print "ok 15\n"; } else { print "not ok 15\n"; warn "$id2 instead of $exp_id2\n"; }
if( $id3 eq $exp_id3)
{ print "ok 16\n"; } else { print "not ok 16\n"; warn "$id3 instead of $exp_id3\n"; }
if( $id4 eq $exp_id4)
{ print "ok 17\n"; } else { print "not ok 17\n"; warn "$id4 instead of $exp_id4\n"; }
unless( $path_error)
{ print "ok 18\n"; } else { print "not ok 18\n"; warn "$path_error\n"; }
$id1=''; $exp_id1= 'p2_1';
my $t3= new XML::Twig( TwigRoots => { '/doc/p1/p2' => sub { $id1.= $_[1]->id; } } );
$t3->parse( $doc);
if( $id1 eq $exp_id1)
{ print "ok 19\n"; } else { print "not ok 19\n"; warn "$id1 instead of $exp_id1\n"; }
$id2=''; $exp_id2= 'p2_3p2_4';
$t3= new XML::Twig( TwigRoots => { '/doc/p2' => sub { $id2.= $_[1]->id;} } );
$t3->parse( $doc);
if( $id2 eq $exp_id2)
{ print "ok 20\n"; } else { print "not ok 20\n"; warn "$id2 instead of $exp_id2\n"; }
$id3=''; $exp_id3= 'p2_2p2_7';
$t3= new XML::Twig( TwigRoots => { 'p3/p2' => sub { $id3.= $_[1]->id;} } );
$t3->parse( $doc);
if( $id3 eq $exp_id3)
{ print "ok 21\n"; } else { print "not ok 21\n"; warn "$id3 instead of $exp_id3\n"; }
# test what happens to 0 in pcdata/cdata
my $pcdata= '<test><text>0</text></test>';
my $cdata= '<test><text><![CDATA[0]]></text></test>';
my $t4= new XML::Twig;
$t4->parse( $pcdata);
if( my $res= $t4->sprint eq $pcdata) { print "ok 22\n"; }
else { print "not ok 22\n"; warn "sprint returns $res instead of $pcdata\n"; }
$t4->parse( $pcdata);
if( my $res= $t4->root->text eq '0') { print "ok 23\n"; }
else { print "not ok 23\n"; warn "sprint returns $res instead of '0'\n"; }
$t4->parse( $cdata);
if( my $res= $t4->sprint eq $cdata) { print "ok 24\n"; }
else { print "not ok 23\n"; warn "sprint returns $res instead of $cdata\n"; }
$t4->parse( $cdata);
if( my $res= $t4->root->text eq '0') { print "ok 25\n"; }
else { print "not ok 25\n"; warn "sprint returns $res instead of '0'\n"; }
my $test_inherit=
'<doc att1="doc1" att2="doc2" att3="doc3"><elt att1="elt1" att_null="0">
<subelt att1="subelt1" att2="subelt2"></subelt>
</elt></doc>';
my $t5= new XML::Twig;
$t5->parse( $test_inherit);
my $subelt= $t5->root->first_child->first_child;
if( my $att= $subelt->att( 'att1') eq "subelt1") { print "ok 26\n"; }
else { print "not ok 26\n"; warn "sprint returns $att instead of 'subelt1'\n"; }
if( my $att= $subelt->inherit_att( 'att1') eq "subelt1") { print "ok 27\n"; }
else { print "not ok 27\n"; warn "sprint returns $att instead of 'subelt1'\n"; }
if( my $att= $subelt->inherit_att( 'att1', 'elt') eq "elt1") { print "ok 28\n"; }
else { print "not ok 28 sprint returns $att instead of 'elt1'\n"; }
if( my $att= $subelt->inherit_att( 'att1', 'elt', 'doc') eq "elt1") { print "ok 29\n"; }
else { print "not ok 29\n"; warn "sprint returns $att instead of 'elt1'\n"; }
if( my $att= $subelt->inherit_att( 'att1', "doc") eq "doc1") { print "ok 30\n"; }
else { print "not ok 30\n"; warn "sprint returns $att instead of 'doc1'\n"; }
if( my $att= $subelt->inherit_att( 'att3') eq "doc3") { print "ok 31\n"; }
else { print "not ok 31\n"; warn "sprint returns $att instead of 'doc3'\n"; }
if( my $att= $subelt->inherit_att( 'att3') eq "doc3") { print "ok 32\n"; }
else { print "not ok 32\n"; warn "sprint returns $att instead of 'doc3'\n"; }
if( my $att= $subelt->inherit_att( 'att_null') == 0) { print "ok 33\n"; }
else { print "not ok 33\n"; warn "sprint returns $att instead of '0'\n"; }
# test attribute paths
my $test_att_path=
'<doc>
<elt id="elt1" att="val1">
<subelt id="subelt1" att="val1"/>
<subelt id="subelt2" att="val1"/>
<subelt id="subelt3" att="val2"/>
</elt>
<elt id="elt2" att="val1">
<subelt id="subelt4" att="val1"/>
<subelt id="subelt5" att="val1"/>
<subelt id="subelt6" att="val2"/>
</elt>
</doc>';
my $res1='';
my $t6= new XML::Twig
( TwigHandlers => #'' (or VIM messes up colors)
{ 'elt[@id="elt1"]' => sub { $res1.= $_[1]->id} }
);
$t6->parse( $test_att_path);
if( $res1 eq 'elt1') { print "ok 34\n"; }
else { print "not ok 34\n"; warn "returns $res1 instead of elt1\n"; }
$res1='';
my $res2='';
$t6= new XML::Twig
( TwigHandlers =>
{ 'elt[@id="elt1"]' => sub { $res1.= $_[1]->id},
'elt[@att="val1"]' => sub { $res2.= $_[1]->id} },
);
$t6->parse( $test_att_path);
if( $res1 eq 'elt1') { print "ok 35\n"; }
else { print "not ok 35\n"; warn "returns $res1 instead of 'elt1'\n"; }
if( $res2 eq 'elt1elt2') { print "ok 36\n"; }
else { print "not ok 36\n"; warn "returns $res2 instead of 'elt1elt2'\n"; }
my $doc_with_escaped_entities=
q{<doc att="m &amp; m">&lt;apos>&apos;&apos;&lt;apos&gt;&lt;&quot;></doc>};
my $exp_res1= q{<doc att="m &amp; m">&lt;apos>''&lt;apos>&lt;"></doc>};
my $exp_res2= q{<doc att="m & m"><apos>''<apos><"></doc>};
my $t7= new XML::Twig();
$t7->parse( $doc_with_escaped_entities);
$res= $t7->sprint;
if( $res eq $exp_res1) { print "ok 37\n"; }
else { print "not ok 37\n"; warn "returns \n$res instead of \n$exp_res1\n"; }
$t7= new XML::Twig( KeepEncoding => 1, NoExpand => 1);
$t7->parse( $doc_with_escaped_entities);
$res= $t7->sprint;
if( $res eq $doc_with_escaped_entities) { print "ok 38\n"; }
else { print "not ok 38\n"; warn "returns \n$res instead of \n$doc_with_escaped_entities\n"; }
# test extra options for new
my $elt= XML::Twig::Elt->new( 'p');
$res= $elt->sprint;
my $exp_res= '<p/>';
if( $res eq $exp_res) { print "ok 39\n"; }
else { print "not ok 39\n"; warn "returns $res instead of $exp_res\n"; }
$elt= XML::Twig::Elt->new( 'p', q{#EMPTY});
$res= $elt->sprint;
$exp_res= '<p/>';
if( $res eq $exp_res) { print "ok 40\n"; }
else { print "not ok 40\n"; warn "returns $res instead of $exp_res\n"; }
$elt= XML::Twig::Elt->new( 'p', { att => 'val'});
$res= $elt->sprint;
$exp_res= '<p att="val"/>';
if( $res eq $exp_res) { print "ok 41\n"; }
else { print "not ok 41\n"; warn "returns $res instead of $exp_res\n"; }
$elt= XML::Twig::Elt->new( 'p', { att => 'val'}, '#EMPTY');
$res= $elt->sprint;
$exp_res= '<p att="val"/>';
if( $res eq $exp_res) { print "ok 42\n"; }
else { print "not ok 42\n"; warn "returns $res instead of $exp_res\n"; }
$elt= XML::Twig::Elt->new( 'p', { att1 => 'val1', att2=> 'val2'});
$res= $elt->sprint;
$exp_res= '<p att1="val1" att2="val2"/>';
if( $res eq $exp_res) { print "ok 43\n"; }
else { print "not ok 43\n"; warn "returns $res instead of $exp_res\n"; }
$elt= XML::Twig::Elt->new( 'p', { att1 => 'val1', att2=>'val2'}, '#EMPTY');
$res= $elt->sprint;
$exp_res= '<p att1="val1" att2="val2"/>';
if( $res eq $exp_res) { print "ok 44\n"; }
else { print "not ok 44\n"; warn "returns $res instead of $exp_res\n"; }
$elt= XML::Twig::Elt->new( 'p', "content");
$res= $elt->sprint;
$exp_res= '<p>content</p>';
if( $res eq $exp_res) { print "ok 45\n"; }
else { print "not ok 45\n"; warn "returns $res instead of $exp_res\n"; }
$elt= XML::Twig::Elt->new( 'p', { att1 => 'val1'}, "content");
$res= $elt->sprint;
$exp_res= '<p att1="val1">content</p>';
if( $res eq $exp_res) { print "ok 46\n"; }
else { print "not ok 46\n"; warn "returns $res instead of $exp_res\n"; }
$elt= XML::Twig::Elt->new( 'p', { att1 => 'val1', att2=>'val2'}, "content");
$res= $elt->sprint;
$exp_res= '<p att1="val1" att2="val2">content</p>';
if( $res eq $exp_res) { print "ok 47\n"; }
else { print "not ok 47\n"; warn "returns $res instead of $exp_res\n"; }
$elt= XML::Twig::Elt->new( 'p', { att1 => 'val1'}, "content", " more content");
$res= $elt->sprint;
$exp_res= '<p att1="val1">content more content</p>';
if( $res eq $exp_res) { print "ok 48\n"; }
else { print "not ok 48\n"; warn "returns $res instead of $exp_res\n"; }
my $sub1= XML::Twig::Elt->new( 'sub', '#EMPTY');
my $sub2= XML::Twig::Elt->new( 'sub', { att => 'val'}, '#EMPTY');
my $sub3= XML::Twig::Elt->new( 'sub', "sub3");
my $sub4= XML::Twig::Elt->new( 'sub', "sub4");
my $sub5= XML::Twig::Elt->new( 'sub', "sub5", $sub3, "sub5 again", $sub4);
$elt= XML::Twig::Elt->new( 'p', { att1 => 'val1'}, $sub1, $sub2, $sub5);
$res= $elt->sprint;
$exp_res= '<p att1="val1"><sub/><sub att="val"/>'.
'<sub>sub5<sub>sub3</sub>sub5 again<sub>sub4</sub></sub></p>';
if( $res eq $exp_res) { print "ok 49\n"; }
else { print "not ok 49\n"; warn "returns \n$res\n instead of \n$exp_res\n"; }
$elt->set_empty_tag_style( 'html');
$res= $elt->sprint;
$exp_res= '<p att1="val1"><sub></sub><sub att="val"></sub>'.
'<sub>sub5<sub>sub3</sub>sub5 again<sub>sub4</sub></sub></p>';
if( $res eq $exp_res) { print "ok 50\n"; }
else { print "not ok 50\n"; warn "returns \n$res\n instead of \n$exp_res\n"; }
$elt->set_empty_tag_style( 'expand');
$res= $elt->sprint;
$exp_res= '<p att1="val1"><sub></sub><sub att="val"></sub>'.
'<sub>sub5<sub>sub3</sub>sub5 again<sub>sub4</sub></sub></p>';
if( $res eq $exp_res) { print "ok 51\n"; }
else { print "not ok 51\n"; warn "returns \n$res\n instead of \n$exp_res\n"; }
$elt->set_empty_tag_style( 'normal');
$res= $elt->sprint;
$exp_res= '<p att1="val1"><sub/><sub att="val"/>'.
'<sub>sub5<sub>sub3</sub>sub5 again<sub>sub4</sub></sub></p>';
if( $res eq $exp_res) { print "ok 52\n"; }
else { print "not ok 52\n"; warn "returns \n$res\n instead of \n$exp_res\n"; }
my $new_elt= parse XML::Twig::Elt( $res);
$res= $new_elt->sprint;
$exp_res= '<p att1="val1"><sub/><sub att="val"/>'.
'<sub>sub5<sub>sub3</sub>sub5 again<sub>sub4</sub></sub></p>';
if( $res eq $exp_res) { print "ok 53\n"; }
else { print "not ok 53\n"; warn "returns \n$res\n instead of \n$exp_res\n"; }
$doc='<doc><elt att="val1">text1</elt><root>root1</root><elt>text 2</elt></doc>';
$res='';
$exp_res= '<elt att="val1">text1</elt>';
$t= new XML::Twig( TwigHandlers =>
{ 'elt[string()="text1"]' => \&display1,
'elt[@att="val1"]' => \&display1,
},
);
$t->parse( $doc);
sub display1 { $res .=$_[1]->sprint; return 0; }
if( $res eq $exp_res) { print "ok 54\n"; }
else { print "not ok 54\n"; warn "returns \n$res\n instead of \n$exp_res\n"; }
$res='';
$exp_res= '<elt att="val1">text1</elt>' x 2;
$t= new XML::Twig( TwigHandlers =>
{ 'elt[string()="text1"]' => \&display2,
'elt[@att="val1"]' => \&display2,
},
);
$t->parse( $doc);
sub display2 { $res .=$_[1]->sprint; }
if( $res eq $exp_res) { print "ok 55\n"; }
else { print "not ok 55\n"; warn "returns \n$res\n instead of \n$exp_res\n"; }
$doc= '<doc id="doc1"><elt id="elt1"><sub id="sub1"/><sub id="sub2"/></elt></doc>';
$t= new XML::Twig;
$t->parse( $doc);
$res= $t->first_elt->id;
$exp_res= 'doc1';
if( $res eq $exp_res) { print "ok 56\n"; }
else { print "not ok 56\n"; warn "returns \n$res\n instead of \n$exp_res\n"; }
$res= $t->first_elt( 'doc')->id;
$exp_res= 'doc1';
if( $res eq $exp_res) { print "ok 57\n"; }
else { print "not ok 57\n"; warn "returns \n$res\n instead of \n$exp_res\n"; }
$res= $t->first_elt( 'sub')->id;
$exp_res= 'sub1';
if( $res eq $exp_res) { print "ok 58\n"; }
else { print "not ok 58\n"; warn "returns \n$res\n instead of \n$exp_res\n"; }
$sub1= $t->first_elt( 'sub');
$res= $sub1->next_elt( 'sub')->id;
$exp_res= 'sub2';
if( $res eq $exp_res) { print "ok 59\n"; }
else { print "not ok 59\n"; warn "returns \n$res\n instead of \n$exp_res\n"; }
$sub1= $t->first_elt( 'sub');
$res= $sub1->next_elt( $sub1, 'sub');
unless( defined $res) { print "ok 60\n"; }
else { print "not ok 60\n"; warn "should return undef, returned elt is " . $res->id; }
$sub1= $t->first_elt( 'sub');
$sub2= $sub1->next_elt( 'sub');
$res= $sub2->next_elt( 'sub');
unless( defined $res) { print "ok 61\n"; }
else { print "not ok 61\n"; warn "should return undef, returned elt is" . $res->id; }
# test : (for name spaces) in elements
$doc="<doc><ns:p>p1</ns:p><p>p</p><ns:p>p2</ns:p></doc>";
$res='';
$exp_res='p1p2';
$t= new XML::Twig( TwigHandlers => { 'ns:p' => sub { $res .= $_[1]->text; } });
$t->parse( $doc);
if( $res eq $exp_res) { print "ok 62\n"; }
else { print "not ok 62\n"; warn "should return $exp_res, returned $res"; }
$exp_res="p";
my $e_res= $t->get_xpath( '/doc/p', 0);
$res= $e_res->text;
if( $res eq $exp_res) { print "ok 63\n"; }
else { print "not ok 63\n"; warn "should return $exp_res, returned $res"; }
$exp_res='p1p2';
$res='';
foreach ($t->get_xpath( 'ns:p'))
{ $res .= $_->text; }
if( $res eq $exp_res) { print "ok 64\n"; }
else { print "not ok 64\n"; warn "should return $exp_res, returned $res"; }
# test : (for name spaces) in attributes
$doc='<doc><ns:p ns:a="a1">p1</ns:p><p ns:a="a1">p</p><p a="a1">p3</p>
<ns:p ns:a="a2">p2</ns:p></doc>';
$res='';
$exp_res='p1';
$t= new XML::Twig( TwigHandlers =>
{ 'ns:p[@ns:a="a1"]' => sub { $res .= $_[1]->text; } });
$t->parse( $doc);
if( $res eq $exp_res) { print "ok 65\n"; }
else { print "not ok 65\n"; warn "should return $exp_res, returned $res"; }
$res='';
$exp_res='p3';
foreach ($t->find_nodes( 'p[@a="a1"]'))
{ $res .= $_->text; }
if( $res eq $exp_res) { print "ok 66\n"; }
else { print "not ok 66\n"; warn "should return $exp_res, returned $res"; }
$res='';
$exp_res='p1';
foreach ($t->find_nodes( 'ns:p[@ns:a="a1"]'))
{ $res .= $_->text; }
if( $res eq $exp_res) { print "ok 67\n"; }
else { print "not ok 67\n"; warn "should return $exp_res, returned $res"; }
$res='';
$exp_res='p1p2';
foreach ($t->get_xpath( 'ns:p[@ns:a="a1" or @ns:a="a2"]'))
{ $res .= $_->text; }
if( $res eq $exp_res) { print "ok 68\n"; }
else { print "not ok 68\n"; warn "should return $exp_res, returned $res"; }
$res='';
$exp_res='p';
foreach ($t->get_xpath( 'p[@b="a1" or @ns:a="a1"]'))
{ $res .= $_->text; }
if( $res eq $exp_res) { print "ok 69\n"; }
else { print "not ok 69\n"; warn "should return $exp_res, returned $res"; }
$doc='<doc><p ns:a="a1">p1</p><p a="a1">p2</p><p>p3</p><p a="0">p4</p></doc>';
$res='';
$exp_res='p2p4';
$t= new XML::Twig( twig_handlers =>
{ 'p[@a]' => sub { $res .= $_[1]->text; } });
$t->parse( $doc);
if( $res eq $exp_res) { print "ok 70\n"; }
else { print "not ok 70\n"; warn "should return $exp_res, returned $res"; }
$res='';
foreach ($t->get_xpath( '//p[@a]'))
{ $res .= $_->text; }
if( $res eq $exp_res) { print "ok 71\n"; }
else { print "not ok 71\n"; warn "should return $exp_res, returned $res"; }
$res='';
$exp_res='p1p2p4';
foreach ($t->get_xpath( '//p[@ns:a or @a ]'))
{ $res .= $_->text; }
if( $res eq $exp_res) { print "ok 72\n"; }
else { print "not ok 72\n"; warn "should return $exp_res, returned $res"; }
$doc='<doc><p a="a1">p1</p><ns:p a="a1">p2</ns:p>
<p>p3</p><p a="0">p4</p></doc>';
$res='';
$exp_res='p1p2p4';
$t= new XML::Twig();
$t->parse( $doc);
$res .= $_->text foreach ($t->get_xpath( '//*[@a]'));
if( $res eq $exp_res) { print "ok 73\n"; }
else { print "not ok 73\n"; warn "should return $exp_res, returned $res"; }
$res='';
$exp_res='p1p2';
$res .= $_->text foreach ($t->get_xpath( '*[@a="a1"]'));
if( $res eq $exp_res) { print "ok 74\n"; }
else { print "not ok 74\n"; warn "should return $exp_res, returned $res"; }
$res='';
$exp_res='p1p2';
$res .= $_->text foreach ($t->get_xpath( '//*[@a="a1"]'));
if( $res eq $exp_res) { print "ok 75\n"; }
else { print "not ok 75\n"; warn "should return $exp_res, returned $res"; }
$res='';
$exp_res='p1';
$res .= $_->text foreach ($t->get_xpath( 'p[string()= "p1"]'));
if( $res eq $exp_res) { print "ok 76\n"; }
else { print "not ok 76\n"; warn "should return $exp_res, returned $res"; }
$doc='<doc><ns:p ns:a="a1">p1</ns:p><p ns:a="a1">p</p><p a="a1">p3</p>
<ns:p ns:a="a2">p2</ns:p></doc>';
$res='';
$exp_res='p1p';
$t= new XML::Twig( TwigHandlers =>
{ '[@ns:a="a1"]' => sub { $res .= $_[1]->text; } });
$t->parse( $doc);
if( $res eq $exp_res) { print "ok 77\n"; }
else { print "not ok 77\n"; warn "should return $exp_res, returned $res"; }
$res='';
$res2='';
$exp_res2='p2';
$t= new XML::Twig( TwigHandlers =>
{ '[@ns:a="a1"]' => sub { $res .= $_[1]->text; },
'[@ns:a="a2"]' => sub { $res2 .= $_[1]->text; } });
$t->parse( $doc);
if( $res eq $exp_res) { print "ok 78\n"; }
else { print "not ok 78\n"; warn "should return $exp_res, returned $res"; }
if( $res2 eq $exp_res2) { print "ok 79\n"; }
else { print "not ok 79\n"; warn "should return $exp_res2, returned $res2"; }
$elt= XML::Twig::Elt->new( 'p', { att => 'val', '#EMPTY' => 0 });
$res= $elt->sprint;
$exp_res= '<p att="val"></p>';
if( $res eq $exp_res) { print "ok 80\n"; }
else { print "not ok 80\n"; warn "returns $res instead of $exp_res\n"; }
exit 0;

93
t/test_3_24.t Executable file
View File

@ -0,0 +1,93 @@
#!/usr/bin/perl -w
use strict;
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
$|=1;
my $DEBUG=0;
use XML::Twig;
my $TMAX=15;
print "1..$TMAX\n";
{ # adding comments or pi's before/after the root
my $doc= XML::Twig->nparse( '<doc/>');
my $xsl = XML::Twig::Elt->new('#PI');
$xsl->set_target('xml-stylesheet');
$xsl->set_data('type= "text/xsl" href="xsl_style.xsl"');
$xsl->paste( before => $doc->root);
is( $doc->sprint, '<?xml-stylesheet type= "text/xsl" href="xsl_style.xsl"?><doc/>',
'PI before the root'
);
my $comment= XML::Twig::Elt->new( '#COMMENT');
$comment->set_comment( 'foo');
$comment->paste( before => $doc->root);
is( $doc->sprint, '<?xml-stylesheet type= "text/xsl" href="xsl_style.xsl"?><!--foo--><doc/>',
'Comment before the root'
);
XML::Twig::Elt->new( '#COMMENT')->set_comment( 'bar')->paste( after => $doc->root);
XML::Twig::Elt->new( '#PI')->set_target( 'foo')->set_data( 'bar')->paste( after => $doc->root);
is( $doc->sprint, '<?xml-stylesheet type= "text/xsl" href="xsl_style.xsl"?><!--foo--><doc/><!--bar--><?foo bar?>',
'Pasting things after the root'
);
}
{ # adding comments or pi's before/after the root
my $doc= XML::Twig->nparse( '<doc/>');
$doc->add_stylesheet( xsl => 'xsl_style.xsl');
is( $doc->sprint, '<?xml-stylesheet type="text/xsl" href="xsl_style.xsl"?><doc/>', 'add_stylesheet');
eval{ $doc->add_stylesheet( foo => 'xsl_style.xsl') };
matches( $@, q{^unsupported style sheet type 'foo'}, 'unsupported stylesheet type');
}
{ # creating a CDATA element
my $elt1= XML::Twig::Elt->new( foo => { '#CDATA' => 1 }, '<&>');
is( $elt1->sprint, '<foo><![CDATA[<&>]]></foo>', "creating a CDATA element");
my $elt2= XML::Twig::Elt->new( foo => { '#CDATA' => 1, att => 'v1' }, '<&>');
is( $elt2->sprint, '<foo att="v1"><![CDATA[<&>]]></foo>', "creating a CDATA element");
eval { my $elt3= XML::Twig::Elt->new( foo => { '#CDATA' => 1 }, "bar", $elt1); };
matches( $@, qr/^element #CDATA can only be created from text/,
"error in creating CDATA element");
my $elt4= XML::Twig::Elt->new( foo => { '#CDATA' => 1 }, '<&>', 'bar');
is( $elt4->sprint, '<foo><![CDATA[<&>bar]]></foo>', "creating a CDATA element (from list)");
}
{ # errors creating text/comment/pi elements
eval { my $elt= XML::Twig::Elt->new( '#PCDATA', []); };
matches( $@, qr/^element #PCDATA can only be created from text/, "error in creating PCDATA element");
eval { my $elt= XML::Twig::Elt->new( '#COMMENT', "foo", []); };
matches( $@, qr/^element #COMMENT can only be created from text/, "error in creating COMMENT element");
eval { my $elt= XML::Twig::Elt->new( '#PI', "foo", [], "bah!"); };
matches( $@, qr/^element #PI can only be created from text/, "error in creating PI element");
}
{ # set_cdata on non CDATA element
my $elt = XML::Twig::Elt->new("qux");
$elt->set_cdata("test this '<' & this '>'");
is( $elt->sprint, q{<qux><![CDATA[test this '<' & this '>']]></qux>}, "set_cdata on non CDATA element");
}
{ # set_comment on non comment element
my $elt = XML::Twig::Elt->new(qux => "toto");
$elt->set_comment( " booh ");
is( $elt->sprint, q{<!-- booh -->}, "set_comment on non comment element");
}
{ # set_pi on non pi element
my $elt = XML::Twig::Elt->new(qux => "toto");
$elt->set_pi( ta => "tie ramisu");
is( $elt->sprint, q{<?ta tie ramisu?>}, "set_pi on non pi element");
}

149
t/test_3_26.t Executable file
View File

@ -0,0 +1,149 @@
#!/usr/bin/perl -w
use strict;
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
$|=1;
my $DEBUG=0;
use XML::Twig;
my $DECL=qq{<?xml version="1.0" encoding="iso-8859-1"?>\n};
$DECL='';
my $TMAX=18;
print "1..$TMAX\n";
{ # testing set_inner_xml
my $doc= '<doc><elt/><elt2>with content <p>toto</p></elt2></doc>';
my $t= XML::Twig->nparse( $doc);
my $inner= '<p1/><p>foo</p><bar><elt id="toto">duh</elt></bar>';
$t->first_elt( 'elt')->set_inner_xml( $inner);
(my $expected= $doc)=~ s{<elt/>}{<elt>$inner</elt>};
is( $t->sprint, $expected, "set_inner_xml");
$t->first_elt( 'elt2')->set_inner_xml( $inner);
$expected=~ s{<elt2>.*</elt2>}{<elt2>$inner</elt2>};
is( $t->sprint, $expected, "set_inner_xml (of an elt with content)");
}
{ # testing set_inner_html
if( !XML::Twig::_use( 'HTML::TreeBuilder', 3.13))
{ skip( 4 => "need HTML::TreeBuilder 3.13+ to use set_inner_html method");
}
elsif( !XML::Twig::_use( 'LWP'))
{ skip( 4 => "need LWP to use set_inner_html method");
}
else
{
my $doc= '<html><head><title>a title</title></head><body>par 1<p>par 2<br>after the break</body></html>';
my $t= XML::Twig->nparse( $doc);
my $inner= '<ul><li>foo</li><li>bar</li></ul>';
$t->first_elt( 'p')->set_inner_html( $inner);
(my $expected= $t->sprint)=~ s{<p>.*</p>}{<p>$inner</p>};
is( $t->sprint, $expected, "set_inner_html");
$inner= q{<title>2cd title</title><meta content="bar" name="foo">};
$t->first_elt( 'head')->set_inner_html( $inner);
$inner=~ s{>$}{/>};
$expected=~ s{<head>.*</head>}{<head>$inner</head>};
$expected=~ s{(<meta[^>]*)(/>)}{$1 $2}g;
is( $t->sprint, $expected, "set_inner_html (in head)");
$inner= q{<p>just a p</p>};
$t->root->set_inner_html( $inner);
$expected= qq{$DECL<html><head></head><body>$inner</body></html>};
is( $t->sprint, $expected, "set_inner_html (all doc)");
$inner= q{the content of the <br/> body};
$t->first_elt( 'body')->set_inner_html( $inner);
$expected= qq{$DECL<html><head></head><body>$inner</body></html>};
$expected=~ s{<br/>}{<br />}g;
is( $t->sprint, $expected, "set_inner_html (body)");
}
}
{ if( !XML::Twig::_use( "File::Temp"))
{ skip( 5, "File::Temp not available"); }
else
{
# parsefile_inplace
my $file= "test_3_26.xml";
spit( $file, q{<doc><foo>nice hey?</foo></doc>});
XML::Twig->new( twig_handlers => { foo => sub { $_->set_tag( 'bar')->flush; }})
->parsefile_inplace( $file);
matches( slurp( $file), qr/<bar>/, "parsefile_inplace");
XML::Twig->new( twig_handlers => { bar => sub { $_->set_tag( 'toto')->flush; }})
->parsefile_inplace( $file, '.bak');
matches( slurp( $file), qr/<toto>/, "parsefile_inplace (with backup, checking file)");
matches( slurp( "$file.bak"), qr/<bar>/, "parsefile_inplace (with backup, checking backup)");
unlink( "$file.bak");
XML::Twig->new( twig_handlers => { toto => sub { $_->set_tag( 'tata')->flush; }})
->parsefile_inplace( $file, 'bak_*');
matches( slurp( $file), qr/<tata>/, "parsefile_inplace (with complex backup, checking file)");
matches( slurp( "bak_$file"), qr/<toto>/, "parsefile_inplace (with complex backup, checking backup)");
unlink( "bak_$file");
unlink $file;
}
}
{ if( !XML::Twig::_use( "File::Temp"))
{ skip( 5, "File::Temp not available"); }
elsif( !XML::Twig::_use( "HTML::TreeBuilder"))
{ skip( 5, "HTML::TreeBuilder not available"); }
elsif( !XML::Twig::_use( "LWP"))
{ skip( 5, "LWP not available"); }
elsif( !XML::Twig::_use( "LWP::UserAgent"))
{ skip( 5, "LWP::UserAgent not available"); }
else
{
# parsefile_html_inplace
my $file= "test_3_26.html";
spit( $file, q{<html><head><title>foo</title><body><p>this is it</p></body></html>>});
XML::Twig->new( twig_handlers => { p => sub { $_->set_tag( 'h1')->flush; }})
->parsefile_html_inplace( $file);
matches( slurp( $file), qr/<h1>/, "parsefile_html_inplace");
XML::Twig->new( twig_handlers => { h1 => sub { $_->set_tag( 'blockquote')->flush; }}, error_context => 6)
->parsefile_html_inplace( $file, '.bak');
matches( slurp( $file), qr/<blockquote>/, "parsefile_html_inplace (with backup, checking file)");
matches( slurp( "$file.bak"), qr/<h1>/, "parsefile_html_inplace (with backup, checking backup)");
unlink( "$file.bak");
XML::Twig->new( twig_handlers => { blockquote => sub { $_->set_tag( 'div')->flush; }})
->parsefile_html_inplace( $file, 'bak_*');
matches( slurp( $file), qr/<div>/, "parsefile_html_inplace (with complex backup, checking file)");
matches( slurp( "bak_$file"), qr/<blockquote>/, "parsefile_html_inplace (with complex backup, checking backup)");
unlink( "bak_$file");
unlink $file;
}
}
{ use Cwd;
if( XML::Twig::_use( "LWP::Simple") && XML::Twig::_use( "LWP::UserAgent"))
{ my $file = "test_uri";
my $uri = sprintf( "file://%s/%s", getcwd, $file);
my $content= "ok";
spit( test_uri => $content);
is( XML::Twig::_slurp_uri( $uri), $content, "testing _slurp_uri");
}
else
{ skip( 1, "LWP::Simple or LWP::UserAgent not available"); }
}
{ # test syntax error in XPath predicate (RT #19499)
my $t= XML::Twig->nparse( '<doc/>');
eval { $t->get_xpath( '/*[@!a]'); };
matches( $@, qr/^error in xpath expression/, "syntax error in XPath predicate");
}

383
t/test_3_27.t Executable file
View File

@ -0,0 +1,383 @@
#!/usr/bin/perl -w
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
$|=1;
my $DEBUG=0;
use XML::Twig;
my $TMAX=82;
print "1..$TMAX\n";
{ # test reverse call mode
my $doc=q{<doc id="d"><a id="a1"><b id="b1"/><b id="b2"/><c id="c1"/><b id="b3"/></a>
<e id="e1"/>
<a id="a2"><b id="b4"/><b id="b5"/><c id="c2"/><b id="b6"/></a>
</doc>
};
my $res='';
my $t= XML::Twig->new( twig_handlers => { '_all_' => sub { $res.= $_->id } },
top_down_handlers => 1,
)
->parse( $doc);
is( $res, 'da1b1b2c1b3e1a2b4b5c2b6', 'top_down_handlers _all_');
$res='';
$t= XML::Twig->new( twig_handlers => { 'b' => sub { $res.= $_->id } },
top_down_handlers => 1,
)
->parse( $doc);
is( $res, 'b1b2b3b4b5b6', 'top_down_handlers b)');
$res='';
$t= XML::Twig->new( twig_handlers => { _default_ => sub { $res.= $_->id } },
top_down_handlers => 1,
)
->parse( $doc);
is( $res, 'da1b1b2c1b3e1a2b4b5c2b6', 'top_down_handlers _default_)');
$res='';
$t= XML::Twig->new( twig_handlers => { a => sub { $res.= $_->id; },
b => sub { $res.= $_->id; },
c => sub { $res.= $_->id; },
e => sub { $res.= $_->id; },
},
top_down_handlers => 1,
)
->parse( $doc);
is( $res, 'a1b1b2c1b3e1a2b4b5c2b6', 'top_down_handlers with purge)');
}
{ my $called=0;
my $t= XML::Twig->new( twig_handlers => { 'doc[@a="="]' => sub { $called++; } })
-> parse( '<doc a="="/>');
is( $called, 1, 'handler on attribute with a value of "="');
}
{ # test error message for XPath query starting with a / on a node when the twig is not available
my $sect;
{ my $t= XML::Twig->nparse( '<doc><sect><elt/></sect></doc>');
$sect= $t->root->first_child( 'sect');
}
$sect->cut;
is( $sect->get_xpath( './elt', 0)->sprint, '<elt/>', " XPath query ok");
eval { $sect->get_xpath( '/doc/elt'); };
matches( $@, qr/^cannot use an XPath query starting with a \/ on a node not attached to a whole twig/, "XPath query starting with a /")
;
}
{ # test updating #att in start_tag_handlers
my( $b, $e11, $e12)= '' x 3;
my $t= XML::Twig->new( start_tag_handlers => { a => sub { $_->parent->set_att( '#a' => 1); }, },
twig_handlers => { 'e1[@#a]/b' => sub { $b .= $_->id || $_->tag },
'e1[@#a]' => sub { $e11 .= $_->id || $_->tag },
'e1[!@#a]' => sub { $e12 .= $_->id || $_->tag },
'e1[@#a=1]/b' => sub { $b .= $_->id || $_->tag },
},
)
->parse( q{<d id="d"><e1 id="e1-1"><a id="a1"/><b id="b1"/></e1><e1 id="e1-2"><c id="c1"/><b id="b2"/></e1></d>})
;
is( $b , 'b1b1', 'trigger on e1[@#a]/b');
is( $e11, 'e1-1', 'trigger on e1[@#a]' );
is( $e12, 'e1-2', 'trigger on e1[!@#a]' );
}
{ # numerical tests in handlers
my( $ngt, $nlt, $nge, $nle, $neq, $nne)= '' x 6;
my( $agt, $alt, $age, $ale, $aeq, $ane)= '' x 6;
my $t= XML::Twig->new( twig_handlers => { 'n[@a>2]' => sub { $ngt .= $_->id },
'n[@a>=2]' => sub { $nge .= $_->id },
'n[@a<2]' => sub { $nlt .= $_->id },
'n[@a<=2]' => sub { $nle .= $_->id },
'n[@a=2]' => sub { $neq .= $_->id },
'n[@a!=2]' => sub { $nne .= $_->id },
'a[@a>"b"]' => sub { $agt .= $_->id },
'a[@a>="b"]' => sub { $age .= $_->id },
'a[@a<"b"]' => sub { $alt .= $_->id },
'a[@a<="b"]' => sub { $ale .= $_->id },
'a[@a="b"]' => sub { $aeq .= $_->id },
'a[@a!="b"]' => sub { $ane .= $_->id },
},
)
->parse( q{<d id="d"><n id="n1" a="1.0"/><n id="n2" a="2.0"/><n id="n3" a="3.0"/><n id="n4"/>
<a id="a1" a="a"/><a id="a2" a="b"/><a id="a3" a="c"/><a id="a4"/>
</d>
});
is( $ngt, 'n3', ' numerical test: >' );
is( $nge, 'n2n3', ' numerical test: >=');
is( $nlt, 'n1n4', ' numerical test: <' );
is( $nle, 'n1n2n4', ' numerical test: <=');
is( $neq, 'n2', ' numerical test: =');
is( $nne, 'n1n3n4', ' numerical test: !=');
is( $agt, 'a3', ' string test: >' );
is( $age, 'a2a3', ' string test: >=');
is( $alt, 'a1a4', ' string test: <' );
is( $ale, 'a1a2a4', ' string test: <=');
is( $aeq, 'a2', ' string test: =');
is( $ane, 'a1a3a4', ' string test: !=');
}
{ # test former_* methods
my $t= XML::Twig->nparse( '<d id="d"><e id="e1"/><e id="e2"/><e id="e3"/></d>');
my $e2= $t->elt_id( 'e2');
ok( ! defined( $e2->former_parent), "former_parent on uncut element" );
ok( ! defined( $e2->former_prev_sibling), "former_prev_sibling on uncut element");
ok( ! defined( $e2->former_next_sibling), "former_next_sibling on uncut element");
$e2->cut;
is( $e2->former_parent->id, "d", "former_parent on cut element" );
is( $e2->former_prev_sibling->id, "e1", "former_prev_sibling on cut element");
is( $e2->former_next_sibling->id, "e3", "former_next_sibling on cut element");
$e2->paste( after => $e2->former_next_sibling);
is( $e2->former_parent->id, "d", "former_parent on cut element (after paste)" );
is( $e2->former_prev_sibling->id, "e1", "former_prev_sibling on cut element (after paste)");
is( $e2->former_next_sibling->id, "e3", "former_next_sibling on cut element (after paste)");
}
{ # test merge
my $t= XML::Twig->nparse( '<d id="d"><e>foo</e><e>bar</e></d>');
my $e= $t->first_elt( 'e');
$e->merge( $e->next_sibling);
is( $e->text, 'foobar', "merge");
}
if( $] > 5.008)
{ # testing ignore on the current element
my $calls;
my $h= sub { $calls.= $_[1]->tag; };
my $t= XML::Twig->new( twig_handlers => { _all_ => sub { $calls.= $_[1]->tag; } },
start_tag_handlers => { b => sub { shift()->ignore } }
)
->parse( q{<a><b><c/><d/><e/></b><b><c/><d/><e/></b><g/></a>}) ;
is( $calls, 'ga', 'ignore on an element');
is( $t->sprint, '<a><g/></a>', 'tree build with ignore on an element');
# testing ignore on a non-current element
$calls='';
my $t2= XML::Twig->new( twig_handlers => { _all_ => sub { $calls.= $_[1]->tag; } },
start_tag_handlers => { d => sub { $_[1]->parent->ignore } }
)
->parse( q{<a><f><b><c/><d/><e/></b></f><f><b><c/><d/><e/></b></f></a>})
;
is( $calls, 'cfcfa', 'ignore on a parent element');
is( $t2->sprint, '<a><f></f><f></f></a>', 'tree build with ignore on the parent of an element');
$calls='';
my $t3= XML::Twig->new( twig_handlers => { _all_ => sub { $calls.= $_[1]->tag; } },
start_tag_handlers => { d => sub { $_[1]->parent( 'b')->ignore } }
)
->parse( q{<a><f><b><c/><g><d/></g><e/></b></f><f><b><c/><g><d/></g><e/></b></f><h/></a>})
;
is( $calls, 'cfcfha', 'ignore on a grand-parent element');
is( $t3->sprint, '<a><f></f><f></f><h/></a>', 'tree build with ignore on the grand parent of an element');
$calls='';
# ignore from a regular handler
my $t4= XML::Twig->new( twig_handlers => { _default_ => sub { $calls.= $_[1]->tag; },
g => sub { $calls.= $_[1]->tag;
$_[1]->parent( 'b')->ignore;
},
}
)
->parse( q{<a><f><b><c/><g><d/></g><e/></b></f><f><b><c/><g><d/></g><e/></b></f><h/></a>})
;
is( $calls, 'cdgfcdgfha', 'ignore from a regular handler');
is( $t4->sprint, '<a><f></f><f></f><h/></a>', 'tree build with ignore on the parent of an element in a regular handler');
$calls='';
# ignore from a regular handler
my $t5= XML::Twig->new( twig_handlers => { _default_ => sub { $calls.= $_[1]->tag; },
g => sub { $calls.= $_[1]->tag;
$_[1]->parent( 'b')->ignore;
},
}
)
->parse( q{<a><x/><f><b><c/><g><d/></g><e/></b></f><f><b><c/><g><d/></g><e/></b></f><h/></a>})
;
is( $calls, 'xcdgfcdgfha', 'ignore from a regular handler (2)');
is( $t5->sprint, '<a><x/><f></f><f></f><h/></a>', 'tree build with ignore from a regular handler (2)');
eval { my $t6= XML::Twig->new( twig_handlers => { c => sub { $_->prev_elt( 'f')->ignore } })
->parse( '<a><f/><c/></a>');
};
matches( $@, '^element to be ignored must be ancestor of current element', 'error ignore-ing an element (not ancestor)');
eval { my $t6= XML::Twig->new( twig_handlers => { f => sub { $_->first_child( 'c')->ignore } })
->parse( '<a><f><c/></f></a>');
};
matches( $@, '^element to be ignored must be ancestor of current element', 'error ignore-ing an element ( descendant)');
}
else
{ skip( 12, "not tested under perl < 5.8"); }
{ my $doc='<l0><l1><l2></l2></l1><l1><l2></l2><l2></l2></l1></l0>';
(my $indented_doc= $doc)=~ s{(</?l(\d)>)}{" " x $2 . $1}eg;
$indented_doc=~ s{>}{>\n}g;
$indented_doc=~ s{<l2>\s*</l2>}{<l2></l2>}g;
is( XML::Twig->nparse( $doc)->sprint, $doc, "nparse output");
is( XML::Twig->nparse_e( $doc)->sprint, $doc, "nparse_e output");
is( XML::Twig->nparse_pp( $doc)->sprint, $indented_doc, "nparse_pp output");
is( XML::Twig->nparse_ppe( $doc)->sprint, $indented_doc, "nparse_ppe output");
}
if( _use( 'HTML::TreeBuilder', 4.00) )
{ # first alternative is pre-3.23_1, second one with 3.23_1 (and beyond?)
{ my $doc=qq{<html><head><meta 555="er"/></head><body><p>dummy</p></body></html>};
is_like( XML::Twig->nparse( $doc)->sprint, '<html><head><meta a555="er"/></head><body><p>dummy</p></body></html>', 'invalid att');
is_like( XML::Twig->nparse_e( $doc)->sprint, '<html><head><meta a555="er"/></head><body><p>dummy</p></body></html>', 'invalid att (nparse_e)');
}
{ my $doc=qq{<html><head></head><body><!-- <foo> bar </foo> --><p 1="a" c!ass="duh">dummy</p></body></html>};
# used to trigger an error, now XML::Twig is fault tolerant to bad attributes
#eval { XML::Twig->nparse_e( $doc); };
#ok( $@, "error in html (nparse_e mode 2, HTB < 3.23 or >= 4.00: $@)");
is_like( XML::Twig->nparse_e( $doc)->sprint,
'<html><head></head><body><!-- <foo> bar </foo> --><p a1="a" cass="duh">dummy</p></body></html>',
'wrong attributes, nparse_e mode 2, HTB < 3.23 or >= 4.00'
);
}
{ my $doc=qq{<html><head><script type="text/javascript"><![CDATA[ a>b || a<b ]]></script></head><body c!ass="foo"><p 1="a">dummy</p></body></html>};
# used to trigger an error, now XML::Twig is fault tolerant to bad attributes
#eval { XML::Twig->nparse_e( $doc); };
#ok( $@, "error in html (nparse_e mode 3, HTB < 3.23 or >= 4.00: $@)");
is_like( XML::Twig->nparse_e( $doc)->sprint,
'<html><head><script type="text/javascript"><![CDATA[ a>b || a<b]]></script></head><body cass="foo"><p a1="a">dummy</p></body></html>',
'wrong attributes, nparse_e mode 2, HTB < 3.23 or >= 4.00'
);
}
}
else
{ skip( 4 => "need HTML::TreeBuilder > 4.00 to test error display with HTML data"); }
{ my $e= XML::Twig::Elt->new( 'e');
is( $e->tag_to_span->sprint, '<span class="e"/>', "tag_to_span");
is( $e->tag_to_span->sprint, '<span class="e"/>', "tag_to_span again ");
is( $e->tag_to_div->sprint, '<div class="span"/>', "tag_to_div");
is( $e->tag_to_div->sprint, '<div class="span"/>', "tag_to_div again ");
}
# added coverage
{ my $doc= "<doc><![CDATA[ foo ]]></doc>\n";
my $t= XML::Twig->nparse( $doc);
(my $expected= $doc)=~ s{foo}{bar};
$t->root->first_child( '#CDATA')->set_content( ' bar ');
is( $t->root->sprint , $expected, 'set_content on a CDATA element');
}
{ my $doc= "<doc><br></br><br/><br /></doc>";
my $t= XML::Twig->nparse( pretty_print => 'none', $doc);
(my $expected= $doc)=~ s{(<br></br>|<br\s*/>)}{<br></br>}g;
is( $t->root->sprint( { empty_tags => 'expand' } ) , $expected, 'sprint br with empty_tags expand');
($expected= $doc)=~ s{(<br></br>|<br\s*/>)}{<br />}g;
is( $t->root->sprint( { empty_tags => 'html' } ) , $expected, 'sprint br with empty_tags html');
($expected= $doc)=~ s{(<br></br>|<br\s*/>)}{<br/>}g;
is( $t->root->sprint( { empty_tags => 'normal' } ) , $expected, 'sprint br with empty_tags normal');
}
{ my $doc= "<doc><p>foo</p><p>bar</p></doc>";
my $t= XML::Twig->nparse( pretty_print => 'none', $doc);
is( $t->root->sprint( { pretty_print => 'indented' } ) , "<doc>\n <p>foo</p>\n <p>bar</p>\n</doc>\n", 'sprint br with pretty_print indented');
is( $t->root->sprint( { pretty_print => 'none' } ) , $doc, 'sprint br with pretty_print none');
}
{ my $doc='<d>&amp;</d>';
my $t= XML::Twig->new;
$t->set_keep_encoding( 1);
is( $t->parse( $doc)->sprint, $doc, 'set_keep_encoding(1)');
$t->set_keep_encoding( 0);
is( $t->parse( $doc)->sprint, $doc, 'set_keep_encoding(1)');
}
{ my $doc='<d att="foo"/>';
is( XML::Twig->nparse( quote => 'single', $doc)->sprint, q{<d att='foo'/>}, 'quote option');
}
{ my $doc= qq{<!DOCTYPE doc SYSTEM "dummy.dtd" [<!ENTITY obj.1 SYSTEM "o1.bmp" NDATA bmp>]>\n<doc/>};
(my $expected= $doc)=~ s{ \[.*?\]}{};
my $t= XML::Twig->nparse( $doc);
my $entity_list = $t->entity_list;
foreach my $entity ($entity_list->list()) { $entity_list->delete($entity->name); }
is( $t->sprint( Update_DTD => 1 ), $expected, 'parse entities with all chars in their name');
}
{ my $tmp= "tmp";
foreach my $doc ( qq{<!DOCTYPE d [<!ENTITY e SYSTEM "e.jpeg" NDATA JPEG>]><d/>},
qq{<!DOCTYPE d><d/>},
qq{<!DOCTYPE d []><d/>},
)
{ foreach my $keep_encoding ( 0..1)
{ open( MYOUT, ">$tmp") or die "cannot open $tmp: $!";
my $t= XML::Twig->new( twig_roots=> { dummy => sub {} },
twig_print_outside_roots => \*MYOUT,
keep_encoding => $keep_encoding,
)
->parse( $doc);
close MYOUT;
is_like( slurp( $tmp), $doc, "file with no DTD but entities (keep_encoding: $keep_encoding)");
unlink $tmp;
}
}
}
{ my $doc=qq{<d><e1 id="e1">foo<e id="e">bar</e>baz</e1><e1 id="e2">toto <![CDATA[tata]]> tutu</e1></d>};
my $t= XML::Twig->parse( $doc);
is( $t->elt_id( "e1")->text( 'no_recurse'), 'foobaz', "text_only");
is( $t->elt_id( "e2")->text_only, 'toto tata tutu', "text_only (cdata section)");
is( $t->elt_id( "e")->text_only, 'bar', "text_only (no embedded elt)");
}
{ my $doc=qq{<!DOCTYPE d SYSTEM "dummy.dtd" []><d><e1 id="e1">tutu &lt;&ent; <b>no</b>tata</e1></d>};
my $t= XML::Twig->parse( $doc);
is( $t->elt_id( "e1")->text(), 'tutu <&ent; notata', "text with ent");
is( $t->elt_id( "e1")->text( 'no_recurse'), 'tutu <&ent; tata', "text no_recurse with ent");
is( $t->elt_id( "e1")->xml_text( ), 'tutu &lt;&ent; notata', "xml_text with ent");
is( $t->elt_id( "e1")->xml_text( 'no_recurse'), 'tutu &lt;&ent; tata', "xml_text no_recurse with ent");
}
if( $] > 5.008)
{ my $r;
XML::Twig->parse( twig_handlers => { '/a/b//c' => sub { $r++; } },
q{<a><b><b><c>foo</c></b></b></a>}
);
ok( $r, "handler condition with // and nested elts (/a//b/c)");
}
else
{ skip( 1, "not tested under perl < 5.8"); }
if( $] > 5.008)
{ my @r;
XML::Twig->parse( twig_handlers => { 's[@#a="1"]' => sub { push @r, $_->id},
's/e[@x="1"]' => sub { $_->parent->set_att( '#a' => 1); },
},
q{<d><s id="s1"><e x="2"/><e /></s><s id="s2"><e x="1" /></s><s id="s3"><e x="2" /> <e x="1"/></s></d>},
);
is( join( ':', @r), 's2:s3', 'inner handler changing parent attribute value');
}
else
{ skip( 1, "not tested under perl < 5.8"); }
if( $] > 5.008)
{ my @r;
XML::Twig->parse( twig_roots => { '/d/s[@a="1"]/e[@a="1"]' => => sub { push @r, $_->id}, },
q{<d><s><e a="1" id="e1"/><e id="e2"/></s>
<s a="1"><e a="1" id="e3"/><e id="e4"/></s>
<s><e a="1" id="e5"/><e id="e6"/></s>
<s a="1"><e id="e7"/><e id="e8" a="1"/></s>
</d>},
);
is( join( ':', @r), 'e3:e8', 'complex condition with twig_roots');
}
else
{ skip( 1, "not tested under perl < 5.8"); }
exit 0; # or you get a weird error under 5.6.2

329
t/test_3_30.t Executable file
View File

@ -0,0 +1,329 @@
#!/usr/bin/perl -w
use strict;
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
$|=1;
my $DEBUG=0;
use XML::Twig;
my $TMAX=87;
print "1..$TMAX\n";
if( _use( 'Tie::IxHash'))
{ # test the new indent format example from http://tinyurl.com/2kwscq
my $doc=q{<?xml version="1.0" encoding="UTF-8"?>
<widget
xmlns="http://xmlns.oracle.com/widgets"
id="first.widget"
class="FirstWidgetClass">
<!-- This is a comment about widget instance -->
<widget-instance>
<!-- This is OK, on one line because there is only one attribute -->
<subwidget id="sub.widget" />
<!-- This one has two attributes, so is split up. -->
<subwidget
id="sub.widget.2"
name="SubWidget2"
/>
</widget-instance>
</widget>
};
my $formatted= XML::Twig->parse( keep_atts_order => 1, pretty_print => cvs => $doc)->sprint;
is( $formatted, $doc, 'cvs pretty_print');
}
else
{ skip( 1, "Tie::IxHash not available, cannot test the cvs pretty_print option"); }
if( $XML::Parser::VERSION > 2.27)
{ my $test_dir= "ent_test";
mkdir( $test_dir, 0777) or die "cannot create $test_dir: $!" unless( -d $test_dir);
my $xml_file_base = "test.xml";
my $xml_file= File::Spec->catfile( $test_dir => $xml_file_base);
my $ent_file_base = "ent.xml";
my $ent_file= File::Spec->catfile( $test_dir => $ent_file_base);
my $doc= qq{<!DOCTYPE x [ <!ENTITY ent SYSTEM "$ent_file_base" > ]><x>&ent;</x>};
my $ent= qq{<foo/>};
spit( $xml_file, $doc);
spit( $ent_file, $ent);
my $expected= '<x><foo/></x>';
is( XML::Twig->parse( pretty_print => 'none', $xml_file)->root->sprint, $expected, 'entity resolving when file is in a subdir');
unlink $xml_file or die "cannot remove $xml_file: $!";
unlink $ent_file or die "cannot remove $ent_file: $!";
rmdir $test_dir or die "cannot remove $test_dir: $!";
}
else
{ skip( 1 => "known bug with old XML::Parser versions: base uri not taken into account,\n"
. "see RT #25113 at http://rt.cpan.org/Public/Bug/Display.html?id=25113"
);
}
{ my $doc= "<d><s><a/><e/><e/></s></d>";
my $doc_file= "doc.xml";
spit( $doc_file, $doc);
my $t= XML::Twig->new;
foreach (1..3)
{ $t->parse( $doc);
is( $t->sprint, $doc, "re-using a twig with parse (run $_)");
$t->parse( $doc);
is( $t->sprint, $doc, "re-using a twig with parse (run $_)");
$t->parsefile( $doc_file);
is( $t->sprint, $doc, "re-using a twig with parsefile (run $_)");
$t->parsefile( $doc_file);
is( $t->sprint, $doc, "re-using a twig with parsefile (run $_)");
}
unlink $doc_file;
}
{ my $invalid_doc= "<d><s><a/><e/><e/><a></d>";
my $invalid_doc_file= "invalid_doc.xml";
spit( $invalid_doc_file, $invalid_doc);
my $expected="e";
my( $result);
my $expected_sprint="<d><s><a/><e/></s></d>";
my $t= XML::Twig->new( twig_handlers => { e => sub { $result.= $_->tag; shift->finish_now } });
foreach (1..3)
{ $result='';
$t->parse( $invalid_doc);
is( $result, $expected, "finish_now with parse (run $_)");
is( $t->sprint, $expected_sprint, "finish_now with parse (sprint, run $_)");
$result='';
$t->parsefile( $invalid_doc_file);
is( $result, $expected, "finish_now with parsefile (run $_)");
is( $t->sprint, $expected_sprint, "finish_now with parse (sprint, run $_)");
}
unlink $invalid_doc_file;
}
{ my $doc1=qq{<?xml version="1.0" encoding="UTF-8"?>\n<!DOCTYPE d1 [\n<!ELEMENT d1 (#PCDATA)><!ENTITY e1 "[e1]"><!ENTITY e2 "[e2]">\n]>\n<d1> t1 &e1; &e2;</d1>};
my $doc2=qq{<?xml version="1.0" encoding="UTF-8"?>\n<!DOCTYPE d2 [\n<!ELEMENT d2 (#PCDATA)><!ENTITY e1 "[e1]"><!ENTITY e3 "[e3]">\n]>\n<d2> t1 &e1; &e3;</d2>};
(my $edoc1 = $doc1)=~ s{&e(\d);}{[e$1]}g;
(my $edoc2 = $doc2)=~ s{&e(\d);}{[e$1]}g;
my $t= XML::Twig->new( keep_spaces => 1);
is( $t->parse( $doc1)->sprint, $edoc1, "XML::Twig reuse (run 1: doc1)");
is( $t->parse( $doc2)->sprint, $edoc2, "XML::Twig reuse (run 2: doc2)");
is( $t->parse( $doc1)->sprint, $edoc1, "XML::Twig reuse (run 3: doc1)");
is( $t->parse( $doc1)->sprint, $edoc1, "XML::Twig reuse (run 4: doc1)");
is( $t->parse( $doc2)->sprint, $edoc2, "XML::Twig reuse (run 5: doc2)");
is( $t->parse( $doc2)->sprint, $edoc2, "XML::Twig reuse (run 6: doc2)");
}
# some additional coverage
{ # entity sprint
my $tata= "tata content";
spit( "tata.txt", $tata);
my %ent_desc=( foo => q{"toto"}, bar => q{SYSTEM "tata.txt"}, baz => q{SYSTEM "tutu.txt" NDATA gif});
my %decl= map { $_ => "<!ENTITY $_ $ent_desc{$_}>" } keys %ent_desc;
my $decl_string= join( '', values %decl);
my $doc= qq{<!DOCTYPE d [ $decl_string ]><d/>};
my $t= XML::Twig->parse( $doc);
foreach my $ent (sort keys %decl)
{ is( $t->entity( $ent)->sprint, $decl{$ent}, "sprint entity $ent ($decl{$ent})"); }
}
{ # purge on an element
{ my $t= XML::Twig->parse( twig_handlers => { e2 => sub { $_->purge } }, q{<d><e1/><e2/><e3/></d>});
is( $t->root->first_child->tag, 'e3', "purge on the current element");
}
{ my $t= XML::Twig->parse( twig_handlers => { e2 => sub { $_->prev_sibling->purge } }, q{<d><e1/><e2/><e3/></d>});
is( $t->root->first_child->tag, 'e2', "purge on an element");
}
{ my $t= XML::Twig->parse( twig_handlers => { e2 => sub { $_->prev_sibling->purge( $_) } }, q{<d><e1/><e2/><e3/></d>});
is( $t->root->first_child->tag, 'e3', "purge on an element up to the current element");
}
{ my $t= XML::Twig->parse( twig_handlers => { e3 => sub { $_->prev_sibling( 'e1')->purge( $_->prev_sibling) } }, q{<d><e1/><e2/><e3/></d>});
is( $t->root->first_child->tag, 'e3', "purge on an element up to an other element");
}
{ my $t= XML::Twig->parse( twig_handlers => { e2 => sub { $_[0]->purge_up_to( $_->prev_sibling) } }, q{<d><e1/><e2/><e3/></d>});
is( $t->root->first_child->tag, 'e2', "purge_up_to");
}
}
{ my $t= XML::Twig->parse( '<!DOCTYPE foo PUBLIC "-//xmltwig//DTD xmltwig test 1.0//EN" "foo.dtd" [<!ELEMENT d (#PCDATA)>]><d/>');
is( $t->doctype_name, 'foo', 'doctype_name (with value)');
is( $t->system_id, 'foo.dtd', 'system_id (with value)');
is( $t->public_id, '-//xmltwig//DTD xmltwig test 1.0//EN', 'public_id (with value)');
is( $t->internal_subset, '<!ELEMENT d (#PCDATA)>', 'internal subset (with value)');
}
{ my $t= XML::Twig->parse( '<d/>');
is( $t->doctype_name, '', 'doctype_name (no value)');
is( $t->system_id, '', 'system_id (no value)');
is( $t->public_id, '', 'public_id (no value)');
is( $t->internal_subset, '', 'internal subset (no value)');
}
{ my $t= XML::Twig->parse( '<!DOCTYPE foo SYSTEM "foo.dtd"><d/>');
is( $t->doctype_name, 'foo', 'doctype_name (with value)');
is( $t->system_id, 'foo.dtd', 'system_id (with value)');
is( $t->public_id, '', 'public_id (no value)');
is( $t->internal_subset, '', 'internal subset (no value)');
}
{ my $t= XML::Twig->parse( '<!DOCTYPE foo [<!ELEMENT d (#PCDATA)>]><d/>');
is( $t->doctype_name, 'foo', 'doctype_name (with value)');
is( $t->system_id, '', 'system_id (no value)');
is( $t->public_id, '', 'public_id (no value)');
is( $t->internal_subset, '<!ELEMENT d (#PCDATA)>', 'internal subset (with value)');
}
{ my $prolog= '<!DOCTYPE foo PUBLIC "-//xmltwig//DTD xmltwig test 1.0//EN" "foo.dtd" [<!ELEMENT d (#PCDATA)>]>';
my $doc= '<d/>';
my $t= XML::Twig->parse( $prolog . $doc);
(my $expected_prolog= $prolog)=~ s{foo}{d};
$t->set_doctype( 'd');
is_like( $t->doctype, $expected_prolog, 'set_doctype');
is_like( $t->sprint, $expected_prolog . $doc);
}
{ # test external entity declaration with SYSTEM _and_ PUBLIC
# create external entities
my @ext_files= qw( tata1 tata2);
foreach my $file (@ext_files) { spit( $file => "content of $file"); }
my $doc= q{<!DOCTYPE foo [<!ENTITY % bar1 PUBLIC "toto1" "tata1">%bar1;<!ENTITY bar2 PUBLIC "toto2" "tata2">%bar2;]><d><elt/></d>};
is_like( XML::Twig->parse( $doc)->sprint, $doc, 'external entity declaration with SYSTEM _and_ PUBLIC, regular parse/sprint');
my $out_file= "tmp_test_ext_ent.xml";
open( OUT, ">$out_file") or die "cannot create temp result file '$out_file': $!";
XML::Twig->parse( twig_roots => { elt => sub { $_->print( \*OUT) } }, twig_print_outside_roots => \*OUT, $doc);
close OUT;
is_like( slurp( $out_file), $doc, 'external entity declaration with SYSTEM _and_ PUBLIC, with twig_roots');
unlink $out_file;
open( OUT, ">$out_file") or die "cannot create temp result file '$out_file': $!";
XML::Twig->parse( twig_roots => { elt => sub { $_->print( \*OUT) } }, twig_print_outside_roots => \*OUT, keep_encoding => 1, $doc);
close OUT;
is_like( slurp( $out_file), $doc, 'external entity declaration with SYSTEM _and_ PUBLIC, with twig_roots and keep_encoding');
unlink @ext_files, $out_file;
}
{ my $doc= q{<doc><elt><selt>selt 1</selt><selt>selt 2</selt></elt></doc>};
my $t= XML::Twig->parse( pretty_print => 'indented', $doc);
my $elt_indented = "\n <selt>selt 1</selt>\n <selt>selt 2</selt>";
my $elt_not_indented = "<selt>selt 1</selt><selt>selt 2</selt>";
is( $t->first_elt( 'elt')->xml_string, $elt_indented, 'xml_string, indented');
is( $t->first_elt( 'elt')->xml_string( { pretty_print => 'none'} ), $elt_not_indented, 'xml_string, NOT indented');
is( $t->first_elt( 'elt')->xml_string, $elt_indented, 'xml_string, indented again');
}
{ my $doc=q{<!DOCTYPE foo [ <!ENTITY zzent SYSTEM "zznot_there"> ]><foo>&zzent;</foo>};
eval { XML::Twig->new->parse( $doc); };
matches( $@, qr{zznot_there}, "missing SYSTEM entity: file info in the error message ($@)");
matches( $@, qr{zzent}, "missing SYSTEM entity: entity info in the error message ($@)");
}
{ if( _use( 'HTML::TreeBuilder', 3.13))
{ XML::Twig->set_pretty_print( 'none');
my $html=q{<html><body><h1>Title</h1><p>foo<br>bar</p>};
my $expected= q{<html><head></head><body><h1>Title</h1><p>foo<br />bar</p></body></html>};
is( XML::Twig->new->safe_parse_html( $html)->sprint, $expected, 'safe_parse_html');
my $html_file= "t/test_3_30.html";
spit( $html_file, $html);
is( XML::Twig->new->safe_parsefile_html( $html_file)->sprint, $expected, 'safe_parsefile_html');
if( _use( 'LWP'))
{ is( XML::Twig->new->safe_parseurl_html( "file:$html_file")->sprint, $expected, 'safe_parseurl_html'); }
else
{ skip( 1, "LWP not available, cannot test safe_parseurl_html"); }
unlink $html_file;
}
else
{ skip( 3, "HTML::TreeBuilder not available, cannot test safe_parse.*_html methods"); }
}
{ my $dump= XML::Twig->parse( q{<doc id="1"><elt>text</elt></doc>})->_dump;
my $sp=qr{[\s|-]*};
matches( $dump, qr{^document $sp doc $sp id="1" $sp elt $sp PCDATA: $sp 'text'\s*}x, "twig _dump");
}
{ my $dump= XML::Twig->parse( q{<!DOCTYPE d [ <!ENTITY foo "bar">]><d>&foo;</d>})->entity( 'foo')->_dump;
is( $dump, q{name => 'foo' - val => 'bar'}, "entity dump");
}
{ if( $XML::Parser::VERSION > 2.27)
{ my $t= XML::Twig->parse( q{<!DOCTYPE d [ <!ENTITY afoo "bar"> <!ENTITY % bfoo "baz">]><d>&afoo;</d>});
my $non_param_ent= $t->entity( 'afoo');
nok( $non_param_ent->param, 'param on a non-param entity');
my $param_ent= $t->entity( 'bfoo');
ok( $param_ent->param, 'param on a parameter entity');
}
else
{ skip( 2, "cannot use the param method with XML::Parser 2.27"); }
}
{ my $entity_file = "test_3_30.t.ent";
my $missing_file = "not_there";
spit( $entity_file => "entity text");
my $doc= qq{<!DOCTYPE d [<!ENTITY foo SYSTEM "$entity_file"><!ENTITY bar SYSTEM "$missing_file">]><d>&foo;</d>};
ok( eval { XML::Twig->parse( $doc)}, 'doc with missing external SYSTEM ents');
eval { XML::Twig->parse( expand_external_ents => 1, $doc)};
matches( $@, qr{cannot load SYSTEM entity 'bar' from 'not_there': }, 'missing SYSTEM entity');
ok( eval { XML::Twig->parse( $doc)}, 'doc with missing external SYSTEM ents');
my $t= XML::Twig->parse( expand_external_ents => -1, $doc);
my $missing_entities= $t->{twig_missing_system_entities};
is( scalar( values %$missing_entities), 1, 'number of missing system entities');
is( (values %$missing_entities)[0]->{name}, 'bar', 'name of missing system entity');
is( (values %$missing_entities)[0]->{sysid}, $missing_file, 'sysid of missing system entity');
eval { XML::Twig->parse( $doc)};
ok( eval { XML::Twig->parse( $doc)}, 'doc with missing external SYSTEM NDATA ents');
unlink( $entity_file);
}
{ my $entity_file = "test_3_30.t.gif";
my $missing_file = "not_there.gif";
spit( $entity_file => "entity text");
my $doc= qq{<!DOCTYPE d [ <!ENTITY foon SYSTEM "$entity_file" NDATA gif> <!ENTITY barn SYSTEM "$missing_file" NDATA gif>]>
<d><elt ent1="foon" ent2="barn" /></d>};
my $t= XML::Twig->parse( $doc);
my $missing_entities= $t->{twig_missing_system_entities};
is( scalar( values %$missing_entities), 1, 'number of missing system entities');
is( $missing_entities->{barn}->name, 'barn', 'name of missing system entity');
is( $missing_entities->{barn}->sysid, $missing_file, 'sysid of missing system entity');
unlink( $entity_file);
}
{ my $doc= q{<d><elt>foo <b>bar</b> baz <b>foobar</b><c>xyz</c><b>toto</b>tata<b>tutu</b></elt></d>};
my $t= XML::Twig->parse( twig_handlers => { b => sub { $_->erase } }, $doc);
is( scalar( $t->descendants( '#TEXT')), 3, 'text descendants, no melding');
$t->normalize;
is( scalar( $t->descendants( '#TEXT')), 3, 'text descendants, normalized');
}
{ my $doc=q{<d><e>e</e><e1>e1</e1><e1>e1-2</e1></d>};
XML::Twig::Elt->init_global_state(); # depending on which modules are available, the state could have been modified
my $tmp= "tmp";
open( TMP, ">$tmp") or die "cannot create temp file";
XML::Twig->parse( twig_roots => { e1 => sub { $_->flush( \*TMP) } }, twig_print_outside_roots => \*TMP, $doc);
close TMP;
my $res= slurp( $tmp);
is( $res, $doc, "bug in flush with twig_print_outside_roots");
unlink $tmp;
}
{ # test bug where #default appeared in attributes (RT #27617)
my $doc= '<ns1:doc xmlns:ns1="foo" xmlns="bar"><ns1:elt att="bar"/></ns1:doc>';
my $t= XML::Twig->new( map_xmlns => { 'foo' => 'ns2' },)->parse( $doc);
ok( grep { $_ eq 'att' } keys %{$t->root->first_child->atts}, 'no #default in attribute names');
}
exit;
1;

31
t/test_3_32.t Executable file
View File

@ -0,0 +1,31 @@
#!/usr/bin/perl -w
use strict;
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
$|=1;
my $DEBUG=0;
use XML::Twig;
my $TMAX=1;
print "1..$TMAX\n";
if( $] >= 5.008)
{ # test non ascii letters at the beginning of an element name in a selector
# can't use non ascii chars in script, so the tag name needs to come from the doc!
my $doc=q{<doc><tag>&#233;t&#233;</tag><elt>summer</elt><elt>estate</elt></doc>};
my $t= XML::Twig->parse( $doc);
my $tag= $t->root->first_child( 'tag')->text;
foreach ($t->root->children( 'elt')) { $_->set_tag( $tag); }
is( $t->root->first_child( $tag)->text, 'summer', 'non ascii letter to start a name in a condition');
}
else
{ skip( 1, "known bug in perl $]: tags starting with a non ascii letter cannot be used in expressions"); }
exit;
1;

67
t/test_3_35.t Executable file
View File

@ -0,0 +1,67 @@
#!/usr/bin/perl -w
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
$|=1;
my $DEBUG=0;
use XML::Twig;
my $TMAX=10;
print "1..$TMAX\n";
# escape_gt option
{
is( XML::Twig->parse( '<d/>')->root->insert_new_elt( '#COMMENT' => '- -- -')->twig->sprint,
'<d><!-- - - - - --></d>', 'comment escaping');
}
{ my $t= XML::Twig->parse( '<d><e a="c">foo<e>bar</e></e><e a="b">baz<e>foobar</e></e><e a="b">baz2<e a="c">foobar2</e></e></d>');
$t->root->cut_descendants( 'e[@a="c"]');
is( $t->sprint, '<d><e a="b">baz<e>foobar</e></e><e a="b">baz2</e></d>', 'cut_descendants');
}
{ my $t=XML::Twig->new( pretty_print => 'none')->parse( '<d />');
is( $t->root->_pretty_print, 0, '_pretty_print');
$t->set_pretty_print( 'indented');
is( $t->root->_pretty_print, 3, '_pretty_print');
}
# additional tests to increase coverage
{ is( XML::Twig->parse( no_expand => 1, q{<!DOCTYPE d SYSTEM "dd.dtd" [<!ENTITY foo SYSTEM "x.xml">]><d>&foo;</d>})->root->sprint, "<d>&foo;</d>\n", 'external entities with no_expand');
}
{ my $doc= q{<d id="i1"><e id="i2"><f id="i3"/></e><g><f id="i4">fi4</f></g></d>};
open( my $fh, '>', 'tmp_file');
my $t= XML::Twig->new( twig_handlers => { e => sub { $_->flush( $fh); },
g => sub { is( $_[0]->elt_id( 'i4')->text, 'fi4', 'elt_id, id exists');
nok( $_[0]->elt_id( 'i3'), 'elt_id, id flushed');
},
}
)
->parse( $doc);
}
{ my $xpath='';
XML::Twig->parse( map_xmlns => { "http://foo.com" => 'bar' },
twig_handlers => { "bar:e" => sub { $xpath= $_[0]->path( $_->gi);}, },
q{<foo:d xmlns:foo="http://foo.com"><foo:e/></foo:d>}
);
is( $xpath, '/bar:d/bar:e');
XML::Twig->parse( map_xmlns => { "http://foo.com" => 'bar' },
twig_handlers => { "bar:e" => sub { $xpath= $_[0]->path( $_->local_name);}, },
q{<d xmlns="http://foo.com"><e/></d>}
);
is( $xpath, '/bar:d/bar:e');
}
{ my $t=XML::Twig->parse( pretty_print => 'none', '<d><e1/><e2/><e3/></d>');
$t->first_elt( 'e3')->replace( $t->first_elt( 'e1'));
is( $t->sprint, '<d><e3/><e2/></d>', 'replace called on an element that has not been cut yet');
}
1;

411
t/test_3_36.t Executable file
View File

@ -0,0 +1,411 @@
#!/usr/bin/perl -w
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
$|=1;
my $DEBUG=0;
use XML::Twig;
my $TMAX=67;
print "1..$TMAX\n";
{ my $doc=q{<d><s id="s1"><t>title 1</t><s id="s2"><t>title 2</t></s><s id="s3"></s></s><s id="s4"></s></d>};
my $ids;
XML::Twig->parse( twig_handlers => { 's[t]' => sub { $ids .= $_->id; } }, $doc);
is( $ids, 's2s1', 's[t]');
}
{
my $string = q{<foo>power<baz/><bar></bar></foo>};
my $t=XML::Twig->parse( $string);
my $root = $t->root();
my $copy = $root->copy();
is( $copy->sprint, $root->sprint, 'empty elements in a copy')
}
{ my $doc=q{<d><e>e1</e><e>e2</e><e>e3</e><f>f1</f></d>};
my $t=XML::Twig->parse( $doc);
my $e1= $t->first_elt( 'e');
is( all_text( $e1->siblings), 'e2:e3:f1', 'siblings, all');
is( all_text( $e1->siblings( 'e')), 'e2:e3', 'siblings(e)');
is( all_text( $e1->siblings('f')), 'f1', 'siblings(f)');
my $e2= $e1->next_sibling( 'e');
is( all_text( $e2->siblings), 'e1:e3:f1', 'siblings (2cd elt), all');
is( all_text( $e2->siblings( 'e')), 'e1:e3', 'siblings(e) (2cd elt)');
is( all_text( $e2->siblings('f')), 'f1', 'siblings(f) (2cd elt)');
my $f= $e1->next_sibling( 'f');
is( all_text( $f->siblings), 'e1:e2:e3', 'siblings (f elt), all');
is( all_text( $f->siblings( 'e')), 'e1:e2:e3', 'siblings(e) (f elt)');
is( all_text( $f->siblings('f')), '', 'siblings(f) (f elt)');
}
{ my $doc= q{<d><e a="foo">bar</e><f a="foo2" a2="toto">bar2</f><f1>ff1</f1></d>};
my $t= XML::Twig->new( att_accessors => [ 'b', 'a' ], elt_accessors => [ 'x', 'e', 'f' ], field_accessors => [ 'f3', 'f1' ])
->parse( $doc);
my $d= $t->root;
is( $d->e->a, 'foo', 'accessors (elt + att)');
is( $d->f->a, 'foo2', 'accessors (elt + att), on f');
is( $d->f1, 'ff1', 'field accessor');
eval { $t->elt_accessors( 'tag'); };
matches( $@, q{^attempt to redefine existing method tag using elt_accessors }, 'duplicate elt accessor');
eval { $t->field_accessors( 'tag'); };
matches( $@, q{^attempt to redefine existing method tag using field_accessors }, 'duplicate elt accessor');
$t->att_accessors( 'a2');
is( $d->f->a2, 'toto', 'accessors created after the parse');
$t->elt_accessors( 'f');
$t->att_accessors( 'a2');
is( $d->f->a2, 'toto', 'accessors created twice after the parse');
$t->field_accessors( 'f1');
is( $d->f1, 'ff1', 'field accessor (created twice)');
}
{ my $doc=q{<d><e id="i1">foo</e><e id="i2">bar</e><e id="i3">vaz<e>toto</e></e></d>};
my $t= XML::Twig->parse( $doc);
$t->elt_id( 'i1')->set_outer_xml( '<f id="e1">boh</f>');
$t->elt_id( 'i3')->set_outer_xml( '<f id="e2"><g att="a">duh</g></f>');
is( $t->sprint, '<d><f id="e1">boh</f><e id="i2">bar</e><f id="e2"><g att="a">duh</g></f></d>', 'set_outer_xml');
}
{ my $doc= q{<d><e><f/><g/></e></d>};
my $t= XML::Twig->parse( $doc);
$t->first_elt( 'e')->cut_children( 'g');
is( $t->sprint, q{<d><e><f/></e></d>}, "cut_children leaves some children");
}
{ if( $] >= 5.006)
{ my $t= XML::Twig->parse( q{<d><e/></d>});
$t->first_elt( 'e')->latt( 'a')= 'b';
is( $t->sprint, q{<d><e a="b"/></d>}, 'lvalued attribute (no attributes)');
$t->first_elt( 'e')->latt( 'c')= 'd';
is( $t->sprint, q{<d><e a="b" c="d"/></d>}, 'lvalued attribute (attributes)');
$t->first_elt( 'e')->latt( 'c')= '';
is( $t->sprint, q{<d><e a="b" c=""/></d>}, 'lvalued attribute (modifying existing attributes)');
$t->root->lclass= 'foo';
is( $t->sprint, q{<d class="foo"><e a="b" c=""/></d>}, 'lvalued class (new class)');
$t->root->lclass=~ s{fo}{tot};
is( $t->sprint, q{<d class="toto"><e a="b" c=""/></d>}, 'lvalued class (modify class)');
$t= XML::Twig->parse( '<d a="1"/>');
$t->root->latt( 'a')++;
is( $t->sprint, '<d a="2"/>', '++ on attribute');
}
else
{ skip( 6 => "cannot use lvalued attributes with perl $]"); }
}
# used for all HTML parsing tests with HTML::Tidy
my $DECL= qq{<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">\n};
my $NS= 'xmlns="http://www.w3.org/1999/xhtml"';
{ # testing set_inner_html
if( !XML::Twig::_use( 'HTML::Tidy'))
{ skip( 4 => "need HTML::Tidy to use the use_tidy method method");
}
elsif( !XML::Twig::_use( 'LWP'))
{ skip( 4 => "need LWP to use set_inner_html method");
}
elsif( !XML::Twig::_use( 'HTML::TreeBuilder'))
{ skip( 4 => "need LWP to use set_inner_html method");
}
else
{
my $doc= '<html><head><title>a title</title></head><body>par 1<p>par 2<br>after the break</body></html>';
my $t= XML::Twig->new( use_tidy => 1)->parse_html( $doc);
my $inner= '<ul><li>foo</li><li>bar</li></ul>';
$t->first_elt( 'p')->set_inner_html( $inner);
(my $expected= $t->sprint)=~ s{<p>.*</p>}{<p>$inner</p>};
is( $t->sprint, $expected, "set_inner_html");
$inner= q{<title>2cd title</title><meta content="bar" name="foo">};
$t->first_elt( 'head')->set_inner_html( $inner);
$inner=~ s{>$}{/>};
$expected=~ s{<head>.*</head>}{<head>$inner</head>};
$expected=~ s{(<meta[^>]*)(/>)}{$1 $2}g;
is( $t->sprint, $expected, "set_inner_html (in head)");
$inner= q{<p>just a p</p>};
$t->root->set_inner_html( $inner);
$expected= qq{$DECL<html $NS><head></head><body>$inner</body></html>};
is( $t->sprint, $expected, "set_inner_html (all doc)");
$inner= q{the content of the <br/> body};
$t->first_elt( 'body')->set_inner_html( $inner);
$expected= qq{$DECL<html $NS><head></head><body>$inner</body></html>};
$expected=~ s{<br/>}{<br />}g;
is( $t->sprint, $expected, "set_inner_html (body)");
}
}
{ if( !XML::Twig::_use( "File::Temp"))
{ skip( 5, "File::Temp not available"); }
elsif( !XML::Twig::_use( "HTML::Tidy"))
{ skip( 5, "HTML::Tidy not available"); }
elsif( !XML::Twig::_use( "LWP"))
{ skip( 5, "LWP not available"); }
elsif( !XML::Twig::_use( "LWP::UserAgent"))
{ skip( 5, "LWP::UserAgent not available"); }
else
{
# parsefile_html_inplace
my $file= "test_3_36.html";
spit( $file, q{<html><head><title>foo</title><body><p>this is it</p></body></html>>});
XML::Twig->new( use_tidy => 1, twig_handlers => { p => sub { $_->set_tag( 'h1')->flush; }})
->parsefile_html_inplace( $file);
matches( slurp( $file), qr/<h1>/, "parsefile_html_inplace");
XML::Twig->new( use_tidy => 1, twig_handlers => { h1 => sub { $_->set_tag( 'blockquote')->flush; }}, error_context => 6)
->parsefile_html_inplace( $file, '.bak');
matches( slurp( $file), qr/<blockquote>/, "parsefile_html_inplace (with backup, checking file)");
matches( slurp( "$file.bak"), qr/<h1>/, "parsefile_html_inplace (with backup, checking backup)");
unlink( "$file.bak");
XML::Twig->new( use_tidy => 1, twig_handlers => { blockquote => sub { $_->set_tag( 'div')->flush; }})
->parsefile_html_inplace( $file, 'bak_*');
matches( slurp( $file), qr/<div>/, "parsefile_html_inplace (with complex backup, checking file)");
matches( slurp( "bak_$file"), qr/<blockquote>/, "parsefile_html_inplace (with complex backup, checking backup)");
unlink( "bak_$file");
unlink $file;
}
}
{ if( _use( 'HTML::Tidy'))
{ XML::Twig->set_pretty_print( 'none');
my $html=q{<html><body><h1>Title</h1><p>foo<br>bar</p>};
my $expected= qq{$DECL<html $NS><head><title></title></head><body><h1>Title</h1><p>foo<br />\nbar</p></body></html>};
is( XML::Twig->new( use_tidy => 1 )->safe_parse_html( $html)->sprint, $expected, 'safe_parse_html');
my $html_file= "t/test_3_30.html";
spit( $html_file, $html);
is( XML::Twig->new( use_tidy => 1 )->safe_parsefile_html( $html_file)->sprint, $expected, 'safe_parsefile_html');
if( _use( 'LWP'))
{ is( XML::Twig->new( use_tidy => 1 )->safe_parseurl_html( "file:$html_file")->sprint, $expected, 'safe_parseurl_html'); }
else
{ skip( 1, "LWP not available, cannot test safe_parseurl_html"); }
unlink $html_file;
}
else
{ skip( 3, "HTML::Tidy not available, cannot test safe_parse.*_html methods with the use_tidy option"); }
}
{ # testing parse_html with use_tidy
if( XML::Twig::_use( 'HTML::Tidy') && XML::Twig::_use( 'LWP::Simple') && XML::Twig::_use( 'LWP::UserAgent'))
{ my $html= q{<html><head><title>T</title><meta content="mv" name="mn"></head><body>t<br>t2<p>t3</body></html>};
my $tidy= HTML::Tidy->new( { output_xhtml => 1, # duh!
tidy_mark => 0, # do not add the "generated by tidy" comment
numeric_entities => 1,
char_encoding => 'utf8',
bare => 1,
clean => 1,
doctype => 'transitional',
fix_backslash => 1,
merge_divs => 0,
merge_spans => 0,
sort_attributes => 'alpha',
indent => 0,
wrap => 0,
break_before_br => 0 } );
$tidy->ignore( type =>1, type => 2);
my $expected= $tidy->clean( $html);
$expected=~ s{></(meta|br)}{ /}g;
is_like( XML::Twig->new( use_tidy => 1)->parse_html( $html)->sprint, $expected, 'parse_html string using HTML::Tidy');
my $html_file= File::Spec->catfile( "t", "test_new_features_3_22.html");
spit( $html_file => $html);
if( -f $html_file)
{ is_like( XML::Twig->new( use_tidy => 1)->parsefile_html( $html_file)->sprint, $expected, 'parsefile_html using HTML::Tidy');
open( HTML, "<$html_file") or die "cannot open HTML file '$html_file': $!";
is_like( XML::Twig->new( use_tidy => 1)->parse_html( \*HTML)->sprint, $expected, 'parse_html fh using HTML::Tidy');
}
else
{ skip( 2, "could not write HTML file in t directory, check permissions"); }
}
else
{ skip( 3 => 'need HTML::Tidy and LWP to test parse_html with the use_tidy option'); }
}
{ if( XML::Twig::_use( 'HTML::TreeBuilder'))
{ my $html_with_Amp= XML::Twig->new->parse_html( '<html><head></head><body>&Amp;</body></html>')->sprint;
if( $HTML::TreeBuilder::VERSION <= 3.23)
{ is( $html_with_Amp, '<html><head></head><body>&amp;</body></html>', '&Amp; used in html (fixed HTB < 4.00)'); }
else
{ is( $html_with_Amp, '<html><head></head><body>&amp;Amp;</body></html>', '&Amp; used in html (NOT fixed HTB > r.00)'); }
is( XML::Twig->new->parse_html( '<html><head></head><body><?xml version="1.0" ?></body></html>')->sprint,
'<html><head></head><body></body></html>',
'extra XML declaration in html'
);
my $doc=q{<html><head><script><![CDATA[some script with < and >]]></script></head><body><!-- just a <> comment --></body><div><p>foo<b>ah</b></p><p/></div></html>};
(my $expected= $doc)=~s{<p/>}{<p></p>}g;
is_like( XML::Twig->parse($doc)->sprint, $expected, 'CDATA and comments in html');
}
else
{ skip( 3, 'need HTML::TreeBuilder for additional HTML tests'); }
}
{ my $t= XML::Twig->parse( '<d><e/></d>');
$t->{twig_root}= undef;
is( $t->first_elt, undef, 'first_elt on empty tree');
is( $t->last_elt, undef, 'last_elt on empty tree');
}
{ if( XML::Twig::_use( 'XML::XPathEngine') && XML::Twig::_use( 'XML::Twig::XPath'))
{ my $t= XML::Twig::XPath->new->parse( '<d><p/></d>');
eval { $t->get_xpath( '//d[.//p]'); };
matches( $@, qr{the expression is a valid XPath statement, and you are using XML::Twig::XPath}, 'non XML::Twig xpath with get_xpath');
}
else
{ skip( 1); }
}
{ my $r= XML::Twig->parse( '<d><e/><e1/></d>')->root;
is( $r->is_empty, 0, 'non empty element');
$r->cut_children( 'e');
is( $r->is_empty, 0, 'non empty element after cut_children');
$r->cut_children( 'e1');
is( $r->is_empty, 1, 'empty element after cut_children');
}
{ my $r= XML::Twig->parse( '<d><e/><e1/></d>')->root;
is( $r->is_empty, 0, 'non empty element');
$r->cut_descendants( 'e');
is( $r->is_empty, 0, 'non empty element after cut_descendants');
$r->cut_descendants( 'e1');
is( $r->is_empty, 1, 'empty element after cut_descendants');
}
{ if( XML::Twig::_use( 'LWP::Simple'))
{ eval { XML::Twig->parse( 'file://not_there'); };
matches( $@, 'no element found', 'making xparse fail');
}
else
{ skip( 1); }
}
{ is( XML::Twig::Elt::_short_text( 'a', 0), 'a', 'shorten with no length');
}
{ is( XML::Twig->parse( comments => 'process', pi => 'process', pretty_print => 'indented',
"<d><e><?pi foo?><e1></e1></e><e><!-- comment--><e1></e1></e></d>"
)->sprint,
"<d>\n <e>\n <?pi foo?>\n <e1></e1>\n </e>\n <e>\n <!-- comment-->\n <e1></e1>\n </e>\n</d>\n",
'indenting pi and comments'
);
}
{ XML::Twig::_set_debug_handler(3);
XML::Twig->new( twig_handlers => { 'foo[@a="bar"]' => sub { $_->att( 'a')++; } });
my $expected=<<'EXPECTED';
parsing path 'foo[@a="bar"]'
predicate is: '@a="bar"'
predicate becomes: '$elt->{'a'} eq "bar"'
perlfunc:
no warnings;
my( $stack)= @_;
my @current_elts= (scalar @$stack);
my @new_current_elts;
my $elt;
warn q{checking path 'foo[@a="bar"]'
};
foreach my $current_elt (@current_elts)
{ next if( !$current_elt);
$current_elt--;
$elt= $stack->[$current_elt];
if( ($elt->{'##tag'} eq "foo") && $elt->{'a'} eq "bar") { push @new_current_elts, $current_elt;}
}
unless( @new_current_elts) { warn qq%fail at cond '($elt->{'##tag'} eq "foo") && $elt->{'a'} eq "bar"'%;
return 0; }
@current_elts= @new_current_elts;
@new_current_elts=();
warn "handler for 'foo[@a="bar"]' triggered\n";
return q{foo[@a="bar"]};
last tag: 'foo', test_on_text: '0'
score: anchored: 0 predicates: 3 steps: 1 type: 3
EXPECTED
my $got= XML::Twig::_return_debug_handler();
$got=~ s{\\}{}g;
$expected=~ s{\\}{}g;
is( $got, $expected, 'handler content');
XML::Twig::_set_debug_handler( 0);
}
{ my $t=XML::Twig->parse( elt_class => 'XML::Twig::Elt', '<d/>');
is( ref($t->root), 'XML::Twig::Elt', 'alternate class... as the default one!');
}
{ my( $triggered_bare, $triggered_foo);
my $t= XML::Twig->new( twig_handlers => { 'e1[@#a]' => sub { $triggered_bare.=$_->id; },
'e1[@#a="foo"]' => sub { $triggered_foo .=$_->id; },
e2 => sub { $_->parent->set_att( '#a', 1); },
e4 => sub { $_->parent->set_att( '#a', 'foo'); },
}
)
->parse( '<d><e1 id="e1.1"><e4/></e1><e1 id="e1.2"><e2/></e1><e1 id="e1.3"><e3><e2/></e3></e1><e1 id="e1.4"/></d>');
is( $triggered_bare, 'e1.1e1.2', 'handler condition on bare private attribute');
is( $triggered_foo , 'e1.1', 'handler condition on valued private attribute');
}
{ my $t= XML::Twig->parse( '<d class="foo"><e class="bar baz"/></d>');
$t->root->remove_class( 'foo');
is( $t->root->class, '', 'empty class after remove_class');
my $e= $t->first_elt( 'e');
$e->remove_class( 'foo');
is( $e->class, 'bar baz', 'remove_class on non-existent class');
$e->remove_class( 'baz');
is( $e->class, 'bar', 'remove_class');
$e->remove_class( 'foo');
is( $e->class, 'bar', 'remove_class on non-existent class (again)');
$e->remove_class( 'bar');
is( $e->class, '', 'remove_class until no class is left');
}
{ if( XML::Twig::_use( 'Text::Wrap'))
{ my $out= "t/test_wrapped.xml";
my $out_fh;
open( $out_fh, ">$out") or die "cannot create temp file $out: $!";
$Text::Wrap::columns=40;
$Text::Wrap::columns=40;
XML::Twig->parse( pretty_print => 'wrapped', '<d a="foo"><e>' . "foobarbaz " x 10 . '</e></d>')
->print( $out_fh);
close $out_fh;
is( slurp( $out),qq{<d a="foo">\n <e>foobarbaz foobarbaz foobarbaz\n foobarbaz foobarbaz foobarbaz\n foobarbaz foobarbaz foobarbaz\n foobarbaz </e>
</d>\n},
'wrapped print'
);
unlink $out;
}
else
{ skip( 1); }
}
sub all_text
{ return join ':' => map { $_->text } @_; }
1;

139
t/test_3_38.t Executable file
View File

@ -0,0 +1,139 @@
#!/usr/bin/perl -w
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
$|=1;
my $DEBUG=0;
use XML::Twig;
my $TMAX=21;
print "1..$TMAX\n";
my $d= '<d/>';
{ my $r= XML::Twig->parse( $d)->root;
my $result = $r->att('a');
is( $r->sprint, $d, 'att');
}
{ my $r= XML::Twig->parse( $d)->root;
my $result = foo($r->att('a'));
is( $r->sprint, $d, 'att in sub(1)');
}
{ my $r= XML::Twig->parse( $d)->root;
my $result = sub { return @_ }->($r->att('a'));
is( $r->sprint, $d, 'att in anonymous sub');
}
{ my $r= XML::Twig->parse( $d)->root;
my $a= $r->att( 'a');
is( $r->sprint, $d, 'att in scalar context');
}
{ my $r= XML::Twig->parse( $d)->root;
my( $a1, $a2)= ($r->att( 'a1'), $r->att( 'a2'));
is( $r->sprint, $d, 'att in list context');
}
{ my $r= XML::Twig->parse( $d)->root;
$r->att( 'a');
is( $r->sprint, $d, 'att in void context');
}
{ my $r= XML::Twig->parse( $d)->root;
my $result = $r->att('a');
is( $r->sprint, $d, 'att');
}
{ my $r= XML::Twig->parse( $d)->root;
my $result = foo($r->class);
is( $r->sprint, $d, 'class in sub(1)');
}
{ my $r= XML::Twig->parse( $d)->root;
my $result = sub { return @_ }->($r->class);
is( $r->sprint, $d, 'att in anonymous sub');
}
{ my $r= XML::Twig->parse( $d)->root;
my $a= $r->class;
is( $r->sprint, $d, 'class in scalar context');
}
{ my $r= XML::Twig->parse( $d)->root;
my( $a1, $a2)= ($r->class, $r->class);
is( $r->sprint, $d, 'class in list context');
}
{ my $r= XML::Twig->parse( $d)->root;
$r->class;
is( $r->sprint, $d, 'class in void context');
}
{ my $t= XML::Twig->new->parse( '<d/>');
$t->root->latt( 'a')= 1;
is( $t->sprint, '<d a="1"/>', 'latt');
}
{ my $r= XML::Twig->parse( $d)->root;
my $att= $r->att( 'foo');
is( $att, undef, 'unexisting att');
}
# my $value = $root->att('any_attribute');
# $result = length($value);
sub foo { return @_; }
{
my $r;
my $doc='<d><_e id="e1"><foo _a="2" id="bar"/></_e><_e id="e2"><_foo a="2" id="foo"/></_e></d>';
my $t= XML::Twig->new( twig_handlers => { _e => sub { $r.= $_->id } })
->parse( $doc);
is( $r, 'e1e2', 'handler, condition on tag starting with an underscore');
is( $t->first_elt( '_foo')->id, 'foo', 'navigation, element name starts with underscore');
is( $t->first_elt( '*[@_a="2"]')->id, 'bar', 'navigation, attribute name starts with underscore');
}
{ if( _use( 'LWP') && _use( 'HTML::TreeBuilder') )
{ my $html=q{<html><body><h1>Title</h1><p>foo<br>bar</p>};
my $expected= qq{<html><head></head><body><h1>Title</h1><p>foo<br />bar</p></body></html>};
my $html_file= "t/test_3_38.html";
spit( $html_file, $html);
is( scrub_xhtml( XML::Twig->new( )->parseurl_html( "file:$html_file")->sprint), $expected, 'parseurl_html');
unlink $html_file;
}
else
{ skip( 1, "LWP and/or HTML::TreeBuilder not available, cannot test safe_parseurl_html"); }
}
{ my $doc="<d><e> foo bar baz</e></d>";
is( XML::Twig->parse( $doc)->simplify( normalize_space => 2)->{e}, 'foo bar baz', 'simplify with normalize_space => 2');
}
{ my $doc="<d>foo bar foofoo foobar totofoo</d>";
my $t= XML::Twig->parse( $doc);
is( $t->subs_text( qr/(f)o(o)/, '&elt(b => $1) $2')->sprint, '<d><b>f</b> o bar <b>f</b> o<b>f</b> o <b>f</b> obar toto<b>f</b> o</d>', 'complex subs_text');
}
{ my $t= XML::Twig->parse( '<d><e>e1</e><s><e>e2</e></s></d>');
is( join( '-', $t->findvalues( '//e')), 'e1-e2', 'findvalues');
}
1;

78
t/test_3_39.t Executable file
View File

@ -0,0 +1,78 @@
#!/usr/bin/perl -w
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
$|=1;
my $DEBUG=0;
use XML::Twig;
my $TMAX=12;
print "1..$TMAX\n";
{
my $doc='<d>foo bar fooo baz</d>';
my $t= XML::Twig->parse( $doc);
$t->root->split( '(fo+)', e => { att => '$1' } );
is( $t->sprint, '<d><e att="foo">foo</e> bar <e att="fooo">fooo</e> baz</d>', 'split, with $1 on attribute value');
$t= XML::Twig->parse( $doc);
$t->root->split( '(fo+)', e => { '$1' => 'v$1' } );
is( $t->sprint, '<d><e foo="vfoo">foo</e> bar <e fooo="vfooo">fooo</e> baz</d>', 'split, with $1 on attribute name and value');
$t= XML::Twig->parse( $doc);
$t->root->split( '(fo+)', '$1' );
is( $t->sprint, '<d><foo>foo</foo> bar <fooo>fooo</fooo> baz</d>', 'split, with $1 on tag name');
$t= XML::Twig->parse( $doc);
$t->root->split( '(foo+)', '$1', '' );
is( $t->sprint, '<d><foo>foo</foo> bar <fooo>fooo</fooo> baz</d>', 'split, with $1 on tag name');
$t= XML::Twig->parse( $doc);
$t->root->split( '(fo+)(.*?)(a[rz])', x => { class => 'f' }, '', a => { class => 'x' });
is( $t->sprint, '<d><x class="f">foo</x> b<a class="x">ar</a> <x class="f">fooo</x> b<a class="x">az</a></d>', 'split, checking that it works with non capturing grouping');
$t= XML::Twig->parse( $doc);
$t->root->split( '(fo+)(.*?)(a[rz])', x => { class => '$1' }, '', a => { class => '$3' });
is( $t->sprint, '<d><x class="foo">foo</x> b<a class="ar">ar</a> <x class="fooo">fooo</x> b<a class="az">az</a></d>', 'split, with $1 and $3 on att value');
}
{ my $t= XML::Twig->parse( '<d><e>e1</e><s><e>e2</e></s></d>');
is( join( '-', $t->findvalues( '//e')), 'e1-e2', 'findvalues');
}
{ my $html='<html xmlns="http://www.w3.org/1999/xhtml"><head><meta content="text/html; charset=utf-8" http-equiv="Content-Type"/></head><body><p>boo</p></body></html>';
my $well_formed = qq{<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">$html};
my $short_doctype = qq{<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN">$html};
my $t= XML::Twig->new->parse( $well_formed);
is_like( $t->sprint, $well_formed, 'valid xhtml');
if( _use( 'HTML::TreeBuilder'))
{ my $th= XML::Twig->new->parse_html( $well_formed);
is_like( $t->sprint, $well_formed, 'valid xhtml (parsed as html)');
my $t3= XML::Twig->new->parse_html( $short_doctype);
is_like( $t3->sprint, $html, 'xhtml without SYSTEM in DOCTYPE (parsed as html, no DOCTYPE output)');
my $t4= XML::Twig->new( output_html_doctype => 1)->parse_html( $short_doctype);
is_like( $t4->sprint, $well_formed, 'xhtml without SYSTEM in DOCTYPE (parsed as html, with proper DOCTYPE output)');
}
else
{ skip( 3); }
my $t2= XML::Twig->new->safe_parse( $short_doctype);
nok( $t2, 'xhtml without SYSTEM in DOCTYPE');
}

361
t/test_3_40.t Executable file
View File

@ -0,0 +1,361 @@
#!/usr/bin/perl -w
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
$|=1;
my $DEBUG=0;
use XML::Twig;
my $TMAX=96;
print "1..$TMAX\n";
{ my $d="<d><title section='1'>title</title><para>p 1</para> <para>p 2</para></d>";
is( lf_in_t( XML::Twig->parse( pretty_print => 'indented', discard_spaces => 1, $d)), 1, 'space prevents indentation');
is( lf_in_t( XML::Twig->parse( pretty_print => 'indented', discard_all_spaces => 1, $d)), 5, 'discard_all_spaces restores indentation');
}
sub lf_in_t
{ my($t)= @_;
my @lfs= $t->sprint=~ m{\n}g;
return scalar @lfs;
}
{ my $d='<d id="d"><t1 id="t1"/><t2 id="t2"/><t3 att="a|b" id="t3-1" /><t3 att="a" id="t3-2" a2="a|b"/><t3 id="t3-3"><t4 id="t4"/></t3></d>';
my @tests=
( [ 't1|t2', HN => 't1t2' ],
[ 't1|t2|t3[@att="a|b"]', HN => 't1t2t3-1' ],
[ 't1|t2|t3[@att!="a|b"]', HN => 't1t2t3-2t3-3' ],
[ 't1|level(1)', H => 't1t1t2t3-1t3-2t3-3' ],
[ 't1|level(2)', H => 't1t4' ],
[ 't1|_all_', H => 't1t1t2t3-1t3-2t4t3-3d'],
[ qr/t[12]/ . '|t3/t4', H => 't1t2t4' ],
[ 't3[@a2="a|b"]', HN => 't3-2' ],
[ 't3[@a2="a|b"]|t3|t3/t4', H => 't3-1t3-2t3-2t4t3-3' ],
);
foreach my $test (@tests)
{ my $nb=0;
my $ids='';
my( $trigger, $test_cat, $expected_ids)= @$test;
my $handlers= $test_cat =~ m{H} ? { $trigger => sub { $ids.=$_->id; 1; } } : {};
my $t= XML::Twig->new( twig_handlers => $handlers )->parse( $d);
is( $ids, $expected_ids, "(H) trigger with alt: '$trigger'");
my $uniq_ids= join '', sort $expected_ids=~m{(t\d(?:-\d)?)}g;
if( $test_cat =~ m{X})
{ (my $xpath= "//$trigger")=~ s{\|t}{|//t}g;
is( join( '', map { $_->id } $t->findnodes( $xpath)), $uniq_ids, " (X) path with |: '$trigger'");
}
if( $test_cat =~ m{N})
{ is( join( '', map { $_->id } $t->root->children( $trigger)), $uniq_ids, "(N)navigation with |: '$trigger'"); }
}
}
{ my $t1= XML::Twig->parse( '<d id="d1"/>');
is( XML::Twig->active_twig()->root->id, 'd1', 'active_twig, one twig');
my $t2= XML::Twig->parse( '<d id="d2"/>');
is( XML::Twig->active_twig()->root->id, 'd2', 'active_twig, second twig');
}
{ eval { XML::Twig->new(error_context => 1)->parse( $0); };
matches( $@, "you seem to have used the parse method on a filename", 'parse on a file name');
}
{ my $got;
XML::Twig->parse( twig_handlers => { 'e[@a]' => sub { $got .= $_->id; } }, '<d><e a="a" id="i1"/><e id="i2"/><e a="0" id="i3"/></d>');
is( $got, 'i1i3', 'bare attribute in handler condition');
}
if( $] > 5.008)
{ my $doc= q{<!DOCTYPE doc [ <!ELEMENT doc (#PCDATA)><!ENTITY ext SYSTEM "not_there.txt">]><doc>&ext;</doc>};
ok( XML::Twig->parse( expand_external_ents => -1, $doc), 'failsafe expand_external_ents');
}
else
{ skip( 1, 'not tested under perl < 5.8'); }
{ my $t=XML::Twig->parse( q{<doc><e><e1>e11</e1><e2>e21</e2></e><e><e1>e12</e1></e></doc>});
is( join( ':', $t->findvalues( [$t->root->children], "./e1")), 'e11:e12', 'findvalues on array');
}
{ my $t=XML::Twig->parse( "<doc/>");
$t->set_encoding( "UTF-8");
is( $t->sprint, qq{<?xml version="1.0" encoding="UTF-8"?>\n<doc/>}, 'set_encoding without XML declaration');
}
{ my $t=XML::Twig->parse( "<doc/>");
$t->set_standalone( 1);
is( $t->sprint, qq{<?xml version="1.0" standalone="yes"?>\n<doc/>}, 'set_standalone (yes) without XML declaration');
}
{ my $t=XML::Twig->parse( "<doc/>");
$t->set_standalone( 0);
is( $t->sprint, qq{<?xml version="1.0" standalone="no"?>\n<doc/>}, 'set_standalone (no) without XML declaration');
}
{ my $t=XML::Twig->parse( "<doc/>");
nok( $t->xml_version, 'xml_version with no XML declaration');
$t->set_xml_version( 1.1);
is( $t->sprint, qq{<?xml version="1.1"?>\n<doc/>}, 'set_xml_version without XML declaration');
is( $t->xml_version, 1.1, 'xml_version after being set');
}
{ my $t= XML::Twig->new;
is( $t->_dump, "document\n", '_dump on an empty twig');
}
{ my $t=XML::Twig->parse( pretty_print => 'none', '<doc><f a="a">foo</f><f a="b">bar</f></doc>');
$t->root->field_to_att( 'f[@a="b"]', 'g');
is( $t->sprint, '<doc g="bar"><f a="a">foo</f></doc>', 'field_to_att on non-simple condition');
$t->root->att_to_field( g => 'gg');
is( $t->sprint, '<doc><gg>bar</gg><f a="a">foo</f></doc>', 'att_to_field with att != field');
}
{ my $t=XML::Twig->parse( '<root/>');
$t->root->wrap_in( 'nroot');
is( $t->sprint, '<nroot><root/></nroot>', 'wrapping the root');
}
{
my $t=XML::Twig->new;
XML::Twig::_set_weakrefs(0);
my $doc='<doc>\n <e att="a">text</e><e>text <![CDATA[cdata text]]> more text <e>foo</e>\n more</e></doc>';
$t->parse( $doc);
$doc=~ s{\n }{}; # just the first one
is( $t->sprint, $doc, 'parse with no weakrefs');
$t->root->insert_new_elt( first_child => x => 'text');
$doc=~ s{<doc>}{<doc><x>text</x>};
is( $t->sprint, $doc, 'insert first child with no weakrefs');
$t->root->insert_new_elt( last_child => x => 'text');
$doc=~ s{</doc>}{<x>text</x></doc>};
is( $t->sprint, $doc, 'insert last child with no weakrefs');
$t->root->wrap_in( 'dd');
$doc=~ s{<doc>}{<dd><doc>}; $doc=~s{</doc>}{</doc></dd>};
is( $t->sprint, $doc, 'wrap with no weakrefs');
$t->root->unwrap;
$doc=~s{</?dd>}{}g;
is( $t->sprint, $doc, 'unwrap with no weakrefs');
my $new_e= XML::Twig::Elt->new( ee => { c => 1 }, 'ee text');
$new_e->replace( $t->root->first_child( 'e'));
$doc=~ s{<e.*?</e>}{<ee c="1">ee text</ee>};
is( $t->sprint, $doc, 'replace with no weakrefs');
XML::Twig::_set_weakrefs(1);
}
{
my $t= XML::Twig->new( no_expand => 1);
XML::Twig::_set_weakrefs(0);
my $doc='<!DOCTYPE d [<!ENTITY foo SYSTEM "foo.xml"><!ENTITY bar SYSTEM "bar.xml">]><d a="foo"> bar &bar; bar<e/><f>&bar;</f><f>&foo; <e/>&bar; bar &foo;</f><e/>&bar; na &foo;<e/></d>';
$t->parse( $doc);
(my $got= $t->sprint)=~ s{\n}{}g;
is( $got, $doc, 'external entities without weakrefs');
XML::Twig::_set_weakrefs(1);
}
{
XML::Twig::_set_weakrefs(0);
{ my $t= XML::Twig->new; undef $t; }
ok( 1, "DESTROY doesn't crash when weakrefs is off");
XML::Twig::_set_weakrefs(1);
}
{ my $doc= '<d><e a="a" get1="1" id="e1">foo</e><e a="b" id="e2"><e1 id="e11"/>bar</e><e a="b" id="e3"><e2 id="e21"/>bar</e></d>';
my( $got1, $got2);
XML::Twig->new( twig_handlers => { e1 => sub { $_->parent->set_att( get1 => 1); },
e2 => sub { $_->parent->set_att( '#get2' => 1); },
'[@get1]' => sub { $got1 .= 'a' . $_->id; },
'[@#get2]' => sub { $got2 .= 'a' . $_->id; },
'e[@get1]' => sub { $got1 .= 'b' . $_->id; },
'e[@#get2]' => sub { $got2 .= 'b' . $_->id; },
},
)
->parse( $doc);
is( $got1, 'be1ae1', 'handler on bare attribute');
is( $got2, 'be3ae3', 'handler on private (starting with #) bare attribute');
}
{ my $t=XML::Twig->parse( '<foo><e/>foo<!-- comment --></foo>');
my $root= $t->root;
ok( $root->closed, 'closed on completely parsed tree');
ok( $root->_extra_data_before_end_tag, '_extra_data_before_end_tag (success)');
nok( $root->first_child->_extra_data_before_end_tag, '_extra_data_before_end_tag (no data)');
}
{ my $t= XML::Twig->parse( pi => 'process', '<d><?target?></d>');
is( $t->first_elt( '#PI')->pi_string, '<?target?>', 'pi_string with empty data');
}
{ my $t= XML::Twig->parse( '<d><e class="a" id="e1"/><e class="b" id="e2"/><f class="a" id="f1"/></d>');
is( ids( $t->root->children( '.a')), 'e1:f1', 'nav on class');
}
{ my $t=XML::Twig->parse( '<doc><e id="e1">foo</e><e id="e2">bar</e><e id="e3">foobar</e><e id="e4"/><n id="n1">1</n><n id="n2">2</n><n id="n3">3</n></doc>');
is ( ids( $t->root->children( 'e[string()="foo"]')), 'e1', 'navigation condition using string() =');
is ( ids( $t->root->children( 'e[string()=~/foo/]')), 'e1:e3', 'navigation condition using string() =~');
is ( ids( $t->root->children( 'e[string()!~/foo/]')), 'e2:e4', 'navigation condition using string() !~');
is ( ids( $t->root->children( 'e[string()!="foo"]')), 'e2:e3:e4', 'navigation condition using string() !=');
is ( ids( $t->root->children( 'e[string()]')), 'e1:e2:e3', 'navigation condition using bare string()');
is ( ids( $t->root->findnodes( './e[string()="foo"]')), 'e1', 'xpath condition using string() =');
is ( ids( $t->root->findnodes( './e[string()=~/foo/]')), 'e1:e3', 'xpath condition using string() =~');
is ( ids( $t->root->findnodes( './e[string()!~/foo/]')), 'e2:e4', 'xpath condition using string() !~');
is ( ids( $t->root->findnodes( './e[string()!="foo"]')), 'e2:e3:e4', 'xpath condition using string() !=');
is ( ids( $t->root->findnodes( './e[string()]')), 'e1:e2:e3', 'xpath condition using bare string()');
is( ids( $t->root->children( 'n[string()=2]')), 'n2', 'navigation string() =');
is( ids( $t->root->children( 'n[string()!=2]')), 'n1:n3', 'navigation string() !=');
is( ids( $t->root->children( 'n[string()>2]')), 'n3', 'navigation string() >');
is( ids( $t->root->children( 'n[string()>=2]')), 'n2:n3', 'navigation string() >=');
is( ids( $t->root->children( 'n[string()<2]')), 'n1', 'navigation string() <');
is( ids( $t->root->findnodes( './n[string()=2]')), 'n2', 'xpath string() =');
is( ids( $t->root->findnodes( './n[string()!=2]')), 'n1:n3', 'xpath string() !=');
is( ids( $t->root->findnodes( './n[string()>2]')), 'n3', 'xpath string() >');
is( ids( $t->root->findnodes( './n[string()>=2]')), 'n2:n3', 'xpath string() >=');
is( ids( $t->root->findnodes( './n[string()<2]')), 'n1', 'xpath string() <');
is( ids( $t->root->findnodes( './n[string()<=2]')), 'n1:n2', 'xpath string() <=');
}
{ my $got;
my $t=XML::Twig->parse( twig_handlers => { d => sub { $got .="wrong"; },
'd[@id]' => sub { $got .= "ok"; 0 },
},
'<d id="i1"/>'
);
is( $got, 'ok', 'returning 0 prevents the next handler to be called');
}
{ my $d=q{<html><head><title>foo</title><script><![CDATA[ a> b]]></script></head><body id="b1"><!-- test --><p>foo<b>blank</b></p><hr /><div /></body></html>};
my $expected=qq{<html>\n <head>\n <title>foo</title>\n <script><![CDATA[ a> b]]></script></head>\n <body id="b1"><!-- test -->\n <p>foo<b>blank</b></p>\n <hr />\n <div /></body></html>};
XML::Twig::_indent_xhtml( \$d);
is( $d, $expected, '_indent_xhtml');
}
{ my $d='<d><e a="a" b="b">c</e></d>';
my @handlers= ( '/d/e[@a="a" or @b="b"]',
'/d/e[@a="a" or @b="c"]|e',
'/d/e[@a="a"]',
'/d/e[@b="b"]',
'/d/e',
'd/e[@a="a" and @b="b"]',
'd/e[@a="a"]',
'd/e[@b="b"]',
'd/e',
'e[@a="a" or @b="b"]',
'e[@b="b" or @a="a"]',
'e[@a="a"]|f',
'e[@b="b"]',
'e',
qr/e|f/,
qr/e|f|g/,
'level(1)',
);
my $t= XML::Twig->new();
for my $stem ( 1, 100)
{ my $i= $stem;
my $expected= join '', ($stem..$stem+$#handlers);
my $got;
$t->setTwigHandlers( { map { $_ => sub { $got .= $i++; } } @handlers });
$t->parse( $d);
is( $got, $expected, 'handler order');
}
}
{ my $t=XML::Twig->parse( "<d/>");
$t->{twig_dtd}="<!ELEMENT d EMPTY>";
is( $t->doctype(UpdateDTD => 1), "<!ELEMENT d EMPTY>\n", 'doctype with an updated DTD');
}
{ my $t=XML::Twig->parse( '<d><e id="e1"/><e id="e2"><se id="se1"/><se a="1" id="se2"/></e></d>');
$t->elt_accessors( 'e', 'e');
$t->elt_accessors( { e2 => 'e[2]', se => 'se', sea => 'se[@a]' });
my $root= $t->root;
is( $root->e->id, 'e1', 'accessor, no alias, scalar context');
my $e2= ($root->e)[-1];
is( $e2->id, 'e2', 'accessor no alias, list context');
$e2= $root->e2;
is( $e2->id, 'e2', 'accessor alias, list context');
is( $e2->se->id, 'se1', 'accessor alias, scalar context');
is( $e2->sea->id, 'se2', 'accessor, with complex step, alias, scalar context');
}
{ my $t=XML::Twig->new( elt_accessors => [ 'e', 'se' ])
->parse( '<d><e id="e1"/><e id="e2"><se id="se1"/><se a="1" id="se2"/></e></d>');
my $root= $t->root;
is( $root->e->id, 'e1', 'accessor (created in new), no alias, scalar context');
my $se= ($root->e)[-1]->se;
is( $se->id, 'se1', 'accessor (created in new) no alias, scalar context, 2');
}
{ my $t=XML::Twig->new( elt_accessors => { e2 => 'e[2]', se => 'se', sea => 'se[@a]' })
->parse( '<d><e id="e1"/><e id="e2"><se id="se1"/><se a="1" id="se2"/></e></d>');
my $e2= $t->root->e2;
is( $e2->id, 'e2', 'accessor (created in new) alias, list context');
is( $e2->se->id, 'se1', 'accessor (created in new) alias, scalar context');
is( $e2->sea->id, 'se2', 'accessor (created in new), with complex step, alias, scalar context');
}
{ my $doc= '<?xml version="1.0"?><!DOCTYPE d [<!ENTITY foo SYSTEM "foo.xml">]><d/>';
my $t= XML::Twig->parse( do_not_output_DTD => 1, $doc);
is( $t->sprint, qq{<?xml version="1.0"?>\n<d/>}, 'do_not_output_DTD');
}
{ my $t= XML::Twig->parse( no_prolog => 1, '<?xml version="1.0"?><!DOCTYPE d [<!ENTITY foo SYSTEM "foo.xml">]><d/>');
is( $t->sprint, qq{<d/>}, 'no_prolog');
}
{ my $t= XML::Twig->parse( '<?xml version="1.0"?><!DOCTYPE d [<!ENTITY foo SYSTEM "foo.xml">]><d/>');
is( $t->sprint, qq{<?xml version="1.0"?>\n<!DOCTYPE d [\n<!ENTITY foo SYSTEM "foo.xml">\n]>\n<d/>}, 'no_prolog');
}
{ my $e= XML::Twig::Elt->new( 'e');
$e->set_empty;
is( $e->sprint, '<e/>', 'set_empty with no value');
$e->set_empty( 0);
is( $e->sprint, '<e></e>', 'set_empty(0)');
$e->set_empty;
is( $e->sprint, '<e/>', 'set_empty with no value');
$e->set_empty( 1);
is( $e->sprint, '<e/>', 'set_empty(1');
$e->set_empty;
is( $e->sprint, '<e/>', 'set_empty with no value');
$e->set_empty( 1);
is( $e->sprint, '<e/>', 'set_empty(1)');
my $e2= XML::Twig::Elt->parse( '<e></e>');
$e2->set_not_empty();
is( $e2->sprint, '<e></e>', 'set_not_empty');
ok( ! $e2->closed, 'closed on an orphan elt');
}
{ my $t= XML::Twig->parse( '<d a="d"><l1><l2 a="l2"><l3><l4/></l3></l2></l1></d>');
my $l2= $t->first_elt( 'l2');
my $l4= $t->first_elt( 'l4');
$l2->cut;
$l4->cut;
is( $l4->_root_through_cut->tag, 'd', '_root_through_cut');
is( $l4->_inherit_att_through_cut( 'a', 'd'), 'd', '_inherit_att_through_cut');
}
{ my $s= "foo";
is( XML::Twig::_to_utf8( 'iso-8859-1', $s), $s, 'trivial test of _to_utf8');
}

131
t/test_3_41.t Executable file
View File

@ -0,0 +1,131 @@
#!/usr/bin/perl
use strict;
use warnings;
use XML::Twig;
use Test::More tests => 16;
{
my $in= '<plant><flower>Rose</flower><fruit><berry>Blackberry</berry></fruit><veggie>Carrot</veggie></plant>';
my $expected= '<plant><flower>Rose</flower><fruit><berry>Tomato</berry><berry>Blackberry</berry></fruit><veggie>Carrot</veggie></plant>';
{ my $t = XML::Twig->new( twig_handlers => { '//plant/fruit' => sub { XML::Twig::Elt->new( berry => 'Tomato')->paste( $_); } })
->parse( $in);
is( $t->sprint, $expected, 'paste within handler from new element');
}
{ my $t = XML::Twig->new( twig_handlers => { '//plant/fruit' => sub { XML::Twig->new->parse( '<berry>Tomato</berry>')->root->cut->paste( first_child => $_); } })
->parse( $in);
is( $t->sprint, $expected, 'paste new element from twig within handler from parsed element (cut)');
}
{ my $t = XML::Twig->new( twig_handlers => { '//plant/fruit' => sub { XML::Twig->new->parse( '<berry>Tomato</berry>')->root->paste( $_); } })
->parse( $in);
is( $t->sprint, $in, 'paste new element from twig within handler from parsed element (non cut)');
}
}
{ my $d='<d><f/><e>foo</e></d>';
my $calls;
XML::Twig->new( twig_roots => { f => 1 },
end_tag_handlers => { e => sub { $calls .= ":e"; },
'd/e' => sub { $calls .= "d/e" },
},
)
->parse( $d);
is( $calls, 'd/e:e', 'several end_tag_handlers called');
$calls='';
XML::Twig->new( twig_roots => { f => 1 },
end_tag_handlers => { e => sub { $calls .= ":e"; },
'd/e' => sub { $calls .= "d/e"; return 0; },
},
)
->parse( $d);
is( $calls, 'd/e', 'end_tag_handlers chain broken by false return');
}
{ my $d='<d><f><e>foo</e><g/></f></d>';
my $calls;
XML::Twig->new( twig_roots => { f => 1 },
ignore_elts => { e => 1 },
end_tag_handlers => { e => sub { $calls .= ":e"; },
'f/e' => sub { $calls .= "f/e" },
},
)
->parse( $d);
is( $calls, 'f/e:e', 'several end_tag_handlers called with ignore_elts active');
$calls='';
XML::Twig->new( twig_roots => { f => 1 },
ignore_elts => { e => 1 },
end_tag_handlers => { e => sub { $calls .= ":e"; },
'f/e' => sub { $calls .= "f/e"; return 0; },
},
)
->parse( $d);
is( $calls, 'f/e', 'end_tag_handlers chain with ignore_elts active broken by false return');
}
is( XML::Twig->parse( '<d/>')->encoding, undef, 'encoding, no xml declaration');
is( XML::Twig->parse( '<?xml version="1.0"?><d/>')->encoding, undef, 'encoding, xml declaration but no encoding given');
is( XML::Twig->parse( '<?xml version="1.0" encoding="utf-8"?><d/>')->encoding, 'utf-8', 'encoding, encoding given');
is( XML::Twig->parse( '<d/>')->standalone, undef, 'standalone, no xml declaration');
is( XML::Twig->parse( '<?xml version="1.0"?><d/>')->standalone, undef, 'standalone, xml declaration but no standalone bit');
ok( XML::Twig->parse( '<?xml version="1.0" standalone="yes"?><d/>')->standalone, 'standalone, yes');
ok( ! XML::Twig->parse( '<?xml version="1.0" standalone="no"?><d/>')->standalone, 'standalone, no');
{
XML::Twig::_set_weakrefs(0);
my $t= XML::Twig->parse( '<d><e/><e><f/><f/></e><e/></d>');
$t->root->first_child( 'e')->next_sibling( 'e')->erase;
is( $t->sprint, '<d><e/><f/><f/><e/></d>', 'erase without weakrefs');
XML::Twig::_set_weakrefs(1)
}
{
my $doc='<ns1:list xmlns:ns1="http://namespace/CommandService" xmlns:ns2="http://namespace/ShelfService" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance">
<commands>
<commandId>1</commandId>
<command xsi:type="ns2:find">
<equipmentFilter>...</equipmentFilter>
</command>
</commands>
<commands>
<commandId>2</commandId>
<command xsi:type="ns2:getByName">
<name>...</name>
</command>
</commands>
</ns1:list>
';
my $expected= $doc;
$expected=~ s{ns1}{cmdsvc}g;
$expected=~ s{ns2}{shlsvc}g;
my %map= reverse ( cmdsvc => "http://namespace/CommandService",
shlsvc => "http://namespace/ShelfService",
xsi => "http://www.w3.org/2001/XMLSchema-instance",
);
my $x = XML::Twig->new( map_xmlns => { %map },
twig_handlers => { '*[@xsi:type]' => sub { upd_xsi_type( @_, \%map) } },
pretty_print => "indented"
);
$x->parse($doc);
is( $x->sprint, $expected, 'original_uri');
sub upd_xsi_type
{ my( $t, $elt, $map)= @_;
my $type= $elt->att( 'xsi:type');
my( $old_prefix)= $type=~ m{^([^:]*):};
if( my $new_prefix= $map->{$t->original_uri( $old_prefix)})
{ $type=~ s{^$old_prefix}{$new_prefix};
$elt->set_att( 'xsi:type' => $type);
}
return 1; # to make sure other handlers are called
}
}

31
t/test_3_42.t Executable file
View File

@ -0,0 +1,31 @@
#!/usr/bin/perl
use strict;
use warnings;
use XML::Twig;
use Test::More tests => 3;
{ my $t= XML::Twig->new( twig_handlers => { e => sub { XML::Twig::Elt->parse( '<new/>')->paste( before => $_); } })
->parse('<d><e/></d>');
is( $t->sprint, '<d><new/><e/></d>', 'elements created with parse are still available once parsing is done');
}
import myElt;
{ my $doc='<d><f><e2>foo</e2><e>e1</e></f><f><e>e2</e><e2>foo</e2></f></d>';
my $t= XML::Twig->new( elt_class => 'myElt',
field_accessors => { e => 'e' },
elt_accessors => { ee => 'e', ef => 'f', },
)
->parse( $doc);
is( join( ':', map { $_->e } $t->root->ef), 'e1:e2', 'elt_accessors with elt_class');
is( join( ':', map { $_->ee->text } $t->root->children( 'f')), 'e1:e2', 'field_accessors with elt_class');
}
package myElt;
use base 'XML::Twig::Elt';
1;

275
t/test_3_44.t Executable file
View File

@ -0,0 +1,275 @@
#!/usr/bin/perl
use strict;
use warnings;
use XML::Twig;
use Test::More tests => 86;
{ my $e= XML::Twig::Elt->new( 'foo');
$e->set_content( { bar => 'baz', toto => 'titi' });
is( $e->sprint, '<foo bar="baz" toto="titi"/>', 'set_content with just attributes');
}
{ my $e= XML::Twig::Elt->parse( '<d>t</d>');
$e->set_content( 'x');
is( $e->sprint, '<d>x</d>', 'set_content on element that contains just text');
$e->first_child( '#PCDATA')->set_content( 'y');
is( $e->sprint, '<d>y</d>', 'set_content on text element');
$e->set_content( XML::Twig::Elt->new( 'e'));
is( $e->sprint, '<d><e/></d>', 'set_content element on element that contains just text');
$e->set_content( 'z', XML::Twig::Elt->new( 'e'));
is( $e->sprint, '<d>z<e/></d>', 'set_content with 2 elements on element that contains just text');
$e->set_content( '');
is( $e->sprint, '<d></d>', 'set_content with empty content');
$e->set_content( '#EMPTY');
is( $e->sprint, '<d/>', 'set_content with empty content and #EMPTY');
$e->set_content( 'x', 'y');
is( $e->sprint, '<d>xy</d>', 'set_content with 2 strings');
$e->set_content( '', 'y');
is( $e->sprint, '<d>y</d>', 'set_content with 2 strings, first one empty');
}
{ my $t= XML::Twig->parse( '<d><s a="1"><e/></s></d>');
my $s= $t->first_elt( 's');
$s->att_to_field( 'a');
is( $s->sprint, '<s><a>1</a><e/></s>', 'att_to_field with default name');
$s->field_to_att( 'a');
is( $s->sprint, '<s a="1"><e/></s>', 'field_to_att with default name');
$s->att_to_field( a => 'b');
is( $s->sprint, '<s><b>1</b><e/></s>', 'att_to_field with non default name');
$s->field_to_att( b => 'c');
is( $s->sprint, '<s c="1"><e/></s>', 'field_to_att with non default name');
}
{ my $t= XML::Twig->parse( '<d>f</d>');
my $r= $t->root;
$r->suffix( '&1', 'opt' );
is( $t->sprint, '<d>f&amp;1</d>', 'suffix, non asis option');
$r->suffix( '&2', 'asis');
is( $t->sprint, '<d>f&amp;1&2</d>', 'suffix, asis option');
$r->suffix( '&3');
is( $t->sprint, '<d>f&amp;1&2&amp;3</d>', 'suffix, after a suffix with an asis option');
}
{ my $t= XML::Twig->parse( '<d>f</d>');
$t->root->last_child->suffix( '&1', 'opt' );
is( $t->sprint, '<d>f&amp;1</d>', 'pcdata suffix, non asis option');
$t->root->last_child->suffix( '&2', 'asis');
is( $t->sprint, '<d>f&amp;1&2</d>', 'pcdata suffix, asis option');
$t->root->last_child->suffix( '&3', 'asis');
is( $t->sprint, '<d>f&amp;1&2&3</d>', 'pcdata suffix, asis option, after an asis element');
$t->root->last_child->suffix( '&4');
is( $t->sprint, '<d>f&amp;1&2&3&amp;4</d>', 'pcdata suffix, after a suffix with an asis option');
}
{ my $t= XML::Twig->parse( '<d>f</d>');
my $r= $t->root;
$r->prefix( '&1', 'opt' );
is( $t->sprint, '<d>&amp;1f</d>', 'prefix, non asis option');
$r->prefix( '&2', 'asis');
is( $t->sprint, '<d>&2&amp;1f</d>', 'prefix, asis option');
$r->prefix( '&3');
is( $t->sprint, '<d>&amp;3&2&amp;1f</d>', 'prefix, after a prefix with an asis option');
}
{ my $t= XML::Twig->parse( '<d>f</d>');
$t->root->first_child->prefix( '&1', 'opt' );
is( $t->sprint, '<d>&amp;1f</d>', 'pcdata prefix, non asis option');
$t->root->first_child->prefix( '&2', 'asis');
is( $t->sprint, '<d>&2&amp;1f</d>', 'pcdata prefix, asis option');
$t->root->first_child->prefix( '&3', 'asis');
is( $t->sprint, '<d>&3&2&amp;1f</d>', 'pcdata prefix, asis option, before an asis element');
$t->root->first_child->prefix( '&4');
is( $t->sprint, '<d>&amp;4&3&2&amp;1f</d>', 'pcdata prefix, after a prefix with an asis option');
}
{ my $weakrefs= XML::Twig::_weakrefs();
XML::Twig::_set_weakrefs(0);
my $t= XML::Twig->parse( '<d><e>f</e></d>');
my $e= $t->first_elt( 'e');
XML::Twig::Elt->new( x => 'g')->replace( $e);
is( $t->sprint, '<d><x>g</x></d>', 'replace non root element without weakrefs');
XML::Twig::Elt->new( y => 'h')->replace( $t->root);
is( $t->sprint, '<y>h</y>', 'replace root element without weakrefs');
XML::Twig::_set_weakrefs( $weakrefs);
}
{ my $t= XML::Twig->parse( '<d><p>foo<!--c1--></p><!--c2--><p>bar<!--c3-->baz<!--c4--></p></d>');
my $r= $t->root;
is( $r->children_count, 2, '2 p');
$t->root->first_child->merge( $t->root->last_child);
is( $r->children_count, 1, 'merged p');
is( $t->sprint, '<d><p>foo<!--c1--><!--c2-->bar<!--c3-->baz<!--c4--></p></d>', 'merged p with extra data');
}
{ my $t= XML::Twig->parse( '<d><p>foo</p><p>baz<b>bar</b></p></d>');
my $r= $t->root;
is( $r->children_count, 2, '2 p, one with mixed content');
$t->root->first_child->merge( $t->root->last_child);
is( $r->children_count, 1, 'merged p, one with mixed content');
is( $t->sprint, '<d><p>foobaz<b>bar</b></p></d>', 'merged p with extra children in the second element');
}
{ my $t= XML::Twig->parse( '<d/>');
my $r= $t->root;
$r->insert_new_elt( first_child => '#PCDATA') foreach 0..1;
is( $r->children_count, 2, '2 empty texts');
$r->first_child->merge( $r->last_child);
is( $r->children_count, 1, 'merged empty texts, number of children');
is( $t->sprint, '<d></d>', 'merged empty texts');
}
{ my $t= XML::Twig->parse( '<d>a foo a<e/>foo<g>bar</g></d>');
my $c=$t->root->copy->subs_text( qr/(foo)/, '&elt( e => "$1")');
is( $c->sprint, '<d>a <e>foo</e> a<e/><e>foo</e><g>bar</g></d>', 'subs_text');
$c=$t->root->copy->subs_text( qr/(foo)/, 'X &elt( e => "$1") X');
is( $c->sprint, '<d>a X <e>foo</e> X a<e/>X <e>foo</e> X<g>bar</g></d>', 'subs_text');
$c=$t->root->copy->subs_text( qr/(foo)/, 'X &elt( e => "Y $1 Y") X');
is( $c->sprint, '<d>a X <e>Y foo Y</e> X a<e/>X <e>Y foo Y</e> X<g>bar</g></d>', 'subs_text');
$c->subs_text( qr/(foo)/, 'X &elt( e => "Y $1 Y") X');
is( $c->sprint, '<d>a X <e>Y X <e>Y foo Y</e> X Y</e> X a<e/>X <e>Y X <e>Y foo Y</e> X Y</e> X<g>bar</g></d>', 'subs_text (re-using previous substitution)');
}
{ my $e= XML::Twig::Elt->new( 'e');
is( $e->att_nb, 0, 'att_nb on element with no attributes');
ok( $e->has_no_atts, 'has_no_atts on element with no attributes');
my $e2= XML::Twig::Elt->new( e => { a => 1 })->del_att( 'a');;
is( $e->att_nb, 0, 'att_nb on element with no more attributes');
ok( $e->has_no_atts, 'has_no_atts on element with no more attributes');
is( $e->split_at( 1), '', 'split_at on a non text element');
}
SKIP: {
skip 'XML::XPath not available', 1 unless XML::Twig::_use( 'XML::XPath');
XML::Twig::_disallow_use( 'XML::XPathEngine');
XML::Twig::_use( 'XML::Twig::XPath');
my $t= XML::Twig::XPath->parse( '<d><e a="1">e1</e><e a="2">e2</e><e a="3">e3</e></d>');
is( $t->findvalue( '//e[@a>=3]|//e[@a<=1]'), 'e1e3', 'xpath search with XML::XPath');
}
SKIP: { # various tests on _fix_xml
skip 'HTML::TreeBuilder not available', 2 unless XML::Twig::_use( 'HTML::TreeBuilder');
my $html= '<html><head><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" /></head><body><p 1="1">&Amp;</p></body></html>';
my $t= HTML::TreeBuilder->new_from_content( $html);
local $@='not well-formed (invalid token)';
local $HTML::TreeBuilder::VERSION=3.23;
XML::Twig::_fix_xml( $t, \$html);
unlike( $html, qr{Amp}, '&Amp with old versions of HTML::TreeBuilder');
like( $html, qr{<p a1="1"}, 'fix improper naked attributes in old versions of HTML::TreeBuilder');
}
SKIP: {
skip 'cannot use XML::Twig::XPath', 1, unless XML::Twig::_use( 'XML::Twig::XPath') && (XML::Twig::_use( 'XML::XPathEngine') || XML::Twig::_use( 'XML::XPath'));
my $t= XML::Twig::XPath->parse( '<d xmlns:pr="uri"><pr:e>pre1</pr:e><e>e1</e><pr:e>pre2</pr:e><a>a 1</a></d>');
is( $t->findvalue( '/d/*[local-name()="e"]'), 'pre1e1pre2', 'local-name()');
}
{ my $doc= qq{<d><e xml:space="preserve">\n<se/></e><e xml:space="default">\n<se/></e></d>};
(my $expected= $doc)=~ s{("default">)\n}{$1}; # this space should be discarded
my $t= XML::Twig->parse( $doc);
is( $t->sprint, $expected, 'xml:space effect on whitespace discarding');
}
{ my $d= "<d><e/></d>";
my $got=0;
my $t= XML::Twig->new( start_tag_handlers => { e => sub { $got=1; } } );
$t->parse( $d);
is( $got, 1, 'setStartTagHandlers');
$t->setStartTagHandlers( { e => sub { $got=2; } });
$t->parse( $d);
is( $got, 2, 'setStartTagHandlers changed');
}
{ my $d= "<d><e><se/></e></d>";
my $got=0;
my $st;
my $t= XML::Twig->new( start_tag_handlers => { se => sub { $got=1; } },
ignore_elts => { e => \$st },
);
$t->parse( $d);
is( $got, 0, 'check that ignore_elts skips element');
is( $st, '<e><se/></e>', 'check that ignore_elts stores the ignored content');
$st='';
$t->setIgnoreEltsHandler( e => 'discard');
is( $got, 0, 'check that ignore_elts still skips element');
is( $st, '', 'check that ignore_elts now discards the ignored content');
}
{ my $content= '<p>here a <a href="/foo?a=1&amp;b=2">dodo</a> bird</p>';
is( XML::Twig::Elt->new( $content)->sprint, $content, 'XML::Twig::Elt->new with litteral content');
}
{ my $doc= '<d><?pi foo?><e/></d>';
my $doc_no_pi= '<d><e/></d>';
my $t= XML::Twig->parse( $doc);
is( $t->sprint, $doc, 'pi is keep by default');
my $tk= XML::Twig->parse( pi => 'keep', $doc);
is( $tk->sprint, $doc, 'pi is keep');
my $td= XML::Twig->parse( pi => 'drop', $doc);
is( $td->sprint, $doc_no_pi, 'pi is keep');
my $tp= XML::Twig->parse( pi => 'process', $doc);
is( $tp->sprint, $doc, 'pi is process');
foreach my $pi ($t->descendants( '#PI')) { $pi->delete; }
is( $t->sprint, $doc, 'pi cannot be cut when pi => keep (by default)');
foreach my $pi ($tk->descendants( '#PI')) { $pi->delete; }
is( $tk->sprint, $doc, 'pi cannot be cut when pi => keep');
foreach my $pi ($tp->descendants( '#PI')) { $pi->delete; }
is( $tp->sprint, $doc_no_pi, 'pi can be cut when pi => process');
}
{ my $doc= '<d><!-- comment --><e/></d>';
my $doc_no_comment= '<d><e/></d>';
my $t= XML::Twig->parse( $doc);
is( $t->sprint, $doc, 'comments is keep by default');
my $tk= XML::Twig->parse( comments => 'keep', $doc);
is( $tk->sprint, $doc, 'comments is keep');
my $td= XML::Twig->parse( comments => 'drop', $doc);
is( $td->sprint, $doc_no_comment, 'comments is keep');
my $tp= XML::Twig->parse( comments => 'process', $doc);
is( $tp->sprint, $doc, 'comments is process');
foreach my $comment ($t->descendants( '#COMMENT')) { $comment->delete; }
is( $t->sprint, $doc, 'comment cannot be cut when comment => keep (by default)');
foreach my $comment ($tk->descendants( '#COMMENT')) { $comment->delete; }
is( $tk->sprint, $doc, 'comment cannot be cut when comment => keep');
foreach my $comment ($tp->descendants( '#COMMENT')) { $comment->delete; }
is( $tp->sprint, $doc_no_comment, 'comment can be cut when comment => process');
}
{ my $d='<d><s l="1"><t>t1</t><s l="2"><t>t2</t><p id="t">p</p></s></s></d>';
my $t= XML::Twig->parse( $d);
my $p= $t->elt_id( 't');
is( $p->level, 3, 'level');
is( $p->level( 's'), 2, 'level with cond');
is( $p->level( 's[@l]'), 2, 'level with cond on attr');
is( $p->level( 's[@l="2"]'), 1, 'level with more cond on attr');
is( $p->level( 's[@g]'), 0, 'level with unsatisfied more cond on attr');
}
{ my $d='<d><e id="i">e1</e><e id="i2">e2</e><e id="i3">e3</e><e>e4</e><e id="iii">e5</e><f>f1</f><f id="ff">f1</f><f id="fff">f2</f></d>';
my $r;
my $t;
$t= XML::Twig->parse( twig_handlers => { 'e#i' => sub { $r.= $_->text}}, $d);
is( $r, 'e1', '# in twig handlers (1 letter id)');
is( $t->findvalue( '//e#i'), 'e1', 'findvalue with # (1 letter id)');
$r='';
$t= XML::Twig->parse( twig_handlers => { 'e#iii' => sub { $r.= $_->text}}, $d);
is( $r, 'e5', '# in twig handlers (3 letter id)');
is( $t->findvalue( '//e#iii'), 'e5', 'findvalue with # (3 letter id)');
$r='';
$t= XML::Twig->parse( twig_handlers => { 'e#i2' => sub { $r.= $_->text}}, $d);
is( $r, 'e2', '# in twig handlers (letter + digits)');
is( $t->findvalue( '//e#i2'), 'e2', 'findvalue with # (letter + digits)');
$r='';
$t= XML::Twig->parse( twig_handlers => { '*#ff' => sub { $r.= $_->text}}, $d);
is( $r, 'f1', '*# in twig handlers');
is( $t->findvalue( '//*#ff'), 'f1', 'findvalue with *#');
}

103
t/test_3_45.t Executable file
View File

@ -0,0 +1,103 @@
#!/usr/bin/perl
use strict;
use warnings;
use XML::Twig;
use Test::More tests => 16;
is( XML::Twig->new( keep_encoding => 1)->parse( q{<d a='"foo'/>})->sprint, q{<d a="&quot;foo"/>}, "quote in att with keep_encoding");
# test CDATA sections in HTML escaping https://rt.cpan.org/Ticket/Display.html?id=86773
my $html = <<'EOF';
<div id="body">body</div>
<script>
//<![CDATA[
if ( this.value && ( !request.term || matcher.test(text) ) && 1 > 0 && 0 < 1 )
//]]>
</script>
EOF
# module => XML::Twig->new options
my %html_conv= ( 'HTML::TreeBuilder' => {},
'HTML::Tidy' => { use_tidy => 1 },
);
foreach my $module ( sort keys %html_conv)
{ SKIP:
{ eval "use $module";
skip "$module not available", 3 if $@ ;
my $parser= XML::Twig->new( %{$html_conv{$module}});
my $xml = $parser->safe_parse_html($html);
print $@ if $@;
my @cdata = $xml->get_xpath('//#CDATA');
ok(@cdata == 1, "1 CDATA section found (using $module)");
ok(((index $xml->sprint, "//]]>") >= 0), "end of cdata ok in doc (using $module)");
#diag "\n", $xml->sprint, "\n";
my @elts = $xml->get_xpath('//script');
foreach my $el (@elts)
{ #diag $el->sprint;
ok(((index $el->sprint, "//]]>") >= 0), "end of cdata ok in script element (using $module)");
}
}
}
# test & in HTML (RT #86633)
my $html_with_amp='<h1>Marco&amp;company</h1>';
my $expected_body= '<body><h1>Marco&amp;company</h1></body>';
SKIP:
{ eval "use HTML::Tidy";
skip "HTML::Tidy not available", 1 if $@ ;
my $parsert = XML::Twig->new();
my $html_tidy = $parsert->safe_parse_html( { use_tidy => 1 }, "<h1>Marco&amp;company</h1>");
diag $@ if $@;
is( $html_tidy->first_elt( 'body')->sprint, $expected_body, "&amp; in text, converting html with use_tidy");
}
SKIP:
{ eval "use HTML::TreeBuilder";
skip "HTML::TreeBuilder not available", 1 if $@ ;
my $parserh= XML::Twig->new();
my $html = $parserh->safe_parse_html("<h1>Marco&amp;company</h1>");
diag $@ if $@;
is( $html->first_elt( 'body')->sprint , $expected_body, "&amp; in text, converting html with treebuilder");
}
is( XML::Twig::_unescape_cdata( '&lt;tag att="foo&amp;bar&amp;baz"&gt;&gt;&gt;&lt;/tag&gt;'), '<tag att="foo&bar&baz">>></tag>', '_unescape_cdata');
SKIP:
{ skip "safe_print_to_file method does not work on Windows", 6 if $^O =~ m{win}i;
# testing safe_print_to_file
my $tmp= "safe_print_to_file.xml";
my $doc= "<doc>foo</doc>";
unlink( $tmp); # no check, it could not be there
my $t1= XML::Twig->nparse( $doc)->safe_print_to_file( $tmp);
ok( -f $tmp, "safe_print_to_file created document");
my $t2= XML::Twig->nparse( $tmp);
is( $t2->sprint, $t1->sprint, "generated document identical to original document");
unlink( $tmp);
my $e1= XML::Twig->parse( '<d><a>foo</a><b>bar</b></d>')->first_elt( 'b')->safe_print_to_file( $tmp);
ok( -f $tmp, "safe_print_to_file on elt created document");
$t2= XML::Twig->nparse( $tmp);
is( $t2->sprint, '<b>bar</b>', "generated sub-document identical to original sub-document");
unlink( $tmp);
# failure modes
eval { XML::Twig->nparse( $tmp); };
like( $@, qr/Couldn't open $tmp:/, 'parse a non-existent file');
my $non_existent="safe_non_existent_I_hope_01/tmp";
while( -f $non_existent) { $non_existent++; } # most likely unnecessary ;--)
eval { $t1->safe_print_to_file( $non_existent); };
like( $@, qr/(does not exist|is not a directory)/, 'safe_print_to_file in non-existent dir');
}
exit;

45
t/test_3_47.t Executable file
View File

@ -0,0 +1,45 @@
#!/usr/bin/perl
use strict;
use warnings;
use XML::Twig;
use Test::More tests => 3;
use utf8;
# test CDATA sections in HTML escaping https://rt.cpan.org/Ticket/Display.html?id=86773
# module => XML::Twig->new options
my %html_conv= ( 'HTML::TreeBuilder' => {},
'HTML::Tidy' => { use_tidy => 1 },
);
foreach my $module ( sort keys %html_conv)
{ SKIP:
{ eval "use $module";
skip "$module not available", 1 if 1 ;
my $in = q{<h1>Here&amp;there v&amp;r;</h1><p>marco&amp;company; and marco&amp;company &pound; &#163; &#xA3; £</p>};
my $expected= q{<h1>Here&amp;there v&amp;r;</h1><p>marco&amp;company; and marco&amp;company £ £ £ £</p>};
my $parser= XML::Twig->new( %{$html_conv{$module}});
my $t = $parser->safe_parse_html($in);
print $@ if $@;
like $t->sprint, qr{\Q$expected\E}, "In and out are the same ($module)";
}
}
{ # test RT #94295 https://rt.cpan.org/Public/Bug/Display.html?id=94295
# in twig_handlers, '=' in regexps on attributes are turned into 'eq'
my $xml= '<doc><e dn="foo=1 host=0">e1</e><e dn="foo=1 host=2">e2</e></doc>';
my $r;
my $t= XML::Twig->new( twig_handlers => { 'e[@dn =~ /host=0/]' => sub { $r.= $_->text } })
->parse( $xml);
is( $r, 'e1', 'regexp on attribute, including an = sign');
}
exit;

22
t/test_3_48.t Executable file
View File

@ -0,0 +1,22 @@
#!/usr/bin/perl
use strict;
use warnings;
use XML::Twig;
use Test::More tests => 1;
use utf8;
{
XML::Twig::_disallow_use( 'Tie::IxHash');
my $t;
eval { $t= XML::Twig->new( keep_atts_order => 0); };
ok( $t, 'keep_atts_order => 0');
}
exit;

100
t/test_3_50.t Executable file
View File

@ -0,0 +1,100 @@
#!/usr/bin/perl
use strict;
use warnings;
use XML::Twig;
use Test::More tests => 18;
use utf8;
SKIP: {
if( XML::Twig::_use( 'XML::XPathEngine') && XML::Twig::_use( 'XML::Twig::XPath'))
{ ok( XML::Twig::XPath->new()->parse('<xml xmlns:foo="www.bar.com"/>')->findnodes('//namespace::*'), '//namespace::* does not crash'); }
else
{ skip 'cannot use XML::Twig::XPath', 1; }
}
{
my $doc=q{<d><title>title</title><para>p 1</para><para>p 2</para></d>};
my $out;
open( my $out_fh, '>', \$out);
my $t= XML::Twig->new ( twig_handlers => { _default_ => sub { $_->flush( $out_fh); } });
$t->parse( $doc);
is( $out, $doc, 'flush with _default_ handler');
}
{
my $doc=q{<d><title>title</title><para>p 1</para><para>p 2</para></d>};
my $out;
open( my $out_fh, '>', \$out);
my $t= XML::Twig->new ( twig_handlers => { 'd' => sub { $_->flush( $out_fh); } });
$t->parse( $doc);
#is( $out, $doc, 'flush with handler on the root');
}
{ # test notations
my $doc=q{<?xml version="1.0"?>
<!DOCTYPE d [
<!ELEMENT d (code+)>
<!ELEMENT code (#PCDATA)>
<!NOTATION vrml PUBLIC "VRML 1.0">
<!NOTATION perl PUBLIC "Perl 22.4" "/usr/bin/perl">
<!ATTLIST code lang NOTATION (vrml|perl) #REQUIRED>
]>
<d>
<code lang="vrml">DirectionalLight { direction 0 -1 0 }</code>
<code lang="perl">XML::Twig->parse( 'file.xml');</code>
</d>
};
my $t= XML::Twig->parse( $doc);
my $n= $t->notation_list;
is( join( ':', sort $t->notation_names), 'perl:vrml', 'notation_names');
is( join( ':', sort map { $_->name } $n->list), 'perl:vrml', 'notation_list (names)');
is( join( ':', sort map { $_->pubid } $n->list), 'Perl 22.4:VRML 1.0', 'notation_list (pubid)');
is( join( ':', sort map { $_->sysid || '' } $n->list), ':/usr/bin/perl', 'notation_list (pubid)');
is( $n->notation( 'perl')->pubid, 'Perl 22.4', 'individual notation pubid');
is( $n->notation( 'vrml')->base, undef, 'individual notation base');
is( $n->text, qq{<!NOTATION perl PUBLIC "Perl 22.4" "/usr/bin/perl">\n<!NOTATION vrml PUBLIC "VRML 1.0">}, 'all notations');
my $notations= () = ( $t->sprint() =~ m{<!NOTATION}g);
is( $notations, 2, 'count notations (unchanged)');
$notations= () = ( $t->sprint( update_DTD => 1) =~ m{<!NOTATION}g);
is( $notations, 2, 'count notations (unchanged, with update_DTD)');
$n->delete( 'perl');
$notations= () = ( $t->sprint( update_DTD => 1) =~ m{<!NOTATION}g);
is( $notations, 1, 'count notations (updated)');
is( $t->notation( 'vrml')->pubid(), 'VRML 1.0', 'notation method');
$n->add_new_notation( 'svg', '', 'image/svg', 'SVG');
is( $n->notation( 'svg')->text, qq{<!NOTATION svg PUBLIC "SVG" "image/svg">}, 'new notation');
}
{ # somehow these were never tested (they are inlined within the module)
my $t= XML::Twig->parse( '<d><e2/></d>');
my $d= $t->root;
my $e2= $t->first_elt( 'e2');
my $e1= XML::Twig::Elt->new( 'e1');
$d->set_first_child( $e1);
$e2->set_prev_sibling( $e1);
$e1->set_next_sibling( $e2);
is( $t->sprint, '<d><e1/><e2/></d>', 'set_first_child');
my $e3= XML::Twig::Elt->new( 'e3');
$d->set_last_child( $e3);
$e2->set_next_sibling( $e3);
$e3->set_prev_sibling( $e2);
is( $t->sprint, '<d><e1/><e2/><e3/></d>', 'set_last_child');
$e2->insert_new_elt( first_child => '#PCDATA')->_set_pcdata( 'foo');
is( $t->sprint, '<d><e1/><e2>foo</e2><e3/></d>', '_set_pcdata');
$e1->insert_new_elt( first_child => '#CDATA')->_set_cdata( 'bar');
is( $t->sprint, '<d><e1><![CDATA[bar]]></e1><e2>foo</e2><e3/></d>', '_set_cdata');
}
exit;

2700
t/test_additional.t Executable file
View File

File diff suppressed because it is too large Load Diff

54
t/test_attregexp_cond.t Executable file
View File

@ -0,0 +1,54 @@
#!/usr/bin/perl -w
use strict;
use XML::Twig;
$|=1;
my $i=0;
my $failed=0;
my $TMAX=4; # do not forget to update!
print "1..$TMAX\n";
$i++;
print "ok $i\n"; # loading
my $t= XML::Twig->new(
twig_handlers =>
{ 'elt[@att=~/^v/]' => sub { $i++;
if( $_->att( 'ok') eq "ok")
{ print "ok $i\n";
}
else
{ print "NOK $i\n";
# print STDERR "id: ", $_->att( 'id'), "\n";
}
},
'elt[@change=~/^now$/]' => sub { $_[0]->setTwigHandler(
'elt[@att=~/^new/]' =>
sub { $i++;
if( $_->att( 'ok') eq "ok")
{ print "ok $i\n"; }
else
{ print "NOK $i\n";
# print STDERR "id: ", $_->att( 'id'), "\n";
}
});
},
},
);
$t->parse( \*DATA);
exit 0;
__DATA__
<doc id="doc" >
<elt id="elt1" att="val" ok="ok">foo<elt id="elt2" att="no val" ok="nok"/></elt>
<elt id="elt3" att="v" ok="ok"/>
<elt id="elt4" ok="nok"/>q
<elt id="elt5" change="now"/>
<elt id="elt6" att="new_val" ok="ok"/>
<elt id="elt7" att="val" ok="nok"/>
</doc>

34
t/test_autoencoding_conversion.t Executable file
View File

@ -0,0 +1,34 @@
#!/usr/bin/perl -w
#
use strict;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
print "1..2\n";
if( $] < 5.008)
{ skip( 2, "needs perl 5.8 or above to test auto conversion"); }
elsif( $ENV{PERL_UNICODE} && $ENV{PERL_UNICODE}=~ m{SA})
{ skip( 2, 'auto conversion does not happen when $PERL_UNICODE set to SA'); }
else
{ _use( 'Encode');
my $char_utf8 = qq{\x{e9}};
my $char_latin1 = encode("iso-8859-1", $char_utf8);
my $doc_utf8 = qq{<d>$char_utf8</d>};
my $doc_latin1 = qq{<?xml version="1.0" encoding="iso-8859-1"?><d>$char_latin1</d>};
my $file_utf8 = "doc_utf8.xml";
spit( $file_utf8, $doc_utf8);
my $file_latin1 = "doc_latin1.xml";
spit( $file_latin1, $doc_latin1);
my( $q, $q2) = ( ($^O eq "MSWin32") || ($^O eq 'VMS') ) ? ('"', "'") : ("'", '"');
my $lib= File::Spec->catfile( 'blib', 'lib');
my $run_it=qq{$^X -I $lib -MXML::Twig -e$q print XML::Twig->parse( $q2$file_latin1$q2)->root->text$q};
my $parsed= `$run_it`;
is( $parsed, $char_utf8, 'testing auto transcoding of latin1 output');
is( $parsed, $char_latin1, 'testing auto transcoding of latin1 output');
}

143
t/test_bugs_3_15.t Executable file
View File

@ -0,0 +1,143 @@
#!/usr/bin/perl -w
use strict;
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
#$|=1;
my $DEBUG=0;
use XML::Twig;
my $TMAX=17;
print "1..$TMAX\n";
{ # test bug outputing end tag with pretty_print => nsgmls on
my $out= XML::Twig->new( pretty_print => 'nsgmls')->parse( "<doc><elt>text</elt></doc>")->sprint;
ok( XML::Twig->new( error_context => 1)->safe_parse( $out), "end tag with nsgmls option" . ($@ || '') );
}
{ # test bug RT #8830: simplify dies on mixed content
ok( XML::Twig->new->parse( "<doc>text1<elt/></doc>")->root->simplify, "simplify mixed content");
}
{ # testing to see if bug RT #7523 is still around
my $t= XML::Twig->new->parse( '<doc/>');
if( eval( '$t->iconv_convert( "utf8");'))
{ $t->set_output_encoding( 'utf8');
eval { $t->sprint;};
ok( !$@, 'checking bug RT 7523');
}
else
{ if( $@=~ m{^Can't locate Text/Iconv.pm} || $@=~ m{^Text::Iconv not available} )
{ skip( 1, "Text::Iconv not available"); }
elsif( $@=~ m{^Unsupported (encoding|conversion): utf8})
{ skip( 1, "your version of iconv does not support utf8"); }
else
{ skip( 1, "odd error creating filter with iconv: $@"); }
}
}
{ # bug on comments
my $doc= "<doc>\n <!-- comment -->\n <elt>foo</elt>\n</doc>\n";
my $t= XML::Twig->new( comments => 'keep', pretty_print => 'indented')
->parse( $doc);
is( $t->sprint => $doc, "comment with comments => 'keep'");
}
{ # bug with disapearing entities in attributes
my $text= '<doc att="M&uuml;nchen"><elt att="&ent2;"/><elt att="A&amp;E">&ent3;</elt></doc>';
my $doc= qq{<!DOCTYPE doc SYSTEM "test_ent_in_att.dtd"[<!ENTITY foo "toto">]>$text};
XML::Twig::Elt::init_global_state();
my $regular=XML::Twig->new( pretty_print => 'none')->parse( $doc)->root->sprint;
(my $expected= $text)=~ s{&(uuml|ent2);}{}g; # yes, entities in attributes just vanish!
is( $regular => $expected, "entities in atts, no option");
XML::Twig::Elt::init_global_state();
my $with_keep=XML::Twig->new(keep_encoding => 1)->parse( $doc)->root->sprint;
is( $with_keep => $text, "entities in atts with keep_encoding");
XML::Twig::Elt::init_global_state();
my $with_dneaia=XML::Twig->new(do_not_escape_amp_in_atts => 1)->parse( $doc)->root->sprint;
if( $with_dneaia eq '<doc att="Mnchen"><elt att=""/><elt att="A&amp;E">&ent3;</elt></doc>')
{ skip( 1, "option do_not_escape_amp_in_atts not available (it's only available in an old version of expat), no worries"); }
else
{ is( $with_dneaia => $text, "entities in atts with do_not_escape_amp_in_atts"); }
# checking that all goes back to normal
XML::Twig::Elt::init_global_state();
$regular=XML::Twig->new()->parse( $doc)->root->sprint;
is( $regular => $expected, "entities in atts, no option");
}
# bug on xmlns in path expression trigger
{ my $matched=0;
my $twig = XML::Twig->new( map_xmlns => { uri1 => 'aaa', },
twig_handlers => { '/aaa:doc/aaa:elt' => sub { $matched=1; } }
)
->parse( q{<xxx:doc xmlns:xxx="uri1"><xxx:elt/></xxx:doc>});
ok( $matched, "using name spaces in path expression trigger");
$matched=0;
$twig = XML::Twig->new( map_xmlns => { uri1 => 'aaa', },
twig_handlers => { 'aaa:doc/aaa:elt' => sub { $matched=1; } }
)
->parse( q{<xxx:doc xmlns:xxx="uri1"><xxx:elt/></xxx:doc>});
ok( $matched, "using name spaces in partial path expression trigger");
}
# bug where the leading spaces are discarded in an element like <p> <b>foo</b>bar</p>
{ # check that leading spaces after a \n are discarded
my $doc= "<p>\n <b>foo</b>\n</p>";
my $expected= "<p><b>foo</b></p>";
my $result= XML::Twig->new->parse( $doc)->sprint;
is( $result => $expected, 'leading spaces kept when not after a \n');
}
{
# check that leading spaces NOT after a \n are kept around
my $doc= "<p> <b>foo</b>bar</p>";
my $result= XML::Twig->new->parse( $doc)->sprint;
is( $result => $doc, 'leading spaces kept when not after a \n');
}
{
my $t= XML::Twig->new->parse( "<doc><elt> elt 1 </elt> <elt> elt 2 </elt></doc>");
is( scalar $t->descendants( '#PCDATA'), 3, 'properly parsed pcdata');
}
{
my $t= XML::Twig->new->parse( "<doc>\n <elt> elt 1 </elt>\n <elt> elt 2 </elt>\n</doc>");
is( scalar $t->descendants( '#PCDATA'), 2, 'properly parsed pcdata');
}
{ # bug RT 8137
my $doc= q{<doc att="val"/>};
(my $expected= $doc)=~ s{ }{ };
is( XML::Twig->new( keep_encoding => 1)->parse( $doc)->sprint, $expected,
'keep_encoding and 2 spaces between gi and attribute'
);
}
{ # copy of an element with extra_data_before_end_tag
my $doc= '<doc>data<?pi here?>more</doc>';
my $expected= '<doc>data<?pi here?>more</doc>'; # pi's are not being moved around anymore
my $elt= XML::Twig->new( pi => 'keep')->parse( $doc)->root->copy;
is( $elt->sprint, $expected, 'copy of an element with extra_data_before_end_tag');
}
{ # copy of an element with extra_data_before_end_tag
my $doc= '<doc><?pi here?></doc>';
my $elt= XML::Twig->new( pi => 'keep')->parse( $doc)->root->copy;
is( $elt->sprint, $doc, 'copy of an element with extra_data_before_end_tag');
}

599
t/test_bugs_3_18.t Executable file
View File

@ -0,0 +1,599 @@
#!/usr/bin/perl -w
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
$|=1;
my $DEBUG=0;
use XML::Twig;
my $TMAX=158;
print "1..$TMAX\n";
{
#bug with long CDATA
# get an accented char in iso-8859-1
my $char_file=File::Spec->catfile('t', "latin1_accented_char.iso-8859-1");
open( CHARFH, "<$char_file") or die "cannot open $char_file: $!";
my $latin1_char=<CHARFH>;
chomp $latin1_char;
close CHARFH;
my %cdata=( "01- 1023 chars" => 'x' x 1022 . 'a',
"02- 1024 chars" => 'x' x 1023 . 'a',
"03- 1025 chars" => 'x' x 1024 . 'a',
"04- 1026 chars" => 'x' x 1025 . 'a',
"05- 2049 chars" => 'x' x 2048 . 'a',
"06- 1023 chars spaces" => 'x' x 1020 . ' a',
"07- 1024 chars spaces" => 'x' x 1021 . ' a',
"08- 1025 chars spaces" => 'x' x 1022 . ' a',
"09- 1026 chars spaces" => 'x' x 1023 . ' a',
"10- 2049 chars spaces" => 'x' x 2048 . ' a',
"11- 1023 accented chars" => $latin1_char x 1022 . 'a',
"12- 1024 accented chars" => $latin1_char x 1023 . 'a',
"13- 1025 accented chars" => $latin1_char x 1024 . 'a',
"14- 1026 accented chars" => $latin1_char x 1025 . 'a',
"15- 2049 accented chars" => $latin1_char x 2048 . 'a',
"16- 1023 accented chars spaces" => $latin1_char x 1020 . ' a',
"17- 1024 accented chars spaces" => $latin1_char x 1021 . ' a',
"18- 1025 accented chars spaces" => $latin1_char x 1022 . ' a',
"19- 1026 accented chars spaces" => $latin1_char x 1023 . ' a',
"20- 2049 accented chars spaces" => $latin1_char x 2048 . ' a',
"21- 511 accented chars" => $latin1_char x 511 . 'a',
"22- 512 accented chars" => $latin1_char x 512 . 'a',
"23- 513 accented chars" => $latin1_char x 513 . 'a',
#"00- lotsa chars" => 'x' x 2000000 . 'a', # do not try this at home
# but if you do with a higher number, let me know!
);
if( ($] == 5.008) || ($] < 5.006) || ($XML::Parser::VERSION <= 2.27) )
{ skip( scalar keys %cdata, "KNOWN BUG in 5.8.0 and 5.005 or with XML::Parser 2.27 with keep_encoding and long (>1024 char) CDATA, "
. "see RT #14008 at http://rt.cpan.org/Ticket/Display.html?id=14008"
);
}
elsif( perl_io_layer_used())
{ skip( scalar keys %cdata, "cannot test parseurl when UTF8 perIO layer used "
. "(due to PERL_UNICODE being set or -C command line option being used)\n"
);
}
else
{
foreach my $test (sort keys %cdata)
{ my $cdata=$cdata{$test};
my $doc= qq{<?xml version="1.0" encoding="iso-8859-1" ?><doc><![CDATA[$cdata]]></doc>};
my $twig= XML::Twig->new( keep_encoding => 1)->parse($doc);
my $res = $twig->root->first_child->cdata;
is( $res, $cdata, "long CDATA with keep_encoding $test");
}
}
}
# subs_text on text with new lines
{ my $doc= "<doc> foo1 \n foo2 </doc>";
my $t= XML::Twig->new->parse( $doc);
(my $expected= $doc)=~ s{foo}{bar}g;
$t->subs_text( qr{foo}, "bar");
is( $t->sprint, $expected, "subs_text on string with \n");
$expected=~ s{ }{&nbsp;}g;
$t->subs_text( qr{ }, q{&ent( "&nbsp;")} );
if( 0 && $] =~ m{^5.006})
{ skip( 1, "known bug in perl 5.6.*: subs_text with an entity matches line returns\n"
. " this bug is under investigation\n");
}
else
{ is( $t->sprint, $expected, "subs_text on string with \n"); }
}
# testing ID processing
{ # setting existing id to a different value
my $t= XML::Twig->new->parse( '<doc id="i1"/>');
$t->root->set_id( "i2");
is( id_list( $t), "i2", "changing an existing id");
$t->root->del_id();
is( id_list( $t), "", "deleting an id");
$t->root->del_id();
is( id_list( $t), "", "deleting again an id");
$t->root->set_id( "0");
is( id_list( $t), "0", "changing an existing id to 0");
$t->root->del_id();
is( id_list( $t), "", "deleting again an id");
}
{ # setting id through the att
my $t= XML::Twig->new->parse( '<doc id="i1"/>');
$t->root->set_att( id => "i2");
is( fid( $t, "i2"), "i2", "changing an existing id using set_att");
$t->root->set_att( id => "0");
is( fid( $t, "0"), "0", "using set_att with a id of 0");
$t->root->set_atts( { id => "i3" });
is( fid( $t, "i3"), "i3", "using set_atts");
$t->root->set_atts( { id => "0" });
is( fid( $t, "0"), "0", "using set_atts with an if of 0");
}
{ # setting id through a new element
my $t= XML::Twig->new->parse( '<doc id="i1"/>');
my $n= $t->root->insert_new_elt( elt => { id => "i2" });
is( id_list( $t), "i1-i2", "setting id through a new element");
$n= $t->root->insert_new_elt( elt => { id => "0" });
is( id_list( $t), "0-i1-i2", "setting id through a new element");
}
{ # setting ids through a parse
my $t= XML::Twig->new->parse( '<doc id="i1"/>');
my $elt= XML::Twig::Elt->parse( '<elt id="i2"><selt id="i3"/><selt id="0"/></elt>');
$elt->paste( $t->root);
is( id_list( $t), "0-i1-i2-i3", "setting id through a parse");
}
{ # test ]]> in text
my $doc=q{<doc att="]]&gt;">]]&gt;</doc>};
is( XML::Twig->new->parse( $doc)->sprint, $doc, "]]> in char data");
}
sub fid { my $elt= $_[0]->elt_id( $_[1]) or return "unknown";
return $elt->att( $_[0]->{twig_id});
}
# testing ignore messing up with whitespace handling
{ my $doc=qq{<doc>\n <elt2 ignore="1">ba</elt2>\n <elt>foo</elt>\n <elt2>bar</elt2>\n</doc>};
my $res;
my $t= XML::Twig->new( twig_roots => { elt => sub { $_->ignore; },
elt2 => sub { $res.= $_->text; },
},
start_tag_handlers => { elt2 => sub { $_[0]->ignore if( $_->att( 'ignore')); },
},
);
$t->parse( $doc);
is( $res => 'bar', 'checking that ignore and whitespace handling work well together');
}
# test on handlers with ns
{ my $doc=q{<doc xmlns:ns="uri">
<ns:elt ns:att="val" att2="ns_att" >elt with ns att</ns:elt>
<ns:elt att="val" att2="non_ns_att">elt with no ns att</ns:elt>
</doc>
};
my( $res1, $res2);
my $t= XML::Twig->new( map_xmlns => { uri => 'n' },
twig_handlers => { 'n:elt[@n:att="val"]' => sub { $res1 .= $_->text; },
'n:elt[@att="val"]' => sub { $res2 .= $_->text; },
},
)
->parse( $doc);
is( $res1 => 'elt with ns att', 'twig handler on n:elt[@n:att="val"]');
is( $res2 => 'elt with no ns att', 'twig handler on n:elt[@att="val"]');
}
# same with start_tag handlers
{ my $doc=q{<doc xmlns:ns="uri">
<ns:elt ns:att="val" att2="ns_att" >elt with ns att</ns:elt>
<ns:elt att="val" att2="non_ns_att">elt with no ns att</ns:elt>
</doc>
};
my( $res1, $res2);
my $t= XML::Twig->new( map_xmlns => { uri => 'n' },
start_tag_handlers => { 'n:elt[@n:att="val"]' => sub { $res1 .= $_->att( 'att2'); },
'n:elt[@att="val"]' => sub { $res2 .= $_->att( 'att2'); },
},
)
->parse( $doc);
is( $res1 => 'ns_att', 'start_tag handler on n:elt[@n:att="val"]');
is( $res2 => 'non_ns_att', 'start_tag handler on n:elt[@att="val"]');
}
# same with start_tag handlers and twig_roots
{ my $doc=q{<doc xmlns:ns="uri">
<ns:elt ns:att="val" att2="ns_att" >elt with ns att</ns:elt>
<ns:elt att="val" att2="non_ns_att">elt with no ns att</ns:elt>
</doc>
};
my( $res1, $res2);
my $t= XML::Twig->new( map_xmlns => { uri => 'n' },
twig_roots => { foo => 1 },
start_tag_handlers => { 'n:elt[@n:att="val"]' => sub { my( $t, $gi, %atts)= @_;
$res1 .= $atts{att2};
},
'n:elt[@att="val"]' => sub { my( $t, $gi, %atts)= @_;
$res2 .= $atts{att2};
},
},
)
->parse( $doc);
is( $res1 => 'ns_att', 'start_tag handler on n:elt[@n:att="val"]');
is( $res2 => 'non_ns_att', 'start_tag handler on n:elt[@att="val"]');
}
# tests for additional coverage
{ my $doc=q{<doc><elt>foo</elt><elt2>bar</elt2></doc>};
my $res='';
my $t= XML::Twig->new;
$t->setTwigHandlers( { elt => sub { $res.= $_->text}, });
$t->setTwigHandlers();
$t->parse( $doc);
is( $res => '', 'setTwigHandlers with no argument');
}
{ my $doc=q{<doc><elt>foo</elt><elt2>bar</elt2></doc>};
my $res;
my $t= XML::Twig->new;
$t->setTwigHandlers( { elt => sub { $res.= $_->text}, });
$t->parse( $doc);
is( $res => 'foo', 'setTwigHandlers by itself');
}
{ my $doc=q{<doc><elt>foo</elt><elt2>bar</elt2></doc>};
my $res='';
my $t= XML::Twig->new;
$t->setTwigHandlers( { '/doc/elt' => sub { $res.= $_->text}, });
$t->setTwigHandlers( { '/doc/elt' => undef, });
$t->parse( $doc);
is( $res => '', 'setTwigHandlers with an undef path');
}
{ my $doc=q{<doc><elt>foo</elt><elt2>bar</elt2></doc>};
my $res='';
my $t= XML::Twig->new;
$t->setTwigHandlers( { 'doc/elt' => sub { $res.= $_->text}, });
$t->setTwigHandlers( { 'doc/elt' => undef, });
$t->parse( $doc);
is( $res => '', 'setTwigHandlers with an undef subpath');
}
{ my $doc=q{<doc><elt att="baz">foo</elt><elt>bar</elt></doc>};
my $res='';
my $t= XML::Twig->new;
$t->setTwigHandlers( { 'elt[@att="baz"]' => sub { $res.= $_->text}, });
$t->setTwigHandlers( { 'elt[@att="bak"]' => sub { $res.= $_->text}, });
$t->setTwigHandlers( { 'elt[@att="baz"]' => undef, });
$t->setTwigHandlers( { 'elt[@att="bal"]' => undef, });
$t->parse( $doc);
is( $res => '', 'setTwigHandlers with an undef att cond');
}
{ my $doc=q{<doc><elt att="baz">foo</elt><elt>bar</elt></doc>};
my $res='';
my $t= XML::Twig->new;
$t->setTwigHandlers( { 'elt[@att=~/baz/]' => sub { $res.= $_->text}, });
$t->setTwigHandlers( { 'elt[@att=~/bar/]' => sub { $res.= $_->text}, });
$t->setTwigHandlers( { 'elt[@att=~/baz/]' => undef, });
$t->setTwigHandlers( { 'elt[@att=~/bas/]' => undef, });
$t->parse( $doc);
is( $res => '', 'setTwigHandlers with undef regexp on att conds');
}
{ my $doc=q{<doc><elt att="baz">foo</elt><elt>bar</elt></doc>};
my $res='';
my $t= XML::Twig->new;
$t->setTwigHandlers( { 'elt[string()="foo"]' => sub { $res.= $_->text}, });
$t->setTwigHandlers( { 'elt[string()="fool"]' => sub { $res.= $_->text}, });
$t->setTwigHandlers( { 'elt[string()="foo"]' => undef} );
$t->setTwigHandlers( { 'elt[string()="food"]' => undef} );
$t->parse( $doc);
is( $res => '', 'setTwigHandlers with undef string conds');
}
{ my $doc=q{<doc><elt att="baz">foo</elt><elt>bar</elt></doc>};
my $res='';
my $t= XML::Twig->new;
$t->setTwigHandlers( { 'elt[string()=~/foo/]' => sub { $res.= $_->text}, });
$t->setTwigHandlers( { 'elt[string()=~/fool/]' => sub { $res.= $_->text}, });
$t->setTwigHandlers( { 'elt[string()=~/foo/]' => undef});
$t->setTwigHandlers( { 'elt[string()=~/food/]' => undef});
$t->parse( $doc);
is( $res => '', 'setTwigHandlers with undef string regexp conds');
}
{ my $doc=q{<doc><elt att="baz">foo</elt><elt>bar</elt></doc>};
my $res='';
my $t= XML::Twig->new;
$t->setTwigHandlers( { '*[@att="baz"]' => sub { $res.= $_->text}, });
$t->setTwigHandlers( { '*[@att="bak"]' => sub { $res.= $_->text}, });
$t->setTwigHandlers( { '*[@att="baz"]' => undef, });
$t->setTwigHandlers( { '*[@att="bal"]' => undef, });
$t->parse( $doc);
is( $res => '', 'setTwigHandlers with an undef start att cond');
}
{ my $doc=q{<doc><elt att="baz">foo</elt><elt>bar</elt></doc>};
my $res='';
my $t= XML::Twig->new;
$t->setTwigHandlers( { '*[@att=~/baz/]' => sub { $res.= $_->text}, });
$t->setTwigHandlers( { '*[@att=~/bak/]' => sub { $res.= $_->text}, });
$t->setTwigHandlers( { '*[@att=~/baz/]' => undef, });
$t->setTwigHandlers( { '*[@att=~/bal/]' => undef, });
$t->parse( $doc);
is( $res => '', 'setTwigHandlers with an undef start att regexp cond');
}
{ my $doc=q{<doc><elt att="baz">foo</elt><elt>bar</elt></doc>};
my $res='';
my $t= XML::Twig->new;
$t->setStartTagHandlers( { 'elt[@att="baz"]' => sub { $res.= 'not this one'}, });
$t->setStartTagHandlers( { 'elt[@att="bal"]' => sub { $res.= $_->att( 'att') || 'none'}, });
$t->setStartTagHandlers( { 'elt[@att="baz"]' => sub { $res.= $_->att( 'att') || 'none'}, });
$t->parse( $doc);
is( $res => 'baz', 'setStartTagHandlers');
}
{ my $doc=q{<doc><title>title</title><sect><elt>foo</elt><elt>bar</elt></sect></doc>};
my $res='';
my $t= XML::Twig->new( twig_handlers => { 'level(2)' => sub { $res .= $_->text;} })
->parse( $doc);
is( $res => 'foobar', 'level cond');
}
{ my $doc=q{<doc><title>title</title><sect><elt>foo</elt><elt>bar</elt></sect></doc>};
my $res='';
my $t= XML::Twig->new( twig_roots => { 'level(2)' => sub { $res .= $_->text;} })
->parse( $doc);
is( $res => 'foobar', 'level cond');
}
{ my $doc=q{<doc><?t1 d1?><elt/><?t2 d2?></doc>};
my $res='';
XML::Twig->new( pi => 'process', twig_handlers => { '?' => sub { $res.=$_->data } })->parse( $doc);
is( $res => 'd1d2', '? (any pi) handler');
}
{ my $doc=q{<doc><elt>foo <!--commment--> bar</elt></doc>};
my $t= XML::Twig->new->parse( $doc);
is( $t->sprint, $doc, 'embedded comments, output asis');
$t->root->first_child( 'elt')->first_child->set_pcdata( 'toto');
is( $t->sprint, '<doc><elt>toto</elt></doc>', 'embedded comment removed');
}
{ my $doc=q{<?xml version="1.0" ?>
<!DOCTYPE doc [ <!ELEMENT doc (#PCDATA)>
<!ENTITY ent "foo">
]
>
<doc> a &ent; is here</doc>
};
my $t= XML::Twig->new->parse( $doc);
$t->entity_list->add_new_ent( ent2 => 'bar');
my $res= $t->sprint();
is_like( $res, qq{<?xml version="1.0" ?><!DOCTYPE doc[<!ELEMENT doc (#PCDATA)><!ENTITY ent "foo">]>}
.qq{<doc> a foo is here</doc>}, 'new ent, no update dtd');
$res=$t->sprint( updateDTD => 1);
is_like( $res, qq{<?xml version="1.0" ?><!DOCTYPE doc[<!ELEMENT doc (#PCDATA)><!ENTITY ent "foo">}
. qq{<!ENTITY ent2 "bar">]><doc> a foo is here</doc>},
'new ent update dtd'
);
}
{ my $t=XML::Twig->new->parse( '<doc/>');
$t->{entity_list}= XML::Twig::Entity_list->new;
$t->entity_list->add_new_ent( foo => 'bar');
is_like( $t->sprint( update_DTD => 1), '<!DOCTYPE doc [<!ENTITY foo "bar">]><doc/>', "new entity with update DTD");
}
{ my $t=XML::Twig->new( keep_encoding => 1)->parse( '<doc/>');
$t->{entity_list}= XML::Twig::Entity_list->new;
$t->entity_list->add_new_ent( foo => 'bar');
is_like( $t->sprint( update_DTD => 1), '<!DOCTYPE doc [<!ENTITY foo "bar">]><doc/>',
"new entity (keep_encoding)with update DTD"
);
}
{ my $dtd= q{<!DOCTYPE doc [<!ELEMENT doc (elt+)>
<!ATTLIST doc id ID #IMPLIED>
<!ELEMENT elt (#PCDATA)>
<!ATTLIST elt att CDATA 'foo'
fixed CDATA #FIXED 'fixed'
id ID #IMPLIED
>
]>
};
my $doc= q{<doc id="d1"><elt id="e1" att="toto">tata</elt><elt/></doc>};
my $t= XML::Twig->new->parse( $dtd . $doc);
is_like( $t->dtd_text, $dtd, "dtd_text");
}
{ my $t=XML::Twig->new->parse( '<doc><elt/></doc>');
is( $t->root->first_child( 'elt')->sprint, '<elt/>', "nav, first pass");
is( $t->root->first_child( 'elt')->sprint, '<elt/>', "nav, second pass");
is_undef( scalar $t->root->first_child( 'elt')->parent( 'toto'), "undef parent 1");
is_undef( scalar $t->root->parent( 'toto'), "undef parent 2");
is_undef( scalar $t->root->parent(), "undef parent 3");
}
{ my $t= XML::Twig->new->parse( '<doc id="myid"><elt/></doc>');
my $id= $t->root->id;
$t->root->add_id();
is( $t->root->id, $id, "add_id on existing id");
my $elt= $t->root->first_child( 'elt');
$elt->cut;
$elt->set_id( 'elt1');
is_undef( $t->elt_id( 'elt1'), "id added to elt outside the doc");
$elt->paste( $t->root);
is( $t->elt_id( 'elt1')->gi => 'elt', "elt put back in the tree");
# these tests show a bug: the id list is not updated when an element is cut
$elt->cut;
$elt->del_id;
$elt->del_id; # twice to go through a different path
$elt->paste( $t->root);
is( $t->elt_id( 'elt1')->gi => 'elt', "elt put back in the tree without id");
$elt->del_id;
is( $t->elt_id( 'elt1')->gi => 'elt', "deleting an inexisting id which remains in the list");
is( scalar $elt->ancestors_or_self( 'elt'), 1, "ancestors_or_self with cond");
is( scalar $elt->ancestors_or_self(), 2, "ancestors_or_self without cond");
my @current_ns_prefixes= $elt->current_ns_prefixes;
is( scalar @current_ns_prefixes, 0, "current_ns_prefixes");
is_undef( $elt->next_elt( $elt), 'next_elt on an empty elt (limited to the subtree)');
is_undef( $elt->next_elt( $elt, 'foo'), 'next_elt on an empty elt (subtree and elt name)');
is_undef( $elt->next_elt( 'foo'), 'next_elt on an empty elt (elt name)');
is_undef( $elt->prev_elt( $elt), 'prev_elt on an empty elt (limited to the subtree)');
is_undef( $elt->prev_elt( $elt, 'foo'), 'prev_elt on an empty elt (subtree and elt name)');
is_undef( $elt->prev_elt( 'foo'), 'prev_elt on an empty elt (elt name)');
is_undef( $elt->next_n_elt( 1, 'foo'), 'next_n_elt');
is_undef( $elt->next_n_elt( 0, 'foo'), 'next_n_elt');
is( $elt->level(), 1, "level");
is( $elt->level( 'elt'), 0, "level");
is( $elt->level( 'doc'), 1, "level");
is( $elt->level( 'foo'), 0, "level");
ok( $elt->in_context( 'doc'), "in_context doc ");
ok( $elt->in_context( 'doc', 0), "in_context doc with level (0)");
ok( $elt->in_context( 'doc', 1), "in_context doc with level");
ok( $elt->in_context( 'doc', 2), "in_context doc with level");
nok( $elt->in_context( 'foo'), "in_context foo");
nok( $elt->in_context( 'foo', 0), "in_context foo with level (0)");
nok( $elt->in_context( 'foo', 1), "in_context foo with level");
nok( $elt->in_context( 'foo', 2), "in_context foo with level (0)");
nok( $elt->in_context( 'elt'), "in_context elt");
nok( $elt->in_context( 'elt', 0), "in_context elt with level (0)");
nok( $elt->in_context( 'elt', 1), "in_context elt with level");
nok( $elt->in_context( 'elt', 2), "in_context elt with level (0)");
}
{ foreach my $doc ( '<doc><!-- extra data --><ERS><sub/></ERS></doc>',
'<doc><!-- extra data --><ERS>toto<sub/></ERS>toto</doc>',
'<doc>toto<!-- extra data --><ERS>toto<sub/></ERS>toto</doc>',
'<doc>toto<!-- extra data -->tata<ERS>toto<sub/></ERS>toto</doc>',
'<doc>toto<!-- extra data --><ERS>titi <!-- more ed --> tutu<sub/></ERS>toto</doc>',
'<doc>toto<!-- extra data --><ERS><!-- more ed --> tutu<sub/></ERS>toto</doc>',
'<doc><!-- extra data --><ERS><!-- more ed --><sub/></ERS>toto</doc>',
'<doc><!-- extra data --><ERS><!-- more ed -->foo<sub/></ERS>toto</doc>',
'<doc><!-- extra data --><ERS>toto<sub/></ERS>toto</doc>',
'<doc><!-- extra data --><ERS></ERS><elt2/></doc>',
'<doc><!-- extra data --><ERS></ERS></doc>',
'<doc><!-- extra data --><ERS></ERS>toto</doc>',
'<doc><elt><!-- extra data --><ERS></ERS></elt></doc>',
'<doc><elt>foo<!-- extra data --><ERS></ERS></elt></doc>',
'<doc><elt><selt/><!-- extra data --><ERS></ERS></elt></doc>',
'<doc><!-- extra data --><ERS><foo/></ERS></doc>',
'<doc><elt><!-- extra data --><ERS></ERS></elt></doc>',
'<doc><elt><!-- extra data --><ERS><foo/></ERS></elt></doc>',
'<doc><elt><!-- extra data --><ERS></ERS></elt></doc>',
'<ERS><!-- extra data --><elt></elt></ERS>',
'<!-- extra data --><ERS><elt/></ERS>',
'<!-- first comment --><ERS><!-- extra data --><elt></elt></ERS>',
# this one does not work: nothing in XML::Twig to output stuff after the fiinal end tag
#'<!-- first comment --><ERS><!-- extra data --><elt></elt><!-- end comment --></ERS>',
'<doc><ERS>foo<!-- edbet --></ERS><!-- edbet 2 --></doc>',
'<doc><ERS>foo<!-- edbet --></ERS></doc>',
'<doc><ERS>foo<!-- edbet --></ERS><elt/></doc>',
'<doc><ERS>foo<!-- edbet --></ERS><!-- edbet 2 --><elt/></doc>',
'<doc><ERS>foo<!-- edbet --></ERS><!-- edbet 2 --><elt>toto</elt></doc>',
'<doc><ERS>foo<!-- edbet --></ERS>foo</doc>',
'<doc><ERS>foo<!-- edbet --></ERS>foo<!-- edbet 2 --><elt/></doc>',
'<doc><ERS>foo<!-- edbet --></ERS>foo<!-- edbet 2 --></doc>',
'<doc><ERS>foo<!-- edbet --></ERS><!-- edbet 2 -->foo<elt/></doc>',
'<doc><ERS>foo<!-- edbet --></ERS><!-- edbet 2 -->foo</doc>',
'<doc><ERS>foo<!-- edbet --></ERS>foo<!-- edbet 2 -->foo<elt/></doc>',
'<doc><ERS>foo<!-- edbet --></ERS>foo<!-- edbet 2 -->foo</doc>',
'<doc><elt><ERS>foo<!-- edbet --></ERS><!-- edbet 2 --></elt></doc>',
)
{ my $t=XML::Twig->new->parse( $doc);
$t->first_elt( 'ERS')->erase;
(my $expected= $doc)=~ s{</?ERS/?>}{}g;
is( $t->sprint, $expected, "erase in $doc");
}
}
{ my $t=XML::Twig->new->parse( '<doc><p>toto</p></doc>');
my $pcdata= $t->first_elt( '#PCDATA');
$pcdata->split_at( 2);
is( $t->sprint => '<doc><p>toto</p></doc>', 'split_at');
}
{ my $doc= q{<doc>tototata<e>tu</e></doc>};
my $t= XML::Twig->new->parse( $doc);
$t->subs_text( qr/(to)ta/, '&elt(p => $1)ti');
is( $t->sprint,'<doc>to<p>to</p>tita<e>tu</e></doc>' , 'subs_text');
$t->subs_text( qr/(to)ta/, '&elt(p => $1)ti');
is( $t->sprint,'<doc>to<p>to</p>tita<e>tu</e></doc>' , 'subs_text (2cd try, same exp)');
$t->subs_text( qr/(ta)/, '&elt(p1 => $1)ti');
is( $t->sprint,'<doc>to<p>to</p>ti<p1>ta</p1>ti<e>tu</e></doc>' , 'subs_text cannot merge text with next sibling');
}
{ my $doc= q{<doc>tota<e>tu</e></doc>};
my $t= XML::Twig->new->parse( $doc);
$t->subs_text( qr/(to)/, '&elt(e => $1)');
is( $t->sprint,'<doc><e>to</e>ta<e>tu</e></doc>' , 'subs_text (new elt)');
$t->subs_text( qr/(ta)/, '&elt(e => $1)');
is( $t->sprint,'<doc><e>to</e><e>ta</e><e>tu</e></doc>' , 'subs_text (new elt 2)');
$t->subs_text( qr/(t.)/, '&elt(se => $1)');
is( $t->sprint,'<doc><e><se>to</se></e><e><se>ta</se></e><e><se>tu</se></e></doc>' , 'subs_text (several subs)');
}
{ my $doc= q{<doc>totatitu</doc>};
my $t= XML::Twig->new->parse( $doc);
$t->subs_text( qr/(t[aeiou])/, '$1$1');
is( $t->sprint,'<doc>tototatatititutu</doc>' , 'subs_text (duplicate string)');
$t->subs_text( qr/((t[aeiou])\2)/, '$2');
is( $t->sprint,'<doc>totatitu</doc>' , 'subs_text (use \2)');
$t->subs_text( qr/(t[aeiou])/, '$1$1');
is( $t->sprint,'<doc>tototatatititutu</doc>' , 'subs_text (duplicate string)');
$t->subs_text( qr/(t[aeiou]t[aeiou])/, '&elt( p => $1)');
is( $t->sprint,'<doc><p>toto</p><p>tata</p><p>titi</p><p>tutu</p></doc>' , 'subs_text (use \2)');
}
{ my $doc= q{<doc><!-- comment --><e> toto <!-- comment 2 --></e>
<e2 att="val1" att2="val2"><!-- comment --><e> toto <!-- comment 2 --></e></e2>
<e>foo <?tg pi?> bar <!-- duh --> baz</e>
<e><?tg pi?> bar <!-- duh --> baz</e>
<e><?tg pi?> bar <!-- duh --></e>
</doc>
};
my $t= XML::Twig->new->parse( $doc);
my $copy= $t->root->copy;
is( $copy->sprint, $t->root->sprint, "copy with extra data");
$t->root->insert_new_elt( first_child => a => { '#ASIS' => 1 }, 'a <b>c</b> a');
$copy= $t->root->copy;
is( $copy->sprint, $t->root->sprint, "copy with extra data, and asis");
}
{ my $save= XML::Twig::_weakrefs();
XML::Twig::_set_weakrefs( 0);
my $t= XML::Twig->new->parse( '<doc><e id="e1"/><e id="e2">foo <f id="oo"/></e></doc>');
$t->root->first_child->cut->DESTROY;
$t->root->first_child->cut->DESTROY;
is( $t->sprint, '<doc></doc>', 'DESTROY');
XML::Twig::_set_weakrefs( $save);
}
{ # test _keep_encoding even with perl > 5.8.0
if( $] < 5.008)
{ skip( 2 => "testing utf8 flag mongering only needed in perl 5.8.0+"); }
else
{ require Encode; import Encode;
my $s="a";
Encode::_utf8_off( $s);
nok( Encode::is_utf8( $s), "utf8 flag off");
XML::Twig::Elt::_utf8_ify( $s);
if( $] >= 5.008 and $] < 5.010)
{ ok( Encode::is_utf8( $s), "utf8 flag back on"); }
else
{ nok( Encode::is_utf8( $s), "_utf8_ify is a noop"); }
}
}
{ # test keep_encoding
is( XML::Twig::Elt::_keep_encoding(), 0, "_keep_encoding not initialized");
XML::Twig->new( keep_encoding => 0);
is( XML::Twig::Elt::_keep_encoding(), 0, "_keep_encoding initialized (0)");
XML::Twig->new( keep_encoding => 1);
is( XML::Twig::Elt::_keep_encoding(), 1, "_keep_encoding initialized (1)");
XML::Twig->new( keep_encoding => 0);
is( XML::Twig::Elt::_keep_encoding(), 0, "_keep_encoding initialized (0)");
}

105
t/test_bugs_3_19.t Executable file
View File

@ -0,0 +1,105 @@
#!/usr/bin/perl -w
use strict;
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
$|=1;
my $DEBUG=0;
use XML::Twig;
my $TMAX=26;
print "1..$TMAX\n";
{
#bug with long CDATA
# get an accented char in iso-8859-1
my $latin1_char= perl_io_layer_used() ? '' : slurp( File::Spec->catfile('t', "latin1_accented_char.iso-8859-1"));
chomp $latin1_char;
my %cdata=( "01- 1025 chars" => 'x' x 1025 . 'a',
"02- short CDATA with nl" => "first line\nsecond line",
"03- short CDATA with ]" => "first part]second part",
"04- short CDATA with ] and spaces" => "first part ] second part",
"05- 1024 chars with accent" => $latin1_char x 1023 . 'a',
"06- 1025 chars with accent" => $latin1_char x 1024 . 'a',
"07- 1023 chars, last a nl" => 'x' x 1022 . "\n",
"08- 1023 chars, last a ]" => 'x' x 1022 . "]",
"09- 1024 chars, last a nl" => 'x' x 1023 . "\n",
"10- 1024 chars, last a ]" => 'x' x 1023 . "]",
"11- 1025 chars, last a nl" => 'x' x 1024 . "\n",
"12- 1025 chars, last a ]" => 'x' x 1024 . "]",
"13- 1050 chars, last a nl" => ('1' x 1024) . ('2' x 25) . "\n",
"14- 1050 chars, last a ]" => ('1' x 1024) . ('2' x 25) . "]",
'15- 1060 chars, ] and \n' => ('1' x 1024) . ('2' x 26) . "\n \n ]\n]]\n",
'16- 1060 chars, ] and \n' => ('1' x 1024) . ('2' x 26) . "\n \n ]\n]]",
'17- 1060 chars, ] and \n' => ('1' x 1024) . ('2' x 26) . "\n \n ]\n]] ",
'18- 1060 chars, ] and \n' => ('1' x 1024) . ('2' x 26) . "\n \n ]\n]] a",
'19- 1060 chars, ] and \n' => '1' x 500 . "\n \n ]\n]] a" . '2' x 500 . "\n \n ]\n]] a",
"20- 800 chars with accent" => $latin1_char x 800,
"21- 800 chars with accent" => "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa$latin1_char" x 16,
"22- 1600 chars with accent" => "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa$latin1_char" x 32,
'23- 1600 chars with accent and \n' => "aaaaaaaa]aaaaaaaaaaaaaaaaaaaaaaaaa\naaaaaaaaaaaaaaa$latin1_char" x 32,
);
if( ($] == 5.008) || ($] < 5.006) )
{ skip( scalar keys %cdata, "KNOWN BUG in 5.8.0 and 5.005 with keep_encoding and long (>1024 char) CDATA, "
. "see http://rt.cpan.org/Ticket/Display.html?id=14008"
);
}
elsif( perl_io_layer_used())
{ skip( scalar keys %cdata, "cannot test parseurl when UTF8 perIO layer used "
. "(due to PERL_UNICODE or -C option used)\n"
);
}
else
{
foreach my $test (sort keys %cdata)
{ my $cdata=$cdata{$test};
my $doc= qq{<?xml version="1.0" encoding="iso-8859-1" ?><doc><![CDATA[$cdata]]></doc>};
my $twig= XML::Twig->new( keep_encoding => 1)->parse($doc);
my $res = $twig->root->first_child->cdata;
is( $res, $cdata, "long CDATA with keep_encoding $test");
}
}
}
{ # testing _dump
my $doc= q{<doc><!-- comment --><elt att="xyz">foo</elt><elt>bar<![CDATA[baz]]></elt><?t pi?><elt2>toto<b>tata</b>titi</elt2><elt3 /><elt>and now a long (more than 40 characters) text to see if it gets shortened by default (or not)</elt></doc>};
my $t= XML::Twig->new->parse( $doc);
my $dump= q{document
|-doc
| |-elt att="xyz"
| |-- (cpi before) '<!-- comment -->'
| | |-PCDATA: 'foo'
| |-elt
| | |-PCDATA: 'bar'
| | |-CDATA: 'baz'
| |-elt2
| |-- (cpi before) '<?t pi?>'
| | |-PCDATA: 'toto'
| | |-b
| | | |-PCDATA: 'tata'
| | |-PCDATA: 'titi'
| |-elt3
| |-elt
| | |-PCDATA: 'and now a long (more than 40 characters) tex ... see if it gets shortened by default (or not)'
};
is( $t->_dump( { extra => 1 }), $dump, "_dump with extra on");
(my $no_extra= $dump)=~ s{^.*cpi before.*\n}{}gm;
is( $t->_dump( ), $no_extra, "_dump without extra");
(my $no_att= $no_extra)=~ s{ att=.*}{}g;
is( $t->_dump( { atts => 0 }), $no_att, "_dump without atts");
}

87
t/test_bugs_3_21.t Executable file
View File

@ -0,0 +1,87 @@
#!/usr/bin/perl -w
use strict;
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
$|=1;
my $DEBUG=0;
use XML::Twig;
my $TMAX=25;
print "1..$TMAX\n";
{ # testing creation of elements in the proper class
package foo; use base 'XML::Twig::Elt'; package main;
my $t= XML::Twig->new( elt_class => "foo")->parse( '<doc><elt/></doc>');
my $elt= $t->first_elt( 'elt');
$elt->set_text( 'bar');
is( $elt->first_child->text, 'bar', "content of element created with set_text");
is( ref( $elt->first_child), 'foo', "class of element created with set_text");
$elt->set_content( 'baz');
is( $elt->first_child->text, 'baz', "content of element created with set_content");
is( ref( $elt->first_child), 'foo', "class of element created with set_content");
$elt->insert( 'toto');
is( $elt->first_child->tag, 'toto', "tag of element created with set_content");
is( ref( $elt->first_child), 'foo', "class of element created with insert");
$elt->insert_new_elt( first_child => 'tata');
is( $elt->first_child->tag, 'tata', "tag of element created with insert_new_elt");
is( ref( $elt->first_child), 'foo', "class of element created with insert");
$elt->wrap_in( 'tutu');
is( $t->root->first_child->tag, 'tutu', "tag of element created with wrap_in");
is( ref( $t->root->first_child), 'foo', "class of element created with wrap_in");
$elt->prefix( 'titi');
is( $elt->first_child->text, 'titi', "content of element created with prefix");
is( ref( $elt->first_child), 'foo', "class of element created with prefix");
$elt->suffix( 'foobar');
is( $elt->last_child->text, 'foobar', "content of element created with suffix");
is( ref( $elt->last_child), 'foo', "class of element created with suffix");
$elt->last_child->split_at( 3);
is( $elt->last_child->text, 'bar', "content of element created with split_at");
is( ref( $elt->last_child), 'foo', "class of element created with split_at");
is( ref( $elt->copy), 'foo', "class of element created with copy");
$t= XML::Twig->new( elt_class => "foo")->parse( '<doc>toto</doc>');
$t->root->subs_text( qr{(to)} => '&elt( p => $1)');
is( $t->sprint, '<doc><p>to</p><p>to</p></doc>', "subs_text result");
my $result= join( '-', map { join( ":", ref($_), $_->tag) } $t->root->descendants);
is( $result, "foo:p-foo:#PCDATA-foo:p-foo:#PCDATA", "subs_text classes and tags");
}
{ # wrap children with > in attribute
my $doc=q{<d><e a="1" b="w"/><e a=">2" b="w"/><e b="w" a=">>" c=">"/></d>};
my $result =XML::Twig->new->parse( $doc)->root->wrap_children( '<e b="w">+', "w")->strip_att( 'id')->sprint;
my $expected = q{<d><w><e a="1" b="w"/><e a=">2" b="w"/><e a=">>" b="w" c=">"/></w></d>};
is( $result => $expected, "wrap_children with > in attributes");
$result =XML::Twig->new->parse( $doc)->root->wrap_children( '<e a="&gt;&gt;">+', "w")->strip_att( 'id')->sprint;
$expected = q{<d><e a="1" b="w"/><e a=">2" b="w"/><w><e a=">>" b="w" c=">"/></w></d>};
is( $result => $expected, "wrap_children with > in attributes, &gt; in condition");
$result =XML::Twig->new->parse( $doc)->root->wrap_children( '<e a=">>">+', "w")->strip_att( 'id')->sprint;
$expected = q{<d><e a="1" b="w"/><e a=">2" b="w"/><e a=">>" b="w" c=">"/></d>};
is( $result => $expected, "wrap_children with > in attributes un-escaped > in condition");
$result =XML::Twig->new->parse( $doc)->root->wrap_children( '<e b="w" a="1">+', "w")->strip_att( 'id')->sprint;
$expected = q{<d><w><e a="1" b="w"/></w><e a=">2" b="w"/><e a=">>" b="w" c=">"/></d>};
is( $result => $expected, "wrap_children with > in attributes, 2 atts in condition");
$result =XML::Twig->new->parse( $doc)->root->wrap_children( '<e b="N" a="1">+', "w")->strip_att( 'id')->sprint;
$expected = q{<d><e a="1" b="w"/><e a=">2" b="w"/><e a=">>" b="w" c=">"/></d>};
is( $result => $expected, "wrap_children with > in attributes, 2 atts in condition (no child matches)");
}
{ # test improvements to wrap_children
my $doc= q{<doc><elt att="&amp;">ok</elt><elt att="no">NOK</elt></doc>};
my $expected= q{<doc><w a="&amp;"><elt att="&amp;">ok</elt></w><elt att="no">NOK</elt></doc>};
my $t= XML::Twig->new->parse( $doc);
$t->root->wrap_children( '<elt att="&amp;">+', w => { a => "&" });
$t->root->strip_att( 'id');
is( $t->sprint, $expected, "wrap_children with &amp;");
}

447
t/test_bugs_3_22.t Executable file
View File

@ -0,0 +1,447 @@
#!/usr/bin/perl -w
use strict;
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
$|=1;
my $DEBUG=0;
use lib File::Spec->catdir(File::Spec->curdir,"blib/lib");
use XML::Twig;
my $TMAX=181;
print "1..$TMAX\n";
{ # testing how well embedded comments and pi's are kept when changing the content
my @tests= ( [ "foo <!-- comment -->bar baz", "foo bar", "foo <!-- comment -->bar" ],
[ "foo <!-- comment -->bar baz", "foo bar baz foobar", "foo <!-- comment -->bar baz foobar" ],
[ "foo bar<!-- comment --> foobar tutu", "bar tutu", "bar tutu" ],
[ "foo bar<!-- comment --> foobar baz", "foobar baz", "foobar baz"],
[ "foo <!-- comment -->baz", "foo bar baz", "foo bar <!-- comment -->baz"],
[ "foo <!-- comment --> baz", "foo bar baz", "foo bar<!-- comment --> baz"],
[ "foo bar <!-- comment -->baz", "bar baz", "bar <!-- comment -->baz"],
[ "foo bar <!-- comment --> baz toto", "foo toto", "foo toto"],
);
foreach my $test (@tests)
{ my( $initial, $set, $expected)= @$test;
my $t= XML::Twig->nparse( "<doc>$initial</doc>");
$t->root->set_content( $set);
is( $t->sprint, "<doc>$expected</doc>", "set_content '$initial' => '$set'");
}
}
{ # RT #17145
my $twig= new XML::Twig()->parse("<root></root>");
is( scalar( $twig->get_xpath('//root/elt[1]/child')), 0, "Context position of non-existent elements in XPATH expressions");
}
{ # some extra coverage
my @siblings= XML::Twig->nparse( "<doc/>")->root->following_elts;
is( scalar( @siblings), 0, "following_elts on last sibling");
is( XML::Twig->nparse( "<doc/>")->root->del_id->sprint, "<doc/>", "del_id on elt with no atts");
# next_elt with deep tree (
my $t= XML::Twig->nparse( q{
<doc n="12">
<elt n="0"/>
<elt1 n="10">
<selt n="4">
<sselt1 n="1"><ssselt n="0"/></sselt1>
<sselt2 n="1"><ssselt n="0"/></sselt2>
</selt>
<selt1 n="4">
<sselt3 n="1"><ssselt n="0"/></sselt3>
<sselt4 n="1"><ssselt n="0"/></sselt4>
</selt1>
</elt1>
</doc>
});
foreach my $e ($t->root->descendants_or_self)
{ is( scalar( $e->_descendants), $e->att( 'n'), "_descendant " . $e->tag . "\n");
is( scalar( $e->_descendants( 1)), $e->att( 'n') + 1, "_descendant(1) " . $e->tag . "\n");
}
}
{
my $exp= '/foo/1^%';
eval { XML::Twig->nparse( "<doc/>")->get_xpath( $exp); };
matches( $@, "^error in xpath expression", "xpath with valid expression then stuff left");
}
{
my $t = XML::Twig->nparse( "<doc/>");
my $root = $t->root;
my $elt =XML::Twig::Elt->new( 'foo');
foreach my $pos ( qw( before after))
{ eval { $elt->paste( $pos => $root); };
matches( $@, "^cannot paste $pos root", "paste $pos root");
eval " \$elt->paste_$pos( \$root)";
matches( $@, "^cannot paste $pos root", "paste $pos root");
}
}
{ is( XML::Twig->nparse( comments => "process", pi => "process", "<doc><!-- c --><?t data?><?t?></doc>")->_dump,
"document\n|-doc\n| |-COMMENT: '<!-- c -->'\n| |-PI: 't' - 'data'\n| |-PI: 't' - ''\n",
"_dump PI/comment"
);
}
{ is( XML::Twig->nparse( '<doc/>')->root->get_xpath( '.', 0)->gi, 'doc', 'get_xpath: .'); }
{ my $t= XML::Twig->nparse( '<doc><![CDATA[foo]]></doc>');
$t->first_elt( '#CDATA')->set_text( 'bar');
is( $t->sprint, '<doc><![CDATA[bar]]></doc>', " set_text on CDATA");
$t->root->set_text( 'bar');
is( $t->sprint, '<doc>bar</doc>', " set_text on elt containing CDATA");
$t= XML::Twig->nparse( '<doc><![CDATA[foo]]></doc>');
$t->first_elt( '#CDATA')->set_text( 'bar', force_pcdata => 1);
is( $t->sprint, '<doc>bar</doc>', " set_text on CDATA with force_pcdata");}
# print/flush entity
# SAX export entity
{ my $enc= "a_non_existent_encoding_bwaaahhh";
eval { XML::Twig->iconv_convert( $enc); };
matches( $@, "^(Unsupported|Text::Iconv not available|Can't locate)", "unsupported encoding");
}
{ # test comments handlers
my $doc= qq{<doc><!-- comment --><elt/></doc>};
is( XML::Twig->nparse( twig_handlers => { '#COMMENT' => sub { return uc( $_[1]); } }, $doc)->sprint,
qq{<doc><!-- COMMENT --><elt/></doc>},
"comment handler"
);
is( XML::Twig->nparse( twig_handlers => { '#COMMENT' => sub { return uc( $_[1]); } }, keep_encoding => 1, $doc)->sprint,
qq{<doc><!-- COMMENT --><elt/></doc>},
"comment handler (with keep_encoding)"
);
is( XML::Twig->nparse( twig_handlers => { '#COMMENT' => sub { return; } }, keep_encoding => 0, $doc)->sprint,
qq{<doc><elt/></doc>},
"comment handler returning undef comment"
);
is( XML::Twig->nparse( twig_handlers => { '#COMMENT' => sub { return ''; } }, keep_encoding => 1, $doc)->sprint,
qq{<doc><elt/></doc>},
"comment handler returning empty comment (with keep_encoding)"
);
is( XML::Twig->nparse( comments => 'process', twig_handlers => { '#COMMENT' => sub { $_->set_comment( uc( $_->comment)); } },
keep_encoding => 0, $doc)->sprint,
qq{<doc><!-- COMMENT --><elt/></doc>},
"comment handler, process mode"
);
is( XML::Twig->nparse( comments => 'process', twig_handlers => { '#COMMENT' => sub { $_->set_comment( uc( $_->comment)); } },
keep_encoding => 1, $doc)->sprint,
qq{<doc><!-- COMMENT --><elt/></doc>},
"comment handler (with keep_encoding), process mode"
);
is( XML::Twig->nparse( comments => 'process', twig_handlers => { elt => sub { $_->cut; } }, keep_encoding => 0, $doc)->sprint,
qq{<doc><!-- comment --></doc>},
"comment handler deletes comment, process mode"
);
is( XML::Twig->nparse( comments => 'process', twig_handlers => { '#COMMENT' => sub { $_->cut; } }, keep_encoding => 0, $doc)->sprint,
qq{<doc><elt/></doc>},
"comment handler deletes comment, process mode"
);
is( XML::Twig->nparse( comments => 'process', twig_handlers => { '#COMMENT' => sub { $_->set_comment( ''); } }, keep_encoding => 1, $doc)->sprint,
qq{<doc><!----><elt/></doc>},
"comment handler returning empty comment (with keep_encoding), process mode"
);
}
{ # check pi element handler in keep_encoding mode
is( XML::Twig->nparse( pi => 'process', twig_handlers => { '?t' => sub { $_->set_data( uc( $_->data)); } }, '<doc><?t data?></doc>')->sprint,
'<doc><?t DATA?></doc>', 'pi element handler');
is( XML::Twig->nparse( pi => 'process', keep_encoding => 1,twig_handlers => { '?t' => sub { $_->set_data( uc( $_->data)); } },
'<doc><?t data?></doc>')->sprint,
'<doc><?t DATA?></doc>', 'pi element handler in keep_encoding mode');
}
{ # test changes on comments before the root element
my $doc= q{<!-- comment1 --><?t pi?><!--comment2 --><doc/>};
is( XML::Twig->nparse( $doc)->sprint, $doc, 'comment after root element');
is_like( XML::Twig->nparse( pi => 'process', comments => 'process', $doc)->sprint, $doc, 'comment before root element (pi/comment => process)');
is_like( XML::Twig->nparse( pi => 'process', $doc)->sprint, $doc, 'comment before root element (pi => process)');
is_like( XML::Twig->nparse( comments => 'process', $doc)->sprint, $doc, 'comment before root element (comment => process)');
}
{ # test bug on comments after the root element RT #17064
my $doc= q{<doc/><!-- comment1 --><?t pi?><!--comment2 -->};
is( XML::Twig->nparse( $doc)->sprint, $doc, 'comment after root element');
is( XML::Twig->nparse( pi => 'process', comments => 'process', $doc)->sprint, $doc, 'comment after root element (pi/comment => process)');
is_like( XML::Twig->nparse( pi => 'process', $doc)->sprint, $doc, 'comment before root element (pi => process)');
is_like( XML::Twig->nparse( comments => 'process', $doc)->sprint, $doc, 'comment before root element (comment => process)');
}
{ # test bug on doctype declaration (RT #17044)
my $doc= qq{<!DOCTYPE doc PUBLIC "-//XMLTWIG//Test//EN" "dummy.dtd">\n<doc/>};
is( XML::Twig->nparse( $doc)->sprint, $doc, "doctype with public id");
is( XML::Twig->nparse( $doc)->sprint( Update_DTD => 1), $doc, "doctype with public id (update_DTD => 1)");
$doc= qq{<!DOCTYPE doc SYSTEM "dummy.dtd">\n<doc/>};
is( XML::Twig->nparse( $doc)->sprint, $doc, "doctype with public id");
is( XML::Twig->nparse( $doc)->sprint( updateDTD => 1) , $doc, "doctype with public id (update_DTD => 1)");
}
{ # test bug on tag names similar to internal names RT #16540
ok( XML::Twig->nparse( twig_handlers => { level => sub {} }, '<level/>'), " bug on tag names similar to internal names RT #16540");
}
{ # test parsing of an html string
if( XML::Twig::_use( 'HTML::TreeBuilder', 3.13) && XML::Twig::_use( 'HTML::Entities::Numbered'))
{
ok( XML::Twig->parse( error_context => 1, '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<html>
<head>
<link rel="stylesheet" href="/s/style.css" type="text/css">
</head>
<body>
foo<p>
bar<br>
&eacute;t&eacute;
</body>
</html>'), "parsing an html string");
}
else
{ skip( 1, "need HTML::TreeBuilder 3.13+ and HTML::Entities::Numbered for this test"); }
}
{ # testing print_to_file
my $tmp= "print_to_file.xml";
my $doc= "<doc>foo</doc>";
unlink( $tmp); # no check, it could not be there
my $t1= XML::Twig->nparse( $doc)->print_to_file( $tmp);
ok( -f $tmp, "print_to_file created document");
my $t2= XML::Twig->nparse( $tmp);
is( $t2->sprint, $t1->sprint, "generated document identical to original document");
unlink( $tmp);
my $e1= XML::Twig->parse( '<d><a>foo</a><b>bar</b></d>')->first_elt( 'b')->print_to_file( $tmp);
ok( -f $tmp, "print_to_file on elt created document");
$t2= XML::Twig->nparse( $tmp);
is( $t2->sprint, '<b>bar</b>', "generated sub-document identical to original sub-document");
unlink( $tmp);
# failure modes
eval { XML::Twig->nparse( $tmp); };
mtest( $@, "Couldn't open $tmp:");
my $non_existent="non_existent_I_hope_01/tmp";
while( -f $non_existent) { $non_existent++; } # most likely unnecessary ;--)
eval { $t1->print_to_file( $non_existent); };
mtest( $@, "cannot create file $non_existent:");
}
{
my $doc=q{<doc><elt id="elt1" att="v1" att2="v1"/><elt id="elt2" att="v1" att2="v2"/></doc>};
my $t= XML::Twig->nparse( $doc);
test_get_xpath( $t, q{/doc/elt[1][@att2="v2"]}, '');
}
{ my $doc=q{<d id="d1"><e a="1" id="e1">foo</e><e a="1" id="e2">bar</e><e a="2" id="e3">baz</e><e a="1" id="e4">foobar</e></d>};
my $t= XML::Twig->nparse( $doc);
test_get_xpath( $t, q{/d/e[@a="1"][2]}, 'e2');
test_get_xpath( $t, q{/d/e[@a="1"][-2]}, 'e2');
test_get_xpath( $t, q{/d/e[@a="1"][-1]}, 'e4');
test_get_xpath( $t, q{/d/e[@a="1"][-3]}, 'e1');
}
{ # test support for new conditions condition in get_xpath
my $doc=q{<doc id="d1" a="1"><elt id="elt1" a="2">foo</elt><elt id="elt2">bar</elt><elt id="elt3">baz</elt></doc>};
my $t= XML::Twig->nparse( $doc);
# just checking
test_get_xpath( $t, q{//elt[@a]}, 'elt1');
is( ids( $t->get_xpath( q{//*[@a]})), 'd1:elt1', '//*[@a] xpath exp');
# test support for !@att condition in get_xpath
is( ids( $t->get_xpath( q{//elt[!@a]})), 'elt2:elt3', '//elt[!@a] xpath exp');
is( ids( $t->get_xpath( q{//elt[not@a]})), 'elt2:elt3', '//elt[not@a] xpath exp');
is( ids( $t->get_xpath( q{/doc/elt[not@a]})), 'elt2:elt3', '/doc/elt[not@a] xpath exp');
is( ids( $t->get_xpath( q{//*[!@a]})), 'elt2:elt3', '//*[!@a] xpath exp');
is( ids( $t->get_xpath( q{//*[not @a]})), 'elt2:elt3', '//*[not @a] xpath exp');
is( ids( $t->get_xpath( q{/doc/*[not @a]})), 'elt2:elt3', '/doc/*[not @a] xpath exp');
# support for ( and )
test_get_xpath( $t, q{//*[@id="d1" or @a and @id="elt1"]}, 'd1:elt1');
test_get_xpath( $t, q{//*[(@id="d1" or @a) and @id="elt1"]}, 'elt1');
}
{ # more test on new XPath support: axis in node test part
my $doc=q{<doc id="d1">
<elt id="elt1"><selt id="selt1"/></elt>
<elta id="elta1"><selt id="selt2"/></elta>
<elt id="elt2"/>
<eltb id="eltb1"><seltb id="seltb1"><sseltb id="sseltb1"/></seltb></eltb>
<eltc id="eltc1"><seltb id="seltb2"><sseltb id="sseltb2"/></seltb></eltc>
</doc>};
my $t= XML::Twig->nparse( $doc);
# parent axis in node test part
test_get_xpath( $t, q{/doc//selt/..}, 'elt1:elta1');
test_get_xpath( $t, q{/doc//selt/parent::elt}, 'elt1');
test_get_xpath( $t, q{/doc//selt/parent::elta}, 'elta1');
test_get_xpath( $t, q{//sseltb/ancestor::eltc}, 'eltc1');
test_get_xpath( $t, q{//sseltb/ancestor::*}, 'd1:eltb1:seltb1:eltc1:seltb2');
test_get_xpath( $t, q{//sseltb/ancestor-or-self::eltc}, 'eltc1');
test_get_xpath( $t, q{//sseltb/ancestor-or-self::*}, 'd1:eltb1:seltb1:sseltb1:eltc1:seltb2:sseltb2');
test_get_xpath( $t, q{/doc//*[@id="eltc1"]/descendant::*}, 'seltb2:sseltb2');
test_get_xpath( $t, q{/doc//*[@id="eltc1"]/descendant::sseltb}, 'sseltb2');
test_get_xpath( $t, q{/doc//*[@id="eltc1"]/descendant::eltc}, '');
test_get_xpath( $t, q{/doc//*[@id="eltc1"]/descendant-or-self::*}, 'eltc1:seltb2:sseltb2');
test_get_xpath( $t, q{/doc//*[@id="eltc1"]/descendant-or-self::eltc}, 'eltc1');
test_get_xpath( $t, q{/doc//*[@id="eltc1"]/descendant-or-self::seltb}, 'seltb2');
test_get_xpath( $t, q{/doc/elt/following-sibling::*}, 'elta1:elt2:eltb1:eltc1');
test_get_xpath( $t, q{/doc/elt/preceding-sibling::*}, 'elt1:elta1');
test_get_xpath( $t, q{/doc/elt[@id="elt1"]/preceding-sibling::*}, '');
test_get_xpath( $t, q{/doc/elt/following-sibling::elt}, 'elt2');
test_get_xpath( $t, q{/doc/elt/preceding-sibling::elt}, 'elt1');
test_get_xpath( $t, q{/doc/elt[@id="elt1"]/preceding-sibling::elt}, '');
is( $t->elt_id( "sseltb1")->following_elt->id, 'eltc1', 'following_elt');
is( ids( $t->elt_id( "sseltb1")->following_elts), 'eltc1:seltb2:sseltb2', 'following_elts');
is( ids( $t->elt_id( "sseltb1")->following_elts( '')), 'eltc1:seltb2:sseltb2', 'following_elts( "")');
my @elts= $t->elt_id( "eltc1")->descendants_or_self;
is( ids( @elts), 'eltc1:seltb2:sseltb2', 'descendants_or_self');
is( ids( XML::Twig::_unique_elts( @elts)), 'eltc1:seltb2:sseltb2', '_unique_elts');
test_get_xpath( $t, q{/doc//[@id="sseltb1"]/following::*}, 'eltc1:seltb2:sseltb2');
test_get_xpath( $t, q{/doc//[@id="sseltb1"]/following::seltb}, 'seltb2');
test_get_xpath( $t, q{/doc//[@id="selt1"]/following::elt}, 'elt2');
ok( $t->root->last_descendant( 'doc'), "checking if last_descendant returns the element itself");
test_get_xpath( $t, q{/doc/preceding::*}, '');
test_get_xpath( $t, q{/doc/elt[1]/preceding::*}, '');
test_get_xpath( $t, q{/doc/elt/preceding::*}, 'd1:elt1:selt1:elta1:selt2');
test_get_xpath( $t, q{/doc//[@id="sseltb2"]/preceding::seltb}, 'seltb1');
test_get_xpath( $t, q{/doc//[@id="selt1"]/preceding::elt}, '');
test_get_xpath( $t, q{/doc//[@id="selt2"]/preceding::elt}, 'elt1');
test_get_xpath( $t, q{/doc/self::doc}, 'd1');
test_get_xpath( $t, q{/doc/self::*}, 'd1');
test_get_xpath( $t, q{/doc/self::elt}, '');
test_get_xpath( $t, q{//[@id="selt1"]/self::*}, 'selt1');
test_get_xpath( $t, q{//[@id="selt1"]/self::selt}, 'selt1');
test_get_xpath( $t, q{//[@id="selt1"]/self::elt}, '');
}
{ # more tests: more than 1 predicate
my $doc=q{<doc><elt id="elt1" att="v1" att2="v1"/><elt id="elt2" att="v1" att2="v2"/></doc>};
my $t= XML::Twig->nparse( $doc);
test_get_xpath( $t, q{/doc/elt[@id][@att="v1"]}, 'elt1:elt2');
test_get_xpath( $t, q{/doc/elt[@id][@att2="v1"]}, 'elt1');
test_get_xpath( $t, q{/doc/elt[@id][1]}, 'elt1');
test_get_xpath( $t, q{/doc/elt[@att="v1"][1]}, 'elt1');
test_get_xpath( $t, q{/doc/elt[@att="v2"][1]}, '');
test_get_xpath( $t, q{/doc/elt[@att="v1"][2]}, 'elt2');
test_get_xpath( $t, q{/doc/elt[1][@att2="v1"]}, 'elt1');
test_get_xpath( $t, q{/doc/elt[1][@att2="v2"]}, '');
test_get_xpath( $t, q{/doc/elt[@att2="v2"][1]}, 'elt2');
test_get_xpath( $t, q{/doc/elt[@att2="v2"][2]}, '');
test_get_xpath( $t, q{/doc/elt[@att2][1]}, 'elt1');
test_get_xpath( $t, q{/doc/elt[@att2][2]}, 'elt2');
test_get_xpath( $t, q{/doc/elt[@att2][3]}, '');
test_get_xpath( $t, q{/doc/elt[@att2][-1]}, 'elt2');
test_get_xpath( $t, q{/doc/elt[@att2][-2]}, 'elt1');
test_get_xpath( $t, q{/doc/elt[@att2][-3]}, '');
}
{ # testing creation of elements in the proper class
package foo; use base 'XML::Twig::Elt'; package main;
my $t= XML::Twig->new( elt_class => "foo")->parse( '<doc><elt/></doc>');
my $elt= $t->first_elt( 'elt');
$elt->set_text( 'bar');
is( $elt->first_child->text, 'bar', "content of element created with set_text");
is( ref( $elt->first_child), 'foo', "class of element created with set_text");
$elt->set_content( 'baz');
is( $elt->first_child->text, 'baz', "content of element created with set_content");
is( ref( $elt->first_child), 'foo', "class of element created with set_content");
$elt->insert( 'toto');
is( $elt->first_child->tag, 'toto', "tag of element created with set_content");
is( ref( $elt->first_child), 'foo', "class of element created with insert");
$elt->insert_new_elt( first_child => 'tata');
is( $elt->first_child->tag, 'tata', "tag of element created with insert_new_elt");
is( ref( $elt->first_child), 'foo', "class of element created with insert");
$elt->wrap_in( 'tutu');
is( $t->root->first_child->tag, 'tutu', "tag of element created with wrap_in");
is( ref( $t->root->first_child), 'foo', "class of element created with wrap_in");
$elt->prefix( 'titi');
is( $elt->first_child->text, 'titi', "content of element created with prefix");
is( ref( $elt->first_child), 'foo', "class of element created with prefix");
$elt->suffix( 'foobar');
is( $elt->last_child->text, 'foobar', "content of element created with suffix");
is( ref( $elt->last_child), 'foo', "class of element created with suffix");
$elt->last_child->split_at( 3);
is( $elt->last_child->text, 'bar', "content of element created with split_at");
is( ref( $elt->last_child), 'foo', "class of element created with split_at");
is( ref( $elt->copy), 'foo', "class of element created with copy");
$t= XML::Twig->new( elt_class => "foo")->parse( '<doc>toto</doc>');
$t->root->subs_text( qr{(to)} => '&elt( p => $1)');
is( $t->sprint, '<doc><p>to</p><p>to</p></doc>', "subs_text result");
my $result= join( '-', map { join( ":", ref($_), $_->tag) } $t->root->descendants);
is( $result, "foo:p-foo:#PCDATA-foo:p-foo:#PCDATA", "subs_text classes and tags");
}
{ # wrap children with > in attribute
my $doc=q{<d><e a="1" b="w"/><e a=">2" b="w"/><e b="w" a=">>" c=">"/></d>};
my $result =XML::Twig->new->parse( $doc)->root->wrap_children( '<e b="w">+', "w")->strip_att( 'id')->sprint;
my $expected = q{<d><w><e a="1" b="w"/><e a=">2" b="w"/><e a=">>" b="w" c=">"/></w></d>};
is( $result => $expected, "wrap_children with > in attributes");
$result =XML::Twig->new->parse( $doc)->root->wrap_children( '<e a="&gt;&gt;">+', "w")->strip_att( 'id')->sprint;
$expected = q{<d><e a="1" b="w"/><e a=">2" b="w"/><w><e a=">>" b="w" c=">"/></w></d>};
is( $result => $expected, "wrap_children with > in attributes, &gt; in condition");
$result =XML::Twig->new->parse( $doc)->root->wrap_children( '<e a=">>">+', "w")->strip_att( 'id')->sprint;
$expected = q{<d><e a="1" b="w"/><e a=">2" b="w"/><e a=">>" b="w" c=">"/></d>};
is( $result => $expected, "wrap_children with > in attributes un-escaped > in condition");
$result =XML::Twig->new->parse( $doc)->root->wrap_children( '<e b="w" a="1">+', "w")->strip_att( 'id')->sprint;
$expected = q{<d><w><e a="1" b="w"/></w><e a=">2" b="w"/><e a=">>" b="w" c=">"/></d>};
is( $result => $expected, "wrap_children with > in attributes, 2 atts in condition");
$result =XML::Twig->new->parse( $doc)->root->wrap_children( '<e b="N" a="1">+', "w")->strip_att( 'id')->sprint;
$expected = q{<d><e a="1" b="w"/><e a=">2" b="w"/><e a=">>" b="w" c=">"/></d>};
is( $result => $expected, "wrap_children with > in attributes, 2 atts in condition (no child matches)");
}
{ # test improvements to wrap_children
my $doc= q{<doc><elt att="&amp;">ok</elt><elt att="no">NOK</elt></doc>};
my $expected= q{<doc><w a="&amp;"><elt att="&amp;">ok</elt></w><elt att="no">NOK</elt></doc>};
my $t= XML::Twig->new->parse( $doc);
$t->root->wrap_children( '<elt att="&amp;">+', w => { a => "&" });
$t->root->strip_att( 'id');
is( $t->sprint, $expected, "wrap_children with &amp;");
}
{ # test bug on tests on attributes with a value of 0 (RT #15671)
my $t= XML::Twig->nparse( '<foo><bar id="0"/><bar id="1"/></foo>');
my $root = $t->root();
is( scalar $root->children('*[@id="1"]'), 1, 'testing @att="1"');
is( scalar $root->children('*[@id="0"]'), 1, 'testing @att="0"');
is( scalar $root->children('*[@id="0" or @id="1"]'), 2, 'testing @att="0" or');
is( scalar $root->children('*[@id="0" and @id="1"]'), 0, 'testing @att="0" and');
}
{ # test that the '>' after the doctype is properly output when there is no DTD RT#
my $doctype='<!DOCTYPE doc SYSTEM "doc.dtd">';
my $doc="$doctype<doc/>";
is_like( XML::Twig->nparse( $doc)->sprint, $doc);
is_like( XML::Twig->nparse( $doc)->doctype, $doctype);
}

59
t/test_cdata.t Executable file
View File

@ -0,0 +1,59 @@
#!/usr/bin/perl -w
use strict;
use XML::Twig;
$|=1;
$/= "\n\n";
my $xml= <DATA>;
print "1..4\n";
my( $t, $result, $expected_result);
$t= XML::Twig->new( twig_handlers => { 'ehtml/#CDATA' => sub { $_->set_asis; } });
$t->parse( $xml);
$result= $t->sprint;
($expected_result=<DATA>)=~ s{\n*$}{}s;
if( $result eq $expected_result) { print "ok 1\n"; }
else { print "not ok 1\n"; warn "expected: $expected_result\n result : $result"; }
$t= XML::Twig->new( twig_handlers => { 'ehtml/#CDATA' => sub { $_->remove_cdata; } });
$t->parse( $xml);
$result= $t->sprint;
($expected_result=<DATA>)=~ s{\n*$}{}s;
if( $result eq $expected_result) { print "ok 2\n"; }
else { print "not ok 2\n"; warn "expected: $expected_result\n result : $result"; }
$t= XML::Twig->new( keep_encoding => 1, twig_handlers => { 'ehtml/#CDATA' => sub { $_->set_asis; } });
$t->parse( $xml);
$result= $t->sprint;
($expected_result=<DATA>)=~ s{\n*$}{}s;
if( $result eq $expected_result) { print "ok 3\n"; }
else { print "not ok 3\n"; warn "test keep_encoding / asis\n expected: $expected_result\n result : $result"; }
$t= XML::Twig->new( keep_encoding => 1, twig_handlers => { 'ehtml/#CDATA' => sub { $_->remove_cdata; } });
$t->parse( $xml);
$result= $t->sprint;
($expected_result=<DATA>)=~ s{\n*$}{}s;
if( $result eq $expected_result) { print "ok 4\n"; }
else { print "not ok 4\n"; warn "test keep_encoding / remove_cdata\n expected: $expected_result\n result : $result"; }
exit 0;
__DATA__
<doc>
<elt>text</elt>
<ehtml><![CDATA[hello<br>world & all]]></ehtml>
</doc>
<doc><elt>text</elt><ehtml>hello<br>world & all</ehtml></doc>
<doc><elt>text</elt><ehtml>hello&lt;br>world &amp; all</ehtml></doc>
<doc><elt>text</elt><ehtml>hello<br>world & all</ehtml></doc>
<doc><elt>text</elt><ehtml>hello&lt;br>world &amp; all</ehtml></doc>

7
t/test_changes.t Executable file
View File

@ -0,0 +1,7 @@
#!/usr/bin/perl
use Test::More;
eval 'use Test::CPAN::Changes';
plan skip_all => 'Test::CPAN::Changes required for this test' if $@;
plan skip_all => 'Author test. Set $ENV{TEST_AUTHOR} to a true value to run.' if ! $ENV{TEST_AUTHOR};
changes_ok();

68
t/test_class_methods.t Executable file
View File

@ -0,0 +1,68 @@
#!/usr/bin/perl -w
# testing methods on class attribute:
# class set_class add_to_class att_to_class add_att_to_class move_att_to_class
# tag_to_class add_tag_to_class set_tag_class in_class
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
use XML::Twig;
my $DEBUG=0;
my $TMAX=26;
print "1..$TMAX\n";
{
my $root= XML::Twig->new->parse( q{<doc att1="val1" att2="val2"/>})->root;
nok( $root->class, "no class");
$root->set_class( 'foo');
is( $root->class, 'foo', 'set_class');
$root->set_class( 'bar');
is( $root->class, 'bar', 'set_class');
ok( $root->in_class( 'bar'), 'in_class (ok)');
nok( $root->in_class( 'foo'), 'in_class (nok)');
$root->add_to_class( 'foo');
ok( $root->in_class( 'bar'), 'in_class (ok)');
ok( $root->in_class( 'foo'), 'in_class (ok)');
nok( $root->in_class( 'baz'), 'in_class (nok)');
$root->tag_to_class;
is( $root->class, 'doc', 'tag_to__class');
ok( $root->in_class( 'doc'), 'in_class (ok)');
nok( $root->in_class( 'foo'), 'in_class (nok)');
$root->tag_to_class;
is( $root->class, 'doc', 'tag_to_class (with existing class)');
$root->add_tag_to_class;
is( $root->class, 'doc', 'add_tag_to_class');
$root->att_to_class( 'att1');
is( $root->class, 'val1', 'att_to_class');
$root->att_to_class( 'att1');
is( $root->class, 'val1', 'att_to_class (with existing class)');
$root->add_att_to_class( 'att');
is( $root->class, 'val1', 'att_to_class (non existing att)');
$root->add_att_to_class( 'att2');
is( $root->class, 'val1 val2', 'att_to_class (2 classes now)');
ok( $root->in_class( 'val1'), 'in_class');
ok( $root->in_class( 'val2'), 'in_class');
nok( $root->in_class( 'val'), 'in_class (nok)');
$root->set_tag_class( 'new');
is( $root->sprint, '<new att1="val1" att2="val2" class="doc val1 val2"/>', 'set_tag_class');
$root->move_att_to_class( 'att2');
is( $root->sprint, '<new att1="val1" class="doc val1 val2"/>', 'set_tag_class');
ok( $root->matches( '.doc'), 'match on class (first)');
ok( $root->matches( '.val1'), 'match on class (middle)');
ok( $root->matches( '.val2'), 'match on class (last)');
nok( $root->matches( '.val'), 'match on class (not good)');
}
exit 0;

65
t/test_class_selector.t Executable file
View File

@ -0,0 +1,65 @@
#!/usr/bin/perl
use strict;
use warnings;
use XML::Twig;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,'t');
use tools;
my @DATA;
while( <DATA>) { chomp; my( $cond, $expected)= split /\s*=>\s*/; push @DATA, [$cond, $expected]; }
my $TMAX= 20;
print "1..$TMAX\n";
my $doc=q{<d><e class="c1">e1</e><e class="c1 c2" a="v1">e2</e><e class="c2" a="v2">e3</e></d>};
my $doc_dot=q{<d><e class="c1">wrong e1</e><e class="c1 c2" a="v1">wrong e2</e><e class="c2" a="v2">wrong e3</e><e.c1>e1</e.c1><e.c1 a="v1">e2</e.c1><e.c2 a="v2">e3</e.c2></d>};
my $t= XML::Twig->parse( $doc);
foreach my $test (@DATA)
{ my( $cond, $expected)= @$test;
my $got= join '', map { $_->text } $t->root->children( $cond);
is( $got, $expected, "navigation: $cond" );
}
if( $] > 5.008)
{
foreach my $test (@DATA)
{ my( $cond, $expected)= @$test;
my $got='';
XML::Twig->new( twig_handlers => { $cond => sub { $got.= $_->text } },
css_sel => 1,
)
->parse( $doc);
is( $got, $expected, "handlers (css_sel enabled): $cond" );
}
foreach my $test (@DATA)
{ my( $cond, $expected)= @$test;
next if $cond !~ m{^e};
my $got='';
XML::Twig->new( twig_handlers => { $cond => sub { $got.= $_->text } },)
->parse( $doc_dot);
is( $got, $expected, "handlers (css_sel NOT enabled): $cond" );
}
}
else
{ skip( 12, 'not tested under perl < 5.8'); }
__DATA__
e.c1 => e1e2
e.c1[@a="v1"] => e2
e.c1[@a] => e2
e.c1[@a="v2"] =>
*.c1[@a="v1"] => e2
*.c1[@a="v2" or @a="v1"] => e2
.c1[@a="v1"] => e2
.c1[@a="v2" or @a="v1"] => e2

75
t/test_comment_handler.t Executable file
View File

@ -0,0 +1,75 @@
#!/usr/bin/perl -w
use strict;
use Carp;
# test for the various conditions in navigation methods
use XML::Twig;
if( $] < 5.008)
{ warn "skipped, not tested under perl < 5.8\n"; print "1..1\nok 1\n"; exit 0; }
my $nb_tests=4;
print "1..$nb_tests\n";
{
my $result;
my $t= XML::Twig->new( comments => 'process',
twig_handlers => { '#COMMENT' => sub { $result .=$_->text; } },
);
$t->parse( q{<doc id="doc"><!-- comment in doc --></doc>});
my $expected= ' comment in doc ';
if( $result eq $expected)
{ print "ok 1\n"; }
else
{ print "not ok 1\n";
warn "expected: $expected\nfound : $result\n";
}
}
{
my $result='';
my $t= XML::Twig->new( comments => 'process',
twig_handlers => { '#COMMENT' => sub { $result .=$_->text; } },
);
$t->parse( q{<!-- comment in doc --><doc id="doc"></doc>});
my $expected= ' comment in doc ';
if( $result eq $expected)
{ print "ok 2\n"; }
else
{ print "not ok 2\n";
warn "expected: $expected\nfound : $result\n";
}
}
{
my $result='';
my $t= XML::Twig->new( twig_handlers => { 'doc' => sub { $result= $_->{extra_data}; } },);
$t->parse( q{<!-- comment in doc --><doc id="doc"></doc>});
my $expected= '<!-- comment in doc -->';
if( $result eq $expected)
{ print "ok 3\n"; }
else
{ print "not ok 3\n";
warn "expected: $expected\nfound : $result\n";
}
}
{
my $result='';
my $t= XML::Twig->new( comments => 'process',
twig_roots => { '/#COMMENT' => sub { $result= $_->{extra_data}; },
elt => sub { },
});
$t->parse( q{<!-- comment in doc --><doc id="doc"><elt/></doc>});
my $expected= ''; # This is a bug!
if( $result eq $expected)
{ print "ok 4\n"; }
else
{ print "not ok 4\n";
warn "expected: $expected\nfound : $result\n";
}
}
exit 0;

42
t/test_drop_comments.t Executable file
View File

@ -0,0 +1,42 @@
#!/usr/bin/perl -w
use strict;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
use XML::Twig;
print "1..3\n";
my $xml = <<XML_TEST;
<xml_root>
<!-- some comment -->
<key>value</key>
</xml_root>
XML_TEST
{
my $twig1 = XML::Twig->new(comments => 'keep', keep_spaces => 1);
$twig1->parse($xml);
ok ($twig1->sprint() =~ /<!--.*-->/s, 'keep comments');
#print $twig1->sprint, "\n", '-'x80, "\n"; # keeps comments ok
$twig1->dispose;
}
{
my $twig2 = XML::Twig->new(comments => 'drop', keep_spaces => 1);
$twig2->parse($xml);
ok ($twig2->sprint() !~ /<!--.*-->/s, 'drop comments');
#print $twig2->sprint, "\n", '-'x80, "\n"; # drops comments ok
$twig2->dispose;
}
{
my $twig3 = XML::Twig->new(comments => 'keep', keep_spaces => 1);
$twig3->parse($xml);
ok ($twig3->sprint() =~ /<!--.*-->/s, 'keep comments');
#print $twig3->sprint, "\n", '-'x80, "\n"; # drops comments!!
$twig3->dispose;
}
exit 0;

213
t/test_entities.t Executable file
View File

@ -0,0 +1,213 @@
#!/usr/bin/perl -w
use strict;
#use diagnostics;
use XML::Twig;
$|=1;
my $TMAX=6; # do not forget to update!
print "1..$TMAX\n";
my $doc= read_data();
# test 1 : roots and twig_print_outside_roots
my $result_file= "test_entities.res1";
open( RESULT, ">$result_file") or die "cannot create $result_file: $!";
my $t= XML::Twig->new( twig_roots => { elt2 => sub { $_->print} },
twig_print_outside_roots => 1,
#load_DTD => 1,
error_context => 2,
);
select RESULT;
$t->safe_parse( $doc) or die "This error is probably due to an incompatibility between
XML::Twig and the version of libexpat that you are using\n See the README and the
XML::Twig FAQ for more information\n";;
close RESULT;
select STDOUT;
check_result( $result_file, 1);
# test 2 : roots only, test during parsing
$result_file= "test_entities.res2";
open( RESULT, ">$result_file") or die "cannot create $result_file: $!";
$t= XML::Twig->new( twig_roots => { elt2 => sub { $_->print} },
error_context => 1,
);
select RESULT;
$t->parse( $doc);
close RESULT;
select STDOUT;
check_result( $result_file, 2);
# test 3 : roots only, test parse result
$result_file= "test_entities.res3";
open( RESULT, ">$result_file") or die "cannot create $result_file: $!";
$t= XML::Twig->new( twig_roots => { elt2 => 1 },
pretty_print => 'indented',
error_context => 1,
);
$t->parse( $doc);
$t->print( \*RESULT);
close RESULT;
check_result( $result_file, 3);
# test 4 : roots and twig_print_outside_roots
$result_file= "test_entities.res4";
open( RESULT, ">$result_file") or die "cannot create $result_file: $!";
$t= XML::Twig->new( twig_roots => { elt2 => sub { $_->print} },
twig_print_outside_roots => 1,
keep_encoding => 1,
error_context => 1,
);
select RESULT;
$t->parse( $doc);
close RESULT;
select STDOUT;
check_result( $result_file, 4);
# test 5 : roots only, test during parsing
$result_file= "test_entities.res5";
open( RESULT, ">$result_file") or die "cannot create $result_file: $!";
$t= XML::Twig->new( twig_roots => { elt2 => sub { $_->print} },
keep_encoding => 1,
error_context => 1,
);
select RESULT;
$t->parse( $doc);
close RESULT;
select STDOUT;
check_result( $result_file, 5);
# test 6 : roots only, test parse result
$result_file= "test_entities.res6";
open( RESULT, ">$result_file") or die "cannot create $result_file: $!";
$t= XML::Twig->new( twig_roots => { elt2 => 1 },
pretty_print => 'indented',
keep_encoding => 1,
error_context => 1,
);
$t->parse( $doc);
$t->print( \*RESULT);
close RESULT;
check_result( $result_file, 6);
exit 0;
sub check_result
{ my( $result_file, $test_no)= @_;
# now check result
my $expected_result= read_data();
my $result= read_result( $result_file);
if( $result eq $expected_result)
{ print "ok $test_no\n"; }
else
{ print "not ok $test_no\n";
print STDERR "\ntest $test_no:\n",
"expected: \n$expected_result\n",
"real: \n$result\n";
}
}
sub read_data
{ local $/="\n\n";
my $data= <DATA>;
$data=~ s{^\s*#.*\n}{}m; # get rid of comments
$data=~ s{\s*$}{}s; # remove trailing spaces (and \n)
$data=~ s{(^|\n)\s*(\n|$)}{}g; # remove empty lines
return $data;
}
sub read_result
{ my $file= shift;
local $/="\n";
open( RESULT, "<$file") or die "cannot read $file: $!";
my @result= grep {m/\S/} <RESULT>;
my $result= join( '', @result);
$result=~ s{(^|\n)\s*(\n|$)}{}g; # remove empty lines
close RESULT;
unlink $file;
return $result;
}
__DATA__
# doc 1
<?xml version="1.0"?>
<!DOCTYPE doc SYSTEM "t/dummy.dtd">
<doc>
<elt1>toto &ent1;</elt1>
<elt2>tata &ent2;</elt2>
<elt3>tutu &ent3;</elt3>
<elt2>tutu &ent4;</elt2>
<elt3>tutu &ent5;</elt3>
</doc>
# expected_res 1
<?xml version="1.0"?>
<!DOCTYPE doc SYSTEM "t/dummy.dtd">
<doc>
<elt1>toto &ent1;</elt1>
<elt2>tata &ent2;</elt2>
<elt3>tutu &ent3;</elt3>
<elt2>tutu &ent4;</elt2>
<elt3>tutu &ent5;</elt3>
</doc>
# expected_res 2
<elt2>tata &ent2;</elt2><elt2>tutu &ent4;</elt2>
# expected_res 3
<?xml version="1.0"?>
<!DOCTYPE doc SYSTEM "t/dummy.dtd">
<doc>
<elt2>tata &ent2;</elt2>
<elt2>tutu &ent4;</elt2>
</doc>
# expected_res 4
<?xml version="1.0"?>
<!DOCTYPE doc SYSTEM "t/dummy.dtd">
<doc>
<elt1>toto &ent1;</elt1>
<elt2>tata &ent2;</elt2>
<elt3>tutu &ent3;</elt3>
<elt2>tutu &ent4;</elt2>
<elt3>tutu &ent5;</elt3>
</doc>
# expected_res 5
<elt2>tata &ent2;</elt2>
<elt2>tutu &ent4;</elt2>
# expected_res 6
<?xml version="1.0"?>
<!DOCTYPE doc SYSTEM "t/dummy.dtd">
<doc>
<elt2>tata &ent2;</elt2>
<elt2>tutu &ent4;</elt2>
</doc>

68
t/test_erase.t Executable file
View File

@ -0,0 +1,68 @@
#!/usr/bin/perl -w
use strict;
use XML::Twig;
$|=1;
my $TMAX=1; # do not forget to update!
print "1..$TMAX\n";
undef $/;
my $doc=<DATA>;
my $t= XML::Twig->new(keep_spaces => 1);
$t->parse( $doc);
foreach my $erase ($t->descendants( 'erase'))
{ $erase->erase; }
my $result=$t->sprint;
$result=~ s{\s*$}{}s; # remove trailing spaces (and \n)
my $expected_result= $doc;
$expected_result=~ s{</?erase/?>}{}g;
$expected_result=~ s{\s*$}{}s; # remove trailing spaces (and \n)
if( $result eq $expected_result)
{ print "ok 1\n"; }
else
{ print "not ok 1\n";
print STDERR "expected: \n$expected_result\n",
"real: \n$result\n";
}
exit 0;
__DATA__
<doc>
<!-- erase an empty element -->
<test1>
<elt><erase/></elt>
<elt>text <erase/></elt>
<elt><erase/> text (1)</elt>
<elt>text <erase/> text (2)</elt>
<elt><child/><erase/><child/></elt>
<elt><erase/><child/></elt>
<elt><child/><erase/></elt>
</test1>
<!-- erase an element with 1 text child -->
<test2>
<elt><erase>text (3)</erase></elt>
<elt>text <erase>text (4)</erase></elt>
<elt><erase>text (5)</erase> text (6)</elt>
<elt>text (7)<erase>text (8)</erase> text (9)</elt>
<elt><child/><erase>text (10)</erase><child/></elt>
<elt><erase>text (11)</erase><child/></elt>
<elt><child/><erase>text</erase></elt>
</test2>
<!-- erase an element with several children -->
<test3>
<elt><erase><child>text (12)</child><child/></erase></elt>
<elt>text (13)<erase><child>text (14)</child><child/></erase></elt>
<elt><erase><child>text (15)</child><child/></erase> text (16)</elt>
<elt>text (17)<erase><child>text (18)</child><child/></erase> text (19)</elt>
<elt><child/><erase><child>text (20)</child><child/></erase>child/></elt>
<elt><erase><child>text (21)</child><child/></erase>child/></elt>
<elt><child/><erase><child>text (22)</child><child/></erase></elt>
</test3>
</doc>

23
t/test_error_with_unicode_layer Executable file
View File

@ -0,0 +1,23 @@
use XML::Twig;
use strict;
use Config;
my( $infile)= @ARGV;
my $perl= used_perl();
open( FH, "$perl -p -e1 $infile |") or die $!;
XML::Twig->nparse( \*FH);
die "OK\n";
sub used_perl
{ my $perl;
if( $^O eq 'VMS') { $perl= $Config{perlpath}; } # apparently $^X does not work on VMS
else { $perl= $^X; } # but $Config{perlpath} does not work in 5.005
if ($^O ne 'VMS' && $Config{_exe} && $perl !~ m{$Config{_exe}$}i) { $perl .= $Config{_exe}; }
$perl .= " -Iblib/lib";
if( $ENV{TEST_COVER}) { $perl .= " -MDevel::Cover"; }
return $perl;
}

354
t/test_errors.t Executable file
View File

@ -0,0 +1,354 @@
#!/usr/bin/perl -w
# test error conditions
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use Config;
use tools;
#$|=1;
use XML::Twig;
my $TMAX=121;
print "1..$TMAX\n";
my $error_file= File::Spec->catfile('t','test_errors.errors');
my( $q, $q2) = ( ($^O eq "MSWin32") || ($^O eq 'VMS') ) ? ('"', "'") : ("'", '"');
{ # test insufficient version of XML::Parser (not that easy, it is already too late here)
my $need_version= 2.23;
use Config;
my $perl= used_perl();
my $version= $need_version - 0.01;
unlink $error_file if -f $error_file;
if ($^O eq 'VMS') {
system( qq{$perl $q-Mblib$q -e$q use vmsish qw(hushed);use XML::Parser; BEGIN { \$XML::Parser::VERSION=$version}; use XML::Twig $q 2> $error_file});
} else {
system( qq{$perl $q-Iblib/lib$q -e$q use XML::Parser; BEGIN { \$XML::Parser::VERSION=$version}; use XML::Twig $q 2> $error_file});
}
ok( -f $error_file, "error generated for low version of XML::Parser");
matches( slurp_error( $error_file), "need at least XML::Parser version ", "error message for low version of XML::Parser");
$version= $need_version;
unlink $error_file if -f $error_file;
system( qq{$perl $q-Mblib$q -e$q use XML::Parser; BEGIN { \$XML::Parser::VERSION=$version}; use XML::Twig $q 2> $error_file});
ok( ! -f $error_file || slurp_error( $error_file)!~ "need at least XML::Parser version",
"no error generated for proper version of XML::Parser"
);
$version= $need_version + 0.01;
unlink $error_file if -f $error_file;
system( qq{$^X -e$q use XML::Parser; BEGIN { \$XML::Parser::VERSION=$version}; use XML::Twig$q 2> $error_file});
ok( ! -f $error_file || slurp_error( $error_file)!~ "need at least XML::Parser version",
"no error generated for high version of XML::Parser"
);
unlink $error_file if -f $error_file;
}
my $warning;
my $init_warn= $SIG{__WARN__};
{ $SIG{__WARN__}= sub { $warning= join '', @_; };
XML::Twig->new( dummy => 1);
$SIG{__WARN__}= $init_warn;
matches( $warning, "invalid option Dummy", "invalid option");
}
{ eval { XML::Twig::_slurp( $error_file) };
matches( $@, "cannot open '\Q$error_file\E'", "_slurp inexisting file");
}
{ eval {XML::Twig->new->parse( '<doc/>')->root->first_child( 'du,')};
matches( $@, "wrong navigation condition", "invalid navigation expression");
}
{ eval {XML::Twig->new->parse( '<doc/>')->root->first_child( '@val=~/[/')};
matches( $@, "wrong navigation condition", "invalid navigation expression");
}
{ eval {XML::Twig->new( twig_print_outside_roots => 1)};
matches( $@, "cannot use twig_print_outside_roots without twig_roots", "invalid option");
}
{ eval {XML::Twig->new( keep_spaces => 1, discard_spaces => 1 )};
matches( $@, "cannot use both keep_spaces and discard_spaces", "invalid option combination keep_spaces and discard_spaces");
eval {XML::Twig->new( keep_spaces => 1, discard_all_spaces => 1 )};
matches( $@, "cannot use both keep_spaces and discard_all_spaces", "invalid option combination keep_spaces and discard_all_spaces");
eval {XML::Twig->new( keep_spaces => 1, keep_spaces_in => ['p'])};
matches( $@, "cannot use both keep_spaces and keep_spaces_in", "invalid option combination keep_spaces and keep_spaces_in");
eval {XML::Twig->new( discard_spaces => 1, discard_all_spaces => 1)};
matches( $@, "cannot use both discard_spaces and discard_all_spaces", "invalid option combination discard_spaces and discard_all_spaces");
eval {XML::Twig->new( discard_spaces => 1, keep_spaces_in => ['p'])};
matches( $@, "cannot use both discard_spaces and keep_spaces_in", "invalid option combination discard_spaces and keep_spaces_in");
eval {XML::Twig->new( keep_spaces_in => [ 'doc' ], discard_spaces_in => ['p'])};
matches( $@, "cannot use both keep_spaces_in and discard_spaces_in", "invalid option combination keep_spaces_in and discard_spaces_in");
eval {XML::Twig->new( discard_spaces => 1, discard_spaces_in => ['p'])};
matches( $@, "cannot use both discard_spaces and discard_spaces_in", "invalid option combination discard_spaces and discard_spaces_in");
eval {XML::Twig->new( keep_spaces_in => [ 'doc' ], discard_all_spaces => 1)};
matches( $@, "cannot use both keep_spaces_in and discard_all_spaces", "invalid option combination keep_spaces_in and discard_all_spaces");
eval {XML::Twig->new( discard_all_spaces => 1, discard_spaces_in => ['p'])};
matches( $@, "cannot use both discard_all_spaces and discard_spaces_in", "invalid option combination discard_all_spaces and discard_spaces_in");
eval {XML::Twig->new( comments => 'wrong') };
matches( $@, "wrong value for comments argument: 'wrong'", "invalid option value for comment");
eval {XML::Twig->new( pi => 'wrong') };
matches( $@, "wrong value for pi argument: 'wrong'", "invalid option value for pi");
}
{ my $t=XML::Twig->new->parse( '<doc><p> p1</p><p>p 2</p></doc>');
my $elt= $t->root;
eval { $elt->sort_children( sub { }, type => 'wrong'); };
matches( $@, "wrong sort type 'wrong', should be either 'alpha' or 'numeric'", "sort type");
}
{
foreach my $wrong_path ( 'wrong path', 'wrong##path', '1', '1tag', '///tag', 'tag/')
{ eval {XML::Twig->new( twig_handlers => { $wrong_path => sub {}});};
matches( $@, "unrecognized expression in handler: '$wrong_path'", "wrong handler ($wrong_path)");
}
eval {XML::Twig->new( input_filter => 'dummy')};
matches( $@, "invalid input filter:", "input filter");
eval {XML::Twig->new( input_filter => {})};
matches( $@, "invalid input filter:", "input filter");
}
{ foreach my $bad_tag ( 'toto', '<1toto', '<foo:bar:baz', '< foo::bar', '<_toto', '<-toto', '<totoatt=', '<#toto', '<toto')
{ eval {XML::Twig::_parse_start_tag( qq{$bad_tag})};
matches( $@, "error parsing tag '$bad_tag'", "bad tag '$bad_tag'");
eval {XML::Twig::Elt::_match_expr( qq{$bad_tag})};
matches( $@, "error parsing tag '$bad_tag'", "bad tag '$bad_tag'");
}
}
{ my $t= XML::Twig->new( twig_handlers => { sax => sub { $_[0]->toSAX1 } });
eval {$t->parse( '<doc><sax/></doc>')};
matches( $@, "cannot use toSAX1 while parsing", "toSAX1 during parsing");
}
{ my $t= XML::Twig->new( twig_handlers => { sax => sub { $_[0]->toSAX2 } });
eval {$t->parse( '<doc><sax/></doc>')};
matches( $@, "cannot use toSAX2 while parsing", "toSAX2 during parsing");
}
{ my $t= XML::Twig->new->parse( '<doc/>');
foreach my $bad_cond ( 'foo bar', 'foo:bar:baz', '.', '..', '...', '**', 'con[@to:ta:ti]')
{ eval { $t->root->first_child( qq{$bad_cond})};
matches( $@, "wrong navigation condition '\Q$bad_cond\E'", "bad navigation condition '$bad_cond'");
}
}
{ my $t= XML::Twig->new->parse( '<doc/>');
eval { XML::Twig->parse( twig_handlers => { q{foo[@a="$sd"]} => sub { } }, "<foo/>"); };
matches( $@, "^wrong handler condition", 'perl syntax in attribute value');
}
{ my $t= XML::Twig->new->parse( '<doc><field/></doc>');
eval { $t->root->set_field( '*[2]'); };
matches( $@, "can't create a field name from", 'set_field');
}
{ my $t= XML::Twig->new( twig_handlers => { erase => sub { $_->parent->erase } });
eval { $t->parse( '<doc><p><erase>toto</erase></p></doc>'); };
matches( $@, "trying to erase an element before it has been completely parsed", 'erase current element');
}
{ my $t= XML::Twig->new->parse( '<doc><erase><e1/><e2/></erase></doc>');
my $e= $t->first_elt( 'erase')->cut;
eval { $e->erase };
matches( $@, "can only erase an element with no parent if it has a single child", 'erase cut element');
$e->paste( $t->root);
eval { $e->paste( first_child => $t->root); };
matches( $@, "cannot paste an element that belongs to a tree", 'paste uncut element');
$e->cut;
eval { $e->paste( $t->root => 'first_child' ); };
matches( $@, "wrong argument order in paste, should be", 'paste uncut element');
eval { $e->paste( first_child => {} ); };
matches( $@, "wrong target type in paste: 'HASH', should be XML::Twig::Elt", 'paste with wrong ref');
eval { $e->paste( 'first_child' ); };
matches( $@, "missing target in paste", 'paste with no target');
eval { $e->paste( 'first_child', 1 ); };
matches( $@, 'wrong target type in paste \(not a reference\)', 'paste with no ref');
eval { $e->paste( 'first_child', bless( {}, 'foo') ); };
matches( $@, "wrong target type in paste: 'foo'", 'paste with wrong object type');
eval { $e->paste( wrong => $t->root ); };
matches( $@, "tried to paste in wrong position 'wrong'", 'paste in wrong position');
eval { $e->paste( before => $t->root); };
matches( $@, "cannot paste before root", 'paste before root');
eval { $e->paste( after => $t->root); };
matches( $@, "cannot paste after root", 'paste after root');
eval { $e->paste_before( $t->root); };
matches( $@, "cannot paste before root", 'paste before root');
eval { $e->paste_after( $t->root); };
matches( $@, "cannot paste after root", 'paste after root');
}
{ my $t= XML::Twig->new->parse( '<doc><p>text1</p><p>text2</p></doc>');
my $p1= $t->root->first_child( 'p');
my $p2= $t->root->first_child( 'p[2]');
eval { $p1->merge_text( 'toto'); } ;
matches( $@, "invalid merge: can only merge 2 elements", 'merge elt and string');
eval { $p1->merge_text( $p2); } ;
matches( $@, "invalid merge: can only merge 2 text elements", 'merge non text elts');
$p1->first_child->merge_text( $p2->first_child);
is( $t->sprint, '<doc><p>text1text2</p><p></p></doc>', 'merge_text');
my $p3= XML::Twig::Elt->new( '#CDATA' => 'foo');
eval { $p1->first_child->merge_text( $p3); };
matches( $@, "invalid merge: can only merge 2 text elements", 'merge cdata and pcdata elts');
}
{ my $t= XML::Twig->new;
$t->save_global_state;
eval { $t->set_pretty_print( 'foo'); };
matches( $@, "invalid pretty print style 'foo'", 'invalid pretty_print style');
eval { $t->set_pretty_print( 987); };
matches( $@, "invalid pretty print style 987", 'invalid pretty_print style');
eval { $t->set_empty_tag_style( 'foo'); };
matches( $@, "invalid empty tag style 'foo'", 'invalid empty_tag style');
eval { $t->set_empty_tag_style( '987'); };
matches( $@, "invalid empty tag style 987", 'invalid empty_tag style');
eval { $t->set_quote( 'foo'); };
matches( $@, "invalid quote 'foo'", 'invalid quote style');
eval { $t->set_output_filter( 'foo'); };
matches( $@, "invalid output filter 'foo'", 'invalid output filter style');
eval { $t->set_output_text_filter( 'foo'); };
matches( $@, "invalid output text filter 'foo'", 'invalid output text filter style');
}
{ my $t= XML::Twig->new->parse( '<doc/>');
my @methods= qw( depth in_element within_element context current_line current_column current_byte
recognized_string original_string xpcroak xpcarp xml_escape base current_element
element_index position_in_context
);
my $method;
foreach $method ( @methods)
{ eval "\$t->$method";
matches( $@, "calling $method after parsing is finished", $method);
}
$SIG{__WARN__}= $init_warn;
}
{ my $t= XML::Twig->new->parse( '<doc><elt/></doc>');
my $elt= $t->root->first_child( 'elt')->cut;
foreach my $pos ( qw( before after))
{ eval { $elt->paste( $pos => $t->root); };
matches( $@, "cannot paste $pos root", "paste( $pos => root)");
}
}
{ my $t= XML::Twig->new->parse( '<doc><a><f1>f1</f1><f2>f2</f2></a></doc>');
eval { $t->root->simplify( group_tags => { a => 'f1' }); };
matches( $@, "error in grouped tag a", "grouped tag error f1");
eval { $t->root->simplify( group_tags => { a => 'f2' }); };
matches( $@, "error in grouped tag a", "grouped tag error f2");
eval { $t->root->simplify( group_tags => { a => 'f3' }); };
matches( $@, "error in grouped tag a", "grouped tag error f3");
}
{ eval { XML::Twig::Elt->parse( '<e>foo</e>')->subs_text( "foo", '&elt( 0/0)'); };
matches( $@, "(invalid replacement expression |Illegal division by zero)", "invalid replacement expression in subs_text");
}
{ eval { my $t=XML::Twig->new( twig_handlers => { e => sub { $_[0]->parse( "<doc/>") } });
$t->parse( "<d><e/></d>");
};
matches( $@, "cannot reuse a twig that is already parsing", "error re-using a twig during parsing");
}
{ ok( XML::Twig->new( twig_handlers => { 'elt[string()="foo"]' => sub {}} ), 'twig_handlers with string condition' );
eval { XML::Twig->new( twig_roots => { 'elt[string()="foo"]' => sub {}} ) };
matches( $@, "string.. condition not supported on twig_roots option", 'twig_roots with string condition' );
ok( XML::Twig->new( twig_handlers => { 'elt[string()=~ /foo/]' => sub {}} ), 'twig_handlers with regexp' );
eval { XML::Twig->new( twig_roots => { 'elt[string()=~ /foo/]' => sub {}} ) };
matches( $@, "string.. condition not supported on twig_roots option", 'twig_roots with regexp condition' );
#ok( XML::Twig->new( twig_handlers => { 'elt[string()!="foo"]' => sub {}} ), 'twig_handlers with !string condition' );
#eval { XML::Twig->new( twig_roots => { 'elt[string()!="foo"]' => sub {}} ) };
#matches( $@, "string.. condition not supported on twig_roots option", 'twig_roots with !string condition' );
#ok( XML::Twig->new( twig_handlers => { 'elt[string()!~ /foo/]' => sub {}} ), 'twig_handlers with !regexp' );
#eval { XML::Twig->new( twig_roots => { 'elt[string()!~ /foo/]' => sub {}} ) };
#matches( $@, "regexp condition not supported on twig_roots option", 'twig_roots with !regexp condition' );
}
{ XML::Twig::_disallow_use( "XML::Parser");
nok( XML::Twig::_use( "XML::Parser"), '_use XML::Parser (disallowed)');
XML::Twig::_allow_use( "XML::Parser");
ok( XML::Twig::_use( "XML::Parser"), '_use XML::Parser (allowed)');
ok( XML::Twig::_use( "XML::Parser"), '_use XML::Parser (allowed, 2cd try)');
nok( XML::Twig::_use( "XML::Parser::foo::nonexistent"), '_use XML::Parser::foo::nonexistent');
}
{ XML::Twig::_disallow_use( "Tie::IxHash");
eval { XML::Twig->new( keep_atts_order => 1); };
matches( $@, "Tie::IxHash not available, option keep_atts_order not allowed", 'no Tie::IxHash' );
}
{ eval { XML::Twig::_first_n { $_ } 0, 1, 2, 3; };
matches( $@, "illegal position number 0", 'null argument to _first_n' );
}
{ if( ( $] <= 5.008) || ($^O eq 'VMS') )
{ skip(1, 'test perl -CSDAL'); }
elsif( ! can_check_for_pipes() )
{ skip( 1, 'your perl cannot check for pipes'); }
else
{
my $infile= File::Spec->catfile('t','test_new_features_3_22.xml');
my $script= File::Spec->catfile('t','test_error_with_unicode_layer');
my $error=File::Spec->catfile('t','error.log');
my $perl = used_perl();
my $cmd= qq{$perl $q-CSDAL$q $script $infile 2>$error};
system $cmd;
matches( slurp( $error), "cannot parse the output of a pipe", 'parse a pipe with perlIO layer set to UTF8 (RT #17500)');
}
}
{ my $e1= XML::Twig::Elt->new( 'foo');
my $e2= XML::Twig::Elt->new( 'foo');
eval { $e1->paste_before( $e2); };
matches( $@, "cannot paste before an orphan element", 'paste before an orphan element' );
eval { $e1->paste_after( $e2); };
matches( $@, "cannot paste after an orphan element", 'paste after an orphan element' );
}
{ my $r= XML::Twig->parse( '<doc/>')->root;
eval { $r->find_nodes( '//foo/1following::') };
matches( $@, "error in xpath expression", 'error in xpath expression //foo/following::');
}
# tests for https://rt.cpan.org/Public/Bug/Display.html?id=97461 (wrong error message due to filehandle seen as a file)
{ eval { XML::Twig->new->parse( do { open( my $fh, '<', $0); $fh}); };
not_matches( $@, "you seem to have used the parse method on a filename", "parse on a filehandle containing invalid XML");
open FOO, "<$0";
eval { XML::Twig->new->parse( \*FOO); };
not_matches( $@, "you seem to have used the parse method on a filename", "parse on a GLOBAL filehandle containing invalid XML");
}
exit 0;
sub can_check_for_pipes
{ my $perl = used_perl();
open( FH, qq{$perl -e$q print 1$q |}) or die "error opening pipe: $!";
return -p FH;
}

25
t/test_even_more_coverage.t Executable file
View File

@ -0,0 +1,25 @@
#!/usr/bin/perl -w
# test designed to improve coverage of the module
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
#$|=1;
my $DEBUG=0;
use XML::Twig;
my $TMAX=1;
print "1..$TMAX\n";
{ my $t= XML::Twig->new( parse_start_tag => sub { return 'a'; })->parse( '<b>c</b>');
is( $t->sprint, '<a>c</a>', "dummy parse_start_tag");
}
exit 0;

5
t/test_expand_external_entities.dtd Normal file
View File

@ -0,0 +1,5 @@
<!ELEMENT doc (p*)>
<!ELEMENT p (#PCDATA)>
<!ENTITY ent1 "ent1 text">
<!ENTITY ent2 "<p>ent2 text</p>">

56
t/test_expand_external_entities.t Executable file
View File

@ -0,0 +1,56 @@
#!/usr/bin/perl -w
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
$|=1;
use XML::Twig;
my $TMAX=3;
print "1..$TMAX\n";
my $xml_file= File::Spec->catfile( "t", "test_expand_external_entities.xml");
my $dtd_file= File::Spec->catfile( "t", "test_expand_external_entities.dtd");
my( $xml, $dtd, $xml_expanded, %ent);
{ local undef $/;
open XML, "<$xml_file" or die "cannot open $xml_file: $!";
$xml= <XML>;
close XML;
open DTD, "<$dtd_file" or die "cannot open $dtd_file: $!";
$dtd= <DTD>;
close DTD;
}
# extract entities
while( $dtd=~ m{<!ENTITY \s+ (\w+) \s+ "([^"]*)" \s* >}gx) { $ent{$1}= $2; } #"
# replace in xml
($xml_expanded= $xml)=~ s{&(\w+);}{$ent{$1}}g;
{
my $t= XML::Twig->new( load_DTD => 1);
$t->set_expand_external_entities;
$t->parsefile( $xml_file);
is( normalize_xml( $t->sprint), normalize_xml( $xml_expanded), "expanded document");
}
{
my $t= XML::Twig->new( load_DTD => 1, expand_external_ents => 1);
$t->parsefile( $xml_file);
is( normalize_xml( $t->sprint), normalize_xml( $xml_expanded), "expanded document");
}
{
(my $xml_no_dtd= $xml_expanded)=~ s{^<!DOCTYPE.*?>}{}s;
my $t= XML::Twig->new( load_DTD => 1, expand_external_ents => 1, do_not_output_DTD => 1);
$t->parsefile( $xml_file);
is( normalize_xml( $t->sprint), normalize_xml( $xml_no_dtd), "expanded document");
}
exit 0;

2
t/test_expand_external_entities.xml Normal file
View File

@ -0,0 +1,2 @@
<!DOCTYPE doc SYSTEM "t/test_expand_external_entities.dtd">
<doc><p>&ent1;</p>&ent2;<p>more &ent1;</p></doc>

116
t/test_ignore_elts.t Executable file
View File

@ -0,0 +1,116 @@
#!/usr/bin/perl -w
use strict;
use XML::Twig;
$|=1;
my $TMAX=1; # do not forget to update!
print "1..$TMAX\n";
my $doc= read_data();
my $t= XML::Twig->new( ignore_elts => { ignore => 1 },
keep_spaces => 1,
);
my $result_file= "test_ignore_elt.res1";
open( RESULT, ">$result_file") or die "cannot create $result_file: $!";
select RESULT;
$t->parse( $doc);
$t->print;
select STDOUT;
close RESULT;
check_result( $result_file, 1);
exit 0;
# Not yet implemented
# test 2
$doc= read_data();
$t= XML::Twig->new( ignore_elts => { ignore => 'print' },
twig_handlers => { elt => sub { $_->print; } },
keep_spaces => 1,
);
$result_file= "test_ignore_elt.res2";
open( RESULT, ">$result_file") or die "cannot create $result_file: $!";
select RESULT;
$t->parse( $doc);
$t->print;
select STDOUT;
close RESULT;
check_result( $result_file, 2);
sub read_data
{ local $/="\n\n";
my $data= <DATA>;
$data=~ s{^\s*#.*\n}{}m; # get rid of comments
$data=~ s{\s*$}{}s; # remove trailing spaces (and \n)
$data=~ s{(^|\n)\s*(\n|$)}{}g; # remove empty lines
return $data;
};
sub check_result
{ my( $result_file, $test_no)= @_;
# now check result
my $expected_result= read_data();
my $result= read_result( $result_file);
if( $result eq $expected_result)
{ print "ok $test_no\n"; }
else
{ print "not ok $test_no\n";
print STDERR "\ntest $test_no:\n",
"expected: \n$expected_result\n",
"real: \n$result\n";
}
}
sub read_result
{ my $file= shift;
local $/="\n";
open( RESULT, "<$file") or die "cannot read $file: $!";
my @result= grep {m/\S/} <RESULT>;
close RESULT;
unlink $file;
return join '', @result;
}
__DATA__
# doc 1
<doc>
<ignore>text<child ok="no"/></ignore>
<elt>
<child ok="yes"/>
<ignore>text<child ok="no"/></ignore>
</elt>
</doc>
# expected result 1
<doc>
<elt>
<child ok="yes"/>
</elt>
</doc>
#doc 2
<doc>
<ignore>text<child ok="no"/></ignore>
<elt>
<child ok="yes"/>
</elt>
<ignore>text<child ok="no"/></ignore>
</doc>
# expected result 2
<ignore att="val">text<child ok="no"/></ignore>
<elt>
<child ok="yes"/>
</elt>
<ignore>text<child ok="no"/></ignore>

86
t/test_keep_atts_order.t Executable file
View File

@ -0,0 +1,86 @@
#!/usr/bin/perl -w
use strict;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
use XML::Twig;
{
if( eval 'require Tie::IxHash')
{ import Tie::IxHash;
print "1..7\n";
}
else
{ warn( "Tie::IxHash not available, option keep_atts_order not allowed\n");
print "1..1\nok 1\n";
exit 0;
}
my $nb_elt=10;
my $doc= gen_doc( $nb_elt);
my $result= XML::Twig->new( pretty_print => 'indented')->parse( $doc)->sprint;
isnt( $result, $doc, "keep_atts_order => 0 (first try)");
$result= XML::Twig->new( keep_atts_order => 1, pretty_print => 'indented')->parse( $doc)->sprint;
is( $result, $doc, "keep_atts_order => 1 (first try)");
$result= XML::Twig->new( pretty_print => 'indented')->parse( $doc)->sprint;
isnt( $result, $doc, "keep_atts_order => 0 (second try)");
$result= XML::Twig->new( keep_atts_order => 1, pretty_print => 'indented')->parse( $doc)->sprint;
is( $result, $doc, "keep_atts_order => 1 (second try)");
$result= XML::Twig->new( keep_atts_order => 1, keep_encoding => 1, pretty_print => 'indented')
->parse( $doc)->sprint;
is( $result, $doc, "keep_atts_order => 1, keep_encoding => 1 (first time)");
$result= XML::Twig->new( keep_encoding => 1, pretty_print => 'indented');
$result= XML::Twig->new( keep_atts_order => 1, keep_encoding => 1, pretty_print => 'indented')
->parse( $doc)->sprint;
is( $result, $doc, "keep_atts_order => 1, keep_encoding => 1 (second time)");
$result= XML::Twig->new( keep_encoding => 1, pretty_print => 'indented')
->parse( $doc)->sprint;
isnt( $result, $doc, " keep_encoding => 1 (second time)");
};
exit 0;
sub gen_doc
{ my( $nb_elt)= @_;
my $doc= "<doc>\n";
foreach (1..$nb_elt)
{ $doc .= " <elt";
my @atts= randomize( 'a'..'e');
my %atts;
tie %atts, 'Tie::IxHash';
%atts= map { $atts[$_] => $_ + 1 } (0..4) ;
while( my( $att, $value)= each %atts)
{ $doc .= qq{ $att="$value"}; }
$doc .= "/>\n";
}
$doc .= "</doc>\n";
return $doc;
}
sub randomize
{ my @list= @_;
my $n= @list;
foreach (1..10)
{ my $i= int rand( $n);
my $j= int rand( $n);
($list[$i], $list[$j])=($list[$j], $list[$i])
}
return @list;
}

13
t/test_kwalitee.t Executable file
View File

@ -0,0 +1,13 @@
#!/usr/bin/perl
use strict;
use warnings;
if( ! $ENV{TEST_AUTHOR} ) { print "1..1\nok 1\n"; warn "Author test. Set \$ENV{TEST_AUTHOR} to a true value to run.\n"; exit; }
eval { require Test::More; Test::More->import(); };
if( $@) { print "1..1\nok 1\n"; warn "need test::More installed for this test\n"; exit; }
eval { require Test::Kwalitee; Test::Kwalitee->import() };
plan( skip_all => 'Test::Kwalitee not installed; skipping' ) if $@;

64
t/test_mark.t Executable file
View File

@ -0,0 +1,64 @@
#!/usr/bin/perl -w
# test the mark method
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
#$|=1;
my $DEBUG=0;
use XML::Twig;
my $perl= $];
my @data= map { chomp; [split /\t+/] } <DATA>;
my $TMAX= 2 * @data;
print "1..$TMAX\n";
foreach my $test (@data)
{ my( $doc, $regexp, $elts, $hits, $result)= @$test;
(my $quoted_elts= $elts)=~ s{(\w+)}{'$1'}g;
my @elts= eval( "($quoted_elts)");
my $t= XML::Twig->new->parse( $doc);
my $root= $t->root;
my @hits= $root->mark( $regexp, @elts);
is( $t->sprint, $result, "mark( /$regexp/, $quoted_elts) on $doc");
is( scalar @hits, $hits, 'nb hits');
}
exit 0;
# doc regexp elts hits result
__DATA__
<doc>text X</doc> (X) s 1 <doc>text <s>X</s></doc>
<doc>text X </doc> X s 1 <doc>text <s/> </doc>
<doc>text</doc> X s 0 <doc>text</doc>
<doc>text</doc> (X) s 0 <doc>text</doc>
<doc>text X</doc> X s 1 <doc>text <s/></doc>
<doc>text X</doc> (X) s 1 <doc>text <s>X</s></doc>
<doc>text X </doc> \s*X\s* s 1 <doc>text<s/></doc>
<doc>text X </doc> \s*(X)\s* s 1 <doc>text<s>X</s></doc>
<doc>text X </doc> (\s*X\s*) s 1 <doc>text<s> X </s></doc>
<doc>text X text</doc> X s 1 <doc>text <s/> text</doc>
<doc>text X text</doc> (X) s 1 <doc>text <s>X</s> text</doc>
<doc>text X text</doc> \s*X\s* s 1 <doc>text<s/>text</doc>
<doc>text X text</doc> \s*(X)\s* s 1 <doc>text<s>X</s>text</doc>
<doc>text X text</doc> (\s*X\s*) s 1 <doc>text<s> X </s>text</doc>
<doc>text XX </doc> X s 2 <doc>text <s/><s/> </doc>
<doc>text XX</doc> (X) s 2 <doc>text <s>X</s><s>X</s></doc>
<doc>text X X </doc> X s 2 <doc>text <s/> <s/> </doc>
<doc>text X X</doc> (X) s 2 <doc>text <s>X</s> <s>X</s></doc>
<doc>text XX text</doc> X s 2 <doc>text <s/><s/> text</doc>
<doc>text XX text</doc> (X) s 2 <doc>text <s>X</s><s>X</s> text</doc>
<doc>text XY text Y text X</doc> ([XY]+) s 3 <doc>text <s>XY</s> text <s>Y</s> text <s>X</s></doc>
<doc>text X</doc> X s, {a => 1} 1 <doc>text <s a="1"/></doc>
<doc>text X</doc> (X) s, {a => 1, b => 2} 1 <doc>text <s a="1" b="2">X</s></doc>
<doc>text X1Y2 text X0 Y0X3Y4 text X</doc> X(\d)Y(\d) s 4 <doc>text <s>1</s><s>2</s> text X0 Y0<s>3</s><s>4</s> text X</doc>

161
t/test_memory.t Executable file
View File

@ -0,0 +1,161 @@
#!/usr/bin/perl -w
use strict;
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
$|=1;
my $DEBUG=0;
use XML::Twig;
# only display warnings, test is too unreliable (especially under Devel::Cover) to trust
my $mem_size= mem_size();
unless( $mem_size)
{ print "1..1\nok 1\n";
warn "skipping: memory size not available\n";;
exit;
}
if( !XML::Twig::_weakrefs())
{ print "1..1\nok 1\n";
warn "skipping: weaken not available\n";;
exit;
}
my $long_test= $ARGV[0] && $ARGV[0] eq '-L';
my $conf= $long_test ? { iter => 10, p => 1000 }
: { iter => 5, p => 500 }
;
$conf->{normal}= $conf->{p} * $conf->{iter};
$conf->{normal_html}= $conf->{normal} * 2;
my $TMAX=6;
print "1..$TMAX\n";
my $warn=0;
my $paras= join '', map { qq{<p>lorem ipsus whatever <i id="i$_">(clever latin stuff) no $_</i></p>}} 1..$conf->{p};
my $test_nb=1;
foreach my $wr (0..1)
{
# first pass if with weakrefs, second without
my $wrm='';
if( $wr)
{ XML::Twig::_set_weakrefs( 0);
$wrm= " (no weak references, disregard unless running with a _really_ old perl, like pre 5.8)";
}
{ my $xml= qq{<doc>$paras</doc>};
XML::Twig->new->parse( $xml);
my $before= mem_size();
for (1..$conf->{iter})
{ my $t= XML::Twig->new->parse( $xml);
if( $wr)
{ really_clear( $t) }
}
my $after= mem_size();
if( $after - $before > $conf->{normal})
{ warn "test $test_nb: possible memory leak parsing xml ($after > $before)$wrm"; $warn++; }
elsif( $long_test)
{ warn "$before => $after\n"; }
ok(1, "testing memory leaks for xml parsing$wrm");
$test_nb++;
}
{ if( XML::Twig::_use( 'HTML::TreeBuilder', 3.13))
{ my $html= qq{<html><head><title>with HTB</title></head><body>$paras</body></html>};
XML::Twig->new->parse_html( $html);
my $before= mem_size();
for (1..$conf->{iter}) { XML::Twig->new->parse_html( $html); }
my $after= mem_size();
if( $after - $before > $conf->{normal_html})
{ warn "test $test_nb: possible memory leak parsing html ($after > $before)$wrm"; $warn++; }
elsif( $long_test)
{ warn "$before => $after\n"; }
ok(1, "testing memory leaks for html parsing$wrm");
}
else
{ skip( 1, "need HTML::TreeBuilder 3.13+"); }
$test_nb++;
}
{ if( XML::Twig::_use( 'HTML::Tidy'))
{ my $html= qq{<html><head><title>with tidy</title></head><body>$paras</body></html>};
XML::Twig->new( use_tidy => 1)->parse_html( $html);
my $before= mem_size();
for (1..$conf->{iter}) { XML::Twig->new( use_tidy => 1)->parse_html( $html); }
my $after= mem_size();
if( $after - $before > $conf->{normal_html})
{ warn "test $test_nb: possible memory leak parsing html ($after > $before)$wrm"; $warn++; }
elsif( $long_test)
{ warn "$before => $after\n"; }
ok(1, "testing memory leaks for html parsing using HTML::Tidy$wrm");
}
else
{ skip( 1, "need HTML::Tidy"); }
$test_nb++;
}
}
if( $warn)
{ warn "\nnote that memory leaks can happen even if the module itself doesn't leak, if running",
"\ntests under Devel::Cover for example. So do not panic if you get a warning here.\n";
}
sub mem_size
{ open( STATUS, "/proc/$$/status") or return;
my( $size)= map { m{^VmSize:\s+(\d+\s+\w+)} } <STATUS>;
$size=~ s{ kB}{};
#warn "data size found: $size\n";
return $size;
}
sub really_clear
{ my( $t)= shift;
my $elt= $t->root->DESTROY;
delete $t->{twig_dtd};
delete $t->{twig_doctype};
delete $t->{twig_xmldecl};
delete $t->{twig_root};
delete $t->{twig_parser};
return;
local $SIG{__WARN__} = sub {};
while( $elt)
{ my $nelt= nelt( $elt);
$elt->del_id( $t);
foreach ( qw(gi att empty former)) { undef $elt->{$_}; delete $elt->{$_}; }
$elt->delete;
$elt= $nelt;
}
$t->dispose;
}
sub nelt
{ my( $elt)= @_;
if( $elt->_first_child) { return deepest_child( $elt); }
if( $elt->_next_sibling) { return deepest_child( $elt->_next_sibling); }
return $elt->parent;
}
sub deepest_child
{ my( $elt)= @_;
while( $elt->_first_child) { $elt= $elt->_first_child; }
return $elt;
}

4
t/test_meta_json.t Executable file
View File

@ -0,0 +1,4 @@
use Test::More;
eval "use Test::CPAN::Meta::JSON";
plan skip_all => "Test::CPAN::Meta::JSON required for testing META.json" if $@;
meta_json_ok();

144
t/test_nav.t Executable file
View File

@ -0,0 +1,144 @@
#!/usr/bin/perl -w
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
# test for the various conditions in navigation methods
use XML::Twig;
my $t= XML::Twig->new;
$t->parse(
'<doc id="doc">
<elt id="elt-1" toto="foo" val="1">
<subelt id="subelt-1">text1</subelt>
</elt>
<elt id="elt-2" val="2"/>
<elt2 id="elt2-1"/>
<elt2 id="elt2-2">text</elt2>
<elt2 id="elt2-3">
<subelt id="subelt-2">text</subelt>
<subelt id="subelt-3">text}</subelt>
<subelt id="subelt-3">text"</subelt>
<subelt id="subelt-3">text\'</subelt>
<subelt id="subelt-4">text 2</subelt>
</elt2>
text level1
</doc>');
my $root= $t->root;
my @data= grep { !/^##/ && m{\S} } <DATA>;
my %result= map { chomp; split /\s*=>\s*/} @data;
my $nb_tests= keys %result;
print "1..$nb_tests\n";
foreach my $cond ( sort keys %result)
{ my $expected_result= $result{$cond};
my $result;
my $res= $root->first_child( $cond);
if( $res)
{ if( $res->id) { $result= $res->id; }
else { $result= $res->text;
$result=~ s/^\s+//;
$result=~ s/\s+$//;
}
}
else { $result= 'none'; }
is( $result => $expected_result, "$cond");
}
exit 0;
__DATA__
=> elt-1
elt => elt-1
#ELT => elt-1
!#ELT => text level1
#TEXT => text level1
!#TEXT => elt-1
elt2 => elt2-1
foo => none
elt[@id] => elt-1
elt[@id!="elt-1"] => elt-2
elt[@duh!="elt-1"] => elt-1
elt[@toto] => elt-1
elt[!@toto] => elt-2
/2$/ => elt2-1
elt[@id="elt-1"] => elt-1
elt[@id="elt-1" or @foo="bar"] => elt-1
elt[@id="elt-1" and @foo!="bar"] => elt-1
elt[@id="elt-1" and @foo="bar"] => none
elt2[@id=~/elt2/] => elt2-1
elt[@id="elt2-1"] => none
elt2[@id="elt2-1"] => elt2-1
elt[@id=~/elt2/] => none
*[@id="elt1-1"] => none
*[@foo] => none
*[@id] => elt-1
*[@id="elt-1" or @foo="bar"] => elt-1
*[@id=~/elt2$/] => none
*[@id=~/2-2$/] => elt2-2
*[@id=~/^elt2/] => elt2-1
[@id="elt1-1"] => none
[@foo] => none
[@id] => elt-1
[@id="elt-1" or @foo="bar"] => elt-1
[@id=~/elt2$/] => none
[@id=~/2-2$/] => elt2-2
[@id=~/^elt2/] => elt2-1
#PCDATA => text level1
elt[text(subelt)="text}" ] => none
elt2[text(subelt)="text}"] => elt2-3
elt2[text()="text}"] => none
elt2[text(subelt)='text"'] => elt2-3
elt2[text(subelt)="text'"] => elt2-3
[text(subelt)="text}"] => elt2-3
[text(subelt)="text1"] => elt-1
[text(subelt)="text 2"] => elt2-3
*[text(subelt)="text1"] => elt-1
*[text(subelt)="text 2"] => elt2-3
elt2[text(subelt)="text 2"]=> elt2-3
elt[text(subelt)="text 2"] => none
*[text(subelt)="foo"] => none
*[text(subelt)=~/text/] => elt-1
*[text(subelt)=~/^ext/] => none
[text(subelt)="foo"] => none
[text(subelt)=~/text/] => elt-1
[text(subelt)=~/^ext/] => none
elt2[text(subelt)="text"] => elt2-2
elt[text(subelt)="text"] => none
elt[text(subelt)="foo"] => none
elt[text(subelt)=~/text/] => elt-1
elt[text(subelt)=~/^ext/] => none
elt2[text(subelt)="text"] => elt2-3
elt2[text(subelt)="foo"] => none
elt2[text(subelt)=~/tex/] => elt2-3
elt2[text(subelt)=~/^et/] => none
elt2[text(subelt)=~/^et}/] => none
/ELT/i => elt-1
elt2[text(subelt)='text"'] => elt2-3
elt[@val>'1'] => elt-2
@val>"1" => elt-2
elt[@val<"2"] => elt-1
@val<"2" => elt-1
elt[@val>1] => elt-2
@val>1 => elt-2
elt[@val<2] => elt-1
@val<2 => elt-1
@val => elt-1
[@val="1" or @dummy="2"] => elt-1
[@val="2" or @dummy="2"] => elt-2
*[@val="1" or @dummy="2"] => elt-1
*[@val="2" or @dummy="2"] => elt-2
@val="1" and @dummy="2" => none
@val="1" or @dummy="2" => elt-1
@val="2" or @dummy="2" => elt-2
[@val=~/2/] => elt-2
*[@val=~/2/] => elt-2
@val=~/^2/ => elt-2
@val!~/^1/ => elt-2

48
t/test_need_3_args_open.t Executable file
View File

@ -0,0 +1,48 @@
#!/usr/bin/perl -w
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
$|=1;
use XML::Twig;
# abort (before compiling so the 3 arg open doesn't cause a crash) unless perl 5.8+
BEGIN
{ if( $] < 5.008) { print "1..1\nok 1\n"; warn "skipping tests that require 3 args open\n"; exit 0; } }
my $TMAX=4;
print "1..$TMAX\n";
{ my $out='';
open( my $fh, '>', \$out);
my $doc=q{<doc><elt att="a">foo</elt><elt att="b">bar</elt></doc>};
my $t= XML::Twig->new( twig_handlers => { elt => sub { $_->flush( $fh) } });
$t->parse( $doc);
is( $out, $doc, "flush to a scalar (with autoflush)");
$t->flush( $fh);
is( $out, $doc, "double flush");
$t->flush();
is( $out, $doc, "triple flush");
}
{
my $out= '';
my $twig = XML::Twig->new( output_encoding => 'utf-8',);
$twig->parse( "<root/>");
my $greet = $twig->root->insert_new_elt( last_child => 'g');
$greet->set_text("Gr\x{00FC}\x{00DF}");
open(my $fh, '>:utf8', \$out);
$twig->print(\*$fh);
print {*$fh} "<c>Copyright \x{00A9} 2008 Me</c>";
close($fh);
is( $out, qq{<?xml version="1.0" encoding="utf-8"?><root><g>Grüß</g></root><c>Copyright © 2008 Me</c>},
'$t->print and regular print mixed, with utf-8 encoding'
);
}

436
t/test_need_io_scalar.t Executable file
View File

@ -0,0 +1,436 @@
#!/usr/bin/perl -w
# tests that require IO::String to run
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
#$|=1;
my $DEBUG=0;
use XML::Twig;
BEGIN
{ eval "require IO::String";
if( $@)
{ print "1..1\nok 1\n";
warn "skipping, need IO::String\n";
exit;
}
else
{ import IO::String; }
}
print "1..1778\n";
{ my $out1='';
my $fh1= IO::String->new( \$out1);
my $out2='';
my $fh2= IO::String->new( \$out2);
my $doc='<d><e><m>main</m><i>ignored<i2>completely</i2></i><m>in</m></e><i>ignored<i2>completely</i2></i></d>';
my $out= select $fh1;
my $t= XML::Twig->new( ignore_elts => { i => 'print' })->parse( $doc);
$t->print( $fh2);
select $out;
is( $out1,'<i>ignored<i2>completely</i2></i><i>ignored<i2>completely</i2></i>', 'ignored with print option');
is( $out2,'<d><e><m>main</m><m>in</m></e></d>', 'print after ignored_elts');
}
{ my $doc='<d><e><m>main</m><i>ignored<i2>completely</i2></i><m>in</m></e><i>ignored<i2>completely</i2></i></d>';
my $t= XML::Twig->new( ignore_elts => { i => 'string' })->parse( $doc);
is( $t->{twig_buffered_string} || '','<i>ignored<i2>completely</i2></i><i>ignored<i2>completely</i2></i>', 'ignored with string option');
is( $t->sprint,'<d><e><m>main</m><m>in</m></e></d>', 'string after ignored_elts (to string)');
}
{ my $string='';
my $doc='<d><e><m>main</m><i>ignored<i2>completely</i2></i><m>in</m></e><i>ignored<i2>completely</i2></i></d>';
my $t= XML::Twig->new( ignore_elts => { i => \$string })->parse( $doc);
is( $string,'<i>ignored<i2>completely</i2></i><i>ignored<i2>completely</i2></i>', 'ignored with string reference option');
is( $t->sprint,'<d><e><m>main</m><m>in</m></e></d>', 'string after ignored_elts (to string reference)');
}
{ # test autoflush
my $out='';
my $fh= IO::String->new( \$out);
my $doc= "<doc><elt/></doc>";
my $t= XML::Twig->nparse( twig_handlers => { elt => sub { $_->flush( $fh) } }, $doc);
is( $out, $doc, "autoflush, no args");
}
{ my $out='';
my $fh= IO::String->new( \$out);
my $doc= "<doc><elt/></doc>";
my $t= XML::Twig->nparse( twig_handlers => { elt => sub { $_->flush( $fh, empty_tags => "expand") } }, $doc);
is( $out, "<doc><elt></elt></doc>", "autoflush, no args, expand empty tags");
}
{ # test bug on comments after the root element RT #17064
my $out='';
my $fh= IO::String->new( \$out);
my $doc= q{<doc/><!-- comment1 --><?t pi?><!--comment2 -->};
XML::Twig->nparse( $doc)->print( $fh);
is( $out, $doc, 'comment after root element');
}
{ # more tests, with flush this time
my $c= '<!--c#-->';
my $pi= '<?t pi #?>';
my @simple_docs= ('<doc/>', '<doc><!--c--></doc>', '<doc><elt>foo</elt></doc>');
my $i=0;
my @docs= map { $i++; (my $l= $_)=~ s{#}{$i}g;
$i++; (my $t= $_)=~ s{#}{$i}g;
map { ("$l$_", "$_$t", "$l$_$t") } @simple_docs;
}
( $c, $pi, $c.$pi, $pi.$c, $c.$c, $pi.$pi, $c.$pi.$c, $pi.$c.$pi, $c.$pi.$c.$pi, $pi.$c.$pi.$c, $c.$c.$pi, $c.$pi.$pi)
;
foreach my $doc (@docs)
{ foreach my $options ( { comments => "keep", pi => "keep" },
{ comments => "process", pi => "keep" },
{ comments => "keep", pi => "process" },
{ comments => "process", pi => "process" },
)
{ my $options_text= join( ', ', map { "$_ => $options->{$_}" } sort keys %$options);
is( XML::Twig->nparse( %$options, $doc)->sprint, $doc, "sprint cpi $options_text $doc");
is( XML::Twig->nparse( %$options, keep_encoding => 1, $doc)->sprint, $doc, "sprint cpi keep_encoding $options_text $doc");
{ my $out='';
my $fh= IO::String->new( \$out);
XML::Twig->nparse( %$options, $doc)->flush( $fh);
is( $out, $doc, "flush cpi $options_text $doc");
}
{ my $out='';
my $fh= IO::String->new( \$out);
XML::Twig->nparse( keep_encoding => 1, %$options, $doc)->flush( $fh);
is( $out, $doc, "flush cpi keep_encoding $options_text $doc");
}
}
}
}
{ my $out='';
my $fh= IO::String->new( \$out);
my $doc=q{<doc><link/><link></link><script/><script></script><elt>foo</elt><elt /><elt2/><link/><link></link><script/><script></script></doc>};
my $t= XML::Twig->new( pretty_print => 'indented', empty_tags => 'expand',
twig_handlers => { elt => sub { $_[0]->flush( $fh, pretty_print => 'none',
empty_tags => 'html'
);
},
},
);
$t->{twig_autoflush}=0;
$t->parse( $doc);
is( $out => q{<doc><link /><link /><script></script><script></script><elt>foo</elt><elt></elt>}, 'flush with a pretty_print arg');
is( $t->sprint => qq{<doc>\n <elt2></elt2>\n <link></link>\n <link></link>\n <script></script>\n <script></script>\n</doc>\n},
'flush with a pretty_print arg (checking that option values are properly restored)'
);
}
{ my $out='';
my $fh= IO::String->new( \$out);
select $fh;
my $doc=q{<doc><link/><link></link><script/><script></script><elt>foo</elt><elt /><elt2/><link/><link></link><script/><script></script></doc>};
my $t= XML::Twig->new( pretty_print => 'indented', empty_tags => 'expand',
twig_handlers => { elt => sub { $_[0]->flush( pretty_print => 'none',
empty_tags => 'html'
);
},
},
);
$t->{twig_autoflush}=0;
$t->parse( $doc);
select STDOUT;
is( $out => q{<doc><link /><link /><script></script><script></script><elt>foo</elt><elt></elt>}, 'flush with a pretty_print arg (default fh)');
is( $t->sprint => qq{<doc>\n <elt2></elt2>\n <link></link>\n <link></link>\n <script></script>\n <script></script>\n</doc>\n},
'flush with a pretty_print arg (checking that option values are properly restored) (default fh)'
);
}
{ my $out='';
my $fh= IO::String->new( \$out);
select $fh;
my $doc=q{<doc><elt>foo</elt><elt /><elt2/></doc>};
my $t= XML::Twig->new( pretty_print => 'indented', empty_tags => 'expand',
twig_handlers => { elt => sub { $_[0]->flush_up_to( $_, pretty_print => 'none',
empty_tags => 'html'
);
},
},
);
$t->{twig_autoflush}=0;
$t->parse( $doc);
select STDOUT;
is( $out => q{<doc><elt>foo</elt><elt></elt>}, 'flush with a pretty_print arg (default fh)');
is( $t->sprint => qq{<doc>\n <elt2></elt2>\n</doc>\n},
'flush with a pretty_print arg (checking that option values are properly restored)'
);
}
{ my $out=''; my $out2=''; my $out3=''; my $out4='';
my $fh= IO::String->new( \$out);
my $fh2= IO::String->new( \$out2);
my $fh3= IO::String->new( \$out3);
my $fh4= IO::String->new( \$out4);
my $t= XML::Twig->new( empty_tags => 'expand', pretty_print => 'none')->parse( '<doc><elt/></doc>');
$t->print( $fh);
is( $out, "<doc><elt></elt></doc>", "empty_tags expand");
$t->print( $fh2, empty_tags => 'normal', pretty_print => 'indented' );
is( $out2, "<doc>\n <elt/>\n</doc>\n", "print with args");
$t->print( $fh3);
is( $out3, "<doc><elt></elt></doc>", "print without args");
is( $t->sprint( empty_tags => 'normal'), "<doc><elt/></doc>", "empty_tags normal");
$t->print( $fh4);
is( $t->sprint( pretty_print => 'indented', empty_tags => 'normal'), "<doc>\n <elt/>\n</doc>\n", "empty_tags expand");
$t->set_pretty_print( 'none');
$t->set_empty_tag_style( 'normal');
}
{ my $out=''; my $out2='';
my $fh= IO::String->new( \$out);
my $fh2= IO::String->new( \$out2);
my $t= XML::Twig->new( empty_tags => 'expand', pretty_print => 'none')->parse( '<doc><elt/></doc>');
$t->root->print( $fh);
is( $out, "<doc><elt></elt></doc>", "empty_tags expand");
$t->root->print( $fh2, { pretty_print => 'indented' } );
is( $out2, "<doc>\n <elt></elt>\n</doc>\n", "print elt indented");
$out=''; $fh= IO::String->new( \$out); $t->root->print( $fh);
is( $out, "<doc><elt></elt></doc>", "back to default");
$t->set_pretty_print( 'none');
$t->set_empty_tag_style( 'normal');
}
{ my $out=''; my $out2='';
my $fh= IO::String->new( \$out);
my $fh2= IO::String->new( \$out2);
my $t= XML::Twig->new( empty_tags => 'expand', pretty_print => 'none');
$t->parse( '<doc><elt/></doc>')->flush( $fh);
is( $out, "<doc><elt></elt></doc>", "empty_tags expand");
$t->parse( '<doc><elt/></doc>')->flush( $fh2);
is( $t->sprint( empty_tags => 'normal'), "<doc><elt/></doc>", "empty_tags normal");
$out=''; $t->parse( '<doc><elt/></doc>')->flush( $fh);
is( $t->sprint( pretty_print => 'indented', empty_tags => 'normal'), "<doc>\n <elt/>\n</doc>\n", "empty_tags expand");
$t->set_pretty_print( 'none');
$t->set_empty_tag_style( 'normal');
}
{ my $out='';
my $fh= IO::String->new( \$out);
my $doc= q{<doc><sect><p>p1</p><p>p2</p><flush/></sect></doc>};
my $t= XML::Twig->new( twig_handlers => { flush => sub { $_->flush( $fh) } } );
$t->{twig_autoflush}=0;
$t->parse( $doc);
is( $out, q{<doc><sect><p>p1</p><p>p2</p><flush/>}, "flush");
close $fh;
$out="";
$fh= IO::String->new( \$out);
$t= XML::Twig->new( twig_handlers => { flush => sub { $_[0]->flush_up_to( $_->prev_sibling, $fh) } } );
$t->{twig_autoflush}=0;
$t->parse( $doc);
is( $out, q{<doc><sect><p>p1</p><p>p2</p>}, "flush_up_to");
$t= XML::Twig->new( twig_handlers => { purge => sub { $_[0]->purge_up_to( $_->prev_sibling->prev_sibling, $fh) } } )
->parse( q{<doc><sect2/><sect><p>p1</p><p><sp>sp 1</sp></p><purge/></sect></doc>});
is( $t->sprint, q{<doc><sect><p><sp>sp 1</sp></p><purge/></sect></doc>}, "purge_up_to");
}
{ my $out='';
my $fh= IO::String->new( \$out);
my $t= XML::Twig->new()->parse( q{<!DOCTYPE doc [<!ELEMENT doc (#PCDATA)*>]><doc>toto</doc>});
$t->dtd_print( $fh);
is( $out, "<!DOCTYPE doc [\n<!ELEMENT doc (#PCDATA)*>\n\n]>\n", "dtd_print");
close $fh;
}
{ my $out="";
my $fh= IO::String->new( \$out);
my $t= XML::Twig->new( twig_handlers => { stop => sub { print $fh "[X]"; $_->set_text( '[Y]'); $_[0]->flush( $fh); $_[0]->finish_print( $fh); } });
$t->{twig_autoflush}=0;
$t->parse( q{<doc>before<stop/>finish</doc>});
select STDOUT;
is( $out, q{[X]<doc>before<stop>[Y]</stop>finish</doc>}, "finish_print");
}
package test_handlers;
sub new { bless { } }
sub recognized_string { return 'recognized_string'; }
sub original_string { return 'original_string'; }
package main;
{
my $out='';
my $fh= IO::String->new( \$out);
my $stdout= select $fh;
XML::Twig::_twig_print_original_default( test_handlers->new);
select $stdout;
close $fh;
is( $out, 'original_string', 'twig_print_original_default');
$out='';
$fh= IO::String->new( \$out);
select $fh;
XML::Twig::_twig_print( test_handlers->new);
select $stdout;
close $fh;
is( $out, 'recognized_string', 'twig_print_default');
$out='';
$fh= IO::String->new( \$out);
select $fh;
XML::Twig::_twig_print_end_original( test_handlers->new);
select $stdout;
close $fh;
is( $out, 'original_string', 'twig_print_end_original');
$out='';
$fh= IO::String->new( \$out);
select $fh;
XML::Twig::_twig_print( test_handlers->new);
select $stdout;
close $fh;
is( $out, 'recognized_string', 'twig_print_end');
}
XML::Twig::_twig_print_entity(); # does nothing!
{
my %ents= ( foo => '"toto"', pile => 'SYSTEM "file.bar" NDATA bar');
my %ent_text = hash_ent_text( %ents);
my $ent_text = string_ent_text( %ents);
my $doc= "<!DOCTYPE doc [$ent_text]><doc/>";
my $t= XML::Twig->new->parse( $doc);
is( normalize_xml( $t->entity_list->text), $ent_text, 'entity_list');
my @entities= $t->entity_list->list;
is( scalar @entities, scalar keys %ents, 'entity_list');
foreach my $ent (@entities)
{ my $out='';
my $fh= IO::String->new( \$out);
my $stdout= select $fh;
$ent->print;
close $fh;
select $stdout;
is( normalize_xml( $out), $ent_text{$ent->name}, "print $ent->{name}");
}
my $out='';
my $fh= IO::String->new( \$out);
my $stdout= select $fh;
$t->entity_list->print;
close $fh;
select $stdout;
is( normalize_xml( $out), $ent_text, 'print entity_list');
}
{ my( $out1, $out2, $out3);
my $fh1= IO::String->new( \$out1);
my $fh2= IO::String->new( \$out2);
my $fh3= IO::String->new( \$out3);
my $stdout= select $fh3;
my $t= XML::Twig->new( twig_handlers => { e => sub { $_->print( $fh2);
print $fh1 "X";
$_[0]->finish_print( $fh1);
},
},
)
->parse( '<doc>text<e>e <p>text</p></e>more text <p>foo</p></doc>');
print 'should be in $out3';
select $stdout;
is( $out1, 'Xmore text <p>foo</p></doc>', 'finish_print');
is( $out2, '<e>e <p>text</p></e>', 'print to fh');
is( $out3, 'should be in $out3', 'restoring initial fh');
}
{ my $doc= '<doc><![CDATA[toto]]>tata<!-- comment -->t<?pi data?> more</doc>';
my $out;
my $fh= IO::String->new( \$out);
my $t= XML::Twig->new( comments => 'process', pi => 'process')->parse( $doc);
$t->flush( $fh);
is( $out, $doc, 'flush with cdata');
}
{ my $out='';
my $fh= IO::String->new( \$out);
my $doc='<doc><elt>text</elt><elt1/><elt2/><elt3>text</elt3></doc>';
my $t= XML::Twig->new( twig_roots=> { elt2 => 1 },
start_tag_handlers => { elt => sub { print $fh '<e1/>'; } },
end_tag_handlers => { elt3 => sub { print $fh '<e2/>'; } },
twig_print_outside_roots => $fh,
keep_encoding => 1
)
->parse( $doc);
is( $out, '<doc><e1/><elt>text</elt><elt1/><elt3>text<e2/></elt3></doc>',
'twig_print_outside_roots, start/end_tag_handlers, keep_encoding');
close $fh;
$out='';
$fh= IO::String->new( \$out);
$t= XML::Twig->new( twig_roots=> { elt2 => 1 },
start_tag_handlers => { elt => sub { print $fh '<e1/>'; } },
end_tag_handlers => { elt3 => sub { print $fh '<e2/>'; } },
twig_print_outside_roots => $fh,
)
->parse( $doc);
is( $out, '<doc><e1/><elt>text</elt><elt1/><elt3>text<e2/></elt3></doc>',
'twig_print_outside_roots and start_tag_handlers');
}
{ my $t= XML::Twig->new->parse( '<doc/>');
eval( '$t->set_output_encoding( "ISO-8859-1");');
if( $@)
{ skip( 1 => "your system does not seem to support conversions to ISO-8859-1: $@\n"); }
else
{ is( $t->sprint, qq{<?xml version="1.0" encoding="ISO-8859-1"?><doc/>},
'creating an output encoding'
);
}
}
{ my $out='';
my $fh= IO::String->new( \$out);
select $fh;
my $doc='<?xml version="1.0"?><!DOCTYPE doc [ <!ELEMENT doc (#PCDATA)> <!ENTITY foo "bar">]><doc/>';
my( $expected)= $doc=~ m{(<!DOCTYPE.*?\]>)};
XML::Twig->new->parse( $doc)->dtd_print;
select STDOUT;
is_like( $out, $expected, "dtd_print to STDOUT");
}
{ my $out='';
my $fh= IO::String->new( \$out);
select $fh;
my $doc='<doc><elt1/><elt2/></doc>';
XML::Twig->new( twig_handlers => { elt1 => sub { $_[0]->finish_print; } })->parse( $doc);
select STDOUT;
is( $out, '<elt2/></doc>', "finish_print to STDOUT");
}
{ my $out='';
my $fh= IO::String->new( \$out);
select $fh;
my $doc='<doc><elt1/><elt2/></doc>';
XML::Twig->new( keep_encoding => 1, twig_handlers => { elt1 => sub { $_[0]->finish_print; } })->parse( $doc);
select STDOUT;
is( $out, '<elt2/></doc>', "finish_print to STDOUT");
}
exit 0;

59
t/test_need_use_bytes.t Executable file
View File

@ -0,0 +1,59 @@
#!/usr/bin/perl -w
# tests that require IO::Scalar to run
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
#$|=1;
my $DEBUG=0;
use XML::Twig;
BEGIN
{ eval "use bytes";
if( $@)
{ print "1..1\nok 1\n";
warn "skipping, need to be able to use bytes\n";
exit;
}
}
print "1..2\n";
my $text= "&#233;t&#233;";
my $text_safe= "&#233;t&#233;";
my $text_safe_hex= "&#xe9;t&#xe9;";
my $doc=qq{<?xml version="1.0" encoding="UTF-8"?>\n<doc>$text</doc>};
my $doc_safe=qq{<?xml version="1.0" encoding="UTF-8"?>\n<doc>$text_safe</doc>};
my $doc_safe_hex=qq{<?xml version="1.0" encoding="UTF-8"?>\n<doc>$text_safe_hex</doc>};
my $t= XML::Twig->new()->parse( $doc);
if( $] == 5.008)
{ skip( 2); }
else
{ $t->set_output_text_filter( sub { my $text= shift;
use bytes;
$text=~ s{([\xC0-\xDF].|[\xE0-\xEF]..|[\xF0-\xFF]...)}
{XML::Twig::_XmlUtf8Decode($1)}egs;
return $text;
}
);
is( $t->sprint, $doc_safe, 'safe with _XmlUtf8Decode'); # test 338
$t->set_output_text_filter( sub { my $text= shift;
use bytes;
$text=~ s{([\xC0-\xDF].|[\xE0-\xEF]..|[\xF0-\xFF]...)}
{XML::Twig::_XmlUtf8Decode($1, 1)}egs;
return $text;
}
);
is( $t->sprint, $doc_safe_hex, 'safe_hex with _XmlUtf8Decode'); # test 339
}
exit 0;

29
t/test_new_features_3_15.t Executable file
View File

@ -0,0 +1,29 @@
#!/usr/bin/perl -w
use strict;
# test designed to improve coverage of the module
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
#$|=1;
my $DEBUG=0;
use XML::Twig;
my $TMAX=1;
print "1..$TMAX\n";
{ my $indented="<doc>\n <elt/>\n</doc>\n";
(my $straight=$indented)=~ s{\s}{}g;
is( XML::Twig->new( pretty_print => 'indented')->parse( $indented)->sprint,
$indented, "pretty printed doc"); exit;
is( XML::Twig->new()->parse( $indented)->sprint,
$straight, "non pretty printed doc");
}

179
t/test_new_features_3_16.t Executable file
View File

@ -0,0 +1,179 @@
#!/usr/bin/perl -w
use strict;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
use XML::Twig;
my $TMAX=85;
my $DEBUG=0;
print "1..$TMAX\n";
# state information are now attached to each twig
# default/fixed attribute values are now filled when the "load_DTD" option is used
my $dtd_file= 'test_default_att.dtd';
my $dtd=<<'DTD';
<!ELEMENT doc (elt+)>
<!ATTLIST doc att1 (toto|tata) "tata"
att2 CDATA #FIXED "0"
att3 CDATA #IMPLIED
att4 CDATA "tutu"
>
<!ELEMENT elt (#PCDATA)>
<!ATTLIST elt att1 (foo|bar) "foo"
att2 CDATA #FIXED "baz"
att3 CDATA #IMPLIED
att5 CDATA "0"
>
DTD
my $doc = q{<doc><elt/><elt att1="bar" /><elt att5="titi"/><elt att3="foobar"/></doc>};
my $filled_doc = q{<doc att1="tata" att2="0" att4="tutu">}
.q{<elt att1="foo" att2="baz" att5="0"/>}
.q{<elt att1="bar" att2="baz" att5="0"/>}
.q{<elt att1="foo" att2="baz" att5="titi"/>}
.q{<elt att1="foo" att2="baz" att3="foobar" att5="0"/>}
.q{</doc>};
{
open( FHDTD, ">$dtd_file") or die "cannot open dtd file '$dtd': $!";
print FHDTD $dtd;
close FHDTD;
my $doc_with_external_dtd= qq{<!DOCTYPE doc SYSTEM "$dtd_file">$doc};
my $result= XML::Twig->new( error_context => 1, load_DTD => 1)
->parse( $doc_with_external_dtd)
->root->sprint;
is( $result => $filled_doc, 'filling attribute default values with EXTERNAL DTD');
unlink $dtd_file;
}
{
my $doc_with_internal_dtd= qq{<!DOCTYPE doc [$dtd]>$doc};
my $result= XML::Twig->new( error_context => 1, load_DTD => 1)
->parse( $doc_with_internal_dtd)
->root->sprint;
is( $result => $filled_doc, 'filling attribute default values with INTERNAL DTD');
}
# test the first_descendant method
{
my $t= XML::Twig->new->parse( '<doc><elt><a/></elt><b/></doc>');
is( $t->root->first_child->first_descendant( 'a')->tag, 'a', 'first_descendant succeeds');
nok( $t->root->first_child->first_descendant( 'b'), 'first_descendant fails (match outside of the subtree)');
}
# test the index option and method
{ my $doc=q{<doc><elt><t>t1</t></elt><t>t2</t></doc>};
my $t= XML::Twig->new( index => [ 't', 'none' ])->parse( $doc);
is( $t->index( 't', 0)->text, 't1', 'index');
is( $t->index( 't', 1)->text, 't2', 'index');
is_undef( $t->index( 't', 2), 'index');
is( $t->index( 't', -1)->text, 't2', 'index');
my $index= $t->index( 't');
is( $index->[0]->text, 't1', 'index');
is( $index->[ 1]->text, 't2', 'index');
is_undef( $index->[ 2], 'index');
is( $index->[-1]->text, 't2', 'index');
}
{ my $doc=q{<doc><elt><t>t1</t></elt><t>t2</t></doc>};
my $t= XML::Twig->new( index => { target => 't' })->parse( $doc);
is( $t->index( 'target', 0)->text, 't1', 'index');
is( $t->index( 'target', 1)->text, 't2', 'index');
is_undef( $t->index( 'target', 2), 'index');
is( $t->index( 'target', -1)->text, 't2', 'index');
my $index= $t->index( 'target');
is( $index->[0]->text, 't1', 'index');
is( $index->[ 1]->text, 't2', 'index');
is_undef( $index->[ 2], 'index');
is( $index->[-1]->text, 't2', 'index');
}
# test the remove_cdata option
{ my $doc = q{<doc><![CDATA[<tag&>]]></doc>};
my $escaped_doc= q{<doc>&lt;tag&amp;></doc>};
my $t= XML::Twig->new( remove_cdata => 1)->parse( $doc);
is( $t->sprint, $escaped_doc, 'remove_cdata on');
$t= XML::Twig->new( remove_cdata => 0)->parse( $doc);
is( $t->sprint, $doc, 'remove_cdata off');
}
# test the create_accessors method
if( $] < 5.006)
{ skip( 11 => "create_accessors not tested with perl < 5.006"); }
else
{ my $doc= '<doc att1="1" att3="foo"/>';
my $t= XML::Twig->new->parse( $doc);
$t->create_accessors( qw(att1 att2));
my $root= $t->root;
is( $root->att1, 1, 'attribute getter');
$root->att1( 2);
is( $root->att1, 2, 'attribute setter');
eval '$root->att1=3'; # eval'ed to keep 5.005 from barfing
is( $root->att1, 3, 'attribute as lvalue');
eval '$root->att1++'; # eval'ed to keep 5.005 from barfing
is( $root->att1, 4, 'attribute as lvalue (++)');
is( $root->att1, $root->att( 'att1'), 'check with regular att method');
eval { $^W=0; $root->att3; $^W=1; };
matches( $@, q{^Can't locate object method "att3" via package "XML::Twig::Elt" }, 'unknow accessor');
is( $root->att2, undef, 'get non-existent att');
$root->att2( 'bar');
is( $root->att2, "bar", 'get non-existent att');
is( $t->sprint, '<doc att1="4" att2="bar" att3="foo"/>', 'final output');
eval { $t->create_accessors( 'tag'); };
matches( $@, q{^attempt to redefine existing method tag using att_accessors }, 'duplicate accessor');
$@='';
eval { XML::Twig->create_accessors( 'att2'); };
is( $@, '', 'redefining existing accessor');
}
{ # test embedded comments/pis
foreach my $doc (
q{<doc>text <!--cdata coming--><![CDATA[here]]></doc>},
q{<doc>text<!--comment-->more</doc>},
q{<doc>text<!--comment-->more<!--comment2--></doc>},
q{<doc>text<!--comment-->more<!--comment2-->more2</doc>},
q{<doc><!--comment-->more<!--comment2-->more2</doc>},
q{<doc><!--comment--></doc>},
q{<doc>tata<!--comment & all-->toto</doc>},
q{<doc>tata &lt;<!--comment &amp; tu &lt; all-->toto &lt;</doc>},
q{<doc>text<!--comment-->more &amp; even more<!--comment2-->more2</doc>},
q{<doc>text <!--cdata coming--> <![CDATA[here]]></doc>},
q{<doc> <!--comment--> more <!--comment2--> more2 </doc>},
q{<doc><!--comment--> more <!--comment2--> more2</doc>},
)
{ my $t= XML::Twig->new->parse( $doc);
is( $t->sprint, $doc, "comment within pcdata ($doc)");
my $t2= XML::Twig->new( keep_encoding => 1)->parse( $doc);
is( $t2->sprint, $doc, "comment within pcdata in keep encoding mode($doc)");
my $doc_pi= $doc;
$doc_pi=~ s{<!--}{<?pi}g; $doc_pi=~ s{-->}{?>}g;
my $t3= XML::Twig->new->parse( $doc_pi);
is( $t3->sprint, $doc_pi, "pi within pcdata ($doc_pi)");
my $t4= XML::Twig->new( keep_encoding => 1)->parse( $doc_pi);
is( $t4->sprint, $doc_pi, "pi within pcdata in keep encoding mode($doc_pi)");
}
}
{ # test processing of embedded comments/pis
my $doc= q{<doc><elt>foo<!--comment-->bar</elt><elt>foobar</elt></doc>};
my $t= XML::Twig->new->parse( $doc);
my @elt= $t->findnodes( '//elt[string()="foobar"]');
is( scalar( @elt), 2, 'searching on text with embedded comments');
foreach my $elt (@elt) { $elt->set_text( 'toto'); }
is( $t->sprint, q{<doc><elt>toto</elt><elt>toto</elt></doc>}, "set_text");
my $t2= XML::Twig->new( keep_encoding => 1)->parse( $doc);
@elt= $t2->findnodes( '//elt[string()="foobar"]');
is( scalar( @elt), 2, 'searching on text with embedded comments');
foreach my $elt (@elt) { $elt->set_text( 'toto'); }
is( $t2->sprint, q{<doc><elt>toto</elt><elt>toto</elt></doc>}, "set_text");
}

136
t/test_new_features_3_18.t Executable file
View File

@ -0,0 +1,136 @@
#!/usr/bin/perl -w
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
use XML::Twig;
my $DEBUG=0;
print "1..44\n";
{ # test tag regexp handler
my @res;
my $doc=q{<doc><foo_f1/><foo_f2/><foo_f1/><foo_f3/><afoo_f1/><FOO_f4/></doc>};
my $handlers= { qr/^foo_/ => sub { push @res, $_->tag; },
foo_f2 => sub { push @res, uc $_->tag; 0 },
};
my $expected= 'foo_f1:FOO_F2:foo_f1:foo_f3';
XML::Twig->new( twig_handlers => $handlers)->parse( $doc);
my $res= join( ':', @res);
is( $res, $expected, "tag regexp handlers");
}
{ # test tag regexp handler with i modifier
my @res;
my $doc=q{<doc><foo_f1/><foo_f2/><foo_f1/><foo_f3/><afoo_f1/><FOO_f4/></doc>};
my $handlers= { qr/^foo_/i => sub { push @res, $_->tag; },
foo_f2 => sub { push @res, uc $_->tag; 0 },
};
my $expected= 'foo_f1:FOO_F2:foo_f1:foo_f3:FOO_f4';
XML::Twig->new( twig_handlers => $handlers)->parse( $doc);
my $res= join( ':', @res);
is( $res, $expected, "tag regexp handlers");
}
{ # test tag regexp handler with all modifier
my @res;
my $doc=q{<doc><foo_f1/><foo_f2/><foo_f1/><foo_f3/><afoo_f1/><FOO_f4/></doc>};
my $handlers= { qr/^foo_/xism => sub { push @res, $_->tag; },
foo_f2 => sub { push @res, uc $_->tag; 0 },
};
my $expected= 'foo_f1:FOO_F2:foo_f1:foo_f3:FOO_f4';
XML::Twig->new( twig_handlers => $handlers)->parse( $doc);
my $res= join( ':', @res);
is( $res, $expected, "tag regexp handlers");
}
{ # testing last_descendant
my $t= XML::Twig->new->parse( '<doc id="doc">
<e3 id="e3">t_e_3</e3>
<e4 id="e4" />
<e id="e1">t_e_1</e>
<e id="e2">t_e_2<n id="n1">t_n</n></e>
</doc>
'
);
my %exp2id= ( '' => 't_n',
'n' => 'n1',
'#ELT' => 'n1',
'e' => 'e2',
'e[@id="e1"]' => 'e1',
'e2' => undef,
);
foreach my $exp (sort keys %exp2id)
{ my $expected= $exp2id{$exp};
is( result( $t->last_elt( $exp)), $expected, "last_elt( $exp)");
is( result( $t->root->last_descendant( $exp)), $expected, "last_descendant( $exp)");
}
# some more tests to check that we stay in te subtree and that we get the last descendant if it is itself
is( result( $t->last_elt( 'e3')), 'e3', 'last_elt( e3)');
is( result( $t->root->last_descendant( 'e3')), 'e3', 'last_descendant( e3)');
is( result( $t->root->first_child( 'e3')->last_descendant( 'e3')), 'e3', 'last_descendant( e3) (on e3)');
is( result( $t->root->first_child( 'e3')->last_descendant()), 't_e_3', 'last_descendant() (on e3)');
is_undef( $t->root->last_child->last_descendant( 'e3'), 'last_descendant (no result)');
is( result( $t->root->first_child( 'e4')->last_descendant( 'e4')), 'e4', 'last_descendant( e4) (on e4)');
is( result( $t->root->first_child( 'e4')->last_descendant( )), 'e4', 'last_descendant( ) (on e4)');
sub result
{ my( $elt)= @_;
return undef unless $elt;
return $elt->id || $elt->text;
}
}
{# testing trim
my $expected;
while( <DATA>)
{ chomp;
next unless( m{\S});
if( s{^#}{}) { $expected= $_; }
is( XML::Twig->new->parse( $_)->trim->root->sprint, $expected, "trimming '$_'");
}
}
{ # testing children_trimmed_text
my $t = XML::Twig->new;
$t->parse("<o><e> hell </e><i> foo </i><e> o, \n world</e></o>");
is( join( ':', $t->root->children_trimmed_text("e")), "hell:o, world" , "children_trimmed_text (list context)");
my $scalar= $t->root->children_trimmed_text("e");
is( $scalar, "hello, world" , "children_trimmed_text (scalar context)");
is( join( ':', $t->root->children_text("e")), " hell : o, \n world" , "children_text (list context)");
$scalar= $t->root->children_text("e");
is( $scalar, " hell o, \n world" , "children_text (scalar context)");
}
__DATA__
#<doc>text1 text2</doc>
<doc> text1 text2</doc>
<doc> text1 text2</doc>
<doc>text1 text2 </doc>
<doc>text1 text2 </doc>
<doc>text1 text2 </doc>
<doc>text1 text2</doc>
<doc> text1 text2 </doc>
<doc> text1 text2 </doc>
#<doc>text1 <e>text2</e> text3</doc>
<doc>text1 <e>text2</e> text3 </doc>
#<doc>text1 <e> text2 </e> text3</doc>
<doc>text1 <e> text2 </e> text3 </doc>
#<doc><![CDATA[text1 text2]]></doc>
<doc> <![CDATA[text1 text2]]> </doc>
<doc><![CDATA[ text1 text2 ]]></doc>
#<doc>text <b> hah! </b> yep</doc>
<doc> text <b> hah! </b> yep</doc>

1
t/test_new_features_3_22.html Normal file
View File

@ -0,0 +1 @@
<html><head><title>T</title><meta content="mv" name="mn"></head><body>t<br>t2<p>t3</body></html>

153
t/test_new_features_3_22.t Executable file
View File

@ -0,0 +1,153 @@
#!/usr/bin/perl -w
use strict;
use Carp;
use FindBin qw($Bin);
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
use XML::Twig;
my $DEBUG=0;
print "1..20\n";
{ my $doc= q{<?xml version="1.0" ?>
<!DOCTYPE doc [ <!ENTITY foo 'toto'>]>
<doc>&foo;</doc>};
XML::Twig->new( keep_encoding => 1)->parse( $doc);
}
{ # testing parse_html
if( XML::Twig::_use( 'HTML::TreeBuilder', 3.13) && XML::Twig::_use( 'LWP::Simple') && XML::Twig::_use( 'LWP::UserAgent'))
{ my $html= q{<html><head><title>T</title><meta content="mv" name="mn"></head><body>t<br>t2<p>t3</body></html>};
my $expected= HTML::TreeBuilder->new->parse( $html)->as_XML;
$expected=~ s{></(meta|br)}{ /}g;
is_like( XML::Twig->new->parse_html( $html)->sprint, $expected, 'parse_html string using HTML::TreeBuilder');
my $html_file= File::Spec->catfile( "t", "test_new_features_3_22.html");
spit( $html_file => $html);
if( -f $html_file)
{ is_like( XML::Twig->new->parsefile_html( $html_file)->sprint, $expected, 'parsefile_html using HTML::TreeBuilder');
open( HTML, "<$html_file") or die "cannot open HTML file '$html_file': $!";
is_like( XML::Twig->new->parse_html( \*HTML)->sprint, $expected, 'parse_html fh using HTML::TreeBuilder');
}
else
{ skip( 2, "could not write HTML file in t directory, check permissions"); }
}
else
{ skip( 3 => 'need HTML::TreeBuilder 3.13+ and LWP to test parse_html'); }
}
{ # testing _use
ok( XML::Twig::_use( 'XML::Parser'), '_use XML::Parser');
ok( XML::Twig::_use( 'XML::Parser'), '_use XML::Parser (2cd time)'); # second time tests the caching
nok( XML::Twig::_use( 'I::HOPE::THIS::MODULE::NEVER::MAKES::IT::TO::CPAN'), '_use non-existent-module');
nok( XML::Twig::_use( 'I::HOPE::THIS::MODULE::NEVER::MAKES::IT::TO::CPAN'), '_use non-existent-module (2cd time)');
}
{ # testing auto-new features
my $doc= '<doc/>';
is( XML::Twig->nparse( empty_tags => 'normal', $doc)->sprint, $doc, 'nparse string');
is( XML::Twig->nparse( empty_tags => 'expand', $doc)->sprint, '<doc></doc>', 'nparse string and option');
my $doc_file= 'doc.xml';
spit( $doc_file => $doc);
# doc is still expanded because empty_tags was set above
is( XML::Twig->nparse( $doc_file)->sprint, '<doc></doc>', 'nparse file');
is( XML::Twig->nparse( twig_handlers => { doc => sub { $_->set_tag( 'foo'); } }, $doc_file)->sprint, '<foo></foo>', 'nparse file and option');
unlink $doc_file;
if( XML::Twig::_use( 'HTML::TreeBuilder', 3.13) && XML::Twig::_use( 'LWP::Simple') && XML::Twig::_use( 'LWP::UserAgent'))
{
$doc=q{<html><head><title>foo</title></head><body><p>toto</p></body></html>};
is( XML::Twig->nparse( $doc)->sprint, $doc, 'nparse well formed html string');
$doc_file="doc.html";
spit( $doc_file => $doc);
is( XML::Twig->nparse( $doc_file)->sprint, $doc, 'nparse well formed html file');
#is( XML::Twig->nparse( "file://$doc_file")->sprint, $doc, 'nparse well formed url');
unlink $doc_file;
XML::Twig::_disallow_use( 'HTML::TreeBuilder');
eval{ XML::Twig->new->parse_html( '<html/>'); };
matches( $@, "^cannot parse HTML: missing HTML::TreeBuilder", "parse_html without HTML::TreeBuilder");
XML::Twig::_allow_use( 'HTML::TreeBuilder');
}
else
{ skip( 3, "need HTML::TreeBuilder 3.13+"); }
if( XML::Twig::_use( 'HTML::TreeBuilder', 3.13) && XML::Twig::_use( 'LWP::Simple') && XML::Twig::_use( 'LWP::UserAgent'))
{ $doc=q{<html><head><title>foo</title></head><body><p>toto<br>tata</p></body></html>};
(my $expected= $doc)=~ s{<br>}{<br />};
$doc_file="doc.html";
spit( $doc_file => $doc);
is( XML::Twig->nparse( $doc_file)->sprint, $expected, 'nparse html file');
#is( XML::Twig->nparse( "file://$doc_file")->sprint, $doc, 'nparse html url');
unlink $doc_file;
}
else
{ skip ( 1, "need HTML::TreeBuilder 3.13+"); }
}
{
my $file= File::Spec->catfile( $Bin, "test_new_features_3_22.html");
if( -f $file)
{ XML::Twig::_disallow_use( 'LWP::Simple');
eval { XML::Twig->nparse( "file://$file"); };
matches( $@, "^missing LWP::Simple", "nparse html url without LWP::Simple");
XML::Twig::_allow_use( 'LWP::Simple');
if( XML::Twig::_use( 'LWP::Simple') && XML::Twig::_use( 'LWP::UserAgent') && XML::Twig::_use( 'HTML::TreeBuilder', 3.13))
{ my $url= "file://$file";
$url=~ s{\\}{/}g; # we need a URL, not a file name
my $content= XML::Twig->nparse( $url)->sprint;
(my $expected= slurp( $file))=~ s{(<(meta|br)[^>]*>)}{$1</$2>}g;
$expected=~s{<p>t3}{<p>t3</p>};
$expected=~ s{></(meta|br)}{ /}g;
is( $content, $expected, "nparse url");
}
else
{ skip( 1 => "cannot test html url parsing without LWP::Simple and HTML::TreeBuilder 3.13+"); }
}
else
{ skip( 2 => "cannot find $file"); }
}
{
my $file= File::Spec->catfile( $Bin, "test_new_features_3_22.xml");
if( -f $file)
{ XML::Twig::_disallow_use( 'LWP::Simple');
eval { XML::Twig->nparse( "file://$file"); };
matches( $@, "^missing LWP::Simple", "nparse url without LWP::Simple");
XML::Twig::_allow_use( 'LWP::Simple');
if( perl_io_layer_used())
{ skip( 1 => "cannot test url parsing when UTF8 perlIO layer used"); }
elsif( XML::Twig::_use( 'LWP::Simple') && XML::Twig::_use( 'LWP::UserAgent'))
{ my $url= "file://$file";
$url=~ s{\\}{/}g; # we need a URL, not a file name
if( LWP::Simple::get( $url))
{ my $content= XML::Twig->nparse( $url)->sprint;
is( $content, "<doc></doc>", "nparse url (nothing there)");
}
else
{ skip( 1 => "it looks like your LWP::Simple's get cannot handle '$url'"); }
}
else
{ skip( 1 => "cannot test url parsing without LWP"); }
}
else
{ skip( 2 => "cannot find $file"); }
}
{ my $file= File::Spec->catfile( "t", "test_new_features_3_22.xml");
open( FH, "<$file") or die "cannot find test file '$file': $!";
my $content= XML::Twig->nparse( \*FH)->sprint;
is( $content, "<doc></doc>", "nparse glob");
}

1
t/test_new_features_3_22.xml Normal file
View File

@ -0,0 +1 @@
<doc></doc>

69
t/test_pi_handler.t Executable file
View File

@ -0,0 +1,69 @@
#!/usr/bin/perl -w
use strict;
use Carp;
# test for the various conditions in navigation methods
$|=1;
use XML::Twig;
if( $] < 5.008)
{ warn "skipped, not tested under perl < 5.8\n"; print "1..1\nok 1\n"; exit 0; }
my $nb_tests=4;
print "1..$nb_tests\n";
my $result;
my $t= XML::Twig->new( pi => 'process',
twig_handlers => { '?pi' => sub { $result .=$_->text; } },
);
$t->parse( q{<doc id="doc"><?pi pi in doc ?></doc>});
my $expected= '<?pi pi in doc ?>';
if( $result eq $expected)
{ print "ok 1\n"; }
else
{ print "not ok 1\n";
warn "expected: $expected\nfound : $result\n";
}
$result='';
$t= XML::Twig->new( pi => 'process',
twig_handlers => { '?pi' => sub { $result .=$_->text; } },
);
$t->parse( q{<?pi pi in doc ?><doc id="doc"></doc>});
$expected= '<?pi pi in doc ?>';
if( $result eq $expected)
{ print "ok 2\n"; }
else
{ print "not ok 2\n";
warn "expected: $expected\nfound : $result\n";
}
$result='';
$t= XML::Twig->new( twig_handlers => { 'doc' => sub { $result= $_->{extra_data}; } },);
$t->parse( q{<?pi pi in doc ?><doc id="doc"></doc>});
$expected= '<?pi pi in doc ?>';
if( $result eq $expected)
{ print "ok 3\n"; }
else
{ print "not ok 3\n";
warn "expected: $expected\nfound : $result\n";
}
$result='';
$t= XML::Twig->new( pi => 'process',
twig_roots => { '?pi' => sub { $result= $_->target . "/" . $_->data; },
elt => sub { },
});
$t->parse( q{<?pi pi in doc ?><doc id="doc"><elt/></doc>});
$expected= 'pi/pi in doc ';
if( $result eq $expected)
{ print "ok 4\n"; }
else
{ print "not ok 4\n";
warn "expected: /$expected/\nfound : /$result/\n";
}
exit 0;

76
t/test_pos.t Executable file
View File

@ -0,0 +1,76 @@
#!/usr/bin/perl -w
use strict;
use Carp;
$|=1;
# test for the various conditions in navigation methods
use XML::Twig;
my $t= XML::Twig->new;
$t->parse(
'<doc id="doc">
<elt1 id="elt1_1">an element</elt1>
<elt1 id="elt1_2">an element</elt1>
<elt1 id="elt1_3">an element</elt1>
<elt2 id="elt2_1">an element</elt2>
<elt1 id="elt1_4">an element</elt1>
<elt2 id="elt2_2">an element</elt2>
<elt1 id="elt1_5">an element</elt1>
</doc>');
my @data=<DATA>;
my @data_without_comments= grep { !m{^\s*(#.*)?$} } @data;
my @test= map { s{\#.*$}{}; $_ } @data_without_comments;
#my @test= map { s{#.*$}{}; $_ } grep { !m{^\s*(#.*)?$} } <DATA>;
my $nb_test= @test;
print "1..$nb_test\n";
my $i=1;
foreach my $test (@test)
{ my( $id, $exp, $expected_pos)= split /\t+/, $test;
chomp $expected_pos;
$exp= '' if( $exp eq '_');
test( $i++, $id, $exp, $expected_pos);
}
sub test
{ my( $i, $id, $exp, $expected_pos)= @_;
my $elt= $t->elt_id( $id);
my $pos= $elt->pos( $exp);
if( $pos == $expected_pos)
{ print "ok $i\n"; }
else
{ print "not ok $i\n";
my $filter= $exp ? " filter: $exp" : '';
warn "test $i: $id $filter - expected $expected_pos, actual $pos\n";
}
}
exit 0;
__DATA__
#id exp expected
doc _ 1
doc elt1 0
doc toto 0
elt1_1 _ 1
elt1_1 elt1 1
elt1_1 toto 0
elt1_2 _ 2
elt1_2 elt1 2
elt1_2 toto 0
elt2_1 _ 4
elt2_1 elt1 0
elt2_1 elt2 1
elt2_1 toto 0
elt2_2 _ 6
elt2_2 elt1 0
elt2_2 elt2 2
elt2_2 toto 0

45
t/test_safe_encode.t Executable file
View File

@ -0,0 +1,45 @@
#!/usr/bin/perl -w
use strict;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
use XML::Twig;
my $DEBUG=0;
print "1..8\n";
if( $] >= 5.006) { eval "use utf8;"; }
# suitable for perl 5.6.*
my $doc=q{<doc><élément att="été">été</élément></doc>};
(my $safe_xml_doc= $doc)=~ s{é}{&#233;}g;
(my $safe_hex_doc= $doc)=~ s{é}{&#xe9;}g;
(my $text_safe_xml_doc= $doc)=~ s{été}{&#233;t&233;}g;
(my $text_safe_hex_doc= $doc)=~ s{é}{&#xe9;t&xe9;}g;
is( XML::Twig->new( output_filter => 'safe')->parse( $doc)->sprint, $safe_xml_doc, "output_filter => 'safe'");
is( XML::Twig->new( output_filter => 'safe_hex')->parse( $doc)->sprint, $safe_hex_doc, "output_filter => 'safe_hex'");
is( XML::Twig->new( output_text_filter => 'safe')->parse( $doc)->sprint, $safe_xml_doc, "output_text_filter => 'safe'");
is( XML::Twig->new( output_text_filter => 'safe_hex')->parse( $doc)->sprint, $safe_hex_doc, "output_text_filter => 'safe_hex'");
# suitable for 5.8.* and above (you can't have utf-8 hash keys before that)
if( $] < 5.008)
{ skip( 4 => "cannot process utf-8 attribute names with a perl before 5.8"); }
else
{
my $doc='<doc><élément atté="été">été</élément></doc>';
(my $safe_xml_doc= $doc)=~ s{é}{&#233;}g;
(my $safe_hex_doc= $doc)=~ s{é}{&#xe9;}g;
(my $text_safe_xml_doc= $doc)=~ s{été}{&#233;t&233;}g;
(my $text_safe_hex_doc= $doc)=~ s{é}{&#xe9;t&xe9;}g;
is( XML::Twig->new( output_filter => 'safe')->parse( $doc)->sprint, $safe_xml_doc, "output_filter => 'safe'");
is( XML::Twig->new( output_filter => 'safe_hex')->parse( $doc)->sprint, $safe_hex_doc, "output_filter => 'safe_hex'");
is( XML::Twig->new( output_text_filter => 'safe')->parse( $doc)->sprint, $safe_xml_doc, "output_text_filter => 'safe'");
is( XML::Twig->new( output_text_filter => 'safe_hex')->parse( $doc)->sprint, $safe_hex_doc, "output_text_filter => 'safe_hex'");
}

128
t/test_simplify.t Executable file
View File

@ -0,0 +1,128 @@
#!/usr/bin/perl -w
use strict;
use XML::Twig;
foreach my $module ( qw( XML::Simple Test::More Data::Dumper ) ) # add YAML if using Dump() below.
{ if( eval "require $module")
{ import $module; }
else
{ print "1..1\nok 1\n";
warn "skipping: $module is not installed\n";
exit;
}
}
if( $XML::Simple::VERSION < 2.09)
{ print "1..1\nok 1\n";
warn "skipping: need XML::Simple 2.09 or above\n";
exit;
}
undef $XML::Simple::PREFERRED_PARSER;
$XML::Simple::PREFERRED_PARSER= 'XML::Parser';
$/="\n\n";
my @doc= <DATA>;
my @options= ( { },
{ content_key => 'foo' },
{ group_tags => { templates => 'template'} },
{ group_tags => { dirs => 'dir', templates => 'template'} },
{ forcearray => 1 },
{ forcearray => [ qw(server) ] },
{ noattr => 1, },
{ noattr => 0, },
{ content_key => 'mycontent' },
{ content_key => '-mycontent' },
{ var_attr => 'var' },
{ var_attr => 'var', var_regexp => qr/\$\{?(\w+)\}?/ },
{ variables => { var => 'foo' } },
{ keyattr => [ qw(name)] },
{ keyattr => [ 'name' ] },
{ keyattr => [ qw(foo bar)] },
{ keyattr => {server => 'name' } },
{ keyattr => {server => '+name' } },
{ keyattr => {server => '-name' } },
{ normalize_space => 1 },
{ normalise_space => 2 },
{ group_tags => { f1_ar => 'f1' } },
{ group_tags => { f1_ar => 'f1', f2_ar => 'f2'} },
);
plan( tests => @options * @doc);
$SIG{__WARN__} = sub { };
foreach my $doc (@doc)
{ foreach my $options (@options)
{ (my $options_text= Dumper( $options))=~ s{\s*\n\s*}{ }g;
$options_text=~ s{^\$VAR1 = }{};
my( $options_twig, $options_simple)= UNIVERSAL::isa( $options, 'ARRAY') ?
@$options : ($options, $options);
my $t = XML::Twig->new->parse( $doc);
my $twig = $t->root->simplify( %$options_twig);
my $doc_name = $t->root->att( 'doc');
delete $options_simple->{var_regexp};
my $simple = XMLin( $doc, %$options_simple);
my $res=is_deeply( $twig, $simple, "doc: $doc_name - options: $options_text" ); #. Dump( {twig => $twig, simple => $simple}));
#exit unless( $res);
}
}
exit 0;
__DATA__
<config doc="XML::Simple example" logdir="/var/log/foo/" debugfile="/tmp/foo.debug">
<server name="sahara" osname="solaris" osversion="2.6">
<address>10.0.0.101</address>
<address>10.0.1.101</address>
</server>
<server name="gobi" osname="irix" osversion="6.5">
<address>10.0.0.102</address>
</server>
<server name="kalahari" osname="linux" osversion="2.0.34">
<address>10.0.0.103</address>
<address>10.0.1.103</address>
</server>
</config>
<config doc="example from XML::Twig" host="laptop.xmltwig.org">
<server>localhost</server>
<dirs>
<dir name="base">/home/mrodrigu/standards</dir>
<dir name="tools">${base}/tools</dir>
</dirs>
<templates>
<template name="std_def">std_def.templ</template>
<template name="dummy">dummy</template>
</templates>
</config>
<doc doc="simple example with variables"><var var="var">foo</var><string>var is ${var}</string></doc>
<doc doc=" val with spaces ">
<item name="n1">text with spaces </item>
<item name="n2 "> text with spaces</item>
<item name=" n3 ">text with spaces</item>
<item name="n 4 "> text with spaces
</item>
</doc>
<doc doc="minimal">
<f1_ar><f1>f1 1</f1><f1>f1 2</f1></f1_ar>
<f2_ar><f2>f2 1</f2><f2>f2 2</f2></f2_ar>
</doc>
<doc doc="empty elements test">
<section><elt><![CDATA[something]]></elt></section>
<section><elt><![CDATA[0]]></elt></section>
<section><elt><![CDATA[]]></elt></section>
<section><elt/></section>
<section><elt>something</elt></section>
<section><elt>0</elt></section>
<section><elt></elt></section>
</doc>

72
t/test_spaces.t Executable file
View File

@ -0,0 +1,72 @@
#!/usr/bin/perl -w
use strict;
use XML::Twig;
$/="\n\n";
print "1..3\n";
my $twig=XML::Twig->new( keep_spaces_in => [ 'e']);
test( $twig, 1);
$twig=XML::Twig->new( keep_spaces_in => [ 'e', 'sub1']);
test( $twig, 2);
$twig=XML::Twig->new( keep_spaces => 1);
test( $twig, 3);
sub test
{ my( $twig, $test_nb)= @_;
my $doc= <DATA>; chomp $doc;
my $expected_res= <DATA>; chomp $expected_res;
$twig->parse( $doc);
my $res= $twig->sprint;
$res=~ s/\n+$//;
if( $res eq $expected_res)
{ print "ok $test_nb\n"; }
else
{ print "not ok $test_nb\n";
warn " expected: \n$expected_res\n result: \n$res\n";
}
}
exit 0;
__DATA__
<!DOCTYPE e SYSTEM "dummy.dtd">
<e> &c;b</e>
<!DOCTYPE e SYSTEM "dummy.dtd">
<e> &c;b</e>
<!DOCTYPE e SYSTEM "dummy.dtd">
<e><sub1> &c;b</sub1>
<sub1>
&c;
</sub1>
</e>
<!DOCTYPE e SYSTEM "dummy.dtd">
<e><sub1> &c;b</sub1>
<sub1>
&c;
</sub1>
</e>
<!DOCTYPE e SYSTEM "dummy.dtd">
<e><sub1> &c;b</sub1>
<sub1>
&c;
</sub1>
</e>
<!DOCTYPE e SYSTEM "dummy.dtd">
<e><sub1> &c;b</sub1>
<sub1>
&c;
</sub1>
</e>

335
t/test_twig_roots.t Executable file
View File

@ -0,0 +1,335 @@
#!/usr/bin/perl -w
use strict;
#use diagnostics;
use XML::Twig;
$|=1;
my $TMAX=12; # do not forget to update!
print "1..$TMAX\n";
$/= "\n\n";
my $t= XML::Twig->new( twig_roots => { },
twig_print_outside_roots => \*RESULT,
error_context => 1,
);
test_twig( $t, 1);
$t= XML::Twig->new( twig_roots => { elt2 => sub { } },
twig_print_outside_roots => \*RESULT,
error_context => 1,
);
test_twig( $t, 2);
$t= XML::Twig->new( twig_roots => { elt3 => sub { } },
twig_print_outside_roots => \*RESULT,
error_context => 1,
);
test_twig( $t, 3);
$t= XML::Twig->new( twig_roots => { },
twig_print_outside_roots => \*RESULT,
error_context => 1,
);
test_twig( $t, 4);
$t= XML::Twig->new( twig_roots => { elt2 => sub { } },
twig_print_outside_roots => \*RESULT,
error_context => 1,
);
test_twig( $t, 5);
$t= XML::Twig->new( twig_roots => { elt3 => sub { } },
twig_print_outside_roots => \*RESULT,
error_context => 1,
);
test_twig( $t, 6);
$t= XML::Twig->new( twig_roots => { },
twig_print_outside_roots => \*RESULT,
error_context => 1,
);
test_twig( $t, 7);
$t= XML::Twig->new( twig_roots => { elt2 => sub { } },
twig_print_outside_roots => \*RESULT,
error_context => 1,
);
test_twig( $t, 8);
$t= XML::Twig->new( twig_roots => { elt3 => sub { } },
twig_print_outside_roots => \*RESULT,
error_context => 1,
);
test_twig( $t, 9);
$t= XML::Twig->new( twig_roots => { elt => sub { print RESULT "elt handler called on ", $_->gi, "\n"; }, },
start_tag_handlers => { doc => sub { print RESULT "start tag handler called on ", $_->gi, "\n"; }, },
end_tag_handlers => { doc => sub { print RESULT "end tag handler called on $_[1]\n"; }, },
);
test_twig( $t, 10);
# test with doc root as root
$t= XML::Twig->new( twig_roots => { doc => sub { $_->print( \*RESULT); } });
test_twig( $t, 11);
# test with elt as root
$t= XML::Twig->new( twig_roots => { elt => sub { $_->print( \*RESULT); } });
test_twig( $t, 12);
exit 0;
sub test_twig
{ my( $t, $test_nb)= @_;
my $doc= read_doc();
my $expected_result= read_expected_result();
my $result_file= "test_twig_roots.res1";
open( RESULT, ">$result_file") or die "cannot create $result_file: $!";
$t->parse( $doc);
check_result( $result_file, $test_nb, $expected_result);
close RESULT;
}
sub check_result
{ my( $result_file, $test_no, $expected_result)= @_;
# now check result
my $result= read_result( $result_file);
if( $result eq $expected_result)
{ print "ok $test_no\n"; }
else
{ print "not ok $test_no\n";
print STDERR "\ntest $test_no:\n",
"expected: \n$expected_result\n",
"real: \n$result\n";
}
}
{ my $last_doc;
my $buffered_result;
sub read_doc
{ local $/="\n\n";
my $doc= <DATA>;
# if the data starts with #doc then it's a doc, otherwise use the previous one
if( $doc=~ /^\s*#\s*doc/)
{ $doc= clean_data( $doc);
$last_doc= $doc;
$buffered_result='';
return $doc;
}
else
{ $buffered_result= clean_data( $doc);
return $last_doc;
}
}
sub read_expected_result
{ if( $buffered_result)
{ return $buffered_result; }
else
{ local $/="\n\n";
my $expected_result= <DATA>;
$expected_result= clean_data( $expected_result);
return $expected_result;
}
}
}
sub clean_data
{ my $data= shift;
$data=~ s{^\s*#.*\n}{}m; # get rid of comments
$data=~ s{\s*$}{}s; # remove trailing spaces (and \n)
$data=~ s{(^|\n)\s*(\n|$)}{}g; # remove empty lines
return $data;
}
sub read_result
{ my $file= shift;
local $/="\n";
open( RESULT, "<$file") or die "cannot read $file: $!";
my @result= grep {m/\S/} <RESULT>;
my $result= join( '', @result);
$result=~ s{(^|\n)\s*(\n|$)}{}g; # remove empty lines
close RESULT;
unlink $file;
return $result;
}
__DATA__
# doc 1
<?xml version="1.0"?>
<!DOCTYPE doc SYSTEM "t/dummy.dtd">
<doc>
<!-- a comment -->
<elt> text <subelt> subelt text</subelt></elt>
<?pi a pi?>
<elt>another elt text</elt>
<elt2>an other type of element</elt2>
<elt3>
<!-- a comment -->
<subelt> text of subelt</subelt>
</elt3>
</doc>
# expected_res 1
<?xml version="1.0"?>
<!DOCTYPE doc SYSTEM "t/dummy.dtd">
<doc>
<!-- a comment -->
<elt> text <subelt> subelt text</subelt></elt>
<?pi a pi?>
<elt>another elt text</elt>
<elt2>an other type of element</elt2>
<elt3>
<!-- a comment -->
<subelt> text of subelt</subelt>
</elt3>
</doc>
# expected_res 2
<?xml version="1.0"?>
<!DOCTYPE doc SYSTEM "t/dummy.dtd">
<doc>
<!-- a comment -->
<elt> text <subelt> subelt text</subelt></elt>
<?pi a pi?>
<elt>another elt text</elt>
<elt3>
<!-- a comment -->
<subelt> text of subelt</subelt>
</elt3>
</doc>
# expected_res 3
<?xml version="1.0"?>
<!DOCTYPE doc SYSTEM "t/dummy.dtd">
<doc>
<!-- a comment -->
<elt> text <subelt> subelt text</subelt></elt>
<?pi a pi?>
<elt>another elt text</elt>
<elt2>an other type of element</elt2>
</doc>
# doc 2
<?xml version="1.0"?>
<doc>
<!-- a comment -->
<elt> text <subelt> subelt text</subelt></elt>
<?pi a pi?>
<elt>another elt text</elt>
<elt2>an other type of element</elt2>
<elt3>
<!-- a comment -->
<subelt> text of subelt</subelt>
</elt3>
</doc>
# expected_res 4
<?xml version="1.0"?>
<doc>
<!-- a comment -->
<elt> text <subelt> subelt text</subelt></elt>
<?pi a pi?>
<elt>another elt text</elt>
<elt2>an other type of element</elt2>
<elt3>
<!-- a comment -->
<subelt> text of subelt</subelt>
</elt3>
</doc>
# expected_res 5
<?xml version="1.0"?>
<doc>
<!-- a comment -->
<elt> text <subelt> subelt text</subelt></elt>
<?pi a pi?>
<elt>another elt text</elt>
<elt3>
<!-- a comment -->
<subelt> text of subelt</subelt>
</elt3>
</doc>
# expected_res 6
<?xml version="1.0"?>
<doc>
<!-- a comment -->
<elt> text <subelt> subelt text</subelt></elt>
<?pi a pi?>
<elt>another elt text</elt>
<elt2>an other type of element</elt2>
</doc>
# doc 3
<doc>
<!-- a comment -->
<elt> text <subelt> subelt text</subelt></elt>
<?pi a pi?>
<elt>another elt text</elt>
<elt2>an other type of element</elt2>
<elt3>
<!-- a comment -->
<subelt> text of subelt</subelt>
</elt3>
</doc>
# expected_res 7
<doc>
<!-- a comment -->
<elt> text <subelt> subelt text</subelt></elt>
<?pi a pi?>
<elt>another elt text</elt>
<elt2>an other type of element</elt2>
<elt3>
<!-- a comment -->
<subelt> text of subelt</subelt>
</elt3>
</doc>
# expected_res 8
<doc>
<!-- a comment -->
<elt> text <subelt> subelt text</subelt></elt>
<?pi a pi?>
<elt>another elt text</elt>
<elt3>
<!-- a comment -->
<subelt> text of subelt</subelt>
</elt3>
</doc>
# expected_res 9
<doc>
<!-- a comment -->
<elt> text <subelt> subelt text</subelt></elt>
<?pi a pi?>
<elt>another elt text</elt>
<elt2>an other type of element</elt2>
</doc>
# doc 4
<doc>
<elt/>
</doc>
# expected_res 10
start tag handler called on doc
elt handler called on elt
end tag handler called on doc
# expected_res 11
<doc><elt/></doc>
# expected_res 12
<elt/>

78
t/test_unique_xpath.t Executable file
View File

@ -0,0 +1,78 @@
#!/usr/bin/perl -w
use strict;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
use XML::Twig;
print "1..65\n";
my $t= XML::Twig->new->parse( \*DATA);
foreach my $c ($t->descendants( 'c'))
{ is( $c->xpath, $c->text, "xpath");
is( $t->findvalue( $c->text), $c->text, "findvalue (>0)");
}
foreach my $d ($t->descendants( 'd'))
{ is( $t->findvalue( $d->text), $d->text, "findvalue (<0)"); }
foreach( 1..4)
{ is( $_, $t->root->first_child( "[$_]")->att( 'pos'), "first_child[$_]");
is( 5-$_, $t->root->first_child( "[-$_]")->att( 'pos'), "first_child[-$_]");
is( $_, $t->root->first_child( "b[$_]")->att( 'pos'), "first_child b[$_]");
is( 5-$_, $t->root->first_child( "b[-$_]")->att( 'pos'), "first_child b[-$_]");
}
my $e= $t->get_xpath( '/a/b[-1]/e', 0);
foreach( 1..4)
{ is( $_, $e->first_child( "f[$_]")->att( 'fpos'), "first_child f[$_]");
is( 5-$_, $e->first_child( "f[-$_]")->att( 'fpos'), "first_child f[-$_]");
is( $_, $e->first_child( "g[$_]")->att( 'gpos'), "first_child g[$_]");
is( 5-$_, $e->first_child( "g[-$_]")->att( 'gpos'), "first_child g[-$_]");
}
foreach( 1..8)
{ is( $_, $e->first_child( "[$_]")->att( 'pos'), "first_child [$_]");
is( 9-$_, $e->first_child( "[-$_]")->att( 'pos'), "first_child [-$_]");
}
exit 0;
__DATA__
<a>
<b pos="1">
<c>/a/b[1]/c[1]</c>
<c>/a/b[1]/c[2]</c>
<d>/a/b[-4]/d[-2]</d>
<d>/a/b[-4]/d[-1]</d>
</b>
<b pos="2">
<c>/a/b[2]/c[1]</c>
<d>/a/b[-3]/d[-2]</d>
<d>/a/b[-3]/d[-1]</d>
<bar>tata</bar>
<c>/a/b[2]/c[2]</c>
</b>
<b pos="3">
<c>/a/b[3]/c</c>
</b>
<b pos="4">
<baz>titi</baz>
<c>/a/b[4]/c</c>
<d>/a/b[4]/d[-1]</d>
<foobar>tutu</foobar>
<e>
<f pos="1" fpos="1"/>
<g pos="2" gpos="1"/>
<f pos="3" fpos="2"/>
<f pos="4" fpos="3"/>
<g pos="5" gpos="2"/>
<f pos="6" fpos="4"/>
<g pos="7" gpos="3"/>
<g pos="8" gpos="4"/>
</e>
</b>
</a>

42
t/test_variables.t Executable file
View File

@ -0,0 +1,42 @@
#!/usr/bin/perl -w
use strict;
use XML::Twig;
$|=1;
print "1..6\n";
#warn "\n\n### warnings are normal here ###\n\n";
my $t= XML::Twig->new->parse( \*DATA);
# intercept warnings
$SIG{__WARN__} = sub { print STDERR @_ if( $_[0]=~ /^test/); };
my $s= $t->simplify( var_attr => 'var', variables => { 'v2' => 'elt2'});
if( $s->{elt2} eq 'elt using elt1') { print "ok 1\n" }
else { print "not ok 1\n"; warn "test 1: /$s->{elt2}/ instead of 'elt using elt1'\n"; }
if( $s->{elt3} eq 'elt using elt1') { print "ok 2\n" }
else { print "not ok 2\n"; warn "test 2: /$s->{elt3}/ instead of 'elt using elt1'\n"; }
if( $s->{elt4} eq 'elt using elt2') { print "ok 3\n"; warn "\n"; }
else { print "not ok 3\n"; warn "test 3: /$s->{elt4}/ instead of 'elt using elt2'\n"; }
if( $s->{elt5}->{att1} eq 'att with elt1') { print "ok 4\n" }
else { print "not ok 4\n"; warn "test 4: /$s->{elt5}->{att1}/ instead of 'att with elt1'\n"; }
$s= $t->simplify( variables => { 'v2' => 'elt2'});
if( $s->{elt2} eq 'elt using $v1') { print "ok 5\n" }
else { print "not ok 5\n"; warn "test 5: /$s->{elt2}/ instead of 'elt using \$v1'\n"; }
if( $s->{elt4} eq 'elt using elt2') { print "ok 6\n" }
else { print "not ok 6\n"; warn "test 6: /$s->{elt4}/ instead of 'elt using elt2'\n"; }
exit 0;
__DATA__
<doc>
<elt1 var="v1">elt1</elt1>
<elt2>elt using $v1</elt2>
<elt3>elt using ${v1}</elt3>
<elt4>elt using $v2</elt4>
<elt5 att1="att with $v1"/>
</doc>

91
t/test_with_lwp.t Executable file
View File

@ -0,0 +1,91 @@
#!/usr/bin/perl -w
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
$|=1;
use XML::Twig;
eval { require LWP; };
if( $@) { import LWP; print "1..1\nok 1\n"; warn "skipping, LWP not available\n"; exit }
# skip on Win32, it looks like we have a problem there (named pipes?)
if( ($^O eq "MSWin32") && ($]<5.008) ) { print "1..1\nok 1\n"; warn "skipping, *parseurl methods not available on Windows with perl < 5.8.0\n"; exit }
if( perl_io_layer_used())
{ print "1..1\nok 1\n";
warn "cannot test parseurl when UTF8 perIO layer used (due to PERL_UNICODE or -C option used)\n";
exit;
}
my $TMAX=13;
chdir 't';
print "1..$TMAX\n";
{ my $t= XML::Twig->new->parseurl( 'file:test_with_lwp.xml', LWP::UserAgent->new);
is( $t->sprint, '<doc><elt>text</elt></doc>', "parseurl");
}
{
my $t= XML::Twig->new->parseurl( 'file:test_with_lwp.xml');
is( $t->sprint, '<doc><elt>text</elt></doc>', "parseurl");
}
{
my $t= XML::Twig->new->safe_parseurl( 'file:test_with_lwp.xml');
is( $t->sprint, '<doc><elt>text</elt></doc>', "parseurl");
}
{
warn "\n\n### warning is normal here ###\n\n";
my $t=0;
if ($^O ne 'VMS')
{ # On VMS we get '%SYSTEM-F-ABORT, abort' and an exit when a file does not exist
# Behaviour is probably different on VMS due to it not having 'fork' to do the
# LWP::UserAgent request and (safe) parse of that request not happening in a child process.
$t = XML::Twig->new->safe_parseurl( 'file:test_with_lwp_no_file.xml');
ok( !$t, "no file");
matches( $@, '^\s*(no element found|Ran out of memory for input buffer)', "no file, error message");
}
else
{ skip( 2 => "running on VMS, cannot test error message for non-existing file"); }
}
{
my $t= XML::Twig->new->safe_parseurl( 'file:test_with_lwp_not_wf.xml');
ok( !$t, "not well-formed");
matches( $@, '^\s*mismatched tag', "not well-formed, error message");
}
{
my $t= XML::Twig->new->parsefile( 'test_with_lwp.xml');
is( $t->sprint, '<doc><elt>text</elt></doc>', "parseurl");
}
{
my $t= XML::Twig->new->safe_parsefile( 'test_with_lwp.xml');
is( $t->sprint, '<doc><elt>text</elt></doc>', "parseurl");
}
{
my $t= XML::Twig->new->safe_parsefile( 'test_with_lwp_no_file.xml');
ok( !$t, "no file");
matches( $@, '^\s*Couldn', "no file, error message");
}
{
my $t= XML::Twig->new->safe_parsefile( 'test_with_lwp_not_wf.xml');
ok( !$t, "not well-formed");
matches( $@, '^\s*mismatched tag', "not well-formed, error message");
}
exit 0;

3
t/test_with_lwp.xml Normal file
View File

@ -0,0 +1,3 @@
<doc>
<elt>text</elt>
</doc>

3
t/test_with_lwp_not_wf.xml Normal file
View File

@ -0,0 +1,3 @@
<doc>
<elt>text<elt>
</doc>

107
t/test_wrapped.t Executable file
View File

@ -0,0 +1,107 @@
#!/usr/bin/perl -w
use strict;
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
$|=1;
my $DEBUG=0;
use XML::Twig;
my $TMAX=13;
print "1..$TMAX\n";
unless( XML::Twig::_use( 'Text::Wrap')) { print "1..1\nok 1\n"; warn "skipping: Text::Wrap not available\n"; exit; }
while( my $doc= get_doc())
{ my $result= XML::Twig->nparse( pretty_print => 'wrapped', $doc)->sprint;
my $expected= get_doc();
foreach ($result, $expected) { s{ }{.}g; }
is( $result, $expected, '');
}
XML::Twig::Elt->set_wrap(0);
is( XML::Twig::Elt->set_wrap(1), 0, "set_wrap - 1");
is( XML::Twig::Elt->set_wrap(1), 1, "set_wrap - 2");
is( XML::Twig::Elt->set_wrap(0), 1, "set_wrap - 3");
is( XML::Twig::Elt->set_wrap(0), 0, "set_wrap - 4");
is( XML::Twig::Elt::set_wrap(1), 0, "set_wrap - 5");
is( XML::Twig::Elt::set_wrap(1), 1, "set_wrap - 6");
is( XML::Twig::Elt::set_wrap(0), 1, "set_wrap - 7");
is( XML::Twig::Elt::set_wrap(0), 0, "set_wrap - 8");
sub get_doc
{ local $/="\n\n";
my $doc= <DATA>;
if( $doc)
{ $doc=~ s{\n\n}{\n};
$doc=~ s/\{([^}]*)\}/$1/eeg;
}
return $doc;
}
__DATA__
<doc><elt>{"foo" x 40}</elt></doc>
<doc>
<elt>foofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoo
foofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoo</elt>
</doc>
<doc><elt>{"foo" x 80}</elt></doc>
<doc>
<elt>foofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoo
foofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofo
ofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoof
oofoofoofoofoofoofoofoofoofoofoo</elt>
</doc>
<doc><section><elt>{"foo" x 40}</elt></section></doc>
<doc>
<section>
<elt>foofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoof
oofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoo</elt>
</section>
</doc>
<doc>
<elt att="foo">{"foo " x 40}</elt>
<elt att="bar">{"bar " x 40}</elt>
</doc>
<doc>
<elt att="foo">foo foo foo foo foo foo foo foo foo foo foo foo foo foo
foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo
foo foo foo foo foo foo foo foo </elt>
<elt att="bar">bar bar bar bar bar bar bar bar bar bar bar bar bar bar
bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar
bar bar bar bar bar bar bar bar </elt>
</doc>
<doc>
<elt att="foo">{"foo " x 40}{ "aaa" x 60}{ "foo "x20 }</elt>
<elt att="bar">{"bar " x 40}</elt>
</doc>
<doc>
<elt att="foo">foo foo foo foo foo foo foo foo foo foo foo foo foo foo
foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo
foo foo foo foo foo foo foo foo
aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaafoo foo foo foo foo foo foo foo
foo foo foo foo foo foo foo foo foo foo foo foo </elt>
<elt att="bar">bar bar bar bar bar bar bar bar bar bar bar bar bar bar
bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar
bar bar bar bar bar bar bar bar </elt>
</doc>

167
t/test_xml_split.t Executable file
View File

@ -0,0 +1,167 @@
#!/usr/bin/perl -w
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
use Config;
my $devnull = File::Spec->devnull;
my $DEBUG=0;
my $extra_flags= $Devel::Cover::VERSION ? '-MDevel::Cover -Ilib' : '-Ilib';
# be cautious: run this only on systems I have tested it on
my %os_ok=( linux => 1, solaris => 1, darwin => 1, MSWin32 => 1);
if( !$os_ok{$^O}) { print "1..1\nok 1\n"; warn "skipping, test runs only on some OSs\n"; exit; }
if( $] < 5.006) { print "1..1\nok 1\n"; warn "skipping, xml_merge runs only on perl 5.6 and later\n"; exit; }
print "1..59\n";
my $perl= $Config{perlpath};
if ($^O ne 'VMS') { $perl .= $Config{_exe} unless $perl =~ m/$Config{_exe}$/i; }
$perl.= " $extra_flags";
my $xml_split = File::Spec->catfile( "tools", "xml_split", "xml_split");
my $xml_merge = File::Spec->catfile( "tools", "xml_merge", "xml_merge");
my $xml_pp = File::Spec->catfile( "tools", "xml_pp", "xml_pp");
sys_ok( "$perl -c $xml_split", "xml_split compilation");
sys_ok( "$perl -c $xml_merge", "xml_merge compilation");
my $test_dir = File::Spec->catfile( "t", "test_xml_split");
my $test_file = File::Spec->catfile( "t", "test_xml_split.xml");
my $base_nb; # global, managed by test_split_merge
test_split_merge( $test_file, "", "" );
test_split_merge( $test_file, "-i", "-i" );
test_split_merge( $test_file, "-c elt1", "" );
test_split_merge( $test_file, "-i -c elt1", "-i" );
test_split_merge( $test_file, "-c elt2", "" );
test_split_merge( $test_file, "-i -c elt2", "-i" );
test_split_merge( $test_file, "-s 1K", "" );
test_split_merge( $test_file, "-i -s 1K", "-i" );
test_split_merge( $test_file, "-l 1", "" );
test_split_merge( $test_file, "-i -l 1", "-i" );
test_split_merge( $test_file, "-g 5", "" );
test_split_merge( $test_file, "-i -g 5", "-i" );
$test_file=File::Spec->catfile( "t", "test_xml_split_entities.xml");
test_split_merge( $test_file, "", "" );
test_split_merge( $test_file, "-g 2", "" );
test_split_merge( $test_file, "-l 1", "" );
$test_file=File::Spec->catfile( "t", "test_xml_split_w_decl.xml");
test_split_merge( $test_file, "", "" );
test_split_merge( $test_file, "-c elt1", "" );
test_split_merge( $test_file, "-g 2", "" );
test_split_merge( $test_file, "-l 1", "" );
test_split_merge( $test_file, "-s 1K", "" );
test_split_merge( $test_file, "-g 2 -l 2", "" );
if( _use( 'IO::CaptureOutput'))
{ test_error( $xml_split => "-h", 'xml_split ');
test_error( $xml_merge => "-h", 'xml_merge ');
test_out( $xml_split => "-V", 'xml_split ');
test_out( $xml_merge => "-V", 'xml_merge ');
if( `pod2text -h` && $^O !~ m{^MS})
{ test_out( $xml_split => "-m", 'NAME\s*xml_split ');
test_out( $xml_merge => "-m", 'NAME\s*xml_merge ');
test_out( $xml_pp => "-h", 'NAME\s*xml_pp ');
}
else
{ skip( 3, "pod2text not found in the path, cannot use -m oprion for xml_split and xml_merge"); }
test_error( $xml_split => "-c foo -s 1K", 'cannot use -c and -s at the same time');
test_error( $xml_split => "-g 100 -s 1K", 'cannot use -g and -s at the same time');
test_error( $xml_split => "-g 100 -c fo", 'cannot use -g and -c at the same time');
test_error( $xml_split => "-s 1Kc", 'invalid size');
test_error( $xml_pp => "-s --style", 'usage:');
test_error( $xml_pp => "-i --in_place", 'usage:');
test_error( $xml_pp => "-e utf8 --encoding utf8", 'usage:');
test_error( $xml_pp => "-l --load", 'usage:');
}
else
{ skip( 15, 'need IO::CaptureOutput to test tool options'); }
sub test_error
{ my( $command, $options, $expected)= @_;
my( $stdout, $stderr, $success, $exit_code) = IO::CaptureOutput::capture_exec( "$perl $command $options test_xml_split.xml");
matches( $stderr, qr/$expected/, "$command $options");
}
sub test_out
{ my( $command, $options, $expected)= @_;
my( $stdout, $stderr, $success, $exit_code) = IO::CaptureOutput::capture_exec( "$perl $command $options test_xml_split.xml");
matches( $stdout, qr/^$expected/, "$command $options");
}
sub test_split_merge
{ my( $file, $split_opts, $merge_opts)= @_;
$split_opts ||= '';
$merge_opts ||= '';
$base_nb++;
my $verbifdebug = $DEBUG ? '-v' : '';
my $expected_base= File::Spec->catfile( "$test_dir", "test_xml_split_expected-$base_nb");
my $base= File::Spec->catfile( "$test_dir", "test_xml_split-$base_nb");
systemq( "$perl $xml_split $verbifdebug -b $base $split_opts $file");
ok( same_files( $expected_base, $base), "xml_split $split_opts $test_file");
my $merged= "$base.xml";
system "$perl $xml_merge $verbifdebug -o $merged $merge_opts $base-00.xml";
system "$perl $xml_pp -i $merged";
ok( same_file( $merged, $file), "xml_merge $merge_opts $test_file ($merged $base-00.xml");
unlink( glob( "$base*")) unless( $DEBUG);
}
sub same_files
{ my( $expected_base, $base)= @_;
my $nb="00";
while( -f "$base-$nb.xml")
{ my( $real, $expected)= ( "$base-$nb.xml", "$expected_base-$nb.xml");
if( ! -z $expected) { _use( 'File::Copy'); copy( $real, $expected); }
unless( same_file( $expected, $real))
{ warn " $expected and $real are different";
if( $DEBUG) { warn `diff $expected, $real`; }
return 0;
}
$nb++;
}
return 1;
}
sub same_file
{ my( $file1, $file2)= @_;
my $eq= slurp_mod( $file1) eq slurp_mod( $file2);
if( $DEBUG && ! $eq) { system "diff $file1 $file2\n"; }
return $eq;
}
# slurp and remove spaces and _expected from the file
sub slurp_mod
{ my( $file)= @_;
local undef $/;
open( FHSLURP, "<$file") or return "$file not found:$!";
my $content=<FHSLURP>;
$content=~ s{\s}{}g;
$content=~ s{_expected}{}g;
return $content;
}
sub systemq
{ if( !$DEBUG)
{ system "$_[0] 1>$devnull 2>$devnull"; }
else
{ warn "$_[0]\n";
system $_[0];
}
}

17
t/test_xml_split.xml Normal file
View File

@ -0,0 +1,17 @@
<doc>
<elt1>elt1 content 1</elt1>
<elt1>elt1 content 2</elt1>
<elt1>elt1 content 3</elt1>
<elt2>
<elt1>elt1 content 4</elt1>
<elt1>elt1 content 5</elt1>
</elt2>
<elt2>
<elt2>
<elt1>elt1 content 6</elt1>
<elt1>elt1 content 7</elt1>
</elt2>
<elt1>elt1 content 8</elt1>
<elt1>elt1 content 9</elt1>
</elt2>
</doc>

7
t/test_xml_split/test_xml_split_expected-1-00.xml Normal file
View File

@ -0,0 +1,7 @@
<doc>
<?merge subdocs = 0 :t/test_xml_split/test_xml_split-1-01.xml?>
<?merge subdocs = 0 :t/test_xml_split/test_xml_split-1-02.xml?>
<?merge subdocs = 0 :t/test_xml_split/test_xml_split-1-03.xml?>
<?merge subdocs = 0 :t/test_xml_split/test_xml_split-1-04.xml?>
<?merge subdocs = 0 :t/test_xml_split/test_xml_split-1-05.xml?>
</doc>

Some files were not shown because too many files have changed in this diff Show More