# Content.pm: Class Used for Managing the RDA Content

package RDA::Object::Content;

# $Id: Content.pm,v 1.15 2015/05/05 13:18:39 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Object/Content.pm,v 1.15 2015/05/05 13:18:39 RDA Exp $
#
# Change History
# 20150505  MSC  Improve the documentation.

=head1 NAME

RDA::Object::Content - Class Used for Managing the RDA Content

=head1 SYNOPSIS

 require RDA::Object::Content;

=head1 DESCRIPTION

The objects of the C<RDA::Object::Content> class are used to manage the RDA
content. It is a subclass of L<RDA::Object|RDA::Object>.


This package is designed to manage the RDA software configuration. It is a
subclass of L<RDA::Object|RDA::Object>.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use IO::File;
  use RDA::Text qw(get_string);
  use RDA::Object;
  use RDA::Object::Rda;
  use RDA::Object::View;
}

# Define the global public variables
use vars qw($CHK_DSC $CHK_FAM $CHK_INI $CHK_OLD $CHK_PLT $CHK_PRD $CHK_SEQ
            $CHK_SET $CHK_TAG $CHK_TGT $CHK_TYP $CHK_UID
            $RE_DC $RE_MC $RE_SC $RE_TL $RE_TM @TB_TRC %TB_TRC
            $RE_ABR $RE_CFG $RE_CHK $RE_GRP $RE_MOD $RE_SET
            $RE_TRC $RE_TST $RE_TYP
            $STRINGS $VERSION @ISA @EXPORT_OK %SDCL);
$VERSION   = sprintf('%d.%02d', q$Revision: 1.15 $ =~ /(\d+)\.(\d+)/);
@EXPORT_OK = qw($CHK_DSC $CHK_FAM $CHK_INI $CHK_OLD $CHK_PLT $CHK_PRD $CHK_SEQ
                $CHK_SET $CHK_TAG $CHK_TGT $CHK_TYP $CHK_UID
                $RE_DC $RE_MC $RE_SC $RE_TL $RE_TM @TB_TRC %TB_TRC
                $RE_ABR $RE_CFG $RE_CHK $RE_GRP $RE_MOD $RE_SET
                $RE_TRC $RE_TST $RE_TYP);
@ISA       = qw(RDA::Object Exporter);
%SDCL      = (
  als => {
    ## no critic (Interpolation)
    'getList'     => ['$[CNT]', 'get_list'],
    'getModule'   => ['$[CNT]', 'get_module'],
    'getModules'  => ['$[CNT]', 'get_modules'],
    'getPackages' => ['$[CNT]', 'get_packages'],
    'getSet'      => ['$[CNT]', 'get_set'],
    'getSets'     => ['$[CNT]', 'get_sets'],
     },
  beg => \&_begin_content,
  inc => [qw(RDA::Object)],
  met => {
    'get_abbr'     => {ret => 0},
    'get_desc'     => {ret => 0},
    'get_details'  => {ret => 0},
    'get_list'     => {ret => 0},
    'get_module'   => {ret => 0},
    'get_modules'  => {ret => 0},
    'get_packages' => {ret => 1},
    'get_offsets'  => {ret => 1},
    'get_set'      => {ret => 0},
    'get_sets'     => {ret => 0},
    },
  top => 'CNT',
  );

# Define the module patterns
$RE_DC = qr/^(([A-Z][A-Z\d]*):)?DC([a-z][a-z\d]*)$/i;
$RE_MC = qr/^(([A-Z][A-Z\d]*):)?MC([a-z][a-z\d]*)$/i;
$RE_SC = qr/^(([A-Z][A-Z\d]*):)?SC([a-z][a-z\d]*)$/i;
$RE_TL = qr/^(([A-Z][A-Z\d]*):)?TL([a-z][a-z\d]*)$/i;
$RE_TM = qr/^(([A-Z][A-Z\d]*):)?TM([a-z][a-z\d]*)$/i;

$RE_ABR = qr/^([A-Z][A-Z\d]*)_([A-Z][A-Z\d]*)/i;
$RE_CFG = qr/^(CB|MR|PR)$/;  ## no critic (Fixed)
$RE_CHK = qr/^([ADPT])$/;
$RE_GRP = qr/^[A-Z][A-Z\d]*$/;
$RE_MOD = qr/^(([A-Z][A-Z\d]*):)?([DM]C|T[LM])([a-z][a-z\d]*)$/i;
$RE_SET = qr/^([A-Z][A-Z\d]*):([A-Z][a-z\d]+_([a-z]{2,3}))$/i;
$RE_TRC = qr/^([Tt][\/:])(.*)$/;
$RE_TST = qr/^(([A-Z][A-Z\d]*):)?(T[LM])([a-z][a-z\d]*)$/i;
$RE_TYP = qr/^([DMS]C|T[LM]?)$/;

$CHK_TAG =  0;
$CHK_SEQ =  1;
$CHK_UID =  2;
$CHK_TYP =  3;
$CHK_SET =  4;
$CHK_DSC =  5;
$CHK_PRD =  6;
$CHK_PLT =  7;
$CHK_FAM =  8;
$CHK_INI =  9;
$CHK_OLD = 10;
$CHK_TGT = 11;

@TB_TRC = (q{}, 't:', 'T:', 'T:', 'T:', 'T:', 'T:', 'T:', 'T:', 'T:');
%TB_TRC = (
  't:' => 1,
  'T:' => 2,
  'T/' => 2,
  't/' => 2,
  );

# Define the global private constants
my $ALL_TYP = 'ADPT';

my $CHK_GRP = 0;
my $CHK_NAM = 1;

my $COL_ABR = 0;
my $COL_GRP = 1;
my $COL_NAM = 2;

my $COL_SEQ = 0;
my $COL_DSC = 1;

my $TOP_TAG = 0;
my $TOP_SEQ = 1;
my $TOP_GRP = 2;
my $TOP_DSC = 3;

# Define the global private variables
my @tb_inf = (
  dsc => $CHK_DSC,
  fam => $CHK_FAM,
  ini => $CHK_INI,
  old => $CHK_OLD,
  plt => $CHK_PLT,
  prd => $CHK_PRD,
  seq => $CHK_SEQ,
  set => $CHK_SET,
  tag => $CHK_TAG,
  tgt => $CHK_TGT,
  typ => $CHK_TYP,
  uid => $CHK_UID,
  );
my %tb_abr = (
  q{DC} => ['DC'],
  q{MC} => ['MC'],
  q{SC} => ['SC'],
  q{T}  => ['TL','TM'],
  q{TL} => ['TL'],
  q{TM} => ['TM'],
  q{*}  => ['DC'],
  );
my %tb_cfg = (
  convert => 'CB',
  mrc     => 'MR',
  profile => 'PR',
  );
my %tb_chk = (
  abr => \&_get_set_abr,
  dir => \&_get_set_dir,
  dsc => \&_get_set_dsc,
  grp => \&_get_set_grp,
  ini => \&_get_set_ini,
  nam => \&_get_set_nam,
  old => \&_get_set_old,
  plt => \&_get_set_plt,
  prd => \&_get_set_prd,
  seq => \&_get_set_seq,
  tgt => \&_get_set_tgt,
  typ => \&_get_set_typ,
  uid => \&_get_set_uid,
  );
