DBD-Redbase
view release on metacpan or search on metacpan
$status_update = 0;
$status_error = 1;
$status_data = 2;
$err = 0; #holds error code for DBI::err
$errstr = ""; #holds error string for DBI:errstr
$sqlstate = ""; #holds SQL state for DBI::state
$drh = undef; #holds driver handle once initialized
sub driver($;$)
{
return $drh if defined($drh);
my ($class, $attr) = @_;
$class .= "::dr";
$drh = DBI::_new_drh($class,
{
'Name' => 'Redbase',
'Version' => $VERSION,
return $drh;
}
###############################################################################
# Driver package follows
###############################################################################
package DBD::Redbase::dr; # =========== Driver ==============
$DBD::Redbase::dr::imp_data_size = 0;
sub connect($$;$$$)
{
my ($drh, $dbname, $user, $auth, $attr) = @_;
my $dbh;
my $var;
my $port;
my $host;
my $socket;
my $ds;
$ds->writeUTF($user);
$ds->writeUTF($auth);
#Checking for success or failure is acctually delayed until the first
#Query is executed due to the fact that Redbase does not report status of
#the connection if it's successfull only if it's a failure
return $dbh;
}
sub data_sources($$)
{
return ();
}
sub disconnect_all($)
{
}
###############################################################################
# Database package follows
###############################################################################
package DBD::Redbase::db;
$DBD::Redbase::db::imp_data_size = 0;
sub prepare($$;@)
{
my ($dbh, $statement, @attr) = @_;
my $sth;
$sth = DBI::_new_sth($dbh, {'Statement' => $statement});
if ($sth)
{
$sth->STORE('redbase_params', []);
$sth->STORE('NUM_OF_PARAMS', ($statement =~ tr/?//));
}
return $sth;
}
#XXX retunr error if cannot close socket
sub disconnect($)
{
my ($dbh) = @_;
my $socket;
my $ds;
#Checking if we are in the AutoCommit mode that do a rollback on everything
#That has not been finalized
if (!$dbh->FETCH('AutoCommit'))
{
$dbh->STORE('RaiseError', 0);
$dbh->rollback();
}
$socket = $dbh->FETCH("redbase_socket");
return $socket->close();
}
sub FETCH($$)
{
my ($dbh, $attr) = @_;
if (($attr eq lc($attr)) || ($attr eq 'AutoCommit'))
{
return $dbh->{$attr};
}
else
{
return $dbh->DBD::_::db::FETCH($attr);
}
}
sub STORE($$$)
{
#Special handling required for AutoCommit
my ($dbh, $attr, $value) = @_;
if ($attr eq 'AutoCommit')
{
if($value && !$dbh->FETCH('AutoCommit'))
{
$dbh->do("SET AUTOCOMMIT TRUE");
return 1;
}
else
{
return $dbh->DBD::_::db::STORE($attr, $value);
}
}
#XXX Not implemented yet
sub type_info_all($)
{
my ($dbh) = @_;
}
sub commit($)
{
my ($dbh) = @_;
if ($dbh->FETCH('AutoCommit'))
{
if ($dbh->FETCH('Warn'))
{
warn("Commit ineffective while AutoCommit is on", -1);
}
return 1;
}
else
{
return $dbh->do("COMMIT");
}
}
sub rollback($)
{
my ($dbh) = @_;
if ($dbh->FETCH('AutoCommit'))
{
if ($dbh->FETCH('Warn'))
{
warn("Rollback ineffective while AutoCommit is on", -1);
}
return 0;
}
else
{
return $dbh->do("ROLLBACK");
}
}
sub quote($$;$)
{
my ($dbh, $str, $type) = @_;
if (defined($type) &&
(
$type == DBI::SQL_NUMERIC() ||
$type == DBI::SQL_DECIMAL() ||
$type == DBI::SQL_INTEGER() ||
$type == DBI::SQL_SMALLINT() ||
$type == DBI::SQL_FLOAT() ||
$str =~ s/\r/\\r/sg;
return "'$str'";
}
}
sub DESTROY
{
undef;
}
sub _list_tables($)
{
my ($dbh) = @_;
my $sth;
my @tables = ();
my $row;
$sth = $dbh->prepare("SELECT table_name FROM system_tables");
$sth->execute() || return undef;
for(my $i = 0 ; ;$i++)
2002 => "STRUCT",
2003 => "ARRAY",
2004 => "BLOB",
2005 => "CLOB",
2006 => "REF",
70 => "DATALINK",
16 => "BOOLEAN",
100 => "VARCHAR_IGNORECASE",
};
sub bind_param($$$$)
{
my ($sth, $pNum, $val, $attr) = @_;
my $params;
my $type;
my $dbh;
$type = (ref $attr)?$attr->{TYPE}:$attr;
$dbh = $sth->{Database};
$val = $dbh->quote($val, $type);
$params = $sth->FETCH('redbase_params');
$params->[$pNum - 1] = $val;
return 1;
}
sub execute($@)
{
my ($sth, @bind_values) = @_;
my $statement;
my $params;
my $param_number;
my $dbh;
my $ds;
my $mode;
my $bytes;
}
$sth->{'redbase_data'} = \@data;
$sth->{'redbase_rows'} = @data;
return @data || '0E0';
}
}
sub fetch($)
{
my ($sth) = @_;
my $data;
my $row;
$data = $sth->FETCH('redbase_data');
$row = shift @{$data};
if (!$row)
{
return undef;
if ($sth->FETCH('ChopBlanks'))
{
map { $_ =~ s/\s+$//; } @$row;
}
return $sth->_set_fbav($row);
}
*fetchrow_arrayref = \&fetch;
sub rows($)
{
my ($sth) = @_;
return $sth->FETCH('redbase_rows');
}
sub finish($)
{
my ($sth) = @_;
undef $sth->{'redbase_data'};
undef $sth->{'redbase_rows'};
$sth->DBD::_::st::finish();
return 1;
}
sub FETCH($$)
{
my ($sth, $attr) = @_;
if ($attr eq 'NAME')
{
return $sth->{NAME};
}
elsif ($attr eq 'NULLABLE')
{
return $sth->{NULLABLE};
elsif ($attr eq lc($attr))
{
return $sth->{$attr};
}
else
{
return $sth->DBD::_::st::FETCH($attr);
}
}
sub STORE($$$)
{
my ($sth, $attr, $value) = @_;
if ($attr eq 'NAME')
{
if (defined($sth->{NAME}))
{
$sth->DBI::set_err(4, "NAME attribute of statement handle has already been set!");
return 0;
elsif ($attr eq lc($attr))
{
$sth->{$attr} = $value;
}
else
{
return $sth->DBD::_::st::STORE($attr, $value);
}
}
sub DESTROY($)
{
undef;
}
1;
__END__
Redbase/DataStream.pm view on Meta::CPAN
my $FHOUT;
my $FHIN;
#Resettable bytes counter
my $byte_count;
###############################################################################
# Constructor for DataStream, takes in two arguments input filehandle and
# output file handle
###############################################################################
sub new($$$)
{
my $this = shift();
$FHIN = shift();
$FHOUT = shift();
$byte_count = 0;
my $class = ref($this) || $this;
return bless({}, $class);
}
###############################################################################
# This routine resets the byte counter
###############################################################################
sub resetByteCount()
{
$byte_count = 0;
}
###############################################################################
# This routine is used to query byte counter
###############################################################################
sub getByteCount()
{
return $byte_count;
}
###############################################################################
# The following is public write functions for the object
###############################################################################
sub writeUTF($)
{
my $this = shift;
my $string = _writeUTF(shift);
$FHOUT->print(_writeShort(length($string)));
$FHOUT->print($string);
}
sub writeString($)
{
my $this = shift;
my $string = _writeUTF(shift);
$FHOUT->print(_writeInt(length($string)));
$FHOUT->print($string);
}
sub writeChar($)
{
my $this = shift;
$FHOUT->print(_writeChar(shift()));
}
sub writeBoolean($)
{
my $this = shift;
$FHOUT->print(_writeBoolean(shift()));
}
sub writeByte($)
{
my $this = shift;
$FHOUT->print(_writeByte(shift()));
}
sub writeUnsignedByte($)
{
my $this = shift;
$FHOUT->print(_writeUnsignedByte(shift()));
}
sub writeShort($)
{
my $this = shift;
$FHOUT->print(_writeShort(shift()));
}
sub writeUnsignedShort($)
{
my $this = shift;
$FHOUT->print(_writeUnsignedShort(shift()));
}
sub writeInt($)
{
my $this = shift;
$FHOUT->print(_writeInt(shift()));
}
sub writeLong($)
{
my $this = shift;
$FHOUT->print(_writeLong(shift()));
}
sub writeFloat($)
{
my $this = shift;
$FHOUT->print(_writeFloat(shift()));
}
sub writeDouble($)
{
my $this = shift;
$FHOUT->print(_writeDouble(shift()));
}
sub readUTF($)
{
my $this = shift;
my $bytes_to_read;
my $buf;
$bytes_to_read = $this->readShort();
$FHIN->read($buf, $bytes_to_read);
$byte_count += $bytes_to_read;
return _readUTF($buf);
}
sub readString($)
{
my $this = shift;
my $bytes_to_read;
my $buf;
$bytes_to_read = $this->readInt();
$FHIN->read($buf, $bytes_to_read);
$byte_count += $bytes_to_read;
return _readUTF($buf);
}
sub readChar($)
{
my $this = shift;
my $buf;
$FHIN->read($buf, 2);
$byte_count += 2;
return _readChar($buf);
}
sub readBoolean($)
{
my $this = shift;
my $buf;
$FHIN->read($buf, 1);
$byte_count += 1;
return _readBoolean($buf);
}
sub readByte($)
{
my $this = shift;
my $buf;
$FHIN->read($buf, 1);
$byte_count += 1;
return _readByte($buf);
}
sub readUnsignedByte($)
{
my $this = shift;
my $buf;
$FHIN->read($buf, 1);
$byte_count += 1;
return _readUnsignedByte($buf);
}
sub readShort($)
{
my $this = shift;
my $buf;
$FHIN->read($buf, 2);
$byte_count += 2;
return _readShort($buf);
}
sub readUnsignedShort($)
{
my $this = shift;
my $buf;
$FHIN->read($buf, 2);
$byte_count += 2;
return _readUnsignedShort($buf);
}
sub readInt($)
{
my $this = shift;
my $buf;
$FHIN->read($buf, 4);
$byte_count += 4;
return _readInt($buf);
}
sub readLong($)
{
my $this = shift;
my $buf;
$FHIN->read($buf, 8);
$byte_count += 8;
return _readLong($buf);
}
sub readFloat($)
{
my $this = shift;
my $buf;
$FHIN->read($buf, 4);
$byte_count += 4;
return _readFloat($buf);
}
sub readDouble($)
{
my $this = shift;
my $buf;
$FHIN->read($buf, 8);
$byte_count += 8;
return _readDouble($buf);
}
sub readDate($)
{
my $this = shift;
my $long;
my @time;
$long = $this->readLong();
#Since number is in milliseconds and not seconds
@time = localtime(substr($long, 0, length($long) - 3));
return sprintf("%04d-%02d-%02d", ($time[5] + 1900), ($time[4] + 1), $time[3]);
}
sub readTime($)
{
my $this = shift;
my $long;
my @time;
$long = $this->readLong();
#Since number is in milliseconds and not seconds
@time = localtime(substr($long,0, length($long) - 3));
return sprintf("%02d:%02d:%02d", $time[2], $time[1], $time[0]);
}
sub readTimestamp($)
{
my $this = shift;
my $stamp;
my $nanos;
my @time;
$stamp = $this->readLong();
$nanos = $this->readInt();
#Since number is in milliseconds and not seconds
Redbase/DataStream.pm view on Meta::CPAN
return sprintf("%04d-%02d-%02d %02d:%02d:%02d.%d",
($time[5] + 1900),
($time[4] + 1),
$time[3],
$time[2],
$time[1],
$time[0],
$nanos);
}
sub readByteArray($)
{
my $this = shift;
my $buf;
my $size;
$size = $this->readInt();
$FHIN->read($buf, $size);
$byte_count += $size;
return $buf;
}
sub readDecimal($)
{
my $this = shift;
my $bytes;
my $scale;
return _readDecimal($this->readByteArray(), $this->readInt());
}
###############################################################################
# PRIVATE FUNCTIONS
###############################################################################
###############################################################################
# This function return string compatible with with javas Input/OutputStream
# readUTF method
###############################################################################
sub _writeUTF($)
{
my $unicode_string = utf8(shift());
while ((my $pos = index($unicode_string, "\000")) > -1)
{
$unicode_string = substr($unicode_string, 0, $pos) . chr(192) . chr(128) . substr($unicode_string, $pos + 1);
}
return $unicode_string;
}
###############################################################################
# This method writes binary char compatible with Java
###############################################################################
sub _writeChar($)
{
my $u = new Unicode::String(shift());
my $f = $u->hex();
#Chopping to have only a single char
$f =~ s/ .*$//;
$f =~ s/^U\+/0x/;
return _writeShort(oct($f));
}
###############################################################################
# This method writes binary boolean compatible with Java
###############################################################################
sub _writeBoolean($)
{
my $b = shift();
if ((!defined($b)) || ($b == 0) || ($b =~ /^false$/i))
{
return pack("x");
}
else
{
return pack("C", 0x01);
}
}
###############################################################################
# This method writes binary byte compatible with Java
###############################################################################
sub _writeUnsignedByte($)
{
return _writeByte(shift());
}
###############################################################################
# This method writes binary byte compatible with Java
###############################################################################
sub _writeByte($)
{
my $i = int(shift());
#Chopping integer if too big
if ($i > 0xff)
{
$i = $i & 0xff;
}
return pack("C", $i);
}
###############################################################################
# This method writes binary short compatible with Java
###############################################################################
sub _writeShort($)
{
my $i = int(shift());
#Chopping integer if too big
if ($i > 0xffff)
{
$i = $i & 0xffff;
}
return pack("CC", (($i & 0xff00) >> 8), ($i & 0x00ff));
}
###############################################################################
# This method writes unsigned binary short compatible with Java
###############################################################################
sub _writeUnsignedShort($)
{
return _writeShort(shift());
}
###############################################################################
# This method writes binary int compatible with Java
###############################################################################
sub _writeInt($)
{
my $i = int(shift());
#Chopping integer if too big
if ($i > 0xffffffff)
{
$i = $i & 0xffffffff;
}
return pack("CCCC", (($i & 0xff000000) >> 24), (($i & 0x00ff0000) >> 16), (($i & 0x0000ff00) >> 8), ($i & 0x000000ff));
}
###############################################################################
# This method writes binary long compatible with Java
###############################################################################
sub _writeLong($)
{
my $bvector = Bit::Vector->new_Dec(64, shift());
return pack("B64", $bvector->to_Bin());
}
###############################################################################
# This method writes float number compatible with java and
# IEEE 754 single precision
###############################################################################
sub _writeFloat($)
{
return pack("B32", _convert_to_ieee(shift(), 32));
}
###############################################################################
# This method writes float number compatible with java and
# IEEE 754 single precision
###############################################################################
sub _writeDouble($)
{
return pack("B64", _convert_to_ieee(shift(), 64));
}
###############################################################################
# The following functions support ieee 754 conversion from strings
###############################################################################
sub _convert_to_ieee($$)
{
my $number = shift;
my $size = shift;
my @Result;
my @BinValue;
$FLOATSTATUS = $NORMAL;
if($size == 32)
Redbase/DataStream.pm view on Meta::CPAN
{
return "0000000000000000000000000000000000000000000000000000000000000000";
}
}
else
{
return join ("", @Result);
}
}
sub _dec_2_bin($$$$)
{
my ($number, $size, $BinValue, $Result) = @_;
my $value;
my $intpart;
my $decpart;
my $binexpnt;
my $index1;
my $sign;
my $exp;
my $num;
Redbase/DataStream.pm view on Meta::CPAN
else
{
$BinValue->[$index1] = 0;
}
}
return;
}
sub _convert_2_bin($$)
{
my ($number, $size, $BinValue, $Result) = @_;
my $binexp;
my $i1;
my $i2;
#Find most significant bit of the the mantissa
for($i1 = 0; (($i1 < $CONST) && ($BinValue->[$i1] != 1)); $i1++) {};
$binexp = $BIAS - $i1;
Redbase/DataStream.pm view on Meta::CPAN
{
$binexp = ($binexp - 1) / 2;
}
}
}
###############################################################################
# This function canonizes float of arbitrary length into scientific notation
# of form [+,-][0-9].[0-9]*E[+,-][0-9][0-9][0-9][0-9]+
###############################################################################
sub _canonical($)
{
my $number = shift();
my $sign;
my $exp;
my $mantissa;
my $index;
$number = uc($number); #In case we have exponential notation
if ($number >= 0)
Redbase/DataStream.pm view on Meta::CPAN
$mantissa =~ s/0*$//;
$number = $sign . $mantissa . "E" . sprintf("%05d", $exp);
return $number;
}
###############################################################################
# This method converts Java UTF-8 string into current encoding
###############################################################################
sub _readUTF($)
{
my $unicode_string = utf8(shift());
while ((my $pos = index($unicode_string, chr(192) . chr(128))) > -1)
{
$unicode_string = substr($unicode_string, 0, $pos) . chr(0) . substr($unicode_string, $pos + 2);
}
return $unicode_string->latin1();
}
###############################################################################
# This method reads binary char compatible with Java
###############################################################################
sub _readChar($)
{
return chr(_readShort(shift) & 0x00ff);
}
###############################################################################
# This method reads binary boolean compatible with Java
###############################################################################
sub _readBoolean($)
{
return unpack("C", shift());
}
###############################################################################
# This method reads binary byte compatible with Java
###############################################################################
sub _readByte($)
{
return unpack("c", shift());
}
###############################################################################
# This method reads binary unsigned byte compatible with Java
###############################################################################
sub _readUnsignedByte($)
{
return unpack("C", shift());
}
###############################################################################
# This method reads binary short compatible with Java
###############################################################################
sub _readShort($)
{
my $i = shift;
my $a = unpack("C", substr($i,0,1));
my $b = unpack("C", substr($i,1,1));
#Trick to make perl treat this as signed
return unpack("s", pack("s", (($a << 8) | ($b & 0xff))));
}
###############################################################################
# This method reads binary unsigned short compatible with Java
###############################################################################
sub _readUnsignedShort($)
{
my $i = shift;
return (
((unpack("C", substr($i,0,1)) & 0xff) << 8) |
(unpack("C", substr($i,1,1)) & 0xff))
}
###############################################################################
# This method reads binary int compatible with Java
###############################################################################
sub _readInt($)
{
my $i = shift;
#Trick to make perl treat this as signed
return unpack("i", pack("i", (
((unpack("C", substr($i,1,1)) & 0xff) << 24) |
((unpack("C", substr($i,1,1)) & 0xff) << 16) |
((unpack("C", substr($i,2,1)) & 0xff) << 8) |
(unpack("C", substr($i,3,1)) & 0xff))))
}
###############################################################################
# This method reads binary long compatible with Java
###############################################################################
sub _readLong($)
{
my $input = shift;
my $bvector;
my $bstring;
$bvector = Bit::Vector->new_Bin(64, unpack("B64", $input));
return $bvector->to_Dec();
}
###############################################################################
# This method reads Java's BigDecimal
###############################################################################
sub _readDecimal($$)
{
my $bytes = shift;
my $scale = shift;
my $bin_string;
my $bvector;
my $bvector_scale;
my $decstring;
my $negative = 0;
$bin_string = unpack("B*", $bytes);
Redbase/DataStream.pm view on Meta::CPAN
$decstring = substr($decstring, 0, length($decstring) - $scale) . "." . substr($decstring, length($decstring) - $scale);
$decstring = "-" . $decstring if ($negative);
return $decstring;
}
###############################################################################
# This method reads binary float compatible with Java
###############################################################################
#XXX need to check for positive and negative infinity
sub _readFloat($)
{
my $bitvec = Bit::Vector->new_Bin(32, unpack("B32", shift()));
my $evec = new Bit::Vector(8);
my $mvec = new Bit::Vector(24);
my $s;
my $m;
my $e;
if ($bitvec->bit_test(31))
{
Redbase/DataStream.pm view on Meta::CPAN
}
$m = oct("0x". $mvec->to_Hex());
return $s * $m * pow(2, ($e - 150));
}
###############################################################################
# This method reads binary double compatible with Java
###############################################################################
#XXX need to check for positive and negative infinity
sub _readDouble($)
{
my $bitvec = Bit::Vector->new_Bin(64, unpack("B64", shift()));
my $evec = new Bit::Vector(11);
my $mvec = new Bit::Vector(54);
my $s;
my $m;
my $e;
my $result;
if ($bitvec->bit_test(63))
Redbase/DataStream.pm view on Meta::CPAN
}
else
{
$mvec->Bit_On(52);
}
$m = new Math::BigFloat($mvec->to_Dec());
return $s * $m * big_pow2($e - 1075);
}
sub big_pow2($)
{
my $pow = shift;
my $base = Bit::Vector->new_Dec(2048, 2);
Bit::Vector->Configuration("in=dec,ops=arithmetic,out=dec");
$base **= abs($pow);
$base = new Math::BigFloat($base->to_Dec());
if ($pow < 0)
t/10dsnlist.t view on Meta::CPAN
last;
}
}
if ( $mdriver eq 'pNET' || $mdriver eq 'Adabas' )
{
print "1..0\n";
exit 0;
}
print "Driver is $mdriver\n";
sub ServerError()
{
print STDERR (
"Cannot connect: ",
$DBI::errstr,
"\n",
"\tEither your server is not up and running or you have no\n",
"\tpermissions for acessing the DSN $test_dsn.\n",
"\tThis test requires a running server and write permissions.\n",
"\tPlease make sure your server is running and you have\n",
"\tpermissions, then retry.\n"
t/20createdrop.t view on Meta::CPAN
{
print STDERR "Error while executing lib.pl: $@\n";
exit 10;
}
if ( $mdriver ne '' )
{
last;
}
}
sub ServerError()
{
print STDERR (
"Cannot connect: ",
$DBI::errstr,
"\n",
"\tEither your server is not up and running or you have no\n",
"\tpermissions for acessing the DSN $test_dsn.\n",
"\tThis test requires a running server and write permissions.\n",
"\tPlease make sure your server is running and you have\n",
"\tpermissions, then retry.\n"
t/30insertfetch.t view on Meta::CPAN
{
print STDERR "Error while executing lib.pl: $@\n";
exit 10;
}
if ( $mdriver ne '' )
{
last;
}
}
sub ServerError()
{
print STDERR (
"Cannot connect: ",
$DBI::errstr,
"\n",
"\tEither your server is not up and running or you have no\n",
"\tpermissions for acessing the DSN $test_dsn.\n",
"\tThis test requires a running server and write permissions.\n",
"\tPlease make sure your server is running and you have\n",
"\tpermissions, then retry.\n"
t/40bindparam.t view on Meta::CPAN
{
last;
}
}
if ( $mdriver eq 'pNET' )
{
print "1..0\n";
exit 0;
}
sub ServerError()
{
my $err = $DBI::errstr; # Hate -w ...
print STDERR (
"Cannot connect: ",
$DBI::errstr,
"\n",
"\tEither your server is not up and running or you have no\n",
"\tpermissions for acessing the DSN $test_dsn.\n",
"\tThis test requires a running server and write permissions.\n",
"\tPlease make sure your server is running and you have\n",
t/40listfields.t view on Meta::CPAN
}
if ( $dbdriver ne '' )
{
last;
}
}
@table_def =
( [ "id", "INTEGER", 4, $COL_KEY ], [ "name", "CHAR", 64, $COL_NULLABLE ] );
sub ServerError()
{
print STDERR (
"Cannot connect: ",
$DBI::errstr,
"\n",
"\tEither your server is not up and running or you have no\n",
"\tpermissions for acessing the DSN $test_dsn.\n",
"\tThis test requires a running server and write permissions.\n",
"\tPlease make sure your server is running and you have\n",
"\tpermissions, then retry.\n"
t/40nulls.t view on Meta::CPAN
{
print STDERR "Error while executing lib.pl: $@\n";
exit 10;
}
if ( $mdriver ne '' )
{
last;
}
}
sub ServerError()
{
print STDERR (
"Cannot connect: ",
$DBI::errstr,
"\n",
"\tEither your server is not up and running or you have no\n",
"\tpermissions for acessing the DSN $test_dsn.\n",
"\tThis test requires a running server and write permissions.\n",
"\tPlease make sure your server is running and you have\n",
"\tpermissions, then retry.\n"
t/40numrows.t view on Meta::CPAN
{
print STDERR "Error while executing lib.pl: $@\n";
exit 10;
}
if ( $mdriver ne '' )
{
last;
}
}
sub ServerError()
{
print STDERR (
"Cannot connect: ",
$DBI::errstr,
"\n",
"\tEither your server is not up and running or you have no\n",
"\tpermissions for acessing the DSN $test_dsn.\n",
"\tThis test requires a running server and write permissions.\n",
"\tPlease make sure your server is running and you have\n",
"\tpermissions, then retry.\n"
);
exit 10;
}
sub TrueRows($)
{
my ( $sth ) = @_;
my $count = 0;
while ( $sth->fetchrow_arrayref )
{
++$count;
}
$count;
}
t/50chopblanks.t view on Meta::CPAN
print STDERR "Error while executing lib.pl: $@\n";
exit 10;
}
if ( $mdriver ne '' )
{
last;
}
}
}
sub ServerError()
{
print STDERR (
"Cannot connect: ",
$DBI::errstr,
"\n",
"\tEither your server is not up and running or you have no\n",
"\tpermissions for acessing the DSN $test_dsn.\n",
"\tThis test requires a running server and write permissions.\n",
"\tPlease make sure your server is running and you have\n",
"\tpermissions, then retry.\n"
t/50commit.t view on Meta::CPAN
exit 0;
}
use vars qw($gotWarning);
sub CatchWarning ($)
{
$gotWarning = 1;
}
sub NumRows($$$)
{
my ( $dbh, $table, $num ) = @_;
my ( $sth, $got );
if ( !( $sth = $dbh->prepare( "SELECT * FROM $table" ) ) )
{
return "Failed to prepare: err "
. $dbh->err
. ", errstr "
. $dbh->errstr;
t/Redbase.dbtest view on Meta::CPAN
$keyDef = "";
}
$def = sprintf( "CREATE TABLE %s (%s%s)",
$tablename, join ( ", ", @colDefs ), $keyDef );
}
#
# This function generates a list of tables associated to a
# given DSN.
#
sub ListTables(@)
{
my ( $dbh ) = shift;
my ( @tables );
@tables = $dbh->func( '_list_tables' );
if ( $dbh->errstr )
{
die "Cannot create table list: " . $dbh->errstr;
}
@tables;
t/Redbase.dbtest view on Meta::CPAN
# host.
sub HostDsn ($$)
{
my ( $hostname, $dsn ) = @_;
"$dsn:$hostname";
}
#
# Return a string for checking, whether a given column is NULL.
#
sub IsNull($)
{
my ( $var ) = @_;
"$var IS NULL";
}
#
# Return TRUE, if database supports transactions
#
sub HaveTransactions ()
( run in 0.337 second using v1.01-cache-2.11-cpan-1f129e94a17 )