source: perl/lib/XML/Stream/Parser.pm @ b6a253c

barnowl_perlaimdebianrelease-1.10release-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since b6a253c was 0ff8d110, checked in by Alejandro R. Sedeño <asedeno@mit.edu>, 17 years ago
Adding XML::Stream, Net::XMPP, and Net::Jabber to perl/lib/
  • Property mode set to 100644
File size: 14.1 KB
RevLine 
[0ff8d110]1##############################################################################
2#
3#  This library is free software; you can redistribute it and/or
4#  modify it under the terms of the GNU Library General Public
5#  License as published by the Free Software Foundation; either
6#  version 2 of the License, or (at your option) any later version.
7#
8#  This library is distributed in the hope that it will be useful,
9#  but WITHOUT ANY WARRANTY; without even the implied warranty of
10#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
11#  Library General Public License for more details.
12#
13#  You should have received a copy of the GNU Library General Public
14#  License along with this library; if not, write to the
15#  Free Software Foundation, Inc., 59 Temple Place - Suite 330,
16#  Boston, MA  02111-1307, USA.
17#
18#  Jabber
19#  Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/
20#
21##############################################################################
22
23package XML::Stream::Parser;
24
25=head1 NAME
26
27  XML::Stream::Parser - SAX XML Parser for XML Streams
28
29=head1 SYNOPSIS
30
31  Light weight XML parser that builds XML::Parser::Tree objects from the
32  incoming stream and passes them to a function to tell whoever is using
33  it that there are new packets.
34
35=head1 DESCRIPTION
36
37  This module provides a very light weight parser
38
39=head1 METHODS
40
41=head1 EXAMPLES
42
43=head1 AUTHOR
44
45By Ryan Eatmon in January of 2001 for http://jabber.org/
46
47=head1 COPYRIGHT
48
49This module is free software; you can redistribute it and/or modify
50it under the same terms as Perl itself.
51
52=cut
53
54use strict;
55use vars qw( $VERSION );
56
57$VERSION = "1.22";
58
59sub new
60{
61    my $self = { };
62
63    bless($self);
64
65    my %args;
66    while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
67
68    $self->{PARSING} = 0;
69    $self->{DOC} = 0;
70    $self->{XML} = "";
71    $self->{CNAME} = ();
72    $self->{CURR} = 0;
73
74    $args{nonblocking} = 0 unless exists($args{nonblocking});
75
76    $self->{NONBLOCKING} = delete($args{nonblocking});
77
78    $self->{DEBUGTIME} = 0;
79    $self->{DEBUGTIME} = $args{debugtime} if exists($args{debugtime});
80
81    $self->{DEBUGLEVEL} = 0;
82    $self->{DEBUGLEVEL} = $args{debuglevel} if exists($args{debuglevel});
83
84    $self->{DEBUGFILE} = "";
85
86    if (exists($args{debugfh}) && ($args{debugfh} ne ""))
87    {
88        $self->{DEBUGFILE} = $args{debugfh};
89        $self->{DEBUG} = 1;
90    }
91
92    if ((exists($args{debugfh}) && ($args{debugfh} eq "")) ||
93        (exists($args{debug}) && ($args{debug} ne "")))
94        {
95        $self->{DEBUG} = 1;
96        if (lc($args{debug}) eq "stdout")
97        {
98            $self->{DEBUGFILE} = new FileHandle(">&STDERR");
99            $self->{DEBUGFILE}->autoflush(1);
100        }
101        else
102        {
103            if (-e $args{debug})
104            {
105                if (-w $args{debug})
106                {
107                    $self->{DEBUGFILE} = new FileHandle(">$args{debug}");
108                    $self->{DEBUGFILE}->autoflush(1);
109                }
110                else
111                {
112                    print "WARNING: debug file ($args{debug}) is not writable by you\n";
113                    print "         No debug information being saved.\n";
114                    $self->{DEBUG} = 0;
115                }
116            }
117            else
118            {
119                $self->{DEBUGFILE} = new FileHandle(">$args{debug}");
120                if (defined($self->{DEBUGFILE}))
121                {
122                    $self->{DEBUGFILE}->autoflush(1);
123                }
124                else
125                {
126                    print "WARNING: debug file ($args{debug}) does not exist \n";
127                    print "         and is not writable by you.\n";
128                    print "         No debug information being saved.\n";
129                    $self->{DEBUG} = 0;
130                }
131            }
132        }
133    }
134
135    $self->{SID} = exists($args{sid}) ? $args{sid} : "__xmlstream__:sid";
136
137    $self->{STYLE} = (exists($args{style}) ? lc($args{style}) : "tree");
138    $self->{DTD} = (exists($args{dtd}) ? lc($args{dtd}) : 0);
139
140    if ($self->{STYLE} eq "tree")
141    {
142        $self->{HANDLER}->{startDocument} = sub{ $self->startDocument(@_); };
143        $self->{HANDLER}->{endDocument} = sub{ $self->endDocument(@_); };
144        $self->{HANDLER}->{startElement} = sub{ &XML::Stream::Tree::_handle_element(@_); };
145        $self->{HANDLER}->{endElement} = sub{ &XML::Stream::Tree::_handle_close(@_); };
146        $self->{HANDLER}->{characters} = sub{ &XML::Stream::Tree::_handle_cdata(@_); };
147    }
148    elsif ($self->{STYLE} eq "node")
149    {
150        $self->{HANDLER}->{startDocument} = sub{ $self->startDocument(@_); };
151        $self->{HANDLER}->{endDocument} = sub{ $self->endDocument(@_); };
152        $self->{HANDLER}->{startElement} = sub{ &XML::Stream::Node::_handle_element(@_); };
153        $self->{HANDLER}->{endElement} = sub{ &XML::Stream::Node::_handle_close(@_); };
154        $self->{HANDLER}->{characters} = sub{ &XML::Stream::Node::_handle_cdata(@_); };
155    }
156    $self->setHandlers(%{$args{handlers}});
157
158    $self->{XMLONHOLD} = "";
159
160    return $self;
161}
162
163
164###########################################################################
165#
166# debug - prints the arguments to the debug log if debug is turned on.
167#
168###########################################################################
169sub debug
170{
171    return if ($_[1] > $_[0]->{DEBUGLEVEL});
172    my $self = shift;
173    my ($limit,@args) = @_;
174    return if ($self->{DEBUGFILE} eq "");
175    my $fh = $self->{DEBUGFILE};
176    if ($self->{DEBUGTIME} == 1)
177    {
178        my ($sec,$min,$hour) = localtime(time);
179        print $fh sprintf("[%02d:%02d:%02d] ",$hour,$min,$sec);
180    }
181    print $fh "XML::Stream::Parser: $self->{STYLE}: @args\n";
182}
183
184
185sub setSID
186{
187    my $self = shift;
188    my $sid = shift;
189    $self->{SID} = $sid;
190}
191
192
193sub getSID
194{
195    my $self = shift;
196    return $self->{SID};
197}
198
199
200sub setHandlers
201{
202    my $self = shift;
203    my (%handlers) = @_;
204
205    foreach my $handler (keys(%handlers))
206    {
207        $self->{HANDLER}->{$handler} = $handlers{$handler};
208    }
209}
210
211
212sub parse
213{
214    my $self = shift;
215    my $xml = shift;
216
217    return unless defined($xml);
218    return if ($xml eq "");
219
220    if ($self->{XMLONHOLD} ne "")
221    {
222        $self->{XML} = $self->{XMLONHOLD};
223        $self->{XMLONHOLD} = "";
224    }
225
226    # XXX change this to not use regex?
227    while($xml =~ s/<\!--.*?-->//gs) {}
228
229    $self->{XML} .= $xml;
230
231    return if ($self->{PARSING} == 1);
232
233    $self->{PARSING} = 1;
234
235    if(!$self->{DOC} == 1)
236    {
237        my $start = index($self->{XML},"<");
238
239        if ((substr($self->{XML},$start,3) eq "<?x") ||
240            (substr($self->{XML},$start,3) eq "<?X"))
241        {
242            my $close = index($self->{XML},"?>");
243            if ($close == -1)
244            {
245                $self->{PARSING} = 0;
246                return;
247            }
248            $self->{XML} = substr($self->{XML},$close+2,length($self->{XML})-$close-2);
249        }
250
251        &{$self->{HANDLER}->{startDocument}}($self);
252        $self->{DOC} = 1;
253    }
254
255    while(1)
256    {
257        if (length($self->{XML}) == 0)
258        {
259            $self->{PARSING} = 0;
260            return $self->returnData(0);
261        }
262        my $eclose = -1;
263        $eclose = index($self->{XML},"</".$self->{CNAME}->[$self->{CURR}].">")
264            if ($#{$self->{CNAME}} > -1);
265
266        if ($eclose == 0)
267        {
268            $self->{XML} = substr($self->{XML},length($self->{CNAME}->[$self->{CURR}])+3,length($self->{XML})-length($self->{CNAME}->[$self->{CURR}])-3);
269
270            $self->{PARSING} = 0 if ($self->{NONBLOCKING} == 1);
271            &{$self->{HANDLER}->{endElement}}($self,$self->{CNAME}->[$self->{CURR}]);
272            $self->{PARSING} = 1 if ($self->{NONBLOCKING} == 1);
273
274            $self->{CURR}--;
275            if ($self->{CURR} == 0)
276            {
277                $self->{DOC} = 0;
278                $self->{PARSING} = 0;
279                &{$self->{HANDLER}->{endDocument}}($self);
280                return $self->returnData(0);
281            }
282            next;
283        }
284
285        my $estart = index($self->{XML},"<");
286        my $cdatastart = index($self->{XML},"<![CDATA[");
287        if (($estart == 0) && ($cdatastart != 0))
288        {
289            my $close = index($self->{XML},">");
290            if ($close == -1)
291            {
292                $self->{PARSING} = 0;
293                return $self->returnData(0);
294            }
295            my $empty = (substr($self->{XML},$close-1,1) eq "/");
296            my $starttag = substr($self->{XML},1,$close-($empty ? 2 : 1));
297            my $nextspace = index($starttag," ");
298            my $attribs;
299            my $name;
300            if ($nextspace != -1)
301            {
302                $name = substr($starttag,0,$nextspace);
303                $attribs = substr($starttag,$nextspace+1,length($starttag)-$nextspace-1);
304            }
305            else
306            {
307                $name = $starttag;
308            }
309
310            my %attribs = $self->attribution($attribs);
311            if (($self->{DTD} == 1) && (exists($attribs{xmlns})))
312            {
313            }
314
315            &{$self->{HANDLER}->{startElement}}($self,$name,%attribs);
316
317            if($empty == 1)
318            {
319                &{$self->{HANDLER}->{endElement}}($self,$name);
320            }
321            else
322            {
323                $self->{CURR}++;
324                $self->{CNAME}->[$self->{CURR}] = $name;
325            }
326   
327            $self->{XML} = substr($self->{XML},$close+1,length($self->{XML})-$close-1);
328            next;
329        }
330
331        if ($cdatastart == 0)
332        {
333            my $cdataclose = index($self->{XML},"]]>");
334            if ($cdataclose == -1)
335            {
336                $self->{PARSING} = 0;
337                return $self->returnData(0);
338            }
339           
340            &{$self->{HANDLER}->{characters}}($self,substr($self->{XML},9,$cdataclose-9));
341           
342            $self->{XML} = substr($self->{XML},$cdataclose+3,length($self->{XML})-$cdataclose-3);
343            next;
344         }
345
346        if ($estart == -1)
347        {
348            $self->{XMLONHOLD} = $self->{XML};
349            $self->{XML} = "";
350        }
351        elsif (($cdatastart == -1) || ($cdatastart > $estart))
352        {
353            &{$self->{HANDLER}->{characters}}($self,$self->entityCheck(substr($self->{XML},0,$estart)));
354            $self->{XML} = substr($self->{XML},$estart,length($self->{XML})-$estart);
355        }
356    }
357}
358
359
360sub attribution
361{
362    my $self = shift;
363    my $str = shift;
364
365    $str = "" unless defined($str);
366
367    my %attribs;
368
369    while(1)
370    {
371        my $eq = index($str,"=");
372        if((length($str) == 0) || ($eq == -1))
373        {
374            return %attribs;
375        }
376
377        my $ids;
378        my $id;
379        my $id1 = index($str,"\'");
380        my $id2 = index($str,"\"");
381        if((($id1 < $id2) && ($id1 != -1)) || ($id2 == -1))
382        {
383            $ids = $id1;
384            $id = "\'";
385        }
386        if((($id2 < $id1) && ($id1 == -1)) || ($id2 != -1))
387        {
388            $ids = $id2;
389            $id = "\"";
390        }
391
392        my $nextid = index($str,$id,$ids+1);
393        my $val = substr($str,$ids+1,$nextid-$ids-1);
394        my $key = substr($str,0,$eq);
395
396        while($key =~ s/\s//) {}
397
398        $attribs{$key} = $self->entityCheck($val);
399        $str = substr($str,$nextid+1,length($str)-$nextid-1);
400    }
401
402    return %attribs;
403}
404
405
406sub entityCheck
407{
408    my $self = shift;
409    my $str = shift;
410
411    while($str =~ s/\&lt\;/\</) {}
412    while($str =~ s/\&gt\;/\>/) {}
413    while($str =~ s/\&quot\;/\"/) {}
414    while($str =~ s/\&apos\;/\'/) {}
415    while($str =~ s/\&amp\;/\&/) {}
416
417    return $str;
418}
419
420
421sub parsefile
422{
423    my $self = shift;
424    my $fileName = shift;
425
426    open(FILE,"<",$fileName);
427    my $file;
428    while(<FILE>) { $file .= $_; }
429    $self->parse($file);
430    close(FILE);
431
432    return $self->returnData();
433}
434
435
436sub returnData
437{
438    my $self = shift;
439    my $clearData = shift;
440    $clearData = 1 unless defined($clearData);
441
442    my $sid = $self->{SID};
443
444    if ($self->{STYLE} eq "tree")
445    {
446        return unless exists($self->{SIDS}->{$sid}->{tree});
447        my @tree = @{$self->{SIDS}->{$sid}->{tree}};
448        delete($self->{SIDS}->{$sid}->{tree}) if ($clearData == 1);
449        return ( \@tree );
450    }
451    if ($self->{STYLE} eq "node")
452    {
453        return unless exists($self->{SIDS}->{$sid}->{node});
454        my $node = $self->{SIDS}->{$sid}->{node}->[0];
455        delete($self->{SIDS}->{$sid}->{node}) if ($clearData == 1);
456        return $node;
457    }
458}
459
460
461sub startDocument
462{
463    my $self = shift;
464}
465
466
467sub endDocument
468{
469    my $self = shift;
470}
471
472
473sub startElement
474{
475    my $self = shift;
476    my ($sax, $tag, %att) = @_;
477
478    return unless ($self->{DOC} == 1);
479
480    if ($self->{STYLE} eq "debug")
481    {
482        print "$self->{DEBUGHEADER} \\\\ (",join(" ",%att),")\n";
483        $self->{DEBUGHEADER} .= $tag." ";
484    }
485    else
486    {
487        my @NEW;
488        if($#{$self->{TREE}} < 0)
489        {
490            push @{$self->{TREE}}, $tag;
491        }
492        else
493        {
494            push @{ $self->{TREE}[ $#{$self->{TREE}}]}, $tag;
495        }
496        push @NEW, \%att;
497        push @{$self->{TREE}}, \@NEW;
498    }
499}
500
501
502sub characters
503{
504    my $self = shift;
505    my ($sax, $cdata) = @_;
506
507    return unless ($self->{DOC} == 1);
508
509    if ($self->{STYLE} eq "debug") 
510    {
511        my $str = $cdata;
512        $str =~ s/\n/\#10\;/g;
513        print "$self->{DEBUGHEADER} || $str\n";
514    }
515    else
516    {
517        return if ($#{$self->{TREE}} == -1);
518
519        my $pos = $#{$self->{TREE}};
520
521        if ($pos > 0 && $self->{TREE}[$pos - 1] eq "0")
522        {
523            $self->{TREE}[$pos - 1] .= $cdata;
524        }
525        else
526        {
527            push @{$self->{TREE}[$#{$self->{TREE}}]}, 0;
528            push @{$self->{TREE}[$#{$self->{TREE}}]}, $cdata;
529        } 
530    }
531}
532
533
534sub endElement
535{
536    my $self = shift;
537    my ($sax, $tag) = @_;
538
539    return unless ($self->{DOC} == 1);
540
541    if ($self->{STYLE} eq "debug")
542    {
543        $self->{DEBUGHEADER} =~ s/\S+\ $//;
544        print "$self->{DEBUGHEADER} //\n";
545    }
546    else
547    {
548        my $CLOSED = pop @{$self->{TREE}};
549
550        if($#{$self->{TREE}} < 1)
551        {
552            push @{$self->{TREE}}, $CLOSED;
553
554            if($self->{TREE}->[0] eq "stream:error")
555            {
556                $self->{STREAMERROR} = $self->{TREE}[1]->[2];
557            }
558        }
559        else
560        {
561            push @{$self->{TREE}[$#{$self->{TREE}}]}, $CLOSED;
562        }
563    }
564}
565
566
5671;
Note: See TracBrowser for help on using the repository browser.