DBD-QBase

 view release on metacpan or  search on metacpan

QBase.xs  view on Meta::CPAN

void
disconnect(dbh)
    SV *	dbh
    CODE:
    D_imp_dbh(dbh);
    if ( !DBIc_ACTIVE(imp_dbh) ) {
	if (DBIc_WARN(imp_dbh) && !dirty)
	    warn("disconnect: already logged off!");
	XSRETURN_YES;
    }
    /* Check for disconnect() being called whilst refs to cursors	*/
    /* still exists. This needs some more thought.			*/
    /* XXX We need to track DBIc_ACTIVE children not just all children	*/
    if (DBIc_KIDS(imp_dbh) && DBIc_WARN(imp_dbh) && !dirty) {
	warn("disconnect(%s) invalidates %d associated cursor(s)",
	    SvPV(dbh,na), (int)DBIc_KIDS(imp_dbh));
    }
    ST(0) = dbd_db_disconnect(dbh) ? &sv_yes : &sv_no;


void
DESTROY(dbh)
    SV *	dbh
    CODE:
    D_imp_dbh(dbh);

README  view on Meta::CPAN

	your OWN risk.  Therefor, What Software, nor myself, can be blamed for 
	this driver causing any damage or loss of money to your company.  
	However, if you do find a bug, please e-mail it to me at:  	
	Mouring@netnet.net

Note: Lines with "!" infront means something has changed.

Initial Comments:

! This is a bare bones release.  Fetch and non-returning SQL commands work, 
! also $cursor->rows returns the correct value for how many rows affects
! by the fetch command.
!
! For non-implement, or known bugs see TODO file included in package.
!
! Thanks to George Johnston at Filoli for his current help on fetch and
! I'm sure he'll be helping out more in the future.  Also, thanks to DBI
! mailinglist for their replies to my bothersome questions that might have
! been asked a million times already. =)
!
! Hopefully the next release will have cursors, rollback, and commit, but with
! that you'll need a new version of the QuickBase engine.  So, I'll not talk
! to much more about it. 
!
! There is a partly done Makefile.PL...I'm having a few problems, but it
! GREATLY makes my instructions easier to deal with. =)
!
Another little problem you should know is that this is a STATICLY linked module
ONLY.  Since Perl5.001m seems to have problems loading Dynamic ObjC runtime
code at runtime.  This will hopefully be fixed in later version.

dbdimp.c  view on Meta::CPAN

    printf("Warning: %s\n", what);
}


void
fbh_dump(fbh, i)
    imp_fbh_t          *fbh;
    int                 i;

/*
 * Dump information about imp_fbh_t. Currently not used since cursors is
 * not working
 */
{
}

/* ================================================================== */


static void
dump_error_status(cda)

qb.pl  view on Meta::CPAN

$drh = DBI->install_driver( 'QBase' );
die unless $drh;
print "Ok\n";

printf "Connecting to database...";
$dbh = $drh->connect( 'testdb','test','testdb' );
die unless $dbh;
print "Ok!\n";

printf "Insert Test..";
$cursor = $dbh->prepare( "INSERT Table1 (name,age) values (\"Mouring\",16)" );
$cursor->execute;
$cursor->finish;
printf "Ok\n";

printf "Update test..";
$cursor = $dbh->prepare( "UPDATE Table1 SET age=20 where name=\"Mouring\"" );
$cursor->execute;
$cursor->finish;
printf "Ok\n";

printf "Fetch test...\n";
$cursor = $dbh->prepare( "SELECT * from Table1" );
$cursor->execute;
 
while (@field = $cursor->fetchrow) {
   print "User: @field\n";
  }
$cursor->finish;

