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.4 $=~/\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/18 07:08:34 $
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.4 $=~/\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	if (ref ($self->{value}) eq 'ARRAY') {
107	push @{$self->{value}}, $s;
108	} else {
109	$self->{value} .= $s;
110	}
111	}
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	=item $attr_val = $x->get_attribute_value ($local_name)
125
126	Returnes the attribute value whose attribute name is C<$local_name>.
127
128	=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	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
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	ref ($self->{value}) eq 'ARRAY' ? join "\x0A", @{$self->{value}} :
234	$self->{value};
235	}
236
237	sub value ($) {
238	shift->{value};
239	}
240
241	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	$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	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	$r = $self->{local_name}
272	. (ref ($self->{value}) eq 'ARRAY' ? '[list]' : '')
273	. ":" . ((($r !~ /[\x0D\x0A]/) && (length ($r) < 50)) ? '' : "\x0A")
274	. $r . "\x0A";
275	}
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	1; # $Date: 2003/10/18 07:08:34 $