mimetype

#!/usr/bin/perl

use strict;
use warnings;
our $VERSION = '0.35';
$|++;

# ########## #
# Parse ARGV #
# ########## #
use Encode::Locale;
use Encode;
@ARGV = map { decode(locale => $_, 1) } @ARGV;

my %args = ();
my %opts = (
    'help'          => ['h'],
    'usage'         => ['u'],
    'version'       => ['v'],
    'stdin'         => [''],
    'brief'         => ['b'],
    'namefile'      => ['f', 1],
    'noalign'       => ['N'],
    'describe'      => ['d'],
    'file-compat'   => [''],
    'output-format' => ['', 1],
    'language'      => ['l', 1],
    'mimetype'      => ['i'],
    'dereference'   => ['L'],
    'separator'     => ['F',1],
    'debug'         => ['D'],
    'database'      => ['', 1],
    'all'           => ['a'],
    'magic-only'    => ['M'],
);

$args{'file-compat'}++ if $0 =~ m#(^|/)file$#;

while ((@ARGV) && ($ARGV[0] =~ /^-/)) {
    my $opt = shift @ARGV;
    if ($opt =~ /^--?$/) {
        $args{stdin}++ if $args{'file-compat'} && $opt eq '-';
        last;
    }
    elsif ($opt =~ s/^--([\w-]+)(?:=(.*))?/$1/) {
        if (exists $opts{$opt}) {
            if ($opts{$opt}[1]) {
                my $arg = $2 || shift @ARGV;
                complain('--'.$opt, 2) unless defined $arg;
                $args{$opt} .= ( $args{$opt} ? ' ' : '' ) . $arg;
            }
            else { $args{$opt}++ }
        }
        else { complain('--'.$opt) }
    }
    elsif ($opt =~ s/^-(?!-)//) {
        foreach my $o (split //, $opt) {
            my ($key) = grep { $opts{$_}[0] eq $o } keys %opts;
            complain($o) unless $key;

            if ($opts{$key}[1]) {
                my $arg = shift @ARGV;
                complain('-'.$o, 2) unless defined $arg;
                $args{$key} .= ( $args{$key} ? ' ' : '' ).$arg; # join with whitespace
            }
            else { $args{$key}++; }
        }
    }
    else { complain($opt) }
}

if ($args{help} || $args{usage}) {
    eval 'use Pod::Usage';
    die "Could not find perl module Pod::Usage\n" if $@;
    pod2usage( {
        -verbose => 1,
        -exitval => 0,
    } );
}

if ($args{version}) {
    print "mimetype $VERSION\n\n", << 'EOV';
Copyright (c) 2003, 2012 Jaap G Karssenberg. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
EOV
    exit 0;
}

complain(undef, 4) unless scalar(@ARGV) || $args{stdin} || $args{namefile};

# ############# #
# prepare stuff #
# ############# #

our %desc; # desc caching hash

# --database
{
    no warnings 'once';
    @File::MimeInfo::DIRS = split /:/, $args{database} if $args{database};
}

## Actually use our module ##
eval 'use File::MimeInfo::Magic qw/mimetype globs inodetype magic describe/;';
die $@ if $@;

*default = \&File::MimeInfo::default;

# --debug
if ($args{debug}) {
    {
        no warnings 'once';
        $File::MimeInfo::DEBUG++;
        $File::MimeInfo::Magic::DEBUG++;
    }
    print '> Data dirs are: ', join( ', ',
            $args{database}
                ? ( split /:/, $args{database} )
                : (
                    File::BaseDir::xdg_data_home(),
                    File::BaseDir::xdg_data_dirs()
                )
        ), "\n";
}

# --file-compat
$args{describe}++ if $args{'file-compat'} && !$args{mimetype};

# --namefile
if ($args{namefile}) {
    open IN, $args{namefile}
        || die "Couldn't open file: $args{namefile}\n";
    unshift @ARGV, map {chomp; $_} (<IN>);
    close IN;
}

# --language
{
    no warnings 'once';
    $File::MimeInfo::LANG = $args{language} if $args{language};
}

# Formatting stuff
my $l = 5; # "STDIN"
unless ($args{brief} || $args{noalign}) {
    for (@ARGV) { $l = length($_) if $l < length($_) }
}

