File Coverage

blib/lib/IO/Framed/Write.pm
Criterion Covered Total %
statement 51 63 80.9
branch 13 16 81.2
condition 4 8 50.0
subroutine 14 16 87.5
pod 0 8 0.0
total 82 111 73.8


line stmt bran cond sub pod time code
1             package IO::Framed::Write;
2              
3 5     5   102902 use strict;
  5         24  
  5         167  
4 5     5   30 use warnings;
  5         10  
  5         125  
5              
6 5     5   853 use IO::Framed::X ();
  5         12  
  5         3562  
7              
8             sub new {
9 4     4 0 3232 my ( $class, $out_fh ) = @_;
10              
11 4         17 my $self = {
12             _out_fh => $out_fh,
13             _writer => \&_write_now,
14             };
15              
16 4         16 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         9 $_[0]->{'_writer'} = \&_write_now;
27 3         13 return $_[0];
28             }
29              
30             sub enable_write_queue {
31 2   50 2 0 20 $_[0]->{'_write_queue'} ||= [];
32 2         5 $_[0]->{'_writer'} = \&_enqueue_write;
33 2         5 return $_[0];
34             }
35              
36             sub write {
37 65552 100   65552 0 127476 die IO::Framed::X->create('EmptyWrite', "Undefined input to write()!") if !defined $_[1];
38 65546 100       104404 die IO::Framed::X->create('EmptyWrite', "Empty input to write()!" ) if !length $_[1];
39              
40 65542         115569 $_[0]->{'_writer'}->(@_);
41             }
42              
43             #======================================================================
44             #blocking
45             #======================================================================
46              
47             sub _write_now {
48 65539     65539   204100 local $!;
49              
50 65539 100       191981 $_[0]->can('WRITE')->( $_[0]->{'_out_fh'}, $_[1] ) or do {
51 1         59 die IO::Framed::X->create('WriteError', $!);
52             };
53              
54 65538 50       813964 $_[2]->() if $_[2];
55              
56 65538         235698 return;
57             }
58              
59             #======================================================================
60             #non-blocking
61             #======================================================================
62              
63             sub _enqueue_write {
64 3     3   8 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 220005 my ($self) = @_;
75              
76 4098         11603 while ( my $qi = $self->{'_write_queue'}[0] ) {
77 4098 100       8116 return 0 if !$self->_write_now_then_callback( @$qi );
78              
79 3         5 shift @{ $self->{'_write_queue'} };
  3         27  
80             }
81              
82 3         11 return 1;
83             }
84              
85             sub get_write_queue_count {
86 5     5 0 977 my ($self) = @_;
87              
88 5         13 return 0 + @{ $self->{'_write_queue'} };
  5         23  
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   940 require IO::SigGuard;
103 2         1199 *WRITE = *IO::SigGuard::syswrite;
104 2         10 goto &WRITE;
105             }
106              
107             #----------------------------------------------------------------------
108              
109             sub _write_now_then_callback {
110 4098     4098   13291 local $!;
111              
112 4098   66     15233 my $wrote = $_[0]->can('WRITE')->( $_[0]->{'_out_fh'}, $_[1] ) || do {
113 2     2   922 if ($! && !$!{'EAGAIN'} && !$!{'EWOULDBLOCK'}) {
  2         2785  
  2         19  
114             die IO::Framed::X->create('WriteError', $!);
115             }
116              
117             return undef;
118             };
119              
120 3 50       1130 if ($wrote == length $_[1]) {
121 3         10 $_[0]->{'_write_queue_partial'} = 0;
122 3 100       19 $_[2]->() if $_[2];
123 3         20 return 1;
124             }
125              
126             #Trim the bytes that we did send.
127 0         0 substr( $_[1], 0, $wrote ) = q<>;
128              
129             #This seems useful to track … ??
130 0         0 $_[0]->{'_write_queue_partial'} = 1;
131              
132 0         0 return 0;
133             }
134              
135             1;