tag#id syntax accepted in handlers and navigation

mirod · May 4, 2013 · e56d4bf · e56d4bf
1 parent 5e29c0b
commit e56d4bf
Show file tree

Hide file tree

Showing 6 changed files with 211 additions and 114 deletions.
diff --git a/Twig_pm.slow b/Twig_pm.slow
diff --git a/t/test_3_36.t b/t/test_3_36.t
@@ -313,8 +313,7 @@ my $NS= 'xmlns="http://www.w3.org/1999/xhtml"';
      );
 }
 
-{ 
-  XML::Twig::_set_debug_handler( 3);
+{ XML::Twig::_set_debug_handler(3);
   XML::Twig->new( twig_handlers => { 'foo[@a="bar"]' => sub { $_->att( 'a')++; } });
   my $expected=<<'EXPECTED';
 

diff --git a/t/test_3_44.t b/t/test_3_44.t
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 
 use XML::Twig;
-use Test::More tests => 82;
+use Test::More tests => 86;
 
 
 { my $e= XML::Twig::Elt->new( 'foo');
@@ -256,15 +256,20 @@ SKIP: {
 
 { 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;
-  XML::Twig->parse( twig_handlers => { 'e#i' => sub { $r.= $_->text}}, $d);
+  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='';
-  XML::Twig->parse( twig_handlers => { 'e#iii' => sub { $r.= $_->text}}, $d);
+  $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='';
-  XML::Twig->parse( twig_handlers => { 'e#i2' => sub { $r.= $_->text}}, $d);
+  $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='';
-  XML::Twig->parse( twig_handlers => { '*#ff' => sub { $r.= $_->text}}, $d);
+  $t= XML::Twig->parse( twig_handlers => { '*#ff' => sub { $r.= $_->text}}, $d);
   is( $r, 'f1', '*# in twig handlers');
+  is( $t->findvalue( '//*#ff'), 'f1', 'findvalue with *#');
 }
diff --git a/t/test_errors.t b/t/test_errors.t
@@ -114,7 +114,7 @@ my $init_warn= $SIG{__WARN__};
   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/')
+  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)");
     }
@@ -333,8 +333,8 @@ my $init_warn= $SIG{__WARN__};
 }
 
 { my $r=  XML::Twig->parse( '<doc/>')->root;
-  eval { $r->find_nodes( '//foo/following::') };
-  matches( $@, "error in xpath expression", 'error in xpath expression');
+  eval { $r->find_nodes( '//foo/1following::') };
+  matches( $@, "error in xpath expression", 'error in xpath expression //foo/following::');
 }
 
 exit 0;

diff --git a/t/test_memory.t b/t/test_memory.t
@@ -29,56 +29,92 @@ if( !XML::Twig::_weakrefs())
     exit;
   }
 
+my $long_test= $ARGV[0] && $ARGV[0] eq '-L';
 
-my $TMAX=3;
+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 $xml= qq{<doc>} . qq{<p>lorem ipsus whatever (clever latin stuff)</p>} x 100 .qq{</doc>};
-  XML::Twig->new->parse( $xml);
-  my $before= mem_size();
-  for (1..10) { XML::Twig->new->parse( $xml); mem_size(); }
-  my $after= mem_size();
-  if( $after - $before > 1000)
-     { warn "possible memory leak parsing xml ($after > $before)"; $warn++; } 
-  ok(1, "testing memory leaks for xml parsing");
-}
-
-{ if( XML::Twig::_use( 'HTML::TreeBuilder', 3.13))
-    { my $html= qq{<html><body>} . qq{<p>lorem ipsus whatever (clever latin stuff)</p>} x 500 .qq{</body></html>};
-      XML::Twig->new->parse_html( $html);
-      my $before= mem_size();
-      for (1..5) { XML::Twig->new->parse_html( $html); mem_size(); }
-      my $after= mem_size();
-      if( $after - $before > 1000)
-         { warn "possible memory leak parsing html ($after > $before)"; $warn++; } 
-      ok(1, "testing memory leaks for html parsing");
+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)";
     }
-  else
-    { skip( 1, "need HTML::TreeBuilder 3.13+"); }
-}
 
-{ if( XML::Twig::_use( 'HTML::Tidy'))
-    { my $html= qq{<html><body>} . qq{<p>lorem ipsus whatever (clever latin stuff)</p>} x 500 .qq{</body></html>};
-      XML::Twig->new( use_tidy => 1)->parse_html( $html);
+    { my $xml= qq{<doc>$paras</doc>};
+      XML::Twig->new->parse( $xml);
       my $before= mem_size();
-      for (1..5) { XML::Twig->new( use_tidy => 1)->parse_html( $html); 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 > 1000)
-         { warn "possible memory leak parsing html ($after > $before)"; $warn++; } 
-      ok(1, "testing memory leaks for html parsing using HTML::Tidy");
+      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++;
     }
-  else
-    { skip( 1, "need HTML::Tidy"); }
-}
-
-
+
+    { 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 exemple. 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>;
@@ -87,4 +123,39 @@ sub mem_size
     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;
+  }
diff --git a/test_all b/test_all
@@ -1,11 +1,10 @@
 #!/usr/bin/perl
 
-system "make clean && perl Makefile.PL -n && make && make test";
-system "./cover_twig " if $ARGV[0] eq '-c';
-
 # missing: 'perl-5.6.2',  'threaded-perl-5.12.3'
-foreach my $perl ( 'perl-5.17.5', 'perl-5.16.1', 'perl-5.14.3', 'perl-5.12.5', 'perl-5.10.1', 'perl-5.8.9', 'threaded-perl-5.12.3')
-  { system "perlbrew switch $perl && make clean && perl Makefile.PL -n && make && make test"; 
-    system "./cover_twig -i" if $ARGV[0] eq '-c';
+foreach my $perl ( 'perl-5.17.5', 'perl-5.16.2', 'perl-5.14.3', 'perl-5.12.5', 'perl-5.10.1', 'perl-5.8.9', 'threaded-perl-5.12.3')
+  { warn "testing $perl\n";
+    my $system=  "make clean; perlbrew switch $perl; perl Makefile.PL -n && make && make test;";
+    $system  .= "./cover_twig -i" if $ARGV[0] eq '-c';
+    system $system;
   }