# Archive.pm: Class Used to Manage RDA Archives

package RDA::Driver::Archive;

# $Id: Archive.pm,v 1.34 2015/07/23 23:22:49 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Driver/Archive.pm,v 1.34 2015/07/23 23:22:49 RDA Exp $
#
# Change History
# 20150508  MSC  Improve the documentation.

=head1 NAME

RDA::Driver::Archive - Class Used to Manage RDA Archives

=head1 SYNOPSIS

 require RDA::Driver::Archive;

=head1 DESCRIPTION

The objects of the C<RDA::Driver::Archive> class are used to manage expanded or
zipped RDA result archives.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use File::Copy qw(copy);
  use IO::File;
  use RDA::Text qw(get_string);
  use RDA::Driver::Rda;
  use RDA::Driver::Results;
  use RDA::Object;
  use RDA::Object::Collect qw(%SUB_DIRS);
  use RDA::Object::Rda qw($CREATE $DIR_PERMS $FIL_PERMS);
}

# Define the global public variables
use vars qw($DFT_KEY $DFT_SET $RE_KEY $STRINGS $VERSION @EXPORT_OK @ISA);
$DFT_KEY   = q{00000000000000000000000000000000};
$DFT_SET   = q{-};
$RE_KEY    = qr{\A([\dA-Fa-f]{32})(\-[1-9]\d*)?\z};
$VERSION   = sprintf('%d.%02d', q$Revision: 1.34 $ =~ /(\d+)\.(\d+)/);
@EXPORT_OK = qw($DFT_KEY $DFT_SET $RE_KEY);
@ISA       = qw(Exporter);

# Define the global private constants

# Define the global private variables
my %tb_fct = (
  Cygwin  => \&_u_norm,
  Unix    => \&_u_norm,
  Vms     => \&_v_norm,
  Windows => \&_w_norm,
  );
my %tb_fil = (
  d => qr{(.*)\b(\w+_S\d{3}([A-Z][A-Z\d]{0,3})_D\.fil)\z}ims,
  e => qr{(.*)\b(\w+_S\d{3}([A-Z][A-Z\d]{0,3})_E\.fil)\z}ims,
  i => qr{(.*)\b(\w+_S\d{3}([A-Z][A-Z\d]{0,3})_I\.fil)\z}ims,
  D => qr{(.*)\b(([A-Z][A-Z\d]*_[A-Z][A-Z\d]*_)D\.fil)\z}ims,
  E => qr{(.*)\b(([A-Z][A-Z\d]*_[A-Z][A-Z\d]*_)E\.fil)\z}ims,
  I => qr{(.*)\b(([A-Z][A-Z\d]*_[A-Z][A-Z\d]*_)I\.fil)\z}ims,
  );
my %tb_old = (
  A => q{archive/},
  C => q{},
  E => q{extern/},
  M => q{mrc/},
  P => q{remote/},
  R => q{ref/},
  S => q{sample/},
  X => q{transfer/},
  );

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

=head2 S<$h = RDA::Driver::Archive-E<gt>new($agt,$pth)>

The object constructor. This method takes a reference to the agent object and
the archive path as arguments.

C<RDA::Driver::Archive> is represented by a blessed hash reference. The
following special keys are used:

=over 12

=item S<    B<'oid'>  > Object identifier (A,S)

=item S<    B<'_agt'> > Reference to the agent object (M)

=item S<    B<'_arc'> > Reference to the archive object (A,S)

=item S<    B<'_cat'> > Archive catalog (A)

=item S<    B<'_cfg'> > Reference to the RDA software configuration (M)

=item S<    B<'_ctl'> > Reference to the archive control object (A,S)

=item S<    B<'_dat'> > Service data hash (A,S)

=item S<    B<'_dft'> > Default page (S)

=item S<    B<'_dig'> > Digest salt (M)

=item S<    B<'_drv'> > Reference to the archive driver (A)

=item S<    B<'_dsc'> > RDA result set description (S)

=item S<    B<'_fam'> > Archive operating system family (M,S)

=item S<    B<'_fct'> > Normalization function (S)

=item S<    B<'_flg'> > Refresh indicator (A)

=item S<    B<'_grp'> > Result group hash (A)

=item S<    B<'_lim'> > Module limitations (S)

=item S<    B<'_map'> > Path / Archive mapping (M)

=item S<    B<'_mod'> > Module restriction hash (S)

=item S<    B<'_new'> > Newly created archives (M)

=item S<    B<'_pre'> > Path prefix (S)

=item S<    B<'_prv'> > Reference to the previous context (A)

=item S<    B<'_pth'> > Archive path (A)

=item S<    B<'_rep'> > Archive repository (M)

=item S<    B<'_rnd'> > Rendered file catalog (S)

=item S<    B<'_set'> > Result set hash (A)

=item S<    B<'_sub'> > Subdirectory names (A)

=item S<    B<'_tmp'> > Temporary directory (M,S)

=item S<    B<'_top'> > RDA result set hash (A)

=item S<    B<'_typ'> > Subdirectory types (S)

=item S<    B<'_use'> > Last use time (A)

=item S<    B<'_ver'> > Version of the current result set (S)

=item S<    B<'_xpl'> > Potential Explorer result hash (A)

=item S<    B<'_zip'> > Archives present in the package (A)

=back

Internal keys are prefixed by an underscore.

=cut

sub new
{ my ($cls, $agt, $pth, $flg) = @_;
  my ($arc, $cfg, $slf);

  # Create the master object
  $cfg = $agt->get_config;
  $slf = bless {
    oid  => q{*},
    _agt => $agt,
    _cfg => $cfg,
    _dig => [$agt->get_oid, $cfg->get_info('ver')],
    _fam => $cfg->get_family,
    _rep => {},
    }, ref($cls) || $cls;

  # When a path is specified, create the default archive object
  if (defined($pth))
  { $arc = $slf->new_archive($pth, $DFT_KEY);
    return $arc->get_current unless $flg;
  }

  # Return the object reference
  return $slf;
}

