Initial Commit
This commit is contained in:
Riley Schneider
230
database/perl/vendor/lib/IO/SessionData.pm
vendored
Normal file
230
database/perl/vendor/lib/IO/SessionData.pm
vendored
Normal file
@@ -0,0 +1,230 @@
|
||||
# ======================================================================
|
||||
#
|
||||
# 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.03;
|
||||
|
||||
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 {
|
||||
POSIX->can($_) && 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;
|
||||
Reference in New Issue
Block a user