view release on metacpan or  search on metacpan

tools/plha  view on Meta::CPAN

        while ( defined( my $level = $stream->search_header ) ) {
            my $header = Archive::Lha::Header->new(
                level  => $level,
                stream => $stream
            );
            $stream->seek( $header->{next_header} );
            print Dumper($header);
        }

    },
    l => sub {
        my $fname = shift or usage();
        my $stream = open_archive($fname);
        while ( defined( my $level = $stream->search_header ) ) {
            my $header = Archive::Lha::Header->new(
                level  => $level,
                stream => $stream
            );
            $stream->seek( $header->{next_header} );
            my $fullname = _display_name($header);
            $fullname = '' if $fullname eq '.';
            my $has_path = ($fullname =~ m{/} && !_is_directory($header));
            # l shows filename only (no path), + prefix if file has a path component
            my $name = $has_path ? (split m{/}, $fullname)[-1] : $fullname;
            $name .= '/' if _is_directory($header) && $name ne '' && $name !~ m{/$};
            my $prefix = $has_path ? '+' : ' ';
            printf "%s%s\n", $prefix, $name;
        }
    },
    v => sub {
        my $contents = '';
        my $fname = shift or usage();
        my $stream = open_archive($fname);
        my $totals = { original_size => 0, encoded_size => 0, count => 0 };
        print "Original  Packed Ratio    Date     Time    Name\n";
        print "-------- ------- ----- --------- --------  -------------\n";
        while ( defined( my $level = $stream->search_header ) ) {
            my $header = Archive::Lha::Header->new(
                level  => $level,
                stream => $stream
            );
            $stream->seek( $header->{next_header} );

            $totals->{original_size} += $header->{original_size};
            $totals->{encoded_size}  += $header->{encoded_size};
            $totals->{count}         += 1;
            printf "%8d %7d%5.1f%% %s %s  %s\n",
              $header->{original_size},
              $header->{encoded_size},
              (($header->{encoded_size} && $header->{original_size}) ? 100 * ($header->{original_size} - $header->{encoded_size}) / $header->{original_size} : 0),
              _header_date($header),
              _header_time($header),
              _display_name($header);
            printf ": %s\n", $header->{comment} if $header->{comment};
        }
        print "-------- ------- ----- --------- --------\n";
        printf "%8d %7d%5.1f%% %s %s  %s\n",
             $totals->{original_size},
             $totals->{encoded_size},
             (($totals->{encoded_size} && $totals->{original_size}) ? 100 * ($totals->{original_size} - $totals->{encoded_size}) / $totals->{original_size} : 0),
             strftime("%d-%b-%y", localtime((stat($fname))[9])),
             strftime("%T",       localtime((stat($fname))[9])),
             (sprintf(" %d files", $totals->{count}));
    },
    vv => sub {
        my $fname = shift or usage();
        my $stream = open_archive($fname);
        my $totals = { original_size => 0, encoded_size => 0, count => 0 };
        print "Original  Packed Ratio    Date     Time     Atts   Method CRC  L OS\n";
        print "-------- ------- ----- --------- -------- -------- ------ ---- -----\n";
        while ( defined( my $level = $stream->search_header ) ) {
            my $header = Archive::Lha::Header->new(
                level  => $level,
                stream => $stream
            );
            $stream->seek( $header->{next_header} );

            $totals->{original_size} += $header->{original_size};
            $totals->{encoded_size}  += $header->{encoded_size};
            $totals->{count}         += 1;

            my $name = _display_name($header);
            my $os_char = uc($header->{os}[0] // '?');
            my $hdr_level = ref($header) =~ /Level(\d)/ ? $1 : '?';

            printf "%s\n", $name;
            printf "%8d %7d%5.1f%% %s %s ----rwed  -%s- %04X %s %s\n",
              $header->{original_size},
              $header->{encoded_size},
              (($header->{encoded_size} && $header->{original_size}) ? 100 * ($header->{original_size} - $header->{encoded_size}) / $header->{original_size} : 0),
              _header_date($header),
              _header_time($header),
              $header->{method},
              $header->{crc16},
              $hdr_level,
              $os_char;
            printf ": %s\n", $header->{comment} if $header->{comment};
        }
        print "-------- ------- ----- --------- --------\n";
        printf "%8d %7d%5.1f%% %s %s  %s\n",
             $totals->{original_size},
             $totals->{encoded_size},
             (($totals->{encoded_size} && $totals->{original_size}) ? 100 * ($totals->{original_size} - $totals->{encoded_size}) / $totals->{original_size} : 0),
             strftime("%d-%b-%y", localtime((stat($fname))[9])),
             strftime("%T",       localtime((stat($fname))[9])),
             (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;
            }

tools/plha  view on Meta::CPAN

    my $totals = { original_size => 0, encoded_size => 0, count => 0 };

    if ($mode eq 'lv') {
        printf " PERMSSN    UID  GID    PACKED    SIZE  RATIO METHOD CRC     STAMP          NAME\n";
        printf "---------- ----------- ------- ------- ------ ---------- ------------ -------------\n";
    } else {
        printf " PERMSSN    UID  GID      SIZE  RATIO     STAMP           NAME\n";
        printf "---------- ----------- ------- ------ ------------ --------------------\n";
    }

    while ( defined( my $level = $stream->search_header ) ) {
        my $header = Archive::Lha::Header->new(
            level  => $level,
            stream => $stream
        );
        # Skip to next header - no need to decode for listing
        $stream->seek( $header->{next_header} );

        $totals->{original_size} += $header->{original_size};
        $totals->{encoded_size}  += $header->{encoded_size};
        $totals->{count}         += 1;

        my $stamp = _ls_stamp_header($header);
        my $name  = _display_name($header);
        $name = '' if $name eq '.';  # empty root directory
        $name .= '/' if _is_directory($header) && $name ne '' && $name !~ m{/$};
        $name = _fix_msdos_allcaps($name) if ($header->{os}[0] // '') eq 'M';
        my $prefix = _lhasa_prefix($header);
        my $ratio_str = _is_directory($header) ? '******'
            : sprintf("%5.1f%%", $header->{original_size}
                ? unpack('f', pack('f', 100 * $header->{encoded_size} / $header->{original_size})) : 100);

        if ($mode eq 'lv') {
            printf "%s%7d %7d %s -%s- %04x %s %s\n",
                $prefix,
                $header->{encoded_size},
                $header->{original_size},
                $ratio_str,
                $header->{method},
                $header->{crc16},
                $stamp,
                $name;
        } else {
            printf "%s%7d %s %s %s\n",
                $prefix,
                $header->{original_size},
                $ratio_str,
                $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(@_) },