File Coverage

blib/lib/Net/SSLeay/Handle.pm

Criterion	Covered	Total	%
statement	14	100	14.0
branch	0	46	0.0
condition	0	9	0.0
subroutine	5	19	26.3
pod	3	3	100.0
total	22	177	12.4

package Net::SSLeay::Handle;

use 5.8.1;

use strict;

use Socket;
use Net::SSLeay;

require Exporter;

=encoding utf-8

=head1 NAME

Net::SSLeay::Handle - Perl module that lets SSL (HTTPS) sockets be
handled as standard file handles.

=head1 SYNOPSIS

  use Net::SSLeay::Handle qw/shutdown/;
  my ($host, $port) = ("localhost", 443);

  tie(*SSL, "Net::SSLeay::Handle", $host, $port);

  print SSL "GET / HTTP/1.0\r\n";
  shutdown(\*SSL, 1);
  print while ();
  close SSL;

=head1 DESCRIPTION

Net::SSLeay::Handle allows you to request and receive HTTPS web pages
using "old-fashion" file handles as in:

    print SSL "GET / HTTP/1.0\r\n";

and

    print while ();

If you export the shutdown routine, then the only extra code that
you need to add to your program is the tie function as in:

    my $socket;
    if ($scheme eq "https") {
        tie(*S2, "Net::SSLeay::Handle", $host, $port);
        $socket = \*S2;
    else {
        $socket = Net::SSLeay::Handle->make_socket($host, $port);
    }
    print $socket $request_headers;
    ...

=cut

use vars qw(@ISA @EXPORT_OK $VERSION);
@ISA = qw(Exporter);
@EXPORT_OK = qw(shutdown);
$VERSION = '1.93_01';

my $Initialized;       #-- only _initialize() once
my $Debug = 0;         #-- pretty hokey

#== Tie Handle Methods ========================================================
#
# see perldoc perltie for details.
#
#==============================================================================

sub TIEHANDLE {
    my ($class, $socket, $port) = @_;
    $Debug > 10 and print "TIEHANDLE(@{[join ', ', @_]})\n";

    ref $socket eq "GLOB" or $socket = $class->make_socket($socket, $port);

    $class->_initialize();

    my $ctx = Net::SSLeay::CTX_new() or die_now("Failed to create SSL_CTX $!");
    my $ssl = Net::SSLeay::new($ctx) or die_now("Failed to create SSL $!");

    my $fileno = fileno($socket);

  Net::SSLeay::set_fd($ssl, $fileno);   # Must use fileno

    my $resp = Net::SSLeay::connect($ssl);

    $Debug and print "Cipher '" . Net::SSLeay::get_cipher($ssl) . "'\n";

	my $self = bless {
        ssl    => $ssl,
        ctx    => $ctx,
        socket => $socket,
        fileno => $fileno,
    }, $class;

    return $self;
}

sub PRINT {
    my $self = shift;

    my $ssl  = _get_ssl($self);
    my $resp = 0;
    for my $msg (@_) {
        defined $msg or last;
        $resp = Net::SSLeay::write($ssl, $msg) or last;
    }
    return $resp;
}

sub READLINE {
    my $self = shift;
    my $ssl  = _get_ssl($self);
	if (wantarray) {
		my @lines;
		while (my $line = Net::SSLeay::ssl_read_until($ssl)) {
			push @lines, $line;
		}
		return @lines;
	} else {
		my $line = Net::SSLeay::ssl_read_until($ssl);
		return $line ? $line : undef;
	}
}

sub READ {
    my ($self, $buf, $len, $offset) = \ (@_);
    my $ssl = _get_ssl($$self);
    defined($$offset) or
      return length($$buf = Net::SSLeay::ssl_read_all($ssl, $$len));

    defined(my $read = Net::SSLeay::ssl_read_all($ssl, $$len))
      or return undef;

    my $buf_len = length($$buf);
    $$offset > $buf_len and $$buf .= chr(0) x ($$offset - $buf_len);
    substr($$buf, $$offset) = $read;
    return length($read);
}

sub WRITE {
    my $self = shift;
    my ($buf, $len, $offset) = @_;
    $offset = 0 unless defined $offset;

    # Return number of characters written.
    my $ssl  = $self->_get_ssl();
    return $len if Net::SSLeay::write($ssl, substr($buf, $offset, $len));
    return undef;
}

sub CLOSE {
    my $self = shift;
    my $fileno = $self->{fileno};
    $Debug > 10 and print "close($fileno)\n";
    Net::SSLeay::free ($self->{ssl});
    Net::SSLeay::CTX_free ($self->{ctx});
    close $self->{socket};
}

sub FILENO  { $_[0]->{fileno} }


=head1 FUNCTIONS

=over

=item shutdown

  shutdown(\*SOCKET, $mode)

Calls to the main shutdown() don't work with tied sockets created with this
module.  This shutdown should be able to distinquish between tied and untied
sockets and do the right thing.

=cut

sub shutdown {
    my ($obj, @params) = @_;

	my $socket = UNIVERSAL::isa($obj, 'Net::SSLeay::Handle') ?
		$obj->{socket} : $obj;
    return shutdown($socket, @params);
}

=item debug

  my $debug = Net::SSLeay::Handle->debug()
  Net::SSLeay::Handle->debug(1)

Get/set debugging mode. Always returns the debug value before the function call.
if an additional argument is given the debug option will be set to this value.

=cut

sub debug {
    my ($class, $debug) = @_;
    my $old_debug = $Debug;
    @_ >1 and $Debug = $debug || 0;
    return $old_debug;
}

#=== Internal Methods =========================================================

=item make_socket

  my $sock = Net::SSLeay::Handle->make_socket($host, $port);

Creates a socket that is connected to $post using $port. It uses
$Net::SSLeay::proxyhost and proxyport if set and authentificates itself against
this proxy depending on $Net::SSLeay::proxyauth. It also turns autoflush on for
the created socket.

=cut

sub make_socket {
    my ($class, $host, $port) = @_;
    $Debug > 10 and print "_make_socket(@{[join ', ', @_]})\n";
    $host ||= 'localhost';
    $port ||= 443;

    my $phost = $Net::SSLeay::proxyhost;
    my $pport = $Net::SSLeay::proxyhost ? $Net::SSLeay::proxyport : $port;

    my $dest_ip     = gethostbyname($phost || $host);
    my $host_params = sockaddr_in($pport, $dest_ip);

    socket(my $socket, &PF_INET(), &SOCK_STREAM(), 0) or die "socket: $!";
    connect($socket, $host_params)                    or die "connect: $!";

    my $old_select = select($socket); $| = 1; select($old_select);
    $phost and do {
        my $auth = $Net::SSLeay::proxyauth;
        my $CRLF = $Net::SSLeay::CRLF;
        print $socket "CONNECT $host:$port HTTP/1.0$auth$CRLF$CRLF";
        my $line = <$socket>;
    };
    return $socket;
}

=back

=cut

sub _initialize {
    $Initialized++ and return;
  Net::SSLeay::load_error_strings();
  Net::SSLeay::SSLeay_add_ssl_algorithms();
  Net::SSLeay::randomize();
}

sub __dummy {
    my $host = $Net::SSLeay::proxyhost;
    my $port = $Net::SSLeay::proxyport;
    my $auth = $Net::SSLeay::proxyauth;
}

#--- _get_self($socket) -------------------------------------------------------
# Returns a hash containing attributes for $socket (= \*SOMETHING) based
# on fileno($socket).  Will return undef if $socket was not created here.
#------------------------------------------------------------------------------

sub _get_self { return $_[0]; }

#--- _get_ssl($socket) --------------------------------------------------------
# Returns a the "ssl" attribute for $socket (= \*SOMETHING) based
# on fileno($socket).  Will cause a warning and return undef if $socket was not
# created here.
#------------------------------------------------------------------------------

sub _get_ssl {
    return $_[0]->{ssl};
}

1;

__END__