First pass at adding key files
This commit is contained in:
dsainty
749
site/slowtwitch.com/cgi-bin/articles/GT/Socket/Client.pm
Normal file
749
site/slowtwitch.com/cgi-bin/articles/GT/Socket/Client.pm
Normal file
@@ -0,0 +1,749 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Socket::Client
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Client.pm,v 1.16 2005/09/19 23:06:25 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# Client socket module that handles TCP client functionality, including
|
||||
# SSL capabilities (via GT::Socket::Client::SSLHandle and Net::SSLeay).
|
||||
#
|
||||
|
||||
# Perl 5.004 doesn't like: $$$self{foo} mixed with a tied filehandle (as used
|
||||
# by the SSL capabilities) - it confuses Perl into thinking we have a tied
|
||||
# scalar. Unfortunately, this means the rather more ugly ${*$self}{foo} syntax
|
||||
# has to be used instead.
|
||||
|
||||
package GT::Socket::Client;
|
||||
use strict;
|
||||
use vars qw/$ERROR @ISA $MAX_READALL @EXPORT_OK %EXPORT_TAGS $CR $LF $CRLF $VERSION/;
|
||||
use Carp;
|
||||
use Net::servent;
|
||||
use Socket;
|
||||
use POSIX qw/:fcntl_h EINTR EAGAIN EWOULDBLOCK BUFSIZ/;
|
||||
require Exporter;
|
||||
@ISA = 'Exporter';
|
||||
use constants
|
||||
CR => "\015",
|
||||
LF => "\012",
|
||||
CRLF => "\015\012",
|
||||
LINE_SAFETY => 100_000,
|
||||
READALL_MAX => 20 * 1024 * 1024; # Default 20 MB max, but you can pass something larger to readall()
|
||||
|
||||
$CR = CR; $LF = LF; $CRLF = CRLF;
|
||||
@EXPORT_OK = qw/CR LF CRLF $CR $LF $CRLF/;
|
||||
%EXPORT_TAGS = (
|
||||
crlf => [qw/CR LF CRLF $CR $LF $CRLF/]
|
||||
);
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.16 $ =~ /(\d+)\.(\d+)/;
|
||||
|
||||
sub open {
|
||||
my $class = ref($_[0]) || $_[0]; shift;
|
||||
|
||||
my $self = \do { local *GLOB; *GLOB };
|
||||
|
||||
if (!@_ or @_ % 2) {
|
||||
croak('Invalid options: Usage: ' . __PACKAGE__ . '->new(HASH)');
|
||||
}
|
||||
my %opts = @_;
|
||||
|
||||
$opts{host} or croak 'No host entered';
|
||||
$opts{port} or croak 'No port entered';
|
||||
|
||||
if ($opts{port} =~ /\D/) { # Port is a name such as 'ftp' - get the port number
|
||||
my $serv = getservbyname($opts{port});
|
||||
if (!$serv) {
|
||||
$ERROR = "Invalid port entered: $opts{port}";
|
||||
carp $ERROR if $opts{debug};
|
||||
return undef;
|
||||
}
|
||||
$opts{port} = $serv->port;
|
||||
}
|
||||
|
||||
my $iaddr = inet_aton($opts{host});
|
||||
if (!$iaddr) {
|
||||
$ERROR = "Unresolvable host entered: $opts{host}";
|
||||
carp $ERROR if $opts{debug};
|
||||
return undef;
|
||||
}
|
||||
my $paddr = pack_sockaddr_in($opts{port}, $iaddr);
|
||||
|
||||
not $opts{timeout} or $opts{timeout} > 0 or croak "Invalid timeout specified";
|
||||
|
||||
my $use_alarm;
|
||||
if ($opts{timeout} and $^O ne 'MSWin32') { # Perl on Win32 doesn't support alarm
|
||||
require Config;
|
||||
$use_alarm = !!$Config::Config{d_alarm};
|
||||
}
|
||||
|
||||
unless (socket($self, PF_INET, SOCK_STREAM, scalar getprotobyname('tcp'))) {
|
||||
$ERROR = "Socket error: $!";
|
||||
carp $ERROR if $opts{debug};
|
||||
return undef;
|
||||
}
|
||||
|
||||
my ($connected, $timeout);
|
||||
if ($use_alarm) { # This OS supports alarm
|
||||
local $SIG{__DIE__};
|
||||
local $SIG{ALRM} = sub { $timeout = 1; die "timeout\n" };
|
||||
|
||||
alarm($opts{timeout});
|
||||
|
||||
eval { $connected = connect($self, $paddr) };
|
||||
|
||||
alarm(0);
|
||||
}
|
||||
else {
|
||||
$connected = connect($self, $paddr);
|
||||
}
|
||||
unless ($connected) {
|
||||
if ($timeout) {
|
||||
$ERROR = "Unable to connect: Connection timed out";
|
||||
}
|
||||
else {
|
||||
$ERROR = "Unable to connect: $!";
|
||||
}
|
||||
carp $ERROR if $opts{debug};
|
||||
return undef;
|
||||
}
|
||||
|
||||
${*$self}{timeout} = $opts{timeout};
|
||||
|
||||
if ($opts{ssl}) {
|
||||
require GT::Socket::Client::SSLHandle;
|
||||
my $sock = $self;
|
||||
$self = \do { local *SSL; *SSL };
|
||||
tie *$self, "GT::Socket::Client::SSLHandle", \*$sock;
|
||||
%{*$self} = %{*$sock}; # Copy the hash options
|
||||
${*$self}{ssl} = 1; # Keep track of this being an SSL socket
|
||||
bless $self, $class;
|
||||
}
|
||||
else {
|
||||
bless $self, $class;
|
||||
}
|
||||
|
||||
if (not exists $opts{autoflush} or $opts{autoflush}) {
|
||||
select((select($self), $|++)[0]);
|
||||
${*$self}{autoflush} = 1;
|
||||
}
|
||||
if ($opts{non_blocking}) {
|
||||
${*$self}{ssl} and croak "Unable to use non_blocking with ssl sockets";
|
||||
$self->_non_blocking;
|
||||
}
|
||||
|
||||
${*$self}{host} = $opts{host};
|
||||
${*$self}{iaddr} = $iaddr;
|
||||
${*$self}{port} = $opts{port};
|
||||
${*$self}{debug} = $opts{debug};
|
||||
${*$self}{eol} = LF; # Set the default EOL, for ->readline()
|
||||
|
||||
if (${*$self}{non_blocking}) {
|
||||
my %default = (read_wait => 5, select_time => 0.05, read_size => BUFSIZ);
|
||||
# These options do nothing on blocking GT::Socket::Client objects:
|
||||
for (qw/read_wait select_time read_size/) {
|
||||
if (exists $opts{$_}) {
|
||||
$self->$_($opts{$_});
|
||||
}
|
||||
else {
|
||||
${*$self}{$_} = $default{$_};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$self;
|
||||
}
|
||||
|
||||
sub _non_blocking {
|
||||
$ERROR = undef;
|
||||
my $self = shift;
|
||||
|
||||
if ($] >= 5.006) {
|
||||
# Using IO::Handle is much easier for 5.6.x and above; previous
|
||||
# versions need the two (Windows/non-Windows) code below.
|
||||
require IO::Handle;
|
||||
$self->IO::Handle::blocking(0);
|
||||
}
|
||||
else {
|
||||
if ($^O eq 'MSWin32') {
|
||||
# 126 is FIONBIO (some docs say 0x7F << 16)
|
||||
ioctl(
|
||||
$self,
|
||||
0x80000000 | (4 << 16) | (ord('f') << 8) | 126,
|
||||
1
|
||||
) or die "ioctl: $^E";
|
||||
}
|
||||
else {
|
||||
my $flags = fcntl($self, F_GETFL, 0) or die "getfl: $!";
|
||||
$flags |= O_NONBLOCK;
|
||||
fcntl($self, F_SETFL, $flags) or die "setfl: $!";
|
||||
}
|
||||
}
|
||||
|
||||
${*$self}{non_blocking} = 1;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub eol {
|
||||
$ERROR = undef;
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
${*$self}{eol} = shift;
|
||||
defined ${*$self}{eol} and length ${*$self}{eol} or croak "No valid EOL character entered";
|
||||
return 1;
|
||||
}
|
||||
return ${*$self}{eol};
|
||||
}
|
||||
|
||||
sub readline {
|
||||
$ERROR = undef;
|
||||
my $self = shift;
|
||||
if (not ${*$self}{non_blocking} or ${*$self}{ssl}) {
|
||||
local $/ = ${*$self}{eol};
|
||||
$_[0] = <$self>;
|
||||
}
|
||||
else {
|
||||
$_[0] = '';
|
||||
require POSIX;
|
||||
local $!;
|
||||
vec(my $rin = '', fileno($self), 1) = 1;
|
||||
local $SIG{PIPE} = 'IGNORE';
|
||||
my $safety;
|
||||
|
||||
my $select_time = ${*$self}{select_time};
|
||||
while () {
|
||||
if ($safety++ >= LINE_SAFETY) {
|
||||
$ERROR = 'Line reads exceeded safety line cutoff (' . LINE_SAFETY . ')';
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
return undef;
|
||||
}
|
||||
my $nfound;
|
||||
my $rout = $rin;
|
||||
do {
|
||||
$! = 0;
|
||||
$nfound = select($rout, undef, undef, $select_time);
|
||||
} while $! == EINTR;
|
||||
if ($nfound > 0) {
|
||||
my $ret = sysread($self, my $buff, 1);
|
||||
unless ($ret) {
|
||||
next if $! == EAGAIN or $! == EWOULDBLOCK;
|
||||
|
||||
$ERROR = "Unable to read from socket: $!. Read: $_[0]";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
return undef;
|
||||
}
|
||||
$_[0] .= $buff;
|
||||
last if length($_[0]) >= length(${*$self}{eol}) and
|
||||
rindex($_[0], ${*$self}{eol}) == (length($_[0]) - length(${*$self}{eol}))
|
||||
}
|
||||
elsif ($nfound < 0) {
|
||||
$ERROR = "Socket error: $!";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub select_time {
|
||||
$ERROR = undef;
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
my $select_time = shift;
|
||||
unless ($select_time > 0) {
|
||||
croak 'Usage: $obj->select_time(SELECT_TIME)';
|
||||
}
|
||||
${*$self}{select_time} = $select_time;
|
||||
return 1;
|
||||
}
|
||||
|
||||
return ${*$self}{select_time};
|
||||
}
|
||||
|
||||
sub read_wait {
|
||||
$ERROR = undef;
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
my $read_wait = shift;
|
||||
unless ($read_wait eq '0' or $read_wait > 0) {
|
||||
croak 'Usage: $obj->read_wait(READ_WAIT)';
|
||||
}
|
||||
${*$self}{read_wait} = $read_wait;
|
||||
return 1;
|
||||
}
|
||||
|
||||
return ${*$self}{read_wait};
|
||||
}
|
||||
|
||||
sub read_size {
|
||||
$ERROR = undef;
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
my $read_size = shift;
|
||||
unless ($read_size >= 1) {
|
||||
croak 'Usage: $obj->read_size(READ_SIZE)';
|
||||
}
|
||||
${*$self}{read_size} = $read_size;
|
||||
return 1;
|
||||
}
|
||||
|
||||
return ${*$self}{read_size};
|
||||
}
|
||||
|
||||
# Reads all (allowing for a timeout of read_wait, if non-blocking) data from the socket
|
||||
sub readall {
|
||||
my $self = shift;
|
||||
$self->readblock($_[0], -1);
|
||||
}
|
||||
|
||||
sub readblock {
|
||||
$ERROR = undef;
|
||||
my $self = shift;
|
||||
$_[0] = '';
|
||||
my $read_wait = ${*$self}{read_wait};
|
||||
my $select_time = ${*$self}{select_time};
|
||||
|
||||
my $max_size = pop;
|
||||
unless (@_ == 1 and int($max_size) != 0) {
|
||||
croak 'Usage: $obj->readblock($scalar, BLOCK_SIZE)';
|
||||
}
|
||||
|
||||
unless (defined fileno $self) {
|
||||
$ERROR = "Socket closed";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
# Don't return undef - there could still be something waiting on the
|
||||
# socket.
|
||||
}
|
||||
|
||||
local $!;
|
||||
|
||||
if (not ${*$self}{non_blocking} or ${*$self}{ssl}) {
|
||||
if ($max_size > 0) {
|
||||
read($self, $_[0], $max_size);
|
||||
}
|
||||
else {
|
||||
local $/;
|
||||
$_[0] = <$self>;
|
||||
}
|
||||
if (not defined $_[0] and $!) {
|
||||
$ERROR = "Blocking block read failed: $!";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
return undef unless length($_[0]);
|
||||
}
|
||||
}
|
||||
else {
|
||||
my $read_size = ${*$self}{read_size};
|
||||
|
||||
vec(my $rin = '', fileno($self), 1) = 1;
|
||||
local $SIG{PIPE} = 'IGNORE';
|
||||
my $try = 0;
|
||||
|
||||
while () {
|
||||
my $nfound;
|
||||
my $rout = $rin;
|
||||
do {
|
||||
$! = 0;
|
||||
$nfound = select($rout, undef, undef, $select_time);
|
||||
} while $! == EINTR;
|
||||
if ($nfound > 0) {
|
||||
my $read_size = $read_size;
|
||||
if ($max_size > 0 and length($_[0]) + $read_size > $max_size) {
|
||||
$read_size = $max_size - length($_[0]);
|
||||
}
|
||||
my $ret = sysread($self, my $buff, $read_size);
|
||||
unless ($ret) {
|
||||
if ($! == EAGAIN or $! == EWOULDBLOCK) {
|
||||
if (++$try * $select_time > $read_wait) {
|
||||
last;
|
||||
}
|
||||
}
|
||||
elsif ($! == 0) {
|
||||
$ERROR = "Connection closed";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
close $self;
|
||||
length($_[0]) ? last : undef;
|
||||
}
|
||||
else {
|
||||
$ERROR = "Socket error: $!";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
close $self;
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$try = 0;
|
||||
$_[0] .= $buff;
|
||||
undef $buff;
|
||||
last if $max_size > 0 and length($_[0]) >= $max_size;
|
||||
}
|
||||
}
|
||||
elsif ($nfound < 0) {
|
||||
$ERROR = "Socket error: $!";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
return undef;
|
||||
}
|
||||
elsif (++$try * $select_time > $read_wait) {
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
return length($_[0]);
|
||||
}
|
||||
|
||||
sub readalluntil {
|
||||
$ERROR = undef;
|
||||
my $self = shift;
|
||||
my $until = shift;
|
||||
$until = [$until] unless ref $until;
|
||||
@_ or croak 'Usage: $obj->readalluntil($string-or-\@strings, $scalar[, $scalar])';
|
||||
|
||||
my $initial;
|
||||
$initial = pop if @_ > 1;
|
||||
|
||||
return $self->readblock($_[0], -1) if not ${*$self}{non_blocking} or ${*$self}{ssl};
|
||||
|
||||
$_[0] = '';
|
||||
|
||||
my $read_wait = ${*$self}{read_wait};
|
||||
my $select_time = ${*$self}{select_time};
|
||||
my $read_size = ${*$self}{read_size};
|
||||
|
||||
unless (defined fileno $self) {
|
||||
$ERROR = "Socket closed";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
# Don't return undef - there could still be something waiting on the socket.
|
||||
}
|
||||
|
||||
local $!;
|
||||
|
||||
vec(my $rin = '', fileno($self), 1) = 1;
|
||||
local $SIG{PIPE} = 'IGNORE';
|
||||
my ($try, $first) = (0);
|
||||
|
||||
UNTIL: while () {
|
||||
my $nfound;
|
||||
my $rout = $rin;
|
||||
do {
|
||||
$! = 0;
|
||||
$nfound = select($rout, undef, undef, $select_time);
|
||||
} while $! == EINTR;
|
||||
if ($nfound > 0) {
|
||||
my $ret = sysread($self, my $buff, $read_size);
|
||||
unless ($ret) {
|
||||
if ($! == EAGAIN or $! == EWOULDBLOCK) {
|
||||
if (++$try * $select_time > $read_wait) {
|
||||
last;
|
||||
}
|
||||
}
|
||||
elsif ($! == 0) {
|
||||
$ERROR = "Connection closed";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
close $self;
|
||||
length($_[0]) ? last : undef;
|
||||
}
|
||||
else {
|
||||
$ERROR = "Socket error: $!";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
close $self;
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$try = 0;
|
||||
$_[0] .= $buff;
|
||||
undef $buff;
|
||||
|
||||
if (defined $initial and length($_[0]) >= length($initial) and not $first++) {
|
||||
last if $_[0] eq $initial;
|
||||
}
|
||||
for (@$until) {
|
||||
last UNTIL if rindex($_[0], $_) == length($_[0]) - length($_);
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ($nfound < 0) {
|
||||
$ERROR = "Socket error: $!";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
return undef;
|
||||
}
|
||||
elsif (++$try * $select_time > $read_wait) {
|
||||
last;
|
||||
}
|
||||
}
|
||||
return length($_[0]);
|
||||
}
|
||||
|
||||
sub write {
|
||||
my ($self, $msg) = @_;
|
||||
|
||||
unless (defined fileno $self) {
|
||||
$ERROR = "Socket closed";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
}
|
||||
|
||||
return unless defined $msg and length $msg;
|
||||
if (not ${*$self}{non_blocking} or ${*$self}{ssl}) {
|
||||
unless (print $self $msg) {
|
||||
$ERROR = "print failed: $!";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
else {
|
||||
for (1 .. 10) { # Maximum 10 "EAGAIN" tries
|
||||
my $rv = syswrite $self, $msg, length $msg;
|
||||
if (!defined $rv and $! == EAGAIN) {
|
||||
next;
|
||||
}
|
||||
elsif (!defined $rv or $rv != length $msg) {
|
||||
$ERROR = "Could not write to socket: $!";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
return undef;
|
||||
}
|
||||
else {
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
# Returns the IP that we ended up connecting to.
|
||||
# This is the value returned from Socket.pm's inet_aton function.
|
||||
sub iaddr {
|
||||
my $self = shift;
|
||||
${*$self}{iaddr};
|
||||
}
|
||||
|
||||
# This is the _numeric_ port that was connected to, regardless of whether or
|
||||
# not you passed a number or string port.
|
||||
sub port {
|
||||
my $self = shift;
|
||||
${*$self}{port};
|
||||
}
|
||||
|
||||
sub error { $ERROR }
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Socket::Client - Socket module designed for TCP clients
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Socket::Client qw/:crlf/;
|
||||
|
||||
my $socket = GT::Socket::Client->open(
|
||||
host => "gossamer-threads.com",
|
||||
port => "shell", # AKA port 514
|
||||
timeout => 10
|
||||
) or die GT::Socket::Client->error;
|
||||
|
||||
# $socket is now a socket connected to the host. Use
|
||||
# it as you would use any socket.
|
||||
$sock->readline(my $line);
|
||||
print "Read this line from the socket: $line";
|
||||
print $sock "That line" . CRLF;
|
||||
|
||||
$sock->readblock(my $block, 4096);
|
||||
print "Read 4KB from the socket: $block";
|
||||
print $sock "QUIT" . CRLF;
|
||||
|
||||
$sock->readall(my $all);
|
||||
print "Everything else from the socket: $all";
|
||||
print $sock "Something else" . CRLF;
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is a basic socket module that is designed to only handle basic
|
||||
socket connection and simple read capabilities. Anything else that you want to
|
||||
do with the socket is entirely up to you - this doesn't try to support
|
||||
superfluous options that only a few connections will ever use, or options that
|
||||
should be done in the code using this module instead of the module itself. See
|
||||
the GT::WWW::http and GT::WWW::https modules for a good working example.
|
||||
|
||||
By default, GT::Socket::Client exports nothing, however it can export the LF,
|
||||
CR, CRLF, $LF, $CR, and $CRLF constants, individually, or together via the
|
||||
':crlf' export tag.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 open
|
||||
|
||||
Takes a hash (not hash reference) of socket options, as follows:
|
||||
|
||||
=over 4
|
||||
|
||||
=item host
|
||||
|
||||
[REQUIRED] The name or IP of the host to connect to.
|
||||
|
||||
=item port
|
||||
|
||||
[REQUIRED] The numeric value (25) or service name ("smtp") of the port to
|
||||
connect to.
|
||||
|
||||
=item ssl
|
||||
|
||||
[OPTIONAL] If this option is provided, the connection will use SSL. Note that
|
||||
this requires the Net::SSLeay module.
|
||||
|
||||
=item timeout
|
||||
|
||||
[OPTIONAL] A connection timeout period, in integral seconds. Note that this is
|
||||
only supported on systems that support the alarm() function; on other systems
|
||||
(such as Windows), this argument has no effect.
|
||||
|
||||
=item non_blocking
|
||||
|
||||
[OPTIONAL] Before returning it to you, the connected socket will be set up as
|
||||
non-blocking if this option is enabled. Note that this option B<DOES NOT WORK>
|
||||
with the ssl option, due to the Net::SSLeay interface.
|
||||
|
||||
=item autoflush
|
||||
|
||||
[OPTIONAL] Before returning to you, the connected socket will be made non-
|
||||
buffering. If you want your socket to be buffered, pass in autoflush with a
|
||||
false value.
|
||||
|
||||
=item ssl
|
||||
|
||||
[OPTIONAL] GT::Socket::Client has the ability to establish an SSL connection to
|
||||
a server for protocols such as HTTPS, SMTPS, POP3S, IMAPS, etc. Note that it
|
||||
currently has a limitation of not being able to change to or from an SSL
|
||||
connection once the connection is established, for protocols like FTPS.
|
||||
|
||||
=item debug
|
||||
|
||||
[OPTIONAL] If debugging is enabled, internal warnings (such as invalid port,
|
||||
unresolvable host, connection failure, etc.) will be warn()ed. This does not
|
||||
affect the error() method, which will always be set to the error message when
|
||||
a problem occurs. Provide a true value if you want the warn()s to appear.
|
||||
|
||||
=back
|
||||
|
||||
=head2 readline
|
||||
|
||||
This method reads a single line from the socket. It takes one argument, which
|
||||
must be a scalar which will be set to the line read. See the eol() method,
|
||||
which allows you to specify an EOL character other than "\012". Note that on a
|
||||
blocking socket, this will block until it can read a full line (or the server
|
||||
closes the connection). On a non-blocking socket, the amount of time it will
|
||||
wait for input is dependent on the value of the read_wait() method.
|
||||
|
||||
1 is returned on success, undef on failure.
|
||||
|
||||
=head2 readblock
|
||||
|
||||
This method attempts to read a certain number of bytes from the server. This
|
||||
takes two arguments: like readline(), the first argument is a scalar that will
|
||||
be set to the data read. The second argument is the amount of data that may be
|
||||
read. Note that on a blocking socket, this will block until the required
|
||||
amount of data is read, or the socket is closed. On a non-blocking socket, this
|
||||
will return once the requested amount of data is read, the socket closes, or
|
||||
there is no input for C<read_wait> seconds (See L</read_wait>).
|
||||
|
||||
Note that a block size of -1 makes the socket read until the connection is
|
||||
closed, in the case of blocking sockets, or until the read_wait() is hit.
|
||||
|
||||
The number of bytes read is returned on success, undef on failure.
|
||||
|
||||
=head2 readall
|
||||
|
||||
A synonym for C<$obj-E<gt>readblock($_[0], -1)> - in other words, it reads all
|
||||
available data (waiting for up to C<read_wait> seconds, if non-blocking).
|
||||
|
||||
=head2 readalluntil
|
||||
|
||||
A useful function for non-blocking sockets (completely useless for blocking
|
||||
sockets, on which it simply becomes a readall call). Basically, this works
|
||||
like readall(), above, but it will terminate immediately if it encounters a
|
||||
pattern that you provide on the end of the data read. Note that this does NOT
|
||||
work as a delimiter, but is useful for protocols such as POP3 when you want to
|
||||
read as much as you can, but know what should be at the end of what you read.
|
||||
The sole advantage of this is that it allows you to avoid the read_wait timeout
|
||||
that would otherwise be required at the end of a data stream.
|
||||
|
||||
It takes two arguments - the first is a string or array reference of strings
|
||||
containing the trailing string data. The second is a scalar that will be set
|
||||
to the data read. For example, for POP3 you might use: C<"\n.\r\n">. You can
|
||||
optionally pass in a third argument, which is used during the first read - if
|
||||
the result of the first read is equal to the string passed in, it's returned.
|
||||
Using the POP3 example again, this might be C<".\r\n"> - to handle an empty
|
||||
response.
|
||||
|
||||
=head2 select_time
|
||||
|
||||
[Non-blocking sockets only] This adjusts the number of seconds passed to
|
||||
select() to poll the socket for available data. The default value is 0.05,
|
||||
which should work in most situations.
|
||||
|
||||
=head2 read_wait
|
||||
|
||||
[Non-blocking sockets only] This method is used to set the wait time for reads.
|
||||
On a local or very fast connection, this can be set to a low value (i.e. 0.1
|
||||
seconds), but on a typical slower internet connection, longer wait times for
|
||||
reading are usually necessary. Hence, the default is a wait time of 5 seconds.
|
||||
In effect, an attempt to read all data will end after nothing has been received
|
||||
for this many seconds.
|
||||
|
||||
=head2 write
|
||||
|
||||
Sends data to the server. Takes the data to send. This does The Right Thing
|
||||
for either non-blocking or blocking sockets.
|
||||
|
||||
=head2 eol
|
||||
|
||||
This method takes one or more character, and uses it for the EOL character(s)
|
||||
used by readline. If called without any argument, the EOL character for the
|
||||
current object is returned.
|
||||
|
||||
=head2 error
|
||||
|
||||
If an error (such as connection, socket, etc.) occurs, you can access it via
|
||||
the error() method. This can be called as either a class or instance method,
|
||||
since open() return C<undef> instead of an object if the connection fails.
|
||||
|
||||
=head2 iaddr
|
||||
|
||||
Once a connection has been established, you can call this method to get the
|
||||
iaddr value for the connection. This value is as returned by
|
||||
L<Socket.pm|Socket>'s inet_aton function.
|
||||
|
||||
=head2 port
|
||||
|
||||
Once a connection has been established, this method can be used to determine
|
||||
the port connected to. Note that this is not necessarily the same as the value
|
||||
of the C<port> option passed to open() - the return value of this function will
|
||||
always be numeric (e.g. C<25>), even if a service name (e.g. C<"smtp">) was
|
||||
passed to open().
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<GT::Socket> - A socket module made for Links SQL.
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Jason Rhinelander
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Client.pm,v 1.16 2005/09/19 23:06:25 brewt Exp $
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,124 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Socket::Client::SSLHandle
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: SSLHandle.pm,v 1.3 2004/01/13 01:35:20 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# A tied filehandle for SSL connections with GT::Socket::Client (via
|
||||
# Net::SSLeay::Handle).
|
||||
#
|
||||
|
||||
package GT::Socket::Client::SSLHandle;
|
||||
use strict;
|
||||
use vars qw/$VERSION $ERROR/;
|
||||
use GT::Socket::Client;
|
||||
use Net::SSLeay 1.06 qw/print_errs/;
|
||||
|
||||
*ERROR = \$GT::Socket::Client::ERROR;
|
||||
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/;
|
||||
|
||||
Net::SSLeay::load_error_strings();
|
||||
Net::SSLeay::SSLeay_add_ssl_algorithms();
|
||||
Net::SSLeay::randomize();
|
||||
|
||||
sub TIEHANDLE {
|
||||
my ($class, $socket) = @_;
|
||||
|
||||
my $ctx = Net::SSLeay::CTX_new()
|
||||
or return ssl_err("Failed to create new SSL CTX: $!", "SSL CTX_new");
|
||||
my $ssl = Net::SSLeay::new($ctx)
|
||||
or return ssl_err("Failed to create SSL: $!", "SSL new");
|
||||
|
||||
my $fileno = fileno($socket);
|
||||
Net::SSLeay::set_fd($ssl, $fileno);
|
||||
|
||||
my $connect = Net::SSLeay::connect($ssl);
|
||||
|
||||
${*$socket}{SSLHandle_ssl} = $ssl;
|
||||
${*$socket}{SSLHandle_ctx} = $ctx;
|
||||
${*$socket}{SSLHandle_fileno} = $fileno;
|
||||
|
||||
return bless $socket, $class;
|
||||
}
|
||||
|
||||
sub PRINT {
|
||||
my $socket = shift;
|
||||
my $ssl = ${*$socket}{SSLHandle_ssl};
|
||||
my $ret = 0;
|
||||
for (@_) {
|
||||
defined or last;
|
||||
$ret = Net::SSLeay::write($ssl, $_);
|
||||
if (!$ret) {
|
||||
ssl_err("Could not write to SSL socket: $!", "SSL write");
|
||||
last;
|
||||
}
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub READLINE {
|
||||
my $socket = shift;
|
||||
my $ssl = ${*$socket}{SSLHandle_ssl};
|
||||
my $line = Net::SSLeay::ssl_read_until($ssl);
|
||||
if (!$line) {
|
||||
ssl_err("Could not readline from SSL socket: $!", "SSL ssl_read_until");
|
||||
return undef;
|
||||
}
|
||||
return $line;
|
||||
}
|
||||
|
||||
sub READ {
|
||||
my ($socket, $buffer, $length, $offset) = \(@_);
|
||||
my $ssl = ${*$$socket}{SSLHandle_ssl};
|
||||
if (defined $$offset) {
|
||||
my $read = Net::SSLeay::ssl_read_all($ssl, $$length)
|
||||
or return ssl_err("Could not read_all from SSL socket: $!", "SSL ssl_read_all");
|
||||
my $buf_length = length($$buffer);
|
||||
$$offset > $buf_length and $$buffer .= chr(0) x ($$offset - $buf_length);
|
||||
substr($$buffer, $$offset) = $read;
|
||||
return length($read);
|
||||
}
|
||||
else {
|
||||
return length(
|
||||
$$buffer = Net::SSLeay::ssl_read_all($ssl, $$length)
|
||||
or return ssl_err("Could not read_all from SSL socket: $!", "SSL ssl_read_all")
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
sub WRITE {
|
||||
my $socket = shift;
|
||||
my ($buffer, $length, $offset) = @_;
|
||||
$offset = 0 unless defined $offset;
|
||||
|
||||
# Return number of characters written
|
||||
my $ssl = ${*$socket}{SSLHandle_ssl};
|
||||
Net::SSLeay::write($ssl, substr($buffer, $offset, $length))
|
||||
or return ssl_err("Could not write to SSL socket: $!", "SSL write");
|
||||
return $length;
|
||||
}
|
||||
|
||||
sub CLOSE {
|
||||
my $socket = shift;
|
||||
my $fileno = fileno($socket);
|
||||
Net::SSLeay::free(${*$socket}{SSLHandle_ssl});
|
||||
Net::SSLeay::CTX_free(${*$socket}{SSLHandle_ctx});
|
||||
close $socket;
|
||||
}
|
||||
|
||||
sub FILENO { fileno($_[0]) }
|
||||
|
||||
sub ssl_err {
|
||||
my ($msg, $key) = @_;
|
||||
$ERROR = "$msg\n" . print_errs($key); # Also sets $GT::Socket::Client::ERROR
|
||||
return undef;
|
||||
}
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user