Gecko [ fernandoquevedodop.com ]

Name	Size	Permission	Action
DTD.pm	17.5 KB	-rw-r--r--

Code Editor : DTD.pm

##############################################################################
#
#  This library is free software; you can redistribute it and/or
#  modify it under the terms of the GNU Library General Public
#  License as published by the Free Software Foundation; either
#  version 2 of the License, or (at your option) any later version.
#
#  This library is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
#  Library General Public License for more details.
#
#  You should have received a copy of the GNU Library General Public
#  License along with this library; if not, write to the
#  Free Software Foundation, Inc., 59 Temple Place - Suite 330,
#  Boston, MA  02111-1307, USA.
#
#  Jabber
#  Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/
#
##############################################################################

package XML::Stream::Parser::DTD;

=head1 NAME

XML::Stream::Parser::DTD - XML DTD Parser and Verifier

=head1 SYNOPSIS

This is a work in progress.  I had need for a DTD parser and verifier
  and so am working on it here.  If you are reading this then you are
  snooping.  =)

=head1 DESCRIPTION

This module provides the initial code for a DTD parser and verifier.

=head1 METHODS

=head1 EXAMPLES

=head1 AUTHOR

By Ryan Eatmon in February of 2001 for http://jabber.org/

Currently maintained by Darian Anthony Patrick.

=head1 COPYRIGHT

This module licensed under the LGPL, version 2.1.

=cut

use strict;
use warnings;
use vars qw( $VERSION );

$VERSION = "1.24";

sub new
{
    my $self = { };

bless($self);

my %args;
    while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }

$self->{URI} = $args{uri};

$self->{PARSING} = 0;
    $self->{DOC} = 0;
    $self->{XML} = "";
    $self->{CNAME} = ();
    $self->{CURR} = 0;

$self->{ENTITY}->{"&lt;"} = "<";
    $self->{ENTITY}->{"&gt;"} = ">";
    $self->{ENTITY}->{"&quot;"} = "\"";
    $self->{ENTITY}->{"&apos;"} = "'";
    $self->{ENTITY}->{"&amp;"} = "&";

use Scalar::Util qw(weaken);
    my $weak = $self;
    weaken $weak;
    $self->{HANDLER}->{startDocument} = sub{ $weak->startDocument(@_); };
    $self->{HANDLER}->{endDocument} = sub{ $weak->endDocument(@_); };
    $self->{HANDLER}->{startElement} = sub{ $weak->startElement(@_); };
    $self->{HANDLER}->{endElement} = sub{ $weak->endElement(@_); };

$self->{STYLE} = "debug";

open(DTD,$args{uri});
    my $dtd = join("",<DTD>);
    close(DTD);

$self->parse($dtd);

return $self;
}

