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