view release on metacpan or  search on metacpan

lib/Parse/MIME.pm  view on Meta::CPAN

use 5.006; use strict; use warnings;

package Parse::MIME;
our $VERSION = '1.006';

BEGIN { require Exporter; *import = \&Exporter::import }
our @EXPORT_OK = qw(
	&parse_mime_type &parse_media_range &parse_media_range_list 
	&fitness_and_quality_parsed &quality_parsed &quality
	&best_match
);
our %EXPORT_TAGS = ( all => \@EXPORT_OK );

sub _numify($) { no warnings 'numeric'; 0 + shift }

# takes any number of args and returns copies stripped of surrounding whitespace
sub _strip { s/\A +//, s/ +\z// for my @s = @_; @s[ 0 .. $#s ] }

# check whether first two args are equal or one of them is a wildcard
sub _match { $_[0] eq $_[1] or grep { $_ eq '*' } @_[0,1] }

sub parse_mime_type {
	my ( $mime_type ) = @_;

	my @part      = split /;/, $mime_type;
	my $full_type = _strip shift @part;
	my %param     = map { _strip split /=/, $_, 2 } @part;

	# Java URLConnection class sends an Accept header that includes a single "*"
	# Turn it into a legal wildcard.
	$full_type = '*/*' if $full_type eq '*';

	my ( $type, $subtype ) = _strip split m!/!, $full_type;

	return ( $type, $subtype, \%param );
}

sub parse_media_range {
	my ( $range ) = @_;

	my ( $type, $subtype, $param ) = parse_mime_type $range;

	$param->{'q'} = 1
		unless defined $param->{'q'}
		and length  $param->{'q'}
		and _numify $param->{'q'} <= 1
		and _numify $param->{'q'} >= 0;

	return ( $type, $subtype, $param );
}

sub parse_media_range_list {
	my ( $media_range_list ) = @_;
	return map { parse_media_range $_ } split /,/, $media_range_list;
}

sub fitness_and_quality_parsed {
	my ( $mime_type, @parsed_ranges ) = @_;

	my ( $best_fitness, $best_fit_q ) = ( -1, 0 );

	my ( $target_type, $target_subtype, $target_param )
		= parse_media_range $mime_type;

	while ( my ( $type, $subtype, $param ) = splice @parsed_ranges, 0, 3 ) {

		if ( _match( $type, $target_type ) and _match( $subtype, $target_subtype ) ) {

			my $fitness
				= ( $type    eq $target_type    ? 100 : 0 )
				+ ( $subtype eq $target_subtype ?  10 : 0 )
				;

			while ( my ( $k, $v ) = each %$param ) {
				++$fitness
					if $k ne 'q'
					and exists $target_param->{ $k }
					and $target_param->{ $k } eq $v;
			}

			( $best_fitness, $best_fit_q ) = ( $fitness, $param->{'q'} )
				if $fitness > $best_fitness;
		}
	}

	return ( $best_fitness, _numify $best_fit_q );
}

sub quality_parsed {
	return +( fitness_and_quality_parsed @_ )[1];
}

sub quality {