File Coverage

blib/lib/Test2/Tools/HTTP/UA.pm
Criterion Covered Total %
statement 58 64 90.6
branch 12 16 75.0
condition 1 3 33.3
subroutine 16 16 100.0
pod 5 5 100.0
total 92 104 88.4


line stmt bran cond sub pod time code
1             package Test2::Tools::HTTP::UA;
2              
3 9     9   226452 use strict;
  9         23  
  9         264  
4 9     9   50 use warnings;
  9         20  
  9         215  
5 9     9   45 use Carp ();
  9         18  
  9         125  
6 9     9   68 use File::Spec ();
  9         28  
  9         210  
7 9     9   3824 use Test2::Tools::HTTP::Apps;
  9         24  
  9         5295  
8              
9             # ABSTRACT: User agent wrapper for Test2::Tools::HTTP
10             our $VERSION = '0.09'; # VERSION
11              
12              
13             sub _init
14             {
15 5     5   18 foreach my $inc (@INC)
16             {
17 55         518 my $dir = File::Spec->catdir($inc, 'Test2/Tools/HTTP/UA');
18 55 100       844 next unless -d $dir;
19 15         41 my $dh;
20 15         531 opendir $dh, $dir;
21 15         563 my @list = sort grep !/^\./, grep /\.pm$/, readdir $dh;
22 15         236 closedir $dh;
23 15         57 foreach my $pm (@list)
24             {
25 30         55 eval { require "Test2/Tools/HTTP/UA/$pm"; };
  30         4756  
26 30 50       171 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 3269 my($class, $ua) = @_;
40              
41 12 100       47 if($class eq __PACKAGE__)
42             {
43 5         25 _init();
44 5         17 my $class;
45              
46 5 50 33     41 if(ref($ua) eq '' && defined $ua)
47             {
48 0         0 ($class) = @{ $classes{$ua} };
  0         0  
49             }
50             else
51             {
52 5         26 foreach my $try (keys %instance)
53             {
54 6 100       15 if(eval { $ua->isa($try) })
  6         63  
55             {
56 5         14 ($class) = @{ $instance{$try} };
  5         26  
57             }
58             }
59             }
60            
61 5 50       20 if(defined $class)
62             {
63 5         68 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         47 ua => $ua,
73             }, $class;
74             }
75              
76              
77             sub ua
78             {
79 83     83 1 22496 shift->{ua};
80             }
81              
82              
83             sub apps
84             {
85 98     98 1 436 Test2::Tools::HTTP::Apps->new;
86             }
87              
88              
89             sub error
90             {
91 1     1 1 660 my(undef, $message, $res) = @_;
92 1         9 my $error = bless { message => $message, res => $res }, 'Test2::Tools::HTTP::UA::Error';
93 1         8 die $error;
94             }
95              
96              
97             sub register
98             {
99 15     15 1 155 my(undef, $class, $type) = @_;
100 15         71 my $caller = caller;
101 15 100       75 if($type eq 'class')
    50          
102             {
103 7         15 push @{ $classes{$class} }, $caller;
  7         40  
104             }
105             elsif($type eq 'instance')
106             {
107 8         57 push @{ $instance{$class} }, $caller;
  8         43  
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 9     9   88 use overload '""' => sub { shift->as_string };
  9     4   22  
  9         118  
  4         10  
118              
119 4     4   14 sub message { shift->{message} }
120 1     1   5 sub res { shift->{res} }
121 4     4   7 sub as_string { shift->message }
122              
123             1;
124              
125             __END__