File Coverage

blib/lib/GedNav.pm
Criterion Covered Total %
statement 13 15 86.6
branch n/a
condition n/a
subroutine 5 5 100.0
pod n/a
total 18 20 90.0


line stmt bran cond sub pod time code
1             package GedNav;
2              
3 1     1   584 use Cwd;
  1         2  
  1         78  
4 1     1   865 use POSIX qw(ctime);
  1         7673  
  1         6  
5 1     1   1086 use File::Basename;
  1         3  
  1         6238  
6 1     1   746 use FileHandle;
  1         11335  
  1         6  
7 1     1   1787 use GDBM_File;
  0            
  0            
8             use Text::Soundex;
9              
10             use strict;
11              
12             use vars qw($VERSION);
13             $VERSION = '0.02';
14              
15             use GedNav::Individual;
16              
17             sub new
18             {
19             my $type = shift;
20             $type = ref $type if ref $type;
21             my $dataset = shift;
22              
23             my $file = new FileHandle;
24             $file->open("<$dataset.ged") || die "Can't open gedcom file $dataset.ged: $!";
25              
26             my @stat = stat "$dataset.ged";
27              
28             my $newobj = {
29             dataset => $dataset,
30             file => $file,
31             private => 1,
32             lastmod => $stat[9],
33             };
34              
35             bless $newobj, $type;
36              
37             my $ref_tie = $newobj->build_refindex_somewhere;
38              
39             die "Couldn't open/find index file $dataset-refs.gdbm: $!" unless $ref_tie;
40              
41             my $si_tie = $newobj->build_surnameindex_somewhere;
42              
43             warn "Can't open index file $dataset-surnames.gdbm: $!" unless $si_tie;
44              
45             return $newobj;
46             }
47              
48             sub private
49             {
50             my $self = shift;
51             my $attrname = 'private';
52              
53             if (@_)
54             {
55             $self->{$attrname} = shift;
56             }
57              
58             return $self->{$attrname};
59             }
60              
61             sub dataset
62             {
63             my $self = shift;
64             return $self->{'dataset'};
65             }
66              
67             sub lastmod
68             {
69             my $self = shift;
70             return ctime($self->{'lastmod'});
71             }
72              
73             sub get_indi
74             {
75             my $self = shift;
76             my $code = shift;
77              
78             return new GedNav::Individual($self, $code);
79             }
80              
81             sub individuals
82             {
83             my $self = shift;
84              
85             my @indis =
86             map { new GedNav::Individual($self, $_) }
87             grep { s/^indi://i }
88             keys %{$self->{'index'}};
89              
90             return @indis;
91             }
92              
93             sub surnames
94             {
95             my $self = shift;
96             my $attrname = 'surnames';
97              
98             unless (exists $self->{$attrname})
99             {
100             $self->{$attrname} = [];
101              
102             if (exists $self->{'surnameindex'})
103             {
104             @{$self->{$attrname}} =
105             grep { length($_) > 1 }
106             keys %{$self->{'surnameindex'}};
107             }
108             else
109             {
110             my %surnames =
111             map { $_->surname => 1 }
112             grep { length($_->surname) > 1 }
113             $self->individuals;
114              
115             @{$self->{$attrname}} = keys %surnames;
116             }
117             }
118              
119             return @{$self->{$attrname}};
120             }
121              
122             sub families
123             {
124             my $self = shift;
125              
126             my @famlies =
127             map { $self->{'index'}->{$_} }
128             grep { s/^fam://i }
129             keys %{$self->{'index'}};
130              
131             return @famlies;
132             }
133              
134             sub by_surname
135             {
136             my $self = shift;
137             my $surname = shift;
138              
139             my @indis =
140             map { new GedNav::Individual($self, $_) }
141             split(/:/, $self->{'surnameindex'}->{uc($surname)})
142             ;
143              
144             return @indis;
145             }
146              
147             sub by_soundex
148             {
149             my $self = shift;
150             my $soundex = uc(shift);
151              
152             my @indis =
153             sort { $a->surname cmp $b->surname || $a->name cmp $b->name }
154             map { $self->by_surname($_) }
155             grep { soundex($_) eq $soundex }
156             $self->surnames
157             ;
158              
159             return @indis;
160             }
161              
162             sub _get_paragraph
163             {
164             my $self = shift;
165             my $key = uc(shift);
166              
167             unless (exists $self->{'index'}->{$key})
168             {
169             warn "Unknown key: $key";
170             return undef;
171             }
172              
173             my $fh = $self->{'file'};
174              
175             $self->{'file'}->seek($self->{'index'}->{$key}, 0);
176              
177             my @par;
178              
179             my $line = <$fh>;
180             $line =~ s/[\r\n]+$//g;
181             push @par, $line;
182              
183             while (defined ($line = <$fh>) && $line !~ /^0\s/)
184             {
185             $line =~ s/[\r\n]+$//g;
186             push @par, $line;
187             }
188              
189             return \@par;
190             }
191              
192             my @trydirs = qw(. /tmp);
193              
194             sub build_refindex_somewhere
195             {
196             my $self = shift;
197              
198             my $tie;
199             my $dbfile;
200             my %refindex;
201              
202             my $basename = basename($self->{'dataset'});
203             my $file = $self->{'file'};
204             my @filestat = $file->stat;
205              
206             foreach (dirname($self->{'dataset'}), @trydirs)
207             {
208             $dbfile = "$_/$basename-refs.gdbm";
209              
210             my @dbstat = stat($dbfile);
211             next unless @dbstat;
212             next if $dbstat[9] < $filestat[9];
213              
214             $tie = tie(%refindex, 'GDBM_File', $dbfile, &GDBM_READER, 0644);
215              
216             last if $tie;
217             }
218              
219             if ($tie)
220             {
221             $self->{'index'} = \%refindex;
222             return $tie;
223             }
224              
225             foreach (dirname($self->{'dataset'}), @trydirs)
226             {
227             $dbfile = "$_/$basename-refs.gdbm";
228              
229             $tie = tie(%refindex, 'GDBM_File', $dbfile, &GDBM_NEWDB, 0644);
230              
231             last if $tie;
232             }
233              
234             return undef unless $tie;
235              
236             warn "Creating new refdb at $dbfile\n";
237              
238             my %counts = (
239             INDI => 0,
240             FAM => 0,
241             SOUR => 0,
242             );
243              
244             $file->seek(0, 0);
245              
246             my $count = 0;
247             my $offset = 0;
248             while (<$file>)
249             {
250             s/[\r\n]+$//g;
251              
252             my ($tag, $type) = /^0\s+@([\w]+)@\s+(indi|fam|sour)/i;
253              
254             if ($tag)
255             {
256             $tag = uc($tag);
257             $type = uc($type);
258              
259             $counts{$type} += 1;
260              
261             $refindex{"$type:$tag"} = $offset;
262             }
263              
264             $offset = $file->tell;
265             }
266              
267             untie %refindex;
268             undef $tie;
269              
270             warn "Index built: ", join(", ", map { $counts{$_} . " " . $_ } sort keys %counts), "\n";
271              
272             $tie = tie(%refindex, 'GDBM_File', $dbfile, &GDBM_READER, 0644);
273             $self->{'index'} = \%refindex;
274              
275             return $tie;
276             }
277              
278             sub build_surnameindex_somewhere
279             {
280             my $self = shift;
281              
282             my $tie;
283             my $dbfile;
284             my %surnameindex;
285              
286             my $basename = basename($self->{'dataset'});
287             my @filestat = $self->{'file'}->stat;
288              
289             foreach (dirname($self->{'dataset'}), @trydirs)
290             {
291             $dbfile = "$_/$basename-surnames.gdbm";
292              
293             my @dbstat = stat($dbfile);
294             next unless @dbstat;
295             next if $dbstat[9] < $filestat[9];
296              
297             $tie = tie(%surnameindex, 'GDBM_File', $dbfile, &GDBM_READER, 0644);
298              
299             last if $tie;
300             }
301              
302             if ($tie)
303             {
304             $self->{'surnameindex'} = \%surnameindex;
305             return $tie;
306             }
307              
308             foreach (dirname($self->{'dataset'}), @trydirs)
309             {
310             $dbfile = "$_/$basename-surnames.gdbm";
311              
312             $tie = tie(%surnameindex, 'GDBM_File', $dbfile, &GDBM_NEWDB, 0644);
313              
314             last if $tie;
315             }
316              
317             return undef unless $tie;
318              
319             warn "Creating new surnamedb at $dbfile\n";
320              
321             my %surnames;
322              
323             foreach ($self->individuals)
324             {
325             my $surname = uc($_->surname);
326              
327             if (exists $surnames{$surname})
328             {
329             $surnames{$surname} .= ":" . $_->code;
330             }
331             else
332             {
333             $surnames{$surname} = $_->code;
334             }
335             }
336              
337             %surnameindex = %surnames;
338              
339             # now just close & reopen as a reader
340              
341             untie %surnameindex;
342             undef $tie;
343              
344             $tie = tie(%surnameindex, 'GDBM_File', $dbfile, &GDBM_READER, 0644);
345             $self->{'surnameindex'} = \%surnameindex;
346              
347             return $tie;
348             }
349              
350             ###
351              
352             1;
353             __END__