File Coverage

blib/lib/CTK/Timeout.pm
Criterion Covered Total %
statement 57 61 93.4
branch 15 26 57.6
condition 6 11 54.5
subroutine 10 11 90.9
pod 3 3 100.0
total 91 112 81.2


line stmt bran cond sub pod time code
1             package CTK::Timeout;
2 2     2   1204 use strict;
  2         3  
  2         49  
3 2     2   488 use utf8;
  2         14  
  2         10  
4              
5             =encoding utf-8
6              
7             =head1 NAME
8              
9             CTK::Timeout - Provides execute the code reference wrapped with timeout
10              
11             =head1 VERSION
12              
13             Version 1.00
14              
15             =head1 SYNOPSIS
16              
17             use CTK::Timeout;
18              
19             # Create the timeout object
20             my $to = CTK::Timeout->new();
21              
22             # Execute
23             unless ($to->timeout_call(sub { sleep 2 } => 1)) {
24             die $to->error if $to->error;
25             }
26              
27             =head1 DESCRIPTION
28              
29             This class provides execute the code reference wrapped with timeout
30              
31             =head2 new
32              
33             Creates the timeout object
34              
35             my $to = CTK::Timeout->new();
36              
37             Creates the timeout object without the POSIX "sigaction" supporting (forced off)
38              
39             my $to = CTK::Timeout->new(0);
40              
41             =head2 error
42              
43             die $to->error if $to->error;
44              
45             Returns error string
46              
47             =head2 timeout_call
48              
49             Given a code reference (with optional arguments @args) will execute
50             as eval-wrapped with a timeout value (in seconds). This method returns
51             the return-value of the specified code in scalar context
52              
53             my $retval = $to->timeout_call(sub { sleep 2 } => 1, "foo", "bar");
54              
55             =head1 HISTORY
56              
57             See C file
58              
59             =head1 DEPENDENCIES
60              
61             L, L
62              
63             =head1 TO DO
64              
65             See C file
66              
67             =head1 SEE ALSO
68              
69             L, L
70              
71             =head1 AUTHOR
72              
73             Serż Minus (Sergey Lepenkov) L Eabalama@cpan.orgE
74              
75             =head1 COPYRIGHT
76              
77             Copyright (C) 1998-2022 D&D Corporation. All Rights Reserved
78              
79             =head1 LICENSE
80              
81             This program is free software; you can redistribute it and/or
82             modify it under the same terms as Perl itself.
83              
84             See C file and L
85              
86             =cut
87              
88 2     2   72 use vars qw/$VERSION/;
  2         2  
  2         81  
89              
90             $VERSION = "1.00";
91              
92 2     2   10 use Carp;
  2         3  
  2         85  
93 2     2   401 use POSIX ':signal_h';
  2         5230  
  2         11  
94 2     2   1705 use Config;
  2         4  
  2         960  
95              
96             # Check POSIX sigaction support
97             my $USE_POSIX_SIGACTION = 1;
98             $USE_POSIX_SIGACTION = 0 if $^O =~ /mswin/i or $^O =~ /cygwin/i;
99             $USE_POSIX_SIGACTION = 0 unless $Config{'useposix'} && $Config{'d_sigaction'};
100             $USE_POSIX_SIGACTION = 0 if $Config{'archname'} && $Config{'archname'} =~ /^arm/;
101              
102             sub new {
103 2     2 1 343 my $class = shift;
104 2         3 my $force = shift;
105 2 50 50     17 my $self = bless {
106             error => "",
107             use_sigaction => $USE_POSIX_SIGACTION ? $force // 1 : 0,
108             use_sigaction_origin => $USE_POSIX_SIGACTION,
109             }, $class;
110 2         5 return $self;
111             }
112             sub timeout_call {
113 4     4 1 773 my $self = shift;
114 4   50 0   10 my $code = shift // sub {1};
  0         0  
115 4   100     12 my $timeout = shift || 0;
116 4         11 my @args = @_;
117 4 50       10 croak("The code reference incorrect") unless ref($code) eq 'CODE';
118 4         9 $self->{error} = "";
119              
120 4         6 my $failed;
121             my $retval; # scalar context only!
122              
123             # Without timeout
124 4 100       8 if (!$timeout) {
125             eval {
126 3         7 $retval = &$code(@args);
127 2         8 1;
128 3 100       4 } or do {
129 1 50       18 $self->{error} = $@ if $@;
130             };
131 3         8 return $retval;
132             }
133              
134             # With timeout
135 1 50       1 eval { # outer eval
136 1         9 my ($mask, $action, $oldaction);
137 1         2 my $use_sa = $self->{'use_sigaction'};
138 1     1   2 my $h = sub { die "Call timed out\n" }; # N.B. \n required
  1         1000182  
139 1 50       3 local $SIG{ALRM} = $h unless $use_sa; # the handler code ref
140 1 50       2 if ($use_sa) {
141 1         8 $mask = POSIX::SigSet->new(SIGALRM); # list of signals to mask in the handler
142 1         5 $action = POSIX::SigAction->new($h, $mask);
143 1         6 $oldaction = POSIX::SigAction->new();
144 1         44 sigaction(SIGALRM, $action, $oldaction);
145             }
146 1 50       3 eval { # inner eval
147 1         9 alarm($timeout);
148 1         3 $retval = &$code(@args);
149 0         0 alarm(0);
150 0         0 1;
151             } or $failed = 1;
152 1         9 alarm(0); # cancel alarm (if code ran fast)
153 1 50       40 sigaction(SIGALRM, $oldaction) if $use_sa; # restore original signal handler
154 1 50 33     40 die $@ if $failed && $@; # call died
155 0         0 1;
156             } or $failed = 1;
157 1 50       4 if ($failed) {
158 1 50       8 $self->{error} = $@ if $@;
159             }
160 1         7 return $retval;
161             }
162             sub error {
163 4     4 1 279 my $self = shift;
164 4   50     18 return $self->{error} // "";
165             }
166              
167             1;