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.2 $=~/\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>.

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