package Object;

use strict; use warnings;
use Carp;
use Data::Dumper; # for clone

our $AUTOLOAD;

=pod

An object with attributes,
and a clone method.

To implement "virtual attributes",
subclass Object and implement
get_foo and/or set_foo methods.

You get foo() as shortcut for get_foo(),
foo($bar) as shortcut for set_foo($bar),
get("foo") and set("foo", $bar) for free.
Don't override these!

If an attribute starts with an underscore,
it can't be accessed with the methods.
Use this for "private" stuff.

TODO implement classes to wrap lists, etc. separately - maybe

=cut

sub new {
	my ($class, $self) = @_;
	$self ||= {};
	bless $self, $class;
	return $self;
}

sub get {
	my ($self, $attr) = @_;
	if ($attr =~ /^_/) {
		croak "can't read private attribute $attr";
	} elsif (my $method = $self->can("get_$attr")) {
		return $method->();
	} elsif (exists $self->{$attr}) {
		return $self->{$attr};
	} else {
		croak "no readable attribute: ".ref($self).".$attr";
	}
}

sub set {
	my ($self, $attr, $value) = @_;
	if ($attr =~ /^_/) {
		croak "can't write private attribute $attr";
	} elsif (my $method = $self->can("set_$attr")) {
		return $method->($value);
	} elsif (exists $self->{$attr}) {
		$self->{$attr} = $value;
	} else {
		croak "no writable attribute: ".ref($self).".$attr";
	}
}

sub AUTOLOAD {
	my ($self, $value) = @_;
	if (!ref $self) {
		croak "unknown sub $AUTOLOAD";
	}
	my $method = $AUTOLOAD;
	$method =~ s/.*:://;
	return if $method eq "DESTROY";
	my $attr;
	if (($attr) = $method =~ /^get_(.*)/) {
		exists $self->{$attr} or
			croak "no readable attribute: ".ref($self).".$attr";
		return $self->{$attr};
	} elsif (($attr) = $method =~ /^set_(.*)/) {
		exists $self->{$attr} or
			croak "no readable attribute: ".ref($self).".$attr";
		$self->{$attr} = $value;
	} else {
		if (@_ == 1) {
			return $self->get($method);
		} elsif (@_ == 2) {
			$self->set($method, $value);
		} else {
			croak "unknown sub $method, called with ".@_." arguments";
		}
	}
}

sub clone {
	my ($self) = @_;
	my $dump = Dumper($self);
	$dump =~ s/^\$\S+\s*=\s*// or die "Dumper behaving weirdly";
	return eval($dump);
}

1
