Clarion - Perl module for reading CLARION 2.1 data files

	use Clarion;

	my $dbh=new Clarion "customer.dat";

	print $dbh->file_struct;

	for ( 1 .. $dbh->last_record ) {
    		my $r=$dbh->get_record_hash($_);
		next if $r->{_DELETED};
	    	print $r->{CODE}." ".$r->{NAME}." ".$r->{PHONE}."\n";
	}

	$dbh->close();

package Clarion;

use 5.006;
use strict;
use warnings;

use FileHandle;

our $VERSION = '1.02';

sub FILLOCK { 0x01; }	# file is locked
sub FILOWN  { 0x02; }	# file is owned
sub FILCRYP { 0x04; }	# records are encrypted
sub FILMEMO { 0x08; }	# memo file exists
sub FILCOMP { 0x10; }	# file is compressed
sub FILRCLM { 0x20; }	# reclaim deleted records
sub FILREAD { 0x40; }	# file is read only
sub FILCRET { 0x80; }	# file may be created

sub RECNEW  { 0x01; }	# bit 0 - new record
sub RECOLD  { 0x02; }	# bit 1 - old record
sub RECREV  { 0x04; }	# bit 2 - revised record
sub RECDEL  { 0x10; }	# bit 4 - deleted record
sub RECHLD  { 0x40; }	# bit 6 - record held

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

 $self->open(@_) if @_;
 return $self;
}

sub close {
 my $self=shift;
 if($self->{fh}) {
  $self->{fh}->close();
  delete $self->{fh};
 }
 if($self->{fhMemo}) {
  $self->{fhMemo}->close();
  delete $self->{fhMemo};
 }
}

sub DESTROY {
 shift->close;
}

sub open {
 my ($self, $fileName, $skipMemo)=@_;

 my $fh=new FileHandle $fileName
	or die("Cannot open '$fileName': $!\n");
 binmode($fh);
 $self->{fh}=$fh;

 # Read file signature & header
 my ($filesig, $sfatr)=unpack('a2 S', $self->readData(4, 'header'));
 die "Not a Clarion 2.1 file '$fileName'!\n" 	if $filesig ne 'C3';
 $self->{name}=$fileName;
 $self->{sfatr}=$sfatr;
 my $header=$self->readData(2*9+31+9*4-4, 'header');
 
 # File is encrypted?
 if($sfatr & FILOWN) {	
# Looking for key; 4 variants exist
  $self->{Key}=[unpack('x8  CX2C', $header)];	# numdels, high word
#  $self->{Key}=[unpack('x68 CX2C', $header)];	# reserved, low word
#  $self->{Key}=[unpack('x70 CX2C', $header)];	# reserved, high word
#  $self->{Key}=[unpack('x68 CC', $header)];	# reserved, middle word
  $header=$self->decrypt($header);
 }

 # Parse header itself
 my @X=unpack('C L L S S S S L L L L A12 A12 A3 A3 S S L L L S', $header);
 foreach my $f(qw(numbkeys numrecs numdels numflds numpics nummars reclen offset
	logeof logbof freerec recname memnam filpre recpre memolen memowid
	reserved chgtime chgdate reserved2)) {
  $self->{header}{$f}=shift @X;
 }
 
 # Read field descriptions & build record template
 $self->{fields}=[];
 $self->{decimal_fields}=[];
 $self->{record}{unpack}='';
 $self->{record}{No}=0;
 for(my $i=0; $i<$self->{header}{numflds}; $i++) {
  @X=unpack('C A16 S S C C S S', $self->readData(3+16+2*4, 'field descriptor', 1));
  my $fd={};
  foreach my $f(qw(fldtype fldname foffset length decsig decdec arrnum picnum)) {
   $fd->{$f}=shift @X;
  }
  push @{$self->{fields}}, $fd;
  push @{$self->{decimal_fields}}, $fd	if 8==$fd->{fldtype};
  my $n=$fd->{fldname};
  $n=~s/^.+?://;
  $fd->{Name}=$n;
  $self->{field_map}{$n}=$fd->{No}=$i;
  my $c=qw(a l d A A C s G)[$fd->{fldtype}];
  $c='a'	unless $c;
  $c.=$fd->{length}	if uc($c)eq 'A';
  $c='a'.$fd->{length}.' X'.$fd->{length}.' '	if 'G' eq $c;
  $self->{record}{unpack}.=$c.' ';
 }

 # Read key descriptions
 $self->{keys}=[];
 for(my $i=$self->{header}{numbkeys}; $i>0; $i--) {
  @X=unpack('C A16 C C', $self->readData(1+16+1+1, 'key descriptor', 1));
  my $kd={};
  foreach my $f(qw(numcomps keynams comptype complen)) {
   $kd->{$f}=shift @X;
  }
  push @{$self->{keys}}, $kd;

  # Read key parts
  $kd->{parts}=[];
  for(my $j=$kd->{numcomps}; $j>0; $j--) {
   @X=unpack('C S S C', $self->readData(1+2+2+1, 'key element', 1));
   my $kp={};
   foreach my $f(qw(fldtype fldnum elmoff elmlen)) {
    $kp->{$f}=shift @X;
   }
   push @{$kd->{parts}}, $kp;
  }
 }

 return	if defined($skipMemo) or !($sfatr & FILMEMO);
 # Reading memo...
 $fileName=~s/\.[^\.\\\/]*$//;
 $fileName.='.mem';
 $fh=new FileHandle $fileName
	or die("Cannot open memo '$fileName': $!\n");
 binmode($fh);
 $self->{fhMemo}=$fh;

 # Read memo file signature
 read($fh, $filesig, 2);
 die "Not a Clarion 2.1 memo '$fileName'!\n" 	if $filesig ne 'M3';
 my $m={
  isMemo=>1,
  No=>scalar @{$self->{fields}},
  Name=>$self->{header}{memnam},
  fldname=>$self->{header}{memnam}.':'.$self->{header}{filpre},
  length=>$self->{header}{memolen},
 };
 push @{$self->{fields}}, $m;
 $self->{field_map}{$m->{Name}}=$m->{No};
}

