File Coverage

blib/lib/DBIx/Class/ResultDDL.pm

Criterion	Covered	Total	%
statement	291	321	90.6
branch	100	154	64.9
condition	70	143	48.9
subroutine	84	103	81.5
pod	68	74	91.8
total	613	795	77.1

package DBIx::Class::ResultDDL;
# capture the default values of $^H and $^W for this version of Perl
BEGIN { $DBIx::Class::ResultDDL::_default_h= $^H; $DBIx::Class::ResultDDL::_default_w= $^W; }
use Exporter::Extensible -exporter_setup => 1;
use B::Hooks::EndOfScope 'on_scope_end';
use Carp;

# ABSTRACT: Sugar methods for declaring DBIx::Class::Result data definitions
our $VERSION = '2.04'; # VERSION


our $CALLER; # can be used localized to wrap caller context into an anonymous sub

sub swp :Export(-) {
	my $self= shift;
	require strict; strict->import if $^H == $DBIx::Class::ResultDDL::_default_h;
	require warnings; warnings->import if $^W == $DBIx::Class::ResultDDL::_default_w;
	$self->_inherit_dbic;
}
sub _inherit_dbic {
	my $self= shift;
	my $pkg= $self->{into};
	unless ($pkg->can('load_components') && $pkg->can('add_column')) {
		require DBIx::Class::Core;
		no strict 'refs';
		push @{ $pkg . '::ISA' }, 'DBIx::Class::Core';
	}
}


our $DISABLE_AUTOCLEAN;
sub autoclean :Export(-) {
	return if $DISABLE_AUTOCLEAN;
	my $self= shift;
	my $sref= $self->exporter_config_scope;
	$self->exporter_config_scope($sref= \my $x) unless $sref;
	on_scope_end { $$sref->clean };
}


sub V2 :Export(-) {
	shift->exporter_also_import('-swp',':V2','-autoclean');
}
sub exporter_autoload_symbol {
	my ($self, $sym)= @_;
	if ($sym =~ /^-V([0-9]+)$/) {
		my $tag= ":V$1";
		my $method= sub { shift->exporter_also_import('-swp',$tag,'-autoclean') };
		return $self->exporter_register_option("V$1", $method);
	}
	return shift->next::method(@_);
}

