File Coverage

blib/lib/Moops/Keyword/Role.pm
Criterion Covered Total %
statement 38 39 97.4
branch 6 8 75.0
condition 2 3 66.6
subroutine 12 13 92.3
pod 0 5 0.0
total 58 68 85.2


line stmt bran cond sub pod time code
1 33     33   13883 use v5.14;
  33         115  
2 33     33   188 use strict;
  33         62  
  33         931  
3 33     33   166 use warnings FATAL => 'all';
  33         71  
  33         1483  
4 33     33   195 no warnings qw(void once uninitialized numeric);
  33         84  
  33         2732  
5              
6             package Moops::Keyword::Role;
7              
8             our $AUTHORITY = 'cpan:TOBYINK';
9             our $VERSION = '0.037';
10              
11 12     12   86 use Moo;
  12     21   26  
  12         85  
  21         146  
  21         55  
  21         148  
12 12     12   10727 use B qw(perlstring);
  12     21   26  
  12         10546  
  21         21889  
  21         51  
  21         17888  
13             extends qw( Moops::Keyword );
14              
15 0     0 0 0 sub should_support_methods { 1 }
16              
17             sub arguments_for_moosex_mungehas
18             {
19 83     83 0 340 shift;
20 83         425 return qw(eq_1);
21             }
22              
23             my %using = (
24             Moo => 'use Moo::Role; use MooX::late;',
25             Moose => 'use Moose::Role; use MooseX::KavorkaInfo;',
26             Mouse => 'use Mouse::Role;',
27             Tiny => 'use Role::Tiny;',
28             (
29             map { $_ => "use $_;" }
30             qw/ Role::Basic Role::Tiny Moo::Role Mouse::Role Moose::Role /
31             ),
32             );
33              
34             sub default_oo_implementation
35             {
36 139     139 0 494 'Moo';
37             }
38              
39             sub generate_package_setup_oo
40             {
41 19     19 0 53 my $self = shift;
42 19   66     162 my $using = $self->relations->{using}[0] // $self->default_oo_implementation;
43            
44 19 50       100 exists($using{$using})
45             or Carp::croak("Cannot create a package using $using; stopped");
46            
47 19         70 my @lines = (
48             'use namespace::autoclean -also => ["has", "lexical_has"];',
49             'use Lexical::Accessor;',
50             );
51 19 50       117 push @lines, "use MooseX::MungeHas qw(@{[ $self->arguments_for_moosex_mungehas ]});"
  19         71  
52             if $using =~ /^Mo/;
53            
54             return (
55 19         95 $using{$using},
56             $self->generate_package_setup_relationships,
57             @lines,
58             );
59             }
60              
61             sub generate_package_setup_relationships
62             {
63 83     83 0 188 my $self = shift;
64 83 100       153 my @roles = @{ $self->relations->{with} || [] };
  83         508  
65            
66 83 100       425 $self->_mk_guard(
67             sprintf("with(%s);", join(",", map perlstring($_), @roles))
68             ) if @roles;
69 83         452 return;
70             }
71              
72             around known_relationships => sub
73             {
74             my $next = shift;
75             my $self = shift;
76             return($self->$next(@_), qw/ with using /);
77             };
78              
79             around qualify_relationship => sub
80             {
81             my $next = shift;
82             my $self = shift;
83             $_[0] eq 'using' ? !!0 : $self->$next(@_);
84             };
85              
86             around version_relationship => sub
87             {
88             my $next = shift;
89             my $self = shift;
90             $_[0] eq 'using' ? !!0 : $self->$next(@_);
91             };
92              
93             around arguments_for_kavorka => sub
94             {
95             my $next = shift;
96             my $self = shift;
97            
98             my @keywords = qw/ method before after around /;
99            
100             my $using = $self->relations->{using}[0] // $self->default_oo_implementation;
101             push @keywords, qw/ override augment /
102             if $using =~ /^Mo[ou]se\b/;
103            
104             return (
105             $self->$next(@_),
106             @keywords,
107             );
108             };
109              
110             1;