DBIx-Class-ResultDDL

 view release on metacpan or  search on metacpan

lib/DBIx/Class/ResultDDL.pm  view on Meta::CPAN

			if ($class->can($_) == $v_pkg->can($_)) {
				push @tag, $_;
			}
			else {
				my $install_as= "v${v}_$_";
				$class->exporter_export($install_as => $v_pkg->can($_));
				push @tag, $install_as, { -as => $_ };
			}
		}
		return \@tag;
	}
	return shift->next::method(@_);
}


our %_settings_for_package;
sub _settings_for_package {
	return $_settings_for_package{shift()} ||= {};
}

sub enable_inflate_datetime :Export(-inflate_datetime) {
	my $self= shift;
	$self->_inherit_dbic;
	my $pkg= $self->{into};
	$pkg->load_components('InflateColumn::DateTime')
		unless $pkg->isa('DBIx::Class::InflateColumn::DateTime');
	_settings_for_package($pkg)->{inflate_datetime}= 1;
}

sub enable_inflate_json :Export(-inflate_json) {
	my $self= shift;
	$self->_inherit_dbic;
	my $pkg= $self->{into};
	$pkg->load_components('InflateColumn::Serializer')
		unless $pkg->isa('DBIx::Class::InflateColumn::Serializer');
	my $settings= _settings_for_package($pkg);
	$settings->{inflate_json}= 1;
	$settings->{json_defaults}{serializer_class}= 'JSON';
}


sub enable_retrieve_defaults :Export(-retrieve_defaults) {
	my $self= shift;
	my $pkg= $self->{into};
	_settings_for_package($pkg)->{retrieve_defaults}= 1;
}


my @V2= qw(
  table view
  col
    null default auto_inc fk
    integer unsigned tinyint smallint bigint decimal numeric money
    float float4 float8 double real
    char varchar nchar nvarchar MAX binary varbinary bit varbit
    blob tinyblob mediumblob longblob text tinytext mediumtext longtext ntext bytea
    date datetime timestamp enum bool boolean
    uuid json jsonb inflate_json array
  primary_key idx create_index unique sqlt_add_index sqlt_add_constraint
  rel_one rel_many has_one might_have has_many belongs_to many_to_many
    ddl_cascade dbic_cascade
);

our %EXPORT_TAGS;
$EXPORT_TAGS{V2}= \@V2;
export @V2;


sub table {
	my $name= shift;
	DBIx::Class::Core->can('table')->(scalar($CALLER||caller), $name);
}


sub col {
	my $name= shift;
	croak "Odd number of arguments for col(): (".join(',',@_).")"
		if scalar(@_) & 1;
	my $pkg= $CALLER || caller;
	$pkg->add_column($name, expand_col_options($pkg, @_));
	1;
}

sub expand_col_options;

sub _maybe_array {
	my @dims;
	while (@_ && ref $_[0] eq 'ARRAY') {
		my $array= shift @_;
		push @dims, @$array? @$array : '';
	}
	join '', map "[$_]", @dims
}
sub _maybe_size {
	return shift if @_ && Scalar::Util::looks_like_number($_[0]);
	return undef;
}
sub _maybe_size_or_max {
	return shift if @_ && (Scalar::Util::looks_like_number($_[0]) || uc($_[0]) eq 'MAX');
	return undef;
}
sub _maybe_timezone {
	# This is a weak check, but assume the timezone will have at least one capital letter,
	# and that DBIC column attribute names will not.
	return shift if @_ && !ref $_[0] && $_[0] =~ /(^floating$|^local$|[A-Z])/;
	return undef;
}


sub null        { is_nullable => 1, @_ }
sub auto_inc    { is_auto_increment => 1, 'extra.auto_increment_type' => 'monotonic', @_ }
sub fk          { is_foreign_key => 1, @_ }
sub default     { default_value => (@_ > 1? [ @_ ] : $_[0]) }


