Util/Formatter/Base.pm


=head1 NAME

Message::Util::Formatter::Base - Formatting Template Text Replacement Engine

=head1 DESCRIPTION

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