view release on metacpan or  search on metacpan

lib/XBase.pm  view on Meta::CPAN

	}
	my ($rs, $fs, $undef, $fields, $table)
				= @options{ qw( rs fs undef fields table ) };
	if (defined $table) {
		eval 'use Data::ShowTable';
		if ($@) {
			warn "You requested table output format but the module Data::ShowTable doesn't\nseem to be installed correctly. Falling back to standard\n";
			$table = undef;
		} else {
			delete $options{'rs'};
			delete $options{'fs'};
		}
	}

	my @fields = ();
	my @unknown_fields;
	if (defined $fields) {
		if (ref $fields eq 'ARRAY') {
			@fields = @$fields;
		} else {
			@fields = split /\s*,\s*/, $fields;
			my $i = 0;
			while ($i < @fields) {
				if (defined $self->field_name_to_num($fields[$i])) {
					$i++;
				} elsif ($fields[$i] =~ /^(.*)-(.*)/) {
					local $^W = 0;
					my @allfields = $self->field_names;
					my ($start, $end) = ($1, $2);
					if ($start eq '') {
						$start = $allfields[0];
					}
					if ($end eq '') {
						$end = $allfields[$#allfields];
					}
					my $start_num = $self->field_name_to_num($start);
					my $end_num = $self->field_name_to_num($end);
					if ($start ne '' and not defined $start_num) {
						push @unknown_fields, $start;
					}
					if ($end ne '' and not defined $end_num) {
						push @unknown_fields, $end;
					}
					unless (defined $start and defined $end) {
						$start = 0; $end = -1;
					}
					
					splice @fields, $i, 1, @allfields[$start_num .. $end_num];
				} else {
					push @unknown_fields, $fields[$i];
					$i++;
				}
			}
		}
	}

	if (@unknown_fields) {
		$self->Error("There have been unknown fields `@unknown_fields' specified.\n");
		return 0;
	}
	my $cursor = $self->prepare_select(@fields);
	my @record;
	if (defined $table) {
		local $^W = 0;
		&ShowBoxTable( $cursor->names(), [], [],
			sub {
				if ($_[0]) { $cursor->rewind(); }
				else { $cursor->fetch() }
				});
	} else {
		while (@record = $cursor->fetch) {
			print join($fs, map { defined $_ ? $_ : $undef } @record), $rs;
		}
	}
	1;
}


# ###################
# Reading the records

# Returns fields of the specified record; parameters and number of the
# record (starting from 0) and optionally names of the required
# fields. If no names are specified, all fields are returned. The
# first value in the returned list if always 1/0 deleted flag. Returns
# empty list on error.

sub get_record {
	my ($self, $num) = (shift, shift);
	$self->NullError();
	$self->get_record_nf( $num, map { $self->field_name_to_num($_); } @_);
}
*get_record_as_hash = \&get_record_hash;
sub get_record_hash {
	my ($self, $num) = @_;
	my @list = $self->get_record($num) or return;
	my $hash = {};
	@{$hash}{ '_DELETED', $self->field_names() } = @list;
	return %$hash if wantarray;
	$hash;
}
sub get_record_nf {
	my ($self, $num, @fieldnums) = @_;
	my $data = $self->read_record($num) or return;
	if (not @fieldnums) {
		@fieldnums = ( 0 .. $self->last_field );
	}
	my $unpack = join ' ', '@0a1',
		map { my $e;
			defined $_ and $e = $self->{'field_unpacks'}[$_];
			defined $e ? $e : '@0a0'; } @fieldnums;
	
	my $rproc = $self->{'field_rproc'};
	my @fns = (\&_read_deleted, map { (defined $_ and defined $rproc->[$_]) ? $rproc->[$_] : sub { undef; }; } @fieldnums);

	my @out = unpack $unpack, $data;
### 	if ($self->{'encrypted'} ne "\000") {
### 		for my $data (@out) {
### 			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);
### 				my $num = unpack 'C', substr($data, $i, 1);
### 				substr($data, $i, 1) = 	pack 'C', (($num >> 1) | ($num << 7) ^ 052);
### 				}
### 			}
### 		}

	for (@out) { $_ = &{ shift @fns }($_); }

	@out;
}

# Processing on read
sub _read_deleted {
	my $value = shift;
	if ($value eq '*') { return 1; } elsif ($value eq ' ') { return 0; }
	undef;
}

