#!/usr/bin/perl
# Object.pm

package Pixie::Object;

use strict;
use warnings;

require v5.6.0;

use attributes ();
use Exception::Class ('PrivateFieldException' => {isa => 'Exception::Class::Base', fields => ['field_name']},
		      'NoSuchMemberException' => {isa => 'Exception::Class::Base', fields => ['field_name']});

my %overrides;

sub FETCH_CODE_ATTRIBUTES {
    my ($package, $referrent) = @_;
    return exists $overrides{$referrent} ? $overrides{$referrent} : ();
}

sub MODIFY_CODE_ATTRIBUTES {
    my ($package, $referrent, @attrs) = @_;
    my @return;

    local $_;
    foreach (@attrs) {
	if($_ eq 'override') {
	    $overrides{$referrent} = 'override';
	} else {
	    push @return, $_;
	}
    }
    return @return;
}

sub AUTOLOAD {
    my $this = shift;
    my $member = our $AUTOLOAD;
    $member =~ s/.*:://g;
    return unless($member =~ /[^A-Z]/);
    return $this->($member, @_);
}

sub new {
    my ($class, $members) = @_;
    my %members;

    my $this = bless sub {
	my ($key, $value) = @_;
	my ($package, $filename, $line) = caller;
	if($package ne __PACKAGE__) {
	    # Allow protected access?
	    PrivateFieldException->throw(message => 'Direct access of a private field was attempted', field_name => $key);
	}
	unless(exists $members{$key}) {
	    NoSuchMemberException->throw(message => 'No such member exists', field_name => $key);
	}
	$members{$key} = $value if($value);
	return $members{$key};
    }, $class;

    if($members) {
	while(my($key, $value) = each %$members) {
	    $members{$key} = $value;
	    if($this->can($key)) {
		# Do something more extreme?
		my @attributes = eval "attributes::get(\\&{\$this->$key})";
		print "$key : @attributes\n";
		warn "$class already has a method $key; this will be used instead of field access." . 
		      " Attach attribute override to that method if you would like to suppress this message.";
	    }
	}
    }

    return $this;
}
1;

#!/usr/bin/perl
# TestObject.pm

# Test subclass for Pixie::Object
package TestObject;

use strict;
use warnings;

require Pixie::Object;

our @ISA = qw(Pixie::Object);
our $VERSION = 1.0;

sub new {
    my $class = shift;
    return Pixie::Object::new($class, {foo => 56});
}

sub foo : override {
    return "Howdy";
}
1;