view release on metacpan or  search on metacpan

lib/DBD/XBase.pm  view on Meta::CPAN

my %TYPE_INFO_TYPES = map { ( $TYPE_INFO_ALL[$_][0] => $_ ) } ( 1 .. $#TYPE_INFO_ALL );
my %REVTYPES = qw( C char N numeric F float L boolean D date M blob T time );
my %REVSQLTYPES = map { ( $_ => $TYPE_INFO_ALL[  $TYPE_INFO_TYPES{ uc $REVTYPES{$_} } ][1] ) } keys %REVTYPES;

### use Data::Dumper; print STDERR Dumper \@TYPE_INFO_ALL, \%TYPE_INFO_TYPES, \%REVTYPES, \%REVSQLTYPES;

sub type_info_all {
	my $dbh = shift;
	my $result = [ @TYPE_INFO_ALL ];
	my $i = 0;
	my $hash = { map { ( $_ => $i++) } @{$result->[0]} };
	$result->[0] = $hash;
	$result;
}
sub type_info {
	my ($dbh, $type) = @_;
	my @result = ();
	for my $row ( 1 .. $#TYPE_INFO_ALL ) {
		if ($type == DBI::SQL_ALL_TYPES or $type == $TYPE_INFO_ALL[$row][1])
			{ push @result, { map { ( $TYPE_INFO_ALL[0][$_] => $TYPE_INFO_ALL[$row][$_] ) } ( 0 .. $#{$TYPE_INFO_ALL[0]} ) } }
	}
	@result;
}

sub DESTROY {
	# To avoid autoloaded DESTROY
}


# #####################
# The statement package

package DBD::XBase::st;
use strict;
$DBD::XBase::st::imp_data_size = 0;

# Binding of parameters: numbers are converted to :pnumber form,
# values are stored in the sth->{'xbase_bind_values'}->name of the
# parameter hash
sub bind_param {
	my ($sth, $parameter) = (shift, shift);
	if ($parameter =~ /^\d+$/) { $parameter = ':p'.$parameter; }
	$sth->{'xbase_bind_values'}{$parameter} = shift;
	1;
}

# Returns number of rows fetched until now
sub rows {
	defined $_[0]->{'xbase_rows'} ? $_[0]->{'xbase_rows'} : -1;
}

sub _set_rows {
	my $sth = shift;
	if (not @_ or not defined $_[0]) {
		$sth->{'xbase_rows'} = undef; return -1;
	}
	$sth->{'xbase_rows'} = ( $_[0] ? $_[0] : '0E0' );
}
# Execute the current statement, possibly binding parameters. For
# nonselect commands the actions needs to be done here, for select we
# just create the cursor and wait for fetchrows
sub execute {
	my $sth = shift;

	# the binds_order arrayref holds the conversion from the first
	# occurence of the named parameter to its name;
	# we bind the parameters here
	my $parsed_sql = $sth->{'xbase_parsed_sql'};
	for (my $i = 0; $i < @_; $i++) {
		$sth->bind_param($parsed_sql->{'binds_order'}[$i], $_[$i]);
	}

	# binded parameters
	my $bind_values = $sth->{'xbase_bind_values'};

	# cancel the count of rows done in the previous run, this is a
	# new execute
	$sth->{'xbase_rows'} = undef;
	delete $sth->{'xbase_lines'};
	
	# we'll nee dbh, table name and to command to do with them	
	my $dbh = $sth->{'Database'};
	my $table = $parsed_sql->{'table'}[0];
	my $command = $parsed_sql->{'command'};
		
	# create table first; we just create it and are done
	if ($command eq 'create') {
		my $filename = $dbh->{'Name'} . '/' . $table;
		my %opts;
		# get the name and the fields info
		@opts{ qw( name field_names field_types field_lengths
				field_decimals ) } =
			( $filename, @{$parsed_sql}{ qw( createfields
				createtypes createlengths createdecimals ) } );
		# try to create the table (and memo automatically)
		my $xbase = XBase->create(%opts) or do {
			$sth->DBI::set_err(10, XBase->errstr());
			return;
		};
		# keep the table open
		$dbh->{'xbase_tables'}->{$table} = $xbase;	
		return $sth->DBD::XBase::st::_set_rows(0);	# return true
	}

	# let's see if we've already opened the table
	my $xbase = $dbh->{'xbase_tables'}->{$table};
	if (not defined $xbase) {
		# if not, open the table now
		my $filename = $dbh->{'Name'} . '/' . $table;
		my %opts = ('name' => $filename);
		$opts{'ignorememo'} = 1 if $dbh->{'xbase_ignorememo'};
		# try to open the table using XBase.pm
		$xbase = new XBase(%opts) or do {
			$sth->DBI::set_err(3, "Table $table not found: "
							. XBase->errstr());
			return;
		};
		$dbh->{'xbase_tables'}->{$table} = $xbase;	
	}

	# the following is not multiple-statements safe -- I'd overwrite

lib/DBD/XBase.pm  view on Meta::CPAN

	# the array usedfields holds a list of field names that were
	# explicitely mentioned somewhere in the SQL query -- select
	# fields list, where clause, set clauses in update ...
	# we'll try to make a list of those that do not exist in the table
	my %nonexist;
	for my $field (@{$parsed_sql->{'usedfields'}}) {
		$nonexist{$field} = 1 unless defined $xbase->field_type($field);
	}
	if (keys %nonexist) {
		$sth->DBI::set_err(4,
			sprintf 'Field %s not found in table %s',
				join(', ', sort keys %nonexist), $table);
		return;
	}

	# inserting values means appending a new row with reasonable
	# values; the insertfn function expects the TABLE object and
	# the BIND hash (it doesn' make use of them at the moment,
	# AFAIK, because only constants are supported), it returns list
	# of values
	if ($command eq 'insert') {
		my $last = $xbase->last_record;
		my @values = &{$parsed_sql->{'insertfn'}}($xbase, $bind_values);
		
		### here, we'd really need a check for too many or too
		### few values
		if (defined $parsed_sql->{'insertfields'}) {
			my %newval;
			@newval{ @{$parsed_sql->{'insertfields'} } } = @values;
			@values = @newval{ $xbase->field_names };
		}
		$xbase->set_record($last + 1, @values) or do {
			$sth->DBI::set_err(49,'Insert failed: '.$xbase->errstr);
			return;
		};
		return $sth->DBD::XBase::st::_set_rows(1);	# we've added one row
	}


	# rows? what do we need rows here for? never mind.
	my $rows;

	# wherefn is defined if the statement had where clause; it
	# should be called with $TABLE, $VALUES and $BIND parameters
	my $wherefn = $parsed_sql->{'wherefn'};

	# we expand selectall to list of fields
	if (defined $parsed_sql->{'selectall'} and not defined $parsed_sql->{'selectfieldscount'}) {
		$parsed_sql->{'selectnames'} = [ $xbase->field_names ];
		push @{$parsed_sql->{'usedfields'}}, $xbase->field_names;
		$parsed_sql->{'selectfieldscount'} = scalar $xbase->field_names;
	}

	# we only set NUM_OF_FIELDS for select command -- which is
	# exactly what selectfieldscount means
	if (not $sth->FETCH('NUM_OF_FIELDS')) {
		$sth->STORE('NUM_OF_FIELDS', $parsed_sql->{'selectfieldscount'});
	}
		
	# this cursor will be needed, because both select and update and
	# delete with where clause need to fetch the data first
	my $cursor = $xbase->prepare_select(@{$parsed_sql->{'usedfields'}});

	
	# select with order by clause will be done using "substatement"
	if ($command eq 'select' and defined $parsed_sql->{'orderfields'}) {
		my @orderfields = @{$parsed_sql->{'orderfields'}};

		# make a copy of the $parsed_sql hash, but delete the
		# orderfields value
		my $subparsed_sql = { %$parsed_sql };
		delete $subparsed_sql->{'orderfields'};
		delete $subparsed_sql->{'selectall'};

		my $selectfn = $parsed_sql->{'selectfn'};
		$subparsed_sql->{'selectfn'} = sub {
			my ($TABLE, $VALUES, $BINDS) = @_;
			return map({ XBase::SQL::Expr->field($_, $TABLE, $VALUES)->value } @orderfields), &{$selectfn}($TABLE, $VALUES, $BINDS);
		};
### use Data::Dumper; print STDERR Dumper $subparsed_sql;
		$subparsed_sql->{'selectfieldscount'} += scalar(@orderfields);

		# make new $sth
		my $substh = DBI::_new_sth($dbh, {
			'Statement' => $sth->{'Statement'},
			'xbase_parsed_sql' => $subparsed_sql,
			}); 
		
		# bind all parameters in the substh
		for my $key (keys %$bind_values) {
			$substh->bind_param($key, $bind_values->{$key});
		}
		
		# execute and fetch all rows
		$substh->execute;
### use Data::Dumper; print STDERR Dumper $substh->{'xbase_parsed_sql'};
		my $data = $substh->fetchall_arrayref;

		my $sortfn = '';
		for (my $i = 0; $i < @orderfields; $i++) {
			$sortfn .= ' or ' if $i > 0;
			if ($xbase->field_type($orderfields[$i]) =~ /^[CML]$/) {
				if (lc($parsed_sql->{'orderdescs'}[$i]) eq 'desc') {
					$sortfn .= "\$_[1]->[$i] cmp \$_[0]->[$i]";
				} else {
					$sortfn .= "\$_[0]->[$i] cmp \$_[1]->[$i]";
				}
			} else {
				if (lc($parsed_sql->{'orderdescs'}[$i]) eq 'desc') {
					$sortfn .= "\$_[1]->[$i] <=> \$_[0]->[$i]";
				} else {
					$sortfn .= "\$_[0]->[$i] <=> \$_[1]->[$i]";
				}
			}
		}
		my $fn = eval "sub { $sortfn }";
		# sort them and store in xbase_lines
		$sth->{'xbase_lines'} =
			[ map { [ @{$_}[scalar(@orderfields) .. scalar(@$_) - 1 ] ] }
				sort { &{$fn}($a, $b) } @$data ];
	} elsif ($command eq 'select') {
		$sth->{'xbase_cursor'} = $cursor;
	} elsif ($command eq 'delete') {
		if (not defined $wherefn) {
			my $last = $xbase->last_record;
			for (my $i = 0; $i <= $last; $i++) {
				if (not (($xbase->get_record_nf($i, 0))[0])) {
					$xbase->delete_record($i);
					$rows = 0 unless defined $rows;
					$rows++;
				}
			}
		} else {
			my $values;
			while (defined($values = $cursor->fetch_hashref)) {
				next unless &{$wherefn}($xbase, $values,
				$bind_values, 0);
				$xbase->delete_record($cursor->last_fetched);
				$rows = 0 unless defined $rows;
				$rows++;
			}
		}
	} elsif ($command eq 'update') {
		my $values;
		while (defined($values = $cursor->fetch_hashref)) {
			next if defined $wherefn and not
			&{$wherefn}($xbase, $values, $bind_values);
			my %newval;
			@newval{ @{$parsed_sql->{'updatefields'}} } =
			&{$parsed_sql->{'updatefn'}}($xbase, $values,
			$bind_values);
			$xbase->update_record_hash($cursor->last_fetched, %newval);
			$rows = 0 unless defined $rows;
			$rows++;
		}
	} elsif ($command eq 'drop') {
		# dropping the table is really easy
		$xbase->drop or do {
			$sth->DBI::set_err(60, "Dropping table $table failed: "
							. $xbase->errstr);
			return;
		};
		delete $dbh->{'xbase_tables'}{$table};
		$rows = -1;
	}
	
	# finaly, set the number of rows (what if somebody will ask) and
	# return it to curious crowds
	return $sth->DBD::XBase::st::_set_rows($rows);
}



sub fetch {
        my $sth = shift;
	my $retarray;
	if (defined $sth->{'xbase_lines'}) {
		$retarray = shift @{$sth->{'xbase_lines'}};
	} elsif (defined $sth->{'xbase_cursor'}) {
		my $cursor = $sth->{'xbase_cursor'};
		my $wherefn = $sth->{'xbase_parsed_sql'}{'wherefn'};

		my $xbase = $cursor->table;
		my $values;
		while (defined($values = $cursor->fetch_hashref)) {
			### use Data::Dumper; print Dumper $sth->{'xbase_bind_values'};
			next if defined $wherefn and not
			&{$wherefn}($xbase, $values,
					$sth->{'xbase_bind_values'});
			last;
		}
		$retarray = [ &{$sth->{'xbase_parsed_sql'}{'selectfn'}}($xbase, $values, $sth->{'xbase_bind_values'}) ]
			if defined $values;
	}

### use Data::Dumper; print Dumper $retarray;

	return unless defined $retarray;

### print STDERR "sth->{'NUM_OF_FIELDS'}: $sth->{'NUM_OF_FIELDS'} sth->{'NUM_OF_PARAMS'}: $sth->{'NUM_OF_PARAMS'}\n";


	$sth->_set_fbav($retarray); return $retarray;

	my $i = 0;
	for my $ref ( @{$sth->{'xbase_bind_col'}} ) {
		next unless defined $ref;
		$$ref = $retarray->[$i];
	} continue {
		$i++;
	}
	
	return $retarray;
}
*fetchrow_arrayref = \&fetch;

sub FETCH {
	my ($sth, $attrib) = @_;
	my $parsed_sql = $sth->{'xbase_parsed_sql'};
	if ($attrib =~ /^xbase_/) {
		return $sth->{$attrib};
	}
	if ($attrib eq 'NAME') {
		if (defined $sth->{'xbase_nondata_name'}) {
			return $sth->{'xbase_nondata_name'};
		}
		return [ @{$parsed_sql->{'selectnames'}} ];
	} elsif ($attrib eq 'NULLABLE') {
		return [ (1) x scalar(@{$parsed_sql->{'selectnames'}}) ];
	} elsif ($attrib eq 'TYPE') {
		return [ map { ( $REVSQLTYPES{$_} or undef ) }
			map { ( $sth->{'Database'}->{'xbase_tables'}->{$parsed_sql->{'table'}[0]}->field_type($_)  or undef ) }
				@{$parsed_sql->{'selectnames'}} ];
	} elsif ($attrib eq 'PRECISION') {
		return [ map { $sth->{'Database'}->{'xbase_tables'}->{$parsed_sql->{'table'}[0]}->field_length($_) }
			@{$parsed_sql->{'selectnames'}} ];
	} elsif ($attrib eq 'SCALE') {
		return [ map { $sth->{'Database'}->{'xbase_tables'}->{$parsed_sql->{'table'}[0]}->field_decimal($_) }
			@{$parsed_sql->{'selectnames'}} ];
	} elsif ($attrib eq 'ChopBlanks') {
		return $parsed_sql->{'ChopBlanks'};
	} else {
		return $sth->DBD::_::st::FETCH($attrib);
	}
}