Util/Error/TextParser.pm


=head1 NAME

Message::Util::Error::TextParser --- manakai: Common error handler wrapper for formatted-text parser

=head1 DESCRIPTION

This module provides common error handler (error reporting wrapper
module) for formatted-text parser.  With this module, flexible error 
reporting method can be easily implemented.  In addition to the base
module of Message::Util::Error, this module implements line/position
counting method so that error occured position in the parsed plain-text
based data can be reported.

This module is part of manakai.

=cut

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

sub new ($;%) {
  my $self = bless {}, shift;
  $self->{option} = {@_, newline => qr/\x0A|\x0D\x0A?/};
  $self;
}

sub set_position ($$;%) {
  no warnings 'uninitialized';
  my ($self, $s, %opt) = @_;
  return if $self->{__set_position} and not $opt{moved};
  my $pos = $self->{pos}->{$s} ||= {};
  my $length = pos ($$s) - $pos->{pos};
  if ($opt{diff}) {
    $length < $opt{diff} ?
      $length  = 0:
      $length -= $opt{diff};
  }
  my $t = substr ($$s, $pos->{pos}, $length > 0 ? $length : 0);
  ++$pos->{line} and $pos->{char} = 0 
    while $t =~ s/^.*?$self->{option}->{newline}//os;
  $pos->{char} += length $t;
  $pos->{pos} += $length;
  $self->{__set_position} = 1;
}

sub get_position ($$;%) {
  no warnings 'uninitialized';
  my ($self, $s, %opt) = @_;
  (0 + $self->{pos}->{$s}->{line}, 0 + $self->{pos}->{$s}->{char});
}

sub reset_position ($$;%) {
  my ($self, $s, %opt) = @_;
  $self->{pos}->{$s} = {
    pos => pos $$s, line => 0, char => 0,
    %opt,
  };
}

sub fork_position ($$$;%) {
  my ($self, $s => $t, %opt) = @_;
  $self->{pos}->{$t} = {
    %{$self->{pos}->{$s}||{}},
    pos => pos $$t,
    %opt,
  };
  ## ISSUE: Should reference be recursively forked?
  $self->{flag}->{$t} = {%{$self->{flag}->{$t}||{}}};
}

sub set_flag ($$$$;%) {
  my ($self, $s, $name => $value, %opt) = @_;
  unless (defined $value) {
    delete $self->{flag}->{$s}->{$name};
  } else {
    $self->{flag}->{$s}->{$name} = $value;
  }
}

sub get_flag ($$$;%) {
  my ($self, $s, $name, %opt) = @_;
  $self->{flag}->{$s}->{$name};
}

sub report ($%) {
  my ($self, %opt) = @_;
  local $Error::Depth = $Error::Depth + 1;
  local $self->{__set_position} = 0;
  ($self->{option}->{package}.($opt{-class}?'::'.$opt{-class}:''))
        ->report (%opt, -object => $self);
}

sub ___report_error ($$) {
  my ($self, $err) = @_;
  local $Error::Depth = $Error::Depth + 1;
  $self->{option}->{report} ?
    $self->{option}->{report}->($err):
    $self->{option}->{package}->___report_error ($err);
}

package Message::Util::Error::TextParser::error;
push our @ISA, 'Message::Util::Error';

sub _FORMATTER_PACKAGE_ () { 'Message::Util::Error::TextParser::formatter' }

sub ___report_error ($$) {
  $_[1]->throw;
}

package Message::Util::Error::TextParser::formatter;
push our @ISA, 'Message::Util::Error::formatter';

