Pls help with DBI:XBase.

bluegroper · Mar 12, 2005

I'm new to perl, and even newer to DBI:Xbase.
Can somebuddy help me with this code sample ?
Yes, its perl for win32.
Just trying to open a .dbf, then for each record, set DATE_COMPL=DATE_SIGN.
The code seems to work on the .dbf, but halts with an error (below).
Also it doesn't print the first 100 records as requested. (That worked in a previous version.)
It seems like the do .. update statement operates on all records at once, rather than working sequentially thru.
So I assume that I need not bother with a record pointer.
I hope someone can help me use the correct logic and syntax.

Code:

#! perl -w
#

#	COMPILER DIRECTIVES
#
use strict; use diagnostics; use English; 
use DBI;

#	VARIABLES
#
my $array;
my (@data, $data);
my $Directory="D:/some/data";
my $dbFile="DATA.DBF";

#	SANITY CHECKS
#
my $dbhandle=DBI->connect("DBI:XBase:$Directory") or die $DBI::errstr;

#	MAIN
#
my $sthandle1=$dbhandle->prepare("SELECT ID,DATE_SIGN,DATE_COMPL from $dbFile") or die $dbhandle->errstr();
$sthandle1->execute() or die $sthandle1->errstr();
my $sthandle2=$dbhandle->do("UPDATE $dbFile SET DATE_COMPL=DATE_SIGN");
$sthandle2->execute() or die $sthandle2->errstr();

print "ID\t DATE_SIGN\t DATE_COMPL\n";
for (1 .. 100) {
     @data=$sthandle1->fetchrow_array();
     print "$_\t@data\n";
}

#	CLOSURES
#
$dbhandle->disconnect;
exit 0;

#	SUBROUTINES
#

Error message is

Code:

Can't call method "execute" without object or package reference at test.pl line 26 (#1)
(F) You used the syntax of a method call, but the slot filled by the object reference or package name contains an expression that returns a defined value that is neither an object reference nor a package name. etc

Much TIA's

- BG

bluegroper · Mar 12, 2005

Does this command

Code:

$sthandle2->execute() or die $sthandle2->errstr();

simply run off the end of the dbf, hence the error ?
How to limit processing to records in .dbf ?

- BG

Leland123 · Mar 13, 2005

Hi bluegroper,

Remember that each table in the database needs a unique primary key field, so be sure each of your tables have a primary key. In postgresql the first field I use for each of may tables is of a type "Serial", which creates a sequence table that is called each time a record is inserted and auto-increments the primary key field of a table. Postgresql also automatically creates an index on a "Serial" type field, often called primary key field.

I have created a Smglobal.pm class to handle all generic functions for my app including inserts, deletes, updates, and selects. My Smgolbal.pm class look something like this:

#------------------ Begin Smglobal.pm -------------------

#!/usr/bin/perl
# Class Smglobal
package Smglobal;

###### Let Smglobal.pm inherited some other classes #########

use Sm_session;
use Sm_css;
use Sm_error_hand;
use Sm_reports;
use Sm_shared_forms;

@ISA = qw( Sm_session Sm_css Sm_error_hand Sm_reports Sm_shared_forms );

###### End of inherited classes ################################

##########################################
## Set up a html form to handle any errors
## When an error occurs, the code with the
## BEGIN block is calloed
##########################################

use CGI::Carp qw(fatalsToBrowser set_message);

sub BEGIN
{
sub handle_errors
{
my $msg = shift;

print qq
~
<!DOCTYPE HTML PUBLIC '-//W3C//DTD HTML 4.01 Transitional//EN'>
<html lang="en">
<head>
<title>Software - Master (TM) Shopping Cart</title>\n
</head>
<body>
<center>
<TABLE
align = "center}"
cellspacing = "0"
cellpadding = "15"
BORDER = "5"
WIDTH = "90%"
style =
"
text-align : left;
color : white;
background-color : red;
font-family : Arial, Garamond, Times New Roman, serif;
font-size : 20px;
font-style : normal;
font-weight : 100;
"
>

<tbody>

<tr>
<td align="center">
Error
</td>
</tr>
<tr>
<td VALIGN="top">

<TABLE
align = "center}"
cellspacing = "0"
cellpadding = "15"
BORDER = "0"
WIDTH = "100%"
style =
"
text-align : left;
color : black;
background-color : white;
font-family : Arial, Garamond, Times New Roman, serif;
font-size : 20px;
font-style : normal;
font-weight : 100;
"
>
<tr>
<td>

Oh gosh, got an error:<br><br>
$msg
<br>
<br>
Please notify
<a href='mailto:lelandj\@mail.smvfp.com'>Leland Jackson, CPA</a>
and let him know.
<br>
<br>

</td>
</tr>

</table>

</td>
</tr>

</tbody>
</table>
</center>
</body>
</html>
~;
}
set_message( \&handle_errors );
}

