File Coverage

blib/lib/Mojo/IRC/Server/Chinese/Base.pm
Criterion Covered Total %
statement 50 67 74.6
branch 15 36 41.6
condition 6 15 40.0
subroutine 16 67 23.8
pod 0 3 0.0
total 87 188 46.2


line stmt bran cond sub pod time code
1             package Mojo::IRC::Server::Chinese::Base;
2 1     1   3 use strict;
  1         1  
  1         23  
3 1     1   3 use warnings;
  1         1  
  1         18  
4 1     1   3 use feature ();
  1         1  
  1         10  
5            
6             # No imports because we get subclassed, a lot!
7 1     1   2 use Carp ();
  1         1  
  1         14  
8            
9             # Only Perl 5.14+ requires it on demand
10 1     1   3 use IO::Handle ();
  1         1  
  1         77  
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 49     49   64 my ($class, %patch) = @_;
22 1     1   3 no strict 'refs';
  1         1  
  1         19  
23 1     1   3 no warnings 'redefine';
  1         0  
  1         457  
24 49         240 *{"${class}::$_"} = $NAME->("${class}::$_", $patch{$_}) for keys %patch;
  49         236  
25             }
26            
27             sub attr {
28 43     43 0 40 my ($self, $attrs, $value) = @_;
29 43 50 33     183 return unless (my $class = ref $self || $self) && $attrs;
      33        
30            
31 43 50 66     82 Carp::croak 'Default has to be a code reference or constant value'
32             if ref $value && ref $value ne 'CODE';
33            
34 43 100       27 for my $attr (@{ref $attrs eq 'ARRAY' ? $attrs : [$attrs]}) {
  43         83  
35 45 50       109 Carp::croak qq{Attribute "$attr" invalid} unless $attr =~ /^[a-zA-Z_]\w*$/;
36            
37             # Very performance sensitive code with lots of micro-optimizations
38 45 100       58 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      
42             if @_ == 1;
43 0         0 $_[0]{$attr} = $_[1];
44 0         0 $_[0];
45 16         35 };
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      
50             if @_ == 1;
51 0         0 $_[0]{$attr} = $_[1];
52 0         0 $_[0];
53 15         37 };
54             }
55             else {
56             _monkey_patch $class, $attr,
57 14 0   0   45 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      
58             }
59             }
60             }
61            
62             sub import {
63 4     4   5 my $class = shift;
64 4 50       7 return unless my $flag = shift;
65            
66             # Base
67 4 50 66     43 if ($flag eq '-base') { $flag = $class }
  0 50       0  
    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 1         8 $file =~ s!::|'!/!g;
75 1         373 require "$file.pm";
76             }
77            
78             # ISA
79 4 50       8 if ($flag) {
80 4         4 my $caller = caller;
81 1     1   5 no strict 'refs';
  1         0  
  1         189  
82 4         3 push @{"${caller}::ISA"}, $flag;
  4         33  
83 4     43   13 _monkey_patch $caller, 'has', sub { attr($caller, @_) };
  43     43   56  
        43      
        43      
        43      
84             }
85            
86             # Mojo modules are strict!
87 4         38 $_->import for qw(strict warnings);
88 4         232 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;