lib/SQLAbstraction.pm

   1 package SQLAbstraction;
   2 use Carp;
   3
   4 use strict;
   5
   6 =head1 NAME
   7
   8 SQLAbstraction - Simplified interface to DBI.
   9
  10 =head1 SYNOPSIS
  11
  12
  13 =head1 DESCRIPTION
  14
  15 =head2 Constructor
  16
  17 =cut
  18
  19 use fields qw/die_on_error dbh dbh_errstr/;
  20
  21 sub new {
  22   my SQLAbstraction $self = shift;
  23   my ( $p, $first ) = @_;
  24
  25   if ( not ref $self ) {
  26     $self = fields::new($self);
  27   }
  28
  29   my @required_params = qw( );
  30   my %optional_params = ( die_on_error => 1 );
  31
  32   # Initialize new properties.
  33   $self->init( $p, \@required_params, \%optional_params );
  34
  35   $self->check_unknown( $p, $first );
  36   return $self;
  37 }
  38
  39 sub init {
  40   my SQLAbstraction $self = shift;
  41
  42   my ( $p, $required, $optional ) = @_;
  43
  44   foreach my $param ( keys %{$optional} ) {
  45     if ( exists( $p->{$param} ) ) {
  46       $self->{$param} = $p->{$param};
  47       delete( $p->{$param} );
  48     }
  49     else {
  50       $self->{$param} = $optional->{$param};
  51     }
  52   }
  53
  54   foreach my $param ( @{$required} ) {
  55     if ( exists( $p->{$param} ) ) {
  56       $self->{$param} = $p->{$param};
  57       delete( $p->{$param} );
  58     }
  59     else {
  60       croak "Missing required parameter $param for " . ref($self);
  61     }
  62   }
  63 }
  64
  65 sub check_unknown {
  66   my SQLAbstraction $self = shift;
  67   my ( $p, $first ) = @_;
  68
  69   if ( not( defined($first) ) and ( scalar( %{$p} ) ) ) {
  70     my ($callingclass) = caller;
  71     croak "Unknown parameters to " . $callingclass . "::new " . join ", ",
  72       keys %{$p};
  73   }
  74 }
  75
  76 sub DESTROY {
  77   my SQLAbstraction $self = shift;
  78
  79   $self->{dbh}->disconnect()
  80     if defined( $self->{dbh} );
  81 }
  82
  83 =head2 Methods
  84
  85 =over 4
  86
  87 =item Connect
  88
  89   $sa->Connect();
  90
  91 =cut
  92
  93 sub Connect {
  94   my $self = shift();
  95
  96   die "You need to override Connect()";
  97
  98 }
  99
 100 =over 4
 101
 102 =item Count( $table, $args )
 103
 104 Return the number of records in table $table matching $args. $table should
 105 be a string containing the name of a table, $args should be a hash-reference
 106 with field-names and values.
 107
 108 =cut
 109
 110 sub Count {
 111   my $self = shift;
 112   my ( $table, $args ) = @_;
 113
 114   my $dbh = $self->{dbh};
 115
 116   my @where  = ("(1)");
 117   my @values = ();
 118
 119   map { push @where, "($_ = ?)"; push @values, $args->{$_}; }
 120     sort keys %{$args};
 121
 122   my $where = join " and ", @where;
 123   my $sql = "select count(*) from $table where $where";
 124
 125   my $sth = $dbh->prepare($sql)
 126     or die "Prepare failed. $sql\nError: " . $dbh->errstr;
 127
 128   $sth->execute(@values)
 129     or die "Execute failed. $sql\nError: " . $dbh->errstr;
 130
 131   my $aref = $sth->fetchrow_arrayref;
 132   my $res  = $aref->[0];
 133   $sth->finish;
 134   return $res;
 135 }
 136
 137 =item Delete( $table, $args )
 138
 139 Delete all records in table $table matching $args. $table should
 140 be a string containing the name of a table, $args should be a hash-reference
 141 with field-names and values. Returns the number of deleted records.
 142
 143 =cut
 144
 145 sub Delete {
 146   my $self = shift;
 147   my ( $table, $args ) = @_;
 148
 149   my $dbh = $self->{dbh};
 150
 151   my @where  = ("(1)");
 152   my @values = ();
 153
 154   map { push @where, "($_ = ?)"; push @values, $args->{$_}; }
 155     sort keys %{$args};
 156
 157   my $where = join " and ", @where;
 158   my $sql = "delete from $table where $where";
 159
 160   my $sth = $dbh->prepare_cached($sql)
 161     or die "Prepare failed. $sql\nError: " . $dbh->errstr;
 162
 163   my $res = $sth->execute(@values);
 164   $sth->finish;
 165
 166   return $res;
 167 }
 168
 169 =item Add( $table, $values, $die_on_error )
 170
 171 Add a new record to a table. $table should be a string containing the name
 172 of a table, $values should be a hash-reference with field-names and values.
 173 $die_on_error defaults to $self->{die_on_error}.
 174 Returns the primary key assigned to the new record or -1 if the Add failed.
 175
 176 =cut
 177
 178 sub Add {
 179   my $self = shift;
 180   my ( $table, $args, $die_on_error ) = @_;
 181
 182   $die_on_error = $self->{die_on_error} unless defined($die_on_error);
 183
 184   my $dbh = $self->{dbh};
 185
 186   my @fields = ();
 187   my @values = ();
 188
 189   map { push @fields, "$_ = ?"; push @values, $args->{$_}; }
 190     sort keys %{$args};
 191
 192   my $fields = join ", ", @fields;
 193   my $sql = "insert into $table set $fields";
 194
 195   my $sth = $dbh->prepare_cached($sql)
 196     or die "Prepare failed. $sql\nError: " . $dbh->errstr;
 197
 198   $sth->{PrintError} = 0;
 199
 200   if ( not $sth->execute(@values) ) {
 201     if ( $die_on_error ) {
 202       die "Execute failed. $sql\nError: " . $dbh->errstr;
 203     }
 204     else {
 205       $self->{dbh_errstr} = $dbh->errstr;
 206       $sth->finish();
 207       return -1;
 208     }
 209   }
 210
 211   $sth->finish();
 212
 213   return $self->last_inserted_id();
 214 }
 215
 216 =item Update( $table, $args, $new_values )
 217
 218 Update all records matching $args. $table should be a string containing the name of a table, $args and $new_values should be a hash-reference with field-names and values. Returns the number of updated records.
 219
 220 Example:
 221     $ds->Update( "users", { uid => 1 },
 222                  { lastname => "Holmlund",
 223                    firstname => "Mattias" } );
 224
 225 =cut
 226
 227 sub Update {
 228   my $self = shift;
 229   my ( $table, $args, $new_values ) = @_;
 230
 231   my $dbh = $self->{dbh};
 232
 233   my @where  = ("(1)");
 234   my @values = ();
 235
 236   map { push @where, "($_ = ?)"; push @values, $args->{$_}; }
 237     sort keys %{$args};
 238
 239   my $where = join " and ", @where;
 240
 241   my @set       = ();
 242   my @setvalues = ();
 243   map { push @set, "$_ = ?"; push @setvalues, $new_values->{$_}; }
 244     sort keys %{$new_values};
 245
 246   my $setexpr = join ", ", @set;
 247
 248   my $sql = "UPDATE $table SET $setexpr WHERE $where";
 249
 250   my $sth = $dbh->prepare($sql)
 251     or die "Prepare failed. $sql\nError: " . $dbh->errstr;
 252
 253   my $res = $sth->execute( @setvalues, @values )
 254     or die "Execute failed. $sql\nError: " . $dbh->errstr;
 255
 256   $sth->finish();
 257
 258   return $res;
 259 }
 260
 261
 262 sub _BuildLookup {
 263   my $self = shift;
 264   my ( $table, $args, $field, $order ) = @_;
 265
 266   my $dbh = $self->{dbh};
 267
 268   my @where  = ("(1)");
 269   my @values = ();
 270
 271   map { push @where, "($_ = ?)"; push @values, $args->{$_}; }
 272     sort keys %{$args};
 273
 274   my $where = join " and ", @where;
 275
 276   my $sql;
 277
 278   if ( defined $field ) {
 279     $sql = "SELECT $field FROM $table WHERE $where";
 280   }
 281   else {
 282     $sql = "SELECT * FROM $table WHERE $where";
 283   }
 284
 285   if( defined( $order ) and ( scalar( @{$order} ) > 0 ) ) {
 286     $sql .= " ORDER BY " . join( ", ", @{$order} );
 287   }
 288
 289   my $sth = $dbh->prepare_cached($sql)
 290     or die "Prepare failed. $sql\nError: " . $dbh->errstr;
 291
 292   my $res = $sth->execute(@values)
 293     or die "Execute failed. $sql\nError: " . $dbh->errstr;
 294
 295   return $sth;
 296 }
 297
 298 =item Lookup( $table, $args [, $field] )
 299
 300 Retrieve values from a record. $table should be a string containing the name
 301 of a table, $args should be a hash-reference with field-names and values.
 302 If $field is specified, it should be the name of a field in the record and
 303 Lookup will then return the contents of that field. If $field is undef,
 304 a hash-reference with all fields and values in the record is returned.
 305
 306 If $args fails to identify one unique record, undef is returned.
 307
 308 =cut
 309
 310 sub Lookup {
 311   my $self = shift;
 312   my ( $table, $args, $field ) = @_;
 313
 314   my $sth = $self->_BuildLookup( $table, $args, $field );
 315
 316   my $row = $sth->fetchrow_hashref;
 317
 318   if ( not defined($row) ) {
 319     $sth->finish();
 320     return undef;
 321   }
 322
 323   my $row2 = $sth->fetchrow_hashref;
 324   $sth->finish();
 325
 326   die "More than one record returned from $table"
 327       if ( defined $row2 );
 328
 329   return $row->{$field} if defined $field;
 330   return $row;
 331 }
 332
 333 =item LookupMany( $table, $args[, $order,  $limit] )
 334
 335 Retrieve values from several records. $table should be a string
 336 containing the name of a table, $args should be a hash-reference with
 337 field-names and values.  Returns a reference to an array containing
 338 hashrefs for each record.
 339
 340 $order is an arrayref containing expressions to sort on.
 341
 342 $limit can be used to limit the number of records returned. Defaults to
 343 using no limit.
 344
 345 =cut
 346
 347 sub LookupMany {
 348   my $self = shift;
 349   my ( $table, $args, $order, $limit ) = @_;
 350
 351   my $sth = $self->_BuildLookup( $table, $args, undef, $order );
 352
 353   my $res = $sth->fetchall_arrayref( {}, $limit );
 354
 355   $sth->finish();
 356   return $res;
 357 }
 358
 359 =item LookupManySql( $sql[, $argarray] )
 360
 361 Lookup possibly may records using an SQL expression. $sql should be a
 362 string that can be sent to $dbh->prepare(). $argarray can be a
 363 reference to an array of arguments that matches $sql.
 364
 365 Returns a reference to an array containing hashrefs for each record.
 366
 367 =cut
 368
 369 sub LookupManySql {
 370   my $self = shift;
 371   my ( $sql, $argarray ) = @_;
 372
 373   $argarray = [] if not defined $argarray;
 374
 375   my $dbh = $self->{dbh};
 376
 377   my $sth = $dbh->prepare_cached($sql)
 378     or die "Prepare failed. $sql\nError: " . $dbh->errstr;
 379
 380   my $res = $sth->execute(@{$argarray})
 381     or die "Execute failed. $sql\nError: " . $dbh->errstr;
 382
 383   $res = $sth->fetchall_arrayref( {} );
 384
 385   $sth->finish();
 386   return $res;
 387 }
 388
 389 =item Iterate
 390
 391 Same as Lookup, but returns a dbi statement handle that can be used
 392 as an iterator. Can also take several field-arguments.
 393
 394 =cut
 395
 396 sub Iterate {
 397   my $self = shift;
 398   my ( $table, $args, @fields ) = @_;
 399
 400   my $dbh = $self->{dbh};
 401
 402   my @where  = ("(1)");
 403   my @values = ();
 404
 405   map { push @where, "($_ = ?)"; push @values, $args->{$_}; }
 406     sort keys %{$args};
 407
 408   my $where = join " and ", @where;
 409
 410   my $sql;
 411
 412   if ( scalar(@fields) > 0 ) {
 413     $sql = "SELECT " . join( ",", @fields ) . " FROM $table WHERE $where";
 414   }
 415   else {
 416     $sql = "SELECT * FROM $table WHERE $where";
 417   }
 418
 419   my $sth = $dbh->prepare($sql)
 420     or die "Prepare failed. $sql\nError: " . $dbh->errstr;
 421
 422   my $res = $sth->execute(@values)
 423     or die "Execute failed. $sql\nError: " . $dbh->errstr;
 424
 425   return undef if $res == 0;
 426
 427   return $sth;
 428 }
 429
 430 sub Sql {
 431   my SQLAbstraction $self = shift;
 432   my ( $sqlexpr, $values ) = @_;
 433
 434   my $dbh = $self->{dbh};
 435
 436   my $sth = $dbh->prepare($sqlexpr)
 437     or die "Prepare failed. $sqlexpr\nError: " . $dbh->errstr;
 438
 439   my $res = $sth->execute( @{$values} )
 440     or die "Execute failed. $sqlexpr\nError: " . $dbh->errstr;
 441
 442   return ( $res, $sth );
 443 }
 444
 445 sub DoSql {
 446   my SQLAbstraction $self = shift;
 447   my ( $sqlexpr, $values ) = @_;
 448
 449   my ( $res, $sth ) = $self->Sql( $sqlexpr, $values );
 450
 451   $sth->finish();
 452 }
 453
 454 =item errstr
 455
 456 Return the error message from the latest failed operation.
 457
 458 =cut
 459
 460 sub errstr {
 461   my $self = shift;
 462
 463   return $self->{dbh}->errstr;
 464 }
 465
 466 =head1 COPYRIGHT
 467
 468 Copyright (C) 2007 Mattias Holmlund.
 469
 470 =cut
 471
 472 1;
 473
 474 ### Setup coding system
 475 ## Local Variables:
 476 ## coding: utf-8
 477 ## End:
 478