File Coverage

blib/lib/Finance/FITF.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package Finance::FITF;

use strict;
use 5.008_001;
our $VERSION = '0.31';
use Finance::FITF::Writer;
use POSIX qw(ceil);
BEGIN {
    eval "use Class::XSAccessor::Compat 'antlers'; 1" or
    eval "use Class::Accessor::Fast 'antlers'; 1" or die $@;
}

use Sub::Exporter -setup => {
    groups  => {
        default    => [ qw(FITF_TICK_FMT FITF_TICK_NONE  FITF_TICK_USHORT FITF_TICK_ULONG
                           FITF_BAR_FMT  FITF_BAR_USHORT FITF_BAR_ULONG)],
    },
    exports => [qw(FITF_TICK_FMT FITF_TICK_NONE FITF_TICK_USHORT FITF_TICK_ULONG
                   FITF_BAR_FMT FITF_BAR_USHORT FITF_BAR_ULONG)],
};

use constant FITF_TICK_FMT    => 0x000f;
use constant FITF_TICK_NONE   => 0x0000;
use constant FITF_TICK_USHORT => 0x0001;
use constant FITF_TICK_ULONG  => 0x0002;

use constant FITF_BAR_FMT     => 0x00f0;
use constant FITF_BAR_USHORT  => 0x0010;
use constant FITF_BAR_ULONG   => 0x0020;

use constant FITF_VERSION => 0x02;
use constant FITF_MAGIC => "\x1f\xf1";
use Parse::Binary::FixedFormat;

my $header_fmt = Parse::Binary::FixedFormat->new(
    [qw(magic:a2 version:n
        date:a8
        time_zone:Z31
        start:N:3
        end:N:3
        records:N
        bar_seconds:n
        format:N
        divisor:N
        name:Z47
   )]);

my $bar_s =
    Parse::Binary::FixedFormat->new([qw(
                                       open:n
                                       high:n
                                       low:n
                                       close:n
                                       volume:n
                                       ticks:n
                                       index:N
                                   )]);

my $bar_l =
    Parse::Binary::FixedFormat->new([qw(
                                       open:N
                                       high:N
                                       low:N
                                       close:N
                                       volume:N
                                       ticks:N
                                       index:N
                                   )]);


my $tick_s =
    Parse::Binary::FixedFormat->new([qw(
                                       offset_min:s
                                       offset_msec:n
                                       price:n
                                       volume:n
                                   )]);

my $tick_l =
    Parse::Binary::FixedFormat->new([qw(
                                       offset_min:s
                                       offset_msec:n
                                       price:N
                                       volume:N
                                   )]);

has fh => ( is => 'ro' );

has header => ( is => "ro", isa => "HashRef" );

has header_fmt => ( is => "ro", isa => "Parse::Binary::FixedFormat" );
has header_sz  => ( is => "rw", isa => "Int");
has bar_fmt    => ( is => "ro", isa => "Parse::Binary::FixedFormat" );
has bar_sz     => ( is => "rw", isa => "Int");
has tick_fmt   => ( is => "ro", isa => "Parse::Binary::FixedFormat" );
has tick_sz    => ( is => "rw", isa => "Int");

has day        => (is => "rw", isa => "DateTime");
has date_start => (is => "rw", isa => "Int");

has nbars => (is => "rw", isa => "Int");

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_);

    $self->header_sz( length( $self->header_fmt->format({}) ) );
    $self->bar_sz(    length( $self->bar_fmt->format({}) ) );
    $self->tick_sz(   length( $self->tick_fmt->format({}) ) );
    my ($y, $m, $d) = $self->header->{date} =~ m/(\d\d\d\d)(\d\d)(\d\d)/;
    $self->day(DateTime->new(time_zone => $self->header->{time_zone},
                             year => $y, month => $m, day => $d));
    $self->date_start( $self->day->epoch );

    $self->{bar_ts} ||= [];

    for (0..2) {
        my ($start, $end) = ($self->header->{start}[$_], $self->header->{end}[$_]);
        last unless $start && $end;

        push @{$self->{bar_ts}},
            map { $start + $_ * $self->{header}{bar_seconds} }
                (1..($end - $start) / $self->{header}{bar_seconds});
    }
    $self->nbars( scalar @{$self->{bar_ts}} );

    return $self;
}


sub new_from_file {
    my $class = shift;
    my $file = shift;
    open my $fh, '<:raw', $file or die "$file: $!";

    sysread $fh, my $buf, length( $header_fmt->format({}) );

    my $header = $header_fmt->unformat($buf);

    # check magic
    die "file not recognized" unless $header->{magic} eq FITF_MAGIC;
    # XXX: sanity check for format

    my $self = $class->new({
        header_fmt => $header_fmt,
        bar_fmt    => ($header->{format} & FITF_BAR_FMT) == FITF_BAR_USHORT  ? $bar_s  : $bar_l,
        tick_fmt   => ($header->{format} & FITF_TICK_FMT) == FITF_TICK_USHORT ? $tick_s : $tick_l,
        fh => $fh,
        header => $header });

    return $self;
}

