#!perl
#===============================================================================
#   DBD::Template - A sample class for DBI
#   This module is Copyright (C) 2002 Kawai,Takanori (Hippo2000) Japan
#   All rights reserved.
#===============================================================================
require 5.004;
use strict;
#%%%% DBD::Template =================================================================
package DBD::Template;  #<< Change
require DBI;
require SQL::Statement;
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 =~ /(.*?)=(.*)/);
    }
#3. Add Extra attributes
    foreach my $sKey (keys %$rhAttr) {
        $dbh->STORE($sKey, $rhAttr->{$sKey});
    }
    $dbh->{AutoCommit}  =1;

#4. Initialize
    my @aReqF = qw(prepare execute fetch rows name);
    my @aMissing=();
    for my $sFunc (@aReqF) {
        push @aMissing, $sFunc unless(defined($dbh->{tmpl_func_}->{$sFunc}));
    }
    die "Set " . join(',', @aMissing) if(@aMissing);

    &{$dbh->{tmpl_func_}->{connect}}($drh, $dbh) 
                if(defined($dbh->{tmpl_func_}->{connect})); #<<-- Change
    return $dbh;
}
#>>>>> data_sources (DBD::Template::dr) >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
sub data_sources ($;$) {
    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);
# 2. Init parameters and store parameter
    $sth->STORE('tmpl_params__', []);
    my $iPrm = &{$dbh->{tmpl_func_}->{prepare}}($dbh, $sth, $sStmt, $rhAttr);
    $sth->STORE('NUM_OF_PARAMS', $iPrm);
    return $sth;
}
#>>>>> commit (DBD::Template::db) >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
sub commit ($) {
    my($dbh) = shift;
    &{$dbh->{tmpl_func_}->{commit}} ($dbh)
            if(defined($dbh->{tmpl_func_}->{commit}));  #-->> Change
}
#>>>>> 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 ($) {
    my($dbh) = @_;
#-->> Change 
    my ($raTables, $raName) = 
            &{$dbh->{tmpl_func_}->{table_info}}($dbh)
                        if(defined($dbh->{tmpl_func_}->{table_info}));
#<<-- Change 
    return undef unless $raTables;
#2. create DBD::Sponge driver
    my $dbh2 = $dbh->{'_sponge_driver'};
    if (!$dbh2) {
        $dbh2 = $dbh->{'_sponge_driver'} = DBI->connect("DBI:Sponge:");
        if (!$dbh2) {
            $dbh->DBI::set_err( 1, $DBI::errstr);
            return undef;
            $DBI::errstr .= ''; #Just for IGNORE warning
        }
    }
