# Tools.pm: RDA Tool Box

package RDA::UI::Tools;

# $Id: Tools.pm,v 1.35 2015/08/27 19:22:37 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/UI/Tools.pm,v 1.35 2015/08/27 19:22:37 RDA Exp $
#
# Change History
# 20150827  MSC  Extend the diff command.

=head1 NAME

RDA::UI::Tools - RDA Tool Box

=head1 SYNOPSIS

 <rda> <options> -XTools <command> <switches> <arg> ...

 <sdci> <options> -XTools <command> <switches> <arg> ...

=head1 DESCRIPTION

The following commands are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use IO::File;
  use RDA::Text qw(get_string);
  use RDA::Driver::Archive;
  use RDA::Driver::Diff qw(diff_files);
  use RDA::Driver::Web qw(fmt_date fmt_mode);
  use RDA::Handle::Block;
  use RDA::Object;
  use RDA::Object::Buffer;
  use RDA::Object::Index;
  use RDA::Object::Rda qw($APPEND $CREATE $FIL_PERMS);
  use RDA::Object::Type;
  use RDA::Options;
}

# Define the global public variables
use vars qw($STRINGS $VERSION @ISA);
$VERSION = sprintf('%d.%02d', q$Revision: 1.35 $ =~ /(\d+)\.(\d+)/);
@ISA     = qw(Exporter);

# Define the global private constants

# Define the global private variables
my %tb_srt = (
  n  => \&_ls_n,
  s  => \&_ls_s,
  t  => \&_ls_t,
  rn => \&_ls_rn,
  rs => \&_ls_rs,
  rt => \&_ls_rt,
  );

# Report the package version
sub Version
{ return $VERSION;
}

=for stopwords beijqstw

=head2 S<diff [-beijqstw] file1 file2>

This command compares both files line by line. It supports the following
switches:

=over 6

=item B<  -b > Ignores changes in the amount of white spaces.

=item B<  -e > Ignores end-of-line differences in file contents.

=item B<  -i > Ignores case differences in file contents.

=item B<  -j > Joins the continuation lines

=item B<  -q > Only indicates whether files differ.

=item B<  -s > Ignores simple line swabs.

=item B<  -t > Expands tabs to spaces.

=item B<  -w > Ignores all white spaces.

=back

Exit status is 0 if inputs are the same, 1 for trouble with the first file, 2
for trouble with the second file, or 3 if the files are different.

=cut

sub diff
{ my ($agt, @arg) = @_;
  my ($dst, $opt, $out, $src, $str);

  # Treat the switches
  $opt = RDA::Options::getopts('beijqstw', \@arg);
  $str = q{};
  $str .= 'b' if exists($opt->{'b'});
  $str .= 'e' if exists($opt->{'e'});
  $str .= 'i' if exists($opt->{'i'});
  $str .= 'j' if exists($opt->{'j'});
  $str .= 's' if exists($opt->{'s'});
  $str .= 't' if exists($opt->{'t'});
  $str .= 'w' if exists($opt->{'w'});
  $out = \*STDOUT unless exists($opt->{'q'});

  # Compare the files and indicate the result
  $src = shift(@arg);
  $dst = shift(@arg);
  return diff_files($src, $dst, $str, $out);
}

=for stopwords bchimnrFLN

=head2 S<file [-bchimnrFLN] file ...>

This command tries to classify each argument. It performs successively file
system tests, magic tests, and language tests. The first test that succeeds
causes the file type to be printed.

The file system tests are based on examining the return from a C<stat(2)>
system call. The program checks to see whether the file is empty, or whether
it is some sort of special file.

The magic tests are used to check if the files corresponds to particular fixed
formats. It reads the identification information from a magic file, located by
default in the F<admin/data> directory. Such a technique applies for any file
with some invariant identifier at a small fixed offset into the file.

When a file does not match any of the entries in the magic file, it is
examined to determine if it could be a text file.

The command supports the following switches:

=over 6

=item B<  -b > Does not prepend file names to output lines (brief mode).

=item B<  -c > Does a checking printout of the parsed form of the magic file.

=item B<  -h > Does not follow symbolic links.

=item B<  -i > Outputs the MIME type strings.

=item B<  -m > Specifies an alternate magic file.

=item B<  -n > Does not buffer standard output (by default).

=item B<  -r > Does not translate unprintable characters (raw mode).

=item B<  -F > Specifies the separator between the file name and its type.

