File Coverage

blib/lib/Jojo/Role/Compat.pm
Criterion Covered Total %
statement 33 82 40.2
branch 0 12 0.0
condition 0 9 0.0
subroutine 10 16 62.5
pod 2 4 50.0
total 45 123 36.5


line stmt bran cond sub pod time code
1              
2             package Jojo::Role::Compat;
3              
4             our $VERSION = '0.5.0';
5              
6 1     1   646 use 5.018;
  1         3  
7 1     1   5 use strict;
  1         2  
  1         19  
8 1     1   5 use warnings;
  1         2  
  1         21  
9 1     1   612 use utf8;
  1         14  
  1         5  
10 1     1   31 use feature ();
  1         2  
  1         13  
11 1     1   499 use experimental ();
  1         3322  
  1         73  
12              
13             BEGIN {
14 1     1   582 require Role::Tiny;
15 1         4408 Role::Tiny->VERSION('2.000006');
16 1         44 our @ISA = qw(Role::Tiny);
17             }
18              
19             #use Sub::Inject 0.3.0 ();
20 1     1   453 use Importer::Zim ();
  1         4622  
  1         78  
21              
22             # Aliasing of Role::Tiny symbols
23             BEGIN {
24 1     1   4 *INFO = \%Role::Tiny::INFO;
25 1         3 *APPLIED_TO = \%Role::Tiny::APPLIED_TO;
26 1         2 *COMPOSED = \%Role::Tiny::COMPOSED;
27 1         2 *COMPOSITE_INFO = \%Role::Tiny::COMPOSITE_INFO;
28 1         3 *ON_ROLE_CREATE = \@Role::Tiny::ON_ROLE_CREATE;
29              
30 1         821 *_getstash = \&Role::Tiny::_getstash;
31             }
32              
33             our %INFO;
34             our %APPLIED_TO;
35             our %COMPOSED;
36             our %COMPOSITE_INFO;
37             our @ON_ROLE_CREATE;
38              
39             our %EXPORT_TAGS;
40             our %EXPORT_GEN;
41              
42              
43             # Jojo::Role->apply_roles_to_package('Some::Package', qw(Some::Role +Other::Role));
44             sub apply_roles_to_package {
45 0     0 1   my ($self, $target) = (shift, shift);
46             return $self->Role::Tiny::apply_roles_to_package($target,
47 0 0         map { /^\+(.+)$/ ? "${target}::Role::$1" : $_ } @_);
  0            
48             }
49              
50             # Jojo::Role->create_class_with_roles('Some::Base', qw(Some::Role1 +Role2));
51             sub create_class_with_roles {
52 0     0 1   my ($self, $target) = (shift, shift);
53             return $self->Role::Tiny::create_class_with_roles($target,
54 0 0         map { /^\+(.+)$/ ? "${target}::Role::$1" : $_ } @_);
  0            
55             }
56              
57             sub import {
58 0     0     my $target = caller;
59 0           my $me = shift;
60              
61             # Jojo modules are strict!
62 0           $_->import for qw(strict warnings utf8);
63 0           feature->import(':5.18');
64 0           experimental->import('lexical_subs');
65              
66 0           my $flag = shift;
67 0 0         if (!$flag) {
68 0           $me->make_role($target);
69 0           $flag = '-role';
70             }
71              
72 0   0       my @exports = @{$EXPORT_TAGS{$flag} // []};
  0            
73 0           my %exports = $me->_generate_subs($target, @exports);
74 0           Importer::Zim::export_to($target, %exports);
75             #goto &Sub::Inject::sub_inject;
76             }
77              
78 0     0 0   sub role_provider { $_[0] }
79              
80             sub make_role {
81 0     0 0   my ($me, $target) = @_;
82 0 0         return if $me->is_role($target); # already exported into this package
83 0           $INFO{$target}{is_role} = 1;
84              
85             # get symbol table reference
86 0           my $stash = _getstash($target);
87              
88             # grab all *non-constant* (stash slot is not a scalarref) subs present
89             # in the symbol table and store their refaddrs (no need to forcibly
90             # inflate constant subs into real subs) with a map to the coderefs in
91             # case of copying or re-use
92             my @not_methods
93 0 0 0       = map +(ref $_ eq 'CODE' ? $_ : ref $_ ? () : *$_{CODE} || ()),
    0          
94             values %$stash;
95 0           @{$INFO{$target}{not_methods} = {}}{@not_methods} = @not_methods;
  0            
96              
97             # a role does itself
98 0           $APPLIED_TO{$target} = {$target => undef};
99 0           foreach my $hook (@ON_ROLE_CREATE) {
100 0           $hook->($target);
101             }
102 0           return;
103             }
104              
105             BEGIN {
106 1     1   8 %EXPORT_TAGS = ( #
107             -role => [qw(after around before requires with)],
108             -with => [qw(with)],
109             );
110              
111             %EXPORT_GEN = (
112             requires => sub {
113 0         0 my (undef, $target) = @_;
114             return sub {
115 0   0     0 push @{$INFO{$target}{requires} ||= []}, @_;
  0         0  
116 0         0 return;
117 0         0 };
118             },
119             with => sub {
120 0         0 my ($me, $target) = (shift->role_provider, shift);
121             return sub {
122 0         0 $me->apply_roles_to_package($target, @_);
123 0         0 return;
124 0         0 };
125             },
126 1         7 );
127              
128             # before/after/around
129 1         3 foreach my $type (qw(before after around)) {
130             $EXPORT_GEN{$type} = sub {
131 0           my (undef, $target) = @_;
132             return sub {
133 0   0       push @{$INFO{$target}{modifiers} ||= []}, [$type => @_];
  0            
134 0           return;
135 0           };
136 3         120 };
137             }
138             }
139              
140             sub _generate_subs {
141 0     0     my ($class, $target) = (shift, shift);
142 0           return map { my $cb = $EXPORT_GEN{$_}; $_ => $class->$cb($target) } @_;
  0            
  0            
143             }
144              
145             1;
146              
147             __END__