sub new_archive
{ my ($slf, $pth, $oid) = @_;
  my ($flg, $obj);

  # Create the object
  $flg = -d $pth;
  $obj = bless {
    oid  => $oid,
    _ctl => $slf,
    _dat => {},
    _drv => $flg
              ? RDA::Driver::Results->new($pth)
              : RDA::Driver::Rda->new($pth, 1),
    _flg => $flg,
    _pth => $pth,
    _set => {},
    _use => time,
    }, ref($slf);
  push(@{$slf->{'_new'}}, $oid);

  # Scan the archive and select the RDA result set
  $obj->{'_arc'} = _refresh($obj);

  # Return the object reference
  return $slf->{'_rep'}->{$oid} = $obj;
}

sub new_set
{ my ($slf, $oid, $pre, $dsc) = @_;

  # Create the object and return its reference
  return $slf->{'_set'}->{$oid} = bless {
    oid  => $slf->{'oid'}.$oid,
    _arc => $slf,
    _ctl => $slf->{'_ctl'},
    _dat => {},
    _dsc => $dsc,
    _pre => $pre,
    _rnd => {},
    }, ref($slf);
}

=head2 S<$h-E<gt>delete_object>

This method deletes the object.

=cut

sub delete_object  ## no critic (Unpack)
{ RDA::Object::dump_caller($_[0], 'Archive') if $RDA::Object::DELETE;

  # Cascade the object deletion
  if (exists($_[0]->{'_set'}))
  { for (values(%{$_[0]->{'_set'}}))
    { $_->delete_object;
    }
  }
  elsif (exists($_[0]->{'_rep'}))
  { for (values(%{$_[0]->{'_rep'}}))
    { $_->delete_object;
    }
  }

  # Delete associated temporary directory
  RDA::Object::Rda->delete_dir($_[0]->{'_tmp'}) if exists($_[0]->{'_tmp'});

  # Delete the object
  undef %{$_[0]};
  undef $_[0];
  return;
}

=head1 MASTER METHODS

=head2 S<$h-E<gt>add_archive($pth)>

This method adds a new archive.

=cut

sub add_archive
{ my ($slf, $pth) = @_;
  my ($key, $seq, $obj);

  $slf = $slf->{'_ctl'} if exists($slf->{'_ctl'});
  if (exists($slf->{'_map'}->{$pth = RDA::Object::Rda->short($pth, 1)}))
  { # Retrieve an existing archive
    $obj = $slf->{'_map'}->{$pth};
  }
  else
  { # Determine the archive key
    $seq = 0;
    ++$seq while exists($slf->{'_rep'}->{$key = _digest(join(q{:},
      'Web', @{$slf->{'_dig'}}, $pth, $seq, 'RDA'))});

    # Create the object
    $slf->{'_map'}->{$pth} = $obj = $slf->new_archive($pth, $key);
  }

  # Return a reference to the archive object
  return $obj;
}

=head2 S<$h-E<gt>expire($dur)>

This method removes archives that have not been used recently. It returns the
list of archives removed.

=cut

sub expire
{ my ($slf, $dur) = @_;
  my ($lim, $map, $obj, $rep, @del);

  $slf = $slf->{'_ctl'} if exists($slf->{'_ctl'});
  $lim = time - $dur;
  $map = $slf->{'_map'};
  $rep = $slf->{'_rep'};
  foreach my $key (keys(%{$rep}))
  { $obj = $rep->{$key};
    next if $obj->{'_use'} >= $lim || $key eq $DFT_KEY;
    delete($map->{$obj->{'_pth'}});
    delete($rep->{$key});
    $obj->delete_object;
    push(@del, $key);
  }
  delete($slf->{'_new'});
  return @del ? [@del] : undef;
}

=head2 S<$h-E<gt>get_archive($key)>

This method retrieves the specified archive.

=cut

sub get_archive
{ my ($slf, $key) = @_;

  return !defined($key)    ? _get_archive($slf, $DFT_KEY) :
         ($key eq q{-})    ? _get_archive($slf, $DFT_KEY, $key) :
         ($key =~ $RE_KEY) ? _get_archive($slf, uc($1),   $2) :
                             undef;
}

sub _get_archive
{ my ($slf, $key, $set) = @_;
  my ($cur, $obj, $tim);

  $slf = $slf->{'_ctl'} if exists($slf->{'_ctl'});

  # Identify the corresponding archive
  return unless exists($slf->{'_rep'}->{$key});
  $obj = $slf->{'_rep'}->{$key};
  for ($cur = $obj, $tim = time ;;)  ## no critic (CStyle)
  { $cur->{'_use'} = $tim;
    last unless exists($cur->{'_prv'});
    $cur = $cur->{'_prv'};
  }

  # Return the object reference
  return (!defined($set))               ? $obj :
         exists($obj->{'_set'}->{$set}) ? _get_set($obj->{'_set'}->{$set}) :
                                          undef;
}

sub _get_set
{ my ($slf) = @_;
  my ($dsc, $fam);

  unless (exists($slf->{'_ver'}))
  { $dsc = $slf->{'_dsc'};
    $slf->{'_dft'} = $dsc->{'dft'} if exists($dsc->{'dft'});
    $slf->{'_sub'} = exists($dsc->{'new'})
      ? {map {$_ => defined($SUB_DIRS{$_}) ? $SUB_DIRS{$_}.q{/} : q{}}
             keys(%SUB_DIRS)}
      : {%tb_old};
    $slf->{'_typ'} = {reverse %{$slf->{'_sub'}}};
    $slf->{'_ver'} = $dsc->{'ver'};
    if (exists($dsc->{'fam'}))
    { $slf->{'_fam'} = $fam = $dsc->{'fam'};
      eval "require RDA::Local::$fam";
    }
  }
  return $slf;
}

