File Coverage

blib/lib/Finance/QIF.pm

Criterion	Covered	Total	%
statement	191	205	93.1
branch	90	104	86.5
condition	57	72	79.1
subroutine	18	19	94.7
pod	9	9	100.0
total	365	409	89.2

package Finance::QIF;

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

our $VERSION = '3.02';
$VERSION = eval $VERSION;

my %noninvestment = (
    "D" => "date",
    "T" => "transaction",
    "U" => "total",         #Quicken 2005 added this which is usually the same
                            #as T but can sometimes be higher.
    "C" => "status",
    "N" => "number",
    "P" => "payee",
    "M" => "memo",
    "A" => "address",
    "L" => "category",
    "S" => "splits"
);

my %split = (
    "S" => "category",
    "E" => "memo",
    '$' => "amount"
);

my %investment = (
    "D" => "date",
    "N" => "action",
    "Y" => "security",
    "I" => "price",
    "Q" => "quantity",
    "T" => "transaction",
    "U" => "total",         #Quicken 2005 added this which is usually the same
                            #as T but can sometimes be higher.
    "C" => "status",
    "P" => "text",
    "M" => "memo",
    "O" => "commission",
    "L" => "account",
    '$' => "amount"
);

my %account = (
    "N" => "name",
    "D" => "description",
    "L" => "limit",
    "X" => "tax",
    "A" => "note",
    "T" => "type",
    "B" => "balance"
);

my %category = (
    "N" => "name",
    "D" => "description",
    "B" => "budget",
    "E" => "expense",
    "I" => "income",
    "T" => "tax",
    "R" => "schedule"
);

my %class = (
    "N" => "name",
    "D" => "description"
);

my %memorized = (
    "K" => "type",
    "T" => "transaction",
    "U" => "total",        #Quicken 2005 added this which is usually the same as
                           #as T but can sometimes be higher.
    "C" => "status",
    "P" => "payee",
    "M" => "memo",
    "A" => "address",
    "L" => "category",
    "S" => "splits",
    "N" => "action",       #Quicken 2006 added N, Y, I, Q, $ for investment
    "Y" => "security",
    "I" => "price",
    "Q" => "quantity",
    '$' => "amount",
    "1" => "first",
    "2" => "years",
    "3" => "made",
    "4" => "periods",
    "5" => "interest",
    "6" => "balance",
    "7" => "loan"
);

my %security = (
    "N" => "security",
    "S" => "symbol",
    "T" => "type",
    "G" => "goal",
);

my %budget = (
    "N" => "name",
    "D" => "description",
    "E" => "expense",
    "I" => "income",
    "T" => "tax",
    "R" => "schedule",
    "B" => "budget"
);

my %payee = (
    "P" => "name",
    "A" => "address",
    "C" => "city",
    "S" => "state",
    "Z" => "zip",
    "Y" => "country",
    "N" => "phone",
    "#" => "account"
);

my %prices = (
    "S" => "symbol",
    "P" => "price"
);

my %price = (
    "C" => "close",
    "D" => "date",
    "X" => "max",
    "I" => "min",
    "V" => "volume"
);

my %nofields = ();

my %header = (
    "Type:Bank"         => \%noninvestment,
    "Type:Cash"         => \%noninvestment,
    "Type:CCard"        => \%noninvestment,
    "Type:Invst"        => \%investment,
    "Type:Oth A"        => \%noninvestment,
    "Type:Oth L"        => \%noninvestment,
    "Account"           => \%account,
    "Type:Cat"          => \%category,
    "Type:Class"        => \%class,
    "Type:Memorized"    => \%memorized,
    "Type:Security"     => \%security,
    "Type:Budget"       => \%budget,
    "Type:Payee"        => \%payee,
    "Type:Prices"       => \%prices,
    "Option:AutoSwitch" => \%nofields,
    "Option:AllXfr"     => \%nofields,
    "Clear:AutoSwitch"  => \%nofields
);

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

    $self->{debug}            = $opt{debug}            || 0;
    $self->{autodetect}       = $opt{autodetect}       || 0;
    $self->{trim_white_space} = $opt{trim_white_space} || 0;
    $self->{record_separator} = $opt{record_separator} || $/;

    bless( $self, $class );

    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;
    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]': $!");
        binmode( $self->{_filehandle} );
        $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 "\015\012" ) {
                    $self->{record_separator} = "\015\012";
                }
                elsif ( $buffer =~ /\012$/ ) {
                    $self->{record_separator} = "\012";
                }
                elsif ( $buffer =~ /\015$/ ) {
                    $self->{record_separator} = "\015";
                }
            }
        }
        $self->reset();
    }
    else {
        croak("No file specified");
    }
}

