#!perl -w

package Parse::Report;
use 5.006;
use strict;

our $VERSION = '0.03';

=head1 NAME

Parse::Report.pm - read in fixed-width ascii text using C<format>-like
+ pictures. 
=head1 DESCRIPTION

A utility to parse a fixed-width ascii text report by passing
in a picture like that used by C<format>.

=head1 SYNOPSIS

 use Parse::Report;
 use YAML;           # or Data::Dumper if you insist ;->

 my $parser=Parse::Report->(<<'PARSER');
 Subject: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
          $subject
 Index: @<<<<<<<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
        $index,                       $description
 Priority: @<<<<<<<<<< Date: @<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
           $priority,        $date,   $description
 From: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
       $from,                         $description
 Assigned to: @<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
              $programmer,            $description
 ~                                    ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
                                      $description
 ~                                    ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
                                      $description
 ~                                    ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
                                      $description
 ~                                    ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
                                      $description
 ~                                    ^<<<<<<<<<<<<<<<<<<<<<<<...
                                      $description
 PARSER
 
 my @results=$parser->parse(<<'TEXT');
 Subject: A very strange bug with Parse::Report                    
 Index: 12345                         This bug occurs occasionally 
 Priority: Low-ish     Date: 20020814 for no reason. Well, maybe
 From: osfameron                      there *is* a reason, who     
 Assigned to: osfameron               knows what goes on in the 
                                      mind of bugs!
 Subject: Another odd bug with Parse::Report                    
 Index: 12346                         No idea why this one happens
 Priority: High        Date: 20020814 pretty bad luck is all if
 From: osfameron                      ask me really!
 Assigned to: osfameron               
 TEXT
 
 print Dump(\@results);

=cut

package Parse::Report;
use strict;
use YAML qw(:all);


my $parser=Parse::Report->new(<<'PARSER');
Subject: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
         $subject
Index: @<<<<<<<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
       $index,                       $description
Priority: @<<<<<<<<<< Date: @<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
          $priority,        $date,   $description
From: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
      $from,                         $description
Assigned to: @<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
             $programmer,            $description
~                                    ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
                                     $description
~                                    ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
                                     $description
~                                    ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
                                     $description
~                                    ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
                                     $description
~                                    ^<<<<<<<<<<<<<<<<<<<<<<<...
                                     $description
PARSER

my @results=$parser->parse(<<'TEXT');
Subject: A very strange bug with Parse::Report                    
Index: 12345                         This bug occurs occasionally 
Priority: Low-ish     Date: 20020814 for no reason. Well, maybe
From: osfameron                      there *is* a reason, who     
Assigned to: osfameron               knows what goes on in the 
                                                                      
+  mind of bugs!
Subject: Another odd bug with Parse::Report                    
Index: 12346                         No idea why this one happens
Priority: High        Date: 20020814 pretty bad luck is all if
From: osfameron                      ask me really!
Assigned to: osfameron               
TEXT

print Dump(\@results);


sub new {
    my $class=shift;
    my $re='';
    my (@process, @process2);

    my  %trim=(
        ''    => \&ltrim,
        '<'    => \&ltrim,
        '>' => \&rtrim,
        '|' => \&ctrim,
    );

    my @template=split /\n/, shift;

    while (my $format=shift @template) {
        my $optional=($format=~/~/);
        if ($format=~/[@^]/) {
            my $vars = shift @template;
            (my @vars) = ($vars=~/\w+/g);

            # escape any special characters
            $format=~s/(?![@^<>| ])(\W)/\\$1/g;

            # change the placeholders into capturing parentheses
            $format=~s/(([@^])([<>|]*))/ push @process, [$2,substr($3,
+0,1), shift @vars];
                '(.{'. length($1). '})' /eg;

            # deal with the special case of a capture at the end of a 
+string.
            # the outputter may not have printed all the necessary whi
+tespace,
            # so modify regex to account for this.
            $format=~s/\(\.\{(\d+)}\)\s*$/(.{0,$1})/;
        }
        $format="^$format\\n";
        $format="(?:$format)?" if $optional;
        $re.=$format;
    }
    for my $process (@process) {
        push @process2, sub {
            my $value=shift || '';
            my $result=shift;
            my ($vartype, $align, $varname)=@$process;
            #warn "ALIGN '$align'=> '$trim{$align}'";
            $trim{$align}->($value);
            if ($vartype eq '@') {
                $result->{$varname} = $value;
            } else {
                $result->{$varname} ||='';
                $result->{$varname}.=" " if $result->{$varname};
                $result->{$varname}.= $value;
            }
            return $result;
        };
    }
    return bless {
        re      => qr/$re/,
        process => \@process2,
    }, $class;
}

sub parse {
    my $parser = shift;
    my $text   = shift;

    my $re=$parser->{re};
    my @results;
    while ((my @vars)=($text=~/($re)/m)) {
        my @process=@{$parser->{process}};
        my $result= {};
        my $match=shift @vars;

        # consume the matched report
        substr($text,0,length$match)='';

        for (@vars) {
            (shift @process)->($_, $result);
        }
        push @results, $result;
    }
    return @results;
}

###########

sub ltrim { $_[0]=~s/\s+$// }
sub rtrim { $_[0]=~s/\s+$// }
sub ctrim { $_[0]=~s/^\s*(.*?)\s*$/$1/ }


###########

=head1 BUGS, TODO

Many.  This is alpha code, not complete, and not fully tested.
(Though it is the first module I've written where I've tried to
write tests from the beginning - it's very odd, but I'd recommend
it).  (Though hard to keep up: I didn't bother with this version,
bad BAD module author!)

No attempt is made to parse number formats (###.##) as yet.

=head1 AUTHOR, VERSION, LICENSE

osfameron - osfperl@osfameron.abelgratis.co.uk

Version 0.01 - Alpha version.  Not recommended or guaranteed safe
for anything.

This code may be freely distributed under the same conditions as Perl 
+itself.

=cut

#####
1; # return a true value
[download]