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


line stmt bran cond sub pod time code
1             package String::Lookup::FlatFile;
2             $VERSION= 0.13;
3              
4             # what runtime features we need
5 1     1   16 use 5.014;
  1         3  
6 1     1   5 use warnings;
  1         1  
  1         27  
7 1     1   466 use autodie qw( binmode close open );
  1         12797  
  1         4  
8              
9             # modules that we need
10 1     1   544 no bytes;
  1         2  
  1         178  
11 1     1   182 use Encode qw( is_utf8 _utf8_on );
  1         2  
  1         817  
12              
13             # initializations
14             my $format= 'Nnc';
15              
16             # satisfy -require-
17             1;
18              
19             #-------------------------------------------------------------------------------
20             #
21             # Class Methods
22             #
23             #-------------------------------------------------------------------------------
24             # flush
25             #
26             # IN: 1 class
27             # 2 options hash ref
28             # 3 underlying list ref with strings
29             # 4 list ref with ID's to be flushed
30             # OUT: 1 boolean indicating success
31              
32             sub flush {
33 6     6 0 13 my ( $class, $options, $list, $ids )= @_;
34              
35             # initializations
36 6         8 local $_;
37 6         10 my $handle= $options->{handle};
38              
39             # write all ID's
40 6         10 foreach my $id ( @$ids ) {
41             print( $handle
42             pack( $format, $id, bytes::length($_), is_utf8($_) ), $_ ) ||
43             die "Error writing data: $!"
44 8   50     799 foreach $list->[$id];
45             }
46              
47             # make sure it's on disk
48 6 50       262 die "Could not flush data: $!" if !defined $handle->flush;
49              
50 6         7083 return 1;
51             } #flush
52              
53             #-------------------------------------------------------------------------------
54             # init
55             #
56             # IN: 1 class
57             # 2 options hash ref
58             # OUT: 1 hash ref with lookup
59              
60             sub init {
61 8     8 0 17 my ( $class, $options )= @_;
62              
63             # defaults
64 8         9 state $headerlen= 7;
65 8   66     30 $options->{dir} //= $ENV{STRING_LOOKUP_FLATFILE_DIR};
66              
67             # sanity check
68 8         8 my @errors;
69 8 50       18 push @errors, "Must have a 'dir' specified" if !$options->{dir};
70 8 50       13 push @errors, "Must have a 'tag' specified" if !$options->{tag};
71 8 50       15 die join "\n", "Found the following problems with init:", @errors
72             if @errors;
73              
74             # initializations
75 8         12 my %hash;
76 8         18 my $filename= "$options->{dir}/$options->{tag}.lookup";
77              
78             # set up reading of file if there is one
79 8 100       151 if ( -s $filename ) {
80 4         280 open my $handle, '<', $filename;
81 4         400 binmode $handle;
82              
83             # while we have something
84 4         137 my ( $bytes, $header, $id, $stringlen, $string, $utf8on );
85 4         57 while ( $bytes= read $handle, $header, $headerlen ) {
86 8 50       19 die "Did not read complete header: only $bytes of $headerlen"
87             if $bytes != $headerlen;
88              
89             # fetch ID and string
90 8         27 ( $id, $stringlen, $utf8on )= unpack $format, $header;
91 8         18 $bytes= read $handle, $string, $stringlen;
92 8 50       17 die "Error reading data: $!" if !defined $bytes;
93 8 50       31 die "Did not read complete data: only $bytes of $stringlen"
94             if $bytes != $stringlen;
95              
96             # store it in the right way
97 8 100       50 _utf8_on($string) if $utf8on;
98 8         45 $hash{$string}= $id;
99             }
100              
101             # all ok?
102 4 50       12 die "Error reading header: $!" if !defined $bytes;
103 4         12 close $handle;
104             }
105              
106             # open file for flushing (again)
107 8         1014 open my $handle, '>>', $filename;
108 8         3018 binmode $handle;
109 8         1239 $options->{handle}= $handle;
110              
111 8         38 return \%hash;
112             } #init
113              
114             #-------------------------------------------------------------------------------
115             # parameters_ok
116             #
117             # IN: 1 class (not used)
118             # OUT: 1 .. N parameter names
119              
120 8     8 0 13 sub parameters_ok { state $ok= [ qw( dir ) ]; @{$ok} } #parameters_ok
  8         12  
  8         20  
121              
122             #-------------------------------------------------------------------------------
123              
124             __END__