view release on metacpan or  search on metacpan

lib/XBase.pm  view on Meta::CPAN

	my $result = [];
	my @record;
	while (@record = $cursor->fetch())
		{ push @$result, [ @record ]; }
	$result;
}

# #############
# Write records

# Write record, values of the fields are in the argument list.
# Record is always undeleted
sub set_record {
	my ($self, $num, @data) = @_;
	$self->NullError();
	my $wproc = $self->{'field_wproc'};

	if (defined $self->{'attached_index_columns'}) {
		my @nfs = keys %{$self->{'attached_index_columns'}};
		my ($del, @old_data) = $self->get_record_nf($num, @nfs);

		local $^W = 0;
		for my $nf (@nfs) {
			if ($old_data[$nf] ne $data[$nf]) {
				for my $idx (@{$self->{'attached_index_columns'}{$nf}}) {
					$idx->delete($old_data[$nf], $num + 1);
					$idx->insert($data[$nf], $num + 1);
				}
			}
		}
	}

	for (my $i = 0; $i <= $#$wproc; $i++) {
		$data[$i] = &{ $wproc->[$i] }($data[$i]);
	}
	unshift @data, ' ';

### 	if ($self->{'encrypted'} ne "\000") {
### 		for my $data (@data) {
### 			for (my $i = 0; $i < length($data); $i++) {
### 				my $num = unpack 'C', substr($data, $i, 1);
### 				substr($data, $i, 1) = 	pack 'C', (($num << 3) | ($num >> 5) ^ 020);
### 				}
### 			}
### 		}

	$self->write_record($num, @data);
}

# Write record, fields are specified as hash, unspecified are set to
# undef/empty
sub set_record_hash {
	my ($self, $num, %data) = @_;
	$self->NullError();
	$self->set_record($num, map { $data{$_} } $self->field_names );
}

# Write record, fields specified as hash, unspecified will be
# unchanged
sub update_record_hash {
	my ($self, $num) = ( shift, shift );
	$self->NullError();

	my %olddata = $self->get_record_hash($num);
	return unless %olddata;
	$self->set_record_hash($num, %olddata, @_);
}

# Actually write the data (calling XBase::Base::write_record) and keep
# the overall structure of the file correct;
sub write_record {
	my ($self, $num) = (shift, shift);
	my $ret = $self->SUPER::write_record($num, @_) or return;

	if ($num > $self->last_record) {
		$self->SUPER::write_record($num + 1, "\x1a");	# add EOF
		$self->update_last_record($num) or return;
	}
	$self->update_last_change or return;
	$ret;
}

# Delete and undelete record
sub delete_record {
	my ($self, $num) = @_;
	$self->NullError();
	$self->write_record($num, "*");
}
sub undelete_record {
	my ($self, $num) = @_;
	$self->NullError();
	$self->write_record($num, " ");
}

# Update the last change date
sub update_last_change {
	my $self = shift;
	return 1 if defined $self->{'updated_today'};
	my ($y, $m, $d) = (localtime)[5, 4, 3]; $m++; $y -= 100 if $y >= 100;
	$self->write_to(1, pack "C3", ($y, $m, $d)) or return;
	$self->{'updated_today'} = 1;
}
# Update the number of records
sub update_last_record {
	my ($self, $last) = @_;
	$last++;
	$self->write_to(4, pack "V", $last);
	$self->{'num_rec'} = $last;
}

# Creating new dbf file
sub create {
	XBase->NullError();
	my $class = shift;
	my %options = @_;
	if (ref $class) {
		%options = ( %$class, %options ); $class = ref $class;
	}

	my $version = $options{'version'};
	if (not defined $version) {
		if (defined $options{'memofile'}
			and $options{'memofile'} =~ /\.fpt$/i) {
			$version = 0xf5;
		} else {
			$version = 3;
		}
	}

	my $key;
	for $key ( qw( field_names field_types field_lengths field_decimals ) ) {
		if (not defined $options{$key}) {
			__PACKAGE__->Error("Tag $key must be specified when creating new table\n");
			return;
		}
	}

	my $needmemo = 0;

	my $fieldspack = '';
	my $record_len = 1;
	my $i;
	for $i (0 .. $#{$options{'field_names'}}) {
		my $name = uc $options{'field_names'}[$i];
		$name = "FIELD$i" unless defined $name;
		$name .= "\0";
		my $type = $options{'field_types'}[$i];
		$type = 'C' unless defined $type;

		my $length = $options{'field_lengths'}[$i];
		my $decimal = $options{'field_decimals'}[$i];

		if (not defined $length) {		# defaults
			if ($type eq 'C')		{ $length = 64; }
			elsif ($type =~ /^[TD]$/)	{ $length = 8; }
			elsif ($type =~ /^[NF]$/)	{ $length = 8; }
		}
						# force correct lengths
		if ($type =~ /^[MBGP]$/)	{ $length = 10; $decimal = 0; }
		elsif ($type eq 'L')	{ $length = 1; $decimal = 0; }
		elsif ($type eq 'Y')	{ $length = 8; $decimal = 4; }

		if (not defined $decimal) {
			$decimal = 0;