File Coverage

blib/lib/Web/Machine/Util/ContentNegotiation.pm
Criterion Covered Total %
statement 33 33 100.0
branch 10 10 100.0
condition n/a
subroutine 12 12 100.0
pod 5 5 100.0
total 60 60 100.0


line stmt bran cond sub pod time code
1             package Web::Machine::Util::ContentNegotiation;
2             BEGIN {
3 18     18   151990 $Web::Machine::Util::ContentNegotiation::AUTHORITY = 'cpan:STEVAN';
4             }
5             # ABSTRACT: Module to handle content negotiation
6             $Web::Machine::Util::ContentNegotiation::VERSION = '0.15';
7 18     18   300 use strict;
  18         33  
  18         2590  
8 18     18   273 use warnings;
  18         38  
  18         920  
9              
10 18     18   93 use Scalar::Util qw[ blessed ];
  18         44  
  18         1608  
11              
12 18         137 use Web::Machine::Util qw[
13             first
14             pair_key
15 18     18   2454 ];
  18         35  
16              
17 18         158 use Sub::Exporter -setup => {
18             exports => [qw[
19             choose_media_type
20             match_acceptable_media_type
21             choose_language
22             choose_charset
23             choose_encoding
24             ]]
25 18     18   6265 };
  18         36  
26              
27             my $ACTIONPACK = Web::Machine::Util::get_action_pack;
28             my $NEGOTIATOR = $ACTIONPACK->get_content_negotiator;
29              
30             sub choose_media_type {
31 31     31 1 66675 my ($provided, $header) = @_;
32 31         143 $NEGOTIATOR->choose_media_type( $provided, $header );
33             }
34              
35             sub match_acceptable_media_type {
36 14     14 1 1235 my ($to_match, $accepted) = @_;
37 14 100       103 my $content_type = blessed $to_match ? $to_match : $ACTIONPACK->create( 'MediaType' => $to_match );
38 14 100   16   28806 if ( my $acceptable = first { $content_type->match( pair_key( $_ ) ) } @$accepted ) {
  16         218  
39 12         1639 return $acceptable;
40             }
41 2         273 return;
42             }
43              
44             sub choose_language {
45 28     28 1 51351 my ($provided, $header) = @_;
46 28 100       119 return 1 if scalar @$provided == 0;
47 26         112 $NEGOTIATOR->choose_language( $provided, $header );
48             }
49              
50             sub choose_charset {
51 27     27 1 79511 my ($provided, $header) = @_;
52 27 100       94 return 1 if scalar @$provided == 0;
53 26 100       53 $NEGOTIATOR->choose_charset( [ map { ref $_ ? pair_key( $_ ) : $_ } @$provided ], $header );
  43         191  
54             }
55              
56             sub choose_encoding {
57 107     107 1 31149 my ($provided, $header) = @_;
58 107         878 $NEGOTIATOR->choose_encoding( [ keys %$provided ], $header );
59             }
60              
61             1;
62              
63             __END__