diff options
Diffstat (limited to 't/astress.t')
| -rw-r--r-- | t/astress.t | 264 |
1 files changed, 264 insertions, 0 deletions
diff --git a/t/astress.t b/t/astress.t new file mode 100644 index 0000000..210760b --- /dev/null +++ b/t/astress.t @@ -0,0 +1,264 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +BEGIN {print "1..27\n";} +END {print "not ok 1\n" unless $loaded;} +use XML::Parser; +$loaded = 1; +print "ok 1\n"; + +######################### End of black magic. + +# Insert your test code below (better if it prints "ok 13" +# (correspondingly "not ok 13") depending on the success of chunk 13 +# of the test code): + +# Test 2 + + +my $parser = new XML::Parser(ProtocolEncoding => 'ISO-8859-1'); +if ($parser) +{ + print "ok 2\n"; +} +else +{ + print "not ok 2\n"; + exit; +} + +my @ndxstack; +my $indexok = 1; + +# Need this external entity + +open(ZOE, '>zoe.ent'); +print ZOE "'cute'"; +close(ZOE); + +# XML string for tests + +my $xmlstring =<<"End_of_XML;"; +<!DOCTYPE foo + [ + <!NOTATION bar PUBLIC "qrs"> + <!ENTITY zinger PUBLIC "xyz" "abc" NDATA bar> + <!ENTITY fran SYSTEM "fran-def"> + <!ENTITY zoe SYSTEM "zoe.ent"> + ]> +<foo> + First line in foo + <boom>Fran is &fran; and Zoe is &zoe;</boom> + <bar id="jack" stomp="jill"> + <?line-noise *&*&^&<< ?> + 1st line in bar + <blah> 2nd line in bar </blah> + 3rd line in bar <!-- Isn't this a doozy --> + </bar> + <zap ref="zing" /> + This, '\240', would be a bad character in UTF-8. +</foo> +End_of_XML; + +# Handlers +my @tests; +my $pos =''; + +sub ch +{ + my ($p, $str) = @_; + $tests[4]++; + $tests[5]++ if ($str =~ /2nd line/ and $p->in_element('blah')); + if ($p->in_element('boom')) + { + $tests[17]++ if $str =~ /pretty/; + $tests[18]++ if $str =~ /cute/; + } +} + +sub st +{ + my ($p, $el, %atts) = @_; + + $ndxstack[$p->depth] = $p->element_index; + $tests[6]++ if ($el eq 'bar' and $atts{stomp} eq 'jill'); + if ($el eq 'zap' and $atts{'ref'} eq 'zing') + { + $tests[7]++; + $p->default_current; + } + elsif ($el eq 'bar') { + $tests[22]++ if $p->recognized_string eq '<bar id="jack" stomp="jill">'; + } +} + +sub eh +{ + my ($p, $el) = @_; + $indexok = 0 unless $p->element_index == $ndxstack[$p->depth]; + if ($el eq 'zap') + { + $tests[8]++; + my @old = $p->setHandlers('Char', \&newch); + $tests[19]++ if $p->current_line == 17; + $tests[20]++ if $p->current_column == 20; + $tests[23]++ if ($old[0] eq 'Char' and $old[1] == \&ch); + } + if ($el eq 'boom') + { + $p->setHandlers('Default', \&dh); + } +} + +sub dh +{ + my ($p, $str) = @_; + if ($str =~ /doozy/) + { + $tests[9]++; + $pos = $p->position_in_context(1); + } + $tests[10]++ if $str =~ /^<zap/; +} + +sub pi +{ + my ($p, $tar, $data) = @_; + + $tests[11]++ if ($tar eq 'line-noise' and $data =~ /&\^&<</); +} + +sub note +{ + my ($p, $name, $base, $sysid, $pubid) = @_; + + $tests[12]++ if ($name eq 'bar' and $pubid eq 'qrs'); +} + +sub unp +{ + my ($p, $name, $base, $sysid, $pubid, $notation) = @_; + + $tests[13]++ if ($name eq 'zinger' and $pubid eq 'xyz' + and $sysid eq 'abc' and $notation eq 'bar'); +} + +sub newch +{ + my ($p, $str) = @_; + + if ($] < 5.007001) { + $tests[14]++ if $str =~ /'\302\240'/; + } + else { + $tests[14]++ if $str =~ /'\xa0'/; + } +} + +sub extent +{ + my ($p, $base, $sys, $pub) = @_; + + if ($sys eq 'fran-def') + { + $tests[15]++; + return 'pretty'; + } + elsif ($sys eq 'zoe.ent') + { + $tests[16]++; + + open(FOO, $sys) or die "Couldn't open $sys"; + return *FOO; + } +} + +eval { + $parser->setHandlers('Char' => \&ch, + 'Start' => \&st, + 'End' => \&eh, + 'Proc' => \&pi, + 'Notation' => \¬e, + 'Unparsed' => \&unp, + 'ExternEnt' => \&extent, + 'ExternEntFin' => sub {close(FOO);} + ); +}; + +if ($@) +{ + print "not ok 3\n"; + exit; +} + +print "ok 3\n"; + +# Test 4..20 +eval { + $parser->parsestring($xmlstring); +}; + +if ($@) +{ + print "Parse error:\n$@"; +} +else +{ + $tests[21]++; +} + +unlink('zoe.ent') if (-f 'zoe.ent'); + +for (4 .. 23) +{ + print "not " unless $tests[$_]; + print "ok $_\n"; +} + +$cmpstr =<< 'End_of_Cmp;'; + <blah> 2nd line in bar </blah> + 3rd line in bar <!-- Isn't this a doozy --> +===================^ + </bar> +End_of_Cmp; + +if ($cmpstr ne $pos) +{ + print "not "; +} +print "ok 24\n"; + +print "not " unless $indexok; +print "ok 25\n"; + + +# Test that memory leak through autovivifying symbol table entries is fixed. + +my $count = 0; +$parser = new XML::Parser( + Handlers => { + Start => sub { $count++ } + } +); + +$xmlstring = '<a><b>Sea</b></a>'; + +eval { + $parser->parsestring($xmlstring); +}; + +if($count != 2) { + print "not "; +} +print "ok 26\n"; + +if(defined(*{$xmlstring})) { + print "not "; +} +print "ok 27\n"; + |