File-MMagic-1.30/0000755000175000017500000000000012164470762012146 5ustar knokknokFile-MMagic-1.30/README.en0000644000175000001440000000102511730326440013607 0ustar knokusersFile::MMagic Copyright(C) 1999-2006 NOKUBI Takatsugu Yukio USUDA 1. Abstract This module is to guess file type from its contents like file(1) command. 2. Install Extract archive file. Change current directory to File-MMagic-x.xx ("x.xx" is version number). Type "perl Makefile.PL" to create Makefile. Type "make install" to install. 3. How to use See "perldoc File::MMagic". 4. Copyright See COPYING file. 5. See also http://www.namazu.org/trac-namazu/trac.cgi/wiki/File-MMagic.en File-MMagic-1.30/META.yml0000644000175000017500000000103412164470762013415 0ustar knokknok--- #YAML:1.0 name: File-MMagic version: 1.30 abstract: Guess file type from contents author: - NOKUBI Takatsugu license: unknown distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: {} no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.57_05 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 File-MMagic-1.30/Makefile.PL0000644000175000001440000000054211730326440014303 0ustar knokusers# File::MMagic Makefile.PL # # $Id: Makefile.PL 112 1999-10-27 09:44:08Z knok $ use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'File::MMagic', 'VERSION_FROM' => 'MMagic.pm', ($] ge '5.005') ? ('AUTHOR' => 'NOKUBI Takatsugu ', 'ABSTRACT' => 'Guess file type from contents', ) : (), ); File-MMagic-1.30/ChangeLog0000644000175000001440000003034612164470536014120 0ustar knokusers2013-07-02 NOKUBI Takatsugu * MMagic.pm: Version 1.30. 2013-01-21 NOKUBI Takatsugu * MMagic.pm (checktype_byfilename): Remove Scalar::Util::weaken. To prevent too much decrement REFCNT. 2012-07-12 NOKUBI Takatsugu * MMagic.pm (checktype_contents): Fix infinity loop bug. Reported by NMOLDAV@cpan.org (#77836) * Version 1.29. 2012-06-29 NOKUBI Takatsugu * MMagic.pm: Add missing =back. 2012-05-31 NOKUBI Takatsugu * MMagic.pm: Version 1.28. 2012-03-15 NOKUBI Takatsugu * MMagic.pm (readMagicEntry): Removed deprecated code (defined(@array)) reported by wyant@cpan.org (#74252). 2011-07-21 Yukio USUDA * MMagic.pm (checktype_byfilename): Fixed memory leak. 2007-10-02 NOKUBI Takatsugu * MMagic.pm: Added 'regex' and 'search' support for magic entry, and fixed fatal error when unknown type in magic entry. (The patch made by Man Min Yan, thank you). 2006-09-19 NOKUBI Takatsugu * MMagic.pm (readMagicLine): Added Hex representation support. (The patch made by Man Min Yan, thank you) 2006-07-01 NOKUBI Takatsugu * MMagic.pm (checktype_container): Added container check. (Powerd by CodeFest 2006 Akihabara https://members.fsij.org/trac/codefestakihabara2006c) 2006-06-26 NOKUBI Takatsugu * Applied subclass patch, made by Michael Hendricks. 2006-05-23 NOKUBI Takatsugu * MMagic.pm: Version 1.27. * MMagic.pm (readMagicLine): Changed regex for magic entry. (Reported by Dylan Vanderhoof, thank you) 2006-05-17 NOKUBI Takatsugu * MMagic.pm: Added a new line at the end of file. (Reported by Vilmos Soti, thank you.) 2006-02-08 Yukio USUDA * MMagic.pm (magicMatch, dumpMagic): Fixed time waste problem. 2006-01-30 NOKUBI Takatsugu * MMagic.pm: Version 1.26. 2006-01-12 Yukio USUDA * MMagic.pm (magicMatchStr): Fixed Bug. Enbuged at Chageset 194. 2006-01-11 NOKUBI Takatsugu * README.* : Added the Trac URL. 2006-01-05 Yukio USUDA * MMagic.pm (checktype_data): performance improve. http://www.namazu.org/trac-namazu/trac.cgi/ticket/8 * MMagic.pm (magicMatchStr): Fixed time waste problem. * MMagic.pm (__DATA__): Perfomance tuning for mknmz. http://www.namazu.org/pipermail/namazu-devel-ja/2005-December/000793.html 2005-08-27 NOKUBI Takatsugu * Version 1.25. * Moved Build.PL to contrib directory. 2005-08-01 NOKUBI Takatsugu * Version 1.24. * MMagic.pm (check_binary): Removed brackets, closes #13535. (Reported by dakkar, thank you) 2005-07-29 NOKUBI Takatsugu * MMagic.pm: Version 1.23. 2004-04-21 NOKUBI Takatsugu * MMagic.pm (magicMatchStr): Added a length check. Reported by Tadamasa Teranishi, thank you. 2004-03-17 NOKUBI Takatsugu * Build.PL: Added. Contributed by Ryuji Abe, thank you. 2004-03-15 NOKUBI Takatsugu * MMagic.pm: Version 1.22. Changed to treat string/[BCc] as same as string. * Added the 4th test. 2003-11-21 NOKUBI Takatsugu * Version 1.21. * Fixed some tests (bad usage of new method). * Added the third test. Contributed by Simon Matthews, thank you! 2003-11-20 NOKUBI Takatsugu * MMagic.pm (new): Fixed mod_perl issue. Contributed by Simon Matthews, thank you! 2003-07-31 NOKUBI Takatsugu * Version 1.20. * MMagic.pm (addMagicEntry): Added a capability of adding sub entry. 2003-05-08 NOKUBI Takatsugu * Version 1.19. * MMagic.pm (new): Changed the scope of $dataLoc variable. I think it should be fix the following problem. https://rt.cpan.org/Ticket/Display.html?id=2499 If the problem is still there, mail me please. (Reported and patch contributed by Mark Stosberg, thank you) * MMagic.pm (__DATA__): Added EPS entry. (Contributed by Jason Maggard, thank you) 2003-03-26 NOKUBI Takatsugu * Version 1.18. * MMagic.pm (new): Fixed special entry for x-roff. (Reported by Okayasu, thank you) 2003-03-03 NOKUBI Takatsugu * Version 1.17. * MMagic.pm (__DATA__): Removed unnecessary tab in audio/x-wav. (Reported by Knut Haugen, thank you) 2002-09-12 NOKUBI Takatsugu * Version 1.16. * MMagic.pm (new): Fixed binmode() place. (contributed by Everton da Silva Marques, thank you.) 2002-03-14 NOKUBI Takatsugu * MMagic.pm (new): Added a signature for text/x-roff type. 2002-02-22 NOKUBI Takatsugu * Version 1.15. * MMagic.pm: Added new funtions removeSpecials and removeExts. (Patch contributed by Hilko Bengen, thank you.) 2001-11-13 NOKUBI Takatsugu * MMagic.pm: Added binmode() in some file handles. (Reported by Antony O'Sullivan, thanks.) 2001-08-08 NOKUBI Takatsugu * README.en : Added the notice section. * README.ja : Ditto. 2001-07-17 NOKUBI Takatsugu * MANIFEST: Added t/02-extmagic.t for distribution. * t/02-extmagic.t: Added a new file for testing. * MANIFEST: Added t/01-selfcheck.t for distribution. * t/01-selfcheck.t: Added a new file for testing. 2001-07-05 NOKUBI Takatsugu * MMagic.pm (checktype_filename): Added workaround for MSWin32 symlink handling probrem on ActivePerl build 626. (Reported by Thomas Yengst, thank you.) * perl-File-MMagic.spec: Removed. 2001-06-20 NOKUBI Takatsugu * MMagic.pm: Added some archives entry (arc, zoo, arj, rar). 2001-06-19 NOKUBI Takatsugu * MMagic.pm: Added ms-tnef entry. * Version 1.14. 2001-06-18 NOKUBI Takatsugu * MMagic.pm: Added more comment on pod. 2001-06-15 NOKUBI Takatsugu * MMagic.pm (readMagicEntry): Fixed warning output probrem on large magic database. (Reported and patched by John R Lenton. Thanks.) * Version 1.13. 2001-02-09 NOKUBI Takatsugu * MMagic.pm (checktype_data): Changed evaluation sequence of binary-checking and specials-checking. Version 1.12. 2000-12-11 NOKUBI Takatsugu * Discarded disallowEightbit(). Add new variable "allowEightbit". Version 1.11. * MMagic.pm (disallowEightbit): Added new entry. Version 1.10. 2000-10-10 NOKUBI Takatsugu * MMagic.pm: Removed a text/x-info related entry. Version 1.09. 2000-09-12 NOKUBI Takatsugu * MMagic.pm : Added image/png entry. (suggested by Jamie LeTual. Thanks.) Version 1.08. 2000-08-09 NOKUBI Takatsugu * MMagic.pm (new): Added '\.' in $self->{FILEEXTS}. (reported by Yasunori Tada. Thanks.) Version 1.07. 2000-03-29 NOKUBI Takatsugu * MMagic.pm: Removed "\v" from %ESC. 2000-03-23 NOKUBI Takatsugu * MMagic.pm: Added some entries. (committed by kenzo-. Thanks.) 2000-03-08 NOKUBI Takatsugu * Version 1.03. * MMagic.pm (addMagicEntry): Changed priority for added entry. 2000-03-03 NOKUBI Takatsugu * Version 1.02. * MMagic.pm: Added the original copyrignt. (I apology to the original author David Kulp, I overlook it.) (magicMatchStr): Fixed short data handling probrem. 2000-02-29 NOKUBI Takatsugu * Fixed version number. Version 1.01. * Version 1.00. * MMagic.pm (checktype_filehandle): Fixed to work multiple subtests. 2000-02-28 NOKUBI Takatsugu * MMagic.pm: Changed URI for Namzu Project. (contributed by Satoru Takabayasi) Fixed to work multiple subtests. Changed some entries for MicroSoft Office files. Fixed addFileExts() bug. Changed to check file-extends for case insensitive. * perl-File-MMagic.spec: Created. (contributed by Ryuji Abe) 2000-02-24 NOKUBI Takatsugu * MMagic.pm: Changed to work subtest matching. 2000-02-10 NOKUBI Takatsugu * Version 0.20. * MMagic.pm: Fixed media type for RIFF format. Added audio/mpeg, video/mpeg, video/quicktime format. (Thanks for Mr. Perter Breton.) 1999-12-02 NOKUBI Takatsugu * prel-File-MMagic.spec: Renamed from File-MMagic.spec. 1999-11-30 NOKUBI Takatsugu * MMagic.pm: Version 0.19. 1999-11-29 NOKUBI Takatsugu * MMagic.pm: Changed to work with Win32 envoronment. Added excel, powerpoint, ichitaro* entries. (Thanks for kenzo-.) 1999-11-15 NOKUBI Takatsugu * MMagic.pm (new): Changed to handle specified filename for magic file. (Thanks for Mr. Philippe Chiasson.) 1999-10-27 NOKUBI Takatsugu * Added 'AUTHOR' and 'ABSTRACT' paramaters on Makefile.PL. 1999-10-05 NOKUBI Takatsugu * Added excluding character CR on check_binary() function. 1999-09-14 NOKUBI Takatsugu * Changed to return magicMatchStr function when null string is specified in $str. 1999-09-13 NOKUBI Takatsugu * Changed `text/html' SPECIALS entry. * Added empty check on checktype_data, checktype_magic. * Removed non-standard type entry from %SPECIALS, %FILEEXTS, __DATA__. * Added new methods addSpecials, addFileExts, addMagicEntry. * Moved global %SPECIALS, %FILEEXTS variable to object. * Renamed spec file. 1999-09-10 NOKUBI Takatsugu * Added spec file. (Thanks to Mr.Abe.) 1999-09-09 NOKUBI Takatsugu * Fixed unescaped space in VRML magic entry. (Thanks to Mr.Takaku.) 1999-09-08 NOKUBI Takatsugu * Changed %SPECIALS contents. (Remove 'Organization:' from news, add space character on rfc822/news message header, add "^X-Mailer: " on rfc822, add "^X-Newsreader: " on news, add "^From ", "^To: " on rfc822.) * Separated checktype_magic() from checktype_contents(). 1999-09-06 NOKUBI Takatsugu * Added excluding character TAB on check_binary() function. (Tkanks to Mr.Takaku) * Added VRML magic entries. (Tkanks to Mr.Takaku) 1999-08-03 NOKUBI Takatsugu * Fixed flie close bug in checktype_filehandle(). (Thanks to Mr. Alan) 1999-07-29 NOKUBI Takatsugu * Fixed %SPECIALS evaluation bug. * Release version 0.16. 1999-07-14 NOKUBI Takatsugu * Added blessing FileHandle process in new function. (Thanks to Mr. majiCk) 1999-07-13 NOKUBI Takatsugu * Release version 0.15. 1999-07-06 NOKUBI Takatsugu * Fix %SPECIALS media types. (text/(rfc822|news) is bad, message/* is correct. Thanks to Mr.Takaku.) * Changed %SPECIALS token regexp. 1999-06-29 NOKUBI Takatsugu * Fix truncating data processing bug in checktype_data function (pack('a8192') padded "\0", it cause a probrem.) 1999-06-18 NOKUBI Takatsugu * Add initialize some variables code in readMagicEntry function (to avoid '-w' warning). * Add length check code in checktype_contents function. 1999-06-17 NOKUBI Takatsugu * Change %SPECIAL checking code. * Add checktype_byfilename function. * Add data truncation process on checktype_data function. 1999-06-16 NOKUBI Takatsugu * Reorder some magic entries. * Fix MHonArc magic entry. * Add RFC check to %SPECIALS. 1999-06-15 NOKUBI Takatsugu * Add 2 magic entries (MHonArc and bzip2). 1999-06-14 NOKUBI Takatsugu * Add the Apache License. (Thanks to Ian Kluft.) * Add checktype_contents() function. * Add zero check routine in check_binary() funciton. 1999-06-11 NOKUBI Takatsugu * Change __DATA__ handling. (Thanks to Mr. Inaba, Mr. Maeda, and fj.comp.lang.perl.) 1999-06-10 NOKUBI Takatsugu * Initial version. * Branch 'classify' version. File-MMagic-1.30/README.ja0000644000175000001440000000322411730326440013602 0ustar knokusersFile::MMagic Copyright(C) 1999-2006 NOKUBI Takatsugu Yukio USUDA 1. $B$O$8$a$K(B $B$3$N%b%8%e!<%k$O!"(Bfile(1)$B%3%^%s%I$KAjEv$9$k5!G=!"$9$J$o$A%U%!%$%k$NFb(B $BMF$+$i$=$N$d%U%!%$%k%O%s%I%k$+$i?dB,$9$k$3$H$,$G$-$^$9!#(B $B>\$7$$;H$$J}$O!"(Bperldoc File::MMagic$BEy$G3NG'$7$F$/$@$5$$!#(B 4. $BCx:n8"I=<((B Copyright(C) 1999-2001 NOKUBI Takatsugu * Copyright (c) Ian F. Darwin, 1987. * Written by Ian F. Darwin. * Copyright (c) 1995-1999 The Apache Group. All rights reserved. $B$3$N%b%8%e!<%k$O40A4$KL5J]>c$G$9!#(B $B$^$?!"$3$N%b%8%e!<%k$O(BThe Unix Reconstruction Project$B$N@.2LJ*$G$"$k(B Perl Power Tools$B$N(Bfile.kulp$B$r85$K:n@.$5$l$F$$$^$9!#$5$i$K!"(BThe Apache HTTP server project$B$N@.2LJ*$N0lIt$G$"$k(Bmagic$B%U%!%$%k$r85$K$7$?%G!<%?$r(B $BFbJq$7$F$$$^$9!#$h$C$F!"Cx:n8"$O$3$l$i%*%j%8%J%k$N%=%U%H%&%'%"$K=`$8$?(B $B07$$$H$7$^$9!#(B $B>\:Y$O!"%"!<%+%$%V$K4^$^$l$k(BCOPYING$B$H$$$&%U%!%$%k$r;2>H$7$F$/$@$5$$!#(B The Unix Reconstruction Project The Apache HTTP server project 5. $B;2>H(B http://www.namazu.org/trac-namazu/trac.cgi/wiki/File-MMagic File-MMagic-1.30/MANIFEST0000644000175000017500000000046212164470762013301 0ustar knokknokChangeLog MMagic.pm MANIFEST COPYING README.ja README.en Makefile.PL t/01-selfcheck.t t/02-extmagic.t t/03-typecheck.t t/test.html t/04-string-mod.t t/test-magic t/05-subclass.t t/06-conthook.t t/07-contents.t contrib/Build.PL META.yml Module meta-data (added by MakeMaker) File-MMagic-1.30/t/0000755000175000017500000000000012164470762012411 5ustar knokknokFile-MMagic-1.30/t/05-subclass.t0000644000175000001440000000053611730326440015025 0ustar knokusersuse strict; use warnings; use Test::More tests => 3; my $mm = Example::Module->new(); isa_ok( $mm, 'Example::Module', 'subclassed object' ); isa_ok( $mm, 'File::MMagic', 'subclassed object' ); is( $mm->checktype_filename(), 'foo/bar', 'override method' ); package Example::Module; use base qw( File::MMagic ); sub checktype_filename { 'foo/bar' } File-MMagic-1.30/t/test.html0000644000175000001440000000007111730326440014436 0ustar knokusers A test file File-MMagic-1.30/t/04-string-mod.t0000644000175000001440000000062611730326440015270 0ustar knokusers# perl-test # $Id: 04-string-mod.t 187 2005-07-29 05:55:40Z knok $ use strict; use Test; BEGIN { plan tests => 2 }; use File::MMagic; my $dir = -d 't' ? 't/' : ''; my $m1 = File::MMagic->new($dir . 'test-magic'); my $ret = $m1->checktype_filename($dir . 'test.html'); ok($ret eq 'text/html'); my $m2 = File::MMagic->new(); $ret = $m2->checktype_filename($dir . 'test.html'); ok($ret eq 'text/html'); File-MMagic-1.30/t/06-conthook.t0000644000175000001440000000057111730326440015032 0ustar knokusers# perl-test # $Id$ use strict; use Test; BEGIN { plan tests => 1 }; use File::MMagic; my $ans = "text/plain; conthook"; my $magic = File::MMagic->new(); $magic->addContainerHook($ans, sub { my $self = shift; my $data = shift; return "text/plain; conthook" if $data =~ /conthook/; return ""; }); my $ret = $magic->checktype_container('text conthook'); ok($ret eq $ans); File-MMagic-1.30/t/test-magic0000644000175000001440000000007111730326440014551 0ustar knokusers0 string/cB \ 1 }; use File::MMagic; my $magic = File::MMagic->new(); $magic->addMagicEntry("0\tstring\t#\\ perl-test\tapplication/x-perl-test"); my $ret = $magic->checktype_filename('t/02-extmagic.t'); ok($ret eq 'application/x-perl-test'); File-MMagic-1.30/t/03-typecheck.t0000644000175000001440000000057711730326440015170 0ustar knokusers# perl-test # $Id: 03-typecheck.t 182 2003-11-21 02:25:52Z knok $ use strict; use Test; BEGIN { plan tests => 2 }; use File::MMagic; my $dir = -d 't' ? 't/' : ''; my $m1 = File::MMagic->new(); my $ret = $m1->checktype_filename($dir . 'test.html'); ok($ret eq 'text/html'); my $m2 = new File::MMagic; $ret = $m2->checktype_filename($dir . 'test.html'); ok($ret eq 'text/html'); File-MMagic-1.30/t/07-contents.t0000644000175000001440000000033411777415622015055 0ustar knokusers# perl-test # $Id$ use strict; use Test; BEGIN { plan tests => 1 }; use File::MMagic; my $ans = "text/plain"; my $magic = File::MMagic->new(); my $ret = $magic->checktype_contents('text conthook'); ok($ret eq $ans); File-MMagic-1.30/t/01-selfcheck.t0000644000175000001440000000037611730326440015133 0ustar knokusers# perl-test # $Id: 01-selfcheck.t 182 2003-11-21 02:25:52Z knok $ use strict; use Test; BEGIN { plan tests => 1 }; use File::MMagic; my $magic = File::MMagic->new(); my $ret = $magic->checktype_filename('t/01-selfcheck.t'); ok($ret eq 'text/plain'); File-MMagic-1.30/contrib/0000755000175000017500000000000012164470762013606 5ustar knokknokFile-MMagic-1.30/contrib/Build.PL0000644000175000001440000000043211730326440015263 0ustar knokusersuse Module::Build; my $build = Module::Build->new ( module_name => 'File::MMagic', dist_version_from => 'MMagic.pm', license => 'open_source', requires => {'perl' => '5.005'}, pm_files => {'MMagic.pm' => 'lib/File/MMagic.pm'}, ); $build->create_build_script; File-MMagic-1.30/COPYING0000644000175000001440000001063111730326440013364 0ustar knokusersThis program is originated from file.kulp that is a production of The Unix Reconstruction Projct. Copyright (c) 1999 NOKUBI Takatsugu . There is no warranty for the program. This product includes software developed by the Apache Group for use in the Apache HTTP server project (http://www.apache.org/). Licence for the program is followed the original software. The licence is below. This program is free and open software. You may use, copy, modify, distribute and sell this program (and any modified variants) in any way you wish, provided you do not restrict others to do the same, except for the following consideration. I read some of Ian F. Darwin's BSD C implementation, to try to determine how some of this was done since the specification is a little vague. I don't believe that this perl version could be construed as an "altered version", but I did grab the tokens for identifying the hard-coded file types in names.h and copied some of the man page. Here's his notice: * Copyright (c) Ian F. Darwin, 1987. * Written by Ian F. Darwin. * * This software is not subject to any license of the American Telephone * and Telegraph Company or of the Regents of the University of California. * * Permission is granted to anyone to use this software for any purpose on * any computer system, and to alter it and redistribute it freely, subject * to the following restrictions: * * 1. The author is not responsible for the consequences of use of this * software, no matter how awful, even if they arise from flaws in it. * * 2. The origin of this software must not be misrepresented, either by * explicit claim or by omission. Since few users ever read sources, * credits must appear in the documentation. * * 3. Altered versions must be plainly marked as such, and must not be * misrepresented as being the original software. Since few users * ever read sources, credits must appear in the documentation. * * 4. This notice may not be removed or altered. The following is the Apache License. This program contains the magic file that derived from the Apache HTTP Server. * Copyright (c) 1995-1999 The Apache Group. All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in * the documentation and/or other materials provided with the * distribution. * * 3. All advertising materials mentioning features or use of this * software must display the following acknowledgment: * "This product includes software developed by the Apache Group * for use in the Apache HTTP server project (http://www.apache.org/)." * * 4. The names "Apache Server" and "Apache Group" must not be used to * endorse or promote products derived from this software without * prior written permission. For written permission, please contact * apache@apache.org. * * 5. Products derived from this software may not be called "Apache" * nor may "Apache" appear in their names without prior written * permission of the Apache Group. * * 6. Redistributions of any form whatsoever must retain the following * acknowledgment: * "This product includes software developed by the Apache Group * for use in the Apache HTTP server project (http://www.apache.org/)." * * THIS SOFTWARE IS PROVIDED BY THE APACHE GROUP ``AS IS'' AND ANY * EXPRESSED OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE APACHE GROUP OR * ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; * LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED * OF THE POSSIBILITY OF SUCH DAMAGE. File-MMagic-1.30/MMagic.pm0000644000175000001440000015414312164470564014044 0ustar knokusers# File::MMagic # # $Id: MMagic.pm 290 2013-07-02 06:21:39Z knok $ # # This program is originated from file.kulp that is a production of The # Unix Reconstruction Projct. # # Copyright 1999,2000,2001,2002 NOKUBI Takatsugu . # # This product includes software developed by the Apache Group # for use in the Apache HTTP server project (http://www.apache.org/). # # License for the program is followed the original software. The license is # below. # # This program is copyright by dkulp 1999. # # This program is free and open software. You may use, copy, modify, distribute # and sell this program (and any modified variants) in any way you wish, # provided you do not restrict others to do the same, except for the following # consideration. # #I read some of Ian F. Darwin's BSD C implementation, to #try to determine how some of this was done since the specification #is a little vague. I don't believe that this perl version could #be construed as an "altered version", but I did grab the tokens for #identifying the hard-coded file types in names.h and copied some of #the man page. # #Here's his notice: # # * Copyright (c) Ian F. Darwin, 1987. # * Written by Ian F. Darwin. # * # * This software is not subject to any license of the American Telephone # * and Telegraph Company or of the Regents of the University of California. # * # * Permission is granted to anyone to use this software for any purpose on # * any computer system, and to alter it and redistribute it freely, subject # * to the following restrictions: # * # * 1. The author is not responsible for the consequences of use of this # * software, no matter how awful, even if they arise from flaws in it. # * # * 2. The origin of this software must not be misrepresented, either by # * explicit claim or by omission. Since few users ever read sources, # * credits must appear in the documentation. # * # * 3. Altered versions must be plainly marked as such, and must not be # * misrepresented as being the original software. Since few users # * ever read sources, credits must appear in the documentation. # * # * 4. This notice may not be removed or altered. # # The following is the Apache License. This program contains the magic file # that derived from the Apache HTTP Server. # # * Copyright (c) 1995-1999 The Apache Group. All rights reserved. # * # * Redistribution and use in source and binary forms, with or without # * modification, are permitted provided that the following conditions # * are met: # * # * 1. Redistributions of source code must retain the above copyright # * notice, this list of conditions and the following disclaimer. # * # * 2. Redistributions in binary form must reproduce the above copyright # * notice, this list of conditions and the following disclaimer in # * the documentation and/or other materials provided with the # * distribution. # * # * 3. All advertising materials mentioning features or use of this # * software must display the following acknowledgment: # * "This product includes software developed by the Apache Group # * for use in the Apache HTTP server project (http://www.apache.org/)." # * # * 4. The names "Apache Server" and "Apache Group" must not be used to # * endorse or promote products derived from this software without # * prior written permission. For written permission, please contact # * apache@apache.org. # * # * 5. Products derived from this software may not be called "Apache" # * nor may "Apache" appear in their names without prior written # * permission of the Apache Group. # * # * 6. Redistributions of any form whatsoever must retain the following # * acknowledgment: # * "This product includes software developed by the Apache Group # * for use in the Apache HTTP server project (http://www.apache.org/)." # * # * THIS SOFTWARE IS PROVIDED BY THE APACHE GROUP ``AS IS'' AND ANY # * EXPRESSED OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR # * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE APACHE GROUP OR # * ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, # * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT # * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; # * LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) # * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, # * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) # * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED # * OF THE POSSIBILITY OF SUCH DAMAGE. package File::MMagic; =head1 NAME File::MMagic - Guess file type =head1 SYNOPSIS use File::MMagic; use FileHandle; $mm = new File::MMagic; # use internal magic file # $mm = File::MMagic->new('/etc/magic'); # use external magic file # $mm = File::MMagic->new('/usr/share/etc/magic'); # if you use Debian $res = $mm->checktype_filename("/somewhere/unknown/file"); $fh = new FileHandle "< /somewhere/unknown/file2"; $res = $mm->checktype_filehandle($fh); $fh->read($data, 0x8564); $res = $mm->checktype_contents($data); =head1 ABSTRACT This perl library uses perl5 objects to guess file type from filename and/or filehandle. =head1 DESCRIPTION checktype_filename(), checktype_filehandle() and checktype_contents returns string contains file type with MIME mediatype format. =head1 METHODS =over 4 =item File::MMagic->new() =item File::MMagic->new( $filename ) Initializes the module. If no filename is given, the magic numbers stored in File::MMagic are used. =item $mm->addSpecials If a filetype cannot be determined by magic numbers, extra checks are done based on extra regular expressions which can be defined here. The first argument should be the filetype, the remaining arguments should be one or more regular expressions. By default, checks are done for message/news, message/rfc822, text/html, text/x-roff. =item $mm->removeSpecials Removes special regular expressions. Specify one or more filetypes. If no filetypes are specified, all special regexps are removed. Returns a hash containing the removed entries. =item $mm->addFileExts If a filetype cannot be determined by magic numbers, extra checks can be done based on the file extension (actually, a regexp). Two arguments should be geiven: the filename pattern and the corresponding filetype. By default, checks are done for application/x-compress, application/x-bzip2, application/x-gzip, text/html, text/plain =item $mm->removeFileExts Remove filename pattern checks. Specify one or more patterns. If no pattern is specified, all are removed. Returns a hash containing the removed entries. =item $mm->addMagicEntry Add a new magic entry in the object. The format is same as magic(5) file. Ex. # Add a entry $mm->addMagicEntry("0\tstring\tabc\ttext/abc"); # Add a entry with a sub entry $mm->addMagicEntry("0\tstring\tdef\t"); $mm->addMagicEntry(">10\tstring\tghi\ttext/ghi"); =item $mm->readMagicHandle =item $mm->checktype_filename =item $mm->checktype_magic =item $mm->checktype_contents =back =head1 COPYRIGHT This program is originated from file.kulp that is a production of The Unix Reconstruction Projct. Copyright (c) 1999 NOKUBI Takatsugu . There is no warranty for the program. This product includes software developed by the Apache Group for use in the Apache HTTP server project (http://www.apache.org/). License for the program is followed the original software. The license is below. This program is free and open software. You may use, copy, modify, distribute and sell this program (and any modified variants) in any way you wish, provided you do not restrict others to do the same, except for the following consideration. I read some of Ian F. Darwin's BSD C implementation, to try to determine how some of this was done since the specification is a little vague. I don't believe that this perl version could be construed as an "altered version", but I did grab the tokens for identifying the hard-coded file types in names.h and copied some of the man page. Here's his notice: * Copyright (c) Ian F. Darwin, 1987. * Written by Ian F. Darwin. * * This software is not subject to any license of the American Telephone * and Telegraph Company or of the Regents of the University of California. * * Permission is granted to anyone to use this software for any purpose on * any computer system, and to alter it and redistribute it freely, subject * to the following restrictions: * * 1. The author is not responsible for the consequences of use of this * software, no matter how awful, even if they arise from flaws in it. * * 2. The origin of this software must not be misrepresented, either by * explicit claim or by omission. Since few users ever read sources, * credits must appear in the documentation. * * 3. Altered versions must be plainly marked as such, and must not be * misrepresented as being the original software. Since few users * ever read sources, credits must appear in the documentation. * * 4. This notice may not be removed or altered. The following is the Apache License. This program contains the magic file that derived from the Apache HTTP Server. * Copyright (c) 1995-1999 The Apache Group. All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in * the documentation and/or other materials provided with the * distribution. * * 3. All advertising materials mentioning features or use of this * software must display the following acknowledgment: * "This product includes software developed by the Apache Group * for use in the Apache HTTP server project (http://www.apache.org/)." * * 4. The names "Apache Server" and "Apache Group" must not be used to * endorse or promote products derived from this software without * prior written permission. For written permission, please contact * apache@apache.org. * * 5. Products derived from this software may not be called "Apache" * nor may "Apache" appear in their names without prior written * permission of the Apache Group. * * 6. Redistributions of any form whatsoever must retain the following * acknowledgment: * "This product includes software developed by the Apache Group * for use in the Apache HTTP server project (http://www.apache.org/)." * * THIS SOFTWARE IS PROVIDED BY THE APACHE GROUP ``AS IS'' AND ANY * EXPRESSED OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE APACHE GROUP OR * ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; * LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED * OF THE POSSIBILITY OF SUCH DAMAGE. =cut use FileHandle; use strict; use vars qw( %TEMPLATES %ESC $VERSION $magicFile $checkMagic $followLinks $fileList $allowEightbit ); BEGIN { # translation of type in magic file to unpack template and byte count %TEMPLATES = (byte => [ 'c', 1 ], ubyte => [ 'C', 1 ], char => [ 'c', 1 ], uchar => [ 'C', 1 ], short => [ 's', 2 ], ushort => [ 'S', 2 ], long => [ 'l', 4 ], ulong => [ 'L', 4 ], date => [ 'l', 4 ], ubeshort => [ 'n', 2 ], beshort => [ [ 'n', 'S', 's' ], 2 ], ubelong => [ 'N', 4 ], belong => [ [ 'N', 'I', 'i' ], 4 ], bedate => [ 'N', 4 ], uleshort => [ 'v', 2 ], leshort => [ [ 'v', 'S', 's' ], 2 ], ulelong => [ 'V', 4 ], lelong => [ [ 'V', 'I', 'i' ], 4 ], ledate => [ 'V', 4 ], string => undef); # for letter escapes in magic file %ESC = ( n => "\n", r => "\r", b => "\b", t => "\t", f => "\f"); $VERSION = "1.30"; $allowEightbit = 1; } sub new { my $self = {}; my $proto = shift; my $class = ref($proto) || $proto; $self->{MF} = []; $self->{magic} = []; if (! @_) { my $fh = *File::MMagic::DATA{IO}; binmode($fh); bless $fh, 'FileHandle' if ref $fh ne 'FileHandle'; my $dataLoc; # code block to localise the no strict;, contribute by Simon Matthews { no strict 'refs'; my $instance = \${ "$class\::_instance" }; $$instance = $fh->tell() unless $$instance; $dataLoc = $$instance; } $fh->seek($dataLoc, 0); &readMagicHandle($self, $fh); } else { my $filename = shift; my $fh = new FileHandle; if ($fh->open("< $filename")) { binmode($fh); &readMagicHandle($self, $fh); } else { warn __PACKAGE__ . " couldn't load specified file $filename"; } } # from the BSD names.h, some tokens for hard-coded checks of # different texts. This isn't rocket science. It's prone to # failure so these checks are only a last resort. # removSpecials() can be used to remove those afterwards. $self->{SPECIALS} = { "message/rfc822" => [ "^Received:", "^>From ", "^From ", "^To: ", "^Return-Path: ", "^Cc: ", "^X-Mailer: "], "message/news" => [ "^Newsgroups: ", "^Path: ", "^X-Newsreader: "], "text/html" => [ "]*>", "]*>", "]*>", "]*>", "]*>", "]*>", "]*>", "]*>", "]*>", "]*>", ], "text/x-roff" => [ '^\\.\\\\"', "^\\.SH ", "^\\.PP ", "^\\.TH ", "^\\.BR ", "^\\.SS ", "^\\.TP ", "^\\.IR ", ], }; $self->{FILEEXTS} = { '\.gz$' => 'application/x-gzip', '\.bz2$' => 'application/x-bzip2', '\.Z$' => 'application/x-compress', '\.txt$' => 'text/plain', '\.html$' => 'text/html', '\.htm$' => 'text/html', }; # content hook $self->{chook} = {}; return bless $self, $class; } sub addSpecials { my $self = shift; my $mtype = shift; $self->{SPECIALS}->{"$mtype"} = [@_]; return $self; } sub removeSpecials { my $self = shift; # Remove all keys if no arguments given my @mtypes = (@_ or keys %{$self->{SPECIALS}}); my %returnmtypes; foreach my $mtype (@mtypes) { $returnmtypes{"$mtype"} = delete $self->{SPECIALS}->{"$mtype"}; } return %returnmtypes; } sub addFileExts { my $self = shift; my $filepat = shift; my $mtype = shift; $self->{FILEEXTS}->{"$filepat"} = $mtype; return $self; } sub removeFileExts { my $self = shift; # Remove all keys if no arguments given my @filepats = (@_ or keys %{$self->{FILEEXTS}}); my %returnfilepats; foreach my $filepat (@filepats) { $returnfilepats{"$filepat"} = delete $self->{FILEEXTS}->{"$filepat"}; } return %returnfilepats; } sub addMagicEntry { my $self = shift; my $entry = shift; if ($entry =~ /^>/) { $entry =~ s/^>//; my $depth = 1; my $entref = ${${$self->{magic}}[0]}[2]; while ($entry =~ /^>/) { $entry =~ s/^>//; $depth ++; $entref = ${${$entref}[0]}[2]; } $entry = '>' x $depth . $entry; unshift @{$entref}, [$entry, -1, []]; return $self; } unshift @{$self->{magic}}, [$entry, -1, []]; return $self; } sub readMagicHandle { my $self = shift; my $fh = shift; $self->{MF}->[0] = $fh; $self->{MF}->[1] = undef; $self->{MF}->[2] = 0; readMagicEntry($self->{magic}, $self->{MF}); } sub addContainerHook { my $self = shift; my $mtype = shift; my $funcref = shift; $self->{chook}->{$mtype} = $funcref; } # Not implimented. # #sub readMagicFile { # my $self = shift; # my $mfile = shift; #} sub checktype_filename { my $self = shift; # iterate over each file explicitly so we can seek my $file = shift; # the description line. append info to this string my $desc; my $mtype; # 0) check permission if (! -r $file) { $desc .= " can't read `$file': Permission denied."; return "x-system/x-error; $desc"; } # 1) check for various special files first if ($^O eq 'MSWin32') { stat($file); } else { if ($followLinks) { stat($file); } else { lstat($file); } } if (! -f _ or -z _) { if ( $^O ne 'MSWin32' && !$followLinks && -l _ ) { $desc .= " symbolic link to ".readlink($file); } elsif ( -d _ ) { $desc .= " directory"; } elsif ( -p _ ) { $desc .= " named pipe"; } elsif ( -S _ ) { $desc .= " socket"; } elsif ( -b _ ) { $desc .= " block special file"; } elsif ( -c _ ) { $desc .= " character special file"; } elsif ( -z _ ) { $desc .= " empty"; } else { $desc .= " special"; } return "x-system/x-unix; $desc"; } # current file handle. or undef if checkMagic (-c option) is true. my $fh; # $fh = new FileHandle "< $file" or die "$F: $file: $!\n" ; $fh = new FileHandle "< $file" or return "x-system/x-error; $file: $!\n" ; binmode($fh); # for MSWin32 # 2) check for script if (-x $file && -T _) { # Note, some magic files include elaborate attempts # to match #! header lines and return pretty responses # but this slows down matching and is unnecessary. my $line1 = <$fh>; if ($line1 =~ /^\#!\s*(\S+)/) { $desc .= " executable $1 script text"; } else { $desc .= " commands text"; } $fh->close(); return "x-system/x-unix; $desc"; } my $out = checktype_filehandle($self, $fh, $desc); undef $fh; return $out; } sub checktype_filehandle { my $self = shift; my ($fh, $desc) = @_; my $mtype; binmode($fh); # for MSWin32 architecture. # 3) iterate over each magic entry. my $matchFound = 0; my $m; for ($m = 0; $m <= $#{$self->{magic}}; $m++) { # check if the m-th magic entry matches # if it does, then $desc will contain an updated description if (magicMatch($self->{magic}->[$m],\$desc,$fh)) { if (defined $desc && $desc ne '') { $matchFound = 1; $mtype = $desc; last; } } # read another entry from the magic file if we've exhausted # all the entries already buffered. readMagicEntry will # add to the end of the array if there are more. if ($m == $#{$self->{magic}} && !$self->{MF}->[0]->eof()) { readMagicEntry($self->{magic}, $self->{MF}); } } # 4) check if it's text or binary. # if it's text, then do a bunch of searching for special tokens if (!$matchFound) { my $data; $fh->seek(0,0); $fh->read($data, 0x8564); $mtype = checktype_data($self, $data); } $mtype = 'text/plain' if (! defined $mtype); return $mtype; } sub checktype_contents { my $self = shift; my $data = shift; my $mtype; return 'application/octet-stream' if (length($data) <= 0); $mtype = checktype_container($self, $data); return $mtype unless $mtype eq ""; $mtype = checktype_magic($self, $data); # 4) check if it's text or binary. # if it's text, then do a bunch of searching for special tokens if (!defined $mtype) { $mtype = checktype_data($self, $data); } $mtype = 'text/plain' if (! defined $mtype); return $mtype; } sub checktype_container { my $self = shift; my $data = shift; my $href = $self->{chook}; foreach my $mtype (keys %$href) { my $ret = &{$href->{$mtype}}($self, $data); return $ret if $ret ne ""; } return ""; } sub checktype_magic { my $self = shift; my $data = shift; my $desc; my $mtype; return 'application/octet-stream' if (length($data) <= 0); # 3) iterate over each magic entry. my $m; for ($m = 0; $m <= $#{$self->{magic}}; $m++) { # check if the m-th magic entry matches # if it does, then $desc will contain an updated description if (magicMatchStr($self->{magic}->[$m],\$desc,$data)) { if (defined $desc && $desc ne '') { $mtype = $desc; last; } } # read another entry from the magic file if we've exhausted # all the entries already buffered. readMagicEntry will # add to the end of the array if there are more. if ($m == $#{$self->{magic}} && !$self->{MF}->[0]->eof()) { readMagicEntry($self->{magic}, $self->{MF}); } } return $mtype; } sub checktype_data { my $self = shift; my $data = shift; my $mtype; return undef if (length($data) <= 0); # truncate data $data = substr($data, 0, 0x8564); # at first, check SPECIALS { # in BSD's version, there's an effort to search from # more specific to less, but I don't do that. my %val; foreach my $type (keys %{$self->{SPECIALS}}) { my $matched_pos = undef; foreach my $token (@{$self->{SPECIALS}->{$type}}){ pos($data) = 0; if ($data =~ /$token/mg) { my $tmp = pos($data); if ((! defined $matched_pos) || ($matched_pos > $tmp)) { $matched_pos = $tmp; } } } $val{$type} = $matched_pos if $matched_pos; } # search latest match if (%val) { my @skeys = sort { $val{$a} <=> $val{$b} } keys %val; $mtype = $skeys[0]; } # $mtype = 'text/plain' if (! defined $mtype); } if (! defined $mtype && check_binary($data)) { $mtype = "application/octet-stream"; } # $mtype = 'text/plain' if (! defined $mtype); return $mtype; } sub checktype_byfilename { my $self = shift; my $fname = shift; my $type; $fname =~ s/^.*\///; for my $regex (keys %{$self->{FILEEXTS}}) { if ($fname =~ /$regex/i) { if ((defined $type && $type !~ /;/) || (! defined $type)) { $type = $self->{FILEEXTS}->{$regex}; # has no x-type param } } } $type = 'application/octet-stream' unless defined $type; return $type; } sub check_binary { my ($data) = @_; my $len = length($data); if ($allowEightbit) { my $count = ($data =~ tr/\x00-\x08\x0b-\x0c\x0e-\x1a\x1c-\x1f//); # exclude TAB, ESC, nl, cr return 1 if ($len <= 0); # no contents return 1 if (($count/$len) > 0.1); # binary } else { my $count = ($data =~ tr/\x00-\x08\x0b-\x0c\x0e-\x1a\x1c-\x1f\x80-\xff//); # exclude TAB, ESC, nl, cr return 1 if ($len <= 0); # no contents return 1 if (($count/$len) > 0.3); # binary } return 0; } sub check_magic { my $self = shift @_; # read the whole file if we haven't already while (!$self->{MF}->[0]->eof()) { readMagicEntry($self->{magic}, $self->{MF}); } dumpMagic($self->{magic}); } ####### SUBROUTINES ########### # compare the magic item with the filehandle. # if success, print info and return true. otherwise return undef. # # this is called recursively if an item has subitems. sub magicMatch { my ($item, $p_desc, $fh) = @_; # delayed evaluation. if this is our first time considering # this item, then parse out its structure. @$item is just the # raw string, line number, and subtests until we need the real info. # this saves time otherwise wasted parsing unused subtests. if (@$item == 3){ my $tmp = readMagicLine(@$item); return unless defined($tmp); @$item = @$tmp; } # $item could be undef if we ran into troubles while reading # the entry. return unless defined($item); # $fh is not be defined if -c. that way we always return # false for every item which allows reading/checking the entire # magic file. return unless defined($fh); my ($offtype, $offset, $numbytes, $type, $mask, $op, $testval, $template, $message, $subtests) = @$item; # bytes from file my $data; # set to true if match my $match = 0; # offset = [ off1, sz, template, off2 ] for indirect offset if ($offtype == 1) { my ($off1, $sz, $template, $off2) = @$offset; $fh->seek($off1,0) or return; if ($fh->read($data,$sz) != $sz) { return }; $off2 += unpack($template,$data); $fh->seek($off2,0) or return; } elsif ($offtype == 2) { # relative offsets from previous seek $fh->seek($offset,1) or return; } else { # absolute offset $fh->seek($offset,0) or return; } if ($type =~ /^string/ || $type =~ /^regex/) { # read the length of the match string unless the # comparison is '>' ($numbytes == 0), in which case # read to the next null or "\n". (that's what BSD's file does) if ($numbytes > 0) { if ($fh->read($data,$numbytes) != $numbytes) { return; } } else { my $ch = $fh->getc(); while (defined($ch) && $ch ne "\0" && $ch ne "\n") { $data .= $ch; $ch = $fh->getc(); } } # now do the comparison if ($op eq '=') { $match = ($data eq $testval); } elsif ($op eq '<') { $match = ($data lt $testval); } elsif ($op eq '>') { $match = ($data gt $testval); } elsif ($op eq 'match') { $data = ($data || '') ? $data : ''; $match = $data =~ /$testval/; } # else bogus op, but don't die, just skip if ($checkMagic) { print STDERR "STRING: $data $op $testval => $match\n"; } } elsif ($type =~ /^search\//) { } else { #numeric # read up to 4 bytes if ($fh->read($data,$numbytes) != $numbytes) { return; } # If template is a ref to an array of 3 letters, # then this is an endian # number which must be first unpacked into an unsigned and then # coerced into a signed. Is there a better way? if (ref($template)) { $data = unpack($$template[2], pack($$template[1], unpack($$template[0],$data))); } else { $data = unpack($template,$data); } # if mask if (defined($mask)) { $data &= $mask; } # Now do the check if ($op eq '=') { $match = ($data == $testval); } elsif ($op eq 'x') { $match = 1; } elsif ($op eq '!') { $match = ($data != $testval); } elsif ($op eq '&') { $match = (($data & $testval) == $testval); } elsif ($op eq '^') { $match = ((~$data & $testval) == $testval); } elsif ($op eq '<') { $match = ($data < $testval); } elsif ($op eq '>') { $match = ($data > $testval); } # else bogus entry that we're ignoring if ($checkMagic) { print STDERR "NUMERIC: $data $op $testval => $match\n"; } } if ($match) { # it's pretty common to find "\b" in the message, but # sprintf doesn't insert a backspace. if it's at the # beginning (typical) then don't include separator space. if ($message =~ s/^\\b//) { $$p_desc .= sprintf($message,$data); } else { # $$p_desc .= ' ' . sprintf($message,$data) if $message; $$p_desc .= sprintf($message,$data) if $message; } my $subtest; foreach $subtest (@$subtests) { magicMatch($subtest,$p_desc,$fh); } return 1; } } sub magicMatchStr { my ($item, $p_desc, $str) = @_; my $origstr = $str; # delayed evaluation. if this is our first time considering # this item, then parse out its structure. @$item is just the # raw string, line number, and subtests until we need the real info. # this saves time otherwise wasted parsing unused subtests. if (@$item == 3){ my $tmp = readMagicLine(@$item); # $item could be undef if we ran into troubles while reading # the entry. return unless defined($tmp); @$item = @$tmp; } # $fh is not be defined if -c. that way we always return # false for every item which allows reading/checking the entire # magic file. return unless defined($str); return if ($str eq ''); my ($offtype, $offset, $numbytes, $type, $mask, $op, $testval, $template, $message, $subtests) = @$item; return unless defined $op; # bytes from file my $data; # set to true if match my $match = 0; # offset = [ off1, sz, template, off2 ] for indirect offset if ($offtype == 1) { my ($off1, $sz, $template, $off2) = @$offset; return if (length($str) < $off1); $data = pack("a$sz", $str); $off2 += unpack($template,$data); return if (length($str) < $off2); } elsif ($offtype == 2) { # can't handle relative offsets from previous seek return; } else { # absolute offset return if ($offset > length($str)); $str = substr($str, $offset); } if ($type =~ /^string/ || $type =~ /^regex/) { # read the length of the match string unless the # comparison is '>' ($numbytes == 0), in which case # read to the next null or "\n". (that's what BSD's file does) if ($numbytes > 0) { $data = pack("a$numbytes", $str); } else { $str =~ /^(.*)\0|$/; $data = $1; } # now do the comparison if ($op eq '=') { $match = ($data eq $testval); } elsif ($op eq '<') { $match = ($data lt $testval); } elsif ($op eq '>') { $match = ($data gt $testval); } elsif ($op eq 'match') { $match = eval {($data || '') =~ /$testval/}; } # else bogus op, but don't die, just skip if ($checkMagic) { print STDERR "STRING: $data $op $testval => $match\n"; } } elsif ($type =~ /^search\//) { } else { #numeric # read up to 4 bytes return if (length($str) < 4); $data = substr($str, 0, 4); # If template is a ref to an array of 3 letters, # then this is an endian # number which must be first unpacked into an unsigned and then # coerced into a signed. Is there a better way? if (ref($template)) { $data = unpack($$template[2], pack($$template[1], unpack($$template[0],$data))); } else { $data = unpack($template,$data); } # if mask if (defined($mask)) { $data &= $mask; } # Now do the check if ($op eq '=') { $match = ($data == $testval); } elsif ($op eq 'x') { $match = 1; } elsif ($op eq '!') { $match = ($data != $testval); } elsif ($op eq '&') { $match = (($data & $testval) == $testval); } elsif ($op eq '^') { $match = ((~$data & $testval) == $testval); } elsif ($op eq '<') { $match = ($data < $testval); } elsif ($op eq '>') { $match = ($data > $testval); } # else bogus entry that we're ignoring if ($checkMagic) { print STDERR "NUMERIC: $data $op $testval => $match\n"; } } if ($match) { # it's pretty common to find "\b" in the message, but # sprintf doesn't insert a backspace. if it's at the # beginning (typical) then don't include separator space. if ($message =~ s/^\\b//) { $$p_desc .= sprintf($message,$data); } else { # $$p_desc .= ' ' . sprintf($message,$data) if $message; $$p_desc .= sprintf($message,$data) if $message; } my $subtest; foreach $subtest (@$subtests) { # finish evaluation when matched. magicMatchStr($subtest,$p_desc,$origstr); } return 1; } } # readMagicEntry($pa_magic, $MF, $depth) # # reads the next entry from the magic file and stores it as # a ref to an array at the end of @$pa_magic. # # $MF = [ filehandle, last buffered line, line count ] # # This is called recursively with increasing $depth to read in sub-clauses # # returns the depth of the current buffered line. # sub readMagicEntry { my ($pa_magic, $MF, $depth) = @_; # for some reason I need a local var because <$$MF[0]> doesn't work.(?) my $magicFH = $$MF[0]; # a ref to an array containing a magic line's components my ($entry, $line); $line = $$MF[1]; # buffered last line while (1) { $line = '' if (! defined $line); if ($line =~ /^\#/ || $line =~ /^\s*$/) { last if $magicFH->eof(); $line = <$magicFH>; $$MF[2]++; next; } my ($thisDepth) = ($line =~ /^(>+)/); $thisDepth = '' if (! defined $thisDepth); $depth = 0 if (! defined $depth); if (length($thisDepth) > $depth) { $$MF[1] = $line; # call ourselves recursively. will return the depth # of the entry following the nested group. if ((readMagicEntry($entry->[2], $MF, $depth+1) || 0) < $depth || $$MF[0]->eof()) { return; } $line = $$MF[1]; } elsif (length($thisDepth) < $depth) { $$MF[1] = $line; return length($thisDepth); } elsif ('ARRAY' eq ref $entry && @$entry) { # already have an entry. this is not a continuation. # save this line for the next call and exit. $$MF[1] = $line; return length($thisDepth); } else { # we're here if the number of '>' is the same as the # current depth and we haven't read a magic line yet. # create temp entry # later -- if we ever get around to evaluating this condition -- # we'll replace @$entry with the results from readMagicLine. $entry = [ $line , $$MF[2], [] ]; # add to list push(@$pa_magic,$entry); # read the next line last if $magicFH->eof(); $line = <$magicFH>; $$MF[2]++; } } } # readMagicLine($line, $line_num, $subtests) # # parses the match info out of $line. Returns a reference to an array. # # Format is: # # [ offset, bytes, type, mask, operator, testval, template, sprintf, subtests ] # 0 1 2 3 4 5 6 7 8 # # subtests is an array like @$pa_magic. # sub readMagicLine { my ($line, $line_num, $subtests) = @_; my ($offtype, $offset, $numbytes, $type, $mask, $operator, $testval, $template, $message); # this would be easier if escaped whitespace wasn't allowed. # grab the offset and type. offset can either be a decimal, oct, # or hex offset or an indirect offset specified in parenthesis # like (x[.[bsl]][+-][y]), or a relative offset specified by &. # offtype : 0 = absolute, 1 = indirect, 2 = relative if ($line =~ s/^>*([&\(]?[a-fA-Flsx\.\+\-\d]+\)?)\s+(\S+)\s+//) { ($offset,$type) = ($1,$2); if ($offset =~ /^\(/) { # indirect offset. $offtype = 1; # store as a reference [ offset1 type template offset2 ] my ($o1,$type,$o2); if (($o1,$type,$o2) = ($offset =~ /\((\d+)(\.[bsl])?([\+\-]?\d+)?\)/)) { $o1 = oct($o1) if $o1 =~ /^0/o; $o2 = oct($o2) if $o2 =~ /^0/o; $type =~ s/\.//; if ($type eq '') { $type = 'l'; } # default to long $type =~ tr/b/c/; # type will be template for unpack my $sz = $type; # number of bytes $sz =~ tr/csl/124/; $offset = [ $o1,$sz,$type,int($o2) ]; } else { warn "Bad indirect offset at line $line_num. '$offset'\n"; return; } } elsif ($offset =~ /^&/o) { # relative offset $offtype = 2; $offset = substr($offset,1); $offset = oct($offset) if $offset =~ /^0/o; } else { # normal absolute offset $offtype = 0; # convert if needed $offset = oct($offset) if $offset =~ /^0/o; } } else { warn "Bad Offset/Type at line $line_num. '$line'\n"; return; } # check for & operator on type if ($type =~ s/&(.*)//) { $mask = $1; # convert if needed $mask = oct($mask) if $mask =~ /^0/o; } # check if type is valid if (!exists($TEMPLATES{$type}) && $type !~ /^string/ && $type !~ /^regex/ && $type !~ /^search\//) { warn "Invalid type '$type' at line $line_num\n"; return; } # take everything after the first non-escaped space if ($line =~ s/([^\\])\s+(.*)/$1/) { $message = $2; } else { warn "Missing or invalid test condition or message at line $line_num\n"; return; } # remove the return if it's still there $line =~ s/\n$//o; # get the operator. if 'x', must be alone. default is '='. if ($type !~ /regex/) { if ($line =~ s/^([><&^=!])//o) { $operator = $1; } elsif ($line eq 'x') { $operator = 'x'; } else { $operator = '='; } } else { $operator = 'match'; } if ($type =~ /^string/ || $type =~ /^regex/) { $testval = $line; # do octal/hex conversion # manmin $testval =~ s/\\x([0-9a-fA-F][0-9a-fA-F])/pack("H2", $1)/eg; $testval =~ s/\\([0-7][0-7]?[0-7]?)/chr(oct($1))/eg; # end manmin # do single char escapes $testval =~ s/\\(.)/$ESC{$1}||$1/eg; # put the number of bytes to read in numbytes. # '0' means read to \0 or \n. if ($operator =~ /[>x]/o) { $numbytes = 0; } elsif ($operator =~ /[=<]/o) { $numbytes = length($testval); } elsif ($operator eq '!') { # annoying special case. ! operator only applies to numerics so # put it back. $testval = $operator . $testval; $numbytes = length($testval); $operator = '='; } elsif ($operator eq 'match') { eval {"" =~ /$testval/}; # Check the regex warn "Invalid regex at line $line_num - $@\n" if ($@); $numbytes = 0; } else { # there's a bug in my magic file where there's # a line that says "0 string ^!' || $operator eq '<'; } } return [ $offtype, $offset, $numbytes, $type, $mask, $operator, $testval, $template, $message, $subtests ]; } # recursively write the magic file to stderr. Numbers are written # in decimal. sub dumpMagic { my ($magic,$depth) = @_; $magic = [] unless defined $magic; $depth = 0 unless defined $depth; my $entry; foreach $entry (@$magic) { # delayed evaluation. if (@$entry == 3){ my $tmp = readMagicLine(@$entry); next if (! $tmp); @$entry = @$tmp; } next if !defined($entry); my ($offtype, $offset, $numbytes, $type, $mask, $op, $testval, $template, $message, $subtests) = @$entry; print STDERR '>'x$depth; if ($offtype == 1) { $offset->[2] =~ tr/c/b/; print STDERR "($offset->[0].$offset->[2]$offset->[3])"; } elsif ($offtype == 2) { print STDERR "&",$offset; } else { # offtype == 0 print STDERR $offset; } print STDERR "\t",$type; if ($mask) { print STDERR "&",$mask; } print STDERR "\t",$op,$testval,"\t",$message,"\n"; if ($subtests) { dumpMagic($subtests,$depth+1); } } } 1; __DATA__ # Magic data for mod_mime_magic Apache module (originally for file(1) command) # The module is described in htdocs/manual/mod/mod_mime_magic.html # # The format is 4-5 columns: # Column #1: byte number to begin checking from, ">" indicates continuation # Column #2: type of data to match # Column #3: contents of data to match # Column #4: MIME type of result # Column #5: MIME encoding of result (optional) #------------------------------------------------------------------------------ # Localstuff: file(1) magic for locally observed files # Add any locally observed files here. # # The following paramaters are created for Namazu. # # # 1999/08/13 #0 string \