File Coverage

blib/lib/Class/Light.pm

Criterion	Covered	Total	%
statement	60	63	95.2
branch	10	16	62.5
condition	4	12	33.3
subroutine	11	12	91.6
pod	0	1	0.0
total	85	104	81.7

package Class::Light;
# Copyright (c) 2009 Christopher Davaz. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Documentation at the __END__

use strict;
use warnings;
use vars qw($VERSION);
use Carp;

$VERSION = "0.01003";

sub new {
	my $class = shift;

	croak "Attempted instantiation of abstract class " + __PACKAGE__
		if $class eq __PACKAGE__;

	my $super = $class;
	my @super;

	# Find all super classes and add them to @super in hierarchical order.
	no strict 'refs';
	while ($super ne __PACKAGE__) {
		unshift @super, $super;
		$super = ${$super . "::ISA"}[0];
	}

	my $self = {};
	bless $self, $class;

	for (@super) {
		my $init = $_ . "::_init";
		&$init($self, @_) if exists &$init;
	}
	use strict 'refs';

	return $self;
}

# Subclasses should implement their own _init method.
sub init;

our $AUTOLOAD;
sub AUTOLOAD {
	my ($pkg, $method) = ($AUTOLOAD =~ /(.+)::(.+)/);
	my ($type, $attr)  = ($method   =~ /^(get|set)_?(.*)/);

	# We only handle methods that match the pattern /^(get|set)_?(.*)/
	croak "Unknown method: $AUTOLOAD" unless $type && $attr;

	my $origAttr = $attr;
	$attr = lcfirst $attr;

	# Don't allow calls such as "getattr", see documentation for details.
	if ($method eq $type . $attr && $origAttr eq $attr) {
		croak "Unknown method: $AUTOLOAD";
	}

	# Disallow access to private members
	unless ($type && $attr !~ /^_/ && exists $_[0]->{$attr}) {
		croak "Unknown method: $AUTOLOAD";
	}

	# We want to check if an alternative form of invocation is available
	# and if it is make an alias for that method instead of calling the
	# automatically generated one.
	my (@form) = (
		$pkg . "::" . $type . ucfirst $origAttr,
		$pkg . "::" . $type . "_" . $origAttr,
		$pkg . "::" . $type . "_" . $attr
	);

	no strict 'refs';
	for (@form) {
		if (exists &$_) {
			*{$AUTOLOAD} = \&$_;
			goto &{$AUTOLOAD};
		}
	}

	if ($type =~ /^get/) {
		*{$AUTOLOAD} = sub { return $_[0]->{$attr} };
	}
	elsif ($type =~ /^set/) {
		*{$AUTOLOAD} = sub {
			my $old = $_[0]->{$attr};
			$_[0]->{$attr} = $_[1];
			return $old;
		}
	}

	goto &{$AUTOLOAD};
}

sub DESTROY {}

1;
__END__