View source for GncArchive.pl

<pre>
#!/usr/bin/perl -w
# Remove older transactions from the GnuCash XML to create a more
# manageable dataset. Creates new opening balance transactions for
# asset/liability accounts so that the latest and reconciled balances
# are maintained.
# Arguments are file name and date (remove through this date)
# After running, account balances will need to be adjusted.
# Two passes needed, first to figure out what to remove. The second
# to filter out the old transactions.
# Large chunks of this script were copied from gccull.pl from the
# GnuCash wiki, posted by Doug Pastorello.

use POSIX;

# Some syntax flags
my ($inAccount, $inTransaction, $curAccount, $curTransaction);
my ($inSplit, $curSplit);
# Hash of accounts. Key is act:id, value is account object (ref)
my (%accounts);
# Hash of transactions. Key is trn:id, value is transaction object (ref)
my (%transactions);
# Hash of splits. Key is split:id, value is split object (ref)
my (%splits);
# Hash of ISO4217 commodities. Key is ID, value is number of uses.
my (%commodities);
# Reference to root account object
my ($rootAccount);
# Equity account id used for generating balancing transactions
my ($equityAccountId, $equityActCommodity);
# List of deleted transaction GUIDs, available for reuse in balancing
# transactions
my (@guids);
# Misc global vars
my ($i, $buffer, $skip);
my (%actypes);

# Command line arguments
my ($gcFileName) = $ARGV[0];	# Name of the GnuCash XML file to process
my ($delDate) = $ARGV[1];	# Date to delete through
my ($archiveFileName, $postedDate, $enteredDate);
if ($delDate =~ m/^(\d\d\d\d)(\d\d)(\d\d)$/) {
    $postedDate = "$1-$2-$3 00:00:00 +0000";
}
else {die "Bad date format, required as YYYYMMDD\n   "}
($archiveFileName = $gcFileName) =~ s/^(.+)(\.\w+)$/$1-archive-$delDate$2/;
die "Strange filename, does not appear to have an extension\n   " if $archiveFileName eq $gcFileName;
$enteredDate = strftime("%Y-%m-%d %H:%M:%S +0000", gmtime($^T));

# Initial values
$inAccount = 0;
$inTransaction = 0;
$inSplit = 0;

# First pass read the file
open(IF, $gcFileName) || die "Can't open $gcFileName\n   ";
while (<IF>) {
    chomp;
    # -- Process the account lines --
    if (m/^\s*<gnc:account/) {
        $inAccount                 = 1;
        $curAccount                = {};	# New hash for new account
        $curAccount->{id}          = "-NONE-";	# GC account ID code
        $curAccount->{origXactCnt} = 0;	# Number of transactions before cull
        $curAccount->{newXactCnt}  = 0;	# Number of transactions after cull
        $curAccount->{type}        = "-NONE-";
        $curAccount->{name}        = "-NONE-";
        $curAccount->{description} = "-NONE-";
        $curAccount->{parent}      = "-NONE-";
        $curAccount->{children}    = 0;
        $curAccount->{delBalances} = { "n" => 0, "c" => 0, "y" => 0 };
        $curAccount->{commodityID} = "-NONE-";
        $curAccount->{commoditySCU} = 1;
        next;
    }
    if (m/^\s*<\/gnc:account>/) {$inAccount = 0; next}
    if ($inAccount && m/<act:id type="guid">/) {
        if (m/<act:id type="guid">([0-9a-zA-z]+)<\/act:id>/) {
            $accounts{$1} = $curAccount;
            $curAccount->{id} = $1;
        }
        else {die "Unexpected act:id format\n   "}
    }
    if ($inAccount && m/<act:type>/) {
        if (m/<act:type>(.+)<\/act:type>/) {
            $curAccount->{type} = $1;
            $actypes{$1} = 1;
        }
        else {die "Unexpected act:type format\n   "}
    }
    if ($inAccount && m/<act:name>/) {
        if (m/<act:name>(.+)<\/act:name>/) {
            $curAccount->{name} = $1;
        }
        else {die "Unexpected act:name format\n   "}
    }
    if ($inAccount && m/<act:description>/) {
        if (m/<act:description>(.+)<\/act:description>/) {
            $curAccount->{description} = $1;
        }
        else {die "Unexpected act:description format\n   "}
    }
    if ($inAccount && m/<act:parent type=/) {
        if (m/<act:parent type="guid">(.+)<\/act:parent>/) {
            $curAccount->{parent} = $1;
        }
        else {die "Unexpected act:parent format\n   "}
    }
    if ($inAccount && m/<act:commodity-scu>/) {
        if (m/<act:commodity-scu>(.+)<\/act:commodity-scu>/) {
            $curAccount->{commoditySCU} = $1;
        }
        else {die "Unexpected act:commodity-scu format\n   "}
    }
    if ($inAccount && m/<cmdty:id>/) {
        if (m/<cmdty:id>(.+)<\/cmdty:id>/) {
            $curAccount->{commodityID} = $1;
            $commodities{$1} = 0 unless exists($commodities{$1});
            $commodities{$1} += 1;
        }
        else {die "Unexpected cmdty:id format\n   "}
    }
    # -- Process the transaction lines --
    if (m/^\s*<gnc:transaction/) {
        $inTransaction = 1;
        $curTransaction = {};	# New hash for new transaction
        $curTransaction->{id} = "-NONE-";
        $curTransaction->{splits} = {};	# Hash of split entries
        $curTransaction->{toDelete} = 0;	# Flag for deletion
        $curTransaction->{date} = 0;	# Date transaction is posted
        next;
    }
    if (m/^\s*<\/gnc:transaction>/) {$inTransaction = 0; next}
    if ($inTransaction && m/<trn:id type="guid">/) {
        if (m/<trn:id type="guid">([0-9a-zA-z]+)<\/trn:id>/) {
            $transactions{$1} = $curTransaction;
            $curTransaction->{id} = $1;
        }
        else {die "Unexpected trn:id format\n   "}
    }
    if ($inTransaction && m/<trn:date-posted>/) {
        # If the date is not on this line, read the next
        if (! m/<\/ts:date>/) { $_ = <IF>; chomp}
        if (m/<ts:date>([0-9][0-9][0-9][0-9])\-([0-9][0-9])\-([0-9][0-9]).+<\/ts:date>/) {
            $curTransaction->{date} = $1 . $2 . $3;
        }
        else {die "Unexpected ts:date format\n   "}
    }

    # -- Process the split lines --
    if (m/^\s*<trn:split>/) {
        $inSplit = 1;
        $curSplit = {};	# New hash for new split
        $curSplit->{id} = "-NONE-";
        $curSplit->{transaction} = $curTransaction;
        $curSplit->{template} = 0;
        $curSplit->{toDelete} = 0;	# Flag for deletion
        $curSplit->{accountId} = "-NONE-";
        $curSplit->{amountNum} = 0;
        $curSplit->{amountDen} = 1;
        $curSplit->{reconState} = "n";
        next;
    }
    if (m/^\s*<\/trn:split>/) {$inSplit = 0; next}
    if ($inSplit && m/<split:id type="guid">/) {
        if (m/<split:id type="guid">([0-9a-zA-z]+)<\/split:id>/) {
            # Add splits to the current transaction split hash
            $curTransaction->{splits}->{$1} = $curSplit;
            $splits{$1} = $curSplit;	# Add to global split list
            $curSplit->{id} = $1;
        }
        else {die "Unexpected split:id format\n   "}
    }
    if ($inSplit && m/<split:account type="guid">/) {
        if (m/<split:account type="guid">([0-9a-zA-z]+)<\/split:account>/) {
            $curSplit->{accountId} = $1;
            $accounts{$1}->{origXactCnt}++;	# Increment the account transactions
        }
        else {die "Unexpected split:account format\n   "}
    }
    if ($inSplit && m/<slot:key>sched-xaction<\/slot:key>/) {
        $curSplit->{template} = 1;
    }
    if ($inSplit && m/<split:reconciled-state>/) {
        if (m/<split:reconciled-state>([ncy])<\/split:reconciled-state>/) {
            $curSplit->{reconState} = $1;
        }
        else {die "Unexpected split:reconciled-state format\n   "}
    }
    if ($inSplit && m/<split:quantity>/) {
        if (m/<split:quantity>([-0-9]+)\/([0-9]+)<\/split:quantity>/) {
            $curSplit->{amountNum} = $1;
            $curSplit->{amountDen} = $2;
        }
        else {die "Unexpected split:quantity format\n   "}
    }

} # End of first read through the GnuCash file
close(IF);
#
# ----------------------------------------------------------------------
#