sub next {
    my $self = shift;
    my %object;
    my $continue = 1;
    my $csplit;    # Need to keep track of current split for adding split values
    if ( $self->_filehandle->eof ) {
        return undef;
    }
    if ( exists( $self->{header} ) ) {
        $object{header} = $self->{header};
    }
    while ( !$self->_filehandle->eof && $continue ) {
        my $line = $self->_getline;
        next if ( $line =~ /^\s*$/ );
        my ( $field, $value ) = $self->_parseline($line);
        if ( $field eq '!' ) {
            $value =~ s/\s+$//;    # Headers sometimes have trailing white space
            $self->{header} = $value;
            $object{header} = $value;
            if ( !exists( $header{$value} ) ) {
                $self->_warning("Unknown header format '$value'");
            }
        }
        else {
            if ( $field eq '^' ) {
                $continue = 0;
            }
            else {
                if (
                    !exists( $header{ $object{header} } )
                    && !(
                        exists( $header{"split"} )
                        && (   $object{header} eq "noninvestment"
                            || $object{header} eq "memorized" )
                    )
                  )
                {
                    $self->_warning(
                        "Unknown header '$object{header}' can't process line");
                }
                elsif ( $object{header} eq "Type:Prices" ) {
                    $object{"symbol"} = $field;
                    push( @{ $object{"prices"} }, $value );
                }
                elsif ($field eq 'A'
                    && $header{ $object{header} }{$field} eq "address" )
                {
                    if ( $self->{header} eq "Type:Payee" ) {

                        # The address fields are numbered for this record type
                        if ( length($value) == 0 ) {
                            $self->_warning( 'Improper address record for '
                                  . 'this record type' );
                        }
                        else {
                            $value = substr( $value, 1 );
                        }
                    }
                    if ( exists( $object{ $header{ $object{header} }{$field} } )
                        && $object{ $header{ $object{header} }{$field} } ne "" )
                    {
                        $object{ $header{ $object{header} }{$field} } .= "\n";
                    }
                    $object{ $header{ $object{header} }{$field} } .= $value;
                }
                elsif ($field eq 'S'
                    && $header{ $object{header} }{$field} eq "splits" )
                {
                    my %mysplit;    # We assume "S" always appears first
                    $mysplit{ $split{$field} } = $value;
                    push( @{ $object{splits} }, \%mysplit );
                    $csplit = \%mysplit;
                }
                elsif ( ( $field eq 'E' || $field eq '$' ) && $csplit ) {

                    # this currently assumes the "S" was found first
                    $csplit->{ $split{$field} } = $value;
                }
                elsif ($field eq 'B'
                    && $header{ $object{header} }{$field} eq "budget" )
                {
                    push( @{ $object{budget} }, $value );
                }
                elsif ( exists( $header{ $object{header} }{$field} ) ) {
                    $object{ $header{ $object{header} }{$field} } = $value;
                }
                else {
                    $self->_warning("Unknown field '$field'");
                }
            }
        }
    }

    # Must check that we have a valid record to return
    if ( scalar( keys %object ) > 1 ) {
        return \%object;
    }
    else {
        return undef;
    }
}

sub _parseline {
    my $self = shift;
    my $line = shift;
    my @result;
    if (   $line !~ /^!/
        && exists( $self->{header} )
        && $self->{header} eq "Type:Prices" )
    {
        my %price;
        $line =~ s/\"//g;
        my @data = split( ",", $line );
        $result[0]      = $data[0];
        $price{"close"} = $data[1];
        $price{"date"}  = $data[2];
        if ( scalar(@data) > 3 ) {
            $price{"max"}    = $data[3];
            $price{"min"}    = $data[4];
            $price{"volume"} = $data[5];
        }
        $result[1] = \%price;
    }
    else {
        $result[0] = substr( $line, 0, 1 );
        $result[1] = substr( $line, 1 );
        if ( $self->{trim_white_space} ) {
            $result[1] =~ s/^\s*(.*?)\s*$/$1/;
        }
    }
    return @result;
}

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 header {
    my $self   = shift;
    my $header = shift;
    my $fh     = $self->_filehandle;
    local $\ = $self->{record_separator};
    print( $fh "!", $header );

    # used during write to validate passed record is appropriate for
    # current header also generate reverse lookup for mapping record
    # values to file key identifier.
    $self->{currentheader} = $header;
    foreach my $key ( keys %{ $header{$header} } ) {
        $self->{reversemap}{ $header{$header}{$key} } = $key;
    }
    if ( exists( $header{$header}{S} ) && $header{$header}{S} eq "splits" ) {
        foreach my $key ( keys %split ) {
            $self->{reversesplitsmap}{ $split{$key} } = $key;
        }
    }

    $self->{_linecount}++;
    if ( !exists( $header{$header} ) ) {
        $self->_warning("Unsupported header '$header' written to file");
    }
}