sub parse
{
    my $self = shift;
    my $xml = shift;

while($xml =~ s/<\!--.*?-->//gs) {}
    while($xml =~ s/\n//g) {}

$self->{XML} .= $xml;

return if ($self->{PARSING} == 1);

$self->{PARSING} = 1;

if(!$self->{DOC} == 1)
    {
        my $start = index($self->{XML},"<");

if (substr($self->{XML},$start,3) =~ /^<\?x$/i)
        {
            my $close = index($self->{XML},"?>");
            if ($close == -1)
            {
                $self->{PARSING} = 0;
                return;
            }
            $self->{XML} = substr($self->{XML},$close+2,length($self->{XML})-$close-2);
        }

&{$self->{HANDLER}->{startDocument}}($self);
        $self->{DOC} = 1;
    }

while(1)
    {

if (length($self->{XML}) == 0)
        {
            $self->{PARSING} = 0;
            return;
        }

my $estart = index($self->{XML},"<");
        if ($estart == -1)
        {
            $self->{PARSING} = 0;
            return;
        }

my $close = index($self->{XML},">");
        my $dtddata = substr($self->{XML},$estart+1,$close-1);
        my $nextspace = index($dtddata," ");
        my $attribs;

my $type = substr($dtddata,0,$nextspace);
        $dtddata = substr($dtddata,$nextspace+1,length($dtddata)-$nextspace-1);
        $nextspace = index($dtddata," ");

if ($type eq "!ENTITY")
        {
            $self->entity($type,$dtddata);
        }
        else
        {
            my $tag = substr($dtddata,0,$nextspace);
            $dtddata = substr($dtddata,$nextspace+1,length($dtddata)-$nextspace-1);
            $nextspace = index($dtddata," ");

$self->element($type,$tag,$dtddata) if ($type eq "!ELEMENT");
            $self->attlist($type,$tag,$dtddata) if ($type eq "!ATTLIST");
        }

$self->{XML} = substr($self->{XML},$close+1,length($self->{XML})-$close-1);
        next;
    }
}

sub startDocument
{
    my $self = shift;
}

sub endDocument
{
    my $self = shift;
}

sub entity
{
    my $self = shift;
    my ($type, $data) = @_;

foreach my $entity (keys(%{$self->{ENTITY}}))
    {
        $data =~ s/$entity/$self->{ENTITY}->{$entity}/g;
    }

my ($symbol,$tag,undef,$string) = ($data =~ /^\s*(\S+)\s+(\S+)\s+(\"|\')([^\3]*)\3\s*$/);
    $self->{ENTITY}->{"${symbol}${tag}\;"} = $string;
}

sub element
{
    my $self = shift;
    my ($type, $tag, $data) = @_;

foreach my $entity (keys(%{$self->{ENTITY}}))
    {
        $data =~ s/$entity/$self->{ENTITY}->{$entity}/g;
    }

$self->{COUNTER}->{$tag} = 0 unless exists($self->{COUNTER}->{$tag});

$self->parsegrouping($tag,\$self->{ELEMENT}->{$tag},$data);
    $self->flattendata(\$self->{ELEMENT}->{$tag});

}

sub flattendata
{
    my $self = shift;
    my $dstr = shift;

if ($$dstr->{type} eq "list")
    {
        foreach my $index (0..$#{$$dstr->{list}})
        {
            $self->flattendata(\$$dstr->{list}->[$index]);
        }

if (!exists($$dstr->{repeat}) && ($#{$$dstr->{list}} == 0))
        {
            $$dstr = $$dstr->{list}->[0];
        }
    }
}

sub parsegrouping
{
    my $self = shift;
    my ($tag,$dstr,$data) = @_;

$data =~ s/^\s*//;
    $data =~ s/\s*$//;

if ($data =~ /[\*\+\?]$/)
    {
        ($$dstr->{repeat}) = ($data =~ /(.)$/);
        $data =~ s/.$//;
    }

if ($data =~ /^$.*$$/)
    {
        my ($seperator) = ($data =~ /^\(\s*\S+\s*(\,|\|)/);
        $$dstr->{ordered} = "yes" if ($seperator eq ",");
        $$dstr->{ordered} = "no" if ($seperator eq "|");

my $count = 0;
        $$dstr->{type} = "list";
        foreach my $grouping ($self->groupinglist($data,$seperator))
        {
            $self->parsegrouping($tag,\$$dstr->{list}->[$count],$grouping);
            $count++;
        }
    }
    else
    {
        $$dstr->{type} = "element";
        $$dstr->{element} = $data;
        $self->{COUNTER}->{$data} = 0 unless exists($self->{COUNTER}->{$data});
        $self->{COUNTER}->{$data}++;
        $self->{CHILDREN}->{$tag}->{$data} = 1;
    }
}

sub attlist
{
    my $self = shift;
    my ($type, $tag, $data) = @_;

foreach my $entity (keys(%{$self->{ENTITY}}))
    {
        $data =~ s/$entity/$self->{ENTITY}->{$entity}/g;
    }

while($data ne "")
    {
        my ($att) = ($data =~ /^\s*(\S+)/);
        $data =~ s/^\s*\S+\s*//;

my $value;
        if ($data =~ /^\(/)
        {
            $value = $self->getgrouping($data);
            $data = substr($data,length($value)+1,length($data));
            $data =~ s/^\s*//;
            $self->{ATTLIST}->{$tag}->{$att}->{type} = "list";
            foreach my $val (split(/\s*\|\s*/,substr($value,1,length($value)-2))) {
$self->{ATTLIST}->{$tag}->{$att}->{value}->{$val} = 1;
            }
        }
        else
        {
            ($value) = ($data =~ /^(\S+)/);
            $data =~ s/^\S+\s*//;
            $self->{ATTLIST}->{$tag}->{$att}->{type} = $value;
        }

my $default;
        if ($data =~ /^\"|^\'/)
        {
            my($sq,$val) = ($data =~ /^(\"|\')([^\"\']*)\1/);
            $default = $val;
            $data =~ s/^$sq$val$sq\s*//;
        }
        else
        {
            ($default) = ($data =~ /^(\S+)/);
            $data =~ s/^\S+\s*//;
        }

$self->{ATTLIST}->{$tag}->{$att}->{default} = $default;
    }
}

sub getgrouping
{
    my $self = shift;
    my ($data) = @_;

my $count = 0;
    my $parens = 0;
    foreach my $char (split("",$data))
    {
        $parens++ if ($char eq "(");
        $parens-- if ($char eq ")");
        $count++;
        last if ($parens == 0);
    }
    return substr($data,0,$count);
}

sub groupinglist
{
    my $self = shift;
    my ($grouping,$seperator) = @_;

my @list;
    my $item = "";
    my $parens = 0;
    my $word = "";
    $grouping = substr($grouping,1,length($grouping)-2) if ($grouping =~ /^\(/);
    foreach my $char (split("",$grouping))
    {
        $parens++ if ($char eq "(");
        $parens-- if ($char eq ")");
        if (($parens == 0) && ($char eq $seperator))
        {
            push(@list,$word);
            $word = "";
        }
        else
        {
            $word .= $char;
        }
    }
    push(@list,$word) unless ($word eq "");
    return @list;
}

sub root
{
    my $self = shift;
    my $tag = shift;
    my @root;
    foreach my $tag (keys(%{$self->{COUNTER}}))
    {
        push(@root,$tag) if ($self->{COUNTER}->{$tag} == 0);
    }

print "ERROR:  Too many root tags... Check the DTD...\n"
        if ($#root > 0);
    return $root[0];
}

sub children
{
    my $self = shift;
    my ($tag,$tree) = @_;

return unless exists ($self->{CHILDREN}->{$tag});
    return if (exists($self->{CHILDREN}->{$tag}->{EMPTY}));
    if (defined($tree))
    {
        my @current;
        foreach my $current (&XML::Stream::GetXMLData("tree array",$tree,"*","",""))
        {
            push(@current,$$current[0]);
        }
        return $self->allowedchildren($self->{ELEMENT}->{$tag},\@current);
    }
    return $self->allowedchildren($self->{ELEMENT}->{$tag});
}

sub allowedchildren
{
    my $self = shift;
    my ($dstr,$current) = @_;

my @allowed;

if ($dstr->{type} eq "element")
    {
        my $test = (defined($current) && $#{@{$current}} > -1) ? $$current[0] : "";
        shift(@{$current}) if ($dstr->{element} eq $test);
        if ($self->repeatcheck($dstr,$test) == 1)
        {
            return $dstr->{element};
        }
    }
    else
    {
        foreach my $index (0..$#{$dstr->{list}})
        {
            push(@allowed,$self->allowedchildren($dstr->{list}->[$index],$current));
        }
    }

return @allowed;
}

sub repeatcheck
{
    my $self = shift;
    my ($dstr,$tag) = @_;

$dstr = $self->{ELEMENT}->{$dstr} if exists($self->{ELEMENT}->{$dstr});

#  print "repeatcheck: tag($tag)\n";
#  print "repeatcheck: repeat($dstr->{repeat})\n"
#    if exists($dstr->{repeat});

my $return = 0;
    $return = ((!defined($tag) ||
                ($tag eq $dstr->{element})) ?
               0 :
               1)
        if (!exists($dstr->{repeat}) ||
            ($dstr->{repeat} eq "?"));
    $return = ((defined($tag) ||
                (exists($dstr->{ordered}) &&
                ($dstr->{ordered} eq "yes"))) ?
               1 :
               0)
        if (exists($dstr->{repeat}) &&
            (($dstr->{repeat} eq "+") ||
             ($dstr->{repeat} eq "*")));

#  print "repeatcheck: return($return)\n";
    return $return;
}

sub required
{
    my $self = shift;
    my ($dstr,$tag,$count) = @_;

$dstr = $self->{ELEMENT}->{$dstr} if exists($self->{ELEMENT}->{$dstr});

if ($dstr->{type} eq "element")
    {
        return 0 if ($dstr->{element} ne $tag);
        return 1 if !exists($dstr->{repeat});
        return 1 if (($dstr->{repeat} eq "+") && ($count == 1)) ;
    }
    else
    {
        return 0 if (($dstr->{repeat} eq "*") || ($dstr->{repeat} eq "?"));
        my $test = 0;
        foreach my $index (0..$#{$dstr->{list}})
        {
            $test = $test | $self->required($dstr->{list}->[$index],$tag,$count);
        }
        return $test;
    }
    return 0;
}

sub addchild
{
    my $self = shift;
    my ($tag,$child,$tree) = @_;

#  print "addchild: tag($tag) child($child)\n";

my @current;
    if (defined($tree))
    {
#    &Net::Jabber::printData("\$tree",$tree);

@current = &XML::Stream::GetXMLData("index array",$tree,"*","","");

#    &Net::Jabber::printData("\$current",\@current);
    }

my @newBranch = $self->addchildrecurse($self->{ELEMENT}->{$tag},$child,\@current);

return $tree unless ("@newBranch" ne "");

#  &Net::Jabber::printData("\$newBranch",\@newBranch);

my $location = shift(@newBranch);

if ($location eq "end")
    {
        splice(@{$$tree[1]},@{$$tree[1]},0,@newBranch);
    }
    else
    {
        splice(@{$$tree[1]},$location,0,@newBranch);
    }
    return $tree;
}

sub addcdata
{
    my $self = shift;
    my ($tag,$child,$tree) = @_;

#  print "addchild: tag($tag) child($child)\n";

my @current;
    if (defined($tree))
    {
#    &Net::Jabber::printData("\$tree",$tree);

@current = &XML::Stream::GetXMLData("index array",$tree,"*","","");

#    &Net::Jabber::printData("\$current",\@current);
    }

my @newBranch = $self->addchildrecurse($self->{ELEMENT}->{$tag},$child,\@current);

return $tree unless ("@newBranch" ne "");

#  &Net::Jabber::printData("\$newBranch",\@newBranch);

my $location = shift(@newBranch);

if ($location eq "end")
    {
        splice(@{$$tree[1]},@{$$tree[1]},0,@newBranch);
    }
    else
    {
        splice(@{$$tree[1]},$location,0,@newBranch);
    }
    return $tree;
}

sub addchildrecurse
{
    my $self = shift;
    my ($dstr,$child,$current) = @_;

#  print "addchildrecurse: child($child) type($dstr->{type})\n";

if ($dstr->{type} eq "element")
    {
#    print "addchildrecurse: tag($dstr->{element})\n";
        my $count = 0;
        while(($#{@{$current}} > -1) && ($dstr->{element} eq $$current[0]))
        {
            shift(@{$current});
            shift(@{$current});
            $count++;
        }
        if (($dstr->{element} eq $child) &&
            ($self->repeatcheck($dstr,(($count > 0) ? $child : "")) == 1))
        {
            my @return = ( "end" , $self->newbranch($child));
            @return = ($$current[1], $self->newbranch($child))
                if ($#{@{$current}} > -1);
#      print "addchildrecurse: Found the spot! (",join(",",@return),")\n";

return @return;
        }
    }
    else
    {
        foreach my $index (0..$#{$dstr->{list}})
        {
            my @newBranch = $self->addchildrecurse($dstr->{list}->[$index],$child,$current);
            return @newBranch if ("@newBranch" ne "");
        }
    }
#  print "Let's blow....\n";
    return;
}

sub deletechild
{
    my $self = shift;
    my ($tag,$parent,$parenttree,$tree) = @_;

return $tree unless exists($self->{ELEMENT}->{$tag});
    return $tree if $self->required($parent,$tag,&XML::Stream::GetXMLData("count",$parenttree,$tag));

return [];
}

sub newbranch
{
    my $self = shift;
    my $tag = shift;

$tag = $self->root() unless defined($tag);

my @tree = ();

return ("0","") if ($tag eq "#PCDATA");

push(@tree,$tag);
    push(@tree,[ {} ]);

foreach my $att ($self->attribs($tag))
    {
        $tree[1]->[0]->{$att} = ""
            if (($self->{ATTLIST}->{$tag}->{$att}->{default} eq "#REQUIRED") &&
                ($self->{ATTLIST}->{$tag}->{$att}->{type} eq "CDATA"));
    }

push(@{$tree[1]},$self->recursebranch($self->{ELEMENT}->{$tag}));
    return @tree;
}

sub recursebranch
{
    my $self = shift;
    my $dstr = shift;

my @tree;
    if (($dstr->{type} eq "element") &&
        ($dstr->{element} ne "EMPTY"))
    {
        @tree = $self->newbranch($dstr->{element})
            if (!exists($dstr->{repeat}) ||
                ($dstr->{repeat} eq "+"));
    }
    else
    {
        foreach my $index (0..$#{$dstr->{list}})
        {
            push(@tree,$self->recursebranch($dstr->{list}->[$index]))
if (!exists($dstr->{repeat}) ||
        ($dstr->{repeat} eq "+"));
        }
    }
    return @tree;
}

sub attribs
{
    my $self = shift;
    my ($tag,$tree) = @_;

return unless exists ($self->{ATTLIST}->{$tag});

if (defined($tree))
    {
        my %current = &XML::Stream::GetXMLData("attribs",$tree,"","","");
        return $self->allowedattribs($tag,\%current);
    }
    return $self->allowedattribs($tag);
}

sub allowedattribs
{
    my $self = shift;
    my ($tag,$current) = @_;

my %allowed;
    foreach my $att (keys(%{$self->{ATTLIST}->{$tag}}))
    {
        $allowed{$att} = 1 unless (defined($current) &&
                                   exists($current->{$att}));
    }
    return sort {$a cmp $b} keys(%allowed);
}

sub attribvalue
{
    my $self = shift;
    my $tag = shift;
    my $att = shift;

return $self->{ATTLIST}->{$tag}->{$att}->{type}
        if ($self->{ATTLIST}->{$tag}->{$att}->{type} ne "list");
    return sort {$a cmp $b} keys(%{$self->{ATTLIST}->{$tag}->{$att}->{value}});
}

sub addattrib
{
    my $self = shift;
    my ($tag,$att,$tree) = @_;

return $tree unless exists($self->{ATTLIST}->{$tag});
    return $tree unless exists($self->{ATTLIST}->{$tag}->{$att});

my $default = $self->{ATTLIST}->{$tag}->{$att}->{default};
    $default = "" if ($default eq "#REQUIRED");
    $default = "" if ($default eq "#IMPLIED");

$$tree[1]->[0]->{$att} = $default;

return $tree;
}

sub attribrequired
{
    my $self = shift;
    my ($tag,$att) = @_;

return 0 unless exists($self->{ATTLIST}->{$tag});
    return 0 unless exists($self->{ATTLIST}->{$tag}->{$att});

return 1 if ($self->{ATTLIST}->{$tag}->{$att}->{default} eq "#REQUIRED");
    return 0;
}

sub deleteattrib
{
    my $self = shift;
    my ($tag,$att,$tree) = @_;

return $tree unless exists($self->{ATTLIST}->{$tag});
    return $tree unless exists($self->{ATTLIST}->{$tag}->{$att});

return if $self->attribrequired($tag,$att);

delete($$tree[1]->[0]->{$att});

return $tree;
}

${this.title}

Code Editor : DTD.pm