# PROFILE.pm: Collection Profile Command Library

package RDA::Request::PROFILE;

# $Id: PROFILE.pm,v 1.17 2015/08/30 23:44:02 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Request/PROFILE.pm,v 1.17 2015/08/30 23:44:02 RDA Exp $
#
# Change History
# 20150830  MSC  Add the PROFILE.DEFINE command.

=head1 NAME

RDA::Request::PROFILE - Collection Profile Command Library

=head1 SYNOPSIS

 require RDA::Request::PROFILE;

=head1 DESCRIPTION

The objects of the C<RDA::Request::PROFILE> class are used to manage profiles.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use IO::File;
  use RDA::Text qw(get_string);
  use RDA::Agent;
  use RDA::Error;
  use RDA::Handle::Data;
  use RDA::Object;
  use RDA::Object::Content qw($RE_DC @TB_TRC %TB_TRC);
  use RDA::Object::Item qw(decode_value encode_value);
  use RDA::Object::Message;
  use RDA::Object::Rda;
}

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

# Define the global private constants
my $DFT_PRF = 'Default';

my $RPT_EOT = qq{\n.N1\n};
my $RPT_NXT = qq{.N1\n};
my $RPT_SUB = qq{    \001  };
my $RPT_TXT = q{    };

my $MOD = q{(\w+\:)?\w+(\-\w+)*};

# Define the global private variables
my %tb_cmd = (
  'PROFILE.CHECK'   => \&_do_check,
  'PROFILE.DEFINE'  => \&_do_define,
  'PROFILE.DISPLAY' => \&_do_display,
  'PROFILE.LIST'    => \&_do_list,
  'PROFILE.PREVIEW' => \&_do_preview,
  'PROFILE.XREF'    => \&_do_xref,
  );

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

=head2 S<$h = RDA::Request::PROFILE-E<gt>new($agt)>

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

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

The profile object constructor.

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

=over 10

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

=item S<  B<'_alt'> > Alternative profile names (P)

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

=item S<  B<'_chg'> > Setting changes hash (P)

=item S<  B<'_cnt'> > Reference to the RDA content control object (L)

=item S<  B<'_def'> > Group profile definitions (L)

=item S<  B<'_dir'> > Collect directory structure (L)

=item S<  B<'_dsc'> > Profile description (P)

=item S<  B<'_fam'> > Profile compatibility type hash (P)

=item S<  B<'_lib'> > Reference to the library object (P)

=item S<  B<'_lvl'> > Trace level (L)

=item S<  B<'_man'> > Profile manual hash (P)

=item S<  B<'_mod'> > Module list (P)

=item S<  B<'_set'> > Setting level alteration hash (P)

=item S<  B<'_trc'> > Module list with tracing directives (P)

=item S<  B<'_tgt'> > Profile targets hash (P)

=item S<  B<'_typ'> > Object type: L (Library) or P (Profile)

=back

Internal keys are prefixed by an underscore.

=cut

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

  if ($ref = ref($cls))
  { # Create the profile definition object
    $slf = bless {
      _alt => {},
      _lib => $cls,
      _typ => 'P',
      }, $ref;
  }
  else
  { # Create the control object
    $cfg = $agt->get_config;
    $slf = bless {
      _agt => $agt,
      _cfg => $cfg,
      _cnt => $agt->get_content,
      _dir => $cfg->get_group('D_RDA_COL'),
      _def => {},
      _lvl => $agt->get_level,
      _typ => 'L',
      }, ref($cls) || $cls;
  }

  # Return the object reference
  return $slf;
}

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

This method deletes the library object or the profile definition object.

=cut

sub delete_object
{ if (exists($_[0]->{'_def'}))
  { RDA::Object::dump_caller($_[0], 'Commands') if $RDA::Object::DELETE;
    foreach my $def (values(%{$_[0]->{'_def'}}))
    { next unless ref($def);
      foreach my $prf (values(%{$def}))
      { $prf->delete_object;
      }
      undef %{$def};
    }
  }
  undef %{$_[0]};
  undef $_[0];
  return;
}

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

This method dumps the library object.

=cut

sub dump  ## no critic (Builtin)
{ return RDA::Object::dump($_[0]);
}

=head2 S<$h-E<gt>exec_command($req)>

This method executes the command specified in the message.

=cut

sub exec_command
{ my ($slf, $req) = @_;

  my $cmd = $req->{'msg'};
  return exists($tb_cmd{$cmd})
    ? &{$tb_cmd{$cmd}}($slf, $req)
    : $req->error('NotImplemented', get_string('BAD_COMMAND', $cmd));
}

=head1 PROFILE COMMANDS

=head2 PROFILE.CHECK - Check command

This command checks a profile definition file. It supports the following
attribute:

=over 14

=item B<  definition>

Specifies the file to check.

=back

=cut

sub _do_check
{ my ($slf, $req) = @_;
  my ($def);

  # Validate the attribute
  return $req->error('NoDefinition')
    unless defined($def = $req->get_first('definition'));

  # Check the requested file
  eval {$slf->load($def, _get_group($def))};

  # Return the completion status
  return $req->reply($@, 'Check');
}

