reform - Third millenium syntax for Perl 5 OOP

    use reform;

    package Class < Base;

    fields foo,
           bar,
           baz;

    sub initialize($foo, $bar, $baz)
    {
        base->initialize($foo);
        self->foo = $foo;
        self->bar = $bar;
        self->baz = $baz;
    }

    sub method
    {
        print "Hi there";
        class->static_method();
    }

    sub get_foo
    {
    	print "Getting self->foo!";
    	return self->{foo};
    }

    sub set_foo($value)
    {
    	print "Setting self->foo!";
    	self->{foo} = $value;
    }

    package Child < Parent;

    sub method($foo, $bar)
    {
        print "First param: $foo";
        print "Second param: $bar";
    }

    sub method
    {
        self->instance_method();
        class->static_method();
        base->super_class_method();
    }

    fields foo, bar;

    sub method {
        self->foo = "some value";
        print self->foo;
    }

    fields foo;

    sub get_foo
    {
        print "Getting foo!";
        return self->{foo};
    }

    sub set_foo($value)
    {
        print "Setting foo!";
        self->{foo} = $value;
    }

    use reform;
    package Amy;

    fields foo,
           bar;

    sub initialize($foo)
    {
        self->foo = $foo;
    }

    sub method
    {
        self->add_field('boo');
        self->boo = 55;
    }

    ppm install Filter
    ppm install Text-Balanced

# reform.pm
#
# Third millenium syntax for Perl 5 OOP.
# Written by Henning Koch <jaz@netalive.org>.

use strict;
package reform;

our $VERSION = 0.3;

use Filter::Simple;

# Filters the code of a package.
# This is going to be even more ugly than usual as we
# want to preserve whitespace so line numbers won't change.
sub process
{
	
	my ($code) = @_;
	
	$code =~ s/ \b fields (\s+) ([\w\s\,]+) (\s*) \;
	          	          /$1 . process_fields($2) . $3
	          	          /xse;
	          
	$code =~ s/ \b sub (\s+) (\w+) (\s*)                   # 1:space 2:subname 3:space
	                   	                   (\( (.*?) \))? (\s*)                # 4:paramsbracket 5:params 6:space
	                   	                   (: \s* \w+ (\(\w+\))? )? (\s*) \{   # 7:fullattr 8:attrparam 9:space
	          	          / "sub" . $1 . $2 . $3 . 
	                    	                    $7 . $9 . $6 . 
	            	            "{ my(\$self" . ($5? ", $5" : "") . ") = \@_; "
	          	          /xseg;

	$code =~ s/ \b package (\s+) ([\w\:]+) 
	            	            ((\s*) \< (\s*) ([\w\:\,\s]+))? (\s*) \;
	          	          /
	           	           "package" . $1 . $2 . "; " . 
	           	           "use strict; no strict 'subs'; " .
	           	           $4 . $5 . 
	           	           process_bases($6) .
	           	           "use base 'Class'; " .
	           	           "use reform::implicit; " .
	           	           $7
	          	          /xse;

	# print "-----------------\n$code\n-----------\n";
	
	$code . "\n1;";

}

# Processes a "fields" directive.
sub process_fields
{
	my($list) = @_;
	
	$list =~ s/(\w+) ([\s,]*)
	          	          /"class->add_field('$1'); " . remove_commas($2)
	          	          /gesx;

	$list;
}

# Processes inheritance directives.
sub process_bases
{
	my($list) = @_;
	
	$list =~ s/([\w\:]+) ([\s,]*)
	          	          /"use base '$1'; " . remove_commas($2)
	          	          /gesx;
	          
	$list;
}


# Removes commas from a string.
sub remove_commas
{
	my($str) = @_;
	$str =~ s/,//g;
	$str;
}


# Called upon use.
FILTER 
{
	s/^(.*)$/process($1)/es;
}

"";


# Every reformed package inherits from Class.
package Class;

use reform::Property;

# Saves fields by class
my %fields;

# Basic constructor. When you need custom contructors,
# don't overwrite this - overwrite "initialize".
sub new
{
	my $class = shift;
	my $self = {};
	bless($self, $class);
	$self->_tie_field($_) for $self->fields;
	$self->initialize(@_);
	$self;
}


# Called by constructor. When you need custom contructors,
# overwrite this method rather than "new".
sub initialize
{
}

# Create accessors for a field.
# The accessors actually work on self->{_field}, which is "tied"
# to self->{field} through the methods get_field and set_field.
sub add_field
{
	my($self, $field) = @_;
	my $class = $self;
	ref $class and $class = ref $class;
	eval "sub $class\:\:$field : lvalue { \$_[0]->{_$field} }";
	eval "sub $class\:\:get_$field { \$_[0]->{_$field} }"
		unless $class->can("get_$field");
	eval "sub $class\:\:set_$field { \$_[0]->{_$field} = \$_[1] }"
		unless $class->can("set_$field");
	$@ and die "Could not add field $field for class $class: $@";
	push @{$fields{$class}}, $field;
	ref $self and $self->_tie_field($field);
}

# Goes through all classes in %fields and returns fields
# of any class that is a parent of self (or is self's class).
sub fields
{
	my($self) = @_;
	my %re; # Hash to weed out duplicates
	foreach my $class (keys %fields) {
		if($self->isa($class)) {
			map { $re{$_} = 1 } @{$fields{$class}};
		}
	}
	keys %re;
}

# Ties getter/setter methods to a field accessor.
sub _tie_field
{
	my($self, $field) = @_;
	tie $self->{"_$field"}, 'reform::Property', $self, $field;
}

#sub _call_base_method
#{
#	my($self, $method) = (shift, shift);
#	my $class = $self;
#	ref $class and $class = ref $class;
#	print "$self\n";
#	my @re = eval "package $class; \$self->SUPER::$method(\@_)";
#	$@ and die "Error calling base method: $@";
#	@re;
#}

1;