File-MimeInfo-0.29/000755 000765 000024 00000000000 13331544766 014615 5ustar00michielstaff000000 000000 File-MimeInfo-0.29/mimeopen000755 000765 000024 00000020662 13331544632 016352 0ustar00michielstaff000000 000000 #!/usr/bin/perl use strict; our $VERSION = '0.29'; $|++; # ########## # # Parse ARGV # # ########## # my %args = (); my %opts = ( # name => [char, expect_arg_bit ] 'help' => ['h'], 'usage' => ['u'], 'version' => ['v'], 'stdin' => [''], 'dereference' => ['L'], 'debug' => ['D'], 'database' => ['', 1], 'magic-only' => ['M'], 'ask' => ['a'], 'ask-default' => ['d'], 'no-ask' => ['n'], ); while ((@ARGV) && ($ARGV[0] =~ /^-/)) { my $opt = shift @ARGV; if ($opt =~ /^--?$/) { 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 "mimeopen $VERSION\n\n", << 'EOV'; Copyright (c) 2005, 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); # ############# # # prepare stuff # # ############# # # --database @File::MimeInfo::DIRS = split /:/, $args{database} if $args{database}; ## Actually use our modules ## eval 'use File::MimeInfo::Magic qw/mimetype magic/;'; die $@ if $@; eval 'use File::MimeInfo::Applications;'; die $@ if $@; *default = \&File::MimeInfo::default; # --debug if ($args{debug}) { $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"; } # --dereference ## deprecated - so always true $args{dereference} = 1; if ($args{dereference}) { eval 'use File::Spec'; die "Could not find perl module File::Spec\n" if $@; } # ######## # # do stuff # # ######## # my $mimetype; my $file = $ARGV[0]; # --dereference my $f = ($args{dereference} && -l $file) ? resolvelink($file) : $file; # --magic-only $mimetype = $args{'magic-only'} ? (magic($f) || default($f)) : mimetype($f) ; unless (length $mimetype) { print STDERR "Could not determine mimetype for file: $file\n"; exit 5; } my ($default, @other) = mime_applications_all($mimetype); ## Removed this because user should always be able to select "Other..." #unless($default or @other) { # print STDERR "No applications found for mimetype: $mimetype\n"; # exit 6; #} ## if ($args{'no-ask'}) { $default = defined($default) ? $default : $other[0]; } elsif ($args{'ask'}) { $default = choose($mimetype, 0, grep defined($_), $default, @other); } elsif ($args{'ask-default'}) { $default = choose($mimetype, 1, grep defined($_), $default, @other); } elsif (! defined $default) { ($default) = (@other == 1) ? (@other) : choose($mimetype, 1, @other); } print 'Opening '.join(', ', map qq{"$_"}, @ARGV) . ' with '.$default->get_value('Name')." ($mimetype)\n"; #print STDERR "exec string: ".$default->parse_Exec(@ARGV)."\n"; if (@ARGV == 1 or $default->wants_list) { $default->exec(@ARGV); } else { my $last = pop @ARGV; fork or $default->exec($_) for @ARGV; $default->exec($last); } exit 7; # something went wrong in the exec # ########### # # Subroutines # # ########### # sub choose { my ($mime, $set_default, @app) = @_; print $set_default ? "Please choose a default application for files of type $mime\n\n" : "Please choose an application\n\n" ; my @done; for my $i (0 .. $#app) { my (undef, undef, $file) = File::Spec->splitpath( $app[$i]->{file} ); $file =~ s/\.desktop$//; if (grep {$_ eq $file} @done) { $app[$i] = undef; } else { push @done, $file; print "\t", scalar(@done), ") ", $app[$i]->get_value('Name'), " ($file)\n"; } } @app = grep defined($_), @app; print "\t", scalar(@done)+1, ") Other...\n" if $set_default; print "\nuse application #"; my $c = ; chomp $c; unless ($c =~ /^\d+$/) { print STDERR "Cancelled\n"; exit 8; } $c--; # base-1 => base-0 if ($set_default and $c == scalar(@done)) { # ask for custom command print "use command: "; my $cmd = ; chomp $cmd; push @app, eval { mime_applications_set_custom($mime => $cmd) }; warn $@ if $@; } elsif ($c > scalar(@app)) { print STDERR "Cancelled\n"; exit 8; } elsif ($set_default) { eval { mime_applications_set_default($mime => $app[$c]) }; warn $@ if $@; } return $app[$c]; } 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 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; } __END__ =head1 NAME mimeopen - Open files by mimetype =head1 SYNOPSIS mimeopen [options] [-] files =head1 DESCRIPTION This script tries to determine the mimetype of a file and open it with the default desktop application. If no default application is configured the user is prompted with an "open with" menu in the terminal. To use this script you need the freedesktop mime-info database and the freedesktop desktop-file-utils package. See L for more details. =head1 OPTIONS =over 4 =item B<-a>, B<--ask> Do not execute the default application but ask which application to run. This does not change the default application. =item B<-d>, B<--ask-default> Let the user choose a new default program for given files. =item B<-n>, B<--no-ask> Don't ask the user which program to use. Choose the default program or the first program known to handle the file mimetype. This does not set the default application. =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<--database>=I:I:... 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<--debug> Print debug information about how the mimetype was determined. =item B<-h>, B<--help> =item B<-u>, B<--usage> Print a help message and exits. =item B<-v>, B<--version> Print the version of the program and exit. =back =head1 DEPRECATED OPTIONS =over 4 =item B<-L>, B<--dereference> Follow symbolic links. Deprecated because this is the logical default for this command. Ignored silently. =back =head1 BUGS If you find bugs, please file them in our Github issue tracker at L. See File::MimeInfo::Applications(3) and File::DesktopEntry(3) for some limitations. =head1 AUTHOR Jaap Karssenberg Epardus@cpan.orgE Maintained by Michiel Beijen Emichiel.beijen@gmail.comE =head1 COPYRIGHT Copyright (c) 2002, 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, L, L, L, L File-MimeInfo-0.29/Changes000644 000765 000024 00000017737 13331544561 016120 0ustar00michielstaff000000 000000 Revision history for Perl extension File::MimeInfo. Versions up to 0.15 by Jaap Karssenberg Versions starting 0.16 by Michiel Beijen 0.29 2018-08-05 - Stable release to CPAN. 0.28_03 2017-01-22 - `mimeinfo --stdin` did not work. Reported by Marius Gavrilescu, Debian bug https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=784545 Added minimal tests for `mimeinfo`. 0.28_02 2016-12-17 - Improved handling of Path::Tiny objects in default method. 0.28_01 2016-11-29 - Spelling fix courtesy gregor herrmann, Debian Perl group (fixes #25) - Added t/000-report-versions-tiny.t to find out issue with Path::Tiny file handles. 0.28 2016-11-27 - Follow the current mime-apps-spec (fixes #8, #20) The current version of the mime-apps spec locates the per-user defaults file in `$XDG_CONFIG_HOME/mimeapps.list`. Use that location, and fall back to the per-system and distribution defaults as specified, with the previous legacy defaults file as a final fallback. Fix by Patrick Burroughs (Celti) - POD clarifications by Nitish Bezzala 0.27 2015-02-23 - Allow to use mimeinfo on a Path::Tiny object. Reported by Smylers. - Misspelled NoDisplay attribute in .desktop file. Fix by Bernhard Rosenkraenzer (berolinux) - Fix typos in README by Sean Smith (ncstang) as part of CPAN Pull Request Challenge February 2015. 0.26 2014-05-11 - Fix mimeinfo not adhering to the priorization of globs - kudos Stefan Seifert. - Fixed URL in POD. Only run POD 404 tests with extended testing. 0.25 2014-04-03 - Included new test file in MANIFEST. 0.24 2014-04-02 - Fixed freedesktop.org desktop-file-utils URL - David Steinbrunner. 0.23 2014-04-02 - Fixed opening of files with '+' in mime type using File::MimeInfo::Applications. Debian bug 690334, brian m. carlson. 0.22 2014-02-27 - Fixed Double-close on a filehandle issue (RT 93221) - Christian Ludwig. - Fixed cpantesters issue with old version of CPAN::Changes 0.21 2013-11-03 - fixed typo in mimeopen manpage (RT 90005) - Jonathan Dowland, Debian. 0.20 2013-10-09 - mimetype, mimeopen should be set as executable files (RT 89328) - Jitka Plesnikova, Red Hat. 0.19 2013-10-05 - Changed to EU::MM. - Typo fixes - David Steinbrunner. 0.18 2013-09-02 - Fixed RT#87631 - rights on File::MimeInfo::Magic not correct. 0.17 2013-06-06 - Fixed tests on perl 5.18 (RT 85383) - Gregor Herrman - Fixed typos (RT 85634) - Gregor Herrman 0.16 2012-01-03 - Fixed test suite for perl 5.13 and newer (RT 66841) - Kent Fredric - Fixed typos in documentation (RT 70171, 39974) - Gregor Herrman - Fixed bug for files named "0" (RT 41031) - Cleaned up mimetype script (RT 64421) - Removed unessecary error code (RT 66527) - Removed illogical behavior for derefereencing symlinks (RT 58575) 0.15 2008-02-13 A special thanks to Chapman Flack for bug reports and patches. - Added some empty pod declarations to satisfy Pod::Coverage (RT 33099) - Fixed typo \xF7 => \x7F in ascii control char check (RT 30959) - Adapted new File::BaseDir API - Added DesktopEntry as a mandatory dependency - Added support for endian conversion (RT 28618) - Fixed mask behavior by making it a bit-wise regex (RT 28620 28635) - Reduced range by 1 byte to match ref implementation (RT 28634) - Added "--no-ask" switch to the mimeopen command - Added "mime_applications_custom()" to set custom commands - Made Magic load magic data when needed, not at startup - Made MimeInfo load glob data when needed, not at startup 0.14 2007-06-08 - Changed syntax for open() to 3 argument form - Fixed bug for filenames like "0" - Fixed bug with "-l" for Win32 - Fixed bug with malformed utf8 chars in default() method derived from suggestions by mcummings_gentoo.org and jonas_cpan.org - Moved from Makefile.PL to Build.pl 0.13 2006-01-30 Version bump for File::MimeInfo to keep CPAN happy - Fixed a bug with F:M::Applications when dir non-existent 0.12 2005-10-08 Updated to version 0.13 of the shared mimeinfo specification - Magic rules with priority 80 go above globs now - Added mimetype_isa() to check for mimetype subclasses - Added mimetype_canon() to check for mimetype aliases - Added support for the inode/mount-point mimetype - Added File::MimeInfo::Applications and the mimeopen script - Changed the order of checking for inodetype "symlink" and "directory" as suggested by Jens Luedicke - Fixed a few inaccuracies in the documentation 0.11 2005-03-18 - Added an @DIRS to be able to overload the XDG_DATA_DIRS path - Fixed the code to let "mimetype" determine the mime-type of STDIN 2005-03-17 - Fixed a bug in the globs() method, added File::Basename to the dependency list. - Added the --all and --magic-only options to "mimetype" 2005-03-16 - globs() now returns the matched extension when called in list context - Added Cookbook.pm as a kind of FAQ document - Applied part of a patch to support reverse lookup of extensions which was also supplied by jgmyers at proofpoint.com This adds the extensions() method and fixes a bug in a regex. - Applied a spelling patch supplied by jgmyers at proofpoint.com 0.10 2004-02-08 - Stripped down test for IO objects, because it doesn't seem to be platform independent enough - ++'ing version number to keep CPAN satisfied 0.9 2003-12-05 - Fixed magic() and default() to work on IO::something objects - Added a "no warnings" in the default routine to suppress warnings when input is latin2 (thus neither ascii or utf8). Not sure whether this really fixes the problem but it at least ignores it. The problem was reported by Daniel Raska. 0.8 2003-10-22 Seems that the new version of the mime-info spec takes longer then I expected, so I decided to release last weeks bug fixes. - Fine tuned the method interface for describe() - Made mimetype -d -l .. default to english for missing translations - updated URL's for freedesktop - Fixed small bug in Magic.pm causing a lot of warnings on initialisation when using 'perl -w', reported by Steve Barton 0.7 2003-10-03 - Added File::MimeInfo::Rox - ++'ing version number to keep CPAN satisfied 0.6 2003-09-04 - Emergency release because of a bug in the magic test file 0.5 2003-09-03 - added tests for magic typing - fixed design mistake in the basedir file search all xdg data dirs are now used, not only the first one found - put basedir code in a separate package called File::BaseDir - disabled utf8 binmode layer for perl versions prior to 5.8.0 0.4 2003-08-27 - Added the --dir switch. - Added File::MimeInfo::Magic that inherits from File::MimeInfo but also does use the freedesktop magic file - Shifted some code around in File::MimeInfo to make inheriting easier - Made the mimetype script work with Magic by default - Added the --debug switch to trace why a certain file is typed the way it is - Updated and reviewed the documentation 0.3 2003-08-24 - Moved file test operator stuff to a subroutine called inodetype() - Actually implemented the --file-compat switch - Added the -L and -i commandline switches for file(1) compatibility - Fixed a few bugs with relative file names - Changed the script 'mimeinfo' back to 'mimetype' because rox has a '--mime-type' switch doing the same thing as this script. - Added the describe() method for getting human readable descriptions - Implemented the commandline switches --desc and --output-format - Changed the script 'mimetype' to 'mimeinfo' - added some commandline options to make this script a little file(1) compat - added some file test operators for determining types from the inode/* class. - use utf8 binmode for filehandles 0.2 2003-07-12 - bug fix for OO interface, forget to test the constructor :S - added specified default behaviour 0.1 2003-07-11 - original version; created by h2xs 1.22 with options -AX File::MMagic::Freedesktop - implemented finding file type by glob folowing the shared-mime-info-spec version 0.11 - decided to rename it File::MimeInfo because it is less cryptic File-MimeInfo-0.29/MANIFEST000644 000765 000024 00000001734 13331544432 015741 0ustar00michielstaff000000 000000 Changes lib/File/MimeInfo.pm lib/File/MimeInfo/Applications.pm lib/File/MimeInfo/Cookbook.pod lib/File/MimeInfo/Magic.pm lib/File/MimeInfo/Rox.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.json META.yml mimeopen mimetype README.md t/000-report-versions-tiny.t t/00_use_ok.t t/01_normal.t t/02_magic.t t/03_rox.t t/04_IO_objects.t t/05_more.t t/06_pod_ok.t t/07_pod_cover.t t/08_changes.t t/09_no404s.t t/10filehandle.t t/11mimeinfo.t t/applications/foo.desktop t/applications/mimeinfo.cache t/applications/mirage.desktop t/default/binary_file t/default/empty_file t/default/encoding_breakage t/default/plain_text t/default/utf8_text t/magic/application_msword t/magic/application_octet-stream t/magic/application_vnd.corel-draw t/magic/application_x-executable t/magic/application_x-perl t/magic/application_x-perl.txt t/magic/text_plain t/magic/text_x-patch t/mime/aliases t/mime/globs t/mime/magic t/mime/subclasses t/mime/text/plain.xml t/test.png t/text_plain_czech File-MimeInfo-0.29/t/000755 000765 000024 00000000000 13331544766 015060 5ustar00michielstaff000000 000000 File-MimeInfo-0.29/mimetype000755 000765 000024 00000027434 13331544632 016376 0ustar00michielstaff000000 000000 #!/usr/bin/perl use strict; our $VERSION = '0.29'; $|++; # ########## # # Parse ARGV # # ########## # my %args = (); my %opts = ( # name => [char, expect_arg_bit ] '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 @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}) { $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; $_} (); close IN; } # --language $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 $@; } # ######## # # do stuff # # ######## # # --stdin if ($args{stdin}) { my $data; 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/(?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 work-alike, but uses mimetypes instead of descriptions. If one symlinks the I command to I it will behave a little more compatible, see L. 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:I:... 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. =item B<-D>, B<--debug> Print debug information about how the mimetype was determined. =item B<-f> I, B<--namefile>=I 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 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. ( 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, B<--separator>=I 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, this is the default when _not_ using L. =item B<-L>, B<--dereference> Follow symbolic links. =item B<-l> I, B<--language>=I 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 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 =back =head1 FILES The base dir for all data files is determined by two environment variables, see L. =over 4 =item F All other files are compiled from these source files. To re-compile them use B. =item F Compiled information about globs. =item F Compiled information about magic numbers. =item F Descriptions of a mimetype in multiple languages, used for the L 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 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. B 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 Epardus@cpan.orgE Maintained by Michiel Beijen Emichiel.beijen@gmail.comE =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, L, L, L File-MimeInfo-0.29/README.md000644 000765 000024 00000002136 13331544432 016064 0ustar00michielstaff000000 000000 # File-MimeInfo This module can be used to determine the mime type of a file; it's a replacement for [File::MMagic](https://metacpan.org/pod/File::MMagic) trying to implement the freedesktop specification for using the shared mime-info database. The package comes with a script called `mimetype` that can be used as a `file(1)` work-alike. ## INSTALLATION To install this module type the following: perl Makefile.PL make make test make install ## DEPENDENCIES This module expects the freedesktop mime database to be installed, some linux distributions include it, otherwise it can obtained from: http://freedesktop.org/Software/shared-mime-info This module requires these other modules which can be obtained from the [CPAN](https://metacpan.org) if they are not already installed on your system: * Carp * Exporter * Fcntl * Pod::Usage * File::Basename * File::BaseDir * File::DesktopEntry ## COPYRIGHT AND LICENCE Copyright (c) 2003, 2008 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 itself. File-MimeInfo-0.29/MANIFEST.SKIP000644 000765 000024 00000000232 13331544432 016476 0ustar00michielstaff000000 000000 \B\.git\b ^blib\/ pm_to_blib \~$ ^Makefile(\.old)?$ .gitignore ^File-MimeInfo-\d \.bak$ \.tmp$ \.swp$ ^MYMETA appveyor.yml t/symlink .mailmap .travis.yml File-MimeInfo-0.29/META.yml000644 000765 000024 00000002576 13331544766 016100 0ustar00michielstaff000000 000000 --- abstract: 'Determine file types' author: - 'Jaap Karssenberg ' build_requires: Carp: '0' Exporter: '0' Fcntl: '0' File::BaseDir: '0.03' File::DesktopEntry: '0.04' Pod::Usage: '0' Test::More: '0.88' configure_requires: ExtUtils::MakeMaker: '6.30' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.18, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: File-MimeInfo no_index: directory: - t - inc requires: perl: '5.006001' resources: bugtracker: https://github.com/mbeijen/File-MimeInfo/issues repository: https://github.com/mbeijen/File-MimeInfo version: '0.29' x_contributors: - 'Bernhard Rosenkränzer ' - 'Christian Ludwig ' - 'David Steinbrunner ' - 'Jitka Plesnikova ' - 'Jonathan Dowland ' - 'Michiel Beijen ' - 'Nitish Bezzala ' - 'Patrick Burroughs (Celti) ' - 'Rudolf Leermakers ' - 'Sean Smith ' - 'Stefan Seifert ' - 'brian m. carlson ' - 'gregor herrmann ' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' File-MimeInfo-0.29/lib/000755 000765 000024 00000000000 13331544766 015363 5ustar00michielstaff000000 000000 File-MimeInfo-0.29/Makefile.PL000644 000765 000024 00000003642 13331544432 016562 0ustar00michielstaff000000 000000 use strict; use warnings; use 5.006001; use ExtUtils::MakeMaker; WriteMakefile ( 'NAME' => 'File::MimeInfo', 'ABSTRACT' => 'Determine file types', 'AUTHOR' => 'Jaap Karssenberg ', 'DISTNAME' => "File-MimeInfo", 'VERSION_FROM' => 'lib/File/MimeInfo.pm', 'LICENSE' => 'perl', 'MIN_PERL_VERSION' => '5.6.1', 'BUILD_REQUIRES' => { 'Carp' => 0, 'Exporter' => 0, 'Fcntl' => 0, 'Pod::Usage' => 0, 'File::BaseDir' => '0.03', 'File::DesktopEntry' => '0.04', }, 'CONFIGURE_REQUIRES' => { "ExtUtils::MakeMaker" => "6.30" }, 'TEST_REQUIRES' => { 'Test::More' => '0.88', }, 'LIBS' => [''], 'EXE_FILES' => [ 'mimetype', 'mimeopen' ], 'dist' => { COMPRESS => "gzip -9f", SUFFIX => "gz", }, 'test' => { 'TESTS' => "t/*.t" }, META_MERGE => { resources => { repository => 'https://github.com/mbeijen/File-MimeInfo', bugtracker => 'https://github.com/mbeijen/File-MimeInfo/issues', }, # a list of our awesome contributors generated from git # using the command: # git shortlog -se | cut -f2- | sed "s/^/ '/;s/$/',/" x_contributors => [ 'Bernhard Rosenkränzer ', 'Christian Ludwig ', 'David Steinbrunner ', 'Jitka Plesnikova ', 'Jonathan Dowland ', 'Michiel Beijen ', 'Nitish Bezzala ', 'Patrick Burroughs (Celti) ', 'Rudolf Leermakers ', 'Sean Smith ', 'Stefan Seifert ', 'brian m. carlson ', 'gregor herrmann ', ], }, ); File-MimeInfo-0.29/META.json000644 000765 000024 00000004024 13331544766 016236 0ustar00michielstaff000000 000000 { "abstract" : "Determine file types", "author" : [ "Jaap Karssenberg " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.18, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "File-MimeInfo", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "Carp" : "0", "Exporter" : "0", "Fcntl" : "0", "File::BaseDir" : "0.03", "File::DesktopEntry" : "0.04", "Pod::Usage" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.30" } }, "runtime" : { "requires" : { "perl" : "5.006001" } }, "test" : { "requires" : { "Test::More" : "0.88" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/mbeijen/File-MimeInfo/issues" }, "repository" : { "url" : "https://github.com/mbeijen/File-MimeInfo" } }, "version" : "0.29", "x_contributors" : [ "Bernhard Rosenkränzer ", "Christian Ludwig ", "David Steinbrunner ", "Jitka Plesnikova ", "Jonathan Dowland ", "Michiel Beijen ", "Nitish Bezzala ", "Patrick Burroughs (Celti) ", "Rudolf Leermakers ", "Sean Smith ", "Stefan Seifert ", "brian m. carlson ", "gregor herrmann " ], "x_serialization_backend" : "JSON::PP version 2.27300" } File-MimeInfo-0.29/lib/File/000755 000765 000024 00000000000 13331544766 016242 5ustar00michielstaff000000 000000 File-MimeInfo-0.29/lib/File/MimeInfo/000755 000765 000024 00000000000 13331544766 017745 5ustar00michielstaff000000 000000 File-MimeInfo-0.29/lib/File/MimeInfo.pm000644 000765 000024 00000035047 13331544632 020304 0ustar00michielstaff000000 000000 package File::MimeInfo; use strict; 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.29'; our $DEBUG; our ($_hashed, $_hashed_aliases, $_hashed_subclasses); 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; warn "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 FILE, ':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') ); print STDERR << 'EOT' unless @globfiles; WARNING: You don't seem to have a mime-info database. The shared-mime-info package is available from http://freedesktop.org/ . EOT 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 || croak "Could not open file '$file' for reading" ; binmode GLOB, ':utf8' unless $] < 5.008; my ($string, $glob); 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+)*)$/) { $extension{$1} = $string unless exists $extension{$1}; $mime2ext{$string} = [] if !defined($mime2ext{$string}); push @{$mime2ext{$string}}, $1; } else { unshift @globs, [$glob, _glob_to_regexp($glob), $string] } } close GLOB || 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 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 || croak "Could not open file '$file' for reading"; binmode XML, ':utf8' unless $] < 5.008; while () { next unless m!(.*?)!; $desc = $1; last; } close XML || 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 || 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__ =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. This package only uses the globs file. No real magic checking is used. The L package is provided for magic typing. If you want to determine the mimetype of data in a memory buffer you should use L in combination with L. This module loads the various data files when needed. If you want to hash data earlier see the C methods below. =head1 EXPORT The method C is exported by default. The methods C, C, C, C, C and C can be exported on demand. =head1 METHODS =over 4 =item C Simple constructor to allow Object Oriented use of this module. If you want to use this, include the package as C to avoid importing sub C. =item C Returns a mimetype string for C<$file>, returns undef on failure. This method bundles C and C. If these methods are unsuccessful the file is read and the mimetype defaults to 'text/plain' or to 'application/octet-stream' when the first ten chars of the file match ascii control chars (white spaces excluded). If the file doesn't exist or isn't readable C is returned. =item C Returns a mimetype in the 'inode' namespace or undef when the file is actually a normal file. =item C Returns a mimetype string for C<$file> based on the filename and filename extensions. Returns undef on failure. The file doesn't need to exist. Behaviour in list context (wantarray) is unspecified and will change in future releases. =item C This method decides whether a file is binary or plain text by looking at the first few bytes in the file. Used to decide between "text/plain" and "application/octet-stream" if all other methods have failed. The spec states that we should check for the ascii control chars and let higher bit chars pass to allow utf8. We try to be more intelligent using perl utf8 support. =item C In list context, returns the list of filename extensions that map to the given mimetype. In scalar context, returns the first extension that is found in the database for this mimetype. =item C Returns a description of this mimetype as supplied by the mime info database. You can specify a language with the optional parameter C<$lang>, this should be the two letter language code used in the xml files. Also you can set the global variable C<$File::MimeInfo::LANG> to specify a language. This method returns undef when no xml file was found (i.e. the mimetype doesn't exist in the database). It returns an empty string when the xml file doesn't contain a description in the language you specified. I =item C Returns the canonical mimetype for a given mimetype. Deprecated mimetypes are typically aliased to their canonical variants. This method only checks aliases, doesn't check whether the mimetype exists. Use this method as a filter when you take a mimetype as input. =item C =item C When give only one argument this method returns a list with mimetypes that are parent classes for this mimetype. When given two arguments returns true if the second mimetype is a parent class of the first one. This method checks the subclasses table and applies a few rules for implicit subclasses. =item C Rehash the data files. Glob information is preparsed when this method is called. If you want to by-pass the XDG basedir system you can specify your database directories by setting C<@File::MimeInfo::DIRS>. But normally it is better to change the XDG basedir environment variables. =item C Rehashes the F files. =item C Rehashes the F files. =back =head1 DIAGNOSTICS This module throws an exception when it can't find any data files, when it can't open a data file it found for reading or when a subroutine doesn't get enough arguments. In the first case you either don't have the freedesktop mime info database installed, or your environment variables point to the wrong places, in the second case you have the database installed, but it is broken (the mime info database should logically be world readable). =head1 TODO Make an option for using some caching mechanism to reduce init time. Make C use real xml parsing ? =head1 LIMITATIONS Perl versions prior to 5.8.0 do not have the ':utf8' IO Layer, thus for the default method and for reading the xml files utf8 is not supported for these versions. Since it is not possible to distinguish between encoding types (utf8, latin1, latin2 etc.) in a straightforward manner only utf8 is supported (because the spec recommends this). This module does not yet check extended attributes for a mimetype. Patches for this are very welcome. =head1 AUTHOR Jaap Karssenberg Epardus@cpan.orgE Maintained by Michiel Beijen Emichiel.beijen@gmail.comE =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 itself. =head1 SEE ALSO L, L, L, L =over 4 =item related CPAN modules L =item freedesktop specifications used L, L, L =item freedesktop mime database L =back =cut File-MimeInfo-0.29/lib/File/MimeInfo/Magic.pm000644 000765 000024 00000021434 13331544633 021320 0ustar00michielstaff000000 000000 package File::MimeInfo::Magic; use strict; use Carp; use Fcntl 'SEEK_SET'; use File::BaseDir qw/data_files/; require File::MimeInfo; require Exporter; BEGIN { no strict "refs"; for (qw/extensions describe globs inodetype default/) { *{$_} = \&{"File::MimeInfo::$_"}; } } our @ISA = qw(Exporter File::MimeInfo); our @EXPORT = qw(mimetype); our @EXPORT_OK = qw(extensions describe globs inodetype magic); our $VERSION = '0.29'; our $DEBUG; our $_hashed = 0; our $max_buffer = 32; our (@magic_80, @magic); # @magic_80 and @magic are used to store the parse tree of magic data # @magic_80 contains magic rules with priority 80 and higher, @magic the rest # $max_buffer contains the maximum number of chars to be buffered from a non-seekable # filehandle in order to do magic mimetyping sub mimetype { my $file = pop; croak 'subroutine "mimetype" needs a filename as argument' unless defined $file; return magic($file) || default($file) if ref $file; return &File::MimeInfo::mimetype($file) unless -s $file and -r _; my ($mimet, $fh); return $mimet if $mimet = inodetype($file); ($mimet, $fh) = _magic($file, \@magic_80); # high priority rules return $mimet if $mimet; return $mimet if $mimet = globs($file); ($mimet, $fh) = _magic($fh, \@magic); # lower priority rules close $fh if ref $fh; return $mimet if $mimet; return default($file); } sub magic { my $file = pop; croak 'subroutine "magic" needs a filename as argument' unless defined $file; return undef unless ref($file) || -s $file; print STDERR "> Checking all magic rules\n" if $DEBUG; my ($mimet, $fh) = _magic($file, \@magic_80, \@magic); close $fh unless ref $file; return $mimet; } sub _magic { my ($file, @rules) = @_; _rehash() unless $_hashed; my $fh; unless (ref $file) { open $fh, '<', $file or return undef; binmode $fh; } else { $fh = $file } for my $type (map @$_, @rules) { for (2..$#$type) { next unless _check_rule($$type[$_], $fh, 0); close $fh unless ref $file; return ($$type[1], $fh); } } return (undef, $fh); } sub _check_rule { my ($ref, $fh, $lev) = @_; my $line; # Read if (ref $fh eq 'GLOB') { seek($fh, $$ref[0], SEEK_SET); # seek offset read($fh, $line, $$ref[1]); # read max length } else { # allowing for IO::Something $fh->seek($$ref[0], SEEK_SET); # seek offset $fh->read($line, $$ref[1]); # read max length } # Match regex $line = unpack 'b*', $line if $$ref[2]; # unpack to bits if using mask return undef unless $line =~ $$ref[3]; # match regex print STDERR '>', '>'x$lev, ' Value "', _escape_bytes($2), '" at offset ', $$ref[1]+length($1), " matches at $$ref[4]\n" if $DEBUG; return 1 unless $#$ref > 4; # Check nested rules and recurs for (5..$#$ref) { return 1 if _check_rule($$ref[$_], $fh, $lev+1); } print STDERR "> Failed nested rules\n" if $DEBUG && ! $lev; return 0; } sub rehash { &File::MimeInfo::rehash(); &_rehash(); #use Data::Dumper; #print Dumper \@magic_80, \@magic; } sub _rehash { local $_; # limit scope of $_ ... :S ($max_buffer, @magic_80, @magic) = (32); # clear data my @magicfiles = @File::MimeInfo::DIRS ? ( grep {-e $_ && -r $_} map "$_/magic", @File::MimeInfo::DIRS ) : ( reverse data_files('mime/magic') ) ; my @done; for my $file (@magicfiles) { next if grep {$file eq $_} @done; _hash_magic($file); push @done, $file; } @magic = sort {$$b[0] <=> $$a[0]} @magic; while ($magic[0][0] >= 80) { push @magic_80, shift @magic; } $_hashed = 1; } sub _hash_magic { my $file = shift; open MAGIC, '<', $file || croak "Could not open file '$file' for reading"; binmode MAGIC; eq "MIME-Magic\x00\n" or carp "Magic file '$file' doesn't seem to be a magic file"; my $line = 1; while () { $line++; if (/^\[(\d+):(.*?)\]\n$/) { push @magic, [$1,$2]; next; } s/^(\d*)>(\d+)=(.{2})//s || warn "$file line $line skipped\n" && next; my ($i, $o, $l) = ($1, $2, unpack 'n', $3); # indent, offset, value length while (length($_) <= $l) { $_ .= ; $line++; } my $v = substr $_, 0, $l, ''; # value /^(?:&(.{$l}))?(?:~(\d+))?(?:\+(\d+))?\n$/s || warn "$file line $line skipped\n" && next; my ($m, $w, $r) = ($1, $2 || 1, $3 || 1); # mask, word size, range my $mdef = defined $m; # possible big endian to little endian conversion # as a bonus perl also takes care of weird endian cases if ( $w != 1 ) { my ( $utpl, $ptpl ); if ( 2 == $w ) { $v = pack 'S', unpack 'n', $v; $m = pack 'S', unpack 'n', $m if $mdef; } elsif ( 4 == $w ) { $v = pack 'L', unpack 'N', $v; $m = pack 'L', unpack 'N', $m if $mdef; } else { warn "Unsupported word size: $w octets ". " at $file line $line\n" } } my $end = $o + $l + $r - 1; $max_buffer = $end if $max_buffer < $end; my $ref = $i ? _find_branch($i) : $magic[-1]; $r--; # 1-based => 0-based range for regex $r *= 8 if $mdef; # bytes => bits for matching a mask my $reg = '^' . ( $r ? "(.{0,$r}?)" : '()' ) . ( $mdef ? '('. _mask_regex($v, $m) .')' : '('. quotemeta($v) .')' ) ; push @$ref, [ $o, $end, # offset, offset+length+range $mdef, # boolean for mask qr/$reg/sm, # the regex to match undef # debug data ]; $$ref[-1][-1] = "$file line $line" if $DEBUG; } close MAGIC; } sub _find_branch { # finds last branch of tree of rules my $i = shift; my $ref = $magic[-1]; for (1..$i) { $ref = $$ref[-1] } return $ref; } sub _mask_regex { # build regex based on mask my ($v, $m) = @_; my @v = split '', unpack "b*", $v; my @m = split '', unpack "b*", $m; my $re = ''; for (0 .. $#m) { $re .= $m[$_] ? $v[$_] : '.' ; # If $mask = 1 than ($input && $mask) will be same as $input # If $mask = 0 than ($input && $mask) is always 0 # But $mask = 0 only makes sense if $value = 0 # So if $mask = 0 we ignore that bit of $input } return $re; } sub _escape_bytes { # used for debug output my $string = shift; if ($string =~ /[\x00-\x1F\x7F]/) { $string = join '', map { my $o = ord($_); ($o < 32) ? '^' . chr($o + 64) : ($o == 127) ? '^?' : $_ ; } split '', $string; } return $string; } 1; __END__ =head1 NAME File::MimeInfo::Magic - Determine file type with magic =head1 SYNOPSIS use File::MimeInfo::Magic; my $mime_type = mimetype($file); =head1 DESCRIPTION This module inherits from L, it is transparent to its functions but adds support for the freedesktop magic file. Magic data is hashed when you need it for the first time. If you want to force hashing earlier use the C function. =head1 EXPORT The method C is exported by default. The methods C, C, C and C can be exported on demand. =head1 METHODS See also L for methods that are inherited. =over 4 =item C Returns a mime-type string for C<$file>, returns undef on failure. This method bundles C, C and C. Magic rules with an priority of 80 and higher are checked before C is called, all other magic rules afterwards. If this doesn't work the file is read and the mime-type defaults to 'text/plain' or to 'application/octet-stream' when the first ten chars of the file match ascii control chars (white spaces excluded). If the file doesn't exist or isn't readable C is returned. If C<$file> is an object reference only C and the default method are used. See below for details. =item C Returns a mime-type string for C<$file> based on the magic rules, returns undef on failure. C<$file> can be an object reference, in that case it is supposed to have a C and a C method. This allows you for example to determine the mimetype of data in memory by using L. Be aware that when using a filehandle or an C object you need to set the C<:utf8> binmode yourself if appropriate. =item C Rehash the data files. Glob and magic information is preparsed when this method is called. If you want to by-pass the XDG basedir system you can specify your database directories by setting C<@File::MimeInfo::DIRS>. But normally it is better to change the XDG basedir environment variables. =item C =item C =item C =item C =item C These routines are imported from L. =back =head1 SEE ALSO L =head1 LIMITATIONS Only word sizes of 1, 2 or 4 are supported. Any other word size is ignored and will cause a warning. =head1 AUTHOR Jaap Karssenberg Epardus@cpan.orgE Maintained by Michiel Beijen Emichiel.beijen@gmail.comE =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 itself. File-MimeInfo-0.29/lib/File/MimeInfo/Applications.pm000644 000765 000024 00000021237 13331544633 022727 0ustar00michielstaff000000 000000 package File::MimeInfo::Applications; use strict; use Carp; use File::Spec; use File::BaseDir qw/config_home config_dirs data_home data_dirs data_files/; use File::MimeInfo qw/mimetype_canon mimetype_isa/; use File::DesktopEntry; require Exporter; our $VERSION = '0.29'; our @ISA = qw(Exporter); our @EXPORT = qw( mime_applications mime_applications_all mime_applications_set_default mime_applications_set_custom ); print STDERR << 'EOT' unless data_files(qw/applications mimeinfo.cache/); WARNING: You don't seem to have any mimeinfo.cache files. Try running the update-desktop-database command. If you don't have this command you should install the desktop-file-utils package. This package is available from http://freedesktop.org/wiki/Software/desktop-file-utils/ EOT sub mime_applications { croak "usage: mime_applications(MIMETYPE)" unless @_ == 1; my $mime = mimetype_canon(shift @_); local $Carp::CarpLevel = $Carp::CarpLevel + 1; return wantarray ? (_default($mime), _others($mime)) : _default($mime); } sub mime_applications_all { croak "usage: mime_applications(MIMETYPE)" unless @_ == 1; my $mime = shift; return mime_applications($mime), grep defined($_), map mime_applications($_), mimetype_isa($mime); } sub mime_applications_set_default { croak "usage: mime_applications_set_default(MIMETYPE, APPLICATION)" unless @_ == 2; my ($mimetype, $desktop_file) = @_; (undef, undef, $desktop_file) = File::Spec->splitpath($desktop_file->{file}) if ref $desktop_file; croak "missing desktop entry filename for application" unless length $desktop_file; $desktop_file .= '.desktop' unless $desktop_file =~ /\.desktop$/; _write_list($mimetype, $desktop_file); } sub mime_applications_set_custom { croak "usage: mime_applications_set_custom(MIMETYPE, COMMAND)" unless @_ == 2; my ($mimetype, $command) = @_; $command =~ /(\w+)/; my $word = $1 or croak "COMMAND does not contain a word !?"; # Algorithm to generate name copied from other implementations my $i = 1; my $desktop_file = data_home('applications', $word.'-usercreated-'.$i.'.desktop'); while (-e $desktop_file) { $i++; $desktop_file = data_home('applications', $word.'-usercreated-'.$i.'.desktop'); } my $object = File::DesktopEntry->new(); $object->set( Type => 'Application', Name => $word, NoDisplay => 'true', Exec => $command, ); my (undef, undef, $df) = File::Spec->splitpath($desktop_file); _write_list($mimetype, $df); # creates dir if needed $object->write($desktop_file); return $object; } sub _default { my $mimetype = shift; my $user = config_home(qw/mimeapps.list/); my $system = config_dirs(qw/mimeapps.list/); my $deprecated = data_home(qw/applications mimeapps.list/); my $distro = data_dirs(qw/applications mimeapps.list/); my $legacy = data_home(qw/applications defaults.list/); unless ( ( -f $user || -f $system || -f $deprecated || -f $distro || -f $legacy ) && -r _ ) { return undef; } $Carp::CarpLevel++; my @list = _read_list($mimetype, $user, $system, $deprecated, $distro, $legacy); my $desktop_file = _find_file(reverse @list); $Carp::CarpLevel--; return $desktop_file; } sub _others { my $mimetype = shift; $Carp::CarpLevel++; my (@list, @done); for my $dir (data_dirs('applications')) { my $cache = File::Spec->catfile($dir, 'mimeinfo.cache'); next if grep {$_ eq $cache} @done; push @done, $cache; next unless -f $cache and -r _; for (_read_list($mimetype, $cache)) { my $file = File::Spec->catfile($dir, $_); next unless -f $file and -r _; push @list, File::DesktopEntry->new($file); } } $Carp::CarpLevel--; return @list; } sub _read_list { # read list with "mime/type=foo.desktop;bar.desktop" format my $mimetype = shift; my @list; my $succeeded; for my $file (@_) { if (open LIST, '<', $file) { $succeeded = 1; while () { /^\Q$mimetype\E=(.*)$/ or next; push @list, grep defined($_), split ';', $1; } close LIST; } } unless ($succeeded) { croak "Could not read any defaults, tried:\n" . join("\t\n", @_); } return @list; } sub _write_list { my ($mimetype, $desktop_file) = @_; my $file = config_home(qw/mimeapps.list/); my $text; if (-f $file) { open LIST, '<', $file or croak "Could not read file: $file"; while () { $text .= $_ unless /^\Q$mimetype\E=/; } close LIST; $text =~ s/[\n\r]?$/\n/; # just to be sure } else { _mkdir($file); $text = "[Default Applications]\n"; } open LIST, '>', $file or croak "Could not write file: $file"; print LIST $text; print LIST "$mimetype=$desktop_file;\n"; close LIST or croak "Could not write file: $file"; } sub _find_file { my @list = shift; for (@list) { my $file = data_files('applications', $_); return File::DesktopEntry->new($file) if $file; } return undef; } sub _mkdir { my $dir = shift; return if -d $dir; my ($vol, $dirs, undef) = File::Spec->splitpath($dir); my @dirs = File::Spec->splitdir($dirs); my $path = File::Spec->catpath($vol, shift @dirs); while (@dirs) { mkdir $path; # fails silently $path = File::Spec->catdir($path, shift @dirs); } die "Could not create dir: $path\n" unless -d $path; } 1; __END__ =head1 NAME File::MimeInfo::Applications - Find programs to open a file by mimetype =head1 SYNOPSIS use File::MimeInfo::Magic; use File::MimeInfo::Applications; my $file = '/foo/bar'; my $mimetype = mimetype($file) || die "Could not find mimetype for $file\n"; my ($default, @other) = mime_applications($mimetype); if (defined $default) { $default->system($file) } else { # prompt user with choice from @others # ... } =head1 DESCRIPTION This module tries to find applications that can open files with a certain mimetype. This is done in the way suggested by the freedesktop Desktop Entry specification. This module is intended to be compatible with file managers and other applications that implement this specification. This module depends on L being installed. To use this module effectively you need to have the desktop-file-utils package from freedesktop and run update-desktop-database after installing new .desktop files. See L. At the moment of writing this module is compatible with the way Nautilus (Gnome) and with Thunar (XFCE) handle applications for mimetypes. I understand KDE is still working on implementing the freedesktop mime specifications but will follow. At the very least all perl applications using this module are using the same defaults. =head1 EXPORT All methods are exported by default. =head1 METHODS =over 4 =item C Returns an array of L objects. The first is the default application for this mimetype, the rest are applications that say they can handle this mimetype. If the first result is undefined there is no default application and it is good practice to ask the user which application he wants to use. =item C Like C but also takes into account applications that can open mimetypes from which MIMETYPE inherits. Parent mimetypes tell something about the data format, all code inherits from text/plain for example. =item C Save a default application for this mimetype. This action will affect other applications using the same mechanism to find a default application. APPLICATION can either be a File::DesktopEntry object or the basename of a .desktop file. =item C Save a custom shell command as default application. Generates a DesktopEntry file on the fly and calls C. Returns the DesktopEntry object. No checks are done at all on COMMAND. It should however contain at least one word. =back =head1 NOTES This module looks for associations files in the order specified in version 1.0 of the MIME applications specification. It will also attempt a last-resort fallback to the legacy file F<$XDG_DATA_HOME/applications/defaults.list>. In all cases, it will only write to the recommended per-user defaults file located at F<$XDG_CONFIG_HOME/mimeapps.list>. =head1 AUTHOR Jaap Karssenberg Epardus@cpan.orgE Maintained by Michiel Beijen Emichiel.beijen@gmail.comE =head1 COPYRIGHT Copyright (c) 2005, 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 itself. =head1 SEE ALSO L, L, L, L L L =cut File-MimeInfo-0.29/lib/File/MimeInfo/Cookbook.pod000644 000765 000024 00000005704 13331544432 022213 0ustar00michielstaff000000 000000 =head1 NAME File::MimeInfo::Cookbook - various code snippets =head1 DESCRIPTION Some code snippets for non-basic uses of the L module: =over =item B A file does not have to actually exist in order to get a mimetype for it. This means that the following will work: my $extension = '*.txt'; my $mimetype = mimetype( $extension ); =item B If you want to find the mimetype of a scalar value you need magic mimetyping; after all a scalar doesn't have a filename or inode. What you need to do is to use IO::Scalar : use File::MimeInfo::Magic; use IO::Scalar; my $io_scalar = new IO::Scalar \$data; my $mimetype = mimetype( $io_scalar ); In fact most other C will work as long as they support the C and C methods. Of course if you want really obscure things to happen you can always write your own IO object and feed it in there. Be aware that when using a filehandle like this you need to set the C<:utf8> binmode yourself if appropriate. =item B Regrettably for non-seekable filehandles like STDIN simply using an C object will not work. You will need to buffer enough of the data for a proper mimetyping. For example you could mimetype data from STDIN like this: use File::MimeInfo::Magic; use IO::Scalar; my $data; read(STDIN, $data, $File::MimeInfo::Magic::max_buffer); my $io_scalar = new IO::Scalar \$data; my $mimetype = mimetype( $io_scalar ); Be aware that when using a filehandle like this you need to set the C<:utf8> binmode yourself if appropriate. =item B Say you have a temporary file that you want to save with a more proper filename. use File::MimeInfo::Magic qw#mimetype extensions#; use File::Copy; my $tmpfile = '/tmp/foo'; my $mimetype = mimetype($tmpfile); my $extension = extensions($mimetype); my $newfile = 'untitled1'; $newfile .= '.'.$extension if length $extension; move($tmpfile, $newfile); =item B Normally you just need to add the dir where your mime database lives to either the XDG_DATA_HOME or XDG_DATA_DIRS environment variables for it to be found. But in some rare cases you may want to by-pass this system all together. Try one of the following: @File::MimeInfo::DIRS = ('/home/me/share/mime'); eval 'use File::MimeInfo'; die if $@; or: use File::MimeInfo; @File::MimeInfo::DIRS = ('/home/me/share/mime'); File::MimeInfo->rehash(); This can also be used for switching between databases at run time while leaving other XDG configuration stuff alone. =back =head1 AUTHOR Jaap Karssenberg Epardus@cpan.orgE Maintained by Michiel Beijen Emichiel.beijen@gmail.comE =head1 COPYRIGHT Copyright (c) 2005, 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 itself. =head1 SEE ALSO L =cut File-MimeInfo-0.29/lib/File/MimeInfo/Rox.pm000644 000765 000024 00000010226 13331544633 021045 0ustar00michielstaff000000 000000 package File::MimeInfo::Rox; use strict; use Carp; use File::BaseDir qw/config_home data_dirs/; use File::Spec; require Exporter; our @ISA = qw(Exporter); our @EXPORT = qw(mime_exec mime_system); our @EXPORT_OK = qw(suggest_script_name); our %EXPORT_TAGS = (magic => \@EXPORT); our $VERSION = '0.29'; our @choicespath = ( config_home('rox.sourceforge.net'), File::Spec->catdir($ENV{HOME}, 'Choices'), data_dirs('Choices'), ); our ($DEBUG); sub import { my $parent = (grep {$_ eq q/:magic/} @_) ? q/File::MimeInfo::Magic/ : q/File::MimeInfo/; eval "use $parent"; die $@ if $@; goto \&Exporter::import; } sub mime_system { _do_mime('system', @_) } sub mime_exec { _do_mime('exec', @_) } sub _do_mime { my ($act, $file, $mimet) = (shift, shift, shift); $mimet ||= mimetype($file); return undef unless $mimet; print "Using mimetype: $mimet\n" if $DEBUG; my $script = _locate_script($mimet); return undef unless $script; print "Going to $act: $script $file\n" if $DEBUG; ($act eq 'exec') ? exec($script, $file, @_) : (system($script, $file, @_) == 0) or croak "couldn't $act: $script $file"; 42; } sub _locate_script { my $mime = shift; $mime =~ /^(\w+)/; my $media = $1; $mime =~ s#/#_#; my @p = $ENV{CHOICESPATH} ? split(/:/, $ENV{CHOICESPATH}) : (@choicespath); my $script; for ( map("$_/MIME-types/$mime", @p), map("$_/MIME-types/$media", @p) ) { print "looking for: $_\n" if $DEBUG; next unless -e $_; $script = $_; last; } return undef unless $script; $script = "$script/AppRun" if -d $script; return -f $script ? $script : undef; } sub suggest_script_name { my $m = pop; $m =~ s#/#_#; my @p = $ENV{CHOICESPATH} ? split(/:/, $ENV{CHOICESPATH}) : (@choicespath); return "$p[0]/MIME-types", $m; } 1; __END__ =head1 NAME File::MimeInfo::Rox - Open files by mimetype "Rox style" =head1 SYNOPSIS use File::MimeInfo::Magic; use File::MimeInfo::Rox qw/:magic/; # open some file with the appropriate program mime_system($somefile); # more verbose version my $mt = mimetype($somefile) || die "Could not find mimetype for $somefile\n"; mime_system($somefile, $mt) || die "No program to open $somefile available\n"; =head1 DESCRIPTION This module tries to mimic the behaviour of the rox file browser L when "opening" data files. It determines the mime type and searches in rox's C directories for a program to handle that mimetype. See the rox documentation for an extensive discussion of this mechanism. =head1 EXPORT The methods C and C are exported, if you use the export tag C<:magic> you get the same methods but L will be used for mimetype lookup. =head1 ENVIRONMENT The environment variable C is used when searching for rox's config dirs. It defaults to C<$ENV{HOME}/Choices:/usr/local/share/Choices:/usr/share/Choices> =head1 METHODS =over 4 =item C =item C Try to open C<$file> with the appropriate program for files of it's mimetype. You can use C<$mimetype> to force the mimetype. Also if you already know the mimetype it saves a lot of time to just tell it. If either the mimetype couldn't be determined or no appropriate program could be found C is returned. If the actual L fails an exception is raised. All remaining arguments are passed on to the handler. =item C =item C Like C but uses L instead of L, so it B if successful. =item C Returns the list C<($dir, $file)> for the suggested place to write new script files (or symlinks) for mimetype C<$mimetype>. The suggested dir doesn't need to exist. =back =head1 AUTHOR Jaap Karssenberg Epardus@cpan.orgE Maintained by Michiel Beijen Emichiel.beijen@gmail.comE =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 itself. =head1 SEE ALSO L, L, L =cut File-MimeInfo-0.29/t/07_pod_cover.t000644 000765 000024 00000000377 13331544432 017530 0ustar00michielstaff000000 000000 use Test::More; use File::BaseDir qw/xdg_data_dirs/; $ENV{XDG_DATA_DIRS} = join ':', 'share', xdg_data_dirs; eval "use Test::Pod::Coverage 1.00"; plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@; all_pod_coverage_ok(); File-MimeInfo-0.29/t/09_no404s.t000644 000765 000024 00000000466 13331544432 016600 0ustar00michielstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; if (!$ENV{EXTENDED_TESTING}) { plan skip_all => "Skip \$ENV{EXTENDED_TESTING} is not set\n"; } eval "use Test::Pod::No404s"; if ( $@ ) { plan skip_all => 'Test::Pod::No404s required for testing POD'; } else { all_pod_files_ok(); } File-MimeInfo-0.29/t/03_rox.t000644 000765 000024 00000000534 13331544432 016347 0ustar00michielstaff000000 000000 use Test::More tests => 2; $ENV{XDG_DATA_HOME} = './t/'; $ENV{XDG_DATA_DIRS} = './t/'; # forceing non default value $ENV{CHOICESPATH} = './t'; use_ok(q/File::MimeInfo::Rox/); is_deeply( [File::MimeInfo::Rox::suggest_script_name('video/mpeg')], ['./t/MIME-types', 'video_mpeg'], 'suggest_script_name works' ); # dunno what more to test :S File-MimeInfo-0.29/t/02_magic.t000644 000765 000024 00000001145 13331544432 016615 0ustar00michielstaff000000 000000 require Test::More; no warnings; @File::MimeInfo::DIRS = ('./t/mime'); # forceing non default value #$File::MimeInfo::DEBUG = 1; opendir MAGIC, 't/magic/'; my @files = grep {$_ !~ /^\./} readdir MAGIC; closedir MAGIC; Test::More->import( tests => (2 * scalar(@files) + 1) ); use_ok('File::MimeInfo::Magic', qw/mimetype magic/); for (@files) { $type = $_; $type =~ tr#_#/#; $type =~ s#\.\w+$##; ok( mimetype("t/magic/$_") eq $type, "complete (magic) typing of $_"); undef $type if $type eq "text/plain" || $type eq "application/octet-stream"; ok( magic("t/magic/$_") eq $type, "magic typing of $_" ); } File-MimeInfo-0.29/t/00_use_ok.t000644 000765 000024 00000000414 13331544432 017016 0ustar00michielstaff000000 000000 use Test::More tests => 4; require_ok('File::MimeInfo'); require_ok('File::MimeInfo::Magic'); require_ok('File::MimeInfo::Rox'); SKIP: { eval "use File::DesktopEntry"; skip('File::DesktopEntry not installed', 1) if $@; require_ok('File::MimeInfo::Applications'); } File-MimeInfo-0.29/t/magic/000755 000765 000024 00000000000 13331544766 016140 5ustar00michielstaff000000 000000 File-MimeInfo-0.29/t/000-report-versions-tiny.t000644 000765 000024 00000004312 13331544432 021672 0ustar00michielstaff000000 000000 use strict; use warnings; use Test::More 0.88; # This is a relatively nice way to avoid Test::NoWarnings breaking our # expectations by adding extra tests, without using no_plan. It also helps # avoid any other test module that feels introducing random tests, or even # test plans, is a nice idea. our $success = 0; END { $success && done_testing; } # List our own version used to generate this my $v = "\nGenerated by Dist::Zilla::Plugin::ReportVersions::Tiny v1.10\n"; eval { # no excuses! # report our Perl details my $want = '5.006001'; $v .= "perl: $] (wanted $want) on $^O from $^X\n\n"; }; defined($@) and diag("$@"); # Now, our module version dependencies: sub pmver { my ($module, $wanted) = @_; $wanted = " (want $wanted)"; my $pmver; eval "require $module;"; if ($@) { if ($@ =~ m/Can't locate .* in \@INC/) { $pmver = 'module not found.'; } else { diag("${module}: $@"); $pmver = 'died during require.'; } } else { my $version; eval { $version = $module->VERSION; }; if ($@) { diag("${module}: $@"); $pmver = 'died during VERSION check.'; } elsif (defined $version) { $pmver = "$version"; } else { $pmver = ''; } } # So, we should be good, right? return sprintf('%-45s => %-10s%-15s%s', $module, $pmver, $wanted, "\n"); } eval { $v .= pmver('Carp','any version') }; eval { $v .= pmver('Exporter','any version') }; eval { $v .= pmver('Fcntl','any version') }; eval { $v .= pmver('Pod::Usage','any version') }; eval { $v .= pmver('File::Spec','0.03') }; eval { $v .= pmver('File::DesktopEntry','0.04') }; eval { $v .= pmver('Test::More','0.88') }; eval { $v .= pmver('Path::Tiny','any version') }; # All done. $v .= <<'EOT'; Thanks for using my code. I hope it works for you. If not, please try and include this output in the bug report. That will help me reproduce the issue and solve your problem. EOT diag($v); ok(1, "we really didn't test anything, just reporting data"); $success = 1; # Work around another nasty module on CPAN. :/ no warnings 'once'; $Template::Test::NO_FLUSH = 1; exit 0; File-MimeInfo-0.29/t/01_normal.t000644 000765 000024 00000006613 13331544432 017031 0ustar00michielstaff000000 000000 use strict; use Test::More tests => 31; $ENV{XDG_DATA_HOME} = './t/'; $ENV{XDG_DATA_DIRS} = './t/'; # forceing non default value use_ok('File::MimeInfo', qw/mimetype describe globs/); # 1 # test what was read { no warnings; # don't bug me because I use these vars only once File::MimeInfo::rehash(); ok(scalar(keys %File::MimeInfo::literal) == 1, 'literal data is there'); # 2 ok(scalar(@File::MimeInfo::globs) == 1, 'globs data is there'); # 3 } # test _glob_to_regexp my $i = 0; for my $glob ( [ '*.pl', [ '(?-xism:^.*\.pl$)', '(?^u:^.*\.pl$)', '(?^:^.*\.pl$)' ] ], # 4 [ '*.h++', [ '(?-xism:^.*\.h\+\+$)', '(?^u:^.*\.h\+\+$)', '(?^:^.*\.h\+\+$)' ] ], # 5 [ '*.[tar].*', [ '(?-xism:^.*\.[tar]\..*$)', '(?^u:^.*\.[tar]\..*$)', '(?^:^.*\.[tar]\..*$)' ] ], # 6 [ '*.?', [ '(?-xism:^.*\..?$)', '(?^u:^.*\..?$)', '(?^:^.*\..?$)' ] ], # 7 ) { my $converted = File::MimeInfo::_glob_to_regexp( $glob->[0] ); my $number = ++$i; if ( my ($match) = grep { $_ eq "$converted" } @{ $glob->[1] } ) { pass( 'glob ' . $number . ' matches an expected value' ); note explain $match; next; } fail( 'glob ' . $number . ' matches an expected value' ); diag explain { got => "$converted", expected_one_of => $glob->[1] }; } # test parsing file names $i = 0; for ( ['script.pl', 'application/x-perl'], # 8 ['script.old.pl', 'application/x-perl'], # 9 ['script.PL', 'application/x-perl'], # 10 - case insensitive use of glob ['script.tar.pl', 'application/x-perl'], # 11 ['script.gz', 'application/x-gzip'], # 12 ['script.tar.gz', 'application/x-compressed-tar'], # 13 ['INSTALL', 'text/x-install'], # 14 ['script.foo.bar.gz', 'application/x-gzip'], # 15 ['script.foo.tar.gz', 'application/x-compressed-tar'], # 16 ['makefile', 'text/x-makefile'], # 17 ['./makefile', 'text/x-makefile'], # 18 ) { is( mimetype($_->[0]), $_->[1], 'file '.++$i ) } # test OO interface my $ref = File::MimeInfo->new ; is(ref($ref), q/File::MimeInfo/, 'constructor works'); # 19 is( $ref->mimetype('script.pl'), 'application/x-perl', 'OO syntax works'); # 20 # test default is( mimetype('t/default/binary_file'), 'application/octet-stream', 'default works for binary data'); # 21 is( mimetype('t/default/plain_text'), 'text/plain', 'default works for plain text'); # 22 is( mimetype('t/default/empty_file'), 'text/plain', 'default works for empty file'); # 23 ok( ! defined mimetype('t/non_existing_file'), 'default works for non existing file'); # 24 is( mimetype('t/default/utf8_text'), 'text/plain', 'we speak utf8' ); # 25 is( mimetype('t/default/encoding_breakage'), 'application/octet-stream', 'encoding bug gone' ); # 26 # test inode thingy is( mimetype('t'), 'inode/directory', 'directories are recognized'); # 27 SKIP: { unlink 't/symlink' or die "Could not unlink t/symlink" if -l 't/symlink'; skip('symlink not supported', 1) unless eval { symlink("",""); 1 } and symlink('t/default' => 't/symlink') ; is( mimetype('t/symlink'), 'inode/symlink', 'symlinks are recognized'); # 28 } # test describe ok( describe('text/plain') eq 'Plain Text', 'describe works' ); # 29 { no warnings; # don't bug me because I use this var only once $File::MimeInfo::LANG = 'nl'; } ok( describe('text/plain') eq 'Platte tekst', 'describe works with other languages' ); # 30 is( mimetype('t/test.png'), 'image/png', 'glob priority observed'); # 31 File-MimeInfo-0.29/t/05_more.t000644 000765 000024 00000003656 13331544432 016513 0ustar00michielstaff000000 000000 use strict; use File::Spec; use Test::More tests => 16; $ENV{XDG_DATA_HOME} = './t/'; $ENV{XDG_DATA_DIRS} = './t/'; # forceing non default value use_ok('File::MimeInfo', qw/extensions mimetype_canon mimetype_isa/); # 1 ## test reverse extension lookup ok( extensions('text/plain') eq 'asc', 'extenions works'); # 2 is_deeply( [extensions('text/plain')], [qw#asc txt#], 'wantarray extensions works' ); # 3 { # call above should have triggered rehash() no warnings; # don't bug me because I use these vars only once is(scalar(keys %File::MimeInfo::extension), 7, 'extension data is there'); # 4 } ## test alias lookup ok(mimetype_canon('text/plain') eq 'text/plain', 'canon is transparent'); # 5 ok(mimetype_canon('application/x-pdf') eq 'application/pdf', 'canon works'); # 6 ## test subclass lookup ok(mimetype_isa('text/foo', 'text/plain'), 'implicite text/plain subclass'); # 7 is_deeply([mimetype_isa('text/foo')], [qw(text/plain application/octet-stream)], 'implite application/octet-stream subclass'); # 8 ok(mimetype_isa('inode/mount-point', 'inode/directory'), 'implicte inode/directory subclass'); # 9 ok(mimetype_isa('application/x-perl', 'application/x-executable'), 'subclass form file'); # 10 is_deeply([mimetype_isa('application/x-perl')], [qw(application/x-executable text/plain application/octet-stream)], 'subclass list from file'); # 11 ## Tests for Applications SKIP: { eval { require File::DesktopEntry }; skip "File::DesktopEntry not installed", 3 if $@; use_ok('File::MimeInfo::Applications'); my %list = ( 'text/plain' => 'foo.desktop', 'image/svg+xml' => 'mirage.desktop', ); for my $type (keys %list) { my ($default, @other) = mime_applications($type); ok ( !defined($default) && (@other == 1) && ref($other[0]) eq 'File::DesktopEntry', 'mime_application() works' ); is ( $other[0]->{file}, File::Spec->catfile('t', 'applications', $list{$type}), "desktop file is the right one", ); } } File-MimeInfo-0.29/t/default/000755 000765 000024 00000000000 13331544766 016504 5ustar00michielstaff000000 000000 File-MimeInfo-0.29/t/08_changes.t000644 000765 000024 00000000226 13331544432 017152 0ustar00michielstaff000000 000000 use Test::More; eval 'use Test::CPAN::Changes 0.18'; plan skip_all => 'Test::CPAN::Changes 0.18 or later required for this test' if $@; changes_ok(); File-MimeInfo-0.29/t/test.png000644 000765 000024 00000000122 13331544432 016526 0ustar00michielstaff000000 000000 PNG  IHDR%VPLTE IDATc`!3IENDB`File-MimeInfo-0.29/t/11mimeinfo.t000644 000765 000024 00000001203 13331544432 017174 0ustar00michielstaff000000 000000 use strict; use warnings; use Test::More; use File::Spec; use FindBin qw($Bin); eval "use IO::Scalar"; my $have_io_scalar = !$@; my $mimetype_file = File::Spec->catfile($Bin, '..', 'mimetype'); my %tests = ( 'mimeopen', 'application/x-perl', 't/test.png', 'image/png', ); for my $test (sort keys %tests) { my $result = $tests{$test}; is(`$^X $mimetype_file --noalign $test`, "$test: $result\n", $test); SKIP: { skip "Skip stdin test because no IO::Scalar", 1 if !$have_io_scalar; is(`$^X $mimetype_file --noalign --stdin < $test`, "STDIN: $result\n", "$test (stdin)"); }; } done_testing; File-MimeInfo-0.29/t/applications/000755 000765 000024 00000000000 13331544766 017546 5ustar00michielstaff000000 000000 File-MimeInfo-0.29/t/10filehandle.t000644 000765 000024 00000000752 13331544432 017473 0ustar00michielstaff000000 000000 use strict; use warnings; use Test::More; use File::MimeInfo qw(mimetype inodetype globs); eval "use Path::Tiny"; if ($@) { plan skip_all => "module Path::Tiny not installed \n"; } is(mimetype(path('test.png')), 'image/png', 'mimetype of test.png'); is(mimetype(path('../t/test.png')), 'image/png', 'mimetype of file with path'); is(inodetype(path('test.png')), undef, 'inodetype of test.png'); is(globs(path('test.png')), 'image/png', 'globs of test.png'); done_testing; File-MimeInfo-0.29/t/mime/000755 000765 000024 00000000000 13331544766 016007 5ustar00michielstaff000000 000000 File-MimeInfo-0.29/t/text_plain_czech000644 000765 000024 00000000061 13331544432 020311 0ustar00michielstaff000000 000000 "tenika" this is a text with czech letters File-MimeInfo-0.29/t/04_IO_objects.t000644 000765 000024 00000001742 13331544432 017562 0ustar00michielstaff000000 000000 use strict; require Test::More; $ENV{XDG_DATA_HOME} = './t/'; $ENV{XDG_DATA_DIRS} = './t/'; # forceing non default value opendir MAGIC, 't/magic/'; my @files = grep {$_ !~ /\./ and $_ ne 'CVS'} readdir MAGIC; closedir MAGIC; Test::More->import( tests => scalar(@files) ); eval "use File::MimeInfo::Magic"; # force runtime evaluation die $@ if $@; unless (eval 'require IO::Scalar') { ok(1, 'Skip - no IO::Scalar found') for 0 .. $#files; } else { for (@files) { my $type = $_; $type =~ tr#_#/#; open FILE, "t/magic/$_" || die $!; my $file = join '', (); close FILE; my $io = new IO::Scalar \$file; ok( mimetype($io) eq $type, "typing of $_ as io::scalar" ) } } __END__ # Not all platforms seem to support <:encoding(latin2) :( unless (eval 'require IO::File') { ok(1, 'Skip - no IO::File found'); exit 0; } my $io = new IO::File; $io->open('t/text_plain_czech', '<:encoding(latin2)'); ok( mimetype($io) eq 'text/plain', "czech (ISO 8859-2) encoded text" ); File-MimeInfo-0.29/t/06_pod_ok.t000644 000765 000024 00000000235 13331544432 017013 0ustar00michielstaff000000 000000 use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok( all_pod_files(qw/bin lib/) ); File-MimeInfo-0.29/t/mime/subclasses000644 000765 000024 00000000112 13331544432 020061 0ustar00michielstaff000000 000000 application/x-perl application/x-executable application/x-perl text/plain File-MimeInfo-0.29/t/mime/magic000644 000765 000024 00000001127 13331544432 017001 0ustar00michielstaff000000 000000 MIME-Magic [80:application/vnd.corel-draw] >4=CDRXvrsn&+5 [50:application/msword] >0=1 >0=PO^Q` >0=7# >0=ࡱ >0=ۥ- >2080=Microsoft Word 6.0 Document >2112=Microsoft Word document data [50:application/octet-stream] >0= >0=~2 >0=~2 >0= >0=~2 [80:application/x-perl] >0=eval "exec /usr/local/bin/perl >1= /bin/perl+16 [50:text/x-patch] >0=diff >0=Index: >0=*** >0=Only in >0=Common subdirectories: [40:application/x-executable] >0=ELF 1>5= 2>16= >0=ELF 1>5= 2>16= >0=MZ >0=R >0=~2 >0=~2 >0= File-MimeInfo-0.29/t/mime/globs000644 000765 000024 00000000433 13331544432 017026 0ustar00michielstaff000000 000000 # This file is a test file -- it is incomplete ! application/x-perl:*.pl application/x-gzip:*.gz application/x-compressed-tar:*.tar.gz text/x-install:INSTALL text/x-makefile:[Mm]akefile text/plain:*.asc text/plain:*.txt text/x-patch:*.patch image/png:*.png image/apple-ios-png:*.png File-MimeInfo-0.29/t/mime/text/000755 000765 000024 00000000000 13331544766 016773 5ustar00michielstaff000000 000000 File-MimeInfo-0.29/t/mime/aliases000644 000765 000024 00000000117 13331544432 017340 0ustar00michielstaff000000 000000 application/x-pdf application/pdf application/x-zip-compressed application/zip File-MimeInfo-0.29/t/mime/text/plain.xml000644 000765 000024 00000002252 13331544432 020607 0ustar00michielstaff000000 000000 Plain Text Teks Murni Texti Testo semplice プレーンテキスト 보통 글월 Paprastas Tekstas Atklāts Teksts Panui Mäori Обичен текст Test Sempliċi Enkel tekst Platte tekst Rein tekst Text planer Zwykły tekst Texto simples Texto Plano Text simplu Обычный текст File-MimeInfo-0.29/t/applications/mimeinfo.cache000644 000765 000024 00000000101 13331544432 022314 0ustar00michielstaff000000 000000 [MIME Cache] text/plain=foo.desktop image/svg+xml=mirage.desktop File-MimeInfo-0.29/t/applications/mirage.desktop000644 000765 000024 00000001047 13331544432 022375 0ustar00michielstaff000000 000000 [Desktop Entry] Version=1.0 Type=Application Encoding=UTF-8 Name=Foo Viewer Comment=The best viewer for Foo objects available! Comment[eo]=Tekstredaktilo Comment[ja]=テキストエディタ TryExec=fooview Exec=fooview %F Icon=fooview.png MimeType=image/x-foo X-KDE-Library=libfooview X-KDE-FactoryName=fooviewfactory X-KDE-ServiceType=FooService [Desktop Action Inverse] # Inverse Foo => ooF Exec=fooview --inverse %f Name=Foo Viewer (inverse image) [Desktop Action Edit] Exec=fooview --edit %f Name=Foo Viewer (edit image) Icon=fooview-edit.png File-MimeInfo-0.29/t/applications/foo.desktop000644 000765 000024 00000001047 13331544432 021714 0ustar00michielstaff000000 000000 [Desktop Entry] Version=1.0 Type=Application Encoding=UTF-8 Name=Foo Viewer Comment=The best viewer for Foo objects available! Comment[eo]=Tekstredaktilo Comment[ja]=テキストエディタ TryExec=fooview Exec=fooview %F Icon=fooview.png MimeType=image/x-foo X-KDE-Library=libfooview X-KDE-FactoryName=fooviewfactory X-KDE-ServiceType=FooService [Desktop Action Inverse] # Inverse Foo => ooF Exec=fooview --inverse %f Name=Foo Viewer (inverse image) [Desktop Action Edit] Exec=fooview --edit %f Name=Foo Viewer (edit image) Icon=fooview-edit.png File-MimeInfo-0.29/t/default/binary_file000755 000765 000024 00000000023 13331544432 020676 0ustar00michielstaff000000 000000 ELF File-MimeInfo-0.29/t/default/plain_text000644 000765 000024 00000000035 13331544432 020562 0ustar00michielstaff000000 000000 This is a plain text file File-MimeInfo-0.29/t/default/utf8_text000644 000765 000024 00000000014 13331544432 020342 0ustar00michielstaff000000 000000 المادةFile-MimeInfo-0.29/t/default/empty_file000644 000765 000024 00000000000 13331544432 020540 0ustar00michielstaff000000 000000 File-MimeInfo-0.29/t/default/encoding_breakage000644 000765 000024 00000002000 13331544432 022014 0ustar00michielstaff000000 000000 [i %'KE+^iʱFjwl[X~an-k^ud$6[ui{OswE1'xo Av=hxjP Ȭ_>9ir< Ȓ-eR1rh^TB@.3rS!%;D])>fd'/ʞY u("eW}`k>M<!}rĔ+t `k.JsN=ṕ[ߌA"Vq%7wXڼ'žXX[R CjZнaVOCb!Z*DZG%ꏴKMVKA7_KEP3Gxg22_TL}HJ#0Ci$)[bk0/V+wW.VR#U8SV`2XXn=1Mi?xP2&s({F{RSF9 #-U?.30g<2;ji j67%ja(wdRm~3*D?́"VmYj~_eɔ"B[4Le7Eo(Slz4/ft#0mRB6J!Qj񓇆R`%X$Z:@>ÎFile-MimeInfo-0.29/t/magic/text_x-patch000644 000765 000024 00000002444 13331544432 020465 0ustar00michielstaff000000 000000 Index: update-mime-database.c =================================================================== RCS file: /home/freedesktop/shared-mime-info/update-mime-database.c,v retrieving revision 1.27 diff -u -r1.27 update-mime-database.c --- update-mime-database.c 2 Jun 2003 10:25:06 -0000 1.27 +++ update-mime-database.c 27 Aug 2003 14:39:22 -0000 @@ -786,7 +786,7 @@ */ static void parse_int_value(int bytes, const char *in, const char *in_mask, GString *parsed_value, char **parsed_mask, - GError **error) + gboolean big_endian, GError **error) { char *end; char *out_mask = NULL; @@ -802,7 +802,7 @@ for (b = 0; b < bytes; b++) { - int shift = (bytes - b - 1) * 8; + int shift = (big_endian ? (bytes - b - 1) : b) * 8; g_string_append_c(parsed_value, (value >> shift) & 0xff); } @@ -910,13 +910,13 @@ if (strstr(type, "16")) parse_int_value(2, in, in_mask, parsed_value, parsed_mask, - error); + type[0] == 'b', error); else if (strstr(type, "32")) parse_int_value(4, in, in_mask, parsed_value, parsed_mask, - error); + type[0] == 'b', error); else if (strcmp(type, "byte") == 0) parse_int_value(1, in, in_mask, parsed_value, parsed_mask, - error); + FALSE, error); else if (strcmp(type, "string") == 0) { getstr(in, parsed_value); File-MimeInfo-0.29/t/magic/application_msword000644 000765 000024 00000002163 13331544432 021751 0ustar00michielstaff000000 000000 ࡱ> QSJKR[@ bjbj44 ^ViVifffffffz z     S S S \^^^^^^oR^f S ^ff  s f f File-MimeInfo-0.29/t/magic/text_plain000644 000765 000024 00000000023 13331544432 020213 0ustar00michielstaff000000 000000 This is plain text File-MimeInfo-0.29/t/magic/application_vnd.corel-draw000644 000765 000024 00000000123 13331544432 023255 0ustar00michielstaff000000 000000 12345678CDR9vrsn101112.. For this magic type the mask should filter out the "9". File-MimeInfo-0.29/t/magic/application_x-perl000644 000765 000024 00000000045 13331544432 021642 0ustar00michielstaff000000 000000 #!/usr/bin/perl print "Hello world" File-MimeInfo-0.29/t/magic/application_octet-stream000644 000765 000024 00000000400 13331544432 023035 0ustar00michielstaff000000 000000 Dnu/ qm CB_@Z,tp}q_`(u_,4!mryn;V?E^l'mpXjvMM3mPԕtwG^dܘk4P%b|Fl Ŗe9File-MimeInfo-0.29/t/magic/application_x-executable000755 000765 000024 00000001251 13331544432 023024 0ustar00michielstaff000000 000000 ELF44 (444HH@ $$I$I((( Ptdtt8t8/lib/ld-linux.so.2GNUCM 7L+%&DH*<9$F5!(C@ K=>B# 3/8JA;4I1GE:0. File-MimeInfo-0.29/t/magic/application_x-perl.txt000644 000765 000024 00000000045 13331544432 022460 0ustar00michielstaff000000 000000 #!/usr/bin/perl print "Hello world"