vcs.maemo.org Git - pkg-perl/blob - deb-src/libnet-ssleay-perl/libnet-ssleay-perl-1.35/lib/Net/SSLeay/Handle.pm

   1 package Net::SSLeay::Handle;
   2
   3 require 5.005_03;
   4 use strict;
   5
   6 use Socket;
   7 use Net::SSLeay;
   8
   9 require Exporter;
  10
  11 =head1 NAME
  12
  13 Net::SSLeay::Handle - Perl module that lets SSL (HTTPS) sockets be
  14 handled as standard file handles.
  15
  16 =head1 SYNOPSIS
  17
  18   use Net::SSLeay::Handle qw/shutdown/;
  19   my ($host, $port) = ("localhost", 443);
  20
  21   tie(*SSL, "Net::SSLeay::Handle", $host, $port);
  22
  23   print SSL "GET / HTTP/1.0\r\n";
  24   shutdown(\*SSL, 1);
  25   print while (<SSL>);
  26   close SSL;
  27
  28 =head1 DESCRIPTION
  29
  30 Net::SSLeay::Handle allows you to request and receive HTTPS web pages
  31 using "old-fashion" file handles as in:
  32
  33     print SSL "GET / HTTP/1.0\r\n";
  34
  35 and
  36
  37     print while (<SSL>);
  38
  39 If you export the shutdown routine, then the only extra code that
  40 you need to add to your program is the tie function as in:
  41
  42     my $socket;
  43     if ($scheme eq "https") {
  44         tie(*S2, "Net::SSLeay::Handle", $host, $port);
  45         $socket = \*S2;
  46     else {
  47         $socket = Net::SSLeay::Handle->make_socket($host, $port);
  48     }
  49     print $socket $request_headers;
  50     ...
  51
  52 =cut
  53
  54 use vars qw(@ISA @EXPORT_OK $VERSION);
  55 @ISA = qw(Exporter);
  56 @EXPORT_OK = qw(shutdown);
  57 $VERSION = '0.61';
  58
  59 my $Initialized;       #-- only _initialize() once
  60 my $Debug = 0;         #-- pretty hokey
  61 my %Glob_Ref;          #-- used to make unique \*S names for versions < 5.6
  62
  63 #== Tie Handle Methods ========================================================
  64 #
  65 # see perldoc perltie for details.
  66 #
  67 #==============================================================================
  68
  69 sub TIEHANDLE {
  70     my ($class, $socket, $port) = @_;
  71     $Debug > 10 and print "TIEHANDLE(@{[join ', ', @_]})\n";
  72
  73     ref $socket eq "GLOB" or $socket = $class->make_socket($socket, $port);
  74
  75     $class->_initialize();
  76
  77     my $ctx = Net::SSLeay::CTX_new() or die_now("Failed to create SSL_CTX $!");
  78     my $ssl = Net::SSLeay::new($ctx) or die_now("Failed to create SSL $!");
  79
  80     my $fileno = fileno($socket);
  81
  82   Net::SSLeay::set_fd($ssl, $fileno);   # Must use fileno
  83
  84     my $resp = Net::SSLeay::connect($ssl);
  85
  86     $Debug and print "Cipher '" . Net::SSLeay::get_cipher($ssl) . "'\n";
  87
  88         my $self = bless {
  89         ssl    => $ssl,
  90         ctx    => $ctx,
  91         socket => $socket,
  92         fileno => $fileno,
  93     }, $class;
  94
  95     return $self;
  96 }
  97
  98 sub PRINT {
  99     my $self = shift;
 100
 101     my $ssl  = _get_ssl($self);
 102     my $resp = 0;
 103     for my $msg (@_) {
 104         defined $msg or last;
 105         $resp = Net::SSLeay::write($ssl, $msg) or last;
 106     }
 107     return $resp;
 108 }
 109
 110 sub READLINE {
 111     my $self = shift;
 112     my $ssl  = _get_ssl($self);
 113         if (wantarray) {
 114                 my @lines;
 115                 while (my $line = Net::SSLeay::ssl_read_until($ssl)) {
 116                         push @lines, $line;
 117                 }
 118                 return @lines;
 119         } else {
 120                 my $line = Net::SSLeay::ssl_read_until($ssl);
 121                 return $line ? $line : undef;
 122         }
 123 }
 124
 125 sub READ {
 126     my ($self, $buf, $len, $offset) = \ (@_);
 127     my $ssl = _get_ssl($$self);
 128     defined($$offset) or
 129       return length($$buf = Net::SSLeay::ssl_read_all($ssl, $$len));
 130
 131     defined(my $read = Net::SSLeay::ssl_read_all($ssl, $$len))
 132       or return undef;
 133
 134     my $buf_len = length($$buf);
 135     $$offset > $buf_len and $$buf .= chr(0) x ($$offset - $buf_len);
 136     substr($$buf, $$offset) = $read;
 137     return length($read);
 138 }
 139
 140 sub WRITE {
 141     my $self = shift;
 142     my ($buf, $len, $offset) = @_;
 143     $offset = 0 unless defined $offset;
 144
 145     # Return number of characters written.
 146     my $ssl  = $self->_get_ssl();
 147     return $len if Net::SSLeay::write($ssl, substr($buf, $offset, $len));
 148     return undef;
 149 }
 150
 151 sub CLOSE {
 152     my $self = shift;
 153     my $fileno = $self->{fileno};
 154     $Debug > 10 and print "close($fileno)\n";
 155     Net::SSLeay::free ($self->{ssl});
 156     Net::SSLeay::CTX_free ($self->{ctx});
 157     close $self->{socket};
 158 }
 159
 160 sub FILENO  { $_[0]->{fileno} }
 161
 162
 163 =head1 FUNCTIONS
 164
 165 =over
 166
 167 =item shutdown
 168
 169   shutdown(\*SOCKET, $mode)
 170
 171 Calls to the main shutdown() don't work with tied sockets created with this
 172 module.  This shutdown should be able to distinquish between tied and untied
 173 sockets and do the right thing.
 174
 175 =cut
 176
 177 sub shutdown {
 178     my ($obj, @params) = @_;
 179
 180         my $socket = UNIVERSAL::isa($obj, 'Net::SSLeay::Handle') ?
 181                 $obj->{socket} : $obj;
 182     return shutdown($socket, @params);
 183 }
 184
 185 =item debug
 186
 187   my $debug = Net::SSLeay::Handle->debug()
 188   Net::SSLeay::Handle->debug(1)
 189
 190 Get/set debuging mode. Always returns the debug value before the function call.
 191 if an additional argument is given the debug option will be set to this value.
 192
 193 =cut
 194
 195 sub debug {
 196     my ($class, $debug) = @_;
 197     my $old_debug = $Debug;
 198     @_ >1 and $Debug = $debug || 0;
 199     return $old_debug;
 200 }
 201
 202 #=== Internal Methods =========================================================
 203
 204 =item make_socket
 205
 206   my $sock = Net::SSLeay::Handle->make_socket($host, $port);
 207
 208 Creates a socket that is connected to $post using $port. It uses
 209 $Net::SSLeay::proxyhost and proxyport if set and authentificates itself against
 210 this proxy depending on $Net::SSLeay::proxyauth. It also turns autoflush on for
 211 the created socket.
 212
 213 =cut
 214
 215 sub make_socket {
 216     my ($class, $host, $port) = @_;
 217     $Debug > 10 and print "_make_socket(@{[join ', ', @_]})\n";
 218     $host ||= 'localhost';
 219     $port ||= 443;
 220
 221     my $phost = $Net::SSLeay::proxyhost;
 222     my $pport = $Net::SSLeay::proxyhost ? $Net::SSLeay::proxyport : $port;
 223
 224     my $dest_ip     = gethostbyname($phost || $host);
 225     my $host_params = sockaddr_in($pport, $dest_ip);
 226     my $socket = $^V ? undef : $class->_glob_ref("$host:$port");
 227
 228     socket($socket, &PF_INET(), &SOCK_STREAM(), 0) or die "socket: $!";
 229     connect($socket, $host_params)                 or die "connect: $!";
 230
 231     my $old_select = select($socket); $| = 1; select($old_select);
 232     $phost and do {
 233         my $auth = $Net::SSLeay::proxyauth;
 234         my $CRLF = $Net::SSLeay::CRLF;
 235         print $socket "CONNECT $host:$port HTTP/1.0$auth$CRLF$CRLF";
 236         my $line = <$socket>;
 237     };
 238     return $socket;
 239 }
 240
 241 =back
 242
 243 =cut
 244
 245 #--- _glob_ref($strings) ------------------------------------------------------
 246 #
 247 # Create a unique namespace name and return a glob ref to it.  Would be great
 248 # to use the fileno but need this before we get back the fileno.
 249 # NEED TO LOCK THIS ROUTINE IF USING THREADS. (but it is only used for
 250 # versions < 5.6 :)
 251 #------------------------------------------------------------------------------
 252
 253 sub _glob_ref {
 254     my $class = shift;
 255     my $preamb = join("", @_) || "_glob_ref";
 256     my $num = ++$Glob_Ref{$preamb};
 257     my $name = "$preamb:$num";
 258     no strict 'refs';
 259     my $glob_ref = \*$name;
 260     use strict 'refs';
 261
 262     $Debug and do {
 263         print "GLOB_REF $preamb\n";
 264         while (my ($k, $v) = each %Glob_Ref) {print "$k = $v\n"}
 265         print "\n";
 266     };
 267
 268     return $glob_ref;
 269 }
 270
 271 sub _initialize {
 272     $Initialized++ and return;
 273   Net::SSLeay::load_error_strings();
 274   Net::SSLeay::SSLeay_add_ssl_algorithms();
 275   Net::SSLeay::randomize();
 276 }
 277
 278 sub __dummy {
 279     my $host = $Net::SSLeay::proxyhost;
 280     my $port = $Net::SSLeay::proxyport;
 281     my $auth = $Net::SSLeay::proxyauth;
 282 }
 283
 284 #--- _get_self($socket) -------------------------------------------------------
 285 # Returns a hash containing attributes for $socket (= \*SOMETHING) based
 286 # on fileno($socket).  Will return undef if $socket was not created here.
 287 #------------------------------------------------------------------------------
 288
 289 sub _get_self { return $_[0]; }
 290
 291 #--- _get_ssl($socket) --------------------------------------------------------
 292 # Returns a the "ssl" attribute for $socket (= \*SOMETHING) based
 293 # on fileno($socket).  Will cause a warning and return undef if $socket was not
 294 # created here.
 295 #------------------------------------------------------------------------------
 296
 297 sub _get_ssl {
 298     return $_[0]->{ssl};
 299 }
 300
 301 1;
 302
 303 __END__
 304
 305 =head2 USING EXISTING SOCKETS
 306
 307 One of the motivations for writing this module was to avoid
 308 duplicating socket creation code (which is mostly error handling).
 309 The calls to tie() above where it is passed a $host and $port is
 310 provided for convenience testing.  If you already have a socket
 311 connected to the right host and port, S1, then you can do something
 312 like:
 313
 314     my $socket \*S1;
 315     if ($scheme eq "https") {
 316         tie(*S2, "Net::SSLeay::Handle", $socket);
 317         $socket = \*S2;
 318     }
 319     my $last_sel = select($socket); $| = 1; select($last_sel);
 320     print $socket $request_headers;
 321     ...
 322
 323 Note: As far as I know you must be careful with the globs in the tie()
 324 function.  The first parameter must be a glob (*SOMETHING) and the
 325 last parameter must be a reference to a glob (\*SOMETHING_ELSE) or a
 326 scaler that was assigned to a reference to a glob (as in the example
 327 above)
 328
 329 Also, the two globs must be different.  When I tried to use the same
 330 glob, I got a core dump.
 331
 332 =head2 EXPORT
 333
 334 None by default.
 335
 336 You can export the shutdown() function.
 337
 338 It is suggested that you do export shutdown() or use the fully
 339 qualified Net::SSLeay::Handle::shutdown() function to shutdown SSL
 340 sockets.  It should be smart enough to distinguish between SSL and
 341 non-SSL sockets and do the right thing.
 342
 343 =head1 EXAMPLES
 344
 345   use Net::SSLeay::Handle qw/shutdown/;
 346   my ($host, $port) = ("localhost", 443);
 347
 348   tie(*SSL, "Net::SSLeay::Handle", $host, $port);
 349
 350   print SSL "GET / HTTP/1.0\r\n";
 351   shutdown(\*SSL, 1);
 352   print while (<SSL>);
 353   close SSL;
 354
 355 =head1 TODO
 356
 357 Better error handling.  Callback routine?
 358
 359 =head1 CAVEATS
 360
 361 Tying to a file handle is a little tricky (for me at least).
 362
 363 The first parameter to tie() must be a glob (*SOMETHING) and the last
 364 parameter must be a reference to a glob (\*SOMETHING_ELSE) or a scaler
 365 that was assigned to a reference to a glob ($s = \*SOMETHING_ELSE).
 366 Also, the two globs must be different.  When I tried to use the same
 367 glob, I got a core dump.
 368
 369 I was able to associate attributes to globs created by this module
 370 (like *SSL above) by making a hash of hashes keyed by the file head1.
 371
 372 Support for old perls may not be 100%. If in trouble try 5.6.0 or
 373 newer.
 374
 375 =head1 CHANGES
 376
 377 Please see Net-SSLeay-Handle-0.50/Changes file.
 378
 379 =head1 KNOWN BUGS
 380
 381 If you let this module construct sockets for you with Perl versions
 382 below v.5.6 then there is a slight memory leak.  Other upgrade your
 383 Perl, or create the sockets yourself.  The leak was created to let
 384 these older versions of Perl access more than one Handle at a time.
 385
 386 =head1 AUTHOR
 387
 388 Jim Bowlin jbowlin@linklint.org
 389
 390 =head1 SEE ALSO
 391
 392 Net::SSLeay, perl(1), http://openssl.org/
 393
 394 =cut