##################################################
## the object constructor
##################################################
sub new
{
my $proto = shift;
my $class = ref( $proto ) || $proto;
my $self = {};

$self = Sm_css->new();

########### Company Name #########
$self->{ THE_COMPANY } = "Demo";
$self->{ THE_VERSION } = "0.5";
$self->{ ENTER_PAGE } = "Shopping Cart";

############ Paths ################
$self->{ MAIN_PATH } = "/demo";
$self->{ PICTURE_PATH } = "/images";
$self->{ DOCS_PATH } = "

http://www.smvfp.com/kart_docs";

$self->{ DB_BROWSER_PATH } = "/demo/db_browser1.40";

############# Email #################
###### $self->{SMTP_SERVER} = "192.168.1.109"; Must Edit Sendmail.pm to change; defaults to localhost
$self->{ MAIL_FROM } = "lelandj\@mail.smvfp.com";
$self->{ EMAIL_TYPE } = "html";

############ generic user ################
$self->{ THE_SEQ_HERE } = "smgeneric";
$self->{ THE_WAIT_GET } = "generic";

############ adm user ################
$self->{ SU } = "someuser";
$self->{ SU_PASSWD } = "somepassword";

############ The Database ##################
$self->{THE_SERVER} = "postgres";
$self->{DNS} = "no";
if ( $self->{DNS} eq "yes" )
{
$self->{ THE_DBI } = "ODBC

ostgreSQL";
}
else
{
$self->{ THE_DBI } = "Pg:dbname";
$self->{ THE_HOST } = "localhost";
$self->{ THE_DB } = "smdemo";
$self->{ THE_PORT } = 5432;
}
$self->{ THE_AUTOCOMMIT } = 1;

############### OS #######################
$self->{ THE_OS } =
"LINUX"; ## UNIX LINUX OS2 EPOC CYGWIN WINDOWS DOS MACINTOSH VMS ##

############# Customer Info ############
$self->{MODULE} = undef;

############# exec SQL ##################
$self->{ DBH } = undef;
$self->{ STH } = undef;

############# phrase_offset ##############
$self->{ FIRST_PAGE } = undef;
$self->{ THESEARCH } = undef;
$self->{ THE_OFFSET } = undef;

############ linkpoint ##################
$self->{ DO_LINKPOINT } = "yes";
$self->{ HOST_NAME } = "secure.linkpt.net";
$self->{ PORT } = "5555";
$self->{ STORE_NUMBER } = "123456";
$self->{ KEY_FILE } = "/var/

http://www/cgi-bin/smvfp/123456.pem";

$self->{ ORDERTYPE } = "GOOD"
; ## For a test, set ORDERTYPE to GOOD, DECLINE, or DUPLICATE. To process real transactions set ORDERTYPE TO LIVE.

############# pay method ############

$self->{ ACCEPT_VISA } = "yes";
$self->{ ACCEPT_MASTERCARD } = "yes";
$self->{ ACCEPT_AMEX } = "no";
$self->{ ACCEPT_DISCOVER } = "no";
$self->{ ACCEPT_CHECK } = "yes";

############ Session Cookies ############
if ( $^O eq "linux" )
{
$self->{ COOKIE_DIR } = "/tmp";
}
elsif ( $^O eq "MSWin32" )
{
$self->{ COOKIE_DIR } = "c:\temp";
}
else
{
$self->{ COOKIE_DIR } = "/tmp";
}
$self->{SESSION_EXPIRE} = 7200; ## 7200 is in seconds ##

############## others ###################
$self->{ THE_DATE } = undef;
$self->{ FORMATED_NO } = undef;
$self->{ BROWSER_PREFERENCE } = "icons"; ## undef, icons, or buttons
$self->{ DO_ICONS } = undef;
$self->{ THE_VALUE } = undef;
$self->{ THE_CORD } = undef;
$self->{ THUMBNAIL_HEIGTH } = 150;
$self->{ THUMBNAIL_WIDTH } = 150;
$self->{ DO_AFFILIATES } = "yes";
$self->{ CONFIRM_UPDATES } = "yes";
$self->{ CONFIRM_DELETES } = "yes";
$self->{ IS_DEMO } = "yes;
$self->{ CC_CHECK } = "no";
$self->{ ACCOUNT_CC_INFO } = "no";
$self->{ DISPLAY_SOLD_ITEMS } = "yes";
$self->{ PRINT_ON } = undef;
$self->{ ONCLICK_MENU } = "false"; ## true, false, or, undef

bless( $self, $class );
return $self;
}

