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.3 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};

sub ___rule_def () {+{
  -bare_text => {
                 
  },
  -undef     => {
             
  },
  -default   => {
    pre => sub { },
    post => sub { },
    attr => sub { },                 
  },
  -entire    => {
    
  },
}}

sub ___get_rule_def ($$) {
  my ($self, $name) = @_;
  my $def = $self->___rule_def->{$name};
  return $def if $def;
  no strict 'refs';
  for my $SUPER (@{(ref ($self) || $self).'::ISA'}) {
    if ($SUPER->can ('___get_rule_def')) {
      $def = $SUPER->___get_rule_def ($name);
      return $def if $def;
    }
  }  
  return undef;
}

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 { $_[0]->___get_rule_def ($_[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 $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)
              || $self->{rule}->($self, '-undef');
      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*/gco) {
            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*/gco) {
              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) > 20 ?
                                 substr ($format, pos ($format) - 20, 20):
                                 substr ($format, 0, pos ($format))),
              context_after => substr ($format, pos ($format), 20),
              -object => $self, method => 'replace',
              option => \%opt;
          }
        } # 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) > 20 ?
                             substr ($format, pos ($format) - 20, 20):
                             substr ($format, 0, pos ($format))),
          context_after => substr ($format, pos ($format), 20),
          -object => $self, method => 'replace',
          option => \%opt;
      }
      ($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);
  return $opt{param}->{-result} if defined wantarray;
}
}

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;
push our @ISA, 'Message::Util::Error';

