saint/discourse-legacysite-perl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
fc289f2258
discourse-legacysite-perl/site/glist/lib/GT/Socket.pm

801 lines
22 KiB
Perl
Raw Normal View History

First pass at adding key files
2024-06-17 11:49:12 +00:00
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::Socket
# Author : Aki Mimoto
# CVS Info :
# $Id: Socket.pm,v 1.43 2004/08/23 20:07:44 jagerman Exp $
#
# Copyright (c) 2000 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description:
# Handles stuff related to INET connections
#
package GT::Socket;
# ===============================================================
use strict;
use GT::Base;
use vars qw/$ATTRIBS $VERSION $ERRORS @ISA $ERRORS $DEBUG $SHUTDOWN/;
use Symbol;
use Socket;
use Config;
@ISA = qw/GT::Base/;
$DEBUG = 0;
$VERSION = sprintf "%d.%03d", q$Revision: 1.43 $ =~ /(\d+)\.(\d+)/;
$ERRORS = {
NO_HOST => 'No host specified',
NO_PORT => 'No port specified',
UNRESOLV => 'IP of Host: %s is unresolveable. System Error: (%s)',
SOCKET => 'Socket error: %s',
SOCKOPTS => 'Error setting socket options: %s',
BIND => 'Bind error onto port(%i): %s',
LISTEN => 'Listen call file: ',
UNKNOWN_HOST => 'Host: %s is unknown',
UNKNOWN_PORT => 'Port: %s is unknown',
TIMEOUT => 'Host %s connect timed out',
CONNECT => 'Cant connect to host: %s (%s)',
MAX_DOWN => 'Maximum number of bytes (%i) received',
MAX_UP => 'Maximum number of bytes (%i) sent'
};
$ATTRIBS = {
host => undef,
port => 23,
sock => undef,
max_down => 0,
max_up => 0,
received => 0,
sent => 0,
server => 0,
timeout => 40
};
sub DESTROY {
#-------------------------------------------------------------------------------
# Make sure we close the connection.
#
$_[0]->close if $_[0]->{sock};
}
sub init {
#-------------------------------------------------------------------------------
# Called on new() from GT::Base.
#
my $self = shift;
$self->close() if $self->{sock}; # If there is an existing socket, close it
$self->_set_options(@_) if @_;
# If host and port were provided, open the new socket
$self->_open() if $self->{host} and $self->{port} and not $self->{sock};
return $self;
}
sub open {
#-------------------------------------------------------------------------------
# Open a new connection to the host. Returns undef if the connection failed, or
# the GT::Socket object if the connection was established.
#
my $self = shift;
# Create a new GT::Socket object if called as a class method
$self = UNIVERSAL::isa($self, __PACKAGE__) ? $self->new() : __PACKAGE__->new()
unless ref $self and UNIVERSAL::isa($self, __PACKAGE__);
$self->close() if $self->{sock}; # if there is an existing socket, close it
$self->_set_options(@_) if @_;
$self->_open() or return; # open the new socket
return $self;
}
sub server {
#-------------------------------------------------------------------------------
# Create a server socket.
#
my $self = shift;
# Create a new GT::Socket object if called as a class method
$self = UNIVERSAL::isa($self, __PACKAGE__) ? $self->new() : __PACKAGE__->new()
unless ref $self and UNIVERSAL::isa($self, __PACKAGE__);
$self->close() if $self->{sock}; # If there is an existing socket, close it
$self->{server} = 1;
$self->_set_options(@_) if @_;
$self->_server() or return; # open the new socket
return $self;
}
sub close {
#-------------------------------------------------------------------------------
# closes the socket if it is open
#
close $_[0]->{sock} if $_[0]->{sock};
}
sub _open {
#-------------------------------------------------------------------------------
# this does the real opening of the socket
#
# IN: host to connect to, and port to connect to (names such as "ftp" allowed)
#
my $self = shift;
my $host = $self->{host} or return $self->error(NO_HOST => 'WARN');
my $port = $self->{port} or return $self->error(NO_PORT => 'WARN');
if ($port =~ /\D/) { # Port is a name, such as "ftp". Get the port number.
$port = getservbyname($port, 'tcp');
}
int $port or return $self->error(NO_PORT => 'WARN');
# get the packed ip address
my $iaddr = inet_aton($host) or return $self->error(UNRESOLV => 'WARN', $host, "$!");
my $paddr = sockaddr_in($port, $iaddr);
# connect with timeout
my $fh = gensym();
my $proto = getprotobyname('tcp');
socket($fh, PF_INET, SOCK_STREAM, $proto) or return $self->error(SOCKET => 'WARN', "$!");
if ($Config{d_alarm} and $self->{timeout}) {
{
local $SIG{__DIE__};
eval {
local $SIG{ALRM} = sub { undef $fh };
alarm($self->{timeout});
connect($fh, $paddr) or die 'CONNECT';
};
}
alarm(0);
if (not defined $fh) {
return $self->error(TIMEOUT => 'WARN', $host, "$!");
}
elsif ($@) {
return $self->error(CONNECT => 'WARN', $host, "$!");
}
}
else {
connect($fh, $paddr) or return $self->error(CONNECT => 'WARN', $host, $!);
}
$self->{sock} = $fh;
$self->autoflush();
1;
}
sub _server {
#-------------------------------------------------------------------------------
# creates the required server ports
#
my $self = shift;
my $port = $self->{port} or return $self->error(NO_PORT => 'WARN');
my $host = inet_aton($self->{host}) || INADDR_ANY;
my $fh = gensym();
my $proto = getprotobyname('tcp');
socket($fh, PF_INET, SOCK_STREAM, $proto) or return $self->error(SOCKET => 'WARN', "$!");
setsockopt($fh, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) or return $self->error(SOCKOPTS => 'WARM', "$!");
bind($fh, sockaddr_in($port, $host)) or return $self->error(BIND => 'WARN', $port, "$!");
listen($fh, SOMAXCONN) or return $self->error(LISTEN => 'WARN', "$!");
# get a ref to the connect
$self->{sock} = $fh;
$self->autoflush();
1;
}
sub accept {
#-------------------------------------------------------------------------------
# accepts a server's tcpip connection from a client
#
my $self = shift;
my $sock = $self->{sock};
if ($self->pending() and $self->{server}) {
my $ch = gensym();
accept($ch, $sock);
my $client = new GT::Socket(
max_down => $self->{max_down} || undef,
max_up => $self->{max_up} || undef,
server => $self->{server},
timeout => $self->{timeout},
port => $self->{port},
host => $self->{host},
sock => $ch
);
return $client;
}
return;
}
sub autoflush {
#-------------------------------------------------------------------------------
# turns on auto flushing of socket handles.
#
my $self = shift;
my $status = defined($_[0]) ? $_[0] : 1;
my $sock = $self->{sock};
select((select($sock), $| = $status)[0]) if $sock;
1;
}
sub vec {
#-------------------------------------------------------------------------------
# IN: clean or partially preped $bits for select
# OUT: the $bits
#
my ($self, $bits) = @_;
$bits ||= '';
# setup the filehandle vecs
my $sock = $self->{sock} or return $bits;
CORE::vec($bits, fileno($sock), 1) = 1;
return $bits;
}
sub pending {
#-------------------------------------------------------------------------------
# returns non-zero if data is pending
# IN: <0 : value for blocking
# non zero : wait for N seconds
# 0 : don't wait (nonblocking)
# OUT: non-zero if data is pending
#
my $self = shift;
my $tics = defined $_[0] ? ($_[0] < 0 ? undef : shift) : 0;
# if the sock has closed we have no data pending
return 0 if $self->{closed};
my $bits = $self->vec() or return;
# find out the number of bytes to read
return select($bits, undef, undef, $tics);
}
sub EOF {
#-------------------------------------------------------------------------------
# returns number of bytes to be read if there is input pending
# IN: nothing
# OUT: number of bytes
#
my $self = shift;
# if the sock has closed we have no data pending
return 1 if $self->{closed};
# setup the filehandle vecs
my $sock = $self->{sock} or return;
CORE::vec(my $bits = '', fileno($sock), 1) = 1;
# find out if the socket is closed
return select(undef, undef, my $ebits = $bits, 0);
}
sub read {
#-------------------------------------------------------------------------------
# reads a certain number of bytes from the socket
#
my $self = shift;
my $bytes = int(shift) or return;
my $max = $self->{max_down} || 0;
my $buf;
# find out how many bytes to read
if ($max) {
my $received = $self->{received};
if ($received == $max) {
return $self->error('MAX_DOWN', 'WARN', $self->{received});
}
# Lower the number of bytes requested if that would push us over the max byte limit
elsif (($max - $received) < $bytes) {
if (($bytes = $max - $received) < 0) {
return $self->error('MAX_DOWN', 'WARN', $self->{received});
}
}
}
# Attempt to read the requested amount of data.
# If sysread returns 0, it means that there is no more data to be read
my $b_read = sysread($self->{'sock'}, $buf, $bytes);
unless ($b_read) {
$self->{closed} = 1;
return $buf;
}
# Finish up the read
if ((($self->{received} += $b_read) >= $max) and $max) {
$self->{closed} = 1;
$self->close();
}
return $buf;
}
sub gulpread {
#-------------------------------------------------------------------------------
# reads a certain number of bytes from the socket
#
my $self = shift;
my $tics = shift || 0;
my $max_tics = time + $tics;
my $max = $self->{max_down};
my $sock = $self->{sock};
my $buf;
# if there's data pending
while ($tics
? ($max_tics >= time and not $self->EOF() and $self->pending($max_tics - time))
: ($self->pending() and not $self->EOF())
) {
my $bytes = 4096;
# Find out how many bytes to read
if ($max) {
my $received = $self->{received};
if ($received == $max) {
$self->error('MAX_DOWN', 'WARN', $self->{received});
return $buf;
}
elsif (($max - $received) < $bytes) {
if (($bytes = $max - $received) < 0) {
$self->error('MAX_DOWN', 'WARN', $self->{received});
return $buf;
}
}
}
# Attempt to read the requested amount of data.
# If sysread returns 0, it means that there is no more data to be read
my $tmp;
my $b_read = sysread($sock, $tmp, $bytes);
unless ($b_read) {
$self->{closed} = 1;
return $buf . $tmp;
}
# Finish up the read
if ((($self->{received} += $b_read ) >= $max ) and $max) {
$self->{closed} = 1;
$self->close();
}
$buf .= $tmp;
return $buf;
}
return $buf;
}
sub write {
#-------------------------------------------------------------------------------
# writes a certain number of bytes to the socket
#
my $self = shift;
my $buf = shift;
my $bytes = length( $buf );
my $max = $self->{max_up};
# if we're using limit caps on the number of bytes that the service can send out
# tweak the buf to make sure we can!
if ($max) {
# the current buffer would throw us over the top, fix it
if ((my $len = $max - $self->{'sent'}) < $bytes) {
# check the vector
if (($bytes = $len) > 0) {
$buf = substr($buf, 0, $len);
}
else {
return $buf = undef;
}
}
}
# now with all the tweaked values, send off the information
my $sock = $self->{sock};
my $b_sent = syswrite($sock, $buf, length $buf);
$self->{sent} = $b_sent;
}
sub fh {
#-------------------------------------------------------------------------------
# returns the file handle associated
my $self = shift;
return $self->{sock};
}
################################################################################
# PRIVATE PARTS
################################################################################
sub _set_options {
#-------------------------------------------------------------------------------
# cleverly tries to set the options for connection
#
my $self = shift;
# called with { host => HOST, port => PORT }
if (ref $_[0]) {
$self->set($_[0]);
}
# called with HOST,PORT
elsif (@_ == 2) {
$self->set({
host => $_[0],
port => $_[1]
});
}
# called with ( host => HOST, port => PORT )
elsif (!(@_ % 2)) {
$self->set(@_);
}
# called with "HOST:PORT" or just "PORT"
elsif (@_ == 1) {
if ($_[0] =~ /(.*)\:(.*)/) {
$self->set({
host => $1,
port => $2
});
}
else {
$self->set( {
host => 'localhost',
port => int($_[0])
});
}
}
}
1;
__END__
=head1 NAME
GT::Socket - A simple internet socket handling interface
=head1 SYNOPSIS
use GT::Socket;
my $sock = GT::Socket->open({
host => 'www.gossamer-threads.com',
port => 80
});
$sock->write("GET / HTTP/1.0\n\n");
print "REQUEST RETURNED:\n\n", $sock->gulpread(-1);
=head1 DESCRIPTION
GT::Socket provides a simple interface for tcp client/server socket services.
=head2 Method List
Object Creation
open() Creates a new client socket
server() Creates a new server socket
Reading and Writing
write() Sends all or up to max_up bytes of data to remote
read() Receives an amount or max_down bytes of data from remote
gulpread() Gets all or up to max_down bytes of data from remote
Socket Administration
close() Closes the socket
EOF() Returns open/closed status of socket
autoflush() Sets the socket so that no data is buffered
vec() Sets bits in a bitmask for select calls
pending() Returns true if data/clients awaiting
fh() Returns the raw socket handle
Server Handling
accept() Accepts a incoming client request
=head2 Creating a new Client Socket
To instantiate a new Client Socket connection, the open() method must be
called.
my $sock = GT::Socket->open({
host => 'hostname', # hostname/ip to connect to
port => 1234, # port to connect to
max_down => 0, # maximum number of bytes to download (optional)
max_up => 0, # maximum number of bytes to upload (optional)
timeout => 10 # maximum time to wait for host connect (optional)
});
The parameters are somewhat flexible, to connect to www.gossamer-threads.com on
port 80, any of the following calling methods can be used.
my $sock = GT::Socket->open({
host => 'www.gossamer-threads.com',
port => 80
});
my $sock = GT::Socket->open(
host => 'www.gossamer-threads.com',
port => 80
);
my $sock = GT::Socket->open('www.gossamer-threads.com', 80);
my $sock = GT::Socket->open('www.gossamer-threads.com:80');
Note that as port 80 is the HTTP port, and port gets tested and handled with
the getservbyname function, the following can be done:
# 'http' here but can be 'pop3', 'telnet', etc. depending on service wanted
my $sock = GT::Socket->open('www.gossamer-threads.com', 'http');
Note that if the value passed to open() is a hash ref, with a host and port, a
handful of other options may be set.
=head2 Limiting maximum amount of data downloaded
This affects the $sock->read() and the $sock->gulpread() methods.
The option 'max_down' can be used to put a cap on the number of bytes recieved
through the socket.
For example to limit the number of bytes downloaded to 2k, set max_down to 2048
my $sock = GT::Socket->open(
host => 'www.gossamer-threads.com',
port => 80,
max_down => 2048
);
WARNING, once the download maximum has been reached, the socket is closed. Then
no more information can be uploaded to the remote host.
=head2 Limiting maximum amount of data uploaded
The option 'max_up' is used to limit the number of bytes that can be sent to
the remote host.
After the maximum number of bytes is hit, the object will no longer carry out
$sock->write() requests.
This does not affect the number of bytes that can be downloaded. Until max_down
is hit or the remote host finishes the transmission, the socket will keep
listening.
In the following example. The maximum number of bytes for both download and
upload have been set to 2K.
Keep in mind, with this example, if the maximum download limit is reached
before the maximum upload, the socket will be closed so the remote server will
stop responding to $sock->write() as well!
my $sock = GT::Socket->open(
host => 'www.gossamer-threads.com',
port => 80,
max_down => 2048,
max_up => 2048
);
=head2 Limiting time taken to connect to a host
When the module tries to connect to a host, if the host is not running or
simply not present, it may take over 30 seconds for the connect call to give
up.
The 'timout' option allows the forcing the waiting period to be a certain
number of seconds. By default, the value is set to 10 seconds.
Since this uses alarm, it will not function on Win32 machines.
With the following example, the module will spend a maximum of 3 seconds trying
to connect to www.gossamer-threads.com.
my $sock = GT::Socket->open(
host => 'www.gossamer-threads.com',
port => 80,
timeout => 3
);
=head2 Methods
The following methods are available to the Client object
=head2 autoflush ( flag BOOLEAN )
$sock->autoflush(1) # turn on flushing
$sock->autoflush(0) # turn off flushing
Turns off buffering for the socket. By default, the socket is
autoflushed/buffering turned off.
This prevents peculiar errors like stalling when trying to communicate with
http servers.
=head2 close
Closes the socket if open.
=head2 EOF
Returns true of the socket is closed.
=head2 fh
Returns the filehandle.
The return value is file glob, because of this, the upload/download limits
cannot be enforced and the accounting can fall to bits of both the object and
the file glob are being used simultaneously.
=head2 gulpread ( tics INTEGER )
Attempts to read all the data it can into a buffer and return. If max_down is
non zero, it will read till the remote closes or the limit has been reached and
returns.
Tics is a non-zero value that will determine how long the function will run for
or wait:
$tics Action
----------------------------------------
>0 Wait $tics seconds till returning with results
0 Don't wait, simply get what's there and return
<0 Block, wait until all the data (up to max_down) has been received
=head2 pending ( tics INTEGER )
Returns true if socket has data pending to be received. Usually this would be
followed with a call to $sock->gulpread() or $sock->read()
$tics Action
----------------------------------------
>0 Wait $tics seconds till returning with results
0 Don't wait, simply get what's there and return
<0 Block, wait until all the data (up to max_down) has been received
=head2 read ( number_bytes INTEGER )
Reads a max of number_bytes from the socket or up to max_down and returns the
result. This is nonblocking so it is possible to get no data or less than the
requested amount.
=head2 vec ( [ bits SCALAR ] )
Sets the bits appropriate for the object's socket handle. The returned value
can be used in select(RBITS,WBITS,EBITS,TIMEOUT) function calls.
To test a series of socket handles, vec accepts an already set bit list from
another vec call.
$bits = $sock1->vec();
$bits = $sock2->vec($bits);
$bits = $sock3->vec($bits);
And $bits can now be used to test on all three handles.
=head2 write ( buffer SCALAR )
Takes the buffer and send it into the socket or up to the max_up limit.
Returns the number of bytes sent.
=head2 Creating a new Server Socket
Creating a server socket is almost identical to creating a client socket except
no hostname is specified.
my $server = GT::Socket->server({
port => 1234, # port to host services
max_down => 0, # maximum number of bytes to download (optional)
max_up => 0, # maximum number of bytes to upload (optional)
timeout => 10 # maximum time to wait for host connect (optional)
});
The only option that affects the server directly is the port. The optional
values, max_down, max_up, and timeout are passed on to the child socket when
the server accepts a new connection.
=head2 Methods
The following methods are available to the Client object
=head2 accept
Accepts an incoming connection and returns a GT::Socket client object for
further interations with the client.
=head2 fh
Returns the filehandle.
=head2 pending ( tics INTEGER )
Returns true if server has awaiting connections. Usually this would be followed
with a call to $server->accept();
$tics Action
----------------------------------------
>0 Wait $tics seconds till returning with results
0 Don't wait, simply get what's there and return
<0 Block, wait until all the data (up to max_down) has been received
=head2 vec ( [ bits SCALAR ] )
Sets the bits appropriate for the object's socket handle. The returned value
can be used in select(RBITS,WBITS,EBITS,TIMEOUT) function calls.
To test a series of socket handles, vec accepts an already set bit list from
another vec call.
$bits = $sock1->vec();
$bits = $sock2->vec($bits);
$bits = $sock3->vec($bits);
And $bits can now be used to test on all three handles.
=head1 EXAMPLES
=head2 Server
use GT::Socket;
my $server = GT::Socket->server({
port => 7890
});
while (1) {
if ($server->pending(-1)) {
print "Accepting a connection\n";
my $sock = $server->accept();
$sock->write("The time is: " . localtime() . "\n");
}
}
=head2 Client for Server
use GT::Socket;
my $client = GT::Socket->open("localhost:7890");
print "Server Said: ", $client->gulpread(-1);
=head1 COPYRIGHT
Copyright (c) 2000 Gossamer Threads Inc. All Rights Reserved.
http://www.gossamer-threads.com/
=head1 VERSION
Revision: $Id: Socket.pm,v 1.43 2004/08/23 20:07:44 jagerman Exp $
=cut
Reference in New Issue Copy Permalink