1package DJabberd::XMLParser; 2use strict; 3use vars qw($VERSION @ISA); 4$VERSION = '1.00'; 5use XML::LibXML; 6use XML::SAX::Base; 7use base qw(XML::SAX::Base); 8use Carp; 9use Scalar::Util (); 10 11our $instance_count = 0; 12 13sub new { 14 my ($class, @params) = @_; 15 my $self = $class->SUPER::new(@params); 16 17 # libxml mode: 18 if (1) { 19 my $libxml = XML::LibXML->new({ 20 no_network => 1, 21 load_ext_dtd => 0, 22 expand_entities => 0, 23 expand_xinclude => 0, 24 ext_ent_handler => sub { 25 # my ($sys_id, $pub_id) = @_; 26 # warn "Received external entity: $sys_id:$pub_id"; 27 ""; 28 }, 29 }); 30 $libxml->set_handler($self); 31 $self->{LibParser} = $libxml; 32 33 # this buys nothing but less noise when using Devel::Cycle: 34 # make it a developer option? 35 # Scalar::Util::weaken($self->{LibParser}); 36 37 $libxml->init_push; 38 $self->{CONTEXT} = $libxml->{CONTEXT}; 39 } 40 41 # expat mode: 42 if (0) { 43 #use XML::SAX::Expat::Incremental; 44 my $parser = XML::SAX::Expat::Incremental->new(Handler => $self); 45 $self->{expat} = $parser; 46 $parser->parse_start; 47 } 48 49 $instance_count++; 50 return $self; 51} 52 53*parse_more = \&parse_chunk; 54sub parse_chunk { 55 #my ($self, $chunk) = @_; 56 57 # 'push' (wrapper around _push) without context also works, 58 # but _push (xs) is enough faster... 59 $_[0]->{LibParser}->_push($_[0]->{CONTEXT}, 60 $_[1]); 61 62 # expat version: 63 # $_[0]->{expat}->parse_more($_[1]); 64} 65 66sub parse_chunk_scalarref { 67 #my ($self, $chunk) = @_; 68 69 # 'push' (wrapper around _push) without context also works, 70 # but _push (xs) is enough faster... 71 $_[0]->{LibParser}->_push($_[0]->{CONTEXT}, 72 ${$_[1]}); 73 74 # expat version: 75 # $_[0]->{expat}->parse_more(${$_[1]}); 76} 77 78sub finish_push { 79 my $self = shift; 80 return 1 unless $self->{LibParser}; 81 my $parser = delete $self->{LibParser}; 82 eval { $parser->finish_push }; 83 delete $self->{Handler}; 84 delete $self->{CONTEXT}; 85 return 1; 86} 87 88sub DESTROY { 89 my $self = shift; 90 $instance_count--; 91 bless $self, 'XML::SAX::Base'; 92} 93