view release on metacpan or  search on metacpan

lib/Biblio/COUNTER/Report.pm  view on Meta::CPAN

use constant YTD_TOTAL    => 'ytd';

# Metrics
use constant REQUESTS  => 'requests';
use constant SEARCHES  => 'searches';
use constant SESSIONS  => 'sessions';
use constant TURNAWAYS => 'turnaways';

# Field matching
use constant MAY_BE_BLANK => 0;
use constant NOT_BLANK    => 1;
use constant EXACT_MATCH  => 2;

# Useful constants
use constant INVALID => 0;
use constant VALID   => 1;
use constant FIXED   => 2;

# --- Variables

my %mon2num = qw(
    jan 01
    feb 02
    mar 03
    apr 04
    may 05
    jun 06
    jul 07
    aug 08
    sep 09
    oct 10
    nov 11
    dec 12
);

my @num2mon = qw(
    ---
    jan
    feb
    mar
    apr
    may
    jun
    jul
    aug
    sep
    oct
    nov
    dec
);

my $rx_mon = qr/(?i)jan|feb|mar|apr|may|june?|july?|aug|sept?|oct|nov|dec|0[1-9]|1[0-2]/;
my $rx_year = qr/(?:2[012])?\d\d/;  # Good through 2299

# ------------------------------------------------------------ PUBLIC METHODS --

sub new {
    my ($cls, %args) = @_;
    bless {
        'treat_blank_counts_as_zero' => 0,
        'change_not_available_to_blank' => 0,
        'dont_reread_next_row' => 0,
        %args,
    }, $cls;
}

sub process {
    my ($self) = @_;
    $self->begin_file
         ->begin_report
         ->process_header
         ->process_body
         ->end_report
         ->end_file;
}

# ---------------------------------------------- TOP-LEVEL STRUCTURAL METHODS --

sub begin_file {
    my ($self) = @_;
    $self->trigger_callback('begin_file', $self->{'file'});
}

sub end_file {
    my ($self) = @_;
    $self->trigger_callback('end_file', $self->{'file'});
}

sub begin_report {
    my ($self) = @_;
    $self->trigger_callback('begin_report');
    $self->_orient;
}

sub end_report {
    my ($self) = @_;
    $self->{'is_valid'} = !$self->{'errors'};
    $self->trigger_callback('end_report');
    undef $self->{'fh'};
    return $self;
}

sub process_header {
    my ($self) = @_;
    $self->begin_header;
    $self->process_header_rows;
    $self->end_header;
}

sub process_header_rows {
    die "Every report must have its own header-processing code";
}

