File Coverage

blib/lib/Lexical/Attributes.pm

Criterion	Covered	Total	%
statement	59	62	95.1
branch	23	26	88.4
condition	3	3	100.0
subroutine	10	10	100.0
pod	0	4	0.0
total	95	105	90.4

package Lexical::Attributes;

use 5.008001;

use strict;
use warnings;
no  warnings 'syntax';
use Filter::Simple;
use Scalar::Util;

our $VERSION  = '2009121601';

my $sigil     = '[$@%]';
my $sec_sigil = '[.]';
my $trait     = '(?:r[ow]|pr(?:iv)?)';        # read-only, read-write, private.
my $name      = qr /[a-zA-Z_][a-zA-Z0-9_]*/;  # Starts with alpha or _, followed
                                              # by one or more alphanumunders.
my $has_attribute = qr /(?>$sigil$sec_sigil$name)/;
my $use_attribute = qr /(?>(?:\$#?|[%\@])$sec_sigil$name)/;
my $int_attribute = qr /(?>(?:\$#?|\@)$sec_sigil$name)/;  # No hash.

my %attributes;

sub declare_attribute {
    my ($attributes, $trait) = @_;

    $trait = "pr" if !$trait || $trait eq "priv";

    my $text = "";

    foreach my $attribute (split /\s*,\s*/ => $attributes) {

        my ($sigil, $sec_sigil, $name) = unpack "A A A*" => $attribute;
        my $str = "";

        if ($attributes {$name}) {
            warn "Duplicate attribute '$attribute' ignored\n";
            next;
        }

        $attributes {$name} = [$sigil, $trait];

        $str .= "my %$name;";
        unless ($trait eq "pr") {
            if ($sigil eq '$') {
                $str .= <<'                --';
                sub _NAME {
                    my $_key = Scalar::Util::refaddr shift;
                    $_NAME {$_key}
                }
                --
            }
                  # @_ ? @{$_NAME {$_key}} [@_] : @{$_NAME {$_key}};
            elsif ($sigil eq '@') {
                $str .= <<'                --';
                sub _NAME {
                    my $_key = Scalar::Util::refaddr shift;
                    @_ ? @{$_NAME {$_key}} [@_] : @{$_NAME {$_key} || []};
                }
                --
            }
            elsif ($sigil eq '%') {
                $str .= <<'                --';
                sub _NAME {
                    my $_key = Scalar::Util::refaddr shift;
                    @_        ?      @{$_NAME {$_key}} {@_}  :
                    wantarray ?      %{$_NAME {$_key} || {}} :
                                keys %{$_NAME {$_key} || {}};
                }
                --
            }
            else {
                die "'$attribute' not implemented\n";
            }

            if ($trait eq "rw") {
                if ($sigil eq '$') {
                    $str .= <<'                    --';
                    sub set__NAME {
                        my $self = shift;
                        my $_key = Scalar::Util::refaddr $self;
                        $_NAME {$_key} = shift;
                        $self;
                    }
                    --
                }
                elsif ($sigil eq '@') {
                    $str .= <<'                    --';
                    sub set__NAME {
                        my $self = shift;
                        my $_key = Scalar::Util::refaddr $self;
                        if    (@_ == 0) {delete $_NAME {$_key}}
                        elsif (@_ == 1) {
                            if (ref $_ [0] eq 'ARRAY') {$_NAME {$_key} = $_ [0]}
                            else {delete $_NAME {$_key} [$_ [0]]}
                        }
                        else {
                            while (@_ >= 2) {
                                my ($index, $value) = splice @_ => 0, 2;
                                $_NAME {$_key} [$index] = $value;
                            }
                        }
                        $self;
                    }
                    --
                }
                elsif ($sigil eq '%') {
                    $str .= <<'                    --';
                    sub set__NAME {
                        my $self = shift;
                        my $_key = Scalar::Util::refaddr $self;
                        if    (@_ == 0) {delete $_NAME {$_key}}
                        elsif (@_ == 1) {
                            if (ref $_ [0] eq 'HASH') {$_NAME {$_key} = $_ [0]}
                            else {delete $_NAME {$_key} {$_ [0]}}
                        }
                        else {
                            while (@_ >= 2) {
                                my ($key, $value) = splice @_ => 0, 2;
                                $_NAME {$_key} {$key} = $value;
                            }
                        }
                        $self;
                    }
                    --
                }
            }
        }
        $str =~ s/\n\s*/ /g;
        $str =~ s/_NAME/$name/g;

        $text .= $str;
    }

    return $text;
}

sub destroy_attributes {
    my $str = "";
    while (my ($key) = each %attributes) {
        $str .= "delete \$$key {Scalar::Util::refaddr \$self};\n";
    }
    $str;
}

sub use_attribute {
    my ($attribute) = @_;

    my ($sigil, $name) = split /[.]/ => $attribute, 2;

    if (!$attributes {$name}) {
        die $_;
        die qq !Attribute "$attribute" requires declaration!;
    }

    my $str;
    if ($sigil eq '$') {
        $str = "\$$name\{Scalar::Util::refaddr \$self}";
    }
    else {
        $str = "$sigil\{\$$name\{Scalar::Util::refaddr \$self}}";
    }
    $str;
}

sub interpolate {
    local $_ = shift;

    # The regex below finds attribute names. We cannot simply use a
    # regex for finding them, we need to parse the entire string, to
    # be able to deal with backslashes.
    #
    # We use loop unrolling for efficiency.
    #
    s {(                     # Capture non attributes in $1.
           [^\$\@\\]*            # Anything that isn't $, @ or \ is ok.
           (?:                   # Group (1)
               (?:                   # Group (2) ("Special things")
                   \\.                   # Escape followed by any character
                   |                     # or
                   (?:                   # Group (3)
                       (?:>\$\#?)            # Scalar sigil, or array count
                                             # The (?> ) is vital here.
                       |                     # Or
                       \@                    # Array sigil
                   )                     # End group (3)
                   (?!\.$name)           # not followed by dot attribute name
               )                     # End group (2)
               [^\$\@\\]*            # Anything that isn't $, @ or \
           )*                    # End group (1), repeated zero or more times.
       )                     # End capture $1
       |                     # Or
       (                     # In $2, capture an attribute
           (?:(?>\$\#?)|\@)      # Primary sigil
           \.$name               # dot attribute name
       )                     # End $2
    }
    {defined $1 ? $1 : use_attribute ($2)}sexg;

    $_
}

FILTER_ONLY
    #
    # Initialize variables.
    #
    all   => sub {%attributes = ()},

    #
    # Save all attributes found in comments. *Very* simple heuristics
    # to determine comments - note that quote like constructs have been
    # moved out of the way.
    #
    # Moving away the attributes found in comments prevents subsequent
    # passes to modify them. In particular, outcommented attribute
    # declarations shouldn't create methods or hashes.
    #
    code => sub {
        1 while s/(                   # Save
                    (?
                    \#                # Start of a comment.
                    [^\n]*            # Not a newline, not an attribute,
                    (?: $sigil (?!$sec_sigil) [^\n]*)*
                                      # using standard unrolling.
                  ) ($sigil) ($sec_sigil) ($name)
                 /$1$2<$3>$4/xg;
    },

    #
    # Find the attribute declarions and uses. Foreach declararion, the sub
    # 'attribute' is called, which will create an attribute hash,
    # and, for non-private attributes, a constructor (which maybe
    # an lvalue method if the rw trait is given).
    #
    # We recognize:
    #    "has"     [$@%].attribute ( ("is")? "pr(iv)?|ro|rw")? ";"
    #    "has" "(" [$@%].attribute ("," [$@%].attribute)* ")" \
    #                              ( ("is")? "pr(iv)?|ro|rw")? ";"
    #
    # Other attribute usages are just:
    #             ([$@%]|$#).attribute
    #
    # Attribute uses are handled by calling 'use_attribute'.
    #
    code  => sub {
        s{(?:                    # Declaration using 'has',
            \bhas \s*                       # Must start with "has"
             (?:                            # Either
                      ($has_attribute)      #   a single ttribute, stored in $1.
               |                            # or
              [(] \s* ($has_attribute (?: \s* , \s* $has_attribute)*) \s* [)]
                                            #   an attribute list, stored in $2.
             )
             (?: \s* (?:is \s+)? ($trait))? # Optional trait - stored in $3.
             \s* ;                          # Terminated by semi-colon.
          ) |                    # or actual usage.
           ($use_attribute)                 # It's in $4.
         }
         {$4 ? use_attribute ($4) : declare_attribute ($1 || $2, $3)}egx;
    },

    #
    # Interpolation. Double quoted strings, backticks, slashes and q[qrx] {},
    # m// and s/// constructs.
    #
    # Note that '', qw{}, tr///, m'' and s''' don't interpolate.
    #
    # How to test qx?
    #
    quotelike => sub {
        if (m {^(["`/]|q[qrx]\s*\S|[sm]\s*[^\s'])(.*)(\S)$}s) {
            $_ = $1 . interpolate ($2) . $3
        }
    },

    #
    # If a subroutine uses the keyword 'method' (at the beginning of
    # a line), add an assignment to '$self'.
    #

    code => sub {
        s<^(\s*) method (\s+ [a-zA-Z_]\w* \s*     # sub name
            (?:\([^)]*\) \s*)?                    # Optional prototype
            \{)                                   # Opening of block
         ><$1 sub $2 my \$self = shift;>mgx;
    },

    #
    # Add a DESTROY function
    #
    code => sub {
        my $destroy = <<'        --';

        sub DESTROY {
            our @ISA;
            my  $self     = shift;
            my  $DESTRUCT = __PACKAGE__ . "::DESTRUCT";
            $self -> $DESTRUCT if do {no strict 'refs'; exists &$DESTRUCT};
            DESTROY_ATTRIBUTES;
            foreach my $class (@ISA) {
                my $destroy = $class . "::DESTROY";
                $self -> $destroy if $self -> can ($destroy);
            }
        }
        --

        my $destroy_attributes = destroy_attributes;

        $destroy  =~ s/DESTROY_ATTRIBUTES/$destroy_attributes/;
        $destroy  =~ s/^ {8}//gm;

        $_ .= $destroy;
    },

    #
    # Restore tucked away, outcommented, attributes.
    #
    code => sub {
        1 while s/(                   # Save
                    (?
                    \#                # Start of a comment.
                    [^\n]*            # Not a newline, not an attribute,
                    (?: $sigil (?!<$sec_sigil>) [^\n]*)*
                                      # using standard unrolling.
                  ) ($sigil) <($sec_sigil)> ($name)
                 /$1$2$3$4/xg;
    },

    #
    # For debugging purposes; to be removed.
    #
    # all   => sub {print "<<$_>>\n" if $::DEBUG || $ENV {DEBUG}},

;

__END__