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" );