/[MARC-Fast]/trunk/lib/MARC/Fast.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /trunk/lib/MARC/Fast.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/Fast.pm revision 1 by dpavlin, Tue Jan 4 10:26:07 2005 UTC trunk/lib/MARC/Fast.pm revision 47 by dpavlin, Thu Aug 22 11:24:36 2013 UTC
# Line 1  Line 1 
   
1  package MARC::Fast;  package MARC::Fast;
2    
3  use strict;  use strict;
4  use Carp;  use Carp;
5  use Data::Dumper;  use Data::Dump qw/dump/;
6    
7  BEGIN {  BEGIN {
8          use Exporter ();          use Exporter ();
9          use vars qw ($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);          use vars qw ($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
10          $VERSION     = 0.01;          $VERSION     = 0.12;
11          @ISA         = qw (Exporter);          @ISA         = qw (Exporter);
12          #Give a hoot don't pollute, do not export more than needed by default          #Give a hoot don't pollute, do not export more than needed by default
13          @EXPORT      = qw ();          @EXPORT      = qw ();
# Line 23  MARC::Fast - Very fast implementation of Line 23  MARC::Fast - Very fast implementation of
23    
24    use MARC::Fast;    use MARC::Fast;
25    
26      my $marc = new MARC::Fast(
27            marcdb => 'unimarc.iso',
28      );
29    
30      foreach my $mfn ( 1 .. $marc->count ) {
31            print $marc->to_ascii( $mfn );
32      }
33    
34    For longer example with command line options look at L<scripts/dump_fastmarc.pl>
35    
36  =head1 DESCRIPTION  =head1 DESCRIPTION
37    
38  This is very fast alternative to C<MARC> and C<MARC::Record> modules.  This is very fast alternative to C<MARC> and C<MARC::Record> modules.
39    
40  It's is also very sutable for random access to MARC records (as opposed to  It's is also very subtable for random access to MARC records (as opposed to
41  sequential one).  sequential one).
42    
43  =head1 METHODS  =head1 METHODS
# Line 42  Read MARC database Line 51  Read MARC database
51          quiet => 0,          quiet => 0,
52          debug => 0,          debug => 0,
53          assert => 0,          assert => 0,
54            hash_filter => sub {
55                    my ($t, $record_number) = @_;
56                    $t =~ s/foo/bar/;
57                    return $t;
58            },
59    );    );
60    
61  =cut  =cut
# Line 59  sub new { Line 73  sub new {
73          print STDERR "# opening ",$self->{marcdb},"\n" if ($self->{debug});          print STDERR "# opening ",$self->{marcdb},"\n" if ($self->{debug});
74    
75          open($self->{fh}, $self->{marcdb}) || croak "can't open ",$self->{marcdb},": $!";          open($self->{fh}, $self->{marcdb}) || croak "can't open ",$self->{marcdb},": $!";
76            binmode($self->{fh});
77    
78          $self->{count} = 0;          $self->{count} = 0;
79    
# Line 69  sub new { Line 84  sub new {
84                  push @{$self->{fh_offset}}, tell($self->{fh});                  push @{$self->{fh_offset}}, tell($self->{fh});
85    
86                  my $leader;                  my $leader;
87                  read($self->{fh}, $leader, 24);                  my $len = read($self->{fh}, $leader, 24);
88    
89                    if ($len < 24) {
90                            warn "short read of leader, aborting\n";
91                            $self->{count}--;
92                            last;
93                    }
94    
95                  # Byte        Name                  # Byte        Name
96                  # ----        ----                  # ----        ----
# Line 100  sub new { Line 121  sub new {
121                  print STDERR "REC ",$self->{count},": $leader\n" if ($self->{debug});                  print STDERR "REC ",$self->{count},": $leader\n" if ($self->{debug});
122    
123                  # store leader for later                  # store leader for later
124                  push @{$self->{leaders}}, $leader;                  push @{$self->{leader}}, $leader;
125    
126                  # skip to next record                  # skip to next record
127                  seek($self->{fh},substr($leader,0,5)-24,1);                  my $o = substr($leader,0,5);
128                    warn "# in record ", $self->{count}," record length isn't number but: ",dump($o),"\n" unless $o =~ m/^\d+$/;
129                    if ($o > 24) {
130                            seek($self->{fh},$o-24,1) if ($o);
131                    } else {
132                            last;
133                    }
134    
135          }          }
136    
# Line 129  Fetch record from database Line 156  Fetch record from database
156    
157    my $hash = $marc->fetch(42);    my $hash = $marc->fetch(42);
158    
159    First record number is C<1>
160    
161  =cut  =cut
162    
163  sub fetch {  sub fetch {
164          my $self = shift;          my $self = shift;
165    
166          my $rec_nr = shift || return;          my $rec_nr = shift;
167    
168          my $leader = $self->{leaders}->[$rec_nr - 1];          if ( ! $rec_nr ) {
169                    $self->{last_leader} = undef;
170                    return;
171            }
172    
173            my $leader = $self->{leader}->[$rec_nr - 1];
174            $self->{last_leader} = $leader;
175          unless ($leader) {          unless ($leader) {
176                  carp "can't find record $rec_nr";                  carp "can't find record $rec_nr";
177                  return;                  return;
# Line 196  sub fetch { Line 231  sub fetch {
231                  my $f = substr($fields,$addr,$len);                  my $f = substr($fields,$addr,$len);
232                  print STDERR "tag/len/addr $tag [$len] $addr: '$f'\n" if ($self->{debug});                  print STDERR "tag/len/addr $tag [$len] $addr: '$f'\n" if ($self->{debug});
233    
234                  $row->{$tag} = $f;                  push @{ $row->{$tag} }, $f;
235    
236                  my $del = substr($fields,$addr+$len-1,1);                  my $del = substr($fields,$addr+$len-1,1);
237    
# Line 217  sub fetch { Line 252  sub fetch {
252          return $row;          return $row;
253  }  }
254    
255    
256    =head2 last_leader
257    
258    Returns leader of last record L<fetch>ed
259    
260      print $marc->last_leader;
261    
262    Added in version 0.08 of this module, so if you need it use:
263    
264      use MARC::Fast 0.08;
265    
266    to be sure that it's supported.
267    
268    =cut
269    
270    sub last_leader {
271            my $self = shift;
272            return $self->{last_leader};
273    }
274    
275    
276    =head2 to_hash
277    
278    Read record with specified MFN and convert it to hash
279    
280      my $hash = $marc->to_hash( $mfn, include_subfields => 1,
281            hash_filter => sub { my ($l,$tag) = @_; return $l; }
282      );
283    
284    It has ability to convert characters (using C<hash_filter>) from MARC
285    database before creating structures enabling character re-mapping or quick
286    fix-up of data. If you specified C<hash_filter> both in C<new> and C<to_hash>
287    only the one from C<to_hash> will be used.
288    
289    This function returns hash which is like this:
290    
291      '200' => [
292                 {
293                   'i1' => '1',
294                   'i2' => ' '
295                   'a' => 'Goa',
296                   'f' => 'Valdo D\'Arienzo',
297                   'e' => 'tipografie e tipografi nel XVI secolo',
298                 }
299               ],
300    
301    This method will also create additional field C<000> with MFN.
302    
303    =cut
304    
305    sub to_hash {
306            my $self = shift;
307    
308            my $mfn = shift || confess "need mfn!";
309    
310            my $args = {@_};
311            my $filter_coderef = $args->{'hash_filter'} || $self->{'hash_filter'};
312    
313            # init record to include MFN as field 000
314            my $rec = { '000' => [ $mfn ] };
315    
316            my $row = $self->fetch($mfn) || return;
317    
318            foreach my $tag (keys %{$row}) {
319                    foreach my $l (@{$row->{$tag}}) {
320    
321                            # remove end marker
322                            $l =~ s/\x1E$//;
323    
324                            # filter output
325                            $l = $filter_coderef->($l, $tag) if $filter_coderef;
326    
327                            my $val;
328    
329                            # has identifiers?
330                            ($val->{'i1'},$val->{'i2'}) = ($1,$2) if ($l =~ s/^([01 #])([01 #])\x1F/\x1F/);
331    
332                            my $sf_usage;
333                            my @subfields;
334    
335                            # has subfields?
336                            if ($l =~ m/\x1F/) {
337                                    foreach my $t (split(/\x1F/,$l)) {
338                                            next if (! $t);
339                                            my $f = substr($t,0,1);
340                                            my $v = substr($t,1);
341    
342                                            push @subfields, ( $f, $sf_usage->{$f}++ || 0 );
343    
344                                            # repeatable subfiled -- convert it to array
345                                            if ( defined $val->{$f} ) {
346                                                    if ( ref($val->{$f}) ne 'ARRAY' ) {
347                                                            $val->{$f} = [ $val->{$f}, $v ];
348                                                    } else {
349                                                            push @{$val->{$f}}, $v;
350                                                    }
351                                            } else {
352                                                    $val->{$f} = $v;
353                                            }
354                                    }
355                                    $val->{subfields} = [ @subfields ] if $args->{include_subfields};
356                            } else {
357                                    $val = $l;
358                            }
359    
360                            push @{$rec->{$tag}}, $val;
361                    }
362            }
363    
364            return $rec;
365    }
366    
367    =head2 to_ascii
368    
369      print $marc->to_ascii( 42 );
370    
371    =cut
372    
373    sub to_ascii {
374            my $self = shift;
375    
376            my $mfn = shift || confess "need mfn";
377            my $row = $self->fetch($mfn) || return;
378    
379            my $out;
380    
381            foreach my $f (sort keys %{$row}) {
382                    my $dump = join('', @{ $row->{$f} });
383                    $dump =~ s/\x1e$//;
384                    $dump =~ s/\x1f/\$/g;
385                    $out .= "$f\t$dump\n";
386            }
387    
388            return $out;
389    }
390    
391  1;  1;
392  __END__  __END__
393    
394  =head1 BUGS  =head1 UTF-8 ENCODING
395    
396    This module does nothing with encoding. But, since MARC format is byte
397    oriented even when using UTF-8 which has variable number of bytes for each
398    character, file is opened in binary mode.
399    
400    As a result, all scalars recturned to perl don't have utf-8 flag. Solution is
401    to use C<hash_filter> and L<Encode> to decode utf-8 encoding like this:
402    
403  =head1 SUPPORT    use Encode;
404    
405      my $marc = new MARC::Fast(
406            marcdb => 'utf8.marc',
407            hash_filter => sub {
408                    Encode::decode( 'utf-8', $_[0] );
409            },
410      );
411    
412    This will affect C<to_hash>, but C<fetch> will still return binary representation
413    since it doesn't support C<hash_filter>.
414    
415  =head1 AUTHOR  =head1 AUTHOR
416    
# Line 246  LICENSE file included with this module. Line 430  LICENSE file included with this module.
430    
431  =head1 SEE ALSO  =head1 SEE ALSO
432    
433  perl(1).  L<Biblio::Isis>, perl(1).
434    
435  =cut  =cut

Legend:
Removed from v.1  
changed lines
  Added in v.47

  ViewVC Help
Powered by ViewVC 1.1.26