File Coverage

blib/lib/BTRIEVE/SAVE.pm

Criterion	Covered	Total	%
statement	252	337	74.7
branch	46	96	47.9
condition	9	25	36.0
subroutine	21	28	75.0
pod	12	12	100.0
total	340	498	68.2

package BTRIEVE::SAVE;

use Carp;
use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $DEBUG $TEST
	    );
$VERSION = '0.35';
$DEBUG = 0;

require Exporter;
require 5.004;

@ISA = qw(Exporter);
@EXPORT= qw();
@EXPORT_OK= qw();


# Preloaded methods go here.

####################################################################

# This is the constructor method that creates the BTRIEVE object.
# It will attempt to set up info from the config file.

####################################################################
sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $config_file= shift ;
    my $file = shift ||undef;

    my $save_btr = {opt=>{}, array=>[]};
    $save_btr->{'opt'}{'config'}=$config_file;

    bless $save_btr, $class;
    if (-e $config_file) {
	$save_btr->config($config_file);
    } else {
	return $save_btr;
    }
    if (!$file) {return $save_btr};
    $save_btr->{'opt'}{'file'}=$file;


    $save_btr->_initbtrieve();
    return $save_btr;
}

###################################################################
# _initbtrieve() sets up config and filehandle
###################################################################
sub _initbtrieve {
    my $save_btr = shift;
    my $config_file = $save_btr->{'opt'}{'config'};
    $save_btr->{'opt'}{'increment'} = -1;

    my $file = $save_btr->{'opt'}{'file'};
    if (not(-e $file)) {carp "File \"$file\" doesn't exist"; return}
    open (*file, $file);
    binmode *file;
    $save_btr->{'opt'}{'handle'}=\*file; #store filehandle in object
}

###################################################################
# config() looks for a config file which tells us where the
# offsets are in the fixed part of the record, their types and
# what to call them locally.
###################################################################

sub config {
    my $save_btr = shift;
    my $proto_rec = BTRIEVE::SAVE::REC->newconfig($save_btr->{'opt'}{'config'});
    $save_btr->{'opt'}{'proto_rec'} = $proto_rec;
}

###################################################################
# parse_file() reads from a BTRIEVE SAVE file. Can do so
# incrementally.
###################################################################
sub parse_file {
    my $save_btr = shift;
    my $increment = $save_btr->{'opt'}{'increment'}; #pick out increment from the object
    my $recordcount = 0;

    while ($increment==-1 or $recordcount<$increment) {
	my $curr_rec = $save_btr->next_rec;
	last unless $curr_rec;
	push @{$save_btr->{'array'}},$curr_rec;
	$recordcount++;
    } #end reading this record
    return $recordcount;
}

####################################################################

# Returns a new BTRIEVE::SAVE::REC based on the next bits.
# Returns undef if we have reached the end.

####################################################################
sub next_rec {
    my $save_btr=shift;
    my ($rec,$eor) = $save_btr->next_recbits;
    return undef if $eor eq "\cZ";
    return undef unless defined($rec);
    my $proto_rec = $save_btr->{'opt'}{'proto_rec'};
    my $curr_rec = $proto_rec->copy_struct();

    $curr_rec->parse_string($rec);
    return $curr_rec;
}

####################################################################

# Reads thru the handle looking for the bits forming the $rec
# and for the bits that should be $eor (end-of-record).
# Returns ($rec,$eor). $eor is undef if the read is at EOF.
# $eor is undef if we are at the DOS EOF ("\cZ") at the
# appropriate defined place.