my %tb_col = (
  abr => \&_get_module_abr,
  dir => \&_get_module_dir,
  dsc => \&_get_module_dsc,
  grp => \&_get_module_grp,
  nam => \&_get_module_nam,
  seq => \&_get_module_seq,
  uid => \&_get_module_uid,
  );
my %tb_fam = (
  cyg => 'Cygwin',
  vms => 'Vms',
  win => 'Cygwin,Windows',
  );
my %tb_inf = (
  family   => $CHK_FAM,
  init     => $CHK_INI,
  old      => $CHK_OLD,
  platform => $CHK_PLT,
  product  => $CHK_PRD,
  sequence => $CHK_SEQ,
  set      => $CHK_SET,
  target   => $CHK_TGT,
  title    => $CHK_DSC,
  type     => $CHK_TYP,
  );
my %tb_pat = (
  q{DC} => qr/^([A-Z][A-Z\d]*\.)?[A-Z][A-Z\d]*$/,
  q{MC} => qr/^([A-Z][A-Z\d]*\.)?[A-Z][A-Z\d]*$/,
  q{SC} => qr/^([A-Z][A-Z\d]*\.)?[A-Z][A-Z\d]*$/,
  q{T}  => qr/^([A-Z][A-Z\d]*\.)?[a-z][a-z\d]*$/,
  q{TL} => qr/^([A-Z][A-Z\d]*\.)?[a-z][a-z\d]*$/,
  q{TM} => qr/^([A-Z][A-Z\d]*\.)?[a-z][a-z\d]*$/,
  q{.}  => qr/^([A-Z][A-Z\d]*\.)?[A-Z][A-Z\d]*$/,
  q{*}  => qr/^([A-Z][A-Z\d]*\.)?[A-Za-z][A-Za-z\d]*$/,
  );
my %tb_plt = (
  aix => 'aix',
  hp  => 'hpux',
  lin => 'linux',
  mac => 'darwin',
  osf => 'dec_osf',
  sol => 'solaris',
  );
my %tb_top = (
  group    => $TOP_GRP,
  sequence => $TOP_SEQ,
  title    => $TOP_DSC,
  );
my %tb_val = (
  q{DC} => $RE_DC,
  q{MC} => $RE_MC,
  q{SC} => $RE_SC,
  q{T}  => $RE_TST,
  q{TL} => $RE_TL,
  q{TM} => $RE_TM,
  q{*}  => qr/^(([A-Z][A-Z\d]*):)?([A-Za-z][A-Za-z\d]*)$/,
  );

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

=head2 S<$h = RDA::Object::Content-E<gt>new($agent)>

The object constructor. This method enables you to specify the agent reference
as an argument.

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

=over 12

=item S<    B<'agt' > > Reference to the agent object (C,R,T)

=item S<    B<'cfg' > > Reference to the RDA software configuration (C,R,T)

=item S<    B<'lvl' > > Trace level (C,R,T)

=item S<    B<'oid' > > Agent object identifier (T)

=item S<    B<'_bad'> > Bad group hash (C,R)

=item S<    B<'_cas'> > Case sensitivity indicator (C,R,T)

=item S<    B<'_chk'> > Reference to the HCVE rule set manager (T)

=item S<    B<'_col'> > Reference to the data collection module manager (T)

=item S<    B<'_ctx'> > Reference to the context descriptions (C,R)

=item S<    B<'_def'> > Group definition hash (C,R)

=item S<    B<'_dir'> > Directory description hash (R)

=item S<    B<'_dsc'> > Module description hash (C,R)

=item S<    B<'_fct'> > Group analysis function (C,R)

=item S<    B<'_grp'> > Groups not yet analyzed (C,R)

=item S<    B<'_inf'> > Reference for getting missing object attributes (C,R)

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

=item S<    B<'_pth'> > Group paths (C,R)

=item S<    B<'_set'> > Rule set definition hash (R)

=item S<    B<'_skp'> > Files to skip (C,R)

=item S<    B<'_top'> > Top directory (C,R)

=item S<    B<'_typ'> > Object type (C,R,T)

=back

Internal keys are prefixed by an underscore.

=cut

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

  # Create the object
  $cfg = $agt->get_config;
  $slf = bless {
    agt  => $agt,
    cfg  => $cfg,
    lvl  => $agt->get_level,
    oid  => $agt->get_oid,
    _cas => $cfg->get_value('B_CASE'),
    _typ => 'T',
    }, __PACKAGE__;
  $slf->{'_chk'} = _new_chk($slf);
  $slf->{'_col'} = _new_col($slf);

  # Return a reference to it
  return $slf;
}

# Define a control object to manage the HCVE rule sets
sub _new_chk
{ my ($par) = @_;

  return bless {
    agt  => $par->{'agt'},
    cfg  => $par->{'cfg'},
    lvl  => $par->{'lvl'},
    _bad => {CVS => 0},
    _cas => $par->{'_cas'},
    _ctx => {},
    _def => {},
    _dir => {},
    _dsc => {},
    _fct => \&_analyze_chk,
    _inf => $par,
    _set => {},
    _top => $par->{'cfg'}->get_group('D_RDA_CHK'),
    _typ => 'R',
    }, __PACKAGE__;
}

# Define a control object to manage the data collection modules
sub _new_col
{ my ($par) = @_;

  return bless {
    agt  => $par->{'agt'},
    cfg  => $par->{'cfg'},
    lvl  => $par->{'lvl'},
    _bad => {CVS => 0},
    _cas => $par->{'_cas'},
    _ctx => {},
    _def => {},
    _dsc => {},
    _fct => \&_analyze_col,
    _inf => $par,
    _mod => {},
    _top => $par->{'cfg'}->get_group('D_RDA_COL'),
    _typ => 'C',
    }, __PACKAGE__;
}

=head2 S<$h-E<gt>clean($type)>

This method removes obsolete files or directory from the content directory
structure. It supports the following types:

=over 11

=item S<    B<'all'> > All content files or directories

=item S<    B<'chk'> > Rule set files or directories

=item S<    B<'col'> > Data collection files or directories

=back

=cut

sub clean
{ my ($slf, $typ) = @_;
  my ($err);

  $err = 0;
  $err += _clean($slf->{'_chk'}) if $typ eq 'all' || $typ eq 'chk';
  $err += _clean($slf->{'_col'}) if $typ eq 'all' || $typ eq 'col';
  return $err;
}

=head1 DATA COLLECTION MODULE RELATED METHODS

=head2 S<$h-E<gt>get_abbr($type,$module[,$default])>

This method returns the abbreviation of the specified module.

=cut

sub get_abbr
{ my ($slf, $typ, $mod, $dft) = @_;
  my ($tbl);

  $tbl = get_modules($slf, $typ)->{'abr'};
  return exists($tbl->{$mod}) ? $tbl->{$mod} : $dft;
}

=head2 S<$h-E<gt>get_desc($type,$module[,$default])>

