SuikaWiki/Markup/SuikaWikiConfig20.pm


=head1 NAME

SuikaWiki::Markup::SuikaWikiConfig20: SuikaWiki: 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, SuikaWiki::Markup::SuikaWikiConfig20::Parser
can be used.

This module is part of SuikaWiki.

=cut

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

=head1 METHODS

=over 4

=item $x = SuikaWiki::Markup::SuikaWikiConfig20->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';
  for (qw/local_name value/) {
    if ($self->_is_same_class ($self->{$_})) {
      $self->{$_}->{parent} = $self;
    }
  }
  $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;
  $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>.

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

=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};
  }
  $self->{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  \@\@:" . $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 {
      if ($r !~ /[\x0D\x0A]/ && length ($r) < 50) {
        $r = $self->{local_name} . ":" . $r . "\x0A";
      } else {
        $r = $self->{local_name} . ":\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 _is_same_class ($$) {
  my ($self, $something) = @_;
  return 0 if {qw/ARRAY 1 HASH 1 CODE 1 :nonref: 1/}->{ref ($something) || ':nonref:'};
  eval q{$self->_CLASS_NAME eq $something->_CLASS_NAME} ? 1 : 0;
}

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 _CLASS_NAME ($) { 'SuikaWiki::Markup::SuikaWikiConfig09' }

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 #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 LICENSE

Copyright 2003 Wakaba <w@suika.fam.cx>

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

=cut

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