diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Net/SSL.pm')
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Net/SSL.pm | 607 |
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 - |