=head2 S<$h-E<gt>get_data($nam[,$key])>

This method returns the control data for the specified service name in the
specified result set.

=cut

sub get_data
{ my ($slf, $nam, $key) = @_;
  my ($obj);

  $slf = $slf->{'_ctl'} if exists($slf->{'_ctl'});
  return unless ($obj = $slf->get_archive($key));
  $obj->{'_dat'}->{$nam} = {oid => $obj->{'oid'}, slf => $obj}
    unless exists($obj->{'_dat'}->{$nam});
  return $obj->{'_dat'}->{$nam};
}

=head2 S<$h-E<gt>get_recent>

This method returns a reference to an array containing the identifiers of the
archives created since the last call. Otherwise, it returns an undefined value.

=cut

sub get_recent
{ my ($slf) = @_;

  $slf = $slf->{'_ctl'} if exists($slf->{'_ctl'});
  return delete($slf->{'_new'});
}

=head1 ARCHIVE METHODS

=head2 S<$h-E<gt>can_dive>

This method indicates whether subarchives can be explored.

=cut

sub can_dive
{ my ($slf) = @_;

  return exists($slf->{'_arc'}->{'_zip'}) ? $slf->{'_arc'}->{'_zip'} : undef;
}

=head2 S<$h-E<gt>can_refresh>

This method indicates whether the archive content can change.

=cut

sub can_refresh
{ return shift->{'_arc'}->{'_flg'};
}

=head2 S<$h-E<gt>can_rise>

This method indicates whether a return to a previous context is possible.

=cut

sub can_rise
{ my ($slf) = @_;

  return exists($slf->{'_arc'}->{'_prv'}) ? $slf->{'_arc'}->{'_prv'} : undef;
}

=head2 S<$h-E<gt>dive($nam)>

This method switches the context to the specified archive.

=cut

sub dive
{ my ($slf, $nam) = @_;
  my ($obj);

  $slf = $slf->{'_arc'};
  return $slf->{'oid'}
    unless $slf->{'_flg'} && exists($slf->{'_cat'}->{$nam});

  if (exists($slf->{'_det'}->{$nam}))
  { $obj = $slf->{'_det'}->{$nam};
  }
  else
  { $slf->{'_det'}->{$nam} =
    $obj = $slf->{'_ctl'}->add_archive($slf->{'_cat'}->{$nam}->[0]);
  }
  $obj->{'_prv'} = $slf;

  return $obj->{'oid'};
}

=head2 S<$h-E<gt>find_handle($sig[,$flg])>

This method returns a file handle to the specified result. When the flag is
set, it ignores the prefix.

=cut

sub find_handle
{ my ($slf, $url, $flg) = @_;
  my ($cat, $nam, $pre);

  $cat = $slf->{'_arc'}->{'_cat'};
  $pre = $flg ? q{} : get_prefix($slf);
  return (exists($cat->{$nam = $pre.$url})
       || exists($cat->{$nam = $pre.lc($url)}))
    ? $slf->{'_arc'}->{'_drv'}->find_handle($cat->{$nam}->[0],
                                            $cat->{$nam}->[1], 1)
    : undef;
}

=head2 S<$h-E<gt>get_catalog>

This method returns the list of package entries.

=cut

sub get_catalog
{ return keys(%{shift->{'_arc'}->{'_cat'}});
}

=head2 S<$h-E<gt>get_control>

This method returns a reference to the archive control object.

=cut

sub get_control
{ my ($slf) = @_;

  return exists($slf->{'_ctl'}) ? $slf->{'_ctl'} : $slf;
}

=head2 S<$h-E<gt>get_current>

This method returns a reference to the current set or to the archive object
when no set is selected.

=cut

sub get_current
{ my ($slf) = @_;

  $slf = $slf->{'_arc'};
  return (exists($slf->{'_set'}) && exists($slf->{'_set'}->{$DFT_SET}))
    ? $slf->{'_set'}->{$DFT_SET}
    : $slf;
}

=head2 S<$h-E<gt>get_extra_archives>

This method returns the list of extra archives.

=cut

sub get_extra_archives
{ my ($slf) = @_;
  my ($grp);

  $slf = $slf->{'_arc'};

  # Identify the groups on first use
  $grp = exists($slf->{'_grp'}) ? $slf->{'_grp'} : _get_groups($slf);

  # Return the archives that are not in a group
  return (grep {_chk_extra($grp, $_)} @{$slf->{'_zip'}});
}

sub _chk_extra
{ my ($grp, $nam) = @_;

  foreach my $pre (keys(%{$grp}))
  { return 0 if substr($nam, 0, $grp->{$pre}) eq $pre;
  }
  return 1;
}

=head2 S<$h-E<gt>get_extra_files([$flg])>

This method returns the list of extra files. When the flag is set, it regroups
the file per directory.

=cut

sub get_extra_files
{ my ($slf, $flg) = @_;
  my ($grp);

  $slf = $slf->{'_arc'};

  # Identify the groups on first use
  $grp = exists($slf->{'_grp'}) ? $slf->{'_grp'} : _get_groups($slf);

  # Scan the archive
  return _get_extra_groups($slf, $grp) if $flg;
  return (grep {_chk_extra($grp, $_)}
          grep {!m/\.(?:zip|rar|tar(?:\.(?:Z|[gx]z|bzip2))?|t[abg]z)$/i}
          keys(%{$slf->{'_cat'}}));
}

sub _get_extra_groups
{ my ($slf, $grp) = @_;
  my (%tbl);

  foreach my $nam (keys(%{$slf->{'_cat'}}))
  { next if $nam =~ m/\.(?:zip|rar|tar(?:\.(?:Z|[gx]z|bzip2))?|t[abg]z)$/i;
    next unless _chk_extra($grp, $nam);
    if ($nam =~ m{\A(.*)/(.*)\z}s)
    { $tbl{$1}->{$2} = $nam;
    }
    else
    { $tbl{q{}}->{$nam} = $nam;
    }
  }
  return %tbl;
}

