File Coverage

blib/lib/IO/Framed/Write.pm
Criterion Covered Total %
statement 52 64 81.2
branch 13 16 81.2
condition 4 8 50.0
subroutine 14 16 87.5
pod 0 8 0.0
total 83 112 74.1


line stmt bran cond sub pod time code
1             package IO::Framed::Write;
2              
3 5     5   105986 use strict;
  5         23  
  5         147  
4 5     5   27 use warnings;
  5         9  
  5         133  
5              
6 5     5   819 use IO::Framed::X ();
  5         11  
  5         3720  
7              
8             sub new {
9 4     4 0 3168 my ( $class, $out_fh ) = @_;
10              
11 4         16 my $self = {
12             _out_fh => $out_fh,
13             _writer => \&_write_now,
14             };
15              
16 4         15 return bless $self, $class;
17             }
18              
19 0     0 0 0 sub get_write_fh { return $_[0]->{'_out_fh'} }
20              
21             sub disable_write_queue {
22 3 50 33 3 0 13 if ( $_[0]->{'_write_queue'} && @{ $_[0]->{'_write_queue'} } ) {
  0         0  
23 0         0 die 'Refuse to disable non-empty write queue!';
24             }
25              
26 3         7 $_[0]->{'_writer'} = \&_write_now;
27 3         12 return $_[0];
28             }
29              
30             sub enable_write_queue {
31 2   50 2 0 19 $_[0]->{'_write_queue'} ||= [];
32 2         4 $_[0]->{'_writer'} = \&_enqueue_write;
33 2         22 return $_[0];
34             }
35              
36             sub write {
37 65552 100   65552 0 126507 die IO::Framed::X->create('EmptyWrite', "Undefined input to write()!") if !defined $_[1];
38 65546 100       100878 die IO::Framed::X->create('EmptyWrite', "Empty input to write()!" ) if !length $_[1];
39              
40 65542         114193 $_[0]->{'_writer'}->(@_);
41             }
42              
43             #======================================================================
44             #blocking
45             #======================================================================
46              
47             sub _write_now {
48 65539     65539   203379 local $!;
49              
50 65539 100       176774 $_[0]->can('WRITE')->( $_[0]->{'_out_fh'}, $_[1] ) or do {
51 1         45 die IO::Framed::X->create('WriteError', $!);
52             };
53              
54 65538 50       801283 $_[2]->() if $_[2];
55              
56 65538         222588 return;
57             }
58              
59             #======================================================================
60             #non-blocking
61             #======================================================================
62              
63             sub _enqueue_write {
64 3     3   6 my $self = shift;
65              
66 3         5 push @{ $self->{'_write_queue'} }, \@_;
  3         10  
67              
68 3         8 return;
69             }
70              
71             #----------------------------------------------------------------------
72              
73             sub flush_write_queue {
74 4098     4098 0 214325 my ($self) = @_;
75              
76 4098         11704 while ( my $qi = $self->{'_write_queue'}[0] ) {
77 4098 100       7891 return 0 if !$self->_write_now_then_callback( @$qi );
78              
79 3         6 shift @{ $self->{'_write_queue'} };
  3         19  
80             }
81              
82 3         9 return 1;
83             }
84              
85             sub get_write_queue_count {
86 5     5 0 771 my ($self) = @_;
87              
88 5         11 return 0 + @{ $self->{'_write_queue'} };
  5         33  
89             }
90              
91             sub forget_write_queue {
92 0     0 0 0 my ($self) = @_;
93              
94 0         0 my $count = @{ $self->{'_write_queue'} };
  0         0  
95              
96 0         0 @{ $self->{'_write_queue'} } = ();
  0         0  
97              
98 0         0 return $count;
99             }
100              
101             sub WRITE {
102 2     2   923 require IO::SigGuard;
103 2         497 IO::SigGuard->import('syswrite'); # Needed for IO::SigGuard 0.13+
104 2         1071 *WRITE = *IO::SigGuard::syswrite;
105 2         10 goto &WRITE;
106             }
107              
108             #----------------------------------------------------------------------
109              
110             sub _write_now_then_callback {
111 4098     4098   11903 local $!;
112              
113 4098   66     14351 my $wrote = $_[0]->can('WRITE')->( $_[0]->{'_out_fh'}, $_[1] ) || do {
114 2     2   992 if ($! && !$!{'EAGAIN'} && !$!{'EWOULDBLOCK'}) {
  2         2732  
  2         18  
115             die IO::Framed::X->create('WriteError', $!);
116             }
117              
118             return undef;
119             };
120              
121 3 50       1095 if ($wrote == length $_[1]) {
122 3         10 $_[0]->{'_write_queue_partial'} = 0;
123 3 100       19 $_[2]->() if $_[2];
124 3         18 return 1;
125             }
126              
127             #Trim the bytes that we did send.
128 0         0 substr( $_[1], 0, $wrote ) = q<>;
129              
130             #This seems useful to track … ??
131 0         0 $_[0]->{'_write_queue_partial'} = 1;
132              
133 0         0 return 0;
134             }
135              
136             1;