File Coverage

blib/lib/MooX/StrictHas.pm
Criterion Covered Total %
statement 28 28 100.0
branch 7 10 70.0
condition n/a
subroutine 13 13 100.0
pod n/a
total 48 51 94.1


line stmt bran cond sub pod time code
1             package MooX::StrictHas;
2              
3             our $VERSION = '0.03';
4              
5             # this bit would be MooX::Utils but without initial _ on func name
6 1     1   13639 use strict;
  1         3  
  1         27  
7 1     1   5 use warnings;
  1         2  
  1         22  
8 1     1   5 use Moo ();
  1         1  
  1         13  
9 1     1   504 use Moo::Role ();
  1         8171  
  1         27  
10 1     1   6 use Carp qw(croak);
  1         3  
  1         310  
11             #use base qw(Exporter);
12             #our @EXPORT = qw(override_function);
13             sub _override_function {
14 4     4   10 my ($target, $name, $func) = @_;
15 4 50       49 my $orig = $target->can($name) or croak "Override '$target\::$name': not found";
16 4 50       21 my $install_tracked = Moo::Role->is_role($target) ? \&Moo::Role::_install_tracked : \&Moo::_install_tracked;
17 4     4   129 $install_tracked->($target, $name, sub { $func->($orig, @_) });
  4     4   292  
        4      
        4      
        4      
18             }
19             # end MooX::Utils;
20              
21             my %ATTR2MESSAGE = (
22             auto_deref => q{just dereference in your using code},
23             lazy_build => q{Use "is => 'lazy'" instead"},
24             );
25             sub import {
26 4     4   25720 my $target = scalar caller;
27             _override_function($target, 'has', sub {
28 4     4   17 my ($orig, $namespec, %opts) = @_;
29 4 50       14 $namespec = "[@$namespec]" if ref $namespec;
30 4         7 my @messages;
31             push @messages, exists($opts{$_})
32             ? "$_ detected on $namespec: $ATTR2MESSAGE{$_}"
33             : ()
34 4 100       39 for sort keys %ATTR2MESSAGE;
35 4 100       471 croak join "\n", @messages if @messages;
36 1         5 $orig->($namespec, %opts);
37 4         28 });
38             }
39              
40             =head1 NAME
41              
42             MooX::StrictHas - Forbid "has" attributes lazy_build and auto_deref
43              
44             =begin markdown
45              
46             # PROJECT STATUS
47              
48             | OS | Build status |
49             |:-------:|--------------:|
50             | Linux | [![Build Status](https://travis-ci.com/mohawk2/moox-stricthas.svg?branch=master)](https://travis-ci.org/mohawk2/moox-stricthas) |
51              
52             [![CPAN version](https://badge.fury.io/pl/moox-stricthas.svg)](https://metacpan.org/pod/MooX::StrictHas) [![Coverage Status](https://coveralls.io/repos/github/mohawk2/moox-stricthas/badge.svg?branch=master)](https://coveralls.io/github/mohawk2/moox-stricthas?branch=master)
53              
54             =end markdown
55              
56             =head1 SYNOPSIS
57              
58             package MyMod;
59             use Moo;
60             use MooX::StrictHas;
61             has attr => (
62             is => 'ro',
63             auto_deref => 1, # blows up, not implemented in Moo
64             );
65             has attr2 => (
66             is => 'ro',
67             lazy_build => 1, # blows up, not implemented in Moo
68             );
69              
70             =head1 DESCRIPTION
71              
72             This is a L extension, intended to aid those porting modules from
73             L to Moo. It forbids two attributes for L, which Moo
74             does not implement, but silently accepts:
75              
76             =over
77              
78             =item auto_deref
79              
80             This is not considered best practice - just dereference in your using code.
81              
82             =item lazy_build
83              
84             Use C 'lazy'> instead.
85              
86             =back
87              
88             =head1 AUTHOR
89              
90             Ed J
91              
92             =head1 LICENCE
93              
94             The same terms as Perl itself.
95              
96             =cut
97              
98             1;