package IsisDB;
use strict;

use Carp;
use Data::Dumper;

BEGIN {
	use Exporter ();
	use vars qw ($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
	$VERSION     = 0.04;
	@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

IsisDB - Read CDS/ISIS database

=head1 SYNOPSIS

  use IsisDB;

  my $isis = new IsisDB(
  	isisdb => './cds/cds',
  );

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

=head1 DESCRIPTION

This module will read CDS/ISIS databases and create hash values out of it.
It can be used as perl-only alternative to OpenIsis module.

This will module will always be slower that 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.

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).

=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 CDS/ISIS database

 my $isis = new IsisDB(
 	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

Prefix path to CDS/ISIS. It should contain full or relative path to database
and common prefix of C<.FDT>, C<.MST>, C<.CNT>, C<.XRF> and C<.MST> 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.

=back

It will also set C<$isis-E<gt>{'maxmfn'}> which is maximum MFN stored in database.

=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};
	}

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

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

		open(fileFDT, $self->{isisdb}.".FDT") || croak "can't read '$self->{isisdb}.FDT': $!";

		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(fileMST,$self->{isisdb}.".MST") || croak "can't read '$self->{isisdb}.MST': $!";

	# 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(fileMST,4,0);

	my $buff;

	read(fileMST, $buff, 4);
	$self->{'NXTMFN'}=unpack("l",$buff) || carp "NXTNFN is zero";

	# save maximum MFN
	$self->{'maxmfn'} = $self->{'NXTMFN'} - 1;

	close(fileMST);

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

	# There is two 26 Bytes fixed lenght records

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

	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("ssssssllls", $buff);

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

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

	read(fileCNT, $buff, 26);
	$self->unpack_cnt($buff);

	read(fileCNT, $buff, 26);
	$self->unpack_cnt($buff);


	close(fileCNT);

	print Dumper($self) if ($self->{debug});

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

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

	$self ? return $self : return undef;
}

=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 C<^asometing^bsomething else>)

=cut

sub fetch {
	my $self = shift;

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

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

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

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

	my $buff;

	# read XRFMFB abd XRFMFP
	read($self->{'fileXRF'}, $buff, 4);
	my $pointer=unpack("l",$buff) || carp "pointer is null";

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

	print "XRFMFB: $XRFMFB XRFMFP: $XRFMFP\n" if ($self->{debug});

	# XXX fix this to be more readable!!
	# e.g. (XRFMFB - 1) * 512 + XRFMFP

	my $offset = $pointer;
	my $offset2=int($offset/2048)-1;
	my $offset22=int($offset/4096);
	my $offset3=$offset-($offset22*4096);
	if ($offset3>512) {
		$offset3=$offset3-2048;
	}
	my $offset4=($offset2*512)+$offset3;

	print "$offset - $offset2 - $offset3 - $offset4\n" if ($self->{debug});

	# Get Record Information

	seek($self->{'fileMST'},$offset4,0);

	read($self->{'fileMST'}, $buff, 4);
	my $value=unpack("l",$buff);

	if ($value!=$mfn) {
print ("Error: The MFN:".$mfn." is not found in MST(".$value.")");    
		return -1;	# XXX deleted record?
	}

#	$MFRL=$self->Read16($fileMST);
#	$MFBWB=$self->Read32($fileMST);
#	$MFBWP=$self->Read16($fileMST);
#	$BASE=$self->Read16($fileMST);
#	$NVF=$self->Read16($fileMST);
#	$STATUS=$self->Read16($fileMST);

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

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

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

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

	if (! $self->{'include_deleted'} && $MFRL < 0) {
		print "## logically deleted record $mfn, skipping...\n" if ($self->{debug});
		return;
	}

	# Get Directory Format

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

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

	my $fld_len = 0;

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

#		$TAG=$self->Read16($fileMST);
#		$POS=$self->Read16($fileMST);
#		$LEN=$self->Read16($fileMST);

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

		print "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;

		$fld_len += $LEN;
	}

	# Get Variable Fields

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

	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]);
	}
	close(fileMST);

	print Dumper($self) if ($self->{debug});

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

=head2 to_ascii

Dump ascii output of selected MFN

  print $isis->to_ascii(55);

=cut

sub to_ascii {
	my $self = shift;

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

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

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

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

	$out .= "\n";

	return $out;
}

=head2 to_hash

Read 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 remapping or quick
fixup 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 has to produce any output from ISIS data.

=cut

sub to_hash {
	my $self = shift;

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

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

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

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

			# has subfields?
			my $val;
			if ($l =~ m/\^/) {
				foreach my $t (split(/\^/,$l)) {
					next if (! $t);
					$val->{substr($t,0,1)} = substr($t,1);
				}
			} else {
				$val = $l;
			}

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

	return $rec;
}

#
# XXX porting from php left-over:
#
# do I *REALLY* need those methods, or should I use
# $self->{something} directly?
#
# Probably direct usage is better!
#

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

sub NextMFN {
	my $self = shift;
	return $self->{NXTMFN};
}

1;

=head1 BUGS

This module has been very lightly tested. Use with caution and report bugs.

=head1 AUTHOR

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

This module is based heavily on code from LIBISIS.PHP - Library to read ISIS files V0.1.1
written in php and (c) 2000 Franck Martin - <franck@sopac.org> 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

L<http://www.openisis.org|OpenIsis>, perl(1).

