source: perl/lib/XML/Stream/Parser/DTD.pm @ a75309a

barnowl_perlaimdebianrelease-1.10release-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since a75309a was 0ff8d110, checked in by Alejandro R. Sedeño <asedeno@mit.edu>, 19 years ago
Adding XML::Stream, Net::XMPP, and Net::Jabber to perl/lib/
  • Property mode set to 100644
File size: 17.4 KB
Line 
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::DTD;
24
25=head1 NAME
26
27  XML::Stream::Parser::DTD - XML DTD Parser and Verifier
28
29=head1 SYNOPSIS
30
31  This is a work in progress.  I had need for a DTD parser and verifier
32  and so am working on it here.  If you are reading this then you are
33  snooping.  =)
34
35=head1 DESCRIPTION
36
37  This module provides the initial code for a DTD parser and verifier.
38
39=head1 METHODS
40
41=head1 EXAMPLES
42
43=head1 AUTHOR
44
45By Ryan Eatmon in February 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->{URI} = $args{uri};
69
70    $self->{PARSING} = 0;
71    $self->{DOC} = 0;
72    $self->{XML} = "";
73    $self->{CNAME} = ();
74    $self->{CURR} = 0;
75
76    $self->{ENTITY}->{"&lt;"} = "<";
77    $self->{ENTITY}->{"&gt;"} = ">";
78    $self->{ENTITY}->{"&quot;"} = "\"";
79    $self->{ENTITY}->{"&apos;"} = "'";
80    $self->{ENTITY}->{"&amp;"} = "&";
81
82    $self->{HANDLER}->{startDocument} = sub{ $self->startDocument(@_); };
83    $self->{HANDLER}->{endDocument} = sub{ $self->endDocument(@_); };
84    $self->{HANDLER}->{startElement} = sub{ $self->startElement(@_); };
85    $self->{HANDLER}->{endElement} = sub{ $self->endElement(@_); };
86
87    $self->{STYLE} = "debug";
88
89    open(DTD,$args{uri});
90    my $dtd = join("",<DTD>);
91    close(DTD);
92
93    $self->parse($dtd);
94
95    return $self;
96}
97
98
99sub parse
100{
101    my $self = shift;
102    my $xml = shift;
103
104    while($xml =~ s/<\!--.*?-->//gs) {}
105    while($xml =~ s/\n//g) {}
106
107    $self->{XML} .= $xml;
108
109    return if ($self->{PARSING} == 1);
110
111    $self->{PARSING} = 1;
112
113    if(!$self->{DOC} == 1)
114    {
115        my $start = index($self->{XML},"<");
116
117        if (substr($self->{XML},$start,3) =~ /^<\?x$/i)
118        {
119            my $close = index($self->{XML},"?>");
120            if ($close == -1)
121            {
122                $self->{PARSING} = 0;
123                return;
124            }
125            $self->{XML} = substr($self->{XML},$close+2,length($self->{XML})-$close-2);
126        }
127
128        &{$self->{HANDLER}->{startDocument}}($self);
129        $self->{DOC} = 1;
130    }
131
132    while(1)
133    {
134
135        if (length($self->{XML}) == 0)
136        {
137            $self->{PARSING} = 0;
138            return;
139        }
140
141        my $estart = index($self->{XML},"<");
142        if ($estart == -1)
143        {
144            $self->{PARSING} = 0;
145            return;
146        }
147
148        my $close = index($self->{XML},">");
149        my $dtddata = substr($self->{XML},$estart+1,$close-1);
150        my $nextspace = index($dtddata," ");
151        my $attribs;
152
153        my $type = substr($dtddata,0,$nextspace);
154        $dtddata = substr($dtddata,$nextspace+1,length($dtddata)-$nextspace-1);
155        $nextspace = index($dtddata," ");
156
157        if ($type eq "!ENTITY")
158        {
159            $self->entity($type,$dtddata);
160        }
161        else
162        {
163            my $tag = substr($dtddata,0,$nextspace);
164            $dtddata = substr($dtddata,$nextspace+1,length($dtddata)-$nextspace-1);
165            $nextspace = index($dtddata," ");
166
167            $self->element($type,$tag,$dtddata) if ($type eq "!ELEMENT");
168            $self->attlist($type,$tag,$dtddata) if ($type eq "!ATTLIST");
169        }
170
171        $self->{XML} = substr($self->{XML},$close+1,length($self->{XML})-$close-1);
172        next;
173    }
174}
175
176
177sub startDocument
178{
179    my $self = shift;
180}
181
182
183sub endDocument
184{
185    my $self = shift;
186}
187
188
189sub entity
190{
191    my $self = shift;
192    my ($type, $data) = @_;
193
194    foreach my $entity (keys(%{$self->{ENTITY}}))
195    {
196        $data =~ s/$entity/$self->{ENTITY}->{$entity}/g;
197    }
198
199    my ($symbol,$tag,undef,$string) = ($data =~ /^\s*(\S+)\s+(\S+)\s+(\"|\')([^\3]*)\3\s*$/);
200    $self->{ENTITY}->{"${symbol}${tag}\;"} = $string;
201}
202
203sub element
204{
205    my $self = shift;
206    my ($type, $tag, $data) = @_;
207
208    foreach my $entity (keys(%{$self->{ENTITY}}))
209    {
210        $data =~ s/$entity/$self->{ENTITY}->{$entity}/g;
211    }
212
213    $self->{COUNTER}->{$tag} = 0 unless exists($self->{COUNTER}->{$tag});
214
215    $self->parsegrouping($tag,\$self->{ELEMENT}->{$tag},$data);
216    $self->flattendata(\$self->{ELEMENT}->{$tag});
217
218}
219
220
221sub flattendata
222{
223    my $self = shift;
224    my $dstr = shift;
225
226    if ($$dstr->{type} eq "list")
227    {
228        foreach my $index (0..$#{$$dstr->{list}})
229        {
230            $self->flattendata(\$$dstr->{list}->[$index]);
231        }
232
233        if (!exists($$dstr->{repeat}) && ($#{$$dstr->{list}} == 0))
234        {
235            $$dstr = $$dstr->{list}->[0];
236        }
237    }
238}
239
240sub parsegrouping
241{
242    my $self = shift;
243    my ($tag,$dstr,$data) = @_;
244
245    $data =~ s/^\s*//;
246    $data =~ s/\s*$//;
247
248    if ($data =~ /[\*\+\?]$/)
249    {
250        ($$dstr->{repeat}) = ($data =~ /(.)$/);
251        $data =~ s/.$//;
252    }
253
254    if ($data =~ /^\(.*\)$/)
255    {
256        my ($seperator) = ($data =~ /^\(\s*\S+\s*(\,|\|)/);
257        $$dstr->{ordered} = "yes" if ($seperator eq ",");
258        $$dstr->{ordered} = "no" if ($seperator eq "|");
259
260        my $count = 0;
261        $$dstr->{type} = "list";
262        foreach my $grouping ($self->groupinglist($data,$seperator))
263        {
264            $self->parsegrouping($tag,\$$dstr->{list}->[$count],$grouping);
265            $count++;
266        }
267    }
268    else
269    {
270        $$dstr->{type} = "element";
271        $$dstr->{element} = $data;
272        $self->{COUNTER}->{$data} = 0 unless exists($self->{COUNTER}->{$data});
273        $self->{COUNTER}->{$data}++;
274        $self->{CHILDREN}->{$tag}->{$data} = 1;
275    }
276}
277
278
279sub attlist
280{
281    my $self = shift;
282    my ($type, $tag, $data) = @_;
283
284    foreach my $entity (keys(%{$self->{ENTITY}}))
285    {
286        $data =~ s/$entity/$self->{ENTITY}->{$entity}/g;
287    }
288
289    while($data ne "")
290    {
291        my ($att) = ($data =~ /^\s*(\S+)/);
292        $data =~ s/^\s*\S+\s*//;
293
294        my $value;
295        if ($data =~ /^\(/)
296        {
297            $value = $self->getgrouping($data);
298            $data = substr($data,length($value)+1,length($data));
299            $data =~ s/^\s*//;
300            $self->{ATTLIST}->{$tag}->{$att}->{type} = "list";
301            foreach my $val (split(/\s*\|\s*/,substr($value,1,length($value)-2))) {
302$self->{ATTLIST}->{$tag}->{$att}->{value}->{$val} = 1;
303            }
304        }
305        else
306        {
307            ($value) = ($data =~ /^(\S+)/);
308            $data =~ s/^\S+\s*//;
309            $self->{ATTLIST}->{$tag}->{$att}->{type} = $value;
310        }
311
312        my $default;
313        if ($data =~ /^\"|^\'/)
314        {
315            my($sq,$val) = ($data =~ /^(\"|\')([^\"\']*)\1/);
316            $default = $val;
317            $data =~ s/^$sq$val$sq\s*//;
318        }
319        else
320        {
321            ($default) = ($data =~ /^(\S+)/);
322            $data =~ s/^\S+\s*//;
323        }
324
325        $self->{ATTLIST}->{$tag}->{$att}->{default} = $default;
326    }
327}
328
329
330
331sub getgrouping
332{
333    my $self = shift;
334    my ($data) = @_;
335
336    my $count = 0;
337    my $parens = 0;
338    foreach my $char (split("",$data))
339    {
340        $parens++ if ($char eq "(");
341        $parens-- if ($char eq ")");
342        $count++;
343        last if ($parens == 0);
344    }
345    return substr($data,0,$count);
346}
347
348
349sub groupinglist
350{
351    my $self = shift;
352    my ($grouping,$seperator) = @_;
353
354    my @list;
355    my $item = "";
356    my $parens = 0;
357    my $word = "";
358    $grouping = substr($grouping,1,length($grouping)-2) if ($grouping =~ /^\(/);
359    foreach my $char (split("",$grouping))
360    {
361        $parens++ if ($char eq "(");
362        $parens-- if ($char eq ")");
363        if (($parens == 0) && ($char eq $seperator))
364        {
365            push(@list,$word);
366            $word = "";
367        }
368        else
369        {
370            $word .= $char;
371        }
372    }
373    push(@list,$word) unless ($word eq "");
374    return @list;
375}
376
377
378sub root
379{
380    my $self = shift;
381    my $tag = shift;
382    my @root;
383    foreach my $tag (keys(%{$self->{COUNTER}}))
384    {
385        push(@root,$tag) if ($self->{COUNTER}->{$tag} == 0);
386    }
387
388    print "ERROR:  Too many root tags... Check the DTD...\n"
389        if ($#root > 0);
390    return $root[0];
391}
392
393
394sub children
395{
396    my $self = shift;
397    my ($tag,$tree) = @_;
398
399    return unless exists ($self->{CHILDREN}->{$tag});
400    return if (exists($self->{CHILDREN}->{$tag}->{EMPTY}));
401    if (defined($tree))
402    {
403        my @current;
404        foreach my $current (&XML::Stream::GetXMLData("tree array",$tree,"*","",""))
405        {
406            push(@current,$$current[0]);
407        }
408        return $self->allowedchildren($self->{ELEMENT}->{$tag},\@current);
409    }
410    return $self->allowedchildren($self->{ELEMENT}->{$tag});
411}
412
413
414sub allowedchildren
415{
416    my $self = shift;
417    my ($dstr,$current) = @_;
418
419    my @allowed;
420
421    if ($dstr->{type} eq "element")
422    {
423        my $test = (defined($current) && $#{@{$current}} > -1) ? $$current[0] : "";
424        shift(@{$current}) if ($dstr->{element} eq $test);
425        if ($self->repeatcheck($dstr,$test) == 1)
426        {
427            return $dstr->{element};
428        }
429    }
430    else
431    {
432        foreach my $index (0..$#{$dstr->{list}})
433        {
434            push(@allowed,$self->allowedchildren($dstr->{list}->[$index],$current));
435        }
436    }
437
438    return @allowed;
439}
440
441
442sub repeatcheck
443{
444    my $self = shift;
445    my ($dstr,$tag) = @_;
446
447    $dstr = $self->{ELEMENT}->{$dstr} if exists($self->{ELEMENT}->{$dstr});
448
449#  print "repeatcheck: tag($tag)\n";
450#  print "repeatcheck: repeat($dstr->{repeat})\n"
451#    if exists($dstr->{repeat});
452
453    my $return = 0;
454    $return = ((!defined($tag) ||
455                ($tag eq $dstr->{element})) ?
456               0 :
457               1)
458        if (!exists($dstr->{repeat}) ||
459            ($dstr->{repeat} eq "?"));
460    $return = ((defined($tag) ||
461                (exists($dstr->{ordered}) &&
462                ($dstr->{ordered} eq "yes"))) ?
463               1 :
464               0)
465        if (exists($dstr->{repeat}) &&
466            (($dstr->{repeat} eq "+") ||
467             ($dstr->{repeat} eq "*")));
468
469#  print "repeatcheck: return($return)\n";
470    return $return;
471}
472
473
474sub required
475{
476    my $self = shift;
477    my ($dstr,$tag,$count) = @_;
478
479    $dstr = $self->{ELEMENT}->{$dstr} if exists($self->{ELEMENT}->{$dstr});
480
481    if ($dstr->{type} eq "element")
482    {
483        return 0 if ($dstr->{element} ne $tag);
484        return 1 if !exists($dstr->{repeat});
485        return 1 if (($dstr->{repeat} eq "+") && ($count == 1)) ;
486    }
487    else
488    {
489        return 0 if (($dstr->{repeat} eq "*") || ($dstr->{repeat} eq "?"));
490        my $test = 0;
491        foreach my $index (0..$#{$dstr->{list}})
492        {
493            $test = $test | $self->required($dstr->{list}->[$index],$tag,$count);
494        }
495        return $test;
496    }
497    return 0;
498}
499
500
501sub addchild
502{
503    my $self = shift;
504    my ($tag,$child,$tree) = @_;
505
506#  print "addchild: tag($tag) child($child)\n";
507
508    my @current;
509    if (defined($tree))
510    {
511#    &Net::Jabber::printData("\$tree",$tree);
512
513        @current = &XML::Stream::GetXMLData("index array",$tree,"*","","");
514
515#    &Net::Jabber::printData("\$current",\@current);
516    }
517
518    my @newBranch = $self->addchildrecurse($self->{ELEMENT}->{$tag},$child,\@current);
519
520    return $tree unless ("@newBranch" ne "");
521
522#  &Net::Jabber::printData("\$newBranch",\@newBranch);
523
524    my $location = shift(@newBranch);
525
526    if ($location eq "end")
527    {
528        splice(@{$$tree[1]},@{$$tree[1]},0,@newBranch);
529    }
530    else
531    {
532        splice(@{$$tree[1]},$location,0,@newBranch);
533    }
534    return $tree;
535}
536
537
538sub addcdata
539{
540    my $self = shift;
541    my ($tag,$child,$tree) = @_;
542
543#  print "addchild: tag($tag) child($child)\n";
544
545    my @current;
546    if (defined($tree))
547    {
548#    &Net::Jabber::printData("\$tree",$tree);
549
550        @current = &XML::Stream::GetXMLData("index array",$tree,"*","","");
551
552#    &Net::Jabber::printData("\$current",\@current);
553    }
554
555    my @newBranch = $self->addchildrecurse($self->{ELEMENT}->{$tag},$child,\@current);
556
557    return $tree unless ("@newBranch" ne "");
558
559#  &Net::Jabber::printData("\$newBranch",\@newBranch);
560
561    my $location = shift(@newBranch);
562
563    if ($location eq "end")
564    {
565        splice(@{$$tree[1]},@{$$tree[1]},0,@newBranch);
566    }
567    else
568    {
569        splice(@{$$tree[1]},$location,0,@newBranch);
570    }
571    return $tree;
572}
573
574
575sub addchildrecurse
576{
577    my $self = shift;
578    my ($dstr,$child,$current) = @_;
579
580#  print "addchildrecurse: child($child) type($dstr->{type})\n";
581
582    if ($dstr->{type} eq "element")
583    {
584#    print "addchildrecurse: tag($dstr->{element})\n";
585        my $count = 0;
586        while(($#{@{$current}} > -1) && ($dstr->{element} eq $$current[0]))
587        {
588            shift(@{$current});
589            shift(@{$current});
590            $count++;
591        }
592        if (($dstr->{element} eq $child) &&
593            ($self->repeatcheck($dstr,(($count > 0) ? $child : "")) == 1))
594        {
595            my @return = ( "end" , $self->newbranch($child));
596            @return = ($$current[1], $self->newbranch($child))
597                if ($#{@{$current}} > -1);
598#      print "addchildrecurse: Found the spot! (",join(",",@return),")\n";
599
600            return @return;
601        }
602    }
603    else
604    {
605        foreach my $index (0..$#{$dstr->{list}})
606        {
607            my @newBranch = $self->addchildrecurse($dstr->{list}->[$index],$child,$current);
608            return @newBranch if ("@newBranch" ne "");
609        }
610    }
611#  print "Let's blow....\n";
612    return;
613}
614
615
616sub deletechild
617{
618    my $self = shift;
619    my ($tag,$parent,$parenttree,$tree) = @_;
620
621    return $tree unless exists($self->{ELEMENT}->{$tag});
622    return $tree if $self->required($parent,$tag,&XML::Stream::GetXMLData("count",$parenttree,$tag));
623
624    return [];
625}
626
627
628
629sub newbranch
630{
631    my $self = shift;
632    my $tag = shift;
633
634    $tag = $self->root() unless defined($tag);
635
636    my @tree = ();
637
638    return ("0","") if ($tag eq "#PCDATA");
639
640    push(@tree,$tag);
641    push(@tree,[ {} ]);
642
643    foreach my $att ($self->attribs($tag))
644    {
645        $tree[1]->[0]->{$att} = ""
646            if (($self->{ATTLIST}->{$tag}->{$att}->{default} eq "#REQUIRED") &&
647                ($self->{ATTLIST}->{$tag}->{$att}->{type} eq "CDATA"));
648    }
649
650    push(@{$tree[1]},$self->recursebranch($self->{ELEMENT}->{$tag}));
651    return @tree;
652}
653
654
655sub recursebranch
656{
657    my $self = shift;
658    my $dstr = shift;
659
660    my @tree;
661    if (($dstr->{type} eq "element") &&
662        ($dstr->{element} ne "EMPTY"))
663    {
664        @tree = $self->newbranch($dstr->{element})
665            if (!exists($dstr->{repeat}) ||
666                ($dstr->{repeat} eq "+"));
667    }
668    else
669    {
670        foreach my $index (0..$#{$dstr->{list}})
671        {
672            push(@tree,$self->recursebranch($dstr->{list}->[$index]))
673if (!exists($dstr->{repeat}) ||
674        ($dstr->{repeat} eq "+"));
675        }
676    }
677    return @tree;
678}
679
680
681sub attribs
682{
683    my $self = shift;
684    my ($tag,$tree) = @_;
685
686    return unless exists ($self->{ATTLIST}->{$tag});
687
688    if (defined($tree))
689    {
690        my %current = &XML::Stream::GetXMLData("attribs",$tree,"","","");
691        return $self->allowedattribs($tag,\%current);
692    }
693    return $self->allowedattribs($tag);
694}
695
696
697sub allowedattribs
698{
699    my $self = shift;
700    my ($tag,$current) = @_;
701
702    my %allowed;
703    foreach my $att (keys(%{$self->{ATTLIST}->{$tag}}))
704    {
705        $allowed{$att} = 1 unless (defined($current) &&
706                                   exists($current->{$att}));
707    }
708    return sort {$a cmp $b} keys(%allowed);
709}
710
711
712sub attribvalue
713{
714    my $self = shift;
715    my $tag = shift;
716    my $att = shift;
717
718    return $self->{ATTLIST}->{$tag}->{$att}->{type}
719        if ($self->{ATTLIST}->{$tag}->{$att}->{type} ne "list");
720    return sort {$a cmp $b} keys(%{$self->{ATTLIST}->{$tag}->{$att}->{value}});
721}
722
723
724sub addattrib
725{
726    my $self = shift;
727    my ($tag,$att,$tree) = @_;
728
729    return $tree unless exists($self->{ATTLIST}->{$tag});
730    return $tree unless exists($self->{ATTLIST}->{$tag}->{$att});
731
732    my $default = $self->{ATTLIST}->{$tag}->{$att}->{default};
733    $default = "" if ($default eq "#REQUIRED");
734    $default = "" if ($default eq "#IMPLIED");
735
736    $$tree[1]->[0]->{$att} = $default;
737
738    return $tree;
739}
740
741
742sub attribrequired
743{
744    my $self = shift;
745    my ($tag,$att) = @_;
746
747    return 0 unless exists($self->{ATTLIST}->{$tag});
748    return 0 unless exists($self->{ATTLIST}->{$tag}->{$att});
749
750    return 1 if ($self->{ATTLIST}->{$tag}->{$att}->{default} eq "#REQUIRED");
751    return 0;
752}
753
754
755sub deleteattrib
756{
757    my $self = shift;
758    my ($tag,$att,$tree) = @_;
759
760    return $tree unless exists($self->{ATTLIST}->{$tag});
761    return $tree unless exists($self->{ATTLIST}->{$tag}->{$att});
762
763    return if $self->attribrequired($tag,$att);
764
765    delete($$tree[1]->[0]->{$att});
766
767    return $tree;
768}
769
Note: See TracBrowser for help on using the repository browser.