$args{separator} = ':' unless defined $args{separator};
my $format = $args{'output-format'}
    ? parse_format($args{'output-format'})
    : $args{brief}
    ? sub { $args{describe} ? desc($_[1]) : $_[1] }
    : $args{noalign}
    ? sub { ( $_[0], $args{separator}, ' ', $args{describe} ? desc($_[1]) : $_[1] ) }
    : sub { ( $_[0], $args{separator}, ' 'x($l + 1 - length($_[0])),
        $args{describe} ? desc($_[1]) : $_[1] ) };

# --dereference
if ($args{dereference}) {
    eval 'use File::Spec';
    die "Could not find perl module File::Spec\n" if $@;
}
# --stdin
if ($args{stdin}) {
    eval 'use IO::Scalar';
    die "Could not find perl module IO::Scalar\n" if $@;
}

if (!File::MimeInfo::has_mimeinfo_database()) {
    die "No mimeinfo database found\n";
}

# ######## #
# do stuff #
# ######## #

# --stdin
if ($args{stdin}) {
    my $data;
    {
        no warnings 'once';
        read(STDIN, $data, $File::MimeInfo::Magic::max_buffer);
    }
    my $scalar = new IO::Scalar \$data;
    print $format->('STDIN', mimetype($scalar)), "\n";
    exit;
}

foreach my $file (@ARGV) {
    # --dereference
    my $f = ($args{dereference} && -l $file) ? resolvelink($file) : $file;
    # --magic-only
    if ($args{'magic-only'}) {
        print $format->($file, magic($f) || default($f)), "\n";
    }
    # --all
    elsif ($args{all}) {
        for (qw#inodetype globs magic default#) {
            my $m = eval "$_(\$f)";
            print $format->($file, $m), "\n" if $m;
        }
    }
    else {
        print $format->($file, mimetype($f)), "\n"
    }
}

exit;

# ########### #
# Subroutines #
# ########### #

sub complain { # Error messages
    my $opt = shift;
    my $m = shift || 1;

    my $bn = $0;
    $bn =~ s|^(.*/)*||;
    if ($m == 1) { print STDERR "$bn: unrecognized option '$opt'" }
    elsif ($m == 2) { print STDERR "$bn: option '$opt' requires an argument" }
    elsif ($m == 3) { print STDERR "$bn: $opt: No such file or directory\n" }
    elsif ($m == 4) { print STDERR "usage: $bn [options] files" }

    print "\nTry '$bn --help' for more information.\n" unless $m == 3;
    exit $m;
}

sub parse_format { # Advanced formatting
    my $form = shift;
    my $code = "sub { '$form' }";
    # code will get @_ = qw/file type/
    $code =~ s/(?<!\\)%f/'.\$_[0].'/g;
    $code =~ s/(?<!\\)%m/'.\$_[1].'/g;
    $code =~ s/(?<!\\)%d/'.desc(\$_[1]).'/g;
    return eval $code;
}

sub resolvelink { # --dereference
    my $file = shift;
    my $link = readlink($file) || return $file;
    my (undef, $dir, undef) = File::Spec->splitpath($file);
    $link = File::Spec->rel2abs($link, $dir);
    $link = resolvelink($link) if -l $link; # recurs
    return $link;
}

sub desc { # Cache description
    my $mt = shift;
    return undef unless $mt;
    $desc{$mt} ||= describe($mt) || describe($mt, ''); # second form overrules the language settings to default
}

__END__

=head1 NAME

mimetype - Determine file type

=head1 SYNOPSIS

mimetype [options] [-] files

=head1 DESCRIPTION

This script tries to determine the mime type of a file using the
Shared MIME-info database. It is intended as a kind of I<file(1)> work-alike,
but uses mimetypes instead of descriptions.

If one symlinks the I<file> command to I<mimetype> it will behave
a little more compatible, see L</--file-compat>.
Commandline options to specify alternative magic files are not
implemented the same because of the conflicting data formats.
Also the wording of the descriptions will differ.

For naming switches I followed the manpage of file(1) version 4.02
when possible. They seem to differ completely from the spec in the
'utilities' chapter of IEEE Std 1003.1-2001 (POSIX).

=head1 OPTIONS

=over 4

=item B<-a>, B<--all>

Show output of all rules that match the file.

TODO: this method now just returns one match for each
method (globs, magic, etc.).

=item B<-b>, B<--brief>

Do not prepend filenames to output lines (brief mode).

=item B<--database>=I<mimedir>:I<mimedir>:...

Force the program to look in these directories for the shared mime-info
database. The directories specified by the basedir specification
are ignored.

=item B<-d>, B<--describe>

