lib/Net/HTTPS/Any.pm

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