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