view release on metacpan or  search on metacpan

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

{	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;