printf "Rollback test...Currently Broken\n";
#$cursor = $dbh->prepare( "INSERT Table1 SET age=23 where name=\"New User\"" );
#$cursor->execute;
#$cursor->finish;
#
#$cursor = $dbh->prepare( "SELECT * from Table1" );
#$cursor->execute;
#
#printf "** Changed State **\n"; 
#while (@field = $cursor->fetchrow) {
#   print "User: @field\n";
#  }
#$cursor->finish;
#
#$cursor->rollback;
#printf "** Original State **\n";
#$cursor = $dbh->prepare( "SELECT * from Table1" );
#$cursor->execute;
# 
#while (@field = $cursor->fetchrow) {
#   print "User: @field\n";
#  }
#$cursor->finish;

$dbh->disconnect;

exit;

test.pl  view on Meta::CPAN

sub run_test{
    my($dbh) = @_;

    print "Connected as $dbh\n\n";

    $dbh->commit;

    print "Test error handling: prepare invalid query.\n";
    print "Expect an ERROR EVENT message:\n";
    my $cursor_e = $dbh->prepare("select unknown_field_name from ?");
    print "Error not detected!\n" if $cursor_e;
    $cursor_e = 'UNDEF' unless defined $cursor_e;
    print "prepare returned $cursor_e. \$DBI::err=$DBI::err\n\n";

    my $cursor_a = $dbh->prepare("select mode,ino,name from ?");
    print "Cursor prepare'd as $cursor_a\n";
    # $cursor_a->debug(2);

    my($cursor_b) = $dbh->prepare("select blocks,size,name from ?");
    print "Prepared as $cursor_b\n";
    # $cursor_b->debug(2);

    # Test object attributes

    print "Number of fields: $cursor_a->{'NUM_OF_FIELDS'}\n";
    print "Data type of first field: $cursor_a->{'DATA_TYPE'}->[0]\n";
    print "Driver name: $cursor_a->{'Database'}->{'Driver'}->{'Name'}\n";
    print "\n";

    $cursor_a->execute('/usr');
    $cursor_b->bind_param(1, '/usr/spool');
    $cursor_b->execute();

    print "Fetching data from both cursors.\n";
    print "Expect several rows of data:\n";
    my(@row_a, @row_b);
    while((@row_a = $cursor_a->fetchrow)
       && (@row_b = $cursor_b->fetchrow)){
	    die "fetchrow scalar context problem" if @row_a==1 or @row_b==1;
	    print "@row_a, @row_b\n";
    }

    print "\nAutomatic method parameter usage check.\n";
    print "Expect a 'DBI ... invalid' error and a 'Usage: ...' message:\n";
    eval { $dbh->commit('dummy') };
    warn "$@\n";

    print "Preparing new \$cursor_a to replace current \$cursor_a.\n";
    print "We enable debugging on current to watch it's destruction.\n";
    print "Expect several lines of DBI trace information:\n";
    $cursor_a->debug(2);
    $cursor_a = $dbh->prepare("select mtime,name from ?");

    print "\nExecuting via func redirect: \$h->func(..., 'execute')\n";
    $cursor_a->func('/tmp', 'execute');

    print "\nBinding columns of \$cursor_a to variables.\n";
    my($col0, $col1);
    $cursor_a->bind_columns(undef, \($col0, $col1));
    print "\nFetching one row from new \$cursor_a with a bound column.\n";
    print "Expect a large number follwed by a dot:\n";
    my $row_ref = $cursor_a->fetch;
    print join(' ',@$row_ref),"\n";

    print "bind_col ", ($col0 and $col0 eq $row_ref->[0]) ? "worked\n" :
		"didn't work (bound:$col0 fetched:$row_ref->[0])!\n";

    $cursor_a->finish;

    print "\nCursor tests done (scoped objects will be destroyed now)\n";
}

sub mem_test{
    my($dbh) = @_;

	system("echo $count; $ps$$") if (($count++ % 1000) == 0);

    my $cursor_a = $dbh->prepare("select mode,ino,name from ?");
    $cursor_a->execute('/usr');
    my @row_a = $cursor_a->fetchrow;
    $cursor_a->finish;
}

# end.