/[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 24 by dpavlin, Tue Nov 6 20:06:07 2007 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::Dumper;
# Line 7  use Data::Dumper; Line 7  use Data::Dumper;
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                    if ($o > 24) {
128                            seek($self->{fh},$o-24,1) if ($o);
129                    } else {
130                            last;
131                    }
132    
133          }          }
134    
# Line 129  Fetch record from database Line 154  Fetch record from database
154    
155    my $hash = $marc->fetch(42);    my $hash = $marc->fetch(42);
156    
157    First record number is C<1>
158    
159  =cut  =cut
160    
161  sub fetch {  sub fetch {
162          my $self = shift;          my $self = shift;
163    
164          my $rec_nr = shift || return;          my $rec_nr = shift;
165    
166            if ( ! $rec_nr ) {
167                    $self->{last_leader} = undef;
168                    return;
169            }
170    
171          my $leader = $self->{leaders}->[$rec_nr - 1];          my $leader = $self->{leader}->[$rec_nr - 1];
172            $self->{last_leader} = $leader;
173          unless ($leader) {          unless ($leader) {
174                  carp "can't find record $rec_nr";                  carp "can't find record $rec_nr";
175                  return;                  return;
# Line 196  sub fetch { Line 229  sub fetch {
229                  my $f = substr($fields,$addr,$len);                  my $f = substr($fields,$addr,$len);
230                  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});
231    
232                  $row->{$tag} = $f;                  push @{ $row->{$tag} }, $f;
233    
234                  my $del = substr($fields,$addr+$len-1,1);                  my $del = substr($fields,$addr+$len-1,1);
235    
# Line 217  sub fetch { Line 250  sub fetch {
250          return $row;          return $row;
251  }  }
252    
 1;  
 __END__  
253    
254  =head1 BUGS  =head2 last_leader
255    
256    Returns leader of last record L<fetch>ed
257    
258      print $marc->last_leader;
259    
260    Added in version 0.08 of this module, so if you need it use:
261    
262      use MARC::Fast 0.08;
263    
264    to be sure that it's supported.
265    
266    =cut
267    
268    sub last_leader {
269            my $self = shift;
270            return $self->{last_leader};
271    }
272    
273    
274    =head2 to_hash
275    
276    Read record with specified MFN and convert it to hash
277    
278      my $hash = $marc->to_hash( $mfn, include_subfields => 1, );
279    
280    It has ability to convert characters (using C<hash_filter>) from MARC
281    database before creating structures enabling character re-mapping or quick
282    fix-up of data.
283    
284    This function returns hash which is like this:
285    
286      '200' => [
287                 {
288                   'i1' => '1',
289                   'i2' => ' '
290                   'a' => 'Goa',
291                   'f' => 'Valdo D\'Arienzo',
292                   'e' => 'tipografie e tipografi nel XVI secolo',
293                 }
294               ],
295    
296    This method will also create additional field C<000> with MFN.
297    
298    =cut
299    
300    sub to_hash {
301            my $self = shift;
302    
303            my $mfn = shift || confess "need mfn!";
304    
305            my $args = {@_};
306    
307            # init record to include MFN as field 000
308            my $rec = { '000' => [ $mfn ] };
309    
310            my $row = $self->fetch($mfn) || return;
311    
312            foreach my $rec_nr (keys %{$row}) {
313                    foreach my $l (@{$row->{$rec_nr}}) {
314    
315                            # remove end marker
316                            $l =~ s/\x1E$//;
317    
318  =head1 SUPPORT                          # filter output
319                            $l = $self->{'hash_filter'}->($l, $rec_nr) if ($self->{'hash_filter'});
320    
321                            my $val;
322    
323                            # has identifiers?
324                            ($val->{'i1'},$val->{'i2'}) = ($1,$2) if ($l =~ s/^([01 #])([01 #])\x1F/\x1F/);
325    
326                            my $sf_usage;
327                            my @subfields;
328    
329                            # has subfields?
330                            if ($l =~ m/\x1F/) {
331                                    foreach my $t (split(/\x1F/,$l)) {
332                                            next if (! $t);
333                                            my $f = substr($t,0,1);
334    
335                                            push @subfields, ( $f, $sf_usage->{$f}++ || 0 );
336    
337                                            # repeatable subfiled -- convert it to array
338                                            if ($val->{$f}) {
339                                                    if ( ref($val->{$f}) ne 'ARRAY' ) {
340                                                            $val->{$f} = [ $val->{$f}, $val ];
341                                                    } else {
342                                                            push @{$val->{$f}}, $val;
343                                                    }
344                                            }
345                                            $val->{substr($t,0,1)} = substr($t,1);
346                                    }
347                                    $val->{subfields} = [ @subfields ] if $args->{include_subfields};
348                            } else {
349                                    $val = $l;
350                            }
351    
352                            push @{$rec->{$rec_nr}}, $val;
353                    }
354            }
355    
356            return $rec;
357    }
358    
359    =head2 to_ascii
360    
361      print $marc->to_ascii( 42 );
362    
363    =cut
364    
365    sub to_ascii {
366            my $self = shift;
367    
368            my $mfn = shift || confess "need mfn";
369            my $row = $self->fetch($mfn) || return;
370    
371            my $out;
372    
373            foreach my $f (sort keys %{$row}) {
374                    my $dump = join('', @{ $row->{$f} });
375                    $dump =~ s/\x1e$//;
376                    $dump =~ s/\x1f/\$/g;
377                    $out .= "$f\t$dump\n";
378            }
379    
380            return $out;
381    }
382    
383    1;
384    __END__
385    
386  =head1 AUTHOR  =head1 AUTHOR
387    
# Line 246  LICENSE file included with this module. Line 401  LICENSE file included with this module.
401    
402  =head1 SEE ALSO  =head1 SEE ALSO
403    
404  perl(1).  L<Biblio::Isis>, perl(1).
405    
406  =cut  =cut

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

  ViewVC Help
Powered by ViewVC 1.1.26