1package DBIx::Class::ResultSource; 2 3use strict; 4use warnings; 5 6use base qw/DBIx::Class::ResultSource::RowParser DBIx::Class/; 7 8use DBIx::Class::ResultSet; 9use DBIx::Class::ResultSourceHandle; 10 11use DBIx::Class::Carp; 12use DBIx::Class::_Util 'UNRESOLVABLE_CONDITION'; 13use SQL::Abstract::Util 'is_literal_value'; 14use Devel::GlobalDestruction; 15use Try::Tiny; 16use Scalar::Util qw/blessed weaken isweak/; 17 18use namespace::clean; 19 20__PACKAGE__->mk_group_accessors(simple => qw/ 21 source_name name source_info 22 _ordered_columns _columns _primaries _unique_constraints 23 _relationships resultset_attributes 24 column_info_from_storage 25/); 26 27__PACKAGE__->mk_group_accessors(component_class => qw/ 28 resultset_class 29 result_class 30/); 31 32__PACKAGE__->mk_classdata( sqlt_deploy_callback => 'default_sqlt_deploy_hook' ); 33 34=head1 NAME 35 36DBIx::Class::ResultSource - Result source object 37 38=head1 SYNOPSIS 39 40 # Create a table based result source, in a result class. 41 42 package MyApp::Schema::Result::Artist; 43 use base qw/DBIx::Class::Core/; 44 45 __PACKAGE__->table('artist'); 46 __PACKAGE__->add_columns(qw/ artistid name /); 47 __PACKAGE__->set_primary_key('artistid'); 48 __PACKAGE__->has_many(cds => 'MyApp::Schema::Result::CD'); 49 50 1; 51 52 # Create a query (view) based result source, in a result class 53 package MyApp::Schema::Result::Year2000CDs; 54 use base qw/DBIx::Class::Core/; 55 56 __PACKAGE__->load_components('InflateColumn::DateTime'); 57 __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); 58 59 __PACKAGE__->table('year2000cds'); 60 __PACKAGE__->result_source_instance->is_virtual(1); 61 __PACKAGE__->result_source_instance->view_definition( 62 "SELECT cdid, artist, title FROM cd WHERE year ='2000'" 63 ); 64 65 66=head1 DESCRIPTION 67 68A ResultSource is an object that represents a source of data for querying. 69 70This class is a base class for various specialised types of result 71sources, for example L<DBIx::Class::ResultSource::Table>. Table is the 72default result source type, so one is created for you when defining a 73result class as described in the synopsis above. 74 75More specifically, the L<DBIx::Class::Core> base class pulls in the 76L<DBIx::Class::ResultSourceProxy::Table> component, which defines 77the L<table|DBIx::Class::ResultSourceProxy::Table/table> method. 78When called, C<table> creates and stores an instance of 79L<DBIx::Class::ResultSource::Table>. Luckily, to use tables as result 80sources, you don't need to remember any of this. 81 82Result sources representing select queries, or views, can also be 83created, see L<DBIx::Class::ResultSource::View> for full details. 84 85=head2 Finding result source objects 86 87As mentioned above, a result source instance is created and stored for 88you when you define a 89L<Result Class|DBIx::Class::Manual::Glossary/Result Class>. 90 91You can retrieve the result source at runtime in the following ways: 92 93=over 94 95=item From a Schema object: 96 97 $schema->source($source_name); 98 99=item From a Result object: 100 101 $result->result_source; 102 103=item From a ResultSet object: 104 105 $rs->result_source; 106 107=back 108 109=head1 METHODS 110 111=head2 new 112 113 $class->new(); 114 115 $class->new({attribute_name => value}); 116 117Creates a new ResultSource object. Not normally called directly by end users. 118 119=cut 120 121sub new { 122 my ($class, $attrs) = @_; 123 $class = ref $class if ref $class; 124 125 my $new = bless { %{$attrs || {}} }, $class; 126 $new->{resultset_class} ||= 'DBIx::Class::ResultSet'; 127 $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} }; 128 $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}]; 129 $new->{_columns} = { %{$new->{_columns}||{}} }; 130 $new->{_relationships} = { %{$new->{_relationships}||{}} }; 131 $new->{name} ||= "!!NAME NOT SET!!"; 132 $new->{_columns_info_loaded} ||= 0; 133 return $new; 134} 135 136=pod 137 138=head2 add_columns 139 140=over 141 142=item Arguments: @columns 143 144=item Return Value: L<$result_source|/new> 145 146=back 147 148 $source->add_columns(qw/col1 col2 col3/); 149 150 $source->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...); 151 152 $source->add_columns( 153 'col1' => { data_type => 'integer', is_nullable => 1, ... }, 154 'col2' => { data_type => 'text', is_auto_increment => 1, ... }, 155 ); 156 157Adds columns to the result source. If supplied colname => hashref 158pairs, uses the hashref as the L</column_info> for that column. Repeated 159calls of this method will add more columns, not replace them. 160 161The column names given will be created as accessor methods on your 162L<Result|DBIx::Class::Manual::ResultClass> objects. You can change the name of the accessor 163by supplying an L</accessor> in the column_info hash. 164 165If a column name beginning with a plus sign ('+col1') is provided, the 166attributes provided will be merged with any existing attributes for the 167column, with the new attributes taking precedence in the case that an 168attribute already exists. Using this without a hashref 169(C<< $source->add_columns(qw/+col1 +col2/) >>) is legal, but useless -- 170it does the same thing it would do without the plus. 171 172The contents of the column_info are not set in stone. The following 173keys are currently recognised/used by DBIx::Class: 174 175=over 4 176 177=item accessor 178 179 { accessor => '_name' } 180 181 # example use, replace standard accessor with one of your own: 182 sub name { 183 my ($self, $value) = @_; 184 185 die "Name cannot contain digits!" if($value =~ /\d/); 186 $self->_name($value); 187 188 return $self->_name(); 189 } 190 191Use this to set the name of the accessor method for this column. If unset, 192the name of the column will be used. 193 194=item data_type 195 196 { data_type => 'integer' } 197 198This contains the column type. It is automatically filled if you use the 199L<SQL::Translator::Producer::DBIx::Class::File> producer, or the 200L<DBIx::Class::Schema::Loader> module. 201 202Currently there is no standard set of values for the data_type. Use 203whatever your database supports. 204 205=item size 206 207 { size => 20 } 208 209The length of your column, if it is a column type that can have a size 210restriction. This is currently only used to create tables from your 211schema, see L<DBIx::Class::Schema/deploy>. 212 213 { size => [ 9, 6 ] } 214 215For decimal or float values you can specify an ArrayRef in order to 216control precision, assuming your database's 217L<SQL::Translator::Producer> supports it. 218 219=item is_nullable 220 221 { is_nullable => 1 } 222 223Set this to a true value for a column that is allowed to contain NULL 224values, default is false. This is currently only used to create tables 225from your schema, see L<DBIx::Class::Schema/deploy>. 226 227=item is_auto_increment 228 229 { is_auto_increment => 1 } 230 231Set this to a true value for a column whose value is somehow 232automatically set, defaults to false. This is used to determine which 233columns to empty when cloning objects using 234L<DBIx::Class::Row/copy>. It is also used by 235L<DBIx::Class::Schema/deploy>. 236 237=item is_numeric 238 239 { is_numeric => 1 } 240 241Set this to a true or false value (not C<undef>) to explicitly specify 242if this column contains numeric data. This controls how set_column 243decides whether to consider a column dirty after an update: if 244C<is_numeric> is true a numeric comparison C<< != >> will take place 245instead of the usual C<eq> 246 247If not specified the storage class will attempt to figure this out on 248first access to the column, based on the column C<data_type>. The 249result will be cached in this attribute. 250 251=item is_foreign_key 252 253 { is_foreign_key => 1 } 254 255Set this to a true value for a column that contains a key from a 256foreign table, defaults to false. This is currently only used to 257create tables from your schema, see L<DBIx::Class::Schema/deploy>. 258 259=item default_value 260 261 { default_value => \'now()' } 262 263Set this to the default value which will be inserted into a column by 264the database. Can contain either a value or a function (use a 265reference to a scalar e.g. C<\'now()'> if you want a function). This 266is currently only used to create tables from your schema, see 267L<DBIx::Class::Schema/deploy>. 268 269See the note on L<DBIx::Class::Row/new> for more information about possible 270issues related to db-side default values. 271 272=item sequence 273 274 { sequence => 'my_table_seq' } 275 276Set this on a primary key column to the name of the sequence used to 277generate a new key value. If not specified, L<DBIx::Class::PK::Auto> 278will attempt to retrieve the name of the sequence from the database 279automatically. 280 281=item retrieve_on_insert 282 283 { retrieve_on_insert => 1 } 284 285For every column where this is set to true, DBIC will retrieve the RDBMS-side 286value upon a new row insertion (normally only the autoincrement PK is 287retrieved on insert). C<INSERT ... RETURNING> is used automatically if 288supported by the underlying storage, otherwise an extra SELECT statement is 289executed to retrieve the missing data. 290 291=item auto_nextval 292 293 { auto_nextval => 1 } 294 295Set this to a true value for a column whose value is retrieved automatically 296from a sequence or function (if supported by your Storage driver.) For a 297sequence, if you do not use a trigger to get the nextval, you have to set the 298L</sequence> value as well. 299 300Also set this for MSSQL columns with the 'uniqueidentifier' 301L<data_type|DBIx::Class::ResultSource/data_type> whose values you want to 302automatically generate using C<NEWID()>, unless they are a primary key in which 303case this will be done anyway. 304 305=item extra 306 307This is used by L<DBIx::Class::Schema/deploy> and L<SQL::Translator> 308to add extra non-generic data to the column. For example: C<< extra 309=> { unsigned => 1} >> is used by the MySQL producer to set an integer 310column to unsigned. For more details, see 311L<SQL::Translator::Producer::MySQL>. 312 313=back 314 315=head2 add_column 316 317=over 318 319=item Arguments: $colname, \%columninfo? 320 321=item Return Value: 1/0 (true/false) 322 323=back 324 325 $source->add_column('col' => \%info); 326 327Add a single column and optional column info. Uses the same column 328info keys as L</add_columns>. 329 330=cut 331 332sub add_columns { 333 my ($self, @cols) = @_; 334 $self->_ordered_columns(\@cols) unless $self->_ordered_columns; 335 336 my @added; 337 my $columns = $self->_columns; 338 while (my $col = shift @cols) { 339 my $column_info = {}; 340 if ($col =~ s/^\+//) { 341 $column_info = $self->column_info($col); 342 } 343 344 # If next entry is { ... } use that for the column info, if not 345 # use an empty hashref 346 if (ref $cols[0]) { 347 my $new_info = shift(@cols); 348 %$column_info = (%$column_info, %$new_info); 349 } 350 push(@added, $col) unless exists $columns->{$col}; 351 $columns->{$col} = $column_info; 352 } 353 push @{ $self->_ordered_columns }, @added; 354 return $self; 355} 356 357sub add_column { shift->add_columns(@_); } # DO NOT CHANGE THIS TO GLOB 358 359=head2 has_column 360 361=over 362 363=item Arguments: $colname 364 365=item Return Value: 1/0 (true/false) 366 367=back 368 369 if ($source->has_column($colname)) { ... } 370 371Returns true if the source has a column of this name, false otherwise. 372 373=cut 374 375sub has_column { 376 my ($self, $column) = @_; 377 return exists $self->_columns->{$column}; 378} 379 380=head2 column_info 381 382=over 383 384=item Arguments: $colname 385 386=item Return Value: Hashref of info 387 388=back 389 390 my $info = $source->column_info($col); 391 392Returns the column metadata hashref for a column, as originally passed 393to L</add_columns>. See L</add_columns> above for information on the 394contents of the hashref. 395 396=cut 397 398sub column_info { 399 my ($self, $column) = @_; 400 $self->throw_exception("No such column $column") 401 unless exists $self->_columns->{$column}; 402 403 if ( ! $self->_columns->{$column}{data_type} 404 and ! $self->{_columns_info_loaded} 405 and $self->column_info_from_storage 406 and my $stor = try { $self->storage } ) 407 { 408 $self->{_columns_info_loaded}++; 409 410 # try for the case of storage without table 411 try { 412 my $info = $stor->columns_info_for( $self->from ); 413 my $lc_info = { map 414 { (lc $_) => $info->{$_} } 415 ( keys %$info ) 416 }; 417 418 foreach my $col ( keys %{$self->_columns} ) { 419 $self->_columns->{$col} = { 420 %{ $self->_columns->{$col} }, 421 %{ $info->{$col} || $lc_info->{lc $col} || {} } 422 }; 423 } 424 }; 425 } 426 427 return $self->_columns->{$column}; 428} 429 430=head2 columns 431 432=over 433 434=item Arguments: none 435 436=item Return Value: Ordered list of column names 437 438=back 439 440 my @column_names = $source->columns; 441 442Returns all column names in the order they were declared to L</add_columns>. 443 444=cut 445 446sub columns { 447 my $self = shift; 448 $self->throw_exception( 449 "columns() is a read-only accessor, did you mean add_columns()?" 450 ) if @_; 451 return @{$self->{_ordered_columns}||[]}; 452} 453 454=head2 columns_info 455 456=over 457 458=item Arguments: \@colnames ? 459 460=item Return Value: Hashref of column name/info pairs 461 462=back 463 464 my $columns_info = $source->columns_info; 465 466Like L</column_info> but returns information for the requested columns. If 467the optional column-list arrayref is omitted it returns info on all columns 468currently defined on the ResultSource via L</add_columns>. 469 470=cut 471 472sub columns_info { 473 my ($self, $columns) = @_; 474 475 my $colinfo = $self->_columns; 476 477 if ( 478 grep { ! $_->{data_type} } values %$colinfo 479 and 480 ! $self->{_columns_info_loaded} 481 and 482 $self->column_info_from_storage 483 and 484 my $stor = try { $self->storage } 485 ) { 486 $self->{_columns_info_loaded}++; 487 488 # try for the case of storage without table 489 try { 490 my $info = $stor->columns_info_for( $self->from ); 491 my $lc_info = { map 492 { (lc $_) => $info->{$_} } 493 ( keys %$info ) 494 }; 495 496 foreach my $col ( keys %$colinfo ) { 497 $colinfo->{$col} = { 498 %{ $colinfo->{$col} }, 499 %{ $info->{$col} || $lc_info->{lc $col} || {} } 500 }; 501 } 502 }; 503 } 504 505 my %ret; 506 507 if ($columns) { 508 for (@$columns) { 509 if (my $inf = $colinfo->{$_}) { 510 $ret{$_} = $inf; 511 } 512 else { 513 $self->throw_exception( sprintf ( 514 "No such column '%s' on source '%s'", 515 $_, 516 $self->source_name || $self->name || 'Unknown source...?', 517 )); 518 } 519 } 520 } 521 else { 522 %ret = %$colinfo; 523 } 524 525 return \%ret; 526} 527 528=head2 remove_columns 529 530=over 531 532=item Arguments: @colnames 533 534=item Return Value: not defined 535 536=back 537 538 $source->remove_columns(qw/col1 col2 col3/); 539 540Removes the given list of columns by name, from the result source. 541 542B<Warning>: Removing a column that is also used in the sources primary 543key, or in one of the sources unique constraints, B<will> result in a 544broken result source. 545 546=head2 remove_column 547 548=over 549 550=item Arguments: $colname 551 552=item Return Value: not defined 553 554=back 555 556 $source->remove_column('col'); 557 558Remove a single column by name from the result source, similar to 559L</remove_columns>. 560 561B<Warning>: Removing a column that is also used in the sources primary 562key, or in one of the sources unique constraints, B<will> result in a 563broken result source. 564 565=cut 566 567sub remove_columns { 568 my ($self, @to_remove) = @_; 569 570 my $columns = $self->_columns 571 or return; 572 573 my %to_remove; 574 for (@to_remove) { 575 delete $columns->{$_}; 576 ++$to_remove{$_}; 577 } 578 579 $self->_ordered_columns([ grep { not $to_remove{$_} } @{$self->_ordered_columns} ]); 580} 581 582sub remove_column { shift->remove_columns(@_); } # DO NOT CHANGE THIS TO GLOB 583 584=head2 set_primary_key 585 586=over 4 587 588=item Arguments: @cols 589 590=item Return Value: not defined 591 592=back 593 594Defines one or more columns as primary key for this source. Must be 595called after L</add_columns>. 596 597Additionally, defines a L<unique constraint|/add_unique_constraint> 598named C<primary>. 599 600Note: you normally do want to define a primary key on your sources 601B<even if the underlying database table does not have a primary key>. 602See 603L<DBIx::Class::Manual::Intro/The Significance and Importance of Primary Keys> 604for more info. 605 606=cut 607 608sub set_primary_key { 609 my ($self, @cols) = @_; 610 611 my $colinfo = $self->columns_info(\@cols); 612 for my $col (@cols) { 613 carp_unique(sprintf ( 614 "Primary key of source '%s' includes the column '%s' which has its " 615 . "'is_nullable' attribute set to true. This is a mistake and will cause " 616 . 'various Result-object operations to fail', 617 $self->source_name || $self->name || 'Unknown source...?', 618 $col, 619 )) if $colinfo->{$col}{is_nullable}; 620 } 621 622 $self->_primaries(\@cols); 623 624 $self->add_unique_constraint(primary => \@cols); 625} 626 627=head2 primary_columns 628 629=over 4 630 631=item Arguments: none 632 633=item Return Value: Ordered list of primary column names 634 635=back 636 637Read-only accessor which returns the list of primary keys, supplied by 638L</set_primary_key>. 639 640=cut 641 642sub primary_columns { 643 return @{shift->_primaries||[]}; 644} 645 646# a helper method that will automatically die with a descriptive message if 647# no pk is defined on the source in question. For internal use to save 648# on if @pks... boilerplate 649sub _pri_cols_or_die { 650 my $self = shift; 651 my @pcols = $self->primary_columns 652 or $self->throw_exception (sprintf( 653 "Operation requires a primary key to be declared on '%s' via set_primary_key", 654 # source_name is set only after schema-registration 655 $self->source_name || $self->result_class || $self->name || 'Unknown source...?', 656 )); 657 return @pcols; 658} 659 660# same as above but mandating single-column PK (used by relationship condition 661# inference) 662sub _single_pri_col_or_die { 663 my $self = shift; 664 my ($pri, @too_many) = $self->_pri_cols_or_die; 665 666 $self->throw_exception( sprintf( 667 "Operation requires a single-column primary key declared on '%s'", 668 $self->source_name || $self->result_class || $self->name || 'Unknown source...?', 669 )) if @too_many; 670 return $pri; 671} 672 673 674=head2 sequence 675 676Manually define the correct sequence for your table, to avoid the overhead 677associated with looking up the sequence automatically. The supplied sequence 678will be applied to the L</column_info> of each L<primary_key|/set_primary_key> 679 680=over 4 681 682=item Arguments: $sequence_name 683 684=item Return Value: not defined 685 686=back 687 688=cut 689 690sub sequence { 691 my ($self,$seq) = @_; 692 693 my @pks = $self->primary_columns 694 or return; 695 696 $_->{sequence} = $seq 697 for values %{ $self->columns_info (\@pks) }; 698} 699 700 701=head2 add_unique_constraint 702 703=over 4 704 705=item Arguments: $name?, \@colnames 706 707=item Return Value: not defined 708 709=back 710 711Declare a unique constraint on this source. Call once for each unique 712constraint. 713 714 # For UNIQUE (column1, column2) 715 __PACKAGE__->add_unique_constraint( 716 constraint_name => [ qw/column1 column2/ ], 717 ); 718 719Alternatively, you can specify only the columns: 720 721 __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]); 722 723This will result in a unique constraint named 724C<table_column1_column2>, where C<table> is replaced with the table 725name. 726 727Unique constraints are used, for example, when you pass the constraint 728name as the C<key> attribute to L<DBIx::Class::ResultSet/find>. Then 729only columns in the constraint are searched. 730 731Throws an error if any of the given column names do not yet exist on 732the result source. 733 734=cut 735 736sub add_unique_constraint { 737 my $self = shift; 738 739 if (@_ > 2) { 740 $self->throw_exception( 741 'add_unique_constraint() does not accept multiple constraints, use ' 742 . 'add_unique_constraints() instead' 743 ); 744 } 745 746 my $cols = pop @_; 747 if (ref $cols ne 'ARRAY') { 748 $self->throw_exception ( 749 'Expecting an arrayref of constraint columns, got ' . ($cols||'NOTHING') 750 ); 751 } 752 753 my $name = shift @_; 754 755 $name ||= $self->name_unique_constraint($cols); 756 757 foreach my $col (@$cols) { 758 $self->throw_exception("No such column $col on table " . $self->name) 759 unless $self->has_column($col); 760 } 761 762 my %unique_constraints = $self->unique_constraints; 763 $unique_constraints{$name} = $cols; 764 $self->_unique_constraints(\%unique_constraints); 765} 766 767=head2 add_unique_constraints 768 769=over 4 770 771=item Arguments: @constraints 772 773=item Return Value: not defined 774 775=back 776 777Declare multiple unique constraints on this source. 778 779 __PACKAGE__->add_unique_constraints( 780 constraint_name1 => [ qw/column1 column2/ ], 781 constraint_name2 => [ qw/column2 column3/ ], 782 ); 783 784Alternatively, you can specify only the columns: 785 786 __PACKAGE__->add_unique_constraints( 787 [ qw/column1 column2/ ], 788 [ qw/column3 column4/ ] 789 ); 790 791This will result in unique constraints named C<table_column1_column2> and 792C<table_column3_column4>, where C<table> is replaced with the table name. 793 794Throws an error if any of the given column names do not yet exist on 795the result source. 796 797See also L</add_unique_constraint>. 798 799=cut 800 801sub add_unique_constraints { 802 my $self = shift; 803 my @constraints = @_; 804 805 if ( !(@constraints % 2) && grep { ref $_ ne 'ARRAY' } @constraints ) { 806 # with constraint name 807 while (my ($name, $constraint) = splice @constraints, 0, 2) { 808 $self->add_unique_constraint($name => $constraint); 809 } 810 } 811 else { 812 # no constraint name 813 foreach my $constraint (@constraints) { 814 $self->add_unique_constraint($constraint); 815 } 816 } 817} 818 819=head2 name_unique_constraint 820 821=over 4 822 823=item Arguments: \@colnames 824 825=item Return Value: Constraint name 826 827=back 828 829 $source->table('mytable'); 830 $source->name_unique_constraint(['col1', 'col2']); 831 # returns 832 'mytable_col1_col2' 833 834Return a name for a unique constraint containing the specified 835columns. The name is created by joining the table name and each column 836name, using an underscore character. 837 838For example, a constraint on a table named C<cd> containing the columns 839C<artist> and C<title> would result in a constraint name of C<cd_artist_title>. 840 841This is used by L</add_unique_constraint> if you do not specify the 842optional constraint name. 843 844=cut 845 846sub name_unique_constraint { 847 my ($self, $cols) = @_; 848 849 my $name = $self->name; 850 $name = $$name if (ref $name eq 'SCALAR'); 851 $name =~ s/ ^ [^\.]+ \. //x; # strip possible schema qualifier 852 853 return join '_', $name, @$cols; 854} 855 856=head2 unique_constraints 857 858=over 4 859 860=item Arguments: none 861 862=item Return Value: Hash of unique constraint data 863 864=back 865 866 $source->unique_constraints(); 867 868Read-only accessor which returns a hash of unique constraints on this 869source. 870 871The hash is keyed by constraint name, and contains an arrayref of 872column names as values. 873 874=cut 875 876sub unique_constraints { 877 return %{shift->_unique_constraints||{}}; 878} 879 880=head2 unique_constraint_names 881 882=over 4 883 884=item Arguments: none 885 886=item Return Value: Unique constraint names 887 888=back 889 890 $source->unique_constraint_names(); 891 892Returns the list of unique constraint names defined on this source. 893 894=cut 895 896sub unique_constraint_names { 897 my ($self) = @_; 898 899 my %unique_constraints = $self->unique_constraints; 900 901 return keys %unique_constraints; 902} 903 904=head2 unique_constraint_columns 905 906=over 4 907 908=item Arguments: $constraintname 909 910=item Return Value: List of constraint columns 911 912=back 913 914 $source->unique_constraint_columns('myconstraint'); 915 916Returns the list of columns that make up the specified unique constraint. 917 918=cut 919 920sub unique_constraint_columns { 921 my ($self, $constraint_name) = @_; 922 923 my %unique_constraints = $self->unique_constraints; 924 925 $self->throw_exception( 926 "Unknown unique constraint $constraint_name on '" . $self->name . "'" 927 ) unless exists $unique_constraints{$constraint_name}; 928 929 return @{ $unique_constraints{$constraint_name} }; 930} 931 932=head2 sqlt_deploy_callback 933 934=over 935 936=item Arguments: $callback_name | \&callback_code 937 938=item Return Value: $callback_name | \&callback_code 939 940=back 941 942 __PACKAGE__->sqlt_deploy_callback('mycallbackmethod'); 943 944 or 945 946 __PACKAGE__->sqlt_deploy_callback(sub { 947 my ($source_instance, $sqlt_table) = @_; 948 ... 949 } ); 950 951An accessor to set a callback to be called during deployment of 952the schema via L<DBIx::Class::Schema/create_ddl_dir> or 953L<DBIx::Class::Schema/deploy>. 954 955The callback can be set as either a code reference or the name of a 956method in the current result class. 957 958Defaults to L</default_sqlt_deploy_hook>. 959 960Your callback will be passed the $source object representing the 961ResultSource instance being deployed, and the 962L<SQL::Translator::Schema::Table> object being created from it. The 963callback can be used to manipulate the table object or add your own 964customised indexes. If you need to manipulate a non-table object, use 965the L<DBIx::Class::Schema/sqlt_deploy_hook>. 966 967See L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To 968Your SQL> for examples. 969 970This sqlt deployment callback can only be used to manipulate 971SQL::Translator objects as they get turned into SQL. To execute 972post-deploy statements which SQL::Translator does not currently 973handle, override L<DBIx::Class::Schema/deploy> in your Schema class 974and call L<dbh_do|DBIx::Class::Storage::DBI/dbh_do>. 975 976=head2 default_sqlt_deploy_hook 977 978This is the default deploy hook implementation which checks if your 979current Result class has a C<sqlt_deploy_hook> method, and if present 980invokes it B<on the Result class directly>. This is to preserve the 981semantics of C<sqlt_deploy_hook> which was originally designed to expect 982the Result class name and the 983L<$sqlt_table instance|SQL::Translator::Schema::Table> of the table being 984deployed. 985 986=cut 987 988sub default_sqlt_deploy_hook { 989 my $self = shift; 990 991 my $class = $self->result_class; 992 993 if ($class and $class->can('sqlt_deploy_hook')) { 994 $class->sqlt_deploy_hook(@_); 995 } 996} 997 998sub _invoke_sqlt_deploy_hook { 999 my $self = shift; 1000 if ( my $hook = $self->sqlt_deploy_callback) { 1001 $self->$hook(@_); 1002 } 1003} 1004 1005=head2 result_class 1006 1007=over 4 1008 1009=item Arguments: $classname 1010 1011=item Return Value: $classname 1012 1013=back 1014 1015 use My::Schema::ResultClass::Inflator; 1016 ... 1017 1018 use My::Schema::Artist; 1019 ... 1020 __PACKAGE__->result_class('My::Schema::ResultClass::Inflator'); 1021 1022Set the default result class for this source. You can use this to create 1023and use your own result inflator. See L<DBIx::Class::ResultSet/result_class> 1024for more details. 1025 1026Please note that setting this to something like 1027L<DBIx::Class::ResultClass::HashRefInflator> will make every result unblessed 1028and make life more difficult. Inflators like those are better suited to 1029temporary usage via L<DBIx::Class::ResultSet/result_class>. 1030 1031=head2 resultset 1032 1033=over 4 1034 1035=item Arguments: none 1036 1037=item Return Value: L<$resultset|DBIx::Class::ResultSet> 1038 1039=back 1040 1041Returns a resultset for the given source. This will initially be created 1042on demand by calling 1043 1044 $self->resultset_class->new($self, $self->resultset_attributes) 1045 1046but is cached from then on unless resultset_class changes. 1047 1048=head2 resultset_class 1049 1050=over 4 1051 1052=item Arguments: $classname 1053 1054=item Return Value: $classname 1055 1056=back 1057 1058 package My::Schema::ResultSet::Artist; 1059 use base 'DBIx::Class::ResultSet'; 1060 ... 1061 1062 # In the result class 1063 __PACKAGE__->resultset_class('My::Schema::ResultSet::Artist'); 1064 1065 # Or in code 1066 $source->resultset_class('My::Schema::ResultSet::Artist'); 1067 1068Set the class of the resultset. This is useful if you want to create your 1069own resultset methods. Create your own class derived from 1070L<DBIx::Class::ResultSet>, and set it here. If called with no arguments, 1071this method returns the name of the existing resultset class, if one 1072exists. 1073 1074=head2 resultset_attributes 1075 1076=over 4 1077 1078=item Arguments: L<\%attrs|DBIx::Class::ResultSet/ATTRIBUTES> 1079 1080=item Return Value: L<\%attrs|DBIx::Class::ResultSet/ATTRIBUTES> 1081 1082=back 1083 1084 # In the result class 1085 __PACKAGE__->resultset_attributes({ order_by => [ 'id' ] }); 1086 1087 # Or in code 1088 $source->resultset_attributes({ order_by => [ 'id' ] }); 1089 1090Store a collection of resultset attributes, that will be set on every 1091L<DBIx::Class::ResultSet> produced from this result source. 1092 1093B<CAVEAT>: C<resultset_attributes> comes with its own set of issues and 1094bugs! While C<resultset_attributes> isn't deprecated per se, its usage is 1095not recommended! 1096 1097Since relationships use attributes to link tables together, the "default" 1098attributes you set may cause unpredictable and undesired behavior. Furthermore, 1099the defaults cannot be turned off, so you are stuck with them. 1100 1101In most cases, what you should actually be using are project-specific methods: 1102 1103 package My::Schema::ResultSet::Artist; 1104 use base 'DBIx::Class::ResultSet'; 1105 ... 1106 1107 # BAD IDEA! 1108 #__PACKAGE__->resultset_attributes({ prefetch => 'tracks' }); 1109 1110 # GOOD IDEA! 1111 sub with_tracks { shift->search({}, { prefetch => 'tracks' }) } 1112 1113 # in your code 1114 $schema->resultset('Artist')->with_tracks->... 1115 1116This gives you the flexibility of not using it when you don't need it. 1117 1118For more complex situations, another solution would be to use a virtual view 1119via L<DBIx::Class::ResultSource::View>. 1120 1121=cut 1122 1123sub resultset { 1124 my $self = shift; 1125 $self->throw_exception( 1126 'resultset does not take any arguments. If you want another resultset, '. 1127 'call it on the schema instead.' 1128 ) if scalar @_; 1129 1130 $self->resultset_class->new( 1131 $self, 1132 { 1133 try { %{$self->schema->default_resultset_attributes} }, 1134 %{$self->{resultset_attributes}}, 1135 }, 1136 ); 1137} 1138 1139=head2 name 1140 1141=over 4 1142 1143=item Arguments: none 1144 1145=item Result value: $name 1146 1147=back 1148 1149Returns the name of the result source, which will typically be the table 1150name. This may be a scalar reference if the result source has a non-standard 1151name. 1152 1153=head2 source_name 1154 1155=over 4 1156 1157=item Arguments: $source_name 1158 1159=item Result value: $source_name 1160 1161=back 1162 1163Set an alternate name for the result source when it is loaded into a schema. 1164This is useful if you want to refer to a result source by a name other than 1165its class name. 1166 1167 package ArchivedBooks; 1168 use base qw/DBIx::Class/; 1169 __PACKAGE__->table('books_archive'); 1170 __PACKAGE__->source_name('Books'); 1171 1172 # from your schema... 1173 $schema->resultset('Books')->find(1); 1174 1175=head2 from 1176 1177=over 4 1178 1179=item Arguments: none 1180 1181=item Return Value: FROM clause 1182 1183=back 1184 1185 my $from_clause = $source->from(); 1186 1187Returns an expression of the source to be supplied to storage to specify 1188retrieval from this source. In the case of a database, the required FROM 1189clause contents. 1190 1191=cut 1192 1193sub from { die 'Virtual method!' } 1194 1195=head2 source_info 1196 1197Stores a hashref of per-source metadata. No specific key names 1198have yet been standardized, the examples below are purely hypothetical 1199and don't actually accomplish anything on their own: 1200 1201 __PACKAGE__->source_info({ 1202 "_tablespace" => 'fast_disk_array_3', 1203 "_engine" => 'InnoDB', 1204 }); 1205 1206=head2 schema 1207 1208=over 4 1209 1210=item Arguments: L<$schema?|DBIx::Class::Schema> 1211 1212=item Return Value: L<$schema|DBIx::Class::Schema> 1213 1214=back 1215 1216 my $schema = $source->schema(); 1217 1218Sets and/or returns the L<DBIx::Class::Schema> object to which this 1219result source instance has been attached to. 1220 1221=cut 1222 1223sub schema { 1224 if (@_ > 1) { 1225 $_[0]->{schema} = $_[1]; 1226 } 1227 else { 1228 $_[0]->{schema} || do { 1229 my $name = $_[0]->{source_name} || '_unnamed_'; 1230 my $err = 'Unable to perform storage-dependent operations with a detached result source ' 1231 . "(source '$name' is not associated with a schema)."; 1232 1233 $err .= ' You need to use $schema->thaw() or manually set' 1234 . ' $DBIx::Class::ResultSourceHandle::thaw_schema while thawing.' 1235 if $_[0]->{_detached_thaw}; 1236 1237 DBIx::Class::Exception->throw($err); 1238 }; 1239 } 1240} 1241 1242=head2 storage 1243 1244=over 4 1245 1246=item Arguments: none 1247 1248=item Return Value: L<$storage|DBIx::Class::Storage> 1249 1250=back 1251 1252 $source->storage->debug(1); 1253 1254Returns the L<storage handle|DBIx::Class::Storage> for the current schema. 1255 1256=cut 1257 1258sub storage { shift->schema->storage; } 1259 1260=head2 add_relationship 1261 1262=over 4 1263 1264=item Arguments: $rel_name, $related_source_name, \%cond, \%attrs? 1265 1266=item Return Value: 1/true if it succeeded 1267 1268=back 1269 1270 $source->add_relationship('rel_name', 'related_source', $cond, $attrs); 1271 1272L<DBIx::Class::Relationship> describes a series of methods which 1273create pre-defined useful types of relationships. Look there first 1274before using this method directly. 1275 1276The relationship name can be arbitrary, but must be unique for each 1277relationship attached to this result source. 'related_source' should 1278be the name with which the related result source was registered with 1279the current schema. For example: 1280 1281 $schema->source('Book')->add_relationship('reviews', 'Review', { 1282 'foreign.book_id' => 'self.id', 1283 }); 1284 1285The condition C<$cond> needs to be an L<SQL::Abstract::Classic>-style 1286representation of the join between the tables. For example, if you're 1287creating a relation from Author to Book, 1288 1289 { 'foreign.author_id' => 'self.id' } 1290 1291will result in the JOIN clause 1292 1293 author me JOIN book foreign ON foreign.author_id = me.id 1294 1295You can specify as many foreign => self mappings as necessary. 1296 1297Valid attributes are as follows: 1298 1299=over 4 1300 1301=item join_type 1302 1303Explicitly specifies the type of join to use in the relationship. Any 1304SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in 1305the SQL command immediately before C<JOIN>. 1306 1307=item proxy 1308 1309An arrayref containing a list of accessors in the foreign class to proxy in 1310the main class. If, for example, you do the following: 1311 1312 CD->might_have(liner_notes => 'LinerNotes', undef, { 1313 proxy => [ qw/notes/ ], 1314 }); 1315 1316Then, assuming LinerNotes has an accessor named notes, you can do: 1317 1318 my $cd = CD->find(1); 1319 # set notes -- LinerNotes object is created if it doesn't exist 1320 $cd->notes('Notes go here'); 1321 1322=item accessor 1323 1324Specifies the type of accessor that should be created for the 1325relationship. Valid values are C<single> (for when there is only a single 1326related object), C<multi> (when there can be many), and C<filter> (for 1327when there is a single related object, but you also want the relationship 1328accessor to double as a column accessor). For C<multi> accessors, an 1329add_to_* method is also created, which calls C<create_related> for the 1330relationship. 1331 1332=back 1333 1334Throws an exception if the condition is improperly supplied, or cannot 1335be resolved. 1336 1337=cut 1338 1339sub add_relationship { 1340 my ($self, $rel, $f_source_name, $cond, $attrs) = @_; 1341 $self->throw_exception("Can't create relationship without join condition") 1342 unless $cond; 1343 $attrs ||= {}; 1344 1345 # Check foreign and self are right in cond 1346 if ( (ref $cond ||'') eq 'HASH') { 1347 $_ =~ /^foreign\./ or $self->throw_exception("Malformed relationship condition key '$_': must be prefixed with 'foreign.'") 1348 for keys %$cond; 1349 1350 $_ =~ /^self\./ or $self->throw_exception("Malformed relationship condition value '$_': must be prefixed with 'self.'") 1351 for values %$cond; 1352 } 1353 1354 my %rels = %{ $self->_relationships }; 1355 $rels{$rel} = { class => $f_source_name, 1356 source => $f_source_name, 1357 cond => $cond, 1358 attrs => $attrs }; 1359 $self->_relationships(\%rels); 1360 1361 return $self; 1362 1363# XXX disabled. doesn't work properly currently. skip in tests. 1364 1365 my $f_source = $self->schema->source($f_source_name); 1366 unless ($f_source) { 1367 $self->ensure_class_loaded($f_source_name); 1368 $f_source = $f_source_name->result_source; 1369 #my $s_class = ref($self->schema); 1370 #$f_source_name =~ m/^${s_class}::(.*)$/; 1371 #$self->schema->register_class(($1 || $f_source_name), $f_source_name); 1372 #$f_source = $self->schema->source($f_source_name); 1373 } 1374 return unless $f_source; # Can't test rel without f_source 1375 1376 try { $self->_resolve_join($rel, 'me', {}, []) } 1377 catch { 1378 # If the resolve failed, back out and re-throw the error 1379 delete $rels{$rel}; 1380 $self->_relationships(\%rels); 1381 $self->throw_exception("Error creating relationship $rel: $_"); 1382 }; 1383 1384 1; 1385} 1386 1387=head2 relationships 1388 1389=over 4 1390 1391=item Arguments: none 1392 1393=item Return Value: L<@rel_names|DBIx::Class::Relationship> 1394 1395=back 1396 1397 my @rel_names = $source->relationships(); 1398 1399Returns all relationship names for this source. 1400 1401=cut 1402 1403sub relationships { 1404 return keys %{shift->_relationships}; 1405} 1406 1407=head2 relationship_info 1408 1409=over 4 1410 1411=item Arguments: L<$rel_name|DBIx::Class::Relationship> 1412 1413=item Return Value: L<\%rel_data|DBIx::Class::Relationship::Base/add_relationship> 1414 1415=back 1416 1417Returns a hash of relationship information for the specified relationship 1418name. The keys/values are as specified for L<DBIx::Class::Relationship::Base/add_relationship>. 1419 1420=cut 1421 1422sub relationship_info { 1423 #my ($self, $rel) = @_; 1424 return shift->_relationships->{+shift}; 1425} 1426 1427=head2 has_relationship 1428 1429=over 4 1430 1431=item Arguments: L<$rel_name|DBIx::Class::Relationship> 1432 1433=item Return Value: 1/0 (true/false) 1434 1435=back 1436 1437Returns true if the source has a relationship of this name, false otherwise. 1438 1439=cut 1440 1441sub has_relationship { 1442 #my ($self, $rel) = @_; 1443 return exists shift->_relationships->{+shift}; 1444} 1445 1446=head2 reverse_relationship_info 1447 1448=over 4 1449 1450=item Arguments: L<$rel_name|DBIx::Class::Relationship> 1451 1452=item Return Value: L<\%rel_data|DBIx::Class::Relationship::Base/add_relationship> 1453 1454=back 1455 1456Looks through all the relationships on the source this relationship 1457points to, looking for one whose condition is the reverse of the 1458condition on this relationship. 1459 1460A common use of this is to find the name of the C<belongs_to> relation 1461opposing a C<has_many> relation. For definition of these look in 1462L<DBIx::Class::Relationship>. 1463 1464The returned hashref is keyed by the name of the opposing 1465relationship, and contains its data in the same manner as 1466L</relationship_info>. 1467 1468=cut 1469 1470sub reverse_relationship_info { 1471 my ($self, $rel) = @_; 1472 1473 my $rel_info = $self->relationship_info($rel) 1474 or $self->throw_exception("No such relationship '$rel'"); 1475 1476 my $ret = {}; 1477 1478 return $ret unless ((ref $rel_info->{cond}) eq 'HASH'); 1479 1480 my $stripped_cond = $self->__strip_relcond ($rel_info->{cond}); 1481 1482 my $registered_source_name = $self->source_name; 1483 1484 # this may be a partial schema or something else equally esoteric 1485 my $other_rsrc = $self->related_source($rel); 1486 1487 # Get all the relationships for that source that related to this source 1488 # whose foreign column set are our self columns on $rel and whose self 1489 # columns are our foreign columns on $rel 1490 foreach my $other_rel ($other_rsrc->relationships) { 1491 1492 # only consider stuff that points back to us 1493 # "us" here is tricky - if we are in a schema registration, we want 1494 # to use the source_names, otherwise we will use the actual classes 1495 1496 # the schema may be partial 1497 my $roundtrip_rsrc = try { $other_rsrc->related_source($other_rel) } 1498 or next; 1499 1500 if ($registered_source_name) { 1501 next if $registered_source_name ne ($roundtrip_rsrc->source_name || '') 1502 } 1503 else { 1504 next if $self->result_class ne $roundtrip_rsrc->result_class; 1505 } 1506 1507 my $other_rel_info = $other_rsrc->relationship_info($other_rel); 1508 1509 # this can happen when we have a self-referential class 1510 next if $other_rel_info eq $rel_info; 1511 1512 next unless ref $other_rel_info->{cond} eq 'HASH'; 1513 my $other_stripped_cond = $self->__strip_relcond($other_rel_info->{cond}); 1514 1515 $ret->{$other_rel} = $other_rel_info if ( 1516 $self->_compare_relationship_keys ( 1517 [ keys %$stripped_cond ], [ values %$other_stripped_cond ] 1518 ) 1519 and 1520 $self->_compare_relationship_keys ( 1521 [ values %$stripped_cond ], [ keys %$other_stripped_cond ] 1522 ) 1523 ); 1524 } 1525 1526 return $ret; 1527} 1528 1529# all this does is removes the foreign/self prefix from a condition 1530sub __strip_relcond { 1531 +{ 1532 map 1533 { map { /^ (?:foreign|self) \. (\w+) $/x } ($_, $_[1]{$_}) } 1534 keys %{$_[1]} 1535 } 1536} 1537 1538sub compare_relationship_keys { 1539 carp 'compare_relationship_keys is a private method, stop calling it'; 1540 my $self = shift; 1541 $self->_compare_relationship_keys (@_); 1542} 1543 1544# Returns true if both sets of keynames are the same, false otherwise. 1545sub _compare_relationship_keys { 1546# my ($self, $keys1, $keys2) = @_; 1547 return 1548 join ("\x00", sort @{$_[1]}) 1549 eq 1550 join ("\x00", sort @{$_[2]}) 1551 ; 1552} 1553 1554# optionally takes either an arrayref of column names, or a hashref of already 1555# retrieved colinfos 1556# returns an arrayref of column names of the shortest unique constraint 1557# (matching some of the input if any), giving preference to the PK 1558sub _identifying_column_set { 1559 my ($self, $cols) = @_; 1560 1561 my %unique = $self->unique_constraints; 1562 my $colinfos = ref $cols eq 'HASH' ? $cols : $self->columns_info($cols||()); 1563 1564 # always prefer the PK first, and then shortest constraints first 1565 USET: 1566 for my $set (delete $unique{primary}, sort { @$a <=> @$b } (values %unique) ) { 1567 next unless $set && @$set; 1568 1569 for (@$set) { 1570 next USET unless ($colinfos->{$_} && !$colinfos->{$_}{is_nullable} ); 1571 } 1572 1573 # copy so we can mangle it at will 1574 return [ @$set ]; 1575 } 1576 1577 return undef; 1578} 1579 1580sub _minimal_valueset_satisfying_constraint { 1581 my $self = shift; 1582 my $args = { ref $_[0] eq 'HASH' ? %{ $_[0] } : @_ }; 1583 1584 $args->{columns_info} ||= $self->columns_info; 1585 1586 my $vals = $self->storage->_extract_fixed_condition_columns( 1587 $args->{values}, 1588 ($args->{carp_on_nulls} ? 'consider_nulls' : undef ), 1589 ); 1590 1591 my $cols; 1592 for my $col ($self->unique_constraint_columns($args->{constraint_name}) ) { 1593 if( ! exists $vals->{$col} or ( $vals->{$col}||'' ) eq UNRESOLVABLE_CONDITION ) { 1594 $cols->{missing}{$col} = undef; 1595 } 1596 elsif( ! defined $vals->{$col} ) { 1597 $cols->{$args->{carp_on_nulls} ? 'undefined' : 'missing'}{$col} = undef; 1598 } 1599 else { 1600 # we need to inject back the '=' as _extract_fixed_condition_columns 1601 # will strip it from literals and values alike, resulting in an invalid 1602 # condition in the end 1603 $cols->{present}{$col} = { '=' => $vals->{$col} }; 1604 } 1605 1606 $cols->{fc}{$col} = 1 if ( 1607 ( ! $cols->{missing} or ! exists $cols->{missing}{$col} ) 1608 and 1609 keys %{ $args->{columns_info}{$col}{_filter_info} || {} } 1610 ); 1611 } 1612 1613 $self->throw_exception( sprintf ( "Unable to satisfy requested constraint '%s', missing values for column(s): %s", 1614 $args->{constraint_name}, 1615 join (', ', map { "'$_'" } sort keys %{$cols->{missing}} ), 1616 ) ) if $cols->{missing}; 1617 1618 $self->throw_exception( sprintf ( 1619 "Unable to satisfy requested constraint '%s', FilterColumn values not usable for column(s): %s", 1620 $args->{constraint_name}, 1621 join (', ', map { "'$_'" } sort keys %{$cols->{fc}}), 1622 )) if $cols->{fc}; 1623 1624 if ( 1625 $cols->{undefined} 1626 and 1627 !$ENV{DBIC_NULLABLE_KEY_NOWARN} 1628 ) { 1629 carp_unique ( sprintf ( 1630 "NULL/undef values supplied for requested unique constraint '%s' (NULL " 1631 . 'values in column(s): %s). This is almost certainly not what you wanted, ' 1632 . 'though you can set DBIC_NULLABLE_KEY_NOWARN to disable this warning.', 1633 $args->{constraint_name}, 1634 join (', ', map { "'$_'" } sort keys %{$cols->{undefined}}), 1635 )); 1636 } 1637 1638 return { map { %{ $cols->{$_}||{} } } qw(present undefined) }; 1639} 1640 1641# Returns the {from} structure used to express JOIN conditions 1642sub _resolve_join { 1643 my ($self, $join, $alias, $seen, $jpath, $parent_force_left) = @_; 1644 1645 # we need a supplied one, because we do in-place modifications, no returns 1646 $self->throw_exception ('You must supply a seen hashref as the 3rd argument to _resolve_join') 1647 unless ref $seen eq 'HASH'; 1648 1649 $self->throw_exception ('You must supply a joinpath arrayref as the 4th argument to _resolve_join') 1650 unless ref $jpath eq 'ARRAY'; 1651 1652 $jpath = [@$jpath]; # copy 1653 1654 if (not defined $join or not length $join) { 1655 return (); 1656 } 1657 elsif (ref $join eq 'ARRAY') { 1658 return 1659 map { 1660 $self->_resolve_join($_, $alias, $seen, $jpath, $parent_force_left); 1661 } @$join; 1662 } 1663 elsif (ref $join eq 'HASH') { 1664 1665 my @ret; 1666 for my $rel (keys %$join) { 1667 1668 my $rel_info = $self->relationship_info($rel) 1669 or $self->throw_exception("No such relationship '$rel' on " . $self->source_name); 1670 1671 my $force_left = $parent_force_left; 1672 $force_left ||= lc($rel_info->{attrs}{join_type}||'') eq 'left'; 1673 1674 # the actual seen value will be incremented by the recursion 1675 my $as = $self->storage->relname_to_table_alias( 1676 $rel, ($seen->{$rel} && $seen->{$rel} + 1) 1677 ); 1678 1679 push @ret, ( 1680 $self->_resolve_join($rel, $alias, $seen, [@$jpath], $force_left), 1681 $self->related_source($rel)->_resolve_join( 1682 $join->{$rel}, $as, $seen, [@$jpath, { $rel => $as }], $force_left 1683 ) 1684 ); 1685 } 1686 return @ret; 1687 1688 } 1689 elsif (ref $join) { 1690 $self->throw_exception("No idea how to resolve join reftype ".ref $join); 1691 } 1692 else { 1693 my $count = ++$seen->{$join}; 1694 my $as = $self->storage->relname_to_table_alias( 1695 $join, ($count > 1 && $count) 1696 ); 1697 1698 my $rel_info = $self->relationship_info($join) 1699 or $self->throw_exception("No such relationship $join on " . $self->source_name); 1700 1701 my $rel_src = $self->related_source($join); 1702 return [ { $as => $rel_src->from, 1703 -rsrc => $rel_src, 1704 -join_type => $parent_force_left 1705 ? 'left' 1706 : $rel_info->{attrs}{join_type} 1707 , 1708 -join_path => [@$jpath, { $join => $as } ], 1709 -is_single => !!( 1710 (! $rel_info->{attrs}{accessor}) 1711 or 1712 grep { $rel_info->{attrs}{accessor} eq $_ } (qw/single filter/) 1713 ), 1714 -alias => $as, 1715 -relation_chain_depth => ( $seen->{-relation_chain_depth} || 0 ) + 1, 1716 }, 1717 scalar $self->_resolve_condition($rel_info->{cond}, $as, $alias, $join) 1718 ]; 1719 } 1720} 1721 1722sub pk_depends_on { 1723 carp 'pk_depends_on is a private method, stop calling it'; 1724 my $self = shift; 1725 $self->_pk_depends_on (@_); 1726} 1727 1728# Determines whether a relation is dependent on an object from this source 1729# having already been inserted. Takes the name of the relationship and a 1730# hashref of columns of the related object. 1731sub _pk_depends_on { 1732 my ($self, $rel_name, $rel_data) = @_; 1733 1734 my $relinfo = $self->relationship_info($rel_name); 1735 1736 # don't assume things if the relationship direction is specified 1737 return $relinfo->{attrs}{is_foreign_key_constraint} 1738 if exists ($relinfo->{attrs}{is_foreign_key_constraint}); 1739 1740 my $cond = $relinfo->{cond}; 1741 return 0 unless ref($cond) eq 'HASH'; 1742 1743 # map { foreign.foo => 'self.bar' } to { bar => 'foo' } 1744 my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond }; 1745 1746 # assume anything that references our PK probably is dependent on us 1747 # rather than vice versa, unless the far side is (a) defined or (b) 1748 # auto-increment 1749 my $rel_source = $self->related_source($rel_name); 1750 1751 foreach my $p ($self->primary_columns) { 1752 if (exists $keyhash->{$p}) { 1753 unless (defined($rel_data->{$keyhash->{$p}}) 1754 || $rel_source->column_info($keyhash->{$p}) 1755 ->{is_auto_increment}) { 1756 return 0; 1757 } 1758 } 1759 } 1760 1761 return 1; 1762} 1763 1764sub resolve_condition { 1765 carp 'resolve_condition is a private method, stop calling it'; 1766 shift->_resolve_condition (@_); 1767} 1768 1769sub _resolve_condition { 1770# carp_unique sprintf 1771# '_resolve_condition is a private method, and moreover is about to go ' 1772# . 'away. Please contact the development team at %s if you believe you ' 1773# . 'have a genuine use for this method, in order to discuss alternatives.', 1774# DBIx::Class::_ENV_::HELP_URL, 1775# ; 1776 1777####################### 1778### API Design? What's that...? (a backwards compatible shim, kill me now) 1779 1780 my ($self, $cond, @res_args, $rel_name); 1781 1782 # we *SIMPLY DON'T KNOW YET* which arg is which, yay 1783 ($self, $cond, $res_args[0], $res_args[1], $rel_name) = @_; 1784 1785 # assume that an undef is an object-like unset (set_from_related(undef)) 1786 my @is_objlike = map { ! defined $_ or length ref $_ } (@res_args); 1787 1788 # turn objlike into proper objects for saner code further down 1789 for (0,1) { 1790 next unless $is_objlike[$_]; 1791 1792 if ( defined blessed $res_args[$_] ) { 1793 1794 # but wait - there is more!!! WHAT THE FUCK?!?!?!?! 1795 if ($res_args[$_]->isa('DBIx::Class::ResultSet')) { 1796 carp('Passing a resultset for relationship resolution makes no sense - invoking __gremlins__'); 1797 $is_objlike[$_] = 0; 1798 $res_args[$_] = '__gremlins__'; 1799 } 1800 } 1801 else { 1802 $res_args[$_] ||= {}; 1803 1804 # hate everywhere - have to pass in as a plain hash 1805 # pretending to be an object at least for now 1806 $self->throw_exception("Unsupported object-like structure encountered: $res_args[$_]") 1807 unless ref $res_args[$_] eq 'HASH'; 1808 } 1809 } 1810 1811 my $args = { 1812 condition => $cond, 1813 1814 # where-is-waldo block guesses relname, then further down we override it if available 1815 ( 1816 $is_objlike[1] ? ( rel_name => $res_args[0], self_alias => $res_args[0], foreign_alias => 'me', self_result_object => $res_args[1] ) 1817 : $is_objlike[0] ? ( rel_name => $res_args[1], self_alias => 'me', foreign_alias => $res_args[1], foreign_values => $res_args[0] ) 1818 : ( rel_name => $res_args[0], self_alias => $res_args[1], foreign_alias => $res_args[0] ) 1819 ), 1820 1821 ( $rel_name ? ( rel_name => $rel_name ) : () ), 1822 }; 1823####################### 1824 1825 # now it's fucking easy isn't it?! 1826 my $rc = $self->_resolve_relationship_condition( $args ); 1827 1828 my @res = ( 1829 ( $rc->{join_free_condition} || $rc->{condition} ), 1830 ! $rc->{join_free_condition}, 1831 ); 1832 1833 # _resolve_relationship_condition always returns qualified cols even in the 1834 # case of join_free_condition, but nothing downstream expects this 1835 if ($rc->{join_free_condition} and ref $res[0] eq 'HASH') { 1836 $res[0] = { map 1837 { ($_ =~ /\.(.+)/) => $res[0]{$_} } 1838 keys %{$res[0]} 1839 }; 1840 } 1841 1842 # and more legacy 1843 return wantarray ? @res : $res[0]; 1844} 1845 1846# Keep this indefinitely. There is evidence of both CPAN and 1847# darkpan using it, and there isn't much harm in an extra var 1848# anyway. 1849our $UNRESOLVABLE_CONDITION = UNRESOLVABLE_CONDITION; 1850# YES I KNOW THIS IS EVIL 1851# it is there to save darkpan from themselves, since internally 1852# we are moving to a constant 1853Internals::SvREADONLY($UNRESOLVABLE_CONDITION => 1); 1854 1855# Resolves the passed condition to a concrete query fragment and extra 1856# metadata 1857# 1858## self-explanatory API, modeled on the custom cond coderef: 1859# rel_name => (scalar) 1860# foreign_alias => (scalar) 1861# foreign_values => (either not supplied, or a hashref, or a foreign ResultObject (to be ->get_columns()ed), or plain undef ) 1862# self_alias => (scalar) 1863# self_result_object => (either not supplied or a result object) 1864# require_join_free_condition => (boolean, throws on failure to construct a JF-cond) 1865# infer_values_based_on => (either not supplied or a hashref, implies require_join_free_condition) 1866# condition => (sqla cond struct, optional, defeaults to from $self->rel_info(rel_name)->{cond}) 1867# 1868## returns a hash 1869# condition => (a valid *likely fully qualified* sqla cond structure) 1870# identity_map => (a hashref of foreign-to-self *unqualified* column equality names) 1871# join_free_condition => (a valid *fully qualified* sqla cond structure, maybe unset) 1872# inferred_values => (in case of an available join_free condition, this is a hashref of 1873# *unqualified* column/value *EQUALITY* pairs, representing an amalgamation 1874# of the JF-cond parse and infer_values_based_on 1875# always either complete or unset) 1876# 1877sub _resolve_relationship_condition { 1878 my $self = shift; 1879 1880 my $args = { ref $_[0] eq 'HASH' ? %{ $_[0] } : @_ }; 1881 1882 for ( qw( rel_name self_alias foreign_alias ) ) { 1883 $self->throw_exception("Mandatory argument '$_' to _resolve_relationship_condition() is not a plain string") 1884 if !defined $args->{$_} or length ref $args->{$_}; 1885 } 1886 1887 $self->throw_exception("Arguments 'self_alias' and 'foreign_alias' may not be identical") 1888 if $args->{self_alias} eq $args->{foreign_alias}; 1889 1890# TEMP 1891 my $exception_rel_id = "relationship '$args->{rel_name}' on source '@{[ $self->source_name ]}'"; 1892 1893 my $rel_info = $self->relationship_info($args->{rel_name}) 1894# TEMP 1895# or $self->throw_exception( "No such $exception_rel_id" ); 1896 or carp_unique("Requesting resolution on non-existent relationship '$args->{rel_name}' on source '@{[ $self->source_name ]}': fix your code *soon*, as it will break with the next major version"); 1897 1898# TEMP 1899 $exception_rel_id = "relationship '$rel_info->{_original_name}' on source '@{[ $self->source_name ]}'" 1900 if $rel_info and exists $rel_info->{_original_name}; 1901 1902 $self->throw_exception("No practical way to resolve $exception_rel_id between two data structures") 1903 if exists $args->{self_result_object} and exists $args->{foreign_values}; 1904 1905 $self->throw_exception( "Argument to infer_values_based_on must be a hash" ) 1906 if exists $args->{infer_values_based_on} and ref $args->{infer_values_based_on} ne 'HASH'; 1907 1908 $args->{require_join_free_condition} ||= !!$args->{infer_values_based_on}; 1909 1910 $args->{condition} ||= $rel_info->{cond}; 1911 1912 $self->throw_exception( "Argument 'self_result_object' must be an object inheriting from DBIx::Class::Row" ) 1913 if ( 1914 exists $args->{self_result_object} 1915 and 1916 ( ! defined blessed $args->{self_result_object} or ! $args->{self_result_object}->isa('DBIx::Class::Row') ) 1917 ) 1918 ; 1919 1920#TEMP 1921 my $rel_rsrc;# = $self->related_source($args->{rel_name}); 1922 1923 if (exists $args->{foreign_values}) { 1924# TEMP 1925 $rel_rsrc ||= $self->related_source($args->{rel_name}); 1926 1927 if (defined blessed $args->{foreign_values}) { 1928 1929 $self->throw_exception( "Objects supplied as 'foreign_values' ($args->{foreign_values}) must inherit from DBIx::Class::Row" ) 1930 unless $args->{foreign_values}->isa('DBIx::Class::Row'); 1931 1932 carp_unique( 1933 "Objects supplied as 'foreign_values' ($args->{foreign_values}) " 1934 . "usually should inherit from the related ResultClass ('@{[ $rel_rsrc->result_class ]}'), " 1935 . "perhaps you've made a mistake invoking the condition resolver?" 1936 ) unless $args->{foreign_values}->isa($rel_rsrc->result_class); 1937 1938 $args->{foreign_values} = { $args->{foreign_values}->get_columns }; 1939 } 1940 elsif (! defined $args->{foreign_values} or ref $args->{foreign_values} eq 'HASH') { 1941 my $ri = { map { $_ => 1 } $rel_rsrc->relationships }; 1942 my $ci = $rel_rsrc->columns_info; 1943 ! exists $ci->{$_} and ! exists $ri->{$_} and $self->throw_exception( 1944 "Key '$_' supplied as 'foreign_values' is not a column on related source '@{[ $rel_rsrc->source_name ]}'" 1945 ) for keys %{ $args->{foreign_values} ||= {} }; 1946 } 1947 else { 1948 $self->throw_exception( 1949 "Argument 'foreign_values' must be either an object inheriting from '@{[ $rel_rsrc->result_class ]}', " 1950 . "or a hash reference, or undef" 1951 ); 1952 } 1953 } 1954 1955 my $ret; 1956 1957 if (ref $args->{condition} eq 'CODE') { 1958 1959 my $cref_args = { 1960 rel_name => $args->{rel_name}, 1961 self_resultsource => $self, 1962 self_alias => $args->{self_alias}, 1963 foreign_alias => $args->{foreign_alias}, 1964 ( map 1965 { (exists $args->{$_}) ? ( $_ => $args->{$_} ) : () } 1966 qw( self_result_object foreign_values ) 1967 ), 1968 }; 1969 1970 # legacy - never remove these!!! 1971 $cref_args->{foreign_relname} = $cref_args->{rel_name}; 1972 1973 $cref_args->{self_rowobj} = $cref_args->{self_result_object} 1974 if exists $cref_args->{self_result_object}; 1975 1976 ($ret->{condition}, $ret->{join_free_condition}, my @extra) = $args->{condition}->($cref_args); 1977 1978 # sanity check 1979 $self->throw_exception("A custom condition coderef can return at most 2 conditions, but $exception_rel_id returned extra values: @extra") 1980 if @extra; 1981 1982 if (my $jfc = $ret->{join_free_condition}) { 1983 1984 $self->throw_exception ( 1985 "The join-free condition returned for $exception_rel_id must be a hash reference" 1986 ) unless ref $jfc eq 'HASH'; 1987 1988# TEMP 1989 $rel_rsrc ||= $self->related_source($args->{rel_name}); 1990 1991 my ($joinfree_alias, $joinfree_source); 1992 if (defined $args->{self_result_object}) { 1993 $joinfree_alias = $args->{foreign_alias}; 1994 $joinfree_source = $rel_rsrc; 1995 } 1996 elsif (defined $args->{foreign_values}) { 1997 $joinfree_alias = $args->{self_alias}; 1998 $joinfree_source = $self; 1999 } 2000 2001 # FIXME sanity check until things stabilize, remove at some point 2002 $self->throw_exception ( 2003 "A join-free condition returned for $exception_rel_id without a result object to chain from" 2004 ) unless $joinfree_alias; 2005 2006 my $fq_col_list = { map 2007 { ( "$joinfree_alias.$_" => 1 ) } 2008 $joinfree_source->columns 2009 }; 2010 2011 exists $fq_col_list->{$_} or $self->throw_exception ( 2012 "The join-free condition returned for $exception_rel_id may only " 2013 . 'contain keys that are fully qualified column names of the corresponding source ' 2014 . "(it returned '$_')" 2015 ) for keys %$jfc; 2016 2017 ( 2018 length ref $_ 2019 and 2020 defined blessed($_) 2021 and 2022 $_->isa('DBIx::Class::Row') 2023 and 2024 $self->throw_exception ( 2025 "The join-free condition returned for $exception_rel_id may not " 2026 . 'contain result objects as values - perhaps instead of invoking ' 2027 . '->$something you meant to return ->get_column($something)' 2028 ) 2029 ) for values %$jfc; 2030 2031 } 2032 } 2033 elsif (ref $args->{condition} eq 'HASH') { 2034 2035 # the condition is static - use parallel arrays 2036 # for a "pivot" depending on which side of the 2037 # rel did we get as an object 2038 my (@f_cols, @l_cols); 2039 for my $fc (keys %{$args->{condition}}) { 2040 my $lc = $args->{condition}{$fc}; 2041 2042 # FIXME STRICTMODE should probably check these are valid columns 2043 $fc =~ s/^foreign\.// || 2044 $self->throw_exception("Invalid rel cond key '$fc'"); 2045 2046 $lc =~ s/^self\.// || 2047 $self->throw_exception("Invalid rel cond val '$lc'"); 2048 2049 push @f_cols, $fc; 2050 push @l_cols, $lc; 2051 } 2052 2053 # construct the crosstable condition and the identity map 2054 for (0..$#f_cols) { 2055 $ret->{condition}{"$args->{foreign_alias}.$f_cols[$_]"} = { -ident => "$args->{self_alias}.$l_cols[$_]" }; 2056 $ret->{identity_map}{$l_cols[$_]} = $f_cols[$_]; 2057 }; 2058 2059 if ($args->{foreign_values}) { 2060 $ret->{join_free_condition}{"$args->{self_alias}.$l_cols[$_]"} = $args->{foreign_values}{$f_cols[$_]} 2061 for 0..$#f_cols; 2062 } 2063 elsif (defined $args->{self_result_object}) { 2064 2065 for my $i (0..$#l_cols) { 2066 if ( $args->{self_result_object}->has_column_loaded($l_cols[$i]) ) { 2067 $ret->{join_free_condition}{"$args->{foreign_alias}.$f_cols[$i]"} = $args->{self_result_object}->get_column($l_cols[$i]); 2068 } 2069 else { 2070 $self->throw_exception(sprintf 2071 "Unable to resolve relationship '%s' from object '%s': column '%s' not " 2072 . 'loaded from storage (or not passed to new() prior to insert()). You ' 2073 . 'probably need to call ->discard_changes to get the server-side defaults ' 2074 . 'from the database.', 2075 $args->{rel_name}, 2076 $args->{self_result_object}, 2077 $l_cols[$i], 2078 ) if $args->{self_result_object}->in_storage; 2079 2080 # FIXME - temporarly force-override 2081 delete $args->{require_join_free_condition}; 2082 $ret->{join_free_condition} = UNRESOLVABLE_CONDITION; 2083 last; 2084 } 2085 } 2086 } 2087 } 2088 elsif (ref $args->{condition} eq 'ARRAY') { 2089 if (@{$args->{condition}} == 0) { 2090 $ret = { 2091 condition => UNRESOLVABLE_CONDITION, 2092 join_free_condition => UNRESOLVABLE_CONDITION, 2093 }; 2094 } 2095 elsif (@{$args->{condition}} == 1) { 2096 $ret = $self->_resolve_relationship_condition({ 2097 %$args, 2098 condition => $args->{condition}[0], 2099 }); 2100 } 2101 else { 2102 # we are discarding inferred values here... likely incorrect... 2103 # then again - the entire thing is an OR, so we *can't* use them anyway 2104 for my $subcond ( map 2105 { $self->_resolve_relationship_condition({ %$args, condition => $_ }) } 2106 @{$args->{condition}} 2107 ) { 2108 $self->throw_exception('Either all or none of the OR-condition members must resolve to a join-free condition') 2109 if ( $ret and ( $ret->{join_free_condition} xor $subcond->{join_free_condition} ) ); 2110 2111 $subcond->{$_} and push @{$ret->{$_}}, $subcond->{$_} for (qw(condition join_free_condition)); 2112 } 2113 } 2114 } 2115 else { 2116 $self->throw_exception ("Can't handle condition $args->{condition} for $exception_rel_id yet :("); 2117 } 2118 2119 $self->throw_exception(ucfirst "$exception_rel_id does not resolve to a join-free condition fragment") if ( 2120 $args->{require_join_free_condition} 2121 and 2122 ( ! $ret->{join_free_condition} or $ret->{join_free_condition} eq UNRESOLVABLE_CONDITION ) 2123 ); 2124 2125 my $storage = $self->schema->storage; 2126 2127 # we got something back - sanity check and infer values if we can 2128 my @nonvalues; 2129 if ( my $jfc = $ret->{join_free_condition} and $ret->{join_free_condition} ne UNRESOLVABLE_CONDITION ) { 2130 2131 my $jfc_eqs = $storage->_extract_fixed_condition_columns($jfc, 'consider_nulls'); 2132 2133 if (keys %$jfc_eqs) { 2134 2135 for (keys %$jfc) { 2136 # $jfc is fully qualified by definition 2137 my ($col) = $_ =~ /\.(.+)/; 2138 2139 if (exists $jfc_eqs->{$_} and ($jfc_eqs->{$_}||'') ne UNRESOLVABLE_CONDITION) { 2140 $ret->{inferred_values}{$col} = $jfc_eqs->{$_}; 2141 } 2142 elsif ( !$args->{infer_values_based_on} or ! exists $args->{infer_values_based_on}{$col} ) { 2143 push @nonvalues, $col; 2144 } 2145 } 2146 2147 # all or nothing 2148 delete $ret->{inferred_values} if @nonvalues; 2149 } 2150 } 2151 2152 # did the user explicitly ask 2153 if ($args->{infer_values_based_on}) { 2154 2155 $self->throw_exception(sprintf ( 2156 "Unable to complete value inferrence - custom $exception_rel_id returns conditions instead of values for column(s): %s", 2157 map { "'$_'" } @nonvalues 2158 )) if @nonvalues; 2159 2160 2161 $ret->{inferred_values} ||= {}; 2162 2163 $ret->{inferred_values}{$_} = $args->{infer_values_based_on}{$_} 2164 for keys %{$args->{infer_values_based_on}}; 2165 } 2166 2167 # add the identities based on the main condition 2168 # (may already be there, since easy to calculate on the fly in the HASH case) 2169 if ( ! $ret->{identity_map} ) { 2170 2171 my $col_eqs = $storage->_extract_fixed_condition_columns($ret->{condition}); 2172 2173 my $colinfos; 2174 for my $lhs (keys %$col_eqs) { 2175 2176 next if $col_eqs->{$lhs} eq UNRESOLVABLE_CONDITION; 2177 2178# TEMP 2179 $rel_rsrc ||= $self->related_source($args->{rel_name}); 2180 2181 # there is no way to know who is right and who is left in a cref 2182 # therefore a full blown resolution call, and figure out the 2183 # direction a bit further below 2184 $colinfos ||= $storage->_resolve_column_info([ 2185 { -alias => $args->{self_alias}, -rsrc => $self }, 2186 { -alias => $args->{foreign_alias}, -rsrc => $rel_rsrc }, 2187 ]); 2188 2189 next unless $colinfos->{$lhs}; # someone is engaging in witchcraft 2190 2191 if ( my $rhs_ref = is_literal_value( $col_eqs->{$lhs} ) ) { 2192 2193 if ( 2194 $colinfos->{$rhs_ref->[0]} 2195 and 2196 $colinfos->{$lhs}{-source_alias} ne $colinfos->{$rhs_ref->[0]}{-source_alias} 2197 ) { 2198 ( $colinfos->{$lhs}{-source_alias} eq $args->{self_alias} ) 2199 ? ( $ret->{identity_map}{$colinfos->{$lhs}{-colname}} = $colinfos->{$rhs_ref->[0]}{-colname} ) 2200 : ( $ret->{identity_map}{$colinfos->{$rhs_ref->[0]}{-colname}} = $colinfos->{$lhs}{-colname} ) 2201 ; 2202 } 2203 } 2204 elsif ( 2205 $col_eqs->{$lhs} =~ /^ ( \Q$args->{self_alias}\E \. .+ ) /x 2206 and 2207 ($colinfos->{$1}||{})->{-result_source} == $rel_rsrc 2208 ) { 2209 my ($lcol, $rcol) = map 2210 { $colinfos->{$_}{-colname} } 2211 ( $lhs, $1 ) 2212 ; 2213 carp_unique( 2214 "The $exception_rel_id specifies equality of column '$lcol' and the " 2215 . "*VALUE* '$rcol' (you did not use the { -ident => ... } operator)" 2216 ); 2217 } 2218 } 2219 } 2220 2221 # FIXME - temporary, to fool the idiotic check in SQLMaker::_join_condition 2222 $ret->{condition} = { -and => [ $ret->{condition} ] } 2223 unless $ret->{condition} eq UNRESOLVABLE_CONDITION; 2224 2225 $ret; 2226} 2227 2228=head2 related_source 2229 2230=over 4 2231 2232=item Arguments: $rel_name 2233 2234=item Return Value: $source 2235 2236=back 2237 2238Returns the result source object for the given relationship. 2239 2240=cut 2241 2242sub related_source { 2243 my ($self, $rel) = @_; 2244 if( !$self->has_relationship( $rel ) ) { 2245 $self->throw_exception("No such relationship '$rel' on " . $self->source_name); 2246 } 2247 2248 # if we are not registered with a schema - just use the prototype 2249 # however if we do have a schema - ask for the source by name (and 2250 # throw in the process if all fails) 2251 if (my $schema = try { $self->schema }) { 2252 $schema->source($self->relationship_info($rel)->{source}); 2253 } 2254 else { 2255 my $class = $self->relationship_info($rel)->{class}; 2256 $self->ensure_class_loaded($class); 2257 $class->result_source_instance; 2258 } 2259} 2260 2261=head2 related_class 2262 2263=over 4 2264 2265=item Arguments: $rel_name 2266 2267=item Return Value: $classname 2268 2269=back 2270 2271Returns the class name for objects in the given relationship. 2272 2273=cut 2274 2275sub related_class { 2276 my ($self, $rel) = @_; 2277 if( !$self->has_relationship( $rel ) ) { 2278 $self->throw_exception("No such relationship '$rel' on " . $self->source_name); 2279 } 2280 return $self->schema->class($self->relationship_info($rel)->{source}); 2281} 2282 2283=head2 handle 2284 2285=over 4 2286 2287=item Arguments: none 2288 2289=item Return Value: L<$source_handle|DBIx::Class::ResultSourceHandle> 2290 2291=back 2292 2293Obtain a new L<result source handle instance|DBIx::Class::ResultSourceHandle> 2294for this source. Used as a serializable pointer to this resultsource, as it is not 2295easy (nor advisable) to serialize CODErefs which may very well be present in e.g. 2296relationship definitions. 2297 2298=cut 2299 2300sub handle { 2301 return DBIx::Class::ResultSourceHandle->new({ 2302 source_moniker => $_[0]->source_name, 2303 2304 # so that a detached thaw can be re-frozen 2305 $_[0]->{_detached_thaw} 2306 ? ( _detached_source => $_[0] ) 2307 : ( schema => $_[0]->schema ) 2308 , 2309 }); 2310} 2311 2312my $global_phase_destroy; 2313sub DESTROY { 2314 ### NO detected_reinvoked_destructor check 2315 ### This code very much relies on being called multuple times 2316 2317 return if $global_phase_destroy ||= in_global_destruction; 2318 2319###### 2320# !!! ACHTUNG !!!! 2321###### 2322# 2323# Under no circumstances shall $_[0] be stored anywhere else (like copied to 2324# a lexical variable, or shifted, or anything else). Doing so will mess up 2325# the refcount of this particular result source, and will allow the $schema 2326# we are trying to save to reattach back to the source we are destroying. 2327# The relevant code checking refcounts is in ::Schema::DESTROY() 2328 2329 # if we are not a schema instance holder - we don't matter 2330 return if( 2331 ! ref $_[0]->{schema} 2332 or 2333 isweak $_[0]->{schema} 2334 ); 2335 2336 # weaken our schema hold forcing the schema to find somewhere else to live 2337 # during global destruction (if we have not yet bailed out) this will throw 2338 # which will serve as a signal to not try doing anything else 2339 # however beware - on older perls the exception seems randomly untrappable 2340 # due to some weird race condition during thread joining :((( 2341 local $@; 2342 eval { 2343 weaken $_[0]->{schema}; 2344 2345 # if schema is still there reintroduce ourselves with strong refs back to us 2346 if ($_[0]->{schema}) { 2347 my $srcregs = $_[0]->{schema}->source_registrations; 2348 for (keys %$srcregs) { 2349 next unless $srcregs->{$_}; 2350 $srcregs->{$_} = $_[0] if $srcregs->{$_} == $_[0]; 2351 } 2352 } 2353 2354 1; 2355 } or do { 2356 $global_phase_destroy = 1; 2357 }; 2358 2359 return; 2360} 2361 2362sub STORABLE_freeze { Storable::nfreeze($_[0]->handle) } 2363 2364sub STORABLE_thaw { 2365 my ($self, $cloning, $ice) = @_; 2366 %$self = %{ (Storable::thaw($ice))->resolve }; 2367} 2368 2369=head2 throw_exception 2370 2371See L<DBIx::Class::Schema/"throw_exception">. 2372 2373=cut 2374 2375sub throw_exception { 2376 my $self = shift; 2377 2378 $self->{schema} 2379 ? $self->{schema}->throw_exception(@_) 2380 : DBIx::Class::Exception->throw(@_) 2381 ; 2382} 2383 2384=head2 column_info_from_storage 2385 2386=over 2387 2388=item Arguments: 1/0 (default: 0) 2389 2390=item Return Value: 1/0 2391 2392=back 2393 2394 __PACKAGE__->column_info_from_storage(1); 2395 2396Enables the on-demand automatic loading of the above column 2397metadata from storage as necessary. This is *deprecated*, and 2398should not be used. It will be removed before 1.0. 2399 2400=head1 FURTHER QUESTIONS? 2401 2402Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>. 2403 2404=head1 COPYRIGHT AND LICENSE 2405 2406This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE> 2407by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can 2408redistribute it and/or modify it under the same terms as the 2409L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>. 2410 2411=cut 2412 24131; 2414