branches/mus-0.4.x-devel/SrSv/DB/StubGen/Stub.pm

   1 #       This file is part of Invid
   2 #
   3 #       Invid is free software; you can redistribute it and/or
   4 #       modify it under the terms of the GNU Lesser General Public
   5 #       License version 2.1 as published by the Free Software Foundation.
   6
   7 #       This library is distributed in the hope that it will be useful,
   8 #       but WITHOUT ANY WARRANTY; without even the implied warranty of
   9 #       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  10 #       Lesser General Public License for more details.
  11
  12 #       You should have received a copy of the GNU Lesser General Public
  13 #       License along with this library; if not, write to the Free Software
  14 #       Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
  15
  16 # Copyright Adam Schrotenboer <adam@tabris.net> 2007, 2008
  17 #
  18
  19 # This code is based in large part on the MySQL::Stub from SrSv, as well as
  20 # the DB::Sub from M2000's CMS.
  21
  22 =head1 NAME
  23
  24 SrSv::DB::StubGen::Stub - Create functions for SQL queries
  25
  26 =cut
  27
  28 package SrSv::DB::StubGen::Stub;
  29 use strict;
  30
  31 use Carp qw( confess );
  32
  33 our %create_sub = (
  34         # For INSERT queries, returns last_insert_id.
  35         INSERT => sub($) {
  36                 my $dbh = shift @_;
  37                 my $q = shift;
  38                 return sub {
  39                         eval { $q->execute(@_); };
  40                         if($@) { confess($@) }
  41                         $q->finish();
  42                         return $dbh->last_insert_id(undef, undef, undef, undef);
  43                 }
  44         },
  45
  46         # For UPDATE or DELETE queries; returns number of rows affected.
  47         NULL => sub ($) {
  48                 my $dbh = shift @_;
  49                 my $q = shift;
  50                 return sub {
  51                         my $ret;
  52                         eval { $ret = $q->execute(@_) + 0; }; # Force it to be a number.
  53                         if($@) { confess($@) }
  54                         $q->finish();
  55                         return ($ret);
  56                 }
  57         },
  58
  59         # For queries that return only one row with one columns; returns a scalar.
  60         SCALAR => sub ($) {
  61                 my $dbh = shift @_;
  62                 my $q = shift;
  63                 return sub {
  64                         eval { $q->execute(@_); };
  65                         if($@) { confess($@) }
  66                         my $scalar;
  67                         eval { ($scalar) = $q->fetchrow_array; };
  68                         if($@) { confess($@) }
  69                         $q->finish();
  70                         return $scalar;
  71                 }
  72         },
  73
  74         # For queries that return only one row with multiple columns; returns a 1-dimensional array.
  75         ROW => sub ($) {
  76                 my $dbh = shift @_;
  77                 my $q = shift;
  78                 return sub {
  79                         eval { $q->execute(@_); };
  80                         if($@) { confess($@) }
  81                         my @row;
  82                         eval { @row = $q->fetchrow_array; };
  83                         if($@) { confess($@) }
  84
  85                         $q->finish();
  86                         return @row;
  87                 }
  88         },
  89
  90         # For queries that return just a single column, multiple rows
  91         # return a 1D array.
  92         COLUMN => sub ($) {
  93                 my $dbh = shift @_;
  94                 my $q = shift;
  95                 return sub {
  96                         eval { $q->execute(@_); };
  97                         if($@) { confess($@) }
  98                         my $arrayref;
  99                         eval { $arrayref = $q->fetchall_arrayref() };
 100                         if($@) { confess($@) }
 101
 102                         $q->finish();
 103                         return map({ $_->[0] } @$arrayref);
 104                 }
 105         },
 106
 107
 108         # For other queries; returns an arrayref.
 109         ARRAY => sub ($) {
 110                 my $dbh = shift @_;
 111                 my $q = shift;
 112                 return sub {
 113                         #die "improper number of parameters for $sth\n" unless $q->{NUM_OF_PARAMS} == scalar(@_);
 114                         eval { $q->execute(@_); };
 115                         if($@) { confess($@) }
 116                         if ($q->err) { say ("ERROR: ", $q->err); }
 117                         my $arrayref;
 118                         eval { $arrayref = $q->fetchall_arrayref() };
 119                         if($@) { confess($@) }
 120
 121                         $q->finish();
 122                         return @$arrayref;
 123                 }
 124         },
 125
 126         ARRAYREF => sub ($) {
 127                 my $dbh = shift @_;
 128                 my $q = shift;
 129                 return sub {
 130                         $q->execute(@_);
 131                         my $arrayref;
 132                         eval { $arrayref = $q->fetchall_arrayref() };
 133                         if($@) { confess($@) }
 134                         $q->finish();
 135                         return ($arrayref);
 136                 }
 137         },
 138 );
 139
 140 sub import {
 141         shift @_; # Remove most-recent-caller package name from arg list.
 142
 143         # this is the _original_ package caller
 144         my $package = shift @_;
 145         my $dbh = shift @_;
 146
 147         my $printError = $dbh->{PrintError};
 148         $dbh->{PrintError} = 1;
 149
 150         foreach (@_) {
 151                 my ($name, $type, $query) = @$_;
 152 =cut
 153                 $query =~ s/\n/ /gm;
 154                 $query =~ s/\s{2,}/ /g;
 155                 print "$query \n";
 156 =cut
 157                 # Prepare query
 158                 my $q = $dbh->prepare($query);
 159
 160                 # Create subroutine.
 161                 my $sub = $create_sub{$type}->($dbh, $q);
 162
 163                 # Export subroutine into caller's namespace.
 164                 {
 165                         no strict 'refs';
 166                         *{"${package}::${name}"} = $sub;
 167                 }
 168         }
 169         $dbh->{PrintError} = $printError;
 170 }