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   return unless (@row);
 257   return $self->_construct_object(@row);
 258 }
 259
 260 sub _construct_object {
 261   my ($self, @row) = @_;
 262   my @cols = @{ $self->{attrs}{as} };
 263   #warn "@cols -> @row";
 264   my (%me, %pre);
 265   foreach my $col (@cols) {
 266     if ($col =~ /([^\.]+)\.([^\.]+)/) {
 267       $pre{$1}[0]{$2} = shift @row;
 268     } else {
 269       $me{$col} = shift @row;
 270     }
 271   }
 272   my $new = $self->{source}->result_class->inflate_result(
 273               $self->{source}, \%me, \%pre);
 274   $new = $self->{attrs}{record_filter}->($new)
 275     if exists $self->{attrs}{record_filter};
 276   return $new;
 277 }
 278
 279 =head2 count
 280
 281 Performs an SQL C<COUNT> with the same query as the resultset was built
 282 with to find the number of elements. If passed arguments, does a search
 283 on the resultset and counts the results of that.
 284
 285 =cut
 286
 287 sub count {
 288   my $self = shift;
 289   return $self->search(@_)->count if @_ && defined $_[0];
 290   croak "Unable to ->count with a GROUP BY" if defined $self->{attrs}{group_by};
 291   unless (defined $self->{count}) {
 292     my $attrs = { %{ $self->{attrs} },
 293                   select => { 'count' => '*' },
 294                   as => [ 'count' ] };
 295     # offset, order by and page are not needed to count. record_filter is cdbi
 296     delete $attrs->{$_} for qw/rows offset order_by page pager record_filter/;
 297
 298     ($self->{count}) = (ref $self)->new($self->{source}, $attrs)->cursor->next;
 299   }
 300   return 0 unless $self->{count};
 301   my $count = $self->{count};
 302   $count -= $self->{attrs}{offset} if $self->{attrs}{offset};
 303   $count = $self->{attrs}{rows} if
 304     ($self->{attrs}{rows} && $self->{attrs}{rows} < $count);
 305   return $count;
 306 }
 307
 308 =head2 count_literal
 309
 310 Calls search_literal with the passed arguments, then count.
 311
 312 =cut
 313
 314 sub count_literal { shift->search_literal(@_)->count; }
 315
 316 =head2 all
 317
 318 Returns all elements in the resultset. Called implictly if the resultset
 319 is returned in list context.
 320
 321 =cut
 322
 323 sub all {
 324   my ($self) = @_;
 325   return map { $self->_construct_object(@$_); }
 326            $self->cursor->all;
 327 }
 328
 329 =head2 reset
 330
 331 Resets the resultset's cursor, so you can iterate through the elements again.
 332
 333 =cut
 334
 335 sub reset {
 336   my ($self) = @_;
 337   $self->cursor->reset;
 338   return $self;
 339 }
 340
 341 =head2 first
 342
 343 Resets the resultset and returns the first element.
 344
 345 =cut
 346
 347 sub first {
 348   return $_[0]->reset->next;
 349 }
 350
 351 =head2 update(\%values)
 352
 353 Sets the specified columns in the resultset to the supplied values
 354
 355 =cut
 356
 357 sub update {
 358   my ($self, $values) = @_;
 359   croak "Values for update must be a hash" unless ref $values eq 'HASH';
 360   return $self->{source}->storage->update(
 361            $self->{source}->from, $values, $self->{cond});
 362 }
 363
 364 =head2 update_all(\%values)
 365
 366 Fetches all objects and updates them one at a time. ->update_all will run
 367 cascade triggers, ->update will not.
 368
 369 =cut
 370
 371 sub update_all {
 372   my ($self, $values) = @_;
 373   croak "Values for update must be a hash" unless ref $values eq 'HASH';
 374   foreach my $obj ($self->all) {
 375     $obj->set_columns($values)->update;
 376   }
 377   return 1;
 378 }
 379
 380 =head2 delete
 381
 382 Deletes the contents of the resultset from its result source.
 383
 384 =cut
 385
 386 sub delete {
 387   my ($self) = @_;
 388   $self->{source}->storage->delete($self->{source}->from, $self->{cond});
 389   return 1;
 390 }
 391
 392 =head2 delete_all
 393
 394 Fetches all objects and deletes them one at a time. ->delete_all will run
 395 cascade triggers, ->delete will not.
 396
 397 =cut
 398
 399 sub delete_all {
 400   my ($self) = @_;
 401   $_->delete for $self->all;
 402   return 1;
 403 }
 404
 405 =head2 pager
 406
 407 Returns a L<Data::Page> object for the current resultset. Only makes
 408 sense for queries with page turned on.
 409
 410 =cut
 411
 412 sub pager {
 413   my ($self) = @_;
 414   my $attrs = $self->{attrs};
 415   croak "Can't create pager for non-paged rs" unless $self->{page};
 416   $attrs->{rows} ||= 10;
 417   $self->count;
 418   return $self->{pager} ||= Data::Page->new(
 419     $self->{count}, $attrs->{rows}, $self->{page});
 420 }
 421
 422 =head2 page($page_num)
 423
 424 Returns a new resultset for the specified page.
 425
 426 =cut
 427
 428 sub page {
 429   my ($self, $page) = @_;
 430   my $attrs = { %{$self->{attrs}} };
 431   $attrs->{page} = $page;
 432   return (ref $self)->new($self->{source}, $attrs);
 433 }
 434
 435 =head2 new_result(\%vals)
 436
 437 Creates a result in the resultset's result class
 438
 439 =cut
 440
 441 sub new_result {
 442   my ($self, $values) = @_;
 443   $self->{source}->result_class->throw( "new_result needs a hash" )
 444     unless (ref $values eq 'HASH');
 445   $self->{source}->result_class->throw( "Can't abstract implicit construct, condition not a hash" )
 446     if ($self->{cond} && !(ref $self->{cond} eq 'HASH'));
 447   my %new = %$values;
 448   my $alias = $self->{attrs}{alias};
 449   foreach my $key (keys %{$self->{cond}||{}}) {
 450     $new{$1} = $self->{cond}{$key} if ($key =~ m/^(?:$alias\.)?([^\.]+)$/);
 451   }
 452   my $obj = $self->{source}->result_class->new(\%new);
 453   $obj->result_source($self->{source}) if $obj->can('result_source');
 454   $obj;
 455 }
 456
 457 =head2 create(\%vals)
 458
 459 Inserts a record into the resultset and returns the object
 460
 461 Effectively a shortcut for ->new_result(\%vals)->insert
 462
 463 =cut
 464
 465 sub create {
 466   my ($self, $attrs) = @_;
 467   $self->{source}->result_class->throw( "create needs a hashref" ) unless ref $attrs eq 'HASH';
 468   return $self->new_result($attrs)->insert;
 469 }
 470
 471 =head2 find_or_create(\%vals)
 472
 473   $class->find_or_create({ key => $val, ... });
 474
 475 Searches for a record matching the search condition; if it doesn't find one,
 476 creates one and returns that instead.
 477
 478 =cut
 479
 480 sub find_or_create {
 481   my $self     = shift;
 482   my $hash     = ref $_[0] eq "HASH" ? shift: {@_};
 483   my $exists   = $self->find($hash);
 484   return defined($exists) ? $exists : $self->create($hash);
 485 }
 486
 487 =head1 ATTRIBUTES
 488
 489 The resultset takes various attributes that modify its behavior.
 490 Here's an overview of them:
 491
 492 =head2 order_by
 493
 494 Which column(s) to order the results by. This is currently passed
 495 through directly to SQL, so you can give e.g. C<foo DESC> for a
 496 descending order.
 497
 498 =head2 cols (arrayref)
 499
 500 Shortcut to request a particular set of columns to be retrieved - adds
 501 'me.' onto the start of any column without a '.' in it and sets 'select'
 502 from that, then auto-populates 'as' from 'select' as normal
 503
 504 =head2 select (arrayref)
 505
 506 Indicates which columns should be selected from the storage
 507
 508 =head2 as (arrayref)
 509
 510 Indicates column names for object inflation
 511
 512 =head2 join
 513
 514 Contains a list of relationships that should be joined for this query. Can also
 515 contain a hash reference to refer to that relation's relations. So, if one column
 516 in your class C<belongs_to> foo and another C<belongs_to> bar, you can do
 517 C<< join => [qw/ foo bar /] >> to join both (and e.g. use them for C<order_by>).
 518 If a foo contains many margles and you want to join those too, you can do
 519 C<< join => { foo => 'margle' } >>. If you want to fetch the columns from the
 520 related table as well, see C<prefetch> below.
 521
 522 =head2 prefetch
 523
 524 Contains a list of relationships that should be fetched along with the main
 525 query (when they are accessed afterwards they will have already been
 526 "prefetched"). This is useful for when you know you will need the related
 527 object(s), because it saves a query. Currently limited to prefetching
 528 one relationship deep, so unlike C<join>, prefetch must be an arrayref.
 529
 530 =head2 from
 531
 532 This attribute can contain a arrayref of elements. Each element can be another
 533 arrayref, to nest joins, or it can be a hash which represents the two sides
 534 of the join.
 535
 536 NOTE: Use this on your own risk. This allows you to shoot your foot off!
 537
 538 =head2 page
 539
 540 For a paged resultset, specifies which page to retrieve. Leave unset
 541 for an unpaged resultset.
 542
 543 =head2 rows
 544
 545 For a paged resultset, how many rows per page
 546
 547 =head2 group_by (listref)
 548
 549 A listref of columns to group by (note that 'count' doesn't work on grouped
 550 resultsets)
 551
 552   group_by => [qw/ column1 column2 ... /]
 553
 554 =head2 distinct
 555
 556 Set to 1 to group by all columns
 557
 558 =cut
 559
 560 1;