File Coverage

blib/lib/Test/AskAnExpert/Interface/Mock.pm
Criterion Covered Total %
statement 27 27 100.0
branch 6 6 100.0
condition n/a
subroutine 7 7 100.0
pod 4 4 100.0
total 44 44 100.0


line stmt bran cond sub pod time code
1             package Test::AskAnExpert::Interface::Mock;
2              
3 2     2   1009 use strict;
  2         6  
  2         86  
4 2     2   12 use warnings;
  2         4  
  2         76  
5 2     2   11 use base 'Test::AskAnExpert::Interface';
  2         5  
  2         1109  
6              
7             our $VERSION = 1.1;
8              
9             =head1 NAME
10              
11             Test::AskAnExpert::Interface::Mock - Mock interface for testing Test::AskAnExpert
12              
13             =head1 SYNOPSIS
14              
15             use Test::AskAnExpert;
16              
17             initialize('Test::AskAnExpert::Interface::Mock',
18             answer => 'always do this',
19             comment => 'saying this about it',
20             skip => 'or skip because of this',
21             error => 'or give this error'
22             never_answer => 0);
23              
24             # do some testing here to make sure Test::AskAnExpert
25             # reacts properly.
26              
27             =head1 DESCRIPTION
28              
29             This is for internal testing. If you're re-implementing Test::AskAnExpert you might
30             find it useful yourself.
31              
32             =cut
33              
34             sub load {
35 9     9 1 785 my $class = shift;
36 9         27 my %args = @_;
37 9         18 my $self = {};
38              
39 9         20 $self->{_answer} = $args{answer};
40 9         17 $self->{_comment} = $args{comment};
41 9         18 $self->{_skip} = $args{skip};
42 9         18 $self->{_error} = $args{error};
43 9         13 $self->{_dont} = $args{never_answer};
44              
45 9         45 bless $self,$class;
46             }
47              
48             sub submit {
49 10     10 1 450 my ($self,$question,$name) = @_;
50              
51 10 100       59 $self->err($self->{_error}), return undef if $self->{_error};
52 8 100       30 return Test::AskAnExpert::Question->new(question=>$question,
53             name=>$name,
54             id=>"id",
55             skip=>$self->{_skip}) if $self->{_skip};
56 6         37 return Test::AskAnExpert::Question->new(question=>$question,name=>$name,id=>"id");
57             }
58              
59             sub has_answer {
60 20     20 1 435 my $self = shift;
61 20         190 return !$self->{_dont};
62             }
63              
64             sub answer {
65 9     9 1 16 my ($self,$Qobj) = @_;
66              
67 9 100       30 $self->err($self->{_error}), return undef if $self->{_error};
68 7         26 $Qobj->answer($self->{_answer},$self->{_comment});
69             }
70              
71             =head1 AUTHOR
72              
73             Edgar A. Bering, Etrizor@cpan.orgE
74              
75             =head1 COPYRIGHT AND LICENSE
76              
77             Copyright (C) 2007 by Edgar A. Bering
78              
79             This library is free software; you can redistribute it and/or modify
80             it under the terms of the Artistic 2.0 liscence as provided in the
81             LICENSE file of this distribution.
82              
83             =cut
84              
85              
86             1;