line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Test::Mocha::Util; |
2
|
|
|
|
|
|
|
# ABSTRACT: Internal utility functions |
3
|
|
|
|
|
|
|
$Test::Mocha::Util::VERSION = '0.67'; |
4
|
13
|
|
|
13
|
|
116
|
use strict; |
|
13
|
|
|
|
|
38
|
|
|
13
|
|
|
|
|
515
|
|
5
|
13
|
|
|
13
|
|
90
|
use warnings; |
|
13
|
|
|
|
|
33
|
|
|
13
|
|
|
|
|
441
|
|
6
|
|
|
|
|
|
|
|
7
|
13
|
|
|
13
|
|
78
|
use Carp 'croak'; |
|
13
|
|
|
|
|
28
|
|
|
13
|
|
|
|
|
949
|
|
8
|
13
|
|
|
13
|
|
85
|
use Exporter 'import'; |
|
13
|
|
|
|
|
47
|
|
|
13
|
|
|
|
|
490
|
|
9
|
13
|
|
|
13
|
|
91
|
use Test::Mocha::Types 'Slurpy'; |
|
13
|
|
|
|
|
40
|
|
|
13
|
|
|
|
|
82
|
|
10
|
13
|
|
|
13
|
|
3842
|
use Types::Standard qw( ArrayRef HashRef ); |
|
13
|
|
|
|
|
56
|
|
|
13
|
|
|
|
|
88
|
|
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
|
1292
|
my @args = @_; |
26
|
|
|
|
|
|
|
|
27
|
736
|
|
|
|
|
1152
|
my $i = 0; |
28
|
736
|
|
|
|
|
1326
|
foreach (@args) { |
29
|
609
|
100
|
|
|
|
1411
|
if ( Slurpy->check($_) ) { |
30
|
76
|
100
|
|
|
|
3588
|
croak 'No arguments allowed after a slurpy type constraint' |
31
|
|
|
|
|
|
|
if $i < $#args; |
32
|
|
|
|
|
|
|
|
33
|
68
|
|
|
|
|
137
|
my $slurpy = $_->{slurpy}; |
34
|
68
|
100
|
100
|
|
|
184
|
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
|
|
|
|
|
45373
|
$i++; |
39
|
|
|
|
|
|
|
} |
40
|
722
|
|
|
|
|
1405
|
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
|
827
|
my ($method_name) = @_; |
47
|
406
|
|
|
|
|
2475
|
$method_name =~ s/.*:://sm; |
48
|
406
|
|
|
|
|
1095
|
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
|
647
|
my ( $package, $file, $line ); |
55
|
|
|
|
|
|
|
|
56
|
390
|
|
|
|
|
608
|
my $i = 1; |
57
|
390
|
|
|
|
|
538
|
while () { |
58
|
390
|
|
|
|
|
3020
|
( $package, $file, $line ) = caller $i++; |
59
|
390
|
50
|
|
|
|
1275
|
last if $package ne 'UNIVERSAL::ref'; |
60
|
|
|
|
|
|
|
} |
61
|
390
|
|
|
|
|
1684
|
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; |