File Coverage

blib/lib/Test2/Tools/HTTP/UA.pm
Criterion Covered Total %
statement 59 65 90.7
branch 12 16 75.0
condition 1 3 33.3
subroutine 17 17 100.0
pod 5 5 100.0
total 94 106 88.6


line stmt bran cond sub pod time code
1             package Test2::Tools::HTTP::UA;
2              
3 9     9   185924 use strict;
  9         21  
  9         240  
4 9     9   39 use warnings;
  9         16  
  9         181  
5 9     9   35 use Carp ();
  9         15  
  9         93  
6 9     9   43 use File::Spec ();
  9         13  
  9         160  
7 9     9   3213 use Test2::Tools::HTTP::Apps;
  9         21  
  9         4757  
8              
9             # ABSTRACT: User agent wrapper for Test2::Tools::HTTP
10             our $VERSION = '0.11'; # VERSION
11              
12              
13             sub _init
14             {
15 5     5   14 foreach my $inc (@INC)
16             {
17 55         462 my $dir = File::Spec->catdir($inc, 'Test2/Tools/HTTP/UA');
18 55 100       699 next unless -d $dir;
19 15         37 my $dh;
20 15         459 opendir $dh, $dir;
21 15         534 my @list = sort grep !/^\./, grep /\.pm$/, readdir $dh;
22 15         180 closedir $dh;
23 15         51 foreach my $pm (@list)
24             {
25 30         47 eval { require "Test2/Tools/HTTP/UA/$pm"; };
  30         3929  
26 30 50       161 if(my $error = $@)
27             {
28 0         0 warn $error;
29             }
30             }
31             }
32             }
33              
34             my %classes;
35             my %instance;
36              
37             sub new
38             {
39 12     12 1 2807 my($class, $ua) = @_;
40              
41 12 100       39 if($class eq __PACKAGE__)
42             {
43 5         20 _init();
44 5         15 my $class;
45              
46 5 50 33     37 if(ref($ua) eq '' && defined $ua)
47             {
48 0         0 ($class) = @{ $classes{$ua} };
  0         0  
49             }
50             else
51             {
52 5         23 foreach my $try (keys %instance)
53             {
54 6 100       13 if(eval { $ua->isa($try) })
  6         69  
55             {
56 5         10 ($class) = @{ $instance{$try} };
  5         22  
57             }
58             }
59             }
60              
61 5 50       20 if(defined $class)
62             {
63 5         70 return $class->new($ua);
64             }
65             else
66             {
67 0         0 Carp::croak("user agent @{[ ref $ua ]} not supported ");
  0         0  
68             }
69             }
70              
71             bless {
72 7         37 ua => $ua,
73             }, $class;
74             }
75              
76              
77             sub ua
78             {
79 83     83 1 18770 shift->{ua};
80             }
81              
82              
83             sub apps
84             {
85 98     98 1 367 Test2::Tools::HTTP::Apps->new;
86             }
87              
88              
89             sub error
90             {
91 1     1 1 642 my(undef, $message, $res) = @_;
92 1         7 my $error = bless { message => $message, res => $res }, 'Test2::Tools::HTTP::UA::Error';
93 1         6 die $error;
94             }
95              
96              
97             sub register
98             {
99 15     15 1 127 my(undef, $class, $type) = @_;
100 15         43 my $caller = caller;
101 15 100       74 if($type eq 'class')
    50          
102             {
103 7         14 push @{ $classes{$class} }, $caller;
  7         36  
104             }
105             elsif($type eq 'instance')
106             {
107 8         45 push @{ $instance{$class} }, $caller;
  8         37  
108             }
109             else
110             {
111 0         0 Carp::croak("unknown type for $class: $type");
112             }
113             }
114              
115             package Test2::Tools::HTTP::UA::Error;
116              
117             use overload
118 2     2   6 '""' => sub { shift->as_string },
119 9     9   66 bool => sub { 1 }, fallback => 1;
  9     2   23  
  9         111  
  2         6  
120              
121 2     2   11 sub message { shift->{message} }
122 1     1   4 sub res { shift->{res} }
123 2     2   5 sub as_string { shift->message }
124              
125             1;
126              
127             __END__