When should I use subroutine attributes? - perl

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;

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?.

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.

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.

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();