File-Unpack2
view release on metacpan or search on metacpan
lib/File/Unpack2.pm view on Meta::CPAN
my ($number, $dec_places) = @_;
$dec_places = 2 unless defined $dec_places;
my $div = 1;
my $unit = '';
my $neg = '';
if ($number < 0)
{
$neg = '-'; $number = -$number;
}
if ($number > $div * 1024)
{
$div *= 1024; $unit = 'k';
if ($number > $div * 1024)
{
$div *= 1024; $unit = 'm';
if ($number > $div * 1024)
{
$div *= 1024; $unit = 'g';
if ($number > $div * 1024)
{
$div *= 1024; $unit = 't';
}
}
}
}
return sprintf "%s%.*f%s", $neg, $dec_places, ($number / $div), $unit;
}
# see fs.pm/check_fs_health()
sub minfree
{
my $self = shift;
my %opt = @_;
for my $i (qw(factor bytes percent))
{
$self->{minfree}{$i} = $opt{$i} if defined $opt{$i};
$self->{minfree}{$i} ||= 0;
}
$self->{minfree}{bytes} = _bytes_unit($self->{minfree}{bytes});
$self->{minfree}{percent} =~ s{%$}{};
$self->{fs_warn} = $opt{warning} if ref $opt{warning};
}
=head2 mime
$u->mime($filename)
$u->mime(file => $filename)
$u->mime(buf => "#!/bin ...", file => "what-was-read")
$u->mime(fd => \*STDIN, file => "what-was-opened")
Determines the MIME type (and optionally additional information) of a file.
The file can be specified by filename, by a provided buffer or an opened file descriptor.
For the latter two cases, specifying a filename is optional, and used only for diagnostics.
C<mime> uses libmagic by Christos Zoulas exposed via File::LibMagic and also uses
the shared-mime-info database from freedesktop.org exposed via
File::MimeInfo::Magic, if available. Either one is sufficient, but having both
is better. LibMagic sometimes says 'text/x-pascal', although we have a F<.desktop>
file, or says 'text/plain', but has contradicting details in its description.
C<File::MimeInfo::Magic::magic> is consulted where the libmagic output is dubious. E.g. when
the desciption says something interesting like 'Debian binary package (format 2.0)' but the
mimetype says 'application/octet-stream'. The combination of both libraries gives us
excellent reliability in the critical field of MIME type recognition.
This implementation also features multi-level MIME type recognition for efficient unpacking.
When e.g. unpacking a large bzipped tar archive, this saves us from creating a
huge temporary tar-file which C<unpack> would extract in a second step. The multi-level recognition
returns 'application/x-tar+bzip2' in this case, and allows for a MIME helper
to e.g. pipe the bzip2 contents into tar (which is exactly what 'tar jxvf'
does, making a very simple and efficient MIME helper).
C<mime> returns a 3 or 4 element arrayref with mimetype, charset, description, diff;
where diff is only present when the libfile and shared-mime-info methods disagree.
In case of 'text/plain', an additional rule based on file name suffix is used to allow
recognition of well known plain text pack formats.
We return 'text/x-suffix-XX+plain', where XX is one of the recognized suffixes
(in all lower case and without the dot). E.g. a plain mmencoded file has no
header and looks like 'plain/text' to all the known magic libraries. We
recognize the suffixes .mm, .b64, and .base64 for this (case insignificant).
A similar rule exitst for 'application/octect-stream'. It may trigger e.g. for
LZMA compressed files which fail to provide a magic number.
Examples:
[ 'text/x-perl', 'us-ascii', 'a /usr/bin/perl -w script text']
[ 'text/x-mpegurl', 'utf-8', 'M3U playlist text',
[ 'text/plain', 'application/x-mpegurl']]
[ 'application/x-tar+bzip2, 'binary',
"bzip2 compressed data, block size = 900k\nPOSIX tar archive (GNU)", ...]
=cut
sub mime
{
my ($self, @in) = @_;
my %in;
%in = %{$in[0]} if !$#in and ref $in[0] eq 'HASH';
unshift @in, 'file' if !$#in and !ref $in[0];
%in = @in if $#in > 0;
my $flm = $self->{flm} ||= File::LibMagic->new();
unless (defined $in{buf})
{
my $fd = $in{fd};
unless ($fd)
{
open $fd, "<", $in{file} or
return [ 'x-system/x-error', undef, "cannot open '$in{file}': $!" ];
}
my $f = $in{file}||'-';
$in{buf} = '';
my $pos = tell $fd;
##bzip2 below needs a long buffer, or it returns 0.
my $len = read $fd, $in{buf}, $UNCOMP_BUFSZ;
return [ 'x-system/x-error', undef, "read '$f' failed: $!" ] unless defined $len;
return [ 'x-system/x-error', undef, "read '$f' failed: $len: $!" ] if $len < 0;
return [ 'text/x-empty', undef, 'empty' ] if $len == 0;
seek $fd, $pos, 0;
close $fd unless $in{fd};
}
## flm can say 'cannot open \'IP\' (No such file or directory)'
## flm can say 'CDF V2 Document, corrupt: Can\'t read SAT' (application/vnd.ms-excel)
my $mime1 = eval { $flm->checktype_contents($in{buf}) };
if ($@) {
warn $@;
return [ 'x-system/x-error', undef, "libmimemagic exception"];
}
if ($mime1 =~ m{, corrupt: } or $mime1 =~ m{^application/octet-stream\b})
{
# application/x-iso9660-image is reported as application/octet-stream if the buffer is short.
# iso images usually start with 0x8000 bytes of all '\0'.
print STDERR "mime: readahead buffer $UNCOMP_BUFSZ too short\n" if $self->{verbose} > 2;
if (defined $in{file} and -f $in{file})
{
print STDERR "mime: reopening $in{file}\n" if $self->{verbose} > 1;
$mime1 = $flm->checktype_filename($in{file});
}
}
print STDERR "flm->checktype_contents: $mime1\n" if $self->{verbose} > 1;
$in{file} = '-' unless defined $in{file};
return [ 'x-system/x-error', undef, $mime1 ] if $mime1 =~ m{^cannot open};
# in SLES11 we get 'text/plain charset=utf-8' without semicolon.
my $enc; ($mime1, $enc) = ($1,$2) if $mime1 =~ m{^(.*?);\s*(.*)$} or
$mime1 =~ m{^(.*?)\s+(.*)$};
$enc =~ s{^charset=}{} if defined $enc;
my @r = ($mime1, $enc, $flm->describe_contents($in{buf}) );
my $mime2;
if ($mime1 =~ m{^application/xml})
{
# This is horrible from a greedy text cruncher perspective:
# although xml is a plain text syntax, it is reported by flm to be
# outside text/*
$r[0] = "text/x-application-xml";
}
if ($mime1 =~ m{^text/x-(?:pascal|fortran)$})
{
# xterm.desktop
# ['text/x-pascal; charset=utf-8','UTF-8 Unicode Pascal program text']
# 'application/x-desktop'
#
# Times-Roman.afm
# ['text/x-fortran; charset=us-ascii','ASCII font metrics']
# 'application/x-font-afm'
#
# debian/rules
# ['text/x-pascal; charset=us-ascii','a /usr/bin/make -f script text']
# 'text/x-makefile'
if ($mime2 ||= eval { open my $fd,'<',\$in{buf}; File::MimeInfo::Magic::magic($fd); })
{
$r[0] = "text/$1" if $mime2 =~ m{/(\S+)};
}
}
elsif (($mime1 eq 'text/plain' and $r[2] =~ m{(?:PostScript|font)}i)
or ($mime1 eq 'application/postscript'))
{
# 11.3 says:
# IPA.pfa
# ['text/plain; charset=us-ascii','PostScript Type 1 font text (OmegaSerifIPA 001.000)']
# sles11 says:
# IPA.pfa
# ['application/postscript', undef, 'PostScript document text']
#
# mime2 = 'application/x-font-type1'
# $mime2 = eval { File::MimeInfo::Magic::mimetype($in{file}); };
$mime2 ||= eval { open my $fd,'<',\$in{buf}; File::MimeInfo::Magic::magic($fd); };
if ($mime2 and $mime2 =~ m{^(.*)/(.*)$})
{
my ($a,$b) = ($1,$2);
$a = 'text' if $r[2] =~ m{\btext\b}i;
$r[0] = "$a/$b";
}
}
if ($r[0] eq 'text/plain' or
$r[0] eq 'application/octet-stream')
{
# hmm, are we sure? No, if the description contradicts:
#
$r[0] = "text/x-uuencode" if $r[2] eq 'uuencoded or xxencoded text';
# bin/floor
# ['text/x-pascal; charset=us-ascii','a /usr/bin/tclsh script text']
# 'text/plain'
$r[0] = "text/x-$2" if $r[2] =~ m{^a (\S*/)?([^/\s]+) .*script text$}i;
if ($r[2] =~ m{\bimage\b})
{
# ./opengl/test.tga
# ['application/octet-stream; charset=binary','Targa image data - RGB 128 x 128']
# 'image/x-tga'
$mime2 ||= eval { open my $fd,'<',\$in{buf}; File::MimeInfo::Magic::magic($fd); };
$r[0] = $mime2 if $mime2 and $mime2 =~ m{^image/};
}
}
if ($r[0] eq 'application/octet-stream')
{
# it can't get much worse, can it?
##
# dotdot.tar.lzma
lib/File/Unpack2.pm view on Meta::CPAN
$r[0] = "application/x-$b+$compname"
}
else
{
$r[0] = "application/x-$a-$b+$compname"
}
$r[2] .= "\n" . $m2->[2];
$uncomp_buf = $next_uncomp_buf;
}
if ($r[0] eq 'application/unknown+zip' and $r[2] =~ m{\btext\b}i)
{
# empty.odt
# ['application/unknown+zip; charset=binary','Zip archive data, at least v2.0 to extract, mime type application/vnd OpenDocument Text']
# application/vnd.oasis.opendocument.text
if ($mime2 ||= eval { open my $fd,'<',\$in{buf}; File::MimeInfo::Magic::magic($fd); })
{
$mime2 .= '+zip' unless $mime2 =~ m{\+zip}i;
$r[0] = $mime2 if $mime2 =~ m{^application/};
}
}
$r[0] .= '+zip' if $r[0] =~ m{^application/vnd\.oasis\.opendocument\.text$};
if ($r[0] eq 'text/plain' and $in{file} =~ m{\.(mm|b64|base64)$}i)
{
my $suf = lc $1;
$r[0] = "text/x-suffix-$suf+plain";
}
if ($r[0] eq 'application/octet-stream' and $in{file} =~ m{\.(lzma|zx|lz)$}i)
{
my $suf = lc $1;
$r[0] = "application/x-suffix-$suf+octet-stream";
}
if ($r[0] =~ m{^application/x-(ms-dos-|)executable$})
{
if (-x '/usr/bin/upx')
{
# upx refuses to read symlinks. Work around this.
my $in_file = $in{file};
$in_file = readlink($in{file}) if -l $in{file};
# Bound this probe: a hostile executable could hang upx. helper_timeout kills it cleanly
# (whole process group); a timeout just skips the cosmetic '+upx' classification.
$r[0] .= '+upx'
unless run(['/usr/bin/upx', '-q', '-q', '-t', $in_file], {every => 2, helper_timeout => 30, out_err => '/dev/null'});
}
}
${$in{uncomp}} = $uncomp_buf if ref $in{uncomp} eq 'SCALAR';
$r[3] = [ $mime1, $mime2 ] if $mime1 ne $r[0] or ($mime2 and $mime2 ne $mime1);
return \@r;
}
=head1 MIME TYPE DETECTION
File::Unpack2 identifies files by content, not by name. Detection is layered:
L<File::LibMagic> (the same C<libmagic> engine as F</usr/bin/file>) is the primary
source of mime type, charset and a human description; L<File::MimeInfo::Magic>
(the freedesktop.org shared-mime-info database) fills the gaps where libmagic is
weak; and a little extra logic on top recognises compression that carries no
usable magic of its own, most notably raw LZMA. The C<description> string is
cross-checked against the mime type to catch mislabellings before a helper is
chosen. Both magic modules are loaded lazily and only L</mime> requires them.
=head1 SEE ALSO
=over 2
=item *
L<Cavil|https://github.com/openSUSE/cavil> - the openSUSE legal review system this
module is developed for.
=item *
L<File::LibMagic>, L<File::MimeInfo::Magic> - the mime type engines.
=item *
L<IPC::Run> - used to run and supervise the external mime helpers.
=item *
The C<docs/Architecture.md> document in the distribution, for a prose overview.
=back
=head1 REPOSITORY
L<https://github.com/openSUSE/perl-File-Unpack2>
=head1 AUTHOR
Originally written by Juergen Weigert E<lt>jnw@cpan.orgE<gt>. Now maintained by
Sebastian Riedel E<lt>sriedel@suse.comE<gt> and the SUSE team as a dependency of
Cavil.
=head1 LICENSE AND COPYRIGHT
Copyright (C) 2010-2013 Juergen Weigert, (C) 2023-2026 Sebastian Riedel.
This program is free software; you can redistribute it and/or modify it under the
same terms as Perl itself, that is, either the GNU General Public License or the
Artistic License. See L<https://dev.perl.org/licenses/> for more information.
=cut
1; # End of File::Unpack2
( run in 0.376 second using v1.01-cache-2.11-cpan-ff9377addf4 )