=head2 PROFILE.DEFINE - Define command

This command defines profiles provided as data.

=cut

sub _do_define
{ my ($slf, $req) = @_;
  my ($ifh);

  # Load the profiles specified as data
  eval {
    $slf->{'_def'}->{'_DAT_'} = parse($slf, $ifh, undef, 'ERR_PARSE', '<DATA>')
      if ($ifh = RDA::Handle::Data->new($req));
    };

  # Return the completion status
  return $req->reply($@, 'Define');
}

=head2 PROFILE.DISPLAY - Display command

This command displays the manual page of the specified profile entry. It
supports the following attributes:

=over 12

=item B<  groups>

When present, restricts the profile definition search to the specified groups,
the C<RDA> group, and the content of the file referenced by the C<RDA_PROFILE>
environment variable.

=item B<  name>

Specifies the profile name.

=item B<  settings>

When the true, it includes the profile settings (false by default).

=back

=cut

sub _do_display
{ my ($slf, $req) = @_;
  my ($buf, $def, $grp, $nam, $prf);

  # Validate the attribute
  return $req->error('NoName')
    unless defined($prf = $req->get_first('name'));

  # Generate the manual page
  eval {
    $grp = $req->get_value('groups');
    ($def, $nam) = $slf->get_profile($grp, $prf);
    die get_string('NO_PROFILE', $prf) unless ref($def);
    $buf = $def->display($nam, $req->get_first('settings'));
    };
  $req->add_error($@) if $@;

  # Display the manual page
  return $req->has_errors
    ? $req->error('Display')
    : _display($slf, $req, 'OK.Display', $buf);
}

=head2 PROFILE.LIST - List command

This command lists all corresponding profiles. It supports the following
attributes:

=over 15

=item B<  description>

When true, includes the description as data.

=item B<  groups>

When present, restricts the profile definition search to the specified groups,
the C<RDA> group, and the content of the file referenced by the C<RDA_PROFILE>
environment variable.

=item B<  type>

Specifies a profile type (all types per default)

=back

=cut

sub _do_list
{ my ($slf, $req) = @_;
  my ($buf, $def, $grp, $sel, @tbl);

  # Get the list of profiles
  eval {
    # Select the profile definition files
    $grp = $req->get_value('groups');
    $def = $slf->get_profiles($grp, $req->get_first('type'));
    @tbl = sort keys(%{$def});

    # Get the descriptions when requested
    $buf = join(q{},
      map {$_.q{|}.$def->{$_}->[0]->get_title($def->{$_}->[1], q{}).qq{\n}}
          @tbl)
      if $req->get_first('description');
  };
  $req->add_error($@) if $@;

  # Return the completion status
  return $req->has_errors
    ? $req->error('List')
    : $req->new('OK.List', profiles => [@tbl])->add_data($buf);
}

=head2 PROFILE.PREVIEW - Preview command

This command returns the list of modules associated to a profile list, sorted
in the setup order. It supports the following attributes:

=over 12

=item B<  groups>

When present, restricts the profile definition search to the specified groups,
the C<RDA> group, and the content of the file referenced by the
C<RDA_PROFILE> environment variable.

=item B<  profiles>

Specifies the profile list.

=back

=cut

sub _do_preview
{ my ($slf, $req) = @_;
  my ($cnt, $def, $grp, $seq, @tbl, %tbl);

  eval {
    # Get the module list
    $grp = $req->get_value('groups');
    @tbl = $slf->merge($grp, @tbl)->get_modules
      if (@tbl = $req->get_value('profiles'));

    # Get the corresponding setup sequence
    $cnt = $slf->{'_cnt'};
    foreach my $mod (@tbl)
    { next unless $mod =~ $RE_DC;
      $def = _load_group($slf, $2);
      ($seq) = $cnt->get_sequence('DC', $mod);
      if ($seq =~ m/^(E)?(\d{3})(\/(E)?(\d{3}))?$/)
      { $tbl{$mod} =
          $def->get_first($1 ? ['N_END', 'N_CFG'] : 'N_CFG', 500)
             + "0.$2"; ## no critic (Mismatch)
      }
      else
      { $tbl{$mod} = $def->get_first('N_CFG', 500) + 0.5;  ## no critic (Number)
      }
    }
    };
  $req->add_error($@) if $@;

  # Return the completion status
  return $req->has_errors
    ? $req->error('Preview')
    : $req->new('OK.Preview',
        modules => [sort {$tbl{$a} <=> $tbl{$b} || $a cmp $b} @tbl]);
}

=head2 PROFILE.XREF - Cross-reference command

This command produces a cross-reference of existing profile definitions. It
supports the following attributes:

=over 14

=item B<  all>

When true, includes all profiles in the cross-reference. By default, it
considers the profiles with a title only.

=item B<  definition>

When present, restricts the cross-reference to the specified definition file.

=item B<  groups>

When present, restricts the profile definition search to the specified groups,
the C<RDA> group, and the content of the file referenced by the C<RDA_PROFILE>
environment variable.

