1# ====================================================================== 2# 3# Copyright (C) 2000 Lincoln D. Stein 4# Slightly modified by Paul Kulchenko to work on multiple platforms 5# Formatting changed to match the layout layed out in Perl Best Practices 6# (by Damian Conway) by Martin Kutter in 2008 7# 8# ====================================================================== 9 10package IO::SessionData; 11 12use strict; 13use Carp; 14use IO::SessionSet; 15use vars '$VERSION'; 16$VERSION = 1.02; 17 18use constant BUFSIZE => 3000; 19 20BEGIN { 21 my @names = qw(EWOULDBLOCK EAGAIN EINPROGRESS); 22 my %WOULDBLOCK = 23 (eval {require Errno} ? map {Errno->can($_)->() => 1} grep {Errno->can($_)} @names : ()), 24 (eval {require POSIX} ? map {POSIX->can($_)->() => 1} grep {POSIX->can($_)} @names : ()); 25 26 sub WOULDBLOCK { $WOULDBLOCK{$_[0]+0} } 27} 28 29# Class method: new() 30# Create a new IO::SessionData object. Intended to be called from within 31# IO::SessionSet, not directly. 32sub new { 33 my $pack = shift; 34 my ($sset,$handle,$writeonly) = @_; 35 # make the handle nonblocking (but check for 'blocking' method first) 36 # thanks to Jos Clijmans <jos.clijmans@recyfin.be> 37 $handle->blocking(0) if $handle->can('blocking'); 38 my $self = bless { 39 outbuffer => '', 40 sset => $sset, 41 handle => $handle, 42 write_limit => BUFSIZE, 43 writeonly => $writeonly, 44 choker => undef, 45 choked => 0, 46 },$pack; 47 $self->readable(1) unless $writeonly; 48 return $self; 49} 50 51# Object method: handle() 52# Return the IO::Handle object corresponding to this IO::SessionData 53sub handle { 54 return shift->{handle}; 55} 56 57# Object method: sessions() 58# Return the IO::SessionSet controlling this object. 59sub sessions { 60 return shift->{sset}; 61} 62 63# Object method: pending() 64# returns number of bytes pending in the out buffer 65sub pending { 66 return length shift->{outbuffer}; 67} 68 69# Object method: write_limit([$bufsize]) 70# Get or set the limit on the size of the write buffer. 71# Write buffer will grow to this size plus whatever extra you write to it. 72sub write_limit { 73 my $self = shift; 74 return defined $_[0] 75 ? $self->{write_limit} = $_[0] 76 : $self->{write_limit}; 77} 78 79# set a callback to be called when the contents of the write buffer becomes larger 80# than the set limit. 81sub set_choke { 82 my $self = shift; 83 return defined $_[0] 84 ? $self->{choker} = $_[0] 85 : $self->{choker}; 86} 87 88# Object method: write($scalar) 89# $obj->write([$data]) -- append data to buffer and try to write to handle 90# Returns number of bytes written, or 0E0 (zero but true) if data queued but not 91# written. On other errors, returns undef. 92sub write { 93 my $self = shift; 94 return unless my $handle = $self->handle; # no handle 95 return unless defined $self->{outbuffer}; # no buffer for queued data 96 97 $self->{outbuffer} .= $_[0] if defined $_[0]; 98 99 my $rc; 100 if ($self->pending) { # data in the out buffer to write 101 local $SIG{PIPE}='IGNORE'; 102 # added length() to make it work on Mac. Thanks to Robin Fuller <rfuller@broadjump.com> 103 $rc = syswrite($handle,$self->{outbuffer},length($self->{outbuffer})); 104 105 # able to write, so truncate out buffer apropriately 106 if ($rc) { 107 substr($self->{outbuffer},0,$rc) = ''; 108 } 109 elsif (WOULDBLOCK($!)) { # this is OK 110 $rc = '0E0'; 111 } 112 else { # some sort of write error, such as a PIPE error 113 return $self->bail_out($!); 114 } 115 } 116 else { 117 $rc = '0E0'; # nothing to do, but no error either 118 } 119 120 $self->adjust_state; 121 122 # Result code is the number of bytes successfully transmitted 123 return $rc; 124} 125 126# Object method: read($scalar,$length [,$offset]) 127# Just like sysread(), but returns the number of bytes read on success, 128# 0EO ("0 but true") if the read would block, and undef on EOF and other failures. 129sub read { 130 my $self = shift; 131 return unless my $handle = $self->handle; 132 my $rc = sysread($handle,$_[0],$_[1],$_[2]||0); 133 return $rc if defined $rc; 134 return '0E0' if WOULDBLOCK($!); 135 return; 136} 137 138# Object method: close() 139# Close the session and remove it from the monitored list. 140sub close { 141 my $self = shift; 142 unless ($self->pending) { 143 $self->sessions->delete($self); 144 CORE::close($self->handle); 145 } 146 else { 147 $self->readable(0); 148 $self->{closing}++; # delayed close 149 } 150} 151 152# Object method: adjust_state() 153# Called periodically from within write() to control the 154# status of the handle on the IO::SessionSet's IO::Select sets 155sub adjust_state { 156 my $self = shift; 157 158 # make writable if there's anything in the out buffer 159 $self->writable($self->pending > 0); 160 161 # make readable if there's no write limit, or the amount in the out 162 # buffer is less than the write limit. 163 $self->choke($self->write_limit <= $self->pending) if $self->write_limit; 164 165 # Try to close down the session if it is flagged 166 # as in the closing state. 167 $self->close if $self->{closing}; 168} 169 170# choke gets called when the contents of the write buffer are larger 171# than the limit. The default action is to inactivate the session for further 172# reading until the situation is cleared. 173sub choke { 174 my $self = shift; 175 my $do_choke = shift; 176 return if $self->{choked} == $do_choke; # no change in state 177 if (ref $self->set_choke eq 'CODE') { 178 $self->set_choke->($self,$do_choke); 179 } 180 else { 181 $self->readable(!$do_choke); 182 } 183 $self->{choked} = $do_choke; 184} 185 186# Object method: readable($flag) 187# Flag the associated IO::SessionSet that we want to do reading on the handle. 188sub readable { 189 my $self = shift; 190 my $is_active = shift; 191 return if $self->{writeonly}; 192 $self->sessions->activate($self,'read',$is_active); 193} 194 195# Object method: writable($flag) 196# Flag the associated IO::SessionSet that we want to do writing on the handle. 197sub writable { 198 my $self = shift; 199 my $is_active = shift; 200 $self->sessions->activate($self,'write',$is_active); 201} 202 203# Object method: bail_out([$errcode]) 204# Called when an error is encountered during writing (such as a PIPE). 205# Default behavior is to flush all buffered outgoing data and to close 206# the handle. 207sub bail_out { 208 my $self = shift; 209 my $errcode = shift; # save errorno 210 delete $self->{outbuffer}; # drop buffered data 211 $self->close; 212 $! = $errcode; # restore errno 213 return; 214} 215 2161; 217