DBD-Template
view release on metacpan or search on metacpan
Template.pm view on Meta::CPAN
require SQL::Eval;
use vars qw($VERSION $err $errstr $sqlstate $drh);
$VERSION = '0.01'; #<< Change
$err = 0; # holds error code for DBI::err
$errstr = ''; # holds error string for DBI::errstr
$sqlstate = '00000'; # holds sqlstate for DBI::sqlstate
$drh = undef; # holds driver handle once initialised
use vars qw($DBD_IGNORECASE);
$DBD_IGNORECASE = 1;
#>>>>> driver (DBD::Template) >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
sub driver($$){
#0. already created - return it
return $drh if $drh;
#1. not created(maybe normal case)
my($sClass, $rhAttr) = @_;
$sClass .= '::dr';
$drh = DBI::_new_drh($sClass,
{ Name => $sClass,
Version => $VERSION,
Err => \$DBD::Template::err,
Errstr => \$DBD::Template::errstr,
State => \$DBD::Template::sqlstate,
Attribution => 'DBD::Template by KAWAI,Takanori', #<< Change
}
);
return $drh;
}
#%%%% DBD::Template::dr =============================================================
package DBD::Template::dr;
$DBD::Template::dr::imp_data_size = 0;
#>>>>> connect (DBD::Template::dr) >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
sub connect($$;$$$) {
my($drh, $sDbName, $sUsr, $sAuth, $rhAttr)= @_;
#1. create database-handle
my $dbh = DBI::_new_dbh($drh, {
Name => $sDbName,
USER => $sUsr,
CURRENT_USER => $sUsr,
});
#2. Parse extra strings in DSN(key1=val1;key2=val2;...)
foreach my $sItem (split(/;/, $sDbName)) {
$dbh->STORE($1, $2) if ($sItem =~ /(.*?)=(.*)/);
Template.pm view on Meta::CPAN
my($drh, $rhAttr) = @_;
my $sDbdName = 'Template';
my @aDsns = ();
@aDsns = &{$rhAttr->{tmpl_datasources}} ($drh)
if(defined($rhAttr->{tmpl_datasources})); #<<-- Change
return (map {"dbi:$sDbdName:$_"} @aDsns);
}
#>>>>> disconnect_all (DBD::Template::dr) >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
sub disconnect_all($) { }
#%%%%% DBD::Template::db =============================================================
package DBD::Template::db;
$DBD::Template::db::imp_data_size = 0;
#>>>>> prepare (DBD::Template::db) >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
sub prepare {
my($dbh, $sStmt, $rhAttr) = @_;
#1. Create blank sth
my $sth = DBI::_new_sth($dbh, { Statement => $sStmt, });
return $sth unless($sth);
Template.pm view on Meta::CPAN
}
#>>>>> rollback (DBD::Template::db) >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
sub rollback ($) {
my($dbh) = shift;
&{$dbh->{tmpl_func_}->{rollback}} ($dbh)
if(defined($dbh->{tmpl_func_}->{rollback})); #-->> Change
return 1;
}
#>>>>> tmpl_func_ (DBD::Template::db) >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#-->>Change
sub tmpl_func($@) {
my($dbh, @aRest) = @_;
return unless($dbh->{tmpl_func_}->{funcs});
my $sFunc = pop(@aRest);
&{$dbh->{tmpl_func_}->{funcs}->{$sFunc}}($dbh, @aRest)
if(defined($dbh->{tmpl_func_}->{funcs}->{$sFunc}));
}
#<<--Change
#>>>>> table_info (DBD::Template::db) -----------------------------------------------
sub table_info ($) {
Template.pm view on Meta::CPAN
}
#2. Driver private attributes are lower cased
elsif ($sAttr eq (lc $sAttr)) {
$dbh->{$sAttr} = $sValue;
return 1;
}
#3. pass up to DBI to handle
return $dbh->SUPER::STORE($sAttr, $sValue);
}
#>>>>> DESTROY (DBD::Template::db) --------------------------------------------------
sub DESTROY($) {
my($dbh) = @_;
&{$dbh->{tmpl_func_}->{dbh_destroy}}($dbh)
if(defined($dbh->{tmpl_func_}->{dbh_destroy}));
}
#%%%%% DBD::Template::st ============================================================
package DBD::Template::st;
$DBD::Template::st::imp_data_size = 0;
#>>>>> bind_param (DBD::Template::st) -----------------------------------------------
sub bind_param ($$$;$) {
my($sth, $param, $value, $attribs) = @_;
return $sth->DBI::set_err(2, "Can't bind_param $param, too big")
if ($param >= $sth->FETCH('NUM_OF_PARAMS'));
$sth->{tmpl_params__}->[$param] = $value; #<<Change (tmpl_)
return 1;
}
#>>>>> execute (DBD::Template::st) --------------------------------------------------
sub execute($@) {
my ($sth, @aRest) = @_;
#1. Set Parameters
#1.1 Get Parameters
my ($raParams, @aRec);
$raParams = (@aRest)? [@aRest] : $sth->{tmpl_params__}; #<<Change (tmpl_)
#1.2 Check Param count
my $iParams = $sth->FETCH('NUM_OF_PARAMS');
if ($iParams && scalar(@$raParams) != $iParams) { #CHECK FOR RIGHT # PARAMS.
return $sth->DBI::set_err((scalar(@$raParams)-$iParams),
"..execute: Wrong number of bind variables (".
TemplateSS.pm view on Meta::CPAN
require SQL::Eval;
use vars qw($VERSION $err $errstr $sqlstate $drh);
$VERSION = '0.01'; #<< Change
$err = 0; # holds error code for DBI::err
$errstr = ''; # holds error string for DBI::errstr
$sqlstate = '00000'; # holds sqlstate for DBI::sqlstate
$drh = undef; # holds driver handle once initialised
use vars qw($DBD_IGNORECASE);
$DBD_IGNORECASE = 1;
#>>>>> driver (DBD::TemplateSS) >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
sub driver($$){
#0. already created - return it
return $drh if $drh;
#1. not created(maybe normal case)
my($sClass, $rhAttr) = @_;
$sClass .= '::dr';
$drh = DBI::_new_drh($sClass,
{ Name => $sClass,
Version => $VERSION,
Err => \$DBD::TemplateSS::err,
Errstr => \$DBD::TemplateSS::errstr,
State => \$DBD::TemplateSS::sqlstate,
Attribution => 'DBD::TemplateSS by KAWAI,Takanori', #<< Change
}
);
return $drh;
}
#%%%% DBD::TemplateSS::dr =============================================================
package DBD::TemplateSS::dr;
$DBD::TemplateSS::dr::imp_data_size = 0;
#>>>>> connect (DBD::TemplateSS::dr) >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
sub connect($$;$$$) {
my($drh, $sDbName, $sUsr, $sAuth, $rhAttr)= @_;
#1. create database-handle
my $dbh = DBI::_new_dbh($drh, {
Name => $sDbName,
USER => $sUsr,
CURRENT_USER => $sUsr,
});
#2. Parse extra strings in DSN(key1=val1;key2=val2;...)
foreach my $sItem (split(/;/, $sDbName)) {
$dbh->STORE($1, $2) if ($sItem =~ /(.*?)=(.*)/);
TemplateSS.pm view on Meta::CPAN
my($drh, $rhAttr) = @_;
my $sDbdName = 'TemplateSS';
my @aDsns = ();
@aDsns = &{$rhAttr->{tmplss_datasources}} ($drh)
if(defined($rhAttr->{tmplss_datasources})); #<<-- Change
return (map {"dbi:$sDbdName:$_"} @aDsns);
}
#>>>>> disconnect_all (DBD::TemplateSS::dr) >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
sub disconnect_all($) { }
#%%%%% DBD::TemplateSS::db =============================================================
package DBD::TemplateSS::db;
$DBD::TemplateSS::db::imp_data_size = 0;
#>>>>> prepare (DBD::TemplateSS::db) >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
sub prepare {
my($dbh, $sStmt, $rhAttr) = @_;
#1. Create blank sth
my $sth = DBI::_new_sth($dbh, { Statement => $sStmt, });
return $sth unless($sth);
TemplateSS.pm view on Meta::CPAN
}
#>>>>> rollback (DBD::TemplateSS::db) >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
sub rollback ($) {
my($dbh) = shift;
&{$dbh->{tmplss_func_}->{rollback}} ($dbh)
if(defined($dbh->{tmplss_func_}->{rollback})); #-->> Change
return 1;
}
#>>>>> tmplss_func_ (DBD::TemplateSS::db) >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#-->>Change
sub tmplss_func($@) {
my($dbh, @aRest) = @_;
return unless($dbh->{tmplss_func_}->{funcs});
my $sFunc = pop(@aRest);
&{$dbh->{tmplss_func_}->{funcs}->{$sFunc}}($dbh, @aRest)
if(defined($dbh->{tmplss_func_}->{funcs}->{$sFunc}));
}
#<<--Change
#>>>>> table_info (DBD::TemplateSS::db) -----------------------------------------------
sub table_info ($) {
TemplateSS.pm view on Meta::CPAN
}
#2. Driver private attributes are lower cased
elsif ($sAttr eq (lc $sAttr)) {
$dbh->{$sAttr} = $sValue;
return 1;
}
#3. pass up to DBI to handle
return $dbh->SUPER::STORE($sAttr, $sValue);
}
#>>>>> DESTROY (DBD::TemplateSS::db) --------------------------------------------------
sub DESTROY($) {
my($dbh) = @_;
&{$dbh->{tmplss_func_}->{dbh_destroy}}($dbh)
if(defined($dbh->{tmplss_func_}->{dbh_destroy}));
}
#%%%%% DBD::TemplateSS::st ============================================================
package DBD::TemplateSS::st;
$DBD::TemplateSS::st::imp_data_size = 0;
#>>>>> bind_param (DBD::TemplateSS::st) -----------------------------------------------
sub bind_param ($$$;$) {
my($sth, $param, $value, $attribs) = @_;
return $sth->DBI::set_err(2, "Can't bind_param $param, too big")
if ($param >= $sth->FETCH('NUM_OF_PARAMS'));
$sth->{tmplss_params__}->[$param] = $value; #<<Change (tmplss_)
return 1;
}
#>>>>> execute (DBD::TemplateSS::st) --------------------------------------------------
sub execute($@) {
my ($sth, @aRest) = @_;
#1. Set Parameters
#1.1 Get Parameters
my ($raParams, @aRec);
$raParams = (@aRest)? [@aRest] : $sth->{tmplss_params__}; #<<Change (tmplss_)
#1.2 Check Param count
my $iParams = $sth->FETCH('NUM_OF_PARAMS');
if ($iParams && scalar(@$raParams) != $iParams) { #CHECK FOR RIGHT # PARAMS.
return $sth->DBI::set_err((scalar(@$raParams)-$iParams),
"..execute: Wrong number of bind variables (".
TemplateSS.pm view on Meta::CPAN
$raNm ||=$raNames;
$oThis->{col_names} = $raNm;
my $i=0;
foreach my $sNm (@$raNm) {
$oThis->{col_nums}{$sNm} = $i++;
}
return 1;
}
#>>>>> column_num (for "SELECT ... FETCH") ------------------------------------
sub column_num($$) {
my($oThis, $sCol) =@_;
$sCol = uc($sCol) if($DBD::TemplateSS::DBD_IGNORECASE);
return $oThis->SUPER::column_num($sCol);
}
#>>>>> column (for "SELECT ... FETCH") -----------------------------------------
sub column($$;$) {
my($oThis, $sCol, $sVal) =@_;
$sCol = uc($sCol) if($DBD::TemplateSS::DBD_IGNORECASE);
return (defined $sVal)?
$oThis->SUPER::column($sCol, $sVal) : $oThis->SUPER::column($sCol);
}
1;
__END__
=head1 NAME
example/tmpl1.pl view on Meta::CPAN
print "--ALL--\n";
$hSt = $hDb->prepare('SEL ANYFMT');
$hSt->execute();
while(my $raD = $hSt->fetchrow_arrayref()) {
print join(':', @$raD), "\n";
}
$hDb->disconnect;
#%%%%% DRH(datasources) ========================================================
sub datasources($) {
my ($drh) = @_;
#1. Open specified directry
opendir(DIR, '.') or
return DBI::set_err($drh, 1, "Cannot open directory '.'");
my @aDsns = grep { ($_ ne '.') and ($_ ne '..') and (-d $_) } readdir(DIR);
closedir DIR;
return ('', @aDsns);
}
#%%%%% DRH/DBH =================================================================
#>>>>> connect -----------------------------------------------------------------
sub connect($$) {
my ($drh, $dbh) = @_;
$dbh->{tmpl_data_pool_}={};
}
#%%%%% DBH =====================================================================
#>>>>> prepare, commit, rollback -----------------------------------------------
sub prepare($$$$) {
my($dbh, $sth, $sStmt, $rhAttr) = @_;
return ($sStmt =~ tr/?//); # bind_params
}
#>>>>> commit, rollback --------------------------------------------------------
#sub commit($) { my($dbh) = @_; }
#sub rollback($) { my($dbh) = @_; }
#>>>>> table_info --------------------------------------------------------------
sub table_info($) {
my($dbh) = @_;
my @aTables;
#1. Open specified directry
my $sDir = ($dbh->FETCH('tmpl_dir'));
$sDir ||= '.';
if (!opendir(DIR, $sDir)) {
DBI::set_err($dbh, 1, "Cannot open directory $sDir");
return undef;
}
#2. Check and push it array
example/tmpl1.pl view on Meta::CPAN
$sF =~ s/\.sfm$//;
push(@aTables, [undef, undef, $sF, 'TABLE', 'Some Format']);
}
}
return (\@aTables,
['TABLE_QUALIFIER', 'TABLE_OWNER', 'TABLE_NAME',
'TABLE_TYPE', 'REMARKS']);
}
#%%%%% STH =====================================================================
#>>>>> execute, fetch, rows, name, finish --------------------------------------
sub execute($$){
my($sth, $raParam) = @_;
#1.3 Replace Placeholder with parameters
my $sStmt = $sth->FETCH('Statement');
foreach my $sRep (@$raParam) {
my $sQ = $sth->{Database}->quote($sRep);
$sStmt =~ s/\?/$sQ/;
}
#2. Parse command
example/tmpl1.pl view on Meta::CPAN
else {
$rhData->{$sFile} = [];
}
}
else{
return $sth->DBI::set_err(2, "$sCmd is not supported");
}
#3.3 Set NUM_OF_FIELDS
$sth->STORE('NUM_OF_FIELDS', 4);
}
sub fetch($) {
my($sth) = @_;
my $raData = $sth->FETCH('tmpl_sf_row_data');
return (undef, 1, 1) if (!$raData || ref($raData) ne 'ARRAY');
my $raDav = shift @$raData;
return (defined $raDav)?
($raDav, undef, undef) : (undef, 1, undef);
}
sub rows($) {
my($sth) = @_;
return (defined $sth->FETCH('tmpl_sf_row_data'))?
scalar @{$sth->FETCH('tmpl_sf_row_data')} : -1;
}
sub name($) {
my($sth) = @_;
return ['name', 'addr', 'birth', 'age'];
}
sub finish($) {
my($sth) = @_;
$sth->{tmpl_sf_row_data}=undef;
}
example/tmps1.pl view on Meta::CPAN
print "--ALL Rows(order by age)--\n";
$hSt = $hDb->prepare('SELECT * FROM ANYFMT ORDER BY AGE');
$hSt->execute();
while(my $raD = $hSt->fetchrow_arrayref()) {
print join(':', @$raD), "\n";
}
$hDb->disconnect;
#%%%%% DRH(datasources) ========================================================
sub datasources($) {
my ($drh) = @_;
#1. Open specified directry
opendir(DIR, '.') or
die DBI::set_err($drh, 1, "Cannot open directory '.'");
my @aDsns = grep { ($_ ne '.') and ($_ ne '..') and (-d $_) } readdir(DIR);
closedir DIR;
return ('', @aDsns);
}
#%%%%% DRH/DBH ================================================================
#>>>>> connect -----------------------------------------------------------------
sub connect($$) {
my ($drh, $dbh) = @_;
$dbh->{tmplss_data_pool_}={};
}
#%%%%% DBH =====================================================================
#>>>>> prepare, commit, rollback -----------------------------------------------
sub prepare($$$$) { my($dbh, $sth, $sStmt, $rhAttr) = @_; return ; }
sub commit($) { my($dbh) = @_; }
sub rollback($) { my($dbh) = @_; }
#>>>>> table_info --------------------------------------------------------------
sub table_info($) {
my($dbh) = @_;
my @aTables;
#1. Open specified directry
my $sDir = ($dbh->FETCH('tmplss_dir')) ? $dbh->FETCH('tmplss_dir') : '.';
if (!opendir(DIR, $sDir)) {
DBI::set_err($dbh, 1, "Cannot open directory $sDir");
return undef;
}
#2. Check and push it array
my $sFile;
example/tmps1.pl view on Meta::CPAN
$sF =~ s/\.sfm$//;
push(@aTables, [undef, undef, $sF, 'TABLE', 'Some Format']);
}
}
return (\@aTables,
['TABLE_QUALIFIER', 'TABLE_OWNER', 'TABLE_NAME',
'TABLE_TYPE', 'REMARKS']);
}
#%%%%% STH =====================================================================
#>>>>> finish ------------------------------------------------------------------
sub finish($) { my($sth) = @_; }
#%%%%% STH/Statement ===========================================================
#>>>>> open_table --------------------------------------------------------------
sub open_table($$$$) {
my ($sth, $sTable, $bCreMode, $lockMode) = @_;
#0. Init
my $rhData = $sth->{Database}->FETCH('tmplss_data_pool_');
my $sDir = $sth->{Database}->FETCH('tmplss_dir') || '.';
#1. Create Mode
if ($bCreMode) {
die "$sDir/$sTable.sfm Already exists" if(-e "$sDir/$sTable.sfm");
#1.2 create table object(DBD::TemplateSS::Table)
$rhData->{$sTable} =
example/tmps1.pl view on Meta::CPAN
}
}
my $rhItem = $rhData->{$sTable};
$rhItem->{tmplss_table} = $sTable;
$rhItem->{tmplss_currow} = 0;
return $rhItem;
}
#%%%%% table ===================================================================
#>>>>> seek --------------------------------------------------------------------
sub seek($$$$){
my ($oTbl, $sth, $iPos, $iWhence) = @_;
my $iRow = $oTbl->{tmplss_currow};
if ($iWhence == 0){ $iRow = $iPos; }
elsif ($iWhence == 1){ $iRow += $iPos; }
elsif ($iWhence == 2){ $iRow = $#{$oTbl->{tmplss_rows}} + 1; } # last of data
$oTbl->{tmplss_currow} = $iRow if($iRow >=0 );
return $iRow;
}
#>>>>> fetch_row ---------------------------------------------------------------
sub fetch_row($$){
my ($oTbl, $sth) = @_;
my $raItem = $oTbl->{tmplss_rows};
my $raRow = undef;
if($oTbl->{tmplss_currow} <= $#{$raItem}) {
$raRow = $raItem->[$oTbl->{tmplss_currow}];
++$oTbl->{tmplss_currow};
}
return $raRow;
}
#>>>>> push_row ----------------------------------------------------------------
sub push_row($$$){
my($oTbl, $sth, $raFields) = @_;
my $raData = $oTbl->{tmplss_rows};
$raData->[$oTbl->{tmplss_currow}] = $raFields;
++$oTbl->{tmplss_currow};
}
#>>>>> truncate ----------------------------------------------------------------
sub truncate($$){
my($oTbl, $sth) = @_;
$#{$oTbl->{tmplss_rows}} = $oTbl->{tmplss_currow}-1;
}
#>>>>> drop --------------------------------------------------------------------
sub drop($$) {
my($oTbl, $sth) = @_;
my $sDir = $sth->{Database}->FETCH('tmplss_dir') || '.';
my $sTable = $oTbl->{tmplss_table};
unlink "$sDir/$sTable.sfm";
}
( run in 0.344 second using v1.01-cache-2.11-cpan-1f129e94a17 )