Perl con Paradox

[jferrero]

Código:

# Reading DB-files from Paradox with Perl
#
# Copyright (C) 2000-2001 Sergey A. Eremenko ([email protected]) and 
#			Alexander E. Chizhov ([email protected])
# English translation copyright (C) 2001 Edward Stankevich ([email protected])
#
# Created for JSC Rostovtelecom specially
# Licensed by GPL
# $Id: Paradox.pm v1.0.8 $
#
# 1.0.0	- first release
# 1.0.1	- view of 'short' as 0x0000 fixed, its empty now
#	- made as module
#	- additional checking for fields sizes
# 1.0.2	- view of 'money' and 'number' as 0x0000000000000000 fixed,
#	  its empty now
# 1.0.3	- 'get_record_as_hash' added
# 1.0.4	- 'open', 'close', 'reopen' added for multiple reading 
#	  of the same file
#	- small bug of calling 'new' without name was fixed at one
# 1.0.5	- very unpleasant bug of inaccurate copying from localtime.c 
#	  was fixed. There was infinite looping at bounds date of
#	  years, such as 01-01-1999. Thats why those who using this
#	  thing are STRONGLY RECOMMENDED to upgrade for 1.0.5.
# 1.0.6	- the bug of impossibility of reading last record, if last
#	  data block consists of this record alone, fixed.
# 1.0.7	- header data integrity checking added
#	- Paradox 3,4,5,7 checking added
#	- 'long' type processing added
#	- 'autoincrement' type processing added
#	- 'logical' type processing added
#	- 'time' type processing added
#	- 'alt2koi' coding hase been modified
#	- 'win1251' russian coding operation added
#	- sort order and codepage are checking now. Also text coding
#	  process in russian case only.     
#	- 'timestamp' type processing added
# 1.0.8	- bug of reading field name having spaces fixed,
#	  thanks to Christopher R. Redinger 

package Paradox ;

#	Object variables
# handle	- file handle
# dummy	- next reading data
#
#	DB-file header
# record_length		- record length
# header_length		- header length
# block_length		- 1 data block length
# all_records		- number of records
# all_used_blocks	- number of real used data blocks
# first_data_block	- first data block
# all_fields		- number of fields
# sort_order		- sort order
# version		- Paradox version
# code_page		- DOS codepage
# @field_type		- array of field types
# @field_length		- array of field lengths
# @field_name		- array of field names
#
#	Reading file data
# is_last_block		- is it last block?
# current_used_block	- number of current used block
# current_block		- number of current block
# next_block		- number of next block
# need_read_block	- is need to read next data block?
# end_of_base		- is it end of base?
# last_record_offset	- last record offset in data block
# current_record_offset	- current record offset in data block

require 5.004 ;
use Fcntl qw (:flock) ;
use IO::File ;

# Convert string from cp-866 to koi8-r coding. This is actually for 
# russians only. (Opjat eti russkie chto-to pridumali ;-)
# If you don't need it (lucky!) just comment third string in this sub.
sub alt2koi {
	my ($string) = @_;

	$string =~ tr/\x80-\xFF/\xE1\xE2\xF7\xE7\xE4\xE5\xF6\xFA\xE9\xEA\xEB\xEC\xED\xEE\xEF\xF0\xF2\xF3\xF4\xF5\xE6\xE8\xE3\xFE\xFB\xFD\xFF\xF9\xF8\xFC\xE0\xF1\xC1\xC2\xD7\xC7\xC4\xC5\xD6\xDA\xC9\xCA\xCB\xCC\xCD\xCE\xCF\xD0\x90\x91\x92\x81\x87\xB2\xB4\xA7\xA6\xB5\xA1\xA8\xAE\xAD\xAC\x83\x84\x89\x88\x86\x80\x8A\xAF\xB0\xAB\xA5\xBB\xB8\xB1\xA0\xBE\xB9\xBA\xB6\xB7\xAA\xA9\xA2\xA4\xBD\xBC\x85\x82\x8D\x8C\x8E\x8F\x8B\xD2\xD3\xD4\xD5\xC6\xC8\xC3\xDE\xDB\xDD\xDF\xD9\xD8\xDC\xC0\xD1\xB3\xA3\xE5\xC5\x49\x69\xF5\xD5\x9C\x95\x9E\x96\x4E\xD2\x94\x9A/;
	return $string;
}

