/[Biblio-Isis]/trunk/lib/Biblio/Isis.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/Biblio/Isis.pm

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

revision 39 by dpavlin, Thu Jan 27 22:01:17 2005 UTC revision 59 by dpavlin, Sun Jul 9 12:22:09 2006 UTC
# Line 4  use strict; Line 4  use strict;
4  use Carp;  use Carp;
5  use File::Glob qw(:globally :nocase);  use File::Glob qw(:globally :nocase);
6    
 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.12;          $VERSION     = 0.21;
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 90  Open ISIS database Line 88  Open ISIS database
88                  $v =~ s#foo#bar#g;                  $v =~ s#foo#bar#g;
89          },          },
90          debug => 1,          debug => 1,
91            join_subfields_with => ' ; ',
92   );   );
93    
94  Options are described below:  Options are described below:
# Line 119  Filter code ref which will be used befor Line 118  Filter code ref which will be used befor
118    
119  =item debug  =item debug
120    
121  Dump a B<lot> of debugging output.  Dump a B<lot> of debugging output even at level 1. For even more increase level.
122    
123    =item join_subfields_with
124    
125    Define delimiter which will be used to join repeatable subfields. This
126    option is included to support lagacy application written against version
127    older than 0.21 of this module. By default, it disabled. See L</to_hash>.
128    
129  =back  =back
130    
# Line 153  sub new { Line 158  sub new {
158                  }                  }
159          }          }
160    
161          print STDERR "## using files: ",join(" ",@isis_files),"\n" if ($self->{debug});          if ($self->{debug}) {
162                    print STDERR "## using files: ",join(" ",@isis_files),"\n";
163                    eval "use Data::Dump";
164    
165                    if (! $@) {
166                            *Dumper = *Data::Dump::dump;
167                    } else {
168                            use Data::Dumper;
169                    }
170            }
171    
172          # if you want to read .FDT file use read_fdt argument when creating class!          # if you want to read .FDT file use read_fdt argument when creating class!
173          if ($self->{read_fdt} && -e $self->{fdt_file}) {          if ($self->{read_fdt} && -e $self->{fdt_file}) {
# Line 202  sub new { Line 216  sub new {
216          read($self->{'fileMST'}, $buff, 4) || croak "can't read NXTMFN from MST: $!";          read($self->{'fileMST'}, $buff, 4) || croak "can't read NXTMFN from MST: $!";
217          $self->{'NXTMFN'}=unpack("V",$buff) || croak "NXTNFN is zero";          $self->{'NXTMFN'}=unpack("V",$buff) || croak "NXTNFN is zero";
218    
219          print STDERR Dumper($self),"\n" if ($self->{debug});          print STDERR "## self ",Dumper($self),"\n" if ($self->{debug});
220    
221          # open files for later          # open files for later
222          open($self->{'fileXRF'}, $self->{xrf_file}) || croak "can't open '$self->{xrf_file}': $!";          open($self->{'fileXRF'}, $self->{xrf_file}) || croak "can't open '$self->{xrf_file}': $!";
# Line 264  sub fetch { Line 278  sub fetch {
278    
279          # read XRFMFB abd XRFMFP          # read XRFMFB abd XRFMFP
280          read($self->{'fileXRF'}, $buff, 4);          read($self->{'fileXRF'}, $buff, 4);
281          my $pointer=unpack("V",$buff) || croak "pointer is null";          my $pointer=unpack("V",$buff);
282            if (! $pointer) {
283                    if ($self->{include_deleted}) {
284                            return;
285                    } else {
286                            warn "pointer for MFN $mfn is null\n";
287                            return;
288                    }
289            }
290    
291          # check for logically deleted record          # check for logically deleted record
292          if ($pointer & 0x80000000) {          if ($pointer & 0x80000000) {
# Line 370  sub fetch { Line 392  sub fetch {
392          return $self->{'record'};          return $self->{'record'};
393  }  }
394    
395    =head2 mfn
396    
397    Returns current MFN position
398    
399      my $mfn = $isis->mfn;
400    
401    =cut
402    
403    # This function should be simple return $self->{current_mfn},
404    # but if new is called with _hack_mfn it becomes setter.
405    # It's useful in tests when setting $isis->{record} directly
406    
407    sub mfn {
408            my $self = shift;
409            return $self->{current_mfn};
410    };
411    
412    
413  =head2 to_ascii  =head2 to_ascii
414    
415  Returns ASCII output of record with specified MFN  Returns ASCII output of record with specified MFN
# Line 393  sub to_ascii { Line 433  sub to_ascii {
433    
434          my $mfn = shift || croak "need MFN";          my $mfn = shift || croak "need MFN";
435    
436          my $rec = $self->fetch($mfn);          my $rec = $self->fetch($mfn) || return;
437    
438          my $out = "0\t$mfn";          my $out = "0\t$mfn";
439    
# Line 449  which will be used for identifiers, C<i1 Line 489  which will be used for identifiers, C<i1
489               }               }
490             ],             ],
491    
492    In case there are repeatable subfields in record, this will create
493    following structure:
494    
495      '900' => [ {
496            'a' => [ 'foo', 'bar', 'baz' ],
497      }]
498    
499    Or in more complex example of
500    
501      902   ^aa1^aa2^aa3^bb1^aa4^bb2^cc1^aa5
502    
503    it will create
504    
505      902   => [
506            { a => ["a1", "a2", "a3", "a4", "a5"], b => ["b1", "b2"], c => "c1" },
507      ],
508    
509    This behaviour can be changed using C<join_subfields_with> option to L</new>,
510    in which case C<to_hash> will always create single value for each subfield.
511    This will change result to:
512    
513    
514    
515  This method will also create additional field C<000> with MFN.  This method will also create additional field C<000> with MFN.
516    
517    There is also more elaborative way to call C<to_hash> like this:
518    
519      my $hash = $isis->to_hash({
520            mfn => 42,
521            include_subfields => 1,
522      });
523    
524    Each option controll creation of hash:
525    
526    =over 4
527    
528    =item mfn
529    
530    Specify MFN number of record
531    
532    =item include_subfields
533    
534    This option will create additional key in hash called C<subfields> which will
535    have original record subfield order and index to that subfield like this:
536    
537      902   => [ {
538            a => ["a1", "a2", "a3", "a4", "a5"],
539            b => ["b1", "b2"],
540            c => "c1",
541            subfields => ["a", 0, "a", 1, "a", 2, "b", 0, "a", 3, "b", 1, "c", 0, "a", 4],
542      } ],
543    
544    =item join_subfields_with
545    
546    Define delimiter which will be used to join repeatable subfields. You can
547    specify option here instead in L</new> if you want to have per-record control.
548    
549    =back
550    
551  =cut  =cut
552    
553  sub to_hash {  sub to_hash {
554          my $self = shift;          my $self = shift;
555    
556    
557          my $mfn = shift || confess "need mfn!";          my $mfn = shift || confess "need mfn!";
558            my $arg;
559    
560            if (ref($mfn) eq 'HASH') {
561                    $arg = $mfn;
562                    $mfn = $arg->{mfn} || confess "need mfn in arguments";
563            }
564    
565          # init record to include MFN as field 000          # init record to include MFN as field 000
566          my $rec = { '000' => [ $mfn ] };          my $rec = { '000' => [ $mfn ] };
567    
568          my $row = $self->fetch($mfn);          my $row = $self->fetch($mfn) || return;
569    
570            my $j_rs = $arg->{join_subfields_with};
571            $j_rs = $self->{join_subfields_with} unless(defined($j_rs));
572            my $i_sf = $arg->{include_subfields};
573    
574          foreach my $k (keys %{$row}) {          foreach my $f_nr (keys %{$row}) {
575                  foreach my $l (@{$row->{$k}}) {                  foreach my $l (@{$row->{$f_nr}}) {
576    
577                          # filter output                          # filter output
578                          $l = $self->{'hash_filter'}->($l) if ($self->{'hash_filter'});                          if ($self->{'hash_filter'}) {
579                                    $l = $self->{'hash_filter'}->($l);
580                                    next unless defined($l);
581                            }
582    
583                          my $val;                          my $val;
584                            my $r_sf;       # repeatable subfields in this record
585    
586                          # has identifiers?                          # has identifiers?
587                          ($val->{'i1'},$val->{'i2'}) = ($1,$2) if ($l =~ s/^([01 #])([01 #])\^/\^/);                          ($val->{'i1'},$val->{'i2'}) = ($1,$2) if ($l =~ s/^([01 #])([01 #])\^/\^/);
# Line 478  sub to_hash { Line 590  sub to_hash {
590                          if ($l =~ m/\^/) {                          if ($l =~ m/\^/) {
591                                  foreach my $t (split(/\^/,$l)) {                                  foreach my $t (split(/\^/,$l)) {
592                                          next if (! $t);                                          next if (! $t);
593                                          $val->{substr($t,0,1)} = substr($t,1);                                          my ($sf,$v) = (substr($t,0,1), substr($t,1));
594                                            # XXX this might be option, but why?
595                                            next unless ($v);
596    #                                       warn "### $f_nr^$sf:$v",$/ if ($self->{debug} > 1);
597    
598                                            if (ref( $val->{$sf} ) eq 'ARRAY') {
599    
600                                                    push @{ $val->{$sf} }, $v;
601    
602                                                    # record repeatable subfield it it's offset
603                                                    push @{ $val->{subfields} }, ( $sf, $#{ $val->{$sf} } ) if (! $j_rs && $i_sf);
604                                                    $r_sf->{$sf}++;
605    
606                                            } elsif (defined( $val->{$sf} )) {
607    
608                                                    # convert scalar field to array
609                                                    $val->{$sf} = [ $val->{$sf}, $v ];
610    
611                                                    push @{ $val->{subfields} }, ( $sf, 1 ) if (! $j_rs && $i_sf);
612                                                    $r_sf->{$sf}++;
613    
614                                            } else {
615                                                    $val->{$sf} = $v;
616                                                    push @{ $val->{subfields} }, ( $sf, 0 ) if ($i_sf);
617                                            }
618                                  }                                  }
619                          } else {                          } else {
620                                  $val = $l;                                  $val = $l;
621                          }                          }
622    
623                          push @{$rec->{$k}}, $val;                          if ($j_rs) {
624                                    map {
625                                            $val->{$_} = join($j_rs, @{ $val->{$_} });
626                                    } keys %$r_sf
627                            }
628    
629                            push @{$rec->{$f_nr}}, $val;
630                  }                  }
631          }          }
632    
# Line 597  module with databases from programs othe Line 739  module with databases from programs othe
739  tested this against ouput of one C<isis.dll>-based application, but I don't  tested this against ouput of one C<isis.dll>-based application, but I don't
740  know any details about it's version.  know any details about it's version.
741    
742    =head1 VERSIONS
743    
744    As this is young module, new features are added in subsequent version. It's
745    a good idea to specify version when using this module like this:
746    
747      use Biblio::Isis 0.21
748    
749    Below is list of changes in specific version of module (so you can target
750    older versions if you really have to):
751    
752    =over 8
753    
754    =item 0.21
755    
756    Added C<join_subfields_with> to L</new> and L</to_hash>.
757    
758    Added C<include_subfields> to L</to_hash>.
759    
760    =item 0.20
761    
762    Added C<< $isis->mfn >>, support for repeatable subfields and
763    C<< $isis->to_hash({ mfn => 42, ... }) >> calling convention
764    
765    =back
766    
767  =head1 AUTHOR  =head1 AUTHOR
768    
769          Dobrica Pavlinusic          Dobrica Pavlinusic
# Line 618  LICENSE file included with this module. Line 785  LICENSE file included with this module.
785    
786  =head1 SEE ALSO  =head1 SEE ALSO
787    
788    L<Biblio::Isis::Manual> for CDS/ISIS manual appendix F, G and H which describe file format
789    
790  OpenIsis web site L<http://www.openisis.org>  OpenIsis web site L<http://www.openisis.org>
791    
792  perl4lib site L<http://perl4lib.perl.org>  perl4lib site L<http://perl4lib.perl.org>
Legend:
Removed from v.39  
changed lines
  Added in v.59
  ViewVC Help
Powered by ViewVC 1.1.26