sub get_all_records {
	my $self = shift;
	my $cursor = $self->prepare_select(@_);

	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();

lib/XBase.pm  view on Meta::CPAN

=item get_record_as_hash

Returns hash (in list context) or reference to hash (in scalar
context) containing field values indexed by field names. The name of
the deleted flag is C<_DELETED>. The only parameter in the call is
the record number. The field names are returned as uppercase.

=back

=head2 Writing the data

All three writing methods always undelete the record. On success they
return true -- the record number actually written.

=over 4

=item set_record

As parameters, takes the number of the record and the list of values
of the fields. It writes the record to the file. Unspecified fields
(if you pass less than you should) are set to undef/empty.

=item set_record_hash

Takes number of the record and hash as parameters, sets the fields,
unspecified are undefed/emptied.

=item update_record_hash

Like B<set_record_hash> but fields that do not have value specified
in the hash retain their value.

=back

To explicitely delete/undelete a record, use methods B<delete_record>
or B<undelete_record> with record number as a parameter.

Assorted examples of reading and writing:

    my @data = $table->get_record(3, "jezek", "krtek");
    my $hashref = $table->get_record_as_hash(38);
    $table->set_record_hash(8, "jezek" => "jezecek",
					"krtek" => 5);
    $table->undelete_record(4);

This is a code to update field MSG in record where ID is 123.

    use XBase;
    my $table = new XBase "test.dbf" or die XBase->errstr;
    for (0 .. $table->last_record) {
    	my ($deleted, $id) = $table->get_record($_, "ID")
    	die $table->errstr unless defined $deleted;
    	next if $deleted;
	$table->update_record_hash($_, "MSG" => "New message")
						if $id == 123;
    }

=head2 Sequentially reading the file

If you plan to sequentially walk through the file, you can create
a cursor first and then repeatedly call B<fetch> to get next record.

=over 4

=item prepare_select

As parameters, pass list of field names to return, if no parameters,
the following B<fetch> will return all fields.

=item prepare_select_with_index

The first parameter is the file name of the index file, the rest is
as above. For index types that can hold more index structures in on
file, use arrayref instead of the file name and in that array include
file name and the tag name, and optionaly the index type.
The B<fetch> will then return records in the ascending order,
according to the index.

=back

Prepare will return object cursor, the following method are methods of
the cursor, not of the table.

=over 4

=item fetch

Returns the fields of the next available undeleted record. The list
thus doesn't contain the C<_DELETED> flag since you are guaranteed
that the record is not deleted.

=item fetch_hashref

Returns a hash reference of fields for the next non deleted record.

=item last_fetched

Returns the number of the record last fetched.

=item find_eq

This only works with cursor created via B<prepare_select_with_index>.
Will roll to the first record what is equal to specified argument, or
to the first greater if there is none equal. The following B<fetch>es
then continue normally.

=back

Examples of using cursors:

    my $table = new XBase "names.dbf" or die XBase->errstr;
    my $cursor = $table->prepare_select("ID", "NAME", "STREET");
    while (my @data = $cursor->fetch) {
	### do something here, like print "@data\n";
    }

    my $table = new XBase "employ.dbf";
    my $cur = $table->prepare_select_with_index("empid.ndx");
    ## my $cur = $table->prepare_select_with_index(
		["empid.cdx", "ADDRES", "char"], "id", "address");
    $cur->find_eq(1097);
    while (my $hashref = $cur->fetch_hashref
			and $hashref->{"ID"} == 1097) {
	### do something here with $hashref
    }

The second example shows that after you have done B<find_eq>, the
B<fetch>es continue untill the end of the index, so you have to check
whether you are still on records with given value. And if there is no
record with value 1097 in the indexed field, you will just get the
next record in the order.

The updating example can be rewritten to:

    use XBase;
    my $table = new XBase "test.dbf" or die XBase->errstr;
    my $cursor = $table->prepare_select("ID")
    while (my ($id) = $cursor->fetch) {
	$table->update_record_hash($cursor->last_fetched,
			"MSG" => "New message") if $id == 123	
    }

=head2 Dumping the content of the file

A method B<get_all_records> returns reference to an array containing
array of values for each undeleted record at once. As parameters,
pass list of fields to return for each record.

To print the content of the file in a readable form, use method
B<dump_records>. It prints all not deleted records from the file. By
default, all fields are printed, separated by colons, one record on
a row. The method can have parameters in a form of a hash with the
following keys:

=over 4

=item rs

Record separator, string, newline by default.

=item fs

Field separator, string, one colon by default.

=item fields

Reference to a list of names of the fields to print. By default it's
undef, meaning all fields.

=item undef

What to print for undefined (NULL) values, empty string by default.

=back

Example of use is

    use XBase;
    my $table = new XBase "table" or die XBase->errstr;
    $table->dump_records("fs" => " | ", "rs" => " <-+\n",
			"fields" => [ "id", "msg" ]);'

Also note that there is a script dbfdump(1) that does the printing.

=head2 Errors and debugging

If the method fails (returns false or null list), the error message
can be retrieved via B<errstr> method. If the B<new> or B<create>
method fails, you have no object so you get the error message using
class syntax C<XBase-E<gt>errstr()>.

The method B<header_info> returns (not prints) string with
information about the file and about the fields.

Module XBase::Base(3) defines some basic functions that are inherited
by both XBase and XBase::Memo(3) module.

=head1 DATA TYPES