t/test_errors.t - metacpan.org

#!/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=119; 
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::');
}

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;
  }
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)