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