sub integer     {
	my $size= shift if @_ && Scalar::Util::looks_like_number($_[0]);
	data_type => 'integer'.&_maybe_array, size => $size || 11, @_
}
sub unsigned    { 'extra.unsigned' => 1, @_ }
sub tinyint     { data_type => 'tinyint',   size =>  4, @_ }

lib/DBIx/Class/ResultDDL.pm  view on Meta::CPAN

}


sub primary_key { ($CALLER||caller)->set_primary_key(@_); }


sub unique { ($CALLER||caller)->add_unique_constraint(@_) }


sub rel_one {
	_add_rel(scalar($CALLER||caller), 'rel_one', @_);
}
sub rel_many {
	_add_rel(scalar($CALLER||caller), 'rel_many', @_);
}
sub might_have {
	_add_rel(scalar($CALLER||caller), 'might_have', @_);
}
sub has_one {
	_add_rel(scalar($CALLER||caller), 'has_one', @_);
}
sub has_many {
	_add_rel(scalar($CALLER||caller), 'has_many', @_);
}
sub belongs_to {
	_add_rel(scalar($CALLER||caller), 'belongs_to', @_);
}
sub many_to_many {
	DBIx::Class::Core->can('many_to_many')->(scalar($CALLER||caller), @_);
}

sub expand_relationship_params;

