File Coverage

File:blib/lib/Test/Mocha/Util.pm
Coverage:100.0%

linestmtbrancondsubpodtimecode
1package Test::Mocha::Util;
2# ABSTRACT: Internal utility functions
3$Test::Mocha::Util::VERSION = '0.61';
4
12
12
12
35
12
266
use strict;
5
12
12
12
29
13
199
use warnings;
6
7
12
12
12
29
9
418
use Carp 'croak';
8
12
12
12
34
7
178
use Exporter 'import';
9
12
12
12
29
10
39
use Test::Mocha::Types 'Slurpy';
10
12
12
12
3820
3185
442
use Try::Tiny;
11
12
12
12
37
12
40
use Types::Standard qw( ArrayRef HashRef );
12
13our @EXPORT_OK = qw(
14  check_slurpy_arg
15  extract_method_name
16  find_caller
17  find_stub
18  get_method_call
19);
20
21sub check_slurpy_arg {
22    # """
23    # Checks the arguments list for the presence of a slurpy argument matcher.
24    # It will throw an error if it is used incorrectly.
25    # Otherwise it will just return silently.
26    # """
27    # uncoverable pod
28
580
0
383
    my @args = @_;
29
30
580
321
    my $i = 0;
31
580
463
    foreach (@args) {
32
564
555
        if ( Slurpy->check($_) ) {
33
72
1135
            croak 'No arguments allowed after a slurpy type constraint'
34              if $i < $#args;
35
36
68
48
            my $slurpy = $_->{slurpy};
37
68
71
            croak 'Slurpy argument must be a type of ArrayRef or HashRef'
38              unless $slurpy->is_a_type_of(ArrayRef)
39              || $slurpy->is_a_type_of(HashRef);
40        }
41
557
16568
        $i++;
42    }
43
573
584
    return;
44}
45
46sub extract_method_name {
47    # """Extracts the method name from its fully qualified name."""
48    # uncoverable pod
49
282
0
210
    my ($method_name) = @_;
50
282
585
    $method_name =~ s/.*:://sm;
51
282
363
    return $method_name;
52}
53
54sub find_caller {
55    # """Search the call stack to find an external caller"""
56    # uncoverable pod
57
266
0
159
    my ( $package, $file, $line );
58
59
266
141
    my $i = 1;
60
266
154
    while () {
61
267
861
        ( $package, $file, $line ) = caller $i++;
62
267
553
        last if $package ne 'UNIVERSAL::ref';
63    }
64
266
626
    return ( $file, $line );
65}
66
67sub find_stub {
68    # uncoverable pod
69
268
0
158
    my ( $mock, $method_call ) = @_;
70
71
268
295
    my $stubs = $mock->__stubs;
72
268
334
    return if !defined $stubs->{ $method_call->name };
73
74
99
99
60
113
    foreach my $stub ( @{ $stubs->{ $method_call->name } } ) {
75
128
171
        return $stub if $stub->satisfied_by($method_call);
76    }
77
17
28
    return;
78}
79
80sub get_method_call {
81    # """
82    # Get the last method called on a mock object,
83    # removes it from the invocation history,
84    # and restores the last method stub response.
85    # """
86    # uncoverable pod
87
139
0
103
    my ($coderef) = @_;
88
89    try {
90
139
2919
        $coderef->();
91    }
92    catch {
93        ## no critic (RequireCarping,RequireExtendedFormatting)
94
9
153
        die $_
95          if ( m{^No arguments allowed after a slurpy type constraint}sm
96            || m{^Slurpy argument must be a type of ArrayRef or HashRef}sm );
97        ## use critic
98
139
423
    };
99
100
132
1326
    croak 'Coderef must have a method invoked on a mock object'
101      if $Test::Mocha::Mock::num_method_calls == 0;
102
130
224
    croak 'Coderef must not have multiple methods invoked on a mock object'
103      if $Test::Mocha::Mock::num_method_calls > 1;
104
105
129
83
    my $method_call = $Test::Mocha::Mock::last_method_call;
106
129
159
    my $mock        = $method_call->invocant;
107
108    # restore the last method stub response
109
129
136
    if ( defined $Test::Mocha::Mock::last_response ) {
110
2
1
        my $stub = find_stub( $mock, $method_call );
111
2
2
2
3
        unshift @{ $stub->{responses} }, $Test::Mocha::Mock::last_response;
112    }
113
114    # remove the last method call from the invocation history
115
129
129
63
132
    pop @{ $mock->__calls };
116
117
129
159
    return $method_call;
118}
119
120# sub print_call_stack {
121#     # """
122#     # Returns whether the given C<$package> is in the current call stack.
123#     # """
124#     # uncoverable pod
125#     my ( $message ) = @_;
126#
127#     print $message, "\n";
128#     my $level = 1;
129#     while ( my ( $caller, $file, $line, $sub ) = caller $level++ ) {
130#         print "\t[$caller] $sub\n";
131#     }
132#     return;
133# }
134
1351;