Perl con Paradox

[jferrero]

Código:

# read next record while block is being read
# read record and return its data in array or undef
# BCD, Binary and all BLOBs NOT SUPPORTED!

sub PX_read_record {
	my $self = shift ;
	my (@result) ;
	my ($a,$i,$dummy) ;
	
	die "instance method called on class" unless ref $self ;
	if ($self->{current_record_offset}<$self->{last_record_offset}) {
		$self->{need_read_block} = 0 ;
	}
	else {
		$self->{need_read_block} = 1 ;
	}
	if ($self->{current_record_offset}>$self->{last_record_offset}) {
		return ;
	}

	sysseek ($self->{handle},$self->{block_length}*($self->{current_block}-1)+
		$self->{header_length}+6+$self->{current_record_offset},0) || 
		die "Cannot make seek to record: $!\n" ;

	$self->{current_record_offset} += $self->{record_length} ;
	undef @result ;
	for ($i = 0 ; $i<$self->{all_fields} ; $i++) {
# BCD type has a fixed length
		if (${$self->{field_type}}[$i]==0x17) {
			sysread ($self->{handle},$dummy,17) ||
				die "Cannot read record: $!\n" ;
		}
		else {
			sysread ($self->{handle},$dummy,${$self->{field_length}}[$i]) ||
				die "Cannot read record: $!\n" ;
		}
		if (${$self->{field_type}}[$i]==1) {
# Field A
			$a = unpack ('Z' . ${$self->{field_length}}[$i],$dummy) ;
			if (0xc0==$self->{sort_order} && 866==$self->{code_page}) {
				push (@result,alt2koi ($a)) ;
			}
			elsif (0x4c==$self->{sort_order} && 
				(1252==$self->{code_page} || 1251==$self->{code_page})) {
				push (@result,win2koi ($a)) ;
			}
			else {
				push (@result,$a) ;
			}
		}
		elsif (${$self->{field_type}}[$i]==2) {
# Field D
			if (${$self->{field_length}}[$i]==4) {
				push (@result,&paradox_date_to_scalar ($dummy)) ;
			}
			else {
				push (@result,"-*%& UNSUPPORTED &%*-") ;
			}
		}
		elsif (${$self->{field_type}}[$i]==3) {
# Field S 
			if (${$self->{field_length}}[$i]==2) {
				push (@result,&paradox_short_to_scalar ($dummy)) ;
			}
			else {
				push (@result,"-*%& UNSUPPORTED &%*-") ;
			}
		}
		elsif (${$self->{field_type}}[$i]==4) {
# Field I
			if (${$self->{field_length}}[$i]==4) {
				push (@result,&paradox_long_to_scalar ($dummy)) ;
			}
			else {
				push (@result,"-*%& UNSUPPORTED &%*-") ;
			}
		}
		elsif (${$self->{field_type}}[$i]==5) {
# Field $
			if (${$self->{field_length}}[$i]==8) {
				push (@result,&paradox_number_to_scalar ($dummy)) ;
			}
			else {
				push (@result,"-*%& UNSUPPORTED &%*-") ;
			}
		}
		elsif (${$self->{field_type}}[$i]==6) {
# Field N
			if (${$self->{field_length}}[$i]==8) {
				push (@result,&paradox_number_to_scalar ($dummy)) ;
			}
			else {
				push (@result,"-*%& UNSUPPORTED &%*-") ;
			}
		}
		elsif (${$self->{field_type}}[$i]==9) {
# Field L
			if (${$self->{field_length}}[$i]==1) {
				push (@result,&paradox_logic_to_scalar ($dummy)) ;
			}
			else {
				push (@result,"-*%& UNSUPPORTED &%*-") ;
			}
		}
		elsif (${$self->{field_type}}[$i]==0x14) {
# Field T
			if (${$self->{field_length}}[$i]==4) {
				push (@result,&paradox_time_to_scalar ($dummy)) ;
			}
			else {
				push (@result,"-*%& UNSUPPORTED &%*-") ;
			}
		}
		elsif (${$self->{field_type}}[$i]==0x15) {
# Field @
			if (${$self->{field_length}}[$i]==8) {
				push (@result,&paradox_timestamp_to_scalar ($dummy)) ;
			}
			else {
				push (@result,"-*%& UNSUPPORTED &%*-") ;
			}
		}
		elsif (${$self->{field_type}}[$i]==0x16) {
# Field +
			if (${$self->{field_length}}[$i]==4) {
				push (@result,&paradox_long_to_scalar ($dummy)) ;
			}
			else {
				push (@result,"-*%& UNSUPPORTED &%*-") ;
			}
		}
		elsif (${$self->{field_type}}[$i]==0x17) {
# Field #
			push (@result,"-*%& UNSUPPORTED &%*-") ;
		}
		else {
			push (@result,"-*%& UNSUPPORTED &%*-") ;
		}
	}
	return @result ;
}

# read next record 

sub fetch {
	my $self = shift ;
	
	die "instance method called on class" unless ref $self ;
	if ($self->{end_of_base}) {
		return ;
	}
	if ($self->{need_read_block}) {
		for ( ; !$self->{is_last_block} && $self->{current_used_block}<=$self->{all_used_blocks} ; ) {
			$self->{current_block} = $self->{next_block} ;
			$self->PX_read_data_block () ;
			if ($self->{next_block}==0) {
				$self->{is_last_block} = 1 ;
			}
			if ($self->{last_record_offset}<0 || 
				$self->{last_record_offset}>$self->{block_length}-$self->{record_length}) {
				next ;
			}
			$self->{current_record_offset} = 0 ;
			return $self->PX_read_record () ;
		}
		$self->{end_of_base} = 1 ;
		return ;
	}
	return $self->PX_read_record () ;
}

# read next record as hash ("field name" => "value")

sub get_record_as_hash {
	my $self = shift ;
	my $result = {} ;
	my @record_data ;

	if (not (@record_data = $self->fetch (@_))) {
		return ;
	}
	@{$result}{@{$self->{field_name}}} = @record_data ;
	return %$result ;
}

1 ;

# Usage:
#
#use Paradox ;
#
#$d = new Paradox "path/to/file.db" ;
#print "Header:\n" ;
#print join ("|",@{$d->{field_type}}),"\n" ;
#print join ("|",@{$d->{field_length}}),"\n" ;
#print join ("|",@{$d->{field_name}}),"\n" ;
#print "Data:\n" ;
#while (@record_data = $d->fetch ()) {
#	print join ("|",@record_data),"\n" ;
#}