sub last_record {
 return shift->{header}{numrecs};
}

sub bof {
 return shift->{header}{logbof};
}

sub eof {
 return shift->{header}{logeof};
}

# Internal function to read a record

sub readRecord {
 my ($self, $n)=@_;
 $n||=$self->{record}{No}+1;
 return	if $n<1 or $n>$self->{header}{numrecs};
 $self->{record}{data}=[];
 $self->{record}{No}=$n;
 seek($self->{fh}, $self->{header}{offset}+$self->{header}{reclen}*($n-1), 0);

 ($self->{record}{rhd}, $self->{record}{rptr})=unpack('C L', $self->readData(5, 'record'));
 my @Data=unpack($self->{record}{unpack},
  $self->readData($self->{header}{reclen}-5, 'record', $self->{sfatr} & FILCRYP));

 # Convert decimal() fields, if any
 foreach my $f(@{$self->{decimal_fields}}) {
  $Data[$f->{No}]=unpackBCD($Data[$f->{No}], $f->{decsig}, $f->{decdec});
 }
 $self->{record}{data}=\@Data;

 return 1	unless $self->{fhMemo};

# Read memo...
 my $memo;
 $n=($self->{record}{rhd} & RECDEL)? 0 : $self->{record}{rptr};
 while($n) {
  seek($self->{fhMemo}, ($n-1)*256+6, 0);
  $n=unpack('L', $self->readMemo(4));
  my $m=$self->readMemo(252);
  $m=$self->decrypt($m)	if $self->{sfatr} & FILCRYP;
  $memo=''	unless defined($memo);
  $memo.=$m;
 }
 $memo=~s/( +|\00+)\z//	if $memo;
 push @Data, $memo;

 return 1;
}

