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
149
150
151
152
153
154
155
156
|
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl 1.t'
#########################
# change 'tests => 1' to 'tests => last_test_to_print';
use Test::More;
my $do_subsec = 0;
#BEGIN {
# use_ok('Sys::SigAction');
# if ( Sys::SigAction::have_hires() )
# {
# eval "use Time::HiRes qw( time );";
# }
#}
#########################
# Insert your test code below, the Test::More module is use()ed here so read
# its man page ( perldoc Test::More ) for help writing this test script.
use strict;
#use warnings;
use Carp qw( carp cluck croak confess );
use Data::Dumper;
use Sys::SigAction::Alarm;
use Sys::SigAction qw( set_sig_handler timeout_call );
use POSIX qw( INT_MAX pause :signal_h );
use Config;
### identify platforms I don't think can be supported per the smoke testers
#my $broken_hires_platforms = {
# 'archname' => {
##poss 'amd64-midnightbsd-thread-multi' => 1
##testing ,'i486-linux-gnu-thread-multi-64int' => 1
# }
# ,'perlver' => {
##poss 'v5.16.2' => 1
##testing ,'v5.14.2' => 1
# }
#};
#
#
#my $broken_hires = (
# exists ( $broken_hires_platforms->{archname}->{$Config{archname}} )
# && exists ( $broken_hires_platforms->{perlver}->{$^V} )
# );
#$broken_hires = 1; #force broken path
if ( Sys::SigAction::Alarm::hires_works() ) {
$do_subsec = 1;
eval "use Time::HiRes;";
plan tests => 19;
} else {
plan tests => 14;
}
my $num_args_seen;
my $sum_args_seen;
sub hash { die { hash=>1 }; }
sub sleep_one { sleep 1; die "sleep_one"; }
sub immediate { die "immediate"; }
sub forever { pause; }
sub forever_w_args {
$num_args_seen = @_;
$sum_args_seen += $_ for @_;
forever();
}
my $ret = 0;
eval {
$ret = timeout_call( 1, \&hash );
};
ok( (ref( $@ ) and exists($@->{'hash'})) ,'die with hash' );
ok( $ret == 0 ,'hash did not timeout' );
$ret = 0;
eval {
$ret = timeout_call( 1, \&immediate );
};
ok( (not ref($@) and $@ ),'immediate -- die with string' );
ok( $ret == 0 ,'immediate did not timeout' );
$ret = 0;
eval {
$ret = Sys::SigAction::timeout_call( 1, \&forever );
#print "forever timed out\n" if $ret;
};
if ( $@ )
{
print "why did forever throw exception:" .Dumper( $@ );
}
ok( (not $@ ) ,'forever did NOT die' );
ok( $ret ,'forever timed out' );
foreach my $args ([1], [2, 3]) {
$ret = 0;
my $num_args_ok = @$args;
my $sum_args_ok = 0;
$sum_args_ok += $_ for @$args;
$num_args_seen = $sum_args_seen = 0;
eval {
$ret = Sys::SigAction::timeout_call( 1, \&forever_w_args, @$args );
};
local $" = ', ';
ok( (not $@ ) ,"forever_w_args(@$args) did NOT die" );
ok( $ret ,"forever_w_args(@$args) timed out" );
ok( $num_args_seen == $num_args_ok,"forever_w_args(@$args) got $num_args_seen args" );
ok( $sum_args_seen == $sum_args_ok,"forever_w_args(@$args) args sum is $sum_args_seen" );
}
if ( not Sys::SigAction::Alarm::hires_works() )
{
diag "\nTime::HiRes is not installed or Time::HiRes::ualarm() is broken\nFractional second timeout tests skipped\n" ;
}
else
{
#diag( "\nFractional second tests:\n" );
#5 more tests...
$ret = 0;
my $btime;
my $etime;
eval {
$btime = Time::HiRes::time();
$ret = Sys::SigAction::timeout_call( 0.1, \&forever );
};
if ( $@ )
{
print "hires: why did forever throw exception:" .Dumper( $@ );
}
$etime = Time::HiRes::time();
ok( (not $@ ) ,'hires: forever did NOT die' );
ok( $ret ,'hires: forever timed out' );
my $delta = $etime - $btime;
diag( "delta time was ".sprintf( "%.6f" ,$delta ).", timer was for 0.1 secconds" );
ok( ($delta < 0.8 ), "timeout in < 0.8 seconds" );
#diag( "Testing HiRes where msecs is greater than maxint (" .POSIX::INT_MAX().")" );
my $toobig = INT_MAX();
$toobig = ($toobig/1_000_000.0) + 1.1;
$ret = 0;
eval {
$ret = timeout_call( $toobig, \&sleep_one );
};
ok( (not ref($@) and $@ ),"immediate -- die with string (toobig=$toobig)" );
ok( $ret == 0 ,"immediate did not timeout (with toobig=$toobig)" );
}
exit;
|
