line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Test::Mocha::Util; |
2
|
|
|
|
|
|
|
# ABSTRACT: Internal utility functions |
3
|
|
|
|
|
|
|
$Test::Mocha::Util::VERSION = '0.66'; |
4
|
13
|
|
|
13
|
|
102
|
use strict; |
|
13
|
|
|
|
|
33
|
|
|
13
|
|
|
|
|
467
|
|
5
|
13
|
|
|
13
|
|
85
|
use warnings; |
|
13
|
|
|
|
|
25
|
|
|
13
|
|
|
|
|
360
|
|
6
|
|
|
|
|
|
|
|
7
|
13
|
|
|
13
|
|
85
|
use Carp 'croak'; |
|
13
|
|
|
|
|
26
|
|
|
13
|
|
|
|
|
703
|
|
8
|
13
|
|
|
13
|
|
101
|
use Exporter 'import'; |
|
13
|
|
|
|
|
34
|
|
|
13
|
|
|
|
|
401
|
|
9
|
13
|
|
|
13
|
|
77
|
use Test::Mocha::Types 'Slurpy'; |
|
13
|
|
|
|
|
31
|
|
|
13
|
|
|
|
|
76
|
|
10
|
13
|
|
|
13
|
|
3818
|
use Types::Standard qw( ArrayRef HashRef ); |
|
13
|
|
|
|
|
35
|
|
|
13
|
|
|
|
|
79
|
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
our @EXPORT_OK = qw( |
13
|
|
|
|
|
|
|
check_slurpy_arg |
14
|
|
|
|
|
|
|
extract_method_name |
15
|
|
|
|
|
|
|
find_caller |
16
|
|
|
|
|
|
|
); |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
sub check_slurpy_arg { |
19
|
|
|
|
|
|
|
# """ |
20
|
|
|
|
|
|
|
# Checks the arguments list for the presence of a slurpy argument matcher. |
21
|
|
|
|
|
|
|
# It will throw an error if it is used incorrectly. |
22
|
|
|
|
|
|
|
# Otherwise it will just return silently. |
23
|
|
|
|
|
|
|
# """ |
24
|
|
|
|
|
|
|
# uncoverable pod |
25
|
736
|
|
|
736
|
0
|
1231
|
my @args = @_; |
26
|
|
|
|
|
|
|
|
27
|
736
|
|
|
|
|
1056
|
my $i = 0; |
28
|
736
|
|
|
|
|
1272
|
foreach (@args) { |
29
|
609
|
100
|
|
|
|
1350
|
if ( Slurpy->check($_) ) { |
30
|
76
|
100
|
|
|
|
3216
|
croak 'No arguments allowed after a slurpy type constraint' |
31
|
|
|
|
|
|
|
if $i < $#args; |
32
|
|
|
|
|
|
|
|
33
|
68
|
|
|
|
|
138
|
my $slurpy = $_->{slurpy}; |
34
|
68
|
100
|
100
|
|
|
220
|
croak 'Slurpy argument must be a type of ArrayRef or HashRef' |
35
|
|
|
|
|
|
|
unless $slurpy->is_a_type_of(ArrayRef) |
36
|
|
|
|
|
|
|
|| $slurpy->is_a_type_of(HashRef); |
37
|
|
|
|
|
|
|
} |
38
|
595
|
|
|
|
|
44954
|
$i++; |
39
|
|
|
|
|
|
|
} |
40
|
722
|
|
|
|
|
1362
|
return; |
41
|
|
|
|
|
|
|
} |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
sub extract_method_name { |
44
|
|
|
|
|
|
|
# """Extracts the method name from its fully qualified name.""" |
45
|
|
|
|
|
|
|
# uncoverable pod |
46
|
406
|
|
|
406
|
0
|
772
|
my ($method_name) = @_; |
47
|
406
|
|
|
|
|
1994
|
$method_name =~ s/.*:://sm; |
48
|
406
|
|
|
|
|
1090
|
return $method_name; |
49
|
|
|
|
|
|
|
} |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
sub find_caller { |
52
|
|
|
|
|
|
|
# """Search the call stack to find an external caller""" |
53
|
|
|
|
|
|
|
# uncoverable pod |
54
|
390
|
|
|
390
|
0
|
621
|
my ( $package, $file, $line ); |
55
|
|
|
|
|
|
|
|
56
|
390
|
|
|
|
|
581
|
my $i = 1; |
57
|
390
|
|
|
|
|
558
|
while () { |
58
|
390
|
|
|
|
|
2209
|
( $package, $file, $line ) = caller $i++; |
59
|
390
|
50
|
|
|
|
1176
|
last if $package ne 'UNIVERSAL::ref'; |
60
|
|
|
|
|
|
|
} |
61
|
390
|
|
|
|
|
1659
|
return ( $file, $line ); |
62
|
|
|
|
|
|
|
} |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
# sub print_call_stack { |
65
|
|
|
|
|
|
|
# # """ |
66
|
|
|
|
|
|
|
# # Returns whether the given C<$package> is in the current call stack. |
67
|
|
|
|
|
|
|
# # """ |
68
|
|
|
|
|
|
|
# # uncoverable pod |
69
|
|
|
|
|
|
|
# my ( $message ) = @_; |
70
|
|
|
|
|
|
|
# |
71
|
|
|
|
|
|
|
# print $message, "\n"; |
72
|
|
|
|
|
|
|
# my $level = 1; |
73
|
|
|
|
|
|
|
# while ( my ( $caller, $file, $line, $sub ) = caller $level++ ) { |
74
|
|
|
|
|
|
|
# print "\t[$caller] $sub\n"; |
75
|
|
|
|
|
|
|
# } |
76
|
|
|
|
|
|
|
# return; |
77
|
|
|
|
|
|
|
# } |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
1; |