File Coverage

blib/lib/File/MimeInfo.pm

Criterion	Covered	Total	%
statement	195	216	90.2
branch	119	190	62.6
condition	11	18	61.1
subroutine	24	24	100.0
pod	13	13	100.0
total	362	461	78.5

package File::MimeInfo;

use strict;
use warnings;
use Carp;
use Fcntl 'SEEK_SET';
use File::Spec;
use File::BaseDir qw/data_files/;
require Exporter;

our @ISA = qw(Exporter);
our @EXPORT = qw(mimetype);
our @EXPORT_OK = qw(extensions describe globs inodetype mimetype_canon mimetype_isa);
our $VERSION = '0.37';
our $DEBUG;

our ($_hashed, $_hashed_aliases, $_hashed_subclasses, $_has_mimeinfo_database);
our (@globs, %literal, %extension, %mime2ext, %aliases, %subclasses);
our ($LANG, @DIRS);
# @globs = [ [ 'glob', qr//, $mime_string ], ... ]
# %literal contains literal matches
# %extension contains extensions (globs matching /^\*(\.\w)+$/ )
# %mime2ext is used for looking up extension by mime type
# %aliases contains the aliases table
# %subclasses contains the subclasses table
# $LANG can be used to set a default language for the comments
# @DIRS can be used to specify custom database directories

sub new { bless \$VERSION, shift } # what else is there to bless ?

sub mimetype {
    my $file = pop;
    croak 'subroutine "mimetype" needs a filename as argument' unless defined $file;
    return
        inodetype($file) ||
        globs($file)     ||
        default($file);
}

sub inodetype {
    my $file = pop;
    print STDERR "> Checking inode type\n" if $DEBUG;
    lstat $file or return undef;
    return undef if -f _;
    my $t = (-l $file) ? 'inode/symlink' :  # Win32 does not like '_' here
        (-d _) ? 'inode/directory'   :
        (-p _) ? 'inode/fifo'        :
        (-c _) ? 'inode/chardevice'  :
        (-b _) ? 'inode/blockdevice' :
        (-S _) ? 'inode/socket'      : '' ;
    if ($t eq 'inode/directory') { # compare devices to detect mount-points
        my $dev = (stat _)[0]; # device of the node under investigation
        $file = File::Spec->rel2abs($file); # get full path
        my @dirs = File::Spec->splitdir($file);
        $file = File::Spec->catfile(@dirs); # removes trailing '/' or equivalent
        return $t if -l $file; # parent can be on other dev for links
        pop @dirs;
        my $dir = File::Spec->catdir(@dirs); # parent dir
        $t = 'inode/mount-point' unless (stat $dir)[0] == $dev; # compare devices
        return $t;
    }
    else { return $t ? $t : undef }
}

sub globs {
    my $file = pop;
    croak 'subroutine "globs" needs a filename as argument' unless defined $file;
    rehash() unless $_hashed;
    (undef, undef, $file) = File::Spec->splitpath($file); # remove path
    print STDERR "> Checking globs for basename '$file'\n" if $DEBUG;

    return $literal{$file} if exists $literal{$file};

    if ($file =~ /\.(\w+(\.\w+)*)$/) {
        my @ext = split /\./, $1;
        while (@ext) {
            my $ext = join('.', @ext);
            print STDERR "> Checking for extension '.$ext'\n" if $DEBUG;
            carp "WARNING: wantarray behaviour of globs() will change in the future.\n" if wantarray;
            return wantarray
                ? ($extension{$ext}, $ext)
                : $extension{$ext}
                if exists $extension{$ext};
            shift @ext;
        }
    }

    for (@globs) {
        next unless $file =~ $_->[1];
        print STDERR "> This file name matches \"$_->[0]\"\n" if $DEBUG;
        return $_->[2];
    }

    return globs(lc $file) if $file =~ /[A-Z]/; # recurs
    return undef;
}

