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 68 23.5
pod 0 3 0.0
total 87 189 46.0


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