=back

=cut

sub _do_xref
{ my ($slf, $req) = @_;
  my ($buf, $grp, $pth);

  # Generate the cross-reference
  eval {
    $buf = $slf->xref(
      !defined($pth = $req->get_first('definition'))
        ? $slf->select($grp = $req->get_value('groups')) :
      defined($grp = _get_group($pth))
        ? {$grp => $slf->load($pth, $grp)} :
      {'<GRP>' => $slf->load($pth)}, $req->get_first('all'));
    };
  $req->add_error($@) if $@;

  # Display the cross-reference
  return $req->has_errors
    ? $req->error('Xref')
    : _display($slf, $req, 'OK.Xref', $buf);
}

=head1 PROFILE CONTROL METHODS

=head2 S<$h-E<gt>get_profile(group,$name)>

This method returns the definition of the specified profile. In a scalar
context, it returns a reference to the profile definition. In an array context,
it returns a list containing a reference to the profile definition, the profile
name, and the group name.

=cut

sub get_profile
{ my @prf = _get_profile(@_);

  return @prf if wantarray;
  return $prf[0];
}

sub _get_profile
{ my ($slf, $grp, $prf) = @_;
  my ($def, $loc, $nam, $sel, @prf);

  $slf = $slf->{'_lib'} if exists($slf->{'_lib'});
  $def = $slf->{'_def'};

  # Validate the profile name
  die get_string('BAD_PROFILE', $prf)
    unless $prf =~ m/^(\w+\.)*(\w+)$/;
  $nam = $2;

  # Treat group-qualified profile name
  if ($1)
  { $loc = substr($1, 0, -1);
    $sel = $slf->select([split(/\./, $loc)]);
    return ($sel->{$loc}->{$nam}, $nam, $loc)
      if exists($sel->{$loc}) && exists($sel->{$loc}->{$nam});
    return ();
  }

  # Treat other profile name
  $sel = $slf->select($grp);
  foreach my $grp (q{}, '_DAT_', '_ENV_', 'RDA')
  { return ($sel->{$grp}->{$nam}, $nam, $grp)
      if exists($sel->{$grp}) && exists($sel->{$grp}->{$nam});
  }
  foreach my $grp (keys(%{$sel}))
  { next unless exists($sel->{$grp}) && exists($sel->{$grp}->{$nam});
    return () if @prf;
    @prf = ($sel->{$grp}->{$nam}, $nam, $grp);
  }
  return @prf;
}

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

This method returns a reference to a hash containing the profiles and their
definition.

=cut

sub get_profiles
{ my ($slf, $grp, $typ) = @_;
  my ($def, $fct, $sel);

  # Select the profile definitions
  $slf = $slf->{'_lib'} if exists($slf->{'_lib'});
  $sel = $slf->select($grp);

  # Select the relevant profile names
  $def = {};
  $fct = defined($typ) ? \&_sel_type : \&_sel_any;
  foreach my $grp (keys(%{$sel}))
  { _filter($def, $sel->{$grp}, $grp, $fct, $typ)
      unless $grp eq 'RDA' || $grp eq q{};
  }
  foreach my $grp ('RDA', '_DAT_', '_ENV_', q{})
  { _filter($def, $sel->{$grp}, $grp, $fct, $typ, 1)
      if exists($sel->{$grp});
  }

  # Remove ambiguous profile names
  foreach my $nam (keys(%{$def}))
  { delete($def->{$nam}) unless defined($def->{$nam})
  }

  # Return the profile list
  return $def;
}

# Filter the profiles
sub _filter
{ my ($def, $tbl, $grp, $fct, $typ, $flg) = @_;
  my ($prf, $uid);

  foreach my $nam (keys(%{$tbl}))
  { next unless &$fct($prf = $tbl->{$nam}, $typ);
    $uid = $grp.q{.}.$nam;
    if (!exists($def->{$nam}))
    { $def->{$nam} = [$prf, $nam, $uid];
    }
    else
    { $def->{$def->{$nam}->[2]} = $def->{$nam} if defined($def->{$nam});
      $def->{$flg ? $nam : $uid} = [$prf, $nam, $uid];
    }
  }
  return;
}

# Select any profile
sub _sel_any
{ return 1;
}

# Select compatible profile
sub _sel_type
{ my ($prf, $typ) = @_;

  return !exists($prf->{'_fam'}) || exists($prf->{'_fam'}->{$typ});
}

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

This method loads the collection profile definitions from the specified file
and returns a definition hash.

=cut

sub load
{ my ($slf, $fil, $grp) = @_;
  my ($ifh, $pth);

  $ifh = IO::File->new;
  $pth = RDA::Object::Rda->is_absolute($fil)
    ? $fil
    : RDA::Object::Rda->cat_file($slf->{'_dir'}, $fil);
  $ifh->open("<$pth") or die get_string('ERR_OPEN', $pth, $!);
  return $slf->parse($ifh, $grp, 'ERR_PARSE', $fil);  # Text:ERR_PARSE
}

