lib/DBIx/Class/ResultSet.pm

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