summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Net/SSL.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Net/SSL.pm')
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/SSL.pm607
1 files changed, 0 insertions, 607 deletions
diff --git a/Master/tlpkg/tlperl/lib/Net/SSL.pm b/Master/tlpkg/tlperl/lib/Net/SSL.pm
deleted file mode 100755
index f14435aeb69..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/SSL.pm
+++ /dev/null
@@ -1,607 +0,0 @@
-package Net::SSL;
-
-use strict;
-use MIME::Base64;
-use Socket;
-use Carp;
-
-use vars qw(@ISA $VERSION $NEW_ARGS);
-$VERSION = '2.84';
-
-require IO::Socket;
-@ISA=qw(IO::Socket::INET);
-
-my %REAL; # private to this package only
-my $DEFAULT_VERSION = '23';
-my $CRLF = "\015\012";
-my $SEND_USERAGENT_TO_PROXY = 0;
-
-require Crypt::SSLeay;
-
-sub _default_context {
- require Crypt::SSLeay::MainContext;
- Crypt::SSLeay::MainContext::main_ctx(@_);
-}
-
-sub _alarm_set {
- return if $^O eq 'MSWin32' or $^O eq 'NetWare';
- alarm(shift);
-}
-
-sub new {
- my($class, %arg) = @_;
- local $NEW_ARGS = \%arg;
- $class->SUPER::new(%arg);
-}
-
-sub DESTROY {
- my $self = shift;
- delete $REAL{$self};
- local $@;
- eval { $self->SUPER::DESTROY; };
-}
-
-sub configure {
- my($self, $arg) = @_;
- my $ssl_version = delete $arg->{SSL_Version} ||
- $ENV{HTTPS_VERSION} || $DEFAULT_VERSION;
- my $ssl_debug = delete $arg->{SSL_Debug} || $ENV{HTTPS_DEBUG} || 0;
-
- my $ctx = delete $arg->{SSL_Context} || _default_context($ssl_version);
-
- *$self->{ssl_ctx} = $ctx;
- *$self->{ssl_version} = $ssl_version;
- *$self->{ssl_debug} = $ssl_debug;
- *$self->{ssl_arg} = $arg;
- *$self->{ssl_peer_addr} = $arg->{PeerAddr};
- *$self->{ssl_peer_port} = $arg->{PeerPort};
- *$self->{ssl_new_arg} = $NEW_ARGS;
- *$self->{ssl_peer_verify} = 0;
-
- ## Crypt::SSLeay must also aware the SSL Proxy before calling
- ## $socket->configure($args). Because the $sock->configure() will
- ## die when failed to resolve the destination server IP address,
- ## whether the SSL proxy is used or not!
- ## - dqbai, 2003-05-10
- if (my $proxy = $self->proxy) {
- ($arg->{PeerAddr}, $arg->{PeerPort}) = split(':',$proxy);
- $arg->{PeerPort} || croak("no port given for proxy server $proxy");
- }
-
- $self->SUPER::configure($arg);
-}
-
-# override to make sure there is really a timeout
-sub timeout {
- shift->SUPER::timeout || 60;
-}
-
-sub blocking {
- my $self = shift;
- $self->SUPER::blocking(@_);
-}
-
-sub connect {
- my $self = shift;
-
- # configure certs on connect() time, so we can throw an undef
- # and have LWP understand the error
- eval { $self->configure_certs() };
- if($@) {
- $@ = "configure certs failed: $@; $!";
- $self->die_with_error($@);
- }
-
- # finished, update set_verify status
- if(my $rv = *$self->{ssl_ctx}->set_verify()) {
- *$self->{ssl_peer_verify} = $rv;
- }
-
- if ($self->proxy) {
- # don't die() in connect, just return undef and set $@
- my $proxy_connect = eval { $self->proxy_connect_helper(@_) };
- if(! $proxy_connect || $@) {
- $@ = "proxy connect failed: $@; $!";
- croak($@);
- }
- }
- else {
- *$self->{io_socket_peername}=@_ == 1 ? $_[0] : IO::Socket::sockaddr_in(@_);
- if(!$self->SUPER::connect(@_)) {
- # better to die than return here
- $@ = "Connect failed: $@; $!";
- croak($@);
- }
- }
-
- my $debug = *$self->{ssl_debug} || 0;
- my $ssl = Crypt::SSLeay::Conn->new(*$self->{ssl_ctx}, $debug, $self);
- my $arg = *$self->{ssl_arg};
- my $new_arg = *$self->{ssl_new_arg};
- $arg->{SSL_Debug} = $debug;
-
- eval {
- local $SIG{ALRM} = sub { $self->die_with_error("SSL connect timeout") };
- # timeout / 2 because we have 3 possible connects here
- _alarm_set($self->timeout / 2);
-
- my $rv;
- {
- local $SIG{PIPE} = \¨
- $rv = eval { $ssl->connect; };
- }
- if (not defined $rv or $rv <= 0) {
- _alarm_set(0);
- $ssl = undef;
- my %args = (%$new_arg, %$arg);
- if(*$self->{ssl_version} == 23) {
- $args{SSL_Version} = 3;
- # the new connect might itself be overridden with a REAL SSL
- my $new_ssl = Net::SSL->new(%args);
- $REAL{$self} = $REAL{$new_ssl} || $new_ssl;
- return $REAL{$self};
- }
- elsif(*$self->{ssl_version} == 3) {
- # $self->die_with_error("SSL negotiation failed");
- $args{SSL_Version} = 2;
- my $new_ssl = Net::SSL->new(%args);
- $REAL{$self} = $new_ssl;
- return $new_ssl;
- }
- else {
- # don't die, but do set $@, and return undef
- eval { $self->die_with_error("SSL negotiation failed") };
- croak($@);
- }
- }
- _alarm_set(0);
- };
-
- # odd error in eval {} block, maybe alarm outside the evals
- if($@) {
- $@ = "$@; $!";
- croak($@);
- }
-
- # successful SSL connection gets stored
- *$self->{ssl_ssl} = $ssl;
- $self;
-}
-
-# Delegate these calls to the Crypt::SSLeay::Conn object
-sub get_peer_certificate {
- my $self = shift;
- $self = $REAL{$self} || $self;
- *$self->{ssl_ssl}->get_peer_certificate(@_);
-}
-
-sub get_peer_verify {
- my $self = shift;
- $self = $REAL{$self} || $self;
- *$self->{ssl_peer_verify};
-}
-
-sub get_shared_ciphers {
- my $self = shift;
- $self = $REAL{$self} || $self;
- *$self->{ssl_ssl}->get_shared_ciphers(@_);
-}
-
-sub get_cipher {
- my $self = shift;
- $self = $REAL{$self} || $self;
- *$self->{ssl_ssl}->get_cipher(@_);
-}
-
-sub ssl_context {
- my $self = shift;
- $self = $REAL{$self} || $self;
- *$self->{ssl_ctx};
-}
-
-sub die_with_error {
- my $self=shift;
- my $reason=shift;
-
- my @err;
- while(my $err=Crypt::SSLeay::Err::get_error_string()) {
- push @err, $err;
- }
- croak("$reason: " . join( ' | ', @err ));
-}
-
-sub read {
- my $self = shift;
- $self = $REAL{$self} || $self;
-
- local $SIG{__DIE__} = \&Carp::confess;
- local $SIG{ALRM} = sub { $self->die_with_error("SSL read timeout") };
-
- _alarm_set($self->timeout);
- my $n = *$self->{ssl_ssl}->read(@_);
- _alarm_set(0);
- $self->die_with_error("read failed") if !defined $n;
-
- $n;
-}
-
-sub write {
- my $self = shift;
- $self = $REAL{$self} || $self;
- my $n = *$self->{ssl_ssl}->write(@_);
- $self->die_with_error("write failed") if !defined $n;
- $n;
-}
-
-*sysread = \&read;
-*syswrite = \&write;
-
-sub print {
- my $self = shift;
- $self = $REAL{$self} || $self;
- # should we care about $, and $\??
- # I think it is too expensive...
- $self->write(join("", @_));
-}
-
-sub printf {
- my $self = shift;
- $self = $REAL{$self} || $self;
- my $fmt = shift;
- $self->write(sprintf($fmt, @_));
-}
-
-sub getchunk {
- my $self = shift;
- $self = $REAL{$self} || $self;
- my $buf = ''; # warnings
- my $n = $self->read($buf, 32768);
- return unless defined $n;
- $buf;
-}
-
-# This is really inefficient, but we only use it for reading the proxy response
-# so that does not really matter.
-sub getline {
- my $self = shift;
- $self = $REAL{$self} || $self;
- my $val="";
- my $buf;
- do {
- $self->SUPER::recv($buf, 1);
- $val .= $buf;
- } until ($buf eq "\n");
-
- $val;
-}
-
-# XXX: no way to disable <$sock>?? (tied handle perhaps?)
-
-sub get_lwp_object {
- my $self = shift;
-
- my $lwp_object;
- my $i = 0;
- while(1) {
- package DB;
- my @stack = caller($i++);
- last unless @stack;
- my @stack_args = @DB::args;
- my $stack_object = $stack_args[0] || next;
- return $stack_object
- if ref($stack_object)
- and $stack_object->isa('LWP::UserAgent');
- }
- return undef;
-}
-
-sub send_useragent_to_proxy {
- if (my $val = shift) {
- $SEND_USERAGENT_TO_PROXY = $val;
- }
- return $SEND_USERAGENT_TO_PROXY;
-}
-
-sub proxy_connect_helper {
- my $self = shift;
-
- my $proxy = $self->proxy;
- my ($proxy_host, $proxy_port) = split(':',$proxy);
- $proxy_port || croak("no port given for proxy server $proxy");
-
- my $proxy_addr = gethostbyname($proxy_host);
- $proxy_addr || croak("can't resolve proxy server name: $proxy_host, $!");
-
- my($peer_port, $peer_addr) = (*$self->{ssl_peer_port}, *$self->{ssl_peer_addr});
- $peer_addr || croak("no peer addr given");
- $peer_port || croak("no peer port given");
-
- # see if the proxy should be bypassed
- my @no_proxy = split( /\s*,\s*/, $ENV{NO_PROXY} || $ENV{no_proxy} || '');
- my $is_proxied = 1;
- my $domain;
- for $domain (@no_proxy) {
- if ($peer_addr =~ /\Q$domain\E$/) {
- $is_proxied = 0;
- last;
- }
- }
-
- if ($is_proxied) {
- $self->SUPER::connect($proxy_port, $proxy_addr)
- || croak("proxy connect to $proxy_host:$proxy_port failed: $!");
- }
- else {
- $self->SUPER::connect($peer_port, $peer_addr)
- || croak("proxy bypass to $peer_addr:$peer_addr failed: $!");
- }
-
- my $connect_string;
- if ($ENV{"HTTPS_PROXY_USERNAME"} || $ENV{"HTTPS_PROXY_PASSWORD"}) {
- my $user = $ENV{"HTTPS_PROXY_USERNAME"};
- my $pass = $ENV{"HTTPS_PROXY_PASSWORD"};
-
- my $credentials = encode_base64("$user:$pass", "");
- $connect_string = join($CRLF,
- "CONNECT $peer_addr:$peer_port HTTP/1.0",
- "Proxy-authorization: Basic $credentials"
- );
- }
- else {
- $connect_string = "CONNECT $peer_addr:$peer_port HTTP/1.0";
- }
- $connect_string .= $CRLF;
-
- if (send_useragent_to_proxy()) {
- my $lwp_object = $self->get_lwp_object;
- if($lwp_object && $lwp_object->agent) {
- $connect_string .= "User-Agent: ".$lwp_object->agent.$CRLF;
- }
- }
-
- $connect_string .= $CRLF;
- $self->SUPER::send($connect_string);
- my $header;
- my $n = $self->SUPER::sysread($header, 8192);
- my $conn_ok = ($header =~ /HTTP\/\d+\.\d+\s+200\s+/is) ? 1 : 0;
-
- if (not $conn_ok) {
- croak("PROXY ERROR HEADER, could be non-SSL URL:\n$header");
- }
-
- $conn_ok;
-}
-
-# code adapted from LWP::UserAgent, with $ua->env_proxy API
-sub proxy {
- my $proxy_server = $ENV{HTTPS_PROXY} || $ENV{https_proxy};
- return unless $proxy_server;
-
- $proxy_server =~ s|\Ahttps?://||i;
- $proxy_server;
-}
-
-sub configure_certs {
- my $self = shift;
- my $ctx = *$self->{ssl_ctx};
-
- my $count = 0;
- for (qw(HTTPS_PKCS12_FILE HTTPS_CERT_FILE HTTPS_KEY_FILE)) {
- my $file = $ENV{$_};
- if ($file) {
- (-e $file) or croak("$file file does not exist: $!");
- (-r $file) or croak("$file file is not readable");
- $count++;
- if (/PKCS12/) {
- $count++;
- $ctx->use_pkcs12_file($file ,$ENV{'HTTPS_PKCS12_PASSWORD'}) || croak("failed to load $file: $!");
- last;
- }
- elsif (/CERT/) {
- $ctx->use_certificate_file($file ,1) || croak("failed to load $file: $!");
- }
- elsif (/KEY/) {
- $ctx->use_PrivateKey_file($file, 1) || croak("failed to load $file: $!");
- }
- else {
- croak("setting $_ not supported");
- }
- }
- }
-
- # if both configs are set, then verify them
- if ($count == 2) {
- if (! $ctx->check_private_key) {
- croak("Private key and certificate do not match");
- }
- }
-
- $count; # number of successful cert loads/checks
-}
-
-sub accept { shift->_unimpl("accept") }
-sub getc { shift->_unimpl("getc") }
-sub ungetc { shift->_unimpl("ungetc") }
-sub getlines { shift->_unimpl("getlines"); }
-
-sub _unimpl {
- my($self, $meth) = @_;
- croak("$meth not implemented for Net::SSL sockets");
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::SSL - support for Secure Sockets Layer
-
-=head1 METHODS
-
-=over 4
-
-=item new
-
-Creates a new C<Net::SSL> object.
-
-=item configure
-
-Configures a C<Net::SSL> socket for operation.
-
-=item configure_certs
-
-Sets up a certificate file to use for communicating with on
-the socket.
-
-=item connect
-
-=item die_with_error
-
-=item get_cipher
-
-=item get_lwp_object
-
-Walks up the caller stack and looks for something blessed into
-the C<LWP::UserAgent> namespace and returns it. Vaguely deprecated.
-
-=item get_peer_certificate
-
-Gets the peer certificate from the underlying C<Crypt::SSLeay::Conn>
-object.
-
-=item get_peer_verify
-
-=item get_shared_ciphers
-
-=item getchunk
-
-Attempts to read up to 32KiB of data from the socket. Returns
-C<undef> if nothing was read, otherwise returns the data as
-a scalar.
-
-=item getline
-
-Reads one character at a time until a newline is encountered,
-and returns the line, including the newline. Grossly
-inefficient.
-
-=item print
-
-Concatenates the input parameters and writes them to the socket.
-Does not honour C<$,> nor C<$/>. Returns the number of bytes written.
-
-=item printf
-
-Performs a C<sprintf> of the input parameters (thus, the first
-parameter must be the format), and writes the result to the socket.
-Returns the number of bytes written.
-
-=item proxy
-
-Returns the hostname of an https proxy server, as specified by the
-C<HTTPS_PROXY> environment variable.
-
-=item proxy_connect_helper
-
-Helps set up a connection through a proxy.
-
-=item read
-
-Performs a read on the socket and returns the result.
-
-=item ssl_context
-
-=item sysread
-
-Is an alias of C<read>.
-
-=item timeout
-
-Returns the timeout value of the socket as defined by the implementing
-class or 60 seconds by default.
-
-=item blocking
-
-Returns a boolean indicating whether the underlying socket is in
-blocking mode. By default, Net::SSL sockets are in blocking mode.
-
- $sock->blocking(0); # set to non-blocking mode
-
-This method simply calls the underlying C<blocking> method of the
-IO::Socket object.
-
-=item write
-
-Writes the parameters passed in (thus, a list) to the socket. Returns
-the number of bytes written.
-
-=item syswrite
-
-Is an alias of C<write>.
-
-=item accept
-
-Not yet implemented. Will die if called.
-
-=item getc
-
-Not yet implemented. Will die if called.
-
-=item getlines
-
-Not yet implemented. Will die if called.
-
-=item ungetc
-
-Not yet implemented. Will die if called.
-
-=item send_useragent_to_proxy
-
-By default (as of version 2.80 of C<Net::SSL> in the 0.54 distribution
-of Crypt::SSLeay), the user agent string is no longer sent to the
-proxy (but will continue to be sent to the remote host).
-
-The previous behaviour was of marginal benefit, and could cause
-fatal errors in certain scenarios (see CPAN bug #4759) and so no
-longer happens by default.
-
-To reinstate the old behaviour, call C<Net::SSL::send_useragent_to_proxy>
-with a true value (usually 1).
-
-=back
-
-=head1 DIAGNOSTICS
-
- "no port given for proxy server <proxy>"
-
-A proxy was specified for configuring a socket, but no port number
-was given. Ensure that the proxy is specified as a host:port pair,
-such as C<proxy.example.com:8086>.
-
- "configure certs failed: <contents of $@>; <contents of $!>"
-
- "proxy connect failed: <contents of $@>; <contents of $!>"
-
- "Connect failed: <contents of $@>; <contents of $!>"
-
-During connect().
-
-=head2 SEE ALSO
-
-=over 4
-
-=item IO::Socket::INET
-
-C<Net::SSL> is implemented by subclassing C<IO::Socket::INET>, hence
-methods not specifically overridden are defined by that package.
-
-=item Net::SSLeay
-
-A package that provides a Perl-level interface to the C<openssl>
-secure sockets layer library.
-
-=back
-
-=cut
-