This method returns the description of the specified module.

=cut

sub get_desc
{ my ($slf, $typ, $mod, $dft) = @_;
  my ($dsc);

  $slf = $slf->{'_col'};
  unless (exists($slf->{'_dsc'}->{$mod}))
  { unless (exists($slf->{'_mod'}->{$mod}))
    { # Validate the type and the module
      die get_string('BAD_TYPE')
        unless defined($typ) && exists($tb_val{$typ});
      die get_string('BAD_MODULE', $mod)
        unless $mod =~ $tb_val{$typ} && $1;

      # Analyze the group
      _select($slf, [$2]);
      return $dft unless exists($slf->{'_mod'}->{$mod})
    }
    _analyze_module($slf, $mod);
  }
  return defined($dsc = $slf->{'_dsc'}->{$mod}->[$COL_DSC]) ? $dsc : $dft;
}

=head2 S<$h-E<gt>get_list($type[,$group])>

This method returns the existing definition files as a hash reference.

It supports the following types:

=over 10

=item S<    B<'CB'> > Conversion bundle definitions

=item S<    B<'MR'> > Multi-run collection definitions

=item S<    B<'PR'> > Profile definitions

=back

=cut

sub get_list
{ my ($slf, $typ, $grp) = @_;
  my ($def, $tbl);

  # Validate the type
  return {} unless defined($typ) && $typ =~ $RE_CFG;

  # Select and examine the definitions
  $def = _select($slf->{'_col'}, _norm_groups($grp));
  $tbl = {};
  foreach my $grp (keys(%{$def}))
  { $tbl->{$grp} = $def->{$grp}->{$typ} if exists($def->{$grp}->{$typ});
  }
  return $tbl;
}

=head2 S<$h-E<gt>get_module($type,$group,$abbr[,$ext[,$dft]])>

This method returns the name of the module corresponding to the specified
abbreviation. It returns the default value when the abbreviation is not
defined.

It supports the following type restrictions:

=over 10

=item S<    B<'DC'> > Data collection modules

=item S<    B<'MC'> > Multi-run collection modules

=item S<    B<'SC'> > Start scenario modules

=item S<    B<'T' > > Tools or test modules

=item S<    B<'TL'> > Tools

=item S<    B<'TM'> > Test modules

=item S<    B<'*' > > Data collection modules, tools, or test modules

=back

=cut

sub get_module
{ my ($slf, $typ, $grp, $abr, $ext, $dft) = @_;
  my ($ctl, $def, $flg, $nam, $uid);

  # Reject paths and unsupported types
  return $abr unless $abr =~ m/^((\w+)\.)?\w+$/;
  $flg = $slf->{'_cas'};
  $abr = uc($abr) unless $flg;
  $grp = [uc($2)] if $1;
  $typ = q{*} unless defined($typ) && $typ =~ $RE_TYP;

  # Get the relevant group definitions
  $slf = $slf->{'_col'};
  $def = _select($slf, _norm_groups($grp));

  # Apply restrictions
  $uid = join(q{|}, sort keys(%{$def}));
  $ctl =
    (exists($slf->{'_ctx'}->{$typ}) && exists($slf->{'_ctx'}->{$typ}->{$uid}))
    ? $slf->{'_ctx'}->{$typ}->{$uid}
    : _get_col_ctx($slf, $typ, $uid, $def);

  # Try to resolve the abbreviation
  unless ($abr =~ $tb_pat{$flg ? $typ : q{.}})
  { $abr =~ s/\.(cfg|ctl)$//i;
    ($dft, $ext) = ($abr, q{}) unless defined($ext);
    return exists($ctl->{'fil'}->{$abr})
      ? $ctl->{'fil'}->{$abr}.$ext
      : _set_case($dft, $flg);
  }
  ($dft, $ext) = ($abr, q{}) unless defined($ext);
  return exists($ctl->{'abr'}->{$abr})
    ? $ctl->{'abr'}->{$abr}.$ext
    : _set_case($dft, $flg);
}

sub _set_case
{ my ($str, $flg) = @_;

  return $flg          ? $str :
         defined($str) ? uc($str) :
                         $str;
}

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

In a scalar context, this methods returns the list of data collection sorted
alphabetically. In a scalar context, it returns a reference to a hash
containing the path of each data collection module group.

=cut

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

  $slf = $slf->{'_col'};
  _discover_groups($slf) unless exists($slf->{'_grp'});
  return (sort keys(%{$slf->{'_pth'}})) if wantarray;
  return $slf->{'_pth'};
}

=head2 S<$h-E<gt>get_modules([$type[,$group[,$detail...]]])>

This method returns the list of existing modules present in the C<D_RDA_COL>
directory structure.

It supports the following type restrictions:

=over 10

=item S<    B<'DC'> > Data collection modules

=item S<    B<'MC'> > Multi-run collection modules

=item S<    B<'SC'> > Start scenario modules

=item S<    B<'T' > > Tools or test modules

=item S<    B<'TL'> > Tools

=item S<    B<'TM'> > Test modules

=back

In an array context, it returns the modules sorted alphabetically.

In a scalar context, it returns a hash reference. The key values are array
references, which contains requested details. It supports the following module
details:

=over 11

=item S<    B<'abr'> > Module abbreviation

=item S<    B<'dir'> > Module directory

=item S<    B<'dsc'> > Module description

=item S<    B<'grp'> > Module group

=item S<    B<'nam'> > Module name

=item S<    B<'seq'> > Module sequence

=item S<    B<'uid'> > Module identifier

=back

=cut

sub get_modules
{ my ($slf, $typ, $grp, @det) = @_;
  my ($def, $off, $tbl);

  # Validate the type
  return {} unless defined($typ) && $typ =~ $RE_TYP;

  # Get the relevant group definitions
  $slf = $slf->{'_col'};
  $def = _select($slf, _norm_groups($grp));

  # Initialize the result table
  $tbl = {};
  foreach my $lst (values(%{$def}))
  { next unless exists($lst->{$typ});
    foreach my $mod (@{$lst->{$typ}})
    { $tbl->{$mod} = [];
    }
  }
  return (sort keys(%{$tbl})) if wantarray;

  # Extract requested information
  $off = 0;
  foreach my $det (@det)
  { &{$tb_col{$det}}($tbl, $off, $slf, $def, $typ) if exists($tb_col{$det});
    ++$off;
  }

  # Return the results
  return $tbl;
}

=head2 S<$h-E<gt>get_packages($re1[,$re2[,$group...]])>

This method returns the list of packages that are satisfying the first pattern
but not the second pattern, when specified.

=cut

sub get_packages
{ my ($slf, $acc, $rej, @grp) = @_;
  my ($def, $fil, $flg, @tbl);

  if ($acc)
  { # Adjust regular expressions
    $flg = $slf->{'_cas'};
    $acc = RDA::Object::View->is_match($acc, $flg);
    $rej = RDA::Object::View->is_match($rej, $flg, 1);

    # Analyze relevant groups
    $def = _select($slf->{'_col'}, _norm_groups([@grp]));
    foreach my $grp (keys(%{$def}))
    { foreach my $itm (@{$def->{$grp}->{q{*}}})
      { $fil = $itm;
        push(@tbl, $grp.q{:}.$fil)
          if $fil =~ $acc
          && !($rej && $fil =~ $rej)
          && $fil =~ s/\.(ctl|cfg)$//i;
      }
    }
  }

  # Return identified packages
  return (sort @tbl);
}

