File Coverage

blib/lib/Lab/Moose/Connection/Mock.pm
Criterion Covered Total %
statement 52 56 92.8
branch 7 12 58.3
condition 3 6 50.0
subroutine 13 13 100.0
pod 0 2 0.0
total 75 89 84.2


line stmt bran cond sub pod time code
1             package Lab::Moose::Connection::Mock;
2             $Lab::Moose::Connection::Mock::VERSION = '3.900';
3             #ABSTRACT: Mock connection, supplying instrument responses from a log file
4              
5 17     17   14091 use v5.20;
  17         73  
6              
7 17     17   116 use Moose;
  17         38  
  17         141  
8 17     17   119751 use MooseX::Params::Validate;
  17         50  
  17         186  
9 17     17   8006 use namespace::autoclean;
  17         53  
  17         179  
10 17     17   1417 use Data::Dumper;
  17         47  
  17         890  
11 17     17   131 use YAML::XS;
  17         34  
  17         1399  
12 17     17   206 use Carp;
  17         65  
  17         11153  
13              
14              
15             has log_file => (
16             is => 'ro',
17             isa => 'Str',
18             predicate => 'has_log_file',
19             );
20              
21             has log_fh => (
22             is => 'ro',
23             isa => 'FileHandle',
24             builder => 'log_build_fh',
25             predicate => 'has_log_fh',
26             lazy => 1,
27             );
28              
29             has logs => (
30             is => 'ro',
31             isa => 'ArrayRef',
32             writer => '_logs',
33             init_arg => undef,
34             );
35              
36             has id => (
37             is => 'ro',
38             isa => 'Int',
39             writer => '_id',
40             init_arg => undef,
41             default => 0,
42             );
43              
44             sub log_build_fh {
45 13     13 0 35 my $self = shift;
46 13         450 my $file = $self->log_file();
47 13 50       1490 open my $fh, '<', $file
48             or croak "cannot open logfile '$file': $!";
49 13         600 return $fh;
50             }
51              
52             sub BUILD {
53 13     13 0 50 my $self = shift;
54 13 50 33     544 if ( !( $self->has_log_file() || $self->has_log_fh() ) ) {
55 0         0 croak "no log_file in Mock connection";
56             }
57              
58 13         600 my $fh = $self->log_fh();
59 13         31 my $yaml = do { local $/; <$fh> };
  13         81  
  13         9170  
60 13         8237 my @logs = Load($yaml);
61 13         888 $self->_logs( \@logs );
62 13 50       730 close $fh
63             or croak "cannot close log_fh: $!";
64             }
65              
66             my $meta = __PACKAGE__->meta();
67              
68             for my $method (qw/Read Write Query Clear/) {
69             $meta->add_method(
70             $method => sub {
71 542     542   5901 my $self = shift;
        542      
        542      
        542      
72 542         1229 my @params = @_;
73 542         854 my %arg;
74 542 50       1390 if ( ref $params[0] eq 'HASH' ) {
75 0         0 %arg = %{ $params[0] };
  0         0  
76             }
77             else {
78 542         1373 %arg = @params;
79             }
80 542         1171 $arg{method} = $method;
81 542         15940 my $id = $self->id();
82 542         1128 $arg{id} = $id;
83 542         17053 $self->_id( ++$id );
84 542         810 my $log = shift @{ $self->logs };
  542         15412  
85              
86 542         1257 my $retval = delete $log->{retval};
87 542         933 my $retval_enc = delete $log->{retval_enc};
88              
89             # Compare:
90 542         21908 my $arg_yaml = Dump( \%arg );
91 542         12133 my $log_yaml = Dump($log);
92 542 50       2236 if ( $arg_yaml ne $log_yaml ) {
93 0         0 croak <<"EOF";
94             mismatch in Mock Connection:
95             logged:
96             $log_yaml
97             received:
98             $arg_yaml
99             EOF
100             }
101 542 100 66     1497 if ( defined $retval_enc && $retval_enc eq 'hex' ) {
102 9         77 $retval = pack( 'H*', $retval );
103             }
104 542         4080 return $retval;
105             }
106             );
107             }
108              
109             with 'Lab::Moose::Connection';
110              
111             $meta->make_immutable();
112             1;
113              
114             __END__
115              
116             =pod
117              
118             =encoding UTF-8
119              
120             =head1 NAME
121              
122             Lab::Moose::Connection::Mock - Mock connection, supplying instrument responses from a log file
123              
124             =head1 VERSION
125              
126             version 3.900
127              
128             =head1 SYNOPSIS
129              
130             use Lab::Moose;
131              
132             my $instrument = instrument(
133             type => 'some_instrument',
134             connection_type => 'Mock',
135             connection_options => { log_file => 'log.yml' }, # or log_fh => $fh,
136             );
137              
138             =head1 DESCRIPTION
139              
140             Mock connection object for unit testing. Uses a log recorded previously
141             with a real instrument using L<Lab::Moose::Instrument::Log>.
142              
143             =head1 COPYRIGHT AND LICENSE
144              
145             This software is copyright (c) 2023 by the Lab::Measurement team; in detail:
146              
147             Copyright 2016 Simon Reinhardt
148             2017 Andreas K. Huettel, Simon Reinhardt
149             2020 Andreas K. Huettel
150              
151              
152             This is free software; you can redistribute it and/or modify it under
153             the same terms as the Perl 5 programming language system itself.
154              
155             =cut