sub process_body {
    my ($self) = @_;
    $self->_in_scope(RECORD);
    $self->begin_body;
    while (!$self->_eof) {
        $self->begin_record;
        $self->process_record;
        $self->end_record;

lib/Biblio/COUNTER/Report.pm  view on Meta::CPAN

    $self->_in_field(LABEL)->_must_match($str, $rx);
}

sub begin_header {
    my ($self) = @_;
    my $hdr = $self->{'container'} = $self->{'header'} = {
        'name' => $self->canonical_report_name,
        'description' => $self->canonical_report_description,
        'code' => $self->canonical_report_code,
        'release' => $self->release_number,
    };
    $self->trigger_callback('begin_header', $hdr);
    return $self;
}

sub end_header {
    my ($self) = @_;
    my $hdr = $self->{'header'};
    $self->trigger_callback('end_header', $hdr);
    return $self;
}

sub begin_record {
    my ($self) = @_;
    my $rec = $self->{'container'} = $self->{'record'} = {};
    $self->trigger_callback('begin_record', $rec);
    return $self;
}

sub end_record {
    my ($self) = @_;
    my $rec = $self->{'record'};
    push @{ $self->{'records'} ||= [] }, $rec;
    $self->trigger_callback('end_record', $rec);
    return $self;
}

# ----------------------------------------------------------- PRIVATE METHODS --

# --- Record field checking methods

sub _check_field {
    my ($self, $field, $check) = @_;
    $self->_in_field($field);
    my $container = $self->{'container'};
    my $cur = $self->_ref_to_cur_cell;
    $self->_trim($cur);
    if ($check->($self, $field, $cur)) {
        $container->{$field} = $$cur;
    }
    return $self;
}

sub _check_free_text_field {
    my ($self, $field, $mode, $str) = @_;
    if ($mode == EXACT_MATCH) {
        $str = '' unless defined $str;
        $self->_check_field($field, _exact_match_sub($str));
    }
    elsif ($mode == NOT_BLANK) {
        $self->_check_field($field, \&_is_not_blank);
    }
    else {
        $self->_check_field($field, \&_is_anything);
    }
    $self->_next;
}

sub _not_available {
    my ($self) = @_;
    if ($self->{'change_not_available_to_blank'}) {
        $self->_fix('');
    }
    else {
        $self->_cant_fix('<count>');
    }
    return $self;
}

sub _check_count {
    my ($self, $field, $period) = @_;
    my $cur = $self->_ref_to_cur_cell;
    $self->_trim($cur);
    my $val = $$cur;
    my $container = $self->{'container'};
    if (defined $period) {
        # Usage for a particular period
        my ($result, $normalized_period);
        ($result, $period, $normalized_period) = $self->parse_period($period);
        if ($val =~ /^\d+$/) {
            if ($result != INVALID) {
                $container->{'count'}->{$normalized_period}->{$field} = $val;
                $self->trigger_callback('count', $self->{'scope'}, $field, $period, $val);
            }
        }
        elsif ($val eq '') {
            if ($self->{'treat_blank_counts_as_zero'}) {
                $container->{'count'}->{$normalized_period}->{$field} = $val;
                $self->trigger_callback('count', $self->{'scope'}, $field, $period, 0);
            }
        }
        elsif ($val =~ m{^n/a$}i) {
            $self->_not_available;
        }
        else {
            $self->_cant_fix('<count>');
        }
    }
    else {
        # YTD usage
        if ($val =~ /^\d+$/) {
            $container->{'count'}->{$field} = $val;
            $self->trigger_callback("count_$field", $self->{'scope'}, $field, $val);
        }
        elsif ($val eq '') {
            if ($self->{'treat_blank_counts_as_zero'}) {
                $container->{'count'}->{$field} = $val;
                $self->trigger_callback("count_$field", $self->{'scope'}, $field, 0);
            }
        }
        elsif ($val =~ m{^n/a$}i) {
            $self->_not_available;
        }
        else {
            $self->_cant_fix('<count>');
        }
    }
    $self->_next;
}

sub _exact_match_sub {
    # Return a ref to code that compares the current cell's value to the given string
    my ($str) = @_;
    return sub {
        my ($self, $field, $cur) = @_;
        $cur ||= $self->_ref_to_cur_cell;
        if ($$cur eq $str) {
            $self->_ok($cur);
        }
        else {
            $self->_cant_fix($str);
        }
        return $self;
    };
}

sub _force_exact_match_sub {
    # Return a ref to code that forces the current cell's value to the given string
    my ($str) = @_;
    return sub {
        my ($self, $field, $cur) = @_;
        if ($$cur eq $str) {
            $self->_ok($cur);
        }
        else {
            $self->_fix($str);
        }
        return $self;
    };
}

sub _is_yyyymmdd {
    my ($self) = @_;
    my $cur = $self->_ref_to_cur_cell;
    my $val = $$cur;
    if ($val =~ /^(\d\d\d\d)-(\d\d)-(\d\d)$/) {
        # Nothing to do
        return $self->_ok($cur);
    }
    elsif ($val =~ m{^(\d\d?)/(\d\d?)/(\d\d)?(\d\d)$}) {
        # Ack!  Try to fix
        if ($1 < 13 && $2 >= 13) {
            # mm/dd/(cc)?yy
            return $self->_fix(sprintf('%02d%02d-%02d-%02d', $3 || 20, $4, $1, $2));
        }
        elsif ($2 < 13 && $1 >= 13) {
            # dd/mm/(cc)?yy
            return $self->_fix(sprintf('%02d%02d-%02d-%02d', $3 || 20, $4, $2, $1));
        }
    }
    return $self->_cant_fix('<yyyy-mm-dd>');
}

sub _is_anything {
    my ($self) = @_;
    $self->_trim;
}

sub _is_issn {
    my ($self, $field, $cur) = @_;
    $self->_trim;
    my $val = $$cur;
    if (length $val) {
        if ($val =~ /^\d{4}-\d{3}[\dX]$/) {
            $self->_ok($cur);
        }
        elsif ($val =~ /^(\d{3,4})-?(\d{3})([\dXx])$/) {
            $self->_fix(sprintf("%04d-%03d%s", $1, $2, lc $3));
        }
        else {
            $self->_cant_fix('<issn>');
        }
    }
    return $self;
}

sub _is_count {
    my ($self, $field, $cur) = @_;
    if ($$cur =~ /^\d+$/) {
        $self->_ok($cur);
    }
    else {
        $self->_cant_fix('<count>');
    }
    return $self;
}

sub _is_not_blank {
    my ($self, $field, $cur) = @_;
    if ($$cur eq '') {
        $self->_cant_fix('<not blank>');
        return;
    }
    else {
        $self->_ok($cur);
    }
    return $self;
}

sub _must_match {
    my ($self, $str, $rx) = @_;
    $rx ||= _str2rx($str);
    my $cur = $self->_ref_to_cur_cell;
    $self->_trim($cur);
    if ($$cur eq $str) {
        $self->_ok($cur);
    }
    elsif ($$cur =~ /$rx/) {
        $self->_fix($str);
    }
    else {
        $self->_cant_fix($str);
    }
    $self->_next;
}

sub _read_next_line {
    my ($self) = @_;
    # Fetch the next line
    my $fh = $self->{'fh'};
    my $line = <$fh>;
    return unless defined $line;
    chomp $line;
    $self->trigger_callback('line', $.);
    $self->trigger_callback('input', $line);
    return $line;
}

sub _read_next_row {
    my ($self) = @_;
    if ($self->{'dont_reread_next_row'}) {
        $self->{'dont_reread_next_row'} = 0;
        return $self->{'row'};
    }
    my $line = $self->_read_next_line;
    return unless defined $line;
    $line =~s/\x0d$//;  # Strip CR at end of line
    my $begin_row = $self->{'row'} = [ $self->_parse_line($line) ];
    push @{ $self->{'rows'} }, $begin_row;
    $self->{'r'}++;
    $self->{'c'} = 'A';
    return $begin_row;
}

sub _parse_line {
    my ($self, $line) = @_;
    chomp $line;
    if ($line =~ /\t/) {