package RDA::Object::Xml;

# $Id: Xml.pm,v 1.16 2008/02/25 14:55:26 mschenke Exp $
# ARCS: $Header: /home/cvs/repository/RDA_4/src/scripting/lib/RDA/Object/Xml.pm,v 1.16 2008/02/25 14:55:26 mschenke Exp $
#
# Change History
# 20080225  MSC  Change the copyright notice.

=head1 NAME

RDA::Object::Xml - Class Used for Objects to Manage XML Data.

=head1 SYNOPSIS

require RDA::Object::Xml;

=head1 DESCRIPTION

The objects of the C<RDA::Object::Xml> class are used to manage XML data. It is
a sub class of C<RDA::Object::Sgml>.

The following methods are available:

=cut

BEGIN
{ use Exporter;
  use RDA::Object::Sgml;
}

use strict;

# Define the global public variables
use vars qw($VERSION @ISA);
$VERSION = sprintf("%d.%02d", q$Revision: 1.16 $ =~ /(\d+)\.(\d+)/);
@ISA     = qw(RDA::Object::Sgml);

# Report the module version number
sub Version
{ $VERSION;
}

=head2 S<$h = RDA::Object::Xml-E<gt>new([$debug])>

The object constructor.

C<RDA::Object::Xml> is represented by a blessed hash reference. Along with
the keys inherited from C<RDA::Object::Sgml>, the following special keys are
also used:

=over 16

=item B<    '-ent'     > Internal entity hash

=item B<    '-ext'     > External entity hash

=item B<    '-pub'     > External entity public hash

=back

=cut

sub new
{ my $cls = shift;
  my $dbg = shift;

  # Create the object
  my $slf = bless RDA::Object::Sgml->new('X', $dbg ? 'XML> ' : ''), $cls;

  # Perform extra initialisation
  $slf->{'-ent'} = {},
  $slf->{'-ext'} = {},
  $slf->{'-pub'} = {},

  # Return the object reference
  $slf;
}

=head2 S<$h-E<gt>data>

This method returns the text or CDATA contained in the object.

=cut

sub data
{ my ($slf) = @_;
  my $buf = '';

  $slf->traverse(\&_data, \$buf);
  $buf;
}

sub _data
{ my ($slf, $lvl, $flg, $buf) = @_;

  if ($flg)
  { $$buf .= $slf->{'-dat'} unless index('CS', $slf->{'-typ'}) < 0;
  }
  1;
}

=head2 S<$h-E<gt>dump>

This method dumps the item tree and reports the list of defined internal and
external entities. It returns a reference to the XML object.

=cut

sub dump
{ my $slf = shift;
  my $lvl = shift || 0;
  my $pre = '  ' x $lvl;

  # Display the entity information
  if (exists($slf->{'-ent'}))
  { print $pre."Entities:\n";
    for (sort keys(%{$slf->{'-ent'}}))
    { print $pre."  $_=".$slf->fmt_str($slf->{'-ent'}->{$_})."\n";
    }
    print "\n";
  }
  if (exists($slf->{'-ext'}))
  { print $pre."External Entities:\n";
    for (sort keys(%{$slf->{'-ext'}}))
    { print $pre."  $_=".$slf->fmt_str($slf->{'-ext'}->{$_})."\n";
    }
    print "\n";
  }

  # Display the tree information
  print $pre."Object tree:\n";
  $slf->SUPER::dump($lvl);
}

=head2 S<$h-E<gt>parse($string)>;

This method parses the specified string as the next XML chunk. It returns a
reference to the XML object.

=cut