#3. assign table info to the DBD::Sponge driver
    my $sth = $dbh2->prepare("TABLE_INFO", 
            { 'rows' => $raTables, 'NAMES' => $raName });
    if (!$sth) {
        $dbh->DBI::set_err(1, $dbh2->errstr());
    }
    return  $sth;
}
#>>>>> quote (DBD::Template::db) ----------------------------------------------------
sub quote ($$;$) {
    my($dbh, $sObj, $iType) = @_;
    return &{$dbh->{tmpl_func_}->{quote}}($dbh, $sObj, $iType)
                        if(defined($dbh->{tmpl_func_}->{quote}));   #Change

#1.Numeric
    if (defined($iType)  &&
        ($iType == DBI::SQL_NUMERIC()   || $iType == DBI::SQL_DECIMAL()   ||
         $iType == DBI::SQL_INTEGER()   || $iType == DBI::SQL_SMALLINT()  ||
         $iType == DBI::SQL_FLOAT()     || $iType == DBI::SQL_REAL()      ||
         $iType == DBI::SQL_DOUBLE()    || $iType == DBI::TINYINT())) {
        return $sObj;
    }
#2.NULL
    return 'NULL' unless(defined $sObj);
#3. Others
    $sObj =~ s/\\/\\\\/sg;
    $sObj =~ s/\0/\\0/sg;
    $sObj =~ s/\'/\\\'/sg;
    $sObj =~ s/\n/\\n/sg;
    $sObj =~ s/\r/\\r/sg;
    return "'$sObj'";
}
#>>>>> type_info_all (DBD::Template::db) --------------------------------------------
sub type_info_all ($) {
    my ($dbh) = @_;

    my $raType = &{$dbh->{tmpl_func_}->{type_info_all}}($dbh)
                        if(defined($dbh->{tmpl_func_}->{type_info_all}));   #Change
    $raType ||= 
        [
            [ 'VARCHAR',                #TYPE_NAME
                DBI::SQL_VARCHAR(),     #DATA_TYPE
                undef,                  #PRECISION
                "'",                    #LITERAL_PREFIX
                "'",                    #LITERAL_SUFFIX
                undef,                  #CREATE_PARAMS
                0,                      #NULLABLE
                1,                      #CASE_SENSITIVE
                1,                      #SEARCHABLE
                0,                      #UNSIGNED_ATTRIBUTE
                0,                      #MONEY
                0,                      #AUTO_INCREMENT
                undef,                  #LOCAL_TYPE_NAME
                0,                      #MINIMUM_SCALE
                0                       #MAXIMUM_SCALE
            ],
        ];

    return [
        {   TYPE_NAME       =>  0, DATA_TYPE      =>  1, PRECISION      =>  2,
            LITERAL_PREFIX  =>  3, LITERAL_SUFFIX =>  4, CREATE_PARAMS  =>  5,
            NULLABLE        =>  6, CASE_SENSITIVE =>  7, SEARCHABLE     =>  8,
            UNSIGNED_ATTRIBUTE =>  9, MONEY       => 10, AUTO_INCREMENT => 11,
            LOCAL_TYPE_NAME => 12, MINIMUM_SCALE  => 13, MAXIMUM_SCALE  => 14,
        },
        @$raType,
    ];
}
#>>>>> disconnect (DBD::Template::db) -----------------------------------------------
sub disconnect ($) { 
    my ($dbh) = @_;
    &{$dbh->{tmpl_func_}->{disconnect}}($dbh)
                        if(defined($dbh->{tmpl_func_}->{disconnect}));
    1;
}
#>>>>> FETCH (DBD::Template::db) ----------------------------------------------------
sub FETCH ($$) {
    my ($dbh, $sAttr) = @_;
# 1. AutoCommit
    return $dbh->{$sAttr} if ($sAttr eq 'AutoCommit');
# 2. lower cased = Driver private attributes 
    return $dbh->{$sAttr} if ($sAttr eq (lc $sAttr));
# 3. pass up to DBI to handle
    return $dbh->SUPER::FETCH($sAttr);
}
#>>>>> STORE (DBD::Template::db) ----------------------------------------------------
sub STORE ($$$) {
    my ($dbh, $sAttr, $sValue) = @_;
#1. AutoCommit
    if ($sAttr eq 'AutoCommit') {
        if(defined($dbh->{tmpl_func_}->{rollback})) {
            $dbh->{$sAttr} = ($sValue)? 1: 0;
        }
        else{
    #Rollback
            warn("Can't disable AutoCommit with no rollback func", -1)
                                    unless($sValue);
            $dbh->{$sAttr} = 1;
        }
        return 1;
    } 
#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 (".
                (scalar(@$raParams)-$iParams)." too many!)");
    }
#2. Execute
    my($oResult, $iNumFld, $sErr) = 
        &{$sth->{Database}->{tmpl_func_}->{execute}}($sth, $raParams);
    if ($sErr) { return $sth->DBI::set_err( 1, $@); }
#3. Set NUM_OF_FIELDS
    if ($iNumFld  &&  !$sth->FETCH('NUM_OF_FIELDS')) {
        $sth->STORE('NUM_OF_FIELDS', $iNumFld);
    }
