File-MimeInfo-0.27/0000755000175000017500000000000012472721114013631 5ustar michielmichielFile-MimeInfo-0.27/t/0000755000175000017500000000000012472721114014074 5ustar michielmichielFile-MimeInfo-0.27/t/mime/0000755000175000017500000000000012472721114015023 5ustar michielmichielFile-MimeInfo-0.27/t/mime/text/0000755000175000017500000000000012472721114016007 5ustar michielmichielFile-MimeInfo-0.27/t/mime/text/plain.xml0000644000175000017500000000225212460255000017626 0ustar michielmichiel 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.27/t/mime/subclasses0000644000175000017500000000011212460255000017100 0ustar michielmichielapplication/x-perl application/x-executable application/x-perl text/plain File-MimeInfo-0.27/t/mime/aliases0000644000175000017500000000011712460255000016357 0ustar michielmichielapplication/x-pdf application/pdf application/x-zip-compressed application/zip File-MimeInfo-0.27/t/mime/magic0000644000175000017500000000112712460255000016020 0ustar michielmichielMIME-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.27/t/mime/globs0000644000175000017500000000043312460255000016045 0ustar michielmichiel# 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.27/t/text_plain_czech0000644000175000017500000000006112460255000017330 0ustar michielmichiel "tenika" this is a text with czech letters File-MimeInfo-0.27/t/default/0000755000175000017500000000000012472721114015520 5ustar michielmichielFile-MimeInfo-0.27/t/default/encoding_breakage0000644000175000017500000000200012460255000021033 0ustar michielmichiel[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.27/t/default/plain_text0000644000175000017500000000003512460255000017601 0ustar michielmichiel This is a plain text file File-MimeInfo-0.27/t/default/utf8_text0000644000175000017500000000001412460255000017361 0ustar michielmichielالمادةFile-MimeInfo-0.27/t/default/binary_file0000755000175000017500000000002312460255000017715 0ustar michielmichielELF File-MimeInfo-0.27/t/default/empty_file0000644000175000017500000000000012460255000017557 0ustar michielmichielFile-MimeInfo-0.27/t/magic/0000755000175000017500000000000012472721114015154 5ustar michielmichielFile-MimeInfo-0.27/t/magic/text_plain0000644000175000017500000000002312460255000017232 0ustar michielmichielThis is plain text File-MimeInfo-0.27/t/magic/application_msword0000644000175000017500000000216312460255000020770 0ustar michielmichielࡱ> QSJKR[@ bjbj44 ^ViVifffffffz z     S S S \^^^^^^oR^f S ^ff  s f f File-MimeInfo-0.27/t/magic/application_octet-stream0000644000175000017500000000040012460255000022054 0ustar michielmichielDnu/ qm CB_@Z,tp}q_`(u_,4!mryn;V?E^l'mpXjvMM3mPԕtwG^dܘk4P%b|Fl Ŗe9File-MimeInfo-0.27/t/magic/text_x-patch0000644000175000017500000000244412460255000017504 0ustar michielmichielIndex: 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.27/t/magic/application_x-executable0000755000175000017500000000125112460255000022043 0ustar michielmichielELF44 (444HH@ $$I$I((( Ptdtt8t8/lib/ld-linux.so.2GNUCM 7L+%&DH*<9$F5!(C@ K=>B# 3/8JA;4I1GE:0. File-MimeInfo-0.27/t/magic/application_vnd.corel-draw0000644000175000017500000000012312460255000022274 0ustar michielmichiel12345678CDR9vrsn101112.. For this magic type the mask should filter out the "9". File-MimeInfo-0.27/t/magic/application_x-perl.txt0000644000175000017500000000004512460255000021477 0ustar michielmichiel#!/usr/bin/perl print "Hello world" File-MimeInfo-0.27/t/magic/application_x-perl0000644000175000017500000000004512460255000020661 0ustar michielmichiel#!/usr/bin/perl print "Hello world" File-MimeInfo-0.27/t/01_normal.t0000644000175000017500000000661312472706312016062 0ustar michielmichiel 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.27/t/applications/0000755000175000017500000000000012472721114016562 5ustar michielmichielFile-MimeInfo-0.27/t/applications/mimeinfo.cache0000644000175000017500000000010112460255000021333 0ustar michielmichiel[MIME Cache] text/plain=foo.desktop image/svg+xml=mirage.desktop File-MimeInfo-0.27/t/applications/mirage.desktop0000644000175000017500000000104712460255000021414 0ustar michielmichiel[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.27/t/applications/foo.desktop0000644000175000017500000000104712460255000020733 0ustar michielmichiel[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.27/t/02_magic.t0000644000175000017500000000114512460255000015634 0ustar michielmichielrequire 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.27/t/06_pod_ok.t0000644000175000017500000000023512460255000016032 0ustar michielmichieluse 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.27/t/08_changes.t0000644000175000017500000000022612460255000016171 0ustar michielmichieluse 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.27/t/04_IO_objects.t0000644000175000017500000000174212460255000016601 0ustar michielmichieluse 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.27/t/09_no404s.t0000644000175000017500000000046612472706537015642 0ustar michielmichiel#!/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.27/t/03_rox.t0000644000175000017500000000053412460255000015366 0ustar michielmichiel 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.27/t/00_use_ok.t0000644000175000017500000000041412460255000016035 0ustar michielmichieluse 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.27/t/07_pod_cover.t0000644000175000017500000000037712460255000016547 0ustar michielmichieluse 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.27/t/05_more.t0000644000175000017500000000365612460255000015532 0ustar michielmichieluse 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.27/MANIFEST0000644000175000017500000000162212472706230014765 0ustar michielmichiel.travis.yml 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 META.json META.yml mimeopen mimetype README.md 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/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/text_plain_czech File-MimeInfo-0.27/.travis.yml0000644000175000017500000000046612472720631015753 0ustar michielmichiellanguage: perl perl: - "5.20" - "5.18" - "5.16" - "5.14" - "5.12" - "5.10" - "5.8" before_install: - sudo apt-get update -qq - sudo apt-get install -qq desktop-file-utils install: - cpanm --quiet File::BaseDir File::DesktopEntry Path::Tiny Test::Pod Test::Pod::Coverage Test::CPAN::Changes File-MimeInfo-0.27/mimetype0000755000175000017500000002743412472714532015430 0ustar michielmichiel#!/usr/bin/perl use strict; our $VERSION = '0.27'; $|++; # ########## # # 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.27/mimeopen0000755000175000017500000002066212472714532015404 0ustar michielmichiel#!/usr/bin/perl use strict; our $VERSION = '0.27'; $|++; # ########## # # 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.27/Makefile.PL0000644000175000017500000000276512472716317015626 0ustar michielmichieluse 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" }, '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', }, x_contributors => [ 'Michiel Beijen ', 'Christian Ludwig ', 'Bernhard Rosenkränzer ', 'David Steinbrunner ', 'Jitka Plesnikova ', 'Jonathan Dowland ', 'Sean Smith ', 'Stefan Seifert ', 'brian m. carlson ', ], }, ); File-MimeInfo-0.27/lib/0000755000175000017500000000000012472721114014377 5ustar michielmichielFile-MimeInfo-0.27/lib/File/0000755000175000017500000000000012472721114015256 5ustar michielmichielFile-MimeInfo-0.27/lib/File/MimeInfo/0000755000175000017500000000000012472721114016761 5ustar michielmichielFile-MimeInfo-0.27/lib/File/MimeInfo/Magic.pm0000644000175000017500000002142312472714533020350 0ustar michielmichielpackage 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.27'; our $DEBUG; our $_hashed = 0; our (@magic_80, @magic, $max_buffer); # @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.27/lib/File/MimeInfo/Cookbook.pod0000644000175000017500000000570412460255000021232 0ustar michielmichiel=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.27/lib/File/MimeInfo/Rox.pm0000644000175000017500000001022512472714533020076 0ustar michielmichielpackage 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.27'; 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 apropriate 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.27/lib/File/MimeInfo/Applications.pm0000644000175000017500000002003012472714533021747 0ustar michielmichielpackage File::MimeInfo::Applications; use strict; use Carp; use File::Spec; use File::BaseDir qw/data_home data_dirs data_files/; use File::MimeInfo qw/mimetype_canon mimetype_isa/; use File::DesktopEntry; require Exporter; our $VERSION = '0.27'; 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 $file = data_home(qw/applications defaults.list/); return undef unless -f $file && -r _; $Carp::CarpLevel++; my @list = _read_list($mimetype, $file); 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, $file) = @_; my @list; open LIST, '<', $file or croak "Could not read file: $file"; while () { /^\Q$mimetype\E=(.*)$/ or next; push @list, grep defined($_), split ';', $1; } close LIST; return @list; } sub _write_list { my ($mimetype, $desktop_file) = @_; my $file = data_home(qw/applications defaults.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 At present the file with defaults is F<$XDG_DATA_HOME/applications/defaults.list>. This file is not specified in any freedesktop spec and if it gets standardized it should probably be located in C<$XDG_CONFIG_HOME>. For this module I tried to implement the status quo. =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 =cut File-MimeInfo-0.27/lib/File/MimeInfo.pm0000644000175000017500000003420312472714533017330 0ustar michielmichielpackage 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.27'; 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; } 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 () { next if /^\s*#/ or ! /\S/; # skip comments and empty lines chomp; my ($k, $v) = split /\s+/, $_, 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 =head1 SYNOPSIS use File::MimeInfo; my $mime_type = mimetype($file); =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.27/README.md0000644000175000017500000000213612472707423015121 0ustar michielmichiel# 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.27/Changes0000644000175000017500000001606712472714224015142 0ustar michielmichielRevision history for Perl extension File::MimeInfo. Versions up to 0.15 by Jaap Karssenberg Versions starting 0.16 by Michiel Beijen 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.27/META.yml0000644000175000017500000000217112472721114015103 0ustar michielmichiel--- 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' configure_requires: ExtUtils::MakeMaker: '6.30' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.143240' 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.27' x_contributors: - 'Michiel Beijen ' - 'Christian Ludwig ' - 'Bernhard Rosenkränzer ' - 'David Steinbrunner ' - 'Jitka Plesnikova ' - 'Jonathan Dowland ' - 'Sean Smith ' - 'Stefan Seifert ' - 'brian m. carlson ' File-MimeInfo-0.27/META.json0000644000175000017500000000327012472721114015254 0ustar michielmichiel{ "abstract" : "Determine file types", "author" : [ "Jaap Karssenberg " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.143240", "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" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/mbeijen/File-MimeInfo/issues" }, "repository" : { "url" : "https://github.com/mbeijen/File-MimeInfo" } }, "version" : "0.27", "x_contributors" : [ "Michiel Beijen ", "Christian Ludwig ", "Bernhard Rosenkränzer ", "David Steinbrunner ", "Jitka Plesnikova ", "Jonathan Dowland ", "Sean Smith ", "Stefan Seifert ", "brian m. carlson " ] }