sub parse
{ my $slf = shift;
  my $buf  = \$slf->{'-buf'};
  my $dbg  = $slf->{'-dbg'};

  # When EOF, assume rest is text
  return $slf->eof unless defined($_[0]);

  # Filter out some characters
  $_[0] =~ s#\r\n#\n#g;
  $_[0] =~ s#\r#\n#g;

  # Parse XML in the buffer
  $$buf .= $_[0];
  TOKEN: while ($$buf !~ m#^(<\/|<\?|<!|<!\[|<!-|<!--)?$#)
  { $slf->debug('XML> Buffer') if $dbg;

    # Parse the next token
    if ($$buf =~ s#^([^<\]]+)##s)  # Plain text
    { # Extract any text before '<' or ']' characters
      $slf->add_text($1);
      last TOKEN unless length($$buf);
    }
    elsif ($$buf =~ s#^(<!\[)##)  # Section start
    { my $cur = $1;

      if ($$buf =~ s#^(CDATA\[)##)
      { # Treat a data section
        $cur .= $1;
        $slf->debug('XML> ++ CDATA found') if $dbg;
        if ($$buf !~ s#^((.*?)\]\]>)##s)
        { # Need more data to get all data
          $$buf = $cur.$$buf;
          last TOKEN;
        }
        $slf->add_item('C', -dat => $2);
      }
      elsif ($$buf =~ s#^([A-Z]+)\[## ||
             $$buf =~ s#^(\%[a-zA-Z_:][a-zA-Z0-9_:\.\-]*\;)\[##)
      { # Treat a conditional section
        $slf->_add_section($slf->decode($1));
      }
      elsif ($$buf =~ m#^([A-Z]*)$# ||
             $$buf =~ m#^(\%([a-zA-Z_:][a-zA-Z0-9_:\.\-]*(\;)?)?)$#)
      { # Need more data to get the type
        $$buf = $cur.$$buf;
        last TOKEN;
      }
      else
      { # Consider any other pattern as text
        $slf->add_text($cur);
      }
    }
    elsif ($$buf =~ s#^(\](\]>)?)##)  # Conditional section end
    { if ($2)
      { # Close the conditional section
        $slf->_end_section;
      }
      elsif (length($$buf))
      { # Consider any other pattern as text
        $slf->add_text($1);
      }
      else
      { # Need more data to get identify the context
        $$buf = $1.$$buf;
        last TOKEN;
      }
    }
    elsif ($$buf =~ s#^(<!--)\s*##)  # Comment
    { my $cur = $1;
      $slf->debug('XML> ++ Comment found') if $dbg;
      if ($$buf !~ s#^((.*?)\s*-->)##s)
      { # Need more data to get all data
        $$buf = $cur.$$buf;
        last TOKEN;
      }
      $slf->add_item('R', -dat => $2);
    }
    elsif ($$buf =~ s#^(<!)##)  # Markup declaration
    { my ($cur, $typ);

      $cur = $1;
      $slf->debug('XML> ++ Declaration found') if $dbg;

      # Get the declaration type
      if ($$buf =~ s#^(([A-Z]+)\s+)##s)
      { # Extract the declaration type
        $cur .= $1;
        $typ = $2;
      }
      elsif ($$buf =~ m#^[A-Z]+$#)
      { # Need more data to parse the declaration
        $$buf = $cur.$$buf;
        last TOKEN;
      }
      else
      { # Non conform declaration, consider it as text
        $slf->add_text($cur);
        next TOKEN;
      }

      # Extract the declaration
      if ($typ eq 'ENTITY')
      { my (@tok);

        while ($$buf !~ s#^>##)
        { if ($$buf =~ s#^((\%)\s*)##s)
          { # Extract the external entity indicator
            $cur .= $1;
            push(@tok, $2);
          }
          elsif ($$buf =~ s#^(([a-zA-Z_:][a-zA-Z0-9_:\.\-]*)\s+)##s)
          { # Extract a name
            $cur .= $1;
            push(@tok, $2);
          }
          elsif ($$buf =~ s#(^([\042\047])(.*?)\2\s*)##s)
          { # Extract a quoted string
            $cur .= $1;
            push(@tok, "'", $slf->decode($3));
          }
          elsif ($$buf =~ m#^\s*$# ||
                 $$buf =~ m#^([a-zA-Z_:][a-zA-Z0-9_:\.\-]*)?$# ||
                 $$buf =~ m#(^([\042\047]).*$)#s)
          { # Need more data to parse the declaration
            $$buf = $cur.$$buf;
            last TOKEN;
          }
          else
          { # Non conform declaration, consider it as text
            $slf->add_text($cur);
            next TOKEN;
          }
        }
        $slf->_add_entity(@tok);
      }
      else
      { my $dcl = '';
        while ($$buf !~ s#^>##)
        { if ($$buf !~ s#^([^>\[]+)##s && $$buf !~ s#^(\[(.*?)\])##s)
          { # Need more data to get all data
            $$buf = $cur.$dcl.$$buf;
            last TOKEN;
          }
          $dcl .= $1;
        }
        $slf->add_item('D', -nam => $typ, -dat => $dcl);
      }
    }
    elsif ($$buf =~ s#^(<\?xml\s*)##i)  # XML declaration
    { my ($cur, %tbl);

      $cur = $1;
      $slf->debug('XML> ++ XML Declaration found') if $dbg;

      # Look for attributes
      while ($$buf =~ s#^(([a-zA-Z_:][a-zA-Z0-9_:\.\-]*)\s*)##)
      { my ($nam, $val);
        $cur .= $1;
        $nam = $2;

        if ($$buf =~ s#(^=\s*([\042\047])(.*?)\2\s*)##s)
        { # Extract attribute value (quoted)
          $cur .= $1;
          $tbl{$nam} = $slf->decode($3);
        }
        elsif ($$buf =~ m#^(=\s*)$# || $$buf =~ m#^(=\s*[\042\047].*)#s)
        { # Need more data to extract attribute
          $$buf = $cur.$$buf;
          last TOKEN;
        }
        else
        { # Missing or invalid attribute value, consider it as text
          $slf->add_text($cur);
          next TOKEN;
        }
      }

      # Check XML declaration end
      if ($$buf =~ s#^\?>##)
      { $slf->_add_xml(\%tbl);
      }
      elsif (length($$buf))
      { # Not a conforming XML declaration, consider it as text
        $slf->add_text($cur);
      }
      else
      { # Need more data to parse the XML declaration
        $$buf = $cur;
        last TOKEN;
      }
    }
    elsif ($$buf =~ s#^<\?##)  # Processing instruction
    { my ($cur, $tgt);

      $cur = '<?';
      $slf->debug('XML> ++ Processing instruction found') if $dbg;

      # Get the target name
      if ($$buf =~ s#^(([a-zA-Z\_\:][a-zA-Z0-9\_\:\.\-]*)\s*)##)
      { $cur .= $1;
        $tgt = $2;

        # Get the instruction
        if ($$buf !~ s#^((.*?)\s*\?>)##s)
        { # Need more data to parse the processing instruction
          $$buf = $1.$$buf;
          last TOKEN;
        }
        $slf->add_item('P', -nam => $tgt, -dat => $2);
      }
      elsif (length($$buf))
      { # Not a conforming processing instruction, consider it as text
        $slf->add_text($cur);
      }
      else
      { # Need more data to extract the target name
        $$buf = $cur.$$buf;
        last TOKEN;
      }
    }
    elsif ($$buf =~ s#^</##)  # End tag
    { if ($$buf =~ s#^(([a-zA-Z\_\:][a-zA-Z0-9\_\:\.\-]*)\s*>)##)
      { # Close the tag
        $slf->_end_tag($2);
      }
      elsif ($$buf =~ m#^[a-zA-Z\_\:][a-zA-Z0-9\_\:\.\-]*\s*$#)
      { # Need more data for the end tag
        $$buf = '</'.$$buf;
        last TOKEN;
      }
      else
      { # When not valid, consider it as text
        $slf->add_text("</");
      }
    }
    elsif ($$buf =~ s#^(<([a-zA-Z]+)\s*(\/)?>)##)  # Tag without attributes
    { $slf->_add_tag($2, {}, $3);
    }
    elsif ($$buf =~ s#^<##)                        # Tag
    { my ($cur, $tag, %tbl);

      $cur = '<';
      $slf->debug('XML> ++ Start tag found') if $dbg;

      if ($$buf =~ s#^(([a-zA-Z:_][a-zA-Z0-9:_\.\-]*)\s*)##)
      { # Extract the tag name
        $cur .= $1;
        $tag = $2;

        # Extract attributes
        while ($$buf =~ s#^(([a-zA-Z:_][a-zA-Z0-9:_\.\-]*)\s*)##)
        { my ($nam);
          $cur .= $1;
          $nam = $2;

          if ($$buf =~ s#(^=\s*([^\042\047>\s][^>\s]*)\s*)##)
          { # Extract attribute value (unquoted)
            $cur .= $1;
            $tbl{$nam} = $slf->decode($2);
          }
          elsif ($$buf =~ s#(^=\s*([\042\047])(.*?)\2\s*)##s)
          { # Extract attribute value (quoted)
            $cur .= $1;
            $tbl{$nam} = $slf->decode($3);
          }
          elsif ($$buf =~ m#^(=\s*)$# || $$buf =~ m#^(=\s*[\042\047].*)#s)
          { # Need more data to extract attribute
            $$buf = "$cur$1";
            last TOKEN;
          }
          else
          { # Extract attribute value (implicit value)
            $tbl{$nam} = $nam;
          }
        }

        # Check start tag end
        if ($$buf =~ s#^(\/)?>##)
        { # Insert the tag in the object tree
          $slf->_add_tag($tag, \%tbl, $1);
        }
        elsif (length($$buf))
        { # Not a conforming XML declaration, consider it as text
          $slf->add_text($cur);
        }
        else
        { # Need more data to parse the start tag
          $$buf = $cur;
          last TOKEN;
        }
      }
      elsif (length($$buf))
      { # Not a valid start tag, consider it as text
        $slf->add_text($cur);
      }
      else
      { # Need more data to parse the start tag
        $$buf = $cur.$$buf;
        last TOKEN;
      }
    }
  }

  # Return the object reference
  $slf;
}

# Parsing methods
sub _add_entity
{ my $top = shift;
  my ($flg, $nam, $pub, $tok, $val);

  # Insert the entity in the tree
  $top->add_item('E', -dat => join(' ', @_));

  # Decode the entity
  return 0 unless defined($nam = shift);
  if ($nam eq '%')
  { return 0 unless defined($nam = shift);
    $flg = 1;
  }
  return 0 unless defined($tok = shift);
  if ($tok eq "'")
  { return 0 unless defined($val = shift);
  }
  elsif ($tok eq "SYSTEM")
  { return 0 unless defined($tok = shift) && $tok eq "'" &&
                    defined($val = shift);
  }
  elsif ($tok eq "PUBLIC")
  { return 0 unless defined($tok = shift) && $tok eq "'" &&
                    defined($pub = shift) &&
                    defined($tok = shift) && $tok eq "'" &&
                    defined($val = shift);
  }
  else
  { return 0;
  }
  return 0 unless scalar(@_) == 0;
  if ($flg)
  { print "XML> ** Add external entity \%$nam; '$val'\n" if $top->{'-dbg'};
    $top->{'-ext'}->{$nam} = $val;
    $top->{'-pub'}->{$nam} = $pub if defined($pub);
  }
  else
  { print "XML> ** Add entity \&$nam; '$val'\n" if $top->{'-dbg'};
    $top->{'-ent'}->{$nam} = $val;
  }

  return 1;
}

sub _add_section
{ my ($slf, $nam) = @_;
  my ($flg);

  # Resolve entities and determine if the block must be included or ignored
  $flg = ($nam ne 'IGNORE');

  # Create the tag element, insert in the list, and go to the next level
  $slf->add_item('B', -nam => $nam, -flg => $flg);
  $slf->push_item;
}

sub _add_tag
{ my ($slf, $tag, $tbl, $flg) = @_;

  # When requested, filter the tag
  return if exists($slf->{'-flt'}->{'T'});

  # Create the tag element and insert in the list
  $slf->add_item('T', -nam => $tag, %$tbl);

  # Go to the next level when an end tag is expected
  $slf->push_item unless $flg;
}

sub _add_xml
{ my ($slf, $tbl) = @_;

  print 'XML> ** Add XML attributes ('.join(',', %$tbl).")\n"
    if $slf->{'-dbg'};
  foreach my $key (keys(%$tbl))
  { $slf->{$key} = $tbl->{$key};
  }
}

sub decode
{ my ($slf, $str) = @_;

  $str =~ s/(&(\w+);?)/exists($slf->{'-ent'}->{$2}) ? $slf->{'-ent'}->{$2} :
                       $1/eg;
  $str = $slf->SUPER::decode($str);
  $str =~ s/(%(\w+);?)/exists($slf->{'-ext'}->{$2}) ? $slf->{'-ext'}->{$2} :
                       $1/eg;
  $str;
}

sub _end_section
{ my ($slf) = @_;

  # Insert pending text
  $slf->add_text;

  # Close the tag
  $slf->save_stack;
  print "XML> ** Close conditional section\n" if $slf->{'-dbg'};
  my $cur = $slf->{'-cur'};
  for (; $cur->{'-typ'} ne 'X' ; $cur = $slf->pop_item)
  { if ($cur->{'-typ'} eq 'B')
    { $slf->pop_item;
      return;
    }
  }

  # Ignore it when no block has been found
  $slf->restore_stack;
  ++$slf->{'-err'};
  print "ERR> Missing conditional section !\n" if $slf->{'-dbg'};
}

sub _end_tag
{ my ($slf, $tag) = @_;

  # When requested, filter the tag
  return if exists($slf->{'-flt'}->{'T'});

  # Insert pending text
  $slf->add_text;

  # Close the tag
  $slf->save_stack;
  print $slf->{'-dbg'}."** Close tag $tag\n" if $slf->{'-dbg'};
  my $cur = $slf->{'-cur'};
  for (; index('HX', $cur->{'-typ'}) < 0 ; $cur = $slf->pop_item)
  { if ($cur->{'-typ'} eq 'T' && $cur->{'-nam'} eq $tag)
    { $slf->pop_item;
      return;
    }
  }

  # Ignore it when no corresponding tag has been found
  $slf->restore_stack;
  ++$slf->{'-err'};
  print "ERR> Missing tag '$tag' !\n" if $slf->{'-dbg'};
}

1;

__END__

=head1 SEE ALSO

See also L<RDA::Agent|RDA::Agent>, L<RDA::Block|RDA::Block>,
L<RDA::Discover|RDA::Discover>, L<RDA::Module|RDA::Module>,
L<RDA::Setting|RDA::Setting>, L<RDA::Value|RDA::Value>,
L<RDA::Object::Buffer|RDA::Object::Buffer>,
L<RDA::Object::Data|RDA::Object::Data>,
L<RDA::Object::Html|RDA::Object::Html>,
L<RDA::Object::Parser|RDA::Object::Parser>,
L<RDA::Object::Request|RDA::Object::Request>,
L<RDA::Object::Response|RDA::Object::Response>,
L<RDA::Object::Sgml|RDA::Object::Sgml>,
L<RDA::Object::UsrAgent|RDA::Object::UsrAgent>,
L<RDA::Macro::Xml|RDA::Macro::Xml>.

=head1 COPYRIGHT NOTICE

Copyright (c) 2002-2008, Oracle. All rights reserved.

=head1 TRADEMARK NOTICE

Oracle, JD Edwards, PeopleSoft, and Siebel are registered trademarks of Oracle
Corporation and/or its affiliates. Other names may be trademarks of their
respective owners.

=cut