sub ___rule_def () {+{
  err_line => {
    after => sub {
      my ($self, $name, $p, $o) = @_;
      $o->{-object}->set_position ($o->{source}, diff => $o->{position_diff});
      $p->{-result} .= 1 + ($o->{-object}->get_position ($o->{source}))[0];
    },
  },
  err_char => {
    after => sub {
      my ($self, $name, $p, $o) = @_;
      $o->{-object}->set_position ($o->{source}, diff => $o->{position_diff});
      $p->{-result} .= 1 + ($o->{-object}->get_position ($o->{source}))[1];
    },
  },
  err_at => {
    after => sub {
      my ($self, $name, $p, $o) = @_;
      my $pos = pos ${$o->{source}} || 0;
      $o->{position_diff} ||= 0;
      $pos = $pos - $o->{position_diff} > 0 ? $pos - $o->{position_diff} : 0;
      my $before = $p->{before};
      if ($before) {
        $before = $pos if $pos < $before;
      }
      if ($pos == length ${$o->{source}}) {
        $p->{-result} .= substr (${$o->{source}}, $pos - $before, $before)
                       . ($p->{end_of} || ' ** end of string **');
        return;
      } elsif ($pos == 0) {
        $p->{-result} .= ($p->{beginning_of} || '** beginning of string ** ')
                       . substr (${$o->{source}}, $pos, $p->{after});
        return;
      }
      $p->{-result} .= substr (${$o->{source}}, $pos - $before, $before)
                     . ($p->{here} || ' ** here ** ')
                     . substr (${$o->{source}}, $pos, $p->{after});
    },
  },
}}

