Archive-Lha
view release on metacpan or search on metacpan
(sprintf(" %d files", $totals->{count}));
},
t => sub {
my $fname = shift or usage();
printf "Testing integrity of archive '%s':\n", $fname;
my $stream = open_archive($fname);
my $totals = { original_size => 0, encoded_size => 0, count => 0 };
while ( defined( my $level = $stream->search_header ) ) {
my $header = Archive::Lha::Header->new(
level => $level,
stream => $stream
);
$stream->seek( $header->data_top );
_decode_entry($header, $stream);
$stream->seek( $header->{next_header} );
$totals->{original_size} += $header->{original_size};
$totals->{encoded_size} += $header->{encoded_size};
$totals->{count} += 1;
printf " Testing: (%8d/%8d) %s\n", $header->{original_size}, $header->{original_size}, _display_name($header);
}
my $error = undef;
if ($totals->{count}) {
if (!$error) {
printf "%d files tested, all files OK\n", $totals->{count};
}
} else {
$error = 1;
printf "No files tested.\n";
}
if ($error) {
printf "\nOperation not entirely successful\n\n";
} else {
printf "\nOperation succesful\n\n";
}
},
x => sub {
my $fname = shift or usage();
my %target;
if (@_) {
%target = map { $_ => 1 } @_;
}
my $stream = open_archive($fname);
while ( defined( my $level = $stream->search_header ) ) {
my $header = Archive::Lha::Header->new(
level => $level,
stream => $stream
);
if ( %target and !$target{$header->pathname} ) {
$stream->seek( $header->next_header );
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') {
_main_lhasa();
} else {
_main_plha();
}
}
sub _main_plha {
GetOptionsFromArray(\@ARGV,
'from-charset|fc=s' => \$opt_from_charset,
'to-charset|tc=s' => \$opt_to_charset,
'use-locale' => \$opt_use_locale,
);
my $cmd = shift @ARGV or usage();
my $file = shift @ARGV or usage();
check_magic($file);
if ( !exists $controller->{$cmd} ) {
usage("Unknown command: $cmd");
}
$controller->{$cmd}->($file, @ARGV);
}
# lhasa-compatible argument parsing:
# [-]{lvtxep[q{num}][finv]}[w=<dir>] archive_file [file...]
sub _main_lhasa {
my $arg = shift @ARGV or usage_lhasa();
$arg =~ s/^-//; # strip optional leading dash
# extract command letter (first char)
my ($cmd_char) = $arg =~ /^([lvtxep])/i or usage_lhasa();
my $flags = substr($arg, 1); # everything after command char
# parse options from flags string
my %opts = (quiet => 0, verbose => 0, force => 0, ignore_path => 0, dry_run => 0, extract_dir => undef);
while (length $flags) {
if ($flags =~ s/^q(\d*)//) {
$opts{quiet} = length($1) ? int($1) : 1;
} elsif ($flags =~ s/^w=([^\s]+)//) {
$opts{extract_dir} = $1;
} elsif ($flags =~ s/^f//) {
$opts{force} = 1;
} elsif ($flags =~ s/^i//) {
$opts{ignore_path} = 1;
} elsif ($flags =~ s/^n//) {
$opts{dry_run} = 1;
} elsif ($flags =~ s/^v//) {
$opts{verbose} = 1;
} else {
$flags = substr($flags, 1); # skip unknown flag
}
}
# also allow w=<dir> as a separate argument
if (@ARGV && $ARGV[0] =~ /^w=(.+)/) {
$opts{extract_dir} = $1;
shift @ARGV;
}
my $file = shift @ARGV or usage_lhasa();
check_magic($file);
my $cmd = lc $cmd_char;
$cmd = 'x' if $cmd eq 'e';
if ($cmd eq 'p') {
_print_to_stdout($file, \%opts, @ARGV);
} elsif ($cmd eq 'x') {
_extract_lhasa($file, \%opts, @ARGV);
} elsif ($cmd eq 'l') {
_list_lhasa($file, 'l');
} elsif ($cmd eq 'v') {
_list_lhasa($file, 'lv');
} elsif ($cmd eq 't') {
$controller->{t}->($file);
} else {
usage_lhasa();
}
}
sub _print_to_stdout {
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 );
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 =~ s{.*/}{} if $opts->{ignore_path};
if (%target && !$target{$pathname}) {
$stream->seek( $header->{next_header} );
next;
}
$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" .
" v Verbose list i Ignore directory path\n" .
" t Test file CRC in archive n Perform dry run\n" .
" x,e Extract from archive q{num} Quiet mode\n" .
" p Print to stdout from archive v Verbose\n" .
" w=<dir> Specify extract directory\n";
}
sub usage {
my ($msg) = @_;
my $text = "Usage: $0 [options] (l|v|vv|x|t|d) archive (files)\n" .
" l - list contents (LhA terse format, filename only)\n" .
" v - list archive verbose (LhA v format)\n" .
" vv - list archive full (LhA vv format)\n" .
" x - extract archive\n" .
" t - test file\n" .
" d - dump each header\n" .
" -fc, --from-charset <charset> source encoding for filenames (default: auto-detect)\n" .
" -tc, --to-charset <charset> output encoding for filenames (default: UTF-8)\n" .
" --use-locale use system locale for month names (default: English)\n";
if ($msg) {
die "$msg\n$text";
}
die $text;
}
sub _header_date {
my ($h) = @_;
return $h->{timestamp_is_unix}
? strftime("%d-%b-%y", localtime($h->{timestamp}))
: strftime("%d-%b-%y", Archive::Lha::Header::Utils::dostime_fields($h->{timestamp}));
}
sub _header_time {
my ($h) = @_;
return $h->{timestamp_is_unix}
? strftime("%T", localtime($h->{timestamp}))
: strftime("%T", Archive::Lha::Header::Utils::dostime_fields($h->{timestamp}));
}
# ls-style date from Unix epoch (stat mtime etc)
# Note: avoid %e (space-padded day) — not supported on Windows MSVC runtime.
# Use %d and strip the leading zero manually instead.
sub _ls_stamp {
my ($epoch) = @_;
my $six_months = 6 * 30 * 86400;
my @t = localtime($epoch);
my $day = sprintf "%2d", $t[3]; # space-pad day
if (abs(time - $epoch) < $six_months) {
return strftime("%b", @t) . " $day " . strftime("%H:%M", @t);
}
my $ratio = $totals->{original_size}
? unpack('f', pack('f', 100 * $totals->{encoded_size} / $totals->{original_size})) : 100;
my $stamp = _ls_stamp((stat($fname))[9]);
# PERMSSN (10) + sep (1) + UID/GID (11) + sep (1) = 23 chars for prefix
# " Total " (PERMSSN 10) + " " (sep) + "%5d files" (UID/GID 11) + " " (sep) = 23
my $file_str = $totals->{count} == 1 ? 'file ' : 'files';
my $prefix = " Total " . sprintf(" %5d %s ", $totals->{count}, $file_str);
if ($mode eq 'lv') {
printf "%s%7d %7d %5.1f%% %s\n",
$prefix,
$totals->{encoded_size},
$totals->{original_size},
$ratio,
$stamp;
} else {
printf "%s%7d %5.1f%% %s\n",
$prefix,
$totals->{original_size},
$ratio,
$stamp;
}
}
sub _is_directory { $_[0]->{method} eq 'lhd' }
# MS-DOS archives store filenames in all-caps. Lhasa detects per-file
# all-caps paths and converts to lowercase. Match that behavior.
sub _fix_msdos_allcaps {
my ($name) = @_;
return $name if $name =~ /[a-z]/; # has lowercase = not all-caps
return lc $name;
}
# Format permission/owner prefix like lhasa does
sub _lhasa_prefix {
my ($header) = @_;
if (defined $header->{unix_perm}) {
my $perm = $header->{unix_perm};
my $type = _is_directory($header) ? 'd' : '-';
my $str = $type;
for my $shift (6, 3, 0) {
my $bits = ($perm >> $shift) & 7;
$str .= ($bits & 4) ? 'r' : '-';
$str .= ($bits & 2) ? 'w' : '-';
$str .= ($bits & 1) ? 'x' : '-';
}
my $uid = $header->{unix_uid} // 0;
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) = @_;
my $dir = dirname($fname);
mkpath $dir unless -d $dir;
open my $fh, '>:raw', $fname or die $!;
binmode $fh;
print $fh $data;
close $fh;
}
sub check_magic {
my $fname = shift;
open my $fh, '<:raw', $fname or die "Cannot open $fname: $!";
binmode $fh;
my $magic;
my $chars = read($fh, $magic, 5);
my ($signature) = unpack("x2a3", $magic);
die 'Does not look like an LHa file' unless $signature eq "-lh";
# Check for truncation: last byte of a well-formed LHA archive is 0x00
seek $fh, -1, 2;
my $last_byte;
read $fh, $last_byte, 1;
if ( ord($last_byte) != 0x00 ) {
warn "WARNING: Archive may be truncated or corrupt (last byte is not 0x00)\n";
}
close $fh;
}
__END__
=encoding UTF-8
=head1 NAME
plha / plhasa - command line tool for .lzh/.lha archives
=head1 SYNOPSIS
plha [options] <command> archive.lzh [files...]
plha l archive.lzh # terse list (LhA l format)
plha v archive.lzh # verbose list (LhA v format)
plha vv archive.lzh # full verbose list (LhA vv format)
plha x archive.lzh # extract all files
plha x archive.lzh foo.txt # extract a specific file
plha t archive.lzh # test archive integrity
plha d archive.lzh # dump raw header data
# lhasa-compatible interface (via plhasa wrapper)
plhasa l archive.lzh # terse list (lhasa l format, with PERMSSN column)
plhasa v archive.lzh # verbose list (lhasa v format, with METHOD and CRC)
( run in 0.568 second using v1.01-cache-2.11-cpan-600a1bdf6e4 )