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

package Test::MobileAgent::Base;

use strict;
use warnings;
use List::Util 'first';

sub _modify_headers { shift; return @_ }

sub env {
  my ($class, $type, %extra_headers) = @_;

  my $ua;
  if ($type and index($type, '/') >= $[) {
    # it looks like a full user agent.
    $ua = $type;
  }
  else {
    # looking for a candidate from the list
    my @list = $class->list;
    $type = qr/\Q$type/ unless ref $type eq 'Regexp';

    $ua = first { /$type/i } @list;

    $ua ||= $list[-1];
  }

  my %headers = $class->_modify_headers(
    HTTP_USER_AGENT => $ua,
    _normalize_headers(%extra_headers),
  );

  # remove private headers
  foreach my $header (keys %headers) {
    delete $headers{$header} if substr($header, 0, 1) eq '_';
  }
  return %headers;
}

sub _normalize_headers {
  my %headers = @_;

  my %new_headers;
  foreach my $header (keys %headers) {
    my $new_header = uc $header;
       $new_header =~ tr/-/_/;
       $new_header = "HTTP_$new_header" if $new_header =~ /^X_/;
    $new_headers{$new_header} = $headers{$header};
  }
  return %new_headers;
}

sub list { grep { $_ and !/^#/ } split /\n/, (shift->_list) }

1;

__END__