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