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