File Coverage

blib/lib/String/Lookup/FlatFile.pm

Criterion	Covered	Total	%
statement	51	51	100.0
branch	12	20	60.0
condition	3	5	60.0
subroutine	8	8	100.0
pod	0	3	0.0
total	74	87	85.0

package String::Lookup::FlatFile;
$VERSION= 0.13;

# what runtime features we need
use 5.014;
use warnings;
use autodie qw( binmode close open );

# modules that we need
no  bytes;
use Encode qw( is_utf8 _utf8_on );

# initializations
my $format= 'Nnc';

# satisfy -require-
1;

#-------------------------------------------------------------------------------
#
# Class Methods
#
#-------------------------------------------------------------------------------
# flush
#
#  IN: 1 class
#      2 options hash ref
#      3 underlying list ref with strings
#      4 list ref with ID's to be flushed
# OUT: 1 boolean indicating success

sub flush {
    my ( $class, $options, $list, $ids )= @_;

    # initializations
    local $_;
    my $handle= $options->{handle};

    # write all ID's
    foreach my $id ( @$ids ) {
        print( $handle
          pack( $format, $id, bytes::length($_), is_utf8($_) ), $_ ) ||
          die "Error writing data: $!"
          foreach $list->[$id];
    }

    # make sure it's on disk
    die "Could not flush data: $!" if !defined $handle->flush;

    return 1;
} #flush

#-------------------------------------------------------------------------------
# init
#
#  IN: 1 class
#      2 options hash ref
# OUT: 1 hash ref with lookup

sub init {
    my ( $class, $options )= @_;

    # defaults
    state $headerlen= 7;
    $options->{dir} //= $ENV{STRING_LOOKUP_FLATFILE_DIR};

    # sanity check
    my @errors;
    push @errors, "Must have a 'dir' specified" if !$options->{dir};
    push @errors, "Must have a 'tag' specified" if !$options->{tag};
    die join "\n", "Found the following problems with init:", @errors
      if @errors;

    # initializations
    my %hash;
    my $filename= "$options->{dir}/$options->{tag}.lookup";

    # set up reading of file if there is one
    if ( -s $filename ) {
        open my $handle, '<', $filename;
        binmode $handle;

        # while we have something
        my ( $bytes, $header, $id, $stringlen, $string, $utf8on );
        while ( $bytes= read $handle, $header, $headerlen ) {
            die "Did not read complete header: only $bytes of $headerlen"
              if $bytes != $headerlen;

            # fetch ID and string
            ( $id, $stringlen, $utf8on )= unpack $format, $header;
            $bytes= read $handle, $string, $stringlen;
            die "Error reading data: $!" if !defined $bytes;
            die "Did not read complete data: only $bytes of $stringlen"
              if $bytes != $stringlen;

            # store it in the right way
            _utf8_on($string) if $utf8on;
            $hash{$string}= $id;
        }

        # all ok?
        die "Error reading header: $!" if !defined $bytes;
        close $handle;
    }

    # open file for flushing (again)
    open my $handle, '>>', $filename;
    binmode $handle;
    $options->{handle}= $handle;

    return \%hash;
} #init

#-------------------------------------------------------------------------------
# parameters_ok
#
#  IN: 1 class (not used)
# OUT: 1 .. N parameter names

sub parameters_ok { state $ok= [ qw( dir ) ]; @{$ok} } #parameters_ok

#-------------------------------------------------------------------------------

__END__