File Coverage

blib/lib/OAuth/Lite2/Agent/Strict.pm
Criterion Covered Total %
statement 12 26 46.1
branch 0 22 0.0
condition n/a
subroutine 4 5 80.0
pod 1 1 100.0
total 17 54 31.4


line stmt bran cond sub pod time code
1             package OAuth::Lite2::Agent::Strict;
2              
3 1     1   1055 use strict;
  1         2  
  1         30  
4 1     1   6 use warnings;
  1         2  
  1         25  
5              
6 1     1   5 use parent 'OAuth::Lite2::Agent';
  1         1  
  1         5  
7 1     1   474 use OAuth::Lite2::Client::Error;
  1         2  
  1         403  
8              
9             =head1 NAME
10              
11             OAuth::Lite2::Agent::Strict - Preset User Agent class for strict SSL
12              
13             =head1 SYNOPSIS
14              
15             my $client = OAuth::Lite2::Client::WebApp->new(
16             ..., # other params
17             agent => OAuth::Lite2::Client::Agent::Strict->new(
18             https_version => $https_version,
19             ..., # https parameters
20             ),
21             );
22              
23             =head1 DESCRIPTION
24              
25             This module is one of preset user-agent class.
26             This is useful when you want check the SSL strictly.
27              
28             =head1 METHODS
29              
30             =head2 request ($req)
31              
32             Append to the behavior of parent class, this method verify the SSL,
33             and if it fails, it throws the exception.
34              
35             =cut
36              
37             sub request {
38 0     0 1   my ($self, $req) = @_;
39              
40 0 0         OAuth::Lite2::Client::Error::InsecureRequest->throw(
41             message => sprintf q{request url should start with https, but found "%s"}, $req->uri)
42             unless $req->uri =~ /^https/;
43              
44 0 0         local $ENV{HTTPS_DEBUG} = $self->{https_debug} if $self->{https_debug};
45 0 0         local $ENV{HTTPS_CA_FILE} = $self->{https_ca_file} if $self->{https_ca_file};
46 0 0         local $ENV{HTTPS_CA_DIR} = $self->{https_ca_dir} if $self->{https_ca_dir};
47 0 0         local $ENV{HTTPS_CERT_FILE} = $self->{https_cert_file} if $self->{https_cert_file};
48 0 0         local $ENV{HTTPS_KEY_FILE} = $self->{https_key_file} if $self->{https_key_file};
49 0 0         local $ENV{HTTPS_VERSION} = $self->{https_version} if $self->{https_version};
50 0 0         local $ENV{HTTPS_PROXY} = $self->{https_proxy} if $self->{https_proxy};
51 0 0         local $ENV{HTTPS_PROXY_USERNAME} = $self->{https_proxy_username} if $self->{https_proxy_username};
52 0 0         local $ENV{HTTPS_PROXY_PASSWORD} = $self->{https_proxy_password} if $self->{https_proxy_password};
53              
54 0           my $res = $self->SUPER::request($req);
55              
56 0 0         OAuth::Lite2::Client::Error::InsecureResponse->throw(
57             message => "SSL Warning: Unauthorized access to blocked host"
58             ) if $res->header('Client-SSL-Warning');
59              
60 0           return $res;
61             }
62              
63             1;
64              
65             =head1 SEE ALSO
66              
67             L,
68             L
69              
70             =head1 AUTHOR
71              
72             Lyo Kato, C
73              
74             =head1 COPYRIGHT AND LICENSE
75              
76             This library is free software; you can redistribute it and/or modify
77             it under the same terms as Perl itself, either Perl version 5.8.8 or,
78             at your option, any later version of Perl 5 you may have available.
79              
80             =cut