When should I use subroutine attributes?

Question

I don't grok Perl subroutine attributes at all.

I have never seen them in actual code and perldoc perlsub and the perldoc attributes fail to answer my questions:

• What are attributes useful for?
• What do they bring to the table that is not already present in Perl best practices?
• Are there any CPAN modules (well-known or otherwise) that make use of attributes?

It would be great if someone could put together a detailed example of attributes being used the way they should be.

---

For those who are as clueless as me, attributes are the parameters after the colon in the attributes SYNOPSIS examples below:

sub foo : method ;
my ($x,@y,%z) : Bent = 1;
my $s = sub : method { ... };

use attributes ();  # optional, to get subroutine declarations
my @attrlist = attributes::get(\&foo);

use attributes 'get'; # import the attributes::get subroutine
my @attrlist = get \&foo;

Kirimia

The Catalyst web framework makes use of attributes. – Caye

mod_perl uses attributes to differentiate method and non-method handlers. – Atombomb

Answer 1

Attributes allow you annotate variables to perform auto-magic behind the scenes. A similar concept is java annotations. Here is a small example that might help. It uses Attribute::Handlers to create the loud attributes.

use Attribute::Handlers;

sub UNIVERSAL::loud : ATTR(CODE) {
    my ( $pkg, $sym, $code ) = @_;
    no warnings 'redefine';
    *{$sym} = sub {
        return uc $code->(@_);
    };
}

sub foo : loud {
    return "this is $_[0]";
}

say foo("a spoon");
say foo("a fork");

Whenever a sub is declared with the loud attribute the UNIVERSAL::loud callback triggers exposing meta-information on the sub. I redefined the function to actually call an anonymous sub, which in turn calls the original sub and passes it to uc

This outputs:

THIS IS A SPOON
THIS IS A FORK

Now let's looks a the variable example from the SYNOPSIS:

my ($x,@y,%z) : Bent = 1;

Breaking this down into small perl statement without taking into account attributes we have

my $x : Bent
$x = 1;

my @y : Bent
@y = 1;

my %Z : Bent
%z = 1;

We can now see that each variable has been attributed the Bent annotation in a concise way, while also assigning all variables the value 1. Here is a perhaps more interesting example:

use Attribute::Handlers;
use Tie::Toggle;

sub UNIVERSAL::Toggle : ATTR(SCALAR) {
    my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
    my @data = ref $data eq 'ARRAY' ? @$data : $data;
    tie $$referent, 'Tie::Toggle', @data;
}

my $x : Toggle;

say "x is ", $x;
say "x is ", $x;
say "x is ", $x;

Which outputs:

x is 
x is 1
x is 

You can use this to do logging, create test annotations, add type details to variables, syntactic sugar, do moose-ish role composition and many other cool things.

Also see this question: How do Perl method attributes work?.

Bashuk

This goes some way to explain attributes, but what about the Bent = 1 in the Synopsis example? – Kirimia

