view release on metacpan or  search on metacpan

lib/Class/Easy.pm  view on Meta::CPAN

	our $VERSION = '0.18';
	our @ISA;

	use Class::Easy::Import;
	
	my $loaded;
	unless ($ENV{PERL_SUB_IDENTIFY_PP}) {
		local $@;
		eval {
			require XSLoader;
			XSLoader::load(__PACKAGE__, $VERSION);
		};
		
		die $@ if $@ && $@ !~ /object version|loadable object/;
		
		$loaded = 1 unless $@;
	}
	
	our $is_pure_perl = !$loaded;
	
	if ($is_pure_perl) {
		require Class::Easy::PP;
	}

}

require Class::Easy::Timer;

sub stash_name   ($) { (get_coderef_info($_[0]))[0] }
sub sub_name     ($) { (get_coderef_info($_[0]))[1] }
sub sub_fullname ($) { join '::', get_coderef_info($_[0]) }


our @EXPORT = qw(has try_to_use try_to_use_quiet try_to_use_inc try_to_use_inc_quiet make_accessor timer);
our @EXPORT_OK = qw(sub_name stash_name sub_fullname get_coderef_info);

our %EXPORT_FOREIGN = (
	'Class::Easy::Log' => [qw(debug critical debug_depth logger catch_stderr release_stderr)],
#	'Class::Easy::Timer' => [qw(timer)],
);

our $LOG = '';

sub timer {
	return Class::Easy::Timer->new (@_);
}

sub import {
	my $mypkg   = shift;
	my $callpkg = caller;
	
	my %params = @_;
	
	# use warnings
	${^WARNING_BITS} = $Class::Easy::Import::WARN;
	
	# use strict, use utf8;
	$^H |= $Class::Easy::Import::H;
	
	# use feature
	$^H{feature_switch} = $^H{feature_say} = $^H{feature_state} = 1;
	
	# probably check for try_to_use is enough
	return
		if defined *{"$callpkg\::try_to_use"}{CODE}
			and sub_fullname (*{"$callpkg\::try_to_use"}{CODE}) eq __PACKAGE__.'::__ANON__';
	
	# export subs
	*{"$callpkg\::$_"} = \&{"$mypkg\::$_"} foreach @EXPORT;
	foreach my $p (keys %EXPORT_FOREIGN) {
		*{"$callpkg\::$_"} = \&{"$p\::$_"} foreach @{$EXPORT_FOREIGN{$p}};
	}
}

sub has ($;%) {
	
	my ($caller) = caller;
	my $accessor = shift;
	
	return make_accessor ($caller, $accessor, _unless_exists => 1, @_);
}

sub make_accessor ($;$;$;%) {
	my $caller = shift;
	my $name   = shift;

	my $full_ref = "${caller}::$name";
	
	my $default;
	$default = pop
		if @_ == 1 or @_ == 3; # _from_has support
	
	die 'bad call from: ' . join (', ', caller)
		if scalar @_ % 2;
	my %config = @_;
	
	my $isa     = $config{isa};
	my $is      = $config{is} || 'ro';
	$default    = $config{default}
		if exists $config{default};
	
	$config{global} = 1
		if defined $default and $is eq 'ro';
	
	# when make_accessor called from has, we must check for already created
	# accessor and redefine only if redefined flag supplied
	if (delete $config{_unless_exists} and defined *{$full_ref}{CODE}) {
		return;
	}
	
	my $mode;
	$mode = 1 if $is eq 'ro';
	$mode = 2 if $is eq 'rw';
	
	die "unknown accessor type: $is"
		unless $is =~ /^r[ow]$/;
	
	if (ref $default eq 'CODE') {
		
		*{$full_ref} = $default;