File-MMagic-XS-0.09008/000755 000766 000024 00000000000 12321412047 014305 5ustar00JP11194staff000000 000000 File-MMagic-XS-0.09008/benchmark.pl000644 000766 000024 00000000443 12321356423 016602 0ustar00JP11194staff000000 000000 use strict; use Benchmark qw(cmpthese); use File::MMagic; use File::MMagic::XS; my $fm = File::MMagic->new(); my $fmxs = File::MMagic::XS->new(); my $file = shift @ARGV; cmpthese(10_000, { xs => sub { $fmxs->get_mime($file) }, perl => sub { $fm->checktype_filename($file) } });File-MMagic-XS-0.09008/Changes000644 000766 000024 00000006045 12321411667 015614 0ustar00JP11194staff000000 000000 Changes ======= All changes by Daisuke Maki, unless otherwise noted. 0.09008 - 10 Apr 2014 - This is a "I'm a douche for not properly testing code before merging" https://rt.cpan.org/Ticket/Display.html?id=94570 Patch from the above RT was applied 0.09007 - 09 Dec 2013 - Update inc/ . Fixes rt #63048 0.09006 - 19 May 2010 - Should fix errors in t/003_error.t http://cpantesters.org/cpan/report/07280906-b19f-3f77-b713-d32bba55d77f 0.09005 - 17 May 2010 - Should fixe problems with t/005_clone.t - Minor XS tweaks 0.09004 - 11 May 2010 - Disable MSWin32 (patches welcome) 0.09003_03 - 10 May 2010 - Explicitly test add_file_ext - Add thread safety test 0.09003_02 - 26 Apr 2010 - Ah, typemaps! I guess I didn't know about it when I first wrote this - Add many tests - Fix a memory leak under clone() - Fix a memory leak under fhmagic() - Update function declarations to a more modern style * move all functions out of XS section, and make use of automatic linkage by xsubpp - Add a memory leak test * only runnable when running under author mode * set TEST_MEMLEAK=1 * ignore any leaks that does not directly show a Perl_* namespace. 0.09003_01 - 07 Apr 2010 - Fix memory corruption (Martin Blapp) - Fix rt #28072. Changing $/ doesn't change the return value (Martin Blapp) - Fix how SV returned by error() is handled. - Add a clone() method. 0.09003 - 05 Nov 2007 - Fix BBC breakage in anticipation for 5.10 (Thanks a bunch to Jan Dubois and Andres Koenig). This was caused by a erronous Safefree() call where it should have been a simple free(). 0.09002 - 09 Jul 2007 - Allow bufmagic() to accept a ref to a scalar for performance (rt #28040) - Don't close file handle for fhmagic 0.09001 - 06 Jun 2007 - Fix typo (rt #27454) 0.09 - 09 May 2007 - Kwalitee updates: doc fixes, POD tests, license. - Fallback to DynaLoader for older perls - Remove compat.pm 0.08 - 27 Oct 2005 - Implement add_file_ext(), which acts as a fallback to guessing MIME types based on the file extension, when all else fails - Fix fmm_ascmagic so that when it fallsback to text/plain, it correctly reports that it guessed, not a real match. 0.07 - 01 Aug 2005 - Yikes, Perl-C mixup: forgot to call "return". Reported by Tatsuhiko Miyagawa. - Verify return value from softmagic() - Add tests for fhmagic. 0.06 - 26 July 2005 - Remove debug lines. 0.05 - 25 July 2005 - Cleanup XS. Now File::MMagic::XS instance is not a hashref, but a blessed scalar - Use PerlIO* instead of FILE *, fread(), fopen(), et al. - Fallback to text/plain, as File::MMagic does. - Add compatibility to File::MMagic 0.04 - 07 July 2005 - One more missing aTHX_ 0.03 - 23 June 2005 - Switch malloc/free calls with Newz/Safefree. - Use more perl's macros is*() - Use aTHX_ properly 0.02 - 22 June 2005 - Add missing Changes file - Fix return value from fmm_ascmagic. - Add error() 0.01 - 19 June 2005 - Initial CPAN releaseFile-MMagic-XS-0.09008/inc/000755 000766 000024 00000000000 12321412047 015056 5ustar00JP11194staff000000 000000 File-MMagic-XS-0.09008/lib/000755 000766 000024 00000000000 12321412047 015053 5ustar00JP11194staff000000 000000 File-MMagic-XS-0.09008/Makefile.PL000644 000766 000024 00000001627 12321411516 016265 0ustar00JP11194staff000000 000000 BEGIN { if (-e ".git") { my $errors = 0; foreach my $module (qw(Module::Install Module::Install::AuthorTests Module::Install::Repository Module::Install::XSUtil)) { eval "require $module"; if ($@) { $errors++; print $module, "\n"; } } if ($errors) { exit 1; } } } use inc::Module::Install; # if you are getting this from git repo, you need to have # * Module::Install # * Module::Install::AuthorTests # * Module::Install::Repository # * Module::Install::XSUtil # installed name 'File-MMagic-XS'; all_from 'lib/File/MMagic/XS.pm'; if ($^O eq 'MSWin32') { print STDERR "File::MMagic::XS does not compile on Windows\n", "(patches welcome)\n" ; exit 0; } use_ppport; cc_warnings; cc_src_paths 'src'; author_tests 'xt'; auto_set_repository; WriteAll; File-MMagic-XS-0.09008/MANIFEST000644 000766 000024 00000001402 12321412020 015422 0ustar00JP11194staff000000 000000 benchmark.pl Changes inc/Module/Install.pm inc/Module/Install/AuthorTests.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Repository.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm inc/Module/Install/XSUtil.pm lib/File/MMagic/magic lib/File/MMagic/XS.pm Makefile.PL MANIFEST This list of files META.yml src/MMagic.xs src/MMagicST.c src/MMagicST.h src/perl-mmagic-xs.c src/perl-mmagic-xs.h src/typemap t/001_load.t t/002_runthrough.t t/003_error.t t/004_slurp.t t/005_clone.t t/100_compat_selfcheck.t t/101_compat_extmagic.t t/data/picture.jpg t/data/test.rtf t/data/test.xml xt/01_pod.t xt/02_pod-coverage.t xt/03_threads.t xt/04_leak.t File-MMagic-XS-0.09008/META.yml000644 000766 000024 00000001313 12321411742 015555 0ustar00JP11194staff000000 000000 --- abstract: 'Guess File Type With XS (a la mod_mime_magic)' author: - 'Copyright 2005-2007 Daisuke Maki .' build_requires: Devel::PPPort: 3.19 ExtUtils::MakeMaker: 6.36 configure_requires: Devel::PPPort: 3.19 ExtUtils::MakeMaker: 6.36 ExtUtils::ParseXS: 3.18 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.08' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: File-MMagic-XS no_index: directory: - inc - t - xt requires: XSLoader: 0.02 resources: license: http://dev.perl.org/licenses/ repository: git://github.com/lestrrat/File-MMagic-XS.git version: '0.09008' File-MMagic-XS-0.09008/src/000755 000766 000024 00000000000 12321412047 015074 5ustar00JP11194staff000000 000000 File-MMagic-XS-0.09008/t/000755 000766 000024 00000000000 12321412047 014550 5ustar00JP11194staff000000 000000 File-MMagic-XS-0.09008/xt/000755 000766 000024 00000000000 12321412047 014740 5ustar00JP11194staff000000 000000 File-MMagic-XS-0.09008/xt/01_pod.t000644 000766 000024 00000000235 12321356423 016214 0ustar00JP11194staff000000 000000 use strict; use Test::More; eval { require Test::Pod; }; if ($@) { plan skip_all => "Test::Pod is not installed"; } Test::Pod::all_pod_files_ok(); File-MMagic-XS-0.09008/xt/02_pod-coverage.t000644 000766 000024 00000000273 12321356423 020010 0ustar00JP11194staff000000 000000 use strict; use Test::More; eval { require Test::Pod::Coverage; }; if ($@) { plan skip_all => "Test::Pod::Coverage not installed"; } Test::Pod::Coverage::all_pod_coverage_ok(); File-MMagic-XS-0.09008/xt/03_threads.t000644 000766 000024 00000000554 12321356423 017072 0ustar00JP11194staff000000 000000 use strict; use Test::More; use Test::Requires 'threads'; use_ok "File::MMagic::XS"; my $x = File::MMagic::XS->new; my @threads; for (1..5) { push @threads, threads->create(sub{ note( "spawned thread : " . threads->tid() ); }); } foreach my $thr (@threads) { note( "joining thread : " . $thr->tid ); $thr->join; } ok(1); done_testing();File-MMagic-XS-0.09008/xt/04_leak.t000644 000766 000024 00000000557 12321356423 016360 0ustar00JP11194staff000000 000000 use strict; use Test::More; BEGIN { if (! $ENV{TEST_MEMLEAK}) { plan skip_all => "TEST_MEMLEAK is not set"; } } use Test::Requires 'Test::Valgrind', 'XML::Parser', ; while ( my $f = ) { subtest $f => sub { do $f }; } while ( my $f = ) { for my $i (1..10) { subtest $f => sub { do $f }; } } done_testing;File-MMagic-XS-0.09008/t/001_load.t000644 000766 000024 00000000135 12321356423 016240 0ustar00JP11194staff000000 000000 #!perl use strict; use Test::More (tests => 1); BEGIN { use_ok("File::MMagic::XS"); } 1;File-MMagic-XS-0.09008/t/002_runthrough.t000644 000766 000024 00000002607 12321411516 017530 0ustar00JP11194staff000000 000000 # perl-test use strict; use Test::More; my %map; BEGIN { my $file = __FILE__; %map = ( $file => 'text/plain', 't/data/test.xml' => 'text/xml', 't/data/test.rtf' => 'application/rtf' ); plan(tests => (scalar( keys %map ) * 5 + 2) * 2 + 1); } BEGIN { use_ok("File::MMagic::XS"); } foreach my $eol (undef, "\0") { local $/ = $eol; my $fm = File::MMagic::XS->new; foreach my $file (keys %map) { my $mime = $map{$file}; my $got = $fm->get_mime($file); is($got, $mime, "$file: expected $mime") or die; ok(open(F, $file), "ok to open $file"); is($fm->fhmagic(\*F), $mime, "$file: expected $mime from fhmagic") or die; seek(F, 0, 0); my $buf = do { local $/ = undef; }; my $ref = \$buf; is($fm->bufmagic($ref), $mime, "$file: expected $mime from bufmagic"); if ( $mime eq 'text/plain' ) { is( $fm->ascmagic( $buf ), $mime, "$file: expected $mime from ascmagic" ); } else { ok( 1, "$file may be binary, skipping test" ); } } $fm->add_magic( "0\tstring\t#\\ perl-test\tapplication/x-perl-test" ); is( $fm->get_mime( __FILE__ ), 'application/x-perl-test' ); # check file_ext (rt #35269) $fm->add_file_ext('t', 'application/x-perl-test'); is( $fm->get_mime( __FILE__ ), 'application/x-perl-test' ); } File-MMagic-XS-0.09008/t/003_error.t000644 000766 000024 00000000350 12321356423 016453 0ustar00JP11194staff000000 000000 #!perl use strict; use Test::More (tests => 4); BEGIN { use_ok("File::MMagic::XS"); } my $fm = File::MMagic::XS->new; ok ! $fm->error; ok !$fm->fsmagic("t/non-existent"); my $error = $fm->error; ok $error, qr/No such file/; File-MMagic-XS-0.09008/t/004_slurp.t000644 000766 000024 00000000570 12321356423 016474 0ustar00JP11194staff000000 000000 # https://rt.cpan.org/Public/Bug/Display.html?id=28072 use strict; use Test::More tests => 2; use File::MMagic::XS; { local $/ = "\n"; my $magic = File::MMagic::XS->new(); is( $magic->get_mime( 't/data/picture.jpg' ), 'image/jpeg' ); } { local $/; my $magic = File::MMagic::XS->new(); is( $magic->get_mime( 't/data/picture.jpg' ), 'image/jpeg' ); } File-MMagic-XS-0.09008/t/005_clone.t000644 000766 000024 00000002057 12321407256 016433 0ustar00JP11194staff000000 000000 #!perl use strict; use Test::More; my %map; BEGIN { my $file = __FILE__; %map = ( $file => 'text/plain', 't/data/test.xml' => 'text/xml', 't/data/test.rtf' => 'application/rtf' ); plan(tests => (scalar( keys %map ) * 4) * 4 + 1); } BEGIN { use_ok("File::MMagic::XS"); } my $fm = File::MMagic::XS->new; my $clone = $fm->clone(); { runthrough($fm); undef $fm; } { runthrough($clone); undef $clone; } sub runthrough { my $fm = shift; foreach my $endl ("\n", "\0") { local $/ = $endl; while (my($file, $mime) = each %map) { my $got = $fm->get_mime($file); is($got, $mime, "$file: expected $mime"); ok(open(F, $file), "ok to open $file"); is($fm->fhmagic(\*F), $mime, "$file: expected $mime from fhmagic"); seek(F, 0, 0); my $buf = do { local $/ = undef; }; my $ref = \$buf; is($fm->bufmagic($ref), $mime, "$file: expected $mime from bufmagic"); } } }File-MMagic-XS-0.09008/t/100_compat_selfcheck.t000644 000766 000024 00000000500 12321356423 020607 0ustar00JP11194staff000000 000000 # perl-test # $Id: 01-selfcheck.t,v 1.2 2003/11/21 02:25:52 knok Exp $ use strict; use Test::More (tests => 2); BEGIN { use_ok("File::MMagic::XS", qw(:compat)); } my $magic = File::MMagic::XS->new(); my $ret = $magic->checktype_filename(__FILE__); is($ret, 'text/plain', "mime should be 'text/plain'. got $ret"); File-MMagic-XS-0.09008/t/101_compat_extmagic.t000644 000766 000024 00000000557 12321356423 020476 0ustar00JP11194staff000000 000000 # perl-test # $Id: 02-extmagic.t,v 1.3 2003/11/21 02:25:52 knok Exp $ use strict; use Test::More (tests => 2); BEGIN { use_ok("File::MMagic::XS", qw(:compat)); } my $magic = File::MMagic::XS->new(); $magic->addMagicEntry("0\tstring\t#\\ perl-test\tapplication/x-perl-test"); my $ret = $magic->checktype_filename(__FILE__); is($ret, 'application/x-perl-test'); File-MMagic-XS-0.09008/t/data/000755 000766 000024 00000000000 12321412047 015461 5ustar00JP11194staff000000 000000 File-MMagic-XS-0.09008/t/data/picture.jpg000644 000766 000024 00000173265 12321356423 017661 0ustar00JP11194staff000000 000000 JFIFHHXICC_PROFILEHappl scnrRGB XYZ acspAPPLappl-appl rXYZgXYZbXYZ0wtptDchadX,rTRCgTRCbTRCdescncprtAdscmXYZ tK>XYZ Zs&XYZ (W3XYZ Rsf32 B&lcurv3mluc enUS$esES,LdaDK4deDE,fiFI(frFU<itIT,rnlNL$noNO xptBR(JsvSE*jaJPkoKR2zhTW2zhCNKameran RGB-profiiliRGB-profil fr Kamera000 RGB 000000exOMvj_ RGB r_icϏPerfil RGB para CmaraRGB-kameraprofilRGB-Profil fr Kamerasvg: RGB cϏeNRGB-beskrivelse til KameraRGB-profiel CameratT| RGB \ |Perfil RGB de CmeraProfilo RGB FotocameraCamera RGB ProfileProfil RVB de l appareil-phototextCopyright 2003 Apple Computer Inc., all rights reserved.descCamera RGB ProfileCamera RGB ProfileExifMM*   (12<i NIKONCOOLPIX S600HHQuickTime 7.62009:05:25 16:47:51Mac OS X 10.5.7HP"'0220Xl   0100,    2009:05:24 07:58:092009:05:24 07:58:09 C      C  ," }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ? mC[QD $r8>kƐf,ԓ׫|}n\r$/e^)HkRJ>9FXҏ߫Uм> c}=s"2+mגwpi #0H7FH[w.a)4ZZxUQT-_O唒}l5䱈(G9+g?/Rx(y5 >%-5;o!di{x*᮵uxPҵ fĈp= _gwcgBNiCN2]$C8RU?v[4uU5J=kjN$6%o鞕ωuF(EF2y7v%NߵzyW*{f;{ ,fc*)!,<(v6})dό0F$mC71|T^g~h [Sy}؂3ҕCפiL`{J>a_gI6WW#֭k7sFG~@Vݬ1R.<뫩-F|C>)ZNukh>0X\osoj1F]դ$v_9(-a$]vkvaCNIMY|kۃRu:ӾylvFyiU̺'ĿSIl⹞G|!mn< My'?U/t?LMhZW[>f9c*kٶ)fq%OJϡӭ$$R8M+k q r~_lV䈨e썮o tLOcY9|j*w{W :";IJcпb6.5Dچ<4;3;Ooz#D{Q9Mfӌ~j_^ Giz-S{wY-:kݣkw{Y$Quu+BtEo[3 >w >֧hmu>CEK)mŸJZ͜6>}Z >3=zVTHeY[?*x_m(.P׏Ҽ70]k-Qēad%zs音i#I 2^EY@܄q#ںY`(>0<}yM;;5_7_';ۭ;~Uxc+GcySttnφ ZGqpҐX7eC1>S/~k~uSyDc dF@Ccd?lo_|un汢%Q yO)# :2rƥV={h.s_M-Zۯ㵏|\iI;Di2 '>w! V;׵g0YZʢ?<#}թQ|@TCׇ584DvI22~I19 |$M/iCj&% H6NUQ\ivmψ ֊m_އ?"4c$Y]NRCr YZzP]C€=]CTc[⽮"s[6_Fy/ȵDά@+֭M܂x>5֣ uM 2OJs5OH8Tr+r05Go{Qc\^>n*o.kڪ Qٳ.&P>xJxJ<_w #5xxI?SYчL(gBR@\JdT9S,rz;W/. S%s⽏u'{%nSm x; -)`Uu]Zpt=kُ­Oᝏ~7Voΰw.K3wFq|ŪN;>PNOˆ(2s]t&bRJ]=N+ KmMH9Ҹ LzK+GN;¨5+|sؿ5ߡ,r+ #4 eWS& >b{׏yjtOohޗܶ^n,V=O*?o=OZxOV4{ u9#29F$SoNw_c:ĭf;=^hHp~N Ϟ:iKC][x%%08ث߃>;|0voacXt47I/]Ċ|WO%q[nM7ZM+̴u2UU}t_#C-:Md] l 0a\]^,іǖv 2x+d-V#ȱ$ :7twž ѵr"ЕvK##yo8aGĿ>ů|IX,$?)9MxoE0wwlEw<^k[*U[,V ne*G{r[ikC_[A(F+['g۫?n\>8-SW:k*8% <*~~o_ĽyD۹6X\#W<s UL5xw.ͭygf]KFܕmI[##2WWgcQvޯ]0Ĵwg,R((y>xWj+K˿7`)󃞣h X*ЅnA_Ju3\KT-tuooȚ\)Vz~zWF>'ӦRt+KnF 'ck MU#aaZùfFK6xi895ڃBf >Vf HkCc~=ᮽ%&160䰓'w ~e^] uw׹q1CVKoG|&}=tn$gI˖ԵA-_ ^=ռ3 Wqs6]FppdRqֿOß, COmyXrȇZ$;)`Grc^j}_)B\_=#5m>|Ҵcc?64E|Gj .4[i3SNJ>gZd`&э_Ngְ-~2YoTEK!YiBH N<;a_aW}e M>zj7D;2i~*$sǝBR} ,_2~_C|34O| mB!&\64S j[,M؈,7 Sh鞦|q/fӼeik<"ĒMNzRrXJٌ/ݽ-w.Fvj}A#?gDGP^N$Ѯ.IR타˹}_coIN_߂W ocV'?οO5?L6g0rH$mL0{Ϳ 4[ Z &X7GR^*iRi METyI̋Ⱋ^QWTћT>]+`VC}>Z!-- 3 Z.G~Ɵ)=iv:k+hַ^i@!C35GO#g}x Xc6Th$ٮV!NjG;/"6hO"wqO1yk}ڜk2ЯZ14. QQnE|!}fFѴ=^ ɶ8*9_~&ѼY;0r Q>OOon%uɱ395Oղى߆VQiZ;?#&.;?x%4nn-F[ܡ8 5":ѥڰBN #8=˞Zjw˓a#т=VܵNSg,)lSW!{;Y0y}e9j\x <;5ƣpX۩I3Us7&⏄I+OLJ9UW#>GMmXm U9 }UƄ%u3жu{GũVv>#VBa͊I ٢ƾi:fg|umN}R+dD"m`m@@Rph! -ČdVm؜I{Eտ헥t*pjώI] +9.;`bb0+'W['eKhAY^I_W> ig i71ݢYx_<1J)Vd֯ӟ6B ޥq5Չky؎ ${_7b7|o<5us"y.Yųbm$˃y9>a𲪡ion{'tu=fVQrU=5:^vJ3u!ntOO"TyUm<, ?-_ʹX؉;0`Z#R :П\ZV]^Rxd9ՙn"x[E5y|7XY+4*FR !k($^(L^om9b# 4Ckvd!f,^~o Au#5=œב/Ƕ?'=WOҝfmkz̓1ރ$=? ʧ&78tl5 BOChŕ syMA侔xkTysX񘡲|[ofdCyנ|.]֙Mm ͥ#C>n#PUTcZR 8IJz5g/vwNKN#O/W]ʥuxh۾krچ{2XJ[II(FޜuRݗZz O,jN~HP;q]5K-MfnKi,RL872|_1Py<_j [S/PMj RYȶrAfT ~׋NM+ڇ/-JEiM|-LR]\HaVU]+韉?߃d5 m݌h,р ⽪!ϰRSi;(n.z^}#0e:[imW8~^-}~iN[4u& T+~cQW^<%qOzQ]6 >JI'rr3x⦵-F[;x'h. lAFr23־}x3<1Ot~%Y-HCElPsWGr4(u_+is]ͥ?y-1PQWMh[_]RޑmqN PKy$V"28,}'!x*^7rpI5럳ƻ/0m<  ybJ9!ߞ9#<+SX4{ cr2A=|Wil.}hQYb?wc_1~J?7McsU%KKJF 9~>мas|Uu _Rݞ8%w'IAԃ_7Kp$g)+'o7˲{3b!>[w|UC:b+-4PA/su>ԁW[ {O^tY/xC5Q_g+kƱKm@{D٧gKX 'Ğ<=xEö˕}JHH?0y%FqWe3<.ev{Rj)%~>4*V]ԽZh^wWmݺo_.uMsy.cXЏb+Ƭା ZDhN{d Lvp.N܌gxO?vzcռ?mtJ1 9a'Qx{$'o 6ɮi(ݲ8 q5MMxLʌuRpk}sⲊ(Gd/IEzgh_ƯO IV$kT| =ȯ|ebހ?Ïh﷐8^F1jET1\،Ɲrߓ_QbkTnOnWmJfnѤic #θGNo zt5Cq5 I ƈK$:A<&Kş=o ֡m 3脨$NI2ކeN3VM揊nM;4s66沒fbz&OxΣz[.x$Z7o=+"]&6 }! kd'h;|۳+=6y|ic%>:RO] >j^/4 =I )h7N|F|l5ßn4-+Oxl<.ߕ#Nu=BDb^<`>ƩQuDwroef<[[}#P @].9' ?d}Smjt Z+IwF|EKW=H <]]to3E_^spS>X`?q"tpyWN|'KN~xw%U":jJJZ=ivzuks >=иmX(IϹ^/%Xxg¯h"ur*njD m\a_^l,t8kmGU<I{ |<dm+(́N<"%̗4ef]>X4VmiZ/[n~햛xwQ4-Κ 6_ ?<1s׎.]p EoB@-zAʷa,פ15B f#;| yT̈́>Mf(zCF}kxVc5mFۅ_x-_*EU~,I2E,KҊz~ס|GGQNwm-",)WSeSfr_OrYd, ߴ;C[bc(^t{җztOI: ڻ:66ŹOb85 Gt6YcğʹF^cRhqSNd얿syJW|[y8Hg+"›ԖS}:$r5PBLuЮg ZTޣ,䳩?eOBNrwK|uq}AQiRɳQԢ'zWe:kͫcJPϩWm~K[4P<f1ygɯN>Z_|)$zLMKdq5_KKbk w[V9%Zo"JqkWHe&H%xNs|pm1myPױB yZOXm?im.lzkv^)"Yksp빇U9 Wt2\ᛍH^jQn2IktӾ.>Ӈxf(δ/ >G՚iZ ~ N[w^V B8#"W߁xgZM_ZG<[gwn4%2 yTdS j(UA'y|EKxsڌ6:XKF$1>t?k ΋R)VAaƾb_ɼEZlnwϠr%zQ蟖V68jrmym[+ gy_oZiE.|-6՜|;GKxf}SCו,\#Egq9?tuSF&1B3q5084,M8R/UZ랕Y$PkfgY.>`[o&Md%iP]¡fS`ǥxgM |@[獴kͦ79e'wa=V6cvVt3T cmC{pk9ɶ{iKo[ft+1 ʪA}]f+ړ_6#J4$ݸ6O$=* <w:&wm mcHݼ }Ē+< DpxZf9L tʰL;yeu%^%Y>iI?+cԏaᢣ7n_kx{XX~"@º_?/4, 'κ"U:w/>!iiwH5]īf\bJy5Z_{|0^^zUӷ\8<&PJ IV]je_LZ'u+YMúuҠY|Fg!ϊ9w\;i1kOG入fڤ+$_|W^g4vc 6+d,p*ܿ ~~+:Q3ܧ+žmO ?zbTwvm;k3نo Lb+꼓^iusc/~^#VTiŒX00dg&w6;pfl{0{Ջ{+ͬ>E cuRcVh&¹,9NsY^+s_}WZмAj34RXHi@WpKX Uc$k6xaψ2ye*i4v[֯`D g7Iu/L؍dI'`SQ|WE6xoǺ՚/W_]Gg14jK c'=~œ[xLƷO~SJPM_{ۣ?y1X.{$4g+?_|57Ǿռ}mi`$}]EqrTVS= $Uľ2{aipvk wFFq"HxNMoI%$f9nȇ`x _dupبbpPeMktmd[:g[Jo"פTE ~y NC`~.uFpkW0tk;χ_OMf)T~CO jEw0vʱGw? ̳iF.+^W>0SN |[_|~=CE+ {uA2HH=OV+x}t>EqeeV͏~bNGҼBG4|9s*Zɷ.q"sB~<|C+}k d!́;6i}mV5!Q{-;n{2<WCW;_],3ѻ"O:r$ױ$M8 keL᫉1>4}TiX>VWnQ88~w'b[fv$ζ.XGP}Eww=Sŀ’xC6[v÷-*' g^3Ae5m]SGeJc~]wvqMTbƃc}) mg=v=M}'ZM{"w%b@:*?5߲۟tL A|m GMmȟ^j_n4-FLT{Wd9.dEۚU ZrKJkm~}t՟GH A2{ElYxPPmR rV ,0>Xّ&p鑜6k) 'hHW:V/9rxX^yfukR)//Qz; t83ŔMeZI@}$U0a=9>R>HU"kZtl pӑ5O&_~&e%DŽ'jKV?[7Vbқ" <0GVZY8NT~lx4^_yGI: ̋%s𷆼b4.e!nb磡)"P䟝˿$04"xq7/"մ6'͏G:z'g{B_q}+EaY1<7,:}% ףx-)fCXLeluM/?w)5𖲺G=3S𞲧Sfq׭CN|ooȻEx }Nt-9.e=r:ONv[퀘ϱZReUVŅQ?Əg^.hrgE}Mz9-YC i"dt5Sώ  o:# K1X4d4q^)3fsڙF0Z>H;m3"YIumlw=OsˋmbQӫdm5ti[^gAK/N_ݭ7]wLJ|7}fJQ2V@HSV~8!Ҿ*mo/`L`Qp>\7)ǥixr?g+Yn/|3|ѳ8 >bzg'uO'Oşսh .YAMnSh\q~?*bet5]ǚMj%Ivݲ S> hk=UOl?<&!OLMSf_9`I?^~ tX|9jEo?: SXyMnJRҜRw橫%vۺ?. jxYY(蝻~ֳ9'/ |/⟊-eMOjRw rT!$=e-ejRim|%^0ESPc=ߊAauoe89Ü7jh^)?*3^]-ُ]KS`|c+ 1̳:8|抩%d+}, *z3[]~vt3|KimVR#P9p3 Et?KO뺍Yය\F+Cel^W2]Ğm^Kq~P!qݘs+_q:/K۪Iw$66"*fcBl&<ڴG g7񏼚ޖXEȎp>BK|S?}oOeo*;bм5io. {CF@$7$>|7R&,bI$u5x}[JSoFoQ}^L-ʳ[qNmIݭ4IiڿC~|baI=*yj;Rx<+x_Ex:4۞7]~G"ܬ@Xp 9v>ው/k-7V"bLKf ȮpsN8G}}>.Y^jIv 㪒ԝ'oy*IKjdF4hC Jr&VZYy58?ڇ6ҿh_e1U]:ŧEcx.V$d}xM/ŗLuǟe+EqFz_o$<#m \n;ULId>wf$@'^\;>x?藾$Fݑ  Hv Wv;J5*VJ|+]UaS޼]֞s'ODg傔2ޅZK6Lh:̲A$H*= Xڣ~|c@Ѥ :<дSQ<~~rov|^~ҁl%ktN_0|Ĥ]2q]܂NQk݊OM[\ͭ:iaFU擋k]:$mO4o^-mw#Դ뢢OݫE lҽc~$u'LFqW?爾 5+8%)qgi,>v&d<3߄G/6>?40f7opJĖKeB,y+Ϡ#H:q\Ok{=4ͱ9~gQK^=-zC/_Sqz&~п࡚9qeK6xeQ4D2<}zSg׎!ZWӵ;h5 j6 .Pt%#n$*nŦ<4F; `eXA|;UHx\FqoSzkZipk=G%fQԆ漊|CMڃSo;P$5m'oEiZh$35upv|dIn(#iQ^Q_C{n> <>-|=5"/> >EHݝ$g8+ͭ<e$UϨʽ\%꟣i)QiwWP3FhzJ~\} | >(^)KS}Z#lSJ#`\旴t|eG 6&¹Uuaڐ/^Q@ 4 w<63yJ[lmJg-6&F4[=寋ߊKr3Iv}Oȱ^-UTpXxy8"0"%0$+l6"wuk*+2%|^ =F# ⻩)~ G9q)Z&0BO"Hy.[b\?.YǛm'\߯'ź~dnFOx?}Q^phW\>b0s/Ybϱ_,OG#op# ikpM2\Q*.P:ݓs 9e b13wsPOQR:v1tֳbe1ؗ>Wlr{ZlW#c5ufI6W?oskǞ5~AhPqћ_2)|󏜡K)?W2_R?po.'--$n1~+ƺg)ho`Э&+S[8 1X7 mJn+n wÞ!=8Q<{BO]&~p+T7-OZ}69gQ!־ SRX%E8>w+a$Z~pI*_%5ҿ:j&z;5-L1GU_y5KvSJlCM:7ad+7hcWǺ5:|?a2Ml ⣉6ו?2>_'9[:Vks\2\;~,z$@ūB/ fլbssQ|1"On3G)e#2E5A=ZE_^2iʜT5h\kjLm. N:ƱE= 8QHj\پxCē} /4 4n^mD +;wIHK{{Ox֕;Y&m\Z/ _P<<_ޤֲ(o?xÞ?n .=>ns_uF?k[ֶxaz.r]dg#G?ï ZNOZLdE6mU6@S2cVԴ_h׺XԼ+s5ou ] M)n}쇅YF8=(+6km/\S(b*EGm-4?KN#7N-rKt)YgVH.(Ae#n ;q^+u |+}/T^mn9l>߂e@LeNrwcqg887 |}2 +KJH63 IE Os};J-%x.#1,Aø X}VkQJh/ѽ:#|.SjoԴu&Aqizj0S/8!9[zĭ;RMi>{F[H8k n>V$~%]=;ZZs"}I(8#x 4K6ꛉ gol`Wo֤n{p D}"!ZfN{1c$:n_RxQ^!Cѯci$PCq#C c%LH'j:>W$ʎ'ױi` K:F6[[,AJ8ZxP'lYvfX1jOk6vx +ҾI[3z^%ķv -o.$󁴑FkfzRpR}Ͽ} (֧=*eQ뺟> s_Ljgj6v~"c rbq#$^(^]WⶔHoj9N"%DI*@#K^O?G; OjYc%ػa 1 ~9[xUd%;(&oxmM⡘Ny9+pu}8¬9f+=2iGTTr=6I[UmVe eI7mgB$y;Y(mZgʳ!X6\ |~)߃/ZxZBNAl6c_g&: 7ٳ (~${Y`ex׼]VspnT$.@f ~sQ߻$|׳OsMN))E4Z^'E h>-u⫝;].wjۻB'׭s <;}'Z6uxt.LlϟPY~|+׃|yB۝))l!5I!$4\r*/^/#mF}y.Z)c"n#px-q.s*IhWٶm2K-kqJ*z+=Z=|_*X5ZOkǭڛW{ ȧ~_L5/{Ecl|]NېTZ_ MOzjVv^G,%Y0~ҧ'GC*ukinΛg2@Qo9=q\1 ϝveZ]%}|150p#ylmjIem?6_;Ğ[6Vv/D|\pW>^Kx[GZ[)رl,_ֿJ"߉)Vx^Ӵ}A4*DQ:J@2@?C<7x.L>K0[y3f<`/}lveQqڋYRmin}ѧZ:Z2槬[U?5? 1x]2w"\c}.kgnՁ67,^)p9?t?ig:JR4&*XfVWJy0RemH/w " 2"МcKõe~%m$m}Z+)uNcig~xW_StFkŻqP(}@W'~c\=+]JɌwgiq]2A #Jk62.ҁ,sZ{ +A?eLq9Pom@7̓fݵ1_I¾+U̪G+x[&E548 JPbN?-[?R񅥯I⋫6֖3cLrAO㟈qW:5u;Gsl;kSCه_-ۏ3ុ>6R J'&I5ǂ/>k%fڲI`E{\]3:^JWV7]ex8*~*ܓo A{F~+k_7pCsO_ĸG|o4O2~WIb*XUj)|_is'q?:ӳ2ÝzZqpA/xÚ{;;1MyyO 溽KaOߞ4NHqiHo^ >խsZ#q"0M/cTKhƞ#X3?m٣o^5lXu('6=7>~ .c|uͥWxb $?9s_pk 9?~%/Ieuk= ق@8BG 8O6x Bso[l)^+hxy;)&۷&|Gɘn,op>nՋO*WtI| w1,DjVFasuh65u N̷3pƼy~"j3X^5}_M5fm[Hx~TT+(oy(Ӭ̮ 'q:tkhzΉw8{˙.&+oxU85V]g`t2fGIv<Wtgp85ݕ#ZV$+,dy82$סMP-:yRdX,̬~S+YSŭZ3̣ymntP[TZ}+# >W/oxsݞҶoWPqڗ'%،bO4Fa%}NO&vo/Xf)g/.b8cm5%O/¿kz.⹧ԤOf60A!. !޿?,Mse3Z񞵪K{y%o)9pNx__f {~.)cZ2ڴ]:_3{_%ߵ>f>; W;wwi-'/ ?R'fK/Z\ZʤW;WU8#~8!< L2XUR[G+y#Va{Îatãd-n=_/'!k1GIR3^;>8^6è/%7ZtJFUf[}]lڿ'pLjn|M^<rǧ ̖+Z3ޔeũh`FXǾП57<]n " /Uk#>)kv>bj8;-ۃ_ĘNrI.O+apIϞ ]5eqNa XY23?m?i=oX6^\Ph%~A{ ~|@|A{<ˢ^ B}~sE:W7__$t0NH2=M^B~9ρ4 7R-HVO>H]}gP9+~c.j'} /:N'q5c'RN*\掾g?Z`֒25e/:_`wZTE!v' +)2V9BmNAN?jwϛ.q=BM4_6$TUFҸb 88=k ymz7O -}!EF$<,609RѾ0x\K8GZXD=qz} GkH$h'/0 '=$RnW[tx8cNWqۯOf_طg5?|9{{ .˞ٮee&S eAi{UfbnHḱv!対?lB<7RiZXĎ̈RlKіclvj ` y=k-~9b:r9ZQIrY4{]֣j5輏8m_/uW`'`$J0͌ @zz16Du 2amo.j1kQ|.+w4|#iZc,f&3ۍGtIUu]Va#%b;UW%T5t F#(E-#dMMm:~?$$QͻϷ1_N.cy֓(bw@UDےNwqX>$,OlR wN0GZ-]+mY'{95Ρ,]+\ H1x)Օ'y=mlwvݶo/+xYχ5b xSğezdJ>bh*H'ٓ@b|QBӆuKH+93,7W >12SS6VеAP} `W9_Nס|m㏊_| o2C7,DsY2wF1d9pxQf*i+9l{.v8{O!+w},lfS'iMR4<%Ak^_cIy gkdcd_۫VEk]"ºΙg —Ա.\V(F0 2;|}/ngwW,lO^ y S4O+\\\K1˱nֿcr`p|AUF2~]J:hω4b:57Er5xm{m}? x/C|-FXX9A-z5GyŲJ潜GW}u4a78J 4+lv?W'>GG '|I'-9A^|+/7 2(@Y#^0·KK Z.0 6ȯg?hB#q^}X`6f†`p{iJ*)YݤKumk#02DIj.2ì$ 7oj4b6` )u[חFϒfJdd>FkPeac"Aٙ@>E|Qv/ '5mW鶠 . +9,ɷM?UsՕ/Ͽ(%y\$(+_↳> ,I7H_ xgjZLBU?Gu} ]75N3Gc#k7ӖpjT^քmS5 Fgs@|WM9--a#s[2|–5fr-tk~Sŋ2gİSNO}+R6~|Eg|)Vg5[zepG澏aʄ:T$ΝL3q_~uO4ͯ檲7Pr3_H|) ? |4΃x`#OgoT%xpt.)=y S?is0t66ө j^UZK)7^Wꍰ*]Z-u+~u "CP@e8"l>u.ZY]]g<1@~3xC|WeCxm{%ַwgKyWGf`py!W_|'8hj:nlHAK X"'_IBU{z2ݜ]z3xl-?tO^ռ mi0m"{Q]#z5jM_6)YKC c?v[ypߑ֟?0c-4?r߉@Oeگ~",O_?  :$pLG-fijc'p,xfr8n Udw?R_ |eIcšJC\FIo4ʼn-ExSӢ1F!IB,'5H’19&Y-U wpKmLtTk_~B(hSkO#VNh!x Y|`'RX 9uEbvֺ 0~9K+TGyt?/`` ڱs\ldTډ>ԥෛ=SHD7_U9o8@@ZXnQw Txq[f˃ qqWi$d_GGL^HE.}G?k?+G].-w}VXt=kt0+ps^W|9'e'C#֖^=!#߭x߶Nr7Mjbm/} (ϙ ~ؽ3T7Ϡ-uQ$jb}EliZ"Kk8@Ed-e2+.qin# ʾ+NK+;q'}#MɣԌ_zwP:?g¿]Oºx>\pr$Ys7/5/%bp@c ~A-|Gg|1F}B}~'V+hρy&4[.iS66IVM)2Y$@Ldr>W|4n5o3,k/t1'IXsjQLtVV԰9V'2sGm[Zޛ ^1yWeDhٶy'ZF6$ $Z}ƩppC+fTc0z8b˙|&F:p6c*pnw 9xl<9ݥ$n[TH!9r^'Լ'hИryH \{O zOpSsp"-'p=>i5?BgW{oxjrE$jX#q HxyNUe،\ ԼRNVڎZ7F2.d_kh⃌mA ڀ oN%ݖk-ܐLJ 򘡎;o3˓ 6G@ hE(GȱHï_jy]}j5yOWt>["£pyO,FڨIKD) 8 8%5%c|8'#9K0o)';P@b2h&sT+>nYEŶѩ^II%c̲*xjrMN6Iq򳶭|_dգԮ]f"5#o}+ijml/gj Mwo#}Y!F cRH%5/m0u%۫rŀw>=} #F='dvod[x0V|۔tz쉥ִ2 ^0Ytʼn¨vmsl4ToU%ݛտuYk]Kd*^WӷWm7ů~(AcxUnmP!S<#GQExҚ M}'s0Y°+GOkR5tR?,;㓀˞2jY[0ׯz?1V\k_Vu+j8l-*8ބܗMXTz|WE:Roi?|iH8SmFNM|/.s<խt%f܃G'?|-O>&Xoh$!<Ċ= ŹGoZ\9`I/v-yIt;>|HZhӸ]ȸ>/τvZnAKK$ 3o?eO X\;.< $##5?|{}U4vVw$mE븎 ׌M`5g]Zq}OTj< T}kS,#vo.+״i.<H?: FaE!/ѡXa0 J<+G&SүPseut=U`AGyGƻkZGi4 M2XHsNT&)\=\-zuV|//<5GZL%|I-hϩm!A7?f32:3f+h&Dǟugt|#q ՝ͫR=T~,Zf^ѷ_3ЯbjE{vYGGj"ifGҺK.~ĺԖ@[ԙS PT?&'y3#>I _ d'jK-.Pu#ҡWR4E=yOҝ>ChMj&ōyr+վ&AuP־~\@ƅ7/=c;7 ѥ I? ppt\ޝˋx4" eqҽ^xGG Ŧ{O"7LNՃΤ_Q3iVOdWqzyyc0 +ִ__/..db`V#JK7RW,72uG[y֢0ױ_ 2QN(cކ(v ?6W(r.8̄y{_6/4fxǶ"@㨯v f3o4фIǰ TR}+]j$vWvp^ T= x-s8=}AN/Eҧݲbk]3u9z~7$^ !v_'YxE_ 3}j' -][E}cFQE㮏u|4T2L+H-?Rn2vqj%#݅ڞ/W|EImRKyeM(g+1jƳ8ʆ8HqaSj-ynmS ҺkNnjk۲+ 9]߆o"bNszW +U|[Kj'8bUd;׿8h-N~ucڟWæ"9.u D2BW=^ xn{x4X;c0:rnjs\/쫥7 @5%:ԲPz>/' uM-[\qv8]tB[,ۯ :zGQKRO_t|fj0c"Wނ%RQD`N0kōhLdc;q_>$_]:slQ74׈ge_2N>8eB0Hf?=WAѼS#Vw ,cKnWI#9zG"|CcB.D[^<*wvG;5tUn{rgz<_PেS,c^7І_)FuiIFߟ|{$^k[Wx2m9yn_Zx.}Ŀqʅtmp 3Jjk]Ӵ/ ɥ|2[.G5W$l q pqko/|..[-rǻ^9 Q9TqԨ֌ef]VzkN}~uG4Y֡zkG.7e[$jBybv峕#I>I{I%%q̃_J7>}BK1a$+ [Pdq~ vP|SrZ;vߦky=IP>N]߭WtJe^ka:{+=7gj~-Ȟ+-ܜ!?zqXsxv=kFgf@)_8 JзV 7w(.2|zԫ,<"Fz/}˦Uɪ}~yKOZ{$#L}ɯZ/oٻoo ]kk,pZ_%}1Oxg^%!٥ߥOx:=zX]_fó5ލD31v"^O7o[L;ͤ] A+uHVS)F yǟf+weMecrsiK>c>xC዇36i.ٞE0I[JZjQgG|"i6 񜒊BݰkD-1RgO֧USǥAME"H+M!f`Ax%<ʌ&ZRQڏg=[iu-'I_}.FǢrF}ONR_ũX,)Չ8+h({IẖL _÷5a+`8 ڰ7Z|#MJwɀ7R䝡s JXY,?/DNq2l_ G}W4߽Z g5c\t>⵾|Fע|t-8Pa,g=[njY.k>Z5$JȬF?մu`q++BGcj"(UE~էR8Y-cOg/Gq\TEBm6o$?^'_驧$j;pM╶Bz~;||?eOW}p<) /D p:Gֿ$1p{dS]X9OvO3i?huZe>Il9^8xo>|KRMFCBY_(E\͵` l>&b,W, a19?V1u.7v6~8hm"̍ez .(ZV0i֮!?*ϧ$z> >fV8'uqеȱnSe4M}.fڟ~-M1Yt[ʂ%}m\g=_Q\[XjVZގVUTtHu=5fZGZʑ^!9e\A?mRpn[5[?6>M#<?6A㥋TL$\I?uZzYX]pJIzkћgkOi.#ҭýz~?x?~Cf6+|x>'YIusn`9@9߂9 sY>1Ḧ.G =q'>:8_{6i{xl[Og[AVU`_ZN&a0q<֍[|?C^_eFoq_=_a\(GeUHUR<-๯5é xe(G;Ӟ:0UXmlOCֿA,zxx+2&1=k䏊 ]V]~O}6iH$ *C[UL^*yW_u?>#|"Wd^񳷛/=dx^;9oTd0V=|a1"uɆX*$ya2^G<c/MMUW흹})qo/ѿE~LHR]KGŧ- :R_6W}^潦xNu2.F)пh-K1H.z8)g[O>A@1 p qGչ<+,7 5U)֕m߫VW׹vG4OK[ͦ| [g;v[03'l`r_ڛş؞XEK̑@.UQ4\#,Tsz]cC6^ }vl(ݕ+~#C-c'mexՖG֖fJqvz7/M|KwھC,*k&evXyԹp~5_gAb#cc >6ܖ ;!u~p2]g_+Km*O WJ҃z&_h^y_ڱ'>"I7hv˵.s$9Rq鞔WSwqͧ,MYN>ԶRтr;SHF+>>y_m< l-qe~ 8WNfͦ<7rFJR=E}!*`x=1\WOVW1ArFջ־[0۫Zu_\&a-6Rs>#˥i-ԭ1d;cIpzΏ0xw-mFXʬy jO 6ַ k:b~2@$7~KR)Q.o*O~U(RrW]7QLѵKpV%c:<kU(6n+3}( %k@Z !Q W^>-ͦ][Oi4w`,A*uOp~"Pmr[F[pu\L}wyX#Ywqb^X!`DG_|gVO^H0~M@㡯׌k2TV!Ue2ᔜqk='j?$KBI'_:+n+KaY<;hr-+${O=;ל A`6%# ξnA[Ĩ]=^Ǐ1]I3~Y;xU&׊Z~/xzŗ_έ`xRÎV'?`߳U, p=ĸQTr%$,Z\/`KdaR|"~x{*d jos'ʱFKɱ=I?*Oͦ[M)_F:'Ğ14]vG!H+ieaqN@+/#ofV7շo%v~8IW/^#ʿk/I7&̖z0}ilbs!b kjj6D-1@mWٗGfas&]_?_TU궈%Z\We 6UaJP;]-oz',N2Mԃ{j[ IxHsAm$؂pMF 8݂sZGsQoY0G@ZI'I 26FLXc^"‹ ϶|bK3ZGNd2H\_+_r de/8]~? Isr'5t~2xOtYm<ϩۀ8}ϏGAmI8zӟ%bX|7дA~R'̜SWod`wʣt=^{:q^ZOϫ묞|=x#K;UK !礷 (ZDKV-݉*q吏BuW~M@?iWx#k߳]3H͕ia ~5:tl/`%dIu1k䏍O[?7>I[]Cz>ƿVuYR$~Rm -jIuazSmN >^ScV xJ%fj63J$]ggd?ů|#g4b|Ic?yY{w\y6zdDR1cZMp&F0{׏oMxius }k\ qQ(sMm8/G>S.1XHZvz?Yxkt9hkr+Nk#_ —ZuZ(\|IUKd|@]{&!AT~洹lTmѮ_@Qn||A Int[A 08_'82ҥV7ۯ,έ?cJqz=Ix CY2C<*(E$*횡%Y"GF%od`{@lࢾ4:B._=wŻ3zdt֕op^٤$C潉e^!j{Fk;^sbZgRv=ÿKK[moC:tclAg, Wxgh6WoxoH[|1sM o2Gn <|+/(?v-,AfcG3/5X뚯DS>"Cϑn~z7y*٢Z+]I yҡYo+'%so?iKz?artgUc@~k\bNIؿd?R_&ILtEnmO>8~)k4ӵ>xHYԵ?妧w= qt]^cpZ٠ DOa޼o9e\/KUUHsmqJ*VKeQ[~~xi~ M: K&YgnYۙ$GTPGe~"6q1n[ mE$ϕcęR$aojKR'վ񔤶S]nY߉_ݻhmm_a+=WT#U/~/qo.G֠ķ^ W /Ԗ lr1XSc]tKK>.1,ɹr^97ve&0>Ѧ>4S6uǩ }4EJD!ӱ>ulwÿXB.T5֋+/A>^zxT\etmH*Ac_[i+ĊW'޾D{i ?ZL&UhQvn^km{3ǿaZm$}ҾcoNJ}=˓p0;81׸~UjXفD@uUʃtFlkO[>AeO3~H>[q_ͼy3(T$p{_{zm8:Xu7?T .-;|#v $t'ן~˟_kI}"-n$eW p':fDȝ;g5CԕidUFI[0KtW4&(OZ.i!+f Ѝ7eAz_gW'iVo%I:/'sz⾊մ Σŷ:.nfu=ry3Ǻʟ#޸17/{3F3Gïmt|;t++KYRX&n͜ )$|M椡;gМy;Wq6l08uQ} := ZK4vpcs#R(x',|YY127dw{5<]IFk.%X>E:t{;}>\Kq,'³aTsW/˾iݏ.O??:el KuIq/}eG}-zJ=ש6zܷdskm拝uѾNN8ry~ҋ' .яZW\p:Ffi3ԓ]t2*r޺5(KcܚO$$q= ƮA;ϿZ/7C)W^ I 0* '/N|IYt"o/QVHr^77ʟii$ [ rl?V]#(5xw Lb+g1Jߥyl1fk뫙=9 *J5c4{ͱ:2[ǫ?R|;E-/:?q^=xm0)Xܿ1:~&~j:d WWVy[Xe F\c(c׊Eci6Ŀ+nӴ_]ZMϽr=qOxFm[gk۷=̣+bEz0ww6!3#I>¾Y++4Vs@nY!ܤBC_ _ ?c?г]@ 9 y9iG*x_ផ3[ZG}A9?}9fD9c_ xWKv7i5)qTҕWWob:USt!֙/ٓ##jc[I|꺼y8_"My8K4ַ2]G+T}rZrS&tc}=+M>|ڻ7wmݺEp*3_(Jnuǣ1QHz}NMyG026zu(9 ?j/ۃmCYOsߓ |9A>'PVi-$-%߉F6;2?Tr X*h6${WmN_|Uos(j: YQK2X.EqêFw-^@|r>,FY׭OnVZ3yOn7"I+l]1E_pESFmj~W'JT;?U[ovԢ+mCjUtf[ǐ6;.C}kGCklS?j-ڵ'B/=77ۊ3k N}WCd{9p WhwJ0mv&?ω/}ix&k+8!so_ Io Gjo(\RI6y4Mqt(ű55w~\_ʽ{7=* t;(J7JPFs\#JOGp9SFyD{~!|k߼v)1Oj)Զ~IZ-IRݥܖS-$du2?}>O)ĺ,_*͟1=#ppL1yYQͩ{,e%8XLu| M #ⵤ6>Ϟj'^i%j մ^M0܂p*D6u;Ȗ n?JAko8ܰ5eg~b\BZHѷ\!QZPZ2 ~xG0k:Kppz:{`h"cԚ_+"_[^~ s4xy6,/v#&cVڸ݁ʟS Rzr>\kYxw_-ƶK'zqv*|5oK&$Ik¢U=U L֚֟cFG̫,WrP5g½%g4dqWC^wəeӌRI5dSF8:q̚S~Wxs~D_.`V ߏ5v?Fu3NN v^0M}'{e{x,KV:1q1vH;?m#Pb#nd ^*xܟr_fxW)Jq;3-Z2!=z#Owu,%zqؚ_>+[( I[lWC =ٚV?ujG"ko(Omu DM Pǥ}FUG QRQ]8o1}>aoM{?Əj^-Gl@v%*k_Sk#[Ki[q꽈⾁?n|k?}.T3w A_¼cWAחJB LI{SOnַSZi1O'6>S]~3IH2D,ǥ}EMCJJs o G_ a 6v]`%XÐ>^CX4*J]d 1h~ƙZr)uM5~5?t~*fҌe 9-]#:F;G%{I|RA BY]L^~Ⱦ<>3V3Q?۝[ qZV߰]J4FI{ { ~UzSd~O:p#/+O>CW'|Bרr̜9OּO"pIUf\ӭ~'l:emPWkGoi-_˴$7Gt!.>؏Q\^|,=_]gQWrCS,#o>a݄R j=zeSVFrW"gVvZ-Yp(Cu^I`KxG`\5K3kqaBtT%Ok뾥f4V"ە˖?t\]dqO>]Ec y @\۶qV9u}Rԍ[Mʳ{kkY" #H%_x_6\2^\oY'˓$:m u3]oaQN?g1k7o_%CwZ惥izrθ/_%A9;WgW'qy3M}4rI?exVCms,|Q9yN Tn3%8Fw]灸3d3k J.Jk筻_NǏ[WqZ.#Sx;ݳk0-\͹`{ׄxK3{okD]9m߹0]rrkQ/z%ZjCO@)ڡbeQc|`k67pjLP Ȅc''+g O.j-twmݛVV. ΆTQ\~^)w쒺+ 7zLv:t"1Yp9v=وԼ;q$W,g=fb@&aJA >/n\<Ma07K r+%~?+1Ts!gGm6sg3FONwcsgYm#kI'}fQV)+C7p%-{oB=q~5z!s^QD^w,à++iG쾼173߬IkcPV =X6dz4W63n=dW@ m?`2i0Cr?gv5<Yj{)e?@=yl~ªU+tht3֝^ZpZD0vvO-Xjwd9AuGuԵn\Tʠc>^c Z I S ^YEc.kKJ^.9FqmvwEC%pW5L"{<0gDb:fu"L#T2O({k㱏rDkǏWHeѼEH 2̅%,x pkt0NQ浟%oMNRʭ\گU}-9Ƨz{N~"?iЙ_m|1n1ি_دZf7F~'iȼ5 39`}}޽}< K Wb[|E_[WL-465&crjgBM[wz|Ȓ+8aϡ>'i}r"YVI8־_ EHҴiZF$,M `|y'^mƂWwe]6{y]\5)փe#?jO ğ d&a 8h;vFH< Vֵ 2I<ۙȲR;zg+tmﵭ7@-m4Kgy9l*=Z$[vpXM6v"` rG")Q˩B ]ߺZ?7KK8<9UZYmz%߲8π4B_ֵ qq;xxa lrx,}9׊<-}e=Πw&y9@]6\[ٗחG˴AT\TIk|!_3jP<@1`_8c?bk-#qȸG5"8Z򜬒;~+qV_Kh]{u>>πYDOe1%ybsӯ-k<^IORIFuumBY'V̒9}ұ,׊#<=QgJ{+yv~IU\*G*/??cʹo&8vr7>JĮ3Pzt| K785]>ktEڴ yA=k'g' Z>b˓{ģP?2c1Zhɤޝ??ꥈ,sEv< ɝ]@v!^SctaԖ9*Y7|ۜڗb6c`rG9,g 6/t%)~[L1ߟOZG~z#Ju=RG<\ŸL5eH}] }mϵy'nmҼ|VWH9͞I 鲗9TE_7ICF|,%ZLC1'}?`ٙuCv{o!*sc[ qv8?C>_ 2v譭,h0+d3ӫ&矈-%_oo_Q;s軰zWg h`L zg⿃r-evţU?Cj?/QE,Cp8>K+5j~_b4yur-w Uu)V+[@ !# Fލ _ʿ9F5,R*Wχ~5~u0DGc } 7XAGM5բ0Yc x9Vw|x[{_kH/?:[zo7/zP{{jyCZ]my>=jgOxZJ5srQ+|=A(0+nIYz{pA+[F.9(ʽO skZke:rG^j`0qpѽ5MUz=OoqMnhl ߏqgW۵=F49jk BNc吲r[RJJ(C^mkQZ5/uhz/c]JpC{^KӢ 60ZHlI+ĖT,e+1SY{d*rpEra/ 7V.GG Nb)>x=hc^#zsֻo^0ou?iX07/{D=^|$nkQZR/Ȱ[^|)iLo|$cWJ4{響Ϸ}1ynx5/ xw.m#f S@S8q3^_\"ԣԠQ-V ew᾿-g'/$ah!@Bǹ_:G ZG5zb:ebr3]j5)S)K(P` x9 ׏^|׻NַMmN̮U2ٹ֫oKVԿf^$Ӽ,&]G{,HەN8ɮVa&x\ʴkAKm") @8'ľdյ3;NHp1޸_N]~x#U)cK[-0y&"XzY]^m=IZg~=x>ln.H9{uyj:.| ɡv-YN[i|3{j:ۦAfs'j#kȢ.fQޙOR~+2&.fܚM'(__4Oz-U4dw~0? M/l@mEnyXO00y f7(  lhty mK_[d>.N6I)&]N[gܗEt')6~zuRkt$o0dOڽZO©%Eg3Z@Lo^As¼B!^]WU>dDמ|Hc`\.~guQ\߉+|ާ7NN9_yСUT%/;kRo|_@B}u"U:?ڼOMs<:<=:WikH"MDz_u (1rIYg_:-0|/?ّ88_W|YQ$/q!I_'RZ}l,%V6Lktt|P26T,,BFH=ksO>QR -JS:_ؗs 6w8hìڵǪռ=&tRAOEw<K CXOܛԡ h;\ԁpbsLInsX87-[Yw|OimoqץGYid[ʅ=k\_DU\]&+T"ΡkCJuMnyF9 qW> J#!Fpq;6;z~uxJDYtbHhgc1ٸwo qzn(==3\i"h+1Wr| 'sWlmH@=$Ix Kخ_ RUSs=<= Tw"y :SϏ߱׎g; G$5 o?q^Xȯ߭sv^'׭!RC2F/c]=HLrb:OQ_R8|bQ5]~*N k]φY2~Zkw~[VU0U܎Ӽ3_z%g \鞵$Ӿ&_KjuH)|dҵ>%o m5Mh侳YcGY 㪊HcLw;5nh{jJ?i|Ӈ1u/&?Bp9|J-tSZ| vKH9u3E$Z˙61\]jiAZ_j v[.̝9'{/~" ʺIa}'\W~1j:?uIl.-- sdB}8)?lxMf<tf:֦ 1q%m|2puC Vq5cq"H#Oq}ބ`rr+r+qiVXVm ۖu%' g^u#$VgN]RqT,^]W,m<9}xfuO8!bckgܭhəܙ[i v'X~u?m@M3`IjyW1~9w-3?g&KcN jOr?M{ Xt_Ewj:[3c Sy\x<ҼfߩW% {Tj̿noe* bveRq}oulա5xe|Rڤpw2.9ہG":\2i ]s6ǎ+&RpzWE Li29g=znWBx$nyc-Ҕh5RIX/:?QiF?>[RZwqOss,9v><ץx|Hso$H>5 9eG cH51tmĶт0Q]<u ,TN8H?&A% 1^<9,kV.XBOVx,!vW_Ůzil=]PDvN0Mjxc BTolAOEq:M+ sZ*Gpky4{\sӏ5*w:3ѵC ,gvkμC\/KrH[~gQV~8=h҆_d9}ó%g^ztDd6Ek^RHti%Gs^ (~㷐 MytLׇe*aJ=(hϓ BS݋xcRڃ}#O|JOt- /Ǎ{$ e^xμĂ}~kx™cj%k8'l."m)TrKWk}PdiF)TKpOֿ[/$-cKopE,Vw3XZxc+;}}ZzekydSHj~q'o s>"6v1_chrSc5Oh^sJ1OjDA s\յYWxaJTVf8n:.5Q$=*k_5YLe kZW828%s$|.>O=)1q9Q@qMdk&;q/{[;2V$pIN >ݬoB:ׅO1xV ~[[EմlrC>XρzHI7']zdklL$^Xx_4zt^z'g 愰B|пJ]O-uhkk1)+S᝽mum V4bPv3ОⳑM'9F_q{Gh*i F\EL~*6>X?<_x"gڬ_Zσ|Ql5:|; |RD)Tmc[Q>17̎~R`yDle٢5,nTjVqdϗ ԐA\u Ajz,Q)z]N8oO)KF7N >|ҍ0)Q=5oz[z|OAhHpx5,#f;E?e )1B}>µ#E8yOaI:b1 d駹ު;aG+q֪pTq]o<x5bw%pI9cshvσj)m%16ZD^qBZ݃gY\ZC]Rk]񵥚KiHT㦽 miljJ2[=k˩aӗ;˫zx/GE)|Mh\x_ZLp5C篙&k|2;5jcqҵH"FJNa:Jm_ÇZi{蕭mG?;3≴Mȿu:bu K6Mc p62FsrٯuOsjG22_?]פKkѴ$|Ai2;(ҕ,z$־W; S|EuuhE%{tS-on}h~rjBzcgbGz_J kjם+Jb$A״1>x<7^ݩho&ϮX9Uۙ 2L%4R^*%<ٖ2%m+~'w⿊ӄ{kYbdTϩ`0?:χIOK> }NUOgv_奲Gxymb nY QotWWmk\֭l#VX}O&*>1:X =:I|%c}]>WZS~V9ϏA Ic37CوJOW % -۩/fO~x 7zH2l ?XŃ@ c|CIrҩ]/Qu:w_?73>wD. |-z0 vijU]ߝ]6r#'퟇-+xtE?_S2o2ҩOIurOγqv7cOyEsX&_nrE}f/T<5VstfRaОիiЇ#VZy#;}+Y5konFCHb{p)8eӄ[f#RV0oi{Ie:槿VV8>7ט!Wh]RԨg z{5\],Z;f'ӆV9/Wd s<tvz4Vz?70ܠ֝,V4U~5g¯&!}tf}=Nu>7֨| WŒ,zNp>^CuI8d־-aoQBâ _8_gaJkHLT EtZ1Fb&uazfFu*!Wuj)Uo4cVQO"ӌ+?Q_phD2 WOwM3UX/"o2r6ᜲ˵_M[SH?9ETqzT7z̽pygSz3Ⱥ <JH-#m&@U?*sk2s{g\0=Jȥi[]N+ ֥|m1ew\9"r}A5eG?m.1qD,"Ǯg*O+`Uuc%8bqza~\CR֨FT*g9_|A%_?dਖK (U'ƽS%Ϋ^(mEM|t*4Lzu Hb'aÿY4XV^I7;1Ңf"ڠ3X?cƚ]! 9.}SזC1U^;WجVP^K{xc^[Śֽ;%gP[Y?G| ଷ>__鿲x{]_cHA=늧)Tʩ ʑvGo@ SZZ3&It9m$fm3cmq+f4*ve8KY# sMoQُPU{pGaZᥥE8+|ҘTDғ onn9mtasȯNV APk(zt=Mr̫Ur.-/'?|/Eg>WhzZ$vƱ 9ҽ9 Tb A>9~:OgMwr?Cd#rAZRw꿮ǩfRTmOa2qk3~qW|M|.)h]YX#+['&.xĖVvUpxk jI>#e,LsǞ}#^V2R (J }[IuZ;jn~-nQB8j.\t7?{jQmR|#_,|T]zTn8זr$f{^8Owz/XZU1ʢ |B6f#q7J/bf⇈!o)#y\lh?}5?^{K6 p@ p:xX迯XmN:fivB!9g InKMmiH+T8S٤&p$/.;fED%@Ty-p+AeX~ɿ|r{sҷ\ln@9oݧ#*\ E{ZPNQr!{E:=fm(ÇY&mFW:m5hַ j:^'%܍s>J;OuG :3y Gdj)ݲIv&q{Etv X]r޽?u߉:C]Pi TG1`/RrZusTZO yί!XHE؂?`M&ѮlU<'c[|_1{+n/>~^[ix_EXic_g*aiޞ.oE?Nɼ;R}=wgל`KD.:0T𻛭J0r@9溽6F5, 4~ήc| Zߊ ~y]$>o gg_/Qxkׂi 7P@y y_ ,E2q9\R/C cЍɯErG+aGW:V s}W ?S5)V@,^uɯ< O@ dQE?*"jJe\M- aF7U_fY=`|rWww˳=L&g%N=ρ~~x⷏M/imϼ׾|48  ȗY'HOvƮi"R举*3n6>~Ί܇ |%Aú ߏuKtPMQHŏ[6L Ox=OEO{]W6-#U1B'J19,o'yi.fSpyc:b䵰6#QVl'1_/,uj\ֶmǨѢӂZ>ٻ>j«_o],فQ}"Hj"(b'̃1N<1mcTSsjsJOaN+T97k-a I5(1"dZ(ĪK[$$BXDA?Ϊϫ\K!\V,㕁qͶ o2rKMe}|T!I o [)dַ7<+Xo5 " *Hzz/LmE9lЊ|wWQV3XXsy>-LJir^xWt+8LQۦ>E|Bv{}^@-[SįX?. Kv*^Inf'ךq `[WW*|,ڭzFSڣ"el>ҟ(.0ڇ־r}sSw7Xu9{i$xLJ4Hu]Yc/;N: x+Oa2n-_Yd =KW5ɈoF/߁цTIHu؍xf19J(Hzvof1NZPaRvV6VNޠ1STO+ݞxUТY}pȫV 60{2 ,.ϱ-R; mL :@]R$EHvVOi>YSFD'1~\gKR⯴$")6r8CO$U'ݖꏧbyR˧8}Gֱz< 0c^[+ycAn-.M>*ݶr8Ok/ |;Ѽ%,-l- akfyJb1Xچ2 W8n+76.|. %B ~yz(͎}+&1Ż{kY&;$Ү]\sj,T1\vϦ+Ct2~Wwhmd?QGŸ6ğV=Wx⚩o*@q\V]$ ڹ뫆}ێpO?}v&Nڟ?-o@-޹MSW豙2v˻vOC^*Tu=jFile-MMagic-XS-0.09008/t/data/test.rtf000644 000766 000024 00000000676 12321356423 017173 0ustar00JP11194staff000000 000000 {\rtf1\mac\ansicpg10000\cocoartf102 {\fonttbl\f0\fnil\fcharset78 HiraKakuPro-W3;} {\colortbl;\red255\green255\blue255;} \margl1440\margr1440\vieww9600\viewh14400\viewkind0 \pard\tx566\tx1133\tx1700\tx2267\tx2834\tx3401\tx3968\tx4535\tx5102\tx5669\tx6236\tx6803\ql\qnatural \f0\fs24 \cf0 \'82\'b1\'82\'ea\'82\'cdRTF\'83\'74\'83\'40\'83\'43\'83\'8b\'82\'c5\'82\'b2\'82\'b4\'82\'a2\'82\'dc\'82\'b7\'81\'42\ \'82\'a4\'82\'d0\'82\'e5\'82\'db\'82\'db}File-MMagic-XS-0.09008/t/data/test.xml000644 000766 000024 00000000055 12321356423 017167 0ustar00JP11194staff000000 000000 1File-MMagic-XS-0.09008/src/MMagic.xs000644 000766 000024 00000005415 12321356423 016617 0ustar00JP11194staff000000 000000 #include "perl-mmagic-xs.h" static int PerlFMM_mg_free(pTHX_ SV *const sv, MAGIC *const mg) { fmmagic *m; fmmagic *md; PerlFMM *const state = (PerlFMM *) mg->mg_ptr; PERL_UNUSED_VAR(sv); for (m = state->magic; m; ) { md = m; m = m->next; Safefree(md); } state->last = NULL; if (state->ext) { st_free_table(state->ext); } if (state->error != NULL) { SvREFCNT_dec(state->error); state->error = NULL; } Safefree(state); return 0; } static int PerlFMM_mg_dup(pTHX_ MAGIC *const mg, CLONE_PARAMS *const param) { #ifdef USE_ITHREADS PerlFMM *const state = (PerlFMM*) mg->mg_ptr; PerlFMM *newstate; PERL_UNUSED_VAR(param); newstate = PerlFMM_clone(state); mg->mg_ptr = (char *) newstate; #else PERL_UNUSED_VAR(mg); PERL_UNUSED_VAR(param); #endif return 0; } static MAGIC* PerlFMM_mg_find(pTHX_ SV* const sv, const MGVTBL* const vtbl){ MAGIC* mg; assert(sv != NULL); assert(vtbl != NULL); for(mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic){ if(mg->mg_virtual == vtbl){ assert(mg->mg_type == PERL_MAGIC_ext); return mg; } } croak("File::MMagic::XS: Invalid File::MMagic::XS object was passed"); return NULL; /* not reached */ } static MGVTBL PerlFMM_vtbl = { /* for identity */ NULL, /* get */ NULL, /* set */ NULL, /* len */ NULL, /* clear */ PerlFMM_mg_free, /* free */ NULL, /* copy */ PerlFMM_mg_dup, /* dup */ NULL, /* local */ }; #define PerlFMM__create PerlFMM_create MODULE = File::MMagic::XS PACKAGE = File::MMagic::XS PREFIX = PerlFMM_ PROTOTYPES: ENABLE PerlFMM * PerlFMM__create(class_sv) SV *class_sv; PerlFMM * PerlFMM_clone(self) PerlFMM *self; PREINIT: SV *class_sv = ST(0); SV * PerlFMM_parse_magic_file(self, file) PerlFMM *self; char *file; SV * PerlFMM_fhmagic(self, svio) PerlFMM *self; SV *svio; SV * PerlFMM_fsmagic(self, filename) PerlFMM *self; char *filename; SV * PerlFMM_bufmagic(self, buf) PerlFMM *self; SV *buf; SV * PerlFMM_ascmagic(self, data) PerlFMM *self; char *data; SV * PerlFMM_get_mime(self, filename) PerlFMM *self; char *filename; SV * PerlFMM_add_magic(self, magic) PerlFMM *self; char *magic; SV * PerlFMM_add_file_ext(self, ext, mime) PerlFMM *self; char *ext; char *mime; SV * error(self) PerlFMM *self; CODE: if (! FMM_OK(self)) croak("Object not initialized."); if (self->error == NULL) { RETVAL = newSV(0); } else { RETVAL = newSVsv(self->error); } OUTPUT: RETVAL File-MMagic-XS-0.09008/src/MMagicST.c000644 000766 000024 00000025771 12321356423 016665 0ustar00JP11194staff000000 000000 #ifndef __MMAGIC_ST_C__ #define __MMAGIC_ST_C__ /* This is a public domain general purpose hash table package written by Peter Moore @ UCB. */ /* static char sccsid[] = "@(#) st.c 5.1 89/12/14 Crucible"; */ #include #include #include #include "MMagicST.h" #ifdef _WIN32 #include #endif typedef struct st_table_entry st_table_entry; struct st_table_entry { unsigned int hash; st_data_t key; st_data_t record; st_table_entry *next; }; #define ST_DEFAULT_MAX_DENSITY 5 #define ST_DEFAULT_INIT_TABLE_SIZE 11 /* * DEFAULT_MAX_DENSITY is the default for the largest we allow the * average number of items per bin before increasing the number of * bins * * DEFAULT_INIT_TABLE_SIZE is the default for the number of bins * allocated initially * */ static int numcmp(long, long); static int numhash(long); static struct st_hash_type type_numhash = { numcmp, numhash, }; /* extern int strcmp(const char *, const char *); */ static int strhash(const char *); static struct st_hash_type type_strhash = { strcmp, strhash, }; #ifdef RUBY_PLATFORM #define xmalloc ruby_xmalloc #define xcalloc ruby_xcalloc #define xrealloc ruby_xrealloc #define xfree ruby_xfree void *xmalloc(long); void *xcalloc(long, long); void *xrealloc(void *, long); void xfree(void *); #else #define xmalloc malloc #define xcalloc calloc #endif static void rehash(st_table *); #define alloc(type) (type*)xmalloc((unsigned)sizeof(type)) #define Calloc(n,s) (char*)xcalloc((n),(s)) #define EQUAL(table,x,y) ((x)==(y) || (*table->type->compare)((x),(y)) == 0) #define do_hash(key,table) (unsigned int)(*(table)->type->hash)((key)) #define do_hash_bin(key,table) (do_hash(key, table)%(table)->num_bins) /* * MINSIZE is the minimum size of a dictionary. */ #define MINSIZE 8 /* Table of prime numbers 2^n+a, 2<=n<=30. */ static long primes[] = { 8 + 3, 16 + 3, 32 + 5, 64 + 3, 128 + 3, 256 + 27, 512 + 9, 1024 + 9, 2048 + 5, 4096 + 3, 8192 + 27, 16384 + 43, 32768 + 3, 65536 + 45, 131072 + 29, 262144 + 3, 524288 + 21, 1048576 + 7, 2097152 + 17, 4194304 + 15, 8388608 + 9, 16777216 + 43, 33554432 + 35, 67108864 + 15, 134217728 + 29, 268435456 + 3, 536870912 + 11, 1073741824 + 85, 0 }; static int new_size(size) int size; { int i; #if 0 for (i=3; i<31; i++) { if ((1< size) return 1< size) return primes[i]; } /* Ran out of polynomials */ return -1; /* should raise exception */ #endif } #ifdef HASH_LOG static int collision = 0; static int init_st = 0; static void stat_col() { FILE *f = fopen("/tmp/col", "w"); fprintf(f, "collision: %d\n", collision); fclose(f); } #endif st_table* st_init_table_with_size(type, size) struct st_hash_type *type; int size; { st_table *tbl; #ifdef HASH_LOG if (init_st == 0) { init_st = 1; atexit(stat_col); } #endif size = new_size(size); /* round up to prime number */ tbl = alloc(st_table); tbl->type = type; tbl->num_entries = 0; tbl->num_bins = size; tbl->bins = (st_table_entry **)Calloc(size, sizeof(st_table_entry*)); return tbl; } st_table* st_init_table(type) struct st_hash_type *type; { return st_init_table_with_size(type, 0); } st_table* st_init_numtable(void) { return st_init_table(&type_numhash); } st_table* st_init_numtable_with_size(size) int size; { return st_init_table_with_size(&type_numhash, size); } st_table* st_init_strtable(void) { return st_init_table(&type_strhash); } st_table* st_init_strtable_with_size(size) int size; { return st_init_table_with_size(&type_strhash, size); } void st_free_table(table) st_table *table; { register st_table_entry *ptr, *next; int i; for(i = 0; i < table->num_bins; i++) { ptr = table->bins[i]; while (ptr != 0) { next = ptr->next; free(ptr); ptr = next; } } free(table->bins); free(table); } #define PTR_NOT_EQUAL(table, ptr, hash_val, key) \ ((ptr) != 0 && (ptr->hash != (hash_val) || !EQUAL((table), (key), (ptr)->key))) #ifdef HASH_LOG #define COLLISION collision++ #else #define COLLISION #endif #define FIND_ENTRY(table, ptr, hash_val, bin_pos) do {\ bin_pos = hash_val%(table)->num_bins;\ ptr = (table)->bins[bin_pos];\ if (PTR_NOT_EQUAL(table, ptr, hash_val, key)) {\ COLLISION;\ while (PTR_NOT_EQUAL(table, ptr->next, hash_val, key)) {\ ptr = ptr->next;\ }\ ptr = ptr->next;\ }\ } while (0) int st_lookup(table, key, value) st_table *table; register st_data_t key; st_data_t *value; { unsigned int hash_val, bin_pos; register st_table_entry *ptr; hash_val = do_hash(key, table); FIND_ENTRY(table, ptr, hash_val, bin_pos); if (ptr == 0) { return 0; } else { if (value != 0) *value = ptr->record; return 1; } } #define ADD_DIRECT(table, key, value, hash_val, bin_pos)\ do {\ st_table_entry *entry;\ if (table->num_entries/(table->num_bins) > ST_DEFAULT_MAX_DENSITY) {\ rehash(table);\ bin_pos = hash_val % table->num_bins;\ }\ \ entry = alloc(st_table_entry);\ \ entry->hash = hash_val;\ entry->key = key;\ entry->record = value;\ entry->next = table->bins[bin_pos];\ table->bins[bin_pos] = entry;\ table->num_entries++;\ } while (0) int st_insert(table, key, value) register st_table *table; register st_data_t key; st_data_t value; { unsigned int hash_val, bin_pos; register st_table_entry *ptr; hash_val = do_hash(key, table); FIND_ENTRY(table, ptr, hash_val, bin_pos); if (ptr == 0) { ADD_DIRECT(table, key, value, hash_val, bin_pos); return 0; } else { ptr->record = value; return 1; } } void st_add_direct(table, key, value) st_table *table; st_data_t key; st_data_t value; { unsigned int hash_val, bin_pos; hash_val = do_hash(key, table); bin_pos = hash_val % table->num_bins; ADD_DIRECT(table, key, value, hash_val, bin_pos); } static void rehash(table) register st_table *table; { register st_table_entry *ptr, *next, **new_bins; int i, old_num_bins = table->num_bins, new_num_bins; unsigned int hash_val; new_num_bins = new_size(old_num_bins+1); new_bins = (st_table_entry**)Calloc(new_num_bins, sizeof(st_table_entry*)); for(i = 0; i < old_num_bins; i++) { ptr = table->bins[i]; while (ptr != 0) { next = ptr->next; hash_val = ptr->hash % new_num_bins; ptr->next = new_bins[hash_val]; new_bins[hash_val] = ptr; ptr = next; } } free(table->bins); table->num_bins = new_num_bins; table->bins = new_bins; } st_table* st_copy(old_table) st_table *old_table; { st_table *new_table; st_table_entry *ptr, *entry; int i, num_bins = old_table->num_bins; new_table = alloc(st_table); if (new_table == 0) { return 0; } *new_table = *old_table; new_table->bins = (st_table_entry**) Calloc((unsigned)num_bins, sizeof(st_table_entry*)); if (new_table->bins == 0) { free(new_table); return 0; } for(i = 0; i < num_bins; i++) { new_table->bins[i] = 0; ptr = old_table->bins[i]; while (ptr != 0) { entry = alloc(st_table_entry); if (entry == 0) { free(new_table->bins); free(new_table); return 0; } *entry = *ptr; entry->next = new_table->bins[i]; new_table->bins[i] = entry; ptr = ptr->next; } } return new_table; } int st_delete(table, key, value) register st_table *table; register st_data_t *key; st_data_t *value; { unsigned int hash_val; st_table_entry *tmp; register st_table_entry *ptr; hash_val = do_hash_bin(*key, table); ptr = table->bins[hash_val]; if (ptr == 0) { if (value != 0) *value = 0; return 0; } if (EQUAL(table, *key, ptr->key)) { table->bins[hash_val] = ptr->next; table->num_entries--; if (value != 0) *value = ptr->record; *key = ptr->key; free(ptr); return 1; } for(; ptr->next != 0; ptr = ptr->next) { if (EQUAL(table, ptr->next->key, *key)) { tmp = ptr->next; ptr->next = ptr->next->next; table->num_entries--; if (value != 0) *value = tmp->record; *key = tmp->key; free(tmp); return 1; } } return 0; } int st_delete_safe(table, key, value, never) register st_table *table; register st_data_t *key; st_data_t *value; st_data_t never; { unsigned int hash_val; register st_table_entry *ptr; hash_val = do_hash_bin(*key, table); ptr = table->bins[hash_val]; if (ptr == 0) { if (value != 0) *value = 0; return 0; } for(; ptr != 0; ptr = ptr->next) { if ((ptr->key != never) && EQUAL(table, ptr->key, *key)) { table->num_entries--; *key = ptr->key; if (value != 0) *value = ptr->record; ptr->key = ptr->record = never; return 1; } } return 0; } static int delete_never(key, value, never) st_data_t key, value, never; { if (value == never) return ST_DELETE; return ST_CONTINUE; } void st_cleanup_safe(table, never) st_table *table; st_data_t never; { int num_entries = table->num_entries; st_foreach(table, delete_never, never); table->num_entries = num_entries; } void st_foreach(table, func, arg) st_table *table; int (*func)(); st_data_t arg; { st_table_entry *ptr, *last, *tmp; enum st_retval retval; int i; for(i = 0; i < table->num_bins; i++) { last = 0; for(ptr = table->bins[i]; ptr != 0;) { retval = (*func)(ptr->key, ptr->record, arg, 0); switch (retval) { case ST_CHECK: /* check if hash is modified during iteration */ tmp = 0; if (i < table->num_bins) { for (tmp = table->bins[i]; tmp; tmp=tmp->next) { if (tmp == ptr) break; } } if (!tmp) { /* call func with error notice */ retval = (*func)(0, 0, arg, 1); return; } /* fall through */ case ST_CONTINUE: last = ptr; ptr = ptr->next; break; case ST_STOP: return; case ST_DELETE: tmp = ptr; if (last == 0) { table->bins[i] = ptr->next; } else { last->next = ptr->next; } ptr = ptr->next; free(tmp); table->num_entries--; } } } } static int strhash(string) register const char *string; { register int c; #ifdef HASH_ELFHASH register unsigned int h = 0, g; while ((c = *string++) != '\0') { h = ( h << 4 ) + c; if ( g = h & 0xF0000000 ) h ^= g >> 24; h &= ~g; } return h; #elif HASH_PERL register int val = 0; while ((c = *string++) != '\0') { val += c; val += (val << 10); val ^= (val >> 6); } val += (val << 3); val ^= (val >> 11); return val + (val << 15); #else register int val = 0; while ((c = *string++) != '\0') { val = val*997 + c; } return val + (val>>5); #endif } static int numcmp(x, y) long x, y; { return x != y; } static int numhash(n) long n; { return n; } #endif /* __MMAGIC_ST_C__ */ File-MMagic-XS-0.09008/src/MMagicST.h000644 000766 000024 00000003204 12321356423 016655 0ustar00JP11194staff000000 000000 /* This is a public domain general purpose hash table package written by Peter Moore @ UCB. */ /* @(#) st.h 5.1 89/12/14 */ #ifndef ST_INCLUDED #define ST_INCLUDED typedef unsigned long st_data_t; #define ST_DATA_T_DEFINED typedef struct st_table st_table; struct st_hash_type { int (*compare)(); int (*hash)(); }; struct st_table { struct st_hash_type *type; int num_bins; int num_entries; struct st_table_entry **bins; }; #define st_is_member(table,key) st_lookup(table,key,(st_data_t *)0) enum st_retval {ST_CONTINUE, ST_STOP, ST_DELETE, ST_CHECK}; #ifndef _ # define _(args) args #endif #ifndef ANYARGS # ifdef __cplusplus # define ANYARGS ... # else # define ANYARGS # endif #endif st_table *st_init_table _((struct st_hash_type *)); st_table *st_init_table_with_size _((struct st_hash_type *, int)); st_table *st_init_numtable _((void)); st_table *st_init_numtable_with_size _((int)); st_table *st_init_strtable _((void)); st_table *st_init_strtable_with_size _((int)); int st_delete _((st_table *, st_data_t *, st_data_t *)); int st_delete_safe _((st_table *, st_data_t *, st_data_t *, st_data_t)); int st_insert _((st_table *, st_data_t, st_data_t)); int st_lookup _((st_table *, st_data_t, st_data_t *)); void st_foreach _((st_table *, int (*)(ANYARGS), st_data_t)); void st_add_direct _((st_table *, st_data_t, st_data_t)); void st_free_table _((st_table *)); void st_cleanup_safe _((st_table *, st_data_t)); st_table *st_copy _((st_table *)); #define ST_NUMCMP ((int (*)()) 0) #define ST_NUMHASH ((int (*)()) -2) #define st_numcmp ST_NUMCMP #define st_numhash ST_NUMHASH int st_strhash(); #endif /* ST_INCLUDED */ File-MMagic-XS-0.09008/src/perl-mmagic-xs.c000644 000766 000024 00000121521 12321411516 020067 0ustar00JP11194staff000000 000000 /* * Daisuke Maki * All rights reserved. * * This is a complete port of the apache module mod_mime_magic. * This is based on httpd-2.0.52's mod_mime_magic.c -- portions of this * code was shamelessly borrowed from there. * * fmm_mime_magic(file) * -> fsmagic(file) * -> read HOWMANY bytes * -> apply softmagic(buf) * -> apply ascmagic(buf) * * fmm_append_buf -> appends raw string to a buffer * fmm_append_mime -> appends mime string * */ /* Copyright 1999-2004 The Apache Software Foundation * * Licensed under the Apache License, Version 2.0 (the "License"); * you may not use this file except in compliance with the License. * You may obtain a copy of the License at * * http://www.apache.org/licenses/LICENSE-2.0 * * Unless required by applicable law or agreed to in writing, software * distributed under the License is distributed on an "AS IS" BASIS, * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. * See the License for the specific language governing permissions and * limitations under the License. */ /* * mod_mime_magic: MIME type lookup via file magic numbers * Copyright (c) 1996-1997 Cisco Systems, Inc. * * This software was submitted by Cisco Systems to the Apache Software Foundation in July * 1997. Future revisions and derivatives of this source code must * acknowledge Cisco Systems as the original contributor of this module. * All other licensing and usage conditions are those of the Apache Software Foundation. * * Some of this code is derived from the free version of the file command * originally posted to comp.sources.unix. Copyright info for that program * is included below as required. * --------------------------------------------------------------------------- * - 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. 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. * ------------------------------------------------------------------------- * * For compliance with Mr Darwin's terms: this has been very significantly * modified from the free "file" command. * - all-in-one file for compilation convenience when moving from one * version of Apache to the next. * - Memory allocation is done through the Apache API's apr_pool_t structure. * - All functions have had necessary Apache API request or server * structures passed to them where necessary to call other Apache API * routines. (i.e. usually for logging, files, or memory allocation in * itself or a called function.) * - struct magic has been converted from an array to a single-ended linked * list because it only grows one record at a time, it's only accessed * sequentially, and the Apache API has no equivalent of realloc(). * - Functions have been changed to get their parameters from the server * configuration instead of globals. (It should be reentrant now but has * not been tested in a threaded environment.) * - Places where it used to print results to stdout now saves them in a * list where they're used to set the MIME type in the Apache request * record. * - Command-line flags have been removed since they will never be used here. * * Ian Kluft * Engineering Information Framework * Central Engineering * Cisco Systems, Inc. * San Jose, CA, USA * * Initial installation July/August 1996 * Misc bug fixes May 1997 * Submission to Apache Software Foundation July 1997 * */ #ifndef __PERL_MMAGIC_XS_C__ #define __PERL_MMAGIC_XS_C__ #include "perl-mmagic-xs.h" /* * data structures for tar file recognition * -------------------------------------------------------------------------- * Header file for public domain tar (tape archive) program. * * @(#)tar.h 1.20 86/10/29 Public Domain. Created 25 August 1985 by John * Gilmore, ihnp4!hoptoad!gnu. * * Header block on tape. * * I'm going to use traditional DP naming conventions here. A "block" is a big * chunk of stuff that we do I/O on. A "record" is a piece of info that we * care about. Typically many "record"s fit into a "block". */ #define RECORDSIZE 512 #define NAMSIZ 100 #define TUNMLEN 32 #define TGNMLEN 32 union record { char charptr[RECORDSIZE]; struct header { char name[NAMSIZ]; char mode[8]; char uid[8]; char gid[8]; char size[12]; char mtime[12]; char chksum[8]; char linkflag; char linkname[NAMSIZ]; char magic[8]; char uname[TUNMLEN]; char gname[TGNMLEN]; char devmajor[8]; char devminor[8]; } header; }; /* The magic field is filled with this if uname and gname are valid. */ #define TMAGIC "ustar " /* 7 chars and a null */ /* * includes for ASCII substring recognition formerly "names.h" in file * command * * Original notes: names and types used by ascmagic in file(1). These tokens are * here because they can appear anywhere in the first HOWMANY bytes, while * tokens in /etc/magic must appear at fixed offsets into the file. Don't * make HOWMANY too high unless you have a very fast CPU. */ /* these types are used to index the apr_table_t 'types': keep em in sync! */ /* HTML inserted in first because this is a web server module now */ #define L_HTML 0 /* HTML */ #define L_C 1 /* first and foremost on UNIX */ #define L_FORT 2 /* the oldest one */ #define L_MAKE 3 /* Makefiles */ #define L_PLI 4 /* PL/1 */ #define L_MACH 5 /* some kinda assembler */ #define L_ENG 6 /* English */ #define L_PAS 7 /* Pascal */ #define L_MAIL 8 /* Electronic mail */ #define L_NEWS 9 /* Usenet Netnews */ static char *types[] = { "text/html", /* HTML */ "text/plain", /* "c program text", */ "text/plain", /* "fortran program text", */ "text/plain", /* "make commands text", */ "text/plain", /* "pl/1 program text", */ "text/plain", /* "assembler program text", */ "text/plain", /* "English text", */ "text/plain", /* "pascal program text", */ "message/rfc822", /* "mail text", */ "message/news", /* "news text", */ "application/binary", /* "can't happen error on names.h/types", */ 0 }; static struct names { char *name; short type; } names[] = { /* These must be sorted by eye for optimal hit rate */ /* Add to this list only after substantial meditation */ { "", L_HTML }, { "", L_HTML }, { "", L_HTML }, { "", L_HTML }, { "", L_HTML }, { "<TITLE>", L_HTML }, { "<h1>", L_HTML }, { "<H1>", L_HTML }, { "<!--", L_HTML }, { "<!DOCTYPE HTML", L_HTML }, { "</html>", L_HTML }, { "/*", L_C }, /* must precede "The", "the", etc. */ { "#include", L_C }, { "char", L_C }, { "The", L_ENG }, { "the", L_ENG }, { "double", L_C }, { "extern", L_C }, { "float", L_C }, { "real", L_C }, { "struct", L_C }, { "union", L_C }, { "CFLAGS", L_MAKE }, { "LDFLAGS", L_MAKE }, { "all:", L_MAKE }, { ".PRECIOUS", L_MAKE }, /* * Too many files of text have these words in them. Find another way to * recognize Fortrash. */ #ifdef NOTDEF { "subroutine", L_FORT }, { "function", L_FORT }, { "block", L_FORT }, { "common", L_FORT }, { "dimension", L_FORT }, { "integer", L_FORT }, { "data", L_FORT }, #endif /* NOTDEF */ { ".ascii", L_MACH }, { ".asciiz", L_MACH }, { ".byte", L_MACH }, { ".even", L_MACH }, { ".globl", L_MACH }, { "clr", L_MACH }, { "(input,", L_PAS }, { "dcl", L_PLI }, { "Received:", L_MAIL }, { ">From", L_MAIL }, { "Return-Path:", L_MAIL }, { "Cc:", L_MAIL }, { "Newsgroups:", L_NEWS }, { "Path:", L_NEWS }, { "Organization:", L_NEWS }, { NULL, 0 } }; #define NNAMES ((sizeof(names)/sizeof(struct names)) - 1) /* append string to an existing buffer, using printf fashion */ /* Will refuse to append anything after MAXMIMESTRING into dst*/ static void fmm_append_buf(PerlFMM *state, char **dst, char *str, ...) { va_list ap; char buf[MAXMIMESTRING]; SV *err; strcpy( buf, str ); va_start(ap, str); vsnprintf(buf, sizeof(buf), str, ap); va_end(ap); if (strlen(buf) + 1 > MAXMIMESTRING - strlen(*dst)) { err = newSVpv("detected truncation in fmm_append_buf. refusing to append", 0); FMM_SET_ERROR(state, err); return; } #ifdef FMM_DEBUG PerlIO_printf(PerlIO_stderr(), "dst = %s, buf = %s\n", *dst, buf); #endif strncat(*dst, buf, strlen(buf)); } /* APR_CTIME_LEN is defined in apr_time.h */ #define CTIME_LEN 25 #define CTIME_FMT "%a %b %d %H:%M:%S %Y" /* * Convert the byte order of the data we are looking at */ static int fmm_mconvert(PerlFMM *state, union VALUETYPE *p, fmmagic *m) { char *rt; SV *err; switch (m->type) { case BYTE: case SHORT: case LONG: case DATE: return 1; case STRING: /* Null terminate and eat the return */ p->s[sizeof(p->s) - 1] = '\0'; if ((rt = strchr(p->s, '\n')) != NULL) *rt = '\0'; return 1; case BESHORT: p->h = (short) ((p->hs[0] << 8) | (p->hs[1])); return 1; case BELONG: case BEDATE: p->l = (long) ((p->hl[0] << 24) | (p->hl[1] << 16) | (p->hl[2] << 8) | (p->hl[3])); return 1; case LESHORT: p->h = (short) ((p->hs[1] << 8) | (p->hs[0])); return 1; case LELONG: case LEDATE: p->l = (long) ((p->hl[3] << 24) | (p->hl[2] << 16) | (p->hl[1] << 8) | (p->hl[0])); return 1; default: err = newSVpvf( "fmm_mconvert : invalid type %d in mconvert().", m->type ); FMM_SET_ERROR(state, err); return 0; } } static int fmm_mget(PerlFMM *state, union VALUETYPE *p, unsigned char *s, fmmagic *m, size_t nbytes) { long offset = m->offset; if (offset + sizeof(union VALUETYPE) > nbytes) { return 0; } memcpy(p, s + offset, sizeof(union VALUETYPE)); if (!fmm_mconvert(state, p, m)) { return 0; } if (m->flag & INDIR) { switch (m->in.type) { case BYTE: offset = p->b + m->in.offset; break; case SHORT: offset = p->h + m->in.offset; break; case LONG: offset = p->l + m->in.offset; break; } if (offset + sizeof(union VALUETYPE) > nbytes) return 0; memcpy(p, s + offset, sizeof(union VALUETYPE)); if (!fmm_mconvert(state, p, m)) { return 0; } } return 1; } #define isODIGIT(c) (((unsigned char)(c) >= '0') && ((unsigned char)(c) <= '7')) /* * Quick and dirty octal conversion. * * Result is -1 if the field is invalid (all blank, or nonoctal). */ static long from_oct(int digs, char *where) { register long value; while (isSPACE(*where)) { /* Skip spaces */ where++; if (--digs <= 0) return -1; /* All blank field */ } value = 0; while (digs > 0 && isODIGIT(*where)) { /* Scan til nonoctal */ value = (value << 3) | (*where++ - '0'); --digs; } if (digs > 0 && *where && !isSPACE(*where)) return -1; /* Ended on non-space/nul */ return value; } /* * is_tar() -- figure out whether file is a tar archive. * * Stolen (by author of file utility) from the public domain tar program: Public * Domain version written 26 Aug 1985 John Gilmore (ihnp4!hoptoad!gnu). * * @(#)list.c 1.18 9/23/86 Public Domain - gnu $Id: mod_mime_magic.c,v 1.7 * 1997/06/24 00:41:02 ikluft Exp ikluft $ * * Comments changed and some code/comments reformatted for file command by Ian * Darwin. */ /* * Return 0 if the checksum is bad (i.e., probably not a tar archive), 1 for * old UNIX tar file, 2 for Unix Std (POSIX) tar file. */ static int is_tar(unsigned char *buf, size_t nbytes) { register union record *header = (union record *) buf; register int i; register long sum, recsum; register char *p; if (nbytes < sizeof(union record)) return 0; recsum = from_oct(8, header->header.chksum); sum = 0; p = header->charptr; for (i = sizeof(union record); --i >= 0;) { /* * We can't use unsigned char here because of old compilers, e.g. V7. */ sum += 0xFF & *p++; } /* Adjust checksum to count the "chksum" field as blanks. */ for (i = sizeof(header->header.chksum); --i >= 0;) sum -= 0xFF & header->header.chksum[i]; sum += ' ' * sizeof header->header.chksum; if (sum != recsum) return 0; /* Not a tar archive */ if (0 == strcmp(header->header.magic, TMAGIC)) return 2; /* Unix Standard tar archive */ return 1; /* Old fashioned tar archive */ } /* * extend the sign bit if the comparison is to be signed */ static unsigned long fmm_signextend(PerlFMM *state, fmmagic *m, unsigned long v) { SV *err; if (!(m->flag & UNSIGNED)) switch (m->type) { /* * Do not remove the casts below. They are vital. When later * compared with the data, the sign extension must have happened. */ case BYTE: v = (char) v; break; case SHORT: case BESHORT: case LESHORT: v = (short) v; break; case DATE: case BEDATE: case LEDATE: case LONG: case BELONG: case LELONG: v = (long) v; break; case STRING: break; default: err = newSVpvf( "fmm_signextend: can't happen: m->type=%d\n", m->type); FMM_SET_ERROR(state, err); return -1; } return v; } static void fmm_append_mime(PerlFMM *state, char **buf, union VALUETYPE *p, fmmagic *m) { char *pp; unsigned long v; char *time_str; SV *err; #ifdef FMM_DEBUG PerlIO_printf(PerlIO_stderr(), "fmm_append_mime: buf = %s\n", buf); #endif switch (m->type) { case BYTE: v = p->b; break; case SHORT: case BESHORT: case LESHORT: v = p->h; break; case STRING: if (m->reln == '=') { fmm_append_buf(state, buf, m->desc, m->value.s ); } else { fmm_append_buf(state, buf, m->desc, p->s); } return; case DATE: case BEDATE: case LEDATE: Newz(1234, time_str, CTIME_LEN, char); strftime(time_str, CTIME_LEN, CTIME_FMT, localtime((const time_t *) &p->l)); pp = time_str; fmm_append_buf(state, buf, m->desc, pp); Safefree(time_str); return; default: err = newSVpvf( "fmm_append_mime: invalud m->type (%d) in fmm_append_mime().\n", m->type); FMM_SET_ERROR(state, err); return; } v = fmm_signextend(state, m, v) & m->mask; fmm_append_buf(state, buf, m->desc, (unsigned long) v); } static int fmm_mcheck(PerlFMM *state, union VALUETYPE *p, fmmagic *m) { register unsigned long l = m->value.l; register unsigned long v; register unsigned char *a; register unsigned char *b; register int len; int matched; SV *err; if ((m->value.s[0] == 'x') && (m->value.s[1] == '\0')) { /* XXX - WTF does this mean?? */ PerlIO_printf(PerlIO_stderr(), "fmm_mcheck: BOINK\n"); return 1; } switch (m->type) { case BYTE: v = p->b; break; case SHORT: case BESHORT: case LESHORT: v = p->h; break; case LONG: case BELONG: case LELONG: case DATE: case BEDATE: case LEDATE: v = p->l; break; case STRING: l = 0; /* What we want here is: v = strncmp(m->value.s, p->s, m->vallen) * but ignoring any nulls. bcmp doesn't give -/+/0 and isn't * universally available anyway */ v = 0; { a = (unsigned char *) m->value.s; b = (unsigned char *) p->s; len = m->vallen; while (--len >= 0) { if ((v = *b++ - *a++) != 0) { break; } } } break; default: /* bogosity, pretend that it just wan't a match*/ err = newSVpvf( "fmm_mcheck: invalid type %d in mcheck().\n", m->type); FMM_SET_ERROR(state, err); return 0; } v = fmm_signextend(state, m, v) & m->mask; switch (m->reln) { case 'x': matched = 1; break; case '!': matched = v != l; break; case '=': matched = v == l; break; case '>': if (m->flag & UNSIGNED) { matched = v > l; } else { matched = (long) v > (long) l; } break; case '<': if (m->flag & UNSIGNED) { matched = v < l; } else { matched = (long) v < (long) l; } break; case '&': matched = (v & l) == l; break; case '^': matched = (v & l) != l; break; default: /* bogosity, pretend it didn't match */ matched = 0; err = newSVpvf( "fmm_mcheck: Can't happen: invalid relation %d.\n", m->reln); FMM_SET_ERROR(state, err); } return matched; } /* Single hex char to int; -1 if not a hex char. */ static int fmm_hextoint(int c) { if (isDIGIT(c)) return c - '0'; if ((c >= 'a') && (c <= 'f')) return c + 10 - 'a'; if ((c >= 'A') && (c <= 'F')) return c + 10 - 'A'; return -1; } /* * Convert a string containing C character escapes. Stop at an unescaped * space or tab. Copy the converted version to "p", returning its length in * *slen. Return updated scan pointer as function result. */ static char * fmm_getstr(PerlFMM *state, register char *s, register char *p, int plen, int *slen) { char *origs = s, *origp = p; char *pmax = p + plen - 1; register int c; register int val; SV *err; while ((c = *s++) != '\0') { if (isSPACE(c)) break; if (p >= pmax) { err = newSVpvf( "fmm_getstr: string too long: %s", origs); FMM_SET_ERROR(state, err); break; } if (c == '\\') { switch (c = *s++) { case '\0': goto out; default: *p++ = (char) c; break; case 'n': *p++ = '\n'; break; case 'r': *p++ = '\r'; break; case 'b': *p++ = '\b'; break; case 't': *p++ = '\t'; break; case 'f': *p++ = '\f'; break; case 'v': *p++ = '\v'; break; /* \ and up to 3 octal digits */ case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': val = c - '0'; c = *s++; /* try for 2 */ if (c >= '0' && c <= '7') { val = (val << 3) | (c - '0'); c = *s++; /* try for 3 */ if (c >= '0' && c <= '7') val = (val << 3) | (c - '0'); else --s; } else --s; *p++ = (char) val; break; /* \x and up to 3 hex digits */ case 'x': val = 'x'; /* Default if no digits */ c = fmm_hextoint(*s++); /* Get next char */ if (c >= 0) { val = c; c = fmm_hextoint(*s++); if (c >= 0) { val = (val << 4) + c; c = fmm_hextoint(*s++); if (c >= 0) { val = (val << 4) + c; } else --s; } else --s; } else --s; *p++ = (char) val; break; } } else *p++ = (char) c; } out: *p = '\0'; *slen = p - origp; return s; } /* * Read a numeric value from a pointer, into the value union of a magic * pointer, according to the magic type. Update the string pointer to point * just after the number read. Return 0 for success, non-zero for failure. */ static int fmm_getvalue(PerlFMM *state, fmmagic *m, char **p) { int slen; if (m->type == STRING) { *p = fmm_getstr(state, *p, m->value.s, sizeof(m->value.s), &slen); m->vallen = slen; } else if (m->reln != 'x') m->value.l = fmm_signextend(state, m, strtol(*p, p, 0)); return 0; } /* maps to mod_mime_magic::parse */ static int fmm_parse_magic_line(PerlFMM *state, char *l, int lineno) { char *t; char *s; fmmagic *m; SV *err; Newz(1234, m, 1, fmmagic); m->next = NULL; m->flag = 0; m->cont_level = 0; m->lineno = lineno; if (! state->magic || !state->last) { state->magic = state->last = m; } else { state->last->next = m; state->last = m; } while (*l == '>') { l++; /* step over */ m->cont_level++; } if (m->cont_level != 0 && *l == '(') { l++; /* step over */ m->flag |= INDIR; } /* get offset, then skip over it */ m->offset = (int) strtol(l, &t, 0); if (l == t) { err = newSVpvf("Invalid offset in mime magic file, line %d: %s", lineno, l); goto error; } l = t; if (m->flag & INDIR) { m->in.type = LONG; m->in.offset = 0; /* read [.lbs][+=]nnnnn) */ if (*l == '.') { switch (*++l) { case 'l': m->in.type = LONG; break; case 's': m->in.type = SHORT; break; case 'b': m->in.type = BYTE; break; default: err = newSVpvf( "Invalid indirect offset type in mime magic file, line %d: %c", lineno, *l); goto error; } l++; } s = l; if (*l == '+' || *l == '-') { l++; } if (isdigit((unsigned char) *l)) { m->in.offset = strtol(l, &t, 0); if (*s == '-') { m->in.offset = -(m->in.offset); } } else { t = l; } if (*t++ != ')') { err = newSVpvf( "Missing ')' in indirect offset in mime magic file, line %d", lineno); goto error; } l = t; } while (isdigit((unsigned char) *l)) { ++l; } EATAB(l); #define NBYTE 4 #define NSHORT 5 #define NLONG 4 #define NSTRING 6 #define NDATE 4 #define NBESHORT 7 #define NBELONG 6 #define NBEDATE 6 #define NLESHORT 7 #define NLELONG 6 #define NLEDATE 6 if (*l == 'u') { ++l; m->flag |= UNSIGNED; } /* get type, skip it */ if (strncmp(l, "byte", NBYTE) == 0) { m->type = BYTE; l += NBYTE; } else if (strncmp(l, "short", NSHORT) == 0) { m->type = SHORT; l += NSHORT; } else if (strncmp(l, "long", NLONG) == 0) { m->type = LONG; l += NLONG; } else if (strncmp(l, "string", NSTRING) == 0) { m->type = STRING; l += NSTRING; } else if (strncmp(l, "date", NDATE) == 0) { m->type = DATE; l += NDATE; } else if (strncmp(l, "beshort", NBESHORT) == 0) { m->type = BESHORT; l += NBESHORT; } else if (strncmp(l, "belong", NBELONG) == 0) { m->type = BELONG; l += NBELONG; } else if (strncmp(l, "bedate", NBEDATE) == 0) { m->type = BEDATE; l += NBEDATE; } else if (strncmp(l, "leshort", NLESHORT) == 0) { m->type = LESHORT; l += NLESHORT; } else if (strncmp(l, "lelong", NLELONG) == 0) { m->type = LELONG; l += NLELONG; } else if (strncmp(l, "ledate", NLEDATE) == 0) { m->type = LEDATE; l += NLEDATE; } else { err = newSVpvf("Invalid type in mime magic file, line %d: %s", lineno, l); goto error; } /* New-style anding: "0 byte&0x80 =0x80 dynamically linked" */ if (*l == '&') { ++l; m->mask = fmm_signextend(state, m, strtol(l, &l, 0)); } else { m->mask = ~0L; } EATAB(l); switch (*l) { case '>': case '<': /* Old-style anding: "0 byte &0x80 dynamically linked" */ case '&': case '^': case '=': m->reln = *l; ++l; break; case '!': if (m->type != STRING) { m->reln = *l; ++l; break; } /* FALL THROUGH */ default: if (*l == 'x' && isSPACE(l[1])) { m->reln = *l; ++l; goto GetDesc; /* Bill The Cat */ } m->reln = '='; break; } EATAB(l); if (fmm_getvalue(state, m, &l)) return -1; /* * now get last part - the description */ GetDesc: EATAB(l); if (l[0] == '\b') { ++l; m->nospflag = 1; } else if ((l[0] == '\\') && (l[1] == 'b')) { ++l; ++l; m->nospflag = 1; } else { m->nospflag = 0; } strncpy(m->desc, l, sizeof(m->desc) - 1); m->desc[sizeof(m->desc) - 1] = '\0'; return 0; error: FMM_SET_ERROR(state, err); croak(SvPV_nolen(err)); } /* maps to mod_mime_magic::apprentice */ static int fmm_parse_magic_file(PerlFMM *state, char *file) { int ws_offset; int lineno; int errs; /* char line[BUFSIZ + 1];*/ PerlIO *fhandle; SV *err; SV *sv = sv_2mortal(newSV(BUFSIZ)); SV *PL_rs_orig = newSVsv(PL_rs); char *line; fhandle = PerlIO_open(file, "r"); if (! fhandle) { err = newSVpvf( "Failed to open %s: %s", file, strerror(errno)); FMM_SET_ERROR(state, err); PerlIO_close(fhandle); return -1; } /* * Parse it line by line * $/ (slurp mode) is needed here */ PL_rs = sv_2mortal(newSVpvn("\n", 1)); for(lineno = 1; sv_gets(sv, fhandle, 0) != NULL; lineno++) { line = SvPV_nolen(sv); /* delete newline */ if (line[0]) { line[strlen(line) - 1] = '\0'; } /* skip leading whitespace */ ws_offset = 0; while (line[ws_offset] && isSPACE(line[ws_offset])) { ws_offset++; } /* skip blank lines */ if (line[ws_offset] == 0) { continue; } if (line[ws_offset] == '#') { continue; } if (fmm_parse_magic_line(state, line, lineno) != 0) { ++errs; } } PerlIO_close(fhandle); PL_rs = PL_rs_orig; return 1; } /* fmm_fsmagic * * Checks the file's attribute by checking stat() and populates the * mime_type variable with a mime type. If no appropriate mime type is * found then returns -1 on error, 1 if undetermined because we * saw that it's a regular file which needs further processing to * determine its file type */ #define DIR_MAGIC_TYPE "x-system/x-unix; directory" #define FIFO_MAGIC_TYPE "x-system/x-unix; named pipe" #define SOCKET_MAGIC_TYPE "x-system/x-unix; socket" #define BLOCK_MAGIC_TYPE "x-system/x-unix; block special file" #define CHAR_MAGIC_TYPE "x-system/x-unix; character special file" #define EMPTY_MAGIC_TYPE "x-system/x-unix; empty" #define BROKEN_SYMLINK_MAGIC_TYPE "x-system/x-unix; broken symlink" static int fmm_fsmagic_stat(PerlFMM *state, struct stat *sb, char **mime_type) { SV *err; if (sb->st_mode & S_IFREG) { /* Regular file. Need to check for emptiness */ if (sb->st_size == 0) { strcpy(*mime_type, EMPTY_MAGIC_TYPE); return 0; } return 1; } /* it's not a regular file, so check other possibilities... */ if (sb->st_mode & S_IFIFO) { strcpy(*mime_type, FIFO_MAGIC_TYPE); } else if (sb->st_mode & S_IFCHR) { strcpy(*mime_type, CHAR_MAGIC_TYPE); } else if (sb->st_mode & S_IFDIR) { strcpy(*mime_type, DIR_MAGIC_TYPE); } else if (sb->st_mode & S_IFBLK) { strcpy(*mime_type, BLOCK_MAGIC_TYPE); } else if (sb->st_mode & S_IFLNK) { /* According to mod_mime_magic.c, the only reason stat() will return * a S_IFLNK in st_mode is that the symlink is broken */ strcpy(*mime_type, BROKEN_SYMLINK_MAGIC_TYPE); } else if (sb->st_mode & S_IFSOCK) { strcpy(*mime_type, SOCKET_MAGIC_TYPE); } else { /* Unknown type? */ err = newSVpv("fmm_fsmagic: invalid file type", 0); FMM_SET_ERROR(state, err); return -1; } return 0; } static int fmm_fsmagic(PerlFMM *state, char *filename, char **mime_type) { struct stat sb; SV *err; if (stat(filename, &sb) == -1) { err = newSVpvf( "Failed to stat file %s: %s", filename, strerror(errno)); FMM_SET_ERROR(state, err); return -1; } if (fmm_fsmagic_stat(state, &sb, mime_type) == 0) { return 0; } return 1; } static int fmm_ascmagic(unsigned char *buf, size_t nbytes, char **mime_type) { int has_escapes = 0; unsigned char *s; char nbuf[HOWMANY + 1]; /* one extra for terminating '\0' */ char *token; register struct names *p; int small_nbytes; char *strtok_state; unsigned char *tp; /* these are easy, do them first */ /* * for troff, look for . + letter + letter or .\"; this must be done to * disambiguate tar archives' ./file and other trash from real troff * input. */ if (*buf == '.') { tp = buf + 1; while (isSPACE(*tp)) ++tp; /* skip leading whitespace */ if ((isALNUM(*tp) || *tp == '\\') && (isALNUM(*(tp + 1)) || *tp == '"')) { strcpy(*mime_type, "application/x-troff"); return 0; } } if ((*buf == 'c' || *buf == 'C') && isSPACE(*(buf + 1))) { /* Fortran */ strcpy(*mime_type, "text/plain"); return 0; } /* look for tokens from names.h - this is expensive!, so we'll limit * ourselves to only SMALL_HOWMANY bytes */ small_nbytes = (nbytes > SMALL_HOWMANY) ? SMALL_HOWMANY : nbytes; /* make a copy of the buffer here because strtok() will destroy it */ s = (unsigned char *) memcpy(nbuf, buf, small_nbytes); s[small_nbytes] = '\0'; has_escapes = (memchr(s, '\033', small_nbytes) != NULL); while ((token = strtok_r((char *) s, " \t\n\r\f", &strtok_state)) != NULL) { s = NULL; /* make strtok() keep on tokin' */ for (p = names; p < names + NNAMES; p++) { if (strEQ(p->name, token)) { strcpy(*mime_type, types[p->type]); if (has_escapes) strcat(*mime_type, " (with escape sequences)"); return 0; } } } int is_tarball = is_tar(buf, nbytes); if ( is_tarball == 1 || is_tarball == 2 ) { /* 1: V7 tar archive */ /* 2: POSIX tar archive */ strcpy(*mime_type, "application/x-tar"); return 0; } /* all else fails, but it is ascii... */ strcpy(*mime_type, "text/plain"); return 0; } static int fmm_softmagic(PerlFMM *state, unsigned char **buf, int size, char **mime_type) { int cont_level = 0; int need_separator = 0; union VALUETYPE p; fmmagic *m_cont; fmmagic *m = state->magic; for (; m; m = m->next) { /* check if main entry matches */ if (! fmm_mget(state, &p, *buf, m, size) || !fmm_mcheck(state, &p, m)) { /* main entry didn't match, flush its continuations */ if (! m->next || (m->next->cont_level == 0)) { continue; } m_cont = m->next; while (m_cont && (m_cont->cont_level != 0)) { /* this trick allows us to keep *m in sync when the continue * advances the pointer */ m = m_cont; m_cont = m_cont->next; } continue; } /* if we get here, the main entry rule was a match */ /* this will be the last run through the loop */ /* print the match */ fmm_append_mime(state, mime_type, &p, m); /* if we printed something, we'll need to print a blank before * we print something else */ if (m->desc[0]) need_separator = 1; /* and any continuations that match */ cont_level++; m = m->next; while (m && (m->cont_level != 0)) { if (cont_level >= m->cont_level) { if (cont_level > m->cont_level) { /* We're at the end of the level "cont_level" * continuations. */ cont_level = m->cont_level; } if (fmm_mget(state, &p, *buf, m, size) && fmm_mcheck(state, &p, m)) { /* This continuation matched. Print its message, with a * blank before it if the previous item printed and this * isn't empty. */ /* space if previous printed */ if (need_separator && (m->nospflag == 0) && (m->desc[0] != '\0')) { /* putchar ' ' */ fmm_append_buf(state, mime_type, " "); need_separator = 0; } fmm_append_mime(state, mime_type, &p, m); if (m->desc[0]) need_separator = 1; /* If we see any continuations at a higher level, * process them. */ cont_level++; } } /* move to next continuation record */ m = m->next; } return 0; } return 1; } /* Perform mime magic on a PerlIO handle */ /* Perform mime magic on a buffer */ static int fmm_bufmagic(PerlFMM *state, unsigned char **buffer, char **mime_type) { if (fmm_softmagic(state, buffer, HOWMANY, mime_type) == 0) { #ifdef FMM_DEBUG PerlIO_printf(PerlIO_stderr(), "[fmm_bufmagic]: fmm_softmagic returns 0\n"); #endif return 0; } if (fmm_ascmagic(*buffer, HOWMANY, mime_type) == 0) { #ifdef FMM_DEBUG PerlIO_printf(PerlIO_stderr(), "[fmm_bufmagic]: fmm_ascmagic returns 0\n"); #endif return 0; } return 1; } static int fmm_fhmagic(PerlFMM *state, PerlIO *fhandle, char **mime_type) { SV *err; unsigned char *data; int ret = -1; Newz(1234, data, HOWMANY + 1, unsigned char); if (! PerlIO_read(fhandle, data, HOWMANY)) { err = newSVpvf( "Failed to read from handle: %s", strerror(errno) ); FMM_SET_ERROR(state, err); Safefree(data); return -1; } ret = fmm_bufmagic(state, &data, mime_type); Safefree(data); return ret; } static int fmm_ext_magic(PerlFMM *state, char *file, char **mime_type) { char ext[BUFSIZ]; char *temp_mimetype; /* Look for the last dot */ char *dot = rindex(file, '.'); if (dot == 0x00) { return 0; } strncpy(ext, dot + 1, BUFSIZ); if (st_lookup(state->ext, (st_data_t) ext, (st_data_t *) &temp_mimetype) == 0) { return 1; } strncpy(*mime_type, temp_mimetype, MAXMIMESTRING); return 0; } static int fmm_mime_magic(PerlFMM *state, char *file, char **mime_type) { PerlIO *fhandle; SV *err; int ret; if ((ret = fmm_fsmagic(state, file, mime_type)) == 0) { return 0; } if (ret == -1) { return -1; } fhandle = PerlIO_open(file, "r"); if (!fhandle) { err = newSVpvf( "Failed to open file %s: %s", file, strerror(errno)); FMM_SET_ERROR(state, err); return -1; } if ((ret = fmm_fhmagic(state, fhandle, mime_type)) == 0) { #ifdef FMM_DEBUG PerlIO_printf(PerlIO_stderr(), "[fmm_mime_magic]: fmm_fhmagic returns 0\n"); #endif PerlIO_close(fhandle); return 0; } PerlIO_close(fhandle); return fmm_ext_magic(state, file, mime_type); } PerlFMM* PerlFMM_create(SV *class_sv) { PerlFMM *state; PERL_UNUSED_VAR(class_sv); Newz(1234, state, 1, PerlFMM); state->magic = NULL; state->error = NULL; state->ext = st_init_strtable(); return state; } PerlFMM * PerlFMM_clone(PerlFMM *self) { PerlFMM *state; fmmagic *d, *s; state = PerlFMM_create(NULL); st_free_table(state->ext); state->ext = st_copy( self->ext ); s = self->magic; Newxz(d, 1, fmmagic); memcpy(d, s, sizeof(fmmagic)); state->magic = d; while (s->next != NULL) { Newxz(d->next, 1, fmmagic); memcpy(d->next, s->next, sizeof(struct _fmmagic)); d = d->next; s = s->next; } state->last = d; state->last->next = NULL; return state; } SV * PerlFMM_parse_magic_file(PerlFMM *self, char *file) { FMM_SET_ERROR(self, NULL); return fmm_parse_magic_file(self, file) ? &PL_sv_yes : &PL_sv_undef; } SV * PerlFMM_add_magic(PerlFMM *self, char *magic) { return fmm_parse_magic_line(self, magic, 0) == 0 ? &PL_sv_yes : &PL_sv_undef ; } SV * PerlFMM_add_file_ext(PerlFMM *self, char *ext, char *mime) { char *dummy; SV *ret; if (st_lookup(self->ext, (st_data_t) ext, (st_data_t *) &dummy)) { ret = &PL_sv_no; } else { st_insert(self->ext, (st_data_t) ext, (st_data_t) mime); ret = &PL_sv_yes; } return ret; } SV * PerlFMM_fhmagic(PerlFMM *self, SV *svio) { PerlIO *io; char *type; int rc; SV *ret; if (! SvROK(svio)) croak("Usage: self->fhmagic(*handle))"); io = IoIFP(sv_2io(SvRV(svio))); if (! io) croak("Not a handle"); FMM_SET_ERROR(self, NULL); Newz(1234, type, BUFSIZ, char); rc = fmm_fhmagic(self, io, &type); ret = FMM_RESULT(type, rc); Safefree(type); return ret; } SV * PerlFMM_fsmagic(PerlFMM *self, char *filename) { char *type; int rc; SV *ret; FMM_SET_ERROR(self, NULL); Newz(1234, type, BUFSIZ, char); rc = fmm_fsmagic(self, filename, &type); ret = FMM_RESULT(type, rc); Safefree(type); return ret; } SV * PerlFMM_bufmagic(PerlFMM *self, SV *buf) { unsigned char *buffer; char *type; int rc; SV *ret; /* rt #28040, allow RV to SVs to be passed here */ if (SvROK(buf) && SvTYPE(SvRV(buf)) == SVt_PV) { buffer = (unsigned char *) SvPV_nolen( SvRV( buf ) ); } else { buffer = (unsigned char *) SvPV_nolen(buf); } FMM_SET_ERROR(self, NULL); Newz(1234, type, BUFSIZ, char); rc = fmm_bufmagic(self, &buffer, &type); ret = FMM_RESULT(type, rc); Safefree(type); return ret; } SV * PerlFMM_ascmagic(PerlFMM *self, unsigned char *data) { char *type; int rc; SV *ret; Newz(1234, type, BUFSIZ, char); FMM_SET_ERROR(self, NULL); rc = fmm_ascmagic(data, strlen(data), &type); ret = FMM_RESULT(type, rc); Safefree(type); return ret; } SV * PerlFMM_get_mime(PerlFMM *self, char *filename) { char *type; int rc; SV *ret; Newz(1234, type, MAXMIMESTRING, char); FMM_SET_ERROR(self, NULL); rc = fmm_mime_magic(self, filename, &type); ret = FMM_RESULT(type, rc); Safefree(type); return ret; } #endif �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������File-MMagic-XS-0.09008/src/perl-mmagic-xs.h���������������������������������������������������������000644 �000766 �000024 �00000006036 12321356423 020104� 0����������������������������������������������������������������������������������������������������ustar�00JP11194�������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������#ifndef __PERL_MMAGIC_XS_H__ #define __PERL_MMAGIC_XS_H__ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #define NEED_newRV_noinc #define NEED_sv_2pv_nolen #include "ppport.h" #include <sys/types.h> #include <sys/stat.h> #include <string.h> #include "MMagicST.h" #define XS_STATE(type, x) \ INT2PTR(type, SvROK(x) ? SvIV(SvRV(x)) : SvIV(x)) #define EATAB(x) \ {while (isSPACE(*x)) ++x;} #define MAXDESC 50 /* max leng of text description */ #define MAXstring 64 /* max leng of "string" types */ /* HOWMANY must be at least 4096 to make gzip -dcq work */ #define HOWMANY 4096 /* SMALL_HOWMANY limits how much work we do to figure out text files */ #define SMALL_HOWMANY 1024 #define MAXMIMESTRING 256 typedef struct _fmmagic { struct _fmmagic *next; /* link to next entry */ int lineno; /* line number from magic file */ short flag; #define INDIR 1 /* if '>(...)' appears, */ #define UNSIGNED 2 /* comparison is unsigned */ short cont_level; /* level of ">" */ struct { char type; /* byte short long */ long offset; /* offset from indirection */ } in; long offset; /* offset to magic number */ unsigned char reln; /* relation (0=eq, '>'=gt, etc) */ char type; /* int, short, long or string. */ char vallen; /* length of string value, if any */ #define BYTE 1 #define SHORT 2 #define LONG 4 #define STRING 5 #define DATE 6 #define BESHORT 7 #define BELONG 8 #define BEDATE 9 #define LESHORT 10 #define LELONG 11 #define LEDATE 12 union VALUETYPE { unsigned char b; unsigned short h; unsigned long l; char s[MAXstring]; unsigned char hs[2]; /* 2 bytes of a fixed-endian "short" */ unsigned char hl[4]; /* 2 bytes of a fixed-endian "long" */ } value; /* either number or string */ unsigned long mask; /* mask before comparison with value */ char nospflag; /* supress space character */ /* NOTE: this string is suspected of overrunning - find it! */ char desc[MAXDESC]; /* description */ } fmmagic; typedef struct _PerlFMM { fmmagic *magic; fmmagic *last; SV *error; st_table *ext; } PerlFMM; #define FMM_OK(x) \ (x != NULL) #define FMM_SET_ERROR(s, e) \ if (e && s->error) { \ Safefree(s->error); \ } \ s->error = e; #define FMM_RESULT(type, rc) \ (rc == 0 ? \ newSVpv(type, strlen(type)) : \ &PL_sv_undef ) PerlFMM* PerlFMM_create(SV *class_sv); PerlFMM* PerlFMM_clone(PerlFMM *self); void PerlFMM_destroy(PerlFMM *state); SV* PerlFMM_parse_magic_file(PerlFMM *self, char *file); SV* PerlFMM_fhmagic(PerlFMM *self, SV *svio); SV* PerlFMM_fsmagic(PerlFMM *self, char *filename); SV* PerlFMM_bufmagic(PerlFMM *self, SV *buf); SV* PerlFMM_ascmagic(PerlFMM *self, unsigned char *data); SV* PerlFMM_get_mime(PerlFMM *self, char *filename); SV* PerlFMM_add_magic(PerlFMM *self, char *magic); SV* PerlFMM_add_file_ext(PerlFMM *self, char *ext, char *mime); #endif ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������File-MMagic-XS-0.09008/src/typemap������������������������������������������������������������������000644 �000766 �000024 �00000002613 12321356423 016505� 0����������������������������������������������������������������������������������������������������ustar�00JP11194�������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������TYPEMAP PerlFMM* T_FMMXS INPUT T_FMMXS { MAGIC *mg; mg = PerlFMM_mg_find(aTHX_ SvRV($arg), &PerlFMM_vtbl); if (mg) { $var = (PerlFMM *) mg->mg_ptr; } } OUTPUT T_FMMXS if (!$var) /* if null */ SvOK_off($arg); /* then return as undef instead of reaf to undef */ else { /* setup $arg as a ref to a blessed hash hv */ MAGIC *mg; HV *hv = newHV(); const char *classname = \"File::MMagic::XS\"; /* take (sub)class name to use from class_sv if appropriate */ if (SvMAGICAL(class_sv)) mg_get(class_sv); if (SvOK( class_sv ) && sv_derived_from(class_sv, classname ) ) { if(SvROK(class_sv) && SvOBJECT(SvRV(class_sv))) { classname = sv_reftype(SvRV(class_sv), TRUE); } else { classname = SvPV_nolen(class_sv); } } sv_setsv($arg, sv_2mortal(newRV_noinc((SV*)hv))); (void)sv_bless($arg, gv_stashpv(classname, TRUE)); /* now attach $var to the HV */ /* done as two steps to avoid sv_magic SvREFCNT_inc and MGf_REFCOUNTED */ mg = sv_magicext((SV*)hv, NULL, PERL_MAGIC_ext, &PerlFMM_vtbl, (char*) $var, 0); /* sizeof($var)); */ mg->mg_flags |= MGf_DUP; } ���������������������������������������������������������������������������������������������������������������������File-MMagic-XS-0.09008/lib/File/��������������������������������������������������������������������000755 �000766 �000024 �00000000000 12321412047 015732� 5����������������������������������������������������������������������������������������������������ustar�00JP11194�������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������File-MMagic-XS-0.09008/lib/File/MMagic/�������������������������������������������������������������000755 �000766 �000024 �00000000000 12321412047 017067� 5����������������������������������������������������������������������������������������������������ustar�00JP11194�������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������File-MMagic-XS-0.09008/lib/File/MMagic/magic��������������������������������������������������������000644 �000766 �000024 �00000074552 12321411516 020107� 0����������������������������������������������������������������������������������������������������ustar�00JP11194�������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Magic data for mod_mime_magic (originally for file(1) command) # # 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. # Real Audio (Magic .ra\0375) 0 belong 0x2e7261fd audio/x-pn-realaudio 0 string .RMF application/vnd.rn-realmedia #video/x-pn-realvideo #video/vnd.rn-realvideo #application/vnd.rn-realmedia # sigh, there are many mimes for that but the above are the most common. # Taken from magic, converted to magic.mime # mime types according to http://www.geocities.com/nevilo/mod.htm: # audio/it .it # audio/x-zipped-it .itz # audio/xm fasttracker modules # audio/x-s3m screamtracker modules # audio/s3m screamtracker modules # audio/x-zipped-mod mdz # audio/mod mod # audio/x-mod All modules (mod, s3m, 669, mtm, med, xm, it, mdz, stm, itz, xmz, s3z) # Taken from loader code from mikmod version 2.14 # by Steve McIntyre (stevem@chiark.greenend.org.uk) # <doj@cubic.org> added title printing on 2003-06-24 0 string MAS_UTrack_V00 >14 string >/0 audio/x-mod #audio/x-tracker-module #0 string UN05 MikMod UNI format module sound data 0 string Extended\ Module: audio/x-mod #audio/x-tracker-module ##>17 string >\0 Title: "%s" 21 string/c \!SCREAM! audio/x-mod #audio/x-screamtracker-module 21 string BMOD2STM audio/x-mod #audio/x-screamtracker-module 1080 string M.K. audio/x-mod #audio/x-protracker-module #>0 string >\0 Title: "%s" 1080 string M!K! audio/x-mod #audio/x-protracker-module #>0 string >\0 Title: "%s" 1080 string FLT4 audio/x-mod #audio/x-startracker-module #>0 string >\0 Title: "%s" 1080 string FLT8 audio/x-mod #audio/x-startracker-module #>0 string >\0 Title: "%s" 1080 string 4CHN audio/x-mod #audio/x-fasttracker-module #>0 string >\0 Title: "%s" 1080 string 6CHN audio/x-mod #audio/x-fasttracker-module #>0 string >\0 Title: "%s" 1080 string 8CHN audio/x-mod #audio/x-fasttracker-module #>0 string >\0 Title: "%s" 1080 string CD81 audio/x-mod #audio/x-oktalyzer-tracker-module #>0 string >\0 Title: "%s" 1080 string OKTA audio/x-mod #audio/x-oktalyzer-tracker-module #>0 string >\0 Title: "%s" # Not good enough. #1082 string CH #>1080 string >/0 %.2s-channel Fasttracker "oktalyzer" module sound data 1080 string 16CN audio/x-mod #audio/x-taketracker-module #>0 string >\0 Title: "%s" 1080 string 32CN audio/x-mod #audio/x-taketracker-module #>0 string >\0 Title: "%s" # Impuse tracker module (it) 0 string IMPM audio/x-mod #>4 string >\0 "%s" #>40 leshort !0 compatible w/ITv%x #>42 leshort !0 created w/ITv%x #------------------------------------------------------------------------------ # end local stuff #------------------------------------------------------------------------------ # xml based formats! # svg #0 string \<?xml # text/xml >38 string \<\!DOCTYPE\040svg image/svg+xml # xml 0 string \<?xml text/xml #------------------------------------------------------------------------------ # Java 0 short 0xcafe >2 short 0xbabe application/java #------------------------------------------------------------------------------ # audio: file(1) magic for sound formats # # from Jan Nicolai Langfeldt <janl@ifi.uio.no>, # # Sun/NeXT audio data 0 string .snd >12 belong 1 audio/basic >12 belong 2 audio/basic >12 belong 3 audio/basic >12 belong 4 audio/basic >12 belong 5 audio/basic >12 belong 6 audio/basic >12 belong 7 audio/basic >12 belong 23 audio/x-adpcm # DEC systems (e.g. DECstation 5000) use a variant of the Sun/NeXT format # that uses little-endian encoding and has a different magic number # (0x0064732E in little-endian encoding). 0 lelong 0x0064732E >12 lelong 1 audio/x-dec-basic >12 lelong 2 audio/x-dec-basic >12 lelong 3 audio/x-dec-basic >12 lelong 4 audio/x-dec-basic >12 lelong 5 audio/x-dec-basic >12 lelong 6 audio/x-dec-basic >12 lelong 7 audio/x-dec-basic # compressed (G.721 ADPCM) >12 lelong 23 audio/x-dec-adpcm # Bytes 0-3 of AIFF, AIFF-C, & 8SVX audio files are "FORM" # AIFF audio data 8 string AIFF audio/x-aiff # AIFF-C audio data 8 string AIFC audio/x-aiff # IFF/8SVX audio data 8 string 8SVX audio/x-aiff # Creative Labs AUDIO stuff # Standard MIDI data 0 string MThd audio/unknown #>9 byte >0 (format %d) #>11 byte >1 using %d channels # Creative Music (CMF) data 0 string CTMF audio/unknown # SoundBlaster instrument data 0 string SBI audio/unknown # Creative Labs voice data 0 string Creative\ Voice\ File audio/unknown ## is this next line right? it came this way... #>19 byte 0x1A #>23 byte >0 - version %d #>22 byte >0 \b.%d # [GRR 950115: is this also Creative Labs? Guessing that first line # should be string instead of unknown-endian long...] #0 long 0x4e54524b MultiTrack sound data #0 string NTRK MultiTrack sound data #>4 long x - version %ld # Microsoft WAVE format (*.wav) # [GRR 950115: probably all of the shorts and longs should be leshort/lelong] # Microsoft RIFF 0 string RIFF # - WAVE format >8 string WAVE audio/x-wav >8 string/B AVI video/x-msvideo # >8 string CDRA image/x-coreldraw # AAC (aka MPEG-2 NBC) 0 beshort&0xfff6 0xfff0 audio/X-HX-AAC-ADTS 0 string ADIF audio/X-HX-AAC-ADIF 0 beshort&0xffe0 0x56e0 audio/MP4A-LATM 0 beshort 0x4De1 audio/MP4A-LATM # MPEG Layer 3 sound files 0 beshort&0xfffe =0xfffa audio/mpeg #MP3 with ID3 tag 0 string ID3 audio/mpeg # Ogg/Vorbis 0 string OggS application/ogg #------------------------------------------------------------------------------ # c-lang: file(1) magic for C programs or various scripts # # XPM icons (Greg Roelofs, newt@uchicago.edu) # ideally should go into "images", but entries below would tag XPM as C source 0 string /*\ XPM image/x-xpmi 7bit # 3DS (3d Studio files) #16 beshort 0x3d3d image/x-3ds # this first will upset you if you're a PL/1 shop... (are there any left?) # in which case rm it; ascmagic will catch real C programs # C or REXX program text #0 string /* text/x-c # C++ program text #0 string // text/x-c++ #------------------------------------------------------------------------------ # commands: file(1) magic for various shells and interpreters # #0 string :\ shell archive or commands for antique kernel text 0 string #!/bin/sh application/x-shellscript 0 string #!\ /bin/sh application/x-shellscript 0 string #!/bin/csh application/x-shellscript 0 string #!\ /bin/csh application/x-shellscript # korn shell magic, sent by George Wu, gwu@clyde.att.com 0 string #!/bin/ksh application/x-shellscript 0 string #!\ /bin/ksh application/x-shellscript 0 string #!/bin/tcsh application/x-shellscript 0 string #!\ /bin/tcsh application/x-shellscript 0 string #!/usr/local/tcsh application/x-shellscript 0 string #!\ /usr/local/tcsh application/x-shellscript 0 string #!/usr/local/bin/tcsh application/x-shellscript 0 string #!\ /usr/local/bin/tcsh application/x-shellscript # bash shell magic, from Peter Tobias (tobias@server.et-inf.fho-emden.de) 0 string #!/bin/bash application/x-shellscript 0 string #!\ /bin/bash application/x-shellscript 0 string #!/usr/local/bin/bash application/x-shellscript 0 string #!\ /usr/local/bin/bash application/x-shellscript # # zsh/ash/ae/nawk/gawk magic from cameron@cs.unsw.oz.au (Cameron Simpson) 0 string #!/bin/zsh application/x-shellscript 0 string #!/usr/bin/zsh application/x-shellscript 0 string #!/usr/local/bin/zsh application/x-shellscript 0 string #!\ /usr/local/bin/zsh application/x-shellscript 0 string #!/usr/local/bin/ash application/x-shellscript 0 string #!\ /usr/local/bin/ash application/x-shellscript #0 string #!/usr/local/bin/ae Neil Brown's ae #0 string #!\ /usr/local/bin/ae Neil Brown's ae 0 string #!/bin/nawk application/x-nawk 0 string #!\ /bin/nawk application/x-nawk 0 string #!/usr/bin/nawk application/x-nawk 0 string #!\ /usr/bin/nawk application/x-nawk 0 string #!/usr/local/bin/nawk application/x-nawk 0 string #!\ /usr/local/bin/nawk application/x-nawk 0 string #!/bin/gawk application/x-gawk 0 string #!\ /bin/gawk application/x-gawk 0 string #!/usr/bin/gawk application/x-gawk 0 string #!\ /usr/bin/gawk application/x-gawk 0 string #!/usr/local/bin/gawk application/x-gawk 0 string #!\ /usr/local/bin/gawk application/x-gawk # 0 string #!/bin/awk application/x-awk 0 string #!\ /bin/awk application/x-awk 0 string #!/usr/bin/awk application/x-awk 0 string #!\ /usr/bin/awk application/x-awk # update to distinguish from *.vcf files by Joerg Jenderek: joerg dot jenderek at web dot de #0 regex BEGIN[[:space:]]*[{] application/x-awk # For Larry Wall's perl language. The ``eval'' line recognizes an # outrageously clever hack for USG systems. # Keith Waclena <keith@cerberus.uchicago.edu> 0 string #!/bin/perl application/x-perl 0 string #!\ /bin/perl application/x-perl 0 string eval\ "exec\ /bin/perl application/x-perl 0 string #!/usr/bin/perl application/x-perl 0 string #!\ /usr/bin/perl application/x-perl 0 string eval\ "exec\ /usr/bin/perl application/x-perl 0 string #!/usr/local/bin/perl application/x-perl 0 string #!\ /usr/local/bin/perl application/x-perl 0 string eval\ "exec\ /usr/local/bin/perl application/x-perl #------------------------------------------------------------------------------ # compress: file(1) magic for pure-compression formats (no archives) # # compress, gzip, pack, compact, huf, squeeze, crunch, freeze, yabba, whap, etc. # # Formats for various forms of compressed data # Formats for "compress" proper have been moved into "compress.c", # because it tries to uncompress it to figure out what's inside. # standard unix compress #0 string \037\235 application/x-compress # gzip (GNU zip, not to be confused with [Info-ZIP/PKWARE] zip archiver) #0 string \037\213 application/x-gzip 0 string PK\003\004 application/x-zip # RAR archiver (Greg Roelofs, newt@uchicago.edu) 0 string Rar! application/x-rar # According to gzip.h, this is the correct byte order for packed data. 0 string \037\036 application/octet-stream # # This magic number is byte-order-independent. # 0 short 017437 application/octet-stream # XXX - why *two* entries for "compacted data", one of which is # byte-order independent, and one of which is byte-order dependent? # # compacted data 0 short 0x1fff application/octet-stream 0 string \377\037 application/octet-stream # huf output 0 short 0145405 application/octet-stream # Squeeze and Crunch... # These numbers were gleaned from the Unix versions of the programs to # handle these formats. Note that I can only uncrunch, not crunch, and # I didn't have a crunched file handy, so the crunch number is untested. # Keith Waclena <keith@cerberus.uchicago.edu> #0 leshort 0x76FF squeezed data (CP/M, DOS) #0 leshort 0x76FE crunched data (CP/M, DOS) # Freeze #0 string \037\237 Frozen file 2.1 #0 string \037\236 Frozen file 1.0 (or gzip 0.5) # lzh? #0 string \037\240 LZH compressed data 257 string ustar\0 application/x-tar posix 257 string ustar\040\040\0 application/x-tar gnu 0 short 070707 application/x-cpio 0 short 0143561 application/x-cpio swapped 0 string =<ar> application/x-archive 0 string \!<arch> application/x-archive >8 string debian application/x-debian-package #------------------------------------------------------------------------------ # # RPM: file(1) magic for Red Hat Packages Erik Troan (ewt@redhat.com) # 0 beshort 0xedab >2 beshort 0xeedb application/x-rpm 0 lelong&0x8080ffff 0x0000081a application/x-arc lzw 0 lelong&0x8080ffff 0x0000091a application/x-arc squashed 0 lelong&0x8080ffff 0x0000021a application/x-arc uncompressed 0 lelong&0x8080ffff 0x0000031a application/x-arc packed 0 lelong&0x8080ffff 0x0000041a application/x-arc squeezed 0 lelong&0x8080ffff 0x0000061a application/x-arc crunched 0 leshort 0xea60 application/x-arj # LHARC/LHA archiver (Greg Roelofs, newt@uchicago.edu) 2 string -lh0- application/x-lharc lh0 2 string -lh1- application/x-lharc lh1 2 string -lz4- application/x-lharc lz4 2 string -lz5- application/x-lharc lz5 # [never seen any but the last; -lh4- reported in comp.compression:] 2 string -lzs- application/x-lha lzs 2 string -lh\ - application/x-lha lh 2 string -lhd- application/x-lha lhd 2 string -lh2- application/x-lha lh2 2 string -lh3- application/x-lha lh3 2 string -lh4- application/x-lha lh4 2 string -lh5- application/x-lha lh5 2 string -lh6- application/x-lha lh6 2 string -lh7- application/x-lha lh7 # Shell archives 10 string #\ This\ is\ a\ shell\ archive application/octet-stream x-shell #------------------------------------------------------------------------------ # frame: file(1) magic for FrameMaker files # # This stuff came on a FrameMaker demo tape, most of which is # copyright, but this file is "published" as witness the following: # 0 string \<MakerFile application/x-frame 0 string \<MIFFile application/x-frame 0 string \<MakerDictionary application/x-frame 0 string \<MakerScreenFon application/x-frame 0 string \<MML application/x-frame 0 string \<Book application/x-frame 0 string \<Maker application/x-frame #------------------------------------------------------------------------------ # html: file(1) magic for HTML (HyperText Markup Language) docs # # from Daniel Quinlan <quinlan@yggdrasil.com> # 0 string/cB \<!DOCTYPE\ html text/html 0 string/cb \<head text/html 0 string/cb \<title text/html 0 string/bc \<html text/html 0 string \<!-- text/html 0 string/c \<h1 text/html 0 string \<?xml text/xml #------------------------------------------------------------------------------ # images: file(1) magic for image formats (see also "c-lang" for XPM bitmaps) # # originally from jef@helios.ee.lbl.gov (Jef Poskanzer), # additions by janl@ifi.uio.no as well as others. Jan also suggested # merging several one- and two-line files into here. # # XXX - byte order for GIF and TIFF fields? # [GRR: TIFF allows both byte orders; GIF is probably little-endian] # # [GRR: what the hell is this doing in here?] #0 string xbtoa btoa'd file # PBMPLUS # PBM file 0 string P1 image/x-portable-bitmap 7bit # PGM file 0 string P2 image/x-portable-greymap 7bit # PPM file 0 string P3 image/x-portable-pixmap 7bit # PBM "rawbits" file 0 string P4 image/x-portable-bitmap # PGM "rawbits" file 0 string P5 image/x-portable-greymap # PPM "rawbits" file 0 string P6 image/x-portable-pixmap # NIFF (Navy Interchange File Format, a modification of TIFF) # [GRR: this *must* go before TIFF] 0 string IIN1 image/x-niff # TIFF and friends # TIFF file, big-endian 0 string MM image/tiff # TIFF file, little-endian 0 string II image/tiff # possible GIF replacements; none yet released! # (Greg Roelofs, newt@uchicago.edu) # # GRR 950115: this was mine ("Zip GIF"): # ZIF image (GIF+deflate alpha) 0 string GIF94z image/unknown # # GRR 950115: this is Jeremy Wohl's Free Graphics Format (better): # FGF image (GIF+deflate beta) 0 string FGF95a image/unknown # # GRR 950115: this is Thomas Boutell's Portable Bitmap Format proposal # (best; not yet implemented): # PBF image (deflate compression) 0 string PBF image/unknown # GIF 0 string GIF image/gif # JPEG images 0 beshort 0xffd8 image/jpeg # PC bitmaps (OS/2, Windoze BMP files) (Greg Roelofs, newt@uchicago.edu) 0 string BM image/x-ms-bmp #>14 byte 12 (OS/2 1.x format) #>14 byte 64 (OS/2 2.x format) #>14 byte 40 (Windows 3.x format) #0 string IC icon #0 string PI pointer #0 string CI color icon #0 string CP color pointer #0 string BA bitmap array # CDROM Filesystems 32769 string CD001 application/x-iso9660 # Newer StuffIt archives (grant@netbsd.org) 0 string StuffIt application/x-stuffit #>162 string >0 : %s # BinHex is the Macintosh ASCII-encoded file format (see also "apple") # Daniel Quinlan, quinlan@yggdrasil.com 11 string must\ be\ converted\ with\ BinHex\ 4 application/mac-binhex40 ##>41 string x \b, version %.3s #------------------------------------------------------------------------------ # lisp: file(1) magic for lisp programs # # various lisp types, from Daniel Quinlan (quinlan@yggdrasil.com) 0 string ;; text/plain 8bit # Emacs 18 - this is always correct, but not very magical. 0 string \012( application/x-elc # Emacs 19 0 string ;ELC\023\000\000\000 application/x-elc #------------------------------------------------------------------------------ # mail.news: file(1) magic for mail and news # # There are tests to ascmagic.c to cope with mail and news. 0 string Relay-Version: message/rfc822 7bit 0 string #!\ rnews message/rfc822 7bit 0 string N#!\ rnews message/rfc822 7bit 0 string Forward\ to message/rfc822 7bit 0 string Pipe\ to message/rfc822 7bit 0 string Return-Path: message/rfc822 7bit 0 string Received: message/rfc822 0 string Path: message/news 8bit 0 string Xref: message/news 8bit 0 string From: message/rfc822 7bit 0 string Article message/news 8bit #------------------------------------------------------------------------------ # msword: file(1) magic for MS Word files # # Contributor claims: # Reversed-engineered MS Word magic numbers # 0 string \376\067\0\043 application/msword 0 string \320\317\021\340\241\261 application/msword 0 string \333\245-\0\0\0 application/msword #------------------------------------------------------------------------------ # printer: file(1) magic for printer-formatted files # # PostScript 0 string %! application/postscript 0 string \004%! application/postscript # Acrobat # (due to clamen@cs.cmu.edu) 0 string %PDF- application/pdf #------------------------------------------------------------------------------ # sc: file(1) magic for "sc" spreadsheet # 38 string Spreadsheet application/x-sc #------------------------------------------------------------------------------ # tex: file(1) magic for TeX files # # XXX - needs byte-endian stuff (big-endian and little-endian DVI?) # # From <conklin@talisman.kaleida.com> # Although we may know the offset of certain text fields in TeX DVI # and font files, we can't use them reliably because they are not # zero terminated. [but we do anyway, christos] 0 string \367\002 application/x-dvi #0 string \367\203 TeX generic font data #0 string \367\131 TeX packed font data #0 string \367\312 TeX virtual font data #0 string This\ is\ TeX, TeX transcript text #0 string This\ is\ METAFONT, METAFONT transcript text # There is no way to detect TeX Font Metric (*.tfm) files without # breaking them apart and reading the data. The following patterns # match most *.tfm files generated by METAFONT or afm2tfm. 2 string \000\021 application/x-tex-tfm 2 string \000\022 application/x-tex-tfm #>34 string >\0 (%s) # Texinfo and GNU Info, from Daniel Quinlan (quinlan@yggdrasil.com) 0 string \\input\ texinfo text/x-texinfo 0 string This\ is\ Info\ file text/x-info # correct TeX magic for Linux (and maybe more) # from Peter Tobias (tobias@server.et-inf.fho-emden.de) # 0 leshort 0x02f7 application/x-dvi # RTF - Rich Text Format 0 string {\\rtf application/rtf #------------------------------------------------------------------------------ # animation: file(1) magic for animation/movie formats # # animation formats, originally from vax@ccwf.cc.utexas.edu (VaX#n8) # MPEG file # MPEG sequences 0 belong 0x000001BA >4 byte &0x40 video/mp2p >4 byte ^0x40 video/mpeg 0 belong 0x000001BB video/mpeg 0 belong 0x000001B0 video/mp4v-es 0 belong 0x000001B5 video/mp4v-es 0 belong 0x000001B3 video/mpv 0 belong&0xFF5FFF1F 0x47400010 video/mp2t 0 belong 0x00000001 >4 byte&0x1F 0x07 video/h264 # FLI animation format 0 leshort 0xAF11 video/fli # FLC animation format 0 leshort 0xAF12 video/flc # # SGI and Apple formats # Added ISO mimes 0 string MOVI video/sgi 4 string moov video/quicktime 4 string mdat video/quicktime 4 string wide video/quicktime 4 string skip video/quicktime 4 string free video/quicktime 4 string idsc image/x-quicktime 4 string idat image/x-quicktime 4 string pckg application/x-quicktime 4 string/B jP image/jp2 4 string ftyp >8 string isom video/mp4 >8 string mp41 video/mp4 >8 string mp42 video/mp4 >8 string/B jp2 image/jp2 >8 string 3gp video/3gpp >8 string avc1 video/3gpp >8 string mmp4 video/mp4 >8 string/B M4A audio/mp4 >8 string/B qt video/quicktime # The contributor claims: # I couldn't find a real magic number for these, however, this # -appears- to work. Note that it might catch other files, too, # so BE CAREFUL! # # Note that title and author appear in the two 20-byte chunks # at decimal offsets 2 and 22, respectively, but they are XOR'ed with # 255 (hex FF)! DL format SUCKS BIG ROCKS. # # DL file version 1 , medium format (160x100, 4 images/screen) 0 byte 1 video/unknown 0 byte 2 video/unknown # # Databases # # GDBM magic numbers # Will be maintained as part of the GDBM distribution in the future. # <downsj@teeny.org> 0 belong 0x13579ace application/x-gdbm 0 lelong 0x13579ace application/x-gdbm 0 string GDBM application/x-gdbm # 0 belong 0x061561 application/x-dbm # # Executables # 0 string \177ELF >16 leshort 0 application/octet-stream >16 leshort 1 application/x-object >16 leshort 2 application/x-executable >16 leshort 3 application/x-sharedlib >16 leshort 4 application/x-coredump >16 beshort 0 application/octet-stream >16 beshort 1 application/x-object >16 beshort 2 application/x-executable >16 beshort 3 application/x-sharedlib >16 beshort 4 application/x-coredump # # DOS 0 string MZ application/x-dosexec # # KDE 0 string [KDE\ Desktop\ Entry] application/x-kdelnk 0 string \#\ KDE\ Config\ File application/x-kdelnk # xmcd database file for kscd 0 string \#\ xmcd text/xmcd #------------------------------------------------------------------------------ # pkgadd: file(1) magic for SysV R4 PKG Datastreams # 0 string #\ PaCkAgE\ DaTaStReAm application/x-svr4-package #PNG Image Format 0 string \x89PNG image/png # MNG Video Format, <URL:http://www.libpng.org/pub/mng/spec/> 0 string \x8aMNG video/x-mng 0 string \x8aJNG video/x-jng #------------------------------------------------------------------------------ # Hierarchical Data Format, used to facilitate scientific data exchange # specifications at http://hdf.ncsa.uiuc.edu/ #Hierarchical Data Format (version 4) data 0 belong 0x0e031301 application/x-hdf #Hierarchical Data Format (version 5) data 0 string \211HDF\r\n\032 application/x-hdf # Adobe Photoshop 0 string 8BPS image/x-photoshop # Felix von Leitner <felix-file@fefe.de> 0 string d8:announce application/x-bittorrent # lotus 1-2-3 document 0 belong 0x00001a00 application/x-123 0 belong 0x00000200 application/x-123 # MS Access database 4 string Standard\ Jet\ DB application/msaccess ## magic for XBase files #0 byte 0x02 #>8 leshort >0 #>>12 leshort 0 application/x-dbf # #0 byte 0x03 #>8 leshort >0 #>>12 leshort 0 application/x-dbf # #0 byte 0x04 #>8 leshort >0 #>>12 leshort 0 application/x-dbf # #0 byte 0x05 #>8 leshort >0 #>>12 leshort 0 application/x-dbf # #0 byte 0x30 #>8 leshort >0 #>>12 leshort 0 application/x-dbf # #0 byte 0x43 #>8 leshort >0 #>>12 leshort 0 application/x-dbf # #0 byte 0x7b #>8 leshort >0 #>>12 leshort 0 application/x-dbf # #0 byte 0x83 #>8 leshort >0 #>>12 leshort 0 application/x-dbf # #0 byte 0x8b #>8 leshort >0 #>>12 leshort 0 application/x-dbf # #0 byte 0x8e #>8 leshort >0 #>>12 leshort 0 application/x-dbf # #0 byte 0xb3 #>8 leshort >0 #>>12 leshort 0 application/x-dbf # #0 byte 0xf5 #>8 leshort >0 #>>12 leshort 0 application/x-dbf # #0 leshort 0x0006 application/x-dbt # Debian has entries for the old PGP formats: # pgp: file(1) magic for Pretty Good Privacy # see http://lists.gnupg.org/pipermail/gnupg-devel/1999-September/016052.html #text/PGP key public ring 0 beshort 0x9900 application/pgp #text/PGP key security ring 0 beshort 0x9501 application/pgp #text/PGP key security ring 0 beshort 0x9500 application/pgp #text/PGP encrypted data 0 beshort 0xa600 application/pgp-encrypted #text/PGP armored data ##public key block 2 string ---BEGIN\ PGP\ PUBLIC\ KEY\ BLOCK- application/pgp-keys 0 string -----BEGIN\040PGP\40MESSAGE- application/pgp 0 string -----BEGIN\040PGP\40SIGNATURE- application/pgp-signature # # GnuPG Magic: # # #text/GnuPG key public ring 0 beshort 0x9901 application/pgp #text/OpenPGP data 0 beshort 0x8501 application/pgp-encrypted # flash: file(1) magic for Macromedia Flash file format # # See # # http://www.macromedia.com/software/flash/open/ # 0 string FWS >3 byte x application/x-shockwave-flash # The following paramaters are created for Namazu. # <http://www.namazu.org/> # # 1999/08/13 #0 string \<!--\ MHonArc text/html; x-type=mhonarc 0 string BZh application/x-bzip2 # 1999/09/09 # VRML (suggested by Masao Takaku) 0 string #VRML\ V1.0\ ascii model/vrml 0 string #VRML\ V2.0\ utf8 model/vrml #------------------------------------------------------------------------------ # ichitaro456: file(1) magic for Just System Word Processor Ichitaro # # Contributor kenzo-: # Reversed-engineered JS Ichitaro magic numbers # 0 string DOC >43 byte 0x14 application/ichitaro4 >144 string JDASH application/ichitaro4 0 string DOC >43 byte 0x15 application/ichitaro5 0 string DOC >43 byte 0x16 application/ichitaro6 #------------------------------------------------------------------------------ # office97: file(1) magic for MicroSoft Office files # # Contributor kenzo-: # Reversed-engineered MS Office magic numbers # #0 string \320\317\021\340\241\261\032\341 #>48 byte 0x1B application/excel 2080 string Microsoft\ Excel\ 5.0\ Worksheet application/excel 2114 string Biff5 application/excel 0 string \224\246\056 application/msword 0 belong 0x31be0000 application/msword 0 string PO^Q` application/msword 0 string \320\317\021\340\241\261\032\341 >546 string bjbj application/msword >546 string jbjb application/msword 512 string R\0o\0o\0t\0\ \0E\0n\0t\0r\0y application/msword 2080 string Microsoft\ Word\ 6.0\ Document application/msword 2080 string Documento\ Microsoft\ Word\ 6 application/msword 2112 string MSWordDoc application/msword #0 string \320\317\021\340\241\261\032\341 application/powerpoint 0 string \320\317\021\340\241\261\032\341 application/msword 0 string #\ PaCkAgE\ DaTaStReAm application/x-svr4-package # WinNT/WinCE PE files (Warner Losh, imp@village.org) # 128 string PE\000\000 application/octet-stream 0 string PE\000\000 application/octet-stream # miscellaneous formats 0 string LZ application/octet-stream # .EXE formats (Greg Roelofs, newt@uchicago.edu) # 0 string MZ >24 string @ application/octet-stream 0 string MZ >30 string Copyright\ 1989-1990\ PKWARE\ Inc. application/x-zip 0 string MZ >30 string PKLITE\ Copr. application/x-zip 0 string MZ >36 string LHa's\ SFX application/x-lha 0 string MZ application/octet-stream # LHA archiver 2 string -lh >6 string - application/x-lha # Zoo archiver 20 lelong 0xfdc4a7dc application/x-zoo # ARC archiver 0 lelong&0x8080ffff 0x0000081a application/x-arc 0 lelong&0x8080ffff 0x0000091a application/x-arc 0 lelong&0x8080ffff 0x0000021a application/x-arc 0 lelong&0x8080ffff 0x0000031a application/x-arc 0 lelong&0x8080ffff 0x0000041a application/x-arc 0 lelong&0x8080ffff 0x0000061a application/x-arc # Microsoft Outlook's Transport Neutral Encapsulation Format (TNEF) 0 lelong 0x223e9f78 application/ms-tnef # From: stephane.loeuillet@tiscali.f # http://www.djvuzone.org/ 0 string AT&TFORM image/x.djvu # Danny Milosavljevic <danny.milo@gmx.net> # this are adrift (adventure game standard) game files, extension .taf # depending on version magic continues with 0x93453E6139FA (V 4.0) # 0x9445376139FA (V 3.90) # 0x9445366139FA (V 3.80) # this is from source (http://www.adrift.org.uk/) and I have some taf # files, and checked them. #0 belong 0x3C423FC9 #>4 belong 0x6A87C2CF application/x-adrift #0 string \000\000\001\000 image/x-ico # Quark Xpress 3 Files: # (made the mimetype up) 0 string \0\0MMXPR3\0 application/x-quark-xpress-3 # EET archive # From: Tilman Sauerbeck <tilman@code-monkey.de> 0 belong 0x1ee7ff00 application/x-eet # From: Denis Knauf, via gentoo. 0 string fLaC audio/x-flac 0 string CWS application/x-shockwave-flash # Gnumeric spreadsheet # This entry is only semi-helpful, as Gnumeric compresses its files, so # they will ordinarily reported as "compressed", but at least -z helps 39 string =<gmr:Workbook application/x-gnumeric ������������������������������������������������������������������������������������������������������������������������������������������������������File-MMagic-XS-0.09008/lib/File/MMagic/XS.pm��������������������������������������������������������000644 �000766 �000024 �00000010403 12321411545 017757� 0����������������������������������������������������������������������������������������������������ustar�00JP11194�������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������package File::MMagic::XS; use strict; use warnings; use XSLoader; our $VERSION; our $MAGIC_FILE; BEGIN { $VERSION = '0.09008'; XSLoader::load(__PACKAGE__, $VERSION); require File::Spec; foreach my $path (map { File::Spec->catfile($_, qw(File MMagic magic)) } @INC) { if (-f $path) { $MAGIC_FILE = $path; last; } } } sub import { my $class = shift; for(my $idx = 0; $idx < @_; $idx++) { if ($_[$idx] eq ':compat') { *checktype_filename = \&get_mime; *checktype_filehandle = \&fhmagic; *checktype_contents = \&bufmagic; *addMagicEntry = \&add_magic; splice(@_, $idx, 1) and last; } } $class->SUPER::import(@_); } sub new { my ($class, $magic_file) = @_; $magic_file ||= $MAGIC_FILE; my $self = $class->_create(); $self->parse_magic_file( $magic_file ); return $self; } 1; __END__ =head1 NAME File::MMagic::XS - Guess File Type With XS (a la mod_mime_magic) =head1 SYNOPSIS use File::MMagic::XS; my $m = File::MMagic::XS->new(); $m = File::MMagic::XS->new('/etc/magic'); # use external magic file my $mime = $m->get_mime($file); # use File::MMagic compatible interface use File::MMagic::XS qw(:compat); my $m = File::MMagic::XS->new(); $m->checktype_filename($file); =head1 DESCRIPTION This is a port of Apache2 mod_mime_magic.c in Perl, written in XS with the aim of being efficient and fast, especially for applications that need to be run for an extended amount of time. There is a compatibility layer for File::MMagic. you can specify :compat when importing the module use File::MMagic::XS qw(:compat); And then the following methods are going to be available from File::MMagic::XS: checktype_filename checktype_filehandle checktype_contents addMagicEntry Currently this software is in beta. If you have suggestions/recommendations about the interface or anything else, now is your chance to send them! =head1 METHODS =head2 new(%args) Creates a new File::MMagic::XS object. If you specify the C<file> argument, then File::MMagic::XS will load magic definitions from the specified file. If unspecified, it will use the magic file that will be installed under File/MMagic/ directory. =head2 clone() Clones an existing File::MMagic::XS object. =head2 parse_magic_file($file) Read and parse a magic file, as used by Apache2. =head2 get_mime($file) Inspects the file specified by C<$file> and returns a MIME type if possible. If no matching MIME type is found, then undef is returned. =head2 fsmagic($file) Inspects a file and returns a MIME type using inode information only. The contents of the file is not inspected. =head2 fhmagic($fh) Inspects a file handle and returns a mime string by reading the contents of the file handle. =head2 ascmagic($file) Inspects a piece of data (assuming it's not binary data), and attempts to determine the file type. =head2 bufmagic($scalar) Inspects a scalar buffer, and attempts to determine the file type =head2 add_magic($magic_line) Adds a new magic entry to the object. The format of $magic_line is the same as magic(5) file. This allows you to add custom magic entries at run time =head2 add_file_ext($ext, $mime) Adds a new file extension to MIME mapping. This is used as a fallback method to determining MIME types. my $magic = File::MMagic::XS->new; $magic->add_file_ext('t', 'text/perl-test'); my $mime = $magic->get_mime('t/01-sanity.t'); This will make get_mime() return 'text/perl-test'. =head2 error() Returns the last error string. =head1 PERFORMANCE This is on my laptop (MacBook, Core 2 Duo/ Mac OS X 10.4.3), tested against File::MMagic::XS 0.09003 Rate perl xs perl 513/s -- -96% xs 12048/s 2249% -- =head1 SEE ALSO L<File::MMagic|File::MMagic> =head1 AUTHOR Copyright 2005-2007 Daisuke Maki E<lt>daisuke@endeworks.jpE<gt>. Underlying software: Copyright 1999-2004 The Apache Software Foundation, Copyright (c) 1996-1997 Cisco Systems, Inc., Copyright (c) Ian F. Darwin, 1987. Written by Ian F. Darwin. =head1 LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������File-MMagic-XS-0.09008/inc/Module/������������������������������������������������������������������000755 �000766 �000024 �00000000000 12321412047 016303� 5����������������������������������������������������������������������������������������������������ustar�00JP11194�������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������File-MMagic-XS-0.09008/inc/Module/Install/����������������������������������������������������������000755 �000766 �000024 �00000000000 12321412047 017711� 5����������������������������������������������������������������������������������������������������ustar�00JP11194�������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������File-MMagic-XS-0.09008/inc/Module/Install.pm��������������������������������������������������������000644 �000766 �000024 �00000030135 12321411741 020251� 0����������������������������������������������������������������������������������������������������ustar�00JP11194�������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.08'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; <FH> }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; <FH> }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������File-MMagic-XS-0.09008/inc/Module/Install/AuthorTests.pm��������������������������������������������000644 �000766 �000024 �00000002215 12321411741 022534� 0����������������������������������������������������������������������������������������������������ustar�00JP11194�������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install::AuthorTests; use 5.005; use strict; use Module::Install::Base; use Carp (); #line 16 use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.002'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } #line 42 sub author_tests { my ($self, @dirs) = @_; _add_author_tests($self, \@dirs, 0); } #line 56 sub recursive_author_tests { my ($self, @dirs) = @_; _add_author_tests($self, \@dirs, 1); } sub _wanted { my $href = shift; sub { /\.t$/ and -f $_ and $href->{$File::Find::dir} = 1 } } sub _add_author_tests { my ($self, $dirs, $recurse) = @_; return unless $Module::Install::AUTHOR; my @tests = $self->tests ? (split / /, $self->tests) : 't/*.t'; # XXX: pick a default, later -- rjbs, 2008-02-24 my @dirs = @$dirs ? @$dirs : Carp::confess "no dirs given to author_tests"; @dirs = grep { -d } @dirs; if ($recurse) { require File::Find; my %test_dir; File::Find::find(_wanted(\%test_dir), @dirs); $self->tests( join ' ', @tests, map { "$_/*.t" } sort keys %test_dir ); } else { $self->tests( join ' ', @tests, map { "$_/*.t" } sort @dirs ); } } #line 107 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������File-MMagic-XS-0.09008/inc/Module/Install/Base.pm���������������������������������������������������000644 �000766 �000024 �00000002147 12321411741 021125� 0����������������������������������������������������������������������������������������������������ustar�00JP11194�������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.08'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������File-MMagic-XS-0.09008/inc/Module/Install/Can.pm����������������������������������������������������000644 �000766 �000024 �00000006157 12321411741 020761� 0����������������������������������������������������������������������������������������������������ustar�00JP11194�������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.08'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 236 �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������File-MMagic-XS-0.09008/inc/Module/Install/Fetch.pm��������������������������������������������������000644 �000766 �000024 �00000004627 12321411741 021311� 0����������������������������������������������������������������������������������������������������ustar�00JP11194�������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.08'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; ���������������������������������������������������������������������������������������������������������File-MMagic-XS-0.09008/inc/Module/Install/Makefile.pm�����������������������������������������������000644 �000766 �000024 �00000027437 12321411741 022001� 0����������������������������������������������������������������������������������������������������ustar�00JP11194�������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.08'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; <MAKEFILE> }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������File-MMagic-XS-0.09008/inc/Module/Install/Metadata.pm�����������������������������������������������000644 �000766 �000024 �00000043277 12321411741 022004� 0����������������������������������������������������������������������������������������������������ustar�00JP11194�������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.08'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E<lt>}{<}g; $author =~ s{E<gt>}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������File-MMagic-XS-0.09008/inc/Module/Install/Repository.pm���������������������������������������������000644 �000766 �000024 �00000004256 12321411741 022435� 0����������������������������������������������������������������������������������������������������ustar�00JP11194�������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install::Repository; use strict; use 5.005; use vars qw($VERSION); $VERSION = '0.06'; use base qw(Module::Install::Base); sub _execute { my ($command) = @_; `$command`; } sub auto_set_repository { my $self = shift; return unless $Module::Install::AUTHOR; my $repo = _find_repo(\&_execute); if ($repo) { $self->repository($repo); } else { warn "Cannot determine repository URL\n"; } } sub _find_repo { my ($execute) = @_; if (-e ".git") { # TODO support remote besides 'origin'? if ($execute->('git remote show -n origin') =~ /URL: (.*)$/m) { # XXX Make it public clone URL, but this only works with github my $git_url = $1; $git_url =~ s![\w\-]+\@([^:]+):!git://$1/!; return $git_url; } elsif ($execute->('git svn info') =~ /URL: (.*)$/m) { return $1; } } elsif (-e ".svn") { if (`svn info` =~ /URL: (.*)$/m) { return $1; } } elsif (-e "_darcs") { # defaultrepo is better, but that is more likely to be ssh, not http if (my $query_repo = `darcs query repo`) { if ($query_repo =~ m!Default Remote: (http://.+)!) { return $1; } } open my $handle, '<', '_darcs/prefs/repos' or return; while (<$handle>) { chomp; return $_ if m!^http://!; } } elsif (-e ".hg") { if ($execute->('hg paths') =~ /default = (.*)$/m) { my $mercurial_url = $1; $mercurial_url =~ s!^ssh://hg\@(bitbucket\.org/)!https://$1!; return $mercurial_url; } } elsif (-e "$ENV{HOME}/.svk") { # Is there an explicit way to check if it's an svk checkout? my $svk_info = `svk info` or return; SVK_INFO: { if ($svk_info =~ /Mirrored From: (.*), Rev\./) { return $1; } if ($svk_info =~ m!Merged From: (/mirror/.*), Rev\.!) { $svk_info = `svk info /$1` or return; redo SVK_INFO; } } return; } } 1; __END__ =encoding utf-8 #line 128 ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������File-MMagic-XS-0.09008/inc/Module/Install/Win32.pm��������������������������������������������������000644 �000766 �000024 �00000003403 12321411741 021151� 0����������������������������������������������������������������������������������������������������ustar�00JP11194�������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.08'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������File-MMagic-XS-0.09008/inc/Module/Install/WriteAll.pm�����������������������������������������������000644 �000766 �000024 �00000002376 12321411741 022002� 0����������������������������������������������������������������������������������������������������ustar�00JP11194�������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.08'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������File-MMagic-XS-0.09008/inc/Module/Install/XSUtil.pm�������������������������������������������������000644 �000766 �000024 �00000045703 12321411741 021450� 0����������������������������������������������������������������������������������������������������ustar�00JP11194�������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install::XSUtil; use 5.005_03; $VERSION = '0.45'; use Module::Install::Base; @ISA = qw(Module::Install::Base); use strict; use Config; use File::Spec; use File::Find; use constant _VERBOSE => $ENV{MI_VERBOSE} ? 1 : 0; my %ConfigureRequires = ( 'ExtUtils::ParseXS' => 3.18, # shipped with Perl 5.18.0 ); my %BuildRequires = ( ); my %Requires = ( 'XSLoader' => 0.02, ); my %ToInstall; my $UseC99 = 0; my $UseCplusplus = 0; sub _verbose{ print STDERR q{# }, @_, "\n"; } sub _xs_debugging{ return $ENV{XS_DEBUG} || scalar( grep{ $_ eq '-g' } @ARGV ); } sub _xs_initialize{ my($self) = @_; unless($self->{xsu_initialized}){ $self->{xsu_initialized} = 1; if(!$self->cc_available()){ warn "This distribution requires a C compiler, but it's not available, stopped.\n"; exit; } $self->configure_requires(%ConfigureRequires); $self->build_requires(%BuildRequires); $self->requires(%Requires); $self->makemaker_args->{OBJECT} = '$(O_FILES)'; $self->clean_files('$(O_FILES)'); $self->clean_files('*.stackdump') if $^O eq 'cygwin'; if($self->_xs_debugging()){ # override $Config{optimize} if(_is_msvc()){ $self->makemaker_args->{OPTIMIZE} = '-Zi'; } else{ $self->makemaker_args->{OPTIMIZE} = '-g -ggdb -g3'; } $self->cc_define('-DXS_ASSERT'); } } return; } # GNU C Compiler sub _is_gcc{ return $Config{gccversion}; } # Microsoft Visual C++ Compiler (cl.exe) sub _is_msvc{ return $Config{cc} =~ /\A cl \b /xmsi; } { my $cc_available; sub cc_available { return defined $cc_available ? $cc_available : ($cc_available = shift->can_cc()) ; } # cf. https://github.com/sjn/toolchain-site/blob/219db464af9b2f19b04fec05547ac10180a469f3/lancaster-consensus.md my $want_xs; sub want_xs { my($self, $default) = @_; return $want_xs if defined $want_xs; # you're using this module, you must want XS by default # unless PERL_ONLY is true. $default = !$ENV{PERL_ONLY} if not defined $default; foreach my $arg(@ARGV){ my ($k, $v) = split '=', $arg; # MM-style named args if ($k eq 'PUREPERL_ONLY' && defined $v) { return $want_xs = !$v; } elsif($arg eq '--pp'){ # old-style return $want_xs = 0; } elsif($arg eq '--xs'){ return $want_xs = 1; } } if ($ENV{PERL_MM_OPT}) { my($v) = $ENV{PERL_MM_OPT} =~ /\b PUREPERL_ONLY = (\S+) /xms; if (defined $v) { return $want_xs = !$v; } } return $want_xs = $default; } } sub use_ppport{ my($self, $dppp_version) = @_; return if $self->{_ppport_ok}++; $self->_xs_initialize(); my $filename = 'ppport.h'; $dppp_version ||= 3.19; # the more, the better $self->configure_requires('Devel::PPPort' => $dppp_version); $self->build_requires('Devel::PPPort' => $dppp_version); print "Writing $filename\n"; my $e = do{ local $@; eval qq{ use Devel::PPPort; Devel::PPPort::WriteFile(q{$filename}); }; $@; }; if($e){ print "Cannot create $filename because: $@\n"; } if(-e $filename){ $self->clean_files($filename); $self->cc_define('-DUSE_PPPORT'); $self->cc_append_to_inc('.'); } return; } sub use_xshelper { my($self, $opt) = @_; $self->_xs_initialize(); $self->use_ppport(); my $file = 'xshelper.h'; open my $fh, '>', $file or die "Cannot open $file for writing: $!"; print $fh $self->_xshelper_h(); close $fh or die "Cannot close $file: $!"; if(defined $opt) { if($opt eq '-clean') { $self->clean_files($file); } else { $self->realclean_files($file); } } return; } sub _gccversion { my $res = `$Config{cc} --version`; my ($version) = $res =~ /\(GCC\) ([0-9.]+)/; no warnings 'numeric', 'uninitialized'; return sprintf '%g', $version; } sub cc_warnings{ my($self) = @_; $self->_xs_initialize(); if(_is_gcc()){ $self->cc_append_to_ccflags(qw(-Wall)); my $gccversion = _gccversion(); if($gccversion >= 4.0){ $self->cc_append_to_ccflags(qw(-Wextra)); if(!($UseC99 or $UseCplusplus)) { # Note: MSVC++ doesn't support C99, # so -Wdeclaration-after-statement helps # ensure C89 specs. $self->cc_append_to_ccflags(qw(-Wdeclaration-after-statement)); } if($gccversion >= 4.1 && !$UseCplusplus) { $self->cc_append_to_ccflags(qw(-Wc++-compat)); } } else{ $self->cc_append_to_ccflags(qw(-W -Wno-comment)); } } elsif(_is_msvc()){ $self->cc_append_to_ccflags(qw(-W3)); } else{ # TODO: support other compilers } return; } sub c99_available { my($self) = @_; return 0 if not $self->cc_available(); require File::Temp; require File::Basename; my $tmpfile = File::Temp->new(SUFFIX => '.c'); $tmpfile->print(<<'C99'); // include a C99 header #include <stdbool.h> inline // a C99 keyword with C99 style comments int test_c99() { int i = 0; i++; int j = i - 1; // another C99 feature: declaration after statement return j; } C99 $tmpfile->close(); system "$Config{cc} -c " . $tmpfile->filename; (my $objname = File::Basename::basename($tmpfile->filename)) =~ s/\Q.c\E$/$Config{_o}/; unlink $objname or warn "Cannot unlink $objname (ignored): $!"; return $? == 0; } sub requires_c99 { my($self) = @_; if(!$self->c99_available) { warn "This distribution requires a C99 compiler, but $Config{cc} seems not to support C99, stopped.\n"; exit; } $self->_xs_initialize(); $UseC99 = 1; return; } sub requires_cplusplus { my($self) = @_; if(!$self->cc_available) { warn "This distribution requires a C++ compiler, but $Config{cc} seems not to support C++, stopped.\n"; exit; } $self->_xs_initialize(); $UseCplusplus = 1; return; } sub cc_append_to_inc{ my($self, @dirs) = @_; $self->_xs_initialize(); for my $dir(@dirs){ unless(-d $dir){ warn("'$dir' not found: $!\n"); } _verbose "inc: -I$dir" if _VERBOSE; } my $mm = $self->makemaker_args; my $paths = join q{ }, map{ s{\\}{\\\\}g; qq{"-I$_"} } @dirs; if($mm->{INC}){ $mm->{INC} .= q{ } . $paths; } else{ $mm->{INC} = $paths; } return; } sub cc_libs { my ($self, @libs) = @_; @libs = map{ my($name, $dir) = ref($_) eq 'ARRAY' ? @{$_} : ($_, undef); my $lib; if(defined $dir) { $lib = ($dir =~ /^-/ ? qq{$dir } : qq{-L$dir }); } else { $lib = ''; } $lib .= ($name =~ /^-/ ? qq{$name} : qq{-l$name}); _verbose "libs: $lib" if _VERBOSE; $lib; } @libs; $self->cc_append_to_libs( @libs ); } sub cc_append_to_libs{ my($self, @libs) = @_; $self->_xs_initialize(); return unless @libs; my $libs = join q{ }, @libs; my $mm = $self->makemaker_args; if ($mm->{LIBS}){ $mm->{LIBS} .= q{ } . $libs; } else{ $mm->{LIBS} = $libs; } return $libs; } sub cc_assert_lib { my ($self, @dcl_args) = @_; if ( ! $self->{xsu_loaded_checklib} ) { my $loaded_lib = 0; foreach my $checklib (qw(inc::Devel::CheckLib Devel::CheckLib)) { eval "use $checklib 0.4"; if (!$@) { $loaded_lib = 1; last; } } if (! $loaded_lib) { warn "Devel::CheckLib not found in inc/ nor \@INC"; exit 0; } $self->{xsu_loaded_checklib}++; $self->configure_requires( "Devel::CheckLib" => "0.4" ); $self->build_requires( "Devel::CheckLib" => "0.4" ); } Devel::CheckLib::check_lib_or_exit(@dcl_args); } sub cc_append_to_ccflags{ my($self, @ccflags) = @_; $self->_xs_initialize(); my $mm = $self->makemaker_args; $mm->{CCFLAGS} ||= $Config{ccflags}; $mm->{CCFLAGS} .= q{ } . join q{ }, @ccflags; return; } sub cc_define{ my($self, @defines) = @_; $self->_xs_initialize(); my $mm = $self->makemaker_args; if(exists $mm->{DEFINE}){ $mm->{DEFINE} .= q{ } . join q{ }, @defines; } else{ $mm->{DEFINE} = join q{ }, @defines; } return; } sub requires_xs_module { my $self = shift; return $self->requires() unless @_; $self->_xs_initialize(); my %added = $self->requires(@_); my(@inc, @libs); my $rx_lib = qr{ \. (?: lib | a) \z}xmsi; my $rx_dll = qr{ \. dll \z}xmsi; # for Cygwin while(my $module = each %added){ my $mod_basedir = File::Spec->join(split /::/, $module); my $rx_header = qr{\A ( .+ \Q$mod_basedir\E ) .+ \. h(?:pp)? \z}xmsi; SCAN_INC: foreach my $inc_dir(@INC){ my @dirs = grep{ -e } File::Spec->join($inc_dir, 'auto', $mod_basedir), File::Spec->join($inc_dir, $mod_basedir); next SCAN_INC unless @dirs; my $n_inc = scalar @inc; find(sub{ if(my($incdir) = $File::Find::name =~ $rx_header){ push @inc, $incdir; } elsif($File::Find::name =~ $rx_lib){ my($libname) = $_ =~ /\A (?:lib)? (\w+) /xmsi; push @libs, [$libname, $File::Find::dir]; } elsif($File::Find::name =~ $rx_dll){ # XXX: hack for Cygwin my $mm = $self->makemaker_args; $mm->{macro}->{PERL_ARCHIVE_AFTER} ||= ''; $mm->{macro}->{PERL_ARCHIVE_AFTER} .= ' ' . $File::Find::name; } }, @dirs); if($n_inc != scalar @inc){ last SCAN_INC; } } } my %uniq = (); $self->cc_append_to_inc (grep{ !$uniq{ $_ }++ } @inc); %uniq = (); $self->cc_libs(grep{ !$uniq{ $_->[0] }++ } @libs); return %added; } sub cc_src_paths{ my($self, @dirs) = @_; $self->_xs_initialize(); return unless @dirs; my $mm = $self->makemaker_args; my $XS_ref = $mm->{XS} ||= {}; my $C_ref = $mm->{C} ||= []; my $_obj = $Config{_o}; my @src_files; find(sub{ if(/ \. (?: xs | c (?: c | pp | xx )? ) \z/xmsi){ # *.{xs, c, cc, cpp, cxx} push @src_files, $File::Find::name; } }, @dirs); my $xs_to = $UseCplusplus ? '.cpp' : '.c'; foreach my $src_file(@src_files){ my $c = $src_file; if($c =~ s/ \.xs \z/$xs_to/xms){ $XS_ref->{$src_file} = $c; _verbose "xs: $src_file" if _VERBOSE; } else{ _verbose "c: $c" if _VERBOSE; } push @{$C_ref}, $c unless grep{ $_ eq $c } @{$C_ref}; } $self->clean_files(map{ File::Spec->catfile($_, '*.gcov'), File::Spec->catfile($_, '*.gcda'), File::Spec->catfile($_, '*.gcno'), } @dirs); $self->cc_append_to_inc('.'); return; } sub cc_include_paths{ my($self, @dirs) = @_; $self->_xs_initialize(); push @{ $self->{xsu_include_paths} ||= []}, @dirs; my $h_map = $self->{xsu_header_map} ||= {}; foreach my $dir(@dirs){ my $prefix = quotemeta( File::Spec->catfile($dir, '') ); find(sub{ return unless / \.h(?:pp)? \z/xms; (my $h_file = $File::Find::name) =~ s/ \A $prefix //xms; $h_map->{$h_file} = $File::Find::name; }, $dir); } $self->cc_append_to_inc(@dirs); return; } sub install_headers{ my $self = shift; my $h_files; if(@_ == 0){ $h_files = $self->{xsu_header_map} or die "install_headers: cc_include_paths not specified.\n"; } elsif(@_ == 1 && ref($_[0]) eq 'HASH'){ $h_files = $_[0]; } else{ $h_files = +{ map{ $_ => undef } @_ }; } $self->_xs_initialize(); my @not_found; my $h_map = $self->{xsu_header_map} || {}; while(my($ident, $path) = each %{$h_files}){ $path ||= $h_map->{$ident} || File::Spec->join('.', $ident); $path = File::Spec->canonpath($path); unless($path && -e $path){ push @not_found, $ident; next; } $ToInstall{$path} = File::Spec->join('$(INST_ARCHAUTODIR)', $ident); _verbose "install: $path as $ident" if _VERBOSE; my @funcs = $self->_extract_functions_from_header_file($path); if(@funcs){ $self->cc_append_to_funclist(@funcs); } } if(@not_found){ die "Header file(s) not found: @not_found\n"; } return; } my $home_directory; sub _extract_functions_from_header_file{ my($self, $h_file) = @_; my @functions; ($home_directory) = <~> unless defined $home_directory; # get header file contents through cpp(1) my $contents = do { my $mm = $self->makemaker_args; my $cppflags = q{"-I}. File::Spec->join($Config{archlib}, 'CORE') . q{"}; $cppflags =~ s/~/$home_directory/g; $cppflags .= ' ' . $mm->{INC} if $mm->{INC}; $cppflags .= ' ' . ($mm->{CCFLAGS} || $Config{ccflags}); $cppflags .= ' ' . $mm->{DEFINE} if $mm->{DEFINE}; my $add_include = _is_msvc() ? '-FI' : '-include'; $cppflags .= ' ' . join ' ', map{ qq{$add_include "$_"} } qw(EXTERN.h perl.h XSUB.h); my $cppcmd = qq{$Config{cpprun} $cppflags $h_file}; # remove all the -arch options to workaround gcc errors: # "-E, -S, -save-temps and -M options are not allowed # with multiple -arch flags" $cppcmd =~ s/ -arch \s* \S+ //xmsg; _verbose("extract functions from: $cppcmd") if _VERBOSE; `$cppcmd`; }; unless(defined $contents){ die "Cannot call C pre-processor ($Config{cpprun}): $! ($?)"; } # remove other include file contents my $chfile = q/\# (?:line)? \s+ \d+ /; $contents =~ s{ ^$chfile \s+ (?!"\Q$h_file\E") .*? ^(?= $chfile) }{}xmsig; if(_VERBOSE){ local *H; open H, "> $h_file.out" and print H $contents and close H; } while($contents =~ m{ ([^\\;\s]+ # type \s+ ([a-zA-Z_][a-zA-Z0-9_]*) # function name \s* \( [^;#]* \) # argument list [\w\s\(\)]* # attributes or something ;) # end of declaration }xmsg){ my $decl = $1; my $name = $2; next if $decl =~ /\b typedef \b/xms; next if $name =~ /^_/xms; # skip something private push @functions, $name; if(_VERBOSE){ $decl =~ tr/\n\r\t / /s; $decl =~ s/ (\Q$name\E) /<$name>/xms; _verbose("decl: $decl"); } } return @functions; } sub cc_append_to_funclist{ my($self, @functions) = @_; $self->_xs_initialize(); my $mm = $self->makemaker_args; push @{$mm->{FUNCLIST} ||= []}, @functions; $mm->{DL_FUNCS} ||= { '$(NAME)' => [] }; return; } sub _xshelper_h { my $h = <<'XSHELPER_H'; :/* THIS FILE IS AUTOMATICALLY GENERATED BY Module::Install::XSUtil $VERSION. */ :/* :=head1 NAME : :xshelper.h - Helper C header file for XS modules : :=head1 DESCRIPTION : : // This includes all the perl header files and ppport.h : #include "xshelper.h" : :=head1 SEE ALSO : :L<Module::Install::XSUtil>, where this file is distributed as a part of : :=head1 AUTHOR : :Fuji, Goro (gfx) E<lt>gfuji at cpan.orgE<gt> : :=head1 LISENCE : :Copyright (c) 2010, Fuji, Goro (gfx). All rights reserved. : :This library is free software; you can redistribute it and/or modify :it under the same terms as Perl itself. : :=cut :*/ : :#ifdef __cplusplus :extern "C" { :#endif : :#define PERL_NO_GET_CONTEXT /* we want efficiency */ :#include <EXTERN.h> :#include <perl.h> :#define NO_XSLOCKS /* for exceptions */ :#include <XSUB.h> : :#ifdef __cplusplus :} /* extern "C" */ :#endif : :#include "ppport.h" : :/* portability stuff not supported by ppport.h yet */ : :#ifndef STATIC_INLINE /* from 5.13.4 */ :# if defined(__GNUC__) || defined(__cplusplus) || (defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L)) :# define STATIC_INLINE static inline :# else :# define STATIC_INLINE static :# endif :#endif /* STATIC_INLINE */ : :#ifndef __attribute__format__ :#define __attribute__format__(a,b,c) /* nothing */ :#endif : :#ifndef LIKELY /* they are just a compiler's hint */ :#define LIKELY(x) (!!(x)) :#define UNLIKELY(x) (!!(x)) :#endif : :#ifndef newSVpvs_share :#define newSVpvs_share(s) Perl_newSVpvn_share(aTHX_ STR_WITH_LEN(s), 0U) :#endif : :#ifndef get_cvs :#define get_cvs(name, flags) get_cv(name, flags) :#endif : :#ifndef GvNAME_get :#define GvNAME_get GvNAME :#endif :#ifndef GvNAMELEN_get :#define GvNAMELEN_get GvNAMELEN :#endif : :#ifndef CvGV_set :#define CvGV_set(cv, gv) (CvGV(cv) = (gv)) :#endif : :/* general utility */ : :#if PERL_BCDVERSION >= 0x5008005 :#define LooksLikeNumber(x) looks_like_number(x) :#else :#define LooksLikeNumber(x) (SvPOKp(x) ? looks_like_number(x) : (I32)SvNIOKp(x)) :#endif : :#define newAV_mortal() (AV*)sv_2mortal((SV*)newAV()) :#define newHV_mortal() (HV*)sv_2mortal((SV*)newHV()) :#define newRV_inc_mortal(sv) sv_2mortal(newRV_inc(sv)) :#define newRV_noinc_mortal(sv) sv_2mortal(newRV_noinc(sv)) : :#define DECL_BOOT(name) EXTERN_C XS(CAT2(boot_, name)) :#define CALL_BOOT(name) STMT_START { \ : PUSHMARK(SP); \ : CALL_FPTR(CAT2(boot_, name))(aTHX_ cv); \ : } STMT_END XSHELPER_H $h =~ s/^://xmsg; $h =~ s/\$VERSION\b/$Module::Install::XSUtil::VERSION/xms; return $h; } package MY; # XXX: We must append to PM inside ExtUtils::MakeMaker->new(). sub init_PM { my $self = shift; $self->SUPER::init_PM(@_); while(my($k, $v) = each %ToInstall){ $self->{PM}{$k} = $v; } return; } # append object file names to CCCMD sub const_cccmd { my $self = shift; my $cccmd = $self->SUPER::const_cccmd(@_); return q{} unless $cccmd; if (Module::Install::XSUtil::_is_msvc()){ $cccmd .= ' -Fo$@'; } else { $cccmd .= ' -o $@'; } return $cccmd } sub xs_c { my($self) = @_; my $mm = $self->SUPER::xs_c(); $mm =~ s/ \.c /.cpp/xmsg if $UseCplusplus; return $mm; } sub xs_o { my($self) = @_; my $mm = $self->SUPER::xs_o(); $mm =~ s/ \.c /.cpp/xmsg if $UseCplusplus; return $mm; } 1; __END__ #line 1030 �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������