=head2 S<$h-E<gt>get_groups>

This method returns the list of all group prefixes.

=cut

sub get_groups
{ my ($slf) = @_;

  $slf = $slf->{'_arc'};

  # Identify the groups on first use
  _get_groups($slf) unless exists($slf->{'_grp'});

  # Return the group prefixes
  return (sort {$a cmp $b} keys(%{$slf->{'_grp'}}));
}

sub _get_groups
{ my ($slf) = @_;
  my ($grp, $tbl);

  $slf->{'_grp'} = $grp = {};
  if (exists($slf->{'_top'}))
  { foreach my $key (keys(%{$tbl = $slf->{'_top'}}))
    { if ($key =~ s{diag(/[^/]+){3}/incpkg/pkg_\d+/seq_\d+/rda/$}{})
      { $grp->{$key} = length($key);
      }
      elsif (exists($tbl->{$key}->{'xpl'}))
      { $grp->{$tbl->{$key}->{'xpl'}} = length($tbl->{$key}->{'xpl'});
      }
      else
      { $grp->{$key} = length($key);
      }
    }
  }
  return $grp;
}

=head2 S<$h-E<gt>get_oid>

This method returns the archive identifier.

=cut

sub get_oid
{ return shift->{'oid'};
}

=head2 S<$h-E<gt>get_prefixes>

This method returns the list of other possible file prefixes.

=cut

sub get_prefixes
{ my ($slf) = @_;
  my ($pre);

  $slf = $slf->{'_arc'};
  return () unless exists($slf->{'_top'});
  $pre = get_prefix($slf->get_current);
  return (sort map {m{^(.*?)/?\z}s} grep {$_ ne $pre}
                   keys(%{$slf->{'_top'}}));
}

=head2 S<$h-E<gt>has_rda>

This method indicates whether the archive contains RDA results.

=cut

sub has_rda
{ return exists(shift->{'_arc'}->{'_top'});
}

=head2 S<$h-E<gt>refresh>

This method scans the archive and returns the new content sequence value.

=cut

sub refresh
{ my ($slf) = @_;

  _refresh($slf->{'_arc'}) if $slf->{'_arc'}->{'_flg'};
  return;
}

sub _refresh  ## no critic (Complex)
{ my ($slf) = @_;
  my ($obj, $rda, $sel, $set, $uid, $tbl, $top);

  # Delete existing result sets
  $set = $slf->{'_set'};
  delete($set->{$DFT_SET});
  foreach my $key (keys(%{$set}))
  { delete($set->{$key})->delete_object;
  }

  # Scan the archive
  delete($slf->{'_grp'});
  delete($slf->{'_top'});
  delete($slf->{'_xpl'});
  delete($slf->{'_zip'});
  $slf->{'_cat'} = {};
  $slf->{'_dat'} = {};
  $slf->{'_sub'} = {%tb_old};
  $slf->{'_drv'}->scan(\&_scan, $slf);

  # Select the RDA result set
  if (exists($slf->{'_top'}))
  { $top = $slf->{'_top'};

    # Examine possible Explorer results
    if (exists($slf->{'_xpl'}))
    { foreach my $xpl (sort keys(%{$tbl = $slf->{'_xpl'}}))
      { next unless exists($tbl->{$xpl}->{'rda'})
          && exists($top->{$rda = $tbl->{$xpl}->{'rda'}});
        $top->{$rda}->{'xpl'} = $xpl if exists($tbl->{$xpl}->{'extra'}) ||
          (exists($tbl->{$xpl}->{'README'}) && exists($tbl->{$xpl}->{'rev'}));
      }
    }

    # Search the best candidate
    $uid = 0;
    foreach my $pre (sort keys(%{$top}))
    { $top->{$pre}->{'set'} = $obj = $slf->new_set(--$uid, $pre, $top->{$pre});
      if (!exists($top->{$pre}->{'log'}))
      { ($slf->{'_set'}->{$DFT_SET}, $sel) = ($obj, $pre)
          unless defined($sel) && exists($top->{$sel}->{'log'});
      }
      elsif (!exists($top->{$pre}->{'end'}))
      { ($slf->{'_set'}->{$DFT_SET}, $sel) = ($obj, $pre)
          unless defined($sel) && exists($top->{$sel}->{'end'});
      }
      elsif (!exists($top->{$pre}->{'dft'}))
      { ($slf->{'_set'}->{$DFT_SET}, $sel) = ($obj, $pre)
          unless defined($sel) && exists($top->{$sel}->{'dft'});
      }
      else
      { ($slf->{'_set'}->{$DFT_SET}, $sel) = ($obj, $pre)
          unless defined($sel);
      }
    }

    # Apply the best selection
    _get_set($slf->{'_set'}->{$DFT_SET}) if defined($sel);
  }
  return $slf;
}

=head2 S<$h-E<gt>rise>

This method returns to the previous context.

=cut

sub rise
{ my ($slf) = @_;

  return exists($slf->{'_arc'}->{'_prv'})
    ? $slf->{'_arc'}->{'_prv'}->{'oid'}
    : $slf->{'_arc'}->{'oid'};
}

=head2 S<$h-E<gt>select($pre)>

This method selects the specified prefix and adapt the archive context
accordingly.

=cut

sub select  ## no critic (Builtin)
{ my ($slf, $pre) = @_;

  $slf = $slf->{'_arc'};
  return 1 unless defined($pre);
  return 2 unless exists($slf->{'_top'});
  return 3 unless exists($slf->{'_top'}->{$pre}) ||
                  exists($slf->{'_top'}->{$pre = "$pre/"});
  $slf->{'_set'}->{$DFT_SET} = _get_set($slf->{'_top'}->{$pre}->{'set'});
  return 0;
}