# The functions and tag list for previous versions are not loaded by default.
# They are contained in a separate package ::V$N, which inherits many methods
# from this one but then overrides all the ones whose API were different in
# the past version.
# In order to make those versions exportable, they have to be loaded into
# the cache or symbol table of this package before they can be added to a tag
# to get exported.  This also requires that they be given a different name
# The pattern used here is to prefix "v0_" and so on to the methods which
# are re-defined in the subclass.
sub exporter_autoload_tag {
	my ($self, $name)= @_;
	my $class= ref $self || $self;
	if ($name =~ /^V([0-9]+)$/) {
		my $v_pkg= "DBIx::Class::ResultDDL::$name";
		my $v= $1;
		eval "require $v_pkg"
			or croak "Can't load package $v_pkg: $@";
		my $ver_exports= $v_pkg->exporter_get_tag($name);
		# For each tag member, see if it is the same as the method in this class.
		# If not, bring it in as v${X}_${name} and then export { -as => $name }
		my @tag;
		for (@$ver_exports) {
			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, @_ }
sub smallint    { data_type => 'smallint',  size =>  6, @_ }
sub bigint      { data_type => 'bigint',    size => 22, @_ }
sub decimal     { _numeric(decimal => @_) }
sub numeric     { _numeric(numeric => @_) }
sub _numeric    {
	my $type= shift;
	my $precision= &_maybe_size;
	my $size;
	if (defined $precision) {
		my $scale= &_maybe_size;
		$size= defined $scale? [ $precision, $scale ] : [ $precision ];
	}
	return data_type => $type.&_maybe_array, ($size? ( size => $size ) : ()), @_;
}
sub money       { data_type => 'money'.&_maybe_array, @_ }
sub double      { data_type => 'double precision'.&_maybe_array, @_ }
sub float8      { data_type => 'float8'.&_maybe_array, @_ }
sub real        { data_type => 'real'.&_maybe_array, @_ }
sub float4      { data_type => 'float4'.&_maybe_array, @_ }
# the float used by SQL Server allows variable size spec as number of bits of mantissa
sub float       { my $size= &_maybe_size; data_type => 'float'.&_maybe_array, (defined $size? (size => $size) : ()), @_ }


sub char        { my $size= &_maybe_size;  data_type => 'char'.&_maybe_array, size => $size || 1, @_ }
sub nchar       { my $size= &_maybe_size;  data_type => 'nchar'.&_maybe_array, size => $size || 1, @_ }
sub varchar     { my $size= &_maybe_size_or_max;  data_type => 'varchar'.&_maybe_array, size => $size, @_ }
sub nvarchar    { my $size= &_maybe_size_or_max;  data_type => 'nvarchar'.&_maybe_array, size => $size, @_ }
sub binary      { my $size= &_maybe_size_or_max;  data_type => 'binary'.&_maybe_array, size => $size, @_ }
sub varbinary   { my $size= &_maybe_size_or_max;  data_type => 'varbinary'.&_maybe_array, size => $size, @_ }
sub bit         { my $size= &_maybe_size; data_type => 'bit'.&_maybe_array, size => (defined $size? $size : 1), @_ }
sub varbit      { my $size= &_maybe_size; data_type => 'varbit'.&_maybe_array, (defined $size? (size => $size) : ()), @_ }
sub MAX         { 'MAX' }

# postgres blob type
sub bytea       { data_type => 'bytea'.&_maybe_array, @_ }

# These aren't valid for Postgres, so no array notation needed
sub blob          { my $size= &_maybe_size;  data_type => 'blob', (defined $size? (size => $size) : ()), @_ }
sub tinyblob      { data_type => 'tinyblob',  size => 0xFF, @_ }
sub mediumblob    { data_type => 'mediumblob',size => 0xFFFFFF, @_ }
sub longblob      { data_type => 'longblob',  size => 0xFFFFFFFF, @_ }

sub text          { my $size= &_maybe_size_or_max;  data_type => 'text'.&_maybe_array, (defined $size? (size => $size) : ()), @_ }
sub ntext         { my $size= &_maybe_size_or_max;  data_type => 'ntext', size => ($size || 0x3FFFFFFF), @_ }
sub tinytext      { data_type => 'tinytext',  size => 0xFF, @_ }
sub mediumtext    { data_type => 'mediumtext',size => 0xFFFFFF, @_ }
sub longtext      { data_type => 'longtext',  size => 0xFFFFFFFF, @_ }


sub enum        { data_type => 'enum', 'extra.list' => [ @_ ]}
sub boolean     { data_type => 'boolean'.&_maybe_array, @_ }
sub bool        { data_type => 'boolean'.&_maybe_array, @_ }


sub date        { data_type => 'date'.&_maybe_array, @_ }
sub datetime    { my $tz= &_maybe_timezone; data_type => 'datetime'.&_maybe_array, ($tz? (timezone => $tz) : ()), @_ }
sub timestamp   { my $tz= &_maybe_timezone; data_type => 'timestamp'.&_maybe_array,($tz? (timezone => $tz) : ()), @_ }


sub array {
	# If one argument and the argument is a string, then it is a type name
	if (@_ == 1 && $_[0] && !ref $_[0]) {
		return data_type => $_[0] . '[]';
	}
	# Else, scan through argument list looking for data_type, and append [] to following item.
	my $data_type_idx;
	for (my $i= 0; $i < @_; $i++) {
		$data_type_idx= $i+1 if $_[$i] eq 'data_type'
	}
	$data_type_idx && $_[$data_type_idx] && !ref $_[$data_type_idx]
		or die 'array needs a type';
	$_[$data_type_idx] .= '[]';
	return @_;
}


sub uuid          { data_type => 'uuid'.&_maybe_array, @_ }


# This is a generator that includes the json_args into the installed method.
sub json {
	my $pkg= ($CALLER||caller);
	my $defaults= _settings_for_package($pkg)->{json_defaults};
	return data_type => 'json'.&_maybe_array, ($defaults? %$defaults : ()), @_
}
sub jsonb {
	my $pkg= ($CALLER||caller);
	my $defaults= _settings_for_package($pkg)->{json_defaults};
	return data_type => 'jsonb'.&_maybe_array, ($defaults? %$defaults : ()), @_
}

sub inflate_json {
	my $pkg= ($CALLER||caller);
	$pkg->load_components('InflateColumn::Serializer')
		unless $pkg->isa('DBIx::Class::InflateColumn::Serializer');
	return serializer_class => 'JSON', @_;
}


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 {
	my $pkg= $CALLER || caller;
	my $name= ref $_[0]? undef : shift;
	my $fields= shift;
	ref $fields eq 'ARRAY'
		or croak((defined $name? 'Second':'First').' argument must be arrayref of index fields');
	my %options= @_;
	my $type= delete $options{type};  # this is an attribute of Index, not a member of %options
	my $methods= _get_sqlt_hook_method_array($pkg);
	push @$methods, [
		add_index =>
			(defined $name? (name => $name) : ()),
			fields => $fields,
			(keys %options? (options => \%options) : ()),
			(defined $type? (type => $type) : ())
	];
}

BEGIN { *idx= *create_index; }


sub expand_col_options {
	my $pkg= shift;
	my $opts= { is_nullable => 0 };
	# Apply options to the hash in order, so that they get overwritten as expected
	while (@_) {
		my ($k, $v)= (shift, shift);
		$opts->{$k}= $v, next
			unless index($k, '.') >= 0;
		# We support "foo.bar => $v" syntax which we convert to "foo => { bar => $v }"
		# because "foo => { bar => 1 }, foo => { baz => 2 }" would overwrite eachother.
		my @path= split /\./, $k;
		$k= pop @path;
		my $dest= $opts;
		$dest= ($dest->{$_} ||= {}) for @path;
		$dest->{$k}= $v;
	}
	$opts->{retrieve_on_insert}= 1
		if $opts->{default_value} and !defined $opts->{retrieve_on_insert}
			and _settings_for_package($pkg)->{retrieve_defaults};
	return $opts;
}

sub expand_relationship_params {
	my ($pkg, $reltype, $relname, $maybe_colmap)= splice(@_, 0, 4);
	my ($rel_pkg, $dbic_colmap, %opts)= ref $maybe_colmap eq 'HASH'? _translate_colmap($maybe_colmap, $pkg)
		: !ref $maybe_colmap && $maybe_colmap =~ /JOIN /? _translate_join_sql($maybe_colmap, $pkg)
		: !ref $maybe_colmap? ( _interpret_pkg_name($maybe_colmap, $pkg), shift )
		: croak "Unexpected arguments";
	%opts= (%opts, @_);
	return $pkg, $reltype, $relname, $rel_pkg, $dbic_colmap, \%opts;
}

sub _interpret_pkg_name {
	my ($rel_class, $current_pkg)= @_;
	# Related class may be relative to same namespace as current
	return $rel_class if index($rel_class, '::') >= 0;
	my ($parent_namespace)= ($current_pkg =~ /(.*)::[^:]+$/);
	return $parent_namespace.'::'.$rel_class;
}

# DBIC is normally { foreign.col => self.col } but I don't think that's very intuitive,
# so allow an alternate notation of { self_col => CLASS.col } and automatically determine
# which the user is using.
sub _translate_colmap {
	my ($colmap, $self_pkg)= @_;
	my ($rel_class, $direction, %result, $inconsistent)= ('',0);
	# First pass, find the values for $rel_class and $reverse
	for (keys %$colmap) {
		my ($key, $val)= ($_, $colmap->{$_});
		if ($key =~ /([^.]+)\.(.*)/) {
			if ($1 eq 'self') {
				$direction ||= 1;
				++$inconsistent if $direction < 0;
			}
			else {
				$direction ||= -1;
				++$inconsistent if $direction > 0;
				if ($1 ne 'foreign') {
					$rel_class ||= $1;
					++$inconsistent if $rel_class ne $1;
				}
			}
		}
		if ($val =~ /([^.]+)\.(.*)/) {
			if ($1 eq 'self') {
				$direction ||= -1;
				++$inconsistent if $direction > 0;
			}
			else {
				$direction ||= 1;
				++$inconsistent if $direction < 0;
				if ($1 ne 'foreign') {
					$rel_class ||= $1;
					++$inconsistent if $rel_class ne $1;
				}
			}
		}
	}
	croak "Inconsistent {self=>foreign} notation found in relation mapping"
		if $inconsistent;
	croak "Must reference foreign Result class name in one of the keys or values of relation mapping"
		unless $rel_class && $direction;
	# Related class may be relative to same namespace as current
	$rel_class= _interpret_pkg_name($rel_class, $self_pkg);

	# Second pass, rename the keys & values to DBIC canonical notation
	for (keys %$colmap) {
		my ($key, $val)= ($_, $colmap->{$_});
		$key =~ s/.*\.//;
		$val =~ s/.*\.//;
		$result{ $direction > 0? "foreign.$val" : "foreign.$key" }= $direction > 0? "self.$key" : "self.$val";
	}
	return $rel_class, \%result;
}

sub _translate_join_sql {
	my ($sql, $self_pkg)= @_;
	my ($join_type, $rsrc, $alias, $on, $tpl)
		= ($sql =~ /^\s*(LEFT\s*|INNER\s*)?JOIN\s+(\S+)\s+(\w+)\s+(ON\s+)?(.*)/si)
		or Carp::croak("Can't pase SQL, make sure it starts with (LEFT)? JOIN \$class (\$alias)? ON ...\n$sql");
	my $rel_class= _interpret_pkg_name($rsrc, $self_pkg);
	my $replace= $alias =~ /^ON\s*$/i? $rsrc : $alias;
	$tpl =~ s/(["\$\@\\])/\\$1/g;
	$tpl =~ s/\b\Q$replace\E[.]/\$_[0]{foreign_alias}./g;
	$tpl =~ s/\bself[.]/\$_[0]{self_alias}./g;
	my $tpl_fn= eval 'sub { \"'.$tpl.'" }' or die "$@\n in generated expression \"$tpl\"";
	return $rel_class, $tpl_fn, ($join_type? (join_type => $join_type) : () );
}


1;

__END__