lib/DBIx/Class/ResultSet.pm

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