File Coverage

blib/lib/Venus/Role/Mockable.pm
Criterion Covered Total %
statement 24 24 100.0
branch n/a
condition 2 3 66.6
subroutine 8 8 100.0
pod 1 2 50.0
total 35 37 94.5


line stmt bran cond sub pod time code
1             package Venus::Role::Mockable;
2              
3 87     87   1625 use 5.018;
  87         347  
4              
5 87     87   506 use strict;
  87         181  
  87         1886  
6 87     87   441 use warnings;
  87         211  
  87         2914  
7              
8 87     87   583 use Venus::Role 'with';
  87         277  
  87         617  
9              
10             # METHODS
11              
12             sub mock {
13 4     4 1 556 my ($self, $name, $code) = @_;
14              
15 87     87   681 no strict 'refs';
  87         287  
  87         3803  
16 87     87   584 no warnings 'redefine';
  87         230  
  87         14021  
17              
18 4   66     25 my $class = ref $self || $self;
19              
20 4         15 my $orig = $class->can($name);
21              
22 4         26 *{"${class}::${name}"} = my $mock = $code->($orig);
  4         27  
23              
24 4         27 return $mock;
25             }
26              
27             # EXPORTS
28              
29             sub EXPORT {
30 88     88 0 376 ['mock']
31             }
32              
33             1;
34              
35              
36              
37             =head1 NAME
38              
39             Venus::Role::Mockable - Mockable Role
40              
41             =cut
42              
43             =head1 ABSTRACT
44              
45             Mockable Role for Perl 5
46              
47             =cut
48              
49             =head1 SYNOPSIS
50              
51             package Example;
52              
53             use Venus::Class 'with';
54              
55             with 'Venus::Role::Mockable';
56              
57             sub execute {
58             [1..4];
59             }
60              
61             package main;
62              
63             my $example = Example->new;
64              
65             # my $mock = $example->mock(execute => sub {
66             # my ($next) = @_;
67             #
68             # return sub {
69             # [@{$next->()}, @_]
70             # }
71             # });
72              
73             # sub { ... }
74              
75             =cut
76              
77             =head1 DESCRIPTION
78              
79             This package provides a mechanism for mocking subroutines.
80              
81             =cut
82              
83             =head1 METHODS
84              
85             This package provides the following methods:
86              
87             =cut
88              
89             =head2 mock
90              
91             mock(Str $name, CodeRef $code) (CodeRef)
92              
93             The mock method mocks the subroutine specified using the callback given. The
94             coderef provided will be passed the original subroutine coderef as its first
95             argument. The coderef provided should always return a coderef that will serve
96             as the subroutine mock.
97              
98             I>
99              
100             =over 4
101              
102             =item mock example 1
103              
104             package main;
105              
106             my $example = Example->new;
107              
108             my $mock = $example->mock(execute => sub {
109             my ($next) = @_;
110              
111             return sub {
112             [@{$next->()}, @_]
113             }
114             });
115              
116             # sub { ... }
117              
118             # $example->execute;
119              
120             # [1..4]
121              
122             # $example->execute(5, 6);
123              
124             # [1..6]
125              
126             =back
127              
128             =cut
129              
130             =head1 AUTHORS
131              
132             Awncorp, C
133              
134             =cut
135              
136             =head1 LICENSE
137              
138             Copyright (C) 2000, Al Newkirk.
139              
140             This program is free software, you can redistribute it and/or modify it under
141             the terms of the Apache license version 2.0.
142              
143             =cut