sub write {
    my $self   = shift;
    my $record = shift;
    if ( $record->{header} eq $self->{currentheader} ) {
        if ( $record->{header} eq "Type:Prices" ) {
            if ( exists( $record->{symbol} ) && exists( $record->{prices} ) ) {
                foreach my $price ( @{ $record->{prices} } ) {
                    if (   exists( $price->{close} )
                        && exists( $price->{date} )
                        && exists( $price->{max} )
                        && exists( $price->{min} )
                        && exists( $price->{volume} ) )
                    {
                        $self->_writeline(
                            join( ",",
                                '"' . $record->{symbol} . '"',
                                $price->{close},
                                '"' . $price->{date} . '"',
                                $price->{max},
                                $price->{min},
                                $price->{volume} )
                        );
                    }
                    elsif (exists( $price->{close} )
                        && exists( $price->{date} ) )
                    {
                        $self->_writeline(
                            join( ",",
                                '"' . $record->{symbol} . '"',
                                $price->{close},
                                '"' . $price->{date} . '"' )
                        );
                    }
                    else {
                        $self->_warning("Prices missing a required field");
                    }
                }
                $self->_writeline("^");
            }
            else {
                $self->_warning("Record missing 'symbol' or 'prices'");
            }
        }
        else {
            foreach my $value ( keys %{$record} ) {
                next
                  if (
                       $value eq "header"
                    || $value eq "splits"
                    || (   $self->{currentheader} eq "Type:Memorized"
                        && $value eq "transaction" )
                  );
                if ( exists( $self->{reversemap}{$value} ) ) {
                    if ( $value eq "address" ) {
                        my @lines = split( "\n", $record->{$value} );
                        if ( $self->{currentheader} eq "Type:Payee" ) {

                          # The address fields are numbered for this record type
                            for ( my $count = 0 ; $count < 3 ; $count++ ) {
                                if ( $count <= $#lines ) {
                                    $self->_writeline( "A", $count,
                                        $lines[$count] );
                                }
                                else {
                                    $self->_writeline( "A", $count );
                                }
                            }
                        }
                        else {
                            for ( my $count = 0 ; $count < 6 ; $count++ ) {
                                if ( $count <= $#lines ) {
                                    $self->_writeline( "A", $lines[$count] );
                                }
                                else {
                                    $self->_writeline("A");
                                }
                            }
                        }
                    }
                    elsif ( $value eq "budget" ) {
                        foreach my $amount ( @{ $record->{$value} } ) {
                            $self->_writeline( $self->{reversemap}{$value},
                                $amount );
                        }
                    }
                    else {
                        $self->_writeline( $self->{reversemap}{$value},
                            $record->{$value} );
                    }
                }
                else {
                    $self->_warning( "Unsupported field '$value'"
                          . " found in record ignored" );
                }
            }
            if ( exists( $record->{splits} ) ) {
                foreach my $s ( @{ $record->{splits} } ) {
                    foreach my $key ( 'category', 'memo', 'amount' ) {
                        if ( exists( $s->{$key} ) ) {
                            $self->_writeline( $self->{reversesplitsmap}{$key},
                                $s->{$key} );
                        }
                        else {
                            $self->_writeline(
                                $self->{reversesplitsmap}{$key} );
                        }
                    }
                }
            }
            if ( $self->{currentheader} eq "Type:Memorized"
                && exists( $record->{transaction} ) )
            {
                $self->_writeline( $self->{reversemap}{"transaction"},
                    $record->{"transaction"} );
            }
            $self->_writeline("^");
        }
    }
    else {
        $self->_warning( "Record header type '"
              . $record->{header}
              . "' does not match current output header type "
              . $self->{currentheader}
              . "." );
    }
}

sub _writeline {
    my $self = shift;
    my $fh   = $self->_filehandle;
    local $\ = $self->{record_separator};
    print( $fh @_ );
    $self->{_linecount}++;
}

sub reset {
    my $self = shift;
    map( $self->{$_} = undef,    # initialize internally used variables
        qw(_linecount header currentheader reversemap reversesplitsmap) );
    $self->_filehandle->seek( 0, 0 );
}

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

1;

__END__