####################################################################
sub next_recbits {
    my $save_btr = shift;
    my $handle = $save_btr->{'opt'}{'handle'};
    #need to use read to get the right bytes. Bummer.
    my $pos= tell($handle);
    my $info="";
    my $rc= read($handle,$info,14); #assumes that no record is more than 10 gigabytes
    return (undef,undef) unless $rc; #EOF...
    return (undef,"\cZ") if $info=~/^\cZ/;
    my ($length)= $info=~/^(\d+)[, ]/; #definition of btrieve save file format.
#error check here to see if $length is defined.
    seek($handle,$pos,0); #go back to where we were.
    my $rec="";
    $rc= read($handle,$rec,$length +length($length)+1); #definition of btrieve save file format.
    $rec = substr($rec,length($length)+1); #kills the \d+[, ], keeps the rest.
    my $eor="";
    $rc = read($handle,$eor,2); #skip over \r\n, or find \cZ
    return ($rec,$eor);
}
####################################################################
# openbtr() reads in a BTRIEVE SAVE file. It takes a hashref
# with key 'file' (name of the btrieve file). Increment
# defines how many records to read in and is taken from the object.
####################################################################
sub openbtr {
    my $save_btr=shift;
    my $params=shift;
    my $file=$params->{'file'};
    if (not(-e $file)) {carp "File \"$file\" doesn't exist"; return}
    my $totalrecord;
    $save_btr->{'opt'}{'increment'}
         ||= $params->{'increment'}
         ||= 1;
    #store increment in the object, default is 1
    open (*file, $file);
    binmode *file;
    $save_btr->{'opt'}{'handle'}=\*file; #store filehandle in object

    print "read in $totalrecord records\n" if $DEBUG;
    if ($totalrecord==0) {$totalrecord="0 but true"}
    return $totalrecord;
}

####################################################################
# closebtr() will close a file-handle that was opened with
# openbtr()
####################################################################
sub closebtr {
    my $marc = shift;
    $marc->{'opt'}{'increment'}=0;
    if (not($marc->{'opt'}{'handle'})) {carp "There isn't a BTRIEVE SAVE file to close"; return}
    my $ok = close $marc->{'opt'}{'handle'};
    $marc->{'opt'}{'handle'}=undef;
    return $ok;
}

####################################################################
# nextbtr() will read in more records from a file that has
# already been opened with openbtr(). the increment can be
# adjusted if necessary by passing a new value as a parameter. the
# new records will be APPENDED to the BTRIEVE object
####################################################################
sub nextbtr {
    my $save_btr=shift;
    my $increment=shift;
    my $totalrecord;
    if (not($save_btr->{'opt'}{'handle'})) {carp "There isn't a BTRIEVE SAVE file open"; return}
    if ($increment) {$save_btr->{'opt'}{'increment'}=$increment}

    $totalrecord = $save_btr->parse_file();

    return $totalrecord;
}

####################################################################
# output() actually writes the file with a string version of
# $save_btr unless no file is given, in which case it returns the string
####################################################################
sub output {
    my $save_btr=shift;
    my $output = "";
    my $outfile = shift;


    $output = $save_btr->as_string();
    if ($outfile) {
	if ($outfile !~ /^>/) {carp "Don't forget to use > or >>: $!"}
	local(*OUT);
	open (OUT, "$outfile") || carp "Couldn't open file: $!";
        binmode OUT;
	print OUT $output;
	close OUT || carp "Couldn't close file: $!";
	return 1;
    }
      #if no filename was specified return the output so it can be grabbed
    else {
	return $output;
    }
}


####################################################################

# as_string() returns a string version of $save_btr. Handles packing the
# easily updateable version of %fixed.

####################################################################
sub as_string {
    my $output = "";
    my $save_btr=shift;

    for (@{$save_btr->{'array'}}) {
	my $data = $_->data;
	my $packed_rec = $_->counted_rec($data);
	$output .=$packed_rec;
    }
    $output .="\cZ";
    return $output;
}

####################################################################

# Takes an rdb filename, save filename, error file name, and config
# file name.  Also takes the field name for unindexed fixed info and
# var info, and strings to translate to tab and newline. Writes
# an rdb file with that information; warns and writes to the error file
# if there are problems in the data.

####################################################################