##############################################
## methods to access per-object data
## With args, they set the value. Without
## any, they only retrieve it/them.
##############################################

############################################
## No changes needed below this message
############################################

##################################################
## sql_dbh
##################################################
sub sql_dbh
{

##### Connection to the database #######

my $self = shift;

my ( $userlogged ) = @_;

if ( $userlogged eq "t" )
{
eval
{
if ( $self->{DNS} eq "yes" )
{
$self->{DBH} = DBI->connect
(
qq~dbi:$self->{THE_DBI}~,
$self->{ADM_SEQ_HERE},
$self->{ADM_WAIT_GET}
);
#$self->{DBH} = DBI->connect('dbi:ODBC

ostgreSQL', 'postgres', 'SalTexSue');
}
else
{

$self->{DBH} = DBI->connect
( qq~DBI:$self->{THE_DBI} = $self->{THE_DB};
host = $self->{THE_HOST};
port = $self->{THE_PORT}
~,
$self->{ADM_SEQ_HERE}, ## user name
$self->{ADM_WAIT_GET} ## password
); ## Get connected
}

$self->{DBH}->{RaiseError} = 1; ## Turn on Errrors

$self->{DBH}->{autocommit} = $self->{THE_AUTOCOMMIT}; ## set $self{THE_AUTOCOMMIT} to 0 to turn transactions on.
};
}
else
{
eval
{
if ( $self->{DNS} eq "yes" )
{
$self->{DBH} = DBI->connect
(
qq~dbi:$self->{THE_DBI}~,
$self->{THE_SEQ_HERE},
$self->{THE_WAIT_GET}
);
#$self->{DBH} = DBI->connect('dbi:ODBC

ostgreSQL', 'postgres', 'SalTexSue');

### We are interested in the first 512 KB of data
}
else
{
$self->{DBH} = DBI->connect
( qq~DBI:$self->{THE_DBI} = $self->{THE_DB};
host = $self->{THE_HOST};
port = $self->{THE_PORT}
~,
$self->{THE_SEQ_HERE}, ## user name
$self->{THE_WAIT_GET} ## password
); ## Get connected
}

$self->{DBH}->{RaiseError} = 1; ## Turn on Errrors

$self->{DBH}->{autocommit} = $self->{THE_AUTOCOMMIT}; ## set $self{THE_AUTOCOMMIT} to 0 to turn transactions on.
};
}

if ( $@ )
{
$the_error = qq~I was unable to connect to the database because $@~;

$self->new_error_form( $the_error );

if ( defined( $self->{ DBH } ) )
{
$self->{ DBH }->disconnect();
}

exit;
}
else
{
return $self->{ DBH };
}
}

########################################################
################### sql_exec #########################
########################################################
sub sql_exec
{

############ execute SQL passed in #############

my $self = shift;

my ( $the_sql, $display_sql, $chain_to ) = @_;

eval
{
$self->{ DBH }->quote( $the_sql );

};

if ( $self->{ THE_AUTOCOMMIT } == 0 )
{
$self->{ DBH }->BEGIN; ## begin transaction
}

eval
{
if ( $self->{DNS} eq "yes" )
{

$self->{ DBH }->{LongReadLen} = 65536;
$self->{ DBH }->{LongTruncOk} = 1; ### We're happy to truncate any excess
}

$self->{ STH } = $self->{ DBH }->prepare( $the_sql );
$self->{ STH }->execute;

if ( $self->{ THE_AUTOCOMMIT } == 0 )
{
$self->{ DBH }->commit() ## begin transaction
}
};

if ( $@ )
{
$self->{ DO_SELECT } = "false";

my $the_error =
qq~The database server returned the following message:<br><br>$@~;

if ( $display_sql ne "false" )
{
$the_error = $the_error
. qq~<br><br>The SQL pass to the database Server was:<br><br>$the_sql~;
};

$self->new_error_form( $the_error, $chain_to );

if ( $self->{ THE_AUTOCOMMIT } == 0 )
{
eval {
$self->{ DBH }->rollback() ## in case SQL fails
};
}

if ( defined( $self->{ DBH } ) )
{
$self->{ DBH }->disconnect();
}
exit;
}
else
{
return $self->{ STH };
}
}

