view release on metacpan or  search on metacpan

tools/plha  view on Meta::CPAN

                $stamp,
                $name;
        }
    }

    if ($mode eq 'lv') {
        printf "---------- ----------- ------- ------- ------ ---------- ------------ -------------\n";
    } else {
        printf "---------- ----------- ------- ------ ------------ --------------------\n";
    }

    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