#4. AutoCommit
    $sth->{Database}->commit if($sth->{Database}->FETCH('AutoCommit'));
    return $oResult;
}
#>>>>> fetch (DBD::Template::st) ----------------------------------------------------
sub fetch ($) {
    my ($sth) = @_;

#1. get data
    my ($raDav, $bFinish, $bNotSel) = 
        &{$sth->{Database}->{tmpl_func_}->{fetch}}($sth); #<<Change (tmpl_);

    return $sth->DBI::set_err( 1, 
        "Attempt to fetch row from a Non-SELECT Statement") if ($bNotSel);

    if ($bFinish) {
        $sth->finish;
        return undef;
    }

    if ($sth->FETCH('ChopBlanks')) {
        map { $_ =~ s/\s+$//; } @$raDav;
    }
    $sth->_set_fbav($raDav);
}
*fetchrow_arrayref = \&fetch;
#>>>>> rows (DBD::Template::st) -----------------------------------------------------
sub rows ($) { 
    my($sth) = @_;
    return &{$sth->{Database}->{tmpl_func_}->{rows}}($sth); #<<Change (tmpl_)
}
#>>>>> finish (DBD::Template::st) ---------------------------------------------------
sub finish ($) {
    my ($sth) = @_;
#-->> Change (if you want)
    &{$sth->{Database}->{tmpl_func_}->{finish}}($sth)
        if(defined($sth->{Database}->{tmpl_func_}->{finish}));
#<<-- Change
    $sth->SUPER::finish();
    return 1;
}
#>>>>> FETCH (DBD::Template::st) ----------------------------------------------------
sub FETCH ($$) {
    my ($sth, $attrib) = @_;
#NAME
    return &{$sth->{Database}->{tmpl_func_}->{name}}($sth) #<<Change (tmpl_)
                if ($attrib eq 'NAME');
#TYPE... Statement attribute
    return [(DBI::SQL_VARCHAR()) x $sth->FETCH('NUM_OF_FIELDS')]
        if($attrib eq 'TYPE');
    return [(-1) x $sth->FETCH('NUM_OF_FIELDS')]
        if($attrib eq 'PRECISION');
    return [(undef) x $sth->FETCH('NUM_OF_FIELDS')]
        if($attrib eq 'SCALE');
    return [(1) x $sth->FETCH('NUM_OF_FIELDS')]
        if($attrib eq 'NULLABLE');
    return undef if($attrib eq 'RowInCache');
    return undef if($attrib eq 'CursorName');
# Private driver attributes are lower cased
    return $sth->{$attrib} if ($attrib eq (lc $attrib));
    return $sth->SUPER::FETCH($attrib);
}
#>>>>> STORE (DBD::Template::st) ----------------------------------------------------
sub STORE ($$$) {
    my ($sth, $attrib, $value) = @_;
#1. Private driver attributes are lower cased
    if ($attrib eq (lc $attrib)) {
        $sth->{$attrib} = $value;
        return 1;
    }
    else {
        return $sth->SUPER::STORE($attrib, $value);
    }
}
#>>>>> DESTROY (DBD::Template::st) --------------------------------------------------
sub DESTROY {
    my ($sth) = @_;
    &{$sth->{Database}->{tmpl_func_}->{sth_destroy}}($sth)
        if(defined($sth->{Database}->{tmpl_func_}->{sth_destroy}));
}
#>> Just for no warning-----------------------------------------------
$DBD::Template::dr::imp_data_size = 0;
$DBD::Template::db::imp_data_size = 0;
$DBD::Template::st::imp_data_size = 0;
*DBD::Template::st::fetchrow_arrayref = \&DBD::Template::st::fetch;
#<< Just for no warning------------------------------------------------
1;
__END__

=head1 NAME

DBD::Template -  A template/sample class for DBI drivers.

This is still B<alpha version>.

=head1 SYNOPSIS

    use DBI;
    $hDb = DBI->connect("DBI:Template:", '', '',
        {AutoCommit => 1, RaiseError=> 1,
                tmpl_func_ => {
                    connect => \&connect,
                    prepare => \&prepare,
                    execute => \&execute,
                    fetch   => \&fetch,
                    rows    => \&rows,
                    name    => \&name,
                    table_info    => \&table_info,
                },
                tmpl_your_var => 'what you want', #...
            )
        or die "Cannot connect: " . $DBI::errstr;
    $hSt = $hDb->prepare("CREATE TABLE a (id INTEGER, name CHAR(10))")
        or die "Cannot prepare: " . $hDb->errstr();
    ...
    $hDb->disconnect();

=head1 DESCRIPTION

This is still B<alpha version>.

The DBD::Template module is a DBI driver.
You can make DBD with simply define function described below;

=head1 Functions

You can/should defined these functions to make DBD.
I<required> means "You should define that function".
Please refer I<example/tmpl*.pl>, for more detail.

=head2 Driver Level

=over 4

=item datasources

=item connect

=back

=head2 Database Level

=over 4

=item prepare   I<(required)>

=item commit

=item rollback

=item table_info

=item disconnect

=item dbh_destroy

=item quote

=item type_info

=item funcs

=back

=head2 Statement Level

=over 4

=item execute   I<(required)>

=item fetch I<(required)>

=item rows  I<(required)>

=item name  I<(required)>

=item finish

=item sth_destroy

=back 

=head1 AUTHOR

Kawai Takanori (Hippo2000) kwitknr@cpan.org

=head1 SEE ALSO

DBI, DBI::DBD

=head1 COPYRIGHT

Copyright (c) 2002 KAWAI,Takanori
All rights reserved.

You may distribute under the terms of either the GNU General Public
License or the Artistic License, as specified in the Perl README file.

=cut