File Coverage

blib/lib/MojoX/UserAgent/Throttler.pm
Criterion Covered Total %
statement 49 50 98.0
branch 12 16 75.0
condition 7 11 63.6
subroutine 9 9 100.0
pod n/a
total 77 86 89.5


line stmt bran cond sub pod time code
1             package MojoX::UserAgent::Throttler;
2              
3 3     3   599125 use Mojo::Base -strict;
  3         7025  
  3         21  
4              
5             our $VERSION = 'v1.0.2';
6              
7 3     3   869 use Mojo::UserAgent;
  3         211020  
  3         25  
8 3     3   94 use Mojo::Util qw( monkey_patch );
  3         8  
  3         150  
9 3     3   14 use Sub::Util 1.40 qw( set_subname );
  3         74  
  3         179  
10 3     3   969 use Sub::Throttler 0.002000 qw( throttle_me throttle_me_sync done_cb );
  3         20160  
  3         17  
11              
12              
13             # https://github.com/kraih/mojo/issues/663
14             # Inconsistent behavior of Mojo::UserAgent::DESTROY:
15             # - sync requests always executed, even when started while DESTROY
16             # - for all active async requests which was started before DESTROY user's
17             # callback will be called with error in $tx
18             # - for all async requests which was started while DESTROY user's callback
19             # won't be called
20             # To emulate this behaviour with throttling:
21             # - sync request: always executed, even when started while DESTROY
22             # - new async request while DESTROY: ignored
23             # - delayed async request (it was delayed before DESTROY):
24             # * if it start before DESTROY: let Mojo::UserAgent handle it using
25             # done_cb($done,$cb)
26             # * if it start while DESTROY: do $done->(0) and call user's callback
27             # with error in $tx
28             # * if it still delayed after DESTROY: call user's callback with error
29             # in $tx
30              
31 3     3   3113 use constant START_ARGS => 3;
  3         3  
  3         1432  
32              
33             my %Delayed; # $ua => { $tx => [$tx, $cb], … }
34             my %IsDestroying; # $ua => 1
35              
36             my $ORIG_start = \&Mojo::UserAgent::start;
37             my $ORIG_DESTROY= \&Mojo::UserAgent::DESTROY;
38              
39             monkey_patch 'Mojo::UserAgent',
40             start => set_subname('Mojo::UserAgent::start', sub {
41             # WARNING Async call return undef instead of (undocumented) connection $id.
42             ## no critic (ProhibitExplicitReturnUndef)
43 12     12   5749 my ($self, $tx, $cb) = @_;
44 12 100 100     54 if (START_ARGS == @_ && $cb) {
45 6 100       16 if ($IsDestroying{ $self }) {
46             # $cb->($self, $tx->client_close(1)); # to fix issue 663 or not to fix?
47 1         12 return undef;
48             }
49             else {
50 5         18 $Delayed{ $self }{ $tx } = [ $tx, $cb ];
51             }
52             }
53 11 100 100     36 my $done = ref $_[-1] eq 'CODE' ? &throttle_me || return undef : &throttle_me_sync;
54 6         149 ($self, $tx, $cb) = @_;
55 6 100       13 if ($cb) {
56 5 100       9 if ($IsDestroying{ $self }) {
57 1         3 $done->(0);
58             }
59             else {
60 4         10 delete $Delayed{ $self }{ $tx };
61 4         14 $self->$ORIG_start($tx, done_cb($done, $cb));
62             }
63 5         1954 return undef;
64             }
65             else {
66 1         3 $tx = $self->$ORIG_start($tx);
67 1         7990 $done->();
68 1         41 return $tx;
69             }
70             }),
71             DESTROY => sub {
72 4     4   187 my ($self) = @_;
73 4         7 $IsDestroying{ $self } = 1;
74 4 50       6 for (values %{ delete $Delayed{ $self } || {} }) {
  4         19  
75 1         2 my ($tx, $cb) = @{ $_ };
  1         3  
76 1         3 $cb->($self, _client_close($tx, 1));
77             }
78 4         34 $self->$ORIG_DESTROY;
79 4         696 delete $IsDestroying{ $self };
80 4         43 return;
81             };
82              
83             # This is a replacement of $tx->client_close() removed in Mojolicious 6.43.
84             sub _client_close {
85             ## no critic(ProhibitAmbiguousNames,ProhibitMagicNumbers)
86 1     1   2 my ($self, $close) = @_;
87              
88 1         9 my $res = $self->completed->emit('finish')->res->finish;
89 1 50 33     49 if ($close && !$res->code && !$res->error) {
    0 33        
90 1         18 $res->error({message => 'Premature connection close'});
91             }
92             elsif ($res->is_error) {
93 0         0 $res->error({message => $res->message, code => $res->code});
94             }
95              
96 1         9 return $self;
97             }
98              
99              
100             1; # Magic true value required at end of module
101             __END__