line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Sprocket::Common; |
2
|
|
|
|
|
|
|
|
3
|
8
|
|
|
8
|
|
46
|
use strict; |
|
8
|
|
|
|
|
13
|
|
|
8
|
|
|
|
|
258
|
|
4
|
8
|
|
|
8
|
|
37
|
use warnings; |
|
8
|
|
|
|
|
15
|
|
|
8
|
|
|
|
|
190
|
|
5
|
8
|
|
|
8
|
|
6650
|
use Data::UUID; |
|
8
|
|
|
|
|
23977
|
|
|
8
|
|
|
|
|
1700
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
our %hex_chr; |
8
|
|
|
|
|
|
|
our %chr_hex; |
9
|
|
|
|
|
|
|
our $super_event = 'sub super_event {' |
10
|
|
|
|
|
|
|
. 'my $self = shift; my $caller = ( caller( 1 ) )[ 3 ];' |
11
|
|
|
|
|
|
|
. '$caller =~ s/.*::(.+)$/$1/; $caller= "SUPER::$caller";' |
12
|
|
|
|
|
|
|
. 'my $ret = $self->$caller( @_ ); unshift( @_, $self );' |
13
|
|
|
|
|
|
|
. 'push( @_, $ret ); return @_; }'; |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
BEGIN { |
16
|
8
|
|
|
8
|
|
31
|
for ( 0 .. 255 ) { |
17
|
2048
|
|
|
|
|
3506
|
my $h = sprintf( "%%%02X", $_ ); |
18
|
2048
|
|
|
|
|
2643
|
my $c = chr($_); |
19
|
2048
|
|
|
|
|
4764
|
$chr_hex{$c} = $h; |
20
|
2048
|
|
|
|
|
7771
|
$hex_chr{lc($h)} = $hex_chr{uc($h)} = $c; |
21
|
|
|
|
|
|
|
} |
22
|
|
|
|
|
|
|
} |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
sub import { |
25
|
68
|
|
|
68
|
|
143
|
my ( $class, $args ) = @_; |
26
|
68
|
|
|
|
|
148
|
my $package = caller(); |
27
|
|
|
|
|
|
|
|
28
|
68
|
|
|
|
|
254
|
my @exports = qw( |
29
|
|
|
|
|
|
|
uri_unescape |
30
|
|
|
|
|
|
|
uri_escape |
31
|
|
|
|
|
|
|
adjust_params |
32
|
|
|
|
|
|
|
gen_uuid |
33
|
|
|
|
|
|
|
new_uuid |
34
|
|
|
|
|
|
|
); |
35
|
|
|
|
|
|
|
|
36
|
68
|
50
|
|
|
|
238
|
push( @exports, @_ ) if ( @_ ); |
37
|
|
|
|
|
|
|
|
38
|
8
|
|
|
8
|
|
76
|
no strict 'refs'; |
|
8
|
|
|
|
|
16
|
|
|
8
|
|
|
|
|
6065
|
|
39
|
68
|
|
|
|
|
128
|
foreach my $sub ( @exports ) { |
40
|
408
|
50
|
|
|
|
758
|
if ( $sub eq 'super_event' ) { |
41
|
|
|
|
|
|
|
# XXX We must define this sub in the class because it uses SUPER |
42
|
|
|
|
|
|
|
# I don't know of any other way to do this, yet. |
43
|
0
|
|
|
|
|
0
|
eval ( "package $package;" . $super_event ) |
44
|
0
|
0
|
|
|
|
0
|
if ( !defined *{ $package . '::super_event' } ); |
45
|
|
|
|
|
|
|
} else { |
46
|
408
|
|
|
|
|
696
|
*{ $package . '::' . $sub } = \&$sub; |
|
408
|
|
|
|
|
2981
|
|
47
|
|
|
|
|
|
|
} |
48
|
|
|
|
|
|
|
} |
49
|
|
|
|
|
|
|
} |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
sub uri_escape { |
52
|
0
|
0
|
|
0
|
0
|
0
|
my $es = shift or return; |
53
|
0
|
0
|
|
|
|
0
|
$es =~ s/([^A-Za-z0-9\-_.!~*'()])/$chr_hex{$1}||_try_utf8($1)/ge; |
|
0
|
|
|
|
|
0
|
|
54
|
0
|
|
|
|
|
0
|
return $es; |
55
|
|
|
|
|
|
|
} |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
sub _try_utf8 { |
58
|
0
|
|
|
0
|
|
0
|
my $c = shift; |
59
|
0
|
|
|
|
|
0
|
$c = eval { utf8::encode($c); }; |
|
0
|
|
|
|
|
0
|
|
60
|
0
|
0
|
|
|
|
0
|
if ( $@ ) { |
61
|
0
|
|
|
|
|
0
|
warn $@; |
62
|
0
|
|
|
|
|
0
|
return ''; |
63
|
|
|
|
|
|
|
} |
64
|
0
|
|
|
|
|
0
|
return $c |
65
|
|
|
|
|
|
|
} |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
sub uri_unescape { |
68
|
0
|
0
|
|
0
|
0
|
0
|
my $es = shift or return; |
69
|
0
|
|
|
|
|
0
|
$es =~ tr/+/ /; # foo=this+is+a+test |
70
|
0
|
|
|
|
|
0
|
$es =~ s/(%[0-9a-fA-F]{2})/$hex_chr{$1}/gs; |
71
|
0
|
|
|
|
|
0
|
return $es; |
72
|
|
|
|
|
|
|
} |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
# ThisIsCamelCase -> this_is_camel_case |
75
|
|
|
|
|
|
|
# my %opts = &adjust_params; |
76
|
|
|
|
|
|
|
# my $t = adjust_params($f); # $f being a hashref |
77
|
|
|
|
|
|
|
sub adjust_params { |
78
|
30
|
100
|
66
|
30
|
0
|
293
|
my $o = ( $#_ == 0 && ref( $_[ 0 ] ) ) ? shift : { @_ }; |
79
|
30
|
|
|
|
|
130
|
foreach my $k ( keys %$o ) { |
80
|
90
|
|
|
|
|
163
|
local $_ = "$k"; |
81
|
90
|
|
|
|
|
316
|
s/([A-Z][a-z]+)/lc($1)."_"/ge; s/_$//; |
|
92
|
|
|
|
|
287
|
|
|
90
|
|
|
|
|
257
|
|
82
|
90
|
|
|
|
|
402
|
$o->{+lc} = delete $o->{$k}; |
83
|
|
|
|
|
|
|
} |
84
|
30
|
100
|
|
|
|
287
|
return wantarray ? %$o : $o; |
85
|
|
|
|
|
|
|
} |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
sub gen_uuid { |
88
|
28
|
|
|
28
|
0
|
71
|
my $from = shift; |
89
|
28
|
|
|
|
|
3536
|
my $u = Data::UUID->new(); |
90
|
28
|
|
|
|
|
3406
|
my $uuid = $u->create_from_name( "cc.sprocket", "$from" ); |
91
|
28
|
|
|
|
|
2373250
|
return lc( $u->to_string( $uuid ) ); |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
sub new_uuid { |
95
|
29
|
|
|
29
|
0
|
3083859
|
return lc( new Data::UUID->create_str() ); |
96
|
|
|
|
|
|
|
} |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
1; |