| 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 |
require Message::Util::Error;
|
| 21 |
use strict;
|
| 22 |
our $VERSION = do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
|
| 23 |
|
| 24 |
sub new ($;%) {
|
| 25 |
my $self = bless {}, shift;
|
| 26 |
$self->{option} = {@_, newline => qr/\x0A|\x0D\x0A?/};
|
| 27 |
$self;
|
| 28 |
}
|
| 29 |
|
| 30 |
sub set_position ($$;%) {
|
| 31 |
no warnings 'uninitialized';
|
| 32 |
my ($self, $s, %opt) = @_;
|
| 33 |
return if $self->{__set_position};
|
| 34 |
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 |
while $t =~ /^.+?$self->{option}->{newline}/os;
|
| 44 |
$pos->{char} += length $t;
|
| 45 |
$pos->{pos} += $length;
|
| 46 |
$self->{__set_position} = 1;
|
| 47 |
}
|
| 48 |
|
| 49 |
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 |
|
| 55 |
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 |
|
| 63 |
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 |
}
|
| 71 |
|
| 72 |
sub report ($%) {
|
| 73 |
my ($self, %opt) = @_;
|
| 74 |
local $Error::Depth = $Error::Depth + 1;
|
| 75 |
local $self->{__set_position} = 0;
|
| 76 |
($self->{option}->{package}.($opt{-class}?'::'.$opt{-class}:''))
|
| 77 |
->report (%opt, -object => $self);
|
| 78 |
}
|
| 79 |
|
| 80 |
sub ___report_error ($$) {
|
| 81 |
my ($self, $err) = @_;
|
| 82 |
local $Error::Depth = $Error::Depth + 1;
|
| 83 |
$self->{option}->{report} ?
|
| 84 |
$self->{option}->{report}->($err):
|
| 85 |
$self->{option}->{package}->___report_error ($err);
|
| 86 |
}
|
| 87 |
|
| 88 |
package Message::Util::Error::TextParser::error;
|
| 89 |
push our @ISA, 'Message::Util::Error';
|
| 90 |
|
| 91 |
sub _FORMATTER_PACKAGE_ () { 'Message::Util::Error::TextParser::formatter' }
|
| 92 |
|
| 93 |
sub ___report_error ($$) {
|
| 94 |
$_[1]->throw;
|
| 95 |
}
|
| 96 |
|
| 97 |
package Message::Util::Error::TextParser::formatter;
|
| 98 |
push our @ISA, 'Message::Util::Error::formatter';
|
| 99 |
|
| 100 |
sub ___rule_def () {+{
|
| 101 |
err_line => {
|
| 102 |
after => sub {
|
| 103 |
my ($self, $name, $p, $o) = @_;
|
| 104 |
$o->{-object}->set_position ($o->{source}, diff => $o->{position_diff});
|
| 105 |
$p->{-result} .= 1 + ($o->{-object}->get_position ($o->{source}))[0];
|
| 106 |
},
|
| 107 |
},
|
| 108 |
err_char => {
|
| 109 |
after => sub {
|
| 110 |
my ($self, $name, $p, $o) = @_;
|
| 111 |
$o->{-object}->set_position ($o->{source}, diff => $o->{position_diff});
|
| 112 |
$p->{-result} .= 1 + ($o->{-object}->get_position ($o->{source}))[1];
|
| 113 |
},
|
| 114 |
},
|
| 115 |
err_at => {
|
| 116 |
after => sub {
|
| 117 |
my ($self, $name, $p, $o) = @_;
|
| 118 |
my $pos = pos ${$o->{source}};
|
| 119 |
if ($pos == length ${$o->{source}}) {
|
| 120 |
$p->{-result} .= $p->{end_of} || '** end of string **';
|
| 121 |
return;
|
| 122 |
} elsif ($pos == 0) {
|
| 123 |
$p->{-result} .= $p->{beginning_of} || '** beginning of string **';
|
| 124 |
return;
|
| 125 |
}
|
| 126 |
my $before = $p->{before};
|
| 127 |
if ($before) {
|
| 128 |
$before = $pos if $pos < $before;
|
| 129 |
}
|
| 130 |
$p->{-result} .= substr (${$o->{source}}, $pos - $before, $before)
|
| 131 |
. ($p->{here} || ' ** here ** ')
|
| 132 |
. substr (${$o->{source}}, $pos, $p->{after});
|
| 133 |
},
|
| 134 |
},
|
| 135 |
}}
|
| 136 |
|
| 137 |
=head1 LICENSE
|
| 138 |
|
| 139 |
Copyright 2003 Wakaba <w@suika.fam.cx>
|
| 140 |
|
| 141 |
This program is free software; you can redistribute it and/or
|
| 142 |
modify it under the same terms as Perl itself.
|
| 143 |
|
| 144 |
=cut
|
| 145 |
|
| 146 |
1; # $Date: 2003/10/31 08:39:50 $
|
Parent Directory
| 
Revision Log