my $obj = ClosureObj->new();
isa_ok( $obj => 'ClosureObj' );
####
eval { $obj->('foo') };
ok( $@ =~ /^Attempt to access private class data/,
"Stop from accessing class data" );
##
##
eval { $obj->foop() };
ok( $@ =~ /^No such field/, "Stop from accessing non-existant data" );
##
##
$obj->foo(3);
ok( $obj->foo == 3, "Foo is set" );
##
##
{
no warnings; # About unintitlized vars
$obj->foo(undef);
ok( $obj->foo == undef, "Foo can be set to undef" );
}
##
##
my $obj2 = ClosureObj->new();
isa_ok( $obj2 => 'ClosureObj' );
$obj->foo(2);
$obj2->foo(3);
ok( ($obj->foo == 2) && ($obj2->foo == 3),
"Change in one object doesn't affect other" );
##
##
my $sub_obj = SubClosureObj->new();
isa_ok( $sub_obj => 'SubClosureObj' );
$sub_obj->bar(4);
ok( $sub_obj->bar == 4, "Sub object can set values" );
##
##
sub new
{
my $class = shift;
my %field = (
foo => 1,
bar => 1,
baz => 1,
class => $class,
);
bless sub {
my $name = shift;
my ($package, $filename, $line) = caller;
die "Attempt to access private class data " .
"for $field{class} at $filename line $line\n"
unless UNIVERSAL::isa(
$package => __PACKAGE__ );
die "No such field '$name' at $filename line $line\n"
unless exists $field{$name};
die "You can't change the class name " .
"at $filename line $line\n"
if $name eq 'class';
$field{$name} = shift if @_;
$field{$name};
} => $class;
}
##
##
{
my %fields = ( . . . );
sub new
{
my $class = shift;
$fields{class} = $class;
bless sub {
# Same as before
} => $class;
}
}
##
##
sub foo
{
my $self = shift;
$self->('foo', shift) if @_;
$self->('foo');
}
sub foop
{
my $self = shift;
$self->('foop', shift) if @_;
$self->('foop');
}
##
##
package SubClosureObj;
use base qw( ClosureObj );
sub bar
{
my $self = shift;
$self->('bar', shift) if @_;
$self->('bar');
}
##
##
#!/usr/bin/perl
package ClosureObj;
use strict;
use warnings;
sub new
{
my $class = shift;
my %field = (
foo => 1,
bar => 1,
baz => 1,
class => $class,
);
bless sub {
my $name = shift;
my ($package, $filename, $line) = caller;
die "Attempt to access private class data " .
"for $field{class} at $filename line $line\n"
unless UNIVERSAL::isa(
$package => __PACKAGE__ );
die "No such field '$name' at $filename line $line\n"
unless exists $field{$name};
die "You can't change the class name " .
"at $filename line $line\n"
if $name eq 'class';
$field{$name} = shift if @_;
$field{$name};
} => $class;
}
sub foo
{
my $self = shift;
$self->('foo', shift) if @_;
$self->('foo');
}
sub foop
{
my $self = shift;
$self->('foop', shift) if @_;
$self->('foop');
}
package SubClosureObj;
use base qw( ClosureObj );
sub bar
{
my $self = shift;
$self->('bar', shift) if @_;
$self->('bar');
}
package main;
use Test::More tests => 9;
my $obj = ClosureObj->new();
isa_ok( $obj => 'ClosureObj' );
eval { $obj->('foo') };
ok( $@ =~ /^Attempt to access private class data/,
"Stop from accessing class data" );
eval { $obj->foop() };
ok( $@ =~ /^No such field/, "Stop from accessing non-existant data" );
$obj->foo(3);
ok( $obj->foo == 3, "Foo is set" );
{
no warnings; # About unintitlized vars
$obj->foo(undef);
ok( $obj->foo == undef, "Foo can be set to undef" );
}
my $obj2 = ClosureObj->new();
isa_ok( $obj2 => 'ClosureObj' );
$obj->foo(2);
$obj2->foo(3);
ok( ($obj->foo == 2) && ($obj2->foo == 3),
"Change in one object doesn't affect other" );
my $sub_obj = SubClosureObj->new();
isa_ok( $sub_obj => 'SubClosureObj' );
$sub_obj->bar(4);
ok( $sub_obj->bar == 4, "Sub object can set values" );