File Coverage

blib/lib/XML/Smart/DTD.pm

Criterion	Covered	Total	%
statement	333	427	77.9
branch	142	236	60.1
condition	52	119	43.7
subroutine	33	42	78.5
pod	29	38	76.3
total	589	862	68.3

#############################################################################
## Name:        DTD.pm
## Purpose:     XML::Smart::DTD - Apply DTD over a XML::Smart object.
## Author:      Graciliano M. P.
## Modified by: Harish Madabushi
## Created:     25/05/2004
## RCS-ID:
##
##          The DTD parser was based on XML-DTDParser-1.7
##          by [e-mail] http://Jenda.Krynicky.cz
##
## Copyright:   (c) 2004 Graciliano M. P.
## Licence:     This program is free software; you can redistribute it and/or
##              modify it under the same terms as Perl itself
#############################################################################

package XML::Smart::DTD                                        ;

use strict                                                     ;
use warnings                                                   ;

use XML::Smart::Shared qw( _unset_sig_warn _reset_sig_warn )   ;

our ($VERSION , @ISA) ;
$VERSION = '0.05' ;

########
# VARS #
########

my $RE_quoted = qr/(?:"[^"\\]?"|"(?:(?:\\")|[^"])+(?!\\)[^"]?"|'[^'\\]?'|'(?:(?:\\')|[^'])+(?!\\)[^']')/s ;

