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


line stmt bran cond sub pod time code
1             package Net::SSLeay::Handle;
2              
3 1     1   49181 use 5.8.1;
  1         2  
4              
5 1     1   4 use strict;
  1         1  
  1         24  
6              
7 1     1   420 use Socket;
  1         2672  
  1         300  
8 1     1   411 use Net::SSLeay;
  1         2  
  1         50  
9              
10             require Exporter;
11              
12             =encoding utf-8
13              
14             =head1 NAME
15              
16             Net::SSLeay::Handle - Perl module that lets SSL (HTTPS) sockets be
17             handled as standard file handles.
18              
19             =head1 SYNOPSIS
20              
21             use Net::SSLeay::Handle qw/shutdown/;
22             my ($host, $port) = ("localhost", 443);
23              
24             tie(*SSL, "Net::SSLeay::Handle", $host, $port);
25              
26             print SSL "GET / HTTP/1.0\r\n";
27             shutdown(\*SSL, 1);
28             print while ();
29             close SSL;
30              
31             =head1 DESCRIPTION
32              
33             Net::SSLeay::Handle allows you to request and receive HTTPS web pages
34             using "old-fashion" file handles as in:
35              
36             print SSL "GET / HTTP/1.0\r\n";
37              
38             and
39              
40             print while ();
41              
42             If you export the shutdown routine, then the only extra code that
43             you need to add to your program is the tie function as in:
44              
45             my $socket;
46             if ($scheme eq "https") {
47             tie(*S2, "Net::SSLeay::Handle", $host, $port);
48             $socket = \*S2;
49             else {
50             $socket = Net::SSLeay::Handle->make_socket($host, $port);
51             }
52             print $socket $request_headers;
53             ...
54              
55             =cut
56              
57 1     1   5 use vars qw(@ISA @EXPORT_OK $VERSION);
  1         2  
  1         982  
58             @ISA = qw(Exporter);
59             @EXPORT_OK = qw(shutdown);
60             $VERSION = '1.93_01';
61              
62             my $Initialized; #-- only _initialize() once
63             my $Debug = 0; #-- pretty hokey
64              
65             #== Tie Handle Methods ========================================================
66             #
67             # see perldoc perltie for details.
68             #
69             #==============================================================================
70              
71             sub TIEHANDLE {
72 0     0     my ($class, $socket, $port) = @_;
73 0 0         $Debug > 10 and print "TIEHANDLE(@{[join ', ', @_]})\n";
  0            
74              
75 0 0         ref $socket eq "GLOB" or $socket = $class->make_socket($socket, $port);
76              
77 0           $class->_initialize();
78              
79 0 0         my $ctx = Net::SSLeay::CTX_new() or die_now("Failed to create SSL_CTX $!");
80 0 0         my $ssl = Net::SSLeay::new($ctx) or die_now("Failed to create SSL $!");
81              
82 0           my $fileno = fileno($socket);
83              
84 0           Net::SSLeay::set_fd($ssl, $fileno); # Must use fileno
85              
86 0           my $resp = Net::SSLeay::connect($ssl);
87              
88 0 0         $Debug and print "Cipher '" . Net::SSLeay::get_cipher($ssl) . "'\n";
89              
90 0           my $self = bless {
91             ssl => $ssl,
92             ctx => $ctx,
93             socket => $socket,
94             fileno => $fileno,
95             }, $class;
96              
97 0           return $self;
98             }
99              
100             sub PRINT {
101 0     0     my $self = shift;
102              
103 0           my $ssl = _get_ssl($self);
104 0           my $resp = 0;
105 0           for my $msg (@_) {
106 0 0         defined $msg or last;
107 0 0         $resp = Net::SSLeay::write($ssl, $msg) or last;
108             }
109 0           return $resp;
110             }
111              
112             sub READLINE {
113 0     0     my $self = shift;
114 0           my $ssl = _get_ssl($self);
115 0 0         if (wantarray) {
116 0           my @lines;
117 0           while (my $line = Net::SSLeay::ssl_read_until($ssl)) {
118 0           push @lines, $line;
119             }
120 0           return @lines;
121             } else {
122 0           my $line = Net::SSLeay::ssl_read_until($ssl);
123 0 0         return $line ? $line : undef;
124             }
125             }
126              
127             sub READ {
128 0     0     my ($self, $buf, $len, $offset) = \ (@_);
129 0           my $ssl = _get_ssl($$self);
130 0 0         defined($$offset) or
131             return length($$buf = Net::SSLeay::ssl_read_all($ssl, $$len));
132              
133 0 0         defined(my $read = Net::SSLeay::ssl_read_all($ssl, $$len))
134             or return undef;
135              
136 0           my $buf_len = length($$buf);
137 0 0         $$offset > $buf_len and $$buf .= chr(0) x ($$offset - $buf_len);
138 0           substr($$buf, $$offset) = $read;
139 0           return length($read);
140             }
141              
142             sub WRITE {
143 0     0     my $self = shift;
144 0           my ($buf, $len, $offset) = @_;
145 0 0         $offset = 0 unless defined $offset;
146              
147             # Return number of characters written.
148 0           my $ssl = $self->_get_ssl();
149 0 0         return $len if Net::SSLeay::write($ssl, substr($buf, $offset, $len));
150 0           return undef;
151             }
152              
153             sub CLOSE {
154 0     0     my $self = shift;
155 0           my $fileno = $self->{fileno};
156 0 0         $Debug > 10 and print "close($fileno)\n";
157 0           Net::SSLeay::free ($self->{ssl});
158 0           Net::SSLeay::CTX_free ($self->{ctx});
159 0           close $self->{socket};
160             }
161              
162 0     0     sub FILENO { $_[0]->{fileno} }
163              
164              
165             =head1 FUNCTIONS
166              
167             =over
168              
169             =item shutdown
170              
171             shutdown(\*SOCKET, $mode)
172              
173             Calls to the main shutdown() don't work with tied sockets created with this
174             module. This shutdown should be able to distinquish between tied and untied
175             sockets and do the right thing.
176              
177             =cut
178              
179             sub shutdown {
180 0     0 1   my ($obj, @params) = @_;
181              
182             my $socket = UNIVERSAL::isa($obj, 'Net::SSLeay::Handle') ?
183 0 0         $obj->{socket} : $obj;
184 0           return shutdown($socket, @params);
185             }
186              
187             =item debug
188              
189             my $debug = Net::SSLeay::Handle->debug()
190             Net::SSLeay::Handle->debug(1)
191              
192             Get/set debugging mode. Always returns the debug value before the function call.
193             if an additional argument is given the debug option will be set to this value.
194              
195             =cut
196              
197             sub debug {
198 0     0 1   my ($class, $debug) = @_;
199 0           my $old_debug = $Debug;
200 0 0 0       @_ >1 and $Debug = $debug || 0;
201 0           return $old_debug;
202             }
203              
204             #=== Internal Methods =========================================================
205              
206             =item make_socket
207              
208             my $sock = Net::SSLeay::Handle->make_socket($host, $port);
209              
210             Creates a socket that is connected to $post using $port. It uses
211             $Net::SSLeay::proxyhost and proxyport if set and authentificates itself against
212             this proxy depending on $Net::SSLeay::proxyauth. It also turns autoflush on for
213             the created socket.
214              
215             =cut
216              
217             sub make_socket {
218 0     0 1   my ($class, $host, $port) = @_;
219 0 0         $Debug > 10 and print "_make_socket(@{[join ', ', @_]})\n";
  0            
220 0   0       $host ||= 'localhost';
221 0   0       $port ||= 443;
222              
223 0           my $phost = $Net::SSLeay::proxyhost;
224 0 0         my $pport = $Net::SSLeay::proxyhost ? $Net::SSLeay::proxyport : $port;
225              
226 0   0       my $dest_ip = gethostbyname($phost || $host);
227 0           my $host_params = sockaddr_in($pport, $dest_ip);
228            
229 0 0         socket(my $socket, &PF_INET(), &SOCK_STREAM(), 0) or die "socket: $!";
230 0 0         connect($socket, $host_params) or die "connect: $!";
231              
232 0           my $old_select = select($socket); $| = 1; select($old_select);
  0            
  0            
233 0 0         $phost and do {
234 0           my $auth = $Net::SSLeay::proxyauth;
235 0           my $CRLF = $Net::SSLeay::CRLF;
236 0           print $socket "CONNECT $host:$port HTTP/1.0$auth$CRLF$CRLF";
237 0           my $line = <$socket>;
238             };
239 0           return $socket;
240             }
241              
242             =back
243              
244             =cut
245              
246             sub _initialize {
247 0 0   0     $Initialized++ and return;
248 0           Net::SSLeay::load_error_strings();
249 0           Net::SSLeay::SSLeay_add_ssl_algorithms();
250 0           Net::SSLeay::randomize();
251             }
252              
253             sub __dummy {
254 0     0     my $host = $Net::SSLeay::proxyhost;
255 0           my $port = $Net::SSLeay::proxyport;
256 0           my $auth = $Net::SSLeay::proxyauth;
257             }
258              
259             #--- _get_self($socket) -------------------------------------------------------
260             # Returns a hash containing attributes for $socket (= \*SOMETHING) based
261             # on fileno($socket). Will return undef if $socket was not created here.
262             #------------------------------------------------------------------------------
263              
264 0     0     sub _get_self { return $_[0]; }
265              
266             #--- _get_ssl($socket) --------------------------------------------------------
267             # Returns a the "ssl" attribute for $socket (= \*SOMETHING) based
268             # on fileno($socket). Will cause a warning and return undef if $socket was not
269             # created here.
270             #------------------------------------------------------------------------------
271              
272             sub _get_ssl {
273 0     0     return $_[0]->{ssl};
274             }
275              
276             1;
277              
278             __END__