# convert Paradox definition of date to "normal human"
sub paradox_date_to_scalar {
my ($num) = @_ ;
my ($long) ;
if (!defined ($num)) {
return undef ;
}
$long = unpack ('N',$num) ;
if (($long & 0x80000000)>0) {
return &days_to_date ($long & 0x7fffffff) ;
}
elsif ($long == 0) {
return "" ;
}
else {
return "INVAL-DATE" ;
}
}
# convert Paradox definition of date and time to "normal human"
sub paradox_timestamp_to_scalar {
# to work with more than LongInt numbers
use Math::BigInt ;
my ($num) = @_ ;
my ($date,$time) ;
my ($a,$b) ;
if (!defined ($num)) {
return undef ;
}
$date = ¶dox_number_to_scalar ($num) ;
if ("" eq $date) {
return "" ;
}
if ($date<0) {
return "INVAL-TIMESTAMP" ;
}
$a = Math::BigInt->new ($date) ;
$b = Math::BigInt->new ("86400000") ;
($date,$time) = $a->bdiv ($b) ;
return &days_to_date ($date) . " " . &msec_to_time ($time) ;
}
# I don't lay claim to algorythm, it was simply been copied from localtime.c
# Portions (C) 1996 Arthur David Olson ([email protected]).
my (@year_lengths) = (365,366) ;
my (@mon_lengths) = (
[31,28,31,30,31,30,31,31,30,31,30,31],
[31,29,31,30,31,30,31,31,30,31,30,31]
) ;
# is it a leap year?
sub isleap {
my ($y) = @_ ;
if (!defined ($y)) {
return undef ;
}
return ($y % 4)==0 && (($y % 100)!=0 || ($y % 400)==0) ;
}
sub days_to_date {
# to being divided without remainder
use integer ;
my ($days) = @_ ;
my ($year,$mon,$day) ;
my ($yleap,$newy,$ref) ;
if (!defined ($days)) {
return undef ;
}
# as long as this is amount of days from 1st january (1st january of 1st year
# is 1), you have to subtract one day to have an amount of days from beginning
$days-- ;
# Paradox keep the date beginning from 1st year A.D.
$year = 1 ;
while ($days<0 || $days>=$year_lengths[$yleap = isleap ($year)]) {
$newy = $year + $days / 365 ;
if ($days<0) {
$newy-- ;
}
$days -= ($newy - $year) * 365 +
(($newy-1)/4 - ($newy-1)/100 + ($newy-1)/400) -
(($year-1)/4 - ($year-1)/100 + ($year-1)/400) ;
$year = $newy ;
}
$ref = $mon_lengths[$yleap] ;
for ($mon = 0 ; $days>= $ref->[$mon] ; $mon++) {
$days -= $ref->[$mon] ;
}
# months from nil, need to be increased by 1
$mon++ ;
# same situation
$days++ ;
no integer ;
return sprintf "%02d-%02d-%04d",$days,$mon,$year ;
}
# main file is F
sub PX_read_header {
my $self = shift ;
my ($i,$char,$string) ;
die "instance method called on class" unless ref $self ;
sysseek ($self->{handle},0,0) ||
die "Cannot make seek in PX_read_header: $!\n" ;
# 00 word
sysread ($self->{handle},$self->{dummy},2) ||
die "Cannot read header in PX_read_header: $!\n" ;
$self->{record_length} = unpack ('v',$self->{dummy}) ;
# 02 word
sysread ($self->{handle},$self->{dummy},2) ||
die "Cannot read header in PX_read_header: $!\n" ;
$self->{header_length} = unpack ('v',$self->{dummy}) ;
# 04 byte
$self->read_next_header_data (1) ;
$i = unpack ('C',$self->{dummy}) ;
(0==$i || 2==$i) ||
die "Unknown DB-file type!\n" ;
# 05 byte
$self->read_next_header_data (1) ;
$i = unpack ('C',$self->{dummy}) ;
($i>=1 && $i<=4) ||
die "Unknown DB-file block size!\n" ;
$self->{block_length} = $i * 1024 ;
# 06 long
$self->read_next_header_data (4) ;
$self->{all_records} = unpack ('V',$self->{dummy}) ;
# 0A word
$self->read_next_header_data (2) ;
$self->{all_used_blocks} = unpack ('v',$self->{dummy}) ;
# 0C word
$self->read_next_header_data (2) ;
# 0E word
$self->read_next_header_data (2) ;
$self->{first_data_block} = unpack ('v',$self->{dummy}) ;
# 10 word ........
$self->read_next_header_data (0x11) ;
# 21 word
$self->read_next_header_data (2) ;
$self->{all_fields} = unpack ('v',$self->{dummy}) ;
# 23 word long
$self->read_next_header_data (6) ;
# 29 byte
$self->read_next_header_data (1) ;
$self->{sort_order} = unpack ('C',$self->{dummy}) ;
# 2A byte ........
$self->read_next_header_data (0x0f) ;
# 39 byte
$self->read_next_header_data (1) ;
$i = unpack ('C',$self->{dummy}) ;
($i>=3 && $i<=12) ||
die "Unknown DB-file version!\n" ;
$self->{version} = $i ;
$self->read_next_header_data (0x1e) ;
if ($self->{version}>4) {
# 58 word ........
$self->read_next_header_data (18) ;
# 6A word
$self->read_next_header_data (2) ;
$self->{code_page} = unpack ('v',$self->{dummy}) ;
$self->read_next_header_data (12) ;
}
else {
# Paradox 3 has not such header
if (0xc0==$self->{sort_order}) {
$self->{code_page} = 866 ;
}
elsif (0x4c==$self->{sort_order}) {
$self->{code_page} = 1251 ;
}
}
# 58 (Paradox3) or 78 (any) array
undef @{$self->{field_type}} ;
undef @{$self->{field_length}} ;
undef @{$self->{field_name}} ;
for ($i=0 ; $i<$self->{all_fields} ; $i++) {
$self->read_next_header_data (1) ;
push (@{$self->{field_type}},unpack ('C',$self->{dummy})) ;
$self->read_next_header_data (1) ;
push (@{$self->{field_length}},unpack ('C',$self->{dummy})) ;
}
# ignore all until field names
$self->read_next_header_data (4*$self->{all_fields}+4) ;
if ($self->{version}>11) {
$self->read_next_header_data (0x105) ;
}
else {
$self->read_next_header_data (0x4f) ;
}
for ($i=0 ; $i<$self->{all_fields} ; $i++) {
$string = "" ;
do {
sysread ($self->{handle},$char,1) ||
die "Cannot read header in PX_read_header: $!\n" ;
if (sysseek ($self->{handle},0,1)>$self->{header_length}) {
die "Bad format! Header is too small\n" ;
}
$char = unpack ('Z',$char) ;
if ($char) {
$string .= $char ;
}
} while ($char) ;
if (0xc0==$self->{sort_order} && 866==$self->{code_page}) {
push (@{$self->{field_name}},alt2koi($string)) ;
}
elsif (0x4c==$self->{sort_order} &&
(1252==$self->{code_page} || 1251==$self->{code_page})) {
push (@{$self->{field_name}},win2koi($string)) ;
}
else {
push (@{$self->{field_name}},$string) ;
}
}
}
# return next block number and last record offset in block
# and specify file position for reading of first record
sub PX_read_data_block {
my $self = shift ;
my ($dummy) ;
die "instance method called on class" unless ref $self ;
sysseek ($self->{handle},
$self->{block_length}*($self->{current_block}-1)+$self->{header_length},0) ;
sysread ($self->{handle},$dummy,2) ||
die "Cannot read data block N",$self->{current_block},": $!\n" ;
$self->{next_block} = unpack ('v',$dummy) ;
sysread ($self->{handle},$dummy,2) ||
die "Cannot read data block N",$self->{current_block},": $!\n" ;
sysread ($self->{handle},$dummy,2) ||
die "Cannot read data block N",$self->{current_block},": $!\n" ;
$self->{last_record_offset} = unpack ('v',$dummy) ;
$self->{current_used_block}++ ;
}
# new object creating
sub new {
my $class = shift ;
my $new = bless {}, $class ;
$new->{handle} = IO::File->new () ;
return $new->open (@_) ;
}
# open file and initialize all object variables
sub open {
my $self = shift ;
die "instance method called on class" unless ref $self ;
if (!defined ($_[0])) {
return undef ;
}
if (not sysopen ($self->{handle},$_[0],O_RDONLY)) {
warn "Cannot open file \'",$_[0],"\': $!\n" ;
return undef ;
}
if (not flock ($self->{handle},LOCK_SH)) {
warn "Cannot lock file \'",$_[0],"\': $!\n" ;
return undef ;
}
return $self->reopen () ;
}
# close file
sub close {
my $self = shift ;
die "instance method called on class" unless ref $self ;
flock ($self->{handle},LOCK_UN) ;
close ($self->{handle}) ;
}
# unlock and close file
sub DESTROY {
my $self = shift ;
$self->close () ;
}
# re-open file being already opened (properly simply return to BOF)
sub reopen {
my $self = shift ;
die "instance method called on class" unless ref $self ;
$self->PX_read_header () ;
$self->{is_last_block} = 0 ;
$self->{next_block} = $self->{first_data_block} ;
$self->{current_used_block} = 0 ;
$self->{end_of_base} = 0 ;
$self->{need_read_block} = 1 ;
return $self ;
}