sub default {
    my $file = pop;
    croak 'subroutine "default" needs a filename as argument' unless defined $file;

    my $line;
    unless (ref $file) {
        return undef unless -f $file;
        print STDERR "> File exists, trying default method\n" if $DEBUG;
        return 'text/plain' if -z $file;

        open FILE, '<', $file or return undef;
        binmode FILE, ':utf8' unless $] < 5.008;
        read FILE, $line, 32;
        close FILE;
    }
    elsif (ref $file eq 'Path::Tiny') {
        return undef unless $file->exists;
        print STDERR "> File is Path::Tiny object and exists, "
            . "trying default method\n" if $DEBUG;
        open my $fh, '<', $file or return undef;
        binmode $fh, ':utf8' unless $] < 5.008;
        read $fh, $line, 32;
        close $fh;
    }
    else {
        print STDERR "> Trying default method on object\n" if $DEBUG;

        $file->seek(0, SEEK_SET);
        $file->read($line, 32);
    }

    {
        no warnings; # warnings can be thrown when input not ascii
        if ($] < 5.008 or ! utf8::valid($line)) {
            use bytes; # avoid invalid utf8 chars
            $line =~ s/\s//g; # \m, \n and \t are also control chars
            return 'text/plain' unless $line =~ /[\x00-\x1F\x7F]/;
        }
        else {
            # use perl to do something intelligent for ascii & utf8
            return 'text/plain' unless $line =~ /[^[:print:]\s]/;
        }
    }
    print STDERR "> First 10 bytes of the file contain control chars\n" if $DEBUG;
    return 'application/octet-stream';
}

sub rehash {
    (@globs, %literal, %extension, %mime2ext) = (); # clear all data
    local $_; # limit scope of $_ ... :S
    my @globfiles = @DIRS
        ? ( grep {-e $_ && -r $_} map "$_/globs", @DIRS )
        : ( reverse data_files('mime/globs')        );
    if (@globfiles) {
        $_has_mimeinfo_database = 1;
    } else {
        carp "WARNING: You don't seem to have a mime-info database. " .
             "The shared-mime-info package is available from http://freedesktop.org/";
    }
    my @done;
    for my $file (@globfiles) {
        next if grep {$file eq $_} @done;
        _hash_globs($file);
        push @done, $file;
    }
    $_hashed = 1;
}

sub _hash_globs {
    my $file = shift;
    open GLOB, '<', $file or croak "Could not open file '$file' for reading" ;
    binmode GLOB, ':utf8' unless $] < 5.008;
    my ($string, $glob);
    my %seen_extension;
    while () {
        next if /^\s*#/ or ! /\S/; # skip comments and empty lines
        chomp;
        ($string, $glob) = split /:/, $_, 2;
        unless ($glob =~ /[\?\*\[]/) { $literal{$glob} = $string }
        elsif ($glob =~ /^\*\.(\w+(\.\w+)*)$/) {
            next if $seen_extension{$1}++;
            if (exists $extension{$1} && $extension{$1} ne $string) {
                my $old = $extension{$1};
                if (defined $mime2ext{$old}) {
                    @{$mime2ext{$old}} = grep { $_ ne $1 } @{$mime2ext{$old}};
                    delete $mime2ext{$old} unless @{$mime2ext{$old}};
                }
            }
            $extension{$1} = $string;
            $mime2ext{$string} = [] if !defined($mime2ext{$string});
            push @{$mime2ext{$string}}, $1
                unless grep { $_ eq $1 } @{$mime2ext{$string}};
        } else { unshift @globs, [$glob, _glob_to_regexp($glob), $string] }
    }
    close GLOB or croak "Could not open file '$file' for reading" ;
}

sub _glob_to_regexp {
    my $glob = shift;
    $glob =~ s/\./\\./g;
    $glob =~ s/([?*])/.$1/g;
    $glob =~ s/([^\w\/\\\.\?\*\[\]])/\\$1/g;
    qr/^$glob$/;
}

sub has_mimeinfo_database {
    rehash() if (!$_hashed);
    return $_has_mimeinfo_database;
}

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 () {
            next unless m!(.*?)!;
            $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 = ) {
            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__