line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Web::Machine::Util::ContentNegotiation; |
2
|
|
|
|
|
|
|
# ABSTRACT: Module to handle content negotiation |
3
|
|
|
|
|
|
|
|
4
|
18
|
|
|
18
|
|
67149
|
use strict; |
|
18
|
|
|
|
|
21
|
|
|
18
|
|
|
|
|
409
|
|
5
|
18
|
|
|
18
|
|
55
|
use warnings; |
|
18
|
|
|
|
|
19
|
|
|
18
|
|
|
|
|
561
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
our $VERSION = '0.17'; |
8
|
|
|
|
|
|
|
|
9
|
18
|
|
|
18
|
|
57
|
use Scalar::Util qw[ blessed ]; |
|
18
|
|
|
|
|
20
|
|
|
18
|
|
|
|
|
863
|
|
10
|
|
|
|
|
|
|
|
11
|
18
|
|
|
|
|
78
|
use Web::Machine::Util qw[ |
12
|
|
|
|
|
|
|
first |
13
|
|
|
|
|
|
|
pair_key |
14
|
18
|
|
|
18
|
|
1386
|
]; |
|
18
|
|
|
|
|
22
|
|
15
|
|
|
|
|
|
|
|
16
|
18
|
|
|
|
|
104
|
use Sub::Exporter -setup => { |
17
|
|
|
|
|
|
|
exports => [qw[ |
18
|
|
|
|
|
|
|
choose_media_type |
19
|
|
|
|
|
|
|
match_acceptable_media_type |
20
|
|
|
|
|
|
|
choose_language |
21
|
|
|
|
|
|
|
choose_charset |
22
|
|
|
|
|
|
|
choose_encoding |
23
|
|
|
|
|
|
|
]] |
24
|
18
|
|
|
18
|
|
3746
|
}; |
|
18
|
|
|
|
|
33
|
|
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
my $ACTIONPACK = Web::Machine::Util::get_action_pack; |
27
|
|
|
|
|
|
|
my $NEGOTIATOR = $ACTIONPACK->get_content_negotiator; |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
sub choose_media_type { |
30
|
31
|
|
|
31
|
1
|
35072
|
my ($provided, $header) = @_; |
31
|
31
|
|
|
|
|
81
|
$NEGOTIATOR->choose_media_type( $provided, $header ); |
32
|
|
|
|
|
|
|
} |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
sub match_acceptable_media_type { |
35
|
14
|
|
|
14
|
1
|
523
|
my ($to_match, $accepted) = @_; |
36
|
14
|
100
|
|
|
|
66
|
my $content_type = blessed $to_match ? $to_match : $ACTIONPACK->create( 'MediaType' => $to_match ); |
37
|
14
|
100
|
|
16
|
|
16508
|
if ( my $acceptable = first { $content_type->match( pair_key( $_ ) ) } @$accepted ) { |
|
16
|
|
|
|
|
141
|
|
38
|
12
|
|
|
|
|
826
|
return $acceptable; |
39
|
|
|
|
|
|
|
} |
40
|
2
|
|
|
|
|
147
|
return; |
41
|
|
|
|
|
|
|
} |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
sub choose_language { |
44
|
28
|
|
|
28
|
1
|
20003
|
my ($provided, $header) = @_; |
45
|
28
|
100
|
|
|
|
66
|
return 1 if scalar @$provided == 0; |
46
|
26
|
|
|
|
|
61
|
$NEGOTIATOR->choose_language( $provided, $header ); |
47
|
|
|
|
|
|
|
} |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
sub choose_charset { |
50
|
27
|
|
|
27
|
1
|
27296
|
my ($provided, $header) = @_; |
51
|
27
|
100
|
|
|
|
61
|
return 1 if scalar @$provided == 0; |
52
|
26
|
100
|
|
|
|
35
|
$NEGOTIATOR->choose_charset( [ map { ref $_ ? pair_key( $_ ) : $_ } @$provided ], $header ); |
|
43
|
|
|
|
|
114
|
|
53
|
|
|
|
|
|
|
} |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
sub choose_encoding { |
56
|
108
|
|
|
108
|
1
|
16827
|
my ($provided, $header) = @_; |
57
|
108
|
|
|
|
|
470
|
$NEGOTIATOR->choose_encoding( [ keys %$provided ], $header ); |
58
|
|
|
|
|
|
|
} |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
1; |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
__END__ |