Archive-Lha
view release on metacpan or search on metacpan
lib/Archive/Lha.pm view on Meta::CPAN
use Archive::Lha::Stream::File;
use Archive::Lha::Decode;
my $stream = Archive::Lha::Stream::File->new(file => 'archive.lzh');
while (defined(my $level = $stream->search_header)) {
my $header = Archive::Lha::Header->new(
level => $level,
stream => $stream,
);
# filename decoded from archive charset (auto-detected from OS field)
print $header->pathname, "\n";
# or override charset explicitly
print $header->pathname('cp932', 'utf-8'), "\n";
$stream->seek($header->data_top);
my $decoded = '';
my $decoder = Archive::Lha::Decode->new(
header => $header,
read => sub { $stream->read(@_) },
write => sub { $decoded .= join '', @_ },
);
my $crc = $decoder->decode;
die "crc mismatch for " . $header->pathname if $crc != $header->crc16;
$stream->seek($header->next_header);
}
=head1 DESCRIPTION
Archive::Lha reads and extracts LZH/LHA archives, the format historically
lib/Archive/Lha/Decode.pm view on Meta::CPAN
read => sub { $stream->read(@_) },
write => sub { print $fh @_ },
)
my $crc16 = $decoder->decode;
croak "crc mismatch" if $crc16 != $header->crc16;
=head1 DESCRIPTION
This is used to decode/extract an archived file from the stream. Actually this ::Decode class is a factory and decoding is done by a delegated class according to the header's "method" property.
All of the ::Decode subclasses require read/write callbacks. Read callback should take a byte length as an argument, and return the bytes of the length from a file or a string. Write callback should take a part of the decoded (probably binary) string...
=head1 METHODS
=head2 new
takes an Archive::Lha::Header object, and read/write callbacks and creates an appropriate object.
=head2 decode
does the decoding stuff and returns CRC-16 of the decoded string. The decoded string itself is passed to the write callback while decoding (step by step).
=head1 AUTHOR
Kenichi Ishigaki, E<lt>ishigaki@cpan.orgE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2007 by Kenichi Ishigaki.
This program is free software; you can redistribute it and/or
lib/Archive/Lha/Decode/LH0.pm view on Meta::CPAN
1;
__END__
=head1 NAME
Archive::Lha::Decode::LH0
=head1 DESCRIPTION
This is a lh0 decoder -- actually, as lh0 archive is not decoded, this just reads the lh0 body and writes it out.
=head1 METHODS
=head2 new
creates an object.
=head2 decode
reads the lh0 body and writes it out.
t/20_decode.t view on Meta::CPAN
while ( defined ( my $level = $stream->search_header ) ) {
my $header = Archive::Lha::Header->new(
level => $level,
stream => $stream
);
$stream->seek( $header->data_top );
my $pathname = $header->pathname;
ok $pathname !~ m{\xff}, '\xff-free';
my $decoded = '';
my $decoder = Archive::Lha::Decode->new(
header => $header,
read => sub { $stream->read(@_) },
write => sub { $decoded .= join '', @_ },
);
my $crc = $decoder->decode;
if ( $header->crc16 ) {
ok $crc == $header->crc16, "CRC: $crc / ".$header->crc16;
}
if ( defined $value ) {
ok $decoded eq $value, "decoded content matches expected for " . $header->pathname;
}
else {
ok $decoded, "decoded content non-empty for " . $header->pathname;
}
}
}
sub hex_stream {
require Archive::Lha::Stream::Hex;
Archive::Lha::Stream::Hex->new( hex => [qw(
4D 00 2D 6C 68 35 2D 12 00 00 00 26 00 00 00 16
01 60 47 20 02 81 41 4D 07 00 46 A4 03 00 00 0B
00 01 74 65 73 74 2E 74 78 74 1B 00 41 5A 30 61
t/charset.t view on Meta::CPAN
"OS '$os' -> $os_map{$os}";
}
};
subtest 'charset_for_os with no OS field' => sub {
my $obj = bless {}, 'Archive::Lha::Header::Level0';
is Archive::Lha::Header::Base::charset_for_os($obj), 'guess',
'missing OS field falls back to guess';
};
subtest 'Amiga archive: latin-1 filename decoded to UTF-8' => sub {
my $archive = "$Bin/archive/Amoric_src.lha";
plan skip_all => "Amoric_src.lha not found" unless -f $archive;
my $stream = Archive::Lha::Stream::File->new(file => $archive);
my $found;
while (defined(my $level = $stream->search_header)) {
my $header = Archive::Lha::Header->new(level => $level, stream => $stream);
$stream->seek($header->{next_header});
my $raw = $header->{filename} // $header->{pathname} // '';
if ($raw =~ /\xe7/) {
next;
}
$stream->seek( $header->data_top );
if (_is_directory($header)) {
mkpath $header->pathname unless -d $header->pathname;
$stream->seek( $header->{next_header} );
next;
}
my ($decoded, $crc) = _decode_entry($header, $stream);
$stream->seek( $header->{next_header} );
die "crc mismatch" if $crc != $header->crc16;
write_all($header->pathname, $decoded);
}
},
};
my $PROGNAME = $ENV{PLHASA} ? 'plhasa' : basename($0);
&main;exit;
sub main {
if ($PROGNAME eq 'plhasa') {
my %target = map { $_ => 1 } @targets;
my $stream = open_archive($fname);
while ( defined( my $level = $stream->search_header ) ) {
my $header = Archive::Lha::Header->new( level => $level, stream => $stream );
if (%target && !$target{$header->pathname}) {
$stream->seek( $header->{next_header} );
next;
}
next if _is_directory($header);
$stream->seek( $header->data_top );
my ($decoded) = _decode_entry($header, $stream);
$stream->seek( $header->{next_header} );
print $decoded;
}
}
sub _extract_lhasa {
my ($fname, $opts, @targets) = @_;
my %target = map { $_ => 1 } @targets;
my $stream = open_archive($fname);
while ( defined( my $level = $stream->search_header ) ) {
my $header = Archive::Lha::Header->new( level => $level, stream => $stream );
my $pathname = $header->pathname;
$pathname = File::Spec->catfile($opts->{extract_dir}, $pathname)
if $opts->{extract_dir};
if (_is_directory($header)) {
mkpath $pathname unless -d $pathname || $opts->{dry_run};
$stream->seek( $header->{next_header} );
next;
}
$stream->seek( $header->data_top );
my ($decoded, $crc) = _decode_entry($header, $stream);
$stream->seek( $header->{next_header} );
die "crc mismatch for " . $header->pathname if $crc != $header->crc16;
unless ($opts->{dry_run}) {
if (-e $pathname && !$opts->{force}) {
print STDERR "$pathname already exists, skipping (use -f to force)\n";
next;
}
write_all($pathname, $decoded);
}
printf " %s\n", $pathname if $opts->{verbose};
}
}
sub usage_lhasa {
die "plhasa -- Perl LHA tool (lhasa-compatible)\n" .
"usage: plhasa [-]{lvtxep[q{num}][finv]}[w=<dir>] archive_file [file...]\n" .
"commands: options:\n" .
" l List (terse) f Force overwrite (no prompt)\n" .
my $gid = $header->{unix_gid} // 0;
# PERMSSN(10) + sep(1) + UID/GID(%5d/%-5d = 11) + sep(1) = 23
return sprintf "%s %5d/%-5d ", $str, $uid, $gid;
}
return sprintf "%-23s", '[' . ($header->{os}[1] // 'generic') . ']';
}
sub _decode_entry {
my ($header, $stream) = @_;
return ('', 0) if _is_directory($header);
my $decoded = '';
my $decoder = Archive::Lha::Decode->new(
header => $header,
read => sub { $stream->read(@_) },
write => sub { $decoded .= join '', @_ },
);
my $crc = $decoder->decode;
return ($decoded, $crc);
}
sub open_archive {
my $fname = shift;
die "fname missing" unless $fname;
Archive::Lha::Stream::File->new(file => $fname);
}
sub write_all {
my ($fname, $data) = @_;
( run in 0.856 second using v1.01-cache-2.11-cpan-600a1bdf6e4 )