t/tools.pm
t/zz_dump_config.t
t/test_kwalitee.t
-META.yml Module meta-data (added by MakeMaker)
+t/test_meta_json.t
+t/test_3_41.t
+META.yml Module YAML meta-data (added by MakeMaker)
META.json Module JSON meta-data (added by MakeMaker)
"Michel Rodriguez <mirod@cpan.org>"
],
"dynamic_config" : 1,
- "generated_by" : "ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.112150",
+ "generated_by" : "ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.120921",
"license" : [
"perl_5"
],
"prereqs" : {
"build" : {
"requires" : {
- "ExtUtils::MakeMaker" : 0
+ "ExtUtils::MakeMaker" : "0"
}
},
"configure" : {
"requires" : {
- "ExtUtils::MakeMaker" : 0
+ "ExtUtils::MakeMaker" : "0"
}
},
"runtime" : {
"url" : "http://github.com/mirod/xmltwig"
}
},
- "version" : "3.40"
+ "version" : "3.41"
}
configure_requires:
ExtUtils::MakeMaker: 0
dynamic_config: 1
-generated_by: 'ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.112150'
+generated_by: 'ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.120921'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
XML::Parser: 2.23
resources:
repository: http://github.com/mirod/xmltwig
-version: 3.40
+version: 3.41
" '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/)
+ if( prompt("Do you want to install '$program' ($description)?", $default) =~ /^y/i)
{ push(@programs, $program); }
}
}
-WriteMakefile1(
+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 => {
#},
);
-sub WriteMakefile1 { #Written by Alexandr Ciornii, version 0.21. Added by eumm-upgrade.
+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;
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;
+ my $meta= $json->decode( slurp( $MYJSON));
+ $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} @_;
+ }
my $REG_TAG_IN_PREDICATE= $REG_NAME . q{(?=\s*(?i:and\b|or\b|\]|$))};
+# keys in the context stack, chosen not to interfere with att names, even private (#-prefixed) ones
+my $ST_TAG = '##tag';
+my $ST_ELT = '##elt';
+my $ST_NS = '##ns' ;
# used in the handler trigger code
my $REG_NAKED_PREDICATE= qq{((?:"[^"]*"|'[^']*'|$REG_STRING_ARG|$REG_FUNCTION|\@$REG_NAME_W|$REG_MATCH\\s*$REG_REGEXP|[\\s\\d><=!()+.-]|(?i:and)|(?i:or)|$REG_TAG_IN_PREDICATE)*)};
BEGIN
{
-$VERSION = '3.40';
+$VERSION = '3.41';
use XML::Parser;
my $needVersion = '2.23';
|| _set_xpath_handler ( $handlers, $path, $handler, $prev_handler)
|| croak "unrecognized expression in handler: '$whole_path'";
+ # this both takes care of the simple (gi) handlers and store
+ # the handler code reference for other handlers
$handlers->{handlers}->{string}->{$path}= $handler;
}
if( $cpath) { croak "unrecognized expression in handler: '$whole_path'"; }
- # this both takes care of the simple (gi) handlers and store
- # the handler code reference for other handlers
-
return $prev_handler;
}
{ my( $handlers, $path, $handler, $prev_handler)= @_;
if( $path =~ m{^ \s* level \s* \( \s* ([0-9]+) \s* \) \s* $}ox )
{ my $level= $1;
- my $sub= sub { my( $stack)= @_; return( ($stack->[-1]->{_tag} !~ m{^#}) && (scalar @$stack == $level + 1) ) };
+ my $sub= sub { my( $stack)= @_; return( ($stack->[-1]->{$ST_TAG} !~ m{^#}) && (scalar @$stack == $level + 1) ) };
my $handler_data= { tag=> '*', score => { type => $LEVEL_TRIGGER}, trigger => $sub,
path => $path, handler => $handler, test_on_text => 0
};
# if the expression was a regexp it is now a string (it was stringified when it became a hash key)
if( $path=~ m{^\(\?([\^xism]*)(?:-[\^xism]*)?:(.*)\)$})
{ my $regexp= qr/(?$1:$2)/; # convert it back into a regexp
- my $sub= sub { my( $stack)= @_; return( $stack->[-1]->{_tag} =~ $regexp ) };
+ my $sub= sub { my( $stack)= @_; return( $stack->[-1]->{$ST_TAG} =~ $regexp ) };
my $handler_data= { tag=> '*', score => { type => $REGEXP_TRIGGER} , trigger => $sub,
path => $path, handler => $handler, test_on_text => 0
};
{ my( $full_tag)= @_;
my( $tag, $class)= $css_sel ? $full_tag=~ m{^(.*?)(?:\.([^.]*))?$} : ($full_tag, undef);
- my $tag_cond= $tag && $tag ne '*' ? qq#(\$elt->{_tag} eq "$tag")# : '';
+ my $tag_cond= $tag && $tag ne '*' ? qq#(\$elt->{'$ST_TAG'} eq "$tag")# : '';
my $class_cond= defined $class ? qq#(\$elt->{class}=~ m{(^| )$class( |\$)})# : '';
my $full_cond= join( ' && ', grep { $_ } ( $tag_cond, $class_cond));
if( $func || $str_regexp || $str_test_num || $str_test_alpha ) { $flag->{test_on_text}= 1; }
if( defined $str) { $token }
- elsif( $tag) { qq{(\$elt->{_elt} && \$elt->{_elt}->has_child( '$tag'))} }
- elsif( $att) { $att=~ m{^#} ? qq{ (\$elt->{_elt} && \$elt->{_elt}->{att}->{'$att'})}
+ elsif( $tag) { qq{(\$elt->{'$ST_ELT'} && \$elt->{'$ST_ELT'}->has_child( '$tag'))} }
+ elsif( $att) { $att=~ m{^#} ? qq{ (\$elt->{'$ST_ELT'} && \$elt->{'$ST_ELT'}->{att}->{'$att'})}
: qq{\$elt->{'$att'}}
}
# for some reason Devel::Cover flags the following lines as not tested. They are though.
- elsif( $bare_att) { $bare_att=~ m{^#} ? qq{(\$elt->{_elt} && defined(\$elt->{_elt}->{att}->{'$bare_att'}))}
+ elsif( $bare_att) { $bare_att=~ m{^#} ? qq{(\$elt->{'$ST_ELT'} && defined(\$elt->{'$ST_ELT'}->{att}->{'$bare_att'}))}
: qq{defined( \$elt->{'$bare_att'})}
}
elsif( $num_test && ($num_test eq '=') ) { "==" } # others tests are unchanged
elsif( $alpha_test) { $PERL_ALPHA_TEST{$alpha_test} }
elsif( $func && $func=~ m{^string})
- { "\$elt->{_elt}->text"; }
+ { "\$elt->{'$ST_ELT'}->text"; }
elsif( $str_regexp && $str_regexp =~ m{string\(\s*($REG_NAME)\s*\)\s*($REG_MATCH)\s*($REG_REGEXP)})
- { "defined( _first_n { \$_->text $2 $3 } 1, \$elt->{_elt}->_children( '$1'))"; }
+ { "defined( _first_n { \$_->text $2 $3 } 1, \$elt->{'$ST_ELT'}->_children( '$1'))"; }
elsif( $str_test_alpha && $str_test_alpha =~ m{string\(\s*($REG_NAME)\s*\)\s*($REG_COMP)\s*($REG_STRING)})
{ my( $tag, $op, $str)= ($1, $2, $3);
$str=~ s{(?<=.)'(?=.)}{\\'}g; # escape a quote within the string
$str=~ s{^"}{'};
$str=~ s{"$}{'};
- "defined( _first_n { \$_->text $PERL_ALPHA_TEST{$op} $str } 1, \$elt->{_elt}->children( '$tag'))"; }
+ "defined( _first_n { \$_->text $PERL_ALPHA_TEST{$op} $str } 1, \$elt->{'$ST_ELT'}->children( '$tag'))"; }
elsif( $str_test_num && $str_test_num =~ m{string\(\s*($REG_NAME)\s*\)\s*($REG_COMP)\s*($REG_NUMBER)})
{ my $test= ($2 eq '=') ? '==' : $2;
- "defined( _first_n { \$_->text $test $3 } 1, \$elt->{_elt}->children( '$1'))";
+ "defined( _first_n { \$_->text $test $3 } 1, \$elt->{'$ST_ELT'}->children( '$1'))";
}
elsif( $and_or) { $score->{tests}++; $and_or eq 'and' ? '&&' : '||' ; }
else { $token; }
delete $t->{twig_stored_space};
delete $t->{twig_entity_list};
$t->root->delete if( $t->root);
- delete $t->{root};
+ delete $t->{twig_root};
return $t;
}
else
{ my $current_gi= $XML::Twig::index2gi[$current->{'gi'}];
- if( $t->{twig_discard_all_spaces}) { $t->{twig_stored_spaces}=''; return; }
-
- if( ! defined( $t->{twig_space_policy}->{$current_gi}))
- { $t->{twig_space_policy}->{$current_gi}= _space_policy( $t, $current_gi); }
+ if( ! $t->{twig_discard_all_spaces})
+ { if( ! defined( $t->{twig_space_policy}->{$current_gi}))
+ { $t->{twig_space_policy}->{$current_gi}= _space_policy( $t, $current_gi); }
- if( $t->{twig_space_policy}->{$current_gi} || ($t->{twig_stored_spaces}!~ m{\n})
- || $t->{twig_preserve_space}
- )
- { _insert_pcdata( $t, $t->{twig_stored_spaces} ); }
+ if( $t->{twig_space_policy}->{$current_gi} || ($t->{twig_stored_spaces}!~ m{\n})
+ || $t->{twig_preserve_space}
+ )
+ { _insert_pcdata( $t, $t->{twig_stored_spaces} ); }
+ }
$t->{twig_stored_spaces}='';
}
foreach my $att (@att) { $att= $filter->($att); }
}
- if( $t->{twig_map_xmlns}) { _replace_ns( $t, \$gi, \@att); }
+ my $ns_decl;
+ if( $t->{twig_map_xmlns})
+ { $ns_decl= _replace_ns( $t, \$gi, \@att); }
my $elt= $t->{twig_elt_class}->new( $gi);
$elt->set_atts( @att);
-
+
# now we can store the tag and atts
- my $context= { _tag => $gi, _elt => $elt, @att};
- if( $weakrefs) { weaken( $context->{_elt}); }
+ my $context= { $ST_TAG => $gi, $ST_ELT => $elt, @att};
+ $context->{$ST_NS}= $ns_decl if $ns_decl;
+ if( $weakrefs) { weaken( $context->{$ST_ELT}); }
push @{$t->{_twig_context_stack}}, $context;
delete $parent->{'twig_current'} if( $parent);
sub _replace_ns
{ my( $t, $gi, $atts)= @_;
+ my $decls;
foreach my $new_prefix ( $t->parser->new_ns_prefixes)
{ my $uri= $t->parser->expand_ns_prefix( $new_prefix);
# replace the prefix if it is mapped
+ $decls->{$new_prefix}= $uri;
if( !$t->{twig_keep_original_prefix} && (my $mapped_prefix= $t->{twig_map_xmlns}->{$uri}))
{ $new_prefix= $mapped_prefix; }
# now put the namespace declaration back in the element
else { $att_name=1; }
}
}
- return;
+ return $decls;
}
return;
}
+# returns the uri bound to a prefix in the original document
+# only works in a handler
+# can be used to deal with xsi:type attributes
+sub original_uri
+ { my( $t, $prefix)= @_;
+ my $ST_NS = '##ns' ;
+ foreach my $ns (map { $_->{$ST_NS} if $_->{$ST_NS} } reverse @{$t->{_twig_context_stack}})
+ { return $ns->{$prefix} || next; }
+ return;
+ }
+
+
sub _fill_default_atts
{ my( $t, $gi, $atts)= @_;
my $dtd= $t->{twig_dtd};
sub set_root
{ my( $t, $elt)= @_;
$t->{twig_root}= $elt;
- $elt->{twig}= $t;
- if( $weakrefs) { weaken( $elt->{twig}); }
+ if( $elt)
+ { $elt->{twig}= $t;
+ if( $weakrefs) { weaken( $elt->{twig}); }
+ }
return $t;
}
my $cdata= $elt->{cdata};
$elt->_set_cdata( $cdata);
- push @{$t->{_twig_context_stack}}, { _tag => $CDATA };
+ push @{$t->{_twig_context_stack}}, { $ST_TAG => $CDATA };
if( $t->{twig_handlers})
{ # look for handlers
push @args, @{$t->{twig_autoflush_data}->{args}} if( $t->{twig_autoflush_data}->{args});
$t->flush( @args);
delete $t->{twig_autoflush_data};
- $t->root->delete;
+ $t->root->delete if $t->root;
}
# tries to clean-up (probably not very well at the moment)
my $string= $t->prolog( %args) # xml declaration and doctype
. $t->_leading_cpi( %args) # leading comments and pi's in 'process' mode
- . $t->{twig_root}->sprint
+ . ( ($t->{twig_root} && $t->{twig_root}->sprint) || '')
. $t->_trailing_cpi # trailing comments and pi's (elements, in 'process' mode)
. $t->_trailing_cpi_text # trailing comments and pi's (in 'keep' mode)
;
my $fh= $t->{twig_output_fh} || select() || \*STDOUT;
+ my $ns_decl;
unless( $p->depth == 0)
- { if( $t->{twig_map_xmlns}) { _replace_ns( $t, \$gi, \@_); }
+ { if( $t->{twig_map_xmlns}) { $ns_decl= _replace_ns( $t, \$gi, \@_); }
}
- push @{$t->{_twig_context_stack}}, { _tag => $gi, @_};
+ my $context= { $ST_TAG => $gi, @_};
+ $context->{$ST_NS}= $ns_decl if $ns_decl;
+ push @{$t->{_twig_context_stack}}, $context;
my %att= @_;
if( _handler( $t, $t->{twig_roots}, $gi))
return;
}
-#sub _dump_stack { my( $stack)= @_; return join( ":", map { $_->{_tag} } @$stack); }
+#sub _dump_stack { my( $stack)= @_; return join( ":", map { $_->{$ST_TAG} } @$stack); }
sub ignore
{ my( $t, $elt, $action)= @_;
{ my( $t, $elt)= @_;
my $level=1;
foreach my $elt_in_stack ( @{$t->{_twig_context_stack}} )
- { if( $elt_in_stack->{_elt} && ($elt == $elt_in_stack->{_elt})) { return $level }
+ { if( $elt_in_stack->{$ST_ELT} && ($elt == $elt_in_stack->{$ST_ELT})) { return $level }
$level++;
}
}
;
if( ! exists $map->{$prefix}) { $map->{$prefix}= $elt->{'att'}->{$att}; }
}
- $elt= $elt->{parent} || $elt->former_parent;
+ $elt= $elt->{parent} || ($elt->{former} && $elt->{former}->{parent});
}
return $map;
}
sub _root_through_cut
{ my $elt= shift;
- while( $elt->{parent} || $elt->former_parent) { $elt= $elt->{parent} || $elt->former_parent; }
+ while( $elt->{parent} || ($elt->{former} && $elt->{former}->{parent})) { $elt= $elt->{parent} || ($elt->{former} && $elt->{former}->{parent}); }
return $elt;
}
&& ( !%tags || $tags{$XML::Twig::index2gi[$elt->{'gi'}]})
)
{ return $elt->{'att'}->{$att}; }
- } while( $elt= $elt->{parent} || $elt->former_parent);
+ } while( $elt= $elt->{parent} || ($elt->{former} && $elt->{former}->{parent}));
return undef;
}
{ my $elt= shift;
my( $parent, $prev_sibling, $next_sibling, $last_elt);
- # you can't cut the root, sorry
- unless( $parent= $elt->{parent}) { return; }
+ $parent= $elt->{parent};
+ if( ! $parent)
+ { # are we cutting the root?
+ my $t= $elt->{twig};
+ if( $t && ! $t->{twig_parsing})
+ { delete $t->{twig_root};
+ delete $elt->{twig};
+ return $elt;
+ } # cutt`ing the root
+ else
+ { return; } # cutting an orphan, returning $elt would break backward compatibility
+ }
# save the old links, that'll make it easier for some loops
foreach my $link ( qw(parent prev_sibling next_sibling) )
if( (exists $elt->{'pcdata'}))
{ $dump .= "$indent|-PCDATA: '" . _short_text( $elt->{pcdata}, $short_text) . "'\n" }
elsif( (exists $elt->{'ent'}))
- { warn "here"; $dump .= "$indent|-ENTITY: '" . _short_text( $elt->{ent}, $short_text) . "'\n" }
+ { $dump .= "$indent|-ENTITY: '" . _short_text( $elt->{ent}, $short_text) . "'\n" }
elsif( (exists $elt->{'cdata'}))
{ $dump .= "$indent|-CDATA: '" . _short_text( $elt->{cdata}, $short_text) . "'\n" }
elsif( (exists $elt->{'comment'}))
<gr:circle cx="10" cy="90" r="20"/>
</doc>
+=item original_uri ($prefix)
+
+called within a handler, this will return the uri bound to the namespace prefix
+in the original document.
+
=item index ($arrayref or $hashref)
This option creates lists of specific elements during the parsing of the XML.
my $child= $parent->first_child( 'achild');
while( $child->{'att'}->{'cut'})
- { $child->cut; $child= $child->former_next_sibling; }
+ { $child->cut; $child= ($child->{former} && $child->{former}->{next_sibling}); }
=item former_prev_sibling
my $REG_TAG_IN_PREDICATE= $REG_NAME . q{(?=\s*(?i:and\b|or\b|\]|$))};
+# keys in the context stack, chosen not to interfere with att names, even private (#-prefixed) ones
+my $ST_TAG = '##tag';
+my $ST_ELT = '##elt';
+my $ST_NS = '##ns' ;
# used in the handler trigger code
my $REG_NAKED_PREDICATE= qq{((?:"[^"]*"|'[^']*'|$REG_STRING_ARG|$REG_FUNCTION|\@$REG_NAME_W|$REG_MATCH\\s*$REG_REGEXP|[\\s\\d><=!()+.-]|(?i:and)|(?i:or)|$REG_TAG_IN_PREDICATE)*)};
BEGIN
{
-$VERSION = '3.40';
+$VERSION = '3.41';
use XML::Parser;
my $needVersion = '2.23';
|| _set_xpath_handler ( $handlers, $path, $handler, $prev_handler)
|| croak "unrecognized expression in handler: '$whole_path'";
+ # this both takes care of the simple (gi) handlers and store
+ # the handler code reference for other handlers
$handlers->{handlers}->{string}->{$path}= $handler;
}
if( $cpath) { croak "unrecognized expression in handler: '$whole_path'"; }
- # this both takes care of the simple (gi) handlers and store
- # the handler code reference for other handlers
-
return $prev_handler;
}
{ my( $handlers, $path, $handler, $prev_handler)= @_;
if( $path =~ m{^ \s* level \s* \( \s* ([0-9]+) \s* \) \s* $}ox )
{ my $level= $1;
- my $sub= sub { my( $stack)= @_; return( ($stack->[-1]->{_tag} !~ m{^#}) && (scalar @$stack == $level + 1) ) };
+ my $sub= sub { my( $stack)= @_; return( ($stack->[-1]->{$ST_TAG} !~ m{^#}) && (scalar @$stack == $level + 1) ) };
my $handler_data= { tag=> '*', score => { type => $LEVEL_TRIGGER}, trigger => $sub,
path => $path, handler => $handler, test_on_text => 0
};
# if the expression was a regexp it is now a string (it was stringified when it became a hash key)
if( $path=~ m{^\(\?([\^xism]*)(?:-[\^xism]*)?:(.*)\)$})
{ my $regexp= qr/(?$1:$2)/; # convert it back into a regexp
- my $sub= sub { my( $stack)= @_; return( $stack->[-1]->{_tag} =~ $regexp ) };
+ my $sub= sub { my( $stack)= @_; return( $stack->[-1]->{$ST_TAG} =~ $regexp ) };
my $handler_data= { tag=> '*', score => { type => $REGEXP_TRIGGER} , trigger => $sub,
path => $path, handler => $handler, test_on_text => 0
};
{ my( $full_tag)= @_;
my( $tag, $class)= $css_sel ? $full_tag=~ m{^(.*?)(?:\.([^.]*))?$} : ($full_tag, undef);
- my $tag_cond= $tag && $tag ne '*' ? qq#(\$elt->{_tag} eq "$tag")# : '';
+ my $tag_cond= $tag && $tag ne '*' ? qq#(\$elt->{'$ST_TAG'} eq "$tag")# : '';
my $class_cond= defined $class ? qq#(\$elt->{class}=~ m{(^| )$class( |\$)})# : '';
my $full_cond= join( ' && ', grep { $_ } ( $tag_cond, $class_cond));
if( $func || $str_regexp || $str_test_num || $str_test_alpha ) { $flag->{test_on_text}= 1; }
if( defined $str) { $token }
- elsif( $tag) { qq{(\$elt->{_elt} && \$elt->{_elt}->has_child( '$tag'))} }
- elsif( $att) { $att=~ m{^#} ? qq{ (\$elt->{_elt} && \$elt->{_elt}->{att}->{'$att'})}
+ elsif( $tag) { qq{(\$elt->{'$ST_ELT'} && \$elt->{'$ST_ELT'}->has_child( '$tag'))} }
+ elsif( $att) { $att=~ m{^#} ? qq{ (\$elt->{'$ST_ELT'} && \$elt->{'$ST_ELT'}->{att}->{'$att'})}
: qq{\$elt->{'$att'}}
}
# for some reason Devel::Cover flags the following lines as not tested. They are though.
- elsif( $bare_att) { $bare_att=~ m{^#} ? qq{(\$elt->{_elt} && defined(\$elt->{_elt}->{att}->{'$bare_att'}))}
+ elsif( $bare_att) { $bare_att=~ m{^#} ? qq{(\$elt->{'$ST_ELT'} && defined(\$elt->{'$ST_ELT'}->{att}->{'$bare_att'}))}
: qq{defined( \$elt->{'$bare_att'})}
}
elsif( $num_test && ($num_test eq '=') ) { "==" } # others tests are unchanged
elsif( $alpha_test) { $PERL_ALPHA_TEST{$alpha_test} }
elsif( $func && $func=~ m{^string})
- { "\$elt->{_elt}->text"; }
+ { "\$elt->{'$ST_ELT'}->text"; }
elsif( $str_regexp && $str_regexp =~ m{string\(\s*($REG_NAME)\s*\)\s*($REG_MATCH)\s*($REG_REGEXP)})
- { "defined( _first_n { \$_->text $2 $3 } 1, \$elt->{_elt}->_children( '$1'))"; }
+ { "defined( _first_n { \$_->text $2 $3 } 1, \$elt->{'$ST_ELT'}->_children( '$1'))"; }
elsif( $str_test_alpha && $str_test_alpha =~ m{string\(\s*($REG_NAME)\s*\)\s*($REG_COMP)\s*($REG_STRING)})
{ my( $tag, $op, $str)= ($1, $2, $3);
$str=~ s{(?<=.)'(?=.)}{\\'}g; # escape a quote within the string
$str=~ s{^"}{'};
$str=~ s{"$}{'};
- "defined( _first_n { \$_->text $PERL_ALPHA_TEST{$op} $str } 1, \$elt->{_elt}->children( '$tag'))"; }
+ "defined( _first_n { \$_->text $PERL_ALPHA_TEST{$op} $str } 1, \$elt->{'$ST_ELT'}->children( '$tag'))"; }
elsif( $str_test_num && $str_test_num =~ m{string\(\s*($REG_NAME)\s*\)\s*($REG_COMP)\s*($REG_NUMBER)})
{ my $test= ($2 eq '=') ? '==' : $2;
- "defined( _first_n { \$_->text $test $3 } 1, \$elt->{_elt}->children( '$1'))";
+ "defined( _first_n { \$_->text $test $3 } 1, \$elt->{'$ST_ELT'}->children( '$1'))";
}
elsif( $and_or) { $score->{tests}++; $and_or eq 'and' ? '&&' : '||' ; }
else { $token; }
delete $t->{twig_stored_space};
delete $t->{twig_entity_list};
$t->root->delete if( $t->root);
- delete $t->{root};
+ delete $t->{twig_root};
return $t;
}
else
{ my $current_gi= $current->gi;
- if( $t->{twig_discard_all_spaces}) { $t->{twig_stored_spaces}=''; return; }
-
- if( ! defined( $t->{twig_space_policy}->{$current_gi}))
- { $t->{twig_space_policy}->{$current_gi}= _space_policy( $t, $current_gi); }
+ if( ! $t->{twig_discard_all_spaces})
+ { if( ! defined( $t->{twig_space_policy}->{$current_gi}))
+ { $t->{twig_space_policy}->{$current_gi}= _space_policy( $t, $current_gi); }
- if( $t->{twig_space_policy}->{$current_gi} || ($t->{twig_stored_spaces}!~ m{\n})
- || $t->{twig_preserve_space}
- )
- { _insert_pcdata( $t, $t->{twig_stored_spaces} ); }
+ if( $t->{twig_space_policy}->{$current_gi} || ($t->{twig_stored_spaces}!~ m{\n})
+ || $t->{twig_preserve_space}
+ )
+ { _insert_pcdata( $t, $t->{twig_stored_spaces} ); }
+ }
$t->{twig_stored_spaces}='';
}
foreach my $att (@att) { $att= $filter->($att); }
}
- if( $t->{twig_map_xmlns}) { _replace_ns( $t, \$gi, \@att); }
+ my $ns_decl;
+ if( $t->{twig_map_xmlns})
+ { $ns_decl= _replace_ns( $t, \$gi, \@att); }
my $elt= $t->{twig_elt_class}->new( $gi);
$elt->set_atts( @att);
-
+
# now we can store the tag and atts
- my $context= { _tag => $gi, _elt => $elt, @att};
- if( $weakrefs) { weaken( $context->{_elt}); }
+ my $context= { $ST_TAG => $gi, $ST_ELT => $elt, @att};
+ $context->{$ST_NS}= $ns_decl if $ns_decl;
+ if( $weakrefs) { weaken( $context->{$ST_ELT}); }
push @{$t->{_twig_context_stack}}, $context;
$parent->del_twig_current if( $parent);
sub _replace_ns
{ my( $t, $gi, $atts)= @_;
+ my $decls;
foreach my $new_prefix ( $t->parser->new_ns_prefixes)
{ my $uri= $t->parser->expand_ns_prefix( $new_prefix);
# replace the prefix if it is mapped
+ $decls->{$new_prefix}= $uri;
if( !$t->{twig_keep_original_prefix} && (my $mapped_prefix= $t->{twig_map_xmlns}->{$uri}))
{ $new_prefix= $mapped_prefix; }
# now put the namespace declaration back in the element
else { $att_name=1; }
}
}
- return;
+ return $decls;
}
return;
}
+# returns the uri bound to a prefix in the original document
+# only works in a handler
+# can be used to deal with xsi:type attributes
+sub original_uri
+ { my( $t, $prefix)= @_;
+ my $ST_NS = '##ns' ;
+ foreach my $ns (map { $_->{$ST_NS} if $_->{$ST_NS} } reverse @{$t->{_twig_context_stack}})
+ { return $ns->{$prefix} || next; }
+ return;
+ }
+
+
sub _fill_default_atts
{ my( $t, $gi, $atts)= @_;
my $dtd= $t->{twig_dtd};
sub set_root
{ my( $t, $elt)= @_;
$t->{twig_root}= $elt;
- $elt->{twig}= $t;
- if( $weakrefs) { weaken( $elt->{twig}); }
+ if( $elt)
+ { $elt->{twig}= $t;
+ if( $weakrefs) { weaken( $elt->{twig}); }
+ }
return $t;
}
my $cdata= $elt->cdata;
$elt->_set_cdata( $cdata);
- push @{$t->{_twig_context_stack}}, { _tag => $CDATA };
+ push @{$t->{_twig_context_stack}}, { $ST_TAG => $CDATA };
if( $t->{twig_handlers})
{ # look for handlers
push @args, @{$t->{twig_autoflush_data}->{args}} if( $t->{twig_autoflush_data}->{args});
$t->flush( @args);
delete $t->{twig_autoflush_data};
- $t->root->delete;
+ $t->root->delete if $t->root;
}
# tries to clean-up (probably not very well at the moment)
my $string= $t->prolog( %args) # xml declaration and doctype
. $t->_leading_cpi( %args) # leading comments and pi's in 'process' mode
- . $t->{twig_root}->sprint
+ . ( ($t->{twig_root} && $t->{twig_root}->sprint) || '')
. $t->_trailing_cpi # trailing comments and pi's (elements, in 'process' mode)
. $t->_trailing_cpi_text # trailing comments and pi's (in 'keep' mode)
;
my $fh= $t->{twig_output_fh} || select() || \*STDOUT;
+ my $ns_decl;
unless( $p->depth == 0)
- { if( $t->{twig_map_xmlns}) { _replace_ns( $t, \$gi, \@_); }
+ { if( $t->{twig_map_xmlns}) { $ns_decl= _replace_ns( $t, \$gi, \@_); }
}
- push @{$t->{_twig_context_stack}}, { _tag => $gi, @_};
+ my $context= { $ST_TAG => $gi, @_};
+ $context->{$ST_NS}= $ns_decl if $ns_decl;
+ push @{$t->{_twig_context_stack}}, $context;
my %att= @_;
if( _handler( $t, $t->{twig_roots}, $gi))
return;
}
-#sub _dump_stack { my( $stack)= @_; return join( ":", map { $_->{_tag} } @$stack); }
+#sub _dump_stack { my( $stack)= @_; return join( ":", map { $_->{$ST_TAG} } @$stack); }
sub ignore
{ my( $t, $elt, $action)= @_;
{ my( $t, $elt)= @_;
my $level=1;
foreach my $elt_in_stack ( @{$t->{_twig_context_stack}} )
- { if( $elt_in_stack->{_elt} && ($elt == $elt_in_stack->{_elt})) { return $level }
+ { if( $elt_in_stack->{$ST_ELT} && ($elt == $elt_in_stack->{$ST_ELT})) { return $level }
$level++;
}
}
{ my $elt= shift;
my( $parent, $prev_sibling, $next_sibling, $last_elt);
- # you can't cut the root, sorry
- unless( $parent= $elt->_parent) { return; }
+ $parent= $elt->_parent;
+ if( ! $parent)
+ { # are we cutting the root?
+ my $t= $elt->{twig};
+ if( $t && ! $t->{twig_parsing})
+ { delete $t->{twig_root};
+ delete $elt->{twig};
+ return $elt;
+ } # cutt`ing the root
+ else
+ { return; } # cutting an orphan, returning $elt would break backward compatibility
+ }
# save the old links, that'll make it easier for some loops
foreach my $link ( qw(parent prev_sibling next_sibling) )
if( $elt->is_pcdata)
{ $dump .= "$indent|-PCDATA: '" . _short_text( $elt->pcdata, $short_text) . "'\n" }
elsif( $elt->is_ent)
- { warn "here"; $dump .= "$indent|-ENTITY: '" . _short_text( $elt->ent, $short_text) . "'\n" }
+ { $dump .= "$indent|-ENTITY: '" . _short_text( $elt->ent, $short_text) . "'\n" }
elsif( $elt->is_cdata)
{ $dump .= "$indent|-CDATA: '" . _short_text( $elt->cdata, $short_text) . "'\n" }
elsif( $elt->is_comment)
<gr:circle cx="10" cy="90" r="20"/>
</doc>
+=item original_uri ($prefix)
+
+called within a handler, this will return the uri bound to the namespace prefix
+in the original document.
+
=item index ($arrayref or $hashref)
This option creates lists of specific elements during the parsing of the XML.
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)); # set the field and mark as not empty
#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;
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>';
);
}
-{ XML::Twig::_set_debug_handler( 3);
+{
+ XML::Twig::_set_debug_handler( 3);
XML::Twig->new( twig_handlers => { 'foo[@a="bar"]' => sub { $_->att( 'a')++; } });
- is( XML::Twig::_return_debug_handler(), q#
+ my $expected=<<'EXPECTED';
+
parsing path 'foo[@a="bar"]'
predicate is: '@a="bar"'
my @current_elts= (scalar @$stack);
my @new_current_elts;
my $elt;
-warn q{checking path 'foo\[\@a=\"bar\"\]'
+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;}
+ 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"'%;
+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";
+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
-#, 'handler content');
+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);
}
is( $t->first_elt( '*[@_a="2"]')->id, 'bar', 'navigation, attribute name starts with underscore');
}
-{ if( _use( 'LWP'))
+{ 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;
+ unlink $html_file;
}
else
- { skip( 1, "LWP not available, cannot test safe_parseurl_html"); }
+ { skip( 1, "LWP and/or HTML::TreeBuilder not available, cannot test safe_parseurl_html"); }
}
my $t= XML::Twig->new->parse( $well_formed);
is_like( $t->sprint, $well_formed, 'valid xhtml');
- my $th= XML::Twig->new->parse_html( $well_formed);
- is_like( $t->sprint, $well_formed, 'valid xhtml (parsed as html)');
+ 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');
- 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)');
}
--- /dev/null
+#!/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
+ }
+
+}
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&E">&ent3;</elt></doc>')
- { skip( 1, "option do_not_escape_amp_in_atts not available, no worries"); }
+ { 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"); }
use XML::Twig;
-my $TMAX=118;
+my $TMAX=119;
print "1..$TMAX\n";
my $error_file= File::Spec->catfile('t','test_errors.errors');
matches( $@, "cannot paste after an orphan element", 'paste after an orphan element' );
}
+{ my $r= XML::Twig->parse( '<doc/>')->root;
+ eval { $r->find_nodes( '//foo/following::') };
+ matches( $@, "error in xpath expression", 'error in xpath expression');
+}
+
exit 0;
sub can_check_for_pipes
--- /dev/null
+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();
use strict;
use Config;
+use Carp;
-my $DEBUG=0;
-if( grep { m{^-d$} } @ARGV) { $DEBUG=1; warn "debug!\n"; }
-if( grep /^-v$/, @ARGV) { $DEBUG= 1; }
+use vars qw/$TDEBUG $TFATAL/;
+
+BEGIN
+ {
+ if( grep { m{-[f]*[dv][f]*} } @ARGV) { $TDEBUG=1; warn "debug!\n"; }
+ if( grep { m{-[dv]*f[dv]*\b} } @ARGV) { $TFATAL= 1; warn "fatal!\n";}
+ }
{ my $test_nb;
BEGIN { $test_nb=0; }
if( ( !defined( $expected) && !defined( $got) ) || ($expected eq $got) )
{ print "ok $test_nb";
- print " $message" if( $DEBUG);
+ print " $message" if( $TDEBUG);
print "\n";
return 1;
}
{ warn "$message:\nexpected: '$expected'\ngot : '$got'\n"; }
else
{ warn "$message: expected '$expected', got '$got'\n"; }
+ croak if $TFATAL;
return 0;
}
}
if( $expected ne $got)
{ print "ok $test_nb";
- print " $message" if( $DEBUG);
+ print " $message" if( $TDEBUG);
print "\n";
return 1;
}
{ warn "$message:\ngot : '$got'\n"; }
else
{ warn "$message: got '$got'\n"; }
+ croak if $TFATAL;
return 0;
}
}
if( $got=~ /$expected_regexp/)
{ print "ok $test_nb";
- print " $message" if( $DEBUG);
+ print " $message" if( $TDEBUG);
print "\n";
return 1;
}
else { print "not ok $test_nb\n";
warn "$message: expected to match /$expected_regexp/, got '$got'\n";
+ croak if $TFATAL;
return 0;
}
}
if( $cond)
{ print "ok $test_nb";
- print " $message" if( $DEBUG);
+ print " $message" if( $TDEBUG);
print "\n";
return 1;
}
else
{ print "not ok $test_nb\n";
warn "$message: false\n";
+ croak if $TFATAL;
return 0;
}
}
if( !$cond)
{ print "ok $test_nb";
- print " $message" if( $DEBUG);
+ print " $message" if( $TDEBUG);
print "\n";
return 1;
}
else
{ print "not ok $test_nb\n";
warn "$message: true (should be false): '$cond'\n";
+ croak if $TFATAL;
return 0;
}
}
if( ! defined( $cond))
{ print "ok $test_nb";
- print "$message" if( $DEBUG);
+ print "$message" if( $TDEBUG);
print "\n";
return 1;
}
else
{ print "not ok $test_nb\n";
warn "$message is defined: '$cond'\n";
+ croak if $TFATAL;
return 0;
}
}
my $status= system join " ", @_, "2>$devnull";
if( !$status)
{ print "ok $test_nb";
- print " $message" if( $DEBUG);
+ print " $message" if( $TDEBUG);
print "\n";
}
else { print "not ok $test_nb\n"; warn "$message: $!\n"; }
my $status= system join " ", @_, "2>$devnull";
if( $status)
{ print "ok $test_nb";
- print " $message" if( $DEBUG);
+ print " $message" if( $TDEBUG);
print "\n";
}
else { print "not ok $test_nb\n"; warn "$message: $!\n"; }
if( clean_sp( $expected) eq clean_sp( $got))
{ print "ok $test_nb";
- print " $message" if( $DEBUG);
+ print " $message" if( $TDEBUG);
print "\n";
return 1;
}
{ warn "$message: expected '$expected', got '$got'\n"; }
warn "compact expected: ", clean_sp( $expected), "\n",
"compact got: ", clean_sp( $got), "\n";
+ croak if $TFATAL;
return 0;
}
}
}
for my $test ( ($test_nb + 1) .. ($test_nb + $nb_skip))
{ print "ok $test\n";
- warn "skipping $test ($message)\n" if( $DEBUG);
+ warn "skipping $test ($message)\n" if( $TDEBUG);
}
$test_nb= $test_nb + $nb_skip;
return 1;
my $mversion= ${"${module}::VERSION"};
$mversion=~ s{^\s*(\d+\.\d+).*}{$1}; # trim version numbers like 2.42_01
if( $mversion >= $version ) { return 1; }
- else { return 0; }
+ else { croak if $TFATAL; return 0; }
}
}
{ if( $] >= 5.008)
{ return eval '${^UNICODE} & 24'; } # in a eval to pass tests in 5.005
else
- { return 0; }
+ { croak if $TFATAL; return 0; }
}
# slurp and discard locale errors
projects / platform / upstream / perl-XML-Twig.git / commitdiff