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' => 'secure.sisd.com',
  59                      'port' => 443,
  60                      'path' => '/freeside/index.html',
  61                      'args' => { 'field' => 'value' },
  62                      #'args' => [ 'field'=>'value' ], #order preserved
  63                    },
  64                  );
  65
  66   ( $page, $response, %reply_headers )
  67       = https_post(
  68                     'host' => 'secure.sisd.com',
  69                     'port' => 443,
  70                     'path' => '/freeside/index.html',
  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         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         import Net::SSLeay qw(post_https make_headers make_form);
 288         my $headers = make_headers(%headers);
 289
 290         if ($opts->{debug}) {
 291             no warnings 'uninitialized';
 292             $Net::SSLeay::trace = $opts->{debug};
 293         }
 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;