########## Many more subs would go here ##########

1;

#--------------- end Smglobal.pm --------------------

Now, all application can create a namespace in memory of the Smglobal class with the "use" command. Also, a scalar can be created which holds the memory address where the Smglobal.pm namespace is located. Then, the scalar reference can be used to access all the properties and methods of the Smglobal.pm namespace like follows:

#---------- Begin db_example.pl -----------------------
#!/usr/bin/perl

use Apache:

BI;

use DBI;

use CGI;

print "Content-type: text/html\n\n";

use lib "./Sm";
use Sm::Smglobal;
$oMy = Smglobal->new();

$escaped_product_name = $oMy->replace($FORM{ "edit_product_name" }, qq~\'~, qq~\\'~);

$escaped_shortcomment = $oMy->replace($FORM{ "edit_shortcomment" }, qq~\'~, qq~\\'~);

$escaped_longcomment = $oMy->replace($FORM{ "edit_longcomment" } , qq~\'~, qq~\\'~);

$escaped_emailcomment = $oMy->replace($FORM{ "edit_emailcomment" }, qq~\'~, qq~\\'~);

$escaped_taxcategory = $oMy->replace($FORM{ "edit_taxcategory" } , qq~\'~, qq~\\'~);

$the_items_end = $FORM{ "edit_items_beg" } + $FORM{ "edit_items_in" } + $FORM{ "edit_items_out" } + $FORM{ "edit_items_adj" } ;

$thesearch = qq
~
UPDATE products SET
name = '$escaped_product_name',
crc = '$FORM{ "edit_crc" }',
stockno = '$FORM{ "edit_stockno" }',
locationno = '$FORM{ "edit_locationno" }',
shortcomment = '$escaped_shortcomment',
longcomment = '$escaped_longcomment',
emailcomment = '$escaped_emailcomment',
items_beg = '$FORM{ "edit_items_beg" }',
items_in = '$FORM{ "edit_items_in" }',
items_out = '$FORM{ "edit_items_out" }',
items_adj = '$FORM{ "edit_items_adj" }',
items_end = '$the_items_end',
taxcategory = '$escaped_taxcategory',
shipping = '$FORM{ "edit_shipping" }',
shipamount = '$FORM{ "edit_shipamount" }',
price = '$FORM{ "edit_price" }',
due_tier_1 = '$FORM{ "edit_due_tier_1" }',
due_tier_2 = '$FORM{ "edit_due_tier_2" }',
download_path = '$FORM{ "edit_download_path" }',
moreinfo1 = '$FORM{ "edit_moreinfo1" }',
moreinfo2 = '$FORM{ "edit_moreinfo2" }',
thetime = 'now'
WHERE productno = $Unique_id
~;

$dbh = $oMy->sql_dbh( $userlogged );
$sth = $oMy->sql_exec( $thesearch, "false" );

if( defined($dbh) )
{
$dbh->disconnect();
}

if ( $oMy->{CONFIRM_UPDATES} eq "yes" )
{

&oops_hidden_values( "true", "true", "true" );

$the_info = "Product was updated successfully.";

$oMy->update_success
(
$the_info,
"kart_prod_main.pl",
"prod_offset_number",
$FORM{ "prod_offset_number" },
"prod_choice",
"Edit Product"
);

exit;

}

&find_product();
}

#---------------- end db_example.pl -------------------

Regards,

LelandJ

Leland F. Jackson, CPA
Software - Master (TM)

http://www.smvfp.com

Nothing Runs Like the Fox

Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Pls help with DBI:XBase.

bluegroper

Technical User

bluegroper

Technical User

Leland123

Programmer

Similar threads

Part and Inventory Search

Sponsor