=head1 RESULT SET METHODS

=head2 S<$h-E<gt>find_handle($sig[,$flg])>

This method returns a file handle to the specified result. When the flag is
set, it ignores the prefix.

=head2 S<$h-E<gt>find_render($url)>

This method returns a file handle to the specified result.

=cut

sub find_render
{ my ($slf, $url) = @_;
  my ($bas, $cat, $ifh, $nam, $pre, $typ, @pth);

  $cat = $slf->{'_arc'}->{'_cat'};
  $pre = get_prefix($slf);

  # Check the file existence
  return $slf->{'_arc'}->{'_drv'}->find_handle($cat->{$nam}->[0],
                                               $cat->{$nam}->[1], 1)
    if exists($cat->{$nam = $pre.$url})
    || exists($cat->{$nam = $pre.lc($url)});

  # Check for rendering opportunity
  unless (exists($slf->{'_rnd'}->{$url}))
  { # Prevent a double conversion
    $slf->{'_rnd'}->{$url} = undef;

    # Check for known approaches
    $bas = $url;
    if ($bas =~ s/\.htm$//i)
    { return unless exists($cat->{$pre.($nam = $bas.'.txt')}) ||
                    exists($cat->{$pre.($nam = lc($bas).'.txt')}) ||
                    exists($cat->{$pre.($nam = $bas.'.dat')}) ||
                    exists($cat->{$pre.($nam = lc($bas).'.dat')});
      ($typ, $nam) = ($slf->{'_typ'}->{$1}, $2) if $nam =~ m/^(.*\/)(.*)$/;
      @pth = $slf->{'_ctl'}->{'_agt'}->submit(q{.}, 'RENDER.GEN_HTML',
        align     => 0,
        directory => RDA::Object::Rda->current_dir,
        reports   => $nam,
        set       => $slf->{'oid'},
        type      => $typ,
        verbose   => 0,
        version   => $slf->{'_ver'})->get_value('reports');
      return unless @pth;
    }
    elsif ($bas =~ m/\bRDA_(\w+).css$/i)
    { $slf->{'_ctl'}->{'_agt'}->submit(q{.}, 'RENDER.GEN_CSS',
        directory => RDA::Object::Rda->current_dir,
        force     => 1,
        set       => $slf->{'oid'},
        theme     => $1,
        verbose   => 0);
    }
    else
    { return;
    }
  }

  # Return a temporary result
  $ifh = IO::File->new;
  return $ifh->open('<'.$slf->{'_rnd'}->{$url})
    ? $ifh
    : undef;
}

=head2 S<$h-E<gt>find_report($typ,$rpt)>

This method returns a file handle to the specified report.

=cut

sub find_report
{ my ($slf, $typ, $rpt) = @_;
  my ($cat, $nam, $pre);

  $cat = $slf->{'_arc'}->{'_cat'};
  $pre = get_prefix($slf);
  $pre .= $slf->{'_sub'}->{$typ} if exists($slf->{'_sub'}->{$typ});
  return (exists($cat->{$nam = $pre.$rpt})
       || exists($cat->{$nam = $pre.lc($rpt)}))
    ? $slf->{'_arc'}->{'_drv'}->find_handle($cat->{$nam}->[0],
                                            $cat->{$nam}->[1])
    : undef;
}

=head2 S<$h-E<gt>get_family>

This method returns the operating system family where the results have been
produced.

=cut

sub get_family
{ my ($slf, $dft) = @_;

  return exists($slf->{'_fam'})
    ? $slf->{'_fam'}
    : $slf->{'_ctl'}->{'_fam'};
}

=head2 S<$h-E<gt>get_files($typ)>

This method returns the list of the module files from the specified type.

=cut

sub get_files
{ my ($slf, $typ) = @_;
  my ($lgt, $pat, $pre, $sub, @tbl);

  if ($typ eq 'XPL')
  { if (exists($slf->{'_dsc'}->{'xpl'}))
    { $lgt = length($pre = $slf->{'_dsc'}->{'xpl'});
      foreach my $nam (keys(%{$slf->{'_arc'}->{'_cat'}}))
      { next unless substr($nam, 0, $lgt) eq $pre;
        $sub = substr($nam, $lgt);
        push(@tbl, [$sub, $nam]) unless $sub =~ m/^rda\//;;
      }
    }
    return @tbl;
  }

  # Perform restricted search
  if (exists($slf->{'_dsc'}->{'new'}))
  { $typ = uc($typ);
    return _get_restricted($slf, $typ, $slf->{'_mod'})
      if exists($slf->{'_mod'});
  }
  else
  { $typ = lc($typ);
    return _get_restricted($slf, $typ, $slf->{'_lim'})
      if exists($slf->{'_lim'});
  }

  # Perform unrestricted search
  if (exists($tb_fil{$typ}))
  { $pat = $tb_fil{$typ};
    $pre = get_prefix($slf);
    foreach my $nam (keys(%{$slf->{'_arc'}->{'_cat'}}))
    { push(@tbl, $2) if $nam =~ $pat && $1 eq $pre;
    }
  }
  return @tbl;
}

sub _get_restricted
{ my ($slf, $typ, $tbl) = @_;
  my ($pat, $pre, @tbl);

  if (exists($tb_fil{$typ}))
  { $pat = $tb_fil{$typ};
    $pre = get_prefix($slf);
    foreach my $nam (keys(%{$slf->{'_arc'}->{'_cat'}}))
    { push(@tbl, $2) if $nam =~ $pat && $1 eq $pre && exists($tbl->{uc($3)});
    }
  }
  return @tbl;
}

=head2 S<$h-E<gt>get_gid($nam[,$flg[,$dft]])>

This method returns the group identifier of the file or the default value when
not found. When the flag is set, it ignores the prefix.

=cut

sub get_gid
{ my ($slf, $sig, $flg, $dft) = @_;
  my ($cat, $nam, $pre, @sta);

  # Find the catalog entry
  $cat = $slf->{'_arc'}->{'_cat'};
  $pre = $flg ? q{} : get_prefix($slf);
  return unless exists($cat->{$nam = $pre.$sig}) ||
                exists($cat->{$nam = $pre.lc($sig)});
  $cat = $cat->{$nam};

  # Extract from the file when applicable
  if ($cat->[1] eq q{} && $cat->[1] eq q{})
  { @sta = stat($cat->[0]);
    return $sta[5];
  }

  # Extract from the zip header
  return $dft;
}

=head2 S<$h-E<gt>get_oid>

This method returns the result set identifier.

=head2 S<$h-E<gt>get_os>

This method returns the name of the operating system where the results have
been produced.

=cut

sub get_os
{ my ($slf) = @_;

  return (exists($slf->{'_dsc'}) && exists($slf->{'_dsc'}->{'osn'}))
    ? $slf->{'_dsc'}->{'osn'}
    : undef;
}

=head2 S<$h-E<gt>get_prefix>

This method returns the file prefix.

=cut

sub get_prefix
{ my ($slf) = @_;

  return exists($slf->{'_pre'}) ? $slf->{'_pre'} : q{};
}

=head2 S<$h-E<gt>get_reports>

This method returns a reference to a hash associating the reports with their
corresponding archive file.

=cut

sub get_reports
{ my ($slf) = @_;
  my ($dft, $fil, $lgt, $pre, $sub, $tbl);

  $tbl = {};
  $dft = exists($slf->{'_dsc'}->{'new'}) ? q{} : 'collect';
  $lgt = length($pre = get_prefix($slf));
  foreach my $nam (keys(%{$slf->{'_arc'}->{'_cat'}}))
  { next unless substr($nam, 0, $lgt) eq $pre;
    $fil = substr($nam, $lgt);
    next unless $fil =~ m{((\w+)/)?(([A-Z][A-Z\d]*_){2}[A-Z]\w*(-\d+)?\.txt)$}i;
    $sub = $1 ? lc($2) : $dft;
    if ($sub eq 'mrc')
    { $tbl->{$3} = $fil;
    }
    elsif ($sub eq 'collect')
    { $tbl->{$3} = $fil unless exists($tbl->{$3});
    }
  }
  return $tbl;
}

=head2 S<$h-E<gt>get_size($nam[,$flg])>

This method returns the uncompressed size of the file or an undefined value
when not found. When the flag is set, it ignores the prefix.

=cut

sub get_size
{ my ($slf, $sig, $flg) = @_;
  my ($cat, $nam, $pre, @sta);

  # Find the catalog entry
  $cat = $slf->{'_arc'}->{'_cat'};
  $pre = $flg ? q{} : get_prefix($slf);
  return unless exists($cat->{$nam = $pre.$sig}) ||
                exists($cat->{$nam = $pre.lc($sig)});
  $cat = $cat->{$nam};

  # Extract from the file when applicable
  if ($cat->[1] eq q{} && $cat->[1] eq q{})
  { @sta = stat($cat->[0]);
    return $sta[7];
  }

  # Extract from the zip header
  return $cat->[3];
}

=head2 S<$h-E<gt>get_start>

This method returns the name of the start file.

=cut

sub get_start
{ my ($slf) = @_;

  # Return the start file previously found
  return $slf->{'_dft'} if exists($slf->{'_dft'});

  # Generate the index
  $slf->{'_ctl'}->{'_agt'}->submit(q{.}, 'RENDER.GEN_INDEX',
    directory => RDA::Object::Rda->current_dir,
    set       => $slf->{'oid'},
    verbose   => 0,
    version   => $slf->{'_ver'});
  return $slf->{'_dft'} = 'RDA__start.htm';
}

=head2 S<$h-E<gt>get_time($nam[,$flg])>

This method returns the last modify time of the file or an undefined value
when not found. When the flag is set, it ignores the prefix.

=cut

sub get_time
{ my ($slf, $sig, $flg) = @_;
  my ($cat, $day, $hou, $min, $mon, $nam, $pre, $sec, $tim, $yea, @sta);

  # Find the catalog entry
  $cat = $slf->{'_arc'}->{'_cat'};
  $pre = $flg ? q{} : get_prefix($slf);
  return unless exists($cat->{$nam = $pre.$sig}) ||
                exists($cat->{$nam = $pre.lc($sig)});
  $cat = $cat->{$nam};

  # Extract from the file when applicable
  if ($cat->[1] eq q{} && $cat->[1] eq q{})
  { @sta = stat($cat->[0]);
    return $sta[9];
  }

  # Decode the zip format
  ## no critic (Bit,Number)
  if (defined($tim = $cat->[2]))
  { $sec = ($tim & 0x1f) << 1;
    $min = ($tim >> 5)   & 0x3f;
    $hou = ($tim >> 11)  & 0x1f;
    $day = ($tim >> 16)  & 0x1f;
    $mon = ($tim >> 21)  & 0x0f;
    $yea = (($tim >> 25) & 0x7f) + 80;
    eval {
      require POSIX;
      ## no critic (Call)
      $tim = POSIX::mktime($sec, $min, $hou, $day, $mon, $yea, 0, 0, -1);
      };
    $tim = undef if $@;
  }
  return $tim;
}

=head2 S<$h-E<gt>get_uid($nam[,$flg[,$dft]])>

This method returns the user identifier of the file or the default value when
not found. When the flag is set, it ignores the prefix.

=cut

sub get_uid
{ my ($slf, $sig, $flg, $dft) = @_;
  my ($cat, $nam, $pre, @sta);

  # Find the catalog entry
  $cat = $slf->{'_arc'}->{'_cat'};
  $pre = $flg ? q{} : get_prefix($slf);
  return unless exists($cat->{$nam = $pre.$sig}) ||
                exists($cat->{$nam = $pre.lc($sig)});
  $cat = $cat->{$nam};

  # Extract from the file when applicable
  if ($cat->[1] eq q{} && $cat->[1] eq q{})
  { @sta = stat($cat->[0]);
    return $sta[4];
  }

  # Extract from the zip header
  return $dft;
}

=head2 S<$h-E<gt>restrict(@modules)>

This method stores the list of modules that can contribute. When called
without argument, it clears any previous restriction. It returns the object
reference.

=cut

sub restrict
{ my ($slf, @mod) = @_;
  my ($cnt);

  if (@mod)
  { $cnt = $slf->{'_ctl'}->{'_agt'}->get_content;
    $slf->{'_lim'} = {map {$_ => 1} grep {m/^[A-Z][A-Z\d]{0,3}$/} @mod};
    $slf->{'_mod'} = {map {_get_abbr($cnt, $_) => 1} @mod};
  }
  else
  { delete($slf->{'_lim'});
    delete($slf->{'_mod'});
  }

  # Return the object reference
  return $slf;
}

# Get the module abbreviation
sub _get_abbr
{ my ($cnt, $mod) = @_;
  my ($str);

  $str = $cnt->get_module('DC', undef, $mod);
  $str =~ s/^([A-Z][A-Z\d]*):DC(\w+)$/$1\_\U$2\E_/;
  return $str;
}

=head2 S<$h-E<gt>set_temp($prt)>

This method defines a temporary context for rendering results.

=cut

sub set_temp
{ my ($slf, $prt) = @_;
  my ($ctl);

  $ctl = $slf->{'_ctl'};
  $ctl->{'_tmp'} = RDA::Object::Rda->cat_dir(
    $ctl->{'_agt'}->get_collector->get_dir('W', 1), $prt)
    unless exists($ctl->{'_tmp'});

  $slf->{'_fct'} = $tb_fct{$slf->{'_ctl'}->{'_fam'}};
  return $slf->{'_tmp'} = RDA::Object::Rda->cat_dir($ctl->{'_tmp'},
    $slf->{'oid'});
}

=head1 RENDER INPUT/OUTPUT CONTROL INTERFACE

=head2 S<$h-E<gt>check_free>

This method skips free space test.

=cut

sub check_free
{ return;
}

=head2 S<$h-E<gt>copy_file($src,$dst)>

This method copies a file.

=cut

sub copy_file
{ my ($slf, $src, $dst) = @_;
  my ($pth);

  $pth = RDA::Object::Rda->cat_file($slf->{'_tmp'}, $dst);
  $slf->{'_rnd'}->{&{$slf->{'_fct'}}($dst)} = $pth
    if copy($src, $pth);
  return;
}

=head2 S<$h-E<gt>create_file($pth)>

This method creates the specified file.

=cut

sub create_file
{ my ($slf, $nam, $err) = @_;
  my ($ofh, $pth);

  $pth = RDA::Object::Rda->cat_file($slf->{'_tmp'}, $nam);
  RDA::Object::Rda->create_dir(RDA::Object::Rda->dirname($pth), $DIR_PERMS);
  $ofh = IO::File->new;
  $ofh->open($pth, $CREATE, $FIL_PERMS) or die get_string($err, $pth, $!);
    # Text:ERR_BLANK
    # Text:ERR_INDEX
    # Text:ERR_REPORT
    # Text:ERR_START
    # Text:ERR_SUB_INDEX
  $slf->{'_rnd'}->{&{$slf->{'_fct'}}($nam)} = $pth;
  binmode($ofh);
  return $ofh;
}

=head2 S<$h-E<gt>delete_file>

This method discards the file removal request.

=cut

sub delete_file
{ return;
}

=head2 S<$h-E<gt>get_default>

This method indicates which is the default report to display.

=cut

sub get_default
{ return shift->{'dsc'}->{'end'};
}

=head2 S<$h-E<gt>is_available($pth)>

This method indicates whether the corresponding file exists.

=cut

sub is_available
{ my ($slf, $nam) = @_;
  my ($cat, $dat, $pre, $txt, $url);

  $cat = $slf->{'_arc'}->{'_cat'};
  $dat = $txt = $url = &{$slf->{'_fct'}}($nam);
  $dat =~ s/\.htm$/.dat/;
  $txt =~ s/\.htm$/.txt/;
  $pre = get_prefix($slf);

  return exists($cat->{$pre.$url}) ||
         exists($cat->{$pre.lc($url)}) ||
         exists($slf->{'_rnd'}->{$url}) ||
         exists($cat->{$pre.$txt}) ||
         exists($cat->{$pre.lc($txt)}) ||
         exists($cat->{$pre.$dat}) ||
         exists($cat->{$pre.lc($dat)});
}

=head2 S<$h-E<gt>open_file($pth[,$flg])>

This method opens the specified file. When the flag is set, it returns an
undefined value instead of generating an error.

=cut

sub open_file
{ my ($slf, $nam, $flg) = @_;
  my ($ifh, $sig, $url);

  $url = &{$slf->{'_fct'}}($nam);
  if (exists($slf->{'_rnd'}->{$url}))
  { $ifh = IO::File->new;
    $ifh = undef
      unless $ifh->open('<'.$slf->{'_rnd'}->{$url});
  }
  else
  { $sig = $slf->{'_arc'}->{'_cat'}->{get_prefix($slf).$url};
    $ifh = $slf->{'_arc'}->{'_drv'}->find_handle($sig->[0], $sig->[1], 1);
  }
  return $ifh if $flg || defined($ifh);
  die get_string('ERR_OPEN', $nam);
}

=head2 S<$h-E<gt>scan_dir>

This method scans the result directory.

=cut

sub scan_dir
{ my ($slf) = @_;
  my ($pre, @all);

  $pre = get_prefix($slf);
  foreach my $nam (keys(%{$slf->{'_arc'}->{'_cat'}}))
  { push(@all, $2)
      if $nam =~ m/(.*)\b(\w+\.\w+)$/ && $1 eq $pre && lc($2) ne 'rda.log';
  }
  return @all;
}

# --- Normalization routines --------------------------------------------------

# Generate an URL for VMS
sub _v_norm
{ my ($nam) = @_;
  my (@tbl);

  push(@tbl, $1) if $nam =~ s/^([^:]*:)//;
  while ($nam =~ s/\[(.*?)\]//)
  { push(@tbl, split(/\./, $1));
  }
  push(@tbl, $nam) if length($nam);
  return join(q{/}, @tbl);
}

# Generate an URL for UNIX
sub _u_norm
{ return shift;
}

# Generate an URL for Windows
sub _w_norm
{ my ($nam) = @_;

  $nam =~ s{\\}{/}g;
  return $nam;
}

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

# Return a digest of its arguments using the Salvia algorithm
sub _digest
{ my ($str) = @_;
  my ($off, $sum, @hsh);

  ## no critic (Bit)
  $sum = $off = 0;
  $hsh[0] = $hsh[1] = $hsh[2] = $hsh[3] = 0;
  foreach my $chr (unpack('c*', $str))
  { $sum = ($sum + $hsh[$off]) % 15;
    $hsh[$off] = _rotate($chr, ($sum + $chr) % 15) ^ _rotate($hsh[$off], $sum);
    $off = ($off + 1) & 3;
  }
  return sprintf('%08X%08X%08X%08X', @hsh);
}

sub _rotate
{ my ($val, $off) = @_;

  ## no critic (Bit)
  return (($val << $off) & 0xffffffff) | (($val >> (32 - $off)) & 0xffffffff);
}

# Load the family information
sub _load_fam
{ my ($rec, $ifh) = @_;
  my ($lin);

  if (defined($ifh))
  { $lin = <$ifh>;
    $rec->{'ver'} = $1
      if $lin && $lin =~ m/Data Collection Results (\d+\.\d+)/;
    $lin = <$ifh>;
    $ifh->close;
    ($rec->{'osn'}, $rec->{'fam'}) = ($1, RDA::Object::Rda->get_family($1))
      if $lin && $lin =~ m/ OS:(\w+) /;
  }
  return;
}

# Analyze an archive entry
sub _scan
{ my ($nam, $hdr, $slf) = @_;
  my ($ifh);

  # Add the file to the catalog
  $slf->{'_cat'}->{$nam} =
    [$hdr->get_signature, $hdr->get_position,
     $hdr->get_info('mod'), $hdr->get_info('szu')];

  # Identify the platform family
  if ($nam =~ m/^(.*)\b(RDA\.log)$/i)
  { $slf->{'_top'}->{$1}->{'log'} = $2;
  }
  elsif ($nam =~ m/^(.*)\b((\w+)__start\.htm)$/i)
  { $slf->{'_top'}->{$1}->{'dft'} = $2;
    $slf->{'_top'}->{$1}->{'grp'} = $3;
  }
  elsif ($nam =~ m/^(.*)\b(collect\/(RDA_END_report)\.txt)$/i)
  { $slf->{'_top'}->{$1}->{'new'} = 1;
    $slf->{'_top'}->{$1}->{'col'} = $2;
    $slf->{'_top'}->{$1}->{'end'} = "$3.htm";
    _load_fam($slf->{'_top'}->{$1}, $hdr->get_handle)
      unless exists($slf->{'_top'}->{$1}->{'fam'});
  }
  elsif ($nam =~ m/^(.*)\bcollect\/\w+\.txt$/i)
  { $slf->{'_top'}->{$1}->{'new'} = 1;
    _load_fam($slf->{'_top'}->{$1}, $hdr->get_handle)
      unless exists($slf->{'_top'}->{$1}->{'fam'});
  }
  elsif ($nam =~ m/^(.*)\b(mrc\/(\w+_END_report)\.txt)$/i)
  { $slf->{'_top'}->{$1}->{'mrc'} = $2;
    $slf->{'_top'}->{$1}->{'end'} = "$3.htm"
      unless exists($slf->{'_top'}->{$1}->{'end'});
    _load_fam($slf->{'_top'}->{$1}, $hdr->get_handle)
      unless exists($slf->{'_top'}->{$1}->{'fam'});
  }
  elsif ($nam =~ m/^(.*)\b((\w+_END_report)\.txt)$/i)
  { $slf->{'_top'}->{$1}->{'col'} = $2;
    $slf->{'_top'}->{$1}->{'end'} = "$3.htm"
      unless exists($slf->{'_top'}->{$1}->{'end'});
    _load_fam($slf->{'_top'}->{$1}, $hdr->get_handle)
      unless exists($slf->{'_top'}->{$1}->{'fam'});
  }
  elsif ($slf->{'_flg'} && $nam =~ m/\.zip$/ && -s $slf->{'_cat'}->{$nam}->[0])
  { push(@{$slf->{'_zip'}}, $nam);
  }

  # Detect possible Explorer collections
  if ($nam =~ m/^((|.*\/)rda\/)/)
  { $slf->{'_xpl'}->{$2}->{'rda'} = $1;
  }
  elsif ($nam =~ m/^(|.*\/)README$/)
  { $slf->{'_xpl'}->{$1}->{'README'} = 1;
  }
  elsif ($nam =~ m/^(|.*\/)rev$/)
  { $slf->{'_xpl'}->{$1}->{'rev'} = 1;
  }
  elsif ($nam =~ m/^(|.*\/)extra\//)
  { $slf->{'_xpl'}->{$1}->{'extra'}++;
  }

  # Continue the scanning
  return 0;
}

1;

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Driver::Rda|RDA::Driver::Rda>,
L<RDA::Driver::Results|RDA::Driver::Results>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Collect|RDA::Object::Collect>,
L<RDA::Object::Rda|RDA::Object::Rda>,
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