=item B<  -L > Follows symbolic links (by default).

=item B<  -N > Does not pad file names (by default).

=back

=cut

sub file
{ my ($agt, @arg) = @_;
  my ($buf, $ctl, $opt, $sep, $val, @mod, @opt);

  # Treat the switches
  $opt = RDA::Options::getopts('bchim:nrF:LN', \@arg);
  $sep = exists($opt->{'F'}) ? $opt->{'F'} : q{: };

  # Load the dump directives
  $agt->get_collector if $agt->get_env('RDA_DUMP');

  # Create the identification object
  $ctl = RDA::Object::Type->new(exists($opt->{'m'})
    ? $opt->{'m'}
    : $agt->get_config->get_file('D_RDA_DAT', 'magic.txt'));
  $ctl->set_info('lnk', 0) if $opt->{'h'};

  # Treat a check request
  return $ctl->check_magic(1) ? 1 : 0 if exists($opt->{'c'});

  # Identify file types
  foreach my $arg (map {glob} @arg)
  { $buf = exists($opt->{'i'}) ? $ctl->get_mime($arg)
                               : $ctl->get_type($arg);
    unless (exists($opt->{'b'}))
    { $arg =~ s/([\000-\037])/\\sprintf('%03o', ord($1))/eg
        unless exists($opt->{'r'});
      $buf = $arg.$sep.$buf.qq{\n};
    }
    syswrite(STDOUT, $buf, length($buf));
  }

  # Indicate the completion status
  return 0;
}

=head2 S<help>

This command displays the command syntax and the related explanations.

=cut

sub help
{ return shift->submit(q{.}, 'DISPLAY.DSP_POD', package => __PACKAGE__);
}

=for stopwords cqsw md md5sum

=head2 S<md5sum [-b|-t] [-cqsw] file...>

This command prints or checks MD5 (128-bit) check sums. It supports the
following switches:

=over 6

=item B<  -b > Reads the file in binary mode (default).

=item B<  -c > Reads the MD5 check sums from the files and checks them.

=item B<  -t > Reads the file in text mode.

=back

The following options are useful only when verifying check sums:

=over 6

=item B<  -q > Does not output anything, status code shows success (quiet mode).

=item B<  -s > Does not display successfully verified file (short mode).

=item B<  -w > Warns about improperly formatted check sum lines.

=back

The check sums are computed as described in RFC 1321. When checking, the input
should be a former output of this program. The default mode is to print a line
with check sum, a character indicating input mode (C<*> for binary, space for
text), and name for each file specified as an argument.

The command requires the availability of the F<Digest::MD5> Perl package.

=head2 S<sha1sum [-b|-t] [-cqsw] file...>

This command prints or checks SHA1 (160-bit) check sums. It supports the same
switches than the C<md5sum> command.

The check sums are computed as described in FIPS-180-1.

The command requires the availability of the F<Digest::SHA> Perl package.

=cut

sub md5sum
{ return _digest('Digest::MD5', \&_get_md5, 32, @_);
}

sub sha1sum
{ return _digest('Digest::SHA', \&_get_sha1, 40, @_);  ## no critic (Numbered)
}

