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