sub rdb_to_save {
    my $save_btr = shift;
    my ($rdb,$save,$errs,
	$zzname,$varname,$tabtrans,$rettrans) = @_;

    local *RDB;
    local *SAVE;
    local *ERRS;

    open RDB,"$rdb"   or die "Could not open $rdb:$!\n";
    binmode RDB;
    open SAVE,">$save" or die "Could not open $save:$!\n";
    binmode SAVE;
    open ERRS,">$errs" or die "Could not open $errs:$!\n";
    binmode ERRS;

    my $fieldnames = ;
    print ERRS $fieldnames;

    chomp $fieldnames;

    my  @rdbnames = split(/\t/,$fieldnames);

    my $proto_rec = $save_btr->{opt}{proto_rec};

    my @names = @{$proto_rec->{opt}{names}};

    my %fieldlen = (); #Gonna use this for lookup.
    my @fixed_defs = @{$proto_rec->{opt}{fixed_defs}};
    for (@fixed_defs) {
	$fieldlen{ $_->{name}} = $_->{len};
    };

    my $dashline = ;
    print ERRS $dashline;


REC:
    while () {
	chomp;
	next unless /\S/;
	my @fields= split(/\t/);

	my $var;
	my $rhfixed;
	my @fieldnames = @rdbnames;
	if ($#fields != $#rdbnames) {
	    warn "Paranoia 1: Number of fields do not match rdb spec at line $..\n";
	    print ERRS $_;
	    next REC;
	}
	my $err_skip =0;
   FIELD:
	while (@fields) {
	    my $field = shift @fields;
	    $field=~s/$tabtrans/\t/;
	    $field=~s/$rettrans/\n/;
	    my $name  = shift @fieldnames;

	    if ($name eq $zzname) {
		$rhfixed->{'ZZ'} = $field;
		next FIELD;
	    }
	    if ($name eq $varname) {
		$var = $field;
		next FIELD;
	    }
	    if ($fieldlen{$name} != length($field)) {
		warn "Paranoia 2: Lengths do not match for $name at line $..\n";
		print ERRS $_;
		next REC;
	    }
	    $rhfixed->{$name}=$field;
	}

	my $curr_rec = $proto_rec->copy_struct();
	@{$curr_rec->{values}} = ($rhfixed,\"",\$var);
	my $counted_rec = $curr_rec->counted_rec_hash();
	print SAVE $counted_rec;
    }

    print SAVE "\cZ";

    close RDB or carp "Could not close $rdb:$!\n";
    close ERRS or carp "Could not close $errs:$!\n";
    close SAVE or carp "Could not close $save:$!\n";
}

####################################################################

# Takes an rdb filename, save filename, error file name, and config
# file name.  Also takes the field name for unindexed fixed info and
# var info, and strings to translate to tab and newline. Writes
# a rdb file with that information; warns and writes to the error file
# if there are problems in the data.

####################################################################
sub save_to_rdb {
    my $save_btr = shift;
    my ($rdb,$save,$errs,
	$zzname,$varname,$tabtrans,$rettrans) = @_;

    local *RDB;
    local *ERRS;

    my $btr = BTRIEVE::SAVE->new($save_btr->{opt}{config},$save);
    $btr->parse_file();
    my $proto_rec = $btr->{'opt'}{'proto_rec'};
    my @names = @{$proto_rec->{'opt'}{'names'}};
    my @rdbnames = @names;
    grep {$_ = $zzname if $_ eq 'ZZ'} @rdbnames;
    open RDB,">$rdb"  or die "Could not open $rdb for write: $!\n";
    binmode RDB;
    open ERRS,">$errs"  or die "Could not open $errs for write: $!\n";
    binmode ERRS;


    foreach my $name (@names) {
	print RDB "$name\t"; # in /rdb systems, deleting an extra column is trivial.
    }
    print RDB "$varname\n";

    for (@names) {
	my $name =$_;
	$name=~s/./-/g;
	print RDB $name."\t";
    }
    my $dashvar = $varname;
    $dashvar=~s/./-/g;
    print RDB $dashvar."\n";

REC:
    foreach my $rec (@{$btr->{array}}) {
	my $rdbline = "";
	foreach my $name (@names) {
	    my $field = $rec->{values}[0]{$name};
	    if ($field=~/$tabtrans|$rettrans/) {
		print ERRS $rec->counted_rec($rec->fixed.$rec->var);
		next REC;
	    }
	    $field =~s/\t/$tabtrans/g;
	    $field =~s/\n/$rettrans/g;
	    $rdbline .= $field."\t";
	}
	my $var = $rec->var();
	$var =~s/\t/$tabtrans/;
	$var =~s/\n/$rettrans/;
	$rdbline.= $var."\n";
	print RDB $rdbline;
    }
    close RDB or carp "Could not close $rdb:$!\n";
    print ERRS "\cZ";
    close ERRS or carp "Could not close $errs:$!\n";;
}