=head2 S<$h-E<gt>merge(group,$name...)>

This method merges the definition of the specified profiles and returns the
result.

=cut

sub merge
{ my ($slf, $grp, @nam) = @_;
  my ($def, $loc, $sel, $tbl, $trc);

  # Select the profile definitions
  $slf = $slf->{'_lib'} if exists($slf->{'_lib'});
  $sel = $slf->select($grp);

  # Merge the profile definitions
  $def = $slf->new(q{*});
  PROFILE: foreach my $nam (@nam)
  { die get_string('BAD_PROFILE', $nam)
      unless $nam =~ m/^([Tt][\/:])?((\w+\.)?(\w+))$/;
    $trc = $1 ? $TB_TRC{$1} : 0;
    if ($3)
    { # Treat group-qualified profile name
      $loc = substr($3, 0, -1);
      if (exists($sel->{$loc}) && exists($sel->{$loc}->{$4}))
      { _merge($def, $sel->{$loc}->{$4}, $2, $trc);
        next PROFILE;
      }
    }
    else
    { # Resolve profile name
      foreach my $grp ('_DAT_', '_ENV_', 'RDA')
      { if (exists($sel->{$grp}) && exists($sel->{$grp}->{$2}))
        { _merge($def, $sel->{$grp}->{$2}, "$grp.$2", $trc);
          next PROFILE;
        }
      }
      foreach my $grp (keys(%{$sel}))
      { if (exists($sel->{$grp}) && exists($sel->{$grp}->{$2}))
        { _merge($def, $sel->{$grp}->{$2}, "$grp.$2", $trc);
          next PROFILE;
        }
      }
    }
    die get_string('NO_PROFILE', $nam);
  }
  if (exists($def->{'_trc'}))
  { $tbl = $def->{'_trc'};
    $def->{'_trc'} =
      [map {$TB_TRC[$tbl->{$_}].$_} @{$def->{'_mod'} = [keys(%{$tbl})]}];
  }

  # Return the profile definition
  return $def;
}

sub _merge  ## no critic (Complex)
{ my ($dst, $src, $nam, $trc) = @_;
  my ($cnt, $val);

  # Check type compatibility
  if (exists($src->{'_fam'}))
  { if (exists($dst->{'_fam'}))
    { $cnt = 0;
      foreach my $key (keys(%{$dst->{'_fam'}}))
      { if (exists($src->{'_fam'}->{$key}))
        { ++$cnt;
        }
        else
        { delete($dst->{'_fam'}->{$key})
        }
      }
      die get_string('INCOMPATIBLE') unless $cnt;
    }
    else
    { $dst->{'_fam'} = {%{$src->{'_fam'}}};
    }
  }

  # Add the name
  push(@{$dst->{'_nam'}}, $nam);

  # Merge module lists
  if (exists($src->{'_mod'}))
  { foreach my $mod (@{$src->{'_mod'}})
    { $dst->{'_trc'}->{$mod} = $trc
        unless exists($dst->{'_trc'}->{$mod})  ## no critic (Unless)
            && $dst->{'_trc'}->{$mod} >= $trc;
    }
  }

  # Merge setting changes
  if (exists($src->{'_chg'}))
  { foreach my $key (keys(%{$src->{'_chg'}}))
    { $val = $src->{'_chg'}->{$key};
      $dst->{'_chg'}->{$key} = $val
        unless $key =~ m/(^|[\.\/])([DF]_\w+)$/
            && RDA::Object::Item->validate($2, $val);
    }
  }

  # Merge setting level alterations
  if (exists($src->{'_set'}))
  { foreach my $mod (keys(%{$src->{'_set'}}))
    { foreach my $key (keys(%{$src->{'_set'}->{$mod}}))
      { $val = $src->{'_set'}->{$mod}->{$key};
        $dst->{'_set'}->{$mod}->{$key} = $val
          unless exists($dst->{'_set'})  ## no critic (Unless)
              && exists($dst->{'_set'}->{$mod})
              && exists($dst->{'_set'}->{$mod}->{$key})
              && $val < $dst->{'_set'}->{$mod}->{$key};
      }
    }
  }

  # Merge profile targets
  if (exists($src->{'_tgt'}))
  { foreach my $key (keys(%{$src->{'_tgt'}}))
    { $dst->{'_tgt'}->{$key} = $src->{'_tgt'}->{$key};
    }
  }
  return;
}

=head2 S<$h-E<gt>parse($ifh,$group,$error...)>

This method parses the collection profile definitions from the specified input
file handle and returns a definition hash.

=cut