sub get_record {
 my ($self, $n, @fields)=@_;

 $self->readRecord($n)	or return;

 return ($self->{record}{rhd} & RECDEL, @{$self->{record}{data}})	
	unless @fields;

 return
	$self->{record}{rhd} & RECDEL, 
	map($self->{record}{data}[$self->{field_map}{$_}], @fields);
}

sub get_record_hash {
 my ($self, $n, @fields)=@_;

 $self->readRecord($n) or return;

 my %res= @fields ?
	map(($_, $self->{record}{data}[$self->{field_map}{$_}]), @fields) :
	map(($_->{Name}, $self->{record}{data}[$_->{No}]), @{$self->{fields}});
 
 $res{_DELETED}=$self->{record}{rhd} & RECDEL;
 return \%res;
}

sub file_struct {
 my $self=shift;

 my $res=$self->{name};
 $res=~s/\.dat$//i;
 $res=~s/^.*[\/\\]//;
 $res=uc($res);

 $res.="\tFILE,NAME('$res'),PRE('$self->{header}{filpre}')";

 $res.=",OWNER('???')"	if $self->{sfatr} & FILOWN;
 $res.=",ENCRYPT"		if $self->{sfatr} & FILCRYP;
 $res.=",CREATE"		if $self->{sfatr} & FILCRET;
 $res.=",RECLAIM"		if $self->{sfatr} & FILRCLM;
 $res.=",PROTECT"		if $self->{sfatr} & FILREAD;
 $res.="\n$self->{header}{memnam}\tMEMO($self->{header}{memolen})"
 				if $self->{sfatr} & FILMEMO;

 $res.="\n$self->{header}{recname}\tRECORD\n";
 
 for my $f(@{$self->{fields}}) {
  next	if $f->{isMemo};
  $res.=$f->{Name}."\t";
  my $t=qw(? LONG REAL . . BYTE SHORT . DECIMAL)[$f->{fldtype}];
  if(!$t or '?' eq $t) {
   $t='UNKNOWN TYPE';
   $res.='!';
  }
  if('.' eq $t){
   $res.="STRING($f->{length})";
   $res.="\t!GROUP"		if 7==$f->{fldtype};
  } else {
   $res.=$t;
   $res.="(".($f->{decsig}+$f->{decdec}).",$f->{decdec})"
				if 8==$f->{fldtype};
  }
  $res.="\n";
 }
 return $res."\t. .\n";
}

# Clarion "decryption"

sub decrypt {
 my ($self, $str)=@_;
 return $str	unless defined($self->{Key});
 my $res='';
 do{
  my($c1, $c2)=unpack('C2', $str);
  defined($c2)	or return $res.$str;
  $res.=pack('C2', $c1^$self->{Key}[0], $c2^$self->{Key}[1]);
  $str=unpack('x2 a*', $str);
 }while(1);
}

sub readData {
 my ($self, $len, $what, $decrypt)=@_;
 my $rc=read($self->{fh}, my $buf, $len)||0;
 die "Read error Clarion file ($what) ($rc bytes read instead of $len)!\n"
	if $rc!=$len;
 return $decrypt? $self->decrypt($buf) : $buf;
}

sub readMemo {
 my ($self, $len)=@_;
 my $rc=read($self->{fhMemo}, my $buf, $len)||0;
 die "Read error Clarion memo ($rc bytes read instead of $len)!\n"
	if $rc!=$len;
 return $buf;
}

# Convert BCD to string

sub unpackBCD {
 my ($bcd, $decsig, $decdec)=@_;
 $bcd=unpack('H*', $bcd);

 my $sign=substr($bcd, 0, 1) eq '0' ? '' : '-';
 $bcd=substr($bcd, 1);
 $bcd=~s/\D/9/g	and
    warn "Incorrect DECIMAL value!\n";
 
 my $sig=substr($bcd, 0, $decsig);
 $sig=~s/^0+//;
 $sig='0'	if !length($sig);

 my $dec=substr($bcd, $decsig, $decdec);
 $dec=~s/0+$//;
 $sig.='.'	if length($dec);

 return $sign.$sig.$dec;
}

1;
__END__