view release on metacpan or  search on metacpan

tools/plha  view on Meta::CPAN

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);
    }
    return strftime("%b", @t) . " $day  " . strftime("%Y", @t);
}

# ls-style date from a header (handles both DOS and Unix timestamps)
sub _ls_stamp_header {
    my ($header) = @_;
    my $epoch = $header->{timestamp_is_unix}
        ? $header->{timestamp}
        : Archive::Lha::Header::Utils::_dostime2utime($header->{timestamp});
    return _ls_stamp($epoch);