####################################################################

# BTRIEVE::SAVE::REC is responsible for internal representation of btrieve
# records. It knows enough to parse the %fixed information from
# a string and can generate string representations of data and
# counted string.

####################################################################

package BTRIEVE::SAVE::REC;

use vars qw( %TYPEMAP %TYPE_SCALE $VERSION);
%TYPEMAP =    (Zstring => 'a', Integer => 'V', RAW => 'a');
%TYPE_SCALE = (Zstring => 1,  Integer => 0.25, RAW => 1  ); # Btrieve standard has byte counts.

$VERSION = '0.35';
####################################################################

# This roughly specifies what real recs know: a template to pack and
# unpack strings and a list of names for %fixed keys. The arrayref
# stores [$rhfixed,$rfixed,$rrest] information.

####################################################################
sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my ($ranames,$rtemplate,$packed_length,$rhfixed_defs) = @_;
    my $save_rec = {opt=>{names =>$ranames,template=>$rtemplate,
		      len=>$packed_length,fixed_defs=>$rhfixed_defs },
		values=>[]};
    return bless $save_rec,$class;
}

sub newconfig {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $handle = shift;
    local $/="\n";
    local(*F);
    open F,$handle or die "Could not open $handle:$!\n";
    binmode *F;
    my $fixed_length = 0;

    my $langname_preamble;
    my $lang_len;
    my $rhfixed_defs = [];
    while () {
	if (/langname/i) {
	    ($langname_preamble) =/^(.*)langname/i ;
	    $lang_len = length($langname_preamble) ;
	}
	($fixed_length) = /(\d+)/ if /Record Length/;
	if (/^\s+\d+/) {
	    my ($len,$type) = /^\s+\d+\s+\d+\s+\d+\s+(\d+)\s+(\S+)/o;
	    die "Type $type not understood" unless $TYPEMAP{$type};
	    my ($langname)  = /^.{$lang_len}(.*)/o;
	    $langname=~s/\W//og;
	    die '"ZZ" is a reserved fieldname\n' if $langname eq "ZZ";
	    push @{$rhfixed_defs},{len=>$len,type=>$type,name=>$langname};
	}
    }
    # We define the unmatched as "ZZ"



    my $template="";

    my $hashed_len = 0;
    for (@{$rhfixed_defs}) {
	$template.= $TYPEMAP{$_->{'type'}}.($_->{'len'}*$TYPE_SCALE{$_->{'type'}})." "; #works for ZString and Integer
	$hashed_len += $_->{'len'};
    }
    my $ZZ_len = $fixed_length-$hashed_len;
    die "Sum of field lengths exceeds fixed length by ".-$ZZ_len." bytes\n" if $ZZ_len < 0;
    push @{$rhfixed_defs},{len=>$ZZ_len,type=>"RAW",name=>"ZZ"};
    $template .= $TYPEMAP{'RAW'}.$ZZ_len;
    my @names = map {$_->{'name'} } @{$rhfixed_defs};
    # Templates with "a0" in them return empty strings, so ok
    # to have $fixed_length= $hashed_len. Perl rules OK?

    $template=~s/(\D)1 /$1 /g;
    close F or die "Could not close config file:$!\n";
    return $class->new(\@names,$template,$fixed_length,$rhfixed_defs);
}

