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.2 $=~/\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/14 11:08:45 $
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	our $VERSION = do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
17	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	sub construct_xml_tree (%);
31	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	$base = $self->Message::Markup::XML::NodeTree::_resolve_relative_uri_by_parent ($base, \%o);
154	}
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	1; # $Date: 2004/02/14 11:08:45 $