1use 5.006; use strict; use warnings;
2
3package Parse::MIME;
4
5our $VERSION = '1.005';
6
7use Exporter ();
8our @ISA = 'Exporter';
9our @EXPORT_OK = qw(
10	&parse_mime_type &parse_media_range &parse_media_range_list
11	&fitness_and_quality_parsed &quality_parsed &quality
12	&best_match
13);
14our %EXPORT_TAGS = ( all => \@EXPORT_OK );
15
16sub _numify($) { no warnings 'numeric'; 0 + shift }
17
18# takes any number of args and returns copies stripped of surrounding whitespace
19sub _strip { s/\A +//, s/ +\z// for my @s = @_; @s[ 0 .. $#s ] }
20
21# check whether first two args are equal or one of them is a wildcard
22sub _match { $_[0] eq $_[1] or grep { $_ eq '*' } @_[0,1] }
23
24sub parse_mime_type {
25	my ( $mime_type ) = @_;
26
27	my @part      = split /;/, $mime_type;
28	my $full_type = _strip shift @part;
29	my %param     = map { _strip split /=/, $_, 2 } @part;
30
31	# Java URLConnection class sends an Accept header that includes a single "*"
32	# Turn it into a legal wildcard.
33	$full_type = '*/*' if $full_type eq '*';
34
35	my ( $type, $subtype ) = _strip split m!/!, $full_type;
36
37	return ( $type, $subtype, \%param );
38}
39
40sub parse_media_range {
41	my ( $range ) = @_;
42
43	my ( $type, $subtype, $param ) = parse_mime_type $range;
44
45	$param->{'q'} = 1
46		unless defined $param->{'q'}
47		and length  $param->{'q'}
48		and _numify $param->{'q'} <= 1
49		and _numify $param->{'q'} >= 0;
50
51	return ( $type, $subtype, $param );
52}
53
54sub parse_media_range_list {
55	my ( $media_range_list ) = @_;
56	return map { parse_media_range $_ } split /,/, $media_range_list;
57}
58
59sub fitness_and_quality_parsed {
60	my ( $mime_type, @parsed_ranges ) = @_;
61
62	my ( $best_fitness, $best_fit_q ) = ( -1, 0 );
63
64	my ( $target_type, $target_subtype, $target_param )
65		= parse_media_range $mime_type;
66
67	while ( my ( $type, $subtype, $param ) = splice @parsed_ranges, 0, 3 ) {
68
69		if ( _match( $type, $target_type ) and _match( $subtype, $target_subtype ) ) {
70
71			my $fitness
72				= ( $type    eq $target_type    ? 100 : 0 )
73				+ ( $subtype eq $target_subtype ?  10 : 0 )
74				;
75
76			while ( my ( $k, $v ) = each %$param ) {
77				++$fitness
78					if $k ne 'q'
79					and exists $target_param->{ $k }
80					and $target_param->{ $k } eq $v;
81			}
82
83			( $best_fitness, $best_fit_q ) = ( $fitness, $param->{'q'} )
84				if $fitness > $best_fitness;
85		}
86	}
87
88	return ( $best_fitness, _numify $best_fit_q );
89}
90
91sub quality_parsed {
92	return +( fitness_and_quality_parsed @_ )[1];
93}
94
95sub quality {
96	my ( $mime_type, $ranges ) = @_;
97	my @parsed_range = parse_media_range_list $ranges;
98	return quality_parsed $mime_type, @parsed_range;
99}
100
101sub best_match {
102	my ( $supported, $header ) = @_;
103	my @parsed_header = parse_media_range_list $header;
104
105	# fitness_and_quality_parsed will return fitness -1 on failure,
106	# so we want to start with an invalid value greater than that
107	my ( $best_fitness, $best_fit_q, $match ) = ( -.5, 0 );
108
109	for my $type ( @$supported ) {
110		my ( $fitness, $fit_q ) = fitness_and_quality_parsed $type, @parsed_header;
111		next if $fitness < $best_fitness;
112		next if $fitness == $best_fitness and $fit_q < $best_fit_q;
113		( $best_fitness, $best_fit_q, $match ) = ( $fitness, $fit_q, $type );
114	}
115
116	return if not defined $match;
117	return $match;
118}
119
120__END__
121
122=pod
123
124=encoding UTF-8
125
126=head1 NAME
127
128Parse::MIME - Parse mime-types, match against media ranges
129
130=head1 SYNOPSIS
131
132 use Parse::MIME qw( best_match );
133 print best_match( [ qw( application/xbel+xml text/xml ) ], 'text/*;q=0.5,*/*; q=0.1' );
134 # text/xml
135
136=head1 DESCRIPTION
137
138This module provides basic functions for handling mime-types. It can handle
139matching mime-types against a list of media-ranges. See section 14.1 of the
140HTTP specification [RFC 2616] for a complete explanation:
141L<http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.1>
142
143=head1 INTERFACE
144
145None of the following functions are exported by default. You can use the
146C<:all> tag to import all of them into your package:
147
148 use Parse::MIME ':all';
149
150=head2 parse_mime_type
151
152Parses a mime-type into its component parts and returns type, subtype and
153params, where params is a reference to a hash of all the parameters for the
154media range:
155
156 parse_mime_type 'application/xhtml;q=0.5'
157 # ( 'application', 'xhtml', { q => 0.5 } )
158
159=head2 parse_media_range
160
161Media-ranges are mime-types with wild-cards and a C<q> quality parameter. This
162function works just like L</parse_mime_type>, but also guarantees that there is
163a value for C<q> in the params hash, supplying the default value if necessary.
164
165 parse_media_range 'application/xhtml'
166 # ( 'application', 'xhtml', { q => 1 } )
167
168=head2 parse_media_range_list
169
170Media-range lists are comma-separated lists of media ranges. This function
171works just like L</parse_media_range>, but accepts a list of media ranges and
172returns for all of media-ranges.
173
174 my @l = parse_media_range_list 'application/xhtml, text/html;q=0.7'
175 # ( 'application', 'xhtml', { q => 1 }, 'text', 'html', { q => 0.7 } )
176
177=head2 fitness_and_quality_parsed
178
179Find the best match for a given mime-type (passed as the first parameter)
180against a list of media ranges that have already been parsed by
181L</parse_media_range> (passed as a flat list). Returns the fitness value and
182the value of the C<q> quality parameter of the best match, or C<( -1, 0 )> if
183no match was found.
184
185 # for @l see above
186 fitness_and_quality_parsed( 'text/html', @l )
187 # ( 110, 0.7 )
188
189=head2 quality
190
191Determines the quality (C<q>) of a mime-type (passed as the first parameter)
192when compared against a media-range list string. F.ex.:
193
194 quality( 'text/html', 'text/*;q=0.3, text/html;q=0.7, text/html;level=1, text/html;level=2;q=0.4, */*;q=0.5' )
195 # 0.7
196
197=head2 quality_parsed
198
199Just like L</quality>, except the second parameter must be pre-parsed by
200L</parse_media_range_list>.
201
202=head2 best_match
203
204Choose the mime-type with the highest quality (C<q>) from a list of candidates.
205Takes an array of supported mime-types as the first parameter and finds the
206best match for all the media-ranges listed in header, which is passed as the
207second parameter. The value of header must be a string that conforms to the
208format of the HTTP C<Accept> header. F.ex.:
209
210 best_match( [ qw( application/xbel+xml text/xml ) ], 'text/*;q=0.5,*/*; q=0.1' )
211 # 'text/xml'
212
213=head1 AUTHOR
214
215Aristotle Pagaltzis <pagaltzis@gmx.de>
216
217=head1 COPYRIGHT AND LICENSE
218
219This software is copyright (c) 2018 by Aristotle Pagaltzis.
220
221This is free software; you can redistribute it and/or modify it under
222the same terms as the Perl 5 programming language system itself.
223
224=cut
225