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
24
24
24
66
22
479
use strict;
5
24
24
24
54
22
325
use warnings;
6
7
24
24
24
55
24
714
use Carp 'croak';
8
24
24
24
52
19
320
use Exporter 'import';
9
24
24
24
56
22
71
use Test::Mocha::Types 'Slurpy';
10
24
24
24
3129
19
78
use Types::Standard qw( ArrayRef HashRef );
11
12our @EXPORT_OK = qw(
13  check_slurpy_arg
14  extract_method_name
15  find_caller
16);
17
18sub 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
1054
0
717
    my @args = @_;
26
27
1054
615
    my $i = 0;
28
1054
889
    foreach (@args) {
29
1020
1074
        if ( Slurpy->check($_) ) {
30
134
2337
            croak 'No arguments allowed after a slurpy type constraint'
31              if $i < $#args;
32
33
126
87
            my $slurpy = $_->{slurpy};
34
126
129
            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
1006
33019
        $i++;
39    }
40
1040
1118
    return;
41}
42
43sub extract_method_name {
44    # """Extracts the method name from its fully qualified name."""
45    # uncoverable pod
46
578
0
418
    my ($method_name) = @_;
47
578
1199
    $method_name =~ s/.*:://sm;
48
578
773
    return $method_name;
49}
50
51sub find_caller {
52    # """Search the call stack to find an external caller"""
53    # uncoverable pod
54
546
0
296
    my ( $package, $file, $line );
55
56
546
308
    my $i = 1;
57
546
281
    while () {
58
550
1743
        ( $package, $file, $line ) = caller $i++;
59
550
1540
        last if $package ne 'UNIVERSAL::ref';
60    }
61
546
1332
    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
791;