####################################################################

# All_index returns true iff the structure of the record implies that
# there are no extra bytes in the fixed portion that are not indexed.

####################################################################
sub all_indexed {
    my $save_rec = shift;
    my $rhfixed_defs = $save_rec->{'opt'}{'fixed_defs'};
    my $hashed_len = 0;
    for (@{$rhfixed_defs}) {
	$hashed_len += $_->{'len'};
    }
    return 1 if $hashed_len == $save_rec->{opt}{len};
    return 0;
}

####################################################################

# This produces a clone with the same structure but no data.

####################################################################
sub copy_struct {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my ($btr) = @_;

    my $save_rec = {opt=>$proto->{'opt'}, values=>[{},\"",\""]};

    return bless $save_rec,$class;
}

####################################################################

# This uses the {opt} information to fill in {values} from the string
# passed as a parameter.  {values} will look like
# [$rhfixed,$rfixed,$rrest].

####################################################################
sub parse_string {
    my $save_rec = shift;
    my $string = shift;
    my $fixed_len = $save_rec->{'opt'}{'len'};
#    my($fixed,$rest)= $string=~/^(.{$save_rec->{'opt'}{'len'}})(.*)/os;
    my $fixed= substr($string,0,$fixed_len);
    my $rest = substr($string,$fixed_len);

    my @fixed=unpack($save_rec->{'opt'}{'template'},$fixed);
    my %fixed;
    for (@{$save_rec->{'opt'}{'names'}}) {
	#remove warnings about use of undefined value.
        if ($_ eq 'ZZ' and !defined($fixed[0])) {
	   $fixed{$_} ='';
	   next;
	}
	$fixed{$_}= shift @fixed;
    }
    $save_rec->{'values'}=[\%fixed,\$fixed,\$rest];
}

####################################################################

# We know how to take a string and add the necessary appurtenances
# for appending to the on-file btrieve set of records.

####################################################################
sub counted_rec {
    my ($save_rec,$data) = @_;
    return length($data).",".$data."\015\012"; # octal def for x-platform.
}

####################################################################

# We know how to use our hash to create a string
# for appending to the on-file btrieve set of records.

####################################################################
sub counted_rec_hash {
    my ($save_rec) = @_;
    my $data = $save_rec->data();
    return $save_rec->counted_rec($data);
}

####################################################################

# Looks up the fixed string component of self.

####################################################################
sub fixed {
    my $save_rec = shift;
    if (@_) {
        ${$save_rec->{values}[1]} = shift;
    }
    return ${$save_rec->{values}[1]};
}


####################################################################

# Looks up the var string component of self.

####################################################################
sub var {
    my $save_rec = shift;
    if (@_) {
        ${$save_rec->{values}[2]} = shift;
    }
    return ${$save_rec->{values}[2]};
}

####################################################################

# We know how to produce data from the hashed fixed info.

####################################################################
sub data {
    my ($save_rec) = @_;

    my $rrest = $save_rec->{'values'}[2];
    my $fixed = $save_rec->fix_hash_to_string();
    return  $fixed.$$rrest;
}

####################################################################

# We know how to produce a fixed string from the hashed fixed info.

####################################################################

sub fix_hash_to_string {
    my ($save_rec) = @_;

    my $rhfixed = $save_rec->{'values'}[0];
    my $template = $save_rec->{'opt'}{'template'};
    $rhfixed->{"ZZ"} = '' unless defined $rhfixed->{"ZZ"};
    my @values = ();
    # ?? do we want to use an array slice:
    # my %fixed = %$rhfixed;
    # my @names = @{$save_rec->{opt}{names}}
    # @values = @fixed{@names}??
    #
    for (@{$save_rec->{'opt'}{'names'}}) {
	push @values, $rhfixed->{$_};
    }
    return pack($template,@values);
}
1;  # so the require or use succeeds

__END__