/[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

revision 1 by dpavlin, Tue Jan 4 10:26:07 2005 UTC revision 30 by dpavlin, Thu Feb 4 17:08:03 2010 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.09;
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                            carp "short read of leader, aborting\n";
91                            last;
92                    }
93    
94                  # Byte        Name                  # Byte        Name
95                  # ----        ----                  # ----        ----
# Line 100  sub new { Line 120  sub new {
120                  print STDERR "REC ",$self->{count},": $leader\n" if ($self->{debug});                  print STDERR "REC ",$self->{count},": $leader\n" if ($self->{debug});
121    
122                  # store leader for later                  # store leader for later
123                  push @{$self->{leaders}}, $leader;                  push @{$self->{leader}}, $leader;
124    
125                  # skip to next record                  # skip to next record
126                  seek($self->{fh},substr($leader,0,5)-24,1);                  my $o = substr($leader,0,5);
127                    warn "# in record ", $self->{count}," record length isn't number but: ",dump($o),"\n" unless $o =~ m/^\d+$/;
128                    if ($o > 24) {
129                            seek($self->{fh},$o-24,1) if ($o);
130                    } else {
131                            last;
132                    }
133    
134          }          }
135    
# Line 129  Fetch record from database Line 155  Fetch record from database
155    
156    my $hash = $marc->fetch(42);    my $hash = $marc->fetch(42);
157    
158    First record number is C<1>
159    
160  =cut  =cut
161    
162  sub fetch {  sub fetch {
163          my $self = shift;          my $self = shift;
164    
165          my $rec_nr = shift || return;          my $rec_nr = shift;
166    
167            if ( ! $rec_nr ) {
168                    $self->{last_leader} = undef;
169                    return;
170            }
171    
172          my $leader = $self->{leaders}->[$rec_nr - 1];          my $leader = $self->{leader}->[$rec_nr - 1];
173            $self->{last_leader} = $leader;
174          unless ($leader) {          unless ($leader) {
175                  carp "can't find record $rec_nr";                  carp "can't find record $rec_nr";
176                  return;                  return;
# Line 196  sub fetch { Line 230  sub fetch {
230                  my $f = substr($fields,$addr,$len);                  my $f = substr($fields,$addr,$len);
231                  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});
232    
233                  $row->{$tag} = $f;                  push @{ $row->{$tag} }, $f;
234    
235                  my $del = substr($fields,$addr+$len-1,1);                  my $del = substr($fields,$addr+$len-1,1);
236    
# Line 217  sub fetch { Line 251  sub fetch {
251          return $row;          return $row;
252  }  }
253    
254    
255    =head2 last_leader
256    
257    Returns leader of last record L<fetch>ed
258    
259      print $marc->last_leader;
260    
261    Added in version 0.08 of this module, so if you need it use:
262    
263      use MARC::Fast 0.08;
264    
265    to be sure that it's supported.
266    
267    =cut
268    
269    sub last_leader {
270            my $self = shift;
271            return $self->{last_leader};
272    }
273    
274    
275    =head2 to_hash
276    
277    Read record with specified MFN and convert it to hash
278    
279      my $hash = $marc->to_hash( $mfn, include_subfields => 1, );
280    
281    It has ability to convert characters (using C<hash_filter>) from MARC
282    database before creating structures enabling character re-mapping or quick
283    fix-up of data.
284    
285    This function returns hash which is like this:
286    
287      '200' => [
288                 {
289                   'i1' => '1',
290                   'i2' => ' '
291                   'a' => 'Goa',
292                   'f' => 'Valdo D\'Arienzo',
293                   'e' => 'tipografie e tipografi nel XVI secolo',
294                 }
295               ],
296    
297    This method will also create additional field C<000> with MFN.
298    
299    =cut
300    
301    sub to_hash {
302            my $self = shift;
303    
304            my $mfn = shift || confess "need mfn!";
305    
306            my $args = {@_};
307    
308            # init record to include MFN as field 000
309            my $rec = { '000' => [ $mfn ] };
310    
311            my $row = $self->fetch($mfn) || return;
312    
313            foreach my $rec_nr (keys %{$row}) {
314                    foreach my $l (@{$row->{$rec_nr}}) {
315    
316                            # remove end marker
317                            $l =~ s/\x1E$//;
318    
319                            # filter output
320                            $l = $self->{'hash_filter'}->($l, $rec_nr) if ($self->{'hash_filter'});
321    
322                            my $val;
323    
324                            # has identifiers?
325                            ($val->{'i1'},$val->{'i2'}) = ($1,$2) if ($l =~ s/^([01 #])([01 #])\x1F/\x1F/);
326    
327                            my $sf_usage;
328                            my @subfields;
329    
330                            # has subfields?
331                            if ($l =~ m/\x1F/) {
332                                    foreach my $t (split(/\x1F/,$l)) {
333                                            next if (! $t);
334                                            my $f = substr($t,0,1);
335    
336                                            push @subfields, ( $f, $sf_usage->{$f}++ || 0 );
337    
338                                            # repeatable subfiled -- convert it to array
339                                            if ($val->{$f}) {
340                                                    if ( ref($val->{$f}) ne 'ARRAY' ) {
341                                                            $val->{$f} = [ $val->{$f}, $val ];
342                                                    } else {
343                                                            push @{$val->{$f}}, $val;
344                                                    }
345                                            }
346                                            $val->{substr($t,0,1)} = substr($t,1);
347                                    }
348                                    $val->{subfields} = [ @subfields ] if $args->{include_subfields};
349                            } else {
350                                    $val = $l;
351                            }
352    
353                            push @{$rec->{$rec_nr}}, $val;
354                    }
355            }
356    
357            return $rec;
358    }
359    
360    =head2 to_ascii
361    
362      print $marc->to_ascii( 42 );
363    
364    =cut
365    
366    sub to_ascii {
367            my $self = shift;
368    
369            my $mfn = shift || confess "need mfn";
370            my $row = $self->fetch($mfn) || return;
371    
372            my $out;
373    
374            foreach my $f (sort keys %{$row}) {
375                    my $dump = join('', @{ $row->{$f} });
376                    $dump =~ s/\x1e$//;
377                    $dump =~ s/\x1f/\$/g;
378                    $out .= "$f\t$dump\n";
379            }
380    
381            return $out;
382    }
383    
384  1;  1;
385  __END__  __END__
386    
387  =head1 BUGS  =head1 UTF-8 ENCODING
388    
389    This module does nothing with encoding. But, since MARC format is byte
390    oriented even when using UTF-8 which has variable number of bytes for each
391    character, file is opened in binary mode.
392    
393    As a result, all scalars recturned to perl don't have utf-8 flag. Solution is
394    to use C<hash_filter> and L<Encode> to decode utf-8 encoding like this:
395    
396  =head1 SUPPORT    use Encode;
397    
398      my $marc = new MARC::Fast(
399            marcdb => 'utf8.marc',
400            hash_filter => sub {
401                    Encode::decode( 'utf-8', $_[0] );
402            },
403      );
404    
405    This will affect C<to_hash>, but C<fetch> will still return binary representation
406    since it doesn't support C<hash_filter>.
407    
408  =head1 AUTHOR  =head1 AUTHOR
409    
# Line 246  LICENSE file included with this module. Line 423  LICENSE file included with this module.
423    
424  =head1 SEE ALSO  =head1 SEE ALSO
425    
426  perl(1).  L<Biblio::Isis>, perl(1).
427    
428  =cut  =cut

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

  ViewVC Help
Powered by ViewVC 1.1.26