# Copy the account transaction counts from old to new, count the
# number of child accounts
foreach $curAccount (values(%accounts)) {
    $curAccount->{newXactCnt} = $curAccount->{origXactCnt};
    my $parent = $curAccount->{parent};
    $accounts{$parent}->{children}++ if $parent ne "-NONE-";
}
# Find the root account to use as parent for the generated account for the
# balancing transactions
foreach $curAccount (values(%accounts)) {
    if (($curAccount->{type} eq "ROOT") && ($curAccount->{name} ne "-NONE-")) {
        $rootAccount = $curAccount;
        print "Creating equity account for balancing transactions under $curAccount->{name}\n";
        last;
    }
}

# Mark deletable transactions
$i = 0; # count deleted transactions
foreach $curTransaction (values(%transactions)) {
    if (&xactIsDeletable($curTransaction)) {
        push @guids, $curTransaction->{id};
        foreach $split (values($curTransaction->{splits})) {
            push @guids, $split->{id};
        }
        $i++;
    }
}
print "Marked $i (full) transactions for delete\n";
print "Recovered " . scalar(@guids) . " GUIDs for reuse\n";

# Calculate new opening balances
foreach $curTransaction (values(%transactions)) {
    if ($curTransaction->{toDelete}) {
        foreach $split (values($curTransaction->{splits})) {
            my ($aid, $rs, $n, $d) = ($split->{accountId}, $split->{reconState}, $split->{amountNum}, $split->{amountDen});
            if (($n != 0) && ($aid ne "-NONE-")) {
                my $a = $accounts{$aid};
                die "Deletable transaction has different fractional denominator\n   " if $d != $a->{commoditySCU};
                $a->{delBalances}->{$rs} += $n;
            }
        }
    }
}

# Dump out some account data
open(OF, ">${gcFileName}_accounts.csv") || die "Output error";
foreach $i (keys(%accounts)) {
    $curAccount = $accounts{$i};
    print OF "$curAccount->{id}\t$curAccount->{type}\t$curAccount->{name}";
    print OF "\t$curAccount->{delBalances}->{n}\t$curAccount->{delBalances}->{c}\t$curAccount->{delBalances}->{y}";
    print OF "\t$curAccount->{children}";
    print OF "\t$curAccount->{origXactCnt}\t$curAccount->{newXactCnt}";
    print OF "\t$curAccount->{description}\n";
}
close(OF);

