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