File Coverage

blib/lib/Mojo/Weixin/Base.pm
Criterion Covered Total %
statement 51 67 76.1
branch 17 36 47.2
condition 6 15 40.0
subroutine 20 188 10.6
pod 0 3 0.0
total 94 309 30.4


line stmt bran cond sub pod time code
1             package Mojo::Weixin::Base;
2 1     1   12 use strict;
  1         2  
  1         24  
3 1     1   4 use warnings;
  1         2  
  1         24  
4 1     1   4 use feature ();
  1         1  
  1         11  
5            
6             # No imports because we get subclassed, a lot!
7 1     1   4 use Carp ();
  1         1  
  1         10  
8            
9             # Only Perl 5.14+ requires it on demand
10 1     1   479 use IO::Handle ();
  1         4912  
  1         81  
11            
12             # Supported on Perl 5.22+
13             my $NAME
14             = eval { require Sub::Util; Sub::Util->can('set_subname') } || sub { $_[1] };
15            
16             # Protect subclasses using AUTOLOAD
17       0     sub DESTROY { }
18            
19             # Declared here to avoid circular require problems in Mojo::Util
20             sub _monkey_patch {
21 170     170   379 my ($class, %patch) = @_;
22 1     1   6 no strict 'refs';
  1         2  
  1         34  
23 1     1   5 no warnings 'redefine';
  1         1  
  1         464  
24 170         827 *{"${class}::$_"} = $NAME->("${class}::$_", $patch{$_}) for keys %patch;
  170         813  
25             }
26            
27             sub attr {
28 105     105 0 160 my ($self, $attrs, $value) = @_;
29 105 50 33     355 return unless (my $class = ref $self || $self) && $attrs;
      33        
30            
31 105 50 66     185 Carp::croak 'Default has to be a code reference or constant value'
32             if ref $value && ref $value ne 'CODE';
33            
34 105 100       105 for my $attr (@{ref $attrs eq 'ARRAY' ? $attrs : [$attrs]}) {
  105         243  
35 162 50       443 Carp::croak qq{Attribute "$attr" invalid} unless $attr =~ /^[a-zA-Z_]\w*$/;
36            
37             # Very performance sensitive code with lots of micro-optimizations
38 162 100       259 if (ref $value) {
    100          
39             _monkey_patch $class, $attr, sub {
40             return
41 0 0   0   0 exists $_[0]{$attr} ? $_[0]{$attr} : ($_[0]{$attr} = $value->($_[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      
42             if @_ == 1;
43 0         0 $_[0]{$attr} = $_[1];
44 0         0 $_[0];
45 27         84 };
46             }
47             elsif (defined $value) {
48             _monkey_patch $class, $attr, sub {
49 0 0   0   0 return exists $_[0]{$attr} ? $_[0]{$attr} : ($_[0]{$attr} = $value)
    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      
50             if @_ == 1;
51 0         0 $_[0]{$attr} = $_[1];
52 0         0 $_[0];
53 52         163 };
54             }
55             else {
56             _monkey_patch $class, $attr,
57 83 0   0   222 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      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
58             }
59             }
60             }
61            
62             sub import {
63 15     15   29 my $class = shift;
64 15 100       1891 return unless my $flag = shift;
65            
66             # Base
67 8 100 66     91 if ($flag eq '-base') { $flag = $class }
  1 50       2  
    100          
68            
69             # Strict
70 0         0 elsif ($flag eq '-strict') { $flag = undef }
71            
72             # Module
73             elsif ((my $file = $flag) && !$flag->can('new')) {
74 2         17 $file =~ s!::|'!/!g;
75 2         698 require "$file.pm";
76             }
77            
78             # ISA
79 8 50       148961 if ($flag) {
80 8         18 my $caller = caller;
81 1     1   7 no strict 'refs';
  1         2  
  1         188  
82 8         14 push @{"${caller}::ISA"}, $flag;
  8         88  
83 8     105   46 _monkey_patch $caller, 'has', sub { attr($caller, @_) };
  105     105   181  
        105      
        105      
        105      
        105      
        105      
        105      
        105      
84             }
85            
86             # Mojo modules are strict!
87 8         150 $_->import for qw(strict warnings);
88 8         1641 feature->import(':5.10');
89             }
90            
91             sub new {
92 0     0 0   my $class = shift;
93 0 0 0       bless @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {}, ref $class || $class;
  0 0          
94             }
95            
96             sub tap {
97 0     0 0   my ($self, $cb) = (shift, shift);
98 0           $_->$cb(@_) for $self;
99 0           return $self;
100             }
101            
102             1;