Print file descriptions instead of mime types, this is the
default when using L</--file-compat>.

=item B<-D>, B<--debug>

Print debug information about how the mimetype was determined.

=item B<-f> I<namefile>, B<--namefile>=I<namefile>

Read the names of the files to be examined from the file 'namefile'
(one per line) before the argument list.

=item B<--file-compat>

Make mimetype behave a little more L<file(1)> compatible. This
is turned on automatically when you call mimetype by a link
called 'file'.

A single '-' won't be considered a separator
between options and filenames anymore, but becomes identical to L</--stdin>.
( You can still use '--' as separator, but
that is not backward compatible with the original file command. )
Also the default becomes to print descriptions instead of mimetypes.

=item B<-F> I<string>, B<--separator>=I<string>

Use string as custom separator between the file name and its mimetype
or description, defaults to ':' .

=item B<-h>, B<--help>

=item B<-u>, B<--usage>

Print a help message and exits.

=item B<-i>, B<--mimetype>

Use mime types, opposite to L</--describe>,
this is the default when _not_ using L</--file-compat>.

=item B<-L>, B<--dereference>

Follow symbolic links.

=item B<-l> I<code>, B<--language>=I<code>

The language attribute specifies a two letter language code, this makes
descriptions being outputted in the specified language.

=item B<-M>, B<--magic-only>

Do not check for extensions, globs or inode type, only look at the content
of the file. This is particularly useful if for some reason you don't trust
the name or the extension a file has.

=item B<-N>, B<--noalign>

Do not align output fields.

=item B<--output-format>

If you want an alternative output format, you can specify a format string
containing the following escapes:

    %f for the filename
    %d description
    %m mime type

Alignment is not available when using this,
you need to post-process the output to do that.

=item B<--stdin>

Determine type of content from STDIN, less powerful then normal file checking
because it only uses magic typing. This will happen also if the STDIN filehandle
is a pipe.

To use this option L<IO::Scalar> needs to be installed.

=item B<-v>, B<--version>

Print the version of the program and exit.

=back

=head1 ENVIRONMENT

=over 4

=item XDG_DATA_HOME

=item XDG_DATA_DIRS

These variables can list base directories to search for data files. The shared
mime-info will be expected in the "mime" sub directory of one of these
directories. If these are not set, there will be searched for the
following directories:

    $HOME/.local/share/mime
    /usr/local/share/mime
    /usr/share/mime

See also the "XDG Base Directory Specification"
L<http://freedesktop.org/Standards/basedir-spec>

=back

=head1 FILES

The base dir for all data files is determined by two environment variables,
see L</ENVIRONMENT>.

=over 4

=item F<BASE/mime/packages/SOURCE.xml>

All other files are compiled from these source files. To re-compile them
use B<update-mime-database(1)>.

=item F<BASE/mime/globs>

Compiled information about globs.

=item F<BASE/mime/magic>

Compiled information about magic numbers.

=item F<BASE/mime/MEDIA/SUBTYPE.xml>

Descriptions of a mimetype in multiple languages, used for the
L</--describe> switch.

=back

=head1 DIAGNOSTICS

If a file has an empty mimetype or an empty description,
most probably the file doesn't exist and the given name
doesn't match any globs. An empty description can also mean that
there is no description available in the language you specified.

The program exits with a non-zero exit value if either the commandline
arguments failed, a module it depends on wasn't found or the shared
mime-info database wasn't accessible. See L<File::MimeInfo> for more details.

=head1 TODO

The '--all' switch doesn't really show all matches, but only one per
mime-typing method. This needs to be implemented in the modules first.

=head1 BUGS

If you find bugs, please file them in our Github
issue tracker at L<https://github.com/mbeijen/File-MimeInfo/issues>.

B<mimetype> doesn't provide a switch for looking inside compressed files
because it seems to me that this can only be done by un-compressing the file,
something that defeats the purpose. On the other hand the option should
exist for strict compatibility with file(1). Possibly a subclass should be
made for this one day.

=head1 AUTHOR

Jaap Karssenberg E<lt>pardus@cpan.orgE<gt>
Maintained by Michiel Beijen E<lt>mb@x14.nlE<gt>

=head1 COPYRIGHT

Copyright (c) 2003, 2012 Jaap G Karssenberg. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

=head1 SEE ALSO

L<file(1)>,
L<update-mime-database(1)>,
L<File::MimeInfo(3)>,
L<http://freedesktop.org/Software/shared-mime-info>