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.3 $=~/\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;
  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 _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/10/05 11:54:35 $
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	wakaba	1.4	our $VERSION = do{my @r=(q$Revision: 1.3 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
23	wakaba	1.1
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	wakaba	1.2	if (ref ($self->{value}) eq 'ARRAY') {
107			push @{$self->{value}}, $s;
108			} else {
109			$self->{value} .= $s;
110			}
111	wakaba	1.1	}
112
113			sub remove_child_node ($$) {
114			my ($self, $node) = @_;
115			return unless ref $node;
116			$node = overload::StrVal ($node);
117			$self->{node} = [grep { overload::StrVal ($_) ne $node } @{$self->{node}}];
118			}
119
120			=item $attr_node = $x->get_attribute ($local_name, %options)
121
122			Returns the attribute node whose local-name is C<$local_name>.
123
124	wakaba	1.4	=item $attr_val = $x->get_attribute_value ($local_name)
125
126			Returnes the attribute value whose attribute name is C<$local_name>.
127
128	wakaba	1.1	=cut
129
130			sub get_attribute ($$;%) {
131			my ($self, $name, %o) = @_;
132			for (@{$self->{node}}) {
133			if ($_->{type} eq '#element'
134			&& $_->{local_name} eq $name) {
135			return $_;
136			}
137			}
138			## Node is not exist
139			if ($o{make_new_node}) {
140			return $self->append_new_node (type => '#element', local_name => $name);
141			} else {
142			return undef;
143			}
144			}
145	wakaba	1.4	sub get_attribute_value ($$;%) {
146			my ($self, $name) = @_;
147			my $node = $self->get_attribute ($name);
148			if (ref $node) {
149			return $node->value;
150			} else {
151			return undef;
152			}
153			}
154	wakaba	1.1
155			=item $attr_node = $x->set_attribute ($local_name => $value, %options)
156
157			Set the value of the attribute. The attribute node is returned.
158
159			=cut
160
161			sub set_attribute ($$$;%) {
162			my ($self, $name, $val, %o) = @_;
163			if ({qw/ARRAY 1 HASH 1 CODE 1/}->{ref ($val)}) {
164			## TODO: common error handling
165			die "set_attribute: new attribute value must be string or blessed object";
166			}
167			for (@{$self->{node}}) {
168			if ($_->{type} eq '#element'
169			&& $_->{local_name} eq $name) {
170			$_->{value} = $val;
171			$_->{node} = [];
172			return $_;
173			}
174			}
175			return $self->append_new_node (type => '#element', local_name => $name,
176			value => $val);
177			}
178
179			=item \@children = $x->child_nodes
180
181			Returns an array reference to child nodes.
182
183			=item $local_name = $x->local_name ([$new_name])
184
185			Returns or set the local-name.
186
187			=item $type = $x->node_type
188
189			Returns the node type.
190
191			=item $node = $x->parent_node
192
193			Returns the parent node. If there is no parent node, undef is returned.
194
195			=cut
196
197			sub child_nodes ($) { $_[0]->{node} }
198			sub local_name ($;$) {
199			my ($self, $newname) = @_;
200			$self->{local_name} = $newname if $newname;
201			$self->{local_name}
202			}
203			sub node_type ($) { $_[0]->{type} }
204			sub parent_node ($) { $_[0]->{parent} }
205
206			=item $i = $x->count
207
208			Returns the number of child nodes.
209
210			=cut
211
212			# TODO: support counting by type
213			sub count ($;@) {
214			(defined $_[0]->{value} ? 1 : 0) + scalar @{$_[0]->{node}};
215			}
216
217			=item $tag = $x->inner_text
218
219			Returns the text content of the node. (In many case the returned value is same
220			as WinIE DOM C<inner_text ()> function's or XPath C<text()> function's.
221			But some classes that inherits this module might implement to return other
222			value (eg. to return the value of the alt attribute of html:img element).
223
224			=cut
225
226			sub inner_text ($;%) {
227			my $self = shift;
228			my %o = @_;
229			my $r = '';
230			if (defined $o{new_value}) {
231			$self->{value} = $o{new_value};
232			}
233	wakaba	1.2	ref ($self->{value}) eq 'ARRAY' ? join "\x0A", @{$self->{value}} :
234			$self->{value};
235	wakaba	1.1	}
236
237	wakaba	1.3	sub value ($) {
238			shift->{value};
239			}
240
241	wakaba	1.1	sub stringify ($;%) {
242			my ($self, %opt) = @_;
243			my $r = '';
244			if ($self->{type} eq '#document') {
245			if ($opt{output_header}) {
246			$r = "#?SuikaWiki/0.9\x0A";
247			}
248			my $ptype = '#';
249			for (@{$self->{node}}) {
250			$r .= "\x0A" if $ptype eq '#comment' && $_->{type} eq '#comment';
251			$ptype = $_->{type};
252			$r .= $_->stringify;
253			}
254			} elsif ($self->{type} eq '#element') {
255			$r = $self->inner_text;
256			$r =~ s/(^\|\x0A)(?=([\\\@\#\s]))?/$1." ".($2?"\\":"")/ges;
257			if (scalar @{$self->{node}}) {
258	wakaba	1.2	$r = $self->{local_name}
259			. ":\x0A \@\@"
260			. (ref ($self->{value}) eq 'ARRAY' ? '[list]' : '')
261			. ":" . (($r !~ /[\x0D\x0A]/) && (length ($r) < 50) ? '' : "\x0A")
262			. $r . "\x0A";
263	wakaba	1.1	for (@{$self->{node}}) {
264			next unless $_->{type} eq '#element';
265			my $rc = $_->stringify;
266			$rc =~ s/\x0A /\x0A /gs;
267			$rc =~ s/(\x0A +\@)/$1\@/gs;
268			$r .= ' @' . $rc;
269			}
270			} else {
271	wakaba	1.2	$r = $self->{local_name}
272			. (ref ($self->{value}) eq 'ARRAY' ? '[list]' : '')
273			. ":" . ((($r !~ /[\x0D\x0A]/) && (length ($r) < 50)) ? '' : "\x0A")
274			. $r . "\x0A";
275	wakaba	1.1	}
276			$r = "\\" . $r if substr ($r, 0, 1) =~ /[\\\@\#\s]/;
277			} else {
278			$r = $self->inner_text;
279			$r =~ s/\x0A/\x0A#/gs;
280			$r = '#' . $r . "\n";
281			}
282			$r;
283			}
284
285			sub _is_same_class ($$) {
286			my ($self, $something) = @_;
287			return 0 if {qw/ARRAY 1 HASH 1 CODE 1 :nonref: 1/}->{ref ($something) \|\| ':nonref:'};
288			eval q{$self->_CLASS_NAME eq $something->_CLASS_NAME} ? 1 : 0;
289			}
290
291			sub root_node ($) {
292			my $self = shift;
293			if ($self->{type} eq '#document') {
294			return $self;
295			} elsif (ref $self->{parent}) {
296			return $self->{parent}->root_node;
297			} else {
298			return $self;
299			}
300			}
301
302			sub _CLASS_NAME ($) { 'SuikaWiki::Markup::SuikaWikiConfig09' }
303
304			sub flag ($$;$) {
305			my ($self, $name, $value) = @_;
306			if (defined $value) {
307			$self->{flag}->{$name} = $value;
308			}
309			$self->{flag}->{$name};
310			}
311
312			sub option ($$;$) {
313			my ($self, $name, $value) = @_;
314			if (defined $value) {
315			$self->{option}->{$name} = $value;
316			}
317			$self->{option}->{$name};
318			}
319
320			=back
321
322			=head1 NODE TYPES
323
324			=over 4
325
326			=item #comment
327
328			Comment declarement. <!-- -->
329
330			=item #element
331
332			Element. Its XML representation consists of start tag, content and end tag,
333			like <TYPE>content</TYPE>.
334
335			=item #fragment
336
337			Fragment of nodes. It's similar to DOM's fragment node.
338
339			=back
340
341			=head1 LICENSE
342
343			Copyright 2003 Wakaba <w@suika.fam.cx>
344
345			This program is free software; you can redistribute it and/or
346			modify it under the same terms as Perl itself.
347
348			=cut
349
350	wakaba	1.4	1; # $Date: 2003/10/05 11:54:35 $