Markup/SuikaWikiConfig20/Node.pm


=head1 NAME

Message::Markup::SuikaWikiConfig20::Node: manakai --- SuikaWikiConfig/2.0 data object and serialization

=head1 DESCRIPTION

This module provides modeled object tree handling for SuikaWikiConfig/2.0 data
format.  It also provides a mean of serializing object data tree in
SuikaWikiConfig/2.0 format.

Note that to parse plain SuikaWikiConfig/2.0 data and compose object
tree for it, Message::Markup::SuikaWikiConfig20::Parser
can be used.

This module is part of manakai.

=cut

package Message::Markup::SuikaWikiConfig20::Node;
use strict;
our $VERSION = do{my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};

=head1 METHODS

=over 4

=item $x = Message::Markup::SuikaWikiConfig20::Node->new (%options)

Returns new instance of the module.  It is itself a node.

=cut

sub new ($;%) {
  my $class = shift;
  my $self = bless {@_}, $class;
  $self->{type} ||= '#element';
  $self->{node} ||= [];
  $self;
}

=item $x->append_node ($node)

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

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

Available options: C<node_or_text>.

=cut

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

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

Appending a new node.  The new node is returned.

=cut

sub append_new_node ($;%) {
  my $self = shift;
  my $new_node = __PACKAGE__->new (@_);
  push @{$self->{node}}, $new_node;
  $new_node->{parent} = $self;
  $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 = shift;
  my $s = shift;
  if (ref ($self->{value}) eq 'ARRAY') {
    push @{$self->{value}}, $s;
  } else {
    $self->{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 $attr_node = $x->get_attribute ($local_name, %options)

Returns the attribute node whose local-name is C<$local_name>.

=item $attr_val = $x->get_attribute_value ($local_name)

Returnes the attribute value whose attribute name is C<$local_name>.

=cut

sub get_attribute ($$;%) {
  my ($self, $name, %o) = @_;
  for (@{$self->{node}}) {
    if ($_->{type} eq '#element'
        && $_->{local_name} eq $name) {
      return $_;
    }
  }
  ## Node is not exist
  if ($o{make_new_node}) {
    return $self->append_new_node (type => '#element', local_name => $name);
  } else {
    return undef;
  }
}
sub get_attribute_value ($$;%) {
  my ($self, $name) = @_;
  my $node = $self->get_attribute ($name);
  if (ref $node) {
    return $node->value;
  } else {
    return undef;
  }
}

=item $attr_node = $x->set_attribute ($local_name => $value, %options)

Set the value of the attribute.  The attribute node is returned.

=cut

sub set_attribute ($$$;%) {
  my ($self, $name, $val, %o) = @_;
  if ({qw/ARRAY 1 HASH 1 CODE 1/}->{ref ($val)}) {
  ## TODO: common error handling
    die "set_attribute: new attribute value must be string or blessed object";
  }
  for (@{$self->{node}}) {
    if ($_->{type} eq '#element'
        && $_->{local_name} eq $name) {
      $_->{value} = $val;
      $_->{node} = [];
      return $_;
    }
  }
  return $self->append_new_node (type => '#element', local_name => $name,
                                 value => $val);
}

=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 $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} }

=item $i = $x->count

Returns the number of child nodes.

=cut

# TODO: support counting by type
sub count ($;@) {
  (defined $_[0]->{value} ? 1 : 0) + scalar @{$_[0]->{node}};
}

=item $tag = $x->inner_text

Returns the text content of the node.  (In many case the returned value is same
as WinIE DOM C<inner_text ()> function's or XPath C<text()> function's.
But some classes that inherits this module might implement to return other
value (eg. to return the value of the alt attribute of html:img element).

=cut

sub inner_text ($;%) {
  my $self = shift;
  my %o = @_;
  my $r = '';
  if (defined $o{new_value}) {
    $self->{value} = $o{new_value};
  }
  ref ($self->{value}) eq 'ARRAY' ? join "\x0A", @{$self->{value}} :
                                    $self->{value};
}

sub value ($) {
  shift->{value};
}

sub stringify ($;%) {
  my ($self, %opt) = @_;
  my $r = '';
  if ($self->{type} eq '#document') {
    if ($opt{output_header}) {
      $r = "#?SuikaWiki/0.9\x0A";
    }
    my $ptype = '#';
    for (@{$self->{node}}) {
      $r .= "\x0A" if $ptype eq '#comment' && $_->{type} eq '#comment';
      $ptype = $_->{type};
      $r .= $_->stringify;
    }
  } elsif ($self->{type} eq '#element') {
    $r = $self->inner_text;
    $r =~ s/(^|\x0A)(?=([\\\@\#\s]))?/$1."  ".($2?"\\":"")/ges;
    if (scalar @{$self->{node}}) {
      $r = $self->{local_name}
         . ":\x0A  \@\@"
         . (ref ($self->{value}) eq 'ARRAY' ? '[list]' : '')
         . ":" . (($r !~ /[\x0D\x0A:]/) && (length ($r) < 50) ? '' : "\x0A")
         . $r . "\x0A";
      for (@{$self->{node}}) {
        next unless $_->{type} eq '#element';
        my $rc = $_->stringify;
        $rc =~ s/\x0A  /\x0A     /gs;
        $rc =~ s/(\x0A +\@)/$1\@/gs;
        $r .= '  @' . $rc;
      }
    } else {
      $r = $self->{local_name}
         . (ref ($self->{value}) eq 'ARRAY' ? '[list]' : '')
         . ":" . ((($r !~ /[\x0D\x0A:]/) && (length ($r) < 50)) ? '' : "\x0A")
         . $r . "\x0A";
    }
    $r = "\\" . $r if substr ($r, 0, 1) =~ /[\\\@\#\s]/;
  } else {
    $r = $self->inner_text;
    $r =~ s/\x0A/\x0A#/gs;
    $r = '#' . $r . "\n";
  }
  $r;
}

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 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};
}

sub clone ($;%) {
  my $self = shift;
  my $clone = bless {node => []}, ref $self;
  ## TODO: Cloning recursively
  $clone->{flag} = {%{$self->{flag}||{}}};
  $clone->{option} = {%{$self->{option}||{}}};
  for (qw/local_name value type/) {
    $clone->{$_} = $self->{$_};
  }
  for (@{$self->{node}}) {
    push @{$clone->{node}}, $_->clone;
  }
  $_->{parent} = $clone for @{$clone->{node}};
  $clone;
}

=back

=head1 NODE TYPES

=over 4 

=item #comment

Comment declarement. <!-- -->

=item #element

Element.  Its XML representation consists of start tag, content and end tag,
like <TYPE>content</TYPE>.

=item #fragment

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

=back

=head1 SEE ALSO

Message::Markup::SuikaWikiConfig20::Parser,
SuikaWikiConfig/2.0 
<http://suika.fam.cx/~wakaba/-temp/wiki/wiki?SuikaWikiConfig/2.0>

=head1 HISTORY

This module was part of SuikaWiki 2, with name of 
C<SuikaWiki::Markup::SuikaWikiConfig20>.

=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/11/15 07:42:34 $
1	wakaba	1.1
2			=head1 NAME
3
4			Message::Markup::SuikaWikiConfig20::Node: manakai --- SuikaWikiConfig/2.0 data object and serialization
5
6			=head1 DESCRIPTION
7
8			This module provides modeled object tree handling for SuikaWikiConfig/2.0 data
9			format. It also provides a mean of serializing object data tree in
10			SuikaWikiConfig/2.0 format.
11
12			Note that to parse plain SuikaWikiConfig/2.0 data and compose object
13			tree for it, Message::Markup::SuikaWikiConfig20::Parser
14			can be used.
15
16			This module is part of manakai.
17
18			=cut
19
20			package Message::Markup::SuikaWikiConfig20::Node;
21			use strict;
22	wakaba	1.2	our $VERSION = do{my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
23	wakaba	1.1
24			=head1 METHODS
25
26			=over 4
27
28			=item $x = Message::Markup::SuikaWikiConfig20::Node->new (%options)
29
30			Returns new instance of the module. It is itself a node.
31
32			=cut
33
34			sub new ($;%) {
35			my $class = shift;
36			my $self = bless {@_}, $class;
37			$self->{type} \|\|= '#element';
38			$self->{node} \|\|= [];
39			$self;
40			}
41
42			=item $x->append_node ($node)
43
44			Appending given node to the object (as the last child).
45			If the type of given node is C<#fragment>, its all children, not the node
46			itself, are appended.
47
48			This method returns the appended node unless the type of given node is C<#fragment>.
49			In such cases, this node (C<$x>) is returned.
50
51			Available options: C<node_or_text>.
52
53			=cut
54
55			sub append_node ($$;%) {
56			my $self = shift;
57			my ($new_node, %o) = @_;
58			unless (ref $new_node) {
59			if ($o{node_or_text}) {
60			return $self->append_text ($new_node);
61			} else {
62			die "append_node: Invalid node";
63			}
64			}
65			if ($new_node->{type} eq '#fragment') {
66			for (@{$new_node->{node}}) {
67			push @{$self->{node}}, $_;
68			$_->{parent} = $self;
69			}
70			$self;
71			} else {
72			push @{$self->{node}}, $new_node;
73			$new_node->{parent} = $self;
74			$new_node;
75			}
76			}
77
78			=item $new_node = $x->append_new_node (%options)
79
80			Appending a new node. The new node is returned.
81
82			=cut
83
84			sub append_new_node ($;%) {
85			my $self = shift;
86			my $new_node = __PACKAGE__->new (@_);
87			push @{$self->{node}}, $new_node;
88			$new_node->{parent} = $self;
89			$new_node;
90			}
91
92			=item $new_node = $x->append_text ($text)
93
94			Appending given text as a new text node. The new text node is returned.
95
96			=cut
97
98			sub append_text ($$;%) {
99			my $self = shift;
100			my $s = shift;
101			if (ref ($self->{value}) eq 'ARRAY') {
102			push @{$self->{value}}, $s;
103			} else {
104			$self->{value} .= $s;
105			}
106			}
107
108			sub remove_child_node ($$) {
109			my ($self, $node) = @_;
110			return unless ref $node;
111			$node = overload::StrVal ($node);
112			$self->{node} = [grep { overload::StrVal ($_) ne $node } @{$self->{node}}];
113			}
114
115			=item $attr_node = $x->get_attribute ($local_name, %options)
116
117			Returns the attribute node whose local-name is C<$local_name>.
118
119			=item $attr_val = $x->get_attribute_value ($local_name)
120
121			Returnes the attribute value whose attribute name is C<$local_name>.
122
123			=cut
124
125			sub get_attribute ($$;%) {
126			my ($self, $name, %o) = @_;
127			for (@{$self->{node}}) {
128			if ($_->{type} eq '#element'
129			&& $_->{local_name} eq $name) {
130			return $_;
131			}
132			}
133			## Node is not exist
134			if ($o{make_new_node}) {
135			return $self->append_new_node (type => '#element', local_name => $name);
136			} else {
137			return undef;
138			}
139			}
140			sub get_attribute_value ($$;%) {
141			my ($self, $name) = @_;
142			my $node = $self->get_attribute ($name);
143			if (ref $node) {
144			return $node->value;
145			} else {
146			return undef;
147			}
148			}
149
150			=item $attr_node = $x->set_attribute ($local_name => $value, %options)
151
152			Set the value of the attribute. The attribute node is returned.
153
154			=cut
155
156			sub set_attribute ($$$;%) {
157			my ($self, $name, $val, %o) = @_;
158			if ({qw/ARRAY 1 HASH 1 CODE 1/}->{ref ($val)}) {
159			## TODO: common error handling
160			die "set_attribute: new attribute value must be string or blessed object";
161			}
162			for (@{$self->{node}}) {
163			if ($_->{type} eq '#element'
164			&& $_->{local_name} eq $name) {
165			$_->{value} = $val;
166			$_->{node} = [];
167			return $_;
168			}
169			}
170			return $self->append_new_node (type => '#element', local_name => $name,
171			value => $val);
172			}
173
174			=item \@children = $x->child_nodes
175
176			Returns an array reference to child nodes.
177
178			=item $local_name = $x->local_name ([$new_name])
179
180			Returns or set the local-name.
181
182			=item $type = $x->node_type
183
184			Returns the node type.
185
186			=item $node = $x->parent_node
187
188			Returns the parent node. If there is no parent node, undef is returned.
189
190			=cut
191
192			sub child_nodes ($) { $_[0]->{node} }
193			sub local_name ($;$) {
194			my ($self, $newname) = @_;
195			$self->{local_name} = $newname if $newname;
196			$self->{local_name}
197			}
198			sub node_type ($) { $_[0]->{type} }
199			sub parent_node ($) { $_[0]->{parent} }
200
201			=item $i = $x->count
202
203			Returns the number of child nodes.
204
205			=cut
206
207			# TODO: support counting by type
208			sub count ($;@) {
209			(defined $_[0]->{value} ? 1 : 0) + scalar @{$_[0]->{node}};
210			}
211
212			=item $tag = $x->inner_text
213
214			Returns the text content of the node. (In many case the returned value is same
215			as WinIE DOM C<inner_text ()> function's or XPath C<text()> function's.
216			But some classes that inherits this module might implement to return other
217			value (eg. to return the value of the alt attribute of html:img element).
218
219			=cut
220
221			sub inner_text ($;%) {
222			my $self = shift;
223			my %o = @_;
224			my $r = '';
225			if (defined $o{new_value}) {
226			$self->{value} = $o{new_value};
227			}
228			ref ($self->{value}) eq 'ARRAY' ? join "\x0A", @{$self->{value}} :
229			$self->{value};
230			}
231
232			sub value ($) {
233			shift->{value};
234			}
235
236			sub stringify ($;%) {
237			my ($self, %opt) = @_;
238			my $r = '';
239			if ($self->{type} eq '#document') {
240			if ($opt{output_header}) {
241			$r = "#?SuikaWiki/0.9\x0A";
242			}
243			my $ptype = '#';
244			for (@{$self->{node}}) {
245			$r .= "\x0A" if $ptype eq '#comment' && $_->{type} eq '#comment';
246			$ptype = $_->{type};
247			$r .= $_->stringify;
248			}
249			} elsif ($self->{type} eq '#element') {
250			$r = $self->inner_text;
251			$r =~ s/(^\|\x0A)(?=([\\\@\#\s]))?/$1." ".($2?"\\":"")/ges;
252			if (scalar @{$self->{node}}) {
253			$r = $self->{local_name}
254			. ":\x0A \@\@"
255			. (ref ($self->{value}) eq 'ARRAY' ? '[list]' : '')
256	wakaba	1.2	. ":" . (($r !~ /[\x0D\x0A:]/) && (length ($r) < 50) ? '' : "\x0A")
257	wakaba	1.1	. $r . "\x0A";
258			for (@{$self->{node}}) {
259			next unless $_->{type} eq '#element';
260			my $rc = $_->stringify;
261			$rc =~ s/\x0A /\x0A /gs;
262			$rc =~ s/(\x0A +\@)/$1\@/gs;
263			$r .= ' @' . $rc;
264			}
265			} else {
266			$r = $self->{local_name}
267			. (ref ($self->{value}) eq 'ARRAY' ? '[list]' : '')
268	wakaba	1.2	. ":" . ((($r !~ /[\x0D\x0A:]/) && (length ($r) < 50)) ? '' : "\x0A")
269	wakaba	1.1	. $r . "\x0A";
270			}
271			$r = "\\" . $r if substr ($r, 0, 1) =~ /[\\\@\#\s]/;
272			} else {
273			$r = $self->inner_text;
274			$r =~ s/\x0A/\x0A#/gs;
275			$r = '#' . $r . "\n";
276			}
277			$r;
278			}
279
280			sub root_node ($) {
281			my $self = shift;
282			if ($self->{type} eq '#document') {
283			return $self;
284			} elsif (ref $self->{parent}) {
285			return $self->{parent}->root_node;
286			} else {
287			return $self;
288			}
289			}
290
291			sub flag ($$;$) {
292			my ($self, $name, $value) = @_;
293			if (defined $value) {
294			$self->{flag}->{$name} = $value;
295			}
296			$self->{flag}->{$name};
297			}
298
299			sub option ($$;$) {
300			my ($self, $name, $value) = @_;
301			if (defined $value) {
302			$self->{option}->{$name} = $value;
303			}
304			$self->{option}->{$name};
305			}
306
307	wakaba	1.2	sub clone ($;%) {
308			my $self = shift;
309			my $clone = bless {node => []}, ref $self;
310			## TODO: Cloning recursively
311			$clone->{flag} = {%{$self->{flag}\|\|{}}};
312			$clone->{option} = {%{$self->{option}\|\|{}}};
313			for (qw/local_name value type/) {
314			$clone->{$_} = $self->{$_};
315			}
316			for (@{$self->{node}}) {
317			push @{$clone->{node}}, $_->clone;
318			}
319			$_->{parent} = $clone for @{$clone->{node}};
320			$clone;
321			}
322
323	wakaba	1.1	=back
324
325			=head1 NODE TYPES
326
327			=over 4
328
329			=item #comment
330
331			Comment declarement. <!-- -->
332
333			=item #element
334
335			Element. Its XML representation consists of start tag, content and end tag,
336			like <TYPE>content</TYPE>.
337
338			=item #fragment
339
340			Fragment of nodes. It's similar to DOM's fragment node.
341
342			=back
343
344			=head1 SEE ALSO
345
346			Message::Markup::SuikaWikiConfig20::Parser,
347			SuikaWikiConfig/2.0
348			<http://suika.fam.cx/~wakaba/-temp/wiki/wiki?SuikaWikiConfig/2.0>
349
350			=head1 HISTORY
351
352			This module was part of SuikaWiki 2, with name of
353			C<SuikaWiki::Markup::SuikaWikiConfig20>.
354
355			=head1 LICENSE
356
357			Copyright 2003 Wakaba <[email protected]>
358
359			This program is free software; you can redistribute it and/or
360			modify it under the same terms as Perl itself.
361
362			=cut
363
364	wakaba	1.2	1; # $Date: 2003/11/15 07:42:34 $