sub _digest  ## no critic (Complex)
{ my ($cls, $fct, $siz, $agt, @arg) = @_;
  my ($err, $opt);

  # Check the availability of the MD5 package
  eval qq{require $cls};
  $agt->abort(get_string('ERR_LOAD', $cls, $@)) if $@;

  # Treat the switches
  $opt = RDA::Options::getopts('bcqstw', \@arg);
  $opt->{'s'} = 1 if $opt->{'q'};
  $opt->{'t'} = 0 if $opt->{'b'};

  # Treat the files
  if ($opt->{'c'})
  { my ($ifh, $lin, $val);

    $ifh = IO::File->new;
    foreach my $fil (map {glob} @arg)
    { next unless -f $fil;
      if ($ifh->open("<$fil"))
      { $lin = 0;
        while (<$ifh>)
        { ++$lin;
          next if m{^\#};
          s{[\n\r\s]+$}{};
          if (m{^([\da-f]{$siz})\s([\*\s])(.*)$})
          { if (!defined($val = &{$fct}($cls, $3, $2 ne q{*})))
            { print "$3: ".get_string('DigestError', $!)."\n"
                unless $opt->{'q'};
              ++$err;
            }
            elsif ($val eq $1)
            { print "$3: ".get_string('DigestOK')."\n"
                unless $opt->{'s'};
            }
            else
            { print "$3: ".get_string('DigestFailed')."\n"
                unless $opt->{'q'};
              ++$err;
            }
          }
          elsif (m{\S})
          { ++$err;
            $agt->add_error(get_string('BAD_CHECK', $fil, $lin))
              if $opt->{'w'};
          }
        }
        $ifh->close;
      }
    }
  }
  else
  { my ($sep, $val);

    $sep = $opt->{'t'} ? q{  } : q{ *};
    foreach my $fil (map {glob} @arg)
    { next unless -f $fil;
      if (defined($val = &{$fct}($cls, $fil, $opt->{'t'})))
      { print "$val$sep$fil\n";
      }
      else
      { $agt->add_error(get_string('ERR_OPEN', $fil, $!));
        ++$err;
      }
    }
  }
  return $err ? 1 : 0;
}

sub _get_md5
{ my ($cls, $fil, $flg) = @_;
  my ($ifh, $val);

  $ifh = IO::File->new;
  return unless $ifh->open("<$fil");
  binmode($ifh) unless $flg;
  $val = $cls->new->addfile($ifh)->hexdigest;
  $ifh->close;
  return $val;
}

sub _get_sha1
{ my ($cls, $fil, $flg) = @_;
  my ($ifh, $val);

  $ifh = IO::File->new;
  return unless $ifh->open("<$fil");
  binmode($ifh) unless $flg;
  $val = $cls->new(1)->addfile($ifh)->hexdigest;
  $ifh->close;
  return $val;
}

=head2 S<tee [-a] [file...]>

This command copies its standard input to each file, and also to standard
output. It supports the following switch:

=over 6

=item B<  -a > Appends to files rather than overwrite.

=back

=cut

sub tee
{ my ($agt, @arg) = @_;
  my ($buf, $lgt, $mod, $opt, @tbl);

  # Treat the switches
  $opt = RDA::Options::getopts('a', \@arg);
  $mod = $opt->{'a'} ? $APPEND : $CREATE;

  # Determine the list of file handles
  @tbl = (\*STDOUT);
  foreach my $arg (@arg)
  { my ($ofh, $pth);

    next unless defined($pth = RDA::Object::Rda->is_path($arg));
    $ofh = IO::File->new;
    $ofh->open($pth, $mod, $FIL_PERMS) or die get_string('ERR_TEE', $pth, $!);
    push(@tbl, $ofh);
  }

  # Tee input to all file handles
  while (($lgt = sysread(STDIN, $buf, 1024)) > 0)
  { foreach my $ofh (@tbl)
    { syswrite($ofh, $buf, $lgt);
    }
  }

  # Indicate a successful completion
  return 0;
}

=head1 COMMANDS RELATED TO COLLECTED ELEMENTS

Those commands retrieves the RDA collection with the C<RPT_DIRECTORY> and
C<RPT_GROUP> settings. You must typically invoke the collected files with
their full path according to the original operating system.

They are indicating a result overview through bits in the exit code as
following:

=over 15

=item B<  Bit 0 (0x01) > One of the contributing file is not complete.

=item B<  Bit 1 (0x02) > One of the specified item does not exist.

=item B<  Bit 2 (0x04) > No result

=item B<  Bit 6 (0x40) > No RDA catalog found

=back

=for stopwords ae

=head2 S<cat [-ae] [-m module,...] [-p prefix] file ...>

This command extracts the named files from the RDA collection and concatenates
them to the standard output.

Files specified as arguments can contain wild cards. C<*> matches any string,
including the null string. C<?> matches any single character. C<[...]> matches
any one of the enclosed characters, which are taken literally. When a path
element starts with a C<.>, this character must be matched explicitly.

The command supports the following switches:

=over 6

=item B<  -a > Concatenates incomplete files also.

=item B<  -e > Reports errors.

=item B<  -m > Restricts the collection to the specified module(s).

=item B<  -p > Selects the specified file prefix(s).

=back

=cut

sub cat
{ my ($agt, @arg) = @_;
  my ($flg, $idx, $opt, $val, @mod, @opt);

  # Treat the switches
  $opt = RDA::Options::getopts('aem:p:z:', \@arg);
  $flg = exists($opt->{'e'}) ? 1 : 0;
  @mod = split(/,/, $opt->{'m'}) if exists($opt->{'m'});
  _check_zip(\@opt, $agt, $opt->{'z'}, $opt->{'p'});

  # Load the index files
  $idx = RDA::Object::Index->new($agt, @opt,
    'all' => exists($opt->{'a'}) ? 1 : 0,
    'err' => $flg,
    );
  unless ($idx->restrict(@mod)->refresh(1))
  { $agt->add_error(get_string('NO_CATALOG'));
    return 64;
  }

  # Concatenate the files
  $val = 4;
  $idx->apply({
    err => [\&_cat_error, [$agt, \$val, $flg]],
    fil => [\&_cat_file,  [$agt, \$val, $flg]],
    }, 0, @arg);

  # Indicate the completion status
  return $val;
}

sub _cat_error
{ my ($idx, $pth, $agt, $val, $flg) = @_;

  $$val |= 2;  ## no critic (Bit)
  $agt->add_error(get_string('MISSING', $pth)) if $flg;
  return
}

sub _cat_file
{ my ($idx, $pth, $cur, $agt, $val, $flg) = @_;
  my ($buf, $ifh, $lgt);

  # Get the block handle
  unless ($ifh = $idx->get_handle($cur))
  { $$val |= 2;  ## no critic (Bit)
    $agt->add_error(get_string('MISSING', $pth)) if $flg;
    return 0;
  }

  # Cat the block
  if ($ifh->is_partial)
  { $$val |= 1;  ## no critic (Bit)
    $agt->add_error(get_string('PARTIAL', $pth)) if $flg;
  }
  binmode($ifh);
  syswrite(STDOUT, $buf, $lgt) while ($lgt = $ifh->sysread($buf, 8192));
  $$val &= 3;  ## no critic (Bit)
  return 1;
}

=for stopwords aev

=head2 S<extract [-aev] [-d dir] [-m module,...] [-p prefix] [file|dir ...] >

This command extracts files or directories from the RDA collection to the
specified directory. When no files are specified, all files are extracted.

Files and directories specified as parameters can contain wild cards. C<*>
matches any string, including the null string. C<?> matches any single
character. C<[...]> matches any one of the enclosed characters, which are taken
literally. When a path element starts with a C<.>, this character must be
matched explicitly.

It converts the full path of the extracted files into paths relative to the
extraction directory.  Windows drives or resource locations are mapped by
creating extra directories.

The command supports the following switches:

=over 6

=item B<  -a > Extracts incomplete files also.

=item B<  -d > Specifies the directory to extract to (F<extract> by default).

=item B<  -e > Reports errors.

=item B<  -m > Restricts the collection to the specified module(s).

=item B<  -p > Selects the specified file prefix(s).

=item B<  -v > Sets the verbose mode.

=back

The command is partially supported for VMS platforms.

=cut

sub extract
{ my ($agt, @arg) = @_;
  my ($dst, $idx, $opt, @mod, @opt);

  # Treat the switches
  $opt = RDA::Options::getopts('ad:em:p:vz:', \@arg);
  $dst = $opt->{'d'}             if exists($opt->{'d'});
  @mod = split(/,/, $opt->{'m'}) if exists($opt->{'m'});
  _check_zip(\@opt, $agt, $opt->{'z'}, $opt->{'p'});

  # Load the index files
  $idx = RDA::Object::Index->new($agt, @opt,
    'all' => exists($opt->{'a'}) ? 1 : 0,
    'dsp' => exists($opt->{'v'}) ? $agt->get_display : $agt->is_verbose,
    'err' => exists($opt->{'e'}) ? 1 : 0,
    );
  unless ($idx->restrict(@mod)->refresh)
  { $agt->add_error(get_string('NO_CATALOG'));
    return 64;
  }

  # Extract the entries
  eval {$idx->extract($dst, @arg)};
  $agt->add_error($@) if $@;

  # Indicate the completion status
  return $idx->get_info('sta');
}

=head2 S<find [-ae] [-m mod,...] [-p prefix] [-d depth] [-n pattern] [dir ...]>

This command searches for files in the RDA collection.

The command supports the following switches:

=over 6

=item B<  -a > Reports incomplete files also.

=item B<  -d > Specifies the search depth.

=item B<  -e > Reports errors.

=item B<  -m > Restricts the collection to the specified module(s).

=item B<  -n > Specifies a base name pattern in a Perl syntax.

=item B<  -p > Selects the specified file prefix(s).

=back

=cut

sub find
{ my ($agt, @arg) = @_;
  my ($idx, $lvl, $opt, $pat, @mod, @opt);

  # Treat the switches
  $opt = RDA::Options::getopts('ad:em:n:p:z:', \@arg);
  $lvl = $1                      if exists($opt->{'d'})
                                 && $opt->{'d'} =~ m/^(\d+)$/ && $1 >= 0;
  @mod = split(/,/, $opt->{'m'}) if exists($opt->{'m'});
  $pat = $opt->{'n'}             if exists($opt->{'n'});
  _check_zip(\@opt, $agt, $opt->{'z'}, $opt->{'p'});

  # Load the index files
  $idx = RDA::Object::Index->new($agt, @opt,
    'all' => exists($opt->{'a'}) ? 1 : 0,
    'err' => exists($opt->{'e'}) ? 1 : 0,
    );
  unless ($idx->restrict(@mod)->refresh(1))
  { $agt->add_error(get_string('NO_CATALOG'));
    return 64;
  }

  # Display the matching files
  eval {
    foreach my $hit ($idx->find($pat, $lvl, @arg))
    { $hit =~ s/[\000-\037]/?/g;
      _display("$hit\n");
    }
    };
  $agt->add_error($@) if $@;

  # Indicate the completion status
  return $idx->get_info('sta');
}

=for stopwords acefhilnvHL Bn Cn Fn

=head2 S<grep [-acefhilnvHL...] [-m module,...] [-p prefix] pattern file ...>

This command searches the named files for lines containing a match to the given
pattern in Perl syntax. By default C<grep> prints the matching lines.

Files and directories specified as arguments can contain wild cards. C<*>
matches any string, including the null string. C<?> matches any single
character. C<[...]> matches any one of the enclosed characters, which are taken
literally. When a path element starts with a C<.>, this character must be
matched explicitly.

Directories are searched up to the search depth specified with the C<-d> option
or to 20 levels with the C<-R> option.

Paths can contain wild cards. C<*> matches any string, including the null
The command supports the following switches:

=over 6

=item B<  -a > Analyzes incomplete files also.

=item B<  -b > Prefixes lines with their byte offset.

=item B<  -c > Returns the match count instead of the match list.

=item B<  -d > Specifies the search depth.

=item B<  -e > Reports errors.

=item B<  -f > Stops file scanning on the first match.

=item B<  -h > Suppresses the prefixing of file names on output.

=item B<  -i > Ignores case when matching.

=item B<  -j > Joins continuation lines.

=item B<  -l > Prints only the name of the files with matching lines.

=item B<  -m > Restricts the collection to the specified module(s).

=item B<  -n > Prefixes output lines with the line number in its input file.

=item B<  -p > Selects the specified file prefix(s).

=item B<  -v > Inverts the sense of matching.

=item B<  -An> Prints E<lt>nE<gt> lines of trailing context after matching
lines.

=item B<  -Bn> Prints E<lt>nE<gt> lines of leading context before matching
lines.

=item B<  -Cn> Prints E<lt>nE<gt> lines of output context.

=item B<  -Fn> Stops file scanning after E<lt>nE<gt> matching lines.

=item B<  -H > Prints the file names for each match.

=item B<  -L > Prints only the name of the files without matching lines.

=item B<  -R > Lists subdirectories recursively (limited to 20 levels)

=back

It uses a vertical bar (|) as separator between file names, line numbers,
counters, and line details.

=cut

sub grep  ## no critic (Builtin)
{ my ($agt, @arg) = @_;
  my ($cmd, $idx, $lvl, $opt, @mod, @opt);

  # Treat the switches and the pattern
  $opt = RDA::Options::getopts('abcd:efhijlm:np:vz:A:B:C:F:HLR', \@arg);
  $cmd = q{};
  $lvl = (exists($opt->{'d'}) && $opt->{'d'} =~ m/^(\d+)$/ && $1 >= 0) ? $1 :
         $opt->{'R'}                                                   ? 20 :
                                                                         0;
  foreach my $key (qw(b c f h i j l n v H L))
  { $cmd .= $key if exists($opt->{$key});
  }
  foreach my $key (qw(A B C F))
  { $cmd .= "$key$1"    if exists($opt->{$key}) && $opt->{$key} =~ m/^(\d+)$/;
  }
  @mod = split(/,/, $opt->{'m'}) if exists($opt->{'m'});
  _check_zip(\@opt, $agt, $opt->{'z'}, $opt->{'p'});

  # Load the index files
  $idx = RDA::Object::Index->new($agt, @opt,
    'all' => exists($opt->{'a'}) ? 1 : 0,
    'err' => exists($opt->{'e'}) ? 1 : 0,
    );
  $idx->set_info('all', exists($opt->{'a'}) ? 1 : 0);
  unless ($idx->restrict(@mod)->refresh(1))
  { $agt->add_error(get_string('NO_CATALOG'));
    return 64;
  }

  # Treat all files
  eval {
    foreach my $hit ($idx->grep($cmd, $lvl, @arg))
    { _display("$hit\n");
    }
  };
  $agt->add_error($@) if $@;

  # Indicate the completion status
  return $idx->get_info('sta');
}

=for stopwords cirtuS

=head2 S<ll [-ae] [-m mod,...] [-p prefix] [-d depth|-R] [-cirtuS] [file ...]>

This command lists information about files in the RDA collection.

Files and directories specified as arguments can contain wild cards. C<*>
matches any string, including the null string. C<?> matches any single
character. C<[...]> matches any one of the enclosed characters, which are taken
literally. When a path element starts with a C<.>, this character must be
matched explicitly.

The command supports the following switches:

=over 6

=item B<  -a > Reports hidden and incomplete files also.

=item B<  -c > Displays the C<ctime>.

=item B<  -d > Specifies the search depth.

=item B<  -e > Reports errors.

=item B<  -i > Displays the index number of each file.

=item B<  -m > Restricts the collection to the specified module(s).

=item B<  -p > Selects the specified file prefix(s).

=item B<  -r > Reverse order while sorting.

=item B<  -t > Sorts by time.

=item B<  -u > Displays the access time.

=item B<  -R > Lists subdirectories recursively (limited to 20 levels)

=item B<  -S > Sorts by the file size.

=back

=cut

sub ll  ## no critic (Complex)
{ my ($agt, @arg) = @_;
  my ($buf, $fct, $idx, $ino, $lnk, $lvl, $nam, $opt, $tim, @max, @mod, @opt);

  # Treat the switches
  $opt = RDA::Options::getopts('RSacd:eim:p:rtuz:', \@arg);
  @mod = split(/,/, $opt->{'m'}) if exists($opt->{'m'});
  $lvl = (exists($opt->{'d'}) && $opt->{'d'} =~ m/^(\d+)$/ && $1 >= 0) ? $1 :
         $opt->{'R'}                                                   ? 20 :
                                                                         0;
  _check_zip(\@opt, $agt, $opt->{'z'}, $opt->{'p'});

  # Determine the display options
  $ino = $opt->{'i'};
  $tim = $opt->{'u'} ? 9 :
         $opt->{'c'} ? 11 :
                       10;

  # Determine the sort criteria
  $fct = $opt->{'t'} ? 't' :
         $opt->{'S'} ? 's' :
                       'n';
  $fct = $tb_srt{$opt->{'r'} ? "r$fct" : $fct};

  # Load the index files
  $idx = RDA::Object::Index->new($agt, @opt,
    'all' => exists($opt->{'a'}) ? 1 : 0,
    'err' => exists($opt->{'e'}) ? 1 : 0,
    );
  unless ($idx->restrict(@mod)->refresh)
  { $agt->add_error(get_string('NO_CATALOG'));
    return 64;
  }

  # Display the files
  eval {
    $buf = q{};
    foreach my $hit ($idx->ls($lvl, @arg))
    { $buf .= shift(@{$hit}).qq{\n};

      # Determine the column sizes
      @max = (0, 1, -1, -1, 0);
      foreach my $rec (@{$hit})
      { $max[0] = $rec->[2] if $rec->[2] > $max[0];
        $max[1] = $rec->[4] if $rec->[4] > $max[1];
        $max[2] = $rec->[5] if $rec->[5] > $max[2];
        $max[3] = $rec->[6] if $rec->[6] > $max[3];
        $max[4] = $rec->[8] if $rec->[8] > $max[4];
      }
      $max[0] = length($max[0]) if $ino;
      $max[1] = length(sprintf(' %d', $max[1]));
      $max[2] = length(sprintf(' %d', $max[2]));
      $max[3] = length(sprintf(' %d', $max[3]));
      $max[4] = length(sprintf(' %d', $max[4]));

      # Display the file information
      foreach my $rec (&$fct($hit, $tim))
      { $nam = $rec->[0];
        if (defined($lnk = $rec->[14]))
        { $lnk = RDA::Object::decode($1) if $lnk =~ m/^"([^"]*)"$/;
          $nam .= ' -> '.$lnk;
        }
        $nam =~ s/[\000-\037]/?/g;
        $buf .= sprintf('%*s ', $max[0], $rec->[2]) if $ino;
        $buf .= sprintf("%s%*d%*d%*d%*d%18s %s\n", fmt_mode($rec->[3]),
          $max[1], $rec->[4],
          $max[2], $rec->[5],
          $max[3], $rec->[6],
          $max[4], $rec->[8],
          fmt_date($rec->[$tim]),
          $nam);
      }
      _display($buf);
      $buf = qq{\n};
    }
    };
  $agt->add_error($@) if $@;

  # Indicate the completion status
  return $idx->get_info('sta');
}

