File Coverage

blib/lib/MIME/Types.pm

Criterion	Covered	Total	%
statement	138	151	91.3
branch	62	84	73.8
condition	8	15	53.3
subroutine	22	28	78.5
pod	13	15	86.6
total	243	293	82.9

# This code is part of Perl distribution MIME-Types version 2.30.
# The POD got stripped from this file by OODoc version 3.05.
# For contributors see file ChangeLog.

# This software is copyright (c) 1999-2025 by Mark Overmeer.

# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
# SPDX-License-Identifier: Artistic-1.0-Perl OR GPL-1.0-or-later


package MIME::Types;{
our $VERSION = '2.30';
}


use strict;
use warnings;

use MIME::Type     ();
use File::Spec     ();
use File::Basename qw/dirname/;
use List::Util     qw/first/;

#--------------------

my %typedb;
sub new(@) { (bless {}, shift)->init( {@_} ) }

sub init($)
{	my ($self, $args) = @_;
	keys %typedb or $self->_read_db($args);
	$self;
}

sub _read_db($)
{	my ($self, $args)   = @_;
	my $skip_extensions = $args->{skip_extensions};
	my $only_complete   = $args->{only_complete};
	my $only_iana       = $args->{only_iana};

	my $db              = $ENV{PERL_MIME_TYPE_DB} || $args->{db_file} ||
		File::Spec->catfile(dirname(__FILE__), 'types.db');

	open my $dbh, '<:encoding(utf8)', $db
		or die "cannot open type database in $db: $!\n";

	while(1)
	{	my $header = $dbh->getline;
		defined $header or last;
		chomp $header;

		# This logic is entangled with the bin/collect_types script
		my ($count, $major, $is_iana, $has_ext) = split /\:/, $header;
		my $skip_section = $major eq 'EXTENSIONS' ? $skip_extensions
		  : (($only_iana && !$is_iana) || ($only_complete && !$has_ext));

		(my $section = $major) =~ s/^x-//;
		if($major eq 'EXTENSIONS')
		{	while(my $line = $dbh->getline)
			{	last if $line =~ m/^$/;
				next if $skip_section;
				chomp $line;
				$typedb{$section}{$1} = $2 if $line =~ m/(.*);(.*)/;
			}
		}
		else
		{	while(my $line = $dbh->getline)
			{	last if $line =~ m/^$/;
				next if $skip_section;
				chomp $line;
				$typedb{$section}{$1} = "$major/$line" if $line =~ m/^(?:x-)?([^;]+)/;
			}
		}
	}

	$dbh->close;
}

# Catalyst-Plugin-Static-Simple uses it :(
sub create_type_index {}

#--------------------

sub type($)
{	my $spec    = lc $_[1];
	$spec       = 'text/plain' if $spec eq 'text';   # old mailers

	$spec =~ m!^(?:x\-)?([^/]+)/(?:x-)?(.*)!
		or return;

	my $section = $typedb{$1}    or return;
	my $record  = $section->{$2} or return;
	return $record if ref $record;   # already extended

	my $simple   = $2;
	my ($type, $ext, $enc, $char) = split m/\;/, $record;
	my $os       = undef;   # XXX TODO

	$section->{$simple} = MIME::Type->new(
		type       => $type,
		extensions => [split /\,/, $ext],
		encoding   => $enc,
		system     => $os,
		charset    => $char,
	);
}


sub mimeTypeOf($)
{	my $self = shift;
	my $ext  = lc(shift);

	# Extensions may contains multiple dots (rare)
	while(1)
	{	if(my $type = $typedb{EXTENSIONS}{$ext})
		{	return $self->type($type);
		}
		$ext =~ s/.*?\.// or last;
	}

	undef;
}


sub addType(@)
{	my $self = shift;

	foreach my $type (@_)
	{	my ($major, $minor) = split m!/!, $type->simplified;
		$typedb{$major}{$minor} = $type;
		$typedb{EXTENSIONS}{$_} = $type for $type->extensions;
	}
	$self;
}


sub types()
{	my $self  = shift;
	my @types;
	foreach my $section (keys %typedb)
	{	next if $section eq 'EXTENSIONS';
		push @types, map $_->type("$section/$_"), sort keys %{$typedb{$section}};
	}
	@types;
}


