Markup/XML/NodeTree.pm


=head1 NAME

Message::Markup::XML::Node --- manakai XML : XML Node Implementation

=head1 DESCRIPTION

This module implements the XML Node object.

This module is part of manakai XML.

=cut

package Message::Markup::XML::NodeTree;
use strict;
our $VERSION = do{my @r=(q$Revision: 1.3 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
use Message::Markup::XML::Node;
use Message::Markup::XML::QName qw/:prefix :special-uri/;
use Exporter;
push our @ISA, 'Exporter';

our @EXPORT_OK = qw/construct_xml_tree/;

=head1 METHODS

=over 4

=cut

sub construct_xml_tree (%);
sub construct_xml_tree (%) {
  my %opt = @_;
  my $parent = $opt{parent} || 'Message::Markup::XML::Node';
  my $method = ref $opt{parent} ? 'append_new_node' : 'new';
  my $node = $parent->$method (map {$_=>$opt{$_}} grep /^[^-]/, keys %opt);
  for (keys %{$opt{-attr}||{}}) {
    $node->set_attribute ($_ => $opt{-attr}->{$_});
  }
  for (@{$opt{-child}||[]}) {
    construct_xml_tree (%$_, parent => $node);
  }
  for (keys %{$opt{-ns}||{}}) {
    $node->{ns}->{   $_
                  || ($_ eq '0' ? '0' : DEFAULT_PFX) }
      = $opt{-ns}->{$_}
                  || ($opt{-ns}->{$_} eq '0' ? ZERO_URI
                                             : NULL_URI);
  }
  $node;
}


#------- Not (re-)Implemented Yet -------

my %NS;
sub merge_external_subset ($) {
  my $self = shift;
  unless ($self->{type} eq '#declaration'
       && $self->{namespace_uri} eq $NS{SGML}.'doctype') {
    return unless $self->{type} eq '#document' || $self->{type} eq '#fragment';
    for (@{$self->{node}}) {
      $_->merge_external_subset;
    }
    return;
  }
  my $xsub = $self->get_attribute ('external-subset');
  return unless ref $xsub;
  for (@{$xsub->{node}}) {
    $_->{parent} = $self;
  }
  push @{$self->{node}}, @{$xsub->{node}};
  $self->remove_child_node ($xsub);
  $self->remove_child_node ($self->get_attribute ('PUBLIC'));
  $self->remove_child_node ($self->get_attribute ('SYSTEM'));
  $self->remove_marked_section;
}

sub remove_marked_section ($) {
  my $self = shift;
  my @node;
  for (@{$self->{node}}) {
    if ({qw/#declaration 1 #element 1 #section 1 #reference 1 #attribute 1
            #document 1 #fragment 1/}->{$_->{type}}) {
      $_->remove_marked_section;
    }
  }
  for (@{$self->{node}}) {
    if ($_->{type} ne '#section') {
      push @node, $_;
    } else {
      my $status = $_->get_attribute ('status', make_new_node => 1)->inner_text;
      if ($status eq 'CDATA') {
        $_->{type} = '#text';
        $_->remove_attribute ('status');
        push @node, $_;
      } elsif ($status ne 'IGNORE') {   # INCLUDE
        for my $e (@{$_->{node}}) {
          if ($e->{type} ne '#attribute') {
            $e->{parent} = $self;
            push @node, $e;
          }
        }
      }
    }
  }
  $self->{node} = \@node;
}

## TODO: references in EntityValue
sub remove_references ($) {
  my $self = shift;
  my @node;
  for (@{$self->{node}}) {
    if ({qw/#declaration 1 #element 1 #section 1 #reference 1 #attribute 1
            #document 1 #fragment 1/}->{$_->{type}}) {
      $_->remove_references;
    }
  }
  for (@{$self->{node}}) {
    if ($_->{type} ne '#reference'
    || ($self->{type} eq '#declaration'
     && $_->{namespace_uri} eq $NS{SGML}.'entity')) {
      push @node, $_;
    } else {
      if (index ($_->{namespace_uri}, 'char') > -1) {
        my $e = ref ($_)->new (type => '#text', value => chr $_->{value});
        $e->{parent} = $self;
        push @node, $e;
      } elsif ($_->{flag}->{smxp__ref_expanded}) {
        for my $e (@{$_->{node}}) {
          if ($e->{type} ne '#attribute') {
            $e->{parent} = $self;
            push @node, $e;
          }
        }
      } else {  ## reference is not expanded
        push @node, $_;
      }
    }
    $_->{flag}->{smxp__defined_with_param_ref} = 0
      if $_->{flag}->{smxp__defined_with_param_ref}
      && !$_->{flag}->{smxp__non_processed_declaration};
  }
  $self->{node} = \@node;
}

sub resolve_relative_uri ($;$%) {
  require URI;
  my ($self, $rel, %o) = @_;
  my $base = $self->get_attribute ('base', namespace_uri => $NS{xml});
  $base = ref ($base) ? $base->inner_text : $NS{default_base_uri};
  if ($base !~ /^[0-9A-Za-z.%+-]+:/) {  # $base is relative
    $base = $self->Message::Markup::XML::NodeTree::_resolve_relative_uri_by_parent ($base, \%o);
  }
  eval q{       ## Catch error such as $base is 'data:,foo' (non hierarchic scheme,...)
    return URI->new ($rel)->abs ($base || '.'); ## BUG (or spec) of URI: $base == false
  } or return $rel;
}
sub _resolve_relative_uri_by_parent ($$$) {
  my ($self, $rel, $o) = @_;
  if (ref $self->{parent}) {
    if (!$o->{use_references_base_uri} && $self->{parent}->{type} eq '#reference') {
      ## This case is necessary to work with
      ## <element>      <!-- element can have base URI -->
      ## text           <!-- text cannot have base URI -->
      ##   &ent;        <!-- ref's base URI is referred entity's one (in this module) -->
      ##     <!-- expantion of ent -->
      ##     entity's text      <!-- text cannot have base URI, so use <element>'s one -->
      ##     <entitys-element/> <!-- element can have base URI, otherwise ENTITY's one -->
      ## </element>
      return $self->{parent}->_resolve_relative_uri_by_parent ($rel, $o);
    } else {
      return $self->{parent}->resolve_relative_uri ($rel, %$o);
    }
  } else {
    return $rel;
  }
}

sub root_node ($) {
  my $self = shift;
  if ($self->{type} eq '#document') {
    return $self;
  } elsif (ref $self->{parent}) {
    return $self->{parent}->root_node;
  } else {
    return $self;
  }
}

sub _get_entity_manager ($) {
  my $self = shift;
  if ($self->{type} eq '#document') {
    unless ($self->{flag}->{smx__entity_manager}) {
      require Message::Markup::XML::EntityManager;
      $self->{flag}->{smx__entity_manager} = Message::Markup::XML::EntityManager->new ($self);
    }
    return $self->{flag}->{smx__entity_manager};
  } elsif (ref $self->{parent}) {
    return $self->{parent}->_get_entity_manager;
  } else {
    unless ($self->{flag}->{smx__entity_manager}) {
      require Message::Markup::XML::EntityManager;
      $self->{flag}->{smx__entity_manager} = Message::Markup::XML::EntityManager->new ($self);
    }
    return $self->{flag}->{smx__entity_manager};
  }
}

=head1 LICENSE

Copyright 2003 Wakaba <[email protected]>

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

1; # $Date: 2004/02/22 01:46:23 $
1	wakaba	1.1
2			=head1 NAME
3
4			Message::Markup::XML::Node --- manakai XML : XML Node Implementation
5
6			=head1 DESCRIPTION
7
8			This module implements the XML Node object.
9
10			This module is part of manakai XML.
11
12			=cut
13
14			package Message::Markup::XML::NodeTree;
15			use strict;
16	wakaba	1.2.2.1	our $VERSION = do{my @r=(q$Revision: 1.3 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
17	wakaba	1.1	use Message::Markup::XML::Node;
18			use Message::Markup::XML::QName qw/:prefix :special-uri/;
19			use Exporter;
20			push our @ISA, 'Exporter';
21
22			our @EXPORT_OK = qw/construct_xml_tree/;
23
24			=head1 METHODS
25
26			=over 4
27
28			=cut
29
30	wakaba	1.2	sub construct_xml_tree (%);
31	wakaba	1.1	sub construct_xml_tree (%) {
32			my %opt = @_;
33			my $parent = $opt{parent} \|\| 'Message::Markup::XML::Node';
34			my $method = ref $opt{parent} ? 'append_new_node' : 'new';
35			my $node = $parent->$method (map {$_=>$opt{$_}} grep /^[^-]/, keys %opt);
36			for (keys %{$opt{-attr}\|\|{}}) {
37			$node->set_attribute ($_ => $opt{-attr}->{$_});
38			}
39			for (@{$opt{-child}\|\|[]}) {
40			construct_xml_tree (%$_, parent => $node);
41			}
42			for (keys %{$opt{-ns}\|\|{}}) {
43			$node->{ns}->{ $_
44			\|\| ($_ eq '0' ? '0' : DEFAULT_PFX) }
45			= $opt{-ns}->{$_}
46			\|\| ($opt{-ns}->{$_} eq '0' ? ZERO_URI
47			: NULL_URI);
48			}
49			$node;
50			}
51
52
53			#------- Not (re-)Implemented Yet -------
54
55			my %NS;
56			sub merge_external_subset ($) {
57			my $self = shift;
58			unless ($self->{type} eq '#declaration'
59			&& $self->{namespace_uri} eq $NS{SGML}.'doctype') {
60			return unless $self->{type} eq '#document' \|\| $self->{type} eq '#fragment';
61			for (@{$self->{node}}) {
62			$_->merge_external_subset;
63			}
64			return;
65			}
66			my $xsub = $self->get_attribute ('external-subset');
67			return unless ref $xsub;
68			for (@{$xsub->{node}}) {
69			$_->{parent} = $self;
70			}
71			push @{$self->{node}}, @{$xsub->{node}};
72			$self->remove_child_node ($xsub);
73			$self->remove_child_node ($self->get_attribute ('PUBLIC'));
74			$self->remove_child_node ($self->get_attribute ('SYSTEM'));
75			$self->remove_marked_section;
76			}
77
78			sub remove_marked_section ($) {
79			my $self = shift;
80			my @node;
81			for (@{$self->{node}}) {
82			if ({qw/#declaration 1 #element 1 #section 1 #reference 1 #attribute 1
83			#document 1 #fragment 1/}->{$_->{type}}) {
84			$_->remove_marked_section;
85			}
86			}
87			for (@{$self->{node}}) {
88			if ($_->{type} ne '#section') {
89			push @node, $_;
90			} else {
91			my $status = $_->get_attribute ('status', make_new_node => 1)->inner_text;
92			if ($status eq 'CDATA') {
93			$_->{type} = '#text';
94			$_->remove_attribute ('status');
95			push @node, $_;
96			} elsif ($status ne 'IGNORE') { # INCLUDE
97			for my $e (@{$_->{node}}) {
98			if ($e->{type} ne '#attribute') {
99			$e->{parent} = $self;
100			push @node, $e;
101			}
102			}
103			}
104			}
105			}
106			$self->{node} = \@node;
107			}
108
109			## TODO: references in EntityValue
110			sub remove_references ($) {
111			my $self = shift;
112			my @node;
113			for (@{$self->{node}}) {
114			if ({qw/#declaration 1 #element 1 #section 1 #reference 1 #attribute 1
115			#document 1 #fragment 1/}->{$_->{type}}) {
116			$_->remove_references;
117			}
118			}
119			for (@{$self->{node}}) {
120			if ($_->{type} ne '#reference'
121			\|\| ($self->{type} eq '#declaration'
122			&& $_->{namespace_uri} eq $NS{SGML}.'entity')) {
123			push @node, $_;
124			} else {
125			if (index ($_->{namespace_uri}, 'char') > -1) {
126			my $e = ref ($_)->new (type => '#text', value => chr $_->{value});
127			$e->{parent} = $self;
128			push @node, $e;
129			} elsif ($_->{flag}->{smxp__ref_expanded}) {
130			for my $e (@{$_->{node}}) {
131			if ($e->{type} ne '#attribute') {
132			$e->{parent} = $self;
133			push @node, $e;
134			}
135			}
136			} else { ## reference is not expanded
137			push @node, $_;
138			}
139			}
140			$_->{flag}->{smxp__defined_with_param_ref} = 0
141			if $_->{flag}->{smxp__defined_with_param_ref}
142			&& !$_->{flag}->{smxp__non_processed_declaration};
143			}
144			$self->{node} = \@node;
145			}
146
147			sub resolve_relative_uri ($;$%) {
148			require URI;
149			my ($self, $rel, %o) = @_;
150			my $base = $self->get_attribute ('base', namespace_uri => $NS{xml});
151			$base = ref ($base) ? $base->inner_text : $NS{default_base_uri};
152			if ($base !~ /^[0-9A-Za-z.%+-]+:/) { # $base is relative
153	wakaba	1.2.2.1	$base = $self->Message::Markup::XML::NodeTree::_resolve_relative_uri_by_parent ($base, \%o);
154	wakaba	1.1	}
155			eval q{ ## Catch error such as $base is 'data:,foo' (non hierarchic scheme,...)
156			return URI->new ($rel)->abs ($base \|\| '.'); ## BUG (or spec) of URI: $base == false
157			} or return $rel;
158			}
159			sub _resolve_relative_uri_by_parent ($$$) {
160			my ($self, $rel, $o) = @_;
161			if (ref $self->{parent}) {
162			if (!$o->{use_references_base_uri} && $self->{parent}->{type} eq '#reference') {
163			## This case is necessary to work with
164			## <element> <!-- element can have base URI -->
165			## text <!-- text cannot have base URI -->
166			## &ent; <!-- ref's base URI is referred entity's one (in this module) -->
167			## <!-- expantion of ent -->
168			## entity's text <!-- text cannot have base URI, so use <element>'s one -->
169			## <entitys-element/> <!-- element can have base URI, otherwise ENTITY's one -->
170			## </element>
171			return $self->{parent}->_resolve_relative_uri_by_parent ($rel, $o);
172			} else {
173			return $self->{parent}->resolve_relative_uri ($rel, %$o);
174			}
175			} else {
176			return $rel;
177			}
178			}
179
180			sub root_node ($) {
181			my $self = shift;
182			if ($self->{type} eq '#document') {
183			return $self;
184			} elsif (ref $self->{parent}) {
185			return $self->{parent}->root_node;
186			} else {
187			return $self;
188			}
189			}
190
191			sub _get_entity_manager ($) {
192			my $self = shift;
193			if ($self->{type} eq '#document') {
194			unless ($self->{flag}->{smx__entity_manager}) {
195			require Message::Markup::XML::EntityManager;
196			$self->{flag}->{smx__entity_manager} = Message::Markup::XML::EntityManager->new ($self);
197			}
198			return $self->{flag}->{smx__entity_manager};
199			} elsif (ref $self->{parent}) {
200			return $self->{parent}->_get_entity_manager;
201			} else {
202			unless ($self->{flag}->{smx__entity_manager}) {
203			require Message::Markup::XML::EntityManager;
204			$self->{flag}->{smx__entity_manager} = Message::Markup::XML::EntityManager->new ($self);
205			}
206			return $self->{flag}->{smx__entity_manager};
207			}
208			}
209
210			=head1 LICENSE
211
212			Copyright 2003 Wakaba <[email protected]>
213
214			This program is free software; you can redistribute it and/or
215			modify it under the same terms as Perl itself.
216
217			=cut
218
219	wakaba	1.2.2.1	1; # $Date: 2004/02/22 01:46:23 $