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!

Register Log in
  • Congratulations strongm on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Pls help with DBI:XBase.

Status
Not open for further replies.
bluegroper

bluegroper

Technical User
Dec 12, 2002
407
AU
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
 
Sort by date Sort by votes
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
 
Upvote 0 Downvote
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 } = " $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:postgreSQL";
}
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/ $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:postgreSQL', '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:postgreSQL', '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::DBI;

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)
Nothing Runs Like the Fox
 
Upvote 0 Downvote
Status
Not open for further replies.

Similar threads

rob54321
  • Locked
  • Question
Perl how to read line from file with interpolation 1
Replies
6
Views
345
rob54321
rob54321
Bob6739
  • Locked
  • Question
Perl Beginner - Need Help
Replies
6
Views
213
feherke
feherke
kokch
  • Locked
  • Question
Need assistance with XML- Sort/Grouping (alpha sort; hide without groups)
Replies
1
Views
122
mikrom
mikrom
tonykent
  • Locked
  • Question
Assistance with printing complex data structure 1
Replies
11
Views
214
tonykent
tonykent
Beilstwh
  • Locked
  • Question
need help with a regular expression
Replies
4
Views
110
mikrom
mikrom

Part and Inventory Search

Sponsor

Back
Top