sub bar_idx {
    my ($self, $timestamp) = @_;
    my $session_idx = 0;
    my $h = $self->header;
    my $offset = 0;
    while ($session_idx < 3 && $timestamp > $h->{end}[$session_idx]) {
        $offset += ($h->{end}[$session_idx] - $h->{start}[$session_idx]) / $h->{bar_seconds};
        ++$session_idx;
    }
    return if $session_idx == 3;
    my $nth = ($timestamp - $h->{start}[$session_idx]) / $h->{bar_seconds} + $offset - 1;
}

sub bar_at {
    my ($self, $timestamp) = @_;
    my $nth = $self->bar_idx($timestamp);
    return unless defined $nth;

    seek $self->{fh}, $nth * $self->bar_sz + $self->header_sz, 0;

    my $buf;
    sysread $self->{fh}, $buf, $self->bar_sz;
    my $bar = $self->bar_fmt->unformat($buf);
    $bar->{$_} /= $self->{header}{divisor} for qw(open high low close);
    return $bar;
}

sub run_ticks {
    my ($self, $start, $end, $cb) = @_;
    my $cnt = $end - $start + 1;
    seek $self->{fh}, $start * $self->tick_sz + $self->nbars * $self->bar_sz + $self->header_sz, 0;

    $self->_fast_unformat($self->tick_fmt, $self->tick_sz, $cnt,
                          sub {
                              my $tick = shift;
                              my $time = $self->{date_start} + $tick->{offset_min}*60 + $tick->{offset_msec}/1000;
                              $cb->($time, $tick->{price} / $self->{header}{divisor}, $tick->{volume});
                          });
}

sub run_bars {
    my ($self, $start, $end, $cb) = @_;
    my $cnt = $end - $start + 1;
    seek $self->{fh}, $start * $self->bar_sz + $self->header_sz, 0;

    $self->_fast_unformat($self->bar_fmt, $self->bar_sz, $cnt, $cb);
}

sub _fast_unformat {
    my ($self, $fmt, $sz, $n, $cb) = @_;

    my $buf;
    read $self->{fh}, $buf, $sz * $n;

    my @records = unpack('('.$fmt->_format.')*', $buf);
    while (my @r = splice(@records, 0, scalar @{$fmt->{Names}})) {
        my $record = {};
        @{$record}{@{$fmt->{Names}}} = @r;
        $cb->($record);
    }
}

sub run_bars_as {
    my ($self, $bar_seconds, $offset, $cb) = @_;
    Carp::confess unless $bar_seconds;
    my @ts;
    my $h = $self->header;
    for (0..2) {
        my ($start, $end) = ($self->header->{start}[$_], $self->header->{end}[$_]);
        last unless $start && $end;

        $start -= $offset;
        push @ts,
            map { my $t = $start + $_ * $bar_seconds;
                  $t < $end ? $t : $end;
              } (1..ceil(($end - $start) / $bar_seconds));
    }

    my $i = 0;
    my $current_bar;
    my $last_price;
    $self->run_bars(0, $self->nbars-1,
                    sub {
                        my $bar = shift;
                        my $ts = $self->{bar_ts}[$i++];
                        if ($bar->{volume}) {
                            if ($current_bar) {
                                $current_bar->{high} = $bar->{high}
                                    if $bar->{high} > $current_bar->{high};
                                $current_bar->{low} = $bar->{low}
                                    if $bar->{low} < $current_bar->{low};

                                $current_bar->{close} = $bar->{close};
                                $current_bar->{volume} += $bar->{volume};
                                $current_bar->{ticks} += $bar->{ticks};
                            }
                            else {
                                $current_bar = $bar;
                            }
                        }
                        if ($ts == $ts[0]) {
                            $current_bar ||= { open => $last_price,
                                               high => $last_price,
                                               low  => $last_price,
                                               close => $last_price,
                                               volume => 0,
                                               ticks => 0,
                                           };
                            $cb->(shift @ts, $current_bar);
                            $last_price = $current_bar->{close};
                            undef $current_bar;
                        }
                    });
    if (@ts) {
        $cb->(shift @ts, $current_bar);
    }
}

sub format_timestamp {
    my ($self, $ts) = @_;
    my $hms = $ts - $self->{date_start};
    my $d = $self->day;

    if ($hms < 0) {
        $d = $d->clone->subtract(days => 1);
        $hms += 86400;
    }
    elsif ($hms >= 86400) {
        $d = $d->clone->add(days => 1);
        $hms -= 86400;
    }
    $hms = sprintf('%02d:%02d:%02d',
                   int($hms / 60 / 60),
                   int(($hms % 3600)/60),
                   ($hms % 60));
    return $d->ymd. ' '.$hms;
}

sub new_writer {
    my ($class, %args) = @_;
    my $hdr = delete $args{header};
    my $header = {
        magic => FITF_MAGIC,
        version => FITF_VERSION,
        start => [],
        end   => [],
        records => 0,
        bar_seconds => 10,
        divisor => 1,
        format => FITF_TICK_ULONG | FITF_BAR_ULONG,
        %$hdr,
    };

    Finance::FITF::Writer->new({
        header_fmt => $header_fmt,
        bar_fmt    => ($header->{format} & FITF_BAR_FMT) == FITF_BAR_USHORT  ? $bar_s  : $bar_l,
        tick_fmt   => ($header->{format} & FITF_TICK_FMT) == FITF_TICK_USHORT ? $tick_s : $tick_l,
        %args,
        header => $header});
}

1;
__END__