=head2 S<$h-E<gt>get_sequence($type,$module)>

This method extracts the execution sequence and the description from the
specified module and returns them as a list.

=head2 S<RDA::Object::Content-E<gt>get_sequence($path)>

This method extracts the execution sequence and the description from the
specified file and returns them as a list.

=cut

sub get_sequence
{ my ($slf, $typ, $mod) = @_;
  my ($def, $nam);

  return _get_col_info($typ, RDA::Object::Rda->basename($typ))
    unless defined($mod);

  $slf = $slf->{'_col'};
  unless (exists($slf->{'_dsc'}->{$mod}))
  { unless (exists($slf->{'_mod'}->{$mod}))
    { # Validate the type and the module
      die get_string('BAD_TYPE')
        unless defined($typ) && exists($tb_val{$typ});
      die get_string('BAD_MODULE', $mod)
        unless $mod =~ $tb_val{$typ} && $1;

      # Analyze the group
      _select($slf, [$2]);
      return (500, q{}) unless exists($slf->{'_mod'}->{$mod})
    }
    _analyze_module($slf, $mod);
  }
  return @{$slf->{'_dsc'}->{$mod}};
}

=head1 RULE SET RELATED METHODS

=head2 S<$h-E<gt>get_details($set)>

This method returns a reference to the rule set information array, which
contains the indication of the C<sdp_diaglet> tag presence, its sequence
number, its identifier, its type, its name, its description, the related
product code, its platform restrictions, its operating system family
restrictions, its initialization package.

=head2 S<$h-E<gt>get_details($path)>

This method returns a reference to the information array if the specified file.

=cut

sub get_details
{ my ($slf, $set) = @_;
  my ($nam);

  # Treat a rule set
  if ($set =~ $RE_SET)
  { $slf = $slf->{'_chk'};
    return $slf->{'_dsc'}->{$set}
      if exists($slf->{'_dsc'}->{$set});
    _select($slf, [$1])
      unless exists($slf->{'_set'}->{$set});
    return _analyze_set($slf, $set);
  }

  # Treat a file
  $nam = RDA::Object::Rda->basename($set);
  $nam =~ s/\.xml$//i;
  return _get_chk_info($set, $nam);
}

=head2 S<$h-E<gt>get_group($path)>

This method returns the group corresponding to the specified path when
existing. Otherwise, it returns an undefined value.

=cut

sub get_group
{ my ($slf, $pth) = @_;
  my ($grp, $rec);

  $rec = _extract_top_info(
    RDA::Object::Rda->cat_file(RDA::Object::Rda->dirname($pth), 'group.xml'));
  $slf->{'_dir'}->{$grp} = $rec
    if defined($grp = $rec->[$TOP_GRP]) && ref($slf);
  return $grp;
}

=head2 S<RDA::Object::Content-E<gt>get_offsets>

This method returns the definition of the offsets used in the information
arrays.

=cut

sub get_offsets
{ return @tb_inf;
}

=head2 S<$h-E<gt>get_set($group,$abbr[,$ext,$dft])>

This method returns the name of the module corresponding to the specified
abbreviation. It returns the default value when the abbreviation is not
defined.

=cut

sub get_set
{ my ($slf, $grp, $abr, $ext, $dft) = @_;
  my ($ctl, $def, $nam, $pat, $typ, $uid);

  # Reject paths and unsupported types
  return $abr unless $abr =~ m/^((\w+)\.)?([A-Z])\w+$/;
  $grp = [uc($2)] if $1;
  $typ = $3;
  $typ = q{*} unless $typ =~ $RE_CHK;
  if ($slf->{'_cas'})
  { $pat = qr/^([A-Z][A-Z\d]*\.)?([A-Z])[a-z\d]+\_[a-z]{2,3}$/;
  }
  else
  { $pat = qr/^([A-Z][A-Z\d]*\.)?([A-Z])[A-Z\d]+\_[A-Z]{2,3}$/;
    $abr = uc($abr);
    $dft = uc($dft) if defined($dft);
  }

  # Get the relevant group definitions
  $slf = $slf->{'_chk'};
  $def = _select($slf, _norm_groups($grp));

  # Apply restrictions
  $uid = join(q{|}, sort keys(%{$def}));
  $ctl =
    (exists($slf->{'_ctx'}->{$typ}) && exists($slf->{'_ctx'}->{$typ}->{$uid}))
    ? $slf->{'_ctx'}->{$typ}->{$uid}
    : _get_chk_ctx($slf, $typ, $uid, $def);

  # Try to resolve the abbreviation
  unless ($abr =~ $pat && $2 eq $typ)
  { $abr =~ s/\.xml$//i;
    ($dft, $ext) = ($abr, q{}) unless defined($ext);
    return exists($ctl->{'fil'}->{$abr})
      ? $ctl->{'fil'}->{$abr}.$ext
      : $dft;
  }
  ($dft, $ext) = ($abr, q{}) unless defined($ext);
  return exists($ctl->{'abr'}->{$abr})
    ? $ctl->{'abr'}->{$abr}.$ext
    : $dft;
}

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

In a list context, this methods returns the list of rule set groups sorted
alphabetically. In a scalar context it returns a reference to a hash containing
the path of each rule set group.

=cut

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

  $slf = $slf->{'_chk'};
  _discover_groups($slf) unless exists($slf->{'_grp'});
  return (sort keys(%{$slf->{'_pth'}})) if wantarray;
  return $slf->{'_pth'};
}

