branches/erry-devel/SrSv/MySQL/Stub.pm

   1 #       This file is part of SurrealServices.
   2 #
   3 #       SurrealServices is free software; you can redistribute it and/or modify
   4 #       it under the terms of the GNU General Public License as published by
   5 #       the Free Software Foundation; either version 2 of the License, or
   6 #       (at your option) any later version.
   7 #
   8 #       SurrealServices is distributed in the hope that it will be useful,
   9 #       but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 #       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 #       GNU General Public License for more details.
  12 #
  13 #       You should have received a copy of the GNU General Public License
  14 #       along with SurrealServices; if not, write to the Free Software
  15 #       Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  16
  17 package SrSv::MySQL::Stub;
  18
  19 =head1 NAME
  20
  21 SrSv::MySQL::Stub - Create functions for SQL queries
  22
  23 =cut
  24
  25 use strict;
  26
  27 use Symbol 'delete_package';
  28 use Carp qw( confess );
  29
  30 use SrSv::Debug;
  31 use SrSv::MySQL '$dbh';
  32 use SrSv::Process::Init;
  33 use DBI qw(:sql_types);
  34
  35 our %types;
  36
  37 sub create_null_stub($) {
  38         my ($stub) = @_;
  39
  40         my $sth;
  41
  42         proc_init {
  43                 $sth = $dbh->prepare($stub->{SQL});
  44         };
  45
  46         return sub {
  47                 my $ret;
  48                 eval { $ret = $sth->execute(@_) + 0; }; #force result to be a number
  49                 if($@) { confess($@) }
  50                 $sth->finish();
  51                 return $ret;
  52         };
  53 }
  54
  55 sub create_insert_stub($) {
  56         my ($stub) = @_;
  57
  58         my $sth;
  59
  60         proc_init {
  61                 $sth = $dbh->prepare($stub->{SQL});
  62                 # This is potentially interesting here,
  63                 # given a INSERT SELECT
  64                 if($stub->{SQL} =~ /OFFSET \?$/) {
  65                         my @dummy = $stub->{SQL} =~ /\?/g;
  66                         $sth->bind_param(scalar(@dummy), 0, SQL_INTEGER);
  67                 }
  68         };
  69
  70         return sub {
  71                 eval { $sth->execute(@_) + 0 }; #force result to be a number
  72                 if($@) { confess($@) }
  73                 $sth->finish();
  74                 return $dbh->last_insert_id(undef, undef, undef, undef);;
  75         };
  76 }
  77
  78 sub create_scalar_stub($) {
  79         my ($stub) = @_;
  80
  81         my $sth;
  82
  83         proc_init {
  84                 $sth = $dbh->prepare($stub->{SQL});
  85                 if($stub->{SQL} =~ /OFFSET \?$/) {
  86                         my @dummy = $stub->{SQL} =~ /\?/g;
  87                         $sth->bind_param(scalar(@dummy), 0, SQL_INTEGER);
  88                 }
  89         };
  90
  91         return sub {
  92                 eval{ $sth->execute(@_); };
  93                 if($@) { confess($@) }
  94                 my $scalar;
  95                 eval{ ($scalar) = $sth->fetchrow_array; };
  96                 if($@) { confess($@) }
  97                 $sth->finish();
  98                 return $scalar;
  99         };
 100 }
 101
 102 sub create_arrayref_stub($) {
 103         my ($stub) = @_;
 104
 105         my $sth;
 106
 107         proc_init {
 108                 $sth = $dbh->prepare($stub->{SQL});
 109                 if($stub->{SQL} =~ /OFFSET \?$/) {
 110                         my @dummy = $stub->{SQL} =~ /\?/g;
 111                         $sth->bind_param(scalar(@dummy), 0, SQL_INTEGER);
 112                 }
 113         };
 114
 115         return sub {
 116                 eval{ $sth->execute(@_); };
 117                 if($@) { confess($@) }
 118                 return $sth->fetchall_arrayref;
 119         };
 120 }
 121
 122 sub create_array_stub($) {
 123         my ($stub) = @_;
 124
 125         my $sth;
 126
 127         proc_init {
 128                 $sth = $dbh->prepare($stub->{SQL});
 129                 if($stub->{SQL} =~ /OFFSET \?$/) {
 130                         my @dummy = $stub->{SQL} =~ /\?/g;
 131                         $sth->bind_param(scalar(@dummy), 0, SQL_INTEGER);
 132                 }
 133         };
 134
 135         return sub {
 136                 eval{ $sth->execute(@_); };
 137                 if($@) { confess($@) }
 138                 my $arrayRef;
 139                 eval{ $arrayRef = $sth->fetchall_arrayref; };
 140                 if($@) { confess($@) }
 141                 $sth->finish();
 142                 return @$arrayRef;
 143         };
 144 }
 145
 146 sub create_column_stub($) {
 147         my ($stub) = @_;
 148
 149         my $sth;
 150
 151         proc_init {
 152                 $sth = $dbh->prepare($stub->{SQL});
 153 =cut
 154 # This isn't useful here.
 155                 if($stub->{SQL} =~ /OFFSET \?$/) {
 156                         my @dummy = $stub->{SQL} =~ /\?/g;
 157                         $sth->bind_param(scalar(@dummy), 0, SQL_INTEGER);
 158                 }
 159 =cut
 160         };
 161
 162         return sub {
 163                 eval{ $sth->execute(@_); };
 164                 if($@) { confess($@) }
 165                 my $arrayRef;
 166                 eval { $arrayRef = $sth->fetchall_arrayref; };
 167                 if($@) { confess($@) }
 168                 $sth->finish();
 169                 return map({ $_->[0] } @$arrayRef);
 170         };
 171 }
 172
 173 sub create_row_stub($) {
 174         my ($stub) = @_;
 175
 176         my $sth;
 177
 178         proc_init {
 179                 $sth = $dbh->prepare($stub->{SQL});
 180                 if($stub->{SQL} =~ /OFFSET \?$/) {
 181                         my @dummy = $stub->{SQL} =~ /\?/g;
 182                         $sth->bind_param(scalar(@dummy), 0, SQL_INTEGER);
 183                 }
 184         };
 185
 186         return sub {
 187                 $sth->execute(@_);
 188                 my @row = $sth->fetchrow_array;
 189                 $sth->finish();
 190                 return @row;
 191         };
 192 }
 193
 194 BEGIN {
 195         %types = (
 196                 NULL => \&create_null_stub,
 197                 SCALAR => \&create_scalar_stub,
 198                 ARRAYREF => \&create_arrayref_stub,
 199
 200                 ARRAY => \&create_array_stub,
 201                 ROW => \&create_row_stub,
 202                 COLUMN => \&create_column_stub,
 203                 INSERT => \&create_insert_stub,
 204         );
 205 }
 206
 207 sub export_stub($$$) {
 208         my ($name, $proto, $code) = @_;
 209
 210         no strict 'refs';
 211
 212         *{$name} = eval "sub $proto { goto &\$code }";
 213 }
 214
 215 sub import {
 216         my (undef, $ins) = @_;
 217
 218         while(my ($name, $args) = each %$ins) {
 219                 my $stub = {
 220                         NAME => $name,
 221                         TYPE => $args->[0],
 222                         SQL => $args->[1],
 223                 };
 224
 225                 my @params = $stub->{SQL} =~ /\?/g;
 226
 227                 $stub->{PROTO} = '(' . ('$' x @params) . ')';
 228                 print "$stub->{NAME} $stub->{PROTO}\n" if DEBUG;
 229
 230                 export_stub scalar(caller) . '::' . $stub->{NAME}, $stub->{PROTO}, $types{$stub->{TYPE}}->($stub);
 231         }
 232 }
 233
 234 1;
 235
 236 =head1 SYNOPSIS
 237
 238  use SrSv::MySQL::Stub {
 239         get_all_foo => ['ARRAYREF', "SELECT * FROM foo"],
 240         is_foo_valid => ['SCALAR', "SELECT 1 FROM foo WHERE id=? AND valid=1"],
 241         delete_foo => ['NULL', "DELETE FROM foo WHERE id=?"],
 242
 243         get_all_foo_array => ['ARRAY', "SELECT * FROM foo"],
 244         get_column_foo => ['COLUMN', "SELECT col FROM foo"],
 245         get_row_foo => ['ROW', "SELECT * FROM foo LIMIT 1"],
 246         insert_foo > ['INSERT', "INSERT INTO foo (foo,bar) VALUES (?,?)"],
 247  };
 248
 249 =head1 DESCRIPTION
 250
 251 This module is a convenient way to make lots of subroutines that execute
 252 SQL statements.
 253
 254 =head1 USAGE
 255
 256   my @listOfListrefs = get_all_foo_array(...);
 257   my $listrefOfListrefs = get_all_foo(...);
 258   my $scalar = is_foo_valid(...);
 259   my $success = delete_foo(...);
 260
 261 type ARRAYREF is for legacy code only, I doubt anyone will want to use
 262 it for new code. ARRAY returns a list of listrefs, while ARRAYREF
 263 returns a listref of listrefs.
 264
 265 NULL returns success or failure. Technically, number of columns
 266 affected. Thus sometimes it may not have FAILED, but as it had no
 267 effect, it will return zero.
 268
 269 INSERT returns the last INSERT ID in the current execution context. This
 270 basically means that if your table has a PRIMARY KEY AUTO_INCREMENT, it
 271 will return the value of that primary key.
 272
 273 COLUMN returns a list consisting of a single column (the first, if there
 274 are more than one in the SELECT).
 275
 276 ROW is like column, but returns an array of only a single row.
 277
 278 =cut