[dancer-users] Dancer::Test + Devel::Cover + subroutine attributes == PAIN

[David Cantrell]

We're using subroutine attributes on our route handlers for
authentication.  eg, things like ...

get '/phonecall/:from/:to/:datetime/download_mp3' => sub :Auth(
    Government TabloidPress
) { ... };

and have a 'before' hook that checks that only logged in users who have
the 'Government' or 'TabloidPress' role can listen in on other peoples'
phone calls.  This works nicely, both when we run the application and
when we test it using Dancer::Test.

However, we'd quite like to get some metrics of how good our tests are,
and Devel::Cover is the tool for that.  Trouble is, something is
breaking, and the attributes are going missing somewhere.  I've boiled
it down to a *really* minimal app and tests, which are appended to this
'ere email.

If I run the app, it works:

  $ ./app.pl &
  [1] 314
  ...

  $ GET http://localhost:3000/plato
  I can Philosophise

and if I run the tests without Devel::Cover, they work too:

  $ PERL5LIB=lib prove -rv
  ./t/test-devel-cover.t .. 
  1..4
  ok 1 - GET /plato - status OK
  ok 2 - content looks good for /plato
  ok 3 - GET /leonardo - status OK
  ok 4 - content looks good for /leonardo
  ok
  All tests successful.

but throw Devel::Cover into the mix too, and it all gone done buggerup:

  $ PERL5OPT=-MDevel::Cover PERL5LIB=lib prove -rv
  ./t/test-devel-cover.t .. 
  1..4
  Use of uninitialized value in concatenation (.) or string at lib/TestApp.pm line 35, <DATA> line 998.
  ok 1 - GET /plato - status OK
  Use of uninitialized value in concatenation (.) or string at lib/TestApp.pm line 35, <DATA> line 998.
  not ok 2 - content looks good for /plato
  ...

I can see (by inserting some print statements!) that the attributes are
getting stored, but something is happening to prevent them from being
pulled back out again.  Has anyone else worked with Dancer and
Devel::Cover and got any tips for me, or am I going to have to delve
into the lump of pure concentrated EVIL that is the Devel::Cover source?

$ cat app.pl 
#!/usr/bin/env perl

use strict;
use warnings;
use lib 'lib';
use Dancer;
use TestApp;
dance;

$ cat lib/TestApp.pm 
package TestApp;

use strict;
use warnings;

use Dancer qw(:syntax);

use Attribute::Handlers;

my %attrs;
 
sub Auth :ATTR(CODE) {
    my ($package, $symbol, $referent, $attr, $data) = @_;
    if(!ref($data)) {
        $data =~ s/^\s+|\s+$//g;
        $data = [split(/\s+/, $data)];
    }
    $attrs{$attr}->{$referent} = $data;
}

sub get_attribs {
    my $class = shift;
    my $sub   = shift;
    my $type  = shift;
    return @{$attrs{$type}->{$sub} || []};
}

hook 'before' => sub {
    my $handler = shift->code();

    var('route_roles', __PACKAGE__->get_attribs($handler, 'Auth'));
    return;
};

get '/plato'    => sub :Auth(Philosophise) { "I can ".var('route_roles') };
get '/leonardo' => sub :Auth(Engineer)     { "I can ".var('route_roles') };

1;

$ cat t/test-devel-cover.t 
use strict;
use warnings;

use TestApp;
use Dancer::Test;
use Test::More tests => 4;
 
foreach my $tuple (
    [ '/plato',    200, 'Philosophise' ],
    [ '/leonardo', 200, 'Engineer'     ],
) {
    my ($url, $status, $lookfor) = @{$tuple};
    response_status_is    [GET => $url], $status, "GET $url - status OK";
    response_content_like [GET => $url], qr/$lookfor/, "content looks good for $url";
}


-- 
David Cantrell | Nth greatest programmer in the world

  NANOG makes me want to unplug everything and hide under the bed
    -- brian d foy