1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
|
package Web::Machine::Util::ContentNegotiation;
# ABSTRACT: Module to handle content negotiation
use strict;
use warnings;
our $VERSION = '0.17';
use Scalar::Util qw[ blessed ];
use Web::Machine::Util qw[
first
pair_key
];
use Sub::Exporter -setup => {
exports => [qw[
choose_media_type
match_acceptable_media_type
choose_language
choose_charset
choose_encoding
]]
};
my $ACTIONPACK = Web::Machine::Util::get_action_pack;
my $NEGOTIATOR = $ACTIONPACK->get_content_negotiator;
sub choose_media_type {
my ($provided, $header) = @_;
$NEGOTIATOR->choose_media_type( $provided, $header );
}
sub match_acceptable_media_type {
my ($to_match, $accepted) = @_;
my $content_type = blessed $to_match ? $to_match : $ACTIONPACK->create( 'MediaType' => $to_match );
if ( my $acceptable = first { $content_type->match( pair_key( $_ ) ) } @$accepted ) {
return $acceptable;
}
return;
}
sub choose_language {
my ($provided, $header) = @_;
return 1 if scalar @$provided == 0;
$NEGOTIATOR->choose_language( $provided, $header );
}
sub choose_charset {
my ($provided, $header) = @_;
return 1 if scalar @$provided == 0;
$NEGOTIATOR->choose_charset( [ map { ref $_ ? pair_key( $_ ) : $_ } @$provided ], $header );
}
sub choose_encoding {
my ($provided, $header) = @_;
$NEGOTIATOR->choose_encoding( [ keys %$provided ], $header );
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Web::Machine::Util::ContentNegotiation - Module to handle content negotiation
=head1 VERSION
version 0.17
=head1 SYNOPSIS
use Web::Machine::Util::ContentNegotiation;
=head1 DESCRIPTION
This module provides a set of functions used in content negotiation.
=head1 FUNCTIONS
=over 4
=item C<choose_media_type ( $provided, $header )>
Given an ARRAY ref of media type strings and an HTTP header, this will
return the matching L<HTTP::Headers::ActionPack::MediaType> instance.
=item C<match_acceptable_media_type ( $to_match, $accepted )>
Given a media type string to match and an ARRAY ref of media type objects,
this will return the first matching one.
=item C<choose_language ( $provided, $header )>
Given a list of language codes and an HTTP header value, this will attempt
to negotiate the best language match.
=item C<choose_charset ( $provided, $header )>
Given a list of charset name and an HTTP header value, this will attempt
to negotiate the best charset match.
=item C<choose_encoding ( $provided, $header )>
Given a list of encoding name and an HTTP header value, this will attempt
to negotiate the best encoding match.
=back
=head1 SUPPORT
bugs may be submitted through L<https://github.com/houseabsolute/webmachine-perl/issues>.
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=back
=head1 COPYRIGHT AND LICENCE
This software is copyright (c) 2016 by Infinity Interactive, Inc.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
|