# --- Internal routines -------------------------------------------------------

sub _add_ctl
{ my ($tbl, $agt, $pth, $pre) = @_;
  my ($ctl);

  $ctl = RDA::Driver::Archive->new($agt, $pth);
  $ctl->select($pre);
  return push(@{$tbl}, ctl => $ctl->get_current);
}

sub _check_zip
{ my ($tbl, $agt, $pth, $pre) = @_;
  my ($abs, $cfg, $cwd);

  return unless defined($pth = $agt->get_info('zip', $pth));
  $cfg = $agt->get_config;
  if ($cfg->is_absolute($pth))
  { if (-d $pth)
    { return _add_ctl($tbl, $agt, $abs, $pre)
        if -r ($abs = $cfg->cat_dir($pth));
    }
    elsif (-f $pth)
    { return _add_ctl($tbl, $agt, $abs, $pre)
        if -r ($abs = $cfg->cat_file($pth));
    }
  }
  else
  { $cwd = $cfg->get_group('D_CWD');
    if (-d ($abs = $cfg->cat_dir($cwd, $pth)) ||
        -f ($abs = $cfg->cat_file($cwd, $pth)))
    { return _add_ctl($tbl, $agt, $abs, $pre)
        if -r $abs;
    }
  }
  die get_string('BAD_ZIP', $pth);
}