sub listTypes()
{	my $self  = shift;
	my @types;
	foreach my $section (keys %typedb)
	{	next if $section eq 'EXTENSIONS';
		foreach my $sub (sort keys %{$typedb{$section}})
		{	my $record = $typedb{$section}{$sub};
			push @types, ref $record ? $record->type : $record =~ m/^([^;]+)/ ? $1 : die;
		}
	}
	@types;
}


sub extensions { keys %{$typedb{EXTENSIONS}} }
sub _MojoExtTable() {$typedb{EXTENSIONS}}

#--------------------

sub httpAccept($)
{	my $self   = shift;
	my @listed;

	foreach (split /\,\s*/, shift)
	{
		m!^   ([a-zA-Z0-9-]+ | \*) / ( [a-zA-Z0-9+-]+ | \* )
			\s* (?: \;\s*q\=\s* ([0-9]+(?:\.[0-9]*)?) \s* )?
			(\;.* | )
		  $ !x or next;

		my $mime = "$1/$2$4";
		my $q    = defined $3 ? $3 : 1;   # q, default=1

		# most complex first
		$q += $4 ? +0.01 : $1 eq '*' ? -0.02 : $2 eq '*' ? -0.01 : 0;

		# keep order
		$q -= @listed*0.0001;

		push @listed, [ $mime => $q ];
	}
	map $_->[0], sort {$b->[1] <=> $a->[1]} @listed;
}


sub httpAcceptBest($@)
{	my $self   = shift;
	my @accept = ref $_[0] eq 'ARRAY' ? @{(shift)} : $self->httpAccept(shift);
	my $match;

	foreach my $acc (@accept)
	{	$acc   =~ s/\s*\;.*//;    # remove attributes
		my $m = $acc !~ s#/\*$## ? first { $_->equals($acc) } @_
		      : $acc eq '*'      ? $_[0]     # $acc eq */*
		      :    first { $_->mediaType eq $acc } @_;
		return $m if defined $m;
	}

	();
}


sub httpAcceptSelect($@)
{	my ($self, $accept) = (shift, shift);
	my $fns  = !@_ ? return () : ref $_[0] eq 'ARRAY' ? shift : [@_];

	unless(defined $accept)
	{	my $fn = $fns->[0];
		return ($fn, $self->mimeTypeOf($fn));
	}

	# create mapping  type -> filename
	my (%have, @have);
	foreach my $fn (@$fns)
	{	my $type = $self->mimeTypeOf($fn) or next;
		$have{$type->simplified} = $fn;
		push @have, $type;
	}

	my $type = $self->httpAcceptBest($accept, @have);
	defined $type ? ($have{$type}, $type) : ();
}

# OLD INTERFACE (version 0.06 and lower)

#--------------------

use base 'Exporter';
our @EXPORT_OK = qw(by_suffix by_mediatype import_mime_types);


my $mime_types;

sub by_suffix($)
{	my $filename = shift;
	$mime_types ||= MIME::Types->new;
	my $mime     = $mime_types->mimeTypeOf($filename);

	my @data     = defined $mime ? ($mime->type, $mime->encoding) : ('','');
	wantarray ? @data : \@data;
}


sub by_mediatype($)
{	my $type = shift;
	$mime_types //= MIME::Types->new;

	my @found;
	if(!ref $type && index($type, '/') >= 0)
	{	my $mime   = $mime_types->type($type);
		@found     = $mime if $mime;
	}
	else
	{	my $search = ref $type eq 'Regexp' ? $type : qr/$type/i;
		@found     = map $mime_types->type($_), grep $_ =~ $search, $mime_types->listTypes;
	}

	my @data;
	foreach my $mime (@found)
	{	push @data, map +[$_, $mime->type, $mime->encoding], $mime->extensions;
	}

	wantarray ? @data : \@data;
}


sub import_mime_types($)
{	my $filename = shift;
	use Carp;
	croak <<'CROAK';
import_mime_types is not supported anymore: if you have types to add
please send them to the author.
CROAK
}

1;