Markup/SuikaWikiConfig20/Parser.pm


=head1 NAME

Message::Markup::SuikaWikiConfig20::Parser: manakai --- SuikaWikiConfig/2.0 parser

=head1 DESCRIPTION

SuikaWikiConfig/2.0 is a general configuration description format.
This module can be used to parse such configuration and to
generate node tree for it.

This module is part of manakai.

=cut

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

=head1 METHODS

=over 4

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

Returns new instance of parser

=cut

sub new ($;%) {
  my $class = shift;
  my $self = bless {@_}, $class;
  $self;
}

sub parse_text ($$) {
  my ($self, $s) = @_;
  my $root = Message::Markup::SuikaWikiConfig20::Node->new
    (type => '#document');
  my $current = $root;
  my $current_element = $root;
  my $is_new_element = 0;
  my $is_list_element = 0;
  for my $line (split /\x0D?\x0A/, $s) {
    if ($line =~ /^([^#\s].*):\s*([^\s:][^:]*)?$/) {
      my ($name, $val) = ($1, $2);
      substr ($name, 0, 1) = '' if defined $name and 
                                   substr ($name, 0, 1) eq '\\';
      substr ($val, 0, 1) = '' if defined $val and
                                  substr ($val, 0, 1) eq '\\';
      if (substr ($name, -6) eq '[list]') {
        substr ($name, -6) = '';
        $val = length ($val) ? [$val] : [];
        $is_list_element = 1;
      } else {
        $is_list_element = 0;
      }
      $current_element = $root->append_new_node (type => '#element',
                                                 local_name => $name,
                                                 value => $val);
      if (defined $2) {  ## Foo: bar
        $current = $root;
        $current_element = $root;
      } else {           ## Foo:\n  bar\n  baz
        $current = $current_element;
        $is_new_element = 1;
      }
    } elsif ($line =~ /^\s+(\@+)(.*):\s*([^\s:][^:]*)?$/) {
      my ($nest, $name, $val) = (length $1, $2, $3);
      substr ($name, 0, 1) = '' if defined $name and 
                                   substr ($name, 0, 1) eq '\\';
      substr ($val, 0, 1) = '' if defined $val and
                                  substr ($val, 0, 1) eq '\\';
      if (substr ($name, -6) eq '[list]') {
        substr ($name, -6) = '';
        $val = (defined ($val) and length ($val)) ? [$val] : [];
        $is_list_element = 1;
      } else {
        $is_list_element = 0;
      }
      my $ce;
      if (length ($name)) {
        while ($current_element->flag ('p__nest_level', undef,
                                       default => 0) >= $nest) {
          $current_element = $current_element->parent_node;
        }
        $ce = $current_element->append_new_node
                                       (type => '#element',
                                        local_name => $name,
                                        value => $val);
        $ce->flag (p__nest_level
                   => $current_element->flag ('p__nest_level', undef,
                                              default => 0) + 1);
        unless (defined $3) {  ##  @foo: \nbar
          $current_element = $ce;
          $current = $ce;
          $is_new_element = 1;
        }
      } else {
        while ($current_element->flag ('p__nest_level', undef,
                                       default => 0) >= $nest - 1) {
          $current_element = $current_element->parent_node;
        }
        $current_element->append_text ($val);
        $current = $current_element;
        unless (defined $3) {  ##  @@: \nbar
          $is_new_element = 1;
        }
      }
    } elsif ($line =~ /^\s+([^\s#].*)$/) {
      my $val = $1;
      substr ($val, 0, 1) = '' if substr ($val, 0, 1) eq '\\';
      if ($is_new_element || $is_list_element) {
        $current_element->append_text ($val);
        $is_new_element = 0;
      } else {
        $current_element->append_text ("\x0A" . $val);
      }
    } elsif ($line =~ /^\s+$/) {
      # skip
    } elsif ($line =~ /^\s*\#(.*)$/) {
      if ($current->node_type eq '#comment') {
        $current->append_text ("\x0A" . $1);
      } else {
        $current = $root->append_new_node (type => '#comment', value => $1);
      }
    } else {
      $current = $root;
      #print STDERR qq(**$line**\n); 
    }
  }
  $root;
}

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 EXAMPLE

  use Message::Markup::SuikaWikiConfig20::Parser;
  my $parser = new Message::Markup::SuikaWikiConfig20::Parser;
  
  my $conf = $parser->parse_text ($config);
  print $conf->get_attribute ('Some Configuration Item');

=head1 SEE ALSO

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

=head1 HISTORY

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

=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: 2004/08/21 05:39:03 $
1	wakaba	1.1
2			=head1 NAME
3
4			Message::Markup::SuikaWikiConfig20::Parser: manakai --- SuikaWikiConfig/2.0 parser
5
6			=head1 DESCRIPTION
7
8			SuikaWikiConfig/2.0 is a general configuration description format.
9			This module can be used to parse such configuration and to
10			generate node tree for it.
11
12			This module is part of manakai.
13
14			=cut
15
16			package Message::Markup::SuikaWikiConfig20::Parser;
17			use strict;
18	wakaba	1.4	our $VERSION = do{my @r=(q$Revision: 1.3 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
19	wakaba	1.1	require Message::Markup::SuikaWikiConfig20::Node;
20
21			=head1 METHODS
22
23			=over 4
24
25			=item $x = Message::Markup::SuikaWikiConfig20::Parser->new (%options)
26
27			Returns new instance of parser
28
29			=cut
30
31			sub new ($;%) {
32			my $class = shift;
33			my $self = bless {@_}, $class;
34			$self;
35			}
36
37			sub parse_text ($$) {
38			my ($self, $s) = @_;
39	wakaba	1.2	my $root = Message::Markup::SuikaWikiConfig20::Node->new
40	wakaba	1.1	(type => '#document');
41			my $current = $root;
42			my $current_element = $root;
43			my $is_new_element = 0;
44			my $is_list_element = 0;
45			for my $line (split /\x0D?\x0A/, $s) {
46			if ($line =~ /^([^#\s].):\s([^\s:][^:]*)?$/) {
47			my ($name, $val) = ($1, $2);
48	wakaba	1.3	substr ($name, 0, 1) = '' if defined $name and
49			substr ($name, 0, 1) eq '\\';
50			substr ($val, 0, 1) = '' if defined $val and
51			substr ($val, 0, 1) eq '\\';
52	wakaba	1.1	if (substr ($name, -6) eq '[list]') {
53			substr ($name, -6) = '';
54			$val = length ($val) ? [$val] : [];
55			$is_list_element = 1;
56			} else {
57			$is_list_element = 0;
58			}
59			$current_element = $root->append_new_node (type => '#element',
60			local_name => $name,
61			value => $val);
62			if (defined $2) { ## Foo: bar
63			$current = $root;
64			$current_element = $root;
65			} else { ## Foo:\n bar\n baz
66			$current = $current_element;
67			$is_new_element = 1;
68			}
69			} elsif ($line =~ /^\s+(\@+)(.):\s([^\s:][^:]*)?$/) {
70			my ($nest, $name, $val) = (length $1, $2, $3);
71	wakaba	1.3	substr ($name, 0, 1) = '' if defined $name and
72			substr ($name, 0, 1) eq '\\';
73			substr ($val, 0, 1) = '' if defined $val and
74			substr ($val, 0, 1) eq '\\';
75	wakaba	1.1	if (substr ($name, -6) eq '[list]') {
76			substr ($name, -6) = '';
77	wakaba	1.3	$val = (defined ($val) and length ($val)) ? [$val] : [];
78	wakaba	1.1	$is_list_element = 1;
79			} else {
80			$is_list_element = 0;
81			}
82			my $ce;
83			if (length ($name)) {
84	wakaba	1.3	while ($current_element->flag ('p__nest_level', undef,
85			default => 0) >= $nest) {
86	wakaba	1.1	$current_element = $current_element->parent_node;
87			}
88	wakaba	1.4	$ce = $current_element->append_new_node
89			(type => '#element',
90			local_name => $name,
91			value => $val);
92	wakaba	1.1	$ce->flag (p__nest_level
93	wakaba	1.3	=> $current_element->flag ('p__nest_level', undef,
94			default => 0) + 1);
95	wakaba	1.1	unless (defined $3) { ## @foo: \nbar
96			$current_element = $ce;
97			$current = $ce;
98			$is_new_element = 1;
99			}
100			} else {
101	wakaba	1.3	while ($current_element->flag ('p__nest_level', undef,
102			default => 0) >= $nest - 1) {
103	wakaba	1.1	$current_element = $current_element->parent_node;
104			}
105			$current_element->append_text ($val);
106			$current = $current_element;
107			unless (defined $3) { ## @@: \nbar
108			$is_new_element = 1;
109			}
110			}
111			} elsif ($line =~ /^\s+([^\s#].*)$/) {
112			my $val = $1;
113			substr ($val, 0, 1) = '' if substr ($val, 0, 1) eq '\\';
114			if ($is_new_element \|\| $is_list_element) {
115			$current_element->append_text ($val);
116			$is_new_element = 0;
117			} else {
118			$current_element->append_text ("\x0A" . $val);
119			}
120			} elsif ($line =~ /^\s+$/) {
121			# skip
122			} elsif ($line =~ /^\s\#(.)$/) {
123			if ($current->node_type eq '#comment') {
124			$current->append_text ("\x0A" . $1);
125			} else {
126			$current = $root->append_new_node (type => '#comment', value => $1);
127			}
128			} else {
129			$current = $root;
130			#print STDERR qq($line\n);
131			}
132			}
133			$root;
134			}
135
136			sub flag ($$;$) {
137			my ($self, $name, $value) = @_;
138			if (defined $value) {
139			$self->{flag}->{$name} = $value;
140			}
141			$self->{flag}->{$name};
142			}
143
144			sub option ($$;$) {
145			my ($self, $name, $value) = @_;
146			if (defined $value) {
147			$self->{option}->{$name} = $value;
148			}
149			$self->{option}->{$name};
150			}
151
152			=back
153
154			=head1 EXAMPLE
155
156			use Message::Markup::SuikaWikiConfig20::Parser;
157			my $parser = new Message::Markup::SuikaWikiConfig20::Parser;
158
159			my $conf = $parser->parse_text ($config);
160			print $conf->get_attribute ('Some Configuration Item');
161
162			=head1 SEE ALSO
163
164			Message::Markup::SuikaWikiConfig20::Node,
165			SuikaWiki <http://suika.fam.cx/~wakaba/-temp/wiki/wiki?SuikaWiki>,
166			<http://suika.fam.cx/~wakaba/-temp/wiki/wiki?SuikaWikiConfig/2.0>
167
168			=head1 HISTORY
169
170			This module was part of SuikaWiki 2, with the name of
171			C<SuikaWiki::Markup::SuikaWikiConfig20::Parser>.
172
173			=head1 LICENSE
174
175			Copyright 2003 Wakaba <w@suika.fam.cx>
176
177			This program is free software; you can redistribute it and/or
178			modify it under the same terms as Perl itself.
179
180			=cut
181
182	wakaba	1.4	1; # $Date: 2004/08/21 05:39:03 $