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

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

sub reset ($;%) {
  my ($self, %opt) = @_;
  for (keys %$self) {
    delete $self->{$_} unless $_ eq 'option';
  }
}

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/31 00:48:44 $
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.5	our $VERSION = do{my @r=(q$Revision: 1.3.2.4 $=~/\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.2.5	sub reset ($;%) {
31			my ($self, %opt) = @_;
32			for (keys %$self) {
33			delete $self->{$_} unless $_ eq 'option';
34			}
35			}
36
37	wakaba	1.3	sub set_position ($$;%) {
38			no warnings 'uninitialized';
39			my ($self, $s, %opt) = @_;
40	wakaba	1.3.2.1	return if $self->{__set_position} and not $opt{moved};
41	wakaba	1.3	my $pos = $self->{pos}->{$s} \|\|= {};
42			my $length = pos ($$s) - $pos->{pos};
43			if ($opt{diff}) {
44			$length < $opt{diff} ?
45			$length = 0:
46			$length -= $opt{diff};
47			}
48			my $t = substr ($$s, $pos->{pos}, $length > 0 ? $length : 0);
49			++$pos->{line} and $pos->{char} = 0
50	wakaba	1.3.2.4	while $t =~ s/^.*?$self->{option}->{newline}//os;
51	wakaba	1.3	$pos->{char} += length $t;
52			$pos->{pos} += $length;
53			$self->{__set_position} = 1;
54			}
55	wakaba	1.1
56	wakaba	1.3	sub get_position ($$;%) {
57			no warnings 'uninitialized';
58			my ($self, $s, %opt) = @_;
59			(0 + $self->{pos}->{$s}->{line}, 0 + $self->{pos}->{$s}->{char});
60			}
61	wakaba	1.1
62	wakaba	1.3	sub reset_position ($$;%) {
63			my ($self, $s, %opt) = @_;
64			$self->{pos}->{$s} = {
65			pos => pos $$s, line => 0, char => 0,
66			%opt,
67			};
68			}
69	wakaba	1.1
70	wakaba	1.3	sub fork_position ($$$;%) {
71			my ($self, $s => $t, %opt) = @_;
72			$self->{pos}->{$t} = {
73			%{$self->{pos}->{$s}\|\|{}},
74			pos => pos $$t,
75			%opt,
76			};
77	wakaba	1.3.2.4	## ISSUE: Should reference be recursively forked?
78			$self->{flag}->{$t} = {%{$self->{flag}->{$t}\|\|{}}};
79			}
80
81			sub set_flag ($$$$;%) {
82			my ($self, $s, $name => $value, %opt) = @_;
83			unless (defined $value) {
84			delete $self->{flag}->{$s}->{$name};
85			} else {
86			$self->{flag}->{$s}->{$name} = $value;
87			}
88			}
89
90			sub get_flag ($$$;%) {
91			my ($self, $s, $name, %opt) = @_;
92			$self->{flag}->{$s}->{$name};
93	wakaba	1.3	}
94	wakaba	1.1
95	wakaba	1.3	sub report ($%) {
96			my ($self, %opt) = @_;
97			local $Error::Depth = $Error::Depth + 1;
98			local $self->{__set_position} = 0;
99			($self->{option}->{package}.($opt{-class}?'::'.$opt{-class}:''))
100			->report (%opt, -object => $self);
101			}
102	wakaba	1.1
103	wakaba	1.3	sub ___report_error ($$) {
104			my ($self, $err) = @_;
105			local $Error::Depth = $Error::Depth + 1;
106			$self->{option}->{report} ?
107			$self->{option}->{report}->($err):
108			$self->{option}->{package}->___report_error ($err);
109	wakaba	1.1	}
110
111	wakaba	1.3	package Message::Util::Error::TextParser::error;
112			push our @ISA, 'Message::Util::Error';
113	wakaba	1.1
114	wakaba	1.3	sub _FORMATTER_PACKAGE_ () { 'Message::Util::Error::TextParser::formatter' }
115	wakaba	1.1
116	wakaba	1.3	sub ___report_error ($$) {
117			$_[1]->throw;
118	wakaba	1.1	}
119
120	wakaba	1.3	package Message::Util::Error::TextParser::formatter;
121			push our @ISA, 'Message::Util::Error::formatter';
122	wakaba	1.1
123	wakaba	1.3	sub ___rule_def () {+{
124			err_line => {
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}))[0];
129			},
130			},
131			err_char => {
132			after => sub {
133			my ($self, $name, $p, $o) = @_;
134			$o->{-object}->set_position ($o->{source}, diff => $o->{position_diff});
135			$p->{-result} .= 1 + ($o->{-object}->get_position ($o->{source}))[1];
136			},
137			},
138			err_at => {
139			after => sub {
140			my ($self, $name, $p, $o) = @_;
141	wakaba	1.3.2.3	my $pos = pos ${$o->{source}} \|\| 0;
142	wakaba	1.3.2.4	$o->{position_diff} \|\|= 0;
143			$pos = $pos - $o->{position_diff} > 0 ? $pos - $o->{position_diff} : 0;
144			my $before = $p->{before};
145			if ($before) {
146			$before = $pos if $pos < $before;
147			}
148	wakaba	1.3	if ($pos == length ${$o->{source}}) {
149	wakaba	1.3.2.4	$p->{-result} .= substr (${$o->{source}}, $pos - $before, $before)
150			. ($p->{end_of} \|\| ' end of string ');
151	wakaba	1.3	return;
152			} elsif ($pos == 0) {
153	wakaba	1.3.2.4	$p->{-result} .= ($p->{beginning_of} \|\| ' beginning of string ')
154			. substr (${$o->{source}}, $pos, $p->{after});
155	wakaba	1.3	return;
156			}
157			$p->{-result} .= substr (${$o->{source}}, $pos - $before, $before)
158			. ($p->{here} \|\| ' here ')
159			. substr (${$o->{source}}, $pos, $p->{after});
160			},
161			},
162			}}
163	wakaba	1.1
164			=head1 LICENSE
165
166			Copyright 2003 Wakaba <w@suika.fam.cx>
167
168			This program is free software; you can redistribute it and/or
169			modify it under the same terms as Perl itself.
170
171			=cut
172
173	wakaba	1.3.2.5	1; # $Date: 2004/05/31 00:48:44 $