view release on metacpan or  search on metacpan

tools/plha  view on Meta::CPAN

use File::Basename;
use File::Path;
use Getopt::Long qw( GetOptionsFromArray );
use lib File::Spec->catfile($FindBin::Bin, '..', 'lib');

use Archive::Lha::Decode;
use Archive::Lha::Header;
use Archive::Lha::Header::Utils ();
use Archive::Lha::Stream::File;
use Carp;
use POSIX qw( strftime setlocale LC_TIME );
use Time::Moment;

# Charset options: -fc (from charset) and -tc (to charset)
my $opt_from_charset;
my $opt_to_charset;
my $opt_use_locale;

# Parse --use-locale before anything else so setlocale runs at startup
Getopt::Long::GetOptionsFromArray(\@ARGV,
    'use-locale'              => \$opt_use_locale,
    'from-charset|fc=s'      => \$opt_from_charset,
    'to-charset|tc=s'        => \$opt_to_charset,
);
setlocale(LC_TIME, 'C') unless $opt_use_locale;

# Return display name for a header, respecting -fc/-tc options.
# Without options, pathname() auto-detects from the OS field.
sub _display_name {
  my ($header) = @_;
  return $header->pathname( $opt_from_charset, $opt_to_charset // 'UTF-8' );
}

my $controller = +{
    d => 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} );
            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 : '?';