package Message::Util::Formatter::Base::error;
push our @ISA, 'Message::Util::Formatter::error';
sub ___error_def () {+{
  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/12/01 07:50:58 $
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.4	our $VERSION = do{my @r=(q$Revision: 1.3 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
18	wakaba	1.1
19	wakaba	1.4	sub ___rule_def () {+{
20	wakaba	1.1	-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	wakaba	1.4	}}
35
36			sub ___get_rule_def ($$) {
37			my ($self, $name) = @_;
38			my $def = $self->___rule_def->{$name};
39			return $def if $def;
40			no strict 'refs';
41			for my $SUPER (@{(ref ($self) \|\| $self).'::ISA'}) {
42			if ($SUPER->can ('___get_rule_def')) {
43			$def = $SUPER->___get_rule_def ($name);
44			return $def if $def;
45			}
46			}
47			return undef;
48			}
49	wakaba	1.1
50			sub new ($;%) {
51			my ($class, %opt) = @_;
52			my $self = bless \%opt, $class;
53			if (ref $self->{rule}) {
54			if (ref $self->{rule} eq 'HASH') {
55			my $rules = $self->{rule};
56			$self->{rule} = sub { $rules->{$_[1]} };
57			}
58			} else {
59	wakaba	1.4	$self->{rule} = sub { $_[0]->___get_rule_def ($_[1]) };
60	wakaba	1.1	}
61			$self;
62			}
63
64			{
65			our $__QuoteBlockContent;
66	wakaba	1.3	$__QuoteBlockContent = qr/[^{}](?>[^{}]+\|{(??{$__QuoteBlockContent})})/;
67	wakaba	1.1	my $WordM = qr(
68			([\w-]+) ## Bare
69			\| {($__QuoteBlockContent)} ## {Quoted}
70			\| "([^"\\](?>[^"\\]+\|\\.))" ## "Quoted"
71			)x;
72
73	wakaba	1.2	sub replace_option () {+{}}
74
75	wakaba	1.1	sub replace ($$;%) {
76	wakaba	1.2	my ($self, $format) = (shift, shift);
77	wakaba	1.3	my (%opt) = (%{$self->replace_option}, @_);
78	wakaba	1.1	my $defrule = $self->{rule}->($self, '-default');
79			my $textrule = $self->{rule}->($self, '-bare_text');
80			my $entirerule = $self->{rule}->($self, '-entire');
81	wakaba	1.2	local $opt{param}->{-result};
82	wakaba	1.3	($entirerule->{pre}\|\|=$defrule->{pre})->($self, '-entire',
83	wakaba	1.2	$opt{param}, $opt{param},
84			option => \%opt);
85	wakaba	1.1	pos ($format) = 0;
86			while (pos ($format) < length ($format)) {
87			if ($format =~ /\G%([\w-]+)\s*/gc) { # ":" is reserved for QName
88			my $name = $1;
89			$name =~ tr/-/_/;
90	wakaba	1.3	my $rule = $self->{rule}->($self, $name)
91			\|\| $self->{rule}->($self, '-undef');
92	wakaba	1.2	my %attr;
93	wakaba	1.3	($rule->{pre}\|\|=$defrule->{pre})->($self, $name, \%attr, $opt{param},
94			option => \%opt);
95	wakaba	1.1	$format =~ /\G\s+/gc;
96
97			if ($format =~ /\G\(\s*/gc) {
98			while (1) {
99	wakaba	1.3	if ($format =~ /\G$WordM\s*/gco) {
100	wakaba	1.1	my $attr_name = $+;
101			$attr_name =~ s/\\(.)/$1/gs if defined $3; # "quoted"
102			$attr_name =~ tr/-/_/;
103			my $nflag;
104			$nflag = $1 if $format =~ /\G(\w+)\s*/gc;
105	wakaba	1.3	if ($format =~ /\G=>\s$WordM\s/gco) {
106	wakaba	1.1	my $attr_val = $+;
107			$attr_val =~ s/\\(.)/$1/gs if defined $3; # "quoted"
108			my $vflag;
109			$vflag = $1 if $format =~ /\G(\w+)\s*/gc;
110	wakaba	1.3	($rule->{attr}\|\|=$defrule->{attr})->($self, $name,
111	wakaba	1.1	\%attr, $opt{param},
112			$attr_name => $attr_val,
113			-name_flag => $nflag,
114	wakaba	1.2	-value_flag => $vflag,
115			option => \%opt);
116	wakaba	1.1	} else {
117	wakaba	1.3	($rule->{attr}\|\|=$defrule->{attr})->($self, $name,
118	wakaba	1.1	\%attr, $opt{param},
119			-boolean => $attr_name,
120	wakaba	1.2	-name_flag => $nflag,
121			option => \%opt);
122	wakaba	1.1	}
123			} # An attribute specification
124			if ($format =~ /\G,\s*/gc) {
125			next;
126			} elsif ($format =~ /\G\)\s*/gc) {
127			last;
128			} else {
129			throw Message::Util::Formatter::Base::error
130	wakaba	1.4	-type => 'ATTR_SEPARATOR_NOT_FOUND',
131			context_before => (pos ($format) > 20 ?
132			substr ($format, pos ($format) - 20, 20):
133			substr ($format, 0, pos ($format))),
134			context_after => substr ($format, pos ($format), 20),
135			-object => $self, method => 'replace',
136			option => \%opt;
137	wakaba	1.1	}
138			} # Attributes
139			} # Attribute specification list
140			if ($format =~ /\G;/gc) {
141	wakaba	1.3	($rule->{post}\|\|=$defrule->{post})->($self, $name,
142	wakaba	1.1	\%attr,
143	wakaba	1.2	$opt{param},
144			option => \%opt);
145	wakaba	1.1	} else {
146			throw Message::Util::Formatter::Base::error
147	wakaba	1.4	-type => 'SEMICOLON_NOT_FOUND',
148			context_before => (pos ($format) > 20 ?
149			substr ($format, pos ($format) - 20, 20):
150			substr ($format, 0, pos ($format))),
151			context_after => substr ($format, pos ($format), 20),
152			-object => $self, method => 'replace',
153			option => \%opt;
154	wakaba	1.1	}
155	wakaba	1.3	($entirerule->{attr}\|\|=$defrule->{attr})->($self, '-entire',
156	wakaba	1.1	$opt{param}, $opt{param},
157	wakaba	1.2	$name => \%attr,
158			option => \%opt);
159	wakaba	1.3	} elsif ($format =~ /\G(?>[^%]+\|%(?![\w-]))+/gc) {
160	wakaba	1.2	my %attr;
161	wakaba	1.3	($textrule->{pre}\|\|=$defrule->{pre})->($self, '-bare_text',
162	wakaba	1.2	\%attr, $opt{param},
163			option => \%opt);
164	wakaba	1.3	($textrule->{attr}\|\|=$defrule->{attr})->($self, '-bare_text',
165	wakaba	1.1	\%attr, $opt{param},
166	wakaba	1.2	-bare_text => substr ($format, $-[0], $+[0]-$-[0]),
167			option => \%opt);
168	wakaba	1.3	($textrule->{post}\|\|=$defrule->{post})->($self, '-bare_text',
169	wakaba	1.2	\%attr, $opt{param},
170			option => \%opt);
171	wakaba	1.3	($entirerule->{attr}\|\|=$defrule->{attr})->($self, '-entire',
172	wakaba	1.1	$opt{param}, $opt{param},
173	wakaba	1.2	-bare_text => \%attr,
174			option => \%opt);
175	wakaba	1.1	}
176			}
177	wakaba	1.3	($entirerule->{post}\|\|=$defrule->{post})->($self, '-entire',
178	wakaba	1.2	$opt{param}, $opt{param},
179			option => \%opt);
180	wakaba	1.3	return $opt{param}->{-result} if defined wantarray;
181	wakaba	1.1	}
182			}
183
184			sub call ($$;@) {
185			my ($self, $name, $function) = (@_[0,1,2]);
186			( ($self->{rule}->($self, $name) or $self->{rule}->($self, '-undef') )
187			->{$function}
188			or $self->{rule}->($self, '-default')->{$function})
189	wakaba	1.2	->($self, $name, @_[3..$#_]);
190	wakaba	1.1	}
191
192			package Message::Util::Formatter::error;
193			require Message::Util::Error;
194	wakaba	1.4	push our @ISA, 'Message::Util::Error';
195
196	wakaba	1.1	package Message::Util::Formatter::Base::error;
197	wakaba	1.4	push our @ISA, 'Message::Util::Formatter::error';
198			sub ___error_def () {+{
199	wakaba	1.1	ATTR_SEPARATOR_NOT_FOUND => {
200			description => q[Separator ("," or ")") expected at "%t(name=>context-before);"here"%t(name=>context-after);"],
201			},
202			SEMICOLON_NOT_FOUND => {
203			description => q(Semicolon (";") expected at "%t(name=>context-before);"here"%t(name=>context-after);"),
204			},
205			}}
206
207			=head1 LICENSE
208
209			Copyright 2003 Wakaba <[email protected]>
210
211			This program is free software; you can redistribute it and/or
212			modify it under the same terms as Perl itself.
213
214			=cut
215
216	wakaba	1.4	1; # $Date: 2003/12/01 07:50:58 $