lib/Biblio/Isis.pm

package Biblio::Isis;
use strict;

use Carp;
use File::Glob qw(:globally :nocase);

BEGIN {
        use Exporter ();
        use vars qw ($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
        $VERSION     = 0.20;
        @ISA         = qw (Exporter);
        #Give a hoot don't pollute, do not export more than needed by default
        @EXPORT      = qw ();
        @EXPORT_OK   = qw ();
        %EXPORT_TAGS = ();

}

=head1 NAME

Biblio::Isis - Read CDS/ISIS, WinISIS and IsisMarc database

=head1 SYNOPSIS

  use Biblio::Isis;

  my $isis = new Biblio::Isis(
        isisdb => './cds/cds',
  );

  for(my $mfn = 1; $mfn <= $isis->count; $mfn++) {
        print $isis->to_ascii($mfn),"\n";
  }

=head1 DESCRIPTION

This module will read ISIS databases created by DOS CDS/ISIS, WinIsis or
IsisMarc. It can be used as perl-only alternative to OpenIsis module which
seems to depriciate it's old C<XS> bindings for perl.

It can create hash values from data in ISIS database (using C<to_hash>),
ASCII dump (using C<to_ascii>) or just hash with field names and packed
values (like C<^asomething^belse>).

Unique feature of this module is ability to C<include_deleted> records.
It will also skip zero sized fields (OpenIsis has a bug in XS bindings, so
fields which are zero sized will be filled with random junk from memory).

It also has support for identifiers (only if ISIS database is created by
IsisMarc), see C<to_hash>.

This module will always be slower than OpenIsis module which use C
library. However, since it's written in perl, it's platform independent (so
you don't need C compiler), and can be easily modified. I hope that it
creates data structures which are easier to use than ones created by
OpenIsis, so reduced time in other parts of the code should compensate for
slower performance of this module (speed of reading ISIS database is
rarely an issue).

=head1 METHODS

=cut

#  my $ORDN;            # Nodes Order
#  my $ORDF;            # Leafs Order
#  my $N;               # Number of Memory buffers for nodes
#  my $K;               # Number of buffers for first level index
#  my $LIV;             # Current number of Index Levels
#  my $POSRX;           # Pointer to Root Record in N0x
#  my $NMAXPOS;         # Next Available position in N0x
#  my $FMAXPOS;         # Next available position in L0x
#  my $ABNORMAL;        # Formal BTree normality indicator

#
# some binary reads
#

=head2 new

Open ISIS database

 my $isis = new Biblio::Isis(
        isisdb => './cds/cds',
        read_fdt => 1,
        include_deleted => 1,
        hash_filter => sub {
                my $v = shift;
                $v =~ s#foo#bar#g;
        },
        debug => 1,
 );

Options are described below:

=over 5

=item isisdb

This is full or relative path to ISIS database files which include
common prefix of C<.MST>, and C<.XRF> and optionally C<.FDT> (if using
C<read_fdt> option) files.

In this example it uses C<./cds/cds.MST> and related files.

=item read_fdt

Boolean flag to specify if field definition table should be read. It's off
by default.

=item include_deleted

Don't skip logically deleted records in ISIS.

=item hash_filter

Filter code ref which will be used before data is converted to hash.

=item debug

Dump a B<lot> of debugging output even at level 1. For even more increase level.

=back

=cut

sub new {
        my $class = shift;
        my $self = {};
        bless($self, $class);

        croak "new needs database name (isisdb) as argument!" unless ({@_}->{isisdb});

        foreach my $v (qw{isisdb debug include_deleted hash_filter}) {
                $self->{$v} = {@_}->{$v};
        }

        my @isis_files = grep(/\.(FDT|MST|XRF|CNT)$/i,glob($self->{isisdb}."*"));

        foreach my $f (@isis_files) {
                my $ext = $1 if ($f =~ m/\.(\w\w\w)$/);
                $self->{lc($ext)."_file"} = $f;
        }

        my @must_exist = qw(mst xrf);
        push @must_exist, "fdt" if ($self->{read_fdt});

        foreach my $ext (@must_exist) {
                unless ($self->{$ext."_file"}) {
                        carp "missing ",uc($ext)," file in ",$self->{isisdb};
                        return;
                }
        }

        if ($self->{debug}) {
                print STDERR "## using files: ",join(" ",@isis_files),"\n";
                eval "use Data::Dump";

                if (! $@) {
                        *Dumper = *Data::Dump::dump;
                } else {
                        use Data::Dumper;
                }
        }

        # if you want to read .FDT file use read_fdt argument when creating class!
        if ($self->{read_fdt} && -e $self->{fdt_file}) {

                # read the $db.FDT file for tags
                my $fieldzone=0;

                open(my $fileFDT, $self->{fdt_file}) || croak "can't read '$self->{fdt_file}': $!";
                binmode($fileFDT);

                while (<$fileFDT>) {
                        chomp;
                        if ($fieldzone) {
                                my $name=substr($_,0,30);
                                my $tag=substr($_,50,3);

                                $name =~ s/\s+$//;
                                $tag =~ s/\s+$//;

                                $self->{'TagName'}->{$tag}=$name;  
                        }

                        if (/^\*\*\*/) {
                                $fieldzone=1;
                        }
                }
                
                close($fileFDT);
        }

        # Get the Maximum MFN from $db.MST

        open($self->{'fileMST'}, $self->{mst_file}) || croak "can't open '$self->{mst_file}': $!";
        binmode($self->{'fileMST'});

        # MST format:   (* = 32 bit signed)
        # CTLMFN*       always 0
        # NXTMFN*       MFN to be assigned to the next record created
        # NXTMFB*       last block allocated to master file
        # NXTMFP        offset to next available position in last block
        # MFTYPE        always 0 for user db file (1 for system)
        seek($self->{'fileMST'},4,0) || croak "can't seek to offset 0 in MST: $!";

        my $buff;

        read($self->{'fileMST'}, $buff, 4) || croak "can't read NXTMFN from MST: $!";
        $self->{'NXTMFN'}=unpack("V",$buff) || croak "NXTNFN is zero";

        print STDERR "## self ",Dumper($self),"\n" if ($self->{debug});

        # open files for later
        open($self->{'fileXRF'}, $self->{xrf_file}) || croak "can't open '$self->{xrf_file}': $!";
        binmode($self->{'fileXRF'});

        $self ? return $self : return undef;
}

=head2 count

Return number of records in database

  print $isis->count;

=cut

sub count {
        my $self = shift;
        return $self->{'NXTMFN'} - 1;
}

=head2 fetch

Read record with selected MFN

  my $rec = $isis->fetch(55);

Returns hash with keys which are field names and values are unpacked values
for that field like this:

  $rec = {
    '210' => [ '^aNew York^cNew York University press^dcop. 1988' ],
    '990' => [ '2140', '88', 'HAY' ],
  };

=cut

sub fetch {
        my $self = shift;

        my $mfn = shift || croak "fetch needs MFN as argument!";

        # is mfn allready in memory?
        my $old_mfn = $self->{'current_mfn'} || -1;
        return $self->{record} if ($mfn == $old_mfn);

        print STDERR "## fetch: $mfn\n" if ($self->{debug});

        # XXX check this?
        my $mfnpos=($mfn+int(($mfn-1)/127))*4;

        print STDERR "## seeking to $mfnpos in file '$self->{xrf_file}'\n" if ($self->{debug});
        seek($self->{'fileXRF'},$mfnpos,0);

        my $buff;

        # delete old record
        delete $self->{record};

        # read XRFMFB abd XRFMFP
        read($self->{'fileXRF'}, $buff, 4);
        my $pointer=unpack("V",$buff);
        if (! $pointer) {
                if ($self->{include_deleted}) {
                        return;
                } else {
                        warn "pointer for MFN $mfn is null\n";
                        return;
                }
        }

        # check for logically deleted record
        if ($pointer & 0x80000000) {
                print STDERR "## record $mfn is logically deleted\n" if ($self->{debug});
                $self->{deleted} = $mfn;

                return unless $self->{include_deleted};

                # abs
                $pointer = ($pointer ^ 0xffffffff) + 1;
        }

        my $XRFMFB = int($pointer/2048);
        my $XRFMFP = $pointer - ($XRFMFB*2048);

        # (XRFMFB - 1) * 512 + XRFMFP
        # why do i have to do XRFMFP % 1024 ?

        my $blk_off = (($XRFMFB - 1) * 512) + ($XRFMFP % 512);

        print STDERR "## pointer: $pointer XRFMFB: $XRFMFB XRFMFP: $XRFMFP offset: $blk_off\n" if ($self->{'debug'});

        # Get Record Information

        seek($self->{'fileMST'},$blk_off,0) || croak "can't seek to $blk_off: $!";

        read($self->{'fileMST'}, $buff, 4) || croak "can't read 4 bytes at offset $blk_off from MST file: $!";
        my $value=unpack("V",$buff);

        print STDERR "## offset for rowid $value is $blk_off (blk $XRFMFB off $XRFMFP)\n" if ($self->{debug});

        if ($value!=$mfn) {
                if ($value == 0) {
                        print STDERR "## record $mfn is physically deleted\n" if ($self->{debug});
                        $self->{deleted} = $mfn;
                        return;
                }

                carp "Error: MFN ".$mfn." not found in MST file, found $value";    
                return;
        }

        read($self->{'fileMST'}, $buff, 14);

        my ($MFRL,$MFBWB,$MFBWP,$BASE,$NVF,$STATUS) = unpack("vVvvvv", $buff);

        print STDERR "## MFRL: $MFRL MFBWB: $MFBWB MFBWP: $MFBWP BASE: $BASE NVF: $NVF STATUS: $STATUS\n" if ($self->{debug});

        warn "MFRL $MFRL is not even number" unless ($MFRL % 2 == 0);

        warn "BASE is not 18+6*NVF" unless ($BASE == 18 + 6 * $NVF);

        # Get Directory Format

        my @FieldPOS;
        my @FieldLEN;
        my @FieldTAG;

        read($self->{'fileMST'}, $buff, 6 * $NVF);

        my $rec_len = 0;

        for (my $i = 0 ; $i < $NVF ; $i++) {

                my ($TAG,$POS,$LEN) = unpack("vvv", substr($buff,$i * 6, 6));

                print STDERR "## TAG: $TAG POS: $POS LEN: $LEN\n" if ($self->{debug});

                # The TAG does not exists in .FDT so we set it to 0.
                #
                # XXX This is removed from perl version; .FDT file is updated manually, so
                # you will often have fields in .MST file which aren't in .FDT. On the other
                # hand, IsisMarc doesn't use .FDT files at all!

                #if (! $self->{TagName}->{$TAG}) {
                #       $TAG=0;
                #}

                push @FieldTAG,$TAG;
                push @FieldPOS,$POS;
                push @FieldLEN,$LEN;

                $rec_len += $LEN;
        }

        # Get Variable Fields

        read($self->{'fileMST'},$buff,$rec_len);

        print STDERR "## rec_len: $rec_len poc: ",tell($self->{'fileMST'})."\n" if ($self->{debug});

        for (my $i = 0 ; $i < $NVF ; $i++) {
                # skip zero-sized fields
                next if ($FieldLEN[$i] == 0);

                push @{$self->{record}->{$FieldTAG[$i]}}, substr($buff,$FieldPOS[$i],$FieldLEN[$i]);
        }

        $self->{'current_mfn'} = $mfn;

        print STDERR Dumper($self),"\n" if ($self->{debug});

        return $self->{'record'};
}

=head2 mfn

Returns current MFN position

  my $mfn = $isis->mfn;

=cut

# This function should be simple return $self->{current_mfn},
# but if new is called with _hack_mfn it becomes setter.
# It's useful in tests when setting $isis->{record} directly

sub mfn {
        my $self = shift;
        return $self->{current_mfn};
};


=head2 to_ascii

Returns ASCII output of record with specified MFN

  print $isis->to_ascii(42);

This outputs something like this:

  210   ^aNew York^cNew York University press^dcop. 1988
  990   2140
  990   88
  990   HAY

If C<read_fdt> is specified when calling C<new> it will display field names
from C<.FDT> file instead of numeric tags.

=cut

sub to_ascii {
        my $self = shift;

        my $mfn = shift || croak "need MFN";

        my $rec = $self->fetch($mfn) || return;

        my $out = "0\t$mfn";

        foreach my $f (sort keys %{$rec}) {
                my $fn = $self->tag_name($f);
                $out .= "\n$fn\t".join("\n$fn\t",@{$self->{record}->{$f}});
        }

        $out .= "\n";

        return $out;
}

=head2 to_hash

Read record with specified MFN and convert it to hash

  my $hash = $isis->to_hash($mfn);

It has ability to convert characters (using C<hash_filter>) from ISIS
database before creating structures enabling character re-mapping or quick
fix-up of data.

This function returns hash which is like this:

  $hash = {
    '210' => [
               {
                 'c' => 'New York University press',
                 'a' => 'New York',
                 'd' => 'cop. 1988'
               }
             ],
    '990' => [
               '2140',
               '88',
               'HAY'
             ],
  };

You can later use that hash to produce any output from ISIS data.

If database is created using IsisMarc, it will also have to special fields
which will be used for identifiers, C<i1> and C<i2> like this:

  '200' => [
             {
               'i1' => '1',
               'i2' => ' '
               'a' => 'Goa',
               'f' => 'Valdo D\'Arienzo',
               'e' => 'tipografie e tipografi nel XVI secolo',
             }
           ],

In case there are repeatable subfields in record, this will create
following structure:

  '900' => [ {
        'a' => [ 'foo', 'bar', 'baz' ],
  }]

This method will also create additional field C<000> with MFN.

=cut

sub to_hash {
        my $self = shift;

        my $mfn = shift || confess "need mfn!";

        # init record to include MFN as field 000
        my $rec = { '000' => [ $mfn ] };

        my $row = $self->fetch($mfn) || return;

        foreach my $k (keys %{$row}) {
                foreach my $l (@{$row->{$k}}) {

                        # filter output
                        if ($self->{'hash_filter'}) {
                                $l = $self->{'hash_filter'}->($l);
                                next unless defined($l);
                        }

                        my $val;

                        # has identifiers?
                        ($val->{'i1'},$val->{'i2'}) = ($1,$2) if ($l =~ s/^([01 #])([01 #])\^/\^/);

                        # has subfields?
                        if ($l =~ m/\^/) {
                                foreach my $t (split(/\^/,$l)) {
                                        next if (! $t);
                                        my ($sf,$v) = (substr($t,0,1), substr($t,1));
                                        # FIXME make this option !
                                        next unless ($v);
#                                       warn "### $k^$sf:$v",$/ if ($self->{debug} > 1);

                                        # FIXME array return optional, by default unroll to ' ; '
                                        if (ref( $val->{$sf} ) eq 'ARRAY') {

                                                push @{ $val->{$sf} }, $v;
                                        } elsif (defined( $val->{$sf} )) {
                                                # convert scalar field to array
                                                $val->{$sf} = [ $val->{$sf}, $v ];
                                        } else {
                                                $val->{$sf} = $v;
                                        }
                                }
                        } else {
                                $val = $l;
                        }

                        push @{$rec->{$k}}, $val;
                }
        }

        return $rec;
}

=head2 tag_name

Return name of selected tag

 print $isis->tag_name('200');

=cut

sub tag_name {
        my $self = shift;
        my $tag = shift || return;
        return $self->{'TagName'}->{$tag} || $tag;
}


=head2 read_cnt

Read content of C<.CNT> file and return hash containing it.

  print Dumper($isis->read_cnt);

This function is not used by module (C<.CNT> files are not required for this
module to work), but it can be useful to examine your index (while debugging
for example).

=cut

sub read_cnt  {
        my $self = shift;

        croak "missing CNT file in ",$self->{isisdb} unless ($self->{cnt_file});

        # Get the index information from $db.CNT
   
        open(my $fileCNT, $self->{cnt_file}) || croak "can't read '$self->{cnt_file}': $!";
        binmode($fileCNT);

        my $buff;

        read($fileCNT, $buff, 26) || croak "can't read first table from CNT: $!";
        $self->unpack_cnt($buff);

        read($fileCNT, $buff, 26) || croak "can't read second table from CNT: $!";
        $self->unpack_cnt($buff);

        close($fileCNT);

        return $self->{cnt};
}

=head2 unpack_cnt

Unpack one of two 26 bytes fixed length record in C<.CNT> file.

Here is definition of record:

 off key        description                             size
  0: IDTYPE     BTree type                              s
  2: ORDN       Nodes Order                             s
  4: ORDF       Leafs Order                             s
  6: N          Number of Memory buffers for nodes      s
  8: K          Number of buffers for first level index s
 10: LIV        Current number of Index Levels          s
 12: POSRX      Pointer to Root Record in N0x           l
 16: NMAXPOS    Next Available position in N0x          l
 20: FMAXPOS    Next available position in L0x          l
 24: ABNORMAL   Formal BTree normality indicator        s
 length: 26 bytes

This will fill C<$self> object under C<cnt> with hash. It's used by C<read_cnt>.

=cut

sub unpack_cnt {
        my $self = shift;

        my @flds = qw(ORDN ORDF N K LIV POSRX NMAXPOS FMAXPOS ABNORMAL);

        my $buff = shift || return;
        my @arr = unpack("vvvvvvVVVv", $buff);

        print STDERR "unpack_cnt: ",join(" ",@arr),"\n" if ($self->{'debug'});

        my $IDTYPE = shift @arr;
        foreach (@flds) {
                $self->{cnt}->{$IDTYPE}->{$_} = abs(shift @arr);
        }
}

1;

=head1 BUGS

Some parts of CDS/ISIS documentation are not detailed enough to exmplain
some variations in input databases which has been tested with this module.
When I was in doubt, I assumed that OpenIsis's implementation was right
(except for obvious bugs).

However, every effort has been made to test this module with as much
databases (and programs that create them) as possible.

I would be very greatful for success or failure reports about usage of this
module with databases from programs other than WinIsis and IsisMarc. I had
tested this against ouput of one C<isis.dll>-based application, but I don't
know any details about it's version.

=head1 VERSIONS

You can find version dependencies documented here

=over 8 

=item 0.20

Added C<< $isis->mfn >> and support for repeatable subfields

=back

=head1 AUTHOR

        Dobrica Pavlinusic
        CPAN ID: DPAVLIN
        dpavlin@rot13.org
        http://www.rot13.org/~dpavlin/

This module is based heavily on code from C<LIBISIS.PHP> library to read ISIS files V0.1.1
written in php and (c) 2000 Franck Martin <franck@sopac.org> and released under LGPL.

=head1 COPYRIGHT

This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.

The full text of the license can be found in the
LICENSE file included with this module.


=head1 SEE ALSO

OpenIsis web site L<http://www.openisis.org>

perl4lib site L<http://perl4lib.perl.org>

1	dpavlin	36	package Biblio::Isis;
2	dpavlin	1	use strict;
3
4			use Carp;
5	dpavlin	18	use File::Glob qw(:globally :nocase);
6
7	dpavlin	1	BEGIN {
8			use Exporter ();
9			use vars qw ($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
10	dpavlin	50	$VERSION = 0.20;
11	dpavlin	1	@ISA = qw (Exporter);
12			#Give a hoot don't pollute, do not export more than needed by default
13			@EXPORT = qw ();
14			@EXPORT_OK = qw ();
15			%EXPORT_TAGS = ();
16
17			}
18
19			=head1 NAME
20
21	dpavlin	36	Biblio::Isis - Read CDS/ISIS, WinISIS and IsisMarc database
22	dpavlin	1
23			=head1 SYNOPSIS
24
25	dpavlin	36	use Biblio::Isis;
26	dpavlin	11
27	dpavlin	36	my $isis = new Biblio::Isis(
28	dpavlin	1	isisdb => './cds/cds',
29			);
30
31	dpavlin	32	for(my $mfn = 1; $mfn <= $isis->count; $mfn++) {
32	dpavlin	11	print $isis->to_ascii($mfn),"\n";
33			}
34
35	dpavlin	1	=head1 DESCRIPTION
36
37	dpavlin	15	This module will read ISIS databases created by DOS CDS/ISIS, WinIsis or
38	dpavlin	27	IsisMarc. It can be used as perl-only alternative to OpenIsis module which
39			seems to depriciate it's old C<XS> bindings for perl.
40	dpavlin	1
41	dpavlin	15	It can create hash values from data in ISIS database (using C<to_hash>),
42			ASCII dump (using C<to_ascii>) or just hash with field names and packed
43			values (like C<^asomething^belse>).
44	dpavlin	11
45			Unique feature of this module is ability to C<include_deleted> records.
46			It will also skip zero sized fields (OpenIsis has a bug in XS bindings, so
47			fields which are zero sized will be filled with random junk from memory).
48
49	dpavlin	15	It also has support for identifiers (only if ISIS database is created by
50			IsisMarc), see C<to_hash>.
51
52	dpavlin	27	This module will always be slower than OpenIsis module which use C
53	dpavlin	15	library. However, since it's written in perl, it's platform independent (so
54			you don't need C compiler), and can be easily modified. I hope that it
55			creates data structures which are easier to use than ones created by
56			OpenIsis, so reduced time in other parts of the code should compensate for
57			slower performance of this module (speed of reading ISIS database is
58			rarely an issue).
59
60	dpavlin	1	=head1 METHODS
61
62			=cut
63
64			# my $ORDN; # Nodes Order
65			# my $ORDF; # Leafs Order
66			# my $N; # Number of Memory buffers for nodes
67			# my $K; # Number of buffers for first level index
68			# my $LIV; # Current number of Index Levels
69			# my $POSRX; # Pointer to Root Record in N0x
70			# my $NMAXPOS; # Next Available position in N0x
71			# my $FMAXPOS; # Next available position in L0x
72			# my $ABNORMAL; # Formal BTree normality indicator
73
74			#
75			# some binary reads
76			#
77
78			=head2 new
79
80	dpavlin	15	Open ISIS database
81	dpavlin	1
82	dpavlin	36	my $isis = new Biblio::Isis(
83	dpavlin	1	isisdb => './cds/cds',
84			read_fdt => 1,
85	dpavlin	12	include_deleted => 1,
86			hash_filter => sub {
87			my $v = shift;
88			$v =~ s#foo#bar#g;
89			},
90	dpavlin	1	debug => 1,
91			);
92
93	dpavlin	2	Options are described below:
94
95			=over 5
96
97	dpavlin	1	=item isisdb
98
99	dpavlin	15	This is full or relative path to ISIS database files which include
100	dpavlin	18	common prefix of C<.MST>, and C<.XRF> and optionally C<.FDT> (if using
101			C<read_fdt> option) files.
102	dpavlin	1
103	dpavlin	15	In this example it uses C<./cds/cds.MST> and related files.
104
105	dpavlin	1	=item read_fdt
106
107			Boolean flag to specify if field definition table should be read. It's off
108			by default.
109
110	dpavlin	9	=item include_deleted
111
112	dpavlin	11	Don't skip logically deleted records in ISIS.
113	dpavlin	9
114	dpavlin	12	=item hash_filter
115
116			Filter code ref which will be used before data is converted to hash.
117
118			=item debug
119
120	dpavlin	54	Dump a B<lot> of debugging output even at level 1. For even more increase level.
121	dpavlin	12
122	dpavlin	2	=back
123
124	dpavlin	1	=cut
125
126			sub new {
127			my $class = shift;
128			my $self = {};
129			bless($self, $class);
130
131	dpavlin	9	croak "new needs database name (isisdb) as argument!" unless ({@_}->{isisdb});
132	dpavlin	1
133	dpavlin	12	foreach my $v (qw{isisdb debug include_deleted hash_filter}) {
134	dpavlin	9	$self->{$v} = {@_}->{$v};
135			}
136	dpavlin	1
137	dpavlin	18	my @isis_files = grep(/\.(FDT\|MST\|XRF\|CNT)$/i,glob($self->{isisdb}."*"));
138
139			foreach my $f (@isis_files) {
140			my $ext = $1 if ($f =~ m/\.(\w\w\w)$/);
141			$self->{lc($ext)."_file"} = $f;
142			}
143
144			my @must_exist = qw(mst xrf);
145			push @must_exist, "fdt" if ($self->{read_fdt});
146
147			foreach my $ext (@must_exist) {
148	dpavlin	39	unless ($self->{$ext."_file"}) {
149			carp "missing ",uc($ext)," file in ",$self->{isisdb};
150			return;
151			}
152	dpavlin	18	}
153
154	dpavlin	45	if ($self->{debug}) {
155			print STDERR "## using files: ",join(" ",@isis_files),"\n";
156			eval "use Data::Dump";
157	dpavlin	18
158	dpavlin	45	if (! $@) {
159			Dumper = Data::Dump::dump;
160			} else {
161			use Data::Dumper;
162			}
163			}
164
165	dpavlin	1	# if you want to read .FDT file use read_fdt argument when creating class!
166	dpavlin	18	if ($self->{read_fdt} && -e $self->{fdt_file}) {
167	dpavlin	1
168			# read the $db.FDT file for tags
169			my $fieldzone=0;
170
171	dpavlin	33	open(my $fileFDT, $self->{fdt_file}) \|\| croak "can't read '$self->{fdt_file}': $!";
172			binmode($fileFDT);
173	dpavlin	1
174	dpavlin	33	while (<$fileFDT>) {
175	dpavlin	1	chomp;
176			if ($fieldzone) {
177			my $name=substr($_,0,30);
178			my $tag=substr($_,50,3);
179
180			$name =~ s/\s+$//;
181			$tag =~ s/\s+$//;
182
183			$self->{'TagName'}->{$tag}=$name;
184			}
185
186			if (/^\\\*/) {
187			$fieldzone=1;
188			}
189			}
190
191	dpavlin	33	close($fileFDT);
192	dpavlin	1	}
193
194			# Get the Maximum MFN from $db.MST
195
196	dpavlin	18	open($self->{'fileMST'}, $self->{mst_file}) \|\| croak "can't open '$self->{mst_file}': $!";
197	dpavlin	33	binmode($self->{'fileMST'});
198	dpavlin	1
199			# MST format: (* = 32 bit signed)
200			# CTLMFN* always 0
201			# NXTMFN* MFN to be assigned to the next record created
202			# NXTMFB* last block allocated to master file
203			# NXTMFP offset to next available position in last block
204			# MFTYPE always 0 for user db file (1 for system)
205	dpavlin	34	seek($self->{'fileMST'},4,0) \|\| croak "can't seek to offset 0 in MST: $!";
206	dpavlin	1
207	dpavlin	11	my $buff;
208
209	dpavlin	34	read($self->{'fileMST'}, $buff, 4) \|\| croak "can't read NXTMFN from MST: $!";
210			$self->{'NXTMFN'}=unpack("V",$buff) \|\| croak "NXTNFN is zero";
211	dpavlin	11
212	dpavlin	45	print STDERR "## self ",Dumper($self),"\n" if ($self->{debug});
213	dpavlin	18
214			# open files for later
215			open($self->{'fileXRF'}, $self->{xrf_file}) \|\| croak "can't open '$self->{xrf_file}': $!";
216	dpavlin	33	binmode($self->{'fileXRF'});
217	dpavlin	18
218			$self ? return $self : return undef;
219			}
220
221	dpavlin	32	=head2 count
222
223			Return number of records in database
224
225			print $isis->count;
226
227			=cut
228
229			sub count {
230			my $self = shift;
231			return $self->{'NXTMFN'} - 1;
232			}
233
234	dpavlin	7	=head2 fetch
235	dpavlin	1
236	dpavlin	2	Read record with selected MFN
237	dpavlin	1
238	dpavlin	7	my $rec = $isis->fetch(55);
239	dpavlin	2
240			Returns hash with keys which are field names and values are unpacked values
241	dpavlin	15	for that field like this:
242	dpavlin	2
243	dpavlin	15	$rec = {
244			'210' => [ '^aNew York^cNew York University press^dcop. 1988' ],
245			'990' => [ '2140', '88', 'HAY' ],
246			};
247
248	dpavlin	2	=cut
249
250	dpavlin	7	sub fetch {
251	dpavlin	1	my $self = shift;
252
253	dpavlin	7	my $mfn = shift \|\| croak "fetch needs MFN as argument!";
254	dpavlin	1
255	dpavlin	16	# is mfn allready in memory?
256			my $old_mfn = $self->{'current_mfn'} \|\| -1;
257	dpavlin	25	return $self->{record} if ($mfn == $old_mfn);
258	dpavlin	1
259	dpavlin	16	print STDERR "## fetch: $mfn\n" if ($self->{debug});
260
261	dpavlin	1	# XXX check this?
262			my $mfnpos=($mfn+int(($mfn-1)/127))*4;
263
264	dpavlin	18	print STDERR "## seeking to $mfnpos in file '$self->{xrf_file}'\n" if ($self->{debug});
265	dpavlin	7	seek($self->{'fileXRF'},$mfnpos,0);
266	dpavlin	1
267	dpavlin	11	my $buff;
268
269	dpavlin	25	# delete old record
270			delete $self->{record};
271
272	dpavlin	1	# read XRFMFB abd XRFMFP
273	dpavlin	11	read($self->{'fileXRF'}, $buff, 4);
274	dpavlin	41	my $pointer=unpack("V",$buff);
275			if (! $pointer) {
276			if ($self->{include_deleted}) {
277			return;
278			} else {
279			warn "pointer for MFN $mfn is null\n";
280			return;
281			}
282			}
283	dpavlin	1
284	dpavlin	25	# check for logically deleted record
285	dpavlin	33	if ($pointer & 0x80000000) {
286	dpavlin	25	print STDERR "## record $mfn is logically deleted\n" if ($self->{debug});
287			$self->{deleted} = $mfn;
288
289			return unless $self->{include_deleted};
290
291	dpavlin	33	# abs
292			$pointer = ($pointer ^ 0xffffffff) + 1;
293	dpavlin	25	}
294
295	dpavlin	1	my $XRFMFB = int($pointer/2048);
296			my $XRFMFP = $pointer - ($XRFMFB*2048);
297
298	dpavlin	16	# (XRFMFB - 1) * 512 + XRFMFP
299			# why do i have to do XRFMFP % 1024 ?
300	dpavlin	1
301	dpavlin	26	my $blk_off = (($XRFMFB - 1) * 512) + ($XRFMFP % 512);
302	dpavlin	1
303	dpavlin	16	print STDERR "## pointer: $pointer XRFMFB: $XRFMFB XRFMFP: $XRFMFP offset: $blk_off\n" if ($self->{'debug'});
304	dpavlin	1
305			# Get Record Information
306
307	dpavlin	33	seek($self->{'fileMST'},$blk_off,0) \|\| croak "can't seek to $blk_off: $!";
308	dpavlin	1
309	dpavlin	33	read($self->{'fileMST'}, $buff, 4) \|\| croak "can't read 4 bytes at offset $blk_off from MST file: $!";
310			my $value=unpack("V",$buff);
311	dpavlin	1
312	dpavlin	16	print STDERR "## offset for rowid $value is $blk_off (blk $XRFMFB off $XRFMFP)\n" if ($self->{debug});
313
314	dpavlin	1	if ($value!=$mfn) {
315	dpavlin	26	if ($value == 0) {
316			print STDERR "## record $mfn is physically deleted\n" if ($self->{debug});
317			$self->{deleted} = $mfn;
318			return;
319			}
320
321			carp "Error: MFN ".$mfn." not found in MST file, found $value";
322			return;
323	dpavlin	1	}
324
325	dpavlin	7	read($self->{'fileMST'}, $buff, 14);
326	dpavlin	1
327	dpavlin	33	my ($MFRL,$MFBWB,$MFBWP,$BASE,$NVF,$STATUS) = unpack("vVvvvv", $buff);
328	dpavlin	1
329	dpavlin	16	print STDERR "## MFRL: $MFRL MFBWB: $MFBWB MFBWP: $MFBWP BASE: $BASE NVF: $NVF STATUS: $STATUS\n" if ($self->{debug});
330	dpavlin	1
331	dpavlin	25	warn "MFRL $MFRL is not even number" unless ($MFRL % 2 == 0);
332	dpavlin	9
333	dpavlin	16	warn "BASE is not 18+6NVF" unless ($BASE == 18 + 6 $NVF);
334
335	dpavlin	1	# Get Directory Format
336
337			my @FieldPOS;
338			my @FieldLEN;
339			my @FieldTAG;
340
341	dpavlin	8	read($self->{'fileMST'}, $buff, 6 * $NVF);
342
343	dpavlin	16	my $rec_len = 0;
344	dpavlin	8
345	dpavlin	1	for (my $i = 0 ; $i < $NVF ; $i++) {
346
347	dpavlin	33	my ($TAG,$POS,$LEN) = unpack("vvv", substr($buff,$i * 6, 6));
348	dpavlin	1
349	dpavlin	16	print STDERR "## TAG: $TAG POS: $POS LEN: $LEN\n" if ($self->{debug});
350	dpavlin	1
351			# The TAG does not exists in .FDT so we set it to 0.
352			#
353			# XXX This is removed from perl version; .FDT file is updated manually, so
354			# you will often have fields in .MST file which aren't in .FDT. On the other
355			# hand, IsisMarc doesn't use .FDT files at all!
356
357			#if (! $self->{TagName}->{$TAG}) {
358			# $TAG=0;
359			#}
360
361			push @FieldTAG,$TAG;
362			push @FieldPOS,$POS;
363			push @FieldLEN,$LEN;
364	dpavlin	8
365	dpavlin	16	$rec_len += $LEN;
366	dpavlin	1	}
367
368			# Get Variable Fields
369
370	dpavlin	16	read($self->{'fileMST'},$buff,$rec_len);
371	dpavlin	8
372	dpavlin	16	print STDERR "## rec_len: $rec_len poc: ",tell($self->{'fileMST'})."\n" if ($self->{debug});
373
374	dpavlin	1	for (my $i = 0 ; $i < $NVF ; $i++) {
375	dpavlin	10	# skip zero-sized fields
376			next if ($FieldLEN[$i] == 0);
377
378	dpavlin	8	push @{$self->{record}->{$FieldTAG[$i]}}, substr($buff,$FieldPOS[$i],$FieldLEN[$i]);
379	dpavlin	1	}
380
381	dpavlin	16	$self->{'current_mfn'} = $mfn;
382
383	dpavlin	25	print STDERR Dumper($self),"\n" if ($self->{debug});
384	dpavlin	1
385	dpavlin	2	return $self->{'record'};
386	dpavlin	1	}
387
388	dpavlin	54	=head2 mfn
389
390			Returns current MFN position
391
392			my $mfn = $isis->mfn;
393
394			=cut
395
396			# This function should be simple return $self->{current_mfn},
397			# but if new is called with _hack_mfn it becomes setter.
398			# It's useful in tests when setting $isis->{record} directly
399
400			sub mfn {
401			my $self = shift;
402			return $self->{current_mfn};
403			};
404
405
406	dpavlin	2	=head2 to_ascii
407
408	dpavlin	27	Returns ASCII output of record with specified MFN
409	dpavlin	2
410	dpavlin	15	print $isis->to_ascii(42);
411	dpavlin	2
412	dpavlin	27	This outputs something like this:
413	dpavlin	15
414			210 ^aNew York^cNew York University press^dcop. 1988
415			990 2140
416			990 88
417			990 HAY
418
419			If C<read_fdt> is specified when calling C<new> it will display field names
420			from C<.FDT> file instead of numeric tags.
421
422	dpavlin	2	=cut
423
424			sub to_ascii {
425			my $self = shift;
426
427			my $mfn = shift \|\| croak "need MFN";
428
429	dpavlin	41	my $rec = $self->fetch($mfn) \|\| return;
430	dpavlin	2
431			my $out = "0\t$mfn";
432
433			foreach my $f (sort keys %{$rec}) {
434	dpavlin	15	my $fn = $self->tag_name($f);
435			$out .= "\n$fn\t".join("\n$fn\t",@{$self->{record}->{$f}});
436	dpavlin	2	}
437
438			$out .= "\n";
439
440			return $out;
441			}
442
443	dpavlin	12	=head2 to_hash
444
445	dpavlin	15	Read record with specified MFN and convert it to hash
446	dpavlin	12
447			my $hash = $isis->to_hash($mfn);
448
449	dpavlin	27	It has ability to convert characters (using C<hash_filter>) from ISIS
450	dpavlin	15	database before creating structures enabling character re-mapping or quick
451			fix-up of data.
452	dpavlin	12
453			This function returns hash which is like this:
454
455			$hash = {
456			'210' => [
457			{
458			'c' => 'New York University press',
459			'a' => 'New York',
460			'd' => 'cop. 1988'
461			}
462			],
463			'990' => [
464			'2140',
465			'88',
466			'HAY'
467			],
468			};
469
470	dpavlin	15	You can later use that hash to produce any output from ISIS data.
471	dpavlin	12
472	dpavlin	15	If database is created using IsisMarc, it will also have to special fields
473			which will be used for identifiers, C<i1> and C<i2> like this:
474
475			'200' => [
476			{
477			'i1' => '1',
478			'i2' => ' '
479			'a' => 'Goa',
480			'f' => 'Valdo D\'Arienzo',
481			'e' => 'tipografie e tipografi nel XVI secolo',
482			}
483			],
484
485	dpavlin	50	In case there are repeatable subfields in record, this will create
486			following structure:
487
488			'900' => [ {
489			'a' => [ 'foo', 'bar', 'baz' ],
490			}]
491
492	dpavlin	15	This method will also create additional field C<000> with MFN.
493
494	dpavlin	12	=cut
495
496			sub to_hash {
497			my $self = shift;
498
499			my $mfn = shift \|\| confess "need mfn!";
500
501	dpavlin	15	# init record to include MFN as field 000
502	dpavlin	16	my $rec = { '000' => [ $mfn ] };
503	dpavlin	15
504	dpavlin	41	my $row = $self->fetch($mfn) \|\| return;
505	dpavlin	12
506			foreach my $k (keys %{$row}) {
507			foreach my $l (@{$row->{$k}}) {
508
509			# filter output
510	dpavlin	44	if ($self->{'hash_filter'}) {
511			$l = $self->{'hash_filter'}->($l);
512			next unless defined($l);
513			}
514	dpavlin	12
515	dpavlin	15	my $val;
516
517			# has identifiers?
518	dpavlin	23	($val->{'i1'},$val->{'i2'}) = ($1,$2) if ($l =~ s/^([01 #])([01 #])\^/\^/);
519	dpavlin	15
520	dpavlin	12	# has subfields?
521			if ($l =~ m/\^/) {
522			foreach my $t (split(/\^/,$l)) {
523			next if (! $t);
524	dpavlin	50	my ($sf,$v) = (substr($t,0,1), substr($t,1));
525	dpavlin	54	# FIXME make this option !
526			next unless ($v);
527			# warn "### $k^$sf:$v",$/ if ($self->{debug} > 1);
528
529			# FIXME array return optional, by default unroll to ' ; '
530	dpavlin	50	if (ref( $val->{$sf} ) eq 'ARRAY') {
531	dpavlin	54
532	dpavlin	50	push @{ $val->{$sf} }, $v;
533			} elsif (defined( $val->{$sf} )) {
534			# convert scalar field to array
535			$val->{$sf} = [ $val->{$sf}, $v ];
536			} else {
537			$val->{$sf} = $v;
538			}
539	dpavlin	12	}
540			} else {
541			$val = $l;
542			}
543
544			push @{$rec->{$k}}, $val;
545			}
546			}
547
548			return $rec;
549			}
550
551	dpavlin	15	=head2 tag_name
552	dpavlin	1
553	dpavlin	15	Return name of selected tag
554	dpavlin	1
555	dpavlin	15	print $isis->tag_name('200');
556
557			=cut
558
559			sub tag_name {
560	dpavlin	1	my $self = shift;
561	dpavlin	15	my $tag = shift \|\| return;
562			return $self->{'TagName'}->{$tag} \|\| $tag;
563	dpavlin	1	}
564
565	dpavlin	35
566			=head2 read_cnt
567
568			Read content of C<.CNT> file and return hash containing it.
569
570			print Dumper($isis->read_cnt);
571
572			This function is not used by module (C<.CNT> files are not required for this
573			module to work), but it can be useful to examine your index (while debugging
574			for example).
575
576			=cut
577
578			sub read_cnt {
579			my $self = shift;
580
581			croak "missing CNT file in ",$self->{isisdb} unless ($self->{cnt_file});
582
583			# Get the index information from $db.CNT
584
585			open(my $fileCNT, $self->{cnt_file}) \|\| croak "can't read '$self->{cnt_file}': $!";
586			binmode($fileCNT);
587
588			my $buff;
589
590			read($fileCNT, $buff, 26) \|\| croak "can't read first table from CNT: $!";
591			$self->unpack_cnt($buff);
592
593			read($fileCNT, $buff, 26) \|\| croak "can't read second table from CNT: $!";
594			$self->unpack_cnt($buff);
595
596			close($fileCNT);
597
598			return $self->{cnt};
599			}
600
601			=head2 unpack_cnt
602
603			Unpack one of two 26 bytes fixed length record in C<.CNT> file.
604
605			Here is definition of record:
606
607			off key description size
608			0: IDTYPE BTree type s
609			2: ORDN Nodes Order s
610			4: ORDF Leafs Order s
611			6: N Number of Memory buffers for nodes s
612			8: K Number of buffers for first level index s
613			10: LIV Current number of Index Levels s
614			12: POSRX Pointer to Root Record in N0x l
615			16: NMAXPOS Next Available position in N0x l
616			20: FMAXPOS Next available position in L0x l
617			24: ABNORMAL Formal BTree normality indicator s
618			length: 26 bytes
619
620			This will fill C<$self> object under C<cnt> with hash. It's used by C<read_cnt>.
621
622			=cut
623
624			sub unpack_cnt {
625			my $self = shift;
626
627			my @flds = qw(ORDN ORDF N K LIV POSRX NMAXPOS FMAXPOS ABNORMAL);
628
629			my $buff = shift \|\| return;
630			my @arr = unpack("vvvvvvVVVv", $buff);
631
632			print STDERR "unpack_cnt: ",join(" ",@arr),"\n" if ($self->{'debug'});
633
634			my $IDTYPE = shift @arr;
635			foreach (@flds) {
636			$self->{cnt}->{$IDTYPE}->{$_} = abs(shift @arr);
637			}
638			}
639
640	dpavlin	1	1;
641
642			=head1 BUGS
643
644	dpavlin	27	Some parts of CDS/ISIS documentation are not detailed enough to exmplain
645			some variations in input databases which has been tested with this module.
646			When I was in doubt, I assumed that OpenIsis's implementation was right
647			(except for obvious bugs).
648	dpavlin	1
649	dpavlin	27	However, every effort has been made to test this module with as much
650			databases (and programs that create them) as possible.
651
652			I would be very greatful for success or failure reports about usage of this
653			module with databases from programs other than WinIsis and IsisMarc. I had
654			tested this against ouput of one C<isis.dll>-based application, but I don't
655			know any details about it's version.
656
657	dpavlin	54	=head1 VERSIONS
658
659			You can find version dependencies documented here
660
661			=over 8
662
663			=item 0.20
664
665			Added C<< $isis->mfn >> and support for repeatable subfields
666
667			=back
668
669	dpavlin	1	=head1 AUTHOR
670
671			Dobrica Pavlinusic
672			CPAN ID: DPAVLIN
673			dpavlin@rot13.org
674			http://www.rot13.org/~dpavlin/
675
676	dpavlin	15	This module is based heavily on code from C<LIBISIS.PHP> library to read ISIS files V0.1.1
677			written in php and (c) 2000 Franck Martin <franck@sopac.org> and released under LGPL.
678	dpavlin	1
679			=head1 COPYRIGHT
680
681			This program is free software; you can redistribute
682			it and/or modify it under the same terms as Perl itself.
683
684			The full text of the license can be found in the
685			LICENSE file included with this module.
686
687
688			=head1 SEE ALSO
689
690	dpavlin	15	OpenIsis web site L<http://www.openisis.org>
691	dpavlin	1
692	dpavlin	15	perl4lib site L<http://perl4lib.perl.org>
693