root/trunk/extlib/IO/SessionData.pm @ 3531

# ======================================================================
#
# Copyright (C) 2000 Lincoln D. Stein
# Slightly modified by Paul Kulchenko to work on multiple platforms
# Formatting changed to match the layout layed out in Perl Best Practices
# (by Damian Conway) by Martin Kutter in 2008
#
# ======================================================================

package IO::SessionData;

use strict;
use Carp;
use IO::SessionSet;
use vars '$VERSION';
$VERSION = 1.02;

use constant BUFSIZE => 3000;

BEGIN {
    my @names = qw(EWOULDBLOCK EAGAIN EINPROGRESS);
    my %WOULDBLOCK =
        (eval {require Errno}
            ? map {
                Errno->can($_)
                    ? (Errno->can($_)->() => 1)
                    : (),
                } @names
            : ()
        ),
        (eval {require POSIX}
            ? map {
                eval { POSIX->can($_)->() }
                    ? (POSIX->can($_)->() => 1)
                    : ()
                } @names
            : ()
        );

    sub WOULDBLOCK { $WOULDBLOCK{$_[0]+0} }
}

# Class method: new()
# Create a new IO::SessionData object.  Intended to be called from within
# IO::SessionSet, not directly.
sub new {
    my $pack = shift;
    my ($sset,$handle,$writeonly) = @_;
    # make the handle nonblocking (but check for 'blocking' method first)
    # thanks to Jos Clijmans <jos.clijmans@recyfin.be>
    $handle->blocking(0) if $handle->can('blocking');
    my $self = bless {
        outbuffer   => '',
        sset        => $sset,
        handle      => $handle,
        write_limit => BUFSIZE,
        writeonly   => $writeonly,
        choker      => undef,
        choked      => 0,
    },$pack;
    $self->readable(1) unless $writeonly;
    return $self;
}

# Object method: handle()
# Return the IO::Handle object corresponding to this IO::SessionData
sub handle {
    return shift->{handle};
}

# Object method: sessions()
# Return the IO::SessionSet controlling this object.
sub sessions {
    return shift->{sset};
}

# Object method: pending()
# returns number of bytes pending in the out buffer
sub pending {
    return length shift->{outbuffer};
}

# Object method: write_limit([$bufsize])
# Get or set the limit on the size of the write buffer.
# Write buffer will grow to this size plus whatever extra you write to it.
sub write_limit {
    my $self = shift;
    return defined $_[0]
        ? $self->{write_limit} = $_[0]
        : $self->{write_limit};
}

# set a callback to be called when the contents of the write buffer becomes larger
# than the set limit.
sub set_choke {
    my $self = shift;
    return defined $_[0]
        ? $self->{choker} = $_[0]
        : $self->{choker};
}

# Object method: write($scalar)
# $obj->write([$data]) -- append data to buffer and try to write to handle
# Returns number of bytes written, or 0E0 (zero but true) if data queued but not
# written. On other errors, returns undef.
sub write {
    my $self = shift;
    return unless my $handle = $self->handle; # no handle
    return unless defined $self->{outbuffer}; # no buffer for queued data

    $self->{outbuffer} .= $_[0] if defined $_[0];

    my $rc;
    if ($self->pending) { # data in the out buffer to write
        local $SIG{PIPE}='IGNORE';
        # added length() to make it work on Mac. Thanks to Robin Fuller <rfuller@broadjump.com>
        $rc = syswrite($handle,$self->{outbuffer},length($self->{outbuffer}));

        # able to write, so truncate out buffer apropriately
        if ($rc) {
            substr($self->{outbuffer},0,$rc) = '';
        }
        elsif (WOULDBLOCK($!)) {  # this is OK
            $rc = '0E0';
        }
        else { # some sort of write error, such as a PIPE error
            return $self->bail_out($!);
        }
    }
    else {
        $rc = '0E0';   # nothing to do, but no error either
    }

    $self->adjust_state;

    # Result code is the number of bytes successfully transmitted
    return $rc;
}

# Object method: read($scalar,$length [,$offset])
# Just like sysread(), but returns the number of bytes read on success,
# 0EO ("0 but true") if the read would block, and undef on EOF and other failures.
sub read {
    my $self = shift;
    return unless my $handle = $self->handle;
    my $rc = sysread($handle,$_[0],$_[1],$_[2]||0);
    return $rc if defined $rc;
    return '0E0' if WOULDBLOCK($!);
    return;
}

# Object method: close()
# Close the session and remove it from the monitored list.
sub close {
    my $self = shift;
    unless ($self->pending) {
        $self->sessions->delete($self);
        CORE::close($self->handle);
    }
    else {
        $self->readable(0);
        $self->{closing}++;  # delayed close
    }
}

# Object method: adjust_state()
# Called periodically from within write() to control the
# status of the handle on the IO::SessionSet's IO::Select sets
sub adjust_state {
    my $self = shift;

    # make writable if there's anything in the out buffer
    $self->writable($self->pending > 0);

    # make readable if there's no write limit, or the amount in the out
    # buffer is less than the write limit.
    $self->choke($self->write_limit <= $self->pending) if $self->write_limit;

    # Try to close down the session if it is flagged
    # as in the closing state.
    $self->close if $self->{closing};
}

# choke gets called when the contents of the write buffer are larger
# than the limit.  The default action is to inactivate the session for further
# reading until the situation is cleared.
sub choke {
    my $self = shift;
    my $do_choke = shift;
    return if $self->{choked} == $do_choke;  # no change in state
    if (ref $self->set_choke eq 'CODE') {
        $self->set_choke->($self,$do_choke);
    }
    else {
        $self->readable(!$do_choke);
    }
    $self->{choked} = $do_choke;
}

# Object method: readable($flag)
# Flag the associated IO::SessionSet that we want to do reading on the handle.
sub readable {
    my $self = shift;
    my $is_active = shift;
    return if $self->{writeonly};
    $self->sessions->activate($self,'read',$is_active);
}

# Object method: writable($flag)
# Flag the associated IO::SessionSet that we want to do writing on the handle.
sub writable {
    my $self = shift;
    my $is_active = shift;
    $self->sessions->activate($self,'write',$is_active);
}

# Object method: bail_out([$errcode])
# Called when an error is encountered during writing (such as a PIPE).
# Default behavior is to flush all buffered outgoing data and to close
# the handle.
sub bail_out {
    my $self = shift;
    my $errcode = shift;           # save errorno
    delete $self->{outbuffer};     # drop buffered data
    $self->close;
    $! = $errcode;                 # restore errno
    return;
}

1;