File Coverage

blib/lib/Class/Easy.pm

Criterion	Covered	Total	%
statement	129	149	86.5
branch	49	60	81.6
condition	15	27	55.5
subroutine	19	23	82.6
pod	12	12	100.0
total	224	271	82.6

package Class::Easy;

# PORTIONS FROM Sub::Identify and common::sense

BEGIN {
	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;

	} elsif ($config{global}) {

		*{$full_ref} = sub {

			my $c = @_;

			# return &$default if $c == 1 and ref $default eq 'CODE';
			return $default if $c == 1;
			_has_error ($caller, $name, $c - 1) if $c ^ $mode;

			make_accessor (ref $_[0] || $_[0], $name, %config, default => $_[1]);
		};

	} else {
		*{$full_ref} = sub {

			my $c = @_;

			return $_[0]->{$name} if $c == 1;
			_has_error ($caller, $name, $c - 1) if $c ^ $mode;

			$_[0]->{$name} = $_[1];

		};

	}
}

sub _has_error {
	my $caller = shift;
	my $name   = shift;
	my $argc   = shift;

	my ($acc_caller, $line) = (caller(1))[0, 2];
	die "too many parameters ($argc) for accessor $caller\->$name at $acc_caller line $line.\n";
}

sub _try_to_use {
	my $use_lib = shift;
	my $quiet   = shift;
	my @chunks  = @_;

	my $package = join  '::', @chunks;
	@chunks     = split '::', $package;
	my $path    = join ('/', @chunks) . '.pm';

	$@ = '';

	if ($use_lib) {
		return "exists in \%INC"
			if exists $INC{$path};
	} else {
		# OLD: we removed "or ! exists $INC{$path}" statement because
		# "used" package always available via symbol table
		if (eval ("scalar grep {!/\\w+\:\:/} keys \%$package\::;") > 0) {
			return "exists in symbol table";
		}
	}

	eval "use $package";

	if ($@) {
		Class::Easy::Log::debug ("i can't load module ($path): $@")
			unless $quiet;
		return;
	}

	return 1;
}

sub try_to_use {
	return _try_to_use (0, 0, @_);
}

sub try_to_use_quiet {
	return _try_to_use (0, 1, @_);
}

sub try_to_use_inc {
	return _try_to_use (1, 0, @_);
}

sub try_to_use_inc_quiet {
	return _try_to_use (1, 1, @_);
}

sub list_local_subs_for {
	my $module = shift;
	my $enum_imported = shift || 0;

	my $namespace = \%{$module . '::'};

	my @sub_list = grep {
		defined *{"$module\::$_"}{CODE}
	} keys %{$namespace};

	my $sub_by_type = {
		method   => {},
		imported => {},
		runtime  => {}
	};

	foreach my $sub (@sub_list) {
		my ($real_package, $real_sub) = (get_coderef_info (*{"$module\::$sub"}{CODE}));

		if ($real_package eq $module) {
			$sub_by_type->{method}->{$sub} = 1;
		} elsif ($real_sub eq '__ANON__') {
			$sub_by_type->{runtime}->{$sub} = 1;
		} else {
			$sub_by_type->{imported}->{$real_package}->{$real_sub} = $sub; # who needs $real_sub ?
		}
	}

	wantarray
		? (keys %{$sub_by_type->{method}}, keys %{$sub_by_type->{runtime}})
		: $sub_by_type;
}

sub list_all_subs_for {
	my $module = shift || (caller)[0];
	my $filter = shift || '';

	$module = ref $module
		if ref $module;

	my $namespace = \%{$module . '::'};

	my $linear_isa;

	if ($] < 5.009_005) {
		require Class::Easy::MRO;
		$linear_isa = __get_linear_isa ($module);
	} else {
		require mro;
		$linear_isa = mro::get_linear_isa ($module);
	}

	my $sub_by_type = list_local_subs_for ($module);
	$sub_by_type->{inherited}->{$_} = [list_local_subs_for ($_)]
		foreach grep {$_ ne $module} @$linear_isa;

	wantarray
		? (
			keys %{$sub_by_type->{method}},
			keys %{$sub_by_type->{runtime}},
			map {@{$sub_by_type->{inherited}->{$_}}} keys %{$sub_by_type->{inherited}})
		: $sub_by_type;
}

1;

=head1 NAME

Class::Easy - make class routine easy

=head1 ABSTRACT

This module is a functionality compilation of some good modules from CPAN.
Ideas are taken from Class::Data::Inheritable, Class::Accessor, Modern::Perl
and Moose at least.

Instead of building monstrous alternatives to Moose or making thousand modules
for every function I need, I decide to write small and efficient libraries for
everyday use. Class::Easy::Base is a base component for classes.

=head1 SYNOPSIS

