site/cgi-bin/modules/Squirrel/Table.pm

   1 package Squirrel::Table;
   2
   3 use vars qw($VERSION);
   4 use Carp;
   5 use strict;
   6
   7 $VERSION = "0.11";
   8
   9 use BSE::DB;
  10
  11 my $dh = BSE::DB->single;
  12
  13 my %query_cache;
  14 my $cache_queries;
  15
  16 # no caching is performed if this is zero
  17 my $cache_timeout = 2; # seconds
  18
  19 # cache of loaded tables
  20 # this prevents us from reloading the table so often
  21 # key is the table class name, value is a hash ref with two keys:
  22 #  table - the table object
  23 #  when - time value when the object was created.
  24 # Table::add() invalidates the cache for the given class
  25 my %cache;
  26
  27 sub new {
  28   my ($class, $nocache) = @_;
  29
  30   return $cache{$class}{table}
  31     if !$nocache
  32       && exists $cache{$class}
  33       && defined $cache{$class}{time}
  34       && $cache{$class}{time}+$cache_timeout >= time;
  35
  36   my $sth = $dh->stmt($class)
  37     or confess "No $class member in DatabaseHandle";
  38   $sth->execute
  39     or confess "Cannot execute $class handle from DatabaseHandle:",DBI->errstr;
  40
  41   my %coll;
  42   my @order;
  43   my $rowClass = $class->rowClass;
  44   (my $reqName = $rowClass) =~ s!::!/!g;
  45   require $reqName.".pm";
  46   while (my $row = $sth->fetchrow_arrayref) {
  47     my $item = $rowClass->new(@$row);
  48     $coll{$item->{pkey}} = $item;
  49     push(@order, $item);
  50
  51   }
  52
  53   my $result = bless { ptr=>-1, coll=>\%coll, order=>\@order }, $class;
  54
  55   if ($cache_timeout) {
  56     $cache{$class}{table} = $result;
  57     $cache{$class}{when} = time;
  58   }
  59
  60   return $result;
  61 }
  62
  63 sub EOF {
  64   my $self = shift;
  65
  66   ++$self->{ptr} >= @{$self->{order}};
  67 }
  68
  69 sub getNext {
  70   my $self = shift;
  71   return $self->{order}[$self->{ptr}];
  72 }
  73
  74 sub getByPkey {
  75   my ($self, @values) = @_;
  76
  77   my $class = ref($self) || $self;
  78   my $key = "$class getByPkey ".join("\x01", @values);
  79   my $desc = "getByPkey valuesquery";
  80   if ($cache_queries) {
  81     #print STDERR "Checking for $desc\n";
  82     if (exists $query_cache{$key}) {
  83      # print STDERR "Found query getBy @query\n";
  84       return $query_cache{$key};
  85     }
  86   }
  87
  88   my $result;
  89   if (ref($self)) {
  90     $result = $self->{coll}{join "", @values};
  91   }
  92   else {
  93     # try to get row by key
  94     my $rowClass = $self->rowClass;
  95     (my $reqName = $rowClass) =~ s!::!/!g;
  96     require $reqName . ".pm";
  97     my $member = "get${rowClass}ByPkey";
  98     my $sth = $dh->stmt_noerror($member);
  99     unless ($sth) {
 100       my @cols = ( $rowClass->primary );
 101       my %vals;
 102       @vals{@cols} = @values;
 103       $sth ||= $self->_getBy_sth($member, \@cols, \%vals);
 104     }
 105     $sth
 106       or confess "No $member in BSE::DB";
 107     $sth->execute(@values)
 108       or confess "Cannot execute $member handle from DatabaseHandle:", DBI->errstr;
 109     # should only be one row
 110     if (my $row = $sth->fetchrow_arrayref) {
 111       $result = $rowClass->new(@$row);
 112     }
 113     else {
 114       $result = undef;
 115     }
 116     $sth->finish;
 117   }
 118   $query_cache{$key} = $result if $cache_queries;
 119
 120   return $result;
 121 }
 122
 123 sub add {
 124   my ($self, @data) = @_;
 125
 126   (my $rowRequire = $self->rowClass) =~ s!::!/!g;
 127   require $rowRequire.".pm";
 128   my $item = $self->rowClass->new(undef, @data);
 129
 130   # if called as an instance method
 131   if (ref($self)) {
 132     delete $cache{ref $self};
 133     $self->{coll}{$item->{pkey}} = $item;
 134     push(@{$self->{order}}, $item);
 135   }
 136   else {
 137     delete $cache{ref $self};
 138   }
 139
 140   return $item;
 141 }
 142
 143 # get all values in a particular column
 144 sub getAll {
 145   my ($self, $column) = @_;
 146   my @values = map { $_->{$column} } @{$self->{order}};
 147
 148   return wantarray ? @values : \@values;
 149 }
 150
 151 sub caching {
 152   my ($self, $value) = @_;
 153
 154   $cache_queries = $value;
 155   unless ($value) {
 156     %query_cache = ();
 157   }
 158 }
 159
 160 # column grep
 161 sub getBy {
 162   my ($self, @query) = @_;
 163   my @cols;
 164   my %vals;
 165
 166   @query % 2 == 0
 167     or confess "Odd number of arguments supplied to getBy()";
 168
 169   my $class = ref($self) || $self;
 170   my $key = "$class getBy ".join("\x01", @query);
 171   my $desc = "getBy @query";
 172   if ($cache_queries) {
 173     #print STDERR "Checking for $desc\n";
 174     if (my $entry = $query_cache{$key}) {
 175      # print STDERR "Found query getBy @query\n";
 176       return wantarray ? @$entry : $entry->[0];
 177     }
 178   }
 179
 180   while (my ($col, $val) = splice(@query, 0, 2)) {
 181     push(@cols, $col);
 182     $vals{$col} = $val;
 183   }
 184
 185   my @results;
 186   if (ref($self) && UNIVERSAL::isa($self, __PACKAGE__)) {
 187     # this is an object with the rows already loaded
 188     for my $row (@{$self->{order}}) {
 189       my %comp;
 190       @comp{@cols} =
 191         map ref $row->{$_} ? $row->{$_}->getPkey : $row->{$_}, @cols;
 192       push @results, $row if @cols == grep $comp{$_} eq $vals{$_}, @cols;
 193     }
 194   }
 195   else {
 196     # ask the database directly
 197     my $rowClass = $self->rowClass;
 198     (my $reqName = $rowClass) =~ s!::!/!g;
 199     require $reqName . ".pm";
 200     my $member = "get${rowClass}By".join("And", map "\u$_", @cols);
 201     my $sth = $dh->stmt_noerror($member);
 202     $sth ||= $self->_getBy_sth($member, \@cols, \%vals);
 203     $sth
 204       or confess "No $member in BSE::DB";
 205     $sth->execute(@vals{@cols})
 206       or confess "Cannot execute $member from BSE::DB: ",DBI->errstr;
 207     while (my $row = $sth->fetchrow_arrayref) {
 208       push(@results, $rowClass->new(@$row));
 209     }
 210   }
 211
 212   if ($cache_queries) {
 213     #print STDERR "Saving $desc\n";
 214     $query_cache{$key} = \@results;
 215   }
 216
 217   return wantarray ? @results : $results[0];
 218 }
 219
 220 sub _getBy_sth {
 221   my ($self, $name, $cols, $vals) = @_;
 222
 223   my $bases = $self->rowClass->bases;
 224   keys %$bases
 225     and confess "No statement $name found and cannot generate";
 226
 227   my @db_cols = $self->rowClass->db_columns;
 228   my @code_cols = $self->rowClass->columns;
 229   my %map;
 230   @map{@code_cols} = @db_cols;
 231
 232   my @conds;
 233   for my $col (@$cols) {
 234     my $db_col = $map{$col}
 235       or confess "Cannot generate $name: unknown column $col";
 236     # this doesn't handle null, but that should use a "special"
 237     push @conds, "$db_col = ?";
 238   }
 239
 240   my $sql = "select " . join(",", @db_cols) .
 241     " from " . $self->rowClass->table .
 242       " where " . join(" and ", @conds);
 243
 244   my $sth = $dh->{dbh}->prepare($sql)
 245     or confess "Cannot prepare generated $sql: ", $dh->{dbh}->errstr;
 246
 247   return $sth;
 248 }
 249
 250 sub getColumnsBy {
 251   my ($self, $cols, %find) = @_;
 252
 253   my @db_cols = $self->rowClass->db_columns;
 254   my @code_cols = $self->rowClass->columns;
 255   my %map;
 256   @map{@code_cols} = @db_cols;
 257
 258   my @conds;
 259   my @args;
 260   for my $col (keys %find) {
 261     my $db_col = $map{$col}
 262       or confess "Cannot generate query: unknown column $col";
 263     # this doesn't handle null, but that should use a "special"
 264     push @conds, "$db_col = ?";
 265     push @args, $find{$col};
 266   }
 267   my @result_cols = map $map{$_}, @$cols;
 268
 269   my $sql = "select " . join(",", @result_cols) .
 270     " from " . $self->rowClass->table .
 271       " where " . join(" and ", @conds);
 272
 273   my $sth = $dh->{dbh}->prepare($sql)
 274     or confess "Cannot prepare generated $sql: ", $dh->{dbh}->errstr;
 275
 276   $sth->execute(@args)
 277     or confess "Cannot execute $sql: ",$dh->{dbh}->errstr;
 278
 279   my @rows;
 280   while (my $row = $sth->fetchrow_arrayref) {
 281     my %row;
 282     @row{@$cols} = @$row;
 283     push @rows, \%row;
 284   }
 285
 286   return wantarray ? @rows : \@rows;
 287 }
 288
 289 sub getSpecial {
 290   my ($self, $name, @args) = @_;
 291
 292   my $class = ref($self) || $self;
 293   my $key = "$class getSpecial $name ".join("\x01", @args);
 294   my $desc = "getSpecial $name @args";
 295   if ($cache_queries) {
 296     #print STDERR "Checking for $desc\n";
 297     if (my $entry = $query_cache{$key}) {
 298      # print STDERR "Found query getBy @query\n";
 299       return wantarray ? @$entry : $entry;
 300     }
 301   }
 302
 303   my $rowClass = $self->rowClass;
 304   my $sqlname = $class . "." . $name;
 305   my $sth = $dh->stmt($sqlname)
 306     or confess "No $sqlname in database object";
 307   $sth->execute(@args)
 308     or confess "Cannot execute $sqlname: ", $sth->errstr;
 309   my @results;
 310   while (my $row = $sth->fetchrow_arrayref) {
 311     push(@results, $rowClass->new(@$row));
 312   }
 313
 314   if ($cache_queries) {
 315     #print STDERR "Saving $desc\n";
 316     $query_cache{$key} = \@results;
 317   }
 318
 319   wantarray ? @results : \@results;
 320 }
 321
 322 sub doSpecial {
 323   my ($self, $name, @args) = @_;
 324
 325   my $class = ref $self ? ref $self : $self;
 326   my $sqlname = $class . "." . $name;
 327   my $sth = $dh->stmt($sqlname)
 328     or confess "No $sqlname in database object";
 329   $sth->execute(@args)
 330     or confess "Cannot execute $sqlname: ", $sth->errstr;
 331
 332   return $sth->rows;
 333 }
 334
 335 # a list of all rows in select order
 336 sub all {
 337   my $self = shift;
 338
 339   unless (ref $self) {
 340     $self = $self->new();
 341   }
 342
 343   return @{$self->{order}};
 344 }
 345
 346 sub query {
 347   my ($self, $columns, $query, $opts) = @_;
 348
 349   $dh->generate_query($self->rowClass, $columns, $query, $opts);
 350 }
 351
 352 sub make {
 353   my ($self, %values) = @_;
 354
 355   my @cols = $self->rowClass->columns;
 356   my %defaults = $self->rowClass->defaults;
 357   shift @cols; # presumably the generated private key
 358   my @values;
 359   for my $col (@cols) {
 360     my $value;
 361     # a defined test is inappropriate here, the caller might want to
 362     # set a column to null.
 363     if (exists $values{$col}) {
 364       $value = delete $values{$col};
 365     }
 366     elsif (exists $defaults{$col}) {
 367       $value = $defaults{$col};
 368     }
 369     else {
 370       confess "No value or default supplied for $col";
 371     }
 372     push @values, $value;
 373   }
 374   keys %values
 375     and confess "Extra values ", join(",", keys %values), " supplied to ${self}->make()";
 376
 377   return $self->add(@values);
 378 }
 379
 380 1;
 381
 382 __END__
 383
 384 =head1 NAME
 385
 386 Base class for tables.
 387
 388 =head1 DESCRIPTION
 389
 390 This needs more documentation.
 391
 392 =head1 IMPLEMENT IN THE BASE
 393
 394 =over 4
 395
 396 =item rowClass()
 397
 398 Returns the name of the class implementing the rows for this class.
 399
 400 =back
 401
 402 =head1 IMPLEMENT IN DatabaseHandle
 403
 404 =head1 METHODS
 405
 406 Some methods can be used as both class and instance methods.
 407
 408 In these cases when used as a class method they ask the database
 409 directly for the information.  This requires that appropriate keys be
 410 defined in the DatabaseHandle object.
 411
 412 In the examples SomeTable is used as the name of the table class
 413 derived from Squirell::Table.
 414
 415 =over 4
 416
 417 =item $table = SomeTable->new
 418
 419 Loads the contents of the table into memory.
 420
 421 =item until ($table->EOF) { ... }
 422
 423 Bumps the index into the table, returns TRUE if we've passed the end
 424 of the table.
 425
 426 =item $row = $table->getNext
 427
 428 Gets the currently indexed item in the table.
 429
 430 =item $row = $table->getByPkey(@values)
 431
 432 =item $row = SomeTable->getByPkey(@values)
 433
 434 Retrieves the specified row from the database.
 435
 436 For the class method version to work you must have a statement handle
 437 in the DatabaseHandle object called get${rowClass}ByPkey.
 438
 439 =item $row = $table->add(@data)
 440
 441 =item $row = SomeTable->add(@data)
 442
 443 Adds a row to the table.  @data must contain all except the primary key.
 444
 445 =item @rows = $table->getAll($column)
 446
 447 Returns a list containing that column for each row in the table.
 448
 449 Returns an array ref if called in a scalar context.
 450
 451 =item @rows = $table->getBy($column, $value)
 452
 453 =item @rows = SomeTable->getBy($column, $value)
 454
 455 Returns any rows where the given column has that value.
 456
 457 Returns the first element of the list if called in scalar context
 458 (though it still retrieves the whole lot.)
 459
 460 For the class method form to work the DatabaseHandle object must have
 461 a member "get${rowClass}By\u$column".
 462
 463 =back
 464
 465 =cut
 466