File Coverage

blib/lib/Math/OEIS/SortedFile.pm
Criterion Covered Total %
statement 52 71 73.2
branch 13 26 50.0
condition 5 8 62.5
subroutine 15 19 78.9
pod 0 8 0.0
total 85 132 64.3


line stmt bran cond sub pod time code
1             # Copyright 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2019 Kevin Ryde
2              
3             # This file is part of Math-OEIS.
4             #
5             # Math-OEIS is free software; you can redistribute it and/or modify it
6             # under the terms of the GNU General Public License as published by the Free
7             # Software Foundation; either version 3, or (at your option) any later
8             # version.
9             #
10             # Math-OEIS is distributed in the hope that it will be useful, but
11             # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
12             # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
13             # for more details.
14             #
15             # You should have received a copy of the GNU General Public License along
16             # with Math-OEIS. If not, see .
17              
18              
19             package Math::OEIS::SortedFile;
20 4     4   71828 use 5.006;
  4         30  
21 4     4   20 use strict;
  4         9  
  4         115  
22 4     4   22 use warnings;
  4         7  
  4         106  
23 4     4   19 use Carp 'croak';
  4         6  
  4         196  
24 4     4   2036 use Search::Dict;
  4         4216  
  4         206  
25 4     4   1560 use Math::OEIS;
  4         11  
  4         240  
26              
27 4     4   27 eval q{use Scalar::Util 'weaken'; 1}
  4         8  
  4         122  
28             || eval q{sub weaken { $_[0] = undef }; 1 }
29             || die "Oops, error making a weaken() fallback: $@";
30              
31             our $VERSION = 14;
32              
33             # singleton here results in a separate instance object in each derived subclass
34 4     4   1931 use Class::Singleton;
  4         1190  
  4         2954  
35             our @ISA = ('Class::Singleton');
36             *_new_instance = __PACKAGE__->can('new');
37              
38             # uncomment this to run the ### lines
39             # use Smart::Comments;
40              
41              
42             # Keep track of all instances which exist and on an ithread CLONE re-open
43             # filehandles in the instances so they have their own independent file
44             # positions in the new thread.
45             my %instances;
46             sub DESTROY {
47 4     4   2465 my ($self) = @_;
48 4         67 delete $instances{$self+0};
49             }
50             sub CLONE {
51             # my ($class) = @_;
52 0     0   0 foreach my $self (values %instances) {
53 0         0 $self->close;
54             }
55             }
56              
57             sub new {
58 4     4 0 1844 my $class = shift;
59 4         15 my $self = bless { @_ }, $class;
60 4         38 weaken($instances{$self+0} = $self);
61 4         12 return $self;
62             }
63              
64             sub default_filename {
65 0     0 0 0 my ($self) = @_;
66 0         0 return Math::OEIS->local_filename($self->base_filename);
67             }
68              
69             sub filename {
70 2     2 0 7 my ($self) = @_;
71 2 50 33     29 if (ref $self && defined $self->{'filename'}) {
72 2         11 return $self->{'filename'};
73             }
74 0         0 return $self->default_filename;
75             }
76             sub filename_or_empty {
77 0     0 0 0 my ($self) = @_;
78 0         0 my $filename = $self->filename;
79 0 0       0 if (defined $filename) {
80 0         0 return $filename;
81             }
82 0         0 return '';
83             }
84              
85             sub fh {
86 13     13 0 33 my ($self) = @_;
87 13 50       53 if (! ref $self) { $self = $self->instance; }
  0         0  
88 13 100       36 if (! exists $self->{'fh'}) {
89 2 50       11 if (defined (my $filename = $self->filename)) {
90 2         4 my $fh;
91 2 50       91 if (open $fh, '<', $filename) {
92 2         10 $self->{'fh'} = $fh;
93             }
94             }
95             }
96 13         37 return $self->{'fh'};
97             }
98             sub close {
99 0     0 0 0 my ($self) = @_;
100 0 0       0 if (my $fh = delete $self->{'fh'}) {
101 0 0       0 if (! close $fh) {
102 0         0 my $err = "$!";
103 0         0 croak "Cannot close ",$self->filename_or_empty,": ",$err;
104             }
105             }
106             }
107              
108             # $line is a line from the names or stripped file.
109             # Return the A-number string from the line such as "A000001",
110             # or empty string if unrecognised or a comment line etc.
111             sub line_to_anum {
112 283     283 0 1054 my ($self, $line) = @_;
113             ### line_to_anum(): $line
114 283 100       950 return ($line =~ /^(A\d{6,})/ ? $1 : '');
115             }
116              
117             # $anum is an A-number string like "A000001".
118             # Return that number's line from the names or stripped file.
119             # If no such line then return undef.
120             # If a read error then croak.
121             sub anum_to_line {
122 13     13 0 25 my ($self, $anum) = @_;
123             ### $anum
124 13 50       36 if (! ref $self) { $self = $self->instance; }
  0         0  
125 13   50     48 my $fh = $self->fh || return undef;
126             my $pos = Search::Dict::look ($fh, $anum,
127             { xfrm => sub {
128 268     268   3916 my ($line) = @_;
129             ### $line
130 268 50       443 my ($got_anum) = $self->line_to_anum($line)
131             or return '';
132             ### $got_anum
133 268         498 return $got_anum;
134 13         106 } });
135 13 50       374 if ($pos < 0) {
136 0         0 my $err = "$!";
137 0         0 croak 'Error reading ',$self->filename_or_empty,': ',$err;
138             }
139              
140             # Ensure the line is in fact the $anum requested, since a bad $anum causes
141             # Search::Dict::look() to return the file position before where it would
142             # be found if it were present. This may be at end-of-file too, or perhaps
143             # even the file could be empty somehow.
144             #
145 13         23 my $line;
146 13 100 100     146 return (defined ($line = readline $fh)
147             && $self->line_to_anum($line) eq $anum
148             ? $line
149             : undef);
150             }
151              
152             1;
153             __END__