=head2 S<$h-E<gt>get_sets([$type[,$group[,$all[,$detail...]]])>

This method returns the list of existing rule sets present in the C<D_RDA_CHK>
directory structure.

It supports the following type restrictions:

=over 10

=item S<    B<'A'> > Pre-installation rule sets (Ante)

=item S<    B<'D'> > Diaglets

=item S<    B<'P'> > Post-installation rule sets (Post)

=item S<    B<'T'> > Test rule sets

=back

In an array context, it returns the rule sets sorted alphabetically.

In a scalar context, it returns a hash reference. The key values are array
references, which contains requested details. It supports the following module
details:

=over 11

=item S<    B<'abr'> > Set abbreviation

=item S<    B<'dir'> > Set directory

=item S<    B<'dsc'> > Set description

=item S<    B<'grp'> > Set group

=item S<    B<'ini'> > Initialization package

=item S<    B<'nam'> > Set name

=item S<    B<'plt'> > Related platform

=item S<    B<'prd'> > Related product

=item S<    B<'seq'> > Set sequence

=item S<    B<'typ'> > Set type

=item S<    B<'uid'> > Set identifier

=back

=cut

sub get_sets
{ my ($slf, $typ, $grp, $all, @det) = @_;
  my ($def, $dsc, $fam, $off, $osn, $rec, $tbl);

  # Validate the type
  $typ = q{*} unless defined($typ) && $typ =~ $RE_CHK;

  # Get the relevant group definitions
  $slf = $slf->{'_chk'};
  $def = _select($slf, _norm_groups($grp));

  $tbl = {};
  if ($all)
  { foreach my $lst (values(%{$def}))
    { next unless exists($lst->{$typ});
      foreach my $set (@{$lst->{$typ}})
      { $tbl->{$set} = [];
      }
    }
  }
  else
  { $dsc = $slf->{'_dsc'};
    $fam = $slf->{'cfg'}->get_family;
    $osn = $slf->{'cfg'}->get_os;
    foreach my $lst (values(%{$def}))
    { next unless exists($lst->{$typ});
      foreach my $set (@{$lst->{$typ}})
      { # Get the rule set information on first use
        $rec = exists($dsc->{$set})
          ? $dsc->{$set}
          : _analyze_set($slf, $set);

        # Apply restriction
        if ($rec->[$CHK_PLT])
        { next unless _test_member($rec->[$CHK_PLT], $osn);
        }
        elsif ($rec->[$CHK_FAM])
        { next unless _test_member($rec->[$CHK_FAM], $fam);
        }
        $tbl->{$set} = [];
      }
    }
  }
  return (sort keys(%{$tbl})) if wantarray;

  # Extract requested information
  $off = 0;
  foreach my $det (@det)
  { &{$tb_chk{$det}}($tbl, $off, $slf, $def, $typ) if exists($tb_chk{$det});
    ++$off;
  }

  # Return the results
  return $tbl;
}

# --- Common group routines ---------------------------------------------------

# Analyze the group
sub _analyze_group
{ my ($slf, $grp, $flg) = @_;
  my ($pth);

  $slf->{'agt'}->trace(get_string('Analyze'.$slf->{'_typ'}, $grp))
    unless $slf->{'lvl'} < 20;  ## no critic (Unless)

  if (exists($slf->{'_grp'}))
  { return 0 unless exists($slf->{'_grp'}->{$grp});
    $pth = delete($slf->{'_grp'}->{$grp});
  }
  else
  { $pth = RDA::Object::Rda->cat_dir($slf->{'_top'}, $grp);
  }
  return &{$slf->{'_fct'}}($slf, $grp, $pth, $flg);
}

# Remove obsolete files and directories
sub _clean
{ my ($slf) = @_;
  my ($dir, $err, $flg, $pth, $skp);

  $err = 0;
  $flg = $slf->{'_cas'};

  # Delete obsolete groups
  $skp = _load_skip($slf, $dir = $slf->{'_top'}, $flg);
  foreach my $nam (keys(%{$skp}))
  { next unless $skp->{$nam};
    $pth = RDA::Object::Rda->cat_dir($dir, $nam);
    RDA::Object::Rda->delete_dir($pth);
    ++$err if -d $pth;
  }

  # Clean the groups
  _discover_groups($slf) unless exists($slf->{'_grp'});
  foreach my $grp (keys(%{$slf->{'_grp'}}))
  { $err += _clean_group($slf, RDA::Object::Rda->cat_dir($dir, $grp), $flg);
  }

  # Return the error count
  return $err;
}

# Clean a group
sub _clean_group
{ my ($slf, $dir, $flg) = @_;
  my ($err, $pth, $skp);

  $err = 0;
  $skp = _load_skip($slf, $dir, $flg);
  foreach my $nam (keys(%{$skp}))
  { next unless $skp->{$nam};
    $pth = RDA::Object::Rda->cat_file($dir, $nam);
    1 while unlink($pth);
    ++$err if -f $pth;
  }
  return $err;
}

# Discover all groups
sub _discover_groups
{ my ($slf) = @_;
  my ($flg, $pth, $skp, $tbl);

  $slf->{'agt'}->trace(get_string('Discover'.$slf->{'_typ'}))
    unless $slf->{'lvl'} < 20;  ## no critic (Unless)

  $flg = $slf->{'_cas'};
  $skp = _load_skip($slf, $slf->{'_top'}, $flg);
  $slf->{'_grp'} = $tbl = {};
  if (opendir(DSV, $slf->{'_top'}))
  { foreach my $nam (readdir(DSV))
    { $nam = uc($nam) unless $flg;
      $slf->{'_grp'}->{$1} = $slf->{'_pth'}->{$1} = $pth
        unless exists($skp->{$nam})  ## no critic (Unless)
            || exists($slf->{'_def'}->{$nam})
            || exists($slf->{'_bad'}->{$nam})
            || $nam !~ m/^([A-Z][A-Z\d]*)(?:\.DIR)?$/
            || !-d ($pth = RDA::Object::Rda->cat_dir($slf->{'_top'}, $1));
    }
    closedir(DSV);
  }
  return;
}

# Load the list of obsolete modules
sub _load_skip
{ my ($slf, $dir, $flg) = @_;
  my ($ifh, $skp);

  return $slf->{'_skp'}->{$dir} if exists($slf->{'_skp'}->{$dir});

  $ifh = IO::File->new;
  $skp = {CVS => 0};
  if ($ifh->open('<'.RDA::Object::Rda->cat_file($dir, 'obsolete.txt')))
  { while (<$ifh>)
    { $skp->{$flg ? $1 : uc($1)} = 1 if m/^skp:(.*?)[\n\r\s]+$/i;
    }
    $ifh->close;
  }
  return $slf->{'_skp'}->{$dir} = $skp;
}

# Normalize the group restrictions
sub _norm_groups
{ my ($grp) = @_;
  my ($ref, @bad, @tbl);

  if ($ref = ref($grp))
  { die get_string('BAD_REF') unless $ref eq 'ARRAY';
    return unless (@tbl = grep {defined($_)} @{$grp});
    die get_string('BAD_GROUPS', join(', ', @bad))
      if (@bad = grep {$_ !~ $RE_GRP} @tbl);
    return [@tbl];
  }
  return unless defined($grp);
  die get_string('BAD_GROUPS', $grp) if $grp !~ $RE_GRP;
  return [$grp];
}

# Select the relevant definitions
sub _select
{ my ($slf, $lim) = @_;
  my ($def, $tbl);

  $def = {};
  if ($lim)
  { foreach my $grp ('RDA', @{$lim})
    { next if exists($def->{$grp});

      # Analyze the group on first use
      unless (exists($slf->{'_def'}->{$grp}))
      { # Skip unexisting groups
        next if exists($slf->{'_bad'}->{$grp});

        # Black list the group in case of problems
        unless (_analyze_group($slf, $grp, 1))
        { $slf->{'_bad'}->{$grp} = 1;
          next;
        }
      }

      # Get the group definition
      $def->{$grp} = $slf->{'_def'}->{$grp};
    }
  }
  else
  { # Discover all groups when not yet done
    _discover_groups($slf) unless exists($slf->{'_grp'});

    # Analyze remaining groups
    foreach my $grp (keys(%{$slf->{'_grp'}}))
    { _analyze_group($slf, $grp, 0);
    }

    # Get all group definitions
    foreach my $grp (keys(%{$tbl = $slf->{'_def'}}))
    { $def->{$grp} = $tbl->{$grp}
    }
  }
  return $def;
}

# Test membership
sub _test_member
{ my ($lst, $str) = @_;

  foreach my $itm (split(/,/, $lst))
  { return 1 if $itm eq $str;
  }
  return 0;
}

# --- Data Collection-related routines ----------------------------------------

# Analyze a data collection group
sub _analyze_col
{ my ($slf, $grp, $dir, $new) = @_;
  my ($abr, $flg, $mod, $skp, $tbl, $typ, $uid);

  # Abort when it can not open the directory
  return 0 unless opendir(DIR, $dir);

  # Initialize the group definition
  $slf->{'_def'}->{$grp} = $tbl = {
    q{.} => $dir,
    q{*} => [],
    };
  $slf->{'_pth'}->{$grp} = $dir if $new;

  # Analyze the directory
  $mod = $slf->{'_mod'};
  $flg = $slf->{'_cas'};
  $skp = _load_skip($slf, $dir, $flg);
  foreach my $fil (sort readdir(DIR))
  { next unless -f RDA::Object::Rda->cat_file($dir, $fil);
    $fil = uc($fil) unless $flg;
    next if exists($skp->{$fil});
    push(@{$tbl->{q{*}}}, $fil);
    if ($fil =~ s/\.ctl$//i)
    { if ($fil =~ m/^([DMS]C)([a-z][a-z\d]*)$/i)
      { $typ = uc($1);
        $abr = uc($2);
        $fil = $typ.lc($2) unless $flg;
        push(@{$tbl->{$typ}}, $uid = "$grp:$fil");
        $mod->{$uid} = [$abr, $grp, $fil];
      }
      elsif ($fil =~ m/^(T[LM])([a-z][a-z\d]*)$/i)
      { $typ = uc($1);
        if ($flg)
        { $abr = lc($2);
        }
        else
        { $abr = uc($2);
          $fil = $typ.lc($2);
        }
        $uid = "$grp:$fil";
        push(@{$tbl->{'T'}},  $uid);
        push(@{$tbl->{$typ}}, $uid);
        $mod->{$uid} = [$abr, $grp, $fil];
      }
    }
    elsif ($fil =~ m/^(convert|mrc|profile)\.cfg$/i)
    { $tbl->{$tb_cfg{lc($1)}} = RDA::Object::Rda->cat_file($dir, $fil);
    }
  }
  closedir(DIR);

  # Indicate a successful completion
  return 1;
}

# Analyze a module
sub _analyze_module
{ my ($slf, $mod) = @_;
  my ($def, $nam);

  if (exists($slf->{'_mod'}->{$mod}))
  { $def = $slf->{'_mod'}->{$mod};
    $nam = $def->[$COL_NAM].'.ctl';
    $slf->{'_dsc'}->{$mod} = [_get_col_info(RDA::Object::Rda->cat_file(
      $slf->{'_pth'}->{$def->[$COL_GRP]}, $nam), $nam)];
  }
  else
  { $slf->{'_dsc'}->{$mod} = [500, undef];
  }
  return;
}

# Extract the module sequences
sub _extract_module_info
{ my ($inf, $res, $off, $slf) = @_;
  my ($tbl);

  $tbl = $slf->{'_dsc'};
  foreach my $mod (keys(%{$res}))
  { # Get the module information on first use
    _analyze_module($slf, $mod) unless exists($tbl->{$mod});

    # Store the sequence in the result record
    $res->{$mod}->[$off] = $tbl->{$mod}->[$inf];
  }
  return;
}

# Apply restrictions
sub _get_col_abbr
{ my ($slf, $typ, $def) = @_;
  my ($abr, $ctl, $flg, $grp, $fil, $lst, $tbl, $val, %abr);

  # Determine abbreviations
  $ctl = {};
  foreach my $key (keys(%{$def}))
  { $lst = $def->{$key};
    next unless exists($lst->{$typ});
    $flg = $key eq 'RDA';
    foreach my $mod (@{$lst->{$typ}})
    { ($abr, $grp, $fil) = @{$slf->{'_mod'}->{$mod}};
      $abr{$abr} = $mod if $flg;
      $ctl->{'abr'}->{$abr} = exists($ctl->{'abr'}->{$abr}) ? undef : $mod;
      $abr = $grp.q{.}.$abr;
      $ctl->{'abr'}->{$abr} = exists($ctl->{'abr'}->{$abr}) ? undef : $mod;
      $ctl->{'fil'}->{$fil} = exists($ctl->{'fil'}->{$fil}) ? undef : $mod;
      $ctl->{'rpt'}->{$mod} = $mod;
    }
  }

  # Eliminate the ambiguous files
  $tbl = $ctl->{'fil'};
  foreach my $key (keys(%{$tbl}))
  { delete($tbl->{$key}) unless defined($tbl->{$key});
  }

  # Eliminate the ambiguous abbreviations
  $tbl = $ctl->{'abr'};
  foreach my $key (reverse sort {length($a) <=> length($b)} keys(%{$tbl}))
  { if (defined($val = $tbl->{$key}))
    { $ctl->{'rpt'}->{$val} = $key;
      $ctl->{'abs'}->{$key} = $slf->{'_mod'}->{$val}->[$COL_GRP].q{.}.
                              $slf->{'_mod'}->{$val}->[$COL_ABR];
    }
    elsif (exists($abr{$key}))
    { $ctl->{'abr'}->{$key} = $val = $abr{$key};
      $ctl->{'rpt'}->{$val} = $key;
      $ctl->{'abs'}->{$key} = $slf->{'_mod'}->{$val}->[$COL_GRP].q{.}.
                              $slf->{'_mod'}->{$val}->[$COL_ABR];
    }
    else
    { delete($tbl->{$key});
    }
  }

  # Return the context description
  return $ctl;
}

# Define a new context
sub _get_col_ctx
{ my ($slf, $typ, $uid, $def) = @_;
  my ($dst, $src, $val);

  if ($typ eq q{*})
  { $dst = _get_col_abbr($slf, 'DC', $def);
    $slf->{'_ctx'}->{'T'}->{$uid} = $src = _get_col_abbr($slf, 'T',  $def);

    foreach my $oid (keys(%{$src->{'rpt'}}))
    { $dst->{'rpt'}->{$oid} = $oid;
    }

    foreach my $key ('abr', 'fil')
    { foreach my $oid (keys(%{$src->{$key}}))
      { $dst->{$key}->{$oid} = $val
          if defined($val = $src->{$key}->{$oid})
          && !exists($dst->{$key}->{$oid});
      }
    }
  }
  else
  { $dst = _get_col_abbr($slf, $typ, $def);
  }
  return $slf->{'_ctx'}->{$typ}->{$uid} = $dst;
}

# Get the module information
sub _get_col_info
{ my ($pth, $fil) = @_;
  my ($ifh, $lin, $nxt);

  # Try to extract the sequence and the description from the definition file
  $ifh = IO::File->new;
  if ($ifh->open("<$pth"))
  { if (defined($lin = $ifh->getline))
    { $lin =~ s/[\n\r]+$//;
      while ($lin =~ s/\\$// && defined($nxt = $ifh->getline))
      { $nxt =~ s/^#\s*//;
        $nxt =~ s/[\n\r]+$//;
        $lin .= $nxt;
      }
    }
    $ifh->close;
    if (defined($lin))
    { if ($lin =~ m/^\#\s*([^:]*):\s*(E?\d{3}(\/E?\d{3})?):\s*(.*?)\s*$/i)
      { return ($2, $4) if lc($1) eq lc($fil);
      }
      elsif ($lin =~ m/^\#\s*([^:]*):\s*(.*?)\s*$/i)
      { return (500, $2) if lc($1) eq lc($fil);
      }
    }
    return (500, q{});
  }

  # Return the default information
  return (500);
}

# Extract the module abbreviations
sub _get_module_abr
{ my ($res, $off, $slf, $def, $typ) = @_;
  my ($ctl, $uid);

  # Apply restrictions
  $uid = join(q{|}, sort keys(%{$def}));
  $ctl =
    (exists($slf->{'_ctx'}->{$typ}) && exists($slf->{'_ctx'}->{$typ}->{$uid}))
    ? $slf->{'_ctx'}->{$typ}->{$uid}->{'rpt'}
    : _get_col_ctx($slf, $typ, $uid, $def)->{'rpt'};

  # Add the abbreviation
  foreach my $mod (keys(%{$res}))
  { $res->{$mod}->[$off] = $ctl->{$mod};
  }
  return;
}

# Extract the module directory
sub _get_module_dir
{ my ($res, $off, $slf) = @_;
  my ($pth, $tbl);

  $pth = $slf->{'_pth'};
  $tbl = $slf->{'_mod'};
  foreach my $mod (keys(%{$res}))
  { $res->{$mod}->[$off] = $pth->{$tbl->{$mod}->[$COL_GRP]};
  }
  return;
}

# Extract the module descriptions
sub _get_module_dsc
{ _extract_module_info($COL_DSC, @_);
  return;
}

# Extract the module group
sub _get_module_grp
{ my ($res, $off, $slf) = @_;
  my ($tbl);

  $tbl = $slf->{'_mod'};
  foreach my $mod (keys(%{$res}))
  { $res->{$mod}->[$off] = $tbl->{$mod}->[$COL_GRP];
  }
  return;
}

# Extract the module name
sub _get_module_nam
{ my ($res, $off, $slf) = @_;
  my ($tbl);

  $tbl = $slf->{'_mod'};
  foreach my $mod (keys(%{$res}))
  { $res->{$mod}->[$off] = $tbl->{$mod}->[$COL_NAM];
  }
  return;
}

# Extract the module sequences
sub _get_module_seq
{ return _extract_module_info($COL_SEQ, @_);
}

# Extract the module identifier
sub _get_module_uid
{ my ($res, $off, $slf) = @_;

  foreach my $mod (keys(%{$res}))
  { $res->{$mod}->[$off] = $mod;
  }
  return;
}

# --- HCVE-related routines ---------------------------------------------------

# Analyze a HCVE group
sub _analyze_chk
{ my ($slf, $grp, $dir, $new) = @_;
  my ($flg, $set, $skp, $tbl, $typ, $uid);

  # Abort when it can not open the directory
  return 0 unless opendir(DIR, $dir);

  # Initialize the group definition
  $slf->{'_def'}->{$grp} = $tbl = {
    q{.} => $dir,
    q{*} => [],
    };
  $slf->{'_pth'}->{$grp} = $dir if $new;

  # Analyze the directory
  $set = $slf->{'_set'};
  $flg = $slf->{'_cas'};
  $skp = _load_skip($slf, $dir, $flg);
  $skp->{$flg ? 'group' : 'GROUP'} = 0;
  foreach my $fil (sort readdir(DIR))
  { next unless -f RDA::Object::Rda->cat_file($dir, $fil)
      && $fil =~ s/\.xml$//i;
    $fil = uc($fil) unless $flg;
    next if exists($skp->{$fil});
    if ($fil =~ m/^([ADPT])([a-z\d][a-z\d]*_[a-z]{2,3})$/i)
    { $typ = uc($1);
      $fil = $typ.lc($2) unless $flg;
      push(@{$tbl->{$typ}}, $uid = "$grp:$fil");
    }
    else
    { $uid = "$grp:$fil";
    }
    push(@{$tbl->{q{*}}}, $uid);
    $set->{$uid} = [$grp, $fil];
  }
  closedir(DIR);

  # Indicate a successful completion
  return 1;
}

# Analyze a rule set
sub _analyze_set
{ my ($slf, $set) = @_;
  my ($def, $dir, $grp, $nam, $rec);

  # Treat unknow set
  return $slf->{'_dsc'}->{$set} = [0, 500.500]  ## no critic (Number)
    unless exists($slf->{'_set'}->{$set});

  # Analyze a rule set
  $def = $slf->{'_set'}->{$set};
  $nam = $def->[$CHK_NAM];
  $grp = $def->[$CHK_GRP];
  $rec = _get_chk_info(RDA::Object::Rda->cat_file($slf->{'_pth'}->{$grp},
    "$nam.xml"), $nam);
  $dir = exists($slf->{'_dir'}->{$grp})
    ? $slf->{'_dir'}->{$grp}
    : _analyze_top($slf, $grp);
  $rec->[$CHK_SEQ] = sprintf('%d.%03d', $dir->[$TOP_SEQ], $rec->[$CHK_SEQ]);
  $rec->[$CHK_UID] = $set;
  return $slf->{'_dsc'}->{$set} = $rec;
}

# Analyze a rule set group
sub _analyze_top
{ my ($slf, $grp) = @_;

  return $slf->{'_dir'}->{$grp} = _extract_top_info(
    RDA::Object::Rda->cat_file($slf->{'_top'}, $grp, 'group.xml'));
}

# Extract a rule set information element
sub _extract_set_info
{ my ($inf, $res, $off, $slf) = @_;
  my ($tbl);

  $tbl = $slf->{'_dsc'};
  foreach my $set (keys(%{$res}))
  { $res->{$set}->[$off] = (exists($tbl->{$set})
      ? $tbl->{$set}
      : _analyze_set($slf, $set))->[$inf];
  }
  return;
}

# Extract rule set directory information
sub _extract_top_info
{ my ($pth) = @_;
  my ($buf, $cnt, $ifh, $rec);

  $ifh = IO::File->new;
  $rec = [0, 500];
  if ($ifh->open("<$pth"))
  { $buf = q{};
    $cnt = 10;
    while (<$ifh>)
    { $buf .= $_;
      $buf =~ s/[\n\r\s]*$/ /;
      if ($buf !~ m{<sdp_top})
      { $buf = q{};
        last unless --$cnt;
      }
      elsif ($buf =~ m{<sdp_top.*?>})
      { $buf =~ s{.*<sdp_top\s+}{};
        $rec->[0] = 1;
        while ($buf =~ s{^(\w+)\s*=\s*['"](.*?)['"]\s*}{})
        { $rec->[$tb_top{$1}] = $2 if exists($tb_top{$1});
        }
        last;
      }
    }
    $ifh->close;
  }
  return $rec;
}

# Apply restrictions
sub _get_chk_abbr
{ my ($slf, $typ, $def) = @_;
  my ($abr, $ctl, $grp, $fil, $tbl, $val);

  # Determine abbreviations
  $ctl = {};
  foreach my $lst (values(%{$def}))
  { next unless exists($lst->{$typ});
    foreach my $set (@{$lst->{$typ}})
    { ($grp, $fil) = @{$slf->{'_set'}->{$set}};
      $abr = $fil;
      $ctl->{'abr'}->{$abr} = exists($ctl->{'abr'}->{$abr}) ? undef : $set;
      $abr = $grp.q{.}.$abr;
      $ctl->{'abr'}->{$abr} = exists($ctl->{'abr'}->{$abr}) ? undef : $set;
      $ctl->{'fil'}->{$fil} = exists($ctl->{'fil'}->{$fil}) ? undef : $set;
      $ctl->{'rpt'}->{$set} = $set;
    }
  }

  # Eliminate the ambiguous files
  $tbl = $ctl->{'fil'};
  foreach my $key (keys(%{$tbl}))
  { delete($tbl->{$key}) unless defined($tbl->{$key});
  }

  # Eliminate the ambiguous abbreviations
  $tbl = $ctl->{'abr'};
  foreach my $key (reverse sort {length($a) <=> length($b)} keys(%{$tbl}))
  { if (defined($val = $tbl->{$key}))
    { $ctl->{'rpt'}->{$val} = $key;
      $ctl->{'abs'}->{$key} = $slf->{'_set'}->{$val}->[$CHK_GRP].q{.}.
                              $slf->{'_set'}->{$val}->[$CHK_NAM];
    }
    else
    { delete($tbl->{$key});
    }
  }

  # Return the context description
  return $ctl;
}

# Define a new context
sub _get_chk_ctx
{ my ($slf, $typ, $uid, $def) = @_;

  return $slf->{'_ctx'}->{$typ}->{$uid} = _get_chk_abbr($slf, $typ, $def);
}

# Get the rule set information
sub _get_chk_info
{ my ($pth, $nam) = @_;
  my ($buf, $cnt, $ifh, $rec, $val);

  $ifh = IO::File->new;
  $rec = [0, 500];
  if ($ifh->open("<$pth"))
  { # Initialize the record
    $rec->[$CHK_UID] = $rec->[$CHK_SET] = $rec->[$CHK_DSC] = $nam;
    if ($nam =~ m/^([A-Z])([a-z\d]*)_([a-z]{2,3})$/)
    { $rec->[$CHK_TYP] = $val
        unless index($ALL_TYP, $val = uc($1)) < 0;  ## no critic (Unless)
      $val = lc($3);
      $rec->[$CHK_FAM] = $tb_fam{$val} if exists($tb_fam{$val});
      $rec->[$CHK_PLT] = $tb_plt{$val} if exists($tb_plt{$val});
    }

    # Analyze the file
    $buf = q{};
    $cnt = 10;
    while (<$ifh>)
    { $buf .= $_;
      $buf =~ s/[\n\r\s]*$/ /;
      if ($buf !~ m{<sdp_diaglet})
      { $buf = q{};
        last unless --$cnt;
      }
      elsif ($buf =~ m{<sdp_diaglet.*?>})
      { $buf =~ s{.*<sdp_diaglet\s+}{};
        $rec->[0] = 1;
        while ($buf =~ s{^(\w+)\s*=\s*['"](.*?)['"]\s*}{})
        { $rec->[$tb_inf{$1}] = $2 if exists($tb_inf{$1});
        }
        last;
      }
    }
    $ifh->close;
  }
  return $rec;
}

# Extract the rule set abbreviations
sub _get_set_abr
{ my ($res, $off, $slf, $def, $typ) = @_;
  my ($ctl, $uid);

  # Apply restrictions
  $uid = join(q{|}, sort keys(%{$def}));
  $ctl =
    (exists($slf->{'_ctx'}->{$typ}) && exists($slf->{'_ctx'}->{$typ}->{$uid}))
    ? $slf->{'_ctx'}->{$typ}->{$uid}->{'rpt'}
    : _get_chk_ctx($slf, $typ, $uid, $def)->{'rpt'};

  # Add the abbreviation
  foreach my $set (keys(%{$res}))
  { $res->{$set}->[$off] = $ctl->{$set};
  }
  return;
}

# Extract the rule set directory
sub _get_set_dir
{ my ($res, $off, $slf) = @_;
  my ($pth, $tbl);

  $pth = $slf->{'_pth'};
  $tbl = $slf->{'_set'};
  foreach my $set (keys(%{$res}))
  { $res->{$set}->[$off] = $pth->{$tbl->{$set}->[$COL_GRP]};
  }
  return;
}

# Extract the rule set description
sub _get_set_dsc
{ _extract_set_info($CHK_DSC, @_);
  return;
}

# Extract the rule set group
sub _get_set_grp
{ my ($res, $off, $slf) = @_;
  my ($tbl);

  $tbl = $slf->{'_set'};
  foreach my $set (keys(%{$res}))
  { $res->{$set}->[$off] = $tbl->{$set}->[$CHK_GRP];
  }
  return;
}

# Extract the rule set initialization package
sub _get_set_ini
{ _extract_set_info($CHK_INI, @_);
  return;
}

# Extract the rule set name
sub _get_set_nam
{ my ($res, $off, $slf) = @_;
  my ($tbl);

  $tbl = $slf->{'_set'};
  foreach my $set (keys(%{$res}))
  { $res->{$set}->[$off] = $tbl->{$set}->[$CHK_NAM];
  }
  return;
}

# Extract the obsolescence indicator
sub _get_set_old
{ _extract_set_info($CHK_OLD, @_);
  return;
}

# Extract the rule set platform
sub _get_set_plt
{ _extract_set_info($CHK_PLT, @_);
  return;
}

# Extract the rule set product
sub _get_set_prd
{ _extract_set_info($CHK_PRD, @_);
  return;
}

# Extract the rule set sequence
sub _get_set_seq
{ _extract_set_info($CHK_SEQ, @_);
  return;
}

# Extract the target type
sub _get_set_tgt
{ _extract_set_info($CHK_TGT, @_);
  return;
}

# Extract the rule set type
sub _get_set_typ
{ _extract_set_info($CHK_TYP, @_);
  return;
}

# Extract the rule set identifier
sub _get_set_uid
{ my ($res, $off, $slf) = @_;

  foreach my $set (keys(%{$res}))
  { $res->{$set}->[$off] = $set;
  }
  return;
}

# --- SDCL extensions ---------------------------------------------------------

# Initialize the local report control
sub _begin_content
{ my ($pkg) = @_;

  $pkg->set_top('CNT', $pkg->get_agent->get_content);
  return;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Object::View|RDA::Object::View>,
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