lib/DBIx/Class/ResultSet.pm

   1 package DBIx::Class::ResultSet;
   2
   3 use strict;
   4 use warnings;
   5 use Carp qw/croak/;
   6 use overload
   7         '0+'     => 'count',
   8         'bool'   => sub { 1; },
   9         fallback => 1;
  10 use Data::Page;
  11 use Storable;
  12
  13 =head1 NAME
  14
  15 DBIx::Class::ResultSet - Responsible for fetching and creating resultset.
  16
  17 =head1 SYNOPSIS
  18
  19 my $rs = MyApp::DB::Class->search(registered => 1);
  20 my @rows = MyApp::DB::Class->search(foo => 'bar');
  21
  22 =head1 DESCRIPTION
  23
  24 The resultset is also known as an iterator. It is responsible for handling
  25 queries that may return an arbitrary number of rows, e.g. via C<search>
  26 or a C<has_many> relationship.
  27
  28 =head1 METHODS
  29
  30 =head2 new($source, \%$attrs)
  31
  32 The resultset constructor. Takes a source object (usually a DBIx::Class::Table)
  33 and an attribute hash (see below for more information on attributes). Does
  34 not perform any queries -- these are executed as needed by the other methods.
  35
  36 =cut
  37
  38 sub new {
  39   my $class = shift;
  40   return $class->new_result(@_) if ref $class;
  41   my ($source, $attrs) = @_;
  42   #use Data::Dumper; warn Dumper($attrs);
  43   $attrs = Storable::dclone($attrs || {}); # { %{ $attrs || {} } };
  44   my %seen;
  45   my $alias = ($attrs->{alias} ||= 'me');
  46   if (!$attrs->{select}) {
  47     my @cols = ($attrs->{cols}
  48                  ? @{delete $attrs->{cols}}
  49                  : $source->result_class->_select_columns);
  50     $attrs->{select} = [ map { m/\./ ? $_ : "${alias}.$_" } @cols ];
  51   }
  52   $attrs->{as} ||= [ map { m/^$alias\.(.*)$/ ? $1 : $_ } @{$attrs->{select}} ];
  53   #use Data::Dumper; warn Dumper(@{$attrs}{qw/select as/});
  54   $attrs->{from} ||= [ { $alias => $source->from } ];
  55   if (my $join = delete $attrs->{join}) {
  56     foreach my $j (ref $join eq 'ARRAY'
  57               ? (@{$join}) : ($join)) {
  58       if (ref $j eq 'HASH') {
  59         $seen{$_} = 1 foreach keys %$j;
  60       } else {
  61         $seen{$j} = 1;
  62       }
  63     }
  64     push(@{$attrs->{from}}, $source->resolve_join($join, $attrs->{alias}));
  65   }
  66   $attrs->{group_by} ||= $attrs->{select} if delete $attrs->{distinct};
  67   foreach my $pre (@{delete $attrs->{prefetch} || []}) {
  68     push(@{$attrs->{from}}, $source->resolve_join($pre, $attrs->{alias}))
  69       unless $seen{$pre};
  70     my @pre =
  71       map { "$pre.$_" }
  72       $source->related_source($pre)->columns;
  73     push(@{$attrs->{select}}, @pre);
  74     push(@{$attrs->{as}}, @pre);
  75   }
  76   if ($attrs->{page}) {
  77     $attrs->{rows} ||= 10;
  78     $attrs->{offset} ||= 0;
  79     $attrs->{offset} += ($attrs->{rows} * ($attrs->{page} - 1));
  80   }
  81   my $new = {
  82     source => $source,
  83     cond => $attrs->{where},
  84     from => $attrs->{from},
  85     count => undef,
  86     page => delete $attrs->{page},
  87     pager => undef,
  88     attrs => $attrs };
  89   bless ($new, $class);
  90   return $new;
  91 }
  92
  93 =head2 search
  94
  95   my @obj    = $rs->search({ foo => 3 }); # "... WHERE foo = 3"
  96   my $new_rs = $rs->search({ foo => 3 });
  97
  98 If you need to pass in additional attributes but no additional condition,
  99 call it as ->search(undef, \%attrs);
 100
 101   my @all = $class->search({}, { cols => [qw/foo bar/] }); # "SELECT foo, bar FROM $class_table"
 102
 103 =cut
 104
 105 sub search {
 106   my $self = shift;
 107
 108   #use Data::Dumper;warn Dumper(@_);
 109
 110   my $attrs = { %{$self->{attrs}} };
 111   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 112     $attrs = { %$attrs, %{ pop(@_) } };
 113   }
 114
 115   my $where = (@_ ? ((@_ == 1 || ref $_[0] eq "HASH") ? shift : {@_}) : undef());
 116   if (defined $where) {
 117     $where = (defined $attrs->{where}
 118                 ? { '-and' =>
 119                     [ map { ref $_ eq 'ARRAY' ? [ -or => $_ ] : $_ }
 120                         $where, $attrs->{where} ] }
 121                 : $where);
 122     $attrs->{where} = $where;
 123   }
 124
 125   my $rs = (ref $self)->new($self->{source}, $attrs);
 126
 127   return (wantarray ? $rs->all : $rs);
 128 }
 129
 130 =head2 search_literal
 131   my @obj    = $rs->search_literal($literal_where_cond, @bind);
 132   my $new_rs = $rs->search_literal($literal_where_cond, @bind);
 133
 134 Pass a literal chunk of SQL to be added to the conditional part of the
 135 resultset
 136
 137 =cut
 138
 139 sub search_literal {
 140   my ($self, $cond, @vals) = @_;
 141   my $attrs = (ref $vals[$#vals] eq 'HASH' ? { %{ pop(@vals) } } : {});
 142   $attrs->{bind} = [ @{$self->{attrs}{bind}||[]}, @vals ];
 143   return $self->search(\$cond, $attrs);
 144 }
 145
 146 =head2 find(@colvalues), find(\%cols)
 147
 148 Finds a row based on its primary key(s).
 149
 150 =cut
 151
 152 sub find {
 153   my ($self, @vals) = @_;
 154   my $attrs = (@vals > 1 && ref $vals[$#vals] eq 'HASH' ? pop(@vals) : {});
 155   my @pk = $self->{source}->primary_columns;
 156   #use Data::Dumper; warn Dumper($attrs, @vals, @pk);
 157   $self->{source}->result_class->throw( "Can't find unless primary columns are defined" )
 158     unless @pk;
 159   my $query;
 160   if (ref $vals[0] eq 'HASH') {
 161     $query = $vals[0];
 162   } elsif (@pk == @vals) {
 163     $query = {};
 164     @{$query}{@pk} = @vals;
 165   } else {
 166     $query = {@vals};
 167   }
 168   #warn Dumper($query);
 169   # Useless -> disabled
 170   #$self->{source}->result_class->throw( "Can't find unless all primary keys are specified" )
 171   #  unless (keys %$query >= @pk); # If we check 'em we run afoul of uc/lc
 172                                   # column names etc. Not sure what to do yet
 173   return $self->search($query)->next;
 174 }
 175
 176 =head2 search_related
 177
 178   $rs->search_related('relname', $cond?, $attrs?);
 179
 180 =cut
 181
 182 sub search_related {
 183   my ($self, $rel, @rest) = @_;
 184   my $rel_obj = $self->{source}->relationship_info($rel);
 185   $self->{source}->result_class->throw(
 186     "No such relationship ${rel} in search_related")
 187       unless $rel_obj;
 188   my $rs = $self->search(undef, { join => $rel });
 189   return $self->{source}->schema->resultset($rel_obj->{class}
 190            )->search( undef,
 191              { %{$rs->{attrs}},
 192                alias => $rel,
 193                select => undef(),
 194                as => undef() }
 195            )->search(@rest);
 196 }
 197
 198 =head2 cursor
 199
 200 Returns a storage-driven cursor to the given resultset.
 201
 202 =cut
 203
 204 sub cursor {
 205   my ($self) = @_;
 206   my ($source, $attrs) = @{$self}{qw/source attrs/};
 207   $attrs = { %$attrs };
 208   return $self->{cursor}
 209     ||= $source->storage->select($self->{from}, $attrs->{select},
 210           $attrs->{where},$attrs);
 211 }
 212
 213 =head2 search_like
 214
 215 Identical to search except defaults to 'LIKE' instead of '=' in condition
 216
 217 =cut
 218
 219 sub search_like {
 220   my $class    = shift;
 221   my $attrs = { };
 222   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 223     $attrs = pop(@_);
 224   }
 225   my $query    = ref $_[0] eq "HASH" ? { %{shift()} }: {@_};
 226   $query->{$_} = { 'like' => $query->{$_} } for keys %$query;
 227   return $class->search($query, { %$attrs });
 228 }
 229
 230 =head2 slice($first, $last)
 231
 232 Returns a subset of elements from the resultset.
 233
 234 =cut
 235
 236 sub slice {
 237   my ($self, $min, $max) = @_;
 238   my $attrs = { %{ $self->{attrs} || {} } };
 239   $attrs->{offset} ||= 0;
 240   $attrs->{offset} += $min;
 241   $attrs->{rows} = ($max ? ($max - $min + 1) : 1);
 242   my $slice = (ref $self)->new($self->{source}, $attrs);
 243   return (wantarray ? $slice->all : $slice);
 244 }
 245
 246 =head2 next
 247
 248 Returns the next element in the resultset (undef is there is none).
 249
 250 =cut
 251
 252 sub next {
 253   my ($self) = @_;
 254   my @row = $self->cursor->next;
 255   return unless (@row);
 256   return $self->_construct_object(@row);
 257 }
 258
 259 sub _construct_object {
 260   my ($self, @row) = @_;
 261   my @cols = @{ $self->{attrs}{as} };
 262   #warn "@cols -> @row";
 263   my (%me, %pre);
 264   foreach my $col (@cols) {
 265     if ($col =~ /([^\.]+)\.([^\.]+)/) {
 266       $pre{$1}[0]{$2} = shift @row;
 267     } else {
 268       $me{$col} = shift @row;
 269     }
 270   }
 271   my $new = $self->{source}->result_class->inflate_result(
 272               $self->{source}, \%me, \%pre);
 273   $new = $self->{attrs}{record_filter}->($new)
 274     if exists $self->{attrs}{record_filter};
 275   return $new;
 276 }
 277
 278 =head2 count
 279
 280 Performs an SQL C<COUNT> with the same query as the resultset was built
 281 with to find the number of elements. If passed arguments, does a search
 282 on the resultset and counts the results of that.
 283
 284 =cut
 285
 286 sub count {
 287   my $self = shift;
 288   return $self->search(@_)->count if @_ && defined $_[0];
 289   croak "Unable to ->count with a GROUP BY" if defined $self->{attrs}{group_by};
 290   unless (defined $self->{count}) {
 291     my $attrs = { %{ $self->{attrs} },
 292                   select => { 'count' => '*' },
 293                   as => [ 'count' ] };
 294     # offset, order by and page are not needed to count. record_filter is cdbi
 295     delete $attrs->{$_} for qw/rows offset order_by page pager record_filter/;
 296
 297     ($self->{count}) = (ref $self)->new($self->{source}, $attrs)->cursor->next;
 298   }
 299   return 0 unless $self->{count};
 300   my $count = $self->{count};
 301   $count -= $self->{attrs}{offset} if $self->{attrs}{offset};
 302   $count = $self->{attrs}{rows} if
 303     ($self->{attrs}{rows} && $self->{attrs}{rows} < $count);
 304   return $count;
 305 }
 306
 307 =head2 count_literal
 308
 309 Calls search_literal with the passed arguments, then count.
 310
 311 =cut
 312
 313 sub count_literal { shift->search_literal(@_)->count; }
 314
 315 =head2 all
 316
 317 Returns all elements in the resultset. Called implictly if the resultset
 318 is returned in list context.
 319
 320 =cut
 321
 322 sub all {
 323   my ($self) = @_;
 324   return map { $self->_construct_object(@$_); }
 325            $self->cursor->all;
 326 }
 327
 328 =head2 reset
 329
 330 Resets the resultset's cursor, so you can iterate through the elements again.
 331
 332 =cut
 333
 334 sub reset {
 335   my ($self) = @_;
 336   $self->cursor->reset;
 337   return $self;
 338 }
 339
 340 =head2 first
 341
 342 Resets the resultset and returns the first element.
 343
 344 =cut
 345
 346 sub first {
 347   return $_[0]->reset->next;
 348 }
 349
 350 =head2 update(\%values)
 351
 352 Sets the specified columns in the resultset to the supplied values
 353
 354 =cut
 355
 356 sub update {
 357   my ($self, $values) = @_;
 358   croak "Values for update must be a hash" unless ref $values eq 'HASH';
 359   return $self->{source}->storage->update(
 360            $self->{source}->from, $values, $self->{cond});
 361 }
 362
 363 =head2 update_all(\%values)
 364
 365 Fetches all objects and updates them one at a time. ->update_all will run
 366 cascade triggers, ->update will not.
 367
 368 =cut
 369
 370 sub update_all {
 371   my ($self, $values) = @_;
 372   croak "Values for update must be a hash" unless ref $values eq 'HASH';
 373   foreach my $obj ($self->all) {
 374     $obj->set_columns($values)->update;
 375   }
 376   return 1;
 377 }
 378
 379 =head2 delete
 380
 381 Deletes the contents of the resultset from its result source.
 382
 383 =cut
 384
 385 sub delete {
 386   my ($self) = @_;
 387   $self->{source}->storage->delete($self->{source}->from, $self->{cond});
 388   return 1;
 389 }
 390
 391 =head2 delete_all
 392
 393 Fetches all objects and deletes them one at a time. ->delete_all will run
 394 cascade triggers, ->delete will not.
 395
 396 =cut
 397
 398 sub delete_all {
 399   my ($self) = @_;
 400   $_->delete for $self->all;
 401   return 1;
 402 }
 403
 404 =head2 pager
 405
 406 Returns a L<Data::Page> object for the current resultset. Only makes
 407 sense for queries with page turned on.
 408
 409 =cut
 410
 411 sub pager {
 412   my ($self) = @_;
 413   my $attrs = $self->{attrs};
 414   croak "Can't create pager for non-paged rs" unless $self->{page};
 415   $attrs->{rows} ||= 10;
 416   $self->count;
 417   return $self->{pager} ||= Data::Page->new(
 418     $self->{count}, $attrs->{rows}, $self->{page});
 419 }
 420
 421 =head2 page($page_num)
 422
 423 Returns a new resultset for the specified page.
 424
 425 =cut
 426
 427 sub page {
 428   my ($self, $page) = @_;
 429   my $attrs = { %{$self->{attrs}} };
 430   $attrs->{page} = $page;
 431   return (ref $self)->new($self->{source}, $attrs);
 432 }
 433
 434 =head2 new_result(\%vals)
 435
 436 Creates a result in the resultset's result class
 437
 438 =cut
 439
 440 sub new_result {
 441   my ($self, $values) = @_;
 442   $self->{source}->result_class->throw( "new_result needs a hash" )
 443     unless (ref $values eq 'HASH');
 444   $self->{source}->result_class->throw( "Can't abstract implicit construct, condition not a hash" )
 445     if ($self->{cond} && !(ref $self->{cond} eq 'HASH'));
 446   my %new = %$values;
 447   my $alias = $self->{attrs}{alias};
 448   foreach my $key (keys %{$self->{cond}||{}}) {
 449     $new{$1} = $self->{cond}{$key} if ($key =~ m/^(?:$alias\.)?([^\.]+)$/);
 450   }
 451   my $obj = $self->{source}->result_class->new(\%new);
 452   $obj->result_source($self->{source}) if $obj->can('result_source');
 453   $obj;
 454 }
 455
 456 =head2 create(\%vals)
 457
 458 Inserts a record into the resultset and returns the object
 459
 460 Effectively a shortcut for ->new_result(\%vals)->insert
 461
 462 =cut
 463
 464 sub create {
 465   my ($self, $attrs) = @_;
 466   $self->{source}->result_class->throw( "create needs a hashref" ) unless ref $attrs eq 'HASH';
 467   return $self->new_result($attrs)->insert;
 468 }
 469
 470 =head2 find_or_create(\%vals)
 471
 472   $class->find_or_create({ key => $val, ... });
 473
 474 Searches for a record matching the search condition; if it doesn't find one,
 475 creates one and returns that instead.
 476
 477 =cut
 478
 479 sub find_or_create {
 480   my $self     = shift;
 481   my $hash     = ref $_[0] eq "HASH" ? shift: {@_};
 482   my $exists   = $self->find($hash);
 483   return defined($exists) ? $exists : $self->create($hash);
 484 }
 485
 486 =head1 ATTRIBUTES
 487
 488 The resultset takes various attributes that modify its behavior.
 489 Here's an overview of them:
 490
 491 =head2 order_by
 492
 493 Which column(s) to order the results by. This is currently passed
 494 through directly to SQL, so you can give e.g. C<foo DESC> for a
 495 descending order.
 496
 497 =head2 cols (arrayref)
 498
 499 Shortcut to request a particular set of columns to be retrieved - adds
 500 'me.' onto the start of any column without a '.' in it and sets 'select'
 501 from that, then auto-populates 'as' from 'select' as normal
 502
 503 =head2 select (arrayref)
 504
 505 Indicates which columns should be selected from the storage
 506
 507 =head2 as (arrayref)
 508
 509 Indicates column names for object inflation
 510
 511 =head2 join
 512
 513 Contains a list of relationships that should be joined for this query. Can also
 514 contain a hash reference to refer to that relation's relations. So, if one column
 515 in your class C<belongs_to> foo and another C<belongs_to> bar, you can do
 516 C<< join => [qw/ foo bar /] >> to join both (and e.g. use them for C<order_by>).
 517 If a foo contains many margles and you want to join those too, you can do
 518 C<< join => { foo => 'margle' } >>. If you want to fetch the columns from the
 519 related table as well, see C<prefetch> below.
 520
 521 =head2 prefetch
 522
 523 Contains a list of relationships that should be fetched along with the main
 524 query (when they are accessed afterwards they will have already been
 525 "prefetched"). This is useful for when you know you will need the related
 526 object(s), because it saves a query. Currently limited to prefetching
 527 one relationship deep, so unlike C<join>, prefetch must be an arrayref.
 528
 529 =head2 from
 530
 531 This attribute can contain a arrayref of elements. Each element can be another
 532 arrayref, to nest joins, or it can be a hash which represents the two sides
 533 of the join.
 534
 535 NOTE: Use this on your own risk. This allows you to shoot your foot off!
 536
 537 =head2 page
 538
 539 For a paged resultset, specifies which page to retrieve. Leave unset
 540 for an unpaged resultset.
 541
 542 =head2 rows
 543
 544 For a paged resultset, how many rows per page
 545
 546 =head2 group_by (listref)
 547
 548 A listref of columns to group by (note that 'count' doesn't work on grouped
 549 resultsets)
 550
 551   group_by => [qw/ column1 column2 ... /]
 552
 553 =head2 distinct
 554
 555 Set to 1 to group by all columns
 556
 557 =cut
 558
 559 1;