sub _display
{ my ($txt) = @_;

  return syswrite(STDOUT, $txt, length($txt));
}

# Define the sort functions
sub _ls_n
{ my ($tbl) = @_;

  return (sort {$a->[0] cmp $b->[0]} @{$tbl});
}

## no critic (Reverse)
sub _ls_s
{ my ($tbl) = @_;

  return (sort {$b->[8] <=> $a->[8] || $a->[0] cmp $b->[0]} @{$tbl});
}

sub _ls_t
{ my ($tbl, $key) = @_;

  return (sort {$b->[$key] <=> $a->[$key] || $a->[0] cmp $b->[0]} @{$tbl});
}

sub _ls_rn
{ my ($tbl) = @_;

  return (sort {$b->[0] cmp $a->[0]} @{$tbl});
}

sub _ls_rs
{ my ($tbl) = @_;

  return (sort {$a->[8] <=> $b->[8] || $b->[0] cmp $a->[0]} @{$tbl});
}

sub _ls_rt
{ my ($tbl, $key) = @_;

  return (sort {$a->[$key] <=> $b->[$key] || $b->[0] cmp $a->[0]} @{$tbl});
}
## use critic

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Driver::Archive|RDA::Driver::Archive>,
L<RDA::Driver::Diff|RDA::Driver::Diff>,
L<RDA::Driver::Web|RDA::Driver::Web>,
L<RDA::Handle::Block|RDA::Handle::Block>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Buffer|RDA::Object::Buffer>,
L<RDA::Object::Index|RDA::Object::Index>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Object::Type|RDA::Object::Type>,
L<RDA::Options|RDA::Options>,
L<RDA::Request::DISPLAY|RDA::Request::DISPLAY>,
L<RDA::Text|RDA::Text>

=head1 COPYRIGHT NOTICE

Copyright (c) 2002, 2016, Oracle and/or its affiliates. All rights reserved.

=head1 TRADEMARK NOTICE

Oracle and Java are registered trademarks of Oracle and/or its
affiliates. Other names may be trademarks of their respective owners.

=cut