=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/05/23 04:02:48 $
1	wakaba	1.1
2			=head1 NAME
3
4			Message::Util::Error::TextParser --- manakai: Common error handler wrapper for formatted-text parser
5
6			=head1 DESCRIPTION
7
8			This module provides common error handler (error reporting wrapper
9			module) for formatted-text parser. With this module, flexible error
10			reporting method can be easily implemented. In addition to the base
11			module of Message::Util::Error, this module implements line/position
12			counting method so that error occured position in the parsed plain-text
13			based data can be reported.
14
15			This module is part of manakai.
16
17			=cut
18
19			package Message::Util::Error::TextParser;
20	wakaba	1.3	require Message::Util::Error;
21	wakaba	1.1	use strict;
22	wakaba	1.3.2.4	our $VERSION = do{my @r=(q$Revision: 1.3.2.3 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
23	wakaba	1.1
24	wakaba	1.3	sub new ($;%) {
25			my $self = bless {}, shift;
26			$self->{option} = {@_, newline => qr/\x0A\|\x0D\x0A?/};
27			$self;
28			}
29	wakaba	1.1
30	wakaba	1.3	sub set_position ($$;%) {
31			no warnings 'uninitialized';
32			my ($self, $s, %opt) = @_;
33	wakaba	1.3.2.1	return if $self->{__set_position} and not $opt{moved};
34	wakaba	1.3	my $pos = $self->{pos}->{$s} \|\|= {};
35			my $length = pos ($$s) - $pos->{pos};
36			if ($opt{diff}) {
37			$length < $opt{diff} ?
38			$length = 0:
39			$length -= $opt{diff};
40			}
41			my $t = substr ($$s, $pos->{pos}, $length > 0 ? $length : 0);
42			++$pos->{line} and $pos->{char} = 0
43	wakaba	1.3.2.4	while $t =~ s/^.*?$self->{option}->{newline}//os;
44	wakaba	1.3	$pos->{char} += length $t;
45			$pos->{pos} += $length;
46			$self->{__set_position} = 1;
47			}
48	wakaba	1.1
49	wakaba	1.3	sub get_position ($$;%) {
50			no warnings 'uninitialized';
51			my ($self, $s, %opt) = @_;
52			(0 + $self->{pos}->{$s}->{line}, 0 + $self->{pos}->{$s}->{char});
53			}
54	wakaba	1.1
55	wakaba	1.3	sub reset_position ($$;%) {
56			my ($self, $s, %opt) = @_;
57			$self->{pos}->{$s} = {
58			pos => pos $$s, line => 0, char => 0,
59			%opt,
60			};
61			}
62	wakaba	1.1
63	wakaba	1.3	sub fork_position ($$$;%) {
64			my ($self, $s => $t, %opt) = @_;
65			$self->{pos}->{$t} = {
66			%{$self->{pos}->{$s}\|\|{}},
67			pos => pos $$t,
68			%opt,
69			};
70	wakaba	1.3.2.4	## ISSUE: Should reference be recursively forked?
71			$self->{flag}->{$t} = {%{$self->{flag}->{$t}\|\|{}}};
72			}
73
74			sub set_flag ($$$$;%) {
75			my ($self, $s, $name => $value, %opt) = @_;
76			unless (defined $value) {
77			delete $self->{flag}->{$s}->{$name};
78			} else {
79			$self->{flag}->{$s}->{$name} = $value;
80			}
81			}
82
83			sub get_flag ($$$;%) {
84			my ($self, $s, $name, %opt) = @_;
85			$self->{flag}->{$s}->{$name};
86	wakaba	1.3	}
87	wakaba	1.1
88	wakaba	1.3	sub report ($%) {
89			my ($self, %opt) = @_;
90			local $Error::Depth = $Error::Depth + 1;
91			local $self->{__set_position} = 0;
92			($self->{option}->{package}.($opt{-class}?'::'.$opt{-class}:''))
93			->report (%opt, -object => $self);
94			}
95	wakaba	1.1
96	wakaba	1.3	sub ___report_error ($$) {
97			my ($self, $err) = @_;
98			local $Error::Depth = $Error::Depth + 1;
99			$self->{option}->{report} ?
100			$self->{option}->{report}->($err):
101			$self->{option}->{package}->___report_error ($err);
102	wakaba	1.1	}
103
104	wakaba	1.3	package Message::Util::Error::TextParser::error;
105			push our @ISA, 'Message::Util::Error';
106	wakaba	1.1
107	wakaba	1.3	sub _FORMATTER_PACKAGE_ () { 'Message::Util::Error::TextParser::formatter' }
108	wakaba	1.1
109	wakaba	1.3	sub ___report_error ($$) {
110			$_[1]->throw;
111	wakaba	1.1	}
112
113	wakaba	1.3	package Message::Util::Error::TextParser::formatter;
114			push our @ISA, 'Message::Util::Error::formatter';
115	wakaba	1.1
116	wakaba	1.3	sub ___rule_def () {+{
117			err_line => {
118			after => sub {
119			my ($self, $name, $p, $o) = @_;
120			$o->{-object}->set_position ($o->{source}, diff => $o->{position_diff});
121			$p->{-result} .= 1 + ($o->{-object}->get_position ($o->{source}))[0];
122			},
123			},
124			err_char => {
125			after => sub {
126			my ($self, $name, $p, $o) = @_;
127			$o->{-object}->set_position ($o->{source}, diff => $o->{position_diff});
128			$p->{-result} .= 1 + ($o->{-object}->get_position ($o->{source}))[1];
129			},
130			},
131			err_at => {
132			after => sub {
133			my ($self, $name, $p, $o) = @_;
134	wakaba	1.3.2.3	my $pos = pos ${$o->{source}} \|\| 0;
135	wakaba	1.3.2.4	$o->{position_diff} \|\|= 0;
136			$pos = $pos - $o->{position_diff} > 0 ? $pos - $o->{position_diff} : 0;
137			my $before = $p->{before};
138			if ($before) {
139			$before = $pos if $pos < $before;
140			}
141	wakaba	1.3	if ($pos == length ${$o->{source}}) {
142	wakaba	1.3.2.4	$p->{-result} .= substr (${$o->{source}}, $pos - $before, $before)
143			. ($p->{end_of} \|\| ' end of string ');
144	wakaba	1.3	return;
145			} elsif ($pos == 0) {
146	wakaba	1.3.2.4	$p->{-result} .= ($p->{beginning_of} \|\| ' beginning of string ')
147			. substr (${$o->{source}}, $pos, $p->{after});
148	wakaba	1.3	return;
149			}
150			$p->{-result} .= substr (${$o->{source}}, $pos - $before, $before)
151			. ($p->{here} \|\| ' here ')
152			. substr (${$o->{source}}, $pos, $p->{after});
153			},
154			},
155			}}
156	wakaba	1.1
157			=head1 LICENSE
158
159			Copyright 2003 Wakaba <w@suika.fam.cx>
160
161			This program is free software; you can redistribute it and/or
162			modify it under the same terms as Perl itself.
163
164			=cut
165
166	wakaba	1.3.2.4	1; # $Date: 2004/05/23 04:02:48 $