File Coverage

blib/lib/Mojo/Base/Che.pm
Criterion Covered Total %
statement 36 50 72.0
branch 24 42 57.1
condition 4 15 26.6
subroutine 177 271 65.3
pod 1 1 100.0
total 242 379 63.8


line stmt bran cond sub pod time code
1             package Mojo::Base::Che;
2             # ABSTRACT: some patch for Mojo::Base(current 8.23)
3              
4 1     1   582 use Mojo::Base -strict;
  1         218306  
  1         11  
5             #~ use mro;# weak
6              
7             # copy-paste sub Mojo::Base::attr + patch 1 line #~
8             sub Mojo::Base::attr {
9 195     195 1 380070 my ($self, $attrs, $value, %kv) = @_;
10 195 50 33     1429 return unless (my $class = ref $self || $self) && $attrs;
      33        
11            
12 195 50 66     690 Carp::croak 'Default has to be a code reference or constant value'
13             if ref $value && ref $value ne 'CODE';
14 195 50       567 Carp::croak 'Unsupported attribute option' if grep { $_ ne 'weak' } keys %kv;
  9         59  
15            
16             # Weaken
17 195 100       526 if ($kv{weak}) {
18 9         34 state %weak_names;
19 9 50       48 unless ($weak_names{$class}) {
20 9         49 my $names = $weak_names{$class} = [];
21             my $sub = sub {
22 0     0   0 my $self = shift->next::method(@_);
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
23 0   0     0 ref $self->{$_} and Scalar::Util::weaken $self->{$_} for @$names;
24 0         0 return $self;
25 9         69 };
26 9         78 Mojo::Util::monkey_patch(my $base = $class . '::_Base', 'new', $sub);
27 1     1   546 no strict 'refs';
  1         3  
  1         885  
28 9         284 unshift @{"${class}::ISA"}, $base;
  9         223  
29             }
30 9 100       30 push @{$weak_names{$class}}, ref $attrs eq 'ARRAY' ? @$attrs : $attrs;
  9         68  
31             }
32            
33 195 100       297 for my $attr (@{ref $attrs eq 'ARRAY' ? $attrs : [$attrs]}) {
  195         824  
34             #~ Carp::croak qq{Attribute "$attr" invalid} unless $attr =~ /^[a-zA-Z_]\w*$/;
35            
36             # Very performance-sensitive code with lots of micro-optimizations
37 253         1377 my $sub;
38 253 100       789 if ($kv{weak}) {
    100          
    100          
39 10 100       27 if (ref $value) {
40             $sub = sub {
41             return exists $_[0]{$attr}
42             ? $_[0]{$attr}
43             : (
44             ref($_[0]{$attr} = $value->($_[0]))
45             && Scalar::Util::weaken($_[0]{$attr}),
46 0 0 0 0   0 $_[0]{$attr}
    0   0      
        0      
        0      
        0      
        0      
        0      
        0      
47             ) if @_ == 1;
48 0 0       0 ref($_[0]{$attr} = $_[1]) and Scalar::Util::weaken($_[0]{$attr});
49 0         0 $_[0];
50 7         36 };
51             }
52             else {
53             $sub = sub {
54 0 0   0   0 return $_[0]{$attr} if @_ == 1;
        0      
        0      
        0      
55 0 0       0 ref($_[0]{$attr} = $_[1]) and Scalar::Util::weaken($_[0]{$attr});
56 0         0 $_[0];
57 3         15 };
58             }
59             }
60             elsif (ref $value) {
61             $sub = sub {
62             return
63 23 100   23   2996 exists $_[0]{$attr} ? $_[0]{$attr} : ($_[0]{$attr} = $value->($_[0]))
    100   23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
        23      
64             if @_ == 1;
65 1         4 $_[0]{$attr} = $_[1];
66 1         4 $_[0];
67 117         470 };
68             }
69             elsif (defined $value) {
70             $sub = sub {
71 1 50   1   23 return exists $_[0]{$attr} ? $_[0]{$attr} : ($_[0]{$attr} = $value)
    50   1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
        1      
72             if @_ == 1;
73 0         0 $_[0]{$attr} = $_[1];
74 0         0 $_[0];
75 55         216 };
76             }
77             else {
78             $sub
79 71 0   0   297 = sub { return $_[0]{$attr} if @_ == 1; $_[0]{$attr} = $_[1]; $_[0] };
  0     0   0  
  0     0   0  
  0     0   0  
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
80             }
81 253         810 Mojo::Util::monkey_patch($class, $attr, $sub);
82             }
83             }
84              
85              
86              
87             #~ sub import {
88             #~ my ($class, $caller) = (shift, caller);
89             #~ my @flags = _lib_flags(@_);
90             #~ Mojo::Base->import(@flags); # patch 2
91             #~ }
92              
93              
94             #~ sub _lib_flags {# patch2
95             #~ my ($flag, $findbin, @flags, @libs) = ();
96              
97             #~ while ((my $it = shift) || @_) {# parse flags
98             #~ unshift @_, @$it
99             #~ and next
100             #~ if ref $it eq 'ARRAY';
101            
102             #~ next
103             #~ unless defined($it) && $it =~ m'/|\w';# / root lib? lets
104              
105             #~ if ($it =~ s'^(-\w+)'') {# controll flag
106             #~ $flag = $1;
107             #~ push @flags, $flag
108             #~ and next
109             #~ unless $flag eq '-lib';
110              
111             #~ unshift @_, split m'[:;]+', $it # -lib:foo;bar
112             #~ if $it;
113              
114             #~ next;
115             #~ } elsif (!$flag || $flag ne '-lib') { # non controll
116             #~ push @flags, $it;
117             #~ next;
118             #~ # unless $flag && $flag eq '-lib';# non lib items
119             #~ }
120            
121             #~ push @libs, $it # abs lib
122             #~ and next
123             #~ if $it =~ m'^/';
124            
125             #~ $findbin ||= require FindBin && $FindBin::Bin;# relative lib
126             #~ push @libs, $findbin.'/'.$it;
127             #~ }
128            
129             #~ my @ok_libs = grep { my $lib = $_; not scalar grep($lib eq $_, @INC) } @libs
130             #~ if @libs;
131             #~ require lib
132             #~ and lib->import(@ok_libs)
133             #~ if @ok_libs;
134            
135             #~ return @flags;
136             #~ }
137              
138             1;
139              
140             =pod
141              
142             =encoding utf8
143              
144             Доброго всем
145              
146             =head1 Mojo::Base::Che
147              
148             ¡ ¡ ¡ ALL GLORY TO GLORIA ! ! !
149              
150             =head1 NAME
151              
152             Mojo::Base::Che - some patch for Mojo::Base
153              
154             =head1 DESCRIPTION
155              
156             Патчи L.
157              
158             =head2 Причины патчей
159              
160             1. НЕТ!!NO!!!1111 Добавление путей в @INC;
161              
162             2. Разрешены хазы/атрибуты не только латиницей;
163              
164             =head1 SYNOPSIS
165              
166             НЕТ!!NO!!!1111 This module provide a extended form for add extra lib directories to perl's search path. See L
167              
168             НЕТ!!NO!!!1111 use Mojo::Base::Che -lib, qw(rel/path/lib /abs/path/lib);
169             НЕТ!!NO!!!1111 use Mojo::Base::Che -lib, ['lib1', 'lib2'];
170             НЕТ!!NO!!!1111 use Mojo::Base::Che '-lib:lib1:lib2;lib3';
171             НЕТ!!NO!!!1111 use Mojo::Base::Che -strict, qw(-lib lib1 lib2);
172             НЕТ!!NO!!!1111 use Mojo::Base::Che qw(-base -lib lib1 lib2);
173             НЕТ!!NO!!!1111 use Mojo::Base::Che 'SomeBaseClass', qw(-lib lib1 lib2);
174            
175             use lib 'lib';
176             use Mojo::Base 'Foo';
177             use Mojo::Base::Che; # apply patch
178             # GLORY utf names allow
179             has [qw(☭хаза ☆маза)];
180              
181             НЕТ!!NO!!!1111 For relative lib path will use L module and C<$FindBin::Bin> is prepends to that lib.
182             НЕТ!!NO!!!1111 Libs always applied first even its last on flags list.
183              
184             =head1 SEE ALSO
185              
186             L
187              
188             =head1 AUTHOR
189              
190             Михаил Че (Mikhail Che), C<< >>
191              
192             =head1 BUGS / CONTRIBUTING
193              
194             Please report any bugs or feature requests at L.
195              
196             =head1 COPYRIGHT
197              
198             Copyright 2016-2018+ Mikhail Che.
199              
200             This library is free software; you can redistribute it and/or modify
201             it under the same terms as Perl itself.
202              
203             =cut