Also, how does it affect variables? (I'm referring to the my ($x,@y,%z) : Bent = 1; example) – Kirimia

my %z = 1; doesn't really make sense here and causes the warnings pragma to complain. Did the example really mean it? – Kirimia

This has gone some way to clarify what attributes are all about. Good job! – Kirimia

I get "Not a GLOB reference at foo.pl line 7." where the anon sub is assigned to *{$sym}. I think that only works with $sym is a name, but it's actually a coderef. – Bosky

Answer 2

• What are attributes useful for?

It is a way to pass some additional information (the attribute) about a variable or subroutine.

You can catch this information (the attribute) as a string ( at COMPILE TIME !) and handle it however you like. You can generate additional code, modify stashs ... . It is up to you.

• What do they bring to the table that is not already present in Perl best practices?

Sometimes it makes life easier. See example below.

Some people use it. Do a : find . -name *.p[ml] | xargs grep 'use attributes;' at your perl installation path to look at packages using attributes. Catalyst extensively uses attributes to handle requests based on the given path.

Example :

Say you like to execute subroutines in a certain order. And you want to tell the subroutine when it has to execute ( by a run number RUNNR ). Using attributes the implementation could be :

#!/usr/bin/env perl

use strict;
use warnings;

use Runner;     # immplements the attribute handling

# some subroutines to be scheduled :
# attibutes automatically filling @$Runner::schedule 
sub func_a : RUNNR(2) {return "You called func_a !"};
sub func_b : RUNNR(1) {return "You called func_b !"};
sub func_c : RUNNR(3) {return "You called func_c !"};

# run the subroutines according to the their RUNNR
sub run {
    # @$Runner::schedule holds the subroutine refs according
    # to their RUNNR
    foreach my $func (@$Runner::schedule) {
       if ( defined $func ) {
         print "Running : $func --> ", $func->(), "\n";
       }
    }
}

print "Starting ...\n\n";
run();
print "\nDone !\n";

The attribute handling is in package Runner using the MODIFY_CODE_ATTRIBUTES hook.

package Runner;

use strict;
use warnings;

use attributes;

BEGIN {
    use Exporter ();                                                                 
    our (@ISA, @EXPORT);       

    @ISA         = qw(Exporter);                 
    @EXPORT      = qw(&MODIFY_CODE_ATTRIBUTES);    # needed for use attributes;    
}

# we have subroutines with attributes : <type> is CODE in MODIFY_<type>_ATTRIBUTES
# MODIFY_CODE_ATTRIBUTES is executed at COMPILE TIME ! try perl -c <prog_name> to prove it :-)

sub MODIFY_CODE_ATTRIBUTES {
    # for each subroutine of a package we get
    # the code ref to it and the attribute(s) as string
    my ($pckg, $code_ref, @attr) = @_;

    # whatever you like to do with the attributes of the sub ... do it
    foreach my $attr (@attr) {
        # here we parse the attribute string(s), extract the number and 
        # save the code ref of the subroutine
        # into $Runner::schedule array ref according to the given number
        # that is how we 'compile' the RUNNR of subroutines into 
        # a schedule
        if ( $attr =~ /^RUNNR\((\d+)\)$/ ) {    
            $Runner::schedule->[$1] = $code_ref;     
        }
    }
    return(); # ERROR if returning a non empty list
}

1;

The output will be :

Starting ...

Running : CODE(0x129c288) --> You called func_b !
Running : CODE(0x129c2b8) --> You called func_a !
Running : CODE(0x12ed460) --> You called func_c !

Done !

If you really want to understand what attributes do and when what happens you have to 'perldoc attributes', read it step by step and play with it. The interface is cumbersome but in principle you hook in at compile time and handle the information provided.

Saran

Just to clarify, is this MODIFY_CODE_ATTRIBUTES sub something expected if the attributes pragma is to be used? – Kirimia

Yes, you have to use this hook. In 'perldoc attributes' section 'What "import" does' and section 'Package-specific Attribute Handling' you can find some explanations. – Saran

Answer 3

You can use attributes to tie a variable upon creation. See the silly module Tie::Hash::Cannabinol which lets you do:

use Tie::Hash::Cannabinol;

my %hash;
tie %hash, 'Tie::Hash::Cannabinol';

## or ##

my %hash : Stoned;

Edit: upon deeper examination, T::H::C (hehe) uses Attribute::Handlers too (as JRideout's answer already suggests) so perhaps that is the place to look.

Precaution

Could you explain what is going on with the my ($x,@y,%z) : Bent = 1; example? – Kirimia

T::H::C provides the Stoned attribute. Presumably you would have to have loaded some module which provides the Bent attribute. – Precaution

looking at the source of T::H::C shows how this is set up: metacpan.org/source/DAVECROSS/Tie-Hash-Cannabinol-1.10/lib/Tie/… – Precaution

Answer 4

Here's an example that I ran on perl 5.26.1 with Carp::Assert. Perl attributes seem to generate nice syntax for decorator pattern. Was sort of a pain to implement MODIFY_CODE_ATTRIBUTES though b.c. of the damn eval and Perl's auto reference counting.

use strict;
use Carp::Assert;


# return true if `$func` is callable, false otherwise 
sub callable {
   my ($func) = @_;
   return defined(&$func);
}

# get the symbol table hash (stash) and the inverse of it the
# coderef table hash (crtash) where coderefs are keys and symbols are
# values. The return value is a pair of hashrefs ($stash, $crtash)
sub get_stash_and_crtash {
   my $stash = eval("\\%" . __PACKAGE__ . "::");
   my %coderef_to_sym;
   while (my ($k, $v) = each(%$stash)) {
      $coderef_to_sym{$v} = $k if (callable($v)); 
   }
   return ($stash, \%coderef_to_sym);
}

# return an eval string that inserts `$inner` as the first argument
# passed into the function call string `$outer`. For example, if
# `$inner` is "$foo" (the lvalue NAME, not the lvalue itself), and 
# `$outer` is "bar(1)", then the resulting eval string will be 
# "bar($foo, 1)"
sub insert_context {
   my ($inner, $outer) = @_;
   my $args_pat = qr/\((.*)\)$/;

   $outer .= '()' if ($outer !~ /\)$/);
   $outer =~ /$args_pat/;
   $1 ? 
      $outer =~ s/$args_pat/($inner, $1)/ : 
      $outer =~ s/$args_pat/($inner)/;
   return $outer;
}

# hook that gets called when appending attributes to functions.
# `$cls` is the package at the point of function declaration/definition,
# `$ref` is the coderef to the function being declared/defined,
# `@attrs` is a list to the attributes being added. Attributes are function
# call strings.
sub MODIFY_CODE_ATTRIBUTES {
   my ($cls, $ref, @attrs) = @_;

   assert($cls eq 'main');
   assert(ref($ref) eq 'CODE');
   for (@attrs) {
      assert(/^appender_d\(.*\)$/ || $_ eq 'upper_d');
   }

   my @non_decorators = grep { !/^\w+_d\b/ } @attrs;
   return @non_decorators if (@non_decorators);

   my ($stash, $crtash) = get_stash_and_crtash();

   my $sym = $crtash->{$ref};

   $stash->{$sym} = sub { 
      my $ref = $ref;
      my $curr = '$ref';

      for my $attr (@attrs) {
         $curr = insert_context($curr, $attr);
      }
      eval("${curr}->()");
   };

   return ();
}

sub appender_d {
   my ($func, $chars) = @_;
   return sub { $func->() . $chars };
}

sub upper_d {
   my ($func) = @_;
   return sub { uc($func->()) };
}

sub foo : upper_d appender_d('!') {
   return "foo";
}

sub main {
   print(foo());
}

main();

Bosky