File Coverage

blib/lib/Finance/IIF.pm

Criterion	Covered	Total	%
statement	78	138	56.5
branch	33	74	44.5
condition	8	14	57.1
subroutine	15	17	88.2
pod	7	7	100.0
total	141	250	56.4

package Finance::IIF;

use 5.006;
use strict;
use warnings;
use Carp;
use IO::File;

our $VERSION = '0.20.01';
$VERSION = eval $VERSION;

sub new {
    my $class = shift;
    my %opt   = @_;
    my $self  = {};

    $self->{debug}           = $opt{debug}           || 0;
    $self->{autodetect}      = $opt{autodetect}      || 0;
    $self->{field_separator} = $opt{field_separator} || "\t";

    bless( $self, $class );

    if ( $opt{record_separator} ) {
        $self->record_separator( $opt{record_separator} );
    }

    if ( $opt{file} ) {
        $self->file( $opt{file} );
        $self->open;
    }
    return $self;
}

sub file {
    my $self = shift;
    if (@_) {
        my @file = ( ref( $_[0] ) eq "ARRAY" ? @{ shift @_ } : (), @_ );
        $self->{file} = [@file];
    }
    if ( $self->{file} ) {
        return wantarray ? @{ $self->{file} } : $self->{file}->[0];
    }
    else {
        return undef;
    }
}

sub record_separator {
    my $self = shift;
    if (@_) {
        $self->{record_separator} = $_[0] if ( $_[0] );
    }
    return $self->{record_separator} || $/;
}

sub _filehandle {
    my $self = shift;
    if (@_) {
        my @args = @_;
        $self->{_filehandle} = IO::File->new(@args)
          or croak("Failed to open file '$args[0]': $!");
        $self->{_linecount} = 0;
    }
    if ( !$self->{_filehandle} ) {
        croak("No filehandle available");
    }
    return $self->{_filehandle};
}

sub open {
    my $self = shift;
    if (@_) {
        $self->file(@_);
    }
    if ( $self->file ) {
        $self->_filehandle( $self->file );
        if ( $self->{autodetect} ) {
            if ( $self->_filehandle->seek( -2, 2 ) ) {
                my $buffer = "";
                $self->_filehandle->read( $buffer, 2 );
                if ( $buffer eq "\r\n" ) {
                    $self->record_separator("\r\n");
                }
                elsif ( $buffer =~ /\n$/ ) {
                    $self->record_separator("\n");
                }
                elsif ( $buffer =~ /\r$/ ) {
                    $self->record_separator("\r");
                }
            }
        }
        $self->reset();
    }
    else {
        croak("No file specified");
    }
}

sub next {
    my $self = shift;
    my %object;
    my $continue = 1;
    if ( $self->_filehandle->eof ) {
        return undef;
    }
    while ( !$self->_filehandle->eof && $continue ) {
        my $line = $self->_getline;
        next if ( $line =~ /^\s*$/ );
        my @data = $self->_parseline($line);

        if ( $self->{debug} > 1 ) {
            warn("_getline:   line($line)\n");
            warn( "_parseline: data[" . scalar(@data) . "](@data)\n" );
        }

        if ( $data[0] =~ /^!(.*)$/ ) {
            delete( $self->{headerfields} );
            shift(@data);
            $self->{header}       = $1;
            $self->{headerfields} = \@data;
        }
        elsif ( $data[0] eq $self->{header} ) {
            $continue = 0;
            $object{header} = shift(@data);
            my $num_hdr = scalar( @{ $self->{headerfields} } );
            my $num_dat = scalar(@data);

            # have seen IIF timer data where last column (USEID) was
            # missing but QuickBooks imports the data without error
            if ( $num_dat < ( $num_hdr - 1 ) ) {
                no warnings 'uninitialized';
                $self->_warning( "parse error: found $num_dat fields but"
                      . " expected $num_hdr." );
                warn(
                    "error info: [header,data] "
                      . join(
                        ' ',
                        map( "$_" . '['
                              . $self->{headerfields}->[$_] . ','
                              . $data[$_] . ']',
                            0 .. ( $num_hdr - 1 ) )
                      )
                );
            }
            else {
                for ( my $i = 0 ; $i <= $#{ $self->{headerfields} } ; $i++ ) {
                    my $val = defined( $data[$i] ) ? $data[$i] : "";
                    $object{ $self->{headerfields}[$i] } = $val;
                }
            }
        }
        else {
            $self->_warning("unable to parse line '$_'");
        }
    }

    if ($continue) {
        return undef;
    }
    else {
        return \%object;
    }
}

sub _parseline {
    my $self = shift;
    my $line = shift;
    my $sep  = $self->{field_separator} || "\t";
    my @data;
    while ( defined $line ) {
        if ( $line =~ /^"(.*?)(?:[^\\]["])[$sep](.*)/ ) {
            warn("parse1: data($1) line($2)\n") if ( $self->{debug} > 2 );
            $line = $2;
            push( @data, $1 );
        }
        elsif ( $line =~ /^([^$sep]+)[$sep](.*)/ ) {
            warn("parse2: data($1) line($2)\n") if ( $self->{debug} > 2 );
            $line = $2;
            push( @data, $1 );
        }
        elsif ( $line =~ /^[$sep](.*)/ ) {
            warn("parse3: data() line($1)\n") if ( $self->{debug} > 2 );
            $line = $1;
            push( @data, "" );
        }
        elsif ( $line =~ /^"(.*?)(?:[^\\]["])$/ ) {
            warn("parse4: data($1) line()\n") if ( $self->{debug} > 2 );
            $line = undef;
            push( @data, $1 );
        }
        elsif ( $line =~ /^(.+)$/ ) {
            warn("parse5: data($1) line()\n") if ( $self->{debug} > 2 );
            $line = undef;
            push( @data, $1 );
        }
        else {
            warn("parse6: data() line($line)\n") if ( $self->{debug} > 2 );
            $line = undef;
            push( @data, "" );
        }
    }
    return @data;
}

sub _getline {
    my $self = shift;
    local $/ = $self->record_separator;
    my $line = $self->_filehandle->getline;
    chomp($line);
    $self->{_linecount}++;
    return $line;
}

sub _warning {
    my $self    = shift;
    my $message = shift;
    carp(   $message
          . " in file '"
          . $self->file
          . "' line "
          . $self->{_linecount} );
}

sub reset {
    my $self = shift;
    $self->_filehandle->seek( 0, 0 );
}

sub close {
    my $self = shift;
    $self->_filehandle->close;
}

1;

__END__