File Coverage

lib/Test/MobileAgent/Base.pm
Criterion Covered Total %
statement 37 37 100.0
branch 8 10 80.0
condition 4 6 66.6
subroutine 9 9 100.0
pod 2 2 100.0
total 60 64 93.7


line stmt bran cond sub pod time code
1             package Test::MobileAgent::Base;
2              
3 8     8   54 use strict;
  8         16  
  8         257  
4 8     8   40 use warnings;
  8         11  
  8         210  
5 8     8   79 use List::Util 'first';
  8         13  
  8         1665  
6              
7 352     352   594 sub _modify_headers { shift; return @_ }
  352         1342  
8              
9             sub env {
10 2106     2106 1 4279 my ($class, $type, %extra_headers) = @_;
11              
12 2106         2612 my $ua;
13 8 100 100 8   10190 if ($type and index($type, '/') >= $[) {
  8         11019  
  8         4700  
  2106         28374  
14             # it looks like a full user agent.
15 2094         3814 $ua = $type;
16             }
17             else {
18             # looking for a candidate from the list
19 12         55 my @list = $class->list;
20 12 50       372 $type = qr/\Q$type/ unless ref $type eq 'Regexp';
21              
22 12     434   162 $ua = first { /$type/i } @list;
  434         771  
23              
24 12   33     228 $ua ||= $list[-1];
25             }
26              
27 2106         5250 my %headers = $class->_modify_headers(
28             HTTP_USER_AGENT => $ua,
29             _normalize_headers(%extra_headers),
30             );
31              
32             # remove private headers
33 2106         5332 foreach my $header (keys %headers) {
34 3040 100       10938 delete $headers{$header} if substr($header, 0, 1) eq '_';
35             }
36 2106         14070 return %headers;
37             }
38              
39             sub _normalize_headers {
40 2106     2106   3824 my %headers = @_;
41              
42 2106         3298 my %new_headers;
43 2106         6844 foreach my $header (keys %headers) {
44 32         60 my $new_header = uc $header;
45 32         53 $new_header =~ tr/-/_/;
46 32 50       91 $new_header = "HTTP_$new_header" if $new_header =~ /^X_/;
47 32         99 $new_headers{$new_header} = $headers{$header};
48             }
49 2106         11406 return %new_headers;
50             }
51              
52 26 100   26 1 174 sub list { grep { $_ and !/^#/ } split /\n/, (shift->_list) }
  4524         17965  
53              
54             1;
55              
56             __END__