view release on metacpan or  search on metacpan

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

		warn "Unable to use ResultDDL sugar '$stmt'\n  "
			.deparse({ %col_info, %$out })." ne ".deparse($orig_col_info)."\n";
		$stmt= join(', ',
			map &_deparse_hashkey.' => '.deparse($orig_col_info->{$_}),
			sort keys %$orig_col_info
		);
	}
	return $stmt;
}


sub generate_relationship_sugar {
	my ($self, $class, $method, $relname, $foreignclass, $colmap, $options)= @_;
	#use DDP; &p(['before', @_[1..$#_]]);
	my $expr= '';
	# The $foreignclass $colmap arguments can be combined into a simpler
	#  hashref of { local_col => 'ForeignClass.colname' } as long as some expectations hold:
	my ($parent_ns)= ($class =~ /^(.*?::)([^:]+)$/);
	if (defined $parent_ns and !ref $foreignclass and (!ref $colmap || ref $colmap eq 'HASH')) {
		# Can we use a shortened class name for the foreign table?
		if ($foreignclass =~ /^(.*?::)([^:]+)$/ and $1 eq $parent_ns) {
			$foreignclass= $2;
		}
		my %newmap= ref $colmap eq 'HASH'? (%$colmap) : ($colmap => $colmap);
		# Just in case SchemaLoader prefixed them with 'self.' or 'foreign.'...
		s/^self[.]// for values %newmap;
		%newmap= reverse %newmap;
		s/^foreign[.]// for values %newmap;
		# Apply the foreign class name to the first column in the map
		my ($first_key)= sort keys %newmap;
		$newmap{$first_key}= $foreignclass . '.' . $newmap{$first_key};
		$expr .= deparse(\%newmap);
	} else {
		$expr .= deparse($foreignclass, $colmap);
	}
	if ($options && keys %$options) {
		$expr .= ', ' . $self->generate_relationship_attr_sugar($options);
	}

	# Test the syntax for equality to the original
	my $checkpkg= $self->_get_class_check_namespace($class);
	my @out;
	eval "package $checkpkg; \@out= DBIx::Class::ResultDDL::expand_relationship_params(\$class, \$method, \$relname, $expr);";
	@out or croak "Error verifying generated ResultDDL for $class $method $relname: $@";

	#use DDP; &p(['after', @out, $expr]);

	return $method . ' ' . deparse_hashkey($relname) . ' => ' . $expr . ';';
}


sub generate_relationship_attr_sugar {
	my ($self, $orig_options)= @_;
	my %options= %$orig_options;
	my @expr;
	if (defined $options{on_update} && defined $options{on_delete}
		&& $options{on_update} eq $options{on_delete}
	) {
		my $val= delete $options{on_update};
		delete $options{on_delete};
		push @expr, $val eq 'CASCADE'? 'ddl_cascade'
			: $val eq 'RESTRICT'? 'ddl_cascade(0)'
			: 'ddl_cascade('.deparse($val).')'
	}
	if (defined $options{cascade_copy} && defined $options{cascade_delete}
		&& $options{cascade_copy} eq $options{cascade_delete}
	) {
		my $val= delete $options{cascade_copy};
		delete $options{cascade_delete};
		push @expr, $val eq '1'? 'dbic_cascade'
			: 'dbic_cascade('.deparse($val).')'
	}
	push @expr, substr(deparse(\%options),2,-2) if keys %options;
	return join ', ', @expr
}

my %rel_methods= map +($_ => 1), qw( belongs_to might_have has_one has_many );
sub _dbic_stmt {
	my ($self, $class, $method)= splice(@_, 0, 3);
	# The first time we generate anything for each class, inject the 'use' line.
	$self->_raw_stmt($class, $self->generate_resultddl_import_line($class))
		unless $self->{_ResultDDL_SchemaLoader}{$class}{use_line}++;
	if ($method eq 'table') {
		$self->_raw_stmt($class, q|table |.deparse(@_).';');
	}
	elsif ($method eq 'add_columns') {
		my @col_defs;
		while (@_) {
			my ($col_name, $col_info)= splice(@_, 0, 2);
			push @col_defs, [
				deparse_hashkey($col_name),
				$self->generate_column_info_sugar($class, $col_name, $col_info)
			];
		}
		# align the definitions, but round up to help avoid unnecessary diffs
		# when new columns get added.
		my $widest= max map length($_->[0]), @col_defs;
		$widest= ($widest + 3) & ~3;
		$self->_raw_stmt($class, sprintf("col %-*s => %s;", $widest, @$_))
			for @col_defs;
	}
	elsif ($method eq 'set_primary_key') {
		$self->_raw_stmt($class, q|primary_key |.deparse(@_).";");
	}
	elsif ($rel_methods{$method} && @_ == 4) {
		# Add a linebreak before the relationships, for readability.
		$self->_raw_stmt($class, "\n")
			unless $self->{_ResultDDL_SchemaLoader}{$class}{relation_linebreak}++;
		$self->_raw_stmt($class, $self->generate_relationship_sugar($class, $method, @_));
	}
	else {
		$self->next::method($class, $method, @_);
	}
	return;
}

my %data_type_sugar= (
	(map {
		my $type= $_;
		$type => sub { my ($col_info)= @_;
			if ($col_info->{size} && $col_info->{size} =~ /^[0-9]+$/) {
				return "$type(".delete($col_info->{size})."),";
			} elsif ($col_info->{size} && ref $col_info->{size} eq 'ARRAY'
				&& ($#{$col_info->{size}} == 0 || $#{$col_info->{size}} == 1)
				&& (all { /^[0-9]+$/ } @{$col_info->{size}})
			) {
				return "$type(".join(',', @{delete($col_info->{size})})."),";
			} else {
				return $type;
			}
		}