The Perl Toolchain Summit 2025 Needs You: You can help 🙏 Learn more

AKHUETTEL / Lab-Measurement-3.930 / lib / Lab / Moose / Instrument / Log.pm 

            

              
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
—
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148

              
package Lab::Moose::Instrument::Log;
$Lab::Moose::Instrument::Log::VERSION = '3.930';
#ABSTRACT: Role for Lab::Moose::Instrument connection logging.
use v5.20;
use Moose::Role;
use Carp;
use namespace::autoclean;
use YAML::XS;
use IO::Handle;
has log_file => (
    is        => 'ro',
    isa       => 'Str',
    predicate => 'has_log_file',
);
has log_fh => (
    is        => 'ro',
    isa       => 'FileHandle',
    builder   => 'log_build_fh',
    predicate => 'has_log_fh',
    lazy      => 1,
);
has log_id => (
    is      => 'ro',
    isa     => 'Int',
    writer  => '_log_id',
    default => 0,
);
my @wrapped_methods = qw/binary_read write binary_query clear/;
requires(@wrapped_methods);
sub log_build_fh {
    my $self = shift;
    my $file = $self->log_file();
    open my $fh, '>', $file
        or croak "cannot open logfile '$file': $!";
    $fh->autoflush();
    return $fh;
}
sub _log_retval {
    my ( $arg_ref, $retval ) = @_;
    if ( $retval !~ /[^[:ascii:]]/ ) {
        $arg_ref->{retval} = $retval;
    }
    else {
        $arg_ref->{retval_enc} = 'hex';
        $arg_ref->{retval} = unpack( 'H*', $retval );
    }
}
for my $method (@wrapped_methods) {
    around $method => sub {
        my $orig   = shift;
        my $self   = shift;
        my @params = @_;
        if ( !( $self->has_log_fh() || $self->has_log_file() ) ) {
            return $self->$orig(@params);
        }
        my %arg;
        if ( ref $params[0] eq 'HASH' ) {
            %arg = %{ $params[0] };
        }
        else {
            %arg = @params;
        }
        my $retval = $self->$orig(@params);
        if ( $method =~ /read|query/ ) {
            _log_retval( \%arg, $retval );
        }
        my %methods = (
            binary_read  => 'Read',
            write        => 'Write',
            binary_query => 'Query',
            clear        => 'Clear',
        );
        $arg{method} = $methods{$method};
        my $id = $self->log_id();
        $arg{id} = $id;
        $self->_log_id( ++$id );
        my $fh = $self->log_fh();
        print {$fh} Dump( \%arg );
        return $retval;
        }
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Lab::Moose::Instrument::Log - Role for Lab::Moose::Instrument connection logging.
=head1 VERSION
version 3.930
=head1 SYNOPSIS
 use Lab::Moose 'instrument';
 my $instr = instrument(
     type => '...',
     connection_type => '...',
     connection_options => {...},
     # write into newly created logfile:
     log_file => '/tmp/instr.log',
     # alternative: write into filehandle:
     log_fh => $filehandle,
 );
=head1 DESCRIPTION
Log all of the instrument's C<read, write, query, clear> function calls into a
logfile or an existing filehandle.
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2025 by the Lab::Measurement team; in detail:
  Copyright 2016       Simon Reinhardt
            2017       Andreas K. Huettel, Simon Reinhardt
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut