File Coverage

blib/lib/Perl6/Classes.pm

Criterion	Covered	Total	%
statement	141	158	89.2
branch	53	74	71.6
condition	8	14	57.1
subroutine	13	14	92.8
pod	0	6	0.0
total	215	266	80.8

package Perl6::Classes;

use Filter::Simple;
use Text::Balanced qw{extract_quotelike extract_codeblock
                      extract_variable  extract_multiple};

our $VERSION = "0.22";

# This whole file is a pile of ascii feces.

my $identifier = qr/(?: :: )?
                    [a-zA-Z_] \w*
                    (?: :: [a-zA-Z_] \w*)*/x;

my $signature  = qr/(?:
                        \s* [\\;\&\%\@\$]
                      )* \s*/x;

my $traits = qr/is \s+ [a-zA-Z_]\w*
                 (?: \s+ is \s+ [a-zA-Z_]\w* )*/x;

my $scope_trait = qr/^ (?: public|protected|private ) $/x;


{   my $symno = '000000';
    sub newclass {
        "__class_" . $symno++
    }
}

sub proccode {
    my ($str, $cls) = @_;

    my $pos = pos;      # Ugh, why doesn't pos localize with $_ ?!
    $str = filter($str);
    pos = $pos;

    $str =~ s/^\s*\{/{my \$self = local \$_ = shift; /;
    $str =~ s/([\$\@\%])\.([a-zA-Z_]\w*)/$1\{\$self->{_data_$cls}{_attr_$2}}/g;
    $str
}

sub parse {
    local $_ = shift;
    my $cls = shift;

    my @components;
    my $ws;

    die unless m/\G \s*\{/gx;

    CHUNK:
    while (length > pos) {
            if (/\G (\s+)/cgx) { $ws .= $1; }
            elsif (/\G (\# [^\n]* \n)/cgx) { $ws .= $1; }
            elsif (/\G has \s* ([\$\@\%])\.([a-zA-Z_]\w*) \s* \;/cgx) {
                push @components, {
                    ws   => $ws,
                    type => 'attr',
                    name => $2,
                    sigil => $1
                };
                undef $ws;
            }
            elsif (/\G sub    \s+ ($identifier)
                             \s*? ( \( ( $signature ) \) )? (\s+ $traits)?/cgx) {
                my @traits = grep { /\S/ && $_ ne 'is' } split /\s+/, $4;
                my ($scope) = grep { /$scope_trait/ } @traits;
                my $code = (extract_codeblock)[0];
                push @components, {
                    ws   => $ws,
                    type => 'sub',
                    name => $1,
                    sig  => ($2 ? "(\$$3)" : "(\$@)"),
                    code => proccode($code, $cls),
                    scope => ($scope || 'public'),
                };
                undef $ws;
            }
            elsif (/\G method \s+ ($identifier)
                             \s*? ( \( ( $signature ) \) )? (\s+ $traits)?/cgx) {
                my @traits = grep { /\S/ && $_ ne 'is' } split /\s+/, $4;
                my ($scope) = grep { /$scope_trait/ } @traits;
                my ($name, $sig, $insig) = ($1, $2, $3);
                my $code = (extract_codeblock)[0];
                push @components, {
                    ws   => $ws,
                    type => 'method',
                    name => $name,
                    sig  => ($sig ? "(\$$insig)" : "(\$@)"),
                    code => proccode($code, $cls),
                    scope => ($scope || 'public'),
                };
                undef $ws;
            }
            elsif (/\G submethod \s+ ($identifier)
                                 \s*? ( \( ( $signature ) \) )? (\s+ $traits)?/cgx) {
                my @traits = grep { /\S/ && $_ ne 'is' } split /\s+/, $4;
                my ($scope) = grep { /$scope_trait/ } @traits;
                my $code = (extract_codeblock)[0];

                push @components, {
                    ws   => $ws,
                    type => 'submethod',
                    name => $1,
                    sig  => ($2 ? "(\$$3)" : "(\$@)"),
                    code => proccode($code, $cls),
                    scope => ($scope || 'private'),
                };
                undef $ws;
            }
            elsif (/\G \}/cgx) {
                push @components, {
                    ws => $ws,
                    type => 'empty',
                };
                last CHUNK;
            }
            else {
                die "Bad token (near '" .
                    substr($_, pos, 15) . "')";
            }
    }

   \@components;
}

sub generate_class {
    my ($name, $data, $base) = @_;

    my %scopecode = (
        private   => sub { qq{require Carp; Carp::croak("Private $_[1] $name\::$_[0]") unless }.
                           qq{caller =~ /^$name(?:__|\$)/; } },
        protected => sub { qq{require Carp; Carp::croak("Protected $_[1] $name\::$_[0]") unless } .
                           qq{caller->isa('$name') || $name->isa(scalar caller); } },
        public    => sub { "" },
    );

    my ($newstruct, $destroystruct, $emptystruct);
    $emptystruct = pop @$data if $data->[-1]->{type} eq 'empty';

    for (@$data) {
        if ($_->{name} eq 'new') {
            $newstruct = $_;
        }
        elsif ($_->{name} eq 'DESTROY') {
            $destroystruct = $_;
        }
    }

    unless ($newstruct) {
        $newstruct = {
            type => 'sub',
            name => 'new',
            sig  => '',
            scope => 'public',
        };
        push @$data, $newstruct;
    }

    unless ($destroystruct) {
        $destroystruct ||= {
            type => 'submethod',
            name => 'DESTROY',
            sig  => '',
            scope => 'public',
        };
        push @$data, $destroystruct;
    }

# Checks

    {   my %seen;
        for (@$data) {
            if ($_->{type} ne 'attr' && $_->{type}) {
                if (exists $seen{$_->{name}}) {
                    die "Duplicate name $_";
                }
                $seen{$_}++;
            }
        }
    }

# New routine

    {
    my $newcode = " { ";

    for (@$data) { # update the closures (???)
        if ($_->{type} eq 'sub') {
            $newcode .= "\$_sub_$_->{name}; ";
        }
    }

    $newcode .= 'my $_class = shift; my $_self = bless {';

    for (@$base) {
        $newcode .= "do { my \$_cl = $_->new; (_parent_$_ => \$_cl, \%\$_cl) }, ";
    }

    $newcode .= "_data_$name => {";

    for (@$data) {
        if ($_->{type} eq 'attr') {
            $newcode .= "_attr_$_->{name} => undef, ";
        }
    }

    $newcode .= "}, ";

    for (@$data) {
        if ($_->{type} eq 'method' || $_->{type} eq 'submethod') {
            $newcode .= "_$_->{type}_$_->{name} => \$_$_->{type}_$_->{name}, ";
        }
    }
    for (@$data) {
        if ($_->{type} eq 'sub') {
            $newcode .= "_sub_$_->{name} => sub { my \$self = shift; " .
                "\$_sub_$_->{name}->(\${\$self->{_class}}, \@_) }, ";
        }
    }

    $newcode .= "_class => \\\$_ret, } => '${name}__object'; " .
                "\$_self->BUILD(\@_) if \$_self->can('BUILD'); \$_self }; ";

    $newstruct->{code} = $newcode;
    }  # End of new routine

    # DESTROY routine
    {
        my $descode = "{ \$_[0]->DESTRUCT if \$_[0]->can('DESTRUCT'); ";
        for (reverse @$base) {
            $descode .= "\$_[0]->$_\::DESTROY;";
        }
        $descode .= " }";
        $destroystruct->{code} = $descode;
    }  # End of DESTROY routine

    my $ret = "{ package $name; my \$_ret; ";
    for (@$data) {
        if ($_->{type} ne 'attr') {
            $ret .= "my \$_$_->{type}_$_->{name}; "
        }
    }
    for (@$data) {
        if ($_->{type} eq 'attr') {
            $ret .= "$_->{ws}";
        }
        else {
            $ret .= "$_->{ws} \$_$_->{type}_$_->{name} = sub $_->{sig} $_->{code}; ";
        }
    }

    $ret .= '$_ret = bless { ';

    for (@$data) {
        if ($_->{type} eq 'sub') {
            $ret .= "_sub_$_->{name} => \$_sub_$_->{name}, ";
        }
    }
    $ret .= "} => '${name}__class'; ";

# Class methods
    $ret .= "{ package ${name}__class; ";

    for (@$data) {
        if ($_->{type} eq 'sub') {
            $ret .= "sub $_->{name} $_->{sig} { " . $scopecode{$_->{scope}}->($_->{name}, $_->{type}) .
                    "goto &{ref \$_[0] ? \$_[0]{_sub_$_->{name}} : \$_sub_$_->{name}} } ";
        }
    }

# Inheritable methods

    $ret .= "package ${name}; ";
    $ret .= "use base '${name}__class'; ";

    for (@$base) {
        $ret .= "use base '$_'; ";
    }

    for (@$data) {
        if ($_->{type} eq 'method') {
            $ret .= "sub $_->{name} $_->{sig} { " . $scopecode{$_->{scope}}->($_->{name}, $_->{type}) .
                    "goto &{\$_[0]{_method_$_->{name}}} }";
        }
    }

# Object methods

    $ret .= "package ${name}__object; ";
    $ret .= "use base '$name'; ";

    for (@$data) {
        if ($_->{type} eq 'submethod') {
            $ret .= "sub $_->{name} $_->{sig} { " . $scopecode{$_->{scope}}->($_->{name}, $_->{type}) .
                    "goto &{\$_[0]{_submethod_$_->{name}}} }";
        }
    }

    $ret .= "} \$_ret; } $emptystruct->{ws}";

    $ret;
}

sub extract_class {
    local $_ = shift if @_;

    my $ret;
    if (/\G class (\s+ $identifier)? (\s+ $traits)? (?= \s* \{ )/cgx) {
        my @inherit = grep { /\S/ && $_ ne 'is' } split /\s+/, $2;

        my $anon;
        my $name = $1;
        unless ($name) {
            $name = newclass;
            $anon = 1;
        }
        $name =~ s/^\s*//;
        my $code = (extract_codeblock)[0];
        my $ppos = pos;
        my $data = parse($code, $name);
        pos = $ppos;

        $ret = generate_class($name, $data, \@inherit);
        if ($anon) {
            $ret = "do $ret";
        }
        else {
            $ret = "$ret;";
        }
    }
    $ret;
}

sub filter {
    local $_ = shift if @_;
    my @parts = extract_multiple(undef, [
                            qr/\s+/,
                            sub { scalar extract_class },
                            qr/#[^\n]*/,
                            sub { scalar extract_quotelike },
                            sub { scalar extract_variable },
                            qr/.[^\&\%\@\$"'q#c]*/,
                            ]);
    join '', @parts;
}

FILTER {
    $_ = filter;
}

__END__