[RFC] DBD-Template

[KAWAI,Takanori]

I've made up a template/sample pure perl DBD, DBD::Template and
DBD::TemplateSS (for SQL::Statement).
These modules make it much easier to make pure perl DBDs. 
(at least I believe).

You can get from here:
http://member.nifty.ne.jp/hippo2000/DBD-Template-0.01.tar.gz

If these are OK, I want to request DBD::Template and DBD::TemplateSS,
with prefix 'tmpl_' and 'tmplss_'.

[ex. poor man's DBD::CSV]
#!/usr/bin/perl -w
use strict;
my $sExt = 'csv';
#%%%%% main ========================================================
use DBI;
#0. Initial Setting
open OUT, ">TEST.$sExt";
print OUT "1,2,3,4\n5,6,7,8\n";
close OUT;
#1. Connect
my $hDb = DBI->connect('dbi:TemplateSS:', '', '', 
        {RaiseError=>1, AutoCommit=> 1,
            tmplss_func_ => {
                open_table  => \&open_table,
                seek        => \&seek,
                fetch_row   => \&fetch_row,
                push_row    => \&push_row,
                truncate    => \&truncate,
                drop        => \&drop,
                table_info  => \&table_info,
            },
            tmplss_csv_col  => [qw(col1 col2 col3 col4)],
        }
    ) or die "Can't connect $DBI::errstr";
#2. SELECT ALL
print "-- Initial --\n";
my $hSt = $hDb->prepare('SELECT * FROM TEST');
my $ra;
$hSt->execute(); 
while($ra = $hSt->fetchrow_arrayref()){print join(':', @$ra), "\n";}
#3. Modify DATA
my $hStI = $hDb->prepare('INSERT INTO TEST VALUES(?, ?, ?, ?)');
$hStI->execute(3, 4, 5, 6);
$hStI->execute(4, 8, 12, 16);
$hDb->do('UPDATE TEST SET col1 = 10 WHERE col1=5');
$hDb->do('DELETE FROM TEST WHERE col1=1');

#4. SELECT ALL
print "--AFTER ALL--\n";
$hSt->execute(); 
while($ra = $hSt->fetchrow_arrayref()){print join(':', @$ra), "\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 ==========================================================
#>>>>> 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_csv_dir') || '.';
    if (!opendir(DIR, $sDir)) {
        DBI::set_err($dbh, 1, "Cannot open directory $sDir");
        return undef;
    }
#2. Check and push it array
    my $sFile;
    while (defined($sFile = readdir(DIR))) {
        next if($sFile !~/\.$sExt$/i);
        my $sFullPath = "$sDir/$sFile";
        if (-f $sFullPath) {
            my $sF = $sFile;
            $sF =~ s/\.$sExt$//;
            push(@aTables, [undef, undef, $sF,'TABLE','TestData']);
        }
    }
    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 $sDir   = $sth->{Database}->FETCH('tmplss_csv_dir') || '.';
#1. Create Mode
    if ($bCreMode) {
        open TMP, ">$sDir/$sTable.csv" or die "Can't create $!";
    }
    else {
        open TMP, "+<$sDir/$sTable.csv" or die "Can't open $!";
    }
    my @aCol = map { uc($_) } @{$sth->{Database}->{tmplss_csv_col}};
    my $rhItem= {
        col_names   => \@aCol,  #For SQL::Statement
        tmplss_table => $sTable,    #For "drop" method
    };
    return $rhItem;
}

#%%%%% table ========================================================
#>>>>> seek ---------------------------------------------------------
sub seek($$$$){
    my ($oTbl, $sth, $iPos, $iWhence) = @_;
    my $iRow = $oTbl->{tmplss_currow};
    if    ($iWhence == 0){ seek TMP, 0, 0; }
    elsif ($iWhence == 1){ for(my $i=0;$i< $iPos;$i++) { <TMP>; } } 
    elsif ($iWhence == 2){ seek TMP, 0, 2; }    # last of data
}
#>>>>> fetch_row ---------------------------------------------------
sub fetch_row($$){
    my ($oTbl, $sth) = @_;
    my $sRow = <TMP>;
    return undef unless(defined($sRow));
    chomp($sRow);
    return [split(/,/, $sRow)];
}
#>>>>> push_row -----------------------------------------------------
sub push_row($$$){
    my($oTbl, $sth, $raFields) = @_;
    print TMP join(',', @$raFields), "\n";
}
#>>>>> truncate -----------------------------------------------------
sub truncate($$){
    my($oTbl, $sth) = @_;
    truncate TMP, tell(TMP);
}
#>>>>> drop ---------------------------------------------------------
sub drop($$) {
    my($oTbl, $sth) = @_;
    my $sDir   = $sth->{Database}->FETCH('tmplss_csv_dir') || '.';
    my $sTable = $oTbl->{tmplss_table};
    unlink "$sDir/$sTable.$sExt";
}


[Result]
-- Initial --
1:2:3:4
5:6:7:8
--AFTER ALL--
10:6:7:8
3:4:5:6
4:8:12:16

==============================================
KAWAI, Takanori(Hippo2000)
   Mail: [EMAIL PROTECTED] [EMAIL PROTECTED]
   http://member.nifty.ne.jp/hippo2000/index_e.htm
   http://www.hippo2000.info/cgi-bin/KbWikiE/KbWiki.pl
 May we translate your pods into Japanese?
    -- Japanized Perl Resource Project
  http://sourceforge.jp/projects/perldocjp/
==============================================