SYNOPSIS

	# automatic loading of strict, warnings and utf8, like common::sense
	use Class::Easy::Import;
	# or same as above + functions like 'has', 'try_to_use', 'timer' and 'logger'
	use Class::Easy;

	# try to load package IO::Easy, return 1 when success
	try_to_use ('IO::Easy');

	# try to load package IO::Easy, but search for package existence
	# within %INC instead of symbolic table
	try_to_use_inc ('IO::Easy');

	# for current package
	has "property_ro"; # make readonly object accessor
	has "property_rw", is => 'rw'; # make readwrite object accessor

	has global25 => 25; # make readonly static accessor with value 25
	has "global", global => 1, is => 'rw'; # make readwrite static accessor

	# make subroutine in package main
	make_accessor ('main', 'initialize', default => sub {
		$::initialized = 1;
		return "initialized!";
	});

	# see documentation for Class::Easy::Log

	# string "[PID] [PACKAGE(STRING)] [DBG] something" logged
	debug "something";

	# see documentation for Class::Easy::Timer

	my $t = timer ('long operation');
	# … long operation

	my $time = $t->lap ('another long op');
	# …

	$time = $t->end;
	# $time contains time between last 'lap' or 'timer'
	# and 'end' call

	$time = $t->total;
	# now $time contains total time between timer init
	# and end call

=head1 FUNCTIONS

=head2 has ($name [, is => 'ro' | 'rw'] [, default => $default], [, global => 1])

create accessor named $name in current scope

=cut

=head2 make_accessor ($scope, $name)

create accessor in selected scope

=cut

=head2 try_to_use, try_to_use_quiet

tries to use specified package with printing error message to STDERR
or "_quiet" version.

return true value in case of successful operation or existing non-package
references in symbol table. correctly works with virtual packages.

takes package name or package name chunks, for example:

	try_to_use ('IO::Easy');
	# or equivalent
	try_to_use (qw(IO Easy));

if you want to separate io errors from syntax errors you may want to
check $! variable;

for example:

	use Errno qw(:POSIX);

	if (!try_to_use ('IO::Easy')) {
		die 'file not found for package IO::Easy'
			if $!{ENOENT};
	}

=cut

=head2 try_to_use_inc, try_to_use_inc_quiet

similar to the try_to_use, but check for module presence in %INC
instead of symbol table lookup.

=cut

=head2 timer

create new L object

=cut

=head2 get_coderef_info, stash_name, sub_name, sub_fullname

retrieve real name for coderef. useful for anonymous or imported functions

	get_coderef_info (*{Class::Easy::timer}{CODE}); # ('Class::Easy', 'timer')
	stash_name (*{Class::Easy::timer}{CODE}); # 'Class::Easy'
	sub_name (*{Class::Easy::timer}{CODE}); # 'timer'
	sub_fullname (*{Class::Easy::timer}{CODE}); # 'Class::Easy::timer'

=cut

=head2 list_all_subs_for, list_local_subs_for

in scalar context return hashref with complete coderef info for class.
 - key 'inherited' contains all inherited methods, separated by class name,
 - key 'runtime' contains all code references in current package which point
to anonymous method,
 - key 'method' contains all local methods,
 - key 'imported' contains all imported subs, separated by class name

	{
		'inherited' => {
			'My::Circle' => [
				'new',
				'global_hash',
				'global_hash_rw',
				'new_default',
				'global_hash_rw_default',
				'dim_x',
				'id',
				'dim_y'
			]
		},
		'runtime' => {
			'global_ro' => 1,
			'global_one' => 1,
			'global_one_defined' => 1,
			'dim_z' => 1,
			'accessor' => 1
		},
		'method' => {
			'sub_z' => 1
		},
		'imported' => {
			'Class::Easy' => {
				'make_accessor' => 'make_accessor',
				'try_to_use' => 'try_to_use',
				'try_to_use_inc' => 'try_to_use_inc',
				'try_to_use_quiet' => 'try_to_use_quiet',
				'has' => 'has',
				'timer' => 'timer',
				'try_to_use_inc_quiet' => 'try_to_use_inc_quiet'
			},
			'Class::Easy::Log' => {
				'critical' => 'critical',
				'release_stderr' => 'release_stderr',
				'catch_stderr' => 'catch_stderr',
				'debug' => 'debug',
				'debug_depth' => 'debug_depth',
				'logger' => 'logger'
			}
		}
	};

'local' version of subroutine doesn't contains any inherited methods


=cut



=head1 AUTHOR

Ivan Baktsheev, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to my email address,
or through the web interface at L.
I will be notified, and then you'll automatically be notified
of progress on your bug as I make changes.

=head1 SUPPORT



=head1 ACKNOWLEDGEMENTS



=head1 COPYRIGHT & LICENSE

Copyright 2008-2009 Ivan Baktsheev

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut