package Base;

sub new {
    my $class = shift;
    bless { @_ }, $class;
};

sub make_attr_subs {
    my $self = shift;
    $self->{Base_called} = 1;
};


package Singleton;

my %Singleton;
sub new { 
    my $class = shift;
    return $Singleton{$class} ||= $class->NEXT::new(@_);
};


package ReadOnly;
use NEXT;

sub make_attr_subs {
    my $self = shift;
    $self->{ReadOnly_called} = 1;
    $self->NEXT::make_attr_subs;
};


package ReadOnlySingleton;
use base qw(Singleton ReadOnly Base);


package main;
use Test::More 'no_plan';

sub new_object { ReadOnlySingleton->new };

isa_ok new_object(), 'ReadOnlySingleton';

is new_object(), new_object(), 'object is a singleton';

my $o = new_object();
$o->make_attr_subs;
ok $o->{Base_called}, 'make_attr_subs in Base called';
ok $o->{ReadOnly_called}, 'make_attr_subs in ReadOnly called';