Dear monastery!
In continuation to
I tried to hack a proof of concept for a concise OO syntax
The basic ideas are that:
Declaration of instance variable
- my on the class level with :attributes
- the TYPE is given right after the my
- attributes reflect the Moo(se-)model of has keys where possible
- the assigned values are defaults for the new-constructor
Access of instance variables inside methods
- an instance variable x is readable and writable via $$x
- this is automatically mirrored in $self->{x}
- $self->{x} is an alternative syntax for the same access
$self
- $self is already shifted from @_ and directly available
Methods
- all subs declared inside the scope of a class are methods
- imported subs (like pp) are ignored
{
use Class BLA => ISA-LIST;
use Data::Dump qw/pp/;
my Int ($x,$y) :has :rw = (10,11);
sub set_x {
my ($var) = @_;
#warn "set_x $$x -> $var \n";
$$x = $var;
}
sub print_x {
print "x = $$x \n";
}
sub print_self_x {
print "x = $self->{x} (via \$self)\n";
}
sub dump {
warn '$self:',\$self;
warn pp '$self: ', $self;
warn pp '$$x: ', $$x;
warn pp '$$y: ', $$y;
}
}
The implementation is done via a macro expansion from use Class which injects some boilerplate into the head of the class, which handles the creation.
Injecting is basically done via a source filter or alternatively via Keyword::Simple. NB: just injecting some code doing introspection. No parsing, regexing or modification of the code you see.
I'm supposing this concise syntax could be used as a front end for all current OO models in Perl and might help offering a stable backwards compatible syntax if it's hardcoded into the engine.
A rough proof of concept follows here:
use strict;
use warnings;
use Data::Dump qw/pp/;
{
package EOS;
use Data::Dump qw/pp/;
use Sub::Util qw/subname/;
use PadWalker qw/set_closed_over/;
sub new {
my ($class, $package, $r_self) = @_;
return bless {package =>$package, r_self => $r_self}, "EOS";
}
sub show_subs {
my $this = shift;
my $pkg = $this->{package};
no strict "refs";
my $stash = \ %{"${pkg}::"};
my %methods;
while ( my($sym,$glob) = each %$stash) {
next unless my $code = *{$glob}{CODE};
#warn "fullname: ",
my $fullname = join "::", *{$glob}{PACKAGE}, $sym;
#warn "subname: ",
my $subname = subname($code);
next unless $subname eq $fullname;
#warn $fullname;
$methods{$fullname} = $code;
}
return %methods;
}
sub patch_methods {
my ($this, $a_attributes, $h_methods) = @_;
# warn pp \@_;
my $var_names =
join ", ",
map { keys %$_ }
@$a_attributes;
my $key_names =
join " ",
map { s/^\$//r }
map { keys %$_ }
@$a_attributes;
my %ref_map =
map { keys %$_ => map {$_->{ref}} values %$_ }
@$a_attributes;
$ref_map{'$self'} = $this->{r_self};
# warn pp
# '$var_names: ', $var_names,
# '$key_names: ', $key_names,
# '\%ref_map: ', \%ref_map;
while ( my ($name,$old_meth) = each %$h_methods) {
my $patch= <<"__CODE__";
my (\$self, $var_names); #closure
sub {
\$self = shift \@_;
#warn '\$self:',\\\$self;
($var_names) = \\ \@\$self{qw/$key_names/};
# warn "patch called";
# warn q/$var_names/, pp [$var_names];
goto \&\$old_meth;
};
__CODE__
#warn $patch;
my $c_patch = eval($patch) or die $@;
#warn pp '$c_patch: ', $c_patch;
set_closed_over($c_patch,\%ref_map);
#my $fake_self = {x=>30,y=>40};
#$c_patch->($fake_self);
#warn "redefining $name";
no warnings "redefine";
no strict "refs";
*{$name} = $c_patch;
}
#BLA::test({x=>30,y=>40});
#delete $ref_map{'$self'};
$this->new_constructor(\%ref_map);
}
sub new_constructor {
my ($this, $ref_map) = @_;
#warn "constructor: ", pp \@_;
my @var_names = grep {!/\$self/ } keys %$ref_map;
my @init = map { $$_ } @$ref_map{@var_names};
my @keys = map { s/^\$//r } @var_names;
my $pkg = $this->{package};
#my $r_self = $this->{'$self'};
# pp '@var_names: ', @var_names;
# pp '@init: ', @init;
# pp '@keys: ', @keys;
my $c_new = sub {
my $self= {};
@$self{@keys} = @init;
return bless $self, $pkg;
};
no strict 'refs';
*{"${pkg}::new"} = $c_new;
}
sub DESTROY {
my $self = shift;
# warn "DESTROYED",pp $self;
my %methods = $self->show_subs();
# warn pp \@BLA::__att__,\%methods;
$self->patch_methods(\@BLA::__att__,\%methods);
}
}
{
package Int;
use Data::Dump qw/pp/;
use PadWalker qw/var_name/;
sub MODIFY_SCALAR_ATTRIBUTES {
#warn pp
my ( $type, $ref, @att) = @_;
#warn pp
my (
$class
) = caller(1);
#warn
my $name = var_name(2, $ref);
no strict 'refs';
push @{"${class}::__att__"},
{
$name => {
ref => $ref,
att => \@att,
}
};
return ;
}
}
{
# use Class BLA => ISA-LIST
# ----start boilerplate
package BLA;
our @ISA = qw/ISA-LIST/;
my $self = {};
#warn '$self:',\$self;
my $__end_of_scope__ = EOS->new(__PACKAGE__, \ $self);
no warnings 'reserved'; # allow lowercase :attributes
# --- stop boilerplate
use Data::Dump qw/pp/;
my Int ($x,$y) :has :rw = (10,11);
sub dump {
warn '$self:',\$self;
warn pp '$self: ', $self;
warn pp '$$x: ', $$x;
warn pp '$$y: ', $$y;
}
sub set_x {
my ($var) = @_;
#warn "set_x $$x -> $var \n";
$$x = $var;
}
sub print_x {
print "x = $$x \n";
}
sub print_self_x {
print "x = $self->{x} (via \$self)\n";
}
}
my $obj = BLA->new();
$obj->print_x();
$obj->set_x(666);
$obj->print_x();
$obj->set_x(42);
$obj->print_self_x;
#$obj->dump();
NB: This example is pretty barebone, and not meant to be an alternative to other OO Frameworks, but rather a frontend.
It doesn't create accessors and the constructor is only simplistic.
Comments?