my $namechar = qr/[#\x41-\x5A\x61-\x7A\xC0-\xD6\xD8-\xF6\xF8-\xFF0-9\xB7._:-]/;
my $name = qr/[\x41-\x5A\x61-\x7A\xC0-\xD6\xD8-\xF6\xF8-\xFF_:]$namechar*/ ;
my $nameX = qr/$name[.?+*]*/ ;

my $nmtoken = qr/$namechar+/ ;

my $AttType = qr/(?:CDATA|ID|IDREF|IDREFS|ENTITY|ENTITIES|NMTOKEN|NMTOKENS|\(.*?\)|NOTATION ?\(.*?\))/ ;
my $DefaultDecl = qr/(?:#REQUIRED|#IMPLIED|#FIXED)/ ;
my $AttDef = qr/($name)[ \t]+($AttType)(?:[ \t]+($DefaultDecl))?(?:[ \t]+($RE_quoted))?/ ;

#{
#  my (@sub) = ( join ("", ) =~ /\n\s*sub\s+(\w+)/gs );
#  foreach my $sub_i (sort @sub ) { print "=>head2 $sub_i\n" ;}
#}
#__DATA__

###############
# AUTOLOADERS #
###############

sub get_url {
  require XML::Smart::Tree ;
  *get_url = \*XML::Smart::Tree::get_url ;
  &XML::Smart::Tree::get_url(@_) ;
}

#######
# NEW #
#######

sub new {
  my $class = shift ;
  my $dtd = shift ;
  $dtd =~ s/^file:\/\/\/?// ;

  my $this = bless({} , $class) ;

  $this->{tree} = $this->ParseDTD($dtd) ;
  return $this ;
}

################################################################################

###############
# ELEM_EXISTS #
###############

sub elem_exists {
  my $this = shift ;
  my ( $tag ) = @_ ;
  return 1 if $this->{tree}{$tag} ;
  return undef ;
}

################
# CHILD_EXISTS #
################

sub child_exists {
  my $this = shift ;
  my ( $tag , $child ) = @_ ;
  return undef if !$this->{tree}{$tag} || !$this->{tree}{$tag}{children} ;
  return 1 if $this->{tree}{$tag}{children}{$child} ;
  return undef ;
}

################
# IS_ELEM_UNIQ #
################

sub is_elem_uniq {
  my $this = shift ;
  return ( $this->get_elem_opt(@_) =~ /^[\!]?$/ ) ? 1 : undef ;
}

######################
# IS_ELEM_CHILD_UNIQ #
######################

sub is_elem_child_uniq {
  my $this = shift ;
  return ( $this->get_elem_child_opt(@_) =~ /^[\!]?$/ ) ? 1 : undef ;
}

#################
# IS_ELEM_MULTI #
#################

sub is_elem_multi {
  my $this = shift ;
  return ( $this->get_elem_opt(@_) =~ /^[\+\*]$/ ) ? 1 : undef ;
}

#######################
# IS_ELEM_CHILD_MULTI #
#######################

sub is_elem_child_multi {
  my $this = shift ;
  return ( $this->get_elem_child_opt(@_) =~ /^[\+\*]$/ ) ? 1 : undef ;
}

###############
# IS_ELEM_REQ #
###############

sub is_elem_req {
  my $this = shift ;
  return ( $this->get_elem_opt(@_) =~ /^[\!\+]?$/ ) ? 1 : undef ;
}

#####################
# IS_ELEM_CHILD_REQ #
#####################

sub is_elem_child_req {
  my $this = shift ;
  return ( $this->get_elem_child_opt(@_) =~ /^[\!\+]?$/ ) ? 1 : undef ;
}

###############
# IS_ELEM_OPT #
###############

sub is_elem_opt {
  my $this = shift ;
  return ( $this->get_elem_opt(@_) =~ /^[\?\*]$/ ) ? 1 : undef ;
}

#####################
# IS_ELEM_CHILD_OPT #
#####################

sub is_elem_child_opt {
  my $this = shift ;
  return ( $this->get_elem_child_opt(@_) =~ /^[\?\*]$/ ) ? 1 : undef ;
}

################
# GET_ELEM_OPT #
################

sub get_elem_opt {
  my $this = shift ;
  my ( $tag ) = @_ ;
  return undef if !$this->{tree}{$tag} ;
  return $this->{tree}{$tag}{option} ;
}

######################
# GET_ELEM_CHILD_OPT #
######################

sub get_elem_child_opt {
  my $this = shift ;
  my ( $tag , $child ) = @_ ;
  return undef if !$this->{tree}{$tag} || !$this->{tree}{$tag}{children} ;
  return $this->{tree}{$tag}{children}{$child} ;
}

###############
# IS_ELEM_ANY #
###############

sub is_elem_any {
  my $this = shift ;
  my ( $tag ) = @_ ;
  return undef if !$this->{tree}{$tag} ;

  return 1 if $this->{tree}{$tag}{any} ;
  return undef ;
}

##################
# IS_ELEM_PCDATA #
##################

sub is_elem_pcdata {
  my $this = shift ;
  my ( $tag ) = @_ ;
  return undef if !$this->{tree}{$tag} ;
  return 1 if $this->{tree}{$tag}{content} ;
}

#################
# IS_ELEM_EMPTY #
#################

sub is_elem_empty {
  my $this = shift ;
  my ( $tag ) = @_ ;
  return undef if !$this->{tree}{$tag} ;

  return 1 if $this->{tree}{$tag}{empty} ;
  return undef ;
}

##################
# IS_ELEM_PARENT #
##################

sub is_elem_parent {
  my $this = shift ;
  my ( $tag , @chk_parent ) = @_ ;
  return undef if !$this->{tree}{$tag} ;

  my @parents = ref($this->{tree}{$tag}{parent}) eq 'ARRAY' ? @{$this->{tree}{$tag}{parent}} : () ;
  my %parents = map { $_ => 1 } @parents ;

  foreach my $chk_parent_i ( @chk_parent ) {
    next if $chk_parent_i eq '' ;
    return undef if !$parents{$chk_parent_i} ;
  }

  return 1 ;
}

###############
# ATTR_EXISTS #
###############

sub attr_exists {
  my $this = shift ;
  my ( $tag , @attrs ) = @_ ;
  return undef if !$this->{tree}{$tag} ;

  foreach my $attrs_i ( @attrs ) {
    return undef if !$this->{tree}{$tag}{attributes}{$attrs_i} ;
  }

  return 1 ;
}

###############
# IS_ATTR_REQ #
###############

sub is_attr_req {
  my $this = shift ;
  my ( $tag , $attr ) = @_ ;

  _unset_sig_warn() ;
  my $attr_check = $this->{tree}{$tag}{attributes}{$attr} ;
  _reset_sig_warn() ;
  return undef if( !$this->{tree}{$tag} || !$attr_check ) ;

  my $opt = @{$this->{tree}{$tag}{attributes}{$attr}}[1] ;

  return 1 if( $opt && ($opt =~ /#REQUIRED/i ) ) ;
  return undef ;
}

###############
# IS_ATTR_FIX #
###############

sub is_attr_fix {
  my $this = shift ;
  my ( $tag , $attr ) = @_ ;
  return undef if !$this->{tree}{$tag} || !$this->{tree}{$tag}{attributes}{$attr} ;

  my $opt = @{$this->{tree}{$tag}{attributes}{$attr}}[1] ;

  return 1 if $opt =~ /#FIXED/i ;
  return undef ;
}

#################
# GET_ATTR_TYPE #
#################

sub get_attr_type {
  my $this = shift ;
  my ( $tag , $attr ) = @_ ;
  return undef if !$this->{tree}{$tag} || !$this->{tree}{$tag}{attributes}{$attr} ;

  my $type = @{$this->{tree}{$tag}{attributes}{$attr}}[0] ;
  return $type ;
}


################
# GET_ATTR_DEF #
################

sub get_attr_def {
  my $this = shift ;
  my ( $tag , $attr ) = @_ ;
  return () if !$this->{tree}{$tag} || !$this->{tree}{$tag}{attributes}{$attr} ;
  my $def = @{$this->{tree}{$tag}{attributes}{$attr}}[2] ;
  return $def ;
}

###################
# GET_ATTR_VALUES #
###################

sub get_attr_values {
  my $this = shift ;
  my ( $tag , $attr ) = @_ ;
  return () if !$this->{tree}{$tag} || !$this->{tree}{$tag}{attributes}{$attr} ;
  my $vals = @{$this->{tree}{$tag}{attributes}{$attr}}[3] ;

  return @$vals if ref $vals eq 'ARRAY' ;
  return () ;
}

##############
# GET_CHILDS #
##############

sub get_childs {
  my $this = shift ;
  my ( $tag ) = @_ ;
  return undef if !$this->{tree}{$tag} ;
  return @{$this->{tree}{$tag}{childrenARR}} if $this->{tree}{$tag}{childrenARR} && @{$this->{tree}{$tag}{childrenARR}} ;
  return () ;
}

##################
# GET_CHILDS_REQ #
##################

sub get_childs_req {
  my $this = shift ;
  my ( $tag ) = @_ ;

  my @childs = $this->get_childs($tag) ;

  my @childs_req ;
  foreach my $child_i ( @childs ) {
    push(@childs_req , $child_i) if $this->is_elem_child_req($tag , $child_i) ;
  }

  return @childs_req ;
}

#############
# GET_ATTRS #
#############

sub get_attrs {
  my $this = shift ;
  my ( $tag ) = @_ ;
  return undef if !$this->{tree}{$tag} || !$this->{tree}{$tag}{attr_order} ;

  my @attrs = @{$this->{tree}{$tag}{attr_order}} ;
  return @attrs ;
}

#################
# GET_ATTRS_REQ #
#################

sub get_attrs_req {
  my $this = shift ;
  my ( $tag ) = @_ ;

  my @attrs = $this->get_attrs($tag) ;

  my @attr_req ;
  foreach my $attrs_i ( @attrs ) {
    push(@attr_req , $attrs_i) if $this->is_attr_req($tag , $attrs_i) ;
  }

  return @attr_req ;
}

#########
# ERROR #
#########

sub error {
  my $this = shift ;

  if ( @_ ) { push( @{$this->{ERRORS}}  , @_) ;}

  return @{ $this->{ERRORS} } if $this->{ERRORS} && @{$this->{ERRORS}} ;
  return () ;
}

########
# TREE #
########

sub tree { return $_[0]->{tree} ; }

########
# ROOT #
########

sub root { return $_[0]->{root} ; }

############
# PARSEDTD #
############

sub ParseDTD {
  my $this = shift ;
  my $xml = read_data( shift(@_) ) ;
  $this->{DATA} = $xml ;

  my (%elements, %definitions) ;

  $xml =~ s/\s+/ /gs ;

  while ($xml =~ s{}{}io) {
    my ($percent, $entity, $include) = ($1,$2,$3) ;
    $percent = '&' unless $percent;
    my $definition = read_data($include) ;
    $definition =~ s/\s+/ /gs ;
    $xml =~ s{\Q$percent$entity;\E}{$definition}g ;
  }

  $xml =~ s{}{}gs ;
  $xml =~ s{<\?.*?\?>}{}gs ;

  while ($xml =~ s{}{}io) {
    my ($percent, $entity, $definition) = ($1,$2,$3) ;
    $percent = '&' unless $percent ;
    $definitions{"$percent$entity"} = $definition ;
  }

  {
    my $replacements = 0 ;
    1 while ++$replacements < 1000 and $xml =~ s{([&%]$name);}{(exists $definitions{$1} ? $definitions{$1} : "$1\x01;")}ge;
    $this->error("Recursive  or too many entities!") if $xml =~ m{([&%]$name);} ;
  }
  undef %definitions ;

  $xml =~ tr/\x01//d ;

  while ($xml =~ s{}{}io) {
    my ($element, $children, $option) = ($1,$2,$3);

    $elements{$element}->{childrenSTR} = $children . $option ;
    $children =~ s/\s//g ;

    if ($children eq '(#PCDATA)') { $children = '#PCDATA' ;}
    elsif ( $children =~ s/^\((#PCDATA(?:\|$name)+)\)$/$1/o && $option eq '*') {
      $children =~ s/\|/*,/g ;
      $children .= '*' ;
    }
    else { $children = simplify_children( $children, $option) ;}

    $this->error(" is not valid!") unless $children =~ m{^#?$nameX(?:,$nameX)*$} ;

    $elements{$element}->{childrenARR} = [] ;

    foreach my $child (split ',', $children) {
      $child =~ s/([\?\*\+])$//
      and $option = $1
      or $option = '!' ;

      $elements{$element}->{children}->{$child} = $option ;
      push @{$elements{$element}->{childrenARR}}, $child unless $child eq '#PCDATA' ;
    }

    delete $elements{$element}->{childrenARR} if !@{$elements{$element}->{childrenARR}} ;
  }

  while ($xml =~ s{}{}io) {
    my ($element, $param) = ($1,$2) ;
    if ( uc($param) eq 'ANY') { $elements{$element}->{any} = 1 ;}
    elsif ( uc($param) eq 'EMPTY') { $elements{$element}->{empty} = 1 ;}
  }

  while ($xml =~ s{}{}io) {
    my ($element, $attributes) = ($1,$2);

    $this->error(" referenced by an  not found!") unless exists $elements{$element} ;

    while ($attributes =~ s/^\s*$AttDef//io) {
      my ($name,$type,$option,$default) = ($1,$2,$3,$4);

      if    ( $default && ( $default =~ /^"(.*?)"$/ ) ) { $default = $1 ; $default =~ s/\\"/"/gs ;}
      elsif ( $default && ( $default =~ /^'(.*?)'$/ ) ) { $default = $1 ; $default =~ s/\\'/'/gs ;}

      $elements{$element}->{attributes}->{$name} = [$type,$option,$default,undef];

      push(@{$elements{$element}->{attr_order}} , $name) ;

      if ($type =~ /^(?:NOTATION\s*)?\(\s*(.*?)\)$/) {
        $elements{$element}->{attributes}->{$name}->[3] = parse_values($1);
      }
    }
  }

  $xml =~ s/\s+/ /gs ;

  if ( $xml =~ /^\s*<\!DOCTYPE\s+($name)\s*\[\s*(.*)$/ ) {
    $this->{root} = $1 ;
    my $data = $2 ;
    $data =~ s/\s*]\s*>\s*$//gi ;
    $xml = $data ;
  }

  $this->error("UNPARSED DATA:\n$xml\n\n") if $xml =~ /\S/ ;

  foreach my $element (keys %elements) {
    foreach my $child (keys %{$elements{$element}->{children}}) {
      if ($child eq '#PCDATA') {
        delete $elements{$element}->{children}->{'#PCDATA'};
        $elements{$element}->{content} = 1;
      }
      else {
        $this->error("Element $child referenced by $element was not found!") unless exists $elements{$child} ;

        if (exists $elements{$child}->{parent}) { push @{$elements{$child}->{parent}}, $element ;}
        else { $elements{$child}->{parent} = [$element] ;}

        $elements{$child}->{option} = $elements{$element}->{children}->{$child} ;
      }
    }

    if ( !%{$elements{$element}->{children}} ) { delete $elements{$element}->{children} ;}
  }

  return \%elements ;
}

##########
# CUTDTD #
##########

sub CutDTD {
  my $this = shift ;
  if ( !@_ ) { push(@_ , $this->{DATA} ) ;}

  my $xml = read_data( shift(@_) ) ;

  my (%elements, %definitions) ;

  $xml =~ s/\r\n?/\n/gs ;

  my $dtd_data ;

  while ($xml =~ s{()}{}io) {
    $dtd_data .= "$1\n" ;
  }

  $xml =~ s{}{}gs ;
  $xml =~ s{<\?.*?\?>}{}gs ;

  while ($xml =~ s{()}{}io) {
    $dtd_data .= "$1\n" ;
  }

  {
    my $replacements = 0 ;
    1 while ++$replacements < 1000 and $xml =~ s{([&%]$name);}{(exists $definitions{$1} ? $definitions{$1} : "$1\x01;")}ge;
    $this->error("Recursive  or too many entities!") if $xml =~ m{([&%]$name);} ;
  }
  undef %definitions ;

  $xml =~ tr/\x01//d ;

  while ($xml =~ s{()}{}io) {
    $dtd_data .= "$1\n" ;
  }

  while ($xml =~ s{()}{}io) {
    $dtd_data .= "$1\n" ;
  }

  while ($xml =~ s{()}{}ios) {
    $dtd_data .= "$1\n" ;
  }

  if ( $xml =~ /^\s*<\!DOCTYPE\s+($name)\s*\[\s*/ ) {
    $dtd_data = "\n" ;
  }

  return $dtd_data ;
}

####################
# FLATTEN_CHILDREN #
####################

sub flatten_children {
  my ( $children , $option ) = @_ ;

  if ($children =~ /\|/) {
    $children =~ s/(\|$name)/${1}?/gs ;
    $children =~ s{\|}{?,}g ;
  }

  if ($option) {
    $children =~ s/,/$option,/g ;
    $children .= $option ;
  }

  return $children ;
}

#####################
# SIMPLIFY_CHILDREN #
#####################

sub simplify_children {
  my ( $children, $option ) = @_;

  1 while $children =~ s{\(($nameX(?:[,|]$nameX)*)\)([\?\*\+]*)}{flatten_children($1, $2)}geo ;

  if ($option) {
    $children =~ s/,/$option,/g ;
    $children .= $option ;
  }

  foreach ($children) {
    s{\?\?}{?}g;
    s{\?\+}{*}g;
    s{\?\*}{*}g;
    s{\+\?}{*}g;
    s{\+\+}{+}g;
    s{\+\*}{*}g;
    s{\*\?}{*}g;
    s{\*\+}{*}g;
    s{\*\*}{*}g;
  }

  return $children ;
}

################
# PARSE_VALUES #
################

sub parse_values {
  my $def = shift ;

  $def =~ s/^\s*\(\s*// ;
  $def =~ s/\s*\)\s*$// ;
  $def = "|$def" ;

  my @def ;
  while( $def =~ /\s*|\s*(?:($RE_quoted)|([^\(\)\|]+))/gs ) {
    if ( defined $1 ) {
      my $q = $1 ;
      if    ( $q =~ /^"(.*?)"$/ ) { $q = $1 ; $q =~ s/\\"/"/gs ;}
      elsif ( $q =~ /^'(.*?)'$/ ) { $q = $1 ; $q =~ s/\\'/'/gs ;}
      push(@def , $q) ;
    }
    elsif ( defined $2 ) {
      my $d = $2 ;
      $d =~ tr/\x20\x09\x0D\x0A//d ; # get rid of whitespace
      push(@def , $d) ;
    }
  }

  foreach my $def_i ( @def ) {

  }

  return \@def ;
}

#############
# READ_DATA #
#############

sub read_data {
  my $data ;
  {
    my ($fh,$open) ;

    if (ref($_[0]) eq 'GLOB') { $fh = $_[0] ;}
    elsif ($_[0] =~ /^http:\/\/\w+[^\r\n]+$/s) { $data = &get_url($_[0]) ;}
    elsif ($_[0] =~ /<.*?>/s) { $data = $_[0] ;}
    else { open ($fh,$_[0]) ; binmode($fh) ; $open = 1 ;}

    if ($fh) {
      1 while( read($fh, $data , 1024*8 , length($data) ) ) ;
      close($fh) if $open ;
    }
  }

  return $data ;
}

################################################################################

#############
# APPLY_DTD #
#############

sub apply_dtd {
  my $xml = shift ;
  my $dtd = shift ;

  if ( ref($dtd) ne 'XML::Smart::DTD' ) { $dtd = XML::Smart::DTD->new($dtd , @_) ;}

  $$xml->{DTD} = $dtd ;

  return if !$dtd || !$dtd->tree || !%{ $dtd->tree } ;

  _apply_dtd($dtd , $xml->tree , undef , undef , {} , undef , undef , {} , @_) ;
}

sub _apply_dtd {

  my ($dtd , $tree , $tag , $ar_i , $prev_tree , $prev_tag , $prev_exists , $parsed , %opts) = @_ ;
  _unset_sig_warn() ;

  ##print "$tag>> $tree , $tag , $prev_tree , $prev_tag , $parsed >> $opts{no_delete}\n" ;

  if ( ref($tree) ) {
    if ($$parsed{"$tree"}) {
	_reset_sig_warn() ;
	return ;
    }
    ++$$parsed{"$tree"} ;
  }

  if (ref($tree) eq 'HASH') {

    if ( $tag ne '' && $dtd->elem_exists($tag) ) {
      if ( $dtd->is_elem_empty($tag) ) {
        $prev_tree->{$tag} = {} ;
      }
      elsif ( $dtd->is_elem_pcdata($tag) ) {
        if ( ref $prev_tree->{$tag} eq 'HASH' ) { $prev_tree->{$tag}{CONTENT} = '' if !defined $prev_tree->{$tag}{CONTENT} ;}
        else { $prev_tree->{$tag} = '' if !defined $prev_tree->{$tag} ;}
      }
      else {
        my @childs_req = $dtd->get_childs_req($tag) ;
        foreach my $childs_req_i ( @childs_req ) {
          if ( !exists $tree->{$childs_req_i} ) {
            $tree->{$childs_req_i} = {} ;
          }
        }

        my @attrs_req = $dtd->get_attrs_req($tag) ;
        foreach my $attrs_req_i ( @attrs_req ) {
          if ( !exists $tree->{$attrs_req_i} ) {
            $tree->{$attrs_req_i} = $dtd->get_attr_def($tag , $attrs_req_i) ;
          }
        }

        {
          my @order = ($dtd->get_attrs($tag) , $dtd->get_childs($tag)) ;

          if ( ! $tree->{'/order'} ) { $tree->{'/order'} = \@order ;}
          else {
            my %in_order ;
            {
              my %n ; %in_order = map { $_ => (++$n{$_}) } @{ $tree->{'/order'} } ;
            }

            my (@new_order , %order) ;
            foreach my $order_i ( @order ) {
		_unset_sig_warn() ;
		push(@new_order , (($order_i) x ($in_order{$order_i} || 1))) ;
		$order{$order_i} = 1 ;
		_reset_sig_warn() ;
            }

            foreach my $order_i ( @{ $tree->{'/order'} } ) {
              next if $order{$order_i} ;
              push(@new_order , $order_i) ;
            }

            $tree->{'/order'} = \@new_order ;
          }

        }


      }

    }

    foreach my $Key ( keys %$tree ) {
      if ($Key eq '' || $Key eq '/order' || $Key eq '/nodes' || $Key eq 'CONTENT') { next ;}

      if ( ( $tag eq '' && $dtd->elem_exists($Key)) || ( $tag ne '' && $dtd->child_exists($tag , $Key)) ) {
	if ( $tree->{'/nodes'}{$Key} && ( $tree->{'/nodes'}{$Key} =~ /^(\w+,\d+),(\d*)/ ) ) { $tree->{'/nodes'}{$Key} = "$1,1" ;}
        else { $tree->{'/nodes'}{$Key} = 1 ;}

        if ( !ref($tree->{$Key}) ) {
          my $content = ( $tree->{$Key} ) ? $tree->{$Key} : '';
          $tree->{$Key} = {} if !ref $tree->{$Key} ;
          $tree->{$Key}{CONTENT} = $content if $content ne '' ;
        }
        elsif ( ref($tree->{$Key}) eq 'ARRAY' ) {
          if ( $tag ne '' && !$dtd->is_elem_child_multi($tag , $Key) ) {
            $tree->{$Key} = $tree->{$Key}[0] ;
          }
        }

        _apply_dtd($dtd , $tree->{$Key} , $Key , undef , $tree , $tag , 1, $parsed , %opts) ;
      } elsif ( $tag ne '' && $dtd->attr_exists($tag , $Key) ) {
        delete $tree->{'/nodes'}{$Key} ;
        if ( ref($tree->{$Key}) eq 'HASH' && exists $tree->{$Key}{CONTENT} && (keys %{$tree->{$Key}}) == 1 ) {
          my $content = $tree->{$Key}{CONTENT} ;
          $tree->{$Key} = $content ;
        }

        if ( ref $tree->{$Key} ) {
          if ( ref $tree->{$Key} eq 'ARRAY' ) { $tree->{$Key} = $tree->{$Key}[0] ;}
          if ( ref $tree->{$Key} eq 'HASH' ) { $tree->{$Key} = $tree->{$Key}{CONTENT} ;}
        }

        if ( $tag ne '' && $tree->{$Key} eq '' ) {
          $tree->{$Key} = $dtd->get_attr_def($tag , $Key) ;
        }
      }
      else {
        if ( $prev_exists && !$opts{no_delete} ) { delete $tree->{$Key} ;}
        else {
          _apply_dtd($dtd , $tree->{$Key} , $Key , undef , $tree , $tag , undef , $parsed , %opts) ;
        }

      }
    }
  }
  elsif (ref($tree) eq 'ARRAY') {
    my $i = -1 ;
    foreach my $tree_i ( @$tree ) {
      ++$i ;
      _apply_dtd($dtd , $tree_i , $tag , $i , $prev_tree , $prev_tag , $prev_exists , $parsed , %opts) ;
    }
  }
  else {
    if ( $tag ne '' && $dtd->elem_exists($tag) ) {
      if ( $prev_tree->{'/nodes'}{$tag} =~ /^(\w+,\d+),(\d*)/ ) { $prev_tree->{'/nodes'}{$tag} = "$1,1" ;}
      else { $prev_tree->{'/nodes'}{$tag} = 1 ;}

      if ( !ref($prev_tree->{$tag}) || ( ref($prev_tree->{$tag}) eq 'HASH' && !exists $prev_tree->{$tag}{CONTENT}) ) {
        my $content = $prev_tree->{$tag} ;
        $prev_tree->{$tag} = {} if !ref $prev_tree->{$tag} ;
        $prev_tree->{$tag}{CONTENT} = $content if $content ne '' ;
      }
    }
    elsif ( $tag ne '' && $dtd->attr_exists($prev_tag , $tag) ) {
      delete $prev_tree->{'/nodes'}{$tag} ;
      if ( ref($prev_tree->{$tag}) eq 'HASH' && exists $prev_tree->{$tag}{CONTENT} && (keys %{$prev_tree->{$tag}}) == 1 ) {
        my $content = $prev_tree->{$tag}{CONTENT} ;
        $prev_tree->{$tag} = $content ;
      }
    }
  }

  delete $$parsed{"$tree"} if ref($tree) ;

  _reset_sig_warn() ;
  return 1 ;
}

#######
# END #
#######

1;

__END__