sub parse  ## no critic (Complex)
{ my ($slf, $ifh, $grp, @err) = @_;
  my ($cas, $cur, $err, $key, $lin, $msg, $pos, $prf, $str, $val);

  # Load the profile definition
  $slf = $slf->{'_lib'} if exists($slf->{'_lib'});
  $cas = $slf->{'_cfg'}->get_info('B_CASE');
  $err = RDA::Error->new;
  $pos = 0;
  $prf = {};
  $lin = q{};
  while (<$ifh>)
  { # Trim leading spaces
    s/^\s+//;
    s/[\r\n]+$//;
    $lin .= $_;

    # Join continuation line
    $pos++;
    next if $lin =~ s/\\$//;
    $lin =~ s/\s+$//;

    # Parse the line
    eval {
      if ($cur && $lin =~ s/^LVL\/([A-Z][A-Z\d]*:\w+)\/(\w+)\s*=\s*(\d+)\s*//)
      { $cur->{'_set'}->{$1}->{$2} = $3;
      }
      elsif ($cur && $lin =~ s/^TGT\/((\w+\.)*[A-Z]{2,}_\w*P\d+)\s*=\s*//)
      { $key = uc($1);
        $val = decode_value($slf, \$lin, 1);
        die get_string('NO_HASH')   unless ref($val) eq 'HASH';
        die get_string('BAD_VALUE') unless $lin =~ m/^\s*(#.*)?$/;
        $cur->{'_tgt'}->{$key} = $val;
      }
      elsif ($cur && $lin =~ s/^((\w+\/)?(\w+\.)*([DF]_\w+))\s*=\s*//)
      { $key = uc($1);
        $str = uc($4);
        $val = decode_value($slf, \$lin, 1);
        die get_string('BAD_VALUE') unless $lin =~ m/^\s*(#.*)?$/;
        $cur->{'_chg'}->{$key} = $val;
      }
      elsif ($cur && $lin =~ s/^((\w+\/)?(\w+\.)*([A-Z]_\w+))\s*=\s*//)
      { $key = uc($1);
        $str = uc($4);
        $val = decode_value($slf, \$lin, 1);
        die $msg if ($msg = RDA::Object::Item->validate($str, $val));
        die get_string('BAD_VALUE') unless $lin =~ m/^\s*(#.*)?$/;
        $cur->{'_chg'}->{$key} = $val;
      }
      elsif ($cur && $lin =~ s/^\?(\w*)\s*=\s*//)
      { $key = length($1) ? "_dsc_$1" : '_dsc';
        $val = _decode(\$lin, get_string('BAD_DESC'));
        $cur->{$key} = $val;
        $cur->{lc($key)} = $val unless $cas;
      }
      elsif ($cur && $lin =~ s/^!((\w*)(!\w+)?)\s*=\s*//)
      { $key = $1;
        $str = ($3 && !$cas) ? $2.lc($3) : undef;
        $val = _decode(\$lin, get_string('BAD_MAN'));
        $cur->{'_man'}->{$key} = $val;
        $cur->{'_man'}->{$str} = $val if defined($str);
      }
      elsif ($lin =~ s/^\[(\w+(\|\w+)*)\]$//)
      { $cur = $slf->new;
        foreach my $alt (split(/\|/, $1))
        { $prf->{$alt} = $cur;
          unless ($cas)
          { $str = lc($alt);
            $cur->{'_alt'}->{$str} = $alt;
            $prf->{$str} = $cur;
          }
        }
      }
      elsif ($cur && $lin =~ s/^\*\s*=\s*($MOD(\s*,\s*$MOD)*)//)
      { $cur->{'_mod'} = [map {_norm_module($grp, $_)} split(/\s*,\s*/, $1)];
        die get_string('BAD_MODULES') unless $lin =~ m/^\s*(#.*)?$/;
      }
      elsif ($cur && $lin =~ s/^\@\s*=\s*((\w+:)?\w+(\s*,\s*(\w+:)?\w+)*)//)
      { $cur->{'_fam'} = {map {$_ => 1} split(/\s*,\s*/, $1)};
        die get_string('BAD_TYPES') unless $lin =~ m/^\s*(#.*)?$/;
      }
      elsif ($lin !~ m/^(?:#.*)?$/)
      { die get_string('BAD_SPEC');
      }
    };

    # Report an error
    if ($@)
    { my ($rec, $txt);

      if (defined($rec = $err->parse_error($@)))
      { $txt = shift(@{$rec});
        last if $txt =~ m/^last/;
        unshift(@{$rec}, get_string('Error', $txt, $pos));
        $err->add_errors($rec);
      }
    }

    # Prepare the next line
    $lin = q{};
  }
  $ifh->close;

  # Detect errors
  $slf->{'_agt'}->abort($err->purge_errors, get_string(@err))
    if $err->has_errors;

  # Return the profile definitions
  return $prf;
}

sub _decode
{ my ($lin, $err) = @_;
  my ($val);

  if ($$lin =~ s/"(.*?)"//)
  { $val = $1;
    die $err unless $$lin =~ m/^\s*(#.*)?$/;
  }
  else
  { $val = $$lin;
  }
  return RDA::Object::decode($val);
}

sub _norm_module
{ my ($grp, $str) = @_;
  my ($mod, @sct);

  ($mod, @sct) = split(/\-/, $str);
  return $str unless index($mod, q{:}) < 0;  ## no critic (Unless)
  die get_string('NO_GROUP') unless defined($grp);
  return join(q{-}, $grp.q{:}.$mod, @sct);
}

sub find
{ die get_string('NO_OBJECT');
}

=head2 S<$h-E<gt>select([$group])>

This method selects the relevant profile definitions.

=cut

sub select  ## no critic (Builtin)
{ my ($slf, $grp) = @_;
  my ($agt, $def, $ifh, $lvl, $pth, $sel, $tbl);

  # Initialization
  $slf = $slf->{'_lib'} if exists($slf->{'_lib'});
  $agt = $slf->{'_agt'};
  $def = $slf->{'_def'};
  $ifh = IO::File->new;
  $lvl = $slf->{'_lvl'};
  $sel = {};

  # Include dynamic profiles
  $sel->{'_DAT_'} = $def->{'_DAT_'} if exists($def->{'_DAT_'});

  # Load the environment specific profiles on the first use
  unless (exists($def->{'_ENV_'}))
  { $def->{'_ENV_'} = undef;
    if (($pth = $agt->get_env('RDA_PROFILE')) && -r $pth)
    { eval {
        $ifh->open("<$pth") or die get_string('ERR_OPEN', $pth, $!);
        unless ($lvl < 10)  ## no critic (Unless)
        { $agt->trace(get_string('Env', $pth));
          $agt->trace(get_string('Loading', $pth));
        }
        $def->{'_ENV_'} = parse($slf, $ifh, undef, 'ERR_PARSE', $pth);
        };
      $agt->add_error($@) if $@;
    }
  }
  $sel->{'_ENV_'} = $def->{'_ENV_'} if defined($def->{'_ENV_'});

  # Treat the relevant profile definition files
  $def = $slf->{'_def'};
  $tbl = $slf->{'_cnt'}->get_list('PR', $grp);
  foreach my $key (keys(%{$tbl}))
  { # Load the definition file on first use
    unless (exists($def->{$key}))
    { $def->{$key} = undef;
      eval {
        $pth = $tbl->{$key};
        $ifh->open("<$pth") or die get_string('ERR_OPEN', $pth, $!);
        $agt->trace(get_string('Loading', $pth))
          unless $lvl < 10;  ## no critic (Unless)
        $def->{$key} = parse($slf, $ifh, $key, 'ERR_PARSE', $pth);
        };
      $agt->add_error($@) if $@;
    }

    # Select it
    $sel->{$key} = $def->{$key} if defined($def->{$key});
  }

  # Return the selected definitions
  return $sel;
}

=head2 S<$h-E<gt>xref($select[,$flag])>

This method produces a cross-reference of the selected profile definitions and
the related modules. When the flag is set, it includes the profiles without
title.

=cut

sub xref
{ my ($slf, $sel, $flg, $nam) = @_;
  my ($buf, $prf, $uid, %bad, %mod, %prf, %typ);

  # Get the module list
  $slf = $slf->{'_lib'} if exists($slf->{'_lib'});
  foreach my $mod ($slf->{'_cnt'}->get_modules('DC'))
  { $mod{$mod} = [];
  }

  # Analyze the profiles
  $typ{q{*}} = [];
  foreach my $grp (sort keys(%{$sel}))
  { foreach my $nam (sort keys(%{$sel->{$grp}}))
    { $prf = $sel->{$grp}->{$nam};
      next unless $flg || $prf->get_title($nam);
      $prf{$uid = $grp.q{.}.$nam} = [];

      # Analyse the modules
      if (exists($prf->{'_mod'}))
      { foreach my $mod (sort @{$prf->{'_mod'}})
        { ($mod) = split(/\-/, $mod);
          if (exists($mod{$mod}))
          { push(@{$mod{$mod}}, $uid);
          }
          else
          { push(@{$bad{$mod}}, $uid);
          }
          push(@{$prf{$uid}}, $mod);
        }
      }
      else
      { foreach my $mod (sort keys(%mod))
        { push(@{$mod{$mod}}, $uid);
          push(@{$prf{$uid}}, $mod);
        }
      }

      # Analyze the profile applicability
      if (exists($prf->{'_fam'}))
      { foreach my $typ (sort keys(%{$prf->{'_fam'}}))
        { $typ{$typ} = [@{$typ{q{*}}}] unless exists($typ{$typ});
          push(@{$typ{$typ}}, $uid);
        }
      }
      else
      { foreach my $typ (keys(%typ))
        { push(@{$typ{$typ}}, $uid);
        }
      }
    }
  }

  # Produce the cross-reference
  $buf = _dsp_name($nam || get_string('Xref')).$RPT_NXT;
  $buf .= _xref_dsp(\%prf, 'XrefDefined',    'profile', q{-});
  $buf .= _xref_dsp(\%mod, 'XrefReferenced', 'collect');
  $buf .= _xref_dsp(\%bad, 'XrefUnknown');
  $buf .= _xref_dsp(\%typ, 'XrefApplicability');
  return $buf;
}

# Display a result set
sub _xref_dsp
{ my ($tbl, $ttl, $typ, $dft) = @_;
  my ($buf, @tbl);

  return q{} unless ref($tbl) eq 'HASH';
  @tbl = keys(%{$tbl});
  @tbl = grep {@{$tbl->{$_}}} @tbl unless defined($dft);
  return q{} unless @tbl;

  $buf = _dsp_table(get_string($ttl));
  foreach my $nam (sort @tbl)
  { $buf .= _dsp_row($typ ? qq{!!$typ:$nam!$nam!!} : qq{``$nam``},
      @{$tbl->{$nam}} ? q{``}.join(q{``, ``}, @{$tbl->{$nam}}).q{``} : $dft);
  }
  return $buf.$RPT_EOT;
}

=head1 PROFILE DEFINITION METHODS

=head2 S<$h-E<gt>display($name[,$flag])>

This method displays the manual page of the specified profile entry. When the
flag is set, it includes the profile settings.

=cut

sub display
{ my ($slf, $nam, $det, $flg) = @_;
  my ($buf, $cnt, $tbl, @sct, @tbl, %sct);

  # Initialization
  die get_string('NO_DETAIL') unless $slf->{'_typ'} eq 'P';
  $cnt = $slf->{'_lib'}->{'_cnt'};
  $nam = $slf->{'_alt'}->{$nam} if exists($slf->{'_alt'}->{$nam});

  # Display the profile name and title
  $buf = _dsp_title(get_string('TtlName'))._dsp_text($RPT_TXT,
    get_string('DspName', $nam, $slf->get_title($nam, q{})), 1);

  # Display the text elements
  if (exists($slf->{'_man'}))
  { $buf .= _dsp_title(get_string('TtlDesc'));
    foreach my $key (sort keys(%{$tbl = $slf->{'_man'}}))
    { $buf .= _dsp_block($RPT_TXT, $tbl->{$key}, 1)
        unless $key =~ m/^\w*(\!(\w+))?$/  ## no critic (Unless)
            && defined($1) && $2 ne $nam;
    }
  }

  # Display the modules and their descriptions
  if (exists($slf->{'_mod'}))
  { $buf .= _dsp_title(get_string('TtlModules'))
      ._dsp_table($RPT_TXT, get_string('DspModules', $nam));
    foreach my $key (@{$slf->{'_mod'}})
    { ($key, @sct) = split(/\-/, $key);
      $buf .= _dsp_row(
        q{!!collect:}.$key.q{!}.$cnt->get_abbr('DC', $key, $key).q{!!},
        $cnt->get_desc('DC', $key, '\040'));  ## no critic (Interpolation)
      $sct{$key} = [@sct] if @sct;
    }
    $buf .= $RPT_EOT;
  }

  # Display the section restrictions
  if (@tbl = keys(%sct))
  { $buf .= _dsp_title(get_string('TtlSections'))
      ._dsp_table($RPT_TXT, get_string('DspSections', $nam));
    foreach my $key (sort @tbl)
    { $buf .= _dsp_row(
        q{!!collect:}.$key.q{!}.$cnt->get_abbr('DC', $key, $key).q{!!},
        join(q{, }, @{$sct{$key}}));
    }
    $buf .= $RPT_EOT;
  }

  # Display the profile details
  if ($det)
  { if (exists($slf->{'_chg'}))
    { # Display the profile settings
      $buf .= _dsp_title(get_string('TtlSettings'))
        ._dsp_text($RPT_TXT, get_string('DspSettings', $nam));
      foreach my $key (sort keys(%{$tbl = $slf->{'_chg'}}))
      { $buf .= _dsp_text($RPT_SUB, q{``}.$key.q{=}
          .encode_value($tbl->{$key}).q{``});
      }
      $buf .= $RPT_NXT;
    }

    # Display the profile targets
    if (exists($slf->{'_tgt'}))
    { # Display the profile settings
      $buf .= _dsp_title(get_string('TtlTargets'))
        ._dsp_text($RPT_TXT, get_string('DspTargets', $nam));
      foreach my $key (sort keys(%{$tbl = $slf->{'_tgt'}}))
      { $buf .= _dsp_text($RPT_SUB, q{``}.$key.q{=}
          .encode_value($tbl->{$key}).q{``});
      }
      $buf .= $RPT_NXT;
    }
  }

  # Display the copyright and trademark notices
  $buf .= _dsp_title(get_string('TtlCopyright'))
    ._dsp_text($RPT_TXT, get_string('Copyright'), 1)
    ._dsp_title(get_string('TtlTrademark'))
    ._dsp_text($RPT_TXT, get_string('Trademark'))
    unless $flg;

  # Return the result
  return $buf;
}

=head2 S<$h-E<gt>get_changes([$default])>

This method returns the setting changes as a hash. It returns the default
value when there are no setting changes.

=cut

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

  die get_string('NO_DETAIL') unless $slf->{'_typ'} eq 'P';
  return exists($slf->{'_chg'}) ? $slf->{'_chg'} : $dft;
}

=head2 S<$h-E<gt>get_levels([$default])>

This method returns the setting level alterations as a hash. It returns the
default value when there are no setting level alterations.

=cut

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

  die get_string('NO_DETAIL') unless $slf->{'_typ'} eq 'P';
  return exists($slf->{'_set'}) ? $slf->{'_set'} : $dft;
}

=head2 S<$h-E<gt>get_modules([$flag])>

This method returns the module list. When the flag is set, the module names
include trace directives.

=cut

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

  die get_string('NO_DETAIL') unless $slf->{'_typ'} eq 'P';
  return () unless exists($slf->{'_mod'});
  return (@{$slf->{$flg ? '_trc' : '_mod'}});
}

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

This method returns the name list.

=cut

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

  die get_string('NO_DETAIL') unless $slf->{'_typ'} eq 'P';
  return () unless exists($slf->{'_nam'});
  return (@{$slf->{'_nam'}});
}

=head2 S<$h-E<gt>get_targets([$default])>

This method returns the profile targets as a hash. It returns the default
value when there are no profile targets.

=cut

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

  die get_string('NO_DETAIL') unless $slf->{'_typ'} eq 'P';
  return exists($slf->{'_tgt'}) ? $slf->{'_tgt'} : $dft;
}

=head2 S<$h-E<gt>get_title($name[,$default])>

This method returns the description of the specified profile or the default
value when not found.

=cut

sub get_title
{ my ($slf, $nam, $ttl) = @_;

  die get_string('NO_DETAIL') unless $slf->{'_typ'} eq 'P';
  return $ttl unless $nam;
  return
    exists($slf->{"_dsc_$nam"}) ? $slf->{"_dsc_$nam"} :
    exists($slf->{'_dsc'})      ? $slf->{'_dsc'} :
                                  $ttl;
}

=head2 S<$h-E<gt>get_types([$default])>

This method returns the profile compatibility hash. It returns the default
value when the selected profiles do not contain any type restrictions.

=cut

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

  die get_string('NO_DETAIL') unless $slf->{'_typ'} eq 'P';
  return exists($slf->{'_fam'}) ? $slf->{'_fam'} : $dft;
}

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

# Display the result
sub _display
{ my ($slf, $req, $sta, $buf) = @_;
  my ($err, $msg);

  $msg = RDA::Object::Message->new('DISPLAY.DSP_REPORT',
    page => 1)->add_data($buf);
  return ($err = $slf->{'_agt'}->submit(q{.}, $msg)->is_error($req))
    ? $req->error($err)
    : $req->new($sta);
}

# Determine the group name
sub _get_group
{ my ($pth) = @_;
  my ($grp, $ifh);

  $ifh = IO::File->new;
  if ($ifh->open('<'.RDA::Object::Rda->cat_file(RDA::Object::Rda->dirname($pth),
    'group.cfg')))
  { while (<$ifh>)
    { if (m/^\[([A-Z][A-Z\d]*)\]/)
      { $grp = $1;
        last;
      }
    }
    $ifh->close;
  }
  return $grp;
}

# Load a group definition
sub _load_group
{ my ($slf, @grp) = @_;
  my ($grp, $nam, $ifh, $run);

  # Check for an existing group definition
  $run = $slf->{'_agt'}->get_run;
  return $grp if defined($grp = $run->find($nam = join(q{.}, 'GROUP', @grp)));

  # Load the group definition
  $ifh = IO::File->new;
  $run->find('GROUP', 1)->load($ifh)
    if $ifh->open('<'
         .RDA::Object::Rda->cat_file($slf->{'_dir'}, @grp, 'group.cfg'));

  # Return a reference to the group definition
  return $run->find($nam, 1);
}

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

sub _dsp_block
{ my ($pre, $txt, $nxt) = @_;
  my $buf = q{};

  foreach my $str (split(/\n|\\n/, $txt))
  { if ($str =~ m/^(\s*[o\*\-]\s+)(.*)$/)
    { $buf .= qq{.I '$pre\001$1'\n$2\n\n};
    }
    else
    { $buf .= qq{.I '$pre'\n$str\n\n};
    }
  }
  $buf .= qq{.N $nxt\n} if $nxt;
  return $buf;
}

sub _dsp_name
{ my ($ttl) = @_;

  return qq{.R '$ttl'\n};
}

sub _dsp_row
{ return join(q{|}, @_).qq{\n};
}

sub _dsp_table
{ my ($pre, $txt) = @_;

  return defined($txt) ? qq{.M 2 '$pre|$txt'\n} : qq{.M 2 '$pre'\n};
}

sub _dsp_text
{ my ($pre, $txt, $nxt) = @_;

  $txt =~ s/\n{2,}/\n\\040\n/g;
  $txt =~ s/(\n|\\n)/\n\n.I '$pre'\n/g;
  return qq{.I '$pre'\n$txt\n\n}.($nxt ? qq{.N $nxt\n} : q{});
}

sub _dsp_title
{ my ($ttl) = @_;

  return qq{.T '$ttl'\n};
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Error|RDA::Error>,
L<RDA::Handle::Data|RDA::Handle::Data>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Content|RDA::Object::Content>,
L<RDA::Object::Item|RDA::Object::Item>,
L<RDA::Object::Message|RDA::Object::Message>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Object::Target|RDA::Object::Target>,
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