view release on metacpan or  search on metacpan

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

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($_)) {