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
32
11
228
use strict;
5
12
12
12
28
11
154
use warnings;
6
7
12
12
12
27
10
337
use Carp 'croak';
8
12
12
12
25
9
148
use Exporter 'import';
9
12
12
12
26
12
33
use Test::Mocha::Types 'Slurpy';
10
12
12
12
1478
9
40
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
527
0
345
    my @args = @_;
26
27
527
306
    my $i = 0;
28
527
429
    foreach (@args) {
29
510
534
        if ( Slurpy->check($_) ) {
30
67
1144
            croak 'No arguments allowed after a slurpy type constraint'
31              if $i < $#args;
32
33
63
44
            my $slurpy = $_->{slurpy};
34
63
60
            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
503
16283
        $i++;
39    }
40
520
562
    return;
41}
42
43sub extract_method_name {
44    # """Extracts the method name from its fully qualified name."""
45    # uncoverable pod
46
289
0
221
    my ($method_name) = @_;
47
289
572
    $method_name =~ s/.*:://sm;
48
289
381
    return $method_name;
49}
50
51sub find_caller {
52    # """Search the call stack to find an external caller"""
53    # uncoverable pod
54
273
0
147
    my ( $package, $file, $line );
55
56
273
155
    my $i = 1;
57
273
133
    while () {
58
275
848
        ( $package, $file, $line ) = caller $i++;
59
275
725
        last if $package ne 'UNIVERSAL::ref';
60    }
61
273
647
    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;