view release on metacpan or  search on metacpan

lib/File/MimeInfo.pm  view on Meta::CPAN

sub extensions {
    my $mimet = mimetype_canon(pop @_);
    rehash() unless $_hashed;
        my $ref = $mime2ext{$mimet} if exists $mime2ext{$mimet};
    return $ref ? @{$ref}    : undef if wantarray;
        return $ref ? @{$ref}[0] : '';
}

sub describe {
    shift if ref $_[0];
    my ($mt, $lang) = @_;
    croak 'subroutine "describe" needs a mimetype as argument' unless $mt;
    $mt = mimetype_canon($mt);
    $lang = $LANG unless defined $lang;
    my $att =  $lang ? qq{xml:lang="$lang"} : '';
    my $desc;
    my @descfiles = @DIRS
        ? ( grep {-e $_ && -r $_} map "$_/$mt.xml", @DIRS        )
        : ( reverse data_files('mime', split '/', "$mt.xml") ) ;
    for my $file (@descfiles) {
        $desc = ''; # if a file was found, return at least empty string
        open XML, '<', $file or croak "Could not open file '$file' for reading";
        binmode XML, ':utf8' unless $] < 5.008;
        while (<XML>) {
            next unless m!<comment\s*$att>(.*?)</comment>!;
            $desc = $1;
            last;
        }
        close XML or croak "Could not open file '$file' for reading";
        last if $desc;
    }
    return $desc;
}

sub mimetype_canon {
    my $mimet = pop;
    croak 'mimetype_canon needs argument' unless defined $mimet;
    rehash_aliases() unless $_hashed_aliases;
    return exists($aliases{$mimet}) ? $aliases{$mimet} : $mimet;
}

sub rehash_aliases {
    %aliases = _read_map_files('aliases');
    $_hashed_aliases++;
}

sub _read_map_files {
    my ($name, $list) = @_;
    my @files = @DIRS
        ? ( grep {-e $_ && -r $_} map "$_/$name", @DIRS )
        : ( reverse data_files("mime/$name")        );
    my (@done, %map);
    for my $file (@files) {
        next if grep {$_ eq $file} @done;
        open MAP, '<', $file or croak "Could not open file '$file' for reading";
        binmode MAP, ':utf8' unless $] < 5.008;
        while (my $line = <MAP>) {
            next unless $line =~ m/\S/; # skip empty lines
            next if $line =~ m/^\s*#/;  # skip comment lines
            chomp $line;
            my ($k, $v) = split m/\s+/, $line, 2;
            if ($list) {
                $map{$k} = [] unless $map{$k};
                push @{$map{$k}}, $v;
            }
            else { $map{$k} = $v }
        }
        close MAP;
        push @done, $file;
    }
    return %map;
}

sub mimetype_isa {
    my $parent = pop || croak 'mimetype_isa needs argument';
    my $mimet = pop;
    if (ref $mimet or ! defined $mimet) {
        $mimet = mimetype_canon($parent);
        undef $parent;
    }
    else {
        $mimet = mimetype_canon($mimet);
        $parent = mimetype_canon($parent);
    }
    rehash_subclasses() unless $_hashed_subclasses;

    my @subc;
    push @subc, 'inode/directory' if $mimet eq 'inode/mount-point';
    push @subc, @{$subclasses{$mimet}} if exists $subclasses{$mimet};
    push @subc, 'text/plain' if $mimet =~ m#^text/#;
    push @subc, 'application/octet-stream' unless $mimet =~ m#^inode/#;

    return $parent ? scalar(grep {$_ eq $parent} @subc) : @subc;
}

sub rehash_subclasses {
    %subclasses = _read_map_files('subclasses', 'LIST');
    $_hashed_subclasses++;
}

1;

__END__

=head1 NAME

File::MimeInfo - Determine file type from the file name

=head1 SYNOPSIS

  use File::MimeInfo;
  my $mime_type = mimetype($file);
  my $mime_type2 = mimetype('test.png');

=head1 DESCRIPTION

This module can be used to determine the mime type of a file. It
tries to implement the freedesktop specification for a shared
MIME database.

For this module shared-mime-info-spec 0.13 was used.