Markup/XML/XPath.pm


=head1 NAME

Message::Markup::XML::XPath --- manakai XML : XML Path Language (XPath) support

=head1 DESCRIPTION

This module implements abstracted XPath object and its
serialization to the expression.

To parse XPath expression, use Message::Markup::XML::XPath::Parser.

This module is part of manakai XML.

=cut

package Message::Markup::XML::XPath;
use strict;
our $VERSION = do{my @r=(q$Revision: 1.19 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
use Char::Class::XML qw!InXML_NCNameStartChar InXMLNCNameChar!;
use Message::Markup::XML::QName qw&DEFAULT_PFX NULL_URI UNDEF_URI&;

use overload 
      '""' => \&stringify,
      fallback => 1;

our %NS = (
           SGML => 'urn:x-suika-fam-cx:markup:sgml:',
           XML  => 'urn:x-suika-fam-cx:markup:xml:',
           internal_ns_invalid  => 'http://suika.fam.cx/~wakaba/-temp/2003/05/17/unknown-namespace#',
           xml  => 'http://www.w3.org/XML/1998/namespace',
           xmlns        => 'http://www.w3.org/2000/xmlns/',
           xpath => 'urn:x-suika-fam-cx:markup:xpath:',
           xslt => 'urn:x-suika-fam-cx:markup:xslt:',
);

=head1 METHODS

=over 4

=item $x = Message::Markup::XML::XPath->new (%options)

Returns new instance of the module.

=cut

sub new ($;%) {
  my $class = shift;
  my $self = bless {
                    axis => 'child',           # axis of step
                    namespace_uri => NULL_URI, # namespace name of node test
                                               #   or function call
                    node => [],                # step in location path
                                               #   or arguments of function call
                    option => {is_context_function_library => {$NS{xpath} => 1}},
                    predict => [],             # predicts in step,etc.
                    type => '#step',           # object type
                    value => '',               # string value of literal 
                                               # or number value
                    @_}, $class;
  for (@{$self->{node}}, @{$self->{predict}}) {
    $_->{parent} = $self;
  }
  $self;
}

=item $x->append_node ($step)

Appending given step to the object (as the last child).
If the type of given step is C<#fragment>, its all children, not the step
itself, are appended.

This method returns the appended step unless the type of given step 
is C<#fragment>. In such cases, this step (C<$x>) is returned.


=cut

sub append_node ($$;%) {
  my $self = shift;
  my ($new_node, %o) = @_;
  unless (ref $new_node) {
    die "append_node: Invalid node";
  }
  if ($new_node->{type} eq '#fragment') {
    for (@{$new_node->{predict}}) {
      push @{$self->{predict}}, $_;
      $_->{parent} = $self;
    }
    $self;
  } else {
    push @{$self->{node}}, $new_node;
    $new_node->{parent} = $self;
    $new_node;
  }
}

=item $new_step = $x->append_new_node (%options)

Appending a new step.  The new node is returned.

=cut

sub append_new_node ($;%) {
  my $self = shift;
  my $new_node = ref ($self)->new (@_, parent => $self);
  push @{$self->{node}}, $new_node;
  $new_node;
}

sub append_new_predict ($;%) {
  my $self = shift;
  my $new_node = ref ($self)->new (@_, parent => $self);
  push @{$self->{predict}}, $new_node;
  $new_node;
}

=item $new_node = $x->append_text ($text)

Appending given text as a new text node.  The new text node is returned.

=cut

sub append_text ($$;%) {
  my ($self, $s, %opt) = @_;
  $s->{value} .= $s;
}

## Non public interface
sub append_baretext ($$;%) {
  my ($self, $s, %opt) = @_;
  $s->{value} .= $s;
}

sub remove_child_node ($$) {
  my ($self, $node) = @_;
  return unless ref $node;
  $node = overload::StrVal ($node);
  $self->{node} = [grep { overload::StrVal ($_) ne $node } @{$self->{node}}];
}

=item \@children = $x->child_nodes

Returns an array reference to child nodes.

=item $local_name = $x->local_name ([$new_name])

Returns or set the local-name.

=item $uri = $x->namespace_uri ([$new_uri])

Returns or set namespace name (URI) of the element or the attribute

=item $uri = $x->namespace_prefix ([$new_prefix])

Returns or set namespace prefix of the element or the attribute.
You may give C<$new_prefix> in form either 'foo' or 'foo:'.
To indicate "default" prefix, use '' (length == 0 string).

=item $uri or ($uri, $name) = $x->expanded_name

Returns expanded name of the node (element or attribute).
In array context, array of namespace name (URI) and local part
is returned; otherwise, a URI which identify name of the node
(in RDF or WebDAV) is returned.

=item $type = $x->node_type

Returns the node type.

=item $node = $x->parent_node

Returns the parent node.  If there is no parent node, undef is returned.

=cut

sub child_nodes ($) { $_[0]->{node} }
sub local_name ($;$) {
  my ($self, $newname) = @_;
  $self->{local_name} = $newname if $newname;
  $self->{local_name};
}
sub node_type ($) { $_[0]->{type} }
sub parent_node ($) { $_[0]->{parent} }

sub namespace_uri ($;$) {
  my ($self, $new_uri) = @_;
  $self->{namespace_uri} = length $new_uri ? $new_uri : NULL_URI
    if defined $new_uri;
  $self->{namespace_uri};
}
sub namespace_prefix ($;$) {
  my ($self, $new_pfx) = @_;
  return DEFAULT_PFX if $self->{namespace_uri} eq NULL_URI;
  
  my $decls = $self->_get_ns_decls_node ();
  
  if (defined ($new_pfx) && $self->{namespace_uri}) {
    Message::Markup::XML::QName::register_prefix_to_name
        ($decls, $new_pfx => $self->{namespace_uri},
         check_prefix => 1, check_xml => 1, check_xmlns => 1);
  }
  Message::Markup::XML::QName::name_to_prefix
      ($decls, $self->{namespace_uri},
       make_new_prefix => 1)
  ->{prefix};
}

sub expanded_name ($) {
  my $self = shift;
  wantarray ? ($self->{namespace_uri}, $self->{local_name})
            : $self->{namespace_uri} . $self->{local_name};
}

=item $i = $x->count

Returns the number of child nodes.

=cut

sub count ($;@) {
  scalar @{$_[0]->{node}};
}

=item $qname = $x->qname

Returns QName ((namespace-)qualified name) of the element type.
Undef is retuened when the type does not have its QName
(ie. when type is neither C<#element> or C<#attribute>).

=cut

sub qname ($;%) {
  my ($self, %opt) = @_;
  my $decls = $self->_get_ns_decls_node ();
  my $q = Message::Markup::XML::QName::expanded_name_to_qname
            ($decls,
             (($opt{use_context_function_library}
               && $self->{option}->{is_context_function_library}
                                 ->{$self->{namespace_uri}}) ?
              NULL_URI : $self->{namespace_uri})
             => ($self->{local_name} || '*'),
             make_new_prefix => 1);
  warn $q->{reason} unless $q->{success};
  $q->{qname};
}

sub _is_same_class ($$) {
  my ($self, $something) = @_;
  eval q{$self->_CLASS_NAME eq $something->_CLASS_NAME} ? 1 : 0;
}

sub root_node ($) {
  my $self = shift;
  if (ref ($self->{parent}) && $self->_is_same_class ($self->{parent})) {
    return $self->{parent}->root_node;
  } else {
    return $self;
  }
}

sub _get_ns_decls_node ($) {
  my $self = shift;
  my $root = $self->root_node;
  if (ref $root->{parent}) {
    return $root->{parent}->_get_ns_decls_node;
  } elsif (ref $root) {
    return $root;
  } else {
    require Carp;
    Carp::carp 'expression holder node not specified';
    return {};
  }
}

sub stringify ($;%) {
  my ($self, %opt) = @_;
  my $r = '';
  if ($self->{type} eq '#step') {
    if ($self->{axis} ne '::root') {
      $r = $self->{axis} . '::' . ($self->qname || '*');
      $r .= $self->__stringify_predicts (\%opt);
    } else {  ## Root node selection
      $r = '/';
    }
  } elsif ($self->{type} eq '#path') {
    $r = join '/', grep {$_ ne '/'} map {
      my $v = $_->stringify;
      if ($_->{type} eq '#expression') {
        $v = '(' . $v . ')';
      }
      $v;
    } @{$self->{node}};
    $r = '/' . $r if $self->{node}->[0]->{type} eq '#step'
                  && $self->{node}->[0]->{axis} eq '::root';
    $r = '-' . $r if $self->{option}->{negated};
  } elsif ($self->{type} eq '#expression') {
    $r = join ' '.($self->{option}->{operator} || '+').' ',
              map {
                my $v = $_->stringify;
                if ($_->{type} eq '#expression') {
                  $v = '(' . $v . ')';
                }
                $v;
              } @{$self->{node}};
    my $predicts = $self->__stringify_predicts;
    $r = '(' . $r . ')' . $predicts if $predicts;
  } elsif ($self->{type} eq '#function') {
    if ($self->{namespace_uri} eq $NS{xpath}) {
      ## Strictly, these are not functions
      if ({qw/comment 1 text 1 processing-instruction 1 node 1/}
          ->{$self->{local_name}}) {
        $r = $self->{axis} . '::';
      }
    }
    $r .= $self->qname (use_context_function_library => 1)
       .  '(' . join (', ', map {$_->stringify} @{$self->{node}})
       .  ')';
    $r .= $self->__stringify_predicts;
  } elsif ($self->{type} eq '#literal') {
    my $v = '' . $self->{value}; # kill "live" object
    if (index ($v, "'") > -1) {
      my @v = split /"/, $v; # ";
      if (@v == 1) {
        $r = '"' . $v . '"';
      } else {
        $r = q<concat ("> . join (q<", '"', ">, @v) . q<")>;
      }
    } else { 
      $r = "'" . $v . "'";
    }
    $r .= $self->__stringify_predicts;
  } elsif ($self->{type} eq '#number') {
    if ($self->{value} =~ /^-?(?:[0-9]+(\.[0-9]*)?|\.[0-9]+)$/) {
      $r = $self->{value};
    } else {
      $r = '0';
    }
  }
  return $r;
}

sub __stringify_predicts ($$) {
  my ($self, $opt) = @_;
  my $r = '';
  for (@{$self->{predict}}) {
    $r .= '[' . $_->stringify . ']';
  }
  $r;
}

sub _CLASS_NAME { 'Message::Markup::XML::XPath' }

sub flag ($$;$) {
  my ($self, $name, $value) = @_;
  if (defined $value) {
    $self->{flag}->{$name} = $value;
  }
  $self->{flag}->{$name};
}

sub option ($$;$) {
  my ($self, $name, $value) = @_;
  if (defined $value) {
    $self->{option}->{$name} = $value;
  }
  $self->{option}->{$name};
}

=back

=head1 NODE TYPES

=over 4 

=item #bare

Bare expression fragment.  This node type should not be used 
unless there is no other way.

=item #expression

An expression.

=item #fragment

Fragment of steps.  It's similar to DOM's fragment node.

=item #function

A function call.

=item #number

A number.

=item #path

A (location) path.

=item #step

A step or root node selection ("/").

=item #text

A literal.

=item #variable

A variable reference.

=cut

=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: 2003/09/14 01:09:36 $
1	wakaba	1.1
2			=head1 NAME
3
4			Message::Markup::XML::XPath --- manakai XML : XML Path Language (XPath) support
5
6			=head1 DESCRIPTION
7
8			This module implements abstracted XPath object and its
9			serialization to the expression.
10
11			To parse XPath expression, use Message::Markup::XML::XPath::Parser.
12
13			This module is part of manakai XML.
14
15			=cut
16
17			package Message::Markup::XML::XPath;
18			use strict;
19			our $VERSION = do{my @r=(q$Revision: 1.19 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
20			use Char::Class::XML qw!InXML_NCNameStartChar InXMLNCNameChar!;
21			use Message::Markup::XML::QName qw&DEFAULT_PFX NULL_URI UNDEF_URI&;
22
23			use overload
24			'""' => \&stringify,
25			fallback => 1;
26
27			our %NS = (
28			SGML => 'urn:x-suika-fam-cx:markup:sgml:',
29			XML => 'urn:x-suika-fam-cx:markup:xml:',
30			internal_ns_invalid => 'http://suika.fam.cx/~wakaba/-temp/2003/05/17/unknown-namespace#',
31			xml => 'http://www.w3.org/XML/1998/namespace',
32			xmlns => 'http://www.w3.org/2000/xmlns/',
33			xpath => 'urn:x-suika-fam-cx:markup:xpath:',
34			xslt => 'urn:x-suika-fam-cx:markup:xslt:',
35			);
36
37			=head1 METHODS
38
39			=over 4
40
41			=item $x = Message::Markup::XML::XPath->new (%options)
42
43			Returns new instance of the module.
44
45			=cut
46
47			sub new ($;%) {
48			my $class = shift;
49			my $self = bless {
50			axis => 'child', # axis of step
51			namespace_uri => NULL_URI, # namespace name of node test
52			# or function call
53			node => [], # step in location path
54			# or arguments of function call
55			option => {is_context_function_library => {$NS{xpath} => 1}},
56			predict => [], # predicts in step,etc.
57			type => '#step', # object type
58			value => '', # string value of literal
59			# or number value
60			@_}, $class;
61			for (@{$self->{node}}, @{$self->{predict}}) {
62			$_->{parent} = $self;
63			}
64			$self;
65			}
66
67			=item $x->append_node ($step)
68
69			Appending given step to the object (as the last child).
70			If the type of given step is C<#fragment>, its all children, not the step
71			itself, are appended.
72
73			This method returns the appended step unless the type of given step
74			is C<#fragment>. In such cases, this step (C<$x>) is returned.
75
76
77			=cut
78
79			sub append_node ($$;%) {
80			my $self = shift;
81			my ($new_node, %o) = @_;
82			unless (ref $new_node) {
83			die "append_node: Invalid node";
84			}
85			if ($new_node->{type} eq '#fragment') {
86			for (@{$new_node->{predict}}) {
87			push @{$self->{predict}}, $_;
88			$_->{parent} = $self;
89			}
90			$self;
91			} else {
92			push @{$self->{node}}, $new_node;
93			$new_node->{parent} = $self;
94			$new_node;
95			}
96			}
97
98			=item $new_step = $x->append_new_node (%options)
99
100			Appending a new step. The new node is returned.
101
102			=cut
103
104			sub append_new_node ($;%) {
105			my $self = shift;
106			my $new_node = ref ($self)->new (@_, parent => $self);
107			push @{$self->{node}}, $new_node;
108			$new_node;
109			}
110
111			sub append_new_predict ($;%) {
112			my $self = shift;
113			my $new_node = ref ($self)->new (@_, parent => $self);
114			push @{$self->{predict}}, $new_node;
115			$new_node;
116			}
117
118			=item $new_node = $x->append_text ($text)
119
120			Appending given text as a new text node. The new text node is returned.
121
122			=cut
123
124			sub append_text ($$;%) {
125			my ($self, $s, %opt) = @_;
126			$s->{value} .= $s;
127			}
128
129			## Non public interface
130			sub append_baretext ($$;%) {
131			my ($self, $s, %opt) = @_;
132			$s->{value} .= $s;
133			}
134
135			sub remove_child_node ($$) {
136			my ($self, $node) = @_;
137			return unless ref $node;
138			$node = overload::StrVal ($node);
139			$self->{node} = [grep { overload::StrVal ($_) ne $node } @{$self->{node}}];
140			}
141
142			=item \@children = $x->child_nodes
143
144			Returns an array reference to child nodes.
145
146			=item $local_name = $x->local_name ([$new_name])
147
148			Returns or set the local-name.
149
150			=item $uri = $x->namespace_uri ([$new_uri])
151
152			Returns or set namespace name (URI) of the element or the attribute
153
154			=item $uri = $x->namespace_prefix ([$new_prefix])
155
156			Returns or set namespace prefix of the element or the attribute.
157			You may give C<$new_prefix> in form either 'foo' or 'foo:'.
158			To indicate "default" prefix, use '' (length == 0 string).
159
160			=item $uri or ($uri, $name) = $x->expanded_name
161
162			Returns expanded name of the node (element or attribute).
163			In array context, array of namespace name (URI) and local part
164			is returned; otherwise, a URI which identify name of the node
165			(in RDF or WebDAV) is returned.
166
167			=item $type = $x->node_type
168
169			Returns the node type.
170
171			=item $node = $x->parent_node
172
173			Returns the parent node. If there is no parent node, undef is returned.
174
175			=cut
176
177			sub child_nodes ($) { $_[0]->{node} }
178			sub local_name ($;$) {
179			my ($self, $newname) = @_;
180			$self->{local_name} = $newname if $newname;
181			$self->{local_name};
182			}
183			sub node_type ($) { $_[0]->{type} }
184			sub parent_node ($) { $_[0]->{parent} }
185
186			sub namespace_uri ($;$) {
187			my ($self, $new_uri) = @_;
188			$self->{namespace_uri} = length $new_uri ? $new_uri : NULL_URI
189			if defined $new_uri;
190			$self->{namespace_uri};
191			}
192			sub namespace_prefix ($;$) {
193			my ($self, $new_pfx) = @_;
194			return DEFAULT_PFX if $self->{namespace_uri} eq NULL_URI;
195
196			my $decls = $self->_get_ns_decls_node ();
197
198			if (defined ($new_pfx) && $self->{namespace_uri}) {
199			Message::Markup::XML::QName::register_prefix_to_name
200			($decls, $new_pfx => $self->{namespace_uri},
201			check_prefix => 1, check_xml => 1, check_xmlns => 1);
202			}
203			Message::Markup::XML::QName::name_to_prefix
204			($decls, $self->{namespace_uri},
205			make_new_prefix => 1)
206			->{prefix};
207			}
208
209			sub expanded_name ($) {
210			my $self = shift;
211			wantarray ? ($self->{namespace_uri}, $self->{local_name})
212			: $self->{namespace_uri} . $self->{local_name};
213			}
214
215			=item $i = $x->count
216
217			Returns the number of child nodes.
218
219			=cut
220
221			sub count ($;@) {
222			scalar @{$_[0]->{node}};
223			}
224
225			=item $qname = $x->qname
226
227			Returns QName ((namespace-)qualified name) of the element type.
228			Undef is retuened when the type does not have its QName
229			(ie. when type is neither C<#element> or C<#attribute>).
230
231			=cut
232
233			sub qname ($;%) {
234			my ($self, %opt) = @_;
235			my $decls = $self->_get_ns_decls_node ();
236			my $q = Message::Markup::XML::QName::expanded_name_to_qname
237			($decls,
238			(($opt{use_context_function_library}
239			&& $self->{option}->{is_context_function_library}
240			->{$self->{namespace_uri}}) ?
241			NULL_URI : $self->{namespace_uri})
242			=> ($self->{local_name} \|\| '*'),
243			make_new_prefix => 1);
244			warn $q->{reason} unless $q->{success};
245			$q->{qname};
246			}
247
248			sub _is_same_class ($$) {
249			my ($self, $something) = @_;
250			eval q{$self->_CLASS_NAME eq $something->_CLASS_NAME} ? 1 : 0;
251			}
252
253			sub root_node ($) {
254			my $self = shift;
255			if (ref ($self->{parent}) && $self->_is_same_class ($self->{parent})) {
256			return $self->{parent}->root_node;
257			} else {
258			return $self;
259			}
260			}
261
262			sub _get_ns_decls_node ($) {
263			my $self = shift;
264			my $root = $self->root_node;
265			if (ref $root->{parent}) {
266			return $root->{parent}->_get_ns_decls_node;
267			} elsif (ref $root) {
268			return $root;
269			} else {
270			require Carp;
271			Carp::carp 'expression holder node not specified';
272			return {};
273			}
274			}
275
276			sub stringify ($;%) {
277			my ($self, %opt) = @_;
278			my $r = '';
279			if ($self->{type} eq '#step') {
280			if ($self->{axis} ne '::root') {
281			$r = $self->{axis} . '::' . ($self->qname \|\| '*');
282			$r .= $self->__stringify_predicts (\%opt);
283			} else { ## Root node selection
284			$r = '/';
285			}
286			} elsif ($self->{type} eq '#path') {
287			$r = join '/', grep {$_ ne '/'} map {
288			my $v = $_->stringify;
289			if ($_->{type} eq '#expression') {
290			$v = '(' . $v . ')';
291			}
292			$v;
293			} @{$self->{node}};
294			$r = '/' . $r if $self->{node}->[0]->{type} eq '#step'
295			&& $self->{node}->[0]->{axis} eq '::root';
296			$r = '-' . $r if $self->{option}->{negated};
297			} elsif ($self->{type} eq '#expression') {
298			$r = join ' '.($self->{option}->{operator} \|\| '+').' ',
299			map {
300			my $v = $_->stringify;
301			if ($_->{type} eq '#expression') {
302			$v = '(' . $v . ')';
303			}
304			$v;
305			} @{$self->{node}};
306			my $predicts = $self->__stringify_predicts;
307			$r = '(' . $r . ')' . $predicts if $predicts;
308			} elsif ($self->{type} eq '#function') {
309			if ($self->{namespace_uri} eq $NS{xpath}) {
310			## Strictly, these are not functions
311			if ({qw/comment 1 text 1 processing-instruction 1 node 1/}
312			->{$self->{local_name}}) {
313			$r = $self->{axis} . '::';
314			}
315			}
316			$r .= $self->qname (use_context_function_library => 1)
317			. '(' . join (', ', map {$_->stringify} @{$self->{node}})
318			. ')';
319			$r .= $self->__stringify_predicts;
320			} elsif ($self->{type} eq '#literal') {
321			my $v = '' . $self->{value}; # kill "live" object
322			if (index ($v, "'") > -1) {
323			my @v = split /"/, $v; # ";
324			if (@v == 1) {
325			$r = '"' . $v . '"';
326			} else {
327			$r = q<concat ("> . join (q<", '"', ">, @v) . q<")>;
328			}
329			} else {
330			$r = "'" . $v . "'";
331			}
332			$r .= $self->__stringify_predicts;
333			} elsif ($self->{type} eq '#number') {
334			if ($self->{value} =~ /^-?(?:[0-9]+(\.[0-9]*)?\|\.[0-9]+)$/) {
335			$r = $self->{value};
336			} else {
337			$r = '0';
338			}
339			}
340			return $r;
341			}
342
343			sub __stringify_predicts ($$) {
344			my ($self, $opt) = @_;
345			my $r = '';
346			for (@{$self->{predict}}) {
347			$r .= '[' . $_->stringify . ']';
348			}
349			$r;
350			}
351
352			sub _CLASS_NAME { 'Message::Markup::XML::XPath' }
353
354			sub flag ($$;$) {
355			my ($self, $name, $value) = @_;
356			if (defined $value) {
357			$self->{flag}->{$name} = $value;
358			}
359			$self->{flag}->{$name};
360			}
361
362			sub option ($$;$) {
363			my ($self, $name, $value) = @_;
364			if (defined $value) {
365			$self->{option}->{$name} = $value;
366			}
367			$self->{option}->{$name};
368			}
369
370			=back
371
372			=head1 NODE TYPES
373
374			=over 4
375
376			=item #bare
377
378			Bare expression fragment. This node type should not be used
379			unless there is no other way.
380
381			=item #expression
382
383			An expression.
384
385			=item #fragment
386
387			Fragment of steps. It's similar to DOM's fragment node.
388
389			=item #function
390
391			A function call.
392
393			=item #number
394
395			A number.
396
397			=item #path
398
399			A (location) path.
400
401			=item #step
402
403			A step or root node selection ("/").
404
405			=item #text
406
407			A literal.
408
409			=item #variable
410
411			A variable reference.
412
413			=cut
414
415			=head1 LICENSE
416
417			Copyright 2003 Wakaba <[email protected]>
418
419			This program is free software; you can redistribute it and/or
420			modify it under the same terms as Perl itself.
421
422			=cut
423
424			1; # $Date: 2003/09/14 01:09:36 $