lib/Net/HTTPS/Any.pm

   1 package Net::HTTPS::Any;
   2
   3 use warnings;
   4 use strict;
   5 use base qw( Exporter );
   6 use vars qw(@EXPORT_OK $ssl_module $skip_NetSSLeay);
   7 use URI::Escape;
   8 use Tie::IxHash;
   9
  10 @EXPORT_OK = qw( https_get https_post );
  11
  12 BEGIN {
  13
  14     $ssl_module = '';
  15
  16     eval {
  17         die if defined($skip_NetSSLeay) && $skip_NetSSLeay;
  18         require Net::SSLeay;
  19         Net::SSLeay->VERSION(1.30);
  20
  21         #import Net::SSLeay
  22         #  qw(get_https post_https make_form make_headers);
  23         $ssl_module = 'Net::SSLeay';
  24     };
  25
  26     if ($@) {
  27         eval {
  28             require LWP::UserAgent;
  29             require HTTP::Request::Common;
  30             require Crypt::SSLeay;
  31
  32             #import HTTP::Request::Common qw(GET POST);
  33             $ssl_module = 'Crypt::SSLeay';
  34         };
  35     }
  36
  37     unless ($ssl_module) {
  38         die "One of Net::SSLeay (v1.30 or later)"
  39           . " or Crypt::SSLeay (+LWP) is required";
  40     }
  41
  42 }
  43
  44 =head1 NAME
  45
  46 Net::HTTPS::Any - Simple HTTPS class using whichever underlying SSL module is available
  47
  48 =cut
  49
  50 our $VERSION = '0.10';
  51
  52 =head1 SYNOPSIS
  53
  54   use Net::HTTPS::Any qw(https_get https_post);
  55
  56   ( $page, $response, %reply_headers )
  57       = https_get(
  58                    { 'host' => 'www.fortify.net',
  59                      'port' => 443,
  60                      'path' => '/sslcheck.html',
  61                    },
  62                  );
  63
  64   ( $page, $response, %reply_headers )
  65       = https_post(
  66                     'host' => 'www.google.com',
  67                     'port' => 443,
  68                     'path' => '/accounts/ServiceLoginAuth',
  69                     'args' => { 'field' => 'value' },
  70                     #'args' => [ 'field'=>'value' ], #order preserved
  71                   );
  72
  73   #...
  74
  75 =head1 DESCRIPTION
  76
  77 This is a simple wrapper around either of the two available SSL
  78 modules.  It offers a unified API for sending GET and POST requests over HTTPS
  79 and receiving responses.
  80
  81 It depends on Net::SSLeay _or_ ( Crypt::SSLeay and LWP::UserAgent ).
  82
  83 =head1 WHY THIS MODULE
  84
  85 If you just want to write something that speaks HTTPS, you don't need this
  86 module.  Just go ahead and use whichever of the two modules is good for you.
  87 Don't worry about it.
  88
  89 On the other hand, if you are a CPAN author or distribute a Perl application,
  90 especially if you aim to support multiple OSes/disributions, using this module
  91 for speaking HTTPS may make things easier on your users.  It allows your code
  92 to be used with either SSL implementation.
  93
  94 =head1 FUNCTIONS
  95
  96 =head2 https_get HASHREF | FIELD => VALUE, ...
  97
  98 Accepts parameters as either a hashref or a list of fields and values.
  99
 100 Parameters are:
 101
 102 =over 4
 103
 104 =item host
 105
 106 =item port
 107
 108 =item path
 109
 110 =item headers (hashref)
 111
 112 For example: { 'X-Header1' => 'value', ... }
 113
 114 =cut
 115
 116 # =item Content-Type
 117 #
 118 # Defaults to "application/x-www-form-urlencoded" if not specified.
 119
 120 =item args
 121
 122 CGI arguments, eitehr as a hashref or a listref.  In the latter case, ordering
 123 is preserved (see L<Tie::IxHash> to do so when passing a hashref).
 124
 125 =item debug
 126
 127 Set true to enable debugging.
 128
 129 =back
 130
 131 Returns a list consisting of the page content as a string, the HTTP
 132 response code and message (i.e. "200 OK" or "404 Not Found"), and a list of
 133 key/value pairs representing the HTTP response headers.
 134
 135 =cut
 136
 137 sub https_get {
 138     my $opts = ref($_[0]) ? shift : { @_ }; #hashref or list
 139
 140     # accept a hashref or a list (keep it ordered)
 141     my $post_data = {}; # technically get_data, pedant
 142     if (      exists($opts->{'args'}) && ref($opts->{'args'}) eq 'HASH'  ) {
 143         $post_data = $opts->{'args'};
 144     } elsif ( exists($opts->{'args'}) && ref($opts->{'args'}) eq 'ARRAY' ) {
 145         tie my %hash, 'Tie::IxHash', @{ $opts->{'args'} };
 146         $post_data = \%hash;
 147     }
 148
 149     $opts->{'port'} ||= 443;
 150     #$opts->{"Content-Type"} ||= "application/x-www-form-urlencoded";
 151
 152     ### XXX referer!!!
 153     my %headers = ();
 154     if ( ref( $opts->{headers} ) eq "HASH" ) {
 155         %headers = %{ $opts->{headers} };
 156     }
 157     $headers{'Host'} ||= $opts->{'host'};
 158
 159     my $path = $opts->{'path'};
 160     if ( keys %$post_data ) {
 161         $path .= '?'
 162           . join( ';',
 163             map { uri_escape($_) . '=' . uri_escape( $post_data->{$_} ) }
 164               keys %$post_data );
 165     }
 166
 167     if ( $ssl_module eq 'Net::SSLeay' ) {
 168
 169         no warnings 'uninitialized';
 170
 171         import Net::SSLeay qw(get_https make_headers);
 172         my $headers = make_headers(%headers);
 173
 174         $Net::SSLeay::trace = $opts->{'debug'}
 175           if exists $opts->{'debug'} && $opts->{'debug'};
 176
 177         my( $res_page, $res_code, @res_headers ) =
 178           get_https( $opts->{'host'},
 179                      $opts->{'port'},
 180                      $path,
 181                      $headers,
 182                      #"",
 183                      #$opts->{"Content-Type"},
 184                    );
 185
 186         $res_code =~ /^(HTTP\S+ )?(.*)/ and $res_code = $2;
 187
 188         return ( $res_page, $res_code, @res_headers );
 189
 190     } elsif ( $ssl_module eq 'Crypt::SSLeay' ) {
 191
 192         import HTTP::Request::Common qw(GET);
 193
 194         my $url = 'https://' . $opts->{'host'};
 195         $url .= ':' . $opts->{'port'}
 196           unless $opts->{'port'} == 443;
 197         $url .= "/$path";
 198
 199         my $ua = new LWP::UserAgent;
 200         foreach my $hdr ( keys %headers ) {
 201             $ua->default_header( $hdr => $headers{$hdr} );
 202         }
 203         $ENV{HTTPS_DEBUG} = $opts->{'debug'} if exists $opts->{'debug'};
 204         my $res = $ua->request( GET($url) );
 205
 206         my @res_headers = map { $_ => $res->header($_) }
 207                               $res->header_field_names;
 208
 209         return ( $res->content, $res->code. ' '. $res->message, @res_headers );
 210
 211     } else {
 212         die "unknown SSL module $ssl_module";
 213     }
 214
 215 }
 216
 217 =head2 https_post HASHREF | FIELD => VALUE, ...
 218
 219 Accepts parameters as either a hashref or a list of fields and values.
 220
 221 Parameters are:
 222
 223 =over 4
 224
 225 =item host
 226
 227 =item port
 228
 229 =item path
 230
 231 =item headers (hashref)
 232
 233 For example: { 'X-Header1' => 'value', ... }
 234
 235 =item Content-Type
 236
 237 Defaults to "application/x-www-form-urlencoded" if not specified.
 238
 239 =item args
 240
 241 CGI arguments, eitehr as a hashref or a listref.  In the latter case, ordering
 242 is preserved (see L<Tie::IxHash> to do so when passing a hashref).
 243
 244 =item content
 245
 246 Raw content (overrides args).  A simple scalar containing the raw content.
 247
 248 =item debug
 249
 250 Set true to enable debugging in the underlying SSL module.
 251
 252 =back
 253
 254 Returns a list consisting of the page content as a string, the HTTP
 255 response code and message (i.e. "200 OK" or "404 Not Found"), and a list of
 256 key/value pairs representing the HTTP response headers.
 257
 258 =cut
 259
 260 sub https_post {
 261     my $opts = ref($_[0]) ? shift : { @_ }; #hashref or list
 262
 263     # accept a hashref or a list (keep it ordered).  or a scalar of content.
 264     my $post_data = '';
 265     if (      exists($opts->{'args'}) && ref($opts->{'args'}) eq 'HASH'  ) {
 266         $post_data = $opts->{'args'};
 267     } elsif ( exists($opts->{'args'}) && ref($opts->{'args'}) eq 'ARRAY' ) {
 268         tie my %hash, 'Tie::IxHash', @{ $opts->{'args'} };
 269         $post_data = \%hash;
 270     }
 271     if ( exists $opts->{'content'} ) {
 272         $post_data = $opts->{'content'};
 273     }
 274
 275     $opts->{'port'} ||= 443;
 276     $opts->{"Content-Type"} ||= "application/x-www-form-urlencoded";
 277
 278     ### XXX referer!!!
 279     my %headers;
 280     if ( ref( $opts->{headers} ) eq "HASH" ) {
 281         %headers = %{ $opts->{headers} };
 282     }
 283     $headers{'Host'} ||= $opts->{'host'};
 284
 285     if ( $ssl_module eq 'Net::SSLeay' ) {
 286
 287         no warnings 'uninitialized';
 288
 289         import Net::SSLeay qw(post_https make_headers make_form);
 290         my $headers = make_headers(%headers);
 291
 292         $Net::SSLeay::trace = $opts->{'debug'}
 293           if exists $opts->{'debug'} && $opts->{'debug'};
 294
 295         my $raw_data = ref($post_data) ? make_form(%$post_data) : $post_data;
 296
 297         $Net::SSLeay::trace = $opts->{'debug'}
 298           if exists $opts->{'debug'} && $opts->{'debug'};
 299
 300         my( $res_page, $res_code, @res_headers ) =
 301           post_https( $opts->{'host'},
 302                       $opts->{'port'},
 303                       $opts->{'path'},
 304                       $headers,
 305                       $raw_data,
 306                       $opts->{"Content-Type"},
 307                     );
 308
 309         $res_code =~ /^(HTTP\S+ )?(.*)/ and $res_code = $2;
 310
 311         return ( $res_page, $res_code, @res_headers );
 312
 313     } elsif ( $ssl_module eq 'Crypt::SSLeay' ) {
 314
 315         import HTTP::Request::Common qw(POST);
 316
 317         my $url = 'https://' . $opts->{'host'};
 318         $url .= ':' . $opts->{'port'}
 319           unless $opts->{'port'} == 443;
 320         $url .= $opts->{'path'};
 321
 322         my $ua = new LWP::UserAgent;
 323         foreach my $hdr ( keys %headers ) {
 324             $ua->default_header( $hdr => $headers{$hdr} );
 325         }
 326
 327         $ENV{HTTPS_DEBUG} = $opts->{'debug'} if exists $opts->{'debug'};
 328
 329         my $res;
 330         if ( ref($post_data) ) {
 331             $res = $ua->request( POST( $url, [%$post_data] ) );
 332         }
 333         else {
 334             my $req = new HTTP::Request( 'POST' => $url );
 335             $req->content_type( $opts->{"Content-Type"} );
 336             $req->content($post_data);
 337             $res = $ua->request($req);
 338         }
 339
 340         my @res_headers = map { $_ => $res->header($_) }
 341                               $res->header_field_names;
 342
 343         return ( $res->content, $res->code. ' '. $res->message, @res_headers );
 344
 345     } else {
 346         die "unknown SSL module $ssl_module";
 347     }
 348
 349 }
 350
 351 =head1 AUTHOR
 352
 353 Ivan Kohler, C<< <ivan-net-https-any at freeside.biz> >>
 354
 355 =head1 BUGS
 356
 357 Please report any bugs or feature requests to C<bug-net-https-any at rt.cpan.org>, or through
 358 the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-HTTPS-Any>.  I will be notified, and then you'll
 359 automatically be notified of progress on your bug as I make changes.
 360
 361 =head1 SUPPORT
 362
 363 You can find documentation for this module with the perldoc command.
 364
 365     perldoc Net::HTTPS::Any
 366
 367 You can also look for information at:
 368
 369 =over 4
 370
 371 =item * RT: CPAN's request tracker
 372
 373 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-HTTPS-Any>
 374
 375 =item * AnnoCPAN: Annotated CPAN documentation
 376
 377 L<http://annocpan.org/dist/Net-HTTPS-Any>
 378
 379 =item * CPAN Ratings
 380
 381 L<http://cpanratings.perl.org/d/Net-HTTPS-Any>
 382
 383 =item * Search CPAN
 384
 385 L<http://search.cpan.org/dist/Net-HTTPS-Any>
 386
 387 =back
 388
 389 =head1 COPYRIGHT & LICENSE
 390
 391 Copyright 2008-2010 Freeside Internet Services, Inc. (http://freeside.biz/)
 392 All rights reserved.
 393
 394 This program is free software; you can redistribute it and/or modify it
 395 under the same terms as Perl itself.
 396
 397 =cut
 398
 399 1;