# Convert string from win1251 to koi8-r coding.
sub win2koi {
	my ($string) = @_;

	$string =~ tr/\x80-\xFF/................................\x9A.......\xB3\xBF......\x9C......\x9E\xA3.......\xE1\xE2\xF7\xE7\xE4\xE5\xF6\xFA\xE9\xEA\xEB\xEC\xED\xEE\xEF\xF0\xF2\xF3\xF4\xF5\xE6\xE8\xE3\xFE\xFB\xFD\xFF\xF9\xF8\xFC\xE0\xF1\xC1\xC2\xD7\xC7\xC4\xC5\xD6\xDA\xC9\xCA\xCB\xCC\xCD\xCE\xCF\xD0\xD2\xD3\xD4\xD5\xC6\xC8\xC3\xDE\xDB\xDD\xDF\xD9\xD8\xDC\xC0\xD1/;
	return $string;
}

# $header_length have to be read at this moment !
sub read_next_header_data {
	my $self = shift;
	my ($length) = @_;

	die "instance method called on class" unless ref $self;
	if (!defined ($length)) {
		return;
	}
	sysread ($self->{handle},$self->{dummy},$length) || 
		die "Cannot read header in read_next_header_data: $!\n" ;
	if (sysseek ($self->{handle},0,1) > $self->{header_length}) {
		die "Bad format! Header is too small\n" ;
	}
}

# convert Paradox definition of two-byte integer into "normal human"

sub paradox_short_to_scalar {
	my ($num) = @_;
	my ($short);
	my ($high,$low);

	if (!defined ($num)) {
		return undef;
	}
	($short) = unpack ('n',$num);
	if ($short==0) {
		return "";
	}
	elsif (($short & 0x8000) > 0) {
		return $short & 0x7fff;
	}
	else {
		return -($short ^ 0x7fff)-1;
	}
}

# convert Paradox definition of four-byte integer into "normal human"

sub paradox_long_to_scalar {
	my ($num) = @_;
	my ($long);

	if (!defined ($num)) {
		return undef;
	}
	($long) = unpack ('N',$num);
	if ($long==0) {
		return "";
	}
	elsif (($long & 0x80000000) > 0) {
		return $long & 0x7fffffff;
	}
	else {
		return -($long ^ 0x7fffffff)-1;
	}
}

# convert Paradox definition of boolean into "normal human"

sub paradox_logic_to_scalar {
	my ($num) = @_ ;
	my ($logical) ;

	if (!defined ($num)) {
		return undef ;
	}
	($logical) = unpack ('C',$num) ;
	if (0==$logical) {
		return "" ;
	}
	elsif (0x81==$logical) {
		return "true" ;
	}
	elsif (0x80==$logical) {
		return "false" ;
	}
	return "INVAL-BOOL" ;
}

# convert Paradox definition of time into "normal human"

sub paradox_time_to_scalar {
	my ($num) = @_ ;
	my ($long) ;

	if (!defined ($num)) {
		return undef ;
	}
	$long = &paradox_long_to_scalar ($num) ;
	if ("" eq $long) {
		return "" ;
	}
	if ($long<0) {
		return "INVAL-TIME" ;
	}
	return &msec_to_time ($long) ;
}

# convert microseconds into time

sub msec_to_time {

# to being divided without remainder
	use integer ;

	my ($hour) = @_ ;
	my ($min,$sec,$msec) ;

	if (!defined ($hour)) {
		return undef ;
	}
	$msec = $hour % 1000 ;
	$hour /= 1000 ;
	$sec = $hour % 60 ;
	$hour /= 60 ;
	$min = $hour % 60 ;
	$hour /= 60 ;
	no integer ;
	return sprintf "%02d:%02d:%02d.%d",$hour,$min,$sec,$msec ;
}

# convert Paradox definition of floating point into "normal human"
# WARNING! I've checked it only at Intel platform!
# I could write some universal, but I'm lazy :-)

sub paradox_number_to_scalar {
	my ($num) = @_ ;
	my ($result) ;
	my (@num_array) ;

	undef $result ;
	if (defined ($num)) {
		@num_array = unpack ('CCCCCCCC',$num) ;
		if ($num_array[0]==0 && $num_array[1]==0 && $num_array[2]==0 &&
		    $num_array[3]==0 && $num_array[4]==0 && $num_array[5]==0 &&
		    $num_array[6]==0 && $num_array[7]==0) {
			return "" ;
		}
# high bit in first byte is set
		if ((@num_array[0] & 0x80) > 0) {
			@num_array[0] &= 0x7f ;
		}
		elsif ((@num_array[0]==0) && ((@num_array[1] & 0xf0) < 0x10 )) {
		}
		else {
			foreach (@num_array) {
				$_ ^= 0xff ;
			}
		}
		@num_array = reverse @num_array ;
		$result = unpack ('d',pack ('CCCCCCCC',@num_array)) ;
	}
	return $result ;
}