Util/Formatter/Base.pm


=head1 NAME

Message::Util::Formatter::Base --- Manakai : Format text replacer

=head1 DESCRIPTION

This module is a base class to implement specific application
of "formatting".

This module is part of manakai.

=cut

package Message::Util::Formatter::Base;
use strict;
our $VERSION = do{my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};

our %DefaultRules = (
  -bare_text => {
                 
  },
  -undef     => {
             
  },
  -default   => {
    pre => sub { },
    post => sub { },
    attr => sub { },                 
  },
  -entire    => {
    
  },
);

sub new ($;%) {
  my ($class, %opt) = @_;
  my $self = bless \%opt, $class;
  if (ref $self->{rule}) {
    if (ref $self->{rule} eq 'HASH') {
      my $rules = $self->{rule};
      $self->{rule} = sub { $rules->{$_[1]} };
    }
  } else {
    $self->{rule} = sub { $DefaultRules{$_[1]} };
  }
  $self;
}

{
our $__QuoteBlockContent;
$__QuoteBlockContent = qr/[^{}]*(?:[^{}]|{(??{$__QuoteBlockContent})})*/;
my $WordM = qr(
                          ([\w-]+)                    ## Bare
                       | {($__QuoteBlockContent)}     ## {Quoted}
                       | "([^"\\]*(?>[^"\\]+|\\.)*)"  ## "Quoted"
)x;

sub replace_option () {+{}}

sub replace ($$;%) {
  my ($self, $format) = (shift, shift);
  my (%opt) = (@_, %{$self->replace_option});
  my $defrule = $self->{rule}->($self, '-default');
  my $textrule = $self->{rule}->($self, '-bare_text');
  my $undefrule = $self->{rule}->($self, '-undef');
  my $entirerule = $self->{rule}->($self, '-entire');
  local $opt{param}->{-result};
  ($entirerule->{pre}||$defrule->{pre})->($self, '-entire',
                                          $opt{param}, $opt{param},
                                          option => \%opt);
  pos ($format) = 0;
  while (pos ($format) < length ($format)) {
    if ($format =~ /\G%([\w-]+)\s*/gc) { # ":" is reserved for QName
      my $name = $1;
      $name =~ tr/-/_/;
      my $rule = $self->{rule}->($self, $name) || $undefrule;
      my %attr;
      ($rule->{pre}||$defrule->{pre})->($self, $name, \%attr, $opt{param},
                                        option => \%opt);
      $format =~ /\G\s+/gc;
      
      if ($format =~ /\G\(\s*/gc) {
        while (1) {
          if ($format =~ /\G$WordM\s*/gc) {
            my $attr_name = $+;
            $attr_name =~ s/\\(.)/$1/gs if defined $3; # "quoted"
            $attr_name =~ tr/-/_/;
            my $nflag;
            $nflag = $1 if $format =~ /\G(\w+)\s*/gc;
            if ($format =~ /\G=>\s*$WordM\s*/gc) {
              my $attr_val = $+;
              $attr_val =~ s/\\(.)/$1/gs if defined $3; # "quoted"
              my $vflag;
              $vflag = $1 if $format =~ /\G(\w+)\s*/gc;
              ($rule->{attr}||$defrule->{attr})->($self, $name,
                                                  \%attr, $opt{param},
                                                  $attr_name => $attr_val,
                                                  -name_flag => $nflag,
                                                  -value_flag => $vflag,
                                                  option => \%opt);
            } else {
              ($rule->{attr}||$defrule->{attr})->($self, $name,
                                                  \%attr, $opt{param},
                                                  -boolean => $attr_name,
                                                  -name_flag => $nflag,
                                                  option => \%opt);
            }
          } # An attribute specification
          if ($format =~ /\G,\s*/gc) {
            next;
          } elsif ($format =~ /\G\)\s*/gc) {
            last;
          } else {
            throw Message::Util::Formatter::Base::error
              type => 'ATTR_SEPARATOR_NOT_FOUND',
              -context_before => (pos ($format) > 10 ?
                                  substr ($format, pos ($format) - 10, 10):
                                  substr ($format, 0, pos ($format))),
              -context_after => substr ($format, pos ($format), 10);
          }
        } # Attributes
      } # Attribute specification list
      if ($format =~ /\G;/gc) {
        ($rule->{post}||$defrule->{post})->($self, $name,
                                            \%attr,
                                            $opt{param},
                                            option => \%opt);
      } else {
        throw Message::Util::Formatter::Base::error
          type => 'SEMICOLON_NOT_FOUND',
          -context_before => (pos ($format) > 10 ?
                              substr ($format, pos ($format) - 10, 10):
                              substr ($format, 0, pos ($format))),
          -context_after => substr ($format, pos ($format), 10);
      }
      ($entirerule->{attr}||$defrule->{attr})->($self, '-entire',
                                                $opt{param}, $opt{param},
                                                $name => \%attr,
                                                option => \%opt);
    } elsif ($format =~ /\G[^%]+(?:%[^\w-]|[^%]+)*/gc) {
      my %attr;
      ($textrule->{pre}||$defrule->{pre})->($self, '-bare_text',
                                            \%attr, $opt{param},
                                            option => \%opt);
      ($textrule->{attr}||$defrule->{attr})->($self, '-bare_text',
                                              \%attr, $opt{param},
                       -bare_text => substr ($format, $-[0], $+[0]-$-[0]),
                                              option => \%opt);
      ($textrule->{post}||$defrule->{post})->($self, '-bare_text',
                                              \%attr, $opt{param},
                                              option => \%opt);
      ($entirerule->{attr}||$defrule->{attr})->($self, '-entire',
                                                $opt{param}, $opt{param},
                                                -bare_text => \%attr,
                                                option => \%opt);
    }
  }
  ($entirerule->{post}||$defrule->{post})->($self, '-entire',
                                            $opt{param}, $opt{param},
                                            option => \%opt);
  $opt{param}->{-result};
}
}

sub call ($$;@) {
  my ($self, $name, $function) = (@_[0,1,2]);
  ( ($self->{rule}->($self, $name) or $self->{rule}->($self, '-undef') )
    ->{$function}
  or $self->{rule}->($self, '-default')->{$function})
  ->($self, $name, @_[3..$#_]);
}

package Message::Util::Formatter::error;
require Message::Util::Error;
our @ISA = 'Message::Util::Error';
package Message::Util::Formatter::Base::error;
our @ISA = 'Message::Util::Formatter::error';
sub ___errors () {+{
  ATTR_SEPARATOR_NOT_FOUND => {
    description => q[Separator ("," or ")") expected at "%t(name=>context-before);"**here**"%t(name=>context-after);"],  
  },
  SEMICOLON_NOT_FOUND => {
    description => q(Semicolon (";") expected at "%t(name=>context-before);"**here**"%t(name=>context-after);"),
  },
}}

=head1 LICENSE

Copyright 2003 Wakaba <[email protected]>

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

=cut

1; # $Date: 2003/11/15 12:30:42 $
1	wakaba	1.1
2			=head1 NAME
3
4			Message::Util::Formatter::Base --- Manakai : Format text replacer
5
6			=head1 DESCRIPTION
7
8			This module is a base class to implement specific application
9			of "formatting".
10
11			This module is part of manakai.
12
13			=cut
14
15			package Message::Util::Formatter::Base;
16			use strict;
17	wakaba	1.2	our $VERSION = do{my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
18	wakaba	1.1
19			our %DefaultRules = (
20			-bare_text => {
21
22			},
23			-undef => {
24
25			},
26			-default => {
27			pre => sub { },
28			post => sub { },
29			attr => sub { },
30			},
31			-entire => {
32
33			},
34			);
35
36			sub new ($;%) {
37			my ($class, %opt) = @_;
38			my $self = bless \%opt, $class;
39			if (ref $self->{rule}) {
40			if (ref $self->{rule} eq 'HASH') {
41			my $rules = $self->{rule};
42			$self->{rule} = sub { $rules->{$_[1]} };
43			}
44			} else {
45			$self->{rule} = sub { $DefaultRules{$_[1]} };
46			}
47			$self;
48			}
49
50			{
51			our $__QuoteBlockContent;
52			$__QuoteBlockContent = qr/[^{}](?:[^{}]\|{(??{$__QuoteBlockContent})})/;
53			my $WordM = qr(
54			([\w-]+) ## Bare
55			\| {($__QuoteBlockContent)} ## {Quoted}
56			\| "([^"\\](?>[^"\\]+\|\\.))" ## "Quoted"
57			)x;
58
59	wakaba	1.2	sub replace_option () {+{}}
60
61	wakaba	1.1	sub replace ($$;%) {
62	wakaba	1.2	my ($self, $format) = (shift, shift);
63			my (%opt) = (@_, %{$self->replace_option});
64	wakaba	1.1	my $defrule = $self->{rule}->($self, '-default');
65			my $textrule = $self->{rule}->($self, '-bare_text');
66			my $undefrule = $self->{rule}->($self, '-undef');
67			my $entirerule = $self->{rule}->($self, '-entire');
68	wakaba	1.2	local $opt{param}->{-result};
69	wakaba	1.1	($entirerule->{pre}\|\|$defrule->{pre})->($self, '-entire',
70	wakaba	1.2	$opt{param}, $opt{param},
71			option => \%opt);
72	wakaba	1.1	pos ($format) = 0;
73			while (pos ($format) < length ($format)) {
74			if ($format =~ /\G%([\w-]+)\s*/gc) { # ":" is reserved for QName
75			my $name = $1;
76			$name =~ tr/-/_/;
77			my $rule = $self->{rule}->($self, $name) \|\| $undefrule;
78	wakaba	1.2	my %attr;
79			($rule->{pre}\|\|$defrule->{pre})->($self, $name, \%attr, $opt{param},
80			option => \%opt);
81	wakaba	1.1	$format =~ /\G\s+/gc;
82
83			if ($format =~ /\G\(\s*/gc) {
84			while (1) {
85			if ($format =~ /\G$WordM\s*/gc) {
86			my $attr_name = $+;
87			$attr_name =~ s/\\(.)/$1/gs if defined $3; # "quoted"
88			$attr_name =~ tr/-/_/;
89			my $nflag;
90			$nflag = $1 if $format =~ /\G(\w+)\s*/gc;
91			if ($format =~ /\G=>\s$WordM\s/gc) {
92			my $attr_val = $+;
93			$attr_val =~ s/\\(.)/$1/gs if defined $3; # "quoted"
94			my $vflag;
95			$vflag = $1 if $format =~ /\G(\w+)\s*/gc;
96			($rule->{attr}\|\|$defrule->{attr})->($self, $name,
97			\%attr, $opt{param},
98			$attr_name => $attr_val,
99			-name_flag => $nflag,
100	wakaba	1.2	-value_flag => $vflag,
101			option => \%opt);
102	wakaba	1.1	} else {
103			($rule->{attr}\|\|$defrule->{attr})->($self, $name,
104			\%attr, $opt{param},
105			-boolean => $attr_name,
106	wakaba	1.2	-name_flag => $nflag,
107			option => \%opt);
108	wakaba	1.1	}
109			} # An attribute specification
110			if ($format =~ /\G,\s*/gc) {
111			next;
112			} elsif ($format =~ /\G\)\s*/gc) {
113			last;
114			} else {
115			throw Message::Util::Formatter::Base::error
116			type => 'ATTR_SEPARATOR_NOT_FOUND',
117			-context_before => (pos ($format) > 10 ?
118			substr ($format, pos ($format) - 10, 10):
119			substr ($format, 0, pos ($format))),
120			-context_after => substr ($format, pos ($format), 10);
121			}
122			} # Attributes
123			} # Attribute specification list
124			if ($format =~ /\G;/gc) {
125			($rule->{post}\|\|$defrule->{post})->($self, $name,
126			\%attr,
127	wakaba	1.2	$opt{param},
128			option => \%opt);
129	wakaba	1.1	} else {
130			throw Message::Util::Formatter::Base::error
131			type => 'SEMICOLON_NOT_FOUND',
132			-context_before => (pos ($format) > 10 ?
133			substr ($format, pos ($format) - 10, 10):
134			substr ($format, 0, pos ($format))),
135			-context_after => substr ($format, pos ($format), 10);
136			}
137			($entirerule->{attr}\|\|$defrule->{attr})->($self, '-entire',
138			$opt{param}, $opt{param},
139	wakaba	1.2	$name => \%attr,
140			option => \%opt);
141	wakaba	1.1	} elsif ($format =~ /\G[^%]+(?:%[^\w-]\|[^%]+)*/gc) {
142	wakaba	1.2	my %attr;
143	wakaba	1.1	($textrule->{pre}\|\|$defrule->{pre})->($self, '-bare_text',
144	wakaba	1.2	\%attr, $opt{param},
145			option => \%opt);
146	wakaba	1.1	($textrule->{attr}\|\|$defrule->{attr})->($self, '-bare_text',
147			\%attr, $opt{param},
148	wakaba	1.2	-bare_text => substr ($format, $-[0], $+[0]-$-[0]),
149			option => \%opt);
150	wakaba	1.1	($textrule->{post}\|\|$defrule->{post})->($self, '-bare_text',
151	wakaba	1.2	\%attr, $opt{param},
152			option => \%opt);
153	wakaba	1.1	($entirerule->{attr}\|\|$defrule->{attr})->($self, '-entire',
154			$opt{param}, $opt{param},
155	wakaba	1.2	-bare_text => \%attr,
156			option => \%opt);
157	wakaba	1.1	}
158			}
159			($entirerule->{post}\|\|$defrule->{post})->($self, '-entire',
160	wakaba	1.2	$opt{param}, $opt{param},
161			option => \%opt);
162			$opt{param}->{-result};
163	wakaba	1.1	}
164			}
165
166			sub call ($$;@) {
167			my ($self, $name, $function) = (@_[0,1,2]);
168			( ($self->{rule}->($self, $name) or $self->{rule}->($self, '-undef') )
169			->{$function}
170			or $self->{rule}->($self, '-default')->{$function})
171	wakaba	1.2	->($self, $name, @_[3..$#_]);
172	wakaba	1.1	}
173
174			package Message::Util::Formatter::error;
175			require Message::Util::Error;
176			our @ISA = 'Message::Util::Error';
177			package Message::Util::Formatter::Base::error;
178			our @ISA = 'Message::Util::Formatter::error';
179			sub ___errors () {+{
180			ATTR_SEPARATOR_NOT_FOUND => {
181			description => q[Separator ("," or ")") expected at "%t(name=>context-before);"here"%t(name=>context-after);"],
182			},
183			SEMICOLON_NOT_FOUND => {
184			description => q(Semicolon (";") expected at "%t(name=>context-before);"here"%t(name=>context-after);"),
185			},
186			}}
187
188			=head1 LICENSE
189
190			Copyright 2003 Wakaba <[email protected]>
191
192			This program is free software; you can redistribute it and/or
193			modify it under the same terms as Perl itself.
194
195			=cut
196
197	wakaba	1.2	1; # $Date: 2003/11/15 12:30:42 $