DBD-Firebird-1.39/0000755000175000017500000000000014743133212011647 5ustar damdamDBD-Firebird-1.39/t/0000755000175000017500000000000014743133212012112 5ustar damdamDBD-Firebird-1.39/t/62-timeout.t0000644000175000017500000000423412247155014014216 0ustar damdam#!/usr/local/bin/perl -w # # # This is a test for Firebird 2.0's wait timeout for ib_set_tx_param(). # use strict; use warnings; use Test::More; use Test::Exception; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ($dbh2, $error_str2) = $T->connect_to_database(); if ($error_str2) { BAIL_OUT("Unknown: $error_str2!"); } unless ( $dbh2->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 15; } ok($dbh2, 'Connected to the database (2)'); # ------- TESTS ------------------------------------------------------------- # SKIP: { my $r = $dbh2->func( -lock_resolution => { 'wait' => 2 }, 'ib_set_tx_param'); defined $r or skip "wait timeout is not available", 12; my ($dbh1, $error_str1) = $T->connect_to_database(); ok($dbh1, 'Connected to the database (1)'); my $table = find_new_table($dbh1); ok($table); { my $def = "CREATE TABLE $table(id INTEGER NOT NULL, cnt INTEGER DEFAULT 0 NOT NULL)"; ok($dbh1->do($def)); } throws_ok { $dbh2->func( -lock_resolution => { 'no_wait' => 2 }, 'ib_set_tx_param' ); } qr/The only valid key is 'wait'/, "try invalid lock resolution"; is($dbh1->{AutoCommit}, 1, "1st tx AutoCommit == 1"); { local $dbh2->{PrintError} = 0; my $stmt = "INSERT INTO $table(id) VALUES(?)"; my $update_stmt = "UPDATE $table SET cnt = cnt+1 WHERE id = ?"; ok($dbh1->do($stmt, undef, 1)); # from now, commit manually local $dbh1->{AutoCommit} = 0; isnt($dbh1->{AutoCommit}, 1, "1st tx AutoCommit == 0"); ok($dbh1->do($update_stmt, undef, 1), "1st tx issues update"); pass("2nd tx issues update (${\scalar localtime()})"); # expected failure after 2 seconds: eval { my $r = $dbh2->do($update_stmt, undef, 1); }; ok($@, "Timeout (${\scalar localtime()})"); ok($dbh1->commit, "1st tx committed"); } ok($dbh2->disconnect); ok($dbh1->do("DROP TABLE $table"), "DROP TABLE $table"); ok($dbh1->disconnect); } # - SKIP {} DBD-Firebird-1.39/t/61-settx.t0000644000175000017500000000712111654054465013705 0ustar damdam#!/usr/bin/perl -w # # # This is a test for ib_set_tx_param() private method. # # 2011-01-29 stefan(s. bv) # New version based on t/testlib.pl and Firebird.dbtest # Note: set_tx_param() is obsoleted by ib_set_tx_param(). # # Transaction behavior default parameter values: # Access mode: read_write # Isolation level: snapshot # Lock resolution: wait use strict; use warnings; use Test::More; use DBI; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ( $dbh1, $error_str1 ) = $T->connect_to_database( { ChopBlanks => 1 } ); if ($error_str1) { BAIL_OUT("Unknown: $error_str1!"); } else { plan tests => 22; } unless ( $dbh1->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } ok($dbh1, 'Connected to the database (1)'); my ( $dbh2, $error_str2 ) = $T->connect_to_database( { ChopBlanks => 1 } ); ok($dbh2, 'Connected to the database (2)'); # DBI->trace(4, "trace.txt"); # ------- TESTS ------------------------------------------------------------- # # # Find a possible new table name # my $table = find_new_table($dbh1); ok($table, "TABLE is '$table'"); # # Create a new table # my $def =<<"DEF"; CREATE TABLE $table ( id INTEGER PRIMARY KEY, name VARCHAR(20) ) DEF ok( $dbh1->do($def), qq{CREATE TABLE '$table'} ); # # Changes transaction params # ok( $dbh1->func( -access_mode => 'read_write', -isolation_level => 'read_committed', -lock_resolution => 'wait', 'ib_set_tx_param' ), 'SET tx param for dbh 1' ); ok( $dbh2->func( -access_mode => 'read_only', -lock_resolution => 'no_wait', 'ib_set_tx_param' ), 'SET tx param for dbh 2' ); SCOPE: { local $dbh1->{AutoCommit} = 0; local $dbh2->{PrintError} = 0; my $insert_stmt = qq{ INSERT INTO $table VALUES(?, 'Yustina') }; my $select_stmt = qq{ SELECT * FROM $table WHERE 1 = 0 }; ok(my $sth2 = $dbh2->prepare($select_stmt), 'PREPARE SELECT'); ok($dbh1->do($insert_stmt, undef, 1), 'DO INSERT (1)'); #- Expected failure ( -access_mode => 'read_only' ) eval { $dbh2->do($insert_stmt, undef, 2); }; ok($@, "DO INSERT (2) Expected failure ('read_only' )"); #- Reading should be ok here ok($sth2->execute, 'EXECUTE sth 2'); ok($sth2->finish, 'FINISH sth 2'); #- Committing the first trans ok($dbh1->commit, 'COMMIT dbh 1'); ok( $dbh1->func( -access_mode => 'read_write', -isolation_level => 'read_committed', -lock_resolution => 'wait', -reserving => { $table => { lock => 'write', access => 'protected', }, }, 'ib_set_tx_param' ), 'CHANGE tx param for dbh 1' ); ok( $dbh2->func( -lock_resolution => 'no_wait', 'ib_set_tx_param' ), 'CHANGE tx param for dbh 2' ); ok($dbh1->do($insert_stmt, undef, 3), 'DO INSERT (2)'); #- Expected failure ( -lock_resolution => 'no_wait' ) eval { $dbh2->do($insert_stmt, undef, 4); }; ok($@, "DO INSERT (3) Expected failure ('no_wait')"); # Committing the first trans ok($dbh1->commit, 'COMMIT dbh 1'); } # # Drop the test table # isa_ok( $dbh1, 'DBI::db' ); isa_ok( $dbh2, 'DBI::db' ); # # Disconnect 2 ok($dbh2->disconnect, 'DISCONNECT 2'); # AutoCommit is on ok( $dbh1->do("DROP TABLE $table"), "DROP TABLE '$table'" ); # # Finally disconnect 1 # ok($dbh1->disconnect, 'DISCONNECT 1'); DBD-Firebird-1.39/t/95-biginteger.t0000644000175000017500000000440311654054465014664 0ustar damdam#!/usr/bin/perl # # 2011-01-31 stefan(s.bv.) Created new test: # Playing with very big | small numbers # Smallest and biggest integer supported by Firebird: # -9223372036854775808, 9223372036854775807 # use strict; use warnings; use Math::BigFloat try => 'GMP'; use Test::More; use DBI; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ($dbh, $error_str) = $T->connect_to_database(); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 12; } ok($dbh, 'Connected to the database'); # DBI->trace(4, "trace.txt"); # ------- TESTS ------------------------------------------------------------- # # Find a new table name my $table = find_new_table($dbh); ok($table, "TABLE is '$table'"); # Create a new table my $def =<<"DEF"; CREATE TABLE $table ( INT_MIN BIGINT, INT_MAX BIGINT ) DEF ok( $dbh->do($def), qq{CREATE TABLE '$table'} ); # Insert some values my $stmt =<<"END_OF_QUERY"; INSERT INTO $table ( INT_MIN, INT_MAX ) VALUES (?, ?) END_OF_QUERY ok(my $insert = $dbh->prepare($stmt), 'PREPARE INSERT'); ok( $insert->execute( '-9223372036854775808', '9223372036854775807' ), 'INSERT MIN | MAX INTEGERS' ); # Expected fetched values my @correct = ( [ '-9223372036854775808', '9223372036854775807' ], ); # Select the values ok( my $cursor = $dbh->prepare( qq{SELECT * FROM $table} ), 'PREPARE SELECT' ); ok($cursor->execute, 'EXECUTE SELECT'); ok((my $res = $cursor->fetchall_arrayref), 'FETCHALL'); my ($types, $names, $fields) = @{$cursor}{qw(TYPE NAME NUM_OF_FIELDS)}; for (my $i = 0; $i < @$res; $i++) { for (my $j = 0; $j < $fields; $j++) { my $result = qq{$res->[$i][$j]}; my $mresult = Math::BigInt->new($result); my $corect = $correct[$i][$j]; my $mcorect = Math::BigInt->new($corect); #ok($mresult->bacmp($mcorect) == 0, , "Field: $names->[$j]"); is($mresult, $mcorect, "Field: $names->[$j]"); # diag "got: $mresult"; # diag "exp: $mcorect"; } } # Drop the test table $dbh->{AutoCommit} = 1; ok( $dbh->do("DROP TABLE $table"), "DROP TABLE '$table'" ); # Finally disconnect. ok($dbh->disconnect(), 'DISCONNECT'); DBD-Firebird-1.39/t/000-check-dependencies.t0000644000175000017500000000023613210350154016270 0ustar damdamuse Test::More 0.94; eval { use Test::CheckDeps 0.007; 1 } or plan skip_all => "Test::CheckDeps 0.007 required"; check_dependencies(); done_testing(); DBD-Firebird-1.39/t/81-event-fork.t0000644000175000017500000000750112777067220014622 0ustar damdam#!/usr/local/bin/perl -w # # use strict; use warnings; use DBI; use Config; use POSIX qw(:signal_h); use Test::More; use lib 't','.'; plan skip_all => 'DBD_FIREBIRD_TEST_SKIP_EVENTS_FORK found in the environment' if $ENV{DBD_FIREBIRD_TEST_SKIP_EVENTS_FORK}; use TestFirebird; my $T = TestFirebird->new; if ( eval{$T->is_embedded} ) { require DBD::FirebirdEmbedded; plan skip_all => 'Only one process can access the database in embedded mode' if DBD::FirebirdEmbedded->fb_api_ver >= 30; } my ($dbh, $error_str) = $T->connect_to_database(); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 17; } ok($dbh, 'Connected to the database'); my $table = find_new_table($dbh); ok($table, qq{Table is '$table'}); # create required test table and triggers { my @ddl = (<<"DDL", <<"DDL", <<"DDL"); CREATE TABLE $table ( id INTEGER NOT NULL, title VARCHAR(255) NOT NULL ); DDL CREATE TRIGGER ins_${table}_trig FOR $table AFTER INSERT POSITION 0 AS BEGIN POST_EVENT 'foo_inserted'; END DDL CREATE TRIGGER del_${table}_trig FOR $table AFTER DELETE POSITION 0 AS BEGIN POST_EVENT 'foo_deleted'; END DDL ok($dbh->do($_)) foreach @ddl; # 3 times } # detect SIGNAL availability my $sig_ok = grep { /HUP$/ } split(/ /, $Config{sig_name}); $dbh->disconnect if $dbh->{ib_embedded}; # try fork { my $how_many = 8; SKIP: { skip "known problems under MSWin32 ActivePerl's emulated fork()", $how_many if $Config{osname} eq 'MSWin32'; skip "SIGHUP is not avalailable", $how_many unless $sig_ok; my $pid = fork; skip "failed to fork", $how_many unless defined $pid; if ($pid) { %::CNT = (); my ($dbh, $error_str) = $T->connect_to_database(); ok($dbh, "Connected: $pid"); my $evh = $dbh->func('foo_inserted', 'foo_deleted', 'ib_init_event'); ok($evh); ok($dbh->func($evh, sub { my $posted_events = shift; while (my ($k, $v) = each %$posted_events) { #diag "Got event $k"; $::CNT{$k} += $v; } 1; }, 'ib_register_callback' ), "Event callback registered"); kill SIGHUP => $pid; is(wait, $pid, "Kid finished"); BAIL_OUT("Kid exit status: $?") unless $? == 0; # then wait until foo_deleted gets posted while (not exists $::CNT{'foo_deleted'}) {} ok($dbh->func($evh, 'ib_cancel_callback')); ok($dbh->disconnect); is($::CNT{'foo_inserted'}, 5, "compare number of inserts"); is($::CNT{'foo_deleted'}, 5, "compare number of deleted rows"); } else { $dbh->{InactiveDestroy} = 1; $|++; $SIG{HUP} = sub { #diag("kid $$ gets sighup\n"); $::SLEEP = 0; }; $::SLEEP = 1; while ($::SLEEP) {} #diag "Kid about to connect"; my ($dbh, $error_str) = $T->connect_to_database({AutoCommit => 1 }); if ($error_str) { #diag "Kid connection error: $error_str"; die; } #diag "Kid connected"; for (1..5) { #diag "Kid about to insert"; $dbh->do(qq{INSERT INTO $table VALUES($_, 'bar')}); #diag "Inserted a row"; } $dbh->do(qq{DELETE FROM $table}); #diag "Deleted all rows"; $dbh->disconnect; #diag "Kid exiting"; exit; } }} ($dbh, $error_str) = $T->connect_to_database() if $dbh->{ib_embedded}; ok($dbh->do(qq(DROP TRIGGER ins_${table}_trig))); ok($dbh->do(qq(DROP TRIGGER del_${table}_trig))); ok($dbh->do(qq(DROP TABLE $table)), "DROP TABLE $table"); ok($dbh->disconnect); DBD-Firebird-1.39/t/TestFirebird.pm0000644000175000017500000002570413210342072015040 0ustar damdampackage TestFirebird; # # Helper file for the DBD::Firebird tests # # 2011-04-01: Created by stefan(s.bv.) # Based on the DBD::InterBase - Makefile.PL script # (2008-01-08 05:29:19Z by edpratomo) # Inspired by the 't/dbdpg_test_setup.pl' script from DBD::Pg. # use strict; use warnings; use Carp; use DBI 1.43; # minimum version for 'parse_dsn' use File::Spec; use File::Basename; use File::Temp; use Test::More; use base 'Exporter'; our @EXPORT = qw(find_new_table); sub import { my $me = shift; $me->export_to_level(1,undef, qw(find_new_table)); } use constant test_conf => 't/tests-setup.tmp.conf'; use constant test_mark => 't/tests-setup.tmp.OK'; use constant dbd => 'DBD::Firebird'; sub new { my $class = shift; my $self = bless {@_}, $class; $self->read_cached_configs; $self->check_credentials; return $self; } sub check_credentials { my $self = shift; unless ( defined $self->{pass} or defined $ENV{DBI_PASS} or defined $ENV{ISC_PASSWORD} ) { plan skip_all => "Neither DBI_PASS nor ISC_PASSWORD present in the environment"; exit 0; # do not fail with CPAN testers } } =head2 read_cached_configs Read the connection parameters from the 'tests-setup.conf' file. =cut sub read_cached_configs { my $self = shift; my $test_conf = $self->test_conf; if (-f $test_conf) { # print "\nReading cached test configuration...\n"; open my $file_fh, '<', $test_conf or croak "Can't open file ", $test_conf, ": $!"; foreach my $line (<$file_fh>) { next if $line =~ m{^#+}; # skip comments my ($key, $val) = split /:=/, $line, 2; chomp $val; $self->{$key} = $val; } close $file_fh; } } =head2 connect_to_database Initialize setting for the connection. Connect to database and return handler. Takes optional parameter for connection attributes. =cut sub connect_to_database { my $self = shift or confess; my $attr = shift; my $error_str = $self->tests_init(); my $dbh; unless ($error_str) { my $default_attr = { RaiseError => 1, PrintError => 0, AutoCommit => 1, ib_enable_utf8 => 1, }; # Merge attributes @{$default_attr}{ keys %{$attr} } = values %{$attr}; # Connect to the database eval { $dbh = DBI->connect( $self->{tdsn}, $self->{user}, $self->{pass}, $default_attr ); }; if ($@) { $error_str .= "Connection error: $@"; } } return ($dbh, $error_str); } =head2 tests_init Read the configurations from the L file, and checks if they are valid. =cut sub tests_init { my $self = shift or confess; my $error_str; if ( $self->check_mark() ) { return undef; } else { $error_str = $self->check_and_set_cached_configs; unless ($error_str) { $error_str = $self->setup_test_database; } } return $error_str; } =head2 check_cached_configs Simply (double)check every value and return what's missing. =cut sub check_and_set_cached_configs { my $self = shift; my $error_str = q{}; # Check user and pass, try the get from ENV if missing defined $self->{user} or $self->{user} = $self->get_user; defined $self->{pass} or $self->{pass} = $self->get_pass; # Check host $self->{host} ||= $self->get_host; # The user can control the test database name and path using the # DBI_DSN environment var. Other option is a default made up dsn $self->{tdsn} = $self->{tdsn} ? $self->check_dsn( $self->{tdsn} ) : $self->get_dsn; $error_str .= $self->{tdsn} ? q{} : q{wrong dsn,}; # The database path $self->{path} = $self->get_path; my (undef, $path, $file) = File::Spec->splitpath($self->{path}); my ($base, $type) = $file =~ /^(.*?)(\.fdb)\z/i; defined $type or $type = ""; # type might be undef when using FIREBIRD_DATABASE # Check database path only if local if ( !$self->{host} or $self->{host} eq 'localhost' ) { $error_str .= "wrong path ($path, base $base)" if $type eq q{.fdb} and $path and not( -d $path and $base ); # if no .fdb extension, then it may be an alias } $self->save_configs; return $error_str; } sub get_user { my $self = shift; return $ENV{DBI_USER} || $ENV{ISC_USER} || q{sysdba}; } sub get_pass { my $self = shift; return defined $ENV{DBI_PASS} ? $ENV{DBI_PASS} : defined $ENV{ISC_PASSWORD} ? $ENV{ISC_PASSWORD} : "masterkey"; } sub get_host { my $self = shift; return q{localhost}; } sub get_charset { my $self = shift; return $self->{charset} || 'UTF8'; } =head2 check_dsn Parse and check the DSN. =cut sub check_dsn { my $self = shift; my $dsn = shift; # Check user provided DSN my ( $scheme, $driver, undef, undef, $driver_dsn ) = DBI->parse_dsn($dsn) or die "Can't parse DBI DSN '$dsn'"; return if $scheme !~ m{dbi}i; # wrong scheme name return if $driver ne q(Firebird); # wrong driver name return if !$driver_dsn; # wrong driver DSN return $dsn; } =head2 get_dsn Make a DSN, using a temporary database in the L dir for tests as default. =cut sub get_dsn { my $self = shift; my $host = $self->{host}; # $path # = 'localhost:' # . File::Spec->catfile( File::Spec->tmpdir(), # 'dbd-fb-testdb.fdb' ); my $db = $ENV{FIREBIRD_DATABASE} || File::Spec->catfile( File::Spec->tmpdir(), 'dbd-fb-testdb.fdb' ); return "dbi:Firebird:db=$db;host=$host;ib_dialect=3;ib_charset=" . $self->get_charset; } =head2 get_path Extract the database path from the dsn. =cut sub get_path { my $self = shift; my $dsn = $self->{tdsn}; my ( $scheme, $driver, undef, undef, $driver_dsn ) = DBI->parse_dsn($dsn) or die "Can't parse DBI DSN '$dsn'"; my @drv_dsn = split /;/, $driver_dsn; ( my $path = $drv_dsn[0] ) =~ s{(db(name)?|database)=}{}; return $path; } =head2 setup_test_database Create the test database if doesn't exists. Check if we can connect, get the dialect as test. =cut sub setup_test_database { my $self = shift; my $have_testdb = $self->check_database; unless ($have_testdb) { $self->create_test_database; # Check again return "Failed to create test database!" unless $have_testdb = $self->check_database; } # Create a mark $self->create_mark; return; } =head2 find_new_table Find and return a non existent table name between TESTAA and TESTZZ. =cut sub find_new_table { my $dbh = shift; my $try_name = 'TESTAA'; my $try_name_quoted = $dbh->quote_identifier($try_name); my %tables = map { uc($_) => undef } $dbh->tables; while (exists $tables{$dbh->quote_identifier($try_name)}) { if (++$try_name gt 'TESTZZ') { diag("Too many test tables cluttering database ($try_name)\n"); exit 255; } } return $try_name; } =head2 save_configs Append the connection parameters to the 'tests-setup.conf' file. =cut sub save_configs { my $self = shift; open my $t_fh, '>>', $self->test_conf or die "Can't write " . $self->test_conf . ": $!"; my $test_time = scalar localtime(); my @record = ( '# Test section: -- (created by ' . __PACKAGE__ . ') #', q(# Time: ) . $test_time, qq(tdsn:=$self->{tdsn}), qq(path:=$self->{path}), qq(user:=$self->{user}), qq(pass:=$self->{pass}), q(# This is a temporary file used for test setup #), ); my $rec = join "\n", @record; print {$t_fh} $rec, "\n"; close $t_fh or die "Can't close " . $self->test_conf . ": $!"; return; } =head2 create_test_database Create the test database. =cut sub create_test_database { my $self = shift; my ( $user, $pass, $path, $host ) = ( $self->{user}, $self->{pass}, $self->{path}, $self->{host} ); $path = "$host:$path" if $host; #- Create test database eval 'require ' . $self->dbd . '; 1' or die $@; diag "Creating test database at $path"; $self->dbd->create_database( { db_path => $path, user => $user, password => $pass, # dialect defaults to 3 character_set => 'UTF8', } ); #-- turn forced writes off $self->dbd->gfix( { db_path => $path, user => $user, password => $pass, forced_writes => 0, } ); return; } =head2 check_database Try to connect and conclude that the database doesn't exist on error. =cut sub check_database { my $self = shift; my ( $user, $pass, $path, $host ) = ( $self->{user}, $self->{pass}, $self->{path}, $self->{host} ); #- Connect to the test database $path = "$host:$path" if $host; print "The databse path is $path\n"; my $driver = $self->dbd; $driver =~ s/^DBD:://; my $dbh = eval { DBI->connect( "dbi:$driver:database=$path", $user, $pass, { RaiseError => 1, PrintError => 0 } ); }; return 0 unless $dbh; # check the dialect my $info = $dbh->func('db_sql_dialect', 'ib_database_info'); $dbh->disconnect; die "Unable to retrieve SQL dialect" unless $info->{db_sql_dialect}; die "Database dialect wrong ($info->{db_sql_dialect})" unless $info->{db_sql_dialect} == 3; return 1; } =head2 create_mark Create empty file used as mark, used to run L only the first time L is called. =cut sub create_mark { my $self = shift; open my $file_fh, '>', $self->test_mark or croak "Can't open file ",$self->test_mark, ": $!"; close $file_fh; return; } =head2 check_mark Check is mark file exists. =cut sub check_mark { my $self = shift; return (-f $self->test_mark); } =head2 drop_test_database Cleanup time, drop the test database, warn on failure or sql errors. =cut sub drop_test_database { my $self = shift; my ( $dbh, $error ) = $self->connect_to_database( { RaiseError => 0 } ); return unless $dbh; # nothing to drop $dbh->func('ib_drop_database') or return 'Error dropping test database'; diag "Test database dropped"; return ''; } =head2 cleanup Cleanup temporary files, warn on failure. =cut sub cleanup { my $self = shift; my @tmp_files = ( $self->test_mark, ); my $unlinked = 0; foreach my $tmp_file (@tmp_files) { print qq{Cleanup $tmp_file }; if (unlink $tmp_file) { $unlinked++; print qq{ done\n}; } else { print qq{could not unlink: $!\n}; } } return 'warning: file cleanup failed.' if $unlinked != scalar @tmp_files; } 1; DBD-Firebird-1.39/t/96-boolean.t0000644000175000017500000000655514622402440014163 0ustar damdam#!/usr/bin/perl use strict; use warnings; use Test::More; use DBI; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ( $dbh, $error_str ) = $T->connect_to_database( { ChopBlanks => 1 } ); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { my $orig_ver = $dbh->func(version => 'ib_database_info')->{version}; (my $ver = $orig_ver) =~ s/.*\bFirebird\s*//; if ($ver =~ /^(\d+)\.(\d+)$/) { if ($1 >= 3) { plan tests => 23; } else { plan skip_all => "Firebird version $1.$2 doesn't support BOOLEAN data type"; } } else { plan skip_all => "Unable to determine Firebird version from '$orig_ver'. Assuming no BOOLEAN support"; } } ok($dbh, 'Connected to the database'); # DBI->trace(4, "trace.txt"); # ------- TESTS ------------------------------------------------------------- # # # Find a possible new table name # my $table = find_new_table($dbh); ok($table, "TABLE is '$table'"); # Expected fetched values # Need to store the decimal precision for 'sprintf' # Prec must also be the same in CREATE TABLE, of course my $expected = { A_BOOLEAN => { test => { 0 => 1, 1 => undef, 2 => 0, 3 => 1, 4 => 1, 5 => 1, 6 => 1, }, }, }; # # Create a new table # my $def =<<"DEF"; CREATE TABLE $table ( a_boolean BOOLEAN ) DEF ok( $dbh->do($def), qq{CREATE TABLE '$table'} ); # # Insert some values # my $stmt =<<"END_OF_QUERY"; INSERT INTO $table ( a_boolean ) VALUES (?) END_OF_QUERY ok(my $insert = $dbh->prepare($stmt), 'PREPARE INSERT'); # Insert positive number ok($insert->execute(1), 'INSERT 1 BOOLEAN VALUE' ); # Insert undef ok($insert->execute(undef), 'INSERT NULL BOOLEAN VALUE' ); # Insert zero number ok($insert->execute(0), 'INSERT ZERO BOOLEAN VALUE' ); # Insert a number greater than 1 (should still be "true") ok($insert->execute(2), 'INSERT "2" BOOLEAN VALUE' ); # Insert negative number (should still be "true") ok($insert->execute(-1), 'INSERT -1 BOOLEAN VALUE' ); # Insert another negative number (should still be "true") ok($insert->execute(-2), 'INSERT -2 BOOLEAN VALUE' ); # Insert positive number ok($insert->execute(1), 'INSERT 1 BOOLEAN VALUE (AGAIN)' ); # # Select the values # ok( my $cursor = $dbh->prepare( qq{SELECT * FROM $table}, ), 'PREPARE SELECT' ); ok($cursor->execute, 'EXECUTE SELECT'); ok((my $res = $cursor->fetchall_arrayref), 'FETCHALL arrayref'); my ($types, $names, $fields) = @{$cursor}{qw(TYPE NAME NUM_OF_FIELDS)}; for (my $i = 0; $i < @$res; $i++) { for (my $j = 0; $j < $fields; $j++) { my $result = $res->[$i][$j]; my $corect = $expected->{$names->[$j]}{test}{$i}; if (defined($corect)) { ok( !($result xor $corect), "Test $i, Field: $names->[$j], value '$res' matches expected '$corect'" ); } else { is($result, $corect, "Test $i, Field: $names->[$j]"); } } } # # Drop the test table # $dbh->{AutoCommit} = 1; ok( $dbh->do("DROP TABLE $table"), "DROP TABLE '$table'" ); # # Finally disconnect. # ok($dbh->disconnect, 'DISCONNECT'); DBD-Firebird-1.39/t/00-base.t0000644000175000017500000000103012600606522013417 0ustar damdam# Test that everything compiles, so the rest of the test suite can # load modules without having to check if it worked. # # 2011-01-29 stefan(s.bv.) # Stolen from DBD::SQLite ;) # use strict; BEGIN { $| = 1; $^W = 1; } use Test::More tests => 7; use_ok('DBI'); use_ok('DBD::Firebird'); use_ok('DBD::Firebird::GetInfo'); use_ok('DBD::Firebird::TableInfo'); use_ok('DBD::Firebird::TableInfo::Basic'); use_ok('DBD::Firebird::TableInfo::Firebird21'); use_ok('DBD::Firebird::TypeInfo'); # diag("\$DBI::VERSION=$DBI::VERSION"); DBD-Firebird-1.39/t/60-leaks.t0000644000175000017500000001256112247154303013627 0ustar damdam#!/usr/local/bin/perl # # # This is a memory leak test. # use strict; use warnings; use utf8; BEGIN { binmode(STDERR, ':utf8'); binmode(STDOUT, ':utf8'); }; my $COUNT_CONNECT = 500; # Number of connect/disconnect iterations my $COUNT_PREPARE = 10000; # Number of prepare/execute/finish iterations my $COUNT_EVENTS = 10000; my $TOTALMEM = 0; use Test::More; use DBI; plan skip_all => "Long fragile memory leak test (try with MEMORY_TEST on linux)\n" unless ( $^O eq 'linux' && $ENV{MEMORY_TEST} ); use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ($dbh, $error_str) = $T->connect_to_database(); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 314 + ($COUNT_EVENTS / 1000 + 1); } ok($dbh, 'Connected to the database'); #DBI->trace(2, "trace.txt"); # # Find a possible new table name # my $table = find_new_table($dbh); ok($table, qq{Table is '$table'}); # # Create a new table # my $def =<<"DEF"; CREATE TABLE $table ( id INTEGER NOT NULL PRIMARY KEY, name CHAR(64) CHARACTER SET ISO8859_1 ) DEF ok( $dbh->do($def), qq{CREATE TABLE '$table'} ); my $ok; #- Testing memory leaks in connect / disconnect $ok = 0; my $nok = 0; for (my $i = 0; $i < $COUNT_CONNECT; $i++) { my ($dbh2, $error_str2) = $T->connect_to_database(); if ($error_str2) { print "Cannot connect: $error_str2"; $ok = 0; last; } $dbh2->disconnect(); undef $dbh2; if ($i == 0) { $ok = check_mem(1); # initialize } elsif ($i % 100 == 99) { $ok = check_mem(); $nok++ unless $ok; ok($ok, "c/d $i"); } } ok($nok == 0, "Memory leak test in connect/disconnect"); #- Testing memory leaks in prepare / execute / finish # Reconnect, if necessary unless ($dbh->ping) { ($dbh, $error_str) = $T->connect_to_database(); ok($dbh, 'reConnected to the database'); } $ok = 0; $nok = 0; for (my $i = 0; $i < $COUNT_PREPARE; $i++) { my $sth = $dbh->prepare("SELECT * FROM $table"); $sth->execute(); $sth->finish(); undef $sth; if ($i % 100 == 99) { $ok = check_mem(); $nok++ unless $ok; ok($ok, "p/e/f $i"); } } ok($nok == 0, "Memory leak test in prepare/execute/finish"); # Testing memory leaks in fetchrow_arrayref # Insert some records into the test table my $row; foreach $row ( [1, 'Jochen Wiedmann'], [2, 'Andreas König'], [3, 'Tim Bunce'], [4, 'Alligator Descartes'], [5, 'Jonathan Leffler'] ) { $dbh->do(sprintf("INSERT INTO $table VALUES (%d, %s)", $row->[0], $dbh->quote($row->[1]))); } $ok = 0; $nok =0; for ( my $i = 0 ; $i < $COUNT_PREPARE ; $i++ ) { { my $sth = $dbh->prepare("SELECT * FROM $table"); $sth->execute(); my $row; while ( $row = $sth->fetchrow_arrayref() ) { } $sth->finish(); } if ( $i % 100 == 99 ) { $ok = check_mem(); $nok++ unless $ok; ok($ok, "f_a $i"); } } ok($nok == 0, "Memory leak test in fetchrow_arrayref"); # Testing memory leaks in fetchrow_hashref $ok = 0; $nok = 0; for (my $i = 0; $i < $COUNT_PREPARE; $i++) { { my $sth = $dbh->prepare("SELECT * FROM $table"); $sth->execute(); my $row; while ($row = $sth->fetchrow_hashref()) { } $sth->finish(); } if ($i % 100 == 99) { $ok = check_mem(); $nok++ unless $ok; ok($ok, "f_h $i"); } } ok($nok == 0, "Memory leak test in fetchrow_hashref"); # Testing memory leaks in ib_event_init $ok = 0; $nok = 0; for (my $i = 0; $i < $COUNT_EVENTS; $i++) { { my $evh = $dbh->func('imaginary_event', 'ib_init_event'); BAIL_OUT ("ib_init_event failed") unless $evh; BAIL_OUT ("event is not a reference") unless ref($evh); BAIL_OUT ("event is an unknown reference ".ref($evh)) unless ref($evh) eq 'DBD::Firebird::Event'; undef($evh); } # allow memory grow after first event object is created # there may be a package stash created, as well as buffer space # these aren't returned to the OS when freed check_mem(1) if $i == 0; if ($i % 1000 == 999) { $ok = check_mem(); $nok++ unless $ok; ok($ok, "i_e $i"); } } ok($nok == 0, "Memory leak test in init_event/destroy"); # # ... and drop it. # ok( $dbh->do(qq{DROP TABLE $table}), qq{DROP TABLE '$table'} ); # # Finally disconnect. # ok( $dbh->disconnect, 'Disconnect' ); #-- Stolen from Matt Sergeant's XML::LibXML's memory.t sub check_mem { my $initialise = shift; # Log Memory Usage local $^W; my %mem; if ( open( FH, "/proc/self/status" ) ) { my $units; while () { if (/^VmSize.*?(\d+)\W*(\w+)$/) { $mem{Total} = $1; $units = $2; } if (/^VmRSS:.*?(\d+)/) { $mem{Resident} = $1; } } close FH; if ( $TOTALMEM != $mem{Total} ) { warn( "LEAK! : ", $mem{Total} - $TOTALMEM, " $units\n" ) unless $initialise; $TOTALMEM = $mem{Total}; return 0; } print( "# Mem Total: $mem{Total} $units, Resident: $mem{Resident} $units\n" ); return 1; } } DBD-Firebird-1.39/t/zz-cleanup.t0000644000175000017500000000052111654054466014400 0ustar damdam#!/usr/bin/perl # # Test for the connection first ... # use strict; use warnings; use Test::More; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; plan tests => 2; pass('clean1'); my $msg1 = $T->drop_test_database(); diag($msg1) if $msg1; #ok(1); pass('clean2'); my $msg2 = $T->cleanup(); diag($msg2) if $msg2; # end DBD-Firebird-1.39/t/dbi-rowcount.t0000644000175000017500000001046711654054465014735 0ustar damdam#/usr/bin/perl # dbi-rowcount.t # # Verify behavior of interfaces which report number of rows affected use strict; use warnings; use Test::More; use DBI; use vars qw($dbh $table); use lib 't'; use TestFirebird; my $T = TestFirebird->new; END { if (defined $dbh and defined $table) { eval { $dbh->do("DROP TABLE $table"); }; } } # is() with special case "zero but true" support sub is_maybe_zbt { my ($value, $expected) = @_; return ($value == $expected) unless $expected == 0; return (($value == 0 and $value)); } # == Test Initialization ========================================= plan tests => 84; ($dbh) = $T->connect_to_database({RaiseError => 1}); pass("connect"); $table = find_new_table($dbh); $dbh->do("CREATE TABLE $table(ID INTEGER NOT NULL, NAME VARCHAR(16) NOT NULL)"); pass("CREATE TABLE $table"); my @TEST_PROGRAM = ( { sql => qq|INSERT INTO $table (ID, NAME) VALUES (1, 'unu')|, desc => 'literal insert', expected => 1, }, { sql => qq|INSERT INTO $table (ID, NAME) VALUES (?, ?)|, desc => 'parameterized insert', params => [2, 'du'], expected => 1, }, { sql => qq|DELETE FROM $table WHERE 1=0|, desc => 'DELETE WHERE (false)', expected => 0, }, { sql => qq|UPDATE $table SET NAME='nomo'|, desc => 'UPDATE all', expected => 2, }, { sql => qq|DELETE FROM $table|, desc => 'DELETE all', expected => 2, }, ); # == Tests == # == 1. do() for my $spec (@TEST_PROGRAM) { my @bind = @{$spec->{params}} if $spec->{params}; my $rv = $dbh->do($spec->{sql}, undef, @bind); ok(is_maybe_zbt($rv, $spec->{expected}), "do($spec->{desc})"); # $DBI::rows is not guaranteed to be correct after $dbh->blah operations } # == 2a. single execute() and rows() for my $spec (@TEST_PROGRAM) { my @bind = @{$spec->{params}} if $spec->{params}; my $sth = $dbh->prepare($spec->{sql}); my $rv = $sth->execute(@bind); ok(is_maybe_zbt($rv, $spec->{expected}), "execute($spec->{desc})"); is($DBI::rows, $spec->{expected}, "execute($spec->{desc}) (\$DBI::rows)"); is($sth->rows, $spec->{expected}, "\$sth->rows($spec->{desc})"); } # == 2b. repeated execute() and rows() { my $i = 0; my $sth = $dbh->prepare("INSERT INTO $table(ID, NAME) VALUES (?, ?)"); for my $name (qw|unu du tri kvar kvin ses sep ok naux dek|) { my $rv = $sth->execute( ++$i, $name ); is( $rv, 1, "re-execute(INSERT one) -> 1" ); is( $DBI::rows, 1, "re-execute(INSERT one) -> 1 (\$DBI::rows)" ); is( $sth->rows, 1, "\$sth->rows(re-executed INSERT)" ); } $sth = $dbh->prepare("DELETE FROM $table WHERE IDexecute($_); is( $rv, 5, "re-execute(DELETE five) -> 1" ); is( $DBI::rows, 5, "re-execute(DELETE five) -> 1 (\$DBI::rows)" ); is( $sth->rows, 5, "\$sth->rows(re-executed DELETE)" ); } my $rv = $sth->execute(16); ok( is_maybe_zbt( $rv, 0 ), "re-execute(DELETE on empty) zero but true" ); is( $DBI::rows, 0, "re-execute(DELETE on empty) (\$DBI::rows) zero but true" ); is( $sth->rows, 0, "\$sth->rows(re-executed DELETE on empty) zero but true" ); } # == 3. special cases # DBD::InterBase tracks the number of FETCHes on a SELECT statement # in $sth->rows() as an extension to the DBI. { my $i = 0; for my $name (qw|unu du tri kvar kvin ses sep ok naux dek|) { $dbh->do( "INSERT INTO $table(ID, NAME) VALUES (?, ?)", undef, ++$i, $name ); } my $sth = $dbh->prepare("SELECT ID, NAME FROM $table"); my $rv = $sth->execute; ok( is_maybe_zbt( $rv, 0 ), "execute(SELECT) -> zero but true" ); is( $DBI::rows, 0, "execute(SELECT) zero but true (\$DBI::rows)" ); is( $sth->rows, 0, "\$sth->rows(SELECT) zero but true" ); my $fetched = 0; while ( $sth->fetch ) { is( ++$fetched, $sth->rows, "\$sth->rows incrementing on SELECT" ); is( $fetched, $DBI::rows, "\$DBI::rows incrementing on SELECT" ); } } DBD-Firebird-1.39/t/51-commit.t0000644000175000017500000000701711654054465014031 0ustar damdam#!/usr/local/bin/perl # # # This is testing the transaction support. # # 2011-01-23 stefan(s.bv.) # New version based on t/testlib.pl and Firebird.dbtest use strict; use warnings; use Test::More; use DBI; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ( $dbh, $error_str ) = $T->connect_to_database( { ChopBlanks => 1, AutoCommit => 1 } ); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } else { plan tests => 30; } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } ok($dbh, 'Connected to the database'); # DBI->trace(4, "trace.txt"); # ------- TESTS ------------------------------------------------------------- # # # Find a possible new table name # my $table = find_new_table($dbh); ok($table, "TABLE is '$table'"); use vars qw($gotWarning); sub CatchWarning ($) { $gotWarning = 1; } # # Create a new table # my $def =<<"DEF"; CREATE TABLE $table ( id INTEGER PRIMARY KEY, name CHAR(64) ) DEF ok( $dbh->do($def), qq{CREATE TABLE '$table'} ); ok($dbh->{AutoCommit}, 'AutoCommit is on'); #- Turn AutoCommit off $dbh->{AutoCommit} = 0; ok(! $dbh->{AutoCommit}, 'AutoCommit is off'); #-- Check rollback ok($dbh->do("INSERT INTO $table VALUES (1, 'Jochen')"), 'INSERT 1'); is(NumRows($dbh, $table), 1, 'CHECK rows'); ok($dbh->rollback, 'ROLLBACK'); is(NumRows($dbh, $table), 0, 'CHECK rows'); #-- Check commit ok($dbh->do("DELETE FROM $table WHERE id = 1"), 'DELETE id=1'); is(NumRows($dbh, $table), 0, 'CHECK rows'); ok($dbh->commit, 'COMMIT'); is(NumRows($dbh, $table), 0, 'CHECK rows'); #-- Check auto rollback after disconnect ok($dbh->do("INSERT INTO $table VALUES (1, 'Jochen')"), 'INSERT 1'); is(NumRows($dbh, $table), 1, 'CHECK rows'); ok($dbh->disconnect, 'DISCONNECT for auto rollback'); #--- Reconnect ( $dbh, $error_str ) = $T->connect_to_database( { ChopBlanks => 1 } ); ok($dbh, 'reConnected to the database'); is(NumRows($dbh, $table), 0, 'CHECK rows'); #--- Check whether AutoCommit is on again ok($dbh->{AutoCommit}, 'AutoCommit is on'); #-- Check whether AutoCommit mode works. ok($dbh->do("INSERT INTO $table VALUES (1, 'Jochen')"), 'INSERT 1'); is(NumRows($dbh, $table), 1, 'CHECK rows'); ok($dbh->disconnect, 'DISCONNECT for auto commit'); #--- Reconnect ( $dbh, $error_str ) = $T->connect_to_database( { ChopBlanks => 1 } ); ok($dbh, 'reConnected to the database'); is(NumRows($dbh, $table), 1, 'CHECK rows'); #-- Check whether commit issues a warning in AutoCommit mode ok($dbh->do("INSERT INTO $table VALUES (2, 'Tim')"), 'INSERT 2'); my $result; $@ = ''; $SIG{__WARN__} = \&CatchWarning; $gotWarning = 0; eval { $result = $dbh->commit; }; $SIG{__WARN__} = 'DEFAULT'; ok($gotWarning, 'GOT WARNING'); # Check whether rollback issues a warning in AutoCommit mode # We accept error messages as being legal, because the DBI # requirement of just issueing a warning seems scary. ok($dbh->do("INSERT INTO $table VALUES (3, 'Alligator')"), 'INSERT 3'); $@ = ''; $SIG{__WARN__} = \&CatchWarning; $gotWarning = 0; eval { $result = $dbh->rollback; }; $SIG{__WARN__} = 'DEFAULT'; ok($gotWarning, 'GOT WARNING'); # # Drop the test table # $dbh->{AutoCommit} = 1; ok( $dbh->do("DROP TABLE $table"), "DROP TABLE '$table'" ); # # Finally disconnect. # ok($dbh->disconnect, 'DISCONNECT'); sub NumRows { my($dbh, $table) = @_; my $sth = $dbh->prepare( qq{SELECT * FROM $table} ); $sth->execute; my $got = 0; while ($sth->fetchrow_arrayref) { $got++; } return $got; } DBD-Firebird-1.39/t/75-utf8.t0000644000175000017500000000736112213026607013424 0ustar damdam#!/usr/bin/perl # # Test the ib_enable_utf8 attribute # use strict; use warnings; use utf8; BEGIN { binmode(STDERR, ':utf8'); binmode(STDOUT, ':utf8'); }; use Test::More; use lib 't','.'; use Encode qw(encode_utf8); use TestFirebird; my $T = TestFirebird->new; eval "use Test::Exception; 1" or plan skip_all => 'Test::Exception needed for this test'; plan tests => 37; # first connect with charset ASCII my $dsn = $T->{tdsn}; $dsn =~ s/(?<=ib_charset=)[^;]+/ASCII/; my $attr = { RaiseError => 1, PrintError => 0, AutoCommit => 1, ChopBlanks => 1 }; my $dbh = DBI->connect( $dsn, $T->{user}, $T->{pass}, $attr ); # …and try to turn on ib_enable_utf8 (should fail) dies_ok( sub { $dbh->{ib_enable_utf8} = 1 }, 'Setting ib_enable_utf8 on charset ASCII db throws'); $dbh->disconnect; # now connect with UTF8 charset $dsn =~ s/(?<=ib_charset=)[^;]+/UTF8/; $dbh = DBI->connect( $dsn, $T->{user}, $T->{pass}, $attr ); # …and try to set ib_enable_utf8 again ok( $dbh->{ib_enable_utf8} = 1, 'Set ib_enable_utf8' ); ok( $dbh->{ib_enable_utf8}, 'Get ib_enable_utf8' ); # ------- TESTS ------------------------------------------------------------- # # # Find a possible new table name # my $table = find_new_table($dbh); ok($table, qq{Table is '$table'}); # # Create a new table # my $def =<<"DEF"; CREATE TABLE $table ( id INTEGER PRIMARY KEY, varchr VARCHAR(20) CHARACTER SET UTF8, chr CHAR(20) CHARACTER SET UTF8, blb BLOB SUB_TYPE TEXT CHARACTER SET UTF8 ) DEF ok( $dbh->do($def), qq{CREATE TABLE '$table'} ); # # Insert a row into the test table as raw SQL # ok( $dbh->do(qq{INSERT INTO $table VALUES (1, 'ASCII varchar', 'ASCII char', 'ASCII blob')}) ); # # Now, see if selected data is plain ASCII as it should be # ok( my $cursor = $dbh->prepare("SELECT * FROM $table WHERE id = ?"), 'SELECT' ); ok( $cursor->execute(1) ); my $row = $cursor->fetchrow_arrayref; $cursor->finish; ok( !utf8::is_utf8($row->[0]), 'ASCII varchar' ); ok( !utf8::is_utf8($row->[1]), 'ASCII char' ); ok( !utf8::is_utf8($row->[2]), 'ASCII blob' ); # # Insert with binding, still ASCII # ok( $dbh->do( "INSERT INTO $table VALUES (2, ?, ?, ?)", {}, 'Still plain varchar', 'Still plain char', 'Still plain blob' ) ); ok( $cursor->execute(2) ); $row = $cursor->fetchrow_arrayref; $cursor->finish; is( $row->[0], 2 ); is( $row->[1], 'Still plain varchar' ); is( $row->[2], 'Still plain char' ); is( $row->[3], 'Still plain blob' ); # # Insert UTF8, embedded # ok( $dbh->do( "INSERT INTO $table VALUES(3, 'Værчàr', 'Tæst', '€÷∞')") ); ok( $cursor->execute(3) ); $row = $cursor->fetchrow_arrayref; $cursor->finish; is( $row->[0], 3 ); is( $row->[1], 'Værчàr' ); is( $row->[2], 'Tæst' ); is( $row->[3], '€÷∞', 'inline unicode blob' ); # # Insert UTF8, binding # ok( $dbh->do( "INSERT INTO $table VALUES(4, ?, ?, ?)", {}, 'Værчàr', 'Tæst', '€÷∞' ) ); ok( $cursor->execute(4) ); $row = $cursor->fetchrow_arrayref; $cursor->finish; is( $row->[0], 4 ); is( $row->[1], 'Værчàr' ); is( $row->[2], 'Tæst' ); is( $row->[3], '€÷∞', 'bound unicode blob' ); # # Now turn off unicode support. things we fetch should not be flagged as # unicode anymore # $dbh->{ib_enable_utf8} = 0; ok( !$dbh->{ib_enable_utf8}, 'Turn off ib_enable_utf8' ); ok( $cursor->execute(4) ); $row = $cursor->fetchrow_arrayref; $cursor->finish; is( $row->[0], 4 ); is( $row->[1], encode_utf8('Værчàr'), 'non-unicode varchar' ); is( $row->[2], encode_utf8('Tæst'), 'non-unicode char' ); is( $row->[3], encode_utf8('€÷∞'), 'non-unicode blob' ); # # ... and drop it. # ok($dbh->do("DROP TABLE $table"), "DROP TABLE '$table'"); # # Finally disconnect. # ok($dbh->disconnect()); DBD-Firebird-1.39/t/47-nulls.t0000644000175000017500000000416511654054465013704 0ustar damdam#!/usr/local/bin/perl # # # This is a test for correctly handling NULL values. # # 2011-01-29 stefansbv # New version based on t/testlib.pl and Firebird.dbtest use strict; use warnings; use Test::More; use Test::Exception; use DBI; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ( $dbh, $error_str ) = $T->connect_to_database( { ChopBlanks => 1 } ); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 14; } ok($dbh, 'Connected to the database'); # DBI->trace(4, "trace.txt"); # ------- TESTS ------------------------------------------------------------- # # # Find a possible new table name # my $table = find_new_table($dbh); ok($table, "TABLE is '$table'"); # # Create a new table # my $def =<<"DEF"; CREATE TABLE $table ( id INTEGER, name CHAR(64) ) DEF ok( $dbh->do($def), qq{CREATE TABLE '$table'} ); # # Test whether or not a field containing a NULL is returned correctly # as undef, or something much more bizarre # my $sql_insert = qq{INSERT INTO $table VALUES ( NULL, 'NULL-valued id' )}; ok( $dbh->do($sql_insert), 'DO INSERT' ); my $sql_sele = qq{SELECT * FROM $table WHERE id IS NULL}; ok( my $cursor = $dbh->prepare($sql_sele), 'PREPARE SELECT' ); ok($cursor->execute, 'EXECUTE SELECT'); ok(my $rv = $cursor->fetchrow_arrayref, 'FETCHROW'); is($$rv[0], undef, 'UNDEFINED id'); is($$rv[1], 'NULL-valued id', 'DEFINED name'); ok($cursor->finish, 'FINISH'); # # Test whether inserting NULL in a non-null field fails # my $table2 = find_new_table($dbh); $dbh->do("CREATE table $table2(id integer not null)"); my $sth = $dbh->prepare("INSERT INTO $table2 VALUES(?)"); throws_ok { $sth->execute(undef) } qr/^DBD::Firebird::st execute failed: You have not provided a value for non-nullable parameter #0\./; # # Drop the test table # $dbh->{AutoCommit} = 1; ok( $dbh->do("DROP TABLE $table"), "DROP TABLE '$table'" ); ok( $dbh->do("DROP TABLE $table2"), "DROP TABLE '$table2'" ); # # Finally disconnect. # ok($dbh->disconnect(), 'DISCONNECT'); DBD-Firebird-1.39/t/93-bigdecimal.t0000644000175000017500000000450613141167125014616 0ustar damdam#!/usr/bin/perl # # 2011-01-31 stefan(s.bv.) Created new test: # Playing with very big | small numbers # Smallest and biggest decimal supported by Firebird: # -922337203685477.5808, 922337203685477.5807 # # Look at bigdecimal_read.t for a variant that uses plain do() without # parameters for the insertion of the values. # use strict; use warnings; use Math::BigFloat try => 'GMP'; use Test::More; use DBI; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ($dbh, $error_str) = $T->connect_to_database(); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 21; } ok($dbh, 'Connected to the database'); # ------- TESTS ------------------------------------------------------------- # # Find a new table name my $table = find_new_table($dbh); ok($table, "TABLE is '$table'"); # Create a new table my $def =<<"DEF"; CREATE TABLE $table ( DEC_MIN DECIMAL(18,4), DEC_MAX DECIMAL(18,4) ) DEF ok( $dbh->do($def), qq{CREATE TABLE '$table'} ); # Expected fetched values my @correct = ( [ '-922337203685477.5808', '922337203685477.5807' ], [ '-0.3', '0.3' ], [ '-0.6', '0.6' ], [ '-0.5', '0.5' ], ); # Insert some values my $stmt =<<"END_OF_QUERY"; INSERT INTO $table ( DEC_MIN, DEC_MAX) VALUES (?, ?) END_OF_QUERY ok(my $insert = $dbh->prepare($stmt), 'PREPARE INSERT'); ok( $insert->execute(@$_), "INSERT '$_->[0]', '$_->[1]'" ) for @correct; # Select the values ok( my $cursor = $dbh->prepare( qq{SELECT * FROM $table} ), 'PREPARE SELECT' ); ok($cursor->execute, 'EXECUTE SELECT'); ok((my $res = $cursor->fetchall_arrayref), 'FETCHALL'); my ($types, $names, $fields) = @{$cursor}{qw(TYPE NAME NUM_OF_FIELDS)}; for (my $i = 0; $i < @$res; $i++) { for (my $j = 0; $j < $fields; $j++) { my $result = qq{$res->[$i][$j]}; my $mresult = Math::BigFloat->new($result); my $corect = $correct[$i][$j]; my $mcorect = Math::BigFloat->new($corect); is($mresult, $mcorect, "Field: $names->[$j]"); # diag "got: $mresult"; # diag "exp: $mcorect"; } } # Drop the test table $dbh->{AutoCommit} = 1; ok( $dbh->do("DROP TABLE $table"), "DROP TABLE '$table'" ); # Finally disconnect. ok($dbh->disconnect(), 'DISCONNECT'); DBD-Firebird-1.39/t/43-cursor.t0000644000175000017500000000445112457761155014061 0ustar damdam#!/usr/local/bin/perl # # # This is a test for CursorName attribute. # # 2011-01-29 stefansbv # New version based on t/testlib.pl and Firebird.dbtest use strict; use warnings; use Test::More; use DBI qw(:sql_types); use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ( $dbh, $error_str ) = $T->connect_to_database( { ChopBlanks => 1 } ); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 27; } ok($dbh, 'Connected to the database'); # DBI->trace(4, "trace.txt"); # ------- TESTS ------------------------------------------------------------- # # # Find a possible new table name # my $table = find_new_table($dbh); ok($table, "TABLE is '$table'"); my $def = qq{ CREATE TABLE $table (user_id INTEGER, comment VARCHAR(20)) }; my %values = ( 1 => 'Lazy', 2 => 'Hubris', 6 => 'Impatience', ); ok($dbh->do($def), "CREATE TABLE '$table'"); my $sql_insert = qq{INSERT INTO $table VALUES (?, ?)}; ok(my $cursor = $dbh->prepare($sql_insert), 'PREPARE INSERT'); ok($cursor->execute($_, $values{$_}), "INSERT id $_") for (keys %values); $dbh->{AutoCommit} = 0; ok (my $sth = $dbh->prepare("select comment from $table where user_id = ?"),"STH"); foreach my $id (sort keys %values) { ok($sth->execute($id),"Excute for $id"); ok(my($c)=$sth->fetchrow_array(),"Fetch for $id"); is($c,$values{$id},"Comment for $id"); } my $sql_sele = qq{SELECT * FROM $table WHERE user_id < 5 FOR UPDATE OF comment}; ok(my $cursor2 = $dbh->prepare($sql_sele), 'PREPARE SELECT'); ok($cursor2->execute, 'EXCUTE SELECT'); # Before.. while (my @res = $cursor2->fetchrow_array) { ok($dbh->do( "UPDATE $table SET comment = 'Zzzzz...' WHERE CURRENT OF $cursor2->{CursorName}"), "DO UPDATE where cursor name is '$cursor2->{CursorName}'" ); } ok(my $cursor3 = $dbh->prepare( "SELECT * FROM $table WHERE user_id < 5"), 'PREPARE SELECT'); ok($cursor3->execute, 'EXECUTE SELECT'); # After.. while (my @res = $cursor3->fetchrow_array) { is($res[1], 'Zzzzz...', 'FETCHROW result check'); } ok($dbh->commit, 'COMMIT'); # # Drop the test table # $dbh->{AutoCommit} = 1; ok( $dbh->do("DROP TABLE $table"), "DROP TABLE '$table'" ); DBD-Firebird-1.39/t/46-listfields.t0000644000175000017500000000355711654054465014714 0ustar damdam#!/usr/local/bin/perl # # # This is a test for statement attributes being present appropriately. # # 2011-01-29 stefansbv # New version based on t/testlib.pl and Firebird.dbtest use strict; use warnings; use Test::More; use DBI qw(:sql_types); use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ( $dbh, $error_str ) = $T->connect_to_database( { ChopBlanks => 1 } ); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 15; } ok($dbh, 'Connected to the database'); # DBI->trace(4, "trace.txt"); # ------- TESTS ------------------------------------------------------------- # # # Find a possible new table name # my $table = find_new_table($dbh); ok($table, "TABLE is '$table'"); # # Create a new table # my $def =<<"DEF"; CREATE TABLE $table ( id INTEGER PRIMARY KEY, name VARCHAR(64) ) DEF ok($dbh->do($def), "CREATE TABLE $table"); my $sql_sele = qq{SELECT * FROM $table}; ok( my $cursor = $dbh->prepare($sql_sele), 'PREPARE SELECT' ); ok($cursor->execute, 'EXECUTE SELECT'); my ($types, $names, $fields, $nullable) = @{$cursor}{qw(TYPE NAME NUM_OF_FIELDS NULLABLE)}; is( $fields, 2, 'CHECK FIELDS NUMBER' ); # 2 fields is( $names->[0], 'ID', 'CHECK NAME for field 1' ); # id is( $names->[1], 'NAME', 'CHECK NAME for field 1' ); # name is( $nullable->[0], q{}, 'CHECK NULLABLE for field 1' ); # id is( $nullable->[1], 1, 'CHECK NULLABLE for field 2' ); # name is( $types->[0], SQL_INTEGER, 'CHECK TYPE for field 1' ); # id is( $types->[1], SQL_VARCHAR, 'CHECK TYPE for field 2' ); # name ok($cursor->finish, 'FINISH'); # # Drop the test table # ok($dbh->do("DROP TABLE $table"), "DROP TABLE '$table'"); # # Finally disconnect. # ok($dbh->disconnect, 'DISCONNECT'); DBD-Firebird-1.39/t/31-prepare_cached.t0000644000175000017500000000546411654054465015470 0ustar damdam#!/usr/bin/perl # test for prepare_cached() use strict; use warnings; use Test::More; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ($dbh, $error_str) = $T->connect_to_database(); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 37; } ok($dbh, 'Connected to the database'); # ------- TESTS ------------------------------------------------------------- # # # Find a possible new table name # my $table = find_new_table($dbh); ok($table, qq{Table is '$table'}); { my $def = "CREATE TABLE $table (id INTEGER NOT NULL, PRIMARY KEY(id))"; ok($dbh->do($def)); my $stmt = "INSERT INTO $table (id) VALUES(?)"; ok($dbh->do($stmt, undef, 1)); } my $prepare_sub = sub { $dbh->prepare(shift), "prepare" }; SKIP: { skip("prepare() tests", 10) if $ENV{SKIP_PREPARE}; simple_query($dbh, $prepare_sub); faulty_query($dbh, $prepare_sub); simple_query($dbh, $prepare_sub); } TEST_CACHED: { $prepare_sub = sub { $dbh->prepare_cached(shift), "prepare_cached" }; my ($query, $n_cached); $query = simple_query($dbh, $prepare_sub); for (values %{$dbh->{CachedKids}}) { $n_cached++ if $_->{Statement} eq $query; } is($n_cached, 1, qq{cached "$query"}); $dbh->commit() unless $dbh->{AutoCommit}; # print Dumper $dbh->{CachedKids} unless $dbh->{AutoCommit}; # $k = faulty_query($dbh, $mode); # ok($dbh->{CachedKids}{$k}, qq{cached "$k"}); # $dbh->rollback() unless $dbh->{AutoCommit}; $query = simple_query($dbh, $prepare_sub); is(scalar keys(%{$dbh->{CachedKids}}), 1); # clear cached sth %{$dbh->{CachedKids}} = (); # wrong: # $dbh->{CachedKids} = undef; # repeat with AutoCommit off if ($dbh->{AutoCommit}) { $dbh->{AutoCommit} = 0; pass("AutoCommit is now turned Off"); goto TEST_CACHED; } else { $dbh->{AutoCommit} = 1; last TEST_CACHED; } } ok($dbh->do("DROP TABLE $table"), "DROP TABLE $table"); ok($dbh->disconnect); # 4 tests sub simple_query { my ($dbh, $prepare_sub) = @_; my $sql = "SELECT id FROM $table"; my ($sth, $mode) = $prepare_sub->($sql); ok($sth, "$mode() for SELECT"); ok(defined($sth->execute()), "execute()"); # print "Active? ", $sth->{Active}, "\n"; my $r = $sth->fetchall_arrayref; is($r->[0][0], 1, "check fetch result"); is($sth->err, undef, "fetch all result set"); return $sql; } # 2 tests sub faulty_query { my ($dbh, $prepare_sub) = @_; my $sql = "INSERT INTO $table VALUES(?)"; my ($sth, $mode) = $prepare_sub->($sql); ok($sth, "$mode() for INSERT"); eval { $sth->execute(1) }; ok ($@, 'expected INSERT failure'); return $sql; } DBD-Firebird-1.39/t/rt55244.t0000644000175000017500000000173711654054466013353 0ustar damdam#!/usr/bin/perl -w # test for https://rt.cpan.org/Public/Bug/Display.html?id=55244 use strict; use warnings; use Test::More; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ( $dbh, $error_str ) = $T->connect_to_database( { AutoCommit => 0, RaiseError => 1 } ); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 6; } ok($dbh, 'Connected to the database'); my $table = find_new_table($dbh); ok( $dbh->do("CREATE TABLE $table(i INTEGER NOT NULL)"), 'table $table created' ); $dbh->commit; my $insert_sql = "INSERT INTO $table(i) VALUES(42)"; my $sth = $dbh->prepare_cached($insert_sql); ok( $sth->execute ); $dbh->rollback; $sth = $dbh->prepare_cached($insert_sql); ok( $sth->execute(), 'cached statement execues after rollback' ); ok( $dbh->do("DROP TABLE $table") ); $dbh->commit; ok( $dbh->disconnect ); DBD-Firebird-1.39/t/TestFirebirdEmbedded.pm0000644000175000017500000000515313210342072016446 0ustar damdampackage TestFirebirdEmbedded; # # Helper file for the DBD::FirebirdEmbedded tests # use strict; use warnings; use Carp; use DBI 1.43; # minimum version for 'parse_dsn' use File::Spec; use File::Basename; use File::Path qw(remove_tree); use File::Temp qw(tempdir); use Test::More; use base qw(Exporter TestFirebird); our @EXPORT = qw(find_new_table); sub import { my $me = shift; TestFirebird->import; $me->export_to_level(1,undef, qw(find_new_table)); } use constant is_embedded => 1; use constant dbd => 'DBD::FirebirdEmbedded'; use DBD::FirebirdEmbedded; sub check_credentials { # this is embedded, nothing to check, we don't need credentials } sub read_cached_configs { my $self = shift; $self->SUPER::read_cached_configs; unless ($self->{firebird_lock_dir}) { my $dir = tempdir( 'dbd-fb.XXXXXXXX', CLEANUP => 0, TMPDIR => 1 ); note "created $dir\n"; open( my $fh, '>>', $self->test_conf ) or die "Unable to open " . $self->test_conf . " for appending: $!"; print $fh qq(firebird_lock_dir:=$dir\n); close($fh) or die "Error closing " . $self->test_conf . ": $!\n"; $self->{firebird_lock_dir} = $dir; } # this is embedded, no server involved $ENV{FIREBIRD_LOCK} = $self->{firebird_lock_dir}; # no authentication either delete $ENV{ISC_USER}; delete $ENV{ISC_PASSWORD}; delete $ENV{DBI_USER}; delete $ENV{DBI_PASS}; delete $self->{user}; delete $self->{pass}; delete $self->{host}; if (DBD::FirebirdEmbedded->fb_api_ver >= 30) { $self->{user} = 'SYSDBA'; $self->{pass} = 'any'; } $self->{tdsn} = $self->get_dsn; $self->{path} = $self->get_path; } sub save_configs { # do nothing as we don't want embedded testing to fiddle with the # carefuly created configs # embedded overrides are implanted already } sub get_dsn { my $self = shift; return join( ';', "dbi:FirebirdEmbedded:db=" . $self->get_path, "ib_dialect=3", 'ib_charset=' . $self->get_charset ); } sub check_dsn { return shift->get_dsn; } sub get_path { my $self = shift; return File::Spec->catfile( $self->{firebird_lock_dir}, 'dbd-firebird-test.fdb' ); } # no authentication for embedded sub get_user { undef } sub get_pass { undef } sub get_host { undef } sub check_mark { my $self = shift; # mimic first run if the test database is not present -f $self->get_path; } sub cleanup { my $self = shift; remove_tree( $self->{firebird_lock_dir}, { verbose => 1, safe => 1 } ); return $self->SUPER::cleanup; } 1; DBD-Firebird-1.39/t/40-alltypes.t0000644000175000017500000001007514622402061014355 0ustar damdam#!/usr/bin/perl # # # This is a test for all data types handling. # # 2011-01-23 stefansbv # New version based on testlib and Firebird.dbtest # NOW and TOMORROW tests replaced with simple TIME and DATE tests # there is a separate test for them anyway use strict; use warnings; use Test::More; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ($dbh, $error_str) = $T->connect_to_database(); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } my $boolean_support = 0; unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { my $orig_ver = $dbh->func(version => 'ib_database_info')->{version}; (my $ver = $orig_ver) =~ s/.*\bFirebird\s*//; if ($ver =~ /^(\d+)\.(\d+)$/) { $boolean_support = ($1 >= 3 and DBD::Firebird->client_major_version >= 3); } else { diag "Unable to determine Firebird version from '$orig_ver'"; diag "Assuming no BOOLEAN data type support"; } plan tests => 32 + $boolean_support; } ok($dbh, 'Connected to the database'); # ------- TESTS ------------------------------------------------------------- # my %expected = ( VALUES => [ 30000, 1000, 'Edwin ', 'Edwin Pratomo ', 'A string', 5000, 1.125, 1.25, '2011-01-23 17:14', '2011-01-23', '17:14', 32.71, -32.71, 123456.79, -123456.79, '86753090000.868', ], TYPE => [ 4,5,1,1,12,4,6,8,11,9,10,5,5,4,4,-5, ], SCALE => [ 0,0,0,0,0,0,0,0,0,0,0,-3,-3,-3,-3,-3, ], PRECISION => [ 4,2,52,80,52,4,4,8,8,4,4,2,2,4,4,8, ] ); my $def = <<"DEF"; INTEGER_ INTEGER, SMALLINT_ SMALLINT, CHAR13_ CHAR(13), CHAR20_ CHAR(20), VARCHAR13_ VARCHAR(13), DECIMAL_ DECIMAL, FLOAT_ FLOAT, DOUBLE_ DOUBLE PRECISION, A_TIMESTAMP TIMESTAMP, A_DATE DATE, A_TIME TIME, NUMERIC_AS_SMALLINT NUMERIC(4,3), NUMERIC_AS_SMALLINT2 NUMERIC(4,3), NUMERIC_AS_INTEGER NUMERIC(9,3), NUMERIC_AS_INTEGER2 NUMERIC(9,3), A_SIXTYFOUR NUMERIC(18,3) DEF if ($boolean_support) { push @{$expected{VALUES}}, 1; push @{$expected{TYPE}}, 16; push @{$expected{SCALE}}, 0; push @{$expected{PRECISION}}, 1; $def =~ s/[\r\n]+$/,\n/; $def .= < $def) { my ($f, $d) = m/^\s*(\S+)\s+(\S+)/; push @{$expected{NAME}}, $f; push @{$expected{NAME_lc}}, lc $f; push @{$expected{NAME_uc}}, uc $f; push @{$expected{DEF}}, $d; } # # Find a possible new table name # my $table = find_new_table($dbh); ok($table, qq{Table is '$table'}); # # Create a new table # ok($dbh->do("CREATE TABLE $table (\n$def)"), "CREATE TABLE $table"); # Prepare insert # my $NAMES = join "," => @{$expected{NAME}}; my $sql = "INSERT INTO $table ($NAMES) VALUES (" . join(',', ('?') x scalar @{$expected{VALUES}}) . ")"; my $cursor = $dbh->prepare($sql); ok($cursor->execute(@{$expected{VALUES}}), "INSERT in $table"); ok(my $cursor2 = $dbh->prepare("SELECT * FROM $table", { ib_timestampformat => '%Y-%m-%d %H:%M', ib_dateformat => '%Y-%m-%d', ib_timeformat => '%H:%M', }), "PREPARE"); ok($cursor2->execute, "EXECUTE"); ok(my $res = $cursor2->fetchall_arrayref, 'FETCHALL arrayref'); is($cursor2->{NUM_OF_FIELDS}, scalar(@{$expected{VALUES}}), "Field count"); do { my $i = 0; for my $t ( @{ $expected{DEF} } ) { my $e = $expected{VALUES}[$i]; if ( $t =~ /^FLOAT|DOUBLE(?: PRECISION)?|NUMERIC\(\d+,\d+\)$/ ) { ok( abs( $res->[0][$i] - $e ) < 1e-10, "$t ~= $e" ); } else { is( $res->[0][$i], $e, "$t == $e" ); } $i++; } }; is_deeply($cursor2->{$_}, $expected{$_}, "attribute $_") for qw( NAME NAME_lc NAME_uc TYPE PRECISION SCALE ); # # Drop the test table # ok($dbh->do("DROP TABLE $table"), "DROP TABLE '$table'"); # # Finally disconnect. # ok($dbh->disconnect(), "Disconnect"); DBD-Firebird-1.39/t/30-insertfetch.t0000644000175000017500000000374411654054465015057 0ustar damdam#!/usr/bin/perl # # # This is a simple insert/fetch test. # # 2011-04-05 stefan(s.bv.) # Adapted to the new test library # # 2011-01-23 stefan(s.bv.) # New version based on testlib and Firebird.dbtest use strict; use warnings; use Test::More; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ($dbh, $error_str) = $T->connect_to_database; if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 13; } ok($dbh, 'Connected to the database'); # ------- TESTS ------------------------------------------------------------- # # # Find a possible new table name # my $table = find_new_table($dbh); ok($table, qq{Table is '$table'}); # # Create a new table # my $def =<<"DEF"; CREATE TABLE $table ( id INTEGER PRIMARY KEY, name VARCHAR(20) ) DEF ok( $dbh->do($def), qq{CREATE TABLE '$table'} ); # # Insert a row into the test table....... # ok( $dbh->do(qq{INSERT INTO $table VALUES (1, 'Alligator Descartes')}) ); # # ... and delete it ... # ok($dbh->do("DELETE FROM $table WHERE id = 1"), "DELETE FROM $table"); # # Now, try SELECT'ing the row out. This should fail. # ok(my $cursor = $dbh->prepare("SELECT * FROM $table WHERE id = 1"), 'SELECT'); ok($cursor->execute); my $row = $cursor->fetchrow_arrayref; $cursor->finish; # # Insert two new rows # ok( $dbh->do("INSERT INTO $table VALUES (1, 'Edwin Pratomo')") ); ok( $dbh->do("INSERT INTO $table VALUES (2, 'Daniel Ritz')") ); # # Try selectrow_array # my @array = $dbh->selectrow_array(qq{SELECT * FROM $table WHERE id = 1}); is( scalar @array, 2, q{TEST selectrow_array} ); # # Try fetchall_hashref # my $hash = $dbh->selectall_hashref( qq{SELECT * FROM $table}, 'ID' ); is( scalar keys %{$hash}, 2, q{TEST selectall_hashref} ); # # ... and drop it. # ok($dbh->do("DROP TABLE $table"), "DROP TABLE '$table'"); # # Finally disconnect. # ok($dbh->disconnect()); DBD-Firebird-1.39/t/92-bigdecimal_read.t0000644000175000017500000000453613141167125015613 0ustar damdam#!/usr/bin/perl # # 2011-04-13 stefan(s.bv.) Modified to run on Windows. # # 2011-01-31 stefan(s.bv.) Created new test: # Playing with very big | small numbers # Smallest and biggest decimal supported by Firebird: # -922337203685477.5808, 922337203685477.5807 # use strict; use warnings; use Math::BigFloat try => 'GMP'; use Test::More; use DBI; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ($dbh, $error_str) = $T->connect_to_database(); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 15; } ok($dbh, 'dbh OK'); # ------- TESTS ------------------------------------------------------------- # # Find a new table name my $table = find_new_table($dbh); ok($table, "TABLE is '$table'"); $dbh->do(<do(<do(<do(<do(<trace(4, "trace.txt"); # Expected fetched values my @correct = ( [ '-922337203685477.5808', '922337203685477.5807' ], [ '-0.3', '0.3' ], [ '-0.6', '0.6' ], [ '-0.5', '0.5' ], ); # Select the values ok( my $cursor = $dbh->prepare( qq{SELECT * FROM $table} ), 'PREPARE SELECT' ); ok($cursor->execute, 'EXECUTE SELECT'); ok((my $res = $cursor->fetchall_arrayref), 'FETCHALL'); my ($types, $names, $fields) = @{$cursor}{qw(TYPE NAME NUM_OF_FIELDS)}; for (my $i = 0; $i < @$res; $i++) { for (my $j = 0; $j < $fields; $j++) { my $result = qq{$res->[$i][$j]}; my $mresult = Math::BigFloat->new($result); my $corect = $correct[$i][$j]; my $mcorect = Math::BigFloat->new($corect); is($mresult, $mcorect, "Field: $names->[$j] is $corect"); #diag "got: $mresult"; #diag "exp: $mcorect"; } } # Drop the test table $dbh->{AutoCommit} = 1; ok( $dbh->do("DROP TABLE $table"), "DROP TABLE '$table'" ); # Finally disconnect. ok($dbh->disconnect(), 'DISCONNECT'); #-- end TESTS DBD-Firebird-1.39/t/70-nested-sth.t0000644000175000017500000000401311654054465014611 0ustar damdam#!/usr/local/bin/perl -w # # # This is a test for nested statement handles. # use strict; use warnings; use Test::More; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ( $dbh, $error_str ) = $T->connect_to_database( { AutoCommit => 1 } ); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 24; } ok($dbh, 'Connected to the database'); # ------- TESTS ------------------------------------------------------------- # my $table = find_new_table($dbh); ok($table); { my $def = "CREATE TABLE $table(id INTEGER, name VARCHAR(20))"; ok($dbh->do($def)); my $stmt = "INSERT INTO $table(id, name) VALUES(?, ?)"; ok($dbh->do($stmt, undef, 1, 'Crocodile')); } # now ready to work # BOTH hard and soft commit WORKS under AC off { local $dbh->{AutoCommit} = 0; TRY_HARD_SOFT_COMMIT: { my $sth1 = $dbh->prepare("SELECT * FROM $table"); ok($sth1); my $sth2 = $dbh->prepare("SELECT * FROM $table WHERE id = ?"); ok($sth2); ok($sth1->execute); while (my $row = $sth1->fetchrow_arrayref) { ok($sth2->execute($row->[0])); my $res = $sth2->fetchall_arrayref; ok($res and @$res); } ok($dbh->commit); not $dbh->{ib_softcommit} and $dbh->{ib_softcommit} = 1 and goto TRY_HARD_SOFT_COMMIT; } } # now try AC on ok($dbh->{AutoCommit}); # AC on ONLY works provided that ib_softcommit is on $dbh->{ib_softcommit} = 1; { my $sth1 = $dbh->prepare("SELECT * FROM $table"); ok($sth1); my $sth2 = $dbh->prepare("SELECT * FROM $table WHERE id = ?"); ok($sth2); ok($sth1->execute); while (my $row = $sth1->fetchrow_arrayref) { ok($sth2->execute($row->[0])); my $res = $sth2->fetchall_arrayref; ok($res and @$res); } } # Drop the test table ok($dbh->do("DROP TABLE $table")); ok($dbh->disconnect); DBD-Firebird-1.39/t/rt110979.t0000644000175000017500000000300212653150257013420 0ustar damdam#!/usr/bin/perl # # Test that RT#110979 is fixed # use strict; use warnings; use Test::More; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ($dbh, $error_str) = $T->connect_to_database(); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } ok($dbh, 'Connected to the database'); # ------- TESTS ------------------------------------------------------------- # my $table = find_new_table($dbh); ok($table, qq{Table is '$table'}); # # Create a new table # my $def =<<"DEF"; CREATE TABLE $table ( id INTEGER PRIMARY KEY, name VARCHAR(200) ) DEF ok( $dbh->do($def), qq{CREATE TABLE '$table'} ); ok( $dbh->do("create generator gen_$table"), "create generator gen_$table" ); $def = <<"DEF"; CREATE TRIGGER $table\_bi FOR $table ACTIVE BEFORE INSERT POSITION 0 AS BEGIN IF (NEW.id IS NULL) THEN NEW.id = GEN_ID(gen_$table,1); END DEF ok( $dbh->do($def), "create trigger $table\_bi" ); my $sth = $dbh->prepare_cached("INSERT INTO $table(name) VALUES(?) RETURNING id"); ok( $sth->execute('foo'), 'Insert worked' ); is( ($sth->fetchrow_array)[0], 1, 'Autoinc PK retrieved' ); ok( $sth->finish, "finish" ); ok( $dbh->do( "drop trigger $table\_bi", "drop trigger" ) ); ok( $dbh->do( "drop generator gen_$table", "drop generator" ) ); ok($dbh->do("DROP TABLE $table"), "DROP TABLE '$table'"); # # Finally disconnect. # ok($dbh->disconnect()); done_testing(); DBD-Firebird-1.39/t/rt72946.t0000644000175000017500000000160112002604524013331 0ustar damdam#!/usr/bin/perl -w # test for https://rt.cpan.org/Ticket/Display.html?id=72946 use strict; use warnings; use Test::More; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ( $dbh, $error_str ) = $T->connect_to_database( { AutoCommit => 1, RaiseError => 1 } ); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 6; } ok($dbh, 'Connected to the database'); my $table = find_new_table($dbh); ok(my $sth = $dbh->prepare('SELECT rdb$relation_name FROM rdb$relations'), 'query prepared'); ok($sth->execute, 'query executed'); ok( $dbh->do("CREATE TABLE $table(i INTEGER NOT NULL)"), 'table $table created' ); ok( $dbh->do("DROP TABLE $table"), 'table dropped' ); ok( $dbh->disconnect, 'disconnected from database' ); DBD-Firebird-1.39/t/63-doubles.t0000644000175000017500000000410212460001510014144 0ustar damdam#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Deep; use DBI; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ( $dbh, $error_str ) = $T->connect_to_database( { ChopBlanks => 1 } ); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } ok($dbh, 'Connected to the database'); # DBI->trace(4, "trace.txt"); # ------- TESTS ------------------------------------------------------------- # # # Find a possible new table name # my $table = find_new_table($dbh); ok($table, "TABLE is '$table'"); my @doubles = ( 0.4, 0.6, 0.8, 0.95, 1.0, 1.1, 1.2, 1.15, 3.14159 ); my $def =<<"DEF"; CREATE TABLE $table ( id integer, flt float, dbl double precision ) DEF ok( $dbh->do($def), qq{CREATE TABLE '$table'} ); # # Insert some values # my $stmt =<<"END_OF_QUERY"; INSERT INTO $table ( id, flt, dbl ) VALUES (?, ?, ?) END_OF_QUERY ok(my $insert = $dbh->prepare($stmt), 'PREPARE INSERT'); # Insert positive numbers my $id = 1; ok($insert->execute( $id++, $_, $_ ), "Inserting $_" ) for @doubles; # Insert positive numbers ok($insert->execute( $id++, -$_, -$_ ), "Inserting -$_" ) for @doubles; # # Select the values # ok( my $cursor = $dbh->prepare( qq{SELECT id, flt, dbl FROM $table WHERE id=?} ), 'PREPARE SELECT' ); $id = 0; for my $n (@doubles) { $id++; ok($cursor->execute($id), "EXECUTE SELECT $id ($n)"); ok((my $res = $cursor->fetchrow_arrayref), "FETCHALL arrayref $id ($n)"); cmp_deeply($res, [ $id, num($n, 1e-6), num($n, 1e-6) ], "row $id ($n)"); } for my $n (@doubles) { $id++; ok($cursor->execute($id), "EXECUTE SELECT $id (-$n)"); ok((my $res = $cursor->fetchrow_arrayref), "FETCHALL arrayref $id (-$n)"); cmp_deeply($res, [ $id, num(-$n, 1e-6), num(-$n, 1e-6) ], "row $id (-$n)"); } # # Drop the test table # $dbh->{AutoCommit} = 1; ok( $dbh->do("DROP TABLE $table"), "DROP TABLE '$table'" ); # # Finally disconnect. # ok($dbh->disconnect, 'DISCONNECT'); done_testing; DBD-Firebird-1.39/t/01-connect.t0000644000175000017500000000114113210342072014135 0ustar damdam#!/usr/bin/perl # # Test for the connection first ... # use strict; use warnings; use Test::More; use Test::Exception; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ($dbh, $error_str) = $T->connect_to_database; if ($error_str) { BAIL_OUT("Error! $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 3; } ok($dbh, 'Connected to the database'); # and disconnect. ok( $dbh->disconnect ); dies_ok { DBI->connect('dbi:Firebird:db=dummy;timeout=-2') } "die on invalid timeout"; DBD-Firebird-1.39/t/dbi-table_info.t0000644000175000017500000001212011654054465015143 0ustar damdam#! /usr/bin/env perl # # Verify that $dbh->tables() returns a list of (quoted) tables. # # Changes 2011-01-21 stefansbv: # - localized variables per test block # use strict; use warnings; use DBI 1.19; # FetchHashKeyName support (2001-07-20) use Test::More; use lib 't','.'; use constant TI_DBI_FIELDS => [qw/ TABLE_CAT TABLE_SCHEM TABLE_NAME TABLE_TYPE REMARKS / ]; use TestFirebird; my $T = TestFirebird->new; my ( $dbh, $error_str ) = $T->connect_to_database( { RaiseError => 1, FetchHashKeyName => 'NAME_uc' } ); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 41; } ok($dbh, 'Connected to the database'); # IB/FB derivatives can add at least 'ib_owner_name' # (rdb$relations.rdb$owner_name) to the ordinary DBI table_info() fields. use constant TI_IB_FIELDS => [ @{TI_DBI_FIELDS()}, 'IB_OWNER_NAME' ]; sub contains { my ($superset, $subset) = @_; # for our purposes, sets must not be empty if (0 == @$superset or 0 == @$subset) { die "Empty set given to contains()"; } my %super = map {$_=>undef} @$superset; for my $element (@$subset) { return undef unless exists $super{$element}; } return 1; } # ------- TESTS ------------------------------------------------------------- # # # Find a possible new table name # my $table = find_new_table($dbh); ok($table, qq{Table is '$table'}); # -- List all catalogs (none) { my $sth = $dbh->table_info('%', '', ''); my $r = $sth->fetch; ok(!defined($r), "No DBI catalog support"); ok(contains($sth->{NAME_uc}, TI_DBI_FIELDS), "Result set contains expected table_info() fields"); } # -- List all schema (none) { my $sth = $dbh->table_info('', '%', ''); ok(!defined($sth->fetch), "No DBI schema support"); ok(contains($sth->{NAME_uc}, TI_DBI_FIELDS), "Result set contains expected table_info() fields"); } # -- List all supported types { my $sth = $dbh->table_info('', '', '', '%'); my @types; while (my $r = $sth->fetchrow_hashref) { push @types, $r->{TABLE_TYPE}; } ok(contains(\@types, ['VIEW', 'TABLE', 'SYSTEM TABLE']), "Minimal types supported"); } # -- Literal table specification { for my $tbl_spec ('RDB$DATABASE') { my $sth1 = $dbh->table_info('', '', $tbl_spec); my $r1 = $sth1->fetchrow_hashref; is($r1->{TABLE_NAME}, $tbl_spec, "TABLE_NAME is $tbl_spec"); is($r1->{TABLE_TYPE}, 'SYSTEM TABLE', 'TABLE_TYPE is SYSTEM TABLE'); ok(contains($sth1->{NAME_uc}, TI_IB_FIELDS), "Result set contains expected table_info() fields"); ok(!defined($sth1->fetch), "One and only one row returned for $tbl_spec"); my $sth2 = $dbh->table_info('', '', $tbl_spec, 'VIEW'); ok(!defined($sth2->fetch), "No VIEW named $tbl_spec"); ok(contains($sth2->{NAME_uc}, TI_IB_FIELDS), "Result set contains expected table_info() fields"); my $sth3 = $dbh->table_info('', '', $tbl_spec, 'VIEW,SYSTEM TABLE'); my $r3 = $sth3->fetchrow_hashref; is($r3->{TABLE_NAME}, $tbl_spec, "$tbl_spec found (multiple TYPEs given)"); is($r3->{TABLE_TYPE}, 'SYSTEM TABLE', 'TABLE_TYPE is SYSTEM TABLE (multiple TYPEs given)'); ok(!defined($sth3->fetch), "Only one row returned (multiple TYPEs given)"); ok(contains($sth3->{NAME_uc}, TI_IB_FIELDS), "Result set contains expected table_info() fields"); } } # -- Pattern tests # Similar to the literal table spec, but may return more than one # matching entry (remember: '_' and '%' are search pattern characters) for my $tbl_spec ('RDB$D_T_B_S_', 'RDB$%', '%', '') { # { my $sth = $dbh->table_info('', '', $tbl_spec); ok(contains($sth->{NAME_uc}, TI_IB_FIELDS), "Result set contains expected table_info() fields"); my ($table_name, $table_type); while (my $r = $sth->fetchrow_hashref) { if ( $r->{TABLE_NAME} eq 'RDB$DATABASE' ) { $table_name = $r->{TABLE_NAME}; $table_type = $r->{TABLE_TYPE}; last; } } is( $table_name, 'RDB$DATABASE', "RDB\$DATABASE found against '$tbl_spec'" ); is( $table_type, 'SYSTEM TABLE', 'is SYSTEM TABLE' ); } # { my $sth = $dbh->table_info('', '', $tbl_spec, 'VIEW,SYSTEM TABLE'); ok(contains($sth->{NAME_uc}, TI_IB_FIELDS), "Result set contains expected table_info() fields"); my ($table_name, $table_type); while (my $r = $sth->fetchrow_hashref) { if ( $r->{TABLE_NAME} eq 'RDB$DATABASE' ) { $table_name = $r->{TABLE_NAME}; $table_type = $r->{TABLE_TYPE}; last; } } is( $table_name, 'RDB$DATABASE', "RDB\$DATABASE found against '$tbl_spec' (multiple TYPEs)" ); is( $table_type, 'SYSTEM TABLE', 'is SYSTEM TABLE (multiple TYPEs)' ); } } done_testing; __END__ # vim: set et ts=4: DBD-Firebird-1.39/t/49-scale.t0000644000175000017500000000444711654054465013643 0ustar damdam # RT#55841 high-scale numbers incorrectly formatted use strict; use warnings; use Test::More; use DBI; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ( $dbh, $error_str ) = $T->connect_to_database( { ChopBlanks => 1 } ); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 52; } ok($dbh, 'Connected to the database'); my @Types = qw|NUMERIC DECIMAL|; my @Tests = ( # Literal Precision Scale Expected [ '-19.061', 18, 0, -19 ], # XXX - we coerce Expected [ '-19.061', 18, 1, -19.1 ], # into a number [ '-19.061', 18, 2, -19.06 ], [ '-19.061', 18, 3, -19.061 ], [ '-19.061', 18, 4, -19.061 ], [ '-19.061', 18, 5, -19.061 ], [ '-19.061', 18, 6, -19.061 ], [ '-19.061', 18, 7, -19.061 ], [ '-19.061', 18, 8, -19.061 ], [ '-19.061', 18, 9, -19.061 ], [ '-19.061', 18, 10, -19.061 ], [ '-19.061', 18, 11, -19.061 ], [ '-19.061', 18, 12, -19.061 ], [ '-19.061', 18, 13, -19.061 ], [ '-19.061', 18, 14, -19.061 ], [ '-19.061', 18, 15, -19.061 ], [ '-19.061', 18, 16, -19.061 ], [ '0.00001', 12, 11, 0.00001 ], [ '0.00001', 12, 10, 0.00001 ], [ '0.00001', 12, 9, 0.00001 ], [ '0.00001', 12, 8, 0.00001 ], [ '0.00001', 12, 7, 0.00001 ], [ '0.00001', 12, 6, 0.00001 ], [ '0.00001', 12, 5, 0.00001 ], [ '0.00001', 12, 4, 0 ], ); # plan tests => (2 + (@Types * @Tests)); for my $type (@Types) { for (@Tests) { my ($literal, $prec, $scale, $expected) = @$_; my $cast = "CAST($literal AS $type($prec, $scale))"; my ($r) = $dbh->selectrow_array("select $cast from RDB\$DATABASE"); is(0+$r, $expected, "$cast"); } } { my ($r) = $dbh->selectrow_array('select 0+1 from RDB$DATABASE'); is($r, '1', "0+1"); # No decimal point on implicit zero-scale field } __END__ # vim: set et ts=4 ft=perl: DBD-Firebird-1.39/t/rt76506.t0000644000175000017500000000302512007201302013317 0ustar damdam#!/usr/bin/perl use strict; use warnings; use utf8; BEGIN { binmode(STDERR, ':utf8'); binmode(STDOUT, ':utf8'); }; use Test::More; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ($dbh, $error_str) = $T->connect_to_database; if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 12; } ok($dbh, 'Connected to the database'); # ------- TESTS ------------------------------------------------------------- # # # Find new table name # my $table = find_new_table($dbh); ok($table, qq{Table is '$table'}); # # Create a new table # my $def =<<"DEF"; CREATE TABLE $table ( CHAR_TEST CHAR(10) CHARACTER SET UTF8 ) DEF ok( $dbh->do($def), qq{CREATE TABLE '$table'} ); # # Prepare insert # my $stmt =<<"END_OF_QUERY"; INSERT INTO $table (CHAR_TEST) VALUES (?) END_OF_QUERY ok(my $cursor = $dbh->prepare($stmt), 'PREPARE INSERT'); ok($cursor->execute('TEST'), "INSERT in $table"); ok( my $cursor2 = $dbh->prepare( "SELECT CHAR_TEST FROM $table", ), 'PREPARE SELECT' ); ok($cursor2->execute, 'SELECT'); ok(my $hash_ref = $cursor2->fetchrow_hashref, 'FETCHALL hashref'); my $char_test = $hash_ref->{CHAR_TEST}; is(length $char_test, 10, 'Match length'); diag(">>$char_test<<"); ok($cursor2->finish, 'FINISH'); # # Drop the test table # ok($dbh->do("DROP TABLE $table"), "DROP TABLE '$table'"); # # Finally disconnect. # ok($dbh->disconnect(), 'DISCONNECT'); DBD-Firebird-1.39/t/91-txinfo.t0000644000175000017500000000166711654054465014061 0ustar damdam#!/usr/bin/perl -w # test for ib_tx_info() use strict; use warnings; use Data::Dumper; use Test::More; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ($dbh1, $error_str) = $T->connect_to_database({AutoCommit => 0}); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh1->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 9; } ok($dbh1, 'Connected to the database'); ok($dbh1->selectall_arrayref(q{SELECT COUNT(1) FROM RDB$DATABASE})); my $info = $dbh1->func('ib_tx_info'); ok($info); print Dumper($info); ok($dbh1->commit); ok($dbh1->func( -isolation_level => 'read_committed', 'ib_set_tx_param' ), "change isolation level" ); ok($dbh1->selectall_arrayref(q{SELECT COUNT(1) FROM RDB$DATABASE})); $info = $dbh1->func('ib_tx_info'); ok($info); print Dumper($info); ok($dbh1->commit); ok($dbh1->disconnect); DBD-Firebird-1.39/t/03-dbh-attr.t0000644000175000017500000000216112460521462014226 0ustar damdamuse strict; use warnings; # Smattering of dbh attribute tests. # FIXME: add generic handle attribute tests, FB-specific attribute tests use Test::More; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; plan tests => 9; my( $dbh, $error ) = $T->connect_to_database; ok(!$error, "Connected to database") or diag($error); ok($dbh->{Active}, "Active attribute is true after connect"); ok(defined($dbh->{AutoCommit}), "AutoCommit attribute supported"); isa_ok($dbh->{Driver}, 'DBI::dr', "Driver attribute returns a DBI::dr"); ok($dbh->{Name} =~ /db=[^;]+/, "Name attribute is of the form db=...") or diag("\$dbh->{Name} is $dbh->{Name}"); $dbh->prepare('SELECT 1 FROM RDB$DATABASE'); cmp_ok($dbh->{Statement}, 'eq', 'SELECT 1 FROM RDB$DATABASE', "Statement attribute is as expected"); # Borrowed from DBD::Pg is($dbh->{RowCacheSize}, undef, "RowCacheSize attribute is undefined"); $dbh->{RowCacheSize} = 42; is($dbh->{RowCacheSize}, undef, "RowCacheSize attribute is undefined after assignment"); $dbh->disconnect(); ok(!$dbh->{Active}, "Active attribute is false after disconnect"); DBD-Firebird-1.39/t/97-db-triggers.t0000644000175000017500000000471414743005335014757 0ustar damdam#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Exception; use DBI; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ($dbh, $error_str) = $T->connect_to_database(); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ($dbh->isa('DBI::db')) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { my $orig_ver = $dbh->func(version => 'ib_database_info')->{version}; (my $ver = $orig_ver) =~ s/.*\bFirebird\s*//; if ($ver =~ /^(\d+)\.(\d+)$/) { if ($1 > 2 or $1 == 2 and $2 >= 1) { plan tests => 15; } else { plan skip_all => "Firebird version $1.$2 doesn't support database-level triggers"; } } else { plan skip_all => "Unable to determine Firebird version from '$orig_ver'. Assuming no database-level triggers"; } } ok($dbh, 'Connected to the database'); # DBI->trace(4, "trace.txt"); eval { $dbh->do("drop table conn_log") }; lives_ok(sub { $dbh->do("create table conn_log(tm timestamp not null)") }, "create conn_log table"); eval { $dbh->do("drop trigger conn_log") }; lives_ok( sub { $dbh->do(<disconnect, 'DISCONNECT'); ($dbh, $error_str) = $T->connect_to_database(); ok($dbh, 'reconnected'); my ($cnt) = $dbh->selectrow_array("SELECT COUNT(*) FROM conn_log"); is($cnt, 1, "Single connection logged (trigger works)"); ok($dbh->disconnect, 'DISCONNECT'); ($dbh, $error_str) = $T->connect_to_database({ ib_db_triggers => 0 }); ok($dbh, 'reconnected wuth ib_db_triggers=0'); ($cnt) = $dbh->selectrow_array("SELECT COUNT(*) FROM conn_log"); is($cnt, 1, "Still single connection logged (ib_db_triggers=0 works)"); ok($dbh->disconnect, 'DISCONNECT'); ($dbh, $error_str) = $T->connect_to_database({ ib_db_triggers => 1 }); ok($dbh, 'reconnected with ib_db_triggers=1'); ($cnt) = $dbh->selectrow_array("SELECT COUNT(*) FROM conn_log"); is($cnt, 2, "Two connections logged (ib_db_triggers=1 works)"); # # Drop the test table/trigger # $dbh->{AutoCommit} = 1; ok($dbh->do("DROP TRIGGER conn_log"), "DROP TRIGGER conn_log"); ok($dbh->do("DROP TABLE conn_log"), "DROP TABLE conn_log"); # # Finally disconnect. # ok($dbh->disconnect, 'DISCONNECT'); DBD-Firebird-1.39/t/80-event-ithreads.t0000644000175000017500000000753612271014143015454 0ustar damdam#!/usr/local/bin/perl -w # # # test cases: # event creation, register callback, cancel callback # event creation, fork / thread (except win32), destruction # event creation, fork / thread (except win32), wait event, destruction # event creation, fork / thread (except win32), register callback, destruction use strict; use warnings; use Data::Dumper; use DBI; use Config; use Test::More; use lib 't','.'; use Time::HiRes qw(sleep); use TestFirebird; my $T = TestFirebird->new; my ($dbh, $error_str) = $T->connect_to_database; my ( $test_dsn, $test_user, $test_password ) = ( $T->{tdsn}, $T->{user}, $T->{pass} ); if ($error_str) { BAIL_OUT("Error! $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 22; } ok($dbh, 'Connected to the database'); my $table = find_new_table($dbh); ok($table, qq{Table is '$table'}); # create required test table and triggers { my @ddl = (<<"DDL", <<"DDL", <<"DDL"); CREATE TABLE $table ( id INTEGER NOT NULL, title VARCHAR(255) NOT NULL ); DDL CREATE TRIGGER ins_${table}_trig FOR $table AFTER INSERT POSITION 0 AS BEGIN POST_EVENT 'foo_inserted'; END DDL CREATE TRIGGER del_${table}_trig FOR $table AFTER DELETE POSITION 0 AS BEGIN POST_EVENT 'foo_deleted'; END DDL ok($dbh->do($_)) foreach @ddl; # 3 times } my $evh = $dbh->func('foo_inserted', 'foo_deleted', 'ib_init_event'); ok($evh); ok($dbh->func($evh, sub { print "about to cancel"; 1 }, 'ib_register_callback')); ok($dbh->func($evh, 'ib_cancel_callback')); my $worker = sub { my $table = shift; my @dbi_args = ( shift, shift, shift ); my $delay = shift; my $dbh = DBI->connect(@dbi_args, {AutoCommit => 1 }) or return 0; sleep($delay) if $delay; for (1..5) { $dbh->do(qq{INSERT INTO $table VALUES($_, 'bar')}); } $dbh->do(qq{DELETE FROM $table}); $dbh->disconnect; }; # try ithreads { my $how_many = 10; SKIP: { skip "this $^O perl $] is not configured to support iThreads", $how_many if (!$Config{useithreads} || $] < 5.008); skip "known problems under MSWin32 ActivePerl's iThreads", $how_many if $Config{osname} eq 'MSWin32'; skip "Perl version is older than 5.8.8", $how_many if $^V and $^V lt v5.8.8; # TODO: try enabling this when firebird 3 is released stable skip "thread tests unstable under load", $how_many if $ENV{AUTOMATED_TESTING}; eval { require threads }; skip "unable to use threads;", $how_many if $@; %::CNT = (); ok($dbh->func($evh, sub { my $posted_events = shift; while (my ($k, $v) = each %$posted_events) { $::CNT{$k} += $v; } 1; }, 'ib_register_callback' ), 'callback registered'); my $t = threads->create($worker, $table, $test_dsn, $test_user, $test_password); ok($t, 'thread created'); ok($t->join, 'thread joined'); while (not exists $::CNT{'foo_deleted'}) {} ok($dbh->func($evh, 'ib_cancel_callback'), 'callback unregistered'); is($::CNT{'foo_inserted'}, 5); is($::CNT{'foo_deleted'}, 5); SKIP: { skip "automated test of ib_wait_event -- flagile under load", 4 if $ENV{AUTOMATED_TESTING}; # test ib_wait_event %::CNT = (); $t = threads->create($worker, $table, $test_dsn, $test_user, $test_password, 0.2); ok($t, "create thread"); for (1..6) { my $posted_events = $dbh->func($evh, 'ib_wait_event'); while (my ($k, $v) = each %$posted_events) { $::CNT{$k} += $v; } } ok($t->join); is($::CNT{'foo_inserted'}, 5); is($::CNT{'foo_deleted'}, 5); } }} ok($dbh->do(qq(DROP TRIGGER ins_${table}_trig))); ok($dbh->do(qq(DROP TRIGGER del_${table}_trig))); ok($dbh->do(qq(DROP TABLE $table))); ok($dbh->disconnect); DBD-Firebird-1.39/t/48-numeric.t0000644000175000017500000000670311654054465014212 0ustar damdam#!/usr/bin/perl # # # 2011-01-29 stefan(s.bv.) # Using string comparison with Test::More's 'is' # # 2011-01-29 stefan(s.bv.) # New version based on t/testlib.pl and Firebird.dbtest use strict; use warnings; use Test::More; use DBI; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ( $dbh, $error_str ) = $T->connect_to_database( { ChopBlanks => 1 } ); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 29; } ok($dbh, 'Connected to the database'); # DBI->trace(4, "trace.txt"); # ------- TESTS ------------------------------------------------------------- # # # Find a possible new table name # my $table = find_new_table($dbh); ok($table, "TABLE is '$table'"); # Expected fetched values # Need to store the decimal precision for 'sprintf' # Prec must also be the same in CREATE TABLE, of course my $expected = { NUMERIC_2_DIGITS => { prec => 2, test => { 0 => 123456.79, 1 => -123456.79, 2 => 123456.01, 3 => -123456.09, 4 => 10.9, }, }, NUMERIC_3_DIGITS => { prec => 3, test => { 0 => 86753090000.868, 1 => -86753090000.868, 2 => 80.080, 3 => -80.080, 4 => 10.9, }, }, NUMERIC_NO_DIGITS => { prec => 0, test => { 0 => 11, 1 => -11, 2 => 10, 3 => 0, 4 => 11, }, }, }; # # Create a new table # my $def =<<"DEF"; CREATE TABLE $table ( NUMERIC_2_DIGITS NUMERIC( 9, 2), NUMERIC_3_DIGITS NUMERIC(18, 3), NUMERIC_NO_DIGITS NUMERIC(10, 0) ) DEF ok( $dbh->do($def), qq{CREATE TABLE '$table'} ); # # Insert some values # my $stmt =<<"END_OF_QUERY"; INSERT INTO $table ( NUMERIC_2_DIGITS, NUMERIC_3_DIGITS, NUMERIC_NO_DIGITS ) VALUES (?, ?, ?) END_OF_QUERY ok(my $insert = $dbh->prepare($stmt), 'PREPARE INSERT'); # Insert positive numbers ok($insert->execute( 123456.7895, 86753090000.8675309, 10.9), 'INSERT POSITIVE NUMBERS' ); # Insert negative numbers ok($insert->execute( -123456.7895, -86753090000.8675309, -10.9), 'INSERT NEGATIVE NUMBERS' ); # Insert with some variations in the precision part ok($insert->execute( 123456.01, 80.080, 10.0), 'INSERT NUMBERS WITH VARIOUS PREC 1' ); ok($insert->execute( -123456.09, -80.080, 0.0), 'INSERT NUMBERS WITH VARIOUS PREC 2' ); ok($insert->execute( 10.9, 10.9, 10.9), 'INSERT NUMBERS WITH VARIOUS PREC 3' ); # # Select the values # ok( my $cursor = $dbh->prepare( qq{SELECT * FROM $table}, ), 'PREPARE SELECT' ); ok($cursor->execute, 'EXECUTE SELECT'); ok((my $res = $cursor->fetchall_arrayref), 'FETCHALL arrayref'); my ($types, $names, $fields) = @{$cursor}{qw(TYPE NAME NUM_OF_FIELDS)}; for (my $i = 0; $i < @$res; $i++) { for (my $j = 0; $j < $fields; $j++) { my $prec = $expected->{ $names->[$j] }{prec}; my $result = sprintf("%.${prec}f", $res->[$i][$j]); my $corect = sprintf("%.${prec}f", $expected->{$names->[$j]}{test}{$i}); is($result, $corect, "Field: $names->[$j]"); } } # # Drop the test table # $dbh->{AutoCommit} = 1; ok( $dbh->do("DROP TABLE $table"), "DROP TABLE '$table'" ); # # Finally disconnect. # ok($dbh->disconnect, 'DISCONNECT'); DBD-Firebird-1.39/t/dbi-tables.t0000644000175000017500000000237611654054465014327 0ustar damdam#! /usr/bin/env perl # # Verify that $dbh->tables() returns a list of (quoted) tables. # use strict; use warnings; use Test::More; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ($dbh, $error_str) = $T->connect_to_database(); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 6; } ok($dbh, 'Connected to the database'); # ------- TESTS ------------------------------------------------------------- # # # Find a possible new table name # my $table = find_new_table($dbh); ok($table, qq{Table is '$table'}); ok($dbh->do(<<__eocreate), "CREATE TABLE $table"); CREATE TABLE $table( i INTEGER NOT NULL, vc VARCHAR(64) NOT NULL ) __eocreate my %tables = map { uc($_) => 1 } $dbh->tables; ok(exists $tables{ $dbh->quote_identifier(uc($table)) }, "tables() returned uppercased, quoted $table"); #diag join(' ', sort keys %tables); ok($dbh->do("DROP TABLE $table"), "DROP TABLE $table"); %tables = map { uc($_) => 1 } $dbh->tables; #diag join(' ', sort keys %tables); ok(!exists($tables{ $dbh->quote_identifier(uc($table)) }), "$table no longer in tables()"); __END__ # vim: set et ts=4: DBD-Firebird-1.39/t/90-dbinfo.t0000644000175000017500000000361511654054465014005 0ustar damdam#!/usr/bin/perl -w # test for ib_database_info() use strict; use warnings; use Test::More; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ($dbh1, $error_str) = $T->connect_to_database(); my ( $test_dsn, $test_user, $test_password ) = ( $T->{tdsn}, $T->{user}, $T->{pass} ); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh1->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 13; } ok($dbh1, 'Connected to the database'); my @items = qw/ allocation base_level db_id implementation no_reserve db_read_only ods_minor_version ods_version page_size version db_sql_dialect current_memory forced_writes max_memory num_buffers sweep_interval user_names fetches marks reads writes active_tran_count creation_date /; my $info = $dbh1->func(@items, 'ib_database_info'); ok($info); SKIP: { my $k = 'active_tran_count'; skip "$k is not available", 10 unless exists $info->{$k}; my ($dbh2, $error_str2) = $T->connect_to_database({AutoCommit => 0 }); ok($dbh2); is($dbh2->func($k, 'ib_database_info')->{$k}, 0, "tx count should be 0, no tx started yet"); ok( $dbh2->selectall_arrayref(q{SELECT COUNT(1) FROM RDB$DATABASE}) ); is($dbh2->func($k, 'ib_database_info')->{$k}, 1, "tx count should be 1"); ok($dbh2->commit); is($dbh2->func($k, 'ib_database_info')->{$k}, 0, "tx count should be 0 after commit"); ok($dbh2->disconnect); ok($dbh1->disconnect); $dbh1 = DBI->connect($test_dsn . ';ib_dbkey_scope=1', $test_user, $test_password); ok($dbh1); is($dbh1->func($k, 'ib_database_info')->{$k}, 1, "tx count should be 1, with dbkey_scope = 1"); } ok($dbh1->disconnect); DBD-Firebird-1.39/t/94-biginteger_read.t0000644000175000017500000000421511654054465015657 0ustar damdam#!/usr/bin/perl # # 2011-04-13 stefan(s.bv.) Modified to run on Windows. # # 2011-01-31 stefan(s.bv.) Created new test: # Playing with very big | small numbers # Smallest and biggest integer supported by Firebird: # -9223372036854775808, 9223372036854775807 # use strict; use warnings; use Math::BigFloat try => 'GMP'; use Test::More; use DBI; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ($dbh, $error_str) = $T->connect_to_database(); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 9; } ok($dbh, 'dbh OK'); # ------- TESTS ------------------------------------------------------------- # # Find a new table name my $table = find_new_table($dbh); ok($table, "TABLE is '$table'"); $dbh->do(<do(<trace(4, "trace.txt"); # Expected fetched values my @correct = ( [ '-9223372036854775808', '9223372036854775807' ], ); # Select the values ok( my $cursor = $dbh->prepare( qq{SELECT * FROM $table} ), 'PREPARE SELECT' ); ok($cursor->execute, 'EXECUTE SELECT'); ok((my $res = $cursor->fetchall_arrayref), 'FETCHALL'); my ($types, $names, $fields) = @{$cursor}{qw(TYPE NAME NUM_OF_FIELDS)}; #my $scale = 0; # scale parameter for (my $i = 0; $i < @$res; $i++) { for (my $j = 0; $j < $fields; $j++) { my $result = qq{$res->[$i][$j]}; my $mresult = Math::BigInt->new($result); my $corect = $correct[$i][$j]; my $mcorect = Math::BigInt->new($corect); #ok($mresult->bacmp($mcorect) == 0, , "Field: $names->[$j]"); is($mresult, $mcorect, "Field: $names->[$j]"); # diag "got: $mresult"; # diag "exp: $mcorect"; } } # Drop the test table $dbh->{AutoCommit} = 1; ok( $dbh->do("DROP TABLE $table"), "DROP TABLE '$table'" ); # Finally disconnect. ok($dbh->disconnect(), 'DISCONNECT'); #-- end TESTS DBD-Firebird-1.39/t/rt49896.t0000644000175000017500000000265111654054466013367 0ustar damdam#!/usr/local/bin/perl -w # # Test cases for DBD-Firebird rt.cpan.org #49896 # "Varchar fields accept data one char over field length (but memory # is corrupted)" # use strict; use warnings; use Test::More; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ($dbh, $error_str) = $T->connect_to_database(); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 9; } ok($dbh, 'Connected to the database'); # ------- TESTS ------------------------------------------------------------- # my $table = find_new_table($dbh); ok($table, qq{Table is '$table'}); my $def =<<"DEF"; CREATE TABLE $table ( c1 VARCHAR(3) ) DEF ok( $dbh->do($def), qq{CREATE TABLE '$table'} ); ok($dbh->do("INSERT INTO $table (c1) VALUES (?)", undef, 'aa'), "INSERT string (length < column size) succeeds"); ok($dbh->do("INSERT INTO $table (c1) VALUES (?)", undef, 'aaa'), "INSERT string (length == column size) succeeds"); $dbh->{RaiseError} = 0; ok(! defined $dbh->do("INSERT INTO $table (c1) VALUES (?)", undef, 'aaa!'), "INSERT string (length == column size + 1) fails"); ok(! defined $dbh->do("INSERT INTO $table (c1) VALUES (?)", undef, 'aaa!!'), "INSERT string (length == column size + 2) fails"); ok($dbh->do("DROP TABLE $table"), "DROP TABLE $table"); ok( $dbh->disconnect ); DBD-Firebird-1.39/t/41-bindparam.t0000644000175000017500000000530412002767027014463 0ustar damdam#!/usr/bin/perl # # # 2011-01-24 stefansbv # New version based on t/testlib.pl and Firebird.dbtest use strict; use warnings; use utf8; BEGIN { binmode(STDERR, ':utf8'); binmode(STDOUT, ':utf8'); }; use Test::More; use DBI qw(:sql_types); use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ($dbh, $error_str) = $T->connect_to_database( { ChopBlanks => 1 } ); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 37; } ok($dbh, 'Connected to the database'); # ------- TESTS ------------------------------------------------------------- # #DBI->trace(4, "trace.txt"); # # Find a possible new table name # my $table = find_new_table($dbh); ok($table, qq{Table is '$table'}); # # Create the new table # my $def = qq{ CREATE TABLE $table ( id INTEGER NOT NULL, name CHAR(64) CHARACTER SET UTF8 ) }; ok($dbh->do($def), "CREATE TABLE '$table'"); ok(my $cursor = $dbh->prepare("INSERT INTO $table VALUES (?, ?)")); # # Insert some rows # # Automatic type detection my $numericVal = 1; my $charVal = 'Alligator Descartes'; ok($cursor->execute($numericVal, $charVal)); # Does the driver remember the automatically detected type? ok($cursor->execute("3", "Jochen Wiedmann")); $numericVal = 2; $charVal = "Tim Bunce"; ok($cursor->execute($numericVal, $charVal)); # Now try the explicit type settings ok($cursor->bind_param(1, ' 4', SQL_INTEGER())); ok($cursor->bind_param(2, 'Andreas König')); ok($cursor->execute); # Works undef -> NULL? ok($cursor->bind_param(1, 5, SQL_INTEGER())); ok($cursor->bind_param(2, undef)); ok($cursor->execute); # # Try various mixes of question marks, single and double quotes # ok($dbh->do("INSERT INTO $table VALUES (6, '?')")); # # And now retreive the rows using bind_columns # ok($cursor = $dbh->prepare("SELECT * FROM $table ORDER BY id")); ok($cursor->execute); my ($id, $name); ok($cursor->bind_columns(undef, \$id, \$name), 'Bind columns'); ok($cursor->fetch); is($id, 1, 'Check id 1'); is($name, 'Alligator Descartes', 'Check name'); ok($cursor->fetch); is($id, 2, 'Check id 2'); is($name, 'Tim Bunce', 'Check name'); ok($cursor->fetch); is($id, 3, 'Check id 3'); is($name, 'Jochen Wiedmann', 'Check name'); ok($cursor->fetch); is($id, 4, 'Check id 4'); is($name, 'Andreas König', 'Check name'); ok($cursor->fetch); is($id, 5, 'Check id 5'); is($name, undef, 'Check name'); ok($cursor->fetch); is($id, 6, 'Check id 6'); is($name, '?', 'Check name'); # Have to call finish ok($cursor->finish); # # Finally drop the test table. # ok($dbh->do("DROP TABLE $table"), "DROP TABLE '$table'"); # -- end test DBD-Firebird-1.39/t/45-datetime.t0000644000175000017500000000535611654054465014344 0ustar damdam#!/usr/local/bin/perl # # # This is a test for date/time types handling with localtime() style. # # 2011-01-29 stefansbv # New version based on t/testlib.pl and Firebird.dbtest use strict; use warnings; use Test::More; use DBI qw(:sql_types); use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ( $dbh, $error_str ) = $T->connect_to_database( { ChopBlanks => 1 } ); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 14; } ok($dbh, 'Connected to the database'); # DBI->trace(4, "trace.txt"); # ------- TESTS ------------------------------------------------------------- # # # Find a possible new table name # my $table = find_new_table($dbh); ok($table, "TABLE is '$table'"); my @times = localtime(); my @is_match = ( sub { my $ref = shift->[0]->[0]; return ($$ref[0] == $times[0]) && ($$ref[1] == $times[1]) && ($$ref[2] == $times[2]) && ($$ref[3] == $times[3]) && ($$ref[4] == $times[4]) && ($$ref[5] == $times[5]); }, sub { my $ref = shift->[0]->[1]; return ($$ref[3] == $times[3]) && ($$ref[4] == $times[4]) && ($$ref[5] == $times[5]); }, sub { my $ref = shift->[0]->[2]; return ($$ref[0] == $times[0]) && ($$ref[1] == $times[1]) && ($$ref[2] == $times[2]); } ); # # Create a new table # my $def =<<"DEF"; CREATE TABLE $table ( A_TIMESTAMP TIMESTAMP, A_DATE DATE, A_TIME TIME ) DEF ok( $dbh->do($def), qq{CREATE TABLE '$table'} ); # # Insert some values # my $stmt =<<"END_OF_QUERY"; INSERT INTO $table ( A_TIMESTAMP, A_DATE, A_TIME ) VALUES (?, ?, ?) END_OF_QUERY ok(my $insert = $dbh->prepare($stmt), 'PREPARE INSERT'); ok($insert->execute(\@times, \@times, \@times)); # # Select the values # ok( my $cursor = $dbh->prepare( "SELECT * FROM $table", { ib_timestampformat => 'TM', ib_dateformat => 'TM', ib_timeformat => 'TM', } ) ); ok($cursor->execute); ok((my $res = $cursor->fetchall_arrayref), 'FETCHALL'); my ($types, $names, $fields) = @{$cursor}{qw(TYPE NAME NUM_OF_FIELDS)}; for (my $i = 0; $i < $fields; $i++) { ok(( $is_match[$i]->($res) ), "field: $names->[$i] ($types->[$i])"); } # # Drop the test table # $dbh->{AutoCommit} = 1; ok( $dbh->do("DROP TABLE $table"), "DROP TABLE '$table'" ); # NUM_OF_FIELDS should be zero (Non-Select) ok(($cursor->{'NUM_OF_FIELDS'}), "NUM_OF_FIELDS == 0"); # # Finally disconnect. # ok($dbh->disconnect()); DBD-Firebird-1.39/t/001-client-version.t0000644000175000017500000000146113210342072015532 0ustar damdam# Test that everything compiles, so the rest of the test suite can # load modules without having to check if it worked. # # 2011-01-29 stefan(s.bv.) # Stolen from DBD::SQLite ;) # use strict; BEGIN { $| = 1; $^W = 1; } use Test::More tests => 4; use DBD::Firebird; can_ok( 'DBD::Firebird' => 'fb_api_ver' ); can_ok( 'DBD::Firebird' => 'client_major_version' ); can_ok( 'DBD::Firebird' => 'client_minor_version' ); can_ok( 'DBD::Firebird' => 'client_version' ); note( "Firebird API version is " . DBD::Firebird->fb_api_ver ); note( "Firebird client major version is " . DBD::Firebird->client_major_version ); note( "Firebird client minor version is " . DBD::Firebird->client_minor_version ); note( "Firebird client version is " . DBD::Firebird->client_version ); # diag("\$DBI::VERSION=$DBI::VERSION"); DBD-Firebird-1.39/t/44-cursoron.t0000644000175000017500000000414411654054465014413 0ustar damdam#!/usr/local/bin/perl # # # This is a test for CursorName attribute with AutoCommit On. # # 2011-01-29 stefansbv # New version based on t/testlib.pl and Firebird.dbtest # same test as 40cursor.t except ib_softcommit is enabled use strict; use warnings; use Test::More; use DBI qw(:sql_types); use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ( $dbh, $error_str ) = $T->connect_to_database( { ChopBlanks => 1 } ); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 16; } ok($dbh, 'Connected to the database'); # DBI->trace(4, "trace.txt"); # ------- TESTS ------------------------------------------------------------- # $dbh->{ib_softcommit} = 1; # # Find a possible new table name # my $table = find_new_table($dbh); ok($table, "TABLE is '$table'"); my $def = "CREATE TABLE $table(user_id INTEGER, comment VARCHAR(20))"; my %values = ( 1 => 'Lazy', 2 => 'Hubris', 6 => 'Impatience', ); ok($dbh->do($def), "CREATE TABLE '$table'"); my $sql_insert = "INSERT INTO $table VALUES (?, ?)"; ok(my $cursor = $dbh->prepare($sql_insert), 'PREPARE INSERT'); ok($cursor->execute($_, $values{$_}), "INSERT id $_") for (keys %values); $dbh->{AutoCommit} = 0; my $sql_sele = qq{SELECT * FROM $table WHERE user_id < 5 FOR UPDATE OF comment}; ok(my $cursor2 = $dbh->prepare($sql_sele), 'PREPARE SELECT'); ok($cursor2->execute, 'EXCUTE SELECT'); # Before.. while (my @res = $cursor2->fetchrow_array) { ok($dbh->do( "UPDATE $table SET comment = 'Zzzzz...' WHERE CURRENT OF $cursor2->{CursorName}"), "DO UPDATE where cursor name is '$cursor2->{CursorName}'" ); } ok(my $cursor3 = $dbh->prepare( "SELECT * FROM $table WHERE user_id < 5"), 'PREPARE SELECT'); ok($cursor3->execute, 'EXECUTE SELECT'); # After.. while (my @res = $cursor3->fetchrow_array) { is($res[1], 'Zzzzz...', 'FETCHROW result check'); } # # Drop the test table # $dbh->{AutoCommit} = 1; ok( $dbh->do("DROP TABLE $table"), "DROP TABLE '$table'" ); DBD-Firebird-1.39/t/42-blobs.t0000644000175000017500000000605413632246355013641 0ustar damdam#!/usr/local/bin/perl # # # This is a test for correct handling of BLOBS; namely $dbh->quote # is expected to work correctly. # # 2011-01-29 stefansbv # New version based on t/testlib.pl and Firebird.dbtest use strict; use warnings; use Test::More; use Test::Exception; use DBI qw(:sql_types); use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ( $dbh, $error_str ) = $T->connect_to_database( { ChopBlanks => 1, LongReadLen => 524288, } ); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } ok($dbh, 'Connected to the database'); # ------- TESTS ------------------------------------------------------------- # # # Find a possible new table name # my $table = find_new_table($dbh); #diag $table; ok($table); my $def = qq{ CREATE TABLE $table ( id INTEGER NOT NULL PRIMARY KEY, name BLOB ) }; # Repeat test? foreach my $size ( 1 .. 5 ) { # # Create a new table # ok( $dbh->do($def), qq{CREATE TABLE '$table'} ); $dbh->{AutoCommit} = 0; # # Create a blob # my $blob = q{}; # Empty my $b = ""; for ( my $j = 0 ; $j < 256 ; $j++ ) { $b .= chr($j); } $blob = $b x $size; # # Insert a row into the test table....... # my ($query); my $sql_insert = "INSERT INTO $table VALUES(?, ?)"; # if ($ENV{'SHOW_BLOBS'} && open(OUT, ">" . $ENV{'SHOW_BLOBS'})) { # print OUT $query; # close(OUT); # } ok( my $cursor = $dbh->prepare($sql_insert), 'PREPARE INSERT blobs' ); # Insert 10 rows for ( my $i = 0 ; $i < 10 ; $i++ ) { ok( $cursor->execute( $i, $blob ), "EXECUTE INSERT row $i" ); } # # Now, try SELECT'ing the row out. # my $sql_sele = qq{SELECT * FROM $table WHERE id < 10 ORDER BY id}; ok( my $cursor2 = $dbh->prepare($sql_sele), 'PREPARE SELECT blobs' ); ok( $cursor2->execute(), "EXECUTE SELECT blobs" ); for ( my $i = 0 ; $i < 10 ; $i++ ) { ok( ( my $row = $cursor2->fetchrow_arrayref ), 'FETCHROW' ); is( $$row[0], $i, 'ID matches' ); is( $$row[1], $blob, 'BLOB matches' ); # Some supplementary inserts if ( $i >= 5 ) { my $id = $i + 10; ok( $cursor->execute( $id, $blob ), "EXECUTE INSERT $id" ); } } ok( $cursor2->finish ); ok( $cursor->finish ); # # Finally drop the test table. # $dbh->{AutoCommit} = 1; ok( $dbh->do("DROP TABLE $table"), "DROP TABLE '$table'" ); } # repeat test ok( $dbh->do($def), qq{CREATE TABLE '$table'} ); my $random_bin = ''; $random_bin .= chr(int(rand(256))) for 1..600_000; ok( $dbh->do( "INSERT into $table values(?, ?)", undef, 42, $random_bin ), "insert blog larger than LongReadLen" ); throws_ok { $dbh->selectall_arrayref("select * from $table WHERE id = 42") } qr/Not enough LongReadLen buffer/, "Fetching a BLOB larger than LongReadLen throws"; #- end test done_testing(); DBD-Firebird-1.39/t/02-ib_embedded.t0000644000175000017500000000057411654054465014741 0ustar damdamuse strict; use warnings; use Test::More; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; plan tests => 2; my( $dbh, $error ) = $T->connect_to_database; ok(!$error, "Connected to database") or diag($error); my $is_embedded = ( ref($T) eq 'TestFirebirdEmbedded' ); is( $dbh->{ib_embedded}, $is_embedded, 'ib_embedded is true only for FirebirdEmbedded' ); DBD-Firebird-1.39/t/50-chopblanks.t0000644000175000017500000000457712007201302014645 0ustar damdam#!/usr/local/bin/perl # # # This driver should check whether 'ChopBlanks' works. # # 2011-01-29 stefansbv # New version based on t/testlib.pl and Firebird.dbtest use strict; use warnings; use Test::More; use DBI; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ( $dbh, $error_str ) = $T->connect_to_database( { ChopBlanks => 1 } ); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } else { plan tests => 38; } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } ok($dbh, 'Connected to the database'); # DBI->trace(4, "trace.txt"); # ------- TESTS ------------------------------------------------------------- # # # Find a possible new table name # my $table = find_new_table($dbh); ok($table, "TABLE is '$table'"); # # Create a new table # my $fld_len = 20; # length of the name field my $def =<<"DEF"; CREATE TABLE $table ( id INTEGER PRIMARY KEY, name CHAR($fld_len) ) DEF ok( $dbh->do($def), qq{CREATE TABLE '$table'} ); my @rows = ( [ 1, '' ], [ 2, ' ' ], [ 3, ' a b c ' ] ); foreach my $ref (@rows) { my ($id, $name) = @{$ref}; #- Insert my $insert = qq{ INSERT INTO $table (id, name) VALUES (?, ?) }; ok(my $sth1 = $dbh->prepare($insert), 'PREPARE INSERT'); ok($sth1->execute($id, $name), "EXECUTE INSERT ($id)"); #- Select my $sele = qq{SELECT id, name FROM $table WHERE id = ?}; ok(my $sth2 = $dbh->prepare($sele), 'PREPARE SELECT'); #-- First try to retrieve without chopping blanks. $sth2->{ChopBlanks} = 0; ok($sth2->execute($id), "EXECUTE SELECT 1 ($id)"); ok(my $nochop = $sth2->fetchrow_arrayref, 'FETCHrow ARRAYref 1'); # Right padding name to the length of the field my $n_ncb = sprintf("%-*s", $fld_len, $name); is($nochop->[1], $n_ncb, 'COMPARE 1'); ok($sth2->finish, 'FINISH 1'); #-- Now try to retrieve with chopping blanks. $sth2->{ChopBlanks} = 1; ok($sth2->execute($id), "EXECUTE SELECT 2 ($id)"); ( my $n_cb = $name ) =~ s{\s+$}{}g; ok(my $chopping = $sth2->fetchrow_arrayref, 'FETCHrow ARRAYref 2'); is($chopping->[1], $n_cb, 'COMPARE 2'); ok($sth2->finish, 'FINISH 2'); } # # Drop the test table # $dbh->{AutoCommit} = 1; ok( $dbh->do("DROP TABLE $table"), "DROP TABLE '$table'" ); # # Finally disconnect. # ok($dbh->disconnect, 'DISCONNECT'); DBD-Firebird-1.39/t/20-createdrop.t0000644000175000017500000000207313210537136014651 0ustar damdam#!/usr/bin/perl # # # 2011-04-05 stefan(s.bv.) # Adapted to the new test library # # 2011-01-21 stefan(s.bv.) # New version based on t/testlib.pl and Firebird.dbtest use strict; use warnings; use Test::More; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ($dbh, $error_str) = $T->connect_to_database; if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 5; } ok($dbh, 'Connected to the database'); # ------- TESTS ------------------------------------------------------------- # # # Find a possible new table name # my $table = find_new_table($dbh); ok($table, qq{Table is '$table'}); # # Create a new table # my $def =<<"DEF"; CREATE TABLE $table ( id INTEGER NOT NULL PRIMARY KEY, name CHAR(64) ) DEF ok( $dbh->do($def), qq{CREATE TABLE '$table'} ); # # ... and drop it. # ok( $dbh->do(qq{DROP TABLE $table}), qq{DROP TABLE '$table'} ); # # Finally disconnect. # ok( $dbh->disconnect ); DBD-Firebird-1.39/t/dbi-primary_key_info.t0000644000175000017500000000344712777067127016431 0ustar damdam#!perl -w # vim: ft=perl # Changes 2011-01-21 stefansbv: # - use testlib.pl instead of lib.pl use strict; use warnings; use Test::More; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ( $dbh, $error_str ) = $T->connect_to_database( { RaiseError => 1, PrintError => 0, AutoCommit => 0 } ); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 13; } ok($dbh, 'Connected to the database'); # ------- TESTS ------------------------------------------------------------- # # # Find a possible new table name # my $table = find_new_table($dbh); ok($table, qq{Table is '$table'}); ok($dbh->do(<<__eosql), "CREATE TABLE $table"); CREATE TABLE $table( Z INTEGER NOT NULL, Y CHAR(10) NOT NULL, X INTEGER NOT NULL, K CHAR(3) NOT NULL, PRIMARY KEY(Z, Y, X), UNIQUE(K) ) __eosql my $sth = $dbh->primary_key_info(undef, undef, $table); ok($sth, "Got primary key info"); is_deeply($sth->{NAME_uc}, [qw|TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME KEY_SEQ PK_NAME|]); my $key_info = $sth->fetch; is_deeply([@$key_info[0..4]], [ undef, undef, $table, 'Z', '1' ]); ok($key_info->[5] =~ /\S/, "PK_NAME is set"); # Something like RBD$PRIMARY123 $key_info = $sth->fetch; is_deeply([@$key_info[0..4]], [ undef, undef, $table, 'Y', '2' ]); ok($key_info->[5] =~ /\S/, "PK_NAME is set"); $key_info = $sth->fetch; is_deeply([@$key_info[0..4]], [ undef, undef, $table, 'X', '3' ]); ok($key_info->[5] =~ /\S/, "PK_NAME is set"); $sth->finish; undef($sth); is_deeply([ $dbh->primary_key(undef, undef, $table) ], [qw|Z Y X|], "Check primary_key results"); ok($dbh->do("DROP TABLE $table"), "Dropped table"); $dbh->disconnect(); DBD-Firebird-1.39/t/rt54561.t0000644000175000017500000000240211654054466013342 0ustar damdam#!/usr/bin/perl -w # test for https://rt.cpan.org/Ticket/Display.html?id=54561 use strict; use warnings; use Test::More; use Test::Exception; use DBI qw(:sql_types); use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ($dbh, $error_str) = $T->connect_to_database( { ChopBlanks => 1 } ); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 9; } ok($dbh); my $table = find_new_table($dbh); ok($dbh->do(<<"EOF")); CREATE TABLE $table ( ID INT NOT NULL PRIMARY KEY, CHARFIELD VARCHAR(100) NOT NULL ) EOF ok(my $sth = $dbh->prepare(<<"EOF")); INSERT INTO $table (ID, CHARFIELD) VALUES (?, ?) EOF # the {} on the end is CRITICAL ok($sth->bind_param_array(1, [qw/1 2 3 /] ), 'bind_param_array'); lives_and { ok( $sth->bind_param_array( 2, [qw/Foo Bar Baz/], {} ) ) } 'bind_param_array works with attr'; is $sth->execute_array({}), 3, 'execute_array'; $sth = $dbh->prepare("SELECT * FROM $table"); $sth->execute; is_deeply( $sth->fetchall_arrayref, [ [ 1, 'Foo' ], [ 2, 'Bar' ], [ 3, 'Baz' ] ], 'bind_param_array data present' ); ok($dbh->do("DROP TABLE $table")); ok($dbh->disconnect); DBD-Firebird-1.39/t/92-bigdecimal10_read.t0000644000175000017500000000510513141170144015740 0ustar damdam#!/usr/bin/perl # # 2011-04-13 stefan(s.bv.) Modified to run on Windows. # # 2011-01-31 stefan(s.bv.) Created new test: # Playing with very big | small numbers # Smallest and biggest decimal supported by Firebird: # -922337203685477.5808, 922337203685477.5807 # use strict; use warnings; use Math::BigFloat try => 'GMP'; use Test::More; use DBI; use lib 't','.'; use TestFirebird; my $T = TestFirebird->new; my ($dbh, $error_str) = $T->connect_to_database(); if ($error_str) { BAIL_OUT("Unknown: $error_str!"); } unless ( $dbh->isa('DBI::db') ) { plan skip_all => 'Connection to database failed, cannot continue testing'; } else { plan tests => 17; } ok($dbh, 'dbh OK'); # ------- TESTS ------------------------------------------------------------- # # Find a new table name my $table = find_new_table($dbh); ok($table, "TABLE is '$table'"); $dbh->do(<do(<do(<do(<do(<do(<trace(4, "trace.txt"); # Expected fetched values my @correct = ( [ '-922337203.6854775808', '922337203.6854775807' ], [ '-0.0000000003', '0.0000000003' ], [ '-0.0000000006', '0.0000000006' ], [ '-0.0000000005', '0.0000000005' ], [ '-0', '0' ], ); # Select the values ok( my $cursor = $dbh->prepare( qq{SELECT * FROM $table} ), 'PREPARE SELECT' ); ok($cursor->execute, 'EXECUTE SELECT'); ok((my $res = $cursor->fetchall_arrayref), 'FETCHALL'); my ($types, $names, $fields) = @{$cursor}{qw(TYPE NAME NUM_OF_FIELDS)}; for (my $i = 0; $i < @$res; $i++) { for (my $j = 0; $j < $fields; $j++) { my $result = qq{$res->[$i][$j]}; my $mresult = Math::BigFloat->new($result); my $corect = $correct[$i][$j]; my $mcorect = Math::BigFloat->new($corect); is($mresult, $mcorect, "Field: $names->[$j] is $corect"); #diag "got: $mresult"; #diag "exp: $mcorect"; } } # Drop the test table $dbh->{AutoCommit} = 1; ok( $dbh->do("DROP TABLE $table"), "DROP TABLE '$table'" ); # Finally disconnect. ok($dbh->disconnect(), 'DISCONNECT'); #-- end TESTS DBD-Firebird-1.39/var/0000755000175000017500000000000014743133212012437 5ustar damdamDBD-Firebird-1.39/var/.keep_dir0000644000175000017500000000000012203070373014205 0ustar damdamDBD-Firebird-1.39/inc/0000755000175000017500000000000014743133212012420 5ustar damdamDBD-Firebird-1.39/inc/FirebirdMaker.pm0000644000175000017500000005540214153070503015470 0ustar damdampackage FirebirdMaker; use warnings; use strict; use base 'Exporter'; use Carp; use ExtUtils::MakeMaker; use File::Basename; use File::Which (); use Config; our @EXPORT_OK = qw( WriteMakefile1 setup_for_ms_gcc setup_for_ms_cl setup_for_cygwin locate_firebird check_and_set_devlibs alternative_locations search_fb_home_dirs search_fb_inc_dirs search_fb_lib_dirs locate_firebird_ms registry_lookup read_registry read_data save_test_parameters read_test_parameters prompt_for_settings prompt_for check_str check_path check_exe check_file help_message welcome_msg closing_msg create_embedded_files detect_firebird_api_version $test_conf $test_mark $use_libfbembed ); our @EXPORT = @EXPORT_OK; our ( $use_libfbembed ); # Temp file names our $test_conf = 't/tests-setup.tmp.conf'; our $test_mark = 't/tests-setup.tmp.OK'; $FB::API_VER = 0; # Written by Alexandr Ciornii, version 0.23. Added by eumm-upgrade. sub WriteMakefile1 { my %params = @_; my $eumm_version = $ExtUtils::MakeMaker::VERSION; $eumm_version = eval $eumm_version; die "EXTRA_META is deprecated" if exists $params{EXTRA_META}; die "License not specified" if not exists $params{LICENSE}; if ( $params{AUTHOR} and ref( $params{AUTHOR} ) eq 'ARRAY' and $eumm_version < 6.5705 ) { $params{META_ADD}{author} = $params{AUTHOR}; $params{AUTHOR} = join( ', ', @{ $params{AUTHOR} } ); } if ( $params{BUILD_REQUIRES} and $eumm_version < 6.5503 ) { #EUMM 6.5502 has problems with BUILD_REQUIRES $params{PREREQ_PM} = { %{ $params{PREREQ_PM} || {} }, %{ $params{BUILD_REQUIRES} } }; delete $params{BUILD_REQUIRES}; } delete $params{CONFIGURE_REQUIRES} if $eumm_version < 6.52; delete $params{MIN_PERL_VERSION} if $eumm_version < 6.48; delete $params{META_MERGE} if $eumm_version < 6.46; delete $params{META_ADD} if $eumm_version < 6.46; delete $params{LICENSE} if $eumm_version < 6.31; delete $params{AUTHOR} if $] < 5.005; delete $params{ABSTRACT_FROM} if $] < 5.005; delete $params{BINARY_LOCATION} if $] < 5.005; WriteMakefile(%params); } #- Helper SUBS ---------------------------------------------------------------# #-- Subs for OS specific setting sub setup_for_ms_gcc { # Support for MinGW (still experimental, patches welcome!) # ActiveState: cc => V:\absolute\path\to\gcc.exe # Strawberry : cc => gcc print "Using MinGW gcc\n"; # For ActiveState Perl hardwired MinGW path # other idea? my $mingw_path = 'C:\Perl\site\lib\auto\MinGW'; # Expecting absolute paths in Straberry Perl my $mingw_inc = $Config{incpath}; # For ActiveState Perl is \include # always? if ( $mingw_inc eq '\include' ) { $mingw_inc = File::Spec->catpath( $mingw_path, $mingw_inc ); } my $mingw_lib = $Config{libpth}; # For ActiveState Perl is \lib # always? if ( $mingw_lib eq '\lib' ) { $mingw_lib = File::Spec->catpath( $mingw_path, $mingw_lib ); } $INC .= qq{ -I"$mingw_inc"}; my $cur_libs = $Config{libs}; my $cur_lddlflags = $Config{lddlflags}; my $lib; if ( -f "$FB::LIB/fbclient_ms.lib" ) { $lib = "$FB::LIB/fbclient_ms.lib"; } else { $lib = "$FB::LIB/gds32_ms.lib"; } # This is ugly :) eval " sub MY::const_loadlibs { ' LDLOADLIBS = \"$lib\" $cur_libs LDDLFLAGS = -L\"$mingw_lib\" $cur_lddlflags ' } "; } sub setup_for_ms_cl { my $cur_libs = $Config{libs}; my $cur_lddlflags = $Config{lddlflags}; my $lib; if (-f "$FB::LIB/fbclient_ms.lib") { $lib = "$FB::LIB/fbclient_ms.lib"; } else { $lib = "$FB::LIB/gds32_ms.lib"; } eval " sub MY::const_loadlibs { ' LDLOADLIBS = \"$lib\" $cur_libs LDDLFLAGS = $cur_lddlflags ' } "; } sub setup_for_cygwin { my $cur_libs = $Config{libs}; my $cur_lddlflags = $Config{lddlflags}; my $dll; if ( -f "$FB::HOME/bin/fbclient.dll" ) { $dll = "$FB::HOME/bin/fbclient.dll"; } else { $dll = "$FB::HOME/bin/gds32.dll"; } eval " sub MY::const_loadlibs { ' LDLOADLIBS = -Wl,--enable-stdcall-fixup \"$dll\" $cur_libs LDDLFLAGS = $cur_lddlflags ' } "; } #-- Subs used to locate Firebird =head2 detect_firebird_api_version Reads F (in the directory stored in C<$FB::INC>) and tries to extract the firebird API version value from the C define. =cut sub detect_firebird_api_version { return if $FB::API_VER; open( my $fh, '<', File::Spec->catfile( $FB::INC, 'ibase.h' ) ) or die "open($FB::INC/ibase.h): $!"; while (<$fh>) { $FB::API_VER = $1, last if /^#define FB_API_VER (\w+)/; } close($fh); warn "Detected Firebird API version $FB::API_VER\n" if $FB::API_VER; } =head2 locate_firebird On *nix like systems try different standard paths. =cut sub locate_firebird { if ( my $fb_config = File::Which::which('fb_config') ) { warn "Using $fb_config as data source\n"; my $cflags = `fb_config --cflags`; chomp $cflags; my @items = split(/\s+/, $cflags); for (@items) { if (s/^-I\s*//) { $FB::INC = $_; last; } } my $libflags = `fb_config --libs`; chomp $libflags; @items = split( /\s+/, $libflags ); for (@items) { if ( s/^-L\s*// ) { $FB::LIB = $_; last; } } my $fb_conf = `fb_config --confdir`; chomp $fb_conf; check_and_set_devlibs($fb_conf); return; } my @bd = search_fb_home_dirs(); foreach my $dir (@bd) { if ( -d $dir ) { # File names specific to the Firebird/bin dir my @fb_files = qw{fbsql isql-fb isql}; # fbsql not yet! but 'isql' is # used by Virtuoso and UnixODBC # That's why Debian ships it as # isql-fb my $found = 0; while ( !$found ) { my $file = shift @fb_files or last; $file = File::Spec->catfile( $dir, 'bin', $file ); if ( -f $file and -x $file ) { # Located my $out = `echo 'quit;' | $file -z 2>&1`; next unless $out =~ /firebird/si; # Firebird's isql? check_and_set_devlibs($dir); last; } } } } return; } =head2 check_and_set_devlibs Check and set global variables for home, inc and lib (?...). =cut sub check_and_set_devlibs { my $fb_dir = shift; $FB::HOME = File::Spec->canonpath($fb_dir); $FB::INC = $FB::INC || File::Spec->catdir( $FB::HOME, 'include' ); $FB::INC = alternative_locations('inc') if !-d $FB::INC || !-f File::Spec->catfile($FB::INC, "ibase.h"); $FB::LIB = $FB::LIB || File::Spec->catdir( $FB::HOME, 'lib' ); $FB::LIB = alternative_locations('lib') if !-d $FB::LIB; detect_firebird_api_version(); for my $dir ( split(/ /, $Config{libpth} ), $FB::LIB||() ) { if ( -e File::Spec->catfile( $dir, 'libfbembed.so' ) ) { $FB::libfbembed_available = 1; print "libfbembed.so found in $dir\n"; last; } } die "libfbembed.so not found\n" if $ENV{DBD_FIREBIRD_REQUIRE_EMBEDDED} and not $FB::libfbembed_available and $FB::API_VER < 30; return; } =head2 alternative_locations Search lib and inc in alternative locations. =cut sub alternative_locations { my $find_what = shift; my @fid = (); @fid = search_fb_lib_dirs() if $find_what eq q{lib}; @fid = search_fb_inc_dirs() if $find_what eq q{inc}; foreach my $dir ( @fid ) { return $dir if -d $dir; } help_message(); die "Firebird '$find_what' dir not located!"; } =head2 search_fb_home_dirs Common places for the Firebird home dir. =cut sub search_fb_home_dirs { # Add other standard paths here return ( qw{ /opt/firebird /usr/local/firebird /usr/local /usr/lib/firebird /usr }, ); } =head2 search_fb_inc_dirs Common places for the Firebird include dir. =cut sub search_fb_inc_dirs { # Add other standard paths here for include return ( qw{ /usr/include/firebird /usr/local/include/firebird }, ); } =head2 search_fb_lib_dirs Common places for the Firebird lib dir. =cut sub search_fb_lib_dirs { # Add other standard paths here for lib return ( qw{ /usr/lib/firebird /usr/local/lib/firebird }, ); } =head2 locate_firebird_ms On Windows use the Registry to locate Firebird. =cut sub locate_firebird_ms { my $hp_ref = registry_lookup('fb'); if (ref $hp_ref) { $FB::HOME = $FB::HOME || File::Spec->canonpath($hp_ref->[0]); $FB::INC = $FB::INC || File::Spec->catdir( $FB::HOME, 'include' ); $FB::LIB = $FB::LIB || File::Spec->catdir( $FB::HOME, 'lib' ); } } sub registry_lookup { my $what = shift; my $reg_data = read_data($what); my $value; foreach my $rec ( @{$reg_data->{$what}} ) { $value = read_registry($rec) } return $value; } sub read_registry { my $rec = shift; my (@path, $path); eval { require Win32::TieRegistry; $path = Win32::TieRegistry->new( $rec->{path} )->GetValue( $rec->{key} ); }; if ($@) { # TieRegistry fails on this key sometimes for some reason my $out = `reg query "$rec->{path}" /v $rec->{key}`; ($path) = $out =~ /REG_\w+\s+(.*)/; } $path =~ s/[\r\n]+//g; push @path, $path if $path; return wantarray ? @path : \@path; } =head2 read_data Read various default settings from the DATA section of this script. =cut sub read_data { my $app_alias = shift; my %reg_data; while () { my ($app, $key, $path) = split /:/, $_, 3; chomp $path; next if $app ne $app_alias; push @{ $reg_data{$app} }, { key => $key, path => $path } ; } return \%reg_data; } sub save_test_parameters { my ($db_path, $db_host, $user, $pass) = @_; open my $t_fh, '>', $test_conf or die "Can't write $test_conf: $!"; my $test_time = scalar localtime(); my @record = ( q(# This is a temporary file used for test setup #), q(# The field separator is := #), q(# Should be deleted at the end of installation #), q(# Init section ------ (created by Makefile.PL) #), q(# Time: ) . $test_time, ); $db_host = $db_host || q{localhost}; # not ||= for compatibility # Other settings (interactive mode) push @record, qq(host:=$db_host); push @record, qq(path:=$db_path) if $db_path; push @record, qq(tdsn:=dbi:Firebird:db=$db_path;host=$db_host;ib_dialect=3;ib_charset=UTF8) if $db_path; push @record, qq(user:=$user) if $user; push @record, qq(pass:=$pass) if $pass; push @record, qq(use_libfbembed:=1) if $use_libfbembed; my $rec = join "\n", @record; print {$t_fh} $rec, "\n"; close $t_fh or die "Can't close $test_conf: $!"; # Remove the mark file if (-f $test_mark) { unlink $test_mark or warn "Could not unlink $test_mark: $!"; } return; } sub read_test_parameters { my $record = {}; if (-f $test_conf) { print "\nReading cached test configuration...\n"; open my $file_fh, '<', $test_conf or croak "Can't open file ", $test_conf, ": $!"; foreach my $line (<$file_fh>) { next if $line =~ m{^#+}; # skip comments my ($key, $val) = split /:=/, $line, 2; chomp $val; $record->{$key} = $val; } close $file_fh; } return $record; } #-- Prompting subs ... sub prompt_for_settings { my $param = read_test_parameters(); my ($user, $pass) = (qw{SYSDBA masterkey}); # some defaults my ($db_path, $db_host); # If saved configs exists set them as defaults if ( ref $param ) { $user = $param->{user} || $user; $pass = $param->{pass} || $pass; $db_host = $param->{host} || 'localhost'; $db_path = $param->{path} || File::Spec->catfile( File::Spec->tmpdir(), 'dbd-fb-testdb.fdb' ); } print qq{\nStarting interactive setup, two attempts for each option,\n}; print qq{ if both fail, the script will abort ...\n}; print qq{\n Enter the full paths to the Firebird instalation:\n}; $FB::HOME = prompt_for( 'path', ' Home:', $FB::HOME ); $FB::INC = $FB::INC || File::Spec->catdir( $FB::HOME, 'include' ); $FB::LIB = $FB::LIB || File::Spec->catdir( $FB::HOME, 'lib' ); $FB::INC = prompt_for( 'path', ' Include:', $FB::INC ); $FB::LIB = prompt_for( 'path', ' Lib:', $FB::LIB ); print qq{\n Configuring the test environment ...\n}; $db_host = prompt_for('str', ' Hostname:', $db_host ); print qq{\n Enter the full path and file name of the test database (.fdb):\n}; $db_path = prompt_for( 'file', ' Test DB:', $db_path ); unless ($use_libfbembed) { print qq{\n Enter authentication options:\n}; $user = prompt_for('str', ' Username:', $user ); $pass = prompt_for('str', ' Password:', $pass ); print "\n"; } save_test_parameters($db_path, $db_host, $user, $pass); return; } =head2 prompt_for Show prompt. =cut sub prompt_for { my ( $type, $msg, $value ) = @_; LOOP: { for ( 1 .. 2 ) { $value = prompt( $msg, $value ); $value = File::Spec->canonpath($value) if ( $type eq q{path} or $type eq q{exe} ); my $check_sub = qq{check_$type}; last LOOP if ( main->$check_sub($value) ); } die "Unable to locate $type. Aborting ..."; } return $value; } sub check_str { return ( $_[1] ) } sub check_path { return ( -d $_[1] ) } sub check_exe { return ( -x $_[1] ) } =head2 prompt_new_file Because we can't make difference between a simple path and a path with a file name without extension, the fdb extension is required for the test database. =cut sub check_file { my ($self, $value) = @_; my ($base, $db_path, $type) = fileparse($value, '\.fdb' ); return 0 if $type ne q{.fdb}; # expecting file with fdb extension return ( -d $db_path and $base ); } #-- Help and message subs sub help_message { my $msg =<<"MSG"; This script prepares the installation of the DBD::Firebird module, automatically with minimum user intervention or in interactive mode. In non interactive mode will try to determine the location of the Firebird HOME, LIBRARY and INCLUDE directories: 1. From the environment variable FIREBIRD_HOME. Also FIREBIRD_INCLUDE and FIREBIRD_LIB if they are not sub directories of FIREBIRD_HOME. 2. From the standard (hardwired) locations where Firebird can be installed on various platforms and distros. If no success, execute this script with the I<-i[nteractive]> command line option, or set the required environment variables. % perl Makefile.PL -i[nteractive] The tests requires the path to the test database, the user name and the password. All options have defaults: DBI_USER = 'SYSDBA', DBI_PASS = 'masterkey', or run the script in interactive mode. (ISC_USER and ISC_PASSWORD are recognized also), for DBI_DSN the default is: dbi:Firebird:db=OS_tmp_path/dbd-fb-testdb.fdb;host=localhost; ib_dialect=3;ib_charset=UTF8 If all else fails, email for help. MSG print $msg; } sub welcome_msg { my $msg =<<"MSG"; This script prepares the installation of the DBD::Firebird module. Warning: the process will create a temporary file to store the values required for the testing phase, including the password for access to the Firebird server in plain text: 't/tests-setup.tmp.conf'. MSG print $msg; } sub closing_msg { my $msg =<<"MSG"; Please, set at least DBI_PASS (or ISC_PASSWORD), before 'make test'. The default for DBI_USER is 'SYSDBA'. MSG print $msg unless $use_libfbembed; } sub copy_mangled { my ( $src, $p ) = @_; my $dir = 'embed'; my $df = $p->{new_path} || File::Spec->catfile( $dir, $p->{name} || $src ); open( my $dfh, '>', $df ) or die "Unable to open $df for writing: $!\n"; open( my $sfh, '<', $src ) or die "Unable to open $src: $!\n"; my ($prefix, $skip_shebang); if ( $src =~ /\.(?:xs|[ch])$/ ) { $prefix = '//'; $skip_shebang = 0; } elsif ( $src =~ /\.pl$/i ) { $prefix = '#'; $skip_shebang = 1; } else { $prefix = '#'; $skip_shebang = 0; } my $header_warning = sub { my $line = '*' x 60; print $dfh "\n" if $skip_shebang; print $dfh "$prefix $line\n"; print $dfh "$prefix This is an automaticaly generated file.\n"; print $dfh "$prefix If needed, edit $src in the parent directory\n"; print $dfh "$prefix and run perl Makefile.PL to re-generate it.\n"; print $dfh "$prefix $line\n\n"; }; my $line_no = 0; while ( defined( $_ = <$sfh> ) ) { &$header_warning if $line_no++ == $skip_shebang; last if $p->{last} and &{ $p->{last} }($_); &{ $p->{mangle} }($_) if $p->{mangle}; print $dfh $_; } close($dfh) or die "Error closing $df: $!\n"; close($sfh) or die "Error closing $src: $!\n"; } sub create_embedded_files { my $dir = "embed"; unless (-d $dir) { mkdir($dir) or die "Error creating directory $dir: $!\n"; } # Makefile.PL copy_mangled( 'Makefile.PL' => { last => sub { $_[0] =~ /^exit 0/ }, mangle => sub { $_[0] =~ s/(?<=^our \$EMBEDDED = )0/1/ }, } ); # Simple copies for my $f (qw( dbdimp.h )) { copy_mangled($f); } copy_mangled( 'Firebird.h' => { name => 'FirebirdEmbedded.h', }, ); # dbdimp.c copy_mangled( 'dbdimp.c' => { mangle => sub { $_[0] =~ s/(?<=^#include "Firebird)\.h"/Embedded.h"/ }, }, ); my $next_is_last = 0; copy_mangled( 'Firebird.pm' => { name => 'FirebirdEmbedded.pm', last => sub { return 1 if $next_is_last; if ( $_[0] =~ /^=head1 DESCRIPTION$/ ) { $next_is_last = 1; $_[0] .= < is a variant of L, linked with the Firebird embedded library, F. In addition to the ability to work with remote Firebird servers (which DBD::Firebird has, being linked with the Firebird client library, F), DBD::FirebirdEmbedded can be used to work with Firebird databases without the need of a dedicated Firebird server. The following things should be set up first: =over =item Username/password These should be unset. Both in the C<< DBI->connection(...) >> call and in the environment (C, C, C, C variables). =item Firebird lock directory The C environment variable should be set to some place where the process can write. Note that if you plan for several processes to access the database file directly, they all should have C set to the same directory, or else database corruption will occur. =item No C in the DSN Obviously, do not set any host when calling C<< DBI->connection(...) >>, not even C. =item Permissions to read/write the database Obviously, the process needs to be able to read/write the database file. =back =head1 COMPARISON WITH DBD::FIREBIRD DBD::FirebirdEmbedded provides exactly the same functionality as the Firebird server of the same version as the F library. It still can work with remote datases, in which case the use is exactly the same (DSN, environment) as with the regular L. =head2 Pros =over =item Standalone work with Firebird databases No need to setup/administer a Firebird server. All the server functionality is available via the F library. Shared access to databases is still possible (but read L above). =item No network latency Working directly with the database file eliminates possible network delays (even if the server is on the local host). =back =head2 Cons =over =item Memory footprint The F library contains a fully functional Firebird server and is therefore bigger than the ordinary client library, F. =item Setup complexity It is very important to make sure that all processes that access a given database use the same lock directory. See L above. =back =head1 SEE ALSO =over =item L =back EOT } return 0; }, mangle => sub { $_[0] =~ s/DBD::Firebird - DBI driver for.+/DBD::FirebirdEmbedded - embedded Firebird server (and client)/; $_[0] =~ s/dbi:Firebird:.+/dbi:FirebirdEmbedded:db=\$dbname", undef, undef);/g; $_[0] =~ s/(? { name => 'FirebirdEmbedded.xs', mangle => sub { $_[0] =~ s/Firebird.h/FirebirdEmbedded.h/; $_[0] =~ s/DBD::Firebird/DBD::FirebirdEmbedded/g; $_[0] =~ s/(?<=^INCLUDE: Firebird).xsi/Embedded.xsi/; }, }, ); for my $f ( glob('t/*.t') ) { next if $f =~ 't/embed'; ( my $n = $f ) =~ s,t/,t/embed-,; copy_mangled( $f => { new_path => $n, mangle => sub { $_[0] =~ s/DBD::Firebird\b(?!::(?:Get|Type|Table)Info)/DBD::FirebirdEmbedded/g; $_[0] =~ s/TestFirebird\b/TestFirebirdEmbedded/g; }, } ); } } 1; #-- Known registry keys __DATA__ fb:DefaultInstance:HKEY_LOCAL_MACHINE\SOFTWARE\Firebird Project\Firebird Server\Instances vc:ProductDir:HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\VisualStudio\6.0\Setup\Microsoft Visual C++ vc:ProductDir:HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\VisualStudio\7.0\Setup\VC vc:ProductDir:HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\VisualStudio\9.0\Setup\VC vc:ProductDir:HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\VisualStudio\10.0\Setup\VC vc:ProductDir:HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\VisualStudio\11.0\Setup\VC pv:CurrentVersion:HKEY_LOCAL_MACHINE\SOFTWARE\ActiveState\ActivePerl pl::HKEY_LOCAL_MACHINE\SOFTWARE\ActiveState\ActivePerl\1203 DBD-Firebird-1.39/Firebird.xs0000644000175000017500000014502514743132245013765 0ustar damdam/* Copyright (c) 2011 Stefan Suciu Copyright (c) 2011, 2025 Damyan Ivanov Copyright (c) 1999-2008 Edwin Pratomo Portions Copyright (c) 2001-2005 Daniel Ritz You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. */ /* vim: set noai ts=4 et sw=4: */ #include "Firebird.h" DBISTATE_DECLARE; static int _cancel_callback(SV *dbh, IB_EVENT *ev) { ISC_STATUS status[ISC_STATUS_LENGTH]; D_imp_dbh(dbh); int ret = 0; if (ev->exec_cb) croak("Can't be called from inside a callback"); if (ev->perl_cb) { ev->state = INACTIVE; SvREFCNT_dec(ev->perl_cb); ev->perl_cb = (SV*)NULL; isc_cancel_events(status, &(imp_dbh->db), &(ev->id)); if (ib_error_check(dbh, status)) ret = 0; else ret = 1; } else croak("No callback found for this event handle. Have you called ib_register_callback?"); return ret; } static int _call_perlsub(IB_EVENT ISC_FAR *ev, short length, #if defined(INCLUDE_TYPES_PUB_H) || defined(FIREBIRD_IMPL_TYPES_PUB_H) const ISC_UCHAR *updated #else char ISC_FAR *updated #endif ) { int retval = 1; #if defined(USE_THREADS) || defined(USE_ITHREADS) || defined(MULTIPLICITY) /* save context, set context from dbh */ void *context = PERL_GET_CONTEXT; PERL_SET_CONTEXT(ev->dbh->context); { #else void *context = PERL_GET_CONTEXT; PerlInterpreter *cb_perl = perl_alloc(); PERL_SET_CONTEXT(cb_perl); { #endif dSP; int i, count; SV **svp; HV *posted_events = newHV(); ISC_ULONG ecount[15]; #if defined(INCLUDE_TYPES_PUB_H) || defined(FIREBIRD_IMPL_TYPES_PUB_H) ISC_UCHAR *result = ev->result_buffer; #else char ISC_FAR *result = ev->result_buffer; #endif while (length--) *result++ = *updated++; isc_event_counts(ecount, ev->epb_length, ev->event_buffer, ev->result_buffer); for (i = 0; i < ev->num; i++) { if (ecount[i]) { svp = hv_store(posted_events, *(ev->names + i), strlen(*(ev->names + i)), newSViv(ecount[i]), 0); if (svp == NULL) croak("Bad: key '%s' not stored", *(ev->names + i)); } } ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(sv_2mortal(newRV_noinc((SV*)posted_events))); PUTBACK; count = perl_call_sv(ev->perl_cb, G_SCALAR); SPAGAIN; if (count > 0) retval = POPi; PUTBACK; FREETMPS; LEAVE; #if defined(USE_THREADS) || defined(USE_ITHREADS) || defined(MULTIPLICITY) } /* restore old context*/ PERL_SET_CONTEXT(context); #else } PERL_SET_CONTEXT(context); perl_free(cb_perl); #endif return retval; } /* callback function for events, called by Firebird */ /* static isc_callback _async_callback(IB_EVENT ISC_FAR *ev, short length, char ISC_FAR *updated) */ static ISC_EVENT_CALLBACK _async_callback(IB_EVENT ISC_FAR *ev, #if defined(INCLUDE_TYPES_PUB_H) || defined(FIREBIRD_IMPL_TYPES_PUB_H) ISC_USHORT length, const ISC_UCHAR *updated #else short length, char ISC_FAR *updated #endif ) { ISC_STATUS status[ISC_STATUS_LENGTH]; switch (ev->state) { case INACTIVE: break; case ACTIVE: ev->exec_cb = 1; if (_call_perlsub(ev, length, updated) == 0) { ev->state = INACTIVE; ev->exec_cb = 0; break; } ev->exec_cb = 0; isc_que_events( status, &(ev->dbh->db), &(ev->id), ev->epb_length, ev->event_buffer, (ISC_EVENT_CALLBACK)_async_callback, ev ); } return (0); } MODULE = DBD::Firebird PACKAGE = DBD::Firebird #ifndef FB_API_VER #define FB_API_VER 0 #endif BOOT: HV *stash = gv_stashpv( "DBD::Firebird", TRUE ); newCONSTSUB( stash, "fb_api_ver", newSViv(FB_API_VER) ); newCONSTSUB( stash, "client_major_version", newSViv( isc_get_client_major_version() ) ); newCONSTSUB( stash, "client_minor_version", newSViv( isc_get_client_minor_version() ) ); { char version_string[1024]; isc_get_client_version(version_string); int len = strlen(version_string); if (len > 1023) die("Version string buffer overflow detected"); SV *ver = newSVpv(version_string, len); newCONSTSUB( stash, "client_version", ver ); } INCLUDE: Firebird.xsi MODULE = DBD::Firebird PACKAGE = DBD::Firebird::db void _do(dbh, statement, attr=Nullsv) SV * dbh SV * statement PROTOTYPE: $$;$@ CODE: { D_imp_dbh(dbh); ISC_STATUS status[ISC_STATUS_LENGTH]; /* isc api status vector */ STRLEN slen; int retval; char *sbuf = SvPV(statement, slen); DBI_TRACE_imp_xxh(imp_dbh, 1, (DBIc_LOGPIO(imp_dbh), "db::_do\n" "Executing : %s\n", sbuf)); /* we need an open transaction */ if (!imp_dbh->tr) { DBI_TRACE_imp_xxh(imp_dbh, 1, (DBIc_LOGPIO(imp_dbh), "starting new transaction..\n")); if (!ib_start_transaction(dbh, imp_dbh)) { retval = -2; XST_mUNDEF(0); /* <= -2 means error */ return; } DBI_TRACE_imp_xxh(imp_dbh, 1, (DBIc_LOGPIO(imp_dbh), "new transaction started.\n")); } /* we need to count the DDL statement whether in soft / hard commit */ #if 0 /* only execute_immediate statment if NOT in soft commit mode */ if (!(imp_dbh->soft_commit)) { isc_dsql_execute_immediate(status, &(imp_dbh->db), &(imp_dbh->tr), 0, sbuf, imp_dbh->sqldialect, NULL); if (ib_error_check(dbh, status)) retval = -2; else retval = -1 ; } else #endif /* count DDL statements is necessary for ib_commit_transaction to work properly */ { isc_stmt_handle stmt = 0L; /* temp statment handle */ static char stmt_info[] = { isc_info_sql_stmt_type }; char info_buffer[20]; /* statment info buffer */ retval = -2; do { char count_item = 0; /* init statement handle */ if (isc_dsql_alloc_statement2(status, &(imp_dbh->db), &stmt)) break; /* prepare statement */ isc_dsql_prepare(status, &(imp_dbh->tr), &stmt, 0, sbuf, imp_dbh->sqldialect, NULL); if (ib_error_check(dbh, status)) break; /* get statement type */ if (!isc_dsql_sql_info(status, &stmt, sizeof(stmt_info), stmt_info, sizeof(info_buffer), info_buffer)) { /* need to count DDL statments */ short l = (short) isc_vax_integer((char *) info_buffer + 1, 2); ISC_LONG stmt_type = isc_vax_integer((char *) info_buffer + 3, l); switch (stmt_type) { case isc_info_sql_stmt_ddl: imp_dbh->sth_ddl++; break; case isc_info_sql_stmt_insert: count_item = isc_info_req_insert_count; break; case isc_info_sql_stmt_update: count_item = isc_info_req_update_count; break; case isc_info_sql_stmt_delete: count_item = isc_info_req_delete_count; break; } } else break; /* exec the statement */ isc_dsql_execute(status, &(imp_dbh->tr), &stmt, imp_dbh->sqldialect, NULL); if (!ib_error_check(dbh, status)) retval = -1; if (count_item) { ISC_LONG rows = ib_rows(dbh, &stmt, count_item); if ( rows >= 0 ) retval = rows; } } while (0); /* close statement */ if (stmt) isc_dsql_free_statement(status, &stmt, DSQL_drop); } /* for AutoCommit: commit */ if (DBIc_has(imp_dbh, DBIcf_AutoCommit)) { if (!ib_commit_transaction(dbh, imp_dbh)) retval = -2; } if (retval < -1) XST_mUNDEF(0); else XST_mIV(0, retval); /* typically 1, rowcount or -1 */ } void _ping(dbh) SV * dbh CODE: { int ret; ret = dbd_db_ping(dbh); if (ret == 0) XST_mUNDEF(0); else XST_mIV(0, ret); } #define TX_INFOBUF(name, len) \ if (strEQ(item, #name)) { \ *p++ = (char) isc_info_tra_##name; \ res_len += len + 3; \ item_buf_len++; \ continue; \ } #define TX_RESBUF_CASE(name) \ case isc_info_tra_##name:\ {\ keyname = #name;\ /* PerlIO_printf(PerlIO_stderr(), "Got %s\n", keyname); */\ p++;\ length = isc_vax_integer (p, 2);\ p += 2;\ (void)hv_store(RETVAL, keyname, strlen(keyname), \ newSViv(isc_vax_integer(p, (short) length)), 0);\ p += length;\ break;\ } HV* ib_tx_info(dbh) SV* dbh PREINIT: char* p; char* result = NULL; short result_length = 0; ISC_STATUS status[ISC_STATUS_LENGTH]; CODE: { D_imp_dbh(dbh); char request[] = { isc_info_tra_id, #if defined(FB_API_VER) && FB_API_VER >= 20 /* FB 2.0: */ isc_info_tra_oldest_interesting, isc_info_tra_oldest_active, isc_info_tra_oldest_snapshot, isc_info_tra_lock_timeout, isc_info_tra_isolation, isc_info_tra_access, #endif isc_info_end }; RETVAL = newHV(); if (!RETVAL) { if (result) { Safefree(result); } do_error(dbh, 2, "unable to allocate hash return value"); XSRETURN_UNDEF; } if (!imp_dbh->tr) { do_error(dbh, 2, "No active transaction"); XSRETURN_UNDEF; } /* calc required result buffer size */ for (p = request; *p != isc_info_end; p++) { result_length++; /* identifier (1 byte)*/ switch (*p) { #if defined(FB_API_VER) && FB_API_VER >= 20 case isc_info_tra_isolation: /* result: length (2 bytes) + first content (1 byte) + length (2 bytes) + second content (2 bytes max) */ result_length += 7; break; case isc_info_tra_access: /* result: length (2 bytes) + content (1 byte) */ result_length += 3; break; #endif default: result_length += 2; /* length (2 bytes) */ result_length += 4; /* pessimistic */ } } result_length += 1; /* add 1 byte for isc_info_end */ /* try insufficient result_length: result_length = 40; */ try_alloc_result_buffer: Newxz(result, result_length, char); /* PerlIO_printf(PerlIO_stderr(), "result_length: %d\n", result_length); */ /* call */ isc_transaction_info(status, &(imp_dbh->tr), sizeof(request), request, result_length, result); if (ib_error_check(dbh, status)) { XSRETURN_UNDEF; } else { /* detect truncation */ for (p = result + result_length - 1; p > result; p--) { if (*p != 0) { break; } } if (p > result) { /* PerlIO_printf(PerlIO_stderr(), "First non-null byte found at: %d\n", (p - result)); */ if (*p == isc_info_truncated) { /* PerlIO_printf(PerlIO_stderr(), "Truncation detected.\n"); */ /* increase result_length, retry allocation */ result_length += 10; Safefree(result); result = NULL; goto try_alloc_result_buffer; } } /* parse result */ for (p = result; p < result + result_length; ) { char *keyname; short length; if (*p == isc_info_end) { /* PerlIO_printf(PerlIO_stderr(), "isc_info_end encountered at byte: %d\n", (p - result)); */ break; } switch (*p) { TX_RESBUF_CASE(id) #if defined(FB_API_VER) && FB_API_VER >= 20 TX_RESBUF_CASE(oldest_interesting) TX_RESBUF_CASE(oldest_active) TX_RESBUF_CASE(oldest_snapshot) TX_RESBUF_CASE(lock_timeout) case isc_info_tra_isolation: { HV* reshv; short length = isc_vax_integer(++p, 2); /* PerlIO_printf(PerlIO_stderr(), "Content length: %d\n", length); */ keyname = "isolation"; /* PerlIO_printf(PerlIO_stderr(), "Got 'isolation' at byte: %d\n", (p - 1 - result)); */ p += 2; if (*p == isc_info_tra_consistency) { (void)hv_store(RETVAL, keyname, strlen(keyname), newSVpv("consistency", 0), 0); } else if (*p == isc_info_tra_concurrency) { (void)hv_store(RETVAL, keyname, strlen(keyname), newSVpv("snapshot (concurrency)", 0), 0); } else if (*p == isc_info_tra_read_committed) { /* warn("got 'read_committed'"); */ reshv = newHV(); if (!reshv) { if (result) { Safefree(result); } do_error(dbh, 2, "unable to allocate hash for read_committed rec/no_rec version"); XSRETURN_UNDEF; } if (*(p + 1) == isc_info_tra_no_rec_version) { (void)hv_store(reshv, "read_committed", 14, newSVpv("no_rec_version", 0), 0); } else if (*(p + 1) == isc_info_tra_rec_version) { (void)hv_store(reshv, "read_committed", 14, newSVpv("rec_version", 0), 0); } else { warn("unrecognized byte"); continue; } (void)hv_store(RETVAL, keyname, strlen(keyname), newRV_noinc((SV*) reshv), 0); } else { PerlIO_printf(PerlIO_stderr(), "+2: got unrecognized byte: %d\n", *((char*)p)); } p += length; break; } case isc_info_tra_access: { short length = isc_vax_integer(++p, 2); keyname = "access"; /* PerlIO_printf(PerlIO_stderr(), "Got 'access' at byte: %d\n", (p - 1 - result)); */ p += 2; if (*p == isc_info_tra_readonly) { (void)hv_store(RETVAL, keyname, strlen(keyname), newSVpvn("readonly", 8), 0); } else if (*p == isc_info_tra_readwrite) { (void)hv_store(RETVAL, keyname, strlen(keyname), newSVpvn("readwrite", 9), 0); } p += length; break; } #endif default: /* PerlIO_printf(PerlIO_stderr(), "now at byte: %d\n", (p - result)); */ p++; } } } } OUTPUT: RETVAL CLEANUP: SvREFCNT_dec(RETVAL); #undef TX_INFOBUF #undef TX_RESBUF_CASE int ib_set_tx_param(dbh, ...) SV *dbh ALIAS: set_tx_param = 1 PREINIT: STRLEN len; char *tx_key, *tx_val, *tpb, *tmp_tpb; int i, rc = 0; int tpb_len; char am_set = 0, il_set = 0, ls_set = 0; I32 j; AV *av; HV *hv; SV *sv, *sv_value; HE *he; CODE: { D_imp_dbh(dbh); #ifdef PERL_UNUSED_VAR PERL_UNUSED_VAR(ix); /* -Wall */ #endif /* if no params or first parameter = 0 or undef -> reset TPB to NULL */ if (items < 3) { if ((items == 1) || !(SvTRUE(ST(1)))) { tpb = NULL; tmp_tpb = NULL; tpb_len = 0; goto do_set_tpb; } } /* we need to know the max. size of TBP, (buffer overflow problem) */ /* mem usage: -access_mode: max. 1 byte */ /* -isolation_level: max. 2 bytes */ /* -lock_resolution: max. 1 byte */ /* -reserving: max. 4 bytes + strlen(tablename) */ tpb_len = 5; /* 4 + 1 for tpb_version */ /* we need to add the length of each table name + 4 bytes */ for (i = 1; i < items-1; i += 2) { sv_value = ST(i + 1); if (strEQ(SvPV_nolen(ST(i)), "-reserving")) if (SvROK(sv_value) && SvTYPE(SvRV(sv_value)) == SVt_PVHV) { hv = (HV *)SvRV(sv_value); hv_iterinit(hv); while ((he = hv_iternext(hv))) { /* retrieve the size of table name(s) */ HePV(he, len); tpb_len += len + 4; } } } /* alloc it */ Newx(tmp_tpb, tpb_len, char); /* do set TPB values */ tpb = tmp_tpb; *tpb++ = isc_tpb_version3; for (i = 1; i < items; i += 2) { tx_key = SvPV_nolen(ST(i)); sv_value = ST(i + 1); /* value specified? */ if (i >= items - 1) { Safefree(tmp_tpb); croak("You must specify parameter => value pairs, but there's no value for %s", tx_key); } /**********************************************************************/ if (strEQ(tx_key, "-access_mode")) { if (am_set) { warn("-access_mode already set; ignoring second try!"); continue; } tx_val = SvPV_nolen(sv_value); if (strEQ(tx_val, "read_write")) *tpb++ = isc_tpb_write; else if (strEQ(tx_val, "read_only")) *tpb++ = isc_tpb_read; else { Safefree(tmp_tpb); croak("Unknown -access_mode value %s", tx_val); } am_set = 1; /* flag */ } /**********************************************************************/ else if (strEQ(tx_key, "-isolation_level")) { if (il_set) { warn("-isolation_level already set; ignoring second try!"); continue; } if (SvROK(sv_value) && SvTYPE(SvRV(sv_value)) == SVt_PVAV) { av = (AV *)SvRV(sv_value); /* sanity check */ for (j = 0; (j <= av_len(av)) && !rc; j++) { sv = *av_fetch(av, j, FALSE); if (strEQ(SvPV_nolen(sv), "read_committed")) { rc = 1; *tpb++ = isc_tpb_read_committed; } } if (!rc) { Safefree(tmp_tpb); croak("Invalid -isolation_level value"); } for (j = 0; j <= av_len(av); j++) { tx_val = SvPV_nolen(*(av_fetch(av, j, FALSE))); if (strEQ(tx_val, "record_version")) { *tpb++ = isc_tpb_rec_version; break; } else if (strEQ(tx_val, "no_record_version")) { *tpb++ = isc_tpb_no_rec_version; break; } else if (!strEQ(tx_val, "read_committed")) { Safefree(tmp_tpb); croak("Unknown -isolation_level value %s", tx_val); } } } else { tx_val = SvPV_nolen(sv_value); if (strEQ(tx_val, "read_committed")) *tpb++ = isc_tpb_read_committed; else if (strEQ(tx_val, "snapshot")) *tpb++ = isc_tpb_concurrency; else if (strEQ(tx_val, "snapshot_table_stability")) *tpb++ = isc_tpb_consistency; else { Safefree(tmp_tpb); croak("Unknown -isolation_level value %s", tx_val); } } il_set = 1; /* flag */ } /**********************************************************************/ else if (strEQ(tx_key, "-lock_resolution")) { if (ls_set) { warn("-lock_resolution already set; ignoring second try!"); continue; } if (SvROK(sv_value) && SvTYPE(SvRV(sv_value)) == SVt_PVHV) { #if defined(FB_API_VER) && FB_API_VER >= 20 hv = (HV *)SvRV(sv_value); if (hv_exists(hv, "wait", 4)) { *tpb++ = isc_tpb_wait; sv = *hv_fetch(hv, "wait", 4, FALSE); if (SvIOK(sv)) { IV lock_timeout = SvIV(sv); if (lock_timeout < 0) { do_error(dbh, 2, "Wait timeout value must be positive integer"); XSRETURN_UNDEF; } else if (lock_timeout > 0) { *tpb++ = isc_tpb_lock_timeout; *tpb++ = sizeof(ISC_LONG); /* length = 4 bytes */ *(ISC_LONG*)tpb = lock_timeout; /* infinite timeout */ tpb += sizeof(ISC_LONG); } } else { do_error(dbh, 2, "Wait timeout value must be positive integer"); XSRETURN_UNDEF; } } else { do_error(dbh, 2, "The only valid key is 'wait'"); XSRETURN_UNDEF; } #else do_error(dbh, 2, "Hashref unsupported. Must be compiled with Firebird 2.0 client library"); XSRETURN_UNDEF; #endif } else { tx_val = SvPV_nolen(sv_value); if (strEQ(tx_val, "wait")) *tpb++ = isc_tpb_wait; else if (strEQ(tx_val, "no_wait")) *tpb++ = isc_tpb_nowait; else { Safefree(tmp_tpb); croak("Unknown transaction parameter %s", tx_val); } } ls_set = 1; /* flag */ } /**********************************************************************/ else if (strEQ(tx_key, "-reserving")) { if (SvROK(sv_value) && SvTYPE(SvRV(sv_value)) == SVt_PVHV) { char *table_name; HV *table_opts; hv = (HV *)SvRV(sv_value); hv_iterinit(hv); while ((he = hv_iternext(hv))) { /* check val type */ if (SvROK(HeVAL(he)) && SvTYPE(SvRV(HeVAL(he))) == SVt_PVHV) { table_opts = (HV*)SvRV(HeVAL(he)); /* if (hv_exists(table_opts, "access", 6)) { comment: access is optional sv = *hv_fetch(table_opts, "access", 6, FALSE); if (strnEQ(SvPV_nolen(sv), "shared", 6)) *tpb++ = isc_tpb_shared; else if (strnEQ(SvPV_nolen(sv), "protected", 9)) *tpb++ = isc_tpb_protected; else { Safefree(tmp_tpb); croak("Invalid -reserving access value"); } } */ if (hv_exists(table_opts, "lock", 4)) { /* lock is required */ sv = *hv_fetch(table_opts, "lock", 4, FALSE); if (strnEQ(SvPV_nolen(sv), "read", 4)) *tpb++ = isc_tpb_lock_read; else if (strnEQ(SvPV_nolen(sv), "write", 5)) *tpb++ = isc_tpb_lock_write; else { Safefree(tmp_tpb); croak("Invalid -reserving lock value"); } } else /* lock */ { Safefree(tmp_tpb); croak("Lock value is required in -reserving"); } /* add the table name to TPB */ table_name = HePV(he, len); *tpb++ = len + 1; { unsigned int k; for (k = 0; k < len; k++) *tpb++ = toupper(*table_name++); } *tpb++ = 0; if (hv_exists(table_opts, "access", 6)) { /* access is optional */ sv = *hv_fetch(table_opts, "access", 6, FALSE); if (strnEQ(SvPV_nolen(sv), "shared", 6)) *tpb++ = isc_tpb_shared; else if (strnEQ(SvPV_nolen(sv), "protected", 9)) *tpb++ = isc_tpb_protected; else { Safefree(tmp_tpb); croak("Invalid -reserving access value"); } } } /* end hashref check*/ else { Safefree(tmp_tpb); croak("Reservation for a given table must be hashref."); } } /* end of while() */ } else { Safefree(tmp_tpb); croak("Invalid -reserving value. Must be hashref."); } } /* end table reservation */ else { Safefree(tmp_tpb); croak("Unknown transaction parameter %s", tx_key); } } /* an ugly label... */ do_set_tpb: Safefree(imp_dbh->tpb_buffer); imp_dbh->tpb_buffer = tmp_tpb; imp_dbh->tpb_length = tpb - imp_dbh->tpb_buffer; /* for AutoCommit: commit current transaction */ if (DBIc_has(imp_dbh, DBIcf_AutoCommit)) { imp_dbh->sth_ddl++; ib_commit_transaction(dbh, imp_dbh); } RETVAL = 1; } OUTPUT: RETVAL #******************************************************************************* # only for use within database_info! #define DB_INFOBUF(name, len) \ if (strEQ(item, #name)) { \ *p++ = (char) isc_info_##name; \ res_len += len + 3; \ item_buf_len++; \ continue; \ } #define DB_RESBUF_CASEHDR(name) \ case isc_info_##name:\ keyname = #name; HV * ib_database_info(dbh, ...) SV *dbh PREINIT: unsigned int i, count; char item_buf[30], *p, *old_p; char *res_buf; short item_buf_len, res_len; AV *av; ISC_STATUS status[ISC_STATUS_LENGTH]; CODE: { D_imp_dbh(dbh); /* process input params, count max. result buffer length */ p = item_buf; res_len = 0; item_buf_len = 0; /* array or array ref? */ if (items == 2 && SvROK(ST(1)) && SvTYPE(SvRV(ST(1))) == SVt_PVAV) { av = (AV *)SvRV(ST(1)); count = av_len(av) + 1; } else { av = NULL; count = items; } /* loop thru all elements */ for (i = 0; i < count; i++) { char *item; /* fetch from array or array ref? */ if (av) item = SvPV_nolen(*av_fetch(av, i, FALSE)); else item = SvPV_nolen(ST(i + 1)); /* database characteristics */ DB_INFOBUF(allocation, 4); DB_INFOBUF(base_level, 2); DB_INFOBUF(db_id, 513); DB_INFOBUF(implementation, 3); DB_INFOBUF(no_reserve, 1); DB_INFOBUF(db_read_only, 1); DB_INFOBUF(ods_minor_version, 1); DB_INFOBUF(ods_version, 1); DB_INFOBUF(page_size, 4); DB_INFOBUF(version, 257); DB_INFOBUF(db_sql_dialect, 1); /* environmental characteristics */ DB_INFOBUF(current_memory, 4); DB_INFOBUF(forced_writes, 1); DB_INFOBUF(max_memory, 4); DB_INFOBUF(num_buffers, 4); DB_INFOBUF(sweep_interval, 4); DB_INFOBUF(user_names, 1024); /* can be more, can be less */ /* performance statistics */ DB_INFOBUF(fetches, 4); DB_INFOBUF(marks, 4); DB_INFOBUF(reads, 4); DB_INFOBUF(writes, 4); #if defined(FB_API_VER) && FB_API_VER >= 20 /* FB 2.0 */ DB_INFOBUF(active_tran_count, 4); DB_INFOBUF(creation_date, sizeof(ISC_TIMESTAMP)); /* 2 x 4 bytes */ #endif /* database operation counts */ /* XXX - not implemented (complicated: returns a descriptor for _each_ table...how to fetch / store this??) but do we really need these? */ } /* the end marker */ *p++ = isc_info_end; item_buf_len++; /* allocate the result buffer */ res_len += 256; /* add some safety...just in case */ Newx(res_buf, res_len, char); /* call the function */ isc_database_info(status, &(imp_dbh->db), item_buf_len, item_buf, res_len, res_buf); if (ib_error_check(dbh, status)) { Safefree(res_buf); XSRETURN_UNDEF; // croak("isc_database_info failed!"); } /* fill hash with key/value pairs */ RETVAL = newHV(); for (p = res_buf; *p != isc_info_end; ) { char *keyname; char item = *p++; int length = isc_vax_integer (p, 2); p += 2; old_p = p; switch (item) { /******************************************************************/ /* database characteristics */ DB_RESBUF_CASEHDR(allocation) (void)hv_store(RETVAL, keyname, strlen(keyname), newSViv(isc_vax_integer(p, (short) length)), 0); break; DB_RESBUF_CASEHDR(base_level) (void)hv_store(RETVAL, keyname, strlen(keyname), newSViv(isc_vax_integer(++p, 1)), 0); break; DB_RESBUF_CASEHDR(db_id) { HV *reshv = newHV(); ISC_LONG slen; (void)hv_store(reshv, "connection", 10, (isc_vax_integer(p++, 1) == 2)? newSVpv("local", 0): newSVpv("remote", 0), 0); slen = isc_vax_integer(p++, 1); (void)hv_store(reshv, "database", 8, newSVpvn(p, slen), 0); p += slen; slen = isc_vax_integer(p++, 1); (void)hv_store(reshv, "site", 8, newSVpvn(p, slen), 0); (void)hv_store(RETVAL, keyname, strlen(keyname), newRV_noinc((SV *) reshv), 0); break; } DB_RESBUF_CASEHDR(implementation) { HV *reshv = newHV(); (void)hv_store(reshv, "implementation", 14, newSViv(isc_vax_integer(++p, 1)), 0); (void)hv_store(reshv, "class", 5, newSViv(isc_vax_integer(++p, 1)), 0); (void)hv_store(RETVAL, keyname, strlen(keyname), newRV_noinc((SV *) reshv), 0); break; } DB_RESBUF_CASEHDR(no_reserve) (void)hv_store(RETVAL, keyname, strlen(keyname), newSViv(isc_vax_integer(p, (short) length)), 0); break; DB_RESBUF_CASEHDR(db_read_only) (void)hv_store(RETVAL, keyname, strlen(keyname), newSViv(isc_vax_integer(p, (short) length)), 0); break; DB_RESBUF_CASEHDR(ods_minor_version) (void)hv_store(RETVAL, keyname, strlen(keyname), newSViv(isc_vax_integer(p, (short) length)), 0); break; DB_RESBUF_CASEHDR(ods_version) (void)hv_store(RETVAL, keyname, strlen(keyname), newSViv(isc_vax_integer(p, (short) length)), 0); break; DB_RESBUF_CASEHDR(page_size) (void)hv_store(RETVAL, keyname, strlen(keyname), newSViv(isc_vax_integer(p, (short) length)), 0); break; DB_RESBUF_CASEHDR(version) { ISC_LONG slen; slen = isc_vax_integer(++p, 1); (void)hv_store(RETVAL, keyname, strlen(keyname), newSVpvn(++p, slen), 0); break; } #ifdef isc_dpb_sql_dialect DB_RESBUF_CASEHDR(db_sql_dialect) (void)hv_store(RETVAL, keyname, strlen(keyname), newSViv(isc_vax_integer(p, (short) length)), 0); break; #endif /******************************************************************/ /* environmental characteristics */ DB_RESBUF_CASEHDR(current_memory) (void)hv_store(RETVAL, keyname, strlen(keyname), newSViv(isc_vax_integer(p, (short) length)), 0); break; DB_RESBUF_CASEHDR(forced_writes) (void)hv_store(RETVAL, keyname, strlen(keyname), newSViv(isc_vax_integer(p, (short) length)), 0); break; DB_RESBUF_CASEHDR(max_memory) (void)hv_store(RETVAL, keyname, strlen(keyname), newSViv(isc_vax_integer(p, (short) length)), 0); break; DB_RESBUF_CASEHDR(num_buffers) (void)hv_store(RETVAL, keyname, strlen(keyname), newSViv(isc_vax_integer(p, (short) length)), 0); break; DB_RESBUF_CASEHDR(sweep_interval) (void)hv_store(RETVAL, keyname, strlen(keyname), newSViv(isc_vax_integer(p, (short) length)), 0); break; DB_RESBUF_CASEHDR(user_names) { AV *avres; SV **svp; ISC_LONG slen; /* array already existing? no -> create */ if (!hv_exists(RETVAL, "user_names", 10)) { avres = newAV(); (void)hv_store(RETVAL, "user_names", 10, newRV_noinc((SV *) avres), 0); } else { svp = hv_fetch(RETVAL, "user_names", 10, 0); if (!svp || !SvROK(*svp)) { Safefree(res_buf); croak("Error fetching hash value"); } avres = (AV *) SvRV(*svp); } /* add value to the array */ slen = isc_vax_integer(p++, 1); av_push(avres, newSVpvn(p, slen)); break; } /******************************************************************/ /* performance statistics */ DB_RESBUF_CASEHDR(fetches) (void)hv_store(RETVAL, keyname, strlen(keyname), newSViv(isc_vax_integer(p, (short) length)), 0); break; DB_RESBUF_CASEHDR(marks) (void)hv_store(RETVAL, keyname, strlen(keyname), newSViv(isc_vax_integer(p, (short) length)), 0); break; DB_RESBUF_CASEHDR(reads) (void)hv_store(RETVAL, keyname, strlen(keyname), newSViv(isc_vax_integer(p, (short) length)), 0); break; DB_RESBUF_CASEHDR(writes) (void)hv_store(RETVAL, keyname, strlen(keyname), newSViv(isc_vax_integer(p, (short) length)), 0); break; #if defined(FB_API_VER) && FB_API_VER >= 20 /* FB 2.0 */ DB_RESBUF_CASEHDR(active_tran_count) (void)hv_store(RETVAL, keyname, strlen(keyname), newSViv(isc_vax_integer(p, (short) length)), 0); break; DB_RESBUF_CASEHDR(creation_date) { struct tm times; ISC_TIMESTAMP cdatetime; char tbuf[100]; Zero(tbuf, sizeof(tbuf), char); cdatetime.timestamp_date = isc_vax_integer(p, sizeof(ISC_DATE)); cdatetime.timestamp_time = isc_vax_integer(p + sizeof(ISC_DATE), sizeof(ISC_TIME)); isc_decode_timestamp(&cdatetime, ×); strftime(tbuf, sizeof(tbuf), "%c", ×); (void)hv_store(RETVAL, keyname, strlen(keyname), newSVpvn(tbuf, strlen(tbuf)), 0); break; } #endif default: break; } p = old_p + length; } /* don't leak */ Safefree(res_buf); } OUTPUT: RETVAL CLEANUP: SvREFCNT_dec(RETVAL); #undef DB_INFOBUF #undef DB_RESBUF_CASEHDR int ib_drop_database(dbh) SV *dbh PREINIT: ISC_STATUS status[ISC_STATUS_LENGTH]; CODE: { D_imp_dbh(dbh); /* set the database handle to inactive */ DBIc_ACTIVE_off(imp_dbh); /* rollback */ if (imp_dbh->tr) { isc_rollback_transaction(status, &(imp_dbh->tr)); if (ib_error_check(dbh, status)) XSRETURN(FALSE); imp_dbh->tr = 0L; } FREE_SETNULL(imp_dbh->ib_charset); FREE_SETNULL(imp_dbh->tpb_buffer); FREE_SETNULL(imp_dbh->dateformat); FREE_SETNULL(imp_dbh->timeformat); FREE_SETNULL(imp_dbh->timestampformat); /* drop */ isc_drop_database(status, &(imp_dbh->db)); if (ib_error_check(dbh, status)) RETVAL = 0; else RETVAL = 1; } OUTPUT: RETVAL #******************************************************************************* SV * ib_init_event(dbh, ...) SV *dbh PREINIT: char *CLASS = "DBD::Firebird::Event"; int i; IB_EVENT ev; D_imp_dbh(dbh); CODE: { unsigned short cnt = items - 1; DBI_TRACE_imp_xxh(imp_dbh, 2, (DBIc_LOGPIO(imp_dbh), "Entering init_event(), %d items..\n", cnt)); if (cnt > 0) { /* check for max number of events in a single call to event block allocation */ if (cnt > MAX_EVENTS) croak("Max number of events exceeded."); /* init members */ ev.dbh = imp_dbh; ev.event_buffer = NULL; ev.result_buffer = NULL; ev.id = 0; ev.num = cnt; ev.perl_cb = NULL; ev.state = INACTIVE; ev.exec_cb = 0; Newx(ev.names, MAX_EVENTS, char *); for (i = 0; i < MAX_EVENTS; i++) { if (i < cnt) { /* dangerous! *(ev.names + i) = SvPV_nolen(ST(i + 1)); */ Newx(ev.names[i], SvCUR(ST(i + 1)) + 1, char); strcpy(ev.names[i], SvPV_nolen(ST(i + 1))); } else *(ev.names + i) = NULL; } ev.epb_length = (short) isc_event_block( &(ev.event_buffer), &(ev.result_buffer), cnt, *(ev.names + 0), *(ev.names + 1), *(ev.names + 2), *(ev.names + 3), *(ev.names + 4), *(ev.names + 5), *(ev.names + 6), *(ev.names + 7), *(ev.names + 8), *(ev.names + 9), *(ev.names + 10), *(ev.names + 11), *(ev.names + 12), *(ev.names + 13), *(ev.names + 14)); } else croak("Names of the events in interest are not specified"); { ISC_STATUS status[ISC_STATUS_LENGTH]; ISC_ULONG ecount[15]; isc_wait_for_event(status, &(imp_dbh->db), ev.epb_length, ev.event_buffer, ev.result_buffer); if (ib_error_check(dbh, status)) XSRETURN_UNDEF; //croak("error in isc_wait_for_event()"); isc_event_counts(ecount, ev.epb_length, ev.event_buffer, ev.result_buffer); } RETVAL = sv_bless( newRV_noinc(newSVpvn((char *)&ev, sizeof(ev))), gv_stashpvn(CLASS, strlen(CLASS), GV_ADD)); DBI_TRACE_imp_xxh(imp_dbh, 2, (DBIc_LOGPIO(imp_dbh), "Leaving init_event()\n")); } OUTPUT: RETVAL int ib_register_callback(dbh, ev_rv, perl_cb) SV *dbh SV *ev_rv SV *perl_cb PREINIT: IB_EVENT *ev = (IB_EVENT *)SvPV_nolen(SvRV(ev_rv)); ISC_STATUS status[ISC_STATUS_LENGTH]; D_imp_dbh(dbh); CODE: { DBI_TRACE_imp_xxh(imp_dbh, 2, (DBIc_LOGPIO(imp_dbh), "Entering register_callback()..\n")); /* save the perl callback function */ if (ev->perl_cb == (SV*)NULL) ev->perl_cb = newSVsv(perl_cb); else { if (_cancel_callback(dbh, ev)) SvSetSV(ev->perl_cb, perl_cb); else XSRETURN_UNDEF; } /* set up the events */ isc_que_events( status, &(imp_dbh->db), &(ev->id), ev->epb_length, ev->event_buffer, (ISC_EVENT_CALLBACK)_async_callback, ev); if (ib_error_check(dbh, status)) XSRETURN_UNDEF; else RETVAL = 1; ev->state = ACTIVE; } OUTPUT: RETVAL int ib_cancel_callback(dbh, ev_rv) SV *dbh SV *ev_rv PREINIT: IB_EVENT *ev = (IB_EVENT *) SvPV_nolen(SvRV(ev_rv)); CODE: RETVAL = _cancel_callback(dbh, ev); OUTPUT: RETVAL HV* ib_wait_event(dbh, ev_rv) SV *dbh SV *ev_rv PREINIT: int i; SV **svp; ISC_STATUS status[ISC_STATUS_LENGTH]; D_imp_dbh(dbh); IB_EVENT *ev = (IB_EVENT *)SvPV_nolen(SvRV(ev_rv)); CODE: { isc_wait_for_event(status, &(imp_dbh->db), ev->epb_length, ev->event_buffer, ev->result_buffer); if (ib_error_check(dbh, status)) { do_error(dbh, 2, "ib_wait_event() error"); XSRETURN_UNDEF; } else { ISC_ULONG ecount[15]; isc_event_counts(ecount, ev->epb_length, ev->event_buffer, ev->result_buffer); RETVAL = newHV(); for (i = 0; i < ev->num; i++) { if (ecount[i]) { DBI_TRACE_imp_xxh(imp_dbh, 2, (DBIc_LOGPIO(imp_dbh), "Event %s caught %lu times.\n", *(ev->names + i), (long unsigned)ecount[i])); svp = hv_store(RETVAL, *(ev->names + i), strlen(*(ev->names + i)), newSViv(ecount[i]), 0); if (svp == NULL) croak("Bad: key '%s' not stored", *(ev->names + i)); } } } } OUTPUT: RETVAL void _create_database(params) HV *params CODE: { ISC_STATUS status[ISC_STATUS_LENGTH]; /* isc api status vector */ char *str; size_t len; int page_size; SV *sql, **sv; unsigned short dialect; isc_db_handle db = 0; isc_tr_handle tr = 0; sv = hv_fetch(params, "db_path", 7, FALSE); if ((sv == NULL) || !SvOK(*sv)) croak("Missing db_path"); sql = sv_2mortal( newSVpv( "CREATE DATABASE '", 0 ) ); str = SvPV( *sv, len ); sv_catpvn( sql, str, len ); sv_catpvn( sql, "'", 1 ); sv = hv_fetch( params, "user", 4, FALSE ); if ( (sv != NULL) && SvOK(*sv) ) { str = SvPV( *sv, len ); sv_catpvn( sql, " USER '", 7 ); sv_catpvn( sql, str, len ); sv_catpvn( sql, "'", 1 ); } sv = hv_fetch( params, "password", 8, FALSE ); if ( (sv != NULL) && SvOK(*sv) ) { str = SvPV( *sv, len ); sv_catpvn( sql, " PASSWORD '", 11 ); sv_catpvn( sql, str, len ); sv_catpvn( sql, "'", 1 ); } sv = hv_fetch( params, "page_size", 9, FALSE ); if ( (sv != NULL) && SvOK(*sv) ) { page_size = SvIV(*sv); sv_catpvf( sql, " PAGE_SIZE %d", page_size ); } sv = hv_fetch( params, "character_set", 13, FALSE ); if ( (sv != NULL) && SvOK(*sv) ) { str = SvPV_nolen(*sv); sv_catpvf( sql, " DEFAULT CHARACTER SET %s", str ); } sv = hv_fetch( params, "dialect", 7, FALSE ); if ( (sv != NULL) && SvOK(*sv) ) { dialect = SvIV(*sv); } else { dialect = DEFAULT_SQL_DIALECT; } str = SvPV(sql, len); isc_dsql_execute_immediate( status, &db, &tr, len, str, dialect, NULL ); if( (str = ib_error_decode(status)) != NULL ) { croak("%s", str); } // disconnect from the just created database isc_detach_database( status, &db ); if ( (str = ib_error_decode(status)) != NULL ) { warn("%s", str); } } void _gfix(params) HV *params CODE: { ISC_STATUS status[ISC_STATUS_LENGTH]; /* isc api status vector */ char *db_path; size_t db_path_len; unsigned short buffers = 0; short forced_writes = -1; char *user = NULL, *pwd = NULL; size_t user_len, pwd_len; char ISC_FAR *dpb_buffer, *dpb; short buflen = 0; SV **sv; isc_db_handle db = 0; char *str; sv = hv_fetch(params, "db_path", 7, FALSE); if ((sv == NULL) || !SvOK(*sv)) croak("Missing db_path"); db_path = SvPV(*sv, db_path_len); if (( (sv = hv_fetch(params, "user", 4, FALSE)) != NULL) && SvOK(*sv)) { user = SvPV(*sv, user_len); DPB_PREP_STRING_LEN(buflen, user_len); } if (( (sv = hv_fetch(params, "password", 8, FALSE)) != NULL) && SvOK(*sv)) { pwd = SvPV(*sv, pwd_len); DPB_PREP_STRING_LEN(buflen, pwd_len); } /* the actual interesting stuff -- database parameters */ if (((sv = hv_fetch(params, "buffers", 7, FALSE)) != NULL) && SvOK(*sv)) { buffers = (unsigned short) SvIV(*sv); DPB_PREP_INTEGER(buflen); } if (((sv = hv_fetch(params, "forced_writes", 13, FALSE)) != NULL) && SvOK(*sv)) { forced_writes = SvTRUE(*sv) ? 1 : 0; DPB_PREP_INTEGER(buflen); } /* add length of other parameters to needed buflen */ buflen += 1; /* dbpversion */ /* Allocate DPB */ Newx(dpb_buffer, buflen, char); /* Fill DPB */ dpb = dpb_buffer; *dpb++ = isc_dpb_version1; if ( user != NULL ) { DPB_FILL_STRING_LEN(dpb, isc_dpb_user_name, user, user_len); } if ( pwd != NULL ) { DPB_FILL_STRING_LEN(dpb, isc_dpb_password, pwd, pwd_len); } if (buffers) { DPB_FILL_INTEGER(dpb, isc_dpb_num_buffers, buffers); } if (forced_writes >= 0) { DPB_FILL_INTEGER(dpb, isc_dpb_force_write, forced_writes); } if ( (dpb-dpb_buffer) != buflen ) { fprintf(stderr, "# gfix: DPB length mismatch: %ld != %d\n", dpb-dpb_buffer, buflen); fflush(stderr); abort(); } isc_attach_database(status, /* status vector */ db_path_len, db_path, &db, buflen, dpb_buffer); /* freeing database parameter buffer */ Safefree(dpb_buffer); /* return false on failed attach */ if ( ( str = ib_error_decode(status)) != NULL ) croak("gfix: %s", str); // disconnect from the just created database isc_detach_database( status, &db ); if ( (str = ib_error_decode(status)) != NULL ) { warn("gfix/detach: %s", str); } } MODULE = DBD::Firebird PACKAGE = DBD::Firebird::Event PROTOTYPES: DISABLE void DESTROY(ev_rv) SV *ev_rv PREINIT: IB_EVENT *evh = (IB_EVENT *)SvPV_nolen(SvRV(ev_rv)); int i; ISC_STATUS status[ISC_STATUS_LENGTH]; CODE: { DBI_TRACE_imp_xxh(evh->dbh, 2, (DBIc_LOGPIO(evh->dbh), "Entering DBD::Firebird::Event::DESTROY..\n")); #ifdef DBI_USE_THREADS if (PERL_GET_CONTEXT != evh->dbh->context) { DBI_TRACE_imp_xxh(evh->dbh, 2, (DBIc_LOGPIO(evh->dbh), "DBD::Firebird::Event::DESTROY ignored because owned by thread %p not current thread %p\n", evh->dbh->context, (PerlInterpreter *)PERL_GET_CONTEXT) ); XSRETURN(0); } #endif for (i = 0; i < evh->num; i++) if (*(evh->names + i)) Safefree(*(evh->names + i)); if (evh->names) Safefree(evh->names); if (evh->perl_cb) { SvREFCNT_dec(evh->perl_cb); isc_cancel_events(status, &(evh->dbh->db), &(evh->id)); } if (evh->event_buffer) #if defined(INCLUDE_TYPES_PUB_H) || defined(FIREBIRD_IMPL_TYPES_PUB_H) isc_free((ISC_SCHAR*)evh->event_buffer); #else isc_free(evh->event_buffer); #endif if (evh->result_buffer) #if defined(INCLUDE_TYPES_PUB_H) || defined(FIREBIRD_IMPL_TYPES_PUB_H) isc_free((ISC_SCHAR*)evh->result_buffer); #else isc_free(evh->result_buffer); #endif } MODULE = DBD::Firebird PACKAGE = DBD::Firebird::st char* ib_plan(sth) SV *sth CODE: { D_imp_sth(sth); ISC_STATUS status[ISC_STATUS_LENGTH]; char plan_info[1]; char plan_buffer[PLAN_BUFFER_LEN]; RETVAL = NULL; Zero(plan_buffer, sizeof(plan_buffer), char); plan_info[0] = isc_info_sql_get_plan; if (isc_dsql_sql_info(status, &(imp_sth->stmt), sizeof(plan_info), plan_info, sizeof(plan_buffer), plan_buffer)) { if (ib_error_check(sth, status)) { ib_cleanup_st_prepare(imp_sth); XSRETURN_UNDEF; } } if (plan_buffer[0] == isc_info_sql_get_plan) { short l = (short) isc_vax_integer((char *)plan_buffer + 1, 2); Newx(RETVAL, l + 2, char); snprintf(RETVAL, l+2, "%.*s%s", l, plan_buffer + 3, "\n"); //PerlIO_printf(PerlIO_stderr(), "Len: %d, orig len: %d\n", strlen(imp_sth->plan), l); } } OUTPUT: RETVAL DBD-Firebird-1.39/dbdimp.c0000644000175000017500000030502014743132310013250 0ustar damdam/* vim: set noai ts=4 et sw=4: */ /* Copyright (c) 2010, 2011 Popa Marius Adrian Copyright (c) 2011-2013, 2024, 2025 Damyan Ivanov Copyright (c) 2010 Mike Pomraning Copyright (c) 1999-2008 Edwin Pratomo Portions Copyright (c) 2001-2005 Daniel Ritz You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. */ #include "Firebird.h" #include #ifndef _MSC_VER #include #endif DBISTATE_DECLARE; #define ERRBUFSIZE 255 #define IB_SQLtimeformat(xxh, format, sv) \ do { \ STRLEN len; \ char *frmt = NULL; \ char *buf = SvPV(sv, len); \ if (len < 2 || len > 30) break; \ Newx(frmt, len + 1, char); \ strcpy(frmt, buf); \ if (format) Safefree(format); \ format = frmt; \ } while (0) #define IB_alloc_sqlda(sqlda, n) \ do { \ short len = n; \ char *tmp; \ if (sqlda) \ { \ Safefree(sqlda); \ sqlda = NULL; \ } \ Newxz(tmp, XSQLDA_LENGTH(len), char); \ sqlda = (XSQLDA*)tmp; \ sqlda->sqln = len; \ sqlda->version = SQLDA_OK_VERSION; \ } while (0) #ifndef is_ascii_string #warning "Using built-in implementation of is_ascii_string." #warning "Upgrading perl to 5.12 is suggested." // for perl before 5.12.0 RC1 // taken straight from the perl source bool is_ascii_string(const U8 *s, STRLEN len) { const U8* const send = s + (len ? len : strlen((const char *)s)); const U8* x = s; for (; x < send; ++x) { if (!UTF8_IS_INVARIANT(*x)) break; } return x == send; } #endif int create_cursor_name(SV *sth, imp_sth_t *imp_sth) { ISC_STATUS status[ISC_STATUS_LENGTH]; #define CURSOR_NAME_LEN 22 Newxz(imp_sth->cursor_name, CURSOR_NAME_LEN, char); snprintf(imp_sth->cursor_name, CURSOR_NAME_LEN, "perl%16.16X", (uint32_t)imp_sth->stmt); isc_dsql_set_cursor_name(status, &(imp_sth->stmt), imp_sth->cursor_name, 0); if (ib_error_check(sth, status)) return FALSE; return TRUE; } void maybe_upgrade_to_utf8(imp_dbh_t *imp_dbh, SV *sv) { if (imp_dbh->ib_enable_utf8) { U8 *p; STRLEN len; p = (U8*)SvPV(sv, len); if (!is_ascii_string(p, len) && is_utf8_string(p, len)) { SvUTF8_on(sv); } } } void dbd_init(dbistate_t *dbistate) { DBISTATE_INIT; } void ib_cleanup_st_prepare (imp_sth_t *imp_sth) { FREE_SETNULL(imp_sth->in_sqlda); FREE_SETNULL(imp_sth->out_sqlda); FREE_SETNULL(imp_sth->dateformat); FREE_SETNULL(imp_sth->timeformat); FREE_SETNULL(imp_sth->timestampformat); } void ib_cleanup_st_execute (imp_sth_t *imp_sth) { if (imp_sth->in_sqlda) { int i; XSQLVAR *var = imp_sth->in_sqlda->sqlvar; for (i = 0; i < imp_sth->in_sqlda->sqln; i++, var++) { Safefree(var->sqldata); var->sqldata = NULL; if (var->sqlind) *(var->sqlind) = -1; /* isNULL */ } } } /* lower level error handling */ void do_error(SV *h, int rc, char *what) { D_imp_xxh(h); SV *errstr = DBIc_ERRSTR(imp_xxh); sv_setiv(DBIc_ERR(imp_xxh), (IV)rc); sv_setpv(errstr, what); if (DBIc_TRACE_LEVEL(imp_xxh) >= 2) PerlIO_printf(DBIc_LOGPIO(imp_xxh), "%s error %d recorded: %s\n", what, rc, SvPV(errstr,PL_na)); } #define CALC_AVAILABLE(buff) sizeof(buff) - strlen(buff) - 1 /* decode status vector into a char pointer (implemented by a mortal scalar) Returns NULL if there is no error */ char* ib_error_decode(const ISC_STATUS *status) { SV *sv = NULL; long sqlcode; #if !defined(FB_API_VER) || FB_API_VER < 20 ISC_STATUS *pvector = status; #else const ISC_STATUS *pvector = status; #endif #if defined (INCLUDE_TYPES_PUB_H) || defined(FIREBIRD_IMPL_TYPES_PUB_H) ISC_SCHAR msg[1024]; #else char msg[1024]; #endif if (status[0] != 1 || status[1] <= 0) return NULL; if ((sqlcode = isc_sqlcode(status)) != 0) { isc_sql_interprete((short) sqlcode, msg, sizeof(msg)); sv = sv_2mortal(newSVpv(msg, 0)); } #if !defined(FB_API_VER) || FB_API_VER < 20 while (isc_interprete(msg, &pvector)) #else while (fb_interpret(msg, sizeof(msg), &pvector)) #endif { if ( sv != NULL ) { sv_catpvn(sv, "\n-", 2); sv_catpv(sv, msg); } else sv = sv_2mortal(newSVpv(msg,0)); } sv_catpvn(sv, "\0", 1); // NUL-terminate return SvPV_nolen(sv); } /* higher level error handling, check and decode status */ int ib_error_check(SV *h, ISC_STATUS *status) { char *msg = ib_error_decode(status); if (msg == NULL) return SUCCESS; do_error(h, isc_sqlcode(status), msg); return FAILURE; } static int ib2sql_type(int ibtype) { /* Firebird Internal (not external) types */ switch(ibtype & ~1) { case SQL_TEXT: return DBI_SQL_CHAR; case SQL_LONG: return DBI_SQL_INTEGER; /* integer */ case SQL_SHORT: return DBI_SQL_SMALLINT; /* smallint */ case SQL_FLOAT: return DBI_SQL_FLOAT; case SQL_DOUBLE: return DBI_SQL_DOUBLE; case SQL_TIMESTAMP: return DBI_SQL_TIMESTAMP; case SQL_TYPE_DATE: return DBI_SQL_DATE; case SQL_TYPE_TIME: return DBI_SQL_TIME; case SQL_VARYING: return DBI_SQL_VARCHAR; #ifdef SQL_INT64 case SQL_INT64: return DBI_SQL_BIGINT; #endif #ifdef SQL_BOOLEAN case SQL_BOOLEAN: return DBI_SQL_BOOLEAN; #endif } /* else map type into DBI reserved standard range */ return -9000 - ibtype; } #if 0 /* from DBI (ANSI/ISO/ODBC) types to Firebird types */ static int ib_sql_type(imp_sth_t *imp_sth, char *name, int sql_type) { /* XXX should detect DBI reserved standard type range here */ switch (sql_type) { case DBI_SQL_NUMERIC: case DBI_SQL_DECIMAL: case DBI_SQL_INTEGER: case DBI_SQL_BIGINT: case DBI_SQL_TINYINT: case DBI_SQL_SMALLINT: case DBI_SQL_FLOAT: case DBI_SQL_REAL: case DBI_SQL_DOUBLE: return 481; case DBI_SQL_VARCHAR: return 449; case DBI_SQL_CHAR: return 453; case SQL_DATE: case SQL_TIME: case SQL_TIMESTAMP: default: if (DBIc_WARN(imp_sth) && imp_sth && name) warn("SQL type %d for '%s' is not fully supported, bound as SQL_VARCHAR instead"); return ib_sql_type(imp_sth, name, DBI_SQL_VARCHAR); } } #endif int dbd_db_login6(SV *dbh, imp_dbh_t *imp_dbh, char *dbname, char *uid, char *pwd, SV *attr) { dTHR; ISC_STATUS status[ISC_STATUS_LENGTH]; HV *hv; SV *sv; SV **svp; /* versatile scalar storage */ unsigned short ib_dialect, ib_cache; bool ib_db_triggers = true; char *ib_role; char ISC_FAR *dpb_buffer, *dpb; int connect_timeout = 0; char ISC_FAR *database; STRLEN len, db_len; /* for SvPV */ char dbkey_scope = 0; short dpb_length = 0; unsigned int buflen = 0; /* buffer size is dynamic */ imp_dbh->db = 0L; imp_dbh->tr = 0L; imp_dbh->tpb_buffer = NULL; imp_dbh->tpb_length = 0; imp_dbh->sth_ddl = 0; imp_dbh->soft_commit = 0; /* use soft commit (isc_commit_retaining)? */ imp_dbh->ib_enable_utf8 = FALSE; /* default date/time formats + * * Old API: dateformat ........ %c * timeformat ........ (none) * timestampformat ... (none) * * v6 API: dateformat ........ %x * timeformat ........ %X * timestampformat ... %c */ Newxz(imp_dbh->dateformat, 3, char); strcpy(imp_dbh->dateformat, "%x"); Newxz(imp_dbh->timeformat, 3, char); strcpy(imp_dbh->timeformat, "%X"); Newxz(imp_dbh->timestampformat, 3, char); strcpy(imp_dbh->timestampformat, "%c"); /* linked list */ imp_dbh->first_sth = NULL; imp_dbh->last_sth = NULL; /* save the current context for thread/multiplicy safety */ #if defined(USE_THREADS) || defined(USE_ITHREADS) || defined(MULTIPLICITY) imp_dbh->context = PERL_GET_CONTEXT; #endif /* Parse DSN and init values */ sv = DBIc_IMP_DATA(imp_dbh); if (!sv || !SvROK(sv)) return FALSE; hv = (HV*) SvRV(sv); if (SvTYPE(hv) != SVt_PVHV) return FALSE; if (uid != NULL) { DPB_PREP_STRING(buflen, uid); } if (pwd != NULL) { DPB_PREP_STRING(buflen, pwd); } /* does't go to DPB -> no buflen inc */ if ((svp = hv_fetch(hv, "database", 8, FALSE))) database = SvPV(*svp, db_len); else database = NULL; /* role, cache, charset, sqldialect */ if ((svp = hv_fetch(hv, "ib_dialect", 10, FALSE))) ib_dialect = (unsigned short) SvIV(*svp); else ib_dialect = DEFAULT_SQL_DIALECT; DPB_PREP_INTEGER(buflen); if ((svp = hv_fetch(hv, "ib_cache", 8, FALSE))) { ib_cache = (unsigned short) SvIV(*svp); DPB_PREP_INTEGER(buflen); } else ib_cache = 0; if ((svp = hv_fetch(hv, "ib_charset", 10, FALSE))) { char *p = SvPV(*svp, len); DPB_PREP_STRING_LEN(buflen, len); Newx(imp_dbh->ib_charset, len+1, char); strncpy(imp_dbh->ib_charset, p, len); *(imp_dbh->ib_charset + len) = '\0'; } else { imp_dbh->ib_charset = NULL; } if ((svp = hv_fetch(hv, "ib_role", 7, FALSE))) { ib_role = SvPV(*svp, len); DPB_PREP_STRING_LEN(buflen, len); } else ib_role = NULL; if ((svp = hv_fetch(hv, "ib_dbkey_scope", 14, FALSE))) { dbkey_scope = (char)SvIV(*svp); if (dbkey_scope) DPB_PREP_INTEGER(buflen); } if ((svp = hv_fetch(hv, "timeout", 7, FALSE))) { int val = SvIV(*svp); if (val <= 0) croak("Positive timeout required"); connect_timeout = val; DPB_PREP_INTEGER(buflen); } if ((svp = hv_fetch(hv, "ib_db_triggers", 14, FALSE))) { ib_db_triggers = SvTRUE(*svp); if (!ib_db_triggers) DPB_PREP_BYTE(buflen); } else { if (SvOK(attr)) { HV *attr_h = (HV*) SvRV(attr); if (SvTYPE(hv) == SVt_PVHV) { if (svp = hv_fetch(attr_h, "ib_db_triggers", 14, FALSE)) { ib_db_triggers = SvTRUE(*svp); if (!ib_db_triggers) DPB_PREP_BYTE(buflen); } } } } /* add length of other parameters to needed buflen */ buflen += 1; /* dbpversion */ DBI_TRACE_imp_xxh(imp_dbh, 2, (DBIc_LOGPIO(imp_dbh), "dbd_db_login6\n")); /* Allocate DPB */ Newx(dpb_buffer, buflen, char); /* Default SQL dialect for every statement */ imp_dbh->sqldialect = ib_dialect; /* Fill DPB */ dpb = dpb_buffer; *dpb++ = isc_dpb_version1; DPB_FILL_STRING(dpb, isc_dpb_user_name, uid); DPB_FILL_STRING(dpb, isc_dpb_password, pwd); if (ib_cache) { /* * Safety check: Do not allocate a cache buffer greater than * 10000 pages, so we don't exhaust memory inadvertently. */ if (ib_cache > 10000) ib_cache = 10000; DPB_FILL_INTEGER(dpb, isc_dpb_num_buffers, ib_cache); } DPB_FILL_INTEGER(dpb, isc_dpb_sql_dialect, ib_dialect); if (dbkey_scope) { DPB_FILL_INTEGER(dpb, isc_dpb_dbkey_scope, dbkey_scope); } if (imp_dbh->ib_charset) { DPB_FILL_STRING(dpb, isc_dpb_lc_ctype, imp_dbh->ib_charset); } if (ib_role) { DPB_FILL_STRING(dpb, isc_dpb_sql_role_name, ib_role); } if (connect_timeout) { DPB_FILL_INTEGER(dpb, isc_dpb_connect_timeout, connect_timeout); } if (!ib_db_triggers) { DPB_FILL_BYTE(dpb, isc_dpb_no_db_triggers, 1); } dpb_length = dpb - dpb_buffer; if ( dpb_length != buflen ) { fprintf(stderr, "# db_login6: %d != %d\n", dpb_length, buflen); fflush(stderr); abort(); } DBI_TRACE_imp_xxh(imp_dbh, 3, (DBIc_LOGPIO(imp_dbh), "dbd_db_login6: attaching to database %s..\n", database)); isc_attach_database(status, /* status vector */ db_len, database, /* connect string */ &(imp_dbh->db), /* ref to db handle */ dpb_length, /* length of dpb */ dpb_buffer); /* connect options */ /* freeing database parameter buffer */ Safefree(dpb_buffer); /* return false on failed attach */ if (ib_error_check(dbh, status)) return FALSE; imp_dbh->charset_bytes_per_char = NULL; DBI_TRACE_imp_xxh(imp_dbh, 3, (DBIc_LOGPIO(imp_dbh), "dbd_db_login6: success attaching.\n")); /* Tell DBI, that dbh->destroy should be called for this handle */ DBIc_IMPSET_on(imp_dbh); /* Tell DBI, that dbh->disconnect should be called for this handle */ DBIc_ACTIVE_on(imp_dbh); return TRUE; } int dbd_db_login(SV *dbh, imp_dbh_t *imp_dbh, char *dbname, char *uid, char *pwd) { return dbd_db_login6(dbh, imp_dbh, dbname, uid, pwd, Nullsv); } int dbd_db_ping(SV *dbh) { D_imp_dbh(dbh); ISC_STATUS status[ISC_STATUS_LENGTH]; char buffer[100]; char req[] = { isc_info_ods_version, isc_info_end }; DBI_TRACE_imp_xxh(imp_dbh, 1, (DBIc_LOGPIO(imp_dbh), "dbd_db_ping\n")); if (isc_database_info(status, &(imp_dbh->db), sizeof(req), req, sizeof(buffer), buffer)) if (ib_error_check(dbh, status)) return FALSE; return TRUE; } int dbd_db_disconnect(SV *dbh, imp_dbh_t *imp_dbh) { dTHR; ISC_STATUS status[ISC_STATUS_LENGTH]; DBI_TRACE_imp_xxh(imp_dbh, 2, (DBIc_LOGPIO(imp_dbh), "dbd_db_disconnect\n")); /* set the database handle to inactive */ DBIc_ACTIVE_off(imp_dbh); /* always do a rollback if there's an open transaction. * Firebird requires to close open transactions before * detaching a database. */ if (imp_dbh->tr) { /* rollback and close trans context */ isc_rollback_transaction(status, &(imp_dbh->tr)); if (ib_error_check(dbh, status)) return FALSE; imp_dbh->tr = 0L; } FREE_SETNULL(imp_dbh->ib_charset); FREE_SETNULL(imp_dbh->tpb_buffer); FREE_SETNULL(imp_dbh->dateformat); FREE_SETNULL(imp_dbh->timeformat); FREE_SETNULL(imp_dbh->timestampformat); FREE_SETNULL(imp_dbh->charset_bytes_per_char); /* detach database */ isc_detach_database(status, &(imp_dbh->db)); if (ib_error_check(dbh, status)) return FALSE; return TRUE; } void dbd_db_destroy (SV *dbh, imp_dbh_t *imp_dbh) { DBI_TRACE_imp_xxh(imp_dbh, 2, (DBIc_LOGPIO(imp_dbh), "dbd_db_destroy\n")); if (DBIc_ACTIVE(imp_dbh)) dbd_db_disconnect(dbh, imp_dbh); /* Nothing in imp_dbh to be freed */ DBIc_IMPSET_off(imp_dbh); } int dbd_db_commit (SV *dbh, imp_dbh_t *imp_dbh) { DBI_TRACE_imp_xxh(imp_dbh, 2, (DBIc_LOGPIO(imp_dbh), "dbd_db_commit\n")); /* no commit if AutoCommit on */ if (DBIc_has(imp_dbh, DBIcf_AutoCommit)) return FALSE; /* commit the transaction */ if (!ib_commit_transaction(dbh, imp_dbh)) return FALSE; DBI_TRACE_imp_xxh(imp_dbh, 3, (DBIc_LOGPIO(imp_dbh), "dbd_db_commit succeed.\n")); return TRUE; } int dbd_db_rollback(SV *dbh, imp_dbh_t *imp_dbh) { DBI_TRACE_imp_xxh(imp_dbh, 2, (DBIc_LOGPIO(imp_dbh), "dbd_db_rollback\n")); /* no rollback if AutoCommit = on */ if (DBIc_has(imp_dbh, DBIcf_AutoCommit) != FALSE) return FALSE; /* rollback the transaction */ if (!ib_rollback_transaction(dbh, imp_dbh)) return FALSE; DBI_TRACE_imp_xxh(imp_dbh, 3, (DBIc_LOGPIO(imp_dbh), "dbd_db_rollback succeed.\n")); return TRUE; } int dbd_db_STORE_attrib(SV *dbh, imp_dbh_t *imp_dbh, SV *keysv, SV *valuesv) { STRLEN kl; char *key = SvPV(keysv, kl); int on = SvTRUE(valuesv)? 1: 0; int oldval; int set_frmts = 0; DBI_TRACE_imp_xxh(imp_dbh, 2, (DBIc_LOGPIO(imp_dbh), "dbd_db_STORE - %s\n", key)); /**************************************************************************/ if ((kl==10) && strEQ(key, "AutoCommit")) { oldval = DBIc_has(imp_dbh, DBIcf_AutoCommit)? 1: 0; DBIc_set(imp_dbh, DBIcf_AutoCommit, on); DBI_TRACE_imp_xxh(imp_dbh, 3, (DBIc_LOGPIO(imp_dbh), "dbd_db_STORE: switch AutoCommit from %d to %d\n", oldval, on)); if (oldval == FALSE && on) { /* AutoCommit set from 0 to 1, commit any outstanding changes */ if (imp_dbh->tr) { if (!ib_commit_transaction(dbh, imp_dbh)) return FALSE; DBI_TRACE_imp_xxh(imp_dbh, 3, (DBIc_LOGPIO(imp_dbh), "dbd_db_STORE: commit open transaction\n")); } } return TRUE; /* handled */ } /**************************************************************************/ else if ((kl==13) && strEQ(key, "ib_softcommit")) { oldval = imp_dbh->soft_commit; DBI_TRACE_imp_xxh(imp_dbh, 3, (DBIc_LOGPIO(imp_dbh), "dbd_db_STORE: switch ib_softcommit from %d to %d\n", oldval, on)); /* set new value */ imp_dbh->soft_commit = on; /* switching softcommit from 1 to 0 -> make a hard commit */ if (!on && oldval) { if (imp_dbh->tr) { if (!ib_commit_transaction(dbh, imp_dbh)) return FALSE; DBI_TRACE_imp_xxh(imp_dbh, 3, (DBIc_LOGPIO(imp_dbh), "dbd_db_STORE: commit open transaction\n")); } } return TRUE; /* handled */ } else if ((kl==14) && strEQ(key, "ib_enable_utf8")) { if (on) { if (imp_dbh->ib_charset && strEQ(imp_dbh->ib_charset, "UTF8")) { imp_dbh->ib_enable_utf8 = TRUE; return TRUE; } else croak( "ib_enable_utf8 requires ib_charset=UTF8 in DSN (you gave %s)", imp_dbh->ib_charset ? imp_dbh->ib_charset : "" ); } else { imp_dbh->ib_enable_utf8 = FALSE; return TRUE; } } else if ((kl==11) && strEQ(key, "ib_time_all")) set_frmts = 1; /**************************************************************************/ if (set_frmts || ((kl==13) && strEQ(key, "ib_dateformat"))) { IB_SQLtimeformat(dbh, imp_dbh->dateformat, valuesv); if (!set_frmts) return TRUE; } if (set_frmts || ((kl==13) && strEQ(key, "ib_timeformat"))) { IB_SQLtimeformat(dbh, imp_dbh->timeformat, valuesv); if (!set_frmts) return TRUE; } if (set_frmts || ((kl==18) && strEQ(key, "ib_timestampformat"))) { IB_SQLtimeformat(dbh, imp_dbh->timestampformat, valuesv); if (!set_frmts) return TRUE; } /**************************************************************************/ if (set_frmts) return TRUE; else return FALSE; /* not handled */ } SV *dbd_db_FETCH_attrib(SV *dbh, imp_dbh_t *imp_dbh, SV *keysv) { STRLEN kl; char * key = SvPV(keysv, kl); SV * result = NULL; DBI_TRACE_imp_xxh(imp_dbh, 2, (DBIc_LOGPIO(imp_dbh), "dbd_db_FETCH - %s\n", key)); if ((kl==10) && strEQ(key, "AutoCommit")) result = boolSV(DBIc_has(imp_dbh, DBIcf_AutoCommit)); else if ((kl==13) && strEQ(key, "ib_softcommit")) result = boolSV(imp_dbh->soft_commit); else if ((kl==14) && strEQ(key, "ib_enable_utf8")) result = boolSV(imp_dbh->ib_enable_utf8); else if ((kl==13) && strEQ(key, "ib_dateformat")) result = newSVpvn(imp_dbh->dateformat, strlen(imp_dbh->dateformat)); else if ((kl==13) && strEQ(key, "ib_timeformat")) result = newSVpvn(imp_dbh->timeformat, strlen(imp_dbh->timeformat)); else if ((kl==18) && strEQ(key, "ib_timestampformat")) result = newSVpvn(imp_dbh->timestampformat, strlen(imp_dbh->timestampformat)); else if ((kl==11) && strEQ(key, "ib_embedded")) #ifdef EMBEDDED result = &PL_sv_yes; #else result = &PL_sv_no; #endif if (result == NULL) return Nullsv; else { if ((result == &PL_sv_yes) || (result == &PL_sv_no)) return result; else return sv_2mortal(result); } } void dbd_preparse(SV *sth, imp_sth_t *imp_sth, char *statement) { ISC_STATUS status[ISC_STATUS_LENGTH]; DBI_TRACE_imp_xxh(imp_sth, 2, (DBIc_LOGPIO(imp_sth), "Enter dbd_preparse\n")); isc_dsql_describe_bind(status, &(imp_sth->stmt), 1, imp_sth->in_sqlda); if (ib_error_check(sth, status)) { ib_cleanup_st_prepare(imp_sth); return; } /* realloc in_sqlda and rebind if not enough XSQLVAR for bind params */ if (imp_sth->in_sqlda->sqld > imp_sth->in_sqlda->sqln) { IB_alloc_sqlda(imp_sth->in_sqlda, imp_sth->in_sqlda->sqld); if (imp_sth->in_sqlda == NULL) { do_error(sth, 1, "Fail to reallocate in_slqda"); ib_cleanup_st_prepare(imp_sth); return; } else { isc_dsql_describe_bind(status, &(imp_sth->stmt), 1, imp_sth->in_sqlda); if (ib_error_check(sth, status)) { ib_cleanup_st_prepare(imp_sth); return; } } } DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "dbd_preparse: describe_bind passed.\n" "dbd_preparse: exit; in_sqlda: sqld: %d, sqln: %d.\n", imp_sth->in_sqlda->sqld, imp_sth->in_sqlda->sqln)); DBIc_NUM_PARAMS(imp_sth) = imp_sth->in_sqlda->sqld; } int dbd_st_prepare(SV *sth, imp_sth_t *imp_sth, char *statement, SV *attribs) { D_imp_dbh_from_sth; ISC_STATUS status[ISC_STATUS_LENGTH]; int i; short dtype; static char stmt_info[1]; char info_buffer[20], count_item; XSQLVAR *var; DBI_TRACE_imp_xxh(imp_sth, 2, (DBIc_LOGPIO(imp_sth), "Enter dbd_st_prepare\n")); if (!DBIc_ACTIVE(imp_dbh)) { do_error(sth, -1, "Database disconnected"); return FALSE; } /* init values */ count_item = 0; imp_sth->count_item = 0; imp_sth->affected = -1; imp_sth->in_sqlda = NULL; imp_sth->out_sqlda = NULL; imp_sth->cursor_name = NULL; imp_sth->dateformat = NULL; imp_sth->timestampformat = NULL; imp_sth->timeformat = NULL; /* double linked list */ imp_sth->prev_sth = NULL; imp_sth->next_sth = NULL; if (attribs) { SV **svp; if ((svp = DBD_ATTRIB_GET_SVP(attribs, "ib_time_all", 11)) != NULL) { IB_SQLtimeformat(sth, imp_sth->dateformat, *svp); IB_SQLtimeformat(sth, imp_sth->timestampformat, *svp); IB_SQLtimeformat(sth, imp_sth->timeformat, *svp); } if ((svp = DBD_ATTRIB_GET_SVP(attribs, "ib_dateformat", 13)) != NULL) IB_SQLtimeformat(sth, imp_sth->dateformat, *svp); if ((svp = DBD_ATTRIB_GET_SVP(attribs, "ib_timestampformat", 18)) != NULL) IB_SQLtimeformat(sth, imp_sth->timestampformat, *svp); if ((svp = DBD_ATTRIB_GET_SVP(attribs, "ib_timeformat", 13)) != NULL) IB_SQLtimeformat(sth, imp_sth->timeformat, *svp); } /* allocate 1 XSQLVAR to in_sqlda */ IB_alloc_sqlda(imp_sth->in_sqlda, 1); if (imp_sth->in_sqlda == NULL) { do_error(sth, 2, "Fail to allocate in_sqlda"); return FALSE; } /* allocate 1 XSQLVAR to out_sqlda */ IB_alloc_sqlda(imp_sth->out_sqlda, 1); if (imp_sth->out_sqlda == NULL) { do_error(sth, 2, "Fail to allocate out_sqlda"); ib_cleanup_st_prepare(imp_sth); return FALSE; } /* init statement handle */ isc_dsql_alloc_statement2(status, &(imp_dbh->db), &(imp_sth->stmt)); if (ib_error_check(sth, status)) { ib_cleanup_st_prepare(imp_sth); return FALSE; } DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "dbd_st_prepare: sqldialect: %d.\n", imp_dbh->sqldialect)); if (!imp_dbh->tr) { /* start a new transaction using current TPB */ if (!ib_start_transaction(sth, imp_dbh)) { ib_cleanup_st_prepare(imp_sth); return FALSE; } } DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "dbd_st_prepare: statement: %s.\n", statement)); isc_dsql_prepare(status, &(imp_dbh->tr), &(imp_sth->stmt), 0, statement, imp_dbh->sqldialect, imp_sth->out_sqlda); if (ib_error_check(sth, status)) { ib_cleanup_st_prepare(imp_sth); return FALSE; } DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "dbd_st_prepare: isc_dsql_prepare succeed..\n")); stmt_info[0] = isc_info_sql_stmt_type; isc_dsql_sql_info(status, &(imp_sth->stmt), sizeof (stmt_info), stmt_info, sizeof (info_buffer), info_buffer); if (ib_error_check(sth, status)) { ib_cleanup_st_prepare(imp_sth); return FALSE; } { short l = (short) isc_vax_integer((char *) info_buffer + 1, 2); imp_sth->type = isc_vax_integer((char *) info_buffer + 3, l); } /* sanity check of statement type */ DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "dbd_st_prepare: statement type: %ld.\n", imp_sth->type)); switch (imp_sth->type) { /* Implemented statement types. */ case isc_info_sql_stmt_select: case isc_info_sql_stmt_select_for_upd: /* * Unfortunately, select count item doesn't work * in current versions of Firebird. * isql does it literally by fetching everything * and counting the number of rows it fetched. * Firebird doesn't seem to be able to estimate * the number of rows before the client app * fetches them all. */ //count_item = isc_info_req_select_count; break; case isc_info_sql_stmt_insert: count_item = isc_info_req_insert_count; break; case isc_info_sql_stmt_update: count_item = isc_info_req_update_count; break; case isc_info_sql_stmt_delete: count_item = isc_info_req_delete_count; break; case isc_info_sql_stmt_ddl: case isc_info_sql_stmt_set_generator: case isc_info_sql_stmt_exec_procedure: case isc_info_sql_stmt_savepoint: case isc_info_sql_stmt_start_trans: case isc_info_sql_stmt_commit: case isc_info_sql_stmt_rollback: /* no count_item to gather */ break; /* * Unimplemented statement types. Some may be implemented in the future. */ case isc_info_sql_stmt_get_segment: case isc_info_sql_stmt_put_segment: default: do_error(sth, 10, "Statement type is not implemented in this version of DBD::Firebird"); return FALSE; break; } imp_sth->count_item = count_item; /* scan statement for '?', ':1' and/or ':foo' style placeholders */ /* realloc in_sqlda where needed */ dbd_preparse(sth, imp_sth, statement); DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "dbd_st_prepare: dbd_describe passed.\n" "out_sqlda: sqld: %d, sqln: %d.\n", imp_sth->out_sqlda->sqld, imp_sth->out_sqlda->sqln)); /* enough output parameter block ? */ if (imp_sth->out_sqlda->sqld > imp_sth->out_sqlda->sqln) { DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "dbd_st_prepare: realloc out_sqlda..\n")); IB_alloc_sqlda(imp_sth->out_sqlda, imp_sth->out_sqlda->sqld); if (imp_sth->out_sqlda == NULL) { do_error(sth, IB_ALLOC_FAIL, "Fail to reallocate out_sqlda"); ib_cleanup_st_prepare(imp_sth); return FALSE; } else { DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "dbd_st_prepare: calling isc_dsql_describe again..\n")); isc_dsql_describe(status, &(imp_sth->stmt), 1, imp_sth->out_sqlda); if (ib_error_check(sth, status)) { ib_cleanup_st_prepare(imp_sth); return FALSE; } DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "dbd_st_prepare: success calling isc_dsql_describe.\n")); } } else if (imp_sth->out_sqlda->sqld == 0) /* not a select statement */ { Safefree(imp_sth->out_sqlda); imp_sth->out_sqlda = NULL; } if (imp_sth->out_sqlda) { for (i = 0, var = imp_sth->out_sqlda->sqlvar; i < imp_sth->out_sqlda->sqld; i++, var++) { dtype = (var->sqltype & ~1); var->sqlind = NULL; DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "dbd_st_prepare: field type: %d.\n", dtype)); /* Alloc space for sqldata */ Newx(var->sqldata, var->sqllen + (dtype == SQL_VARYING ? sizeof(short) : 0), ISC_SCHAR); /* Nullable? */ if (var->sqltype & 1) Newx(var->sqlind, 1, short); } } /* statment is valid -> insert into linked list (at begin) */ imp_sth->next_sth = imp_dbh->first_sth; if (imp_dbh->first_sth == NULL) imp_dbh->last_sth = imp_sth; else imp_dbh->first_sth->prev_sth = imp_sth; imp_dbh->first_sth = imp_sth; DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "dbd_st_prepare: sth inserted into linked list.\n")); /* tell DBI that we have a real statement handle now */ DBIc_IMPSET_on(imp_sth); return TRUE; } int dbd_st_finish_internal(SV *sth, imp_sth_t *imp_sth, int honour_auto_commit) { D_imp_dbh_from_sth; ISC_STATUS status[ISC_STATUS_LENGTH]; DBI_TRACE_imp_xxh(imp_sth, 2, (DBIc_LOGPIO(imp_sth), "dbd_st_finish\n")); if (!DBIc_ACTIVE(imp_sth)) /* already finished */ { DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "dbd_st_finish: nothing to do (not active)\n")); return TRUE; } /* Close the cursor, not drop the statement! */ if (imp_sth->type != isc_info_sql_stmt_exec_procedure) { isc_dsql_free_statement(status, (isc_stmt_handle *)&(imp_sth->stmt), DSQL_close); /* Ignore errors when closing already closed cursor (sqlcode -501). May happen when closing "select * from sample" statement, which was closed by the server because of a "drop table sample" statement. There is no point to error-out here, since nothing bad has happened -- the statement is closed, just without we knowing. There is no resource leak and the user can't and needs not do anything. */ if ((status[0] == 1) && (status[1] > 0)) { long sqlcode = isc_sqlcode(status); if (sqlcode != -501) { if (ib_error_check(sth, status)) return FALSE; } else { DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "dbd_st_finish: ignoring error -501 from isc_dsql_free_statement.\n")); } } DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "dbd_st_finish: isc_dsql_free_statement passed.\n")); } /* set statement to inactive - must be before ib_commit_transaction 'cos commit can call dbd_st_finish function again */ DBIc_ACTIVE_off(imp_sth); if ( imp_sth->param_values != NULL ) hv_clear(imp_sth->param_values); /* if AutoCommit on */ if (DBIc_has(imp_dbh, DBIcf_AutoCommit) && honour_auto_commit) { DBI_TRACE_imp_xxh(imp_sth, 4, (DBIc_LOGPIO(imp_sth), "dbd_st_finish: Trying to call ib_commit_transaction.\n")); if (!ib_commit_transaction(sth, imp_dbh)) { DBI_TRACE_imp_xxh(imp_sth, 4, (DBIc_LOGPIO(imp_sth), "dbd_st_finish: Call ib_commit_transaction finished returned FALSE.\n")); return FALSE; } DBI_TRACE_imp_xxh(imp_sth, 4, (DBIc_LOGPIO(imp_sth), "dbd_st_finish: Call ib_commit_transaction succeeded.\n")); } return TRUE; } int dbd_st_finish(SV *sth, imp_sth_t *imp_sth) { return dbd_st_finish_internal(sth, imp_sth, TRUE); } int dbd_st_execute(SV *sth, imp_sth_t *imp_sth) { D_imp_dbh_from_sth; ISC_STATUS status[ISC_STATUS_LENGTH]; int result = -2; int row_count = 0; if (DBIc_ACTIVE(imp_sth)) dbd_st_finish_internal( sth, imp_sth, TRUE); DBI_TRACE_imp_xxh(imp_sth, 2, (DBIc_LOGPIO(imp_sth), "dbd_st_execute\n")); if (DBIc_ACTIVE(imp_sth)) dbd_st_finish_internal(sth, imp_sth, TRUE); /* if not already done: start new transaction */ if (!imp_dbh->tr) if (!ib_start_transaction(sth, imp_dbh)) return result; DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "dbd_st_execute: statement type: %ld.\n", imp_sth->type)); /* we count DDL statments */ if (imp_sth->type == isc_info_sql_stmt_ddl) imp_dbh->sth_ddl++; /* exec procedure statement */ if (imp_sth->type == isc_info_sql_stmt_exec_procedure) { DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "dbd_st_execute: calling isc_dsql_execute2 (exec procedure)..\n")); isc_dsql_execute2(status, &(imp_dbh->tr), &(imp_sth->stmt), imp_dbh->sqldialect, (imp_sth->in_sqlda && (imp_sth->in_sqlda->sqld > 0))? imp_sth->in_sqlda: NULL, (imp_sth->out_sqlda && (imp_sth->out_sqlda->sqld > 0))? imp_sth->out_sqlda: NULL); if (ib_error_check(sth, status)) { ib_cleanup_st_execute(imp_sth); return result; } DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "dbd_st_execute: isc_dsql_execute2 succeed.\n")); result = row_count = imp_sth->affected = 0; } else /* all other types of SQL statements */ { DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "dbd_st_execute: calling isc_dsql_execute..\n")); /* check for valid in_sqlda */ if (!imp_sth->in_sqlda) return FALSE; isc_dsql_execute(status, &(imp_dbh->tr), &(imp_sth->stmt), imp_dbh->sqldialect, imp_sth->in_sqlda->sqld > 0 ? imp_sth->in_sqlda: NULL); if (ib_error_check(sth, status)) { ib_cleanup_st_execute(imp_sth); /* rollback any active transaction */ if (DBIc_has(imp_dbh, DBIcf_AutoCommit) && imp_dbh->tr) ib_commit_transaction(sth, imp_dbh); return result; } DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "dbd_st_execute: isc_dsql_execute succeed.\n")); } if (imp_sth->count_item) { //PerlIO_printf(PerlIO_stderr(), "calculating row count\n"); row_count = ib_rows(sth, &(imp_sth->stmt), imp_sth->count_item); if (row_count <= -2) ib_cleanup_st_execute(imp_sth); else result = imp_sth->affected = row_count; } else if (imp_sth->type == isc_info_sql_stmt_select) result = row_count = imp_sth->affected = 0; else result = -1; /* Jika AutoCommit On, commit_transaction() (bukan retaining), * dan reset imp_dbh->tr == 0L * For SELECT statement, commit_transaction() is called after fetch, * or within finish() */ if (DBIc_has(imp_dbh, DBIcf_AutoCommit) && imp_sth->type != isc_info_sql_stmt_select && imp_sth->type != isc_info_sql_stmt_select_for_upd && imp_sth->type != isc_info_sql_stmt_exec_procedure) { DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "dbd_st_execute: calling ib_commit_transaction..\n")); if (!ib_commit_transaction(sth, imp_dbh)) { ib_cleanup_st_execute(imp_sth); return result; } DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "dbd_st_execute: ib_commit_transaction succeed.\n")); } /* Declare a unique cursor for this query */ if (imp_sth->type == isc_info_sql_stmt_select_for_upd) { /* We free the cursor_name buffer in dbd_st_destroy. */ if (!create_cursor_name(sth, imp_sth)) { ib_cleanup_st_execute(imp_sth); return result; } } switch (imp_sth->type) { case isc_info_sql_stmt_select: case isc_info_sql_stmt_select_for_upd: case isc_info_sql_stmt_exec_procedure: DBIc_NUM_FIELDS(imp_sth) = (imp_sth->out_sqlda)? imp_sth->out_sqlda->sqld: 0; DBIc_ACTIVE_on(imp_sth); break; } DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "dbd_st_execute: row count: %d.\n" "dbd_st_execute: count_item: %d.\n", row_count, imp_sth->count_item)); return result; } unsigned get_charset_bytes_per_char(const ISC_SHORT subtype, SV *sth); /* from out_sqlda to AV */ AV *dbd_st_fetch(SV *sth, imp_sth_t *imp_sth) { D_imp_dbh_from_sth; /* declare imp_dbh from sth */ ISC_STATUS fetch = 0; ISC_STATUS status[ISC_STATUS_LENGTH]; int chopBlanks; /* chopBlanks ? */ AV *av; /* array buffer */ SV *sv, **svp; /* buffers */ XSQLVAR *var; /* working pointer XSQLVAR */ int i; /* loop */ short dtype; DBI_TRACE_imp_xxh(imp_sth, 2, (DBIc_LOGPIO(imp_sth), "dbd_st_fetch\n")); if (!DBIc_ACTIVE(imp_sth)) { do_error(sth, 0, "no statement executing (perhaps you need to call execute first)\n"); return Nullav; } chopBlanks = DBIc_is(imp_sth, DBIcf_ChopBlanks); av = DBIS->get_fbav(imp_sth); svp = AvARRAY(av); /* * if it's an execute procedure, we've already got the * output from the isc_dsql_execute2() call in dbd_st_execute(). */ if (imp_sth->type != isc_info_sql_stmt_exec_procedure) { fetch = isc_dsql_fetch(status, &(imp_sth->stmt), imp_dbh->sqldialect, imp_sth->out_sqlda); if (ib_error_check(sth, status)) return Nullav; /* * Code 100 means we've reached the end of the set * of rows that the SELECT will return. */ DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "dbd_st_fetch: fetch result: %ld\n", fetch)); if (imp_sth->affected < 0) imp_sth->affected = 0; if (fetch == 100) { /* close the cursor */ isc_dsql_free_statement(status, &(imp_sth->stmt), DSQL_close); if (ib_error_check(sth, status)) return Nullav; DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "isc_dsql_free_statement succeed.\n")); DBIc_ACTIVE_off(imp_sth); /* dbd_st_finish is no longer needed */ /* if AutoCommit on XXX. what to return if fails? */ if (DBIc_has(imp_dbh, DBIcf_AutoCommit)) { if (!ib_commit_transaction(sth, imp_dbh)) return Nullav; DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "fetch ends: ib_commit_transaction succeed.\n")); } return Nullav; } else if (fetch != 0) /* something bad */ { do_error(sth, 0, "Fetch error"); DBIc_ACTIVE_off(imp_sth); return Nullav; } } /* !exec_procedure */ else { /* we only fetch one row for exec procedure */ if (imp_sth->affected) return Nullav; } var = imp_sth->out_sqlda->sqlvar; for (i = 0; i < imp_sth->out_sqlda->sqld; i++, var++) { sv = svp[i]; dtype = var->sqltype & ~1; if ((var->sqltype & 1) && (*(var->sqlind) == -1)) /* if nullable field */ { /* isNULL */ SvOK_off(sv); } else { /* * Got a non-null field. Got to pass it back to the * application, which means some datatype dependant code. */ switch (dtype) { #ifdef SQL_BOOLEAN case SQL_BOOLEAN: FB_BOOLEAN b = (*((FB_BOOLEAN *) (var->sqldata))); #ifdef sv_set_bool sv_set_bool(sv, b == FB_TRUE); #else #ifdef sv_setbool sv_setbool(sv, b == FB_TRUE); #else sv_setiv(sv, (b == FB_TRUE) ? 1 : 0); #endif #endif break; #endif case SQL_SHORT: if (var->sqlscale) /* handle NUMERICs */ { double numeric; numeric = ((double) (*(short *) var->sqldata)) / pow(10.0, (double) -var->sqlscale); sv_setnv(sv, numeric); } else sv_setiv(sv, *(short *) (var->sqldata)); break; case SQL_LONG: if (var->sqlscale) /* handle NUMERICs */ { double numeric; numeric = ((double) (*(ISC_LONG *) var->sqldata)) / pow(10.0, (double) -var->sqlscale); sv_setnv(sv, numeric); } else sv_setiv(sv, *(ISC_LONG *) (var->sqldata)); break; #ifdef SQL_INT64 case SQL_INT64: /* * This seemed difficult at first to return * a 64-bit scaled numeric to Perl through the * SV interface. But as luck would have it, * Perl treats strings and numerics identically. * I can return this numeric as a string and * nobody has a problem with it. */ { static ISC_INT64 const scales[] = { 1LL, 10LL, 100LL, 1000LL, 10000LL, 100000LL, 1000000LL, 10000000LL, 100000000LL, 1000000000LL, 10000000000LL, 100000000000LL, 1000000000000LL, 10000000000000LL, 100000000000000LL, 1000000000000000LL, 10000000000000000LL, 100000000000000000LL }; ISC_INT64 i; /* significand */ char buf[22]; /* NUMERIC(18,2) = -92233720368547758.08 + '\0' */ i = *((ISC_INT64 *) (var->sqldata)); /* We use the system snprintf(3) and system-specific * format codes. :( On my perl, I was unable to * persuade sv_setpvf to handle INT64 values with * IVdf (and there is no I64f). * - MJP 2010-03-25 */ #if defined(_MSC_VER) /* Microsoft C compiler/library */ # define DBD_IB_INT64f "I64d" #elif defined (__FreeBSD__) /* FreeBSD */ # define DBD_IB_INT64f "qd" #else /* others: linux, various unices */ # define DBD_IB_INT64f "lld" #endif if (var->sqlscale == 0) { snprintf(buf, sizeof(buf), "%"DBD_IB_INT64f, i); sv_setpvn(sv, buf, strlen(buf)); } else { bool sign = ( i < 0 ); ISC_INT64 divisor, remainder; divisor = scales[-var->sqlscale]; if (sign) divisor = -divisor; remainder = (i%divisor); if (remainder < 0) remainder = -remainder; snprintf(buf+1, sizeof(buf)-1, "%"DBD_IB_INT64f".%0*"DBD_IB_INT64f, i/divisor, -var->sqlscale, remainder); DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "-------------->SQLINT64=%"DBD_IB_INT64f".%0*"DBD_IB_INT64f,i/divisor, -var->sqlscale, remainder )); if (sign) { *buf = '-'; sv_setpvn(sv, buf, strlen(buf)); } else { sv_setpvn(sv, buf+1, strlen(buf+1)); } } } break; #endif case SQL_FLOAT: sv_setnv(sv, (double)(*(float *) (var->sqldata))); break; case SQL_DOUBLE: if (var->sqlscale) /* handle NUMERICs */ { double d = *(double *)var->sqldata; short q = -var->sqlscale; sv_setnv(sv, d > 0? floor(d * pow(10.0, (double) q)) / pow(10.0, (double) q): ceil(d * pow(10.0, (double) q)) / pow(10.0, (double) q)); } else sv_setnv(sv, *(double *) (var->sqldata)); break; case SQL_TEXT: /* * Thanks to DAM for pointing out that I * don't need to null-terminate this * buffer, and in fact it's a buffer * overrun if I do! */ DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "Fill in TEXT type..\nLength: %d\n", var->sqllen)); if (chopBlanks && (var->sqllen > 0)) { short len = var->sqllen; char *p = (char*)(var->sqldata); while (len && (p[len-1] == ' ')) len--; sv_setpvn(sv, p, len); maybe_upgrade_to_utf8(imp_dbh, sv); } else { /* we need to shrink the string for multy-byte character sets. the padding spaces are too many in this case */ unsigned bpc = get_charset_bytes_per_char( var->sqlsubtype, sth); unsigned len = var->sqllen; sv_setpvn(sv, var->sqldata, len); maybe_upgrade_to_utf8(imp_dbh, sv); SvCUR_set(sv, len/bpc); } break; case SQL_VARYING: { DBD_VARY *vary = (DBD_VARY *) var->sqldata; sv_setpvn(sv, vary->vary_string, vary->vary_length); /* Note that sqllen for VARCHARs is the max length */ maybe_upgrade_to_utf8(imp_dbh, sv); break; } /* * If user specifies a TimestampFormat, TimeFormat, or * DateFormat property of the Statement class, then that * string is the format string for strftime(). * * If the user doesn't specify an XxxFormat, then format * is %c, defined in /usr/lib/locale//LC_TIME/time, * where is the host's chosen locale. */ case SQL_TIMESTAMP: case SQL_TYPE_DATE: case SQL_TYPE_TIME: { char *format = NULL, buf[100]; struct tm times; long int fpsec = 0; switch (dtype) { case SQL_TIMESTAMP: isc_decode_timestamp((ISC_TIMESTAMP *) var->sqldata, ×); format = imp_sth->timestampformat ? imp_sth->timestampformat : imp_dbh->timestampformat; fpsec = TIMESTAMP_FPSECS(var->sqldata); break; case SQL_TYPE_DATE: isc_decode_sql_date((ISC_DATE *) var->sqldata, ×); format = imp_sth->dateformat ? imp_sth->dateformat : imp_dbh->dateformat; break; case SQL_TYPE_TIME: isc_decode_sql_time((ISC_TIME *) var->sqldata, ×); format = imp_sth->timeformat ? imp_sth->timeformat : imp_dbh->timeformat; fpsec = TIME_FPSECS(var->sqldata); break; } DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "Decode passed.\n")); /* hardcoded output format.... */ if (strEQ(format, "iso") || strEQ(format, "ISO")) { switch (dtype) { case SQL_TIMESTAMP: snprintf(buf, sizeof(buf), "%04d-%02d-%02d %02d:%02d:%02d.%04ld", times.tm_year + 1900, times.tm_mon + 1, times.tm_mday, times.tm_hour, times.tm_min, times.tm_sec, fpsec); break; case SQL_TYPE_DATE: snprintf(buf, sizeof(buf), "%04d-%02d-%02d", times.tm_year + 1900, times.tm_mon + 1, times.tm_mday); break; case SQL_TYPE_TIME: snprintf(buf, sizeof(buf), "%02d:%02d:%02d.%04ld", times.tm_hour, times.tm_min, times.tm_sec, fpsec); break; } sv_setpvn(sv, buf, strlen(buf)); break; } /* output as array like perl's localtime? */ if (strEQ(format, "tm") || strEQ(format, "TM")) { AV *list = newAV(); av_push(list, newSViv(times.tm_sec)); av_push(list, newSViv(times.tm_min)); av_push(list, newSViv(times.tm_hour)); av_push(list, newSViv(times.tm_mday)); av_push(list, newSViv(times.tm_mon)); av_push(list, newSViv(times.tm_year)); av_push(list, newSViv(times.tm_wday)); av_push(list, newSViv(times.tm_yday)); av_push(list, newSViv(times.tm_isdst)); /* value returned is a reference to the array */ sv_setsv(sv, sv_2mortal(newRV_noinc((SV *) list))); break; } #ifndef WIN32 /* * may be we must here copy additional fields needed on * some platforms for some strftime formats. copy from a * dummy struct passed to mktime(). calling mktime() * directly with × is wrong. */ /* struct tm has 9 fields plus may be some more */ if (sizeof(struct tm) > (9*sizeof(int))) { struct tm dummy; Zero(&dummy, 1, struct tm); mktime(&dummy); memcpy(((char *)×) + 9*sizeof(int), ((char *)&dummy) + 9*sizeof(int), sizeof(struct tm) - (9*sizeof(int))); } #endif strftime(buf, sizeof(buf), format, ×); sv_setpvn(sv, buf, strlen(buf)); break; } case SQL_BLOB: { isc_blob_handle blob_handle = 0; int blob_stat; char blob_info_buffer[32], *p, blob_segment_buffer[BLOB_SEGMENT]; char blob_info_items[] = { isc_info_blob_type, isc_info_blob_max_segment, isc_info_blob_total_length }; long max_segment = -1L, total_length = -1L, t; unsigned short seg_length; short blob_type = -1; /* Open the Blob according to the Blob id. */ isc_open_blob2(status, &(imp_dbh->db), &(imp_dbh->tr), &blob_handle, (ISC_QUAD *) var->sqldata, #if defined(INCLUDE_FB_TYPES_H) || defined(INCLUDE_TYPES_PUB_H) || defined(FIREBIRD_IMPL_TYPES_PUB_H) (ISC_USHORT) 0, (ISC_UCHAR *) NULL); #else (short) 0, /* no Blob filter */ (char *) NULL); /* no Blob filter */ #endif if (ib_error_check(sth, status)) return FALSE; /* query blob information to find out the segment size */ isc_blob_info(status, &blob_handle, sizeof(blob_info_items), blob_info_items, sizeof(blob_info_buffer), blob_info_buffer); if (ib_error_check(sth, status)) { isc_cancel_blob(status, &blob_handle); return FALSE; } /* Get the information out of the info buffer. */ for (p = blob_info_buffer; *p != isc_info_end; ) { short length; char datum = *p++; length = (short) isc_vax_integer(p, 2); p += 2; switch (datum) { case isc_info_blob_max_segment: max_segment = isc_vax_integer(p, length); break; case isc_info_blob_total_length: total_length = isc_vax_integer(p, length); break; case isc_info_blob_type: blob_type = isc_vax_integer(p, length); break; default: croak("Unknown parameter %d", (int)datum); } p += length; } DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "dbd_st_fetch: BLOB info - max_segment: %ld, total_length: %ld, type: %d\n", max_segment, total_length, blob_type)); if (max_segment == -1L || total_length == -1L || blob_type == -1) { isc_cancel_blob(status, &blob_handle); do_error(sth, 1, "Cannot determine Blob dimensions or type."); return FALSE; break; } /* if maximum segment size is zero, don't pass it to isc_get_segment() */ if (max_segment == 0) { sv_setpv(sv, ""); isc_cancel_blob(status, &blob_handle); if (ib_error_check(sth, status)) return FALSE; break; } if ((DBIc_LongReadLen(imp_sth) < (unsigned long) total_length) && (! DBIc_is(imp_dbh, DBIcf_LongTruncOk))) { isc_close_blob(status, &blob_handle); do_error(sth, 1, "Not enough LongReadLen buffer."); return FALSE; break; } /* Create a zero-length string. */ sv_setpv(sv, ""); t = total_length; while (1) { blob_stat = isc_get_segment(status, &blob_handle, &seg_length, (short) BLOB_SEGMENT, blob_segment_buffer); if (status[1] == isc_segstr_eof) break; if (status[1] != isc_segment) if (ib_error_check(sth, status)) { isc_cancel_blob(status, &blob_handle); return FALSE; } if (seg_length > DBIc_LongReadLen(imp_sth)) break; /* * As long as the fetch was successful, concatenate the segment we fetched * into the growing Perl scalar. */ sv_catpvn(sv, blob_segment_buffer, seg_length); t -= seg_length; if (t <= 0) break; if (blob_stat == 100) break; } /* Clean up after ourselves. */ isc_close_blob(status, &blob_handle); if (ib_error_check(sth, status)) return FALSE; if ( blob_type == isc_blob_text || var->sqlsubtype == isc_blob_text ) maybe_upgrade_to_utf8(imp_dbh, sv); break; } case SQL_ARRAY: #ifdef ARRAY_SUPPORT !!! NOT IMPLEMENTED YET !!! #else sv_setpvn(sv, "** array **", 11); #endif break; default: sv_setpvn(sv, "** unknown **", 13); } /* * I use the column's alias name because in the absence * of an alias, it contains the column name anyway. * Only if the alias AND the column names are zero-length * do I want to use a generic "COLUMN%d" header. * This happens, for example, when the column is a * computed field and the query doesn't use an AS clause * to label the column. */ /* if (var->aliasname_length > 0) { sv_setpvn(sv, var->aliasname, var->aliasname_length)); } else { char s[20]; snprintf(s, sizeof(s), "COLUMN%d", i); sv_setpvn(sv, s, strlen(s)); } */ } } imp_sth->affected += 1; return av; } void dbd_st_destroy(SV *sth, imp_sth_t *imp_sth) { D_imp_dbh_from_sth; ISC_STATUS status[ISC_STATUS_LENGTH]; DBI_TRACE_imp_xxh(imp_dbh, 2, (DBIc_LOGPIO(imp_dbh), "dbd_st_destroy\n")); /* freeing cursor name */ FREE_SETNULL(imp_sth->cursor_name); if ( imp_sth->param_values != NULL ) { hv_undef(imp_sth->param_values); imp_sth->param_values = NULL; } /* freeing in_sqlda */ if (imp_sth->in_sqlda) { int i; XSQLVAR *var = imp_sth->in_sqlda->sqlvar; DBI_TRACE_imp_xxh(imp_dbh, 3, (DBIc_LOGPIO(imp_dbh), "dbd_st_destroy: found in_sqlda..\n")); for (i = 0; i < imp_sth->in_sqlda->sqld; i++, var++) { FREE_SETNULL(var->sqldata); FREE_SETNULL(var->sqlind); } DBI_TRACE_imp_xxh(imp_dbh, 3, (DBIc_LOGPIO(imp_dbh), "dbd_st_destroy: freeing in_sqlda..\n")); Safefree(imp_sth->in_sqlda); imp_sth->in_sqlda = NULL; } /* freeing out_sqlda */ if (imp_sth->out_sqlda) { int i; XSQLVAR *var = imp_sth->out_sqlda->sqlvar; for (i = 0; i < imp_sth->out_sqlda->sqld; i++, var++) { FREE_SETNULL(var->sqldata); FREE_SETNULL(var->sqlind); } Safefree(imp_sth->out_sqlda); imp_sth->out_sqlda = NULL; } /* free all other resources */ FREE_SETNULL(imp_sth->dateformat); FREE_SETNULL(imp_sth->timeformat); FREE_SETNULL(imp_sth->timestampformat); /* Drop the statement */ if (imp_sth->stmt) { isc_dsql_free_statement(status, &(imp_sth->stmt), DSQL_drop); if (ib_error_check(sth, status)) { DBI_TRACE_imp_xxh(imp_dbh, 3, (DBIc_LOGPIO(imp_dbh), "dbd_st_destroy: isc_dsql_free_statement failed.\n")); } else DBI_TRACE_imp_xxh(imp_dbh, 3, (DBIc_LOGPIO(imp_dbh), "dbd_st_destroy: isc_dsql_free_statement succeeded.\n")); imp_sth->stmt = 0L; } /* remove sth from linked list */ /* handle prev element */ if (imp_sth->prev_sth == NULL) imp_dbh->first_sth = imp_sth->next_sth; else imp_sth->prev_sth->next_sth = imp_sth->next_sth; /* handle next element*/ if (imp_sth->next_sth == NULL) imp_dbh->last_sth = imp_sth->prev_sth; else imp_sth->next_sth->prev_sth = imp_sth->prev_sth; /* set next/prev to NULL */ imp_sth->prev_sth = imp_sth->next_sth = NULL; DBI_TRACE_imp_xxh(imp_dbh, 3, (DBIc_LOGPIO(imp_dbh), "dbd_st_destroy: sth removed from linked list.\n")); /* let DBI know we've done it */ if (sth) DBIc_IMPSET_off(imp_sth); } SV* dbd_st_FETCH_attrib(SV *sth, imp_sth_t *imp_sth, SV *keysv) { STRLEN kl; char *key = SvPV(keysv, kl); int i; SV *result = NULL; /* Default to caching results for DBI dispatch quick_FETCH */ int cacheit = TRUE; DBI_TRACE_imp_xxh(imp_sth, 2, (DBIc_LOGPIO(imp_sth), "dbd_st_FETCH - %s\n", key)); if (kl==13 && strEQ(key, "NUM_OF_PARAMS")) /* handled by DBI */ return Nullsv; i = DBIc_NUM_FIELDS(imp_sth); if (!imp_sth) return Nullsv; /**************************************************************************/ if (kl==4 && strEQ(key, "TYPE")) { AV *av; if (!imp_sth->in_sqlda || !imp_sth->out_sqlda) return Nullsv; av = newAV(); result = newRV_inc(sv_2mortal((SV*)av)); while(--i >= 0) av_store(av, i, newSViv(ib2sql_type(imp_sth->out_sqlda->sqlvar[i].sqltype))); } /**************************************************************************/ else if (kl==5 && strEQ(key, "SCALE")) { AV *av; if (!imp_sth->in_sqlda || !imp_sth->out_sqlda) return Nullsv; av = newAV(); result = newRV_inc(sv_2mortal((SV*)av)); while(--i >= 0) av_store(av, i, newSViv(imp_sth->out_sqlda->sqlvar[i].sqlscale)); } /**************************************************************************/ else if (kl==9 && strEQ(key, "PRECISION")) { AV *av; if (!imp_sth->in_sqlda || !imp_sth->out_sqlda) return Nullsv; av = newAV(); result = newRV_inc(sv_2mortal((SV*)av)); while(--i >= 0) av_store(av, i, newSViv(imp_sth->out_sqlda->sqlvar[i].sqllen)); } /**************************************************************************/ else if (kl==4 && strEQ(key, "NAME")) { AV *av; if (!imp_sth->in_sqlda || !imp_sth->out_sqlda) return Nullsv; av = newAV(); result = newRV_inc(sv_2mortal((SV*)av)); while(--i >= 0) { if (imp_sth->out_sqlda->sqlvar[i].aliasname_length > 0) { av_store(av, i, newSVpvn(imp_sth->out_sqlda->sqlvar[i].aliasname, imp_sth->out_sqlda->sqlvar[i].aliasname_length)); } else { char s[20]; snprintf(s, sizeof(s), "COLUMN%d", i); av_store(av, i, newSVpvn(s, strlen(s))); } } } /**************************************************************************/ else if (kl==8 && strEQ(key, "NULLABLE")) { AV *av; if (!imp_sth->in_sqlda || !imp_sth->out_sqlda) return Nullsv; av = newAV(); result = newRV_inc(sv_2mortal((SV*)av)); while(--i >= 0) av_store(av, i, boolSV((imp_sth->out_sqlda->sqlvar[i].sqltype & 1) != 0)); } /**************************************************************************/ else if (kl==10 && strEQ(key, "CursorName")) { if (imp_sth->cursor_name == NULL) return Nullsv; result = newSVpv(imp_sth->cursor_name, strlen(imp_sth->cursor_name)); } /**************************************************************************/ else if (kl==11 && strEQ(key, "ParamValues")) { if (imp_sth->param_values == NULL) return Nullsv; result = newRV_inc((SV*)imp_sth->param_values); } else return Nullsv; if (cacheit) { /* cache for next time (via DBI quick_FETCH) */ SV **svp = hv_fetch((HV*)SvRV(sth), key, kl, 1); sv_free(*svp); *svp = result; (void)SvREFCNT_inc(result); /* so sv_2mortal won't free it */ } return sv_2mortal(result); } int dbd_st_STORE_attrib(SV *sth, imp_sth_t *imp_sth, SV *keysv, SV *valuesv) { STRLEN kl; char *key = SvPV(keysv, kl); DBI_TRACE_imp_xxh(imp_sth, 2, (DBIc_LOGPIO(imp_sth), "dbd_st_STORE - %s\n", key)); return FALSE; } int dbd_discon_all(SV *drh, imp_drh_t *imp_drh) { dTHR; /* The disconnect_all concept is flawed and needs more work */ if (!SvTRUE(perl_get_sv("DBI::PERL_ENDING", 0))) { sv_setiv(DBIc_ERR(imp_drh), (IV)1); sv_setpv(DBIc_ERRSTR(imp_drh), (char*)"disconnect_all not implemented"); (void)DBIh_EVENT2(drh, ERROR_event, DBIc_ERR(imp_drh), DBIc_ERRSTR(imp_drh)); return FALSE; } if (PL_perl_destruct_level) PL_perl_destruct_level = 0; return FALSE; } int ib_blob_write(SV *sth, imp_sth_t *imp_sth, XSQLVAR *var, SV *value) { D_imp_dbh_from_sth; isc_blob_handle handle = 0; ISC_STATUS status[ISC_STATUS_LENGTH]; STRLEN total_length; char *p, *seg, *string; int is_text_blob, seg_len; DBI_TRACE_imp_xxh(imp_sth, 2, (DBIc_LOGPIO(imp_sth), "ib_blob_write\n")); /* we need a transaction */ if (!imp_dbh->tr) if (!ib_start_transaction(sth, imp_dbh)) return FALSE; /* alloc mem for blob id */ if (var->sqldata == NULL) Newxc(var->sqldata, 1, ISC_QUAD, ISC_SCHAR); /* try to create blob handle */ isc_create_blob2(status, &(imp_dbh->db), &(imp_dbh->tr), &handle, (ISC_QUAD *)(var->sqldata), 0, NULL); if (ib_error_check(sth, status)) return FALSE; is_text_blob = (var->sqlsubtype == isc_bpb_type_stream)? 1: 0; /* SUBTYPE TEXT */ /* get length, pointer to data */ string = SvPV(value, total_length); /* write it segment by segment */ seg_len = BLOB_SEGMENT; p = string; while (total_length > 0) { DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "ib_blob_write: %lld bytes left\n", (long long)total_length)); /* set new segment start pointer */ seg = p; if (is_text_blob) { seg_len = 0; while ((seg_len < BLOB_SEGMENT) && (total_length > 0)) { total_length--; p++; seg_len++; if (*(p-1) == '\n') break; } } else { /* no text blob, set seg len to max possible */ if (total_length < BLOB_SEGMENT) seg_len = total_length; /* update segment pointer */ p += seg_len; total_length -= seg_len; } isc_put_segment(status, &handle, (unsigned short) seg_len, seg); if (ib_error_check(sth, status)) { isc_cancel_blob(status, &handle); return FALSE; } DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "ib_blob_write: %d bytes written\n", seg_len)); } /* close blob, check for error */ isc_close_blob(status, &handle); if (ib_error_check(sth, status)) return FALSE; return TRUE; } /* fill in_sqlda with bind parameters */ static int ib_fill_isqlda(SV *sth, imp_sth_t *imp_sth, SV *param, SV *value, IV sql_type) { STRLEN len; XSQLVAR *ivar; int retval; int dtype; int i = (int)SvIV(param) - 1; retval = TRUE; ivar = &(imp_sth->in_sqlda->sqlvar[i]); DBI_TRACE_imp_xxh(imp_sth, 2, (DBIc_LOGPIO(imp_sth), "enter ib_fill_isqlda. processing %d XSQLVAR" " Type %ld" " ivar->sqltype=%d\n", i + 1, (long) sql_type, ivar->sqltype)); DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "ib_fill_isqlda: XSQLDA len: %d\n", imp_sth->in_sqlda->sqln)); /* NULL indicator */ if (!(ivar->sqlind)) Newx(ivar->sqlind, 1, ISC_SHORT); /* *(ivar->sqlind) = ivar->sqltype & 1 ? 0 : 1; */ *(ivar->sqlind) = 0; /* default assume non-NULL */ /* it should be safe not to free here. test it */ #if 0 if (ivar->sqldata) { DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "ib_fill_isqlda: Freeing sqldata\n")); DBI_TRACE_imp_xxh(imp_sth, 4, (DBIc_LOGPIO(imp_sth), "ib_fill_isqlda: Freeing sqldata, sqltype is %d\n", ivar->sqltype)); Safefree(ivar->sqldata); ivar->sqldata = (char *)NULL; } #endif if (!SvOK(value)) /* user passed an undef */ { if (ivar->sqltype & 1) /* Field is NULLable */ { /* * The user has passed 'undef' for this scalar parameter and we use * this to indicate that the parameter should have a NULL state. */ *(ivar->sqlind) = -1; /* NULL */ /* * Hence no need to fill in sqldata for this sqlvar, because it's * NULL anyway.Skip to next loop iteration. */ return retval; } else { /* * User passed an undef to a field that is not nullable. */ char err[ERRBUFSIZE]; snprintf(err, sizeof(err), "You have not provided a value for non-nullable parameter #%d.", i); do_error(sth, 1, err); retval = FALSE; return retval; } } do { char *p; STRLEN len; if ( imp_sth->param_values == NULL ) imp_sth->param_values = newHV(); p = SvPV(param, len); (void)hv_store( imp_sth->param_values, p, len, newSVsv(value), 0 ); } while (0); /* data type minus nullable flag */ dtype = ivar->sqltype & ~1; /* workaround for date problem (bug #429820) */ if (dtype == SQL_TEXT) { if (ivar->sqlsubtype == 0x77) dtype = SQL_TIMESTAMP; } switch (dtype) { /**********************************************************************/ case SQL_VARYING: DBI_TRACE_imp_xxh(imp_sth, 1, (DBIc_LOGPIO(imp_sth), "ib_fill_isqlda: SQL_VARYING\n")); { char *string; STRLEN len; string = SvPV(value, len); if (len > ivar->sqllen) { char err[ERRBUFSIZE]; snprintf(err, sizeof(err), "String truncation (SQL_VARYING): attempted to bind %lu octets to column sized %lu", (long unsigned)len, (long unsigned)(sizeof(char) * (ivar->sqllen))); break; } if (!(ivar->sqldata)) Newxz(ivar->sqldata, ivar->sqllen + sizeof(short), char); *((short *)ivar->sqldata) = len; Copy(string, ivar->sqldata + sizeof(short), len, char); break; } /**********************************************************************/ case SQL_TEXT: DBI_TRACE_imp_xxh(imp_sth, 1, (DBIc_LOGPIO(imp_sth), "ib_fill_isqlda: SQL_TEXT\n")); { char *string; STRLEN len; string = SvPV(value, len); if (len > ivar->sqllen) { char err[ERRBUFSIZE]; snprintf(err, sizeof(err), "String truncation (SQL_TEXT): attempted to bind %lu octets to column sized %lu", (long unsigned)len, (long unsigned)(sizeof(char) * (ivar->sqllen))); break; } if (!(ivar->sqldata)) Newxc(ivar->sqldata, ivar->sqllen, char, ISC_SCHAR); /* Pad the entire field with blanks */ PoisonWith(ivar->sqldata, ivar->sqllen, char, ' '); Copy(string, ivar->sqldata, len, char); break; } /**********************************************************************/ case SQL_SHORT: case SQL_LONG: DBI_TRACE_imp_xxh(imp_sth, 1, (DBIc_LOGPIO(imp_sth), "ib_fill_isqlda: SQL_SHORT/SQL_LONG\n")); { char format[64]; long p, q, r, result; char *svalue; /* we need a bit of mem */ if (!(ivar->sqldata)) { Newxc(ivar->sqldata, (dtype == SQL_SHORT ? sizeof(short) : sizeof(long)), char, ISC_SCHAR); } /* See case SQL_INT64 for commentary. */ p = q = r = (long) 0; svalue = (char *)SvPV(value, len); /* with decimals? */ if (-ivar->sqlscale) { /* numeric(?,?) */ int scale = (int) (pow(10.0, (double) -ivar->sqlscale)); int dscale; char *tmp; char *neg; snprintf(format, sizeof(format), "%%ld.%%%dld%%1ld", -ivar->sqlscale); /* negative -0.x hack */ neg = strchr(svalue, '-'); if (neg) { svalue = neg + 1; len = strlen(svalue); } if (!sscanf(svalue, format, &p, &q, &r)) { /* here we handle values such as .78 passed as string */ snprintf(format, sizeof(format), ".%%%dld%%1ld", -ivar->sqlscale); if (!sscanf(svalue, format, &q, &r) && DBIc_WARN(imp_sth)) warn("problem parsing SQL_LONG type"); } /* Round up if r is 5 or greater */ if (r >= 5) { q++; /* round q up by one */ p += q / scale; /* round p up by one if q overflows */ q %= scale; /* modulus if q overflows */ } /* decimal scaling */ tmp = strchr(svalue, '.'); dscale = (tmp)? -ivar->sqlscale - (len - (int) (tmp - svalue)) + 1: 0; if (dscale < 0) dscale = 0; /* final result */ result = (long) (p * scale + q * (int) (pow(10.0, (double) dscale))) * (neg? -1: 1); } /******************************************************************/ else { /* numeric(?,0): scan for one decimal and do rounding*/ snprintf(format, sizeof(format), "%%ld.%%1ld"); if (!sscanf(svalue, format, &p, &r)) { snprintf(format, sizeof(format), ".%%1ld"); if (!sscanf(svalue, format, &r) && DBIc_WARN(imp_sth)) warn("problem parsing SQL_LONG type"); } /* rounding */ if (r >= 5) { if (p < 0) p--; else p++; } /* the final result */ result = (long) p; } /* result in short or long? */ if (dtype == SQL_SHORT) *(ISC_SHORT *) (ivar->sqldata) = (ISC_SHORT) result; else *(ISC_LONG *) (ivar->sqldata) = (ISC_LONG) result; break; } /**********************************************************************/ #ifdef SQL_BOOLEAN case SQL_BOOLEAN: DBI_TRACE_imp_xxh(imp_sth, 1, (DBIc_LOGPIO(imp_sth), "ib_fill_isqlda: SQL_BOOLEAN\n")); { if (!(ivar->sqldata)) Newxc(ivar->sqldata, 1, FB_BOOLEAN, ISC_SCHAR); bool v = SvTRUE_NN(value); *(FB_BOOLEAN *) (ivar->sqldata) = (v ? FB_TRUE : FB_FALSE); break; } #endif /**********************************************************************/ #ifdef SQL_INT64 case SQL_INT64: DBI_TRACE_imp_xxh(imp_sth, 1, (DBIc_LOGPIO(imp_sth), "ib_fill_isqlda: SQL_INT64\n")); { char *svalue; char format[64]; ISC_INT64 p, q, r; if (!(ivar->sqldata)) Newxc(ivar->sqldata, 1, ISC_INT64, ISC_SCHAR); /* * Here I handle both whole and scaled numerics. * The trick is to avoid converting the Perl scalar * to an IEEE floating value, because this would * introduce exactness errors in the conversion from * base-10 to base-2. * * I create a pattern for scanf() to read the whole * number portion (p), then a number of digits for * the scale (q), then one more digit (r) for the * round-up threshold. * * Note that sprintf replaces %% with a single %. * See the man page for sscanf() for more details * about how it interprets %Ld, %1Ld, etc. */ /* * Define INT64 sscanf formats for various platforms * using #defines eases the adding of a new platform (compiler/library) */ #if defined(_MSC_VER) /* Microsoft C compiler/library */ # define S_INT64_FULL "%%I64d.%%%dI64d%%1I64d" # define S_INT64_NOSCALE "%%I64d.%%1I64d" # define S_INT64_DEC_FULL ".%%%dI64d%%1I64d" # define S_INT64_DEC_NOSCALE ".%%1I64d" #elif defined (__FreeBSD__) /* FreeBSD */ # define S_INT64_FULL "%%qd.%%%dqd%%1qd" # define S_INT64_NOSCALE "%%qd.%%1qd" # define S_INT64_DEC_FULL ".%%%dqd%%1qd" # define S_INT64_DEC_NOSCALE ".%%1qd" #else /* others: linux, various unices */ # define S_INT64_FULL "%%lld.%%%dlld%%1lld" # define S_INT64_NOSCALE "%%lld.%%1lld" # define S_INT64_DEC_FULL ".%%%dlld%%1lld" # define S_INT64_DEC_NOSCALE ".%%1lld" #endif p = q = r = (ISC_INT64) 0; svalue = (char *)SvPV(value, len); /* with decimals? */ if (-ivar->sqlscale) { /* numeric(?,?) */ int scale = (int) (pow(10.0, (double) -ivar->sqlscale)); int dscale; char *tmp; char *neg; snprintf(format, sizeof(format), S_INT64_FULL, -ivar->sqlscale); /* negative -0.x hack */ neg = strchr(svalue, '-'); if (neg) { svalue = neg + 1; len = strlen(svalue); } if (!sscanf(svalue, format, &p, &q, &r)) { /* here we handle values such as .78 passed as string */ snprintf(format, sizeof(format), S_INT64_DEC_FULL, -ivar->sqlscale); if (!sscanf(svalue, format, &q, &r) && DBIc_WARN(imp_sth)) warn("problem parsing SQL_INT64 type"); } /* Round up if r is 5 or greater */ if (r >= 5) { q++; /* round q up by one */ p += q / scale; /* round p up by one if q overflows */ q %= scale; /* modulus if q overflows */ } /* decimal scaling */ tmp = strchr(svalue, '.'); dscale = (tmp)? -ivar->sqlscale - (len - (int) (tmp - svalue)) + 1: 0; if (dscale < 0) dscale = 0; /* final result */ *(ISC_INT64 *) (ivar->sqldata) = (ISC_INT64) (p * scale + q * (int) (pow(10.0, (double) dscale))) * (neg? -1: 1); } /******************************************************************/ else { /* numeric(?,0): scan for one decimal and do rounding*/ snprintf(format, sizeof(format), S_INT64_NOSCALE); if (!sscanf(svalue, format, &p, &r)) { snprintf(format, sizeof(format), S_INT64_DEC_NOSCALE); if (!sscanf(svalue, format, &r) && DBIc_WARN(imp_sth)) warn("problem parsing SQL_INT64 type"); } /* rounding */ if (r >= 5) { if (p < 0) p--; else p++; } /* the final result */ *(ISC_INT64 *) (ivar->sqldata) = (ISC_INT64) p; } break; } #endif /**********************************************************************/ case SQL_FLOAT: DBI_TRACE_imp_xxh(imp_sth, 1, (DBIc_LOGPIO(imp_sth), "ib_fill_isqlda: SQL_FLOAT\n")); if (!(ivar->sqldata)) Newxc(ivar->sqldata, 1, float, ISC_SCHAR); *(float *) (ivar->sqldata) = (float) SvNV(value); break; /**********************************************************************/ case SQL_DOUBLE: DBI_TRACE_imp_xxh(imp_sth, 1, (DBIc_LOGPIO(imp_sth), "ib_fill_isqlda: SQL_DOUBLE\n")); if (!(ivar->sqldata)) Newxc(ivar->sqldata, 1, double, ISC_SCHAR); *(double *) (ivar->sqldata) = SvNV(value); break; /**********************************************************************/ case SQL_TIMESTAMP: case SQL_TYPE_TIME: case SQL_TYPE_DATE: if (SvPOK(value) || SvTYPE(value) == SVt_PVMG) { /* * Coerce the date literal into a CHAR string, so as * to allow Firebird's internal date-string parsing * to interpret the date. */ char *datestring = SvPV(value, len); ivar->sqltype = SQL_TEXT | (ivar->sqltype & 1); /* prevent overflow */ if (len > 100) { do_error(sth, 2, "DATE input parameter too long, but will try...\n"); len = 100; } /* workaround for date problem (bug #429820) */ ivar->sqlsubtype = 0x77; /* (0x77 is a random value) */ ivar->sqllen = len; /* * I should not allocate based on len, I should allocate * a fixed length based on the max date/time string. * For now let's just call it 100. Okay, 101. */ if (!(ivar->sqldata)) Newx(ivar->sqldata, 101, ISC_SCHAR); Copy(datestring, ivar->sqldata, len, ISC_SCHAR); ivar->sqldata[len] = '\0'; } else if (SvROK(value)) { struct tm times; /* unix time struct */ AV *list = (AV *) SvRV(value); /* AV with time items */ SV **svp = AvARRAY(list); /* AV as a C array */ int items = av_len(list) + 1; /* item count in array */ /* check if we have enough items in the list */ if (items < 5) /* we ignore wday, yday, isdst */ { do_error(sth, 2, "Cannot bind date/time value. Not enough" "items in localtime() style array"); retval = FALSE; break; } /* fill in struct tm fields */ times.tm_sec = SvIV(svp[0]); times.tm_min = SvIV(svp[1]); times.tm_hour = SvIV(svp[2]); times.tm_mday = SvIV(svp[3]); times.tm_mon = SvIV(svp[4]); times.tm_year = SvIV(svp[5]); /* free ivar->sqldata (prior call wasn't necessary an localtimes * style list) */ if (ivar->sqldata) Safefree(ivar->sqldata); /* encode for firebird/interbase, store value*/ switch (dtype) { case SQL_TIMESTAMP: { ISC_TIMESTAMP timestamp; isc_encode_timestamp(×, ×tamp); Newxc(ivar->sqldata, 1, ISC_TIMESTAMP, ISC_SCHAR); if (items >= 10) TIMESTAMP_ADD_FPSECS(×tamp, SvIV(svp[9])); *(ISC_TIMESTAMP *) ivar->sqldata = timestamp; break; } case SQL_TYPE_TIME: { ISC_TIME sql_time; isc_encode_sql_time(×, &sql_time); Newxc(ivar->sqldata, 1, ISC_TIME, ISC_SCHAR); if (items >= 10) TIME_ADD_FPSECS(&sql_time, SvIV(svp[9])); *(ISC_TIME *) ivar->sqldata = sql_time; break; } case SQL_TYPE_DATE: { ISC_DATE sql_date; isc_encode_sql_date(×, &sql_date); Newxc(ivar->sqldata, 1, ISC_DATE, ISC_SCHAR); *(ISC_DATE *) ivar->sqldata = sql_date; break; } } } break; /**********************************************************************/ case SQL_BLOB: DBI_TRACE_imp_xxh(imp_sth, 1, (DBIc_LOGPIO(imp_sth), "ib_fill_isqlda: SQL_BLOB\n")); /* SELECT's can't have a blob as in_sqlda. */ if ((imp_sth->type == isc_info_sql_stmt_select) || (imp_sth->type == isc_info_sql_stmt_select_for_upd)) { do_error(sth, 2, "BLOB as an input param for SELECT is not allowed.\n"); retval = FALSE; break; } else /* we have an extra function for this */ retval = ib_blob_write(sth, imp_sth, ivar, value); break; /**********************************************************************/ case SQL_ARRAY: #ifdef ARRAY_SUPPORT !!! NOT IMPLEMENTED YET !!! #endif break; default: break; } DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "exiting ib_fill_isqlda: %d\n", retval)); return retval; } int dbd_bind_ph(SV *sth, imp_sth_t *imp_sth, SV *param, SV *value, IV sql_type, SV *attribs, int is_inout, IV maxlen) { DBI_TRACE_imp_xxh(imp_sth, 2, (DBIc_LOGPIO(imp_sth), "dbd_bind_ph\n")); if (SvTYPE(value) > SVt_PVLV) croak("Can't bind a non-scalar value (%s)", neatsvpv(value,0)); /* is_inout for stored procedure is not implemented yet */ if (is_inout) croak("Can't bind ``lvalue'' mode."); if (!imp_sth || !imp_sth->in_sqlda) return FALSE; /* param is the number of parameter: 1, 2, 3, or ... */ if ((int)SvIV(param) > imp_sth->in_sqlda->sqld) return TRUE; DBI_TRACE_imp_xxh(imp_sth, 3, (DBIc_LOGPIO(imp_sth), "Binding parameter: %d\n", (int)SvIV(param))); return ib_fill_isqlda(sth, imp_sth, param, value, sql_type); } int ib_start_transaction(SV *h, imp_dbh_t *imp_dbh) { ISC_STATUS status[ISC_STATUS_LENGTH]; if (imp_dbh->tr) { DBI_TRACE_imp_xxh(imp_dbh, 3, (DBIc_LOGPIO(imp_dbh), "ib_start_transaction: trans handle already started.\n")); return TRUE; } /* MUST initialized to 0, before it is used */ imp_dbh->tr = 0L; isc_start_transaction(status, &(imp_dbh->tr), 1, &(imp_dbh->db), imp_dbh->tpb_length, imp_dbh->tpb_buffer); if (ib_error_check(h, status)) return FALSE; DBI_TRACE_imp_xxh(imp_dbh, 3, (DBIc_LOGPIO(imp_dbh), "ib_start_transaction: transaction started.\n")); return TRUE; } int ib_commit_transaction(SV *h, imp_dbh_t *imp_dbh) { ISC_STATUS status[ISC_STATUS_LENGTH]; DBI_TRACE_imp_xxh(imp_dbh, 4, (DBIc_LOGPIO(imp_dbh), "ib_commit_transaction: DBIcf_AutoCommit = %lu, imp_dbh->sth_ddl = %u\n", (long unsigned)DBIc_has(imp_dbh, DBIcf_AutoCommit), imp_dbh->sth_ddl)); if (!imp_dbh->tr) { DBI_TRACE_imp_xxh(imp_dbh, 3, (DBIc_LOGPIO(imp_dbh), "ib_commit_transaction: transaction already NULL.\n")); /* In case we switched to use different TPB before we actually use */ /* This transaction handle */ imp_dbh->sth_ddl = 0; return TRUE; } /* do commit */ if ((imp_dbh->sth_ddl == 0) && (imp_dbh->soft_commit)) { DBI_TRACE_imp_xxh(imp_dbh, 2, (DBIc_LOGPIO(imp_dbh), "try isc_commit_retaining\n")); /* commit but don't close transaction */ isc_commit_retaining(status, &(imp_dbh->tr)); if (ib_error_check(h, status)) return FALSE; } else { /* close all open statement handles */ /* if ((imp_dbh->sth_ddl > 0) || !(DBIc_has(imp_dbh, DBIcf_AutoCommit))) */ /* remark: only necessary when we have DDL statement(s) */ if (imp_dbh->sth_ddl > 0) { while (imp_dbh->first_sth != NULL) { /* finish and destroy sth */ dbd_st_finish_internal((SV*)DBIc_MY_H(imp_dbh->first_sth), imp_dbh->first_sth, FALSE); dbd_st_destroy(NULL, imp_dbh->first_sth); } imp_dbh->sth_ddl = 0; } DBI_TRACE_imp_xxh(imp_dbh, 2, (DBIc_LOGPIO(imp_dbh), "try isc_commit_transaction\n")); /* commit and close transaction (sets handle to NULL) */ isc_commit_transaction(status, &(imp_dbh->tr)); if (ib_error_check(h, status)) return FALSE; imp_dbh->tr = 0L; } DBI_TRACE_imp_xxh(imp_dbh, 2, (DBIc_LOGPIO(imp_dbh), "ib_commit_transaction succeed.\n")); return TRUE; } int ib_rollback_transaction(SV *h, imp_dbh_t *imp_dbh) { ISC_STATUS status[ISC_STATUS_LENGTH]; DBI_TRACE_imp_xxh(imp_dbh, 2, (DBIc_LOGPIO(imp_dbh), "ib_rollback_transaction\n")); if (!imp_dbh->tr) { DBI_TRACE_imp_xxh(imp_dbh, 3, (DBIc_LOGPIO(imp_dbh), "ib_rollback_transaction: transaction already NULL.\n")); imp_dbh->sth_ddl = 0; return TRUE; } /* no isc_rollback_retaining in IB prior to 6 */ if ((imp_dbh->sth_ddl == 0) && (imp_dbh->soft_commit)) { DBI_TRACE_imp_xxh(imp_dbh, 2, (DBIc_LOGPIO(imp_dbh), "try isc_rollback_retaining\n")); /* rollback but don't close transaction */ isc_rollback_retaining(status, &(imp_dbh->tr)); if (ib_error_check(h, status)) return FALSE; } else { /* close all open statement handles */ if ((imp_dbh->sth_ddl > 0) || !(DBIc_has(imp_dbh, DBIcf_AutoCommit))) { while (imp_dbh->first_sth != NULL) { /* finish and destroy sth */ dbd_st_finish((SV*)DBIc_MY_H(imp_dbh->first_sth), imp_dbh->first_sth); dbd_st_destroy(NULL, imp_dbh->first_sth); } imp_dbh->sth_ddl = 0; } DBI_TRACE_imp_xxh(imp_dbh, 2, (DBIc_LOGPIO(imp_dbh), "try isc_rollback_transaction\n")); /* rollback and close transaction (sets handle to NULL) */ isc_rollback_transaction(status, &(imp_dbh->tr)); if (ib_error_check(h, status)) return FALSE; imp_dbh->tr = 0L; } DBI_TRACE_imp_xxh(imp_dbh, 2, (DBIc_LOGPIO(imp_dbh), "ib_rollback_transaction succeed\n")); return TRUE; } int dbd_st_blob_read(SV *sth, imp_sth_t *imp_sth, int field, long offset, long len, SV *destrv, long destoffset) { return FALSE; } int dbd_st_rows(SV* sth, imp_sth_t* imp_sth) { /* spot common mistake of checking $h->rows just after ->execut if (imp_sth->affected < 0 && DBIc_WARN(imp_sth) ) { warn("$h->rows count is incomplete before all rows fetched.\n"); } */ return imp_sth->affected; } long ib_rows(SV *xxh, isc_stmt_handle *h_stmt, char count_type) { ISC_STATUS status[ISC_STATUS_LENGTH]; short l; char count_is; char count_info[1], count_buffer[33]; char *p; long row_count = -1; count_info[0] = isc_info_sql_records; if (isc_dsql_sql_info(status, h_stmt, sizeof(count_info), count_info, sizeof(count_buffer), count_buffer)) { if (ib_error_check(xxh, status)) return -2; /* error */ } for (p = count_buffer + 3; *p != isc_info_end;) { count_is = *p++; l = (short) isc_vax_integer(p, 2); p += 2; row_count = (long) isc_vax_integer(p, l); p += l; if (count_is == count_type) break; } return row_count; } /* how many bytes per character in this charset? information is retrieved from RDB$CHARACTER_SETS the first time it is needed and is cached for later */ unsigned get_charset_bytes_per_char(const ISC_SHORT subtype, SV *sth) { unsigned char *p; D_imp_sth(sth); D_imp_dbh_from_sth; //warn("Q: How many bytes/char in CS %d?", subtype & 0xff); if ( (p = imp_dbh->charset_bytes_per_char) == NULL ) { XSQLDA *out = NULL; XSQLVAR *var; isc_stmt_handle stmt = 0; ISC_STATUS status[ISC_STATUS_LENGTH]; char sql[] = "SELECT RDB$CHARACTER_SET_ID, RDB$BYTES_PER_CHARACTER FROM RDB$CHARACTER_SETS"; int fetch_stat; unsigned i; Newxz( imp_dbh->charset_bytes_per_char, 256, unsigned char ); p = imp_dbh->charset_bytes_per_char; IB_alloc_sqlda(out, 2); if (out == NULL) { do_error(sth, 2, "Failed to allocate out sqlda"); goto cleanup; } isc_dsql_alloc_statement2(status, &(imp_dbh->db), &stmt); if (ib_error_check(sth, status)) goto cleanup; isc_dsql_prepare(status, &(imp_dbh->tr), &stmt, 0, sql, imp_dbh->sqldialect, out); if (ib_error_check(sth, status)) goto cleanup; isc_dsql_describe(status, &stmt, SQLDA_OK_VERSION, out); if (ib_error_check(sth, status)) goto cleanup; for (i=0, var = out->sqlvar; i < out->sqld; i++, var++) { unsigned dtype = (var->sqltype & ~1); switch(dtype) { case SQL_SHORT: Newxc(var->sqldata, 1, ISC_SHORT, void); break; default: do_error(sth, 2, "Unexpected datatype"); goto cleanup; break; } if (var->sqltype & 1) { /* allocate variable to hold NULL status */ Newx(var->sqlind, 1, ISC_SHORT); } } isc_dsql_execute(status, &(imp_dbh->tr), &stmt, 1, NULL); if (ib_error_check(sth, status)) goto cleanup; while ((fetch_stat = isc_dsql_fetch(status, &stmt, 1, out)) == 0) { unsigned char cs_id = (unsigned char) *(ISC_SHORT *)(out->sqlvar[0].sqldata); unsigned char bpc = (unsigned char) *(ISC_SHORT *)(out->sqlvar[1].sqldata); p[cs_id] = bpc; //warn("CS %d has %d bytes/char", cs_id, bpc); } cleanup: isc_dsql_free_statement(status, &stmt, DSQL_drop); Safefree(out->sqlvar[0].sqldata); Safefree(out->sqlvar[0].sqlind); Safefree(out->sqlvar[1].sqldata); Safefree(out->sqlvar[1].sqlind); Safefree(out); } //warn("A: %d", p[subtype & 0xff]); return p[ subtype & 0xff ]; } /* end */ DBD-Firebird-1.39/Makefile.PL0000644000175000017500000002362614153066104013632 0ustar damdam#!perl #----------------------------------------------------------------------------- # # Copyright (c) 2011 Stefan Suciu # Copyright (c) 2011 Damyan Ivanov # Copyright (c) 2011 Marius Popa # Copyright (c) 2011 Alexandr Ciornii # Copyright (c) 1999-2008 Edwin Pratomo # Portions Copyright (c) 2001-2005 Daniel Ritz # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # #----------------------------------------------------------------------------- # Changes: # # 2011-09-02: Integrated patch from real-dam # Do not link with libdl.so on GNU/Linux # # 2011-04-04: Integrated patch from Alexandr Ciornii regarding # WriteMakefile sub. # Moved prompting to subs, other layout changes. # # 2011-04-03, Added CLI prompting with optional -interactive command # line parameter. # Added support for VC++ copy-paste from the original (NOT tested!) # # 2011-03-30, Refactored. # Modified to use environment vars or helper subs to locate Firebird # (only MinGW support), removed the CLI prompts. # inspired by the App::Info module: Info.pm - 2008-07-18 16:17:45Z by david # and DBD::Pg - Makefile.PL 2010-11-21 04:19:18Z by turnstep # # 2011-01-31, stefansbv: # using the three-argument form of open for reading tests-setup.tmp.conf # # 2011-01-26, stefansbv: # fixed the isql tool path and the command line # (using quotes around parameters and canonpath) # when isql error create the test database and inform the user # improved support for MinGW (now using the Config module) # added support for ActivePerl! :) # # Notes: MS specific required Firebird installation setting: Copy # Firebird client library to directory? - Yes, unless the # Firebird HOME is in your path. # package MY; our $postamble; sub postamble { return $postamble; } 1; package main; use strict; use warnings; use Carp; use 5.008; use Getopt::Long; use File::Spec; use File::Basename; use ExtUtils::MakeMaker 5.16, qw(prompt &WriteMakefile $Verbose); use Config; # Globals vars our $EMBEDDED = 0; BEGIN { # Theory of operation: # we copy this Makefile.PL to embed/ and set $EMBEDDED to 1 there # this way we have to maintain one code base with special cases for # the embedded module build # See create_embedded_Makefile_PL below unless ($EMBEDDED) { unshift @INC, 'inc'; require FirebirdMaker; FirebirdMaker->import; } } my $interactive; my $help; my $os = $^O; GetOptions( interactive => \$interactive, help => \$help, ) unless $EMBEDDED; if ($help) { help_message(); exit; } my $module_name = $EMBEDDED ? 'DBD::FirebirdEmbedded' : 'DBD::Firebird'; print "Configuring $module_name (on $os)\n"; $FB::libfbembed_available = 0; # We set FIREBIRD_HOME from the first found of: # 1. Environment variable # 2. Helper subs (search Firebird in the known locations) unless ($EMBEDDED) { # 1. Environment variables $FB::HOME = $ENV{FIREBIRD_HOME}; $FB::INC = $ENV{FIREBIRD_INCLUDE}; $FB::LIB = $ENV{FIREBIRD_LIB}; if ($FB::HOME) { # 2. Subdirectory of FIREBIRD_HOME if ($os eq 'darwin') { $FB::INC ||= (grep -d, ( # could be set to Resources/ or not File::Spec->catdir( $FB::HOME, '..', 'Headers' ), File::Spec->catdir( $FB::HOME, 'Headers' ), File::Spec->catdir( $FB::HOME, 'include' ), ))[0]; $FB::LIB ||= (grep -d, ( File::Spec->catdir( $FB::HOME, '..', 'Libraries' ), File::Spec->catdir( $FB::HOME, 'Libraries' ), File::Spec->catdir( $FB::HOME, 'lib' ), ))[0]; } else { $FB::INC ||= File::Spec->catdir( $FB::HOME, 'include' ); $FB::LIB ||= File::Spec->catdir( $FB::HOME, 'lib' ); } } else { # No FIREBIRD_HOME # We could check FIREBIRD_INCLUDE and FIREBIRD_LIB and set # FIREBIRD_HOME as parent dir, but maybe is to weird :) # Anyway their value take precedence in locate_firebird sub. # Try to locate Firebird in the ususal places if ($os eq 'MSWin32' || $os eq 'cygwin') { locate_firebird_ms(); } elsif ($os eq 'darwin') { $FB::HOME = '/Library/Frameworks/Firebird.framework/Resources'; $FB::INC = '/Library/Frameworks/Firebird.framework/Headers'; $FB::LIB = '/Library/Frameworks/Firebird.framework/Libraries'; } else { locate_firebird(); } } detect_firebird_api_version(); } my $client_lib = ( $EMBEDDED and $FB::API_VER < 30 ) ? 'fbembed' : 'fbclient'; if ($interactive) { # Interactive mode setup welcome_msg(); prompt_for_settings(); } else { print "\n"; print 'FIREBIRD_HOME : ', $FB::HOME || '(none)', "\n"; print 'FIREBIRD_INCLUDE: ', $FB::INC || '(none)', "\n"; print 'FIREBIRD_LIB : ', $FB::LIB || '(none)', "\n"; print 'Client library : ', $client_lib,"\n"; print "\n"; save_test_parameters() unless $EMBEDDED; } do { eval { require DBI::DBD; }; if ($@) { print "Could not load DBI::DBD - is the DBI module installed?\n"; exit 0; } $MY::postamble ||= DBI::DBD::dbd_postamble(); ## Prevent duplicate debug info as dbd_postamble also calls this local *STDOUT; $FB::dbi_arch_dir ||= DBI::DBD::dbd_dbi_arch_dir(); } unless $EMBEDDED; my $cflags = $Config{q{ccflags}}||''; $cflags .= " $ENV{CFLAGS}" if $ENV{CFLAGS}; if ($Config{cc} =~ /gcc/) { $cflags = "-Wall -fno-strict-aliasing $cflags"; } my @inc; for ( $FB::INC, $FB::dbi_arch_dir ) { push @inc, qq(-I"$_") if $_ } my %MakeParams = ( NAME => $module_name, VERSION_FROM => $EMBEDDED ? 'FirebirdEmbedded.pm' : 'Firebird.pm', # finds $VERSION C => ['dbdimp.c'], H => [ 'dbdimp.h', $EMBEDDED ? 'FirebirdEmbedded.h' : 'Firebird.h' ], CCFLAGS => $cflags, ( $EMBEDDED ? ( DEFINE => '-DEMBEDDED' ) : () ), INC => join( ' ', @inc ), OBJECT => join( ' ', $EMBEDDED ? "FirebirdEmbedded.o" : "Firebird.o", "dbdimp.o" ), LIBS => [''], OPTIMIZE => $Config{optimize}, XSPROTOARG => '-noprototypes', dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz' }, clean => { FILES => qq(*.xsi *.old t/*.old *~ t/*~ trace.txt t/trace.txt lib/DBD/Firebird/*~ lib/DBD/Firebird/*.old lib/Bundle/DBD/*~ lib/Bundle/DBD/*.old dll.* fb_init fb_sem fb_trace_* dbd-fb-testdb.fdb) }, realclean => { FILES => qq($test_conf $test_mark t/*.sql embed t/embed-*.t) }, AUTHOR => 'Edwin Pratomo (edpratomo@users.sourceforge.net)', ABSTRACT => 'DBD::Firebird is a DBI driver for Firebird, written using Firebird C API.', PREREQ_PM => { DBI => 1.41 }, CONFIGURE_REQUIRES => { DBI => 1.41, 'File::Which' => 0, }, BUILD_REQUIRES => { }, TEST_REQUIRES => { 'File::Path' => 0, 'File::Temp' => 0, 'Math::BigFloat' => 1.55, 'Test::CheckDeps' => 0.007, 'Test::Deep' => 0, 'Test::Exception' => 0.31, 'Test::More' => 0.4, 'Time::HiRes' => 0, }, LICENSE => 'perl', MIN_PERL_VERSION => '5.008001', META_MERGE => { resources => { repository => 'https://github.com/mariuz/perl-dbd-firebird', }, }, ); # The OS specific build environment setup SWITCH: { $os eq 'MSWin32' && do { # Choices for the compiler if ( $Config{cc} =~ m{gcc} ) { setup_for_ms_gcc(); } elsif ( $Config{cc} eq q{cl} ) { setup_for_ms_cl(); } else { print "No suitable compiler found\n"; print "(Try: ppm install MinGW, to install MinGW!)\n"; exit 1; } last SWITCH; }; $os eq 'cygwin' && do { setup_for_cygwin(); last SWITCH; }; $os eq 'solaris' && do { $MakeParams{LIBS} = '-lgdsmt -lm -lc'; last SWITCH; }; $os eq 'linux' && do { $MakeParams{LIBS} = "-L$FB::LIB -l$client_lib "; last SWITCH; }; $os eq 'freebsd' && do { $MakeParams{LIBS} = "-L$FB::LIB -l$client_lib "; last SWITCH; }; $os eq 'gnukfreebsd' && do { $MakeParams{LIBS} = "-L$FB::LIB -l$client_lib "; last SWITCH; }; $os eq 'darwin' && do { my $framework_dir = dirname $FB::HOME; #"/Library/Frameworks/Firebird.framework"; my $framework_name = File::Spec->catfile( $framework_dir, "Firebird"); # For some reason, the framework file can be a broken symlink, see issue #?? # We can use -e to check if the symlink is broken: if ( -e $framework_name ) { $MakeParams{LDDLFLAGS} = $Config{lddlflags} . " -framework Firebird "; } else { $MakeParams{LDDLFLAGS} = $Config{lddlflags}; $MakeParams{LIBS} = "-L$FB::LIB -l$client_lib "; } last SWITCH; }; carp "DBD::Firebird is not supported on platform $os.\n"; exit 1; } unless ($EMBEDDED) { if ($FB::libfbembed_available or $FB::API_VER >= 30) { print "Found libfbembed, will build DBD::FirebirdEmbed too.\n"; create_embedded_files(); } else { print "libfbembed not found and API version is $FB::API_VER, building of DBD::FirebirdEmbed skipped.\n"; # make sure there is no embedded build involved my $mfpl = File::Spec->catfile( 'embed', 'Makefile.PL' ); unlink $mfpl if -e $mfpl; } } # And last but not least write the Makefile WriteMakefile1(%MakeParams); closing_msg() if !$EMBEDDED and !$interactive and ( !defined $ENV{DBI_PASS} and !defined $ENV{ISC_PASSWORD} ); exit 0; #- end of Makefile.PL DBD-Firebird-1.39/lib/0000755000175000017500000000000014743133212012415 5ustar damdamDBD-Firebird-1.39/lib/DBD/0000755000175000017500000000000014743133212013006 5ustar damdamDBD-Firebird-1.39/lib/DBD/Firebird/0000755000175000017500000000000014743133212014534 5ustar damdamDBD-Firebird-1.39/lib/DBD/Firebird/TableInfo.pm0000644000175000017500000000113712457761155016754 0ustar damdampackage DBD::Firebird::TableInfo; use strict; use warnings; sub factory { my (undef, $dbh) = @_; my ($vers, $klass); $vers = $dbh->func('version', 'ib_database_info')->{version}; $dbh->trace_msg("TableInfo factory($dbh [$vers])"); if ($vers =~ /firebird (\d\.\d+)/i and $1 >= 2.1) { $klass = 'DBD::Firebird::TableInfo::Firebird21'; } else { $klass = 'DBD::Firebird::TableInfo::Basic'; } eval "require $klass"; if ($@) { $dbh->set_err(1, "DBD::Firebird::TableInfo factory: $@"); return undef; } $klass->new() if $klass; } 1; DBD-Firebird-1.39/lib/DBD/Firebird/TableInfo/0000755000175000017500000000000014743133212016377 5ustar damdamDBD-Firebird-1.39/lib/DBD/Firebird/TableInfo/Basic.pm0000644000175000017500000001413512457761155017777 0ustar damdampackage DBD::Firebird::TableInfo::Basic; use strict; use warnings; =pod =head1 NAME DBD::Firebird::TableInfo::Basic - A base class for lowest-common denominator Firebird table_info() querying. =head1 SYNOPSIS # Add support for a hypothetical IB derivative package DBD::Firebird::TableInfo::HypotheticalIBDerivative @ISA = qw(DBD::Firebird::TableInfo::Basic); # What table types are supported? sub supported_types { ('SYSTEM TABLE', 'TABLE', 'VIEW', 'SPECIAL TABLE TYPE'); } sub table_info { my ($self, $dbh, $table, @types) = @_; } =head1 INTERFACE =over 4 =item I $ti->list_catalogs($dbh); # $dbh->table_info('%', '', '') Returns a statement handle with an empty result set, as IB does not support the DBI concept of catalogs. (Rule 19a) =item I $ti->list_schema($dbh); # $dbh->table_info('', '%', '') Returns a statement handle with an empty result set, as IB does not support the DBI concept of schema. (Rule 19b) =item I $ti->list_tables($dbh, $table, @types); # $dbh->table_info('', '', # 'FOO%', # 'TABLE,VIEW'); Called in response to $dbh->table_info($cat, $schem, $table, $types). C<$cat> and C<$schem> are presently ignored. This is the workhorse method that must return an appropriate statement handle of tables given the requested C<$table> pattern and C<@types>. A blank C<$table> pattern means "any table," and an empty C<@types> list means "any type." C<@types> is a list of user-supplied, requested types. C will normalize the user-supplied types, stripping quote marks, uppercasing, and removing duplicates. =item I $tbl_info->list_types($dbh); # $dbh->table_info('', '', '', '%') Called in response to $dbh->table_info('', '', '', '%'), returning a statement handle with a TABLE_TYPE column populated with the results of I. (Rule 19c) Normally not overridden. Override I, instead. =item I $tbl_info->supported_types($dbh); Returns a list of supported DBI TABLE_TYPE entries. The default implementation supports 'TABLE', 'SYSTEM TABLE' and 'VIEW'. This method is called by the default implementation of C. =back =cut sub new { bless {}, shift; } my %FbTableTypes = ( 'SYSTEM TABLE' => '((rdb$system_flag = 1) AND rdb$view_blr IS NULL)', 'SYSTEM VIEW' => '((rdb$system_flag = 1) AND rdb$view_blr IS NOT NULL)', 'TABLE' => '((rdb$system_flag = 0 OR rdb$system_flag IS NULL) AND rdb$view_blr IS NULL)', 'VIEW' => '((rdb$system_flag = 0 OR rdb$system_flag IS NULL) AND rdb$view_blr IS NOT NULL)', ); sub supported_types { sort keys %FbTableTypes; } sub sponge { # no warnings 'once'; my ($self, $dbh, $stmt, $attrib_hash) = @_; my $sponge = DBI->connect('dbi:Sponge:', '', '') or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr"); return ($sponge->prepare($stmt, $attrib_hash) or $dbh->DBI::set_err($sponge->err(), $sponge->errstr())); } sub list_catalogs { my ($self, $dbh) = @_; return $self->sponge($dbh, 'catalog_info', { NAME => [qw(TABLE_CAT TABLE_SCHEM TABLE_NAME TABLE_TYPE REMARKS)], rows => [], }); } sub list_schema { my ($self, $dbh) = @_; $self->sponge($dbh, 'schema_info', { NAME => [qw(TABLE_CAT TABLE_SCHEM TABLE_NAME TABLE_TYPE REMARKS)], rows => [], }); } sub list_types { my ($self, $dbh) = @_; my @rows = map { [undef, undef, undef, $_, undef] } $self->supported_types; $self->sponge($dbh, 'supported_type_info', { NAME => [qw(TABLE_CAT TABLE_SCHEM TABLE_NAME TABLE_TYPE REMARKS)], rows => \@rows }); } # # Fetch a listing of tables matching the desired TABLE_NAME pattern # and desired TABLE_TYPEs. Do not presume support for CASE/END, # COALESCE nor derived tables. # # We could put more work on the server than we do here. However, # rdb$relation_name is very likely to be space padded, and we cannot # presume a TRIM() function. So, $dbh->table_info('', '', 'F%T') # cannot be implemented as "rdb$relation_name LIKE 'F%T'", since, in # strict SQL, the padded string 'FOOT ' is NOT LIKE 'F%T'. # sub list_tables { my ($self, $dbh, $name_pattern, @types) = @_; my ($name_ok, $type_ok); my @data; # no warnings 'uninitialized' if (!defined($name_pattern) or $name_pattern eq '%' or $name_pattern eq '') { $name_ok = sub {1}; } else { my $re = quotemeta($name_pattern); for ($re) { s/_/./g; s/%/.*/g; } $name_ok = sub { $_[0] =~ /$re/ }; } if (@types) { my %desired = map { $_ => 1 } grep { exists $FbTableTypes{$_} } @types; $type_ok = sub { exists $desired{$_[0]} }; } else { $type_ok = sub { 1 }; } my $sth = $dbh->prepare(<<'__eosql'); SELECT v.rdb$relation_name AS TABLE_NAME, CAST('VIEW' AS CHAR(5)) AS TABLE_TYPE, v.rdb$description AS REMARKS, v.rdb$owner_name AS ib_owner_name, v.rdb$system_flag AS flag_sys FROM rdb$relations v WHERE v.rdb$view_blr IS NOT NULL UNION ALL SELECT t.rdb$relation_name AS TABLE_NAME, CAST('TABLE' AS CHAR(5)) AS TABLE_TYPE, t.rdb$description AS REMARKS, t.rdb$owner_name AS ib_owner_name, t.rdb$system_flag AS flag_sys FROM rdb$relations t WHERE t.rdb$view_blr IS NULL __eosql if ($sth) { $sth->{ChopBlanks} = 1; $sth->execute or return undef; } while (my $r = $sth->fetch) { my ($name, $type, $remarks, $owner, $flag_sys) = @$r; $type = "SYSTEM $type" if $flag_sys; next unless $name_ok->($name); next unless $type_ok->($type); push @data, [undef, undef, $name, $type, $remarks, $owner]; } return $self->sponge($dbh, 'table_info', { NAME => [qw(TABLE_CAT TABLE_SCHEM TABLE_NAME TABLE_TYPE REMARKS ib_owner_name)], rows => \@data }); } 1; __END__ # vim:set et ts=4: DBD-Firebird-1.39/lib/DBD/Firebird/TableInfo/Firebird21.pm0000644000175000017500000000634112457761155020647 0ustar damdampackage DBD::Firebird::TableInfo::Firebird21; use strict; use warnings; use DBD::Firebird::TableInfo::Basic; use vars qw(@ISA); @ISA = qw(DBD::Firebird::TableInfo::Basic); my %FbTableTypes = ( 'SYSTEM TABLE' => '((rdb$system_flag = 1) AND rdb$view_blr IS NULL)', 'SYSTEM VIEW' => '((rdb$system_flag = 1) AND rdb$view_blr IS NOT NULL)', 'TABLE' => '((rdb$system_flag = 0 OR rdb$system_flag IS NULL) AND rdb$view_blr IS NULL)', 'VIEW' => '((rdb$system_flag = 0 OR rdb$system_flag IS NULL) AND rdb$view_blr IS NOT NULL)', 'GLOBAL TEMPORARY' => '((rdb$system_flag = 0 OR rdb$system_flag IS NULL) AND rdb$relation_type IN (4, 5))', ); sub supported_types { sort keys %FbTableTypes; } sub list_tables { my ($self, $dbh, $table, @types) = @_; my (@conditions, @bindvars); my $where = ''; if (defined($table) and length($table)) { push @conditions, ($table =~ /[_%]/ ? 'TRIM(rdb$relation_name) LIKE ?' : 'rdb$relation_name = ?'); push @bindvars, $table; } if (@types) { push @conditions, join ' OR ' => map { $FbTableTypes{$_} || '(1=0)' } @types; } if (@conditions) { $where = 'WHERE ' . join(' AND ' => map { "($_)" } @conditions); } # "The Firebird System Tables Exposed" # Martijn Tonies, 6th Worldwide Firebird Conference 2008 # Bergamo, Italy my $sth = $dbh->prepare(<<__eosql); SELECT CAST(NULL AS CHAR(1)) AS TABLE_CAT, CAST(NULL AS CHAR(1)) AS TABLE_SCHEM, TRIM(rdb\$relation_name) AS TABLE_NAME, CAST(CASE WHEN rdb\$system_flag > 0 THEN CASE WHEN rdb\$view_blr IS NULL THEN 'SYSTEM TABLE' ELSE 'SYSTEM VIEW' END WHEN rdb\$relation_type IN (4, 5) THEN 'GLOBAL TEMPORARY' WHEN rdb\$view_blr IS NULL THEN 'TABLE' ELSE 'VIEW' END AS CHAR(16)) AS TABLE_TYPE, TRIM(rdb\$description) AS REMARKS, TRIM(rdb\$owner_name) AS ib_owner_name, CASE rdb\$relation_type WHEN 0 THEN 'Persistent' WHEN 1 THEN 'View' WHEN 2 THEN 'External' WHEN 3 THEN 'Virtual' WHEN 4 THEN 'Global Temporary Preserve' WHEN 5 THEN 'Global Temporary Delete' ELSE NULL END AS ib_relation_type FROM rdb\$relations $where __eosql if ($sth) { $sth->{ChopBlanks} = 1; $sth->execute(@bindvars) or return undef; } $sth; } 1; __END__ sub fb15_table_info { SELECT NULL AS TABLE_CAT, NULL AS TABLE_SCHEM, TRIM(rdb\$relation_name) AS TABLE_NAME, CASE WHEN rdb\$system_flag > 0 THEN 'SYSTEM TABLE' WHEN rdb\$view_blr IS NOT NULL THEN 'VIEW' ELSE 'TABLE' END AS TABLE_TYPE, rdb\$description AS REMARKS, rdb\$owner_name AS ib_owner_name, rdb\$external_file AS ib_external_file FROM rdb\$relations } # vim:set et ts=4: DBD-Firebird-1.39/lib/DBD/Firebird/TypeInfo.pm0000644000175000017500000000707512600606522016637 0ustar damdam# # Copyright (c) 2005 Edwin Pratomo # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file # The %type_info_all hash was automatically generated by # DBI::DBD::Metadata::write_typeinfo_pm v1.05. package DBD::Firebird::TypeInfo; use strict; use warnings; { use DBI qw(:sql_types); our $type_info_all = [ { TYPE_NAME => 0, DATA_TYPE => 1, COLUMN_SIZE => 2, LITERAL_PREFIX => 3, LITERAL_SUFFIX => 4, CREATE_PARAMS => 5, NULLABLE => 6, CASE_SENSITIVE => 7, SEARCHABLE => 8, UNSIGNED_ATTRIBUTE => 9, FIXED_PREC_SCALE => 10, AUTO_UNIQUE_VALUE => 11, LOCAL_TYPE_NAME => 12, MINIMUM_SCALE => 13, MAXIMUM_SCALE => 14, SQL_DATA_TYPE => 15, SQL_DATETIME_SUB => 16, NUM_PREC_RADIX => 17, INTERVAL_PRECISION => 18, }, [ "BOOLEAN", SQL_BIT, 1, undef, undef,undef, 1,0,3,undef,0,0, "BOOLEAN", undef,undef,SQL_BIT, undef,10, undef, ], [ "BLOB", SQL_LONGVARBINARY, 2147483647,"0x", undef,undef, 1,1,1,undef,0,undef,"BLOB", undef,undef,SQL_LONGVARBINARY,undef,undef,undef, ], [ "BLOB SUB_TYPE TEXT",SQL_LONGVARCHAR, 2147483647,"'", "'", undef, 1,1,1,undef,0,undef,"BLOB", undef,undef,SQL_LONGVARCHAR, undef,undef,undef, ], [ "CHARACTER", SQL_CHAR, 32765, "'", "'", "length", 1,1,3,undef,0,undef,"CHAR", undef,undef,SQL_CHAR, undef,undef,undef, ], [ "NUMERIC", SQL_NUMERIC, 18, undef, undef,"precision,scale",1,0,3,undef,0,undef,"NUMERIC", undef,undef,SQL_NUMERIC, undef,10, undef, ], [ "DECIMAL", SQL_DECIMAL, 18, undef, undef,"precision,scale",1,0,3,undef,0,undef,"DECIMAL", undef,undef,SQL_DECIMAL, undef,10, undef, ], [ "INTEGER", SQL_INTEGER, 10, undef, undef,undef, 1,0,3,undef,0,undef,"LONG", undef,undef,SQL_INTEGER, undef,10, undef, ], [ "SMALLINT", SQL_SMALLINT, 5, undef, undef,undef, 1,0,3,undef,0,undef,"SHORT", undef,undef,SQL_SMALLINT, undef,10, undef, ], [ "FLOAT", SQL_FLOAT, 53, undef, undef,undef, 1,0,3,undef,0,undef,"FLOAT", undef,undef,SQL_FLOAT, undef,2, undef, ], [ "DOUBLE PRECISION", SQL_DOUBLE, 53, undef, undef,undef, 1,0,3,undef,0,undef,"DOUBLE", undef,undef,SQL_DOUBLE, undef,2, undef, ], [ "CHARACTER VARYING", SQL_VARCHAR, 32765, "'", "'", "length", 1,1,3,undef,0,undef,"VARYING", undef,undef,SQL_VARCHAR, undef,undef,undef, ], [ "DATE", SQL_TYPE_DATE, 10, "{d'", "'}", undef, 1,0,3,undef,0,undef,"DATE", undef,undef,SQL_DATE, 1, undef,undef, ], [ "TIME", SQL_TYPE_TIME, 8, "{t'", "'}", undef, 1,0,3,undef,0,undef,"TIME", undef,undef,SQL_DATE, 2, undef,undef, ], [ "TIMESTAMP", SQL_TYPE_TIMESTAMP,24, "{ts'","'}", undef, 1,0,3,undef,0,undef,"TIMESTAMP",undef,undef,SQL_DATE, 3, undef,undef, ], ]; 1; } __END__ DBD-Firebird-1.39/lib/DBD/Firebird/GetInfo.pm0000644000175000017500000004140212600606522016425 0ustar damdam# # Copyright (c) 2002-2005 Edwin Pratomo # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # The %info hash was automatically generated by # DBI::DBD::Metadata::write_getinfo_pm v1.05. package DBD::Firebird::GetInfo; use strict; use warnings; use DBD::Firebird; # Beware: not officially documented interfaces... # use DBI::Const::GetInfoType qw(%GetInfoType); # use DBI::Const::GetInfoReturn qw(%GetInfoReturnTypes %GetInfoReturnValues); my $sql_driver = 'Firebird'; my $sql_ver_fmt = '%02d.%02d.%04d'; # ODBC version string: ##.##.##### my $sql_driver_ver; { no warnings 'uninitialized'; no if $] >= 5.022, warnings => 'missing'; $sql_driver_ver = sprintf $sql_ver_fmt, split (/\./, $DBD::Firebird::VERSION); } # no longer keywords in firebird 2.5 (still listed below): # BASE_NAME CHECK_POINT_LENGTH DEBUG LOG_BUFFER_SIZE MESSAGE NUM_LOG_BUFFERS my @Keywords = qw( ACTIVE ADMIN AFTER ASC ASCENDING AUTO AUTONOMOUS BASE_NAME BEFORE BIN_NOT BLOB CACHE CALLER CHAR_TO_UUID CHECK_POINT_LENGTH COLLATION COMMITTED COMMON COMPUTED CONDITIONAL CONTAINING CSTRING DATA DATABASE DEBUG DELETE DESC DESCENDING DESCRIPTOR DO DOMAIN ENTRY_POINT EXCEPTION EXIT EXTERNAL FILE FILTER FIRSTNAME FREE_IT FUNCTION GDSCODE GENERATOR GEN_ID GRANTED GROUP_COMMIT_WAIT_TIME IF INACTIVE INPUT_TYPE ISOLATION KEY LASTNAME LENGTH LEVEL LOGFILE LOG_BUFFER_SIZE LONG MANUAL MAPPING MAX MAXIMUM_SEGMENT MERGE MESSAGE MIDDLENAME MODULE_NAME NAMES NUM_LOG_BUFFERS OPTION OS_NAME OUTPUT_TYPE OVERFLOW PAGE PAGES PAGE_SIZE PARAMETER PASSWORD PLAN POST_EVENT PRIVILEGES PROTECTED RAW_PARTITIONS RDB$DB_KEY READ RECORD_VERSION RESERV RESERVING RETAIN RETURNING_VALUES RETURNS ROLE SCHEMA SEGMENT SHADOW SHARED SIMILAR SINGULAR SIZE SNAPSHOT SORT SOURCE STABILITY STARTING STARTS STATEMENT STATISTICS SUB_TYPE SUSPEND TRANSACTION TRIGGER TWO_PHASE TYPE UNCOMMITTED UUID_TO_CHAR VARIABLE WAIT WEEKDAY WHILE WORK WRITE YEARDA ); sub sql_keywords { return join ',', @Keywords; } sub sql_data_source_name { my $dbh = shift; return "dbi:$sql_driver:" . $dbh->{Name}; } sub sql_user_name { my $dbh = shift; # CURRENT_USER is a non-standard attribute, probably undef # Username is a standard DBI attribute return $dbh->{CURRENT_USER} || $dbh->{Username}; } our %info = ( 20 => 'Y', # SQL_ACCESSIBLE_PROCEDURES 19 => 'Y', # SQL_ACCESSIBLE_TABLES 0 => 0, # SQL_ACTIVE_CONNECTIONS 116 => 0, # SQL_ACTIVE_ENVIRONMENTS 1 => 0, # SQL_ACTIVE_STATEMENTS 169 => 127, # SQL_AGGREGATE_FUNCTIONS 117 => 0, # SQL_ALTER_DOMAIN 86 => 134763, # SQL_ALTER_TABLE 10021 => 0, # SQL_ASYNC_MODE 120 => 0, # SQL_BATCH_ROW_COUNT 121 => 0, # SQL_BATCH_SUPPORT 82 => 0, # SQL_BOOKMARK_PERSISTENCE 114 => 1, # SQL_CATALOG_LOCATION 10003 => 'N', # SQL_CATALOG_NAME 41 => '', # SQL_CATALOG_NAME_SEPARATOR 42 => '', # SQL_CATALOG_TERM 92 => 0, # SQL_CATALOG_USAGE 10004 => 'ISO 8859-1', # SQL_COLLATING_SEQUENCE 10004 => 'ISO 8859-1', # SQL_COLLATION_SEQ 87 => 'Y', # SQL_COLUMN_ALIAS 22 => 0, # SQL_CONCAT_NULL_BEHAVIOR 53 => 0, # SQL_CONVERT_BIGINT 54 => 0, # SQL_CONVERT_BINARY 55 => 0, # SQL_CONVERT_BIT 56 => 0, # SQL_CONVERT_CHAR 57 => 0, # SQL_CONVERT_DATE 58 => 0, # SQL_CONVERT_DECIMAL 59 => 0, # SQL_CONVERT_DOUBLE 60 => 0, # SQL_CONVERT_FLOAT 48 => 2, # SQL_CONVERT_FUNCTIONS # 173 => undef, # SQL_CONVERT_GUID 61 => 0, # SQL_CONVERT_INTEGER 123 => 0, # SQL_CONVERT_INTERVAL_DAY_TIME 124 => 0, # SQL_CONVERT_INTERVAL_YEAR_MONTH 71 => 0, # SQL_CONVERT_LONGVARBINARY 62 => 0, # SQL_CONVERT_LONGVARCHAR 63 => 0, # SQL_CONVERT_NUMERIC 64 => 0, # SQL_CONVERT_REAL 65 => 0, # SQL_CONVERT_SMALLINT 66 => 0, # SQL_CONVERT_TIME 67 => 0, # SQL_CONVERT_TIMESTAMP 68 => 0, # SQL_CONVERT_TINYINT 69 => 0, # SQL_CONVERT_VARBINARY 70 => 0, # SQL_CONVERT_VARCHAR 122 => 0, # SQL_CONVERT_WCHAR 125 => 0, # SQL_CONVERT_WLONGVARCHAR 126 => 0, # SQL_CONVERT_WVARCHAR 74 => 2, # SQL_CORRELATION_NAME 127 => 0, # SQL_CREATE_ASSERTION 128 => 0, # SQL_CREATE_CHARACTER_SET 129 => 0, # SQL_CREATE_COLLATION 130 => 0, # SQL_CREATE_DOMAIN 131 => 0, # SQL_CREATE_SCHEMA 132 => 4609, # SQL_CREATE_TABLE 133 => 0, # SQL_CREATE_TRANSLATION 134 => 1, # SQL_CREATE_VIEW 23 => 2, # SQL_CURSOR_COMMIT_BEHAVIOR 24 => 2, # SQL_CURSOR_ROLLBACK_BEHAVIOR 10001 => 0, # SQL_CURSOR_SENSITIVITY 16 => '', # SQL_DATABASE_NAME 2 => \&sql_data_source_name, # SQL_DATA_SOURCE_NAME 25 => 'N', # SQL_DATA_SOURCE_READ_ONLY 119 => 7, # SQL_DATETIME_LITERALS 17 => 'Firebird', # SQL_DBMS_NAME 18 => '01.00.0000', # SQL_DBMS_VER 18 => '01.00.0000', # SQL_DBMS_VERSION 170 => 3, # SQL_DDL_INDEX 26 => 2, # SQL_DEFAULT_TRANSACTION_ISOLATION 26 => 2, # SQL_DEFAULT_TXN_ISOLATION 10002 => 'Y', # SQL_DESCRIBE_PARAMETER 171 => '03.52.0002.0002', # SQL_DM_VER 3 => 136450848, # SQL_DRIVER_HDBC # 135 => undef, # SQL_DRIVER_HDESC 4 => 136446256, # SQL_DRIVER_HENV # 76 => undef, # SQL_DRIVER_HLIB # 5 => undef, # SQL_DRIVER_HSTMT 6 => "DBD::Firebird", # SQL_DRIVER_NAME 77 => '03.52', # SQL_DRIVER_ODBC_VER 7 => $sql_driver_ver, # SQL_DRIVER_VER 136 => 0, # SQL_DROP_ASSERTION 137 => 0, # SQL_DROP_CHARACTER_SET 138 => 0, # SQL_DROP_COLLATION 139 => 0, # SQL_DROP_DOMAIN 140 => 0, # SQL_DROP_SCHEMA 141 => 7, # SQL_DROP_TABLE 142 => 0, # SQL_DROP_TRANSLATION 143 => 1, # SQL_DROP_VIEW 144 => 0, # SQL_DYNAMIC_CURSOR_ATTRIBUTES1 145 => 0, # SQL_DYNAMIC_CURSOR_ATTRIBUTES2 27 => 'N', # SQL_EXPRESSIONS_IN_ORDERBY 8 => 1, # SQL_FETCH_DIRECTION 84 => 0, # SQL_FILE_USAGE 146 => 57345, # SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES1 147 => 3, # SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES2 81 => 11, # SQL_GETDATA_EXTENSIONS 88 => 3, # SQL_GROUP_BY 28 => 1, # SQL_IDENTIFIER_CASE 29 => '"', # SQL_IDENTIFIER_QUOTE_CHAR 148 => 3, # SQL_INDEX_KEYWORDS 149 => 0, # SQL_INFO_SCHEMA_VIEWS 172 => 7, # SQL_INSERT_STATEMENT 73 => 'Y', # SQL_INTEGRITY 150 => 0, # SQL_KEYSET_CURSOR_ATTRIBUTES1 151 => 0, # SQL_KEYSET_CURSOR_ATTRIBUTES2 89 => \&sql_keywords, # SQL_KEYWORDS 113 => 'Y', # SQL_LIKE_ESCAPE_CLAUSE 78 => 0, # SQL_LOCK_TYPES 34 => 0, # SQL_MAXIMUM_CATALOG_NAME_LENGTH 97 => 0, # SQL_MAXIMUM_COLUMNS_IN_GROUP_BY 98 => 0, # SQL_MAXIMUM_COLUMNS_IN_INDEX 99 => 0, # SQL_MAXIMUM_COLUMNS_IN_ORDER_BY 100 => 0, # SQL_MAXIMUM_COLUMNS_IN_SELECT 101 => 0, # SQL_MAXIMUM_COLUMNS_IN_TABLE 30 => 32, # SQL_MAXIMUM_COLUMN_NAME_LENGTH 1 => 0, # SQL_MAXIMUM_CONCURRENT_ACTIVITIES 31 => 18, # SQL_MAXIMUM_CURSOR_NAME_LENGTH 0 => 0, # SQL_MAXIMUM_DRIVER_CONNECTIONS 10005 => 32, # SQL_MAXIMUM_IDENTIFIER_LENGTH 102 => 0, # SQL_MAXIMUM_INDEX_SIZE 104 => 0, # SQL_MAXIMUM_ROW_SIZE 32 => 0, # SQL_MAXIMUM_SCHEMA_NAME_LENGTH 105 => 0, # SQL_MAXIMUM_STATEMENT_LENGTH # 20000 => undef, # SQL_MAXIMUM_STMT_OCTETS # 20001 => undef, # SQL_MAXIMUM_STMT_OCTETS_DATA # 20002 => undef, # SQL_MAXIMUM_STMT_OCTETS_SCHEMA 106 => 0, # SQL_MAXIMUM_TABLES_IN_SELECT 35 => 32, # SQL_MAXIMUM_TABLE_NAME_LENGTH 107 => 128, # SQL_MAXIMUM_USER_NAME_LENGTH 10022 => 0, # SQL_MAX_ASYNC_CONCURRENT_STATEMENTS 112 => 0, # SQL_MAX_BINARY_LITERAL_LEN 34 => 0, # SQL_MAX_CATALOG_NAME_LEN 108 => 0, # SQL_MAX_CHAR_LITERAL_LEN 97 => 0, # SQL_MAX_COLUMNS_IN_GROUP_BY 98 => 0, # SQL_MAX_COLUMNS_IN_INDEX 99 => 0, # SQL_MAX_COLUMNS_IN_ORDER_BY 100 => 0, # SQL_MAX_COLUMNS_IN_SELECT 101 => 0, # SQL_MAX_COLUMNS_IN_TABLE 30 => 32, # SQL_MAX_COLUMN_NAME_LEN 1 => 0, # SQL_MAX_CONCURRENT_ACTIVITIES 31 => 18, # SQL_MAX_CURSOR_NAME_LEN 0 => 0, # SQL_MAX_DRIVER_CONNECTIONS 10005 => 32, # SQL_MAX_IDENTIFIER_LEN 102 => 0, # SQL_MAX_INDEX_SIZE 32 => 0, # SQL_MAX_OWNER_NAME_LEN 33 => 32, # SQL_MAX_PROCEDURE_NAME_LEN 34 => 0, # SQL_MAX_QUALIFIER_NAME_LEN 104 => 0, # SQL_MAX_ROW_SIZE 103 => 'N', # SQL_MAX_ROW_SIZE_INCLUDES_LONG 32 => 0, # SQL_MAX_SCHEMA_NAME_LEN 105 => 0, # SQL_MAX_STATEMENT_LEN 106 => 0, # SQL_MAX_TABLES_IN_SELECT 35 => 32, # SQL_MAX_TABLE_NAME_LEN 107 => 128, # SQL_MAX_USER_NAME_LEN 37 => 'N', # SQL_MULTIPLE_ACTIVE_TXN 36 => 'N', # SQL_MULT_RESULT_SETS 111 => 'N', # SQL_NEED_LONG_DATA_LEN 75 => 1, # SQL_NON_NULLABLE_COLUMNS 85 => 0, # SQL_NULL_COLLATION 49 => 0, # SQL_NUMERIC_FUNCTIONS 9 => 2, # SQL_ODBC_API_CONFORMANCE 152 => 3, # SQL_ODBC_INTERFACE_CONFORMANCE 12 => 1, # SQL_ODBC_SAG_CLI_CONFORMANCE 15 => 2, # SQL_ODBC_SQL_CONFORMANCE 73 => 'Y', # SQL_ODBC_SQL_OPT_IEF 10 => '03.52', # SQL_ODBC_VER 115 => 127, # SQL_OJ_CAPABILITIES 90 => 'N', # SQL_ORDER_BY_COLUMNS_IN_SELECT 38 => 'Y', # SQL_OUTER_JOINS 115 => 127, # SQL_OUTER_JOIN_CAPABILITIES 39 => '', # SQL_OWNER_TERM 91 => 0, # SQL_OWNER_USAGE 153 => 2, # SQL_PARAM_ARRAY_ROW_COUNTS 154 => 2, # SQL_PARAM_ARRAY_SELECTS 80 => 7, # SQL_POSITIONED_STATEMENTS 79 => 0, # SQL_POS_OPERATIONS 21 => 'Y', # SQL_PROCEDURES 40 => 'PROCEDURE', # SQL_PROCEDURE_TERM 114 => 1, # SQL_QUALIFIER_LOCATION 41 => '', # SQL_QUALIFIER_NAME_SEPARATOR 42 => '', # SQL_QUALIFIER_TERM 92 => 0, # SQL_QUALIFIER_USAGE 93 => 3, # SQL_QUOTED_IDENTIFIER_CASE 11 => 'N', # SQL_ROW_UPDATES 39 => '', # SQL_SCHEMA_TERM 91 => 0, # SQL_SCHEMA_USAGE 43 => 10, # SQL_SCROLL_CONCURRENCY 44 => 1, # SQL_SCROLL_OPTIONS 14 => '\\', # SQL_SEARCH_PATTERN_ESCAPE 13 => 'FIREBIRD', # SQL_SERVER_NAME 94 => ' $', # SQL_SPECIAL_CHARACTERS 155 => 7, # SQL_SQL92_DATETIME_FUNCTIONS 156 => 15, # SQL_SQL92_FOREIGN_KEY_DELETE_RULE 157 => 15, # SQL_SQL92_FOREIGN_KEY_UPDATE_RULE 158 => 8176, # SQL_SQL92_GRANT 159 => 0, # SQL_SQL92_NUMERIC_VALUE_FUNCTIONS 160 => 16007, # SQL_SQL92_PREDICATES 161 => 984, # SQL_SQL92_RELATIONAL_JOIN_OPERATORS 162 => 32160, # SQL_SQL92_REVOKE 163 => 15, # SQL_SQL92_ROW_VALUE_CONSTRUCTOR 164 => 233, # SQL_SQL92_STRING_FUNCTIONS 165 => 2, # SQL_SQL92_VALUE_EXPRESSIONS 118 => 1, # SQL_SQL_CONFORMANCE 166 => 3, # SQL_STANDARD_CLI_CONFORMANCE 167 => 1, # SQL_STATIC_CURSOR_ATTRIBUTES1 168 => 0, # SQL_STATIC_CURSOR_ATTRIBUTES2 83 => 0, # SQL_STATIC_SENSITIVITY 50 => 0, # SQL_STRING_FUNCTIONS 95 => 31, # SQL_SUBQUERIES 51 => 7, # SQL_SYSTEM_FUNCTIONS 45 => 'TABLE', # SQL_TABLE_TERM 109 => 511, # SQL_TIMEDATE_ADD_INTERVALS 110 => 511, # SQL_TIMEDATE_DIFF_INTERVALS 52 => 0, # SQL_TIMEDATE_FUNCTIONS 46 => 2, # SQL_TRANSACTION_CAPABLE 72 => 14, # SQL_TRANSACTION_ISOLATION_OPTION 46 => 2, # SQL_TXN_CAPABLE 72 => 14, # SQL_TXN_ISOLATION_OPTION 96 => 3, # SQL_UNION 96 => 3, # SQL_UNION_STATEMENT 47 => \&sql_user_name, # SQL_USER_NAME 10000 => 1994, # SQL_XOPEN_CLI_YEAR ); 1; __END__ DBD-Firebird-1.39/MANIFEST0000644000175000017500000000253714743133212013007 0ustar damdamChanges dbdimp.c dbdimp.h eg/pisql firebird.conf Firebird.h Firebird.pm Firebird.xs inc/FirebirdMaker.pm lib/DBD/Firebird/GetInfo.pm lib/DBD/Firebird/TableInfo.pm lib/DBD/Firebird/TableInfo/Basic.pm lib/DBD/Firebird/TableInfo/Firebird21.pm lib/DBD/Firebird/TypeInfo.pm Makefile.PL MANIFEST This list of files README README.md t/00-base.t t/000-check-dependencies.t t/001-client-version.t t/01-connect.t t/02-ib_embedded.t t/03-dbh-attr.t t/20-createdrop.t t/30-insertfetch.t t/31-prepare_cached.t t/40-alltypes.t t/41-bindparam.t t/42-blobs.t t/43-cursor.t t/44-cursoron.t t/45-datetime.t t/46-listfields.t t/47-nulls.t t/48-numeric.t t/49-scale.t t/50-chopblanks.t t/51-commit.t t/60-leaks.t t/61-settx.t t/62-timeout.t t/63-doubles.t t/70-nested-sth.t t/75-utf8.t t/80-event-ithreads.t t/81-event-fork.t t/90-dbinfo.t t/91-txinfo.t t/92-bigdecimal10_read.t t/92-bigdecimal_read.t t/93-bigdecimal.t t/94-biginteger_read.t t/95-biginteger.t t/96-boolean.t t/97-db-triggers.t t/dbi-primary_key_info.t t/dbi-rowcount.t t/dbi-table_info.t t/dbi-tables.t t/rt110979.t t/rt49896.t t/rt54561.t t/rt55244.t t/rt72946.t t/rt76506.t t/TestFirebird.pm t/TestFirebirdEmbedded.pm t/zz-cleanup.t typemap var/.keep_dir META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) DBD-Firebird-1.39/Changes0000644000175000017500000006134714743133210013153 0ustar damdamRevision history for Perl extension DBD::Firebird. 1.39 [2025-01-19] * adapt checks for Firebird headers to Firebird 4.0.5 (gh#54) 1.38 [2024-05-21] * fix syntax error boolean fall back implementation (thanks to Robert Scheck) * add support for disabling database-level triggers (gh#53) 1.37 [2024-05-20] * fall back to sv_setiv when sv_setbool is not available (gh#58) 1.36 [2024-05-19] * fix problems with Perl before 5.36 and Firebird before 3.0 (gh#56 and gh#57) 1.35 [2024-05-15] * ib2sql_type: ignore nullability bit * map Firebird's 64-bit integer type to SQL_BIGINT * add support for Firebird's BOOLEAN data type * fix a couple of compiler warnings 1.34 [2021-12-05] * Fix Firebird paths detection on systems with fb_config available (e.g. Debian/Ubuntu). Fixes RT#140139. Thanks to Slaven Rezić. 1.33 [2021-11-9] * Do not link with Firebird framework if it does not exist on macOS. This should fix issue #51. 1.32 [2020-03-11] * Add support for COMMIT and ROLLBACK statements #48 1.31 [2017-12-05] * Re-release with all tests (some were missing in MANIFEST in 1.30) 1.30 [2017-12-05] * remove artificial hard-coded limit of 1_000_000 bytes when fetching BLOB data 1.29 [2017-12-02] * add /usr/local to the list of possible firebird homes [RT#123723] * blob_type needs to be signed to be assigned/compared to -1 * bpb parameter to isc_open_blob2 is a pointer * drop unused column character set definition 1.28 [2017-12-01] * Update MANIFEST to include newly added tests * add missing items in 1.27 changes * correctly check for Test::CheckDeps presense 1.27 [2017-12-01] * finish: do not check uninitialised status vector If statement type is isc_info_sql_stmt_exec_procedure, isc_dsql_free_statement is not called and there is no point checking the status vector for errors. An error there may be from a previous call, or just plain garbage Fixes https://bugs.debian.org/883183 -- test failure on i386, and http://www.cpantesters.org/cpan/report/e9ebeff4-d095-11e7-bc5d-91f60384196d, and RT#110979 * add 000-check-dependencies.t * Makefile.PL: move test dependencies in TEST_REQUIRES * fix typo in 1.26 Changes * POD: wrap some overly long lines * add support for a 'timeout=$secs' parameter [RT#119764] * bump years of copyright * put fb_api_ver in XS and make it available to both embedded and regular driver * more constants for client version (major/minor/full version string) 1.26 [2017-11-12] * TestFirebirdEmbedded: use a temporary directory for firebird locks and database storage (RT#123623) * fix typo in FirebirdEmbedded * detect Firebird API version even when paths are supplied via environment 1.25 [2017-10-01] * Add tests for values between 0 and ±1 to bigdecimal[_read].t * dbd_st_fetch: fix conversion of numerics between -1 and 0 * add a variant of t/92_bigdecimal_read.t using numeric(18,10) 1.24 [2016-10-11] * Fix 81-event-fork.t to not fail when FirebirdEmbedded is not available [dam] 1.23 [2016-10-10] * Avoid compiler warning about implicit declaration of dbd_st_finish_internal [dam] * Add support for building/testing with Firebird 3 [dam] * Fix a couple of typos, thanks to Nick Morrott of Debian Perl Group [dam] * Explicitly undef the statement handle in dbi-primary-key-info.t, avoiding an error during global destruction [dam] 1.22 [2016-01-30] * require Math::BigFloat 1.55 for the 'try' import keyword [dam] (RT#110977) * add test for RT#110979 [dam] * 40-alltypes.t: replace non-integer numeric comparison with an approximate one [dam] (RT#104699) 1.21 [2015-09-24] * Update README[.md] [mapopa] * Silence 'Missing argument in sprintf' warning on perl 5.22 [ilmari] * Add support for the SAVEPOINT statement [Bram Stappers] (RT#107142) 1.20 [2015-04-27] * Fix loading DBD::Firebird::TypeInfo with strict/warnings [ilmari] * Added installation hint for Fedora, RHEL, CentOS and derivates [robert-scheck] 1.19 [2015-03-22] * Fix $VERSION in Firebird.pm [mapopa] * Fix typo in ISC_PASSWORD spelling [stefbv70] * Positive logic and early return [Tux] * Allow re-executing/fetch on prepared sth [RT#92810, Tux] * Add rests for $dbh->{Name} and others [mjp] * Implement $dbh->{Name} [mjp] * Fix attributions to Mike Pomraning [mjp] * use strict and warnings in all modules [dmn] * add a test for inserting/fetching float and double numbers as an attempt to reproduce RT#101650 [dmn] * fix File::Which configure prerequisite declaration [RT#101672, dmn] * 03-dbh-attr.t: plan tests after creating the TestFirebird object [dmn] * Buffer Overflow in dbdimp.c [stefan.roas] * use snprintf instead of sprintf everywhere [dmn] 1.18 [2014-03-19] * a bit more verbose ok() calls in 90-event-ithreads.t * disable threaded event tests under AUTOMATED_TESTING * Makefile.PL: check for 'ibase.h' presense in potential include dir [Tux] * allow empty (but still defined) DBI_PASS/ISC_PASSWORD for tests [Tux] * add support for FIREBIRD_DATABASE in tests' environment [Tux] * adjust double tests to not fail with -Duselongdouble perl builds [Tux] * fix statement attr returns and rework 40-alltypes.t [Tux] * update installation notes wrt threaded perl and OpenSUSE [Tux] * add missing pointer initialization (RT#92821, Vadim Belov) * dbd_st_finish: ignore "cursor already closed" error when closing the cursor * dbd_st_execute: finish the statement if still active (RT#92810, HMBRAND) 1.16 [2013-12-02] * Implement event objects as blessed scalar refs * include event creation/destruction in 60-leaks.t * Fix for the reference test for softcommit * Update README * Fix comment about setting firebird home * Add markdown version of the README file * Update Makefile.PL removing old platforms * test invalid lock resolution with 'throws_ok' 1.15 [2013-09-09] * Last release for today :) * do not include fb_init/fb_sem in MANIFEST * remove fb_sem on clean * fix casting to ISC_SHORT/ISC_LONG in ib_fill_isqlda 1.14 [2013-09-09] * skip only fork-based tests, and do that when DBD_FIREBIRD_TEST_SKIP_EVENTS_FORK is present in the environment [dam] 1.13 [2013-09-09] * Bring back 5.8 compatibility [ribasushi] * add small delay before triggering events for ib_wait_event (80-events-ithreads.t) [dam] * skip ib_wait_event tests under AUTOMATED_TESTING [dam] 1.12 [2013-08-15] * use fb_config if available for finding firebird directories * drop usage of bytes_from_utf8 when feeding character data to firebird * Produce sensible POD for DBD::FirebirdEmbedded * Make embedded tests actually run when the libs are there (RT#81621) * Do not package MYMETA * Require Test::Exception that does not break caller() 1.11 [2012-09-25] [Details: https://github.com/mariuz/perl-dbd-firebird/commits/release1.11] * Test::Exception is required add to notes * On freebsd Threaded perl is required you have to re-install perl from ports and you have to select the config option that says 'build a perl with threads' * Test database to use UTF8 charset and enable UTF8 for the connection * Fix CHAR lenght when using multi-byte character set Fixes #32 (RT#76506) * additional debug when finishing already finished statement * avoid double destroying of statement in auto-commit mode with DDL Fixes #30 (RT#72946) 1.00 [2012-04-03] [Details: https://github.com/mariuz/perl-dbd-firebird/commits/release1.00] * t/*event*.t: skip if DBD_FIREBIRD_TEST_SKIP_EVENTS is in the environment * preliminary ISQL-like tool using DBD::Firebird * implement the ParamValues statement attribute * avoid unused return value warning when calling DBIh_EVENT2 * support Microsoft's compiler and other win32 fixes * add Cygwin support * add default FB location on OSX to Makefile.PL * test for RT#72946 (->do segfault with active sth) * Merge pull request #29 from rkitover/master * check_and_set_cached_config: fix when test database is in ./ * Makefile.PL: report '(none)' when some of the firebird directories aren't found * Makefile.PL: avoid adding -I"" to compiler command (closes #31) * #74517: Adding support for Visual Studio 2010 (10.0) and VS 11.0 https://rt.cpan.org/Ticket/Display.html?id=74517 0.91 [2011-11-03] [Details: https://github.com/mariuz/perl-dbd-firebird/commits/release0.91] * fix small typo in Firebird.pm POD * avoid using croak(char*) * fix two cases of format strings != arguments on 32-bit OS 0.90 [2011-11-02] [Details: https://github.com/mariuz/perl-dbd-firebird/commits/release0.90] * Always pass cleanup test and just warn on failure. * fix DBP_FILL_INTEGER * Note other authors in the AUTHORS section * drop inc/ from .gitignore * skip vim swap files * ignore *.bs and *.xsi regardless of the directory * move test routines in a package (TestFirebird) * Build-time generated DBD::FirebirdEmbedded + factor-out most of Makefile.PL in inc/FirebirdMaker.pm + enable FirebirdEmbedded only if libfbembed.so is available + really prevent multiple debugs by dbi_arch_dir + compile embedded dbdimp.c with -DEMBEDDED + t/cleanup: keep the test configuration file + create_test_database: cater for host-less databases (e.g. embedded) + rely on the ib_embedded dbh attribute for embedded detection + remove generated embedded tests on realclean + add test for the ib_embedded dbh attribute + print some info about libfbembed availability + support DBD_FIREBIRD_REQUIRE_EMBEDDED env. variable * create_test_database: set test database forced writes off * drop sleeping in ithreads test * drop use_libfbembed usage * diagnostics on database creation/drop * move decoding of status into ib_error_decode * implement DBD::Firebird->create_database * add DPB_FILL_STRING_LEN macro for when we know the length * use the driver instead of isql for creating the test database * implement DBD::Firebird->gfix * generic create_test_database * check_database: rework without ISQL * add ib_drop_database function * tests: rework database dropping without ISQL * rework tests 92 and 94 without ISQL * build/test without ISQL * db_login6: use determined database length * db_login6: fix dbp ingrements for strings and integers * db_login/charset: copy only SV content * rework populating of DPB * db_login6, gfix: abort if DPB length doesn't match projected * mark all copied/mangled files for embedded as such * add $ENV{CFLAGS} to CCFLAGS * fix a format string warning on 32-bit CPUs * Fix comment about MS platform requirement. * avoid using warn(char*) 0.80 [2011-10-03] [Details: https://github.com/mariuz/perl-dbd-firebird/commits/release0.80] * Reimplement bind_param_array without calling bind_param calling bind_param is not necessary as we ignore $attr anyway it also causes problems when the column has non-NULL constraint this makes bind_param_array work again. Fixes RT 54561 * Append $Config{ccflags} to CCFLAGS This makes it possible for binary distributions to rebuild the module if perl's $Config{ccflags} is changed for whatever reason. Without this appending, binary compatibility can't be guaranteed. http://bugs.debian.org/643038 * Fix test skipping in t/75-utf8t and t/dbi-rowcount.t * Add support for 'gnukfreebsd' platform This is the FreeBSD kernel with GNU userland. For our needs, this is identical to 'freebsd' and 'linux'.Closes Debian bug http://bugs.debian.org/643717 * Define is_ascii_string for perls before 5.12.0 RC1 Fixes #23 * Cleanup temp files at the end of tests. * Client only testing using the interactive test setup. Add host parameter to dns. * Simplified condition to test the DB path. 0.70 [2011-09-26] [Details: https://github.com/mariuz/perl-dbd-firebird/commits/release0.70] * docs cleanup + use standard ROWS alternative to Mysql LIMIT + In firebird 2.5.x standard way is to use sequences + dialects cleanup * tests-setup: avoid passing credentials on the command line * link with libfbembed if given a special environment variable * fix missing database check during tests * t/81-event-fork.t when linked with libfbembed * implement add ib_enable_utf8 dynamic attribute * remove $Id$ markers from CVS/Subversion * add test for RT#55244 * 47-nulls.t: ensure inserting undef in a non-null field fails * fix $dbh->do() and $sth->execute() to properly return the number of affected records 0.60 [2011-09-18] [Details: https://github.com/mariuz/perl-dbd-firebird/commits/release0.60] * Drop support for Firebird 1.0 and earlier * Default dialect set to 3 * Fix ping() for Firebird 2.5+ * fix compiler warnings: + use printf formats matching the arguments + use 0 instead of NULL where an integer is expected + allocate XSQLDA as char array + fix conversion of decimal(x,y) to string * use the decoded milliseconds when formatting times (also fixes a warning) * do not link with libdl.so on linux * fix joined lines in reserved words list * add new keywords for Firebird 2.5 (part of #12) * Removed restrictions on distribution * Readme cleanup * Build system: + Major overhaul by Stefan Suciu + prefer fbsql over isql + look also for isql-fb, used by Debian + add /usr as a possible fb_HOME + skip database tests inless DBI_PASS or ISC_PASSWORD is present + Added isql path to values shown by the script + check if found isql-like executale comes from firebird * Tests + prepend default test database path with localhost: + check database path only if local + bigdecimal.t: use strings to avoid conversion to floats 0.55 [2011-06-24] June 24,2011 - mariuz * added osx patches and various Makefile.PL cleanups June 23,2011 - mariuz+stefan * made it to compile with perl 5.14 (old defines cleanup) * alternative Makefile.PL with no questions asked (with default paths) Jan 21, 2011 - mariuz+stefan * make it work with strawberry perl * cleanup , no support for old compiler bcc and sco * no suport for interbase , we use only firebird Mar 26, 2010 - mjp * Fix corrupted representation of high-scale NUMERIC/DECIMAL values (t/scale.t) (RT#55841) Mar 13, 2010 - mjp * DBI compliance/changes - table_info() accepts specifiers - tables() now returns quotes identifiers - primary_key_info() supported * t/31prepare.t adapt test to modern DBI (RT#53671) * t/62timeout.t work around "object in use" failure on Firebird 2.1 (RT#53904) * Interbase.pm respect and document $ENV{ISC_DATABASE} (RT#53997) * .../InterBase/GetInfo.pm shorten SQL_DRIVER_NAME (RT#53674) * Makefile.PL Allow local, remote and aliased db specifications during build (RT#55530) * InterBase.xs, dbdimp.[ch] Switch to perlclib(1) equivalents of memory and string management functions (addresses RT#49896) Jan 08, 2008 - edpratomo * maintenance release: 0.48 * fixed link problem when using perl-5.6.x (undefined PERL_UNUSED_VAR) * prepare_cached() now works. added t/31prepare.t * some code cleanup (compiler warnings suppressed) * t/81event-fork.t now checks signal availability May 20, 2007 - edpratomo * fixed retval from ib_set_tx * removed debug output from ib_tx_info Oct 25, 2006 - edpratomo * added ib_tx_info() * added t/91txinfo.t * added skip check for t/80event-ithreads.t if Perl version older than 5.8.8 * updated MANIFEST Oct 24, 2006 - edpratomo * fixed some croaks in InterBase.xs * safer t/62timeout.t and t/90dbinfo.t Oct 23, 2006 - edpratomo * added support for wait timeout * added -Wall and some warnings fixes * dbkey_scope defaults to 0. configurable. * added active_tran_count and creation_date req items for ib_database_info() * added tests for ib_database_info() and wait timeout Oct 14, 2006 - edpratomo * applied patches from Michael Moehle for 64 bit platform * added backward compatibility * ib_error_check() reworked, with fb_interpret() Sep 12, 2005 - edpratomo * cleaned warnings when compiled with gcc-4.0 Sep 11, 2005 - edpratomo * removed unused event state * renewed dbd_init(); DBIh_EVENT2 call and DBIS were removed. perl -pi.old -e 's/DBI_TRACE\((\d),\s*?\(DBILOGFP, ("[^"]+".*)\)\);/DBI_TRACE_imp_xxh(imp_xyz, $1, (DBIc_LOGPIO(imp_xyz), $2));/' InterBase.xs dbdimp.c followed by manual tweaking * triggers cleanup in t/8[01]event-*.t Sep 10, 2005 - edpratomo * Updates to documentation regarding bugs, faq, and event * fixed $how_many in t/81event-fork.t * GetInfo.pm was regenerated using easysoft's firebird odbc driver, unixodbc, DBI::DBD::Metadata, and DBD::ODBC, of course * TypeInfo.pm was generated as well, and added to MANIFEST * t/40alltypes.t, t/40datetime.t, t/41numeric.t now use find_new_table() Sep 8, 2005 - edpratomo * FAQ was moved into main documentation, maintaining docs at separate places is difficult * FAQ.pm and Bundle were removed from MANIFEST. Bundle is not necessary. Sep 4, 2005 - edpratomo * fixed segfault when destroying event handles in multithreaded app * increased DBI version in Makefile.PL * added t/80event-ithreads.t, t/81-event-fork.t, uses Test::More * updated documentation Aug 31, 2005 - edpratomo * cleaned warnings about unused variables, different signedness * make it compile with old gcc 2.96 * increased required DBI version - 1.41 Aug 30, 2005 - edpratomo * manually applied patch sf #1042790 by freeduke for dbdimp.c to support InterBase 7. typecasting changes are skipped. * major changes to event API * manually applied patch sf #1068671 by dstreifert Aug 8, 2005 - edpratomo * fixed bug sf #1171702 (memory leak when doing TM type timestamp) Jan 14, 2005 - danielritz * better error handling for blobs * 30insertfetch.t, 40blobs.t with more tests * prevent a possible buffer overflow in date handling * don't accept blob bind param for SELECT statement * remove pointless 'ib_cursorname' attribute. DBD does it automatically Nov 26, 2004 - danielritz * add CLONE() method to support threads * update test scripts for newer DBI Mar 3, 2004 - edpratomo * make bind value with blessed scalar work again Feb 25, 2004 - edpratomo * Fixed memory write error in dbd_db_login6() * update doc Dec 6, 2003 - edpratomo * Makefile.PL now works with remote test db * Added $sth->func('ib_plan') * Updated doc * $sth->execute() now returns correct row count values for non-select stmt Nov 19, 2003 - edpratomo * Fixed bug #844954 Nov 16, 2003 - danielritz * Make it work with Firebird 1.5 May 20, 2003 - edpratomo * Fixed problem in ib_init_event() in filling IB_EVENT->names, caused segfault during destruction. * Added skipping reason in t/60leaks.t July 25, 2002 - danielritz * cleanups, speedups July 18, 2002 - edpratomo * fixes by Sergey Skvortsov: - fix INT64 for FreeBSD - fix for ib_role parsing July 18, 2002 - danielritz * %lld as standard format for INT64 July 8, 2002 - danielritz * numeric fixes for negative values like -0.9 July 1, 2002 - danielritz * trace message can be deactivated June ?, 2002 - danielritz * fixes for ib event * more cleanups, IB5 fixes June ?, 2002 - edpratomo * initial support for ib event May ?, 2002 - danielritz * fix EXECUTE PROCEDURE w/o return values * compile fixes for IB5 * rollback can do isc_rollback_retaining * cleanups April 22, 2002 - danielritz * fix EXECUTE PROCEDURE statments data fetching April 5, 2002 - edpratomo * Switching AutoCommit attribute now also affects active softcommit flags. April 4, 2002 - edpratomo, danielritz * Added ib_softcommit attribute, isc_commit_retaining now needs to be enabled explicitly by users. April 4, 2002 - danielritz * Added set_tx_param() with no param which now resets TPB. April 4, 2002 - edpratomo * Updated t/40cursoron.t, t/70nestedon.t to use ib_softcommit * Makefile.PL code indented properly, now load dbd_dbi_arch_dir() only once, now prompts with directory name, `make clean` cleans trace.txt * Updated documentation in InterBase.pm and FAQ.pm * Changed the semantic of -reserving in set_tx_param(), now uses hashref instead of arrayref. * Fixed warnings when compiled with DBI >= 1.20 * Ilya addressed bug #429820 and some bug in sth_ddl. February 14, 2002 - ilyaverlinsky * fix DATE, TIME, TIMESTAP problem February 8, 2002 - ilyaverlinsky * fix sth_ddl not always being reset February 2, 2002 - danielritz * faster blob write code January 30, 2002 - danielritz * updated numeric handing code * fixed blob code January 29, 2002 * Fixed wrong value stored through bind param if numeric(*, 0) * Added t/41numeric.t for exhaustive test on INT64 type. * Updated version number in FAQ (danielritz) * Change acceptable oldest perl version in InterBase.pm January 28, 2002 * Fixed incorrect precision number in INT64 values and now locale-aware. * changed version number in InterBase.pm * Applied a patch to type_info_all by Christian Lademann * Removed trailing precision if INT64 value is an integer. December 2001, by danielritz * no longer start a default transaction on init * set_tx_param in AutoCommit mode commits any changes, starts a new transcation using updated TPB; all open statement handles are closed! * include Pavel Zheltouhov patch for table reservation * only allow to set each param once in set_tx_param * use SvPV_nolen where no len is required in set_tx_param * fix ChopBlanks on Sun Sparc * close all open statment handles on rollback * close all open statements before commit (AutoCommit = 0) * close all open statements before commit if sth_dll > 0 (AutoCommit = 1) * manage statement handles with double linked list * always set imp_dbh->tr = 0L after isc_commit_transcation or isc_rollback_transaction * ib_commit_transaction uses isc_commit_retaining in AutoCommit mode * fix possible buffer overflow in dbd_db_login6 * don't waste some bytes of memory (dbd_db_login6) * fix $dbh->table_info didn't show views correctly * big update in coding style * cleanups November 2001, by danielritz * handle numberic bind params with values such as .7 passed as string * int64 support for microsoft visual c++ * fix: numeric with bind and negative values stored wrong August 1 2001 * fix set_tx_param crashes perl, by danielritz * always rollback open transactions on disconnect (see source), by danielritz July 24 2001 * fix in bind_param for numeric values, by danielritz July 15 2001 * fix repeated execute() in AutoCommit mode, by danielritz July 13 2001 * Fix for compile with ActiveState Build 626+ and BCC, by danielritz * Fix to fetching blob field with zero maximum segment length June 12 2001 * Fixed to buffer overflow in ib_fill_isqlda, by danielritz. * Fixed to problem with DATE and TIMESTAMP fields, by danielritz. June 7 2001 * Added PatchBCC by danielritz * Fixed problem with repeatable use with blob field. May 2 2001 * Fixed memory leak in bind param. April 19 2001 * Fix to dbdimp.h by danielritz. * Nullify var->sqldata and tpb_buffer when cleaning up. April 18 2001 * Now works correctly with negative INT64 values March 24 2001 * Added private method set_tx_param() for controlling transaction parameters (experimental) * More robust execute() * Added more tests * Easier `make test`. Now allows user to specify test database, as well as username, and password to connect. The test database creation is automated, if it doesn't exist. * Clean compile with MSVC. But in Windows, there's bug with BLOB fields. January 22 2001 * Memory leak problem fixed * Added Flemming's submitted patch to zero sqlda before being used. * SQL dialect 1 now can access timestamp field. * Lighter, faster $dbh->ping(). I hope this is more stable, as well. Sept 27 2000 * Replace isc_commit_retaining() with isc_commit_transaction. Flemming suspected this as the source of some deadlock problem. * Fixed dbd_db_rollback(). Now no longer starts a new transaction after rollback. Aug 30 2000 * Patch to DBI.pm of DBI-1.14, fixes a subtle bug of fetchall_arrayref(). The patched DBI allows DBD::InterBase to work with DBIx::Tree 0.91. Cool! * Moving FAQ.pm to InterBase/FAQ.pm Aug 28 2000 * $sth->{NAME} now return column alias, if any. Aug 22 2000 * Fixed _OdbcParse() in InterBase.pm, to connect to remote host incl. Windows. Aug 19 2000 * $sth->rows() now returns the number of fetched rows, for SELECT, otherwise returns - 1 (unknown). Aug 18 2000 * starting a transaction (automatic or not) is more robust, now it reuses an active transaction handle, instead of overridding it with a new one, leaving the previous one "immortal" (because the previous transaction handle is no longer kept!) Aug 16 2000 * Fix $dbh->do() method for usage with placeholders. * Added support for CursorName attrib * more robust commit with AutoCommit on Aug 13 2000 * Added datatype values conversion routine between InterBase internal values and DBI/ISO/ANSI/ODBC values * Fixed tables() method, now correctly removes the trailing blank spaces * Tested to 100% compliant with DBIx::Recordset (0.21)! Aug 12 2000 * more informative error message * fix ping() method. Now not die if RaiseError => 1 July 29 2000 * AutoCommit attribute handling: - in dbd_login6(): simply turns on imp_dbh->init_commit = 1 - in db_STORE_attrib() : if init_commit == 1: if AutoCommit turned On: do nothing. if AutoCommit turned Off: start a new default transaction, stored in imp_dbh->tr if init_commit == 0: if AutoCommit turned On: commit changes. if AutoCommit turned Off: start a new default transaction, stored in imp_dbh->tr Before returning, init_commit is reset to 0. - DBD-Firebird-1.39/Firebird.pm0000644000175000017500000012544614743132570013755 0ustar damdam# # Copyright (c) 2011 Marius Popa # Copyright (c) 2011 Damyan Ivanov # Copyright (c) 1999-2008 Edwin Pratomo # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file require 5.008001; package DBD::Firebird; use strict; use warnings; use Carp; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD); use DBI 1.41 (); require Exporter; require DynaLoader; @ISA = qw(Exporter DynaLoader); $VERSION = '1.39'; bootstrap DBD::Firebird $VERSION; use vars qw($VERSION $err $errstr $drh); $err = 0; $errstr = ""; $drh = undef; sub CLONE { $drh = undef; } sub driver { return $drh if $drh; my($class, $attr) = @_; $class .= "::dr"; $drh = DBI::_new_drh($class, {'Name' => 'Firebird', 'Version' => $VERSION, 'Err' => \$DBD::Firebird::err, 'Errstr' => \$DBD::Firebird::errstr, 'Attribution' => 'DBD::Firebird by Edwin Pratomo and Daniel Ritz'}); $drh; } # taken from JWIED's DBD::mysql, with slight modification sub _OdbcParse($$$) { my($class, $dsn, $hash, $args) = @_; my($var, $val); if (!defined($dsn)) { return; } while (length($dsn)) { if ($dsn =~ /([^;]*)[;]\r?\n?(.*)/s) { $val = $1; $dsn = $2; } else { $val = $dsn; $dsn = ''; } if ($val =~ /([^=]*)=(.*)/) { $var = $1; $val = $2; if ($var eq 'hostname') { $hash->{'host'} = $val; } elsif ($var eq 'db' || $var eq 'dbname') { $hash->{'database'} = $val; } else { $hash->{$var} = $val; } } else { foreach $var (@$args) { if (!defined($hash->{$var})) { $hash->{$var} = $val; last; } } } } $hash->{host} = "$hash->{host}/$hash->{port}" if ($hash->{host} && $hash->{port}); $hash->{database} = "$hash->{host}:$hash->{database}" if $hash->{host}; } sub create_database { my ( $self, $params ) = ( shift, shift ); $self and $params and ref($params) and ref($params) eq 'HASH' and not @_ or croak 'Usage: ' . __PACKAGE__ . '->create_database( { params...} )'; exists $params->{db_path} and defined( $params->{db_path} ) or croak "Required parameter 'db_path' not supplied"; for( qw(db_path user password character_set) ) { next unless exists $params->{$_}; $params->{$_} =~ s/'/''/g if defined($params->{$_}); } DBD::Firebird::db::_create_database($params); } sub gfix { my ( $self, $params ) = ( shift, shift ); $self and $params and ref($params) and ref($params) eq 'HASH' and not @_ or croak 'Usage: ' . __PACKAGE__ . '->gfix( { params...} )'; DBD::Firebird::db::_gfix($params); } package DBD::Firebird::dr; sub connect { my($drh, $dsn, $dbuser, $dbpasswd, $attr) = @_; $dbuser ||= $ENV{ISC_USER}; #"SYSDBA"; $dbpasswd ||= $ENV{ISC_PASSWORD}; #"masterkey"; my ($this, $private_attr_hash); $private_attr_hash = { 'Name' => $dsn, 'user' => $dbuser, 'password' => $dbpasswd }; DBD::Firebird->_OdbcParse($dsn, $private_attr_hash, ['database', 'host', 'port', 'ib_role', 'ib_dbkey_scope', 'ib_charset', 'ib_dialect', 'ib_cache', 'ib_lc_time', 'ib_db_triggers']); $private_attr_hash->{database} ||= $ENV{ISC_DATABASE}; #"employee.fdb" my ($dbh_name) = ($dsn =~ /(db=[^;]+)/); $dbh_name ||= "db=$private_attr_hash->{database}"; my $dbh = DBI::_new_dbh($drh, { Name => $dbh_name }, $private_attr_hash); DBD::Firebird::db::_login($dbh, $dsn, $dbuser, $dbpasswd, $attr) or return undef; $dbh; } package DBD::Firebird::db; use strict; use Carp; sub do { my($dbh, $statement, $attr, @params) = @_; my $rows; if (@params) { my $sth = $dbh->prepare($statement, $attr) or return undef; defined($sth->execute(@params)) or return undef; $rows = $sth->rows; } else { $rows = DBD::Firebird::db::_do($dbh, $statement, $attr); return undef unless defined($rows); } ($rows == 0) ? "0E0" : $rows; } sub prepare { my ($dbh, $statement, $attribs) = @_; my $sth = DBI::_new_sth($dbh, {'Statement' => $statement }); DBD::Firebird::st::_prepare($sth, $statement, $attribs) or return undef; $sth; } sub primary_key_info { my ($dbh, undef, undef, $tbl) = @_; my $sth = $dbh->prepare(<<'__eosql'); SELECT CAST(NULL AS CHAR(1)) AS TABLE_CAT, CAST(NULL AS CHAR(1)) AS TABLE_SCHEM, rc.rdb$relation_name AS TABLE_NAME, ix.rdb$field_name AS COLUMN_NAME, ix.rdb$field_position + 1 AS KEY_SEQ, rc.rdb$index_name AS PK_NAME FROM rdb$relation_constraints rc INNER JOIN rdb$index_segments ix ON rc.rdb$index_name = ix.rdb$index_name WHERE rc.rdb$relation_name = ? AND rc.rdb$constraint_type = 'PRIMARY KEY' ORDER BY 1, 2, 3, 5 __eosql if ($sth) { $sth->{ChopBlanks} = 1; return unless $sth->execute($tbl); } $sth; } sub table_info { my ($self, $cat, $schem, $name, $type, $attr) = @_; require DBD::Firebird::TableInfo; my $ti = ($self->{private_table_info} ||= DBD::Firebird::TableInfo->factory($self)); no warnings 'uninitialized'; if ($cat eq '%' and $schem eq '' and $name eq '') { return $ti->list_catalogs($self); } elsif ($cat eq '' and $schem eq '%' and $name eq '') { return $ti->list_schema($self); } elsif ($cat eq '' and $schem eq '' and $name eq '' and $type eq '%') { return $ti->list_types($self); } else { my %seen; $type = '' if $type eq '%'; # normalize $type specifiers: upcase, strip quote and uniqify my @types = grep { length and not $seen{$_}++ } map { s/'//g; s/^\s+//; s/\s+$//; uc } split(',' => $type); return $ti->list_tables($self, $name, @types); } } sub ping { my($dbh) = @_; local $SIG{__WARN__} = sub { } if $dbh->{PrintError}; local $dbh->{RaiseError} = 0 if $dbh->{RaiseError}; my $ret = DBD::Firebird::db::_ping($dbh); return $ret; } # The get_info function was automatically generated by # DBI::DBD::Metadata::write_getinfo_pm v1.05. sub get_info { my($dbh, $info_type) = @_; require DBD::Firebird::GetInfo; my $v = $DBD::Firebird::GetInfo::info{int($info_type)}; $v = $v->($dbh) if ref $v eq 'CODE'; return $v; } # The type_info_all function was automatically generated by # DBI::DBD::Metadata::write_typeinfo_pm v1.05. sub type_info_all { my ($dbh) = @_; require DBD::Firebird::TypeInfo; return [ @$DBD::Firebird::TypeInfo::type_info_all ]; } 1; package DBD::Firebird::st; # taken from DBI.pm, with this only change: # - remove the call to bind_param without value when $attr is set # * it fails when the column can't contain NULLs # * it is not necessary anyway, as we allocate param placeholder # structures according to Firebird's ananysis of the SQL, not # according to the datatype the supplied in $attr sub bind_param_array { my $sth = shift; my ($p_id, $value_array, $attr) = @_; return $sth->set_err($DBI::stderr, "Value for parameter $p_id must be a scalar or an arrayref, not a ".ref($value_array)) if defined $value_array and ref $value_array and ref $value_array ne 'ARRAY'; return $sth->set_err($DBI::stderr, "Can't use named placeholder '$p_id' for non-driver supported bind_param_array") unless DBI::looks_like_number($p_id); # because we rely on execute(@ary) here return $sth->set_err($DBI::stderr, "Placeholder '$p_id' is out of range") if $p_id <= 0; # can't easily/reliably test for too big # get/create arrayref to hold params my $hash_of_arrays = $sth->{ParamArrays} ||= { }; $$hash_of_arrays{$p_id} = $value_array; 1; } 1; __END__ =head1 NAME DBD::Firebird - DBI driver for Firebird RDBMS server =head1 SYNOPSIS use DBI; $dbh = DBI->connect("dbi:Firebird:db=$dbname", $user, $password); # See the DBI module documentation for full details =head1 DESCRIPTION DBD::Firebird is a Perl module which works with the DBI module to provide access to Firebird databases. =head1 MODULE DOCUMENTATION This documentation describes driver specific behavior and restrictions. It is not supposed to be used as the only reference for the user. In any case consult the DBI documentation first ! =head1 THE DBI CLASS =head2 DBI Class Methods =over 4 =item B To connect to a database with a minimum of parameters, use the following syntax: $dbh = DBI->connect("dbi:Firebird:dbname=$dbname", $user, $password); If omitted, C<$user> defaults to the ISC_USER environment variable (or, failing that, the DBI-standard DBI_USER environment variable). Similarly, C<$password> defaults to ISC_PASSWORD (or DBI_PASS). If C<$dbname> is blank, that is, I<"dbi:Firebird:dbname=">, the environment variable ISC_DATABASE is substituted. The DSN may take several optional parameters, which may be split over multiple lines. Here is an example of connect statement which uses all possible parameters: $dsn =<< "DSN"; dbi:Firebird:dbname=$dbname; host=$host; port=$port; ib_dialect=$dialect; ib_role=$role; ib_charset=$charset; ib_cache=$cache; ib_db_triggers=0; timeout=$timeout DSN $dbh = DBI->connect($dsn, $username, $password); The C<$dsn> is prefixed by 'dbi:Firebird:', and consists of key-value parameters separated by B. New line may be added after the semicolon. The following is the list of valid parameters and their respective meanings: parameter meaning optional? ----------------------------------------------------------------- database path to the database required dbname path to the database db path to the database hostname hostname / IP address optional host hostname / IP address port port number optional timeout connect timeout in seconds optional ib_dialect the SQL dialect to be used optional ib_role the role of the user optional ib_charset character set to be used optional ib_cache number of database cache buffers optional ib_dbkey_scope change default duration of RDB$DB_KEY optional ib_db_triggers enable/disable database-level triggers optional defaults to 1 (enabled) B could be used interchangebly with B and B. To connect to a remote host, use the B parameter. Here is an example of DSN to connect to a remote Windows host: $dsn = "dbi:Firebird:db=C:/temp/test.gdb;host=example.com;ib_dialect=3"; Database file alias can be used too in connection string. In the following example, "billing" is defined in aliases.conf: $dsn = 'dbi:Firebird:hostname=192.168.88.5;db=billing;ib_dialect=3'; Firebird as of version 1.0 listens on port specified within the services file. To connect to port other than the default 3050, add the port number at the end of host name, separated by a slash. Example: $dsn = 'dbi:Firebird:db=/data/test.gdb;host=localhost/3060'; Firebird 1.0 introduces B to provide backward compatibility with databases created by older versions of Firebird (pre 1.0). In short, SQL dialect controls how Firebird interprets: - double quotes - the DATE datatype - decimal and numeric datatypes - new 1.0 reserved keywords Valid values for B are 1 and 3 .The driver's default value is 3 (Currently it is possible to create databases in Dialect 1 and 3 only, however it is recommended that you use Dialect 3 exclusively, since Dialect 1 will eventually be deprecated. Dialect 2 cannot be used to create a database since it only serves to convert Dialect 1 to Dialect 3). http://www.firebirdsql.org/file/documentation/reference_manuals/user_manuals/html/isql-dialects.html B specifies the role of the connecting user. B is implemented by Firebird to make database administration easier when dealing with lots of users. A detailed reading can be found at: http://www.ibphoenix.com/resources/documents/general/doc_59 If B is not specified, the default database's cache size value will be used. The Firebird Operation Guide discusses in full length the importance of this parameter to gain the best performance. =item B @driver_names = DBI->available_drivers; Implemented by DBI, no driver-specific impact. =item B This method is not yet implemented. =item B DBI->trace($trace_level, $trace_file) Implemented by DBI, no driver-specific impact. =back =head2 DBI Dynamic Attributes See Common Methods. =head1 METHODS COMMON TO ALL DBI HANDLES =over 4 =item B $rv = $h->err; Supported by the driver as proposed by DBI. =item B $str = $h->errstr; Supported by the driver as proposed by DBI. =item B This method is not yet implemented. =item B $h->trace($trace_level, $trace_filename); Implemented by DBI, no driver-specific impact. =item B $h->trace_msg($message_text); Implemented by DBI, no driver-specific impact. =item B See B section for information about invoking C from func() method. =back =head1 ATTRIBUTES COMMON TO ALL DBI HANDLES =over 4 =item B (boolean, inherited) Implemented by DBI, no driver-specific impact. =item B (boolean, read-only) Supported by the driver as proposed by DBI. A database handle is active while it is connected and statement handle is active until it is finished. =item B (integer, read-only) Implemented by DBI, no driver-specific impact. =item B (integer, read-only) Implemented by DBI, no driver-specific impact. =item B (hash ref) Implemented by DBI, no driver-specific impact. =item B (boolean, inherited) Not used by this driver. =item B (boolean) Implemented by DBI, no driver-specific impact. =item B (boolean, inherited) Implemented by DBI, no driver-specific impact. =item B (boolean, inherited) Implemented by DBI, no driver-specific impact. =item B (boolean, inherited) Supported by the driver as proposed by DBI. =item B (integer, inherited) Supported by the driver as proposed by DBI.The default value is 80 bytes. =item B (boolean, inherited) Supported by the driver as proposed by DBI. =item B (boolean, inherited) Implemented by DBI, no driver-specific impact. =back =head1 DATABASE HANDLE OBJECTS =head2 Database Handle Methods =over 4 =item B @row_ary = $dbh->selectrow_array($statement, \%attr, @bind_values); Implemented by DBI, no driver-specific impact. =item B $ary_ref = $dbh->selectall_arrayref($statement, \%attr, @bind_values); Implemented by DBI, no driver-specific impact. =item B $ary_ref = $dbh->selectcol_arrayref($statement, \%attr, @bind_values); Implemented by DBI, no driver-specific impact. =item B $sth = $dbh->prepare($statement, \%attr); Supported by the driver as proposed by DBI. When AutoCommit is On, this method implicitly starts a new transaction, which will be automatically committed after the following execute() or the last fetch(), depending on the statement type. For select statements, commit automatically takes place after the last fetch(), or by explicitly calling finish() method if there are any rows remaining. For non-select statements, execute() will implicitly commits the transaction. =item B $sth = $dbh->prepare_cached($statement, \%attr); Implemented by DBI, no driver-specific impact. =item B $rv = $dbh->do($statement, \%attr, @bind_values); Supported by the driver as proposed by DBI. This should be used for non-select statements, where the driver doesn't take the conservative prepare - execute steps, thereby speeding up the execution time. But if this method is used with bind values, the speed advantage diminishes as this method calls prepare() for binding the placeholders. Instead of calling this method repeatedly with bind values, it would be better to call prepare() once, and execute() many times. See the notes for the execute method elsewhere in this document. Unlike the execute method, currently this method doesn't return the number of affected rows. =item B $rc = $dbh->commit; Supported by the driver as proposed by DBI. See also the notes about B elsewhere in this document. =item B $rc = $dbh->rollback; Supported by the driver as proposed by DBI. See also the notes about B elsewhere in this document. =item B $rc = $dbh->disconnect; Supported by the driver as proposed by DBI. =item B $rc = $dbh->ping; This driver supports the ping-method, which can be used to check the validity of a database-handle. This is especially required by C. =item B $sth = $dbh->primary_key_info('', '', $table_name); @pks = $dbh->primary_key('', '', $table_name); Supported by the driver as proposed by DBI. Note that catalog and schema are ignored. =item B $sth = $dbh->table_info; All Firebird versions support the basic DBI-specified columns (TABLE_NAME, TABLE_TYPE, etc.) as well as C. Peculiar versions may return additional fields, prefixed by C. Table searching may not work as expected on older Interbase/Firebird engines which do not natively offer a TRIM() function. Some engines store TABLE_NAME in a blank-padded CHAR field, and a search for table name is performed via a SQL C predicate, which is sensitive to blanks. That is: $dbh->table_info('', '', 'FOO'); # May not find table "FOO", depending on # FB version $dbh->table_info('', '', 'FOO%'); # Will always find "FOO", but also tables # "FOOD", "FOOT", etc. Future versions of DBD::Firebird may attempt to work around this irritating limitation, at the expense of efficiency. Note that Firebird implementations do not presently support the DBI concepts of 'catalog' and 'schema', so these parameters are effectively ignored. =item B @names = $dbh->tables; Returns a list of tables, excluding any 'SYSTEM TABLE' types. =item B $type_info_all = $dbh->type_info_all; Supported by the driver as proposed by DBI. For further details concerning the Firebird specific data-types please read the Firebird Data Definition Guide http://www.firebirdsql.org/en/reference-manuals/ =item B @type_info = $dbh->type_info($data_type); Implemented by DBI, no driver-specific impact. =item B $sql = $dbh->quote($value, $data_type); Implemented by DBI, no driver-specific impact. =back =head2 Database Handle Attributes =over 4 =item B (boolean) Supported by the driver as proposed by DBI. According to the classification of DBI, Firebird is a database, in which a transaction must be explicitly started. Without starting a transaction, every change to the database becomes immediately permanent. The default of AutoCommit is on, which corresponds to the DBI's default. When setting AutoCommit to off, a transaction will be started and every commit or rollback will automatically start a new transaction. For details see the notes about B elsewhere in this document. =item B (handle) Implemented by DBI, no driver-specific impact. =item B (string, read-only) Not yet implemented. =item B (integer) Implemented by DBI, not used by the driver. =item B (driver-specific, boolean) Set this attribute to TRUE to use Firebird's soft commit feature (default to FALSE). Soft commit retains the internal transaction handle when committing a transaction, while the default commit behavior always closes and invalidates the transaction handle. Since the transaction handle is still open, there is no need to start a new transaction upon every commit, so applications can gain performance improvement. Using soft commit is also desirable when dealing with nested statement handles under AutoCommit on. Switching the attribute's value from TRUE to FALSE will force hard commit thus closing the current transaction. =item B (driver-specific, boolean) Setting this attribute to TRUE will cause any Perl Unicode strings supplied as statement parameters to be downgraded to octet sequences before passing them to Firebird. Also, any character data retrieved from the database (CHAR, VARCHAR, BLOB sub_type TEXT) will be upgraded to Perl Unicode strings. B: Currently this is supported only if the B DSN parameter is C. In the future, encoding and decoding to/from arbitrary character set may be implemented. Example: $dbh = DBI->connect( 'dbi:Firebird:db=database.fdb;ib_charset=UTF8', { ib_enable_utf8 => 1 } ); =back =head1 STATEMENT HANDLE OBJECTS =head2 Statement Handle Methods =over 4 =item B Supported by the driver as proposed by DBI. The SQL data type passed as the third argument is ignored. =item B Supported by the driver as proposed by DBI. The attributes, supplied in the optional third parameter are ignored. =item B Not supported by this driver. =item B $rv = $sth->execute(@bind_values); Supported by the driver as proposed by DBI. =item B $ary_ref = $sth->fetchrow_arrayref; Supported by the driver as proposed by DBI. =item B @ary = $sth->fetchrow_array; Supported by the driver as proposed by DBI. =item B $hash_ref = $sth->fetchrow_hashref; Supported by the driver as proposed by DBI. =item B $tbl_ary_ref = $sth->fetchall_arrayref; Implemented by DBI, no driver-specific impact. =item B $rc = $sth->finish; Supported by the driver as proposed by DBI. =item B $rv = $sth->rows; Supported by the driver as proposed by DBI. It returns the number of B rows for select statements, otherwise it returns -1 (unknown number of affected rows). =item B $rc = $sth->bind_col($column_number, \$var_to_bind, \%attr); Supported by the driver as proposed by DBI. =item B $rc = $sth->bind_columns(\%attr, @list_of_refs_to_vars_to_bind); Supported by the driver as proposed by DBI. =item B $rows = $sth->dump_results($maxlen, $lsep, $fsep, $fh); Implemented by DBI, no driver-specific impact. =back =head2 Statement Handle Attributes =over 4 =item B (integer, read-only) Implemented by DBI, no driver-specific impact. =item B (integer, read-only) Implemented by DBI, no driver-specific impact. =item B (array-ref, read-only) Supported by the driver as proposed by DBI. =item B (array-ref, read-only) Implemented by DBI, no driver-specific impact. =item B (array-ref, read-only) Implemented by DBI, no driver-specific impact. =item B (array-ref, read-only) Supported by the driver as proposed by DBI, with the restriction, that the types are Firebird specific data-types which do not correspond to international standards. =item B (array-ref, read-only) Supported by the driver as proposed by DBI. =item B (array-ref, read-only) Supported by the driver as proposed by DBI. =item B (array-ref, read-only) Supported by the driver as proposed by DBI. =item B (string, read-only) Supported by the driver as proposed by DBI. =item B (string, read-only) Supported by the driver as proposed by DBI. =item B (integer, read-only) Not supported by the driver. =item B (hashref, read-only) Supported by the driver as proposed by DBI. =back =head1 TRANSACTION SUPPORT The transaction behavior is controlled with the attribute AutoCommit. For a complete definition of AutoCommit please refer to the DBI documentation. According to the DBI specification the default for AutoCommit is TRUE. In this mode, any change to the database becomes valid immediately. Any commit() or rollback() will be rejected. If AutoCommit is switched-off, immediately a transaction will be started. A rollback() will rollback and close the active transaction, then implicitly start a new transaction. A disconnect will issue a rollback. Firebird provides fine control over transaction behavior, where users can specify the access mode, the isolation level, the lock resolution, and the table reservation (for a specified table). For this purpose, C database handle method is available. Upon a successful C, these default parameter values will be used for every SQL operation: Access mode: read_write Isolation level: snapshot Lock resolution: wait Any of the above value can be changed using C. =over 4 =item B $dbh->func( -access_mode => 'read_write', -isolation_level => 'read_committed', -lock_resolution => 'wait', 'ib_set_tx_param' ); Valid value for C<-access_mode> is C, or C. Valid value for C<-lock_resolution> is C, or C. In Firebird 2.0, a timeout value for wait is introduced. This can be specified using hash ref as lock_resolution value: $dbh->func( -lock_resolution => { wait => 5 }, # wait for 5 seconds 'ib_set_tx_param' ); C<-isolation_level> may be: C, C, C. If C is to be used with C or C, then they should be inside an anonymous array: $dbh->func( -isolation_level => ['read_committed', 'record_version'], 'ib_set_tx_param' ); Table reservation is supported since C. Names of the tables to reserve as well as their reservation params/values are specified inside a hashref, which is then passed as the value of C<-reserving>. The following example reserves C with C lock and C with C lock and C access: $dbh->func( -access_mode => 'read_write', -isolation_level => 'read_committed', -lock_resolution => 'wait', -reserving => { foo_table => { lock => 'read', }, bar_table => { lock => 'read', access => 'protected', }, }, 'ib_set_tx_param' ); Possible table reservation parameters are: =over 4 =item C (optional) Valid values are C or C. =item C (required) Valid values are C or C. =back Under C mode, invoking this method doesn't only change the transaction parameters (as with C off), but also commits the current transaction. The new transaction parameters will be used in any newly started transaction. C can also be invoked with no parameter in which it resets transaction parameters to the default value. =back =head1 DATE, TIME, and TIMESTAMP FORMATTING SUPPORT C supports various formats for query results of DATE, TIME, and TIMESTAMP types. By default, it uses "%c" for TIMESTAMP, "%x" for DATE, and "%X" for TIME, and pass them to ANSI C's strftime() function to format your query results. These values are respectively stored in ib_timestampformat, ib_dateformat, and ib_timeformat attributes, and may be changed in two ways: =over =item * At $dbh level This replaces the default values. Example: $dbh->{ib_timestampformat} = '%m-%d-%Y %H:%M'; $dbh->{ib_dateformat} = '%m-%d-%Y'; $dbh->{ib_timeformat} = '%H:%M'; =item * At $sth level This overrides the default values only for the currently prepared statement. Example: $attr = { ib_timestampformat => '%m-%d-%Y %H:%M', ib_dateformat => '%m-%d-%Y', ib_timeformat => '%H:%M', }; # then, pass it to prepare() method. $sth = $dbh->prepare($sql, $attr); =back Since locale settings affect the result of strftime(), if your application is designed to be portable across different locales, you may consider using these two special formats: 'TM' and 'ISO'. C returns a 9-element list, much like Perl's localtime(). The C format applies sprintf()'s pattern "%04d-%02d-%02d %02d:%02d:%02d.%04d" for TIMESTAMP, "%04d-%02d-%02d" for DATE, and "%02d:%02d:%02d.%04d" for TIME. C<$dbh-E{ib_time_all}> can be used to specify all of the three formats at once. Example: $dbh->{ib_time_all} = 'TM'; =head1 EVENT ALERT SUPPORT Event alerter is used to notify client applications whenever something is happened on the database. For this to work, a trigger should be created, which then calls POST_EVENT to post the event notification to the interested client. A client could behave in two ways: wait for the event synchronously, or register a callback which will be invoked asynchronously each time a posted event received. =over =item C $evh = $dbh->func(@event_names, 'ib_init_event'); Creates an event handle from a list of event names. =item C $dbh->func($evh, 'ib_wait_event'); Wait synchronously for particular events registered via event handle $evh. Returns a hashref containing pair(s) of posted event's name and its corresponding count, or undef on failure. =item C my $cb = sub { my $posted_events = $_[0]; ++$::COUNT < 6 }; $dbh->func($evh, $cb, 'ib_register_callback'); sub inc_count { my $posted_events = shift; ++$::COUNT < 6 }; $dbh->func($evh, \&inc_count, 'ib_register_callback'); # or anonyomus subroutine $dbh->func( $evh, sub { my ($pe) = @_; ++$::COUNT < 6 }, 'ib_register_callback' ); Associates an event handle with an asynchronous callback. A callback will be passed a hashref as its argument, this hashref contains pair(s) of posted event's name and its corresponding count. It is safe to call C multiple times for the same event handle. In this case, the previously registered callback will be automatically cancelled. If the callback returns FALSE, the registered callback will be no longer invoked, but internally it is still there until the event handle goes out of scope (or undef-ed), or you call C to actually disassociate it from the event handle. =item C $dbh->func($evh, 'ib_cancel_callback'); Unregister a callback from an event handle. This function has a limitation, however, that it can't be called from inside a callback. In many cases, you won't need this function, since when an event handle goes out of scope, its associated callback(s) will be automatically cancelled before it is cleaned up. =back =head1 RETRIEVING FIREBIRD / INTERBASE SPECIFIC INFORMATION =over =item C $hash_ref = $dbh->func('ib_tx_info'); Retrieve information about current active transaction. =item C $hash_ref = $dbh->func(@info, 'ib_database_info'); $hash_ref = $dbh->func([@info], 'ib_database_info'); Retrieve database information from current connection. =item C $plan = $sth->func('ib_plan'); Retrieve query plan from a prepared SQL statement. my $sth = $dbh->prepare('SELECT * FROM foo'); print $sth->func('ib_plan'); # PLAN (FOO NATURAL) =item C $result = $dbh->func('ib_drop_database'); Drops the database, associated with the connection. The database handle is no longer valid after calling this function. Caution is advised as the drop is irrevocable. =back =head1 UNSUPPORTED SQL STATEMENTS Here is a list of SQL statements which can't be used. But this shouldn't be a problem, because their functionality are already provided by the DBI methods. =over 4 =item * SET TRANSACTION Use C<$dbh->func(..., 'set_tx_param')> instead. =item * DESCRIBE Provides information about columns that are retrieved by a DSQL statement, or about placeholders in a statement. This functionality is supported by the driver, and transparent for users. Column names are available via $sth->{NAME} attributes. =item * EXECUTE IMMEDIATE Calling do() method without bind value(s) will do the same. =item * CLOSE, OPEN, DECLARE CURSOR $sth->{CursorName} is automagically available upon executing a "SELECT .. FOR UPDATE" statement. A cursor is closed after the last fetch(), or by calling $sth->finish(). =item * PREPARE, EXECUTE, FETCH Similar functionalities are obtained by using prepare(), execute(), and fetch() methods. =back =head1 COMPATIBILITY WITH DBIx::* MODULES C is known to work with C 0.21, and C 0.87. Yuri Vasiliev > reported successful usage with Apache::AuthDBI (part of C 0.87 distribution). The driver is untested with C. Doesn't work with C. C calls $dbh->prepare("LISTFIELDS $table_name") on which Firebird fails to parse. I think that the call should be made within an eval block. =head1 SERVICE METHODS =head2 DBD::Firebird->create_database( { params... } ) A class method for creating empty databases. The method croaks on error. Params may be: =over =item db_path (string, required) Path to database, including host name if necessary. Examples: =over =item server:/path/to/db.fdb =item /srv/db/base.fdb =back =item user (string, optional) User name to be used for the request. =item password (string, optional) Password to be used for the request. =item page_size (integer, optional) Page size of the newly created database. Should be something supported by the server. Firebird 2.5 supports the following page sizes: 1024, 2048, 4096, 8192 and 16384 and defaults to 4096. =item character_set (string, optional) The default character set of the database. Firebird 2.5 defaults to C. =item dialect (integer, optional) The dialect of the database. Defaults to 3. =back After creation, the new database can be used after connecting to it with the usual DBI->connect(...) =head2 DBD::Firebird->gfix( { params } ) A class method for simulating a subset of the functionality of the Firebird's L utility. Params is a hash reference, with the following keys: =over =item db_path (string, required) The path to the database to connect to. Should include host name if necessary. =item user (string, optional) User name to connect as. Must be SYSDBA or database owner. =item password (string, optional) Password to be used for the connection. Note that user and password are not needed for embedded connections. =item forced_writes (boolean, optional) If given, sets the forced writes flag of the database, causing Firebird to use synchronous writes when working with that database. =item buffers (integer, optional) If given, sets the default number of buffers for the database. Can be overridden on connect time. Note that buffers are measured in database pages, not bytes. =back =head1 FAQ =head2 Why do some operations performing positioned update and delete fail when AutoCommit is on? For example, the following code snippet fails: $sth = $dbh->prepare( "SELECT * FROM ORDERS WHERE user_id < 5 FOR UPDATE OF comment"); $sth->execute; while (@res = $sth->fetchrow_array) { $dbh->do("UPDATE ORDERS SET comment = 'Wonderful' WHERE CURRENT OF $sth->{CursorName}"); } When B, a transaction is started within prepare(), and committed automatically after the last fetch(), or within finish(). Within do(), a transaction is started right before the statement is executed, and gets committed right after the statement is executed. The transaction handle is stored within the database handle. The driver is smart enough not to override an active transaction handle with a new one. So, if you notice the snippet above, after the first fetchrow_array(), the do() is still using the same transaction context, but as soon as it has finished executing the statement, it B the transaction, whereas the next fetchrow_array() still needs the transaction context! So the secret to make this work is B. This can be done in two ways: =over 4 =item * Using AutoCommit = 0 If yours is default to AutoCommit on, you can put the snippet within a block: { $dbh->{AutoCommit} = 0; # same actions like above .... $dbh->commit; } =item * Using $dbh->{ib_softcommit} = 1 This is a driver-specific attribute,You may want to look at t/70-nested-sth.t to see it in action. =back =head2 Why do nested statement handles break under AutoCommit mode? The same explanation as above applies. The workaround is also much alike: { $dbh->{AutoCommit} = 0; $sth1 = $dbh->prepare("SELECT * FROM $table"); $sth2 = $dbh->prepare("SELECT * FROM $table WHERE id = ?"); $sth1->execute; while ($row = $sth1->fetchrow_arrayref) { $sth2->execute($row->[0]); $res = $sth2->fetchall_arrayref; } $dbh->commit; } You may also use $dbh->{ib_softcommit} please check t/70nested-sth.t for an example on how to use it. =head2 Why do placeholders fail to bind, generating unknown datatype error message? You can't bind a field name. The following example will fail: $sth = $dbh->prepare("SELECT (?) FROM $table"); $sth->execute('user_id'); There are cases where placeholders can't be used in conjunction with COLLATE clause, such as this: SELECT * FROM $table WHERE UPPER(author) LIKE UPPER(? COLLATE FR_CA); This deals with the Firebird's SQL parser, not with C. The driver just passes SQL statements through the engine. =head2 How to do automatic increment for a specific field? Create a sequence and a trigger to associate it with the field. The following example creates a sequence named PROD_ID_SEQ, and a trigger for table ORDERS which uses the generator to perform auto increment on field PRODUCE_ID with increment size of 1. $dbh->do("create sequence PROD_ID_SEQ"); $dbh->do( "CREATE TRIGGER INC_PROD_ID FOR ORDERS BEFORE INSERT POSITION 0 AS BEGIN NEW.PRODUCE_ID = NEXT VALUE FOR PROD_ID_SEQ; END"); From Firebird 3.0 there is Identity support =head2 How can I perform LIMIT clause as I usually do in MySQL? C clause let users to fetch only a portion rather than the whole records as the result of a query. This is particularly efficient and useful for paging feature on web pages, where users can navigate back and forth between pages. Using Firebird 2.5.x this can be implemented by using C . http://www.firebirdsql.org/refdocs/langrefupd21-select.html#langrefupd21-select-rows For example, to display a portion of table employee within your application: # fetch record 1 - 5: $res = $dbh->selectall_arrayref("SELECT * FROM employee rows 1 to 5)"); # fetch record 6 - 10: $res = $dbh->selectall_arrayref("SELECT * FROM employee rows 6 to 10)"); =head2 How can I use the date/time formatting attributes? Those attributes take the same format as the C function strftime()'s. Examples: $attr = { ib_timestampformat => '%m-%d-%Y %H:%M', ib_dateformat => '%m-%d-%Y', ib_timeformat => '%H:%M', }; Then, pass it to prepare() method. $sth = $dbh->prepare($stmt, $attr); # followed by execute() and fetch(), or: $res = $dbh->selectall_arrayref($stmt, $attr); =head2 Can I set the date/time formatting attributes between prepare and fetch? No. C, C, and C can only be set during $sth->prepare. If this is a problem to you, let me know, and probably I'll add this capability for the next release. =head2 Can I change ib_dialect after DBI->connect ? No. If this is a problem to you, let me know, and probably I'll add this capability for the next release. =head1 OBSOLETE FEATURES =over =item Private Method C is obsoleted by C. =back =head1 TESTED PLATFORMS =head2 Clients =over 4 =item Linux =item FreeBSD =item Solaris =item Win32 =back =head2 Servers =over 4 =item Firebird 2.5.x SS , SC and Classic for Linux (32 bits and 64) =item Firebird 2.5.x for Windows, FreeBSD, Solaris =back =head1 AUTHORS =over 4 =item * DBI by Tim Bunce =item * DBD::Firebird by Edwin Pratomo , Daniel Ritz and many others. See L. This module is originally based on the work of Bill Karwin's IBPerl. =back =head1 BUGS/LIMITATIONS Please report bugs and feature suggestions using http://rt.cpan.org/Public/Dist/Display.html?Name=DBD-Firebird . This module doesn't work with MSWin32 ActivePerl iThreads, and its emulated fork. Tested with MSWin32 ActivePerl build 809 (Perl 5.8.3). The whole process will block in unpredictable manner. Under Linux, this module has been tested with several different iThreads enabled Perl releases. No problem occurred so far.. until you try to share a DBI handle ;-) But if you plan to use thread, you'd better use the latest stable version of Perl On FreeBSD you need a Perl compiled with thread support. Limitations: =over 4 =item * Arrays are not (yet) supported =item * Read/Write BLOB fields block by block not (yet) supported. The maximum size of a BLOB read/write is hardcoded to about 1 MB. =item * service manager API is not supported. =back =head1 SEE ALSO DBI(3). =head1 COPYRIGHT & LICENSE =over =item Copyright (c) 2010- 2012 Popa Adrian Marius =item Copyright (c) 2011- 2012 Stefan Suciu =item Copyright (c) 2011-2015, 2017, 2024, 2025 Damyan Ivanov =item Copyright (c) 2011 Alexandr Ciornii =item Copyright (c) 2010, 2011 Mike Pomraning =item Copyright (c) 1999-2008 Edwin Pratomo =item Portions Copyright (c) 2001-2005 Daniel Ritz =back The DBD::Firebird module is free software. You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. =head1 ACKNOWLEDGEMENTS An attempt to enumerate all who have contributed patches (may misses some): Michael Moehle, Igor Klingen, Sergey Skvortsov, Ilya Verlinsky, Pavel Zheltouhov, Peter Wilkinson, Mark D. Anderson, Michael Samanov, Michael Arnett, Flemming Frandsen, Mike Shoyher, Christiaan Lademann. =cut DBD-Firebird-1.39/firebird.conf0000644000175000017500000000002212203070373014273 0ustar damdamRootDirectory=var DBD-Firebird-1.39/dbdimp.h0000644000175000017500000002503414743132361013267 0ustar damdam/* Copyright (c) 2011 Marius Popa Copyright (c) 2010 Mike Pomraning Copyright (c) 1999-2008 Edwin Pratomo Portions Copyright (c) 2001-2005 Daniel Ritz Copyright (c) 2025 Damyan Ivanov You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. */ #include /* installed by the DBI module */ /* make it compile with DBI < 1.20 */ #ifndef SQL_TYPE_DATE # define SQL_TYPE_DATE 91 #endif #ifndef SQL_TYPE_TIME # define SQL_TYPE_TIME 92 #endif #ifndef SQL_BLOB # define SQL_BLOB 30 #endif #ifndef SQL_ARRAY # define SQL_ARRAY 50 #endif static const int DBI_SQL_CHAR = SQL_CHAR; static const int DBI_SQL_NUMERIC = SQL_NUMERIC; static const int DBI_SQL_DECIMAL = SQL_DECIMAL; static const int DBI_SQL_INTEGER = SQL_INTEGER; static const int DBI_SQL_SMALLINT = SQL_SMALLINT; static const int DBI_SQL_BIGINT = SQL_BIGINT; static const int DBI_SQL_FLOAT = SQL_FLOAT; static const int DBI_SQL_REAL = SQL_REAL; static const int DBI_SQL_DOUBLE = SQL_DOUBLE; static const int DBI_SQL_DATE = SQL_DATE; static const int DBI_SQL_TIME = SQL_TIME; static const int DBI_SQL_TIMESTAMP = SQL_TIMESTAMP; static const int DBI_SQL_VARCHAR = SQL_VARCHAR; static const int DBI_SQL_TYPE_TIME = SQL_TYPE_TIME; static const int DBI_SQL_TYPE_DATE = SQL_TYPE_DATE; static const int DBI_SQL_ARRAY = SQL_ARRAY; static const int DBI_SQL_BLOB = SQL_BLOB; static const int DBI_SQL_BOOLEAN = SQL_BOOLEAN; /* conflicts */ #undef SQL_CHAR #undef SQL_NUMERIC #undef SQL_DECIMAL #undef SQL_INTEGER #undef SQL_SMALLINT #undef SQL_BIGINT #undef SQL_FLOAT #undef SQL_REAL #undef SQL_DOUBLE #undef SQL_DATE #undef SQL_TIME #undef SQL_TIMESTAMP #undef SQL_VARCHAR #undef SQL_TYPE_TIME #undef SQL_TYPE_DATE #undef SQL_ARRAY #undef SQL_BLOB #undef SQL_BOOLEAN #ifdef __CYGWIN__ #define _WIN32 #define __stdcall __attribute__((stdcall)) #define __cdecl __attribute__((cdecl)) #include #undef _WIN32 #else #include #endif #include /* defines */ /* Firebird API 20 */ #if !defined(FB_API_VER) || FB_API_VER < 20 typedef void (*ISC_EVENT_CALLBACK)(); #endif #ifndef SQLDA_CURRENT_VERSION # define SQLDA_OK_VERSION SQLDA_VERSION1 #else # define SQLDA_OK_VERSION SQLDA_CURRENT_VERSION #endif #define IB_ALLOC_FAIL 2 #define IB_FETCH_ERROR 1 #ifndef ISC_STATUS_LENGTH # define ISC_STATUS_LENGTH 20 #endif #ifndef SvPV_nolen # define SvPV_nolen(sv) SvPV(sv, na) #endif #define FREE_SETNULL(ptr) \ do { \ if (ptr) \ { \ Safefree(ptr); \ ptr = NULL; \ } \ } while (0) #define DPB_FILL_BYTE(dpb, code, byte) \ do { \ *dpb++ = code; \ *dpb++ = 1; \ *dpb++ = byte; \ } while (0) #define DPB_FILL_INTEGER(dpb, code, integer) \ do { \ ISC_LONG tmp = integer; \ *dpb++ = code; \ *dpb++ = sizeof(tmp); \ tmp = isc_vax_integer((char *) &tmp, sizeof(tmp)); \ Copy(&tmp, dpb, 1, ISC_LONG); \ dpb += sizeof(tmp); \ } while (0) #define DPB_FILL_STRING(dpb, code, string) \ DPB_FILL_STRING_LEN(dpb, code, string, strlen(string) ) #define DPB_FILL_STRING_LEN(dpb, code, string, len) \ do { \ if ( len > 255 ) \ croak("DPB string too long (%ld)", (size_t) len); \ *dpb++ = code; \ *dpb++ = len; \ strncpy(dpb, string, (size_t) len); \ dpb += len; \ } while (0) #define DPB_PREP_BYTE(buflen) \ do { \ /* code, length, data */ \ buflen += 3; \ } while (0) #define DPB_PREP_INTEGER(buflen) \ do { \ buflen += sizeof(ISC_LONG) + 2; \ } while (0) #define DPB_PREP_STRING(buflen, string) \ DPB_PREP_STRING_LEN(buflen, strlen(string)) #define DPB_PREP_STRING_LEN(buflen, len) \ do { \ buflen += len + 2; \ } while (0) # define TIMESTAMP_FPSECS(value) \ (long)(((ISC_TIMESTAMP *)value)->timestamp_time % ISC_TIME_SECONDS_PRECISION) # define TIMESTAMP_ADD_FPSECS(value, inc) \ ((ISC_TIMESTAMP *)value)->timestamp_time += (inc % ISC_TIME_SECONDS_PRECISION) # define TIME_FPSECS(value) \ (long)((*(ISC_TIME *)value) % ISC_TIME_SECONDS_PRECISION) # define TIME_ADD_FPSECS(value, inc) \ (*(ISC_TIME *)value) += (inc % ISC_TIME_SECONDS_PRECISION) #ifndef NO_TRACE_MSGS # define DBI_TRACE(level, args) \ do { \ if (DBIS->debug >= level) \ PerlIO_printf args ; \ } while (0) # define DBI_TRACE_imp_xxh(imp_xxh, level, args) \ do { \ if (DBIc_TRACE_LEVEL(imp_xxh) >= level) \ PerlIO_printf args; \ } while (0) #else # define DBI_TRACE(level, args) do {} while (0) # define DBI_TRACE_imp_xxh(imp_xxh, level, args) do {} while (0) #endif #define BLOB_SEGMENT (256) #define DEFAULT_SQL_DIALECT (3) #define INPUT_XSQLDA (1) #define OUTPUT_XSQLDA (0) #define PLAN_BUFFER_LEN 2048 #define SUCCESS (0) #define FAILURE (-1) /* * Hardcoded limit on the length of a Blob that can be fetched into a scalar. * If you want to fetch Blobs that are bigger, write your own Perl */ #define MAX_EVENTS 15 typedef enum { ACTIVE, INACTIVE } IB_EVENT_STATE; /****************/ /* data types */ /****************/ /* structs for event */ typedef struct { imp_dbh_t *dbh; /* pointer to parent dbh */ ISC_LONG id; /* event id assigned by IB */ #if defined(INCLUDE_TYPES_PUB_H) || defined(FIREBIRD_IMPL_TYPES_PUB_H) ISC_UCHAR *event_buffer; ISC_UCHAR *result_buffer; #else char ISC_FAR *event_buffer; char ISC_FAR *result_buffer; #endif char ISC_FAR * ISC_FAR *names; /* names of events of interest */ unsigned short num; /* number of events of interest */ short epb_length; /* length of event parameter buffer */ SV *perl_cb; /* perl callback for this event */ IB_EVENT_STATE state; char exec_cb; } IB_EVENT; /* Define driver handle data structure */ struct imp_drh_st { dbih_drc_t com; /* MUST be first element in structure */ }; /* Define dbh implementor data structure */ struct imp_dbh_st { dbih_dbc_t com; /* MUST be first element in structure */ isc_db_handle db; isc_tr_handle tr; char ISC_FAR *tpb_buffer; /* transaction parameter buffer */ unsigned short tpb_length; /* length of tpb_buffer */ unsigned short sqldialect; /* default sql dialect */ char soft_commit; /* use soft commit ? */ char *ib_charset; bool ib_enable_utf8; unsigned int sth_ddl; /* number of open DDL statments */ imp_sth_t *first_sth; /* pointer to first statement */ imp_sth_t *last_sth; /* pointer to last statement */ #if defined(USE_THREADS) || defined(USE_ITHREADS) || defined(MULTIPLICITY) void *context; /* perl context for threads / multiplicity */ #endif /* per dbh default strftime() formats */ char *dateformat; char *timestampformat; char *timeformat; unsigned char *charset_bytes_per_char; }; /* Define sth implementor data structure */ struct imp_sth_st { dbih_stc_t com; /* MUST be first element in structure */ isc_stmt_handle stmt; XSQLDA *out_sqlda; /* for storing select-list items */ XSQLDA *in_sqlda; /* for storing placeholder values */ char *cursor_name; long type; /* statement type */ char count_item; int affected; /* number of affected rows */ char *dateformat; char *timestampformat; char *timeformat; imp_sth_t *prev_sth; /* pointer to prev statement */ imp_sth_t *next_sth; /* pointer to next statement */ HV *param_values; /* For storing the ParamValues attribute */ }; /* newer header file defines the struct already */ typedef struct dbd_vary { short vary_length; char vary_string [1]; } DBD_VARY; /* These defines avoid name clashes for multiple statically linked DBD's */ #define dbd_init ib_init #define dbd_discon_all ib_discon_all #define dbd_db_login ib_db_login #define dbd_db_login6 ib_db_login6 #define dbd_db_do ib_db_do #define dbd_db_commit ib_db_commit #define dbd_db_rollback ib_db_rollback #define dbd_db_disconnect ib_db_disconnect #define dbd_db_destroy ib_db_destroy #define dbd_db_STORE_attrib ib_db_STORE_attrib #define dbd_db_FETCH_attrib ib_db_FETCH_attrib #define dbd_st_prepare ib_st_prepare #define dbd_st_rows ib_st_rows #define dbd_st_execute ib_st_execute #define dbd_st_fetch ib_st_fetch #define dbd_st_finish ib_st_finish #define dbd_st_destroy ib_st_destroy #define dbd_st_blob_read ib_st_blob_read #define dbd_st_STORE_attrib ib_st_STORE_attrib #define dbd_st_FETCH_attrib ib_st_FETCH_attrib #define dbd_bind_ph ib_bind_ph void do_error _((SV *h, int rc, char *what)); void dbd_init _((dbistate_t *dbistate)); void dbd_preparse _((SV *sth, imp_sth_t *imp_sth, char *statement)); int dbd_describe _((SV *sth, imp_sth_t *imp_sth)); int dbd_db_ping (SV *dbh); char* ib_error_decode(const ISC_STATUS *status); int ib_error_check(SV *h, ISC_STATUS *status); int ib_start_transaction (SV *h, imp_dbh_t *imp_dbh); int ib_commit_transaction (SV *h, imp_dbh_t *imp_dbh); int ib_rollback_transaction(SV *h, imp_dbh_t *imp_dbh); long ib_rows(SV *xxh, isc_stmt_handle *h_stmt, char count_type); void ib_cleanup_st_prepare (imp_sth_t *imp_sth); SV* dbd_db_quote(SV* dbh, SV* str, SV* type); /* end */ DBD-Firebird-1.39/eg/0000755000175000017500000000000014743133212012242 5ustar damdamDBD-Firebird-1.39/eg/pisql0000755000175000017500000000262211663362200013321 0ustar damdam#!/usr/bin/perl use warnings; use strict; use DBD::FirebirdEmbedded; my $dbh; while (1) { print "> "; my $in = <>; last unless defined($in); next if $in =~ /^\s*--/; if ( $in =~ /^\s*create\s*database\s*'([^']+)'\s*$/ ) { my $db_path = $1; DBD::FirebirdEmbedded->create_database({db_path => $1}); $dbh = DBI->connect( "dbi:FirebirdEmbedded:db=$1", undef, undef, { AutoCommit => 0 } ); } elsif ( $in =~ /^\s*connect '([^']+)'\s*$/ ) { $dbh = DBI->connect( "dbi:FirebirdEmbedded:db=$1", undef, undef, { AutoCommit => 0 } ); } elsif ( $in =~ /^\s*exit\s*/i ) { $dbh->commit if $dbh; last; } elsif ( $in =~ /^\s*quit\s*/i ) { $dbh->rollback if $dbh; last; } else { if ($dbh) { my $sth = $dbh->prepare_cached($in); $sth->execute(); if ( $sth->{NUM_OF_FIELDS} > 0 ) { print join( "\t", @{ $sth->{NAME} } ), "\n"; while ( my $row = $sth->fetchrow_arrayref ) { print join( "\t", map( defined($_) ? $_ : 'NULL', @$row ) ), "\n"; } $sth->finish; } } else { warn "E: Not connected to a database.\n"; } } } if ($dbh) { $dbh->rollback; $dbh->disconnect; } DBD-Firebird-1.39/README.md0000644000175000017500000000423614622372704013142 0ustar damdamDBD::Firebird version 1.32 ========================== DBI driver for the Firebird RDBMS server. - Copyright © 2015 Stefan Roas - Copyright © 2014 H.Merijn Brand - Tux - Copyright © 2010-2020 Popa Adrian Marius - Copyright © 2011-2013 Stefan Suciu - Copyright © 2011-2015, 2024 Damyan Ivanov - Copyright © 2011 Alexandr Ciornii - Copyright © 2010-2014 Mike Pomraning - Copyright © 1999-2005 Edwin Pratomo - Portions Copyright © 2001-2005 Daniel Ritz License ------- You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. (https://dev.perl.org/licenses/artistic.html) Installation ------------ Requirements: - Perl (Threaded and version 5.8.1 or higher) - Perl DBI (1.41 or higher) - Firebird (2.5.1 or higher) - A C compiler * UN*X GCC or Clang * Windows - Strawberry perl (https://strawberryperl.com/) comes with it's own compiler (mingw) - Visual Studio C++ (https://visualstudio.com) - Cygwin * Freebsd - Threaded Perl is required (You have to re-install Perl from ports and you have to select the config option that says 'build a Perl with threads') *BEFORE* BUILDING, TESTING AND INSTALLING this you will need to: - Build, test and install Perl 5 (at least 5.8.1). - Build, test and install the DBI module (at least DBI 1.41). On Debian/Ubuntu you can do a simple: sudo apt-get install firebird2.5-dev libdbi-perl - Remember to *read* the DBI README file if you installed it from source - Make sure that Firebird server is running (for testing telnet localhost 3050) BUILDING: Win32/Win64 with Strawberry type 'dmake' from the console Win32/Win64 with MS compiler: type 'nmake', not just 'make' To Configure and build the DBD: perl Makefile.PL make TESTING To run tests module Test::Exception is required on Debian/Ubuntu systems: sudo apt-get install libtest-exception-perl Please, set at least DBI_PASS (or ISC_PASSWORD), before 'make test'. The default for DBI_USER is 'SYSDBA'.(masterkey password is given here as example only) ISC_PASSWORD=masterkey make test INSTALLING: make install DBD-Firebird-1.39/README0000644000175000017500000000470314743132506012540 0ustar damdamDBD::Firebird -- DBI driver for Firebird RDBMS server. Copyright (c) 2010-2015 Popa Adrian Marius Copyright (c) 2011-2013 Stefan Suciu Copyright (c) 2011-2015, 2017, 2024, 2025 Damyan Ivanov Copyright (c) 2011 Alexandr Ciornii Copyright (c) 2010-2011 Mike Pomraning Copyright (c) 1999-2005 Edwin Pratomo Portions Copyright (c) 2001-2005 Daniel Ritz You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. (http://dev.perl.org/licenses/artistic.html) REQUIREMENTS: - Perl (version 5.8.1 or higher) - Perl DBI (1.41 or higher) - Firebird (2.5.1 or higher) - A C compiler * UN*X GCC 4.x (tested, older may or may not work) or other capable clang * Windows - Strawberry perl (http://strawberryperl.com/) comes with it's own compiler (mingw) - Visual Studio C++ (http://visualstudio.com) - Cygwin * Freebsd - Threaded perl is required (You have to re-install perl from ports and you have to select the config option that says 'build a perl with threads') *BEFORE* BUILDING, TESTING AND INSTALLING this you will need to: - Build, test and install Perl 5 (at least 5.8.1). - Build, test and install the DBI module (at least DBI 1.41). On Debian/Ubuntu you can do a simple: sudo apt-get install firebird2.5-dev libdbi-perl On OpenSUSE: sudo zypper in firebird firebird-devel perl-DBI On Fedora, Red Hat Enterprise Linux, CentOS and derivates: sudo yum install firebird firebird-devel perl-DBI - Remember to *read* the DBI README file if you installed it from source - Make sure that Firebird server is running (for testing telnet localhost 3050) sudo service firebird start BUILDING: Win32/Win64 with Strawberry type 'dmake' from the console Win32/Win64 with MS compiler: type 'nmake', not just 'make' To Configure and build the DBD: perl Makefile.PL make TESTING To run tests module Test::Exception is required on Debian/Ubuntu systems: sudo apt-get install libtest-exception-perl Please, set at least DBI_PASS (or ISC_PASSWORD), before 'make test'. The default for DBI_USER is 'SYSDBA'.(masterkey password is given here as example only) ISC_PASSWORD=masterkey make test INSTALLING: make install DBD-Firebird-1.39/typemap0000644000175000017500000000054711627236035013264 0ustar damdamTYPEMAP IB_EVENT * O_OBJECT OUTPUT O_OBJECT sv_setref_pv( $arg, CLASS, (void*)$var ); INPUT O_OBJECT if( sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG) ) $var = ($type)SvIV((SV*)SvRV( $arg )); else{ warn( \"${Package}::$func_name() -- $var is not a blessed SV reference\" ); XSRETURN_UNDEF; } DBD-Firebird-1.39/Firebird.h0000644000175000017500000000324111646331225013551 0ustar damdam/* Copyright (c) 1999,2000 Edwin Pratomo You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. */ #define NEED_DBIXS_VERSION 7 #include "dbdimp.h" #include void dbd_init _((dbistate_t *dbistate)); int dbd_db_login _((SV *dbh, imp_dbh_t *imp_dbh, char *dbname, char *uid, char *pwd)); int dbd_db_do _((SV *sv, char *statement)); int dbd_db_commit _((SV *dbh, imp_dbh_t *imp_dbh)); int dbd_db_rollback _((SV *dbh, imp_dbh_t *imp_dbh)); int dbd_db_disconnect _((SV *dbh, imp_dbh_t *imp_dbh)); void dbd_db_destroy _((SV *dbh, imp_dbh_t *imp_dbh)); int dbd_db_STORE_attrib _((SV *dbh, imp_dbh_t *imp_dbh, SV *keysv, SV *valuesv)); SV *dbd_db_FETCH_attrib _((SV *dbh, imp_dbh_t *imp_dbh, SV *keysv)); int dbd_st_prepare _((SV *sth, imp_sth_t* imp_sth, char *statement, SV *attribs)); /* int dbd_st_rows _((SV *sth, imp_sth_t *imp_sth)); */ int dbd_bind_ph _((SV *sth, imp_sth_t *imp_sth, SV *param, SV *value, IV sqltype, SV *attribs, int is_inout, IV maxlen)); int dbd_st_execute _((SV *sv, imp_sth_t *imp_sth)); AV *dbd_st_fetch _((SV *sv, imp_sth_t *imp_sth)); int dbd_st_finish _((SV *sth, imp_sth_t *imp_sth)); void dbd_st_destroy _((SV *sth, imp_sth_t *imp_sth)); int dbd_st_blob_read _((SV *sth, imp_sth_t *imp_sth, int field, long offset, long len, SV *destrv, long destoffset)); int dbd_st_STORE_attrib _((SV *sth, imp_sth_t *imp_sth, SV *keysv, SV *valuesv)); SV *dbd_st_FETCH_attrib _((SV *sth, imp_sth_t *imp_sth, SV *keysv)); /* end of Firebird.h */ DBD-Firebird-1.39/META.yml0000664000175000017500000000152214743133212013122 0ustar damdam--- abstract: 'DBD::Firebird is a DBI driver for Firebird, written using Firebird C API.' author: - 'Edwin Pratomo (edpratomo@users.sourceforge.net)' build_requires: File::Path: '0' File::Temp: '0' Math::BigFloat: '1.55' Test::CheckDeps: '0.007' Test::Deep: '0' Test::Exception: '0.31' Test::More: '0.4' Time::HiRes: '0' configure_requires: DBI: '1.41' File::Which: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: DBD-Firebird no_index: directory: - t - inc requires: DBI: '1.41' perl: '5.008001' resources: repository: https://github.com/mariuz/perl-dbd-firebird version: '1.39' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' DBD-Firebird-1.39/META.json0000664000175000017500000000265314743133212013300 0ustar damdam{ "abstract" : "DBD::Firebird is a DBI driver for Firebird, written using Firebird C API.", "author" : [ "Edwin Pratomo (edpratomo@users.sourceforge.net)" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "DBD-Firebird", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : {} }, "configure" : { "requires" : { "DBI" : "1.41", "File::Which" : "0" } }, "runtime" : { "requires" : { "DBI" : "1.41", "perl" : "5.008001" } }, "test" : { "requires" : { "File::Path" : "0", "File::Temp" : "0", "Math::BigFloat" : "1.55", "Test::CheckDeps" : "0.007", "Test::Deep" : "0", "Test::Exception" : "0.31", "Test::More" : "0.4", "Time::HiRes" : "0" } } }, "release_status" : "stable", "resources" : { "repository" : { "url" : "https://github.com/mariuz/perl-dbd-firebird" } }, "version" : "1.39", "x_serialization_backend" : "JSON::PP version 4.16" }