sub _add_rel {
	my ($pkg, $reltype, $relname, $rel_pkg, $dbic_colmap, $opts)= &expand_relationship_params;
	if ($reltype eq 'rel_one' || $reltype eq 'rel_many') {
		# Are we referring to the foreign row's primary key?  DBIC load order might not have
		# gotten there yet, so take a guess that if it isn't a part of our primary key, then it
		# is a part of their primary key.
		my $is_f_key;
		if (ref $dbic_colmap eq 'HASH') {
			my @pk= $pkg->primary_columns;
			$is_f_key= !grep { defined $dbic_colmap->{$_} || defined $dbic_colmap->{"self.$_"} } @pk;
		}
		
		$pkg->add_relationship(
			$relname,
			$rel_pkg,
			$dbic_colmap,
			{
				accessor => ($reltype eq 'rel_one'? 'single' : 'multi'),
				join_type => 'LEFT',
				($is_f_key? (
					fk_columns => { map { do {(my $x= $_) =~ s/^self\.//; $x } => 1 } values %$dbic_colmap },
					is_depends_on => 1,
					is_foreign_key_constraint => 1,
					undef_on_null_fk => 1,
				) : (
					is_depends_on => 0,
				)),
				cascade_copy => 0, cascade_delete => 0,
				%$opts
			}
		);
	} else {
		require DBIx::Class::Core;
		DBIx::Class::Core->can($reltype)->($pkg, $relname, $rel_pkg, $dbic_colmap, $opts);
	}
}


sub ddl_cascade {
	my $mode= shift;
	$mode= 'CASCADE' if !defined $mode || $mode eq '1';
	$mode= 'RESTRICT' if $mode eq '0';
	return
		on_update => $mode,
		on_delete => $mode;
}


sub dbic_cascade {
	my $mode= defined $_[0]? $_[0] : 1;
	return
		cascade_copy => $mode,
		cascade_delete => $mode;
}


sub view {
        my ($name, $definition, %opts) = @_;
        my $pkg= $CALLER || caller;
        DBIx::Class::Core->can('table_class')->($pkg, 'DBIx::Class::ResultSource::View');
        DBIx::Class::Core->can('table')->($pkg, $name);

        my $rsi = $pkg->result_source_instance;
        $rsi->view_definition($definition);

        $rsi->deploy_depends_on($opts{depends}) if $opts{depends};
        $rsi->is_virtual($opts{virtual});
        
        return $rsi
}


our %_installed_sqlt_hook_functions;
sub _get_sqlt_hook_method_array {
	my $pkg= shift;
	$_installed_sqlt_hook_functions{$pkg} ||= do {
		# $pkg->can("sqlt_deploy_hook") is insufficient, because it might be declared
		# in a parent class, and that is not an error.  It is only an error if it was
		# already declared in this package.
		no strict 'refs';
		my $stash= %{$pkg.'::'};
		croak "${pkg}::sqlt_deploy_hook already exists; DBIx::Class::ResultDDL won't overwrite it."
			." (but you can use Moo(se) or Class::Method::Modifiers to apply your own wrapper to this generated method)"
			if $stash->{sqlt_deploy_hook} && $stash->{sqlt_deploy_hook}{CODE};

		# Create the sub once, bound to this array.  The array can then be extended without
		# needing to re-declare the sub.
		no warnings 'closure';
		my @methods;
		eval 'sub '.$pkg.'::sqlt_deploy_hook {
			my $self= shift;
			$self->maybe::next::method(@_);
			for (@methods) {
				my ($m, @args)= @$_;
				$_[0]->$m(@args);
			}
		} 1' or die "failed to generate sqlt_deploy_hook: $@";
		\@methods;
	};
}
sub sqlt_add_index {
	my $pkg= $CALLER || caller;
	my $methods= _get_sqlt_hook_method_array($pkg);
	push @$methods, [ add_index => @_ ];
}

sub sqlt_add_constraint {
	my $pkg= $CALLER || caller;
	my $methods= _get_sqlt_hook_method_array($pkg);
	push @$methods, [ add_constraint => @_ ];
}

sub create_index {

lib/DBIx/Class/ResultDDL.pm  view on Meta::CPAN

method.  If C<add_column> exists it is presumably because you already declared a parent class.
Note that this check happens at BEGIN-time, so if you use Moo and C<< extends 'SomeClass'; >>
you need to wrap that in a begin block before the C<< use DBIx::Class::ResultDDL -V2 >> line.

=head2 C<-autoclean>

Remove all added symbols at the end of current scope.

=head2 C<-V2>

Implies C<-swp>, C<:V2>, and C<-autoclean>.

=head2 C<-V1>

Implies C<-swp>, C<:V1>, and C<-autoclean>.

=head2 C<-V0>

Implies C<-swp>, C<:V0>, and C<-autoclean>.

=head2 C<-inflate_datetime>

Inflate all date columns to DateTime objects, by adding the DBIC component
L<DBIx::Class::InflateColumn::DateTime>.

=head2 C<-inflate_json>

Causes all columns declared with C<json> or C<jsonb> sugar methods to also
declare L</inflate_json>.  This requires L<DBIx::Class::InflateColumn::Serializer>
to be installed (which is not an official dependency of this module).

=head2 C<-retrieve_defaults>

Causes all columns having a C<default_value> to also set C<< retrieve_on_insert => 1 >>.
This way after an insert for a row having a date column with C<< default_value => \'NOW()' >>,
the row object will hold the value of NOW() that was generated by the database.

See L<DBIx::Class::ResultSource/retrieve_on_insert> for details on the column flag.

This feature has no way of knowing about the existence of defaults in the database unless
they were declared here in DBIx::Class metadata, nor does it know about triggers or other
things that could cause the inserted row to be different from the insert request.

=head1 EXPORTED COLLECTIONS

=head2 C<:V2>

This tag selects the following symbols:

  table view
  col
    null default auto_inc fk
    integer unsigned tinyint smallint bigint decimal numeric money
    float float4 float8 double real
    char varchar nchar nvarchar MAX binary varbinary bit varbit
    blob tinyblob mediumblob longblob text tinytext mediumtext longtext ntext bytea
    date datetime timestamp enum bool boolean
    uuid json jsonb inflate_json array
  primary_key idx create_index unique sqlt_add_index sqlt_add_constraint
  rel_one rel_many has_one might_have has_many belongs_to many_to_many
    ddl_cascade dbic_cascade

=head2 C<:V1>

See L<DBIx::Class::ResultDDL::V1>.  The primary difference from V2 is a bug in
C<datetime($timezone)> where the timezone generated the wrong DBIC arguments.
Also it didn't support C<-retrieve_defaults>.

=head2 C<:V0>

See L<DBIx::Class::ResultDDL::V0>.  The primary difference from V1 is lack of array
column support, lack of index declaration support, and sugar methods do not pass
through leftover unknown arguments.  Also new Postgres column types were added in V1.

=head1 EXPORTED FUNCTIONS

=head2 table

  table 'foo';
  # becomes...
  __PACKAGE__->table('foo');

=head2 col

  col $name, @options;
  # becomes...
  __PACKAGE__->add_column($name, { is_nullable => 0, @merged_options });

Define a column.  This calls add_column after sensibly merging all your options.
It defaults the column to not-null for you, but you can override that by saying
C<null> in your options.
You will probably use many of the methods below to build the options for the column:

=head3 null

  is_nullable => 1

=head3 auto_inc

  is_auto_increment => 1, 'extra.auto_increment_type' => 'monotonic'

(The 'monotonic' bit is required to correctly deploy on SQLite.  You can read the
L<gory details|https://github.com/dbsrgits/sql-translator/pull/26> but the short
version is that SQLite gives you "fake" autoincrement by default, and you only get
real ANSI-style autoincrement if you ask for it.  SQL::Translator doesn't ask for
the extra work by default, but if you're declaring columns by hand expecting it to
be platform-neutral, then you probably want this.  SQLite also requires data_type
"integer", and for it to be the primary key.)

=head3 fk

  is_foreign_key => 1

=head3 default

  # Call:                       Becomes:
  default($value)               default_value => $value
  default(@value)               default_value => [ @value ]

=head3 integer, tinyint, smallint, bigint, unsigned

lib/DBIx/Class/ResultDDL.pm  view on Meta::CPAN

When writing the SQL, you need to ensure that "self." and whatever alias you chose
don't occur anywhere that you didn't intend; This module does not actually parse the
SQL, it just performs blind text substitution.

=head2 belongs_to

  belongs_to $name => $peer_class, $condition, @attr_list;
  belongs_to $name => { colname => "$ResultClass.$colname" }, @attr_list;
  belongs_to $name => 'JOIN $peer_class ON $sql', @attr_list;
  # becomes...
  __PACKAGE__->belongs_to($rel_name, $peer_class, $condition, { @attr_list });

=head2 might_have

  might_have $name => $peer_class, $condition, @attr_list;
  might_have $name => { colname => "$ResultClass.$colname" }, @attr_list;
  might_have $name => 'JOIN $peer_class ON $sql', @attr_list;
  # becomes...
  __PACKAGE__->might_have($rel_name, $peer_class, $condition, { @attr_list });

=head2 has_one

  has_one $name => $peer_class, $condition, @attr_list;
  has_one $name => { colname => "$ResultClass.$colname" }, @attr_list;
  has_one $name => 'JOIN $peer_class ON $sql', @attr_list;
  # becomes...
  __PACKAGE__->has_one($rel_name, $peer_class, $condition, { @attr_list });

=head2 has_many

  has_many $name => $peer_class, $condition, @attr_list;
  has_many $name => { colname => "$ResultClass.$colname" }, @attr_list;
  has_many $name => 'JOIN $peer_class ON $sql', @attr_list;
  # becomes...
  __PACKAGE__->has_many($rel_name, $peer_class, $condition, { @attr_list });

=head2 many_to_many

  many_to_many $name => $rel_to_linktable, $rel_from_linktable;
  # becomes...
  __PACKAGE__->many_to_many(@_);

=head2 rel_one

Declares a single-record left-join relation B<without implying ownership>.
Note that the DBIC relations that do imply ownership like C<might_have> I<cause an implied
deletion of the related row> if you delete a row from this table that references it, even if
your schema did not have a cascading foreign key.  This DBIC feature is controlled by the
C<cascading_delete> option, and using this sugar function to set up the relation defaults that
feature to "off".

  rel_one $name => $peer_class, $condition, @attr_list;
  rel_one $name => { $mycol => "$ResultClass.$fcol", ... }, @attr_list;
  rel_one $name => 'JOIN $peer_class ON $sql', @attr_list;
  # becomes...
  __PACKAGE__->add_relationship(
    $rel_name, $peer_class, { "foreign.$fcol" => "self.$mycol" },
    {
      join_type => 'LEFT',
      accessor => 'single',
      cascade_copy => 0,
      cascade_delete => 0,
      is_depends_on => $is_f_pk, # auto-detected, unless specified
      ($is_f_pk? fk_columns => { $mycol => 1 } : ()),
      @attr_list
    }
  );

=head2 rel_many

  rel_many $name => { $my_col => "$class.$col", ... }, @attr_list;
  rel_many $name => 'JOIN $peer_class ON $sql', @attr_list;

Same as L</rel_one>, but generates a one-to-many relation with a multi-accessor.

=head2 ddl_cascade

  ddl_cascade;     # same as ddl_cascade("CASCADE");
  ddl_cascade(1);  # same as ddl_cascade("CASCADE");
  ddl_cascade(0);  # same as ddl_cascade("RESTRICT");
  ddl_cascade($mode);

Helper method to generate C<@options> for above.  It generates

  on_update => $mode, on_delete => $mode

This does not affect client-side cascade, and is only used by Schema::Loader to generate DDL
for the foreign keys when the table is deployed.

=head2 dbic_cascade

  dbic_cascade;  # same as dbic_cascade(1)
  dbic_cascade($enabled);

Helper method to generate C<@options> for above.  It generates

  cascade_copy => $enabled, cascade_delete => $enabled

This re-enables the dbic-side cascading that was disabled by default in the C<rel_> functions.

=head2 view

  view $view_name, $view_sql, %options;

Makes the current resultsource into a view. This is used instead of
'table'. Takes two options, 'is_virtual', to make this into a
virtual view, and  'depends' to list tables this view depends on.

It is the equivalent of

  __PACKAGE__->table_class('DBIx::Class::ResultSource::View');
  __PACKAGE__->table($view_name);

  __PACKAGE__->result_source_instance->view_definition($view_sql);
  __PACKAGE__->result_source_instance->deploy_depends_on($options{depends});
  __PACKAGE__->result_source_instance->is_virtual($options{is_virtual});

=head1 INDEXES AND CONSTRAINTS

DBIx::Class doesn't actually track the indexes or constraints on a table.  If you want to add
these to be automatically deployed with your schema, you need an C<sqlt_deploy_hook> function.
This module can create one for you, but does not yet attempt to wrap one that you provide.
(You can of course wrap the one generated by this module using a method modifier from
L<Class::Method::Modifiers>)
The method C<sqlt_deploy_hook> is created in the current package the first time one of these
functions are called.  If it already exists and wasn't created by DBIx::Class::ResultDDL, it
will throw an exception.  The generated method does call C<maybe::next::method> for you.

=head2 sqlt_add_index

This is a direct passthrough to the function L<SQL::Translator::Schema::Table/add_index>,
without any magic.

See notes above about the generated C<sqlt_deploy_hook>.

=head2 sqlt_add_constraint

This is a direct passthrough to the function L<SQL::Translator::Schema::Table/add_constraint>,
without any magic.

See notes above about the generated C<sqlt_deploy_hook>.

=head2 create_index

  create_index $index_name => \@fields, %options;

This is sugar for sqlt_add_index.  It translates to

  sqlt_add_index( name => $index_name, fields => \@fields, options => \%options, type => $options{type} );

where the C<%options> are the L<SQL::Translator::Schema::Index/options>, except if
one of the keys is C<type>, then that key/value gets pulled out and used as
L<SQL::Translator::Schema::Index/type>.

=head2 idx

Alias for L</create_index>; lines up nicely with 'col'.