# Dump out some split information
open(OF, ">${gcFileName}_splits.csv") || die "Output error";
foreach $curSplit (values(%splits)) {
    print OF "$curSplit->{id}\t$curSplit->{accountId}\t$curSplit->{transaction}->{date}\n";
}
close(OF);
#
# ----------------------------------------------------------------------
# Rename the data file to create a backup, and then open and read it,
# this time skipping transactions that are marked for deletion, and
# adding the replacement balancing account and transactions.
#
rename($gcFileName,"${gcFileName}.original") || die "Can't rename $gcFileName to create backup\n   ";
open(IF, "${gcFileName}.original") || die "Can't open ${gcFileName}.original for input\n   ";
open(OF, "> ${gcFileName}") || die "Can't open $gcFileName for output";
open(AF, "> ${archiveFileName}") || die "Can't open $archiveFileName for output";
$addedBalancing = 0;
$buffering = 0;
$inTransaction = 0;
$inScheduled = 0;
$splitCount = 0;
$toDelete = 0;
$buffer = "";
while (<IF>) {
    chomp;

    # Copy everything to the archive file except the scheduled transactions
    $inScheduled = 1 if m/^\s*<gnc:schedxaction/;
    print AF "$_\n" unless $inScheduled;
    $inScheduled = 0 if m/^\s*<\/gnc:schedxaction/;

    # Switch to buffering mode at start of each transaction ...
    if (m/^\s*<gnc:transaction/) {
        $buffering = 1;
        $inTransaction = 1;
        $splitCount = 0;
        $inSplit = 0;
        $toDelete = 0;
        # Insert all the balancing entries before the first transaction
        unless ($addedBalancing) {
            print OF genBalanceAccount($rootAccount);
            foreach $account (values(%accounts)) {
                next if $account->{type} =~ m/^(INCOME|EXPENSE)$/;
                print OF genBalancingXact($account, "n") if $account->{delBalances}->{n};
                print OF genBalancingXact($account, "c") if $account->{delBalances}->{c};
                print OF genBalancingXact($account, "y") if $account->{delBalances}->{y};
            }
            $addedBalancing = 1;
        }
    }
    # ... otherwise just copy from input to output
    unless ($buffering) {
        print OF "$_\n";
        next;
    }
    # Buffering mode, append current line to buffer
    $buffer = $buffer."$_\n";

    if ($inTransaction && m/<trn:id type="guid">/) {
        if (m/<trn:id type="guid">([0-9a-zA-z]+)<\/trn:id>/) {
            $toDelete = $transactions{$1}->{toDelete};
        }
        else {die "Unexpected trn:id format\n   "}
    }
    # Process the split lines, if not skipping transaction --
    if (m/^\s*<trn:split>/) {
        $inSplit = 1;
        next;
    }
    if ($inSplit && m/^\s*<\/trn:split>/) {
        $inSplit = 0;
        $splitCount++;
        next;
    }
    if ($inTransaction && m/^\s*<\/gnc:transaction/) {
        $buffering = 0;
        $inTransaction = 0;
        print OF $buffer unless $toDelete || ($splitCount < 2);
        $buffer = "";
        next;
    }
} # end of filtering pass through input file
close(IF);
close(OF);
exit;
#
#
# ----------------------------------------------------------------------
# ----------------------------------------------------------------------
# SUBROUTINES

# -- Mark deletable splits --
# Returns non-zero if the split gets marked for delete
# Arguments: split pointer, transaction date
sub splitIsDeletable {
    my ($inSplit, $xctDate) = @_;
    my ($splAcnt) = $accounts{$inSplit->{accountId}};
    my ($splAcntType) = $splAcnt->{type};
    my ($rslt) = 0;
    # Work only on splits not marked for delete
    unless ($inSplit->{toDelete} || $inSplit->{template}) {
        if ($xctDate <= $delDate) {
            if ($splAcntType =~ /^(EQUITY|ASSET|LIABILITY|BANK|CREDIT|CASH|STOCK|MUTUAL|INCOME|EXPENSE)$/) {
                $splAcnt->{newXactCnt}--;
                $rslt = 1;
                $inSplit->{toDelete} = 1;
            }
        }
    }
    #print "DEBUG: $inSplit->{id}, $splAcntType, $xctDate, $rslt\n";
    return($rslt);
}

# -- Mark deletable transactions --
sub xactIsDeletable {
    my ($inXact) = @_;
    my ($rslt) = 1;	# Start assuming all splits get deleted
    my ($xactDate) = $inXact->{date};
    my ($xSplit, $xSplits, $i);
    $xSplits = $inXact->{splits};
    foreach $xSplit (values(%$xSplits)) {
        $i = &splitIsDeletable($xSplit, $xactDate);
        $rslt = $rslt && $i;
    }
    if ($rslt) {$inXact->{toDelete} = 1}
    return($rslt);
}

# -- Create equity account for generated opening balances
sub genBalanceAccount {
    my ($ra) = @_;
    $equityAccountId = pop(@guids);
    $equityActCommodity = "-NONE-";
    my $nn = 0;
    while (($c,$n) = each(%commodities)) {
        next if $c eq "template";
        if ($n > $nn) { $equityActCommodity = $c; $nn = $n; }
    }
    my $xml = "";
    $xml .= "<gnc:account version=\"2.0.0\">\n";
    $xml .= "  <act:name>Generated Balancing Transactions</act:name>\n";
    $xml .= "  <act:id type=\"guid\">$equityAccountId</act:id>\n";
    $xml .= "  <act:type>EQUITY</act:type>\n";
    $xml .= "  <act:commodity>\n";
    $xml .= "    <cmdty:space>ISO4217</cmdty:space>\n";
    $xml .= "    <cmdty:id>$equityActCommodity</cmdty:id>\n";
    $xml .= "  </act:commodity>\n";
    $xml .= "  <act:code></act:code>\n";
    $xml .= "  <act:description>Generated Balancing Transactions</act:description>\n";
    $xml .= "  <act:parent type=\"guid\">$rootAccount->{id}</act:parent>\n";
    $xml .= "</gnc:account>\n";
    return ($xml);
}

# -- Create balancing transaction XML --
sub genBalancingXact {
    my ($account,$rs) = @_;
    return ("") if $account->{type} eq "EQUITY";
    my ($n,$c,$d) = ($account->{delBalances}->{$rs}, $account->{commodityID}, $account->{commoditySCU});
    my $e = 0 - $n;
    my $desc = "Opening balance";
    $desc .= " (needs valuation)" if $c ne $equityActCommodity;
    my $xml = "";
    $xml .= "<gnc:transaction version=\"2.0.0\">\n";
    $xml .= "  <trn:id type=\"guid\">" . pop(@guids) . "</trn:id>\n";
    $xml .= "  <trn:date-posted>\n";
    $xml .= "    <ts:date>$postedDate</ts:date>\n";
    $xml .= "  </trn:date-posted>\n";
    $xml .= "  <trn:date-entered>\n";
    $xml .= "    <ts:date>$enteredDate</ts:date>\n";
    $xml .= "  </trn:date-entered>\n";
    $xml .= "  <trn:description>$desc</trn:description>\n";
    $xml .= "  <trn:splits>\n";
    $xml .= "    <trn:split>\n";
    $xml .= "      <split:id type=\"guid\">" . pop(@guids) . "</split:id>\n";
    $xml .= "      <split:reconciled-state>$rs</split:reconciled-state>\n";
    $xml .= "      <split:value>$n/$d</split:value>\n";
    $xml .= "      <split:quantity>$n/$d</split:quantity>\n";
    $xml .= "      <split:account type=\"guid\">$account->{id}</split:account>\n";
    $xml .= "    </trn:split>\n";
    $xml .= "    <trn:split>\n";
    $xml .= "      <split:id type=\"guid\">" . pop(@guids) . "</split:id>\n";
    $xml .= "      <split:reconciled-state>n</split:reconciled-state>\n";
    $xml .= "      <split:value>$e/$d</split:value>\n";
    $xml .= "      <split:quantity>$e/$d</split:quantity>\n";
    $xml .= "      <split:account type=\"guid\">$equityAccountId</split:account>\n";
    $xml .= "    </trn:split>\n";
    $xml .= "  </trn:splits>\n";
    $xml .= "</gnc:transaction>\n";
    return ($xml);
}
</pre>