#
# tied filehandle class for interprocess communication file and socket
# handles. This class is mainly for facilitating testing and debugging.
# We ought to be able to drop in and drop out this class without
# changing the behavior of any application using Forks::Super.
#
# usage:
# $fh = gensym();
# create real socket handle (socketpair, accept, etc.)
# tie *$fh, 'Forks::Super::Tie::IPCSocketHandle',
# *$the_real_socket_handle, $fh;
# as of Forks::Super v0.35 this package is still being
# improved and evaluated, and is not being referenced by
# any other part of this module
package Forks::Super::Tie::IPCSocketHandle;
use Forks::Super::Tie::IPCFileHandle;
use Forks::Super::Debug;
use Exporter;
use strict;
use warnings;
use Carp;
use IO::Socket;
use IO::Handle;
our @ISA = qw(IO::Socket IO::Handle);
our $VERSION = '0.66';
# XXX Windows hack. To get smoothly running sockets on Windows it
# seems we have to do a slight pause after each write op.
# v0.55: try to remove ...
#sub trivial_pause { return $^O eq 'MSWin32'
# && 0
# && Forks::Super::Util::pause(0.001) };
sub TIEHANDLE {
my ($class, $real_socket, $glob) = @_;
$$glob->{DELEGATE} = $real_socket;
eval {
bless $glob, 'Forks::Super::Tie::IPCSocketHandle::Delegator';
} or carp 'Forks::Super::Tie::IPCSocketHandle: ',
"failed to bless tied obj as Delegator\n";
# any attributes that the real socket had should be passed
# on to the glob.
foreach (keys %$$real_socket) {
$$glob->{$_} = $$real_socket->{$_};
}
# apply PerlIO layers to the socket here ...
my $job = $$glob->{job} || Forks::Super::Job->this;
if (defined($job) && $job->{debug}) {
Forks::Super::Debug::debug("io layers are @{$job->{fh_config}{layers}}");
}
if (defined($job) && $job->{fh_config}{layers}) {
my @io_layers = @{$job->{fh_config}{layers}};
if ($$real_socket->{is_read}) {
@io_layers = reverse @io_layers;
}
foreach my $layer (@io_layers) {
for my $redo (1..2) {
local $! = 0;
if (binmode $real_socket, $layer) {
if ($job->{debug}) {
Forks::Super::Debug::debug("applied PerlIO layer $layer",
" to socket $real_socket");
}
last;
} elsif ($redo==1) {
carp 'Forks::Super::Tie::IPCSocketHandle: ',
"failed to apply PerlIO layer $layer to $real_socket: $!";
}
Forks::Super::pause(0.01);
}
}
}
my $self = { SOCKET => $real_socket, GLOB => $glob };
$self->{_FILENO} = CORE::fileno($real_socket);
$self->{_SHUTDOWN} = $$real_socket->{_SHUTDOWN} || 0;
bless $self, $class;
return $self;
}
#############################################################################
sub OPEN {
Carp::confess "Can't call 'open' on a socket handle\n";
}
sub BINMODE {
my ($self, $layer) = @_;
$self->{BINMODE}++;
return binmode $self->{SOCKET}, $layer || ':raw';
}
sub GETC {
my $self = shift;
$self->{GETC}++;
# XXX - handle undef/$! ?
return getc($self->{SOCKET});
}
sub FILENO {
my $self = shift;
$self->{FILENO}++;
return $self->{_FILENO};
}
sub PRINT {
my ($self, @list) = @_;
$self->{PRINT}++;
my $bytes = join(defined $, ? $, : '', @list)
. (defined $\ ? $\ : '');
my $z = print {$self->{SOCKET}} @list;
# if ($^O eq 'MSWin32') {
# trivial_pause();
# }
return $z;
}
sub PRINTF {
my ($self, $template, @list) = @_;
$self->{PRINTF}++;
return $self->PRINT(sprintf $template, @list);
}
sub WRITE {
my ($self, $string, $length, $offset) = @_;
$self->{WRITE}++;
$length ||= length $string;
$offset ||= 0;
my $n = syswrite $self->{SOCKET}, $string, $length, $offset;
# $self->{SOCKET}->flush();
# trivial_pause();
return $n;
}
sub READLINE {
# TODO - call F::S::J::Ipc::_read_socket for appropriate job, sockhandle
my $self = shift;
$self->{READLINE}++;
my $glob = $self->{GLOB};
if ($$glob->{job} || ref($$glob->{job})) {
return Forks::Super::Job::Ipc::_read_socket(
$self->{SOCKET}, $$glob->{job}, wantarray);
}
return readline($self->{SOCKET});
}
sub TELL {
my $self = shift;
$self->{TELL}++;
return tell $self->{SOCKET};
}
sub EOF {
my $self = shift;
return eof $self->{SOCKET};
}
sub READ {
my ($self, undef, $length, $offset) = @_;
$self->{READ}++;
return read $self->{SOCKET}, $_[1], $length, $offset || 0;
}
sub SEEK {
my ($self, $position, $whence) = @_;
$self->{SEEK}++;
return seek $self->{SOCKET}, $position, $whence;
}
sub is_pipe {
return 0;
}
sub opened {
my $self = shift;
return $self->{SOCKET}->opened;
}
sub shutdown {
my ($self, $how) = @_;
my $glob = $self->{GLOB};
while (defined $$glob->{std_delegate}) {
$self = tied *{$glob->{std_delegate}};
$glob = $self->{GLOB};
}
$self->{_SHUTDOWN} ||= 0;
if (($self->{_SHUTDOWN} & (1 + $how)) == 1 + $how) {
return 1; # already shutdown
}
if (!defined $self->{SOCKET}) {
return 1;
}
my $result = shutdown($self->{SOCKET}, $how);
if ($result) {
$self->{_SHUTDOWN} |= 1 + $how;
if ($self->{_SHUTDOWN} == 3) {
# should close
}
}
return $result;
}
sub CLOSE {
my $self = shift;
if (&Forks::Super::Job::_INSIDE_END_QUEUE) {
untie *{$self->{GLOB}};
if ($self->{SOCKET}) {
CORE::shutdown $self->{SOCKET}, 2;
close $self->{SOCKET};
}
close *{$self->{GLOB}};
}
$self->{CLOSE}++;
$self->{_SHUTDOWN} ||= 0;
my $glob = $self->{GLOB};
my $how = $$glob->{is_read} || 0;
$how += 2*($$glob->{is_write} || 0);
$how = ($how+2) % 3;
delete $self->{SOCKET};
${$self->{GLOB}}->{closed}++;
return $self->shutdown($how);
}
sub UNTIE {
}
sub DESTROY {
my $self = shift;
$self = {};
return;
}
#
# when you call a method on a glob that is tied to a
# Forks::Super::Tie::IPCSocketHandle , the method should be invoked
# on the tied object's real underlying socket handle
#
sub Forks::Super::Tie::IPCSocketHandle::Delegator::AUTOLOAD {
return if &Forks::Super::Job::_INSIDE_END_QUEUE;
my $method = $Forks::Super::Tie::IPCSocketHandle::Delegator::AUTOLOAD;
$method =~ s/.*:://;
my $delegator = shift;
return if !$delegator;
my $delegate = $$delegator->{DELEGATE};
return if !$delegate;
## no critic (StringyEval)
if (wantarray) {
my @r = eval "\$delegate->$method(\@_)" or do {};
if ($@) {
Carp::cluck "IPCSocketHandle delegate fail: $method @_; error=$@\n";
}
return @r;
} else {
my $r = eval "\$delegate->$method(\@_)";
if ($@) {
Carp::cluck "IPCSocketHandle delegate fail: $method @_; error=$@\n";
}
return $r;
}
}
sub Forks::Super::Tie::IPCSockethandle::Delegator::DESTROY {
}
1;