# Display.pm: Class Used for Controlling the Display

package RDA::Object::Display;

# $Id: Display.pm,v 1.18 2015/07/23 23:33:44 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Object/Display.pm,v 1.18 2015/07/23 23:33:44 RDA Exp $
#
# Change History
# 20150717  MSC  Change handle.

=head1 NAME

RDA::Object::Display - Class Used for Controlling the Display

=head1 SYNOPSIS

 require RDA::Object::Display;

=head1 DESCRIPTION

The objects of the C<RDA::Object::Display> class are used for controlling the
display. 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::Handle::Memory;
  use RDA::Handle::Vector;
  use RDA::Object;
  use RDA::Object::Rda;
}

# Define the global public variables
use vars qw($STRINGS $VERSION @ISA %SDCL);
$VERSION = sprintf('%d.%02d', q$Revision: 1.18 $ =~ /(\d+)\.(\d+)/);
@ISA     = qw(RDA::Object Exporter);
%SDCL    = (
  als => {
    ## no critic (Interpolation)
    'echo'    => ['$[DSP]', 'dsp_line'],
    'explain' => ['$[DSP]', 'explain'],
    },
  beg => \&_begin_display,
  inc => [qw(RDA::Object)],
  met => {
    'dsp_block'   => {ret => 0},
    'dsp_data'    => {ret => 0},
    'dsp_error'   => {ret => 0},
    'dsp_line'    => {ret => 0, evl => 'L'},
    'dsp_pod'     => {ret => 0},
    'dsp_report'  => {ret => 0},
    'dsp_string'  => {ret => 0},
    'dsp_text'    => {ret => 0},
    'explain'     => {ret => 0},
    'set_info'    => {ret => 0},
    'wrap_string' => {ret => 0},
    },
  top => 'DSP',
  );

# Define the global private constants
my $SPC = q{ };

# Define the global private variables
my %tb_cmd = (
  q{-} => qq{.P\n},
  q{B} => qq{.I '  \001- ' 2\n},
  q{I} => qq{.I '  \001  ' 2\n},
  q{P} => qq{.I '  ' 2\n},
  q{S} => qq{.S\n},
  q{b} => qq{.I '  \001- '\n},
  q{i} => qq{.I '  \001  '\n},
  q{p} => qq{.I '  '\n},
  );
my %tb_fmt = (
  B => \&_fmt_val_bullet,
  C => \&_fmt_val_comma,
  D => \&_fmt_val_dot,
  F => \&_fmt_val_first,
  L => \&_fmt_val_last,
  N => \&_fmt_val_none,
  P => \&_fmt_val_pipe,
  Q => \&_fmt_val_quote,
  S => \&_fmt_val_space,
  T => \&_fmt_val_text,
  );

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

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

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

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

=over 12

=item S<    B<'agt' > > Reference to the agent object

=item S<    B<'cfg' > > Reference to the RDA software configuration

=item S<    B<'oid' > > Object identifier

=item S<    B<'_blk'> > Block indicator (_pod2text)

=item S<    B<'_col'> > Screen width (in columns)

=item S<    B<'_fmt'> > Error explanation format hash

=item S<    B<'_off'> > Text offset (_pod2text)

=item S<    B<'_out'> > Output indicator

=item S<    B<'_pag'> > Pager redirection

=item S<    B<'_pre'> > Previous Tag text (_pod2text)

=item S<    B<'_reg'> > Applicable regions

=item S<    B<'_sep'> > Separation line

=item S<    B<'_tag'> > Tag text (_pod2text)

=item S<    B<'_txt'> > Reference to the text control object

=item S<    B<'_vms'> > VMS indicator

=back

Internal keys are prefixed by an underscore.

=cut

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

  # Create the library object
  $cfg = $agt->get_config;
  $env = $agt->get_env;
  $slf = bless {
    agt  => $agt,
    cfg  => $cfg,
    oid  => $agt->get_oid,
    _col => $cfg->get_columns,
    _out => $agt->get_info('out') ? 0 : 1,
    _reg => {text => 1},
    _vms => $cfg->is_vms,
    }, ref($cls) || $cls;

  # Extra initialization
  $val = $env->get_cmd('PAGER');
  $slf->{'_pag'} =
    defined($val)  ? "| $val" :
    $slf->{'_vms'} ? '| TYPE/PAGE=SAVE SYS$INPUT' : ## no critic (Interpolation)
                     '| more';
  $slf->{'_pag'} .= q{ 2>&1} if $cfg->is_unix || $cfg->is_cygwin;
  $slf->{'_sep'} = q{-} x $slf->{'_col'};

  # Identify applicable regions
  if (defined($val = $env->get_value('RDA_MAN')))
  { foreach my $key (split(/,/, $val))
    { $slf->{'_reg'}->{$key} = 1 if $key;
    }
  }

  # Return the object reference
  return $slf;
}

=head2 S<$h-E<gt>dsp_block($text[,$var[,$flag]])>

This method displays a text block. The text can contain variables that are
resolved through attributes specified as a hash. When the variable is not
defined, settings and properties are used. When the flag is set or not
specified, it displays the error explanation through a pager.

=cut

sub dsp_block
{ my ($slf, $txt, $var, $flg) = @_;

  return _dsp_text($slf,
    (ref($txt) eq 'ARRAY') ? $txt :
    ref($txt)              ? [$txt->get_lines] :
    defined($txt)          ? [split(/\n/, $txt)] :
                             [], $var, $flg);
}

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

This method displays the data content. When the flag is set, it displays the
data through a pager.

=cut

sub dsp_data
{ my ($slf, $dat, $flg) = @_;
  my ($ofh, $pid, $ret);

  return 0 unless $slf->{'_out'} && defined($dat);

  $dat = join(qq{\n}, @{$dat}, q{}) if ref($dat);
  $ofh = $slf->{'agt'}->get_screen;
  return syswrite($ofh, $dat, length($dat))
    unless $flg && -t $ofh;
  $pid = open(OUT, $slf->{'_pag'})  ## no critic (Handle,Open)
    or die get_string('ERR_PAGER', $!);
  $ret = syswrite(OUT, $dat, length($dat));
  close(OUT);
  waitpid($pid, 0);
  return $ret;
}

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

This method displays the explanation of the specified error. When the flag is
set or not specified, it displays the error explanation through a pager.

=cut

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

  return $slf->{'_out'}
    ? dsp_report($slf, RDA::Handle::Memory->new(explain($slf, $err)),
        defined($flg) ? $flg : 1)
    : 0;
}

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

This method displays the help associated to the calling package. It first
looks to an existing translation before extracting the information from the
package file.

=cut

sub dsp_help
{ my ($slf, $flg) = @_;
  my ($fil, $ifh, $pkg);

  $flg = 1 unless defined($flg);
  ($pkg, $fil) = caller;
  return
    ($pkg =~ m/([^:]+)$/
      && ($ifh = $slf->{'cfg'}->get_text->get_handle("$1.pod")))
              ? _dsp_pod($slf, $ifh, $flg) :
    (-r $fil) ? _dsp_pod($slf, $fil, $flg) :
                0;
}

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

This method displays the specified line. It converts the leading spaces and a
possible bullet character in a prefix and wraps the words according to the
display width. Is also recognizes a Control-A character as a separator between
the prefix and the text. When the flag is set, it disables character encoding.

=cut

sub dsp_line
{ my ($slf, $lin, $flg) = @_;
  my ($buf);

  return 0 unless $slf->{'_out'} && defined($lin);

  ## no critic (Capture)
  $lin =~ s/\\/\\134/g if $flg;
  $lin =~  s/^(.*?)\001// || $lin =~ s/^(\s*([o\-\*]\s+)?)//;
  $buf = length($lin) ? wrap_string($slf, $1, $lin) : $1;
  return syswrite($slf->{'agt'}->get_screen, $buf, length($buf));
}

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

This method displays data in Perl documentation format. When you specify an
array of files as the argument, it converts the first readable file from that
list. When the flag is set or not specified, it displays the documentation
through a pager.

=cut

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

  if ($slf->{'_out'} && defined($fil))
  { my ($cfg, $pth, $ref);

    $cfg = $slf->{'cfg'};
    $flg = 1 unless defined($flg);
    $ref = ref($fil);
    if ($ref eq 'ARRAY')
    { foreach my $pth (@{$fil})
      { return _dsp_pod($slf, $pth, $flg) if -r $pth;
      }
    }
    elsif ($ref || $cfg->is_absolute($fil))
    { return _dsp_pod($slf, $fil, $flg);
    }
    else
    { return _dsp_pod($slf, $pth, $flg)
        if -r ($pth = $cfg->get_file('D_RDA_POD', $fil, '.pod'))
        || -r ($pth = $cfg->get_file('D_RDA_COL', $fil, '.ctl'))
        || -r ($pth = $cfg->get_file('D_RDA_INC', $fil, '.pod'))
        || -r ($pth = $cfg->get_file('D_RDA_POD', $fil, '.pm'))
        || -r ($pth = $cfg->get_file('D_RDA_INC', $fil, '.pm'));
    }
  }
  return 0;
}

sub _dsp_pod
{ my ($slf, $fil, $flg) = @_;
  my ($pid, $ret);

  if ($flg && -t $slf->{'agt'}->get_screen)
  { $pid = open(OUT, $slf->{'_pag'})  ## no critic (Handle,Open)
      or die get_string('ERR_PAGER', $!);
    $ret = _pod2text(\*OUT, $slf, $fil);
    close(OUT);
    waitpid($pid, 0);
  }
  else
  { $ret = _pod2text($slf->{'agt'}->get_screen, $slf, $fil);
  }
  return $ret;
}

sub _pod2text  ## no critic (Complex)
{ my ($ofh, $slf, $fil) = @_;
  my ($cut, $dft, $flg, $hdr, $ifh, $max, $reg, @off);
  local $/ = q{};    # Treat multiple empty lines as a single empty line

  $cut = 1;
  $dft = 4;
  $flg = 0;
  $hdr = q{  };
  $slf->{'_blk'} = 0;
  $slf->{'_off'} = $dft;

  # Extract the documentation and format it
  if (ref($fil))
  { $ifh = $fil;
  }
  else
  { $ifh = IO::File->new;
    $ifh->open("<$fil") or die get_string('ERR_MAN', $fil, $!);
  }
  while (<$ifh>)
  { # Extract the documentation
    if ($cut)
    { next unless m/^=/;
      $cut = 0;
    }
    if ($reg)
    { next unless m/^=end\s+$reg[\n\r\s]*$/;
      $reg = undef;
    }

    # Resolve attributes
    $max = 10;
    s{E<(\w+)>}{\&$1;}g;
    while ($max-- && m/[A-Z]</)
    { s{L<([^|>]+)\|[^>]+>}{_fmt_lnk($1)}eg;
      s{C<(.*?)>}{"$1"}sg;
      s{I<(.*?)>}{*$1*}sg;
      s{X<.*?>}{}sg;
      s{[A-Z]<(.*?)>}{$1}sg;
    }
    s{\&amp;}{&}g;
    s{\&lt;}{<}g;
    s{\&gt;}{>}g;
    s{\&verbar;}{|}g;
    s{\&sol;}{/}g;
    s{\&(0[0-7]{1,3}|0x[0-9A-Fa-f]{1,4});}{chr(oct($1))}eg;
    s{\&(\d+);}{chr($1)}eg;
    s{[\s\r\n]+$}{};

    # Treat the pod directives
    if (s{^=(\S*)\s?}{})
    { my $cmd = $1;

      if ($cmd eq 'cut')
      { $cut = 1;
      }
      elsif ($cmd eq 'pod')
      { $cut = 0;
      }
      elsif ($cmd eq 'head1')
      { _prt_buf($slf, $ofh, $_, 0);
      }
      elsif ($cmd eq 'head2' || $cmd eq 'head3')
      { _prt_buf($slf, $ofh, $hdr.$_, 0);
      }
      elsif ($cmd eq 'over')
      { $slf->{'_pre'} = $slf->{'_tag'} if exists($slf->{'_tag'});
        unshift(@off, $slf->{'_off'});
        $slf->{'_off'} += ($_ + 0) || $dft;
        $flg = 1;
      }
      elsif ($cmd eq 'back')
      { _prt_blk($slf, $ofh, q{}, 1) if exists($slf->{'_tag'});
        $slf->{'_off'} = shift(@off) || $dft;
        $flg = 0;
      }
      elsif ($cmd eq 'item')
      { my ($lgt, $off, $tag);

        _prt_blk($slf, $ofh, q{}, 0) if exists($slf->{'_tag'});
        $off = $slf->{'_off'};
        $tag = exists($slf->{'_pre'}) ? delete($slf->{'_pre'}) :
          $SPC x ($off[0] || $dft);
        s{\n}{ }g;
        $tag .= $_.$SPC;
        for ($lgt = length($tag) ; $lgt < $off ; ++$lgt)  ## no critic (Loop)
        { $tag .= $SPC;
        }
        $slf->{'_blk'} = 0 unless $flg;
        $slf->{'_tag'} = $tag;
        $flg = 0;
      }
      elsif ($cmd eq 'begin')
      { if (!exists($slf->{'_reg'}->{$_}))
        { $reg = $_;
        }
        elsif ($_ eq 'credits')
        { _prt_buf($slf, $ofh, 'CREDITS', 0);
        }
      }
    }
    elsif (m/^\s+/)
    { my ($pre);

      _prt_blk($slf, $ofh, q{}, 0) if exists($slf->{'_tag'});
      $pre = $SPC x $slf->{'_off'};
      s{\n}{\n$pre}g;
      _prt_buf($slf, $ofh, qq{$pre$_}, 1);
    }
    else
    { _prt_blk($slf, $ofh, $_, 1);
    }
  }
  close($ifh);
  return 1;
}

sub _fmt_lnk
{ my ($str) = @_;

  $str =~ s/:/./g if $str =~ s/^abr://;
  return $str;
}

sub _prt_blk
{ my ($slf, $ofh, $str, $nxt) = @_;
  my ($buf, $lgt, $off);

  $off = $slf->{'_off'};
  if (exists($slf->{'_tag'}))
  { $lgt = length($buf = delete($slf->{'_tag'}));
    if ($lgt > $off)
    { $buf .= $str;
      ($buf, $str) = ($buf =~ m/^(\s*\S+\s)(.*)/s);
      $lgt = length($buf);
    }
  }
  elsif (exists($slf->{'_pre'}))
  { $lgt = length($buf = delete($slf->{'_pre'}));
  }
  else
  { $buf = $SPC x ($lgt = $off);
  }

  foreach my $wrd (split(/\s/, $str))
  { $lgt += length($wrd);
    if ($lgt > $slf->{'_col'})
    { _prt_buf($slf, $ofh, $buf, 0);
      $buf = $SPC x $off;
      $lgt = $off + length($wrd);
    }
    $buf .= $wrd;
    $buf .= $SPC;
    ++$lgt;
  }

  if ($lgt)
  { _prt_buf($slf, $ofh, $buf, $nxt);
  }
  else
  { $slf->{'_blk'} = $nxt;
  }
  return;
}

sub _prt_buf
{ my ($slf, $ofh, $buf, $nxt) = @_;

  $buf =~ s/\s+$//;
  $buf .= qq{\n};
  $buf = "\n$buf" if $slf->{'_blk'};
  $slf->{'_blk'} = $nxt;
  return syswrite($ofh, $buf, length($buf));
}

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

This method formats and displays a report. You can specify the report as a
string or a reference to an array of lines. When the flag is set or is not
specified, it displays the report through a pager. It returns the number of
lines effectively treated.

Following format directives are available:

Multi-Column output:

  .C <# spaces><eol>
  <item><eol>
  ...
  <item><eol>
  <eol>

Indented paragraph:

  .I '<prefix text>' <# new lines><eol>
  <line><eol>
  ...
  <line><eol>
  <eol>

Matrix output:

  .M <# columns> '<title>'<eol>
  <string>|...|<text><eol>
  ...
  <string>|...|<text><eol>
  <eol>

  .M <# columns> '<prefix|text>'<eol>
  <string>|...|<text><eol>
  ...
  <string>|...|<text><eol>
  <eol>

New lines:

  .N <# new lines><eol>

Paragraph:

  .P <# new lines><eol>
  <line><eol>
  ...
  <line><eol>
  <eol>

Query (Web only)

  .Q <key>='<label>'<eol>

Report Name:

  .R '<title>'<eol>

Separation line:

  .S<eol>

Title:

  .T '<title>'<eol>

Comment:

  # <comment text to skip>

=cut

sub dsp_report
{ my ($slf, $rpt, $flg) = @_;
  my ($cnt, $ifh, $pid, $ref);

  # Abort when there is no output
  return 0 unless $slf->{'_out'};

  # Produce the report
  $ref = ref($rpt);
  if ($ref eq 'ARRAY')
  { $ifh = RDA::Handle::Vector->new($rpt);
  }
  elsif ($ref)
  { $ifh = $rpt;
  }
  elsif (defined($rpt) && length($rpt))
  { $ifh = RDA::Handle::Memory->new($rpt);
    $ifh->setinfo('eol', 0);
  }
  else
  { return 0;
  }

  if (($flg || !defined($flg)) && -t $slf->{'agt'}->get_screen)
  { $pid = open(OUT, $slf->{'_pag'})  ## no critic (Handle,Open)
      or die get_string('ERR_PAGER', $!);
    $cnt = _dsp_report($slf, $ifh, *OUT);
    close(OUT);
    waitpid($pid, 0);
  }
  else
  { $cnt = _dsp_report($slf, $ifh, $slf->{'agt'}->get_screen);
  }

  # Return the number of line treated
  return $cnt;
}

sub _dsp_report  ## no critic (Complex)
{ my ($slf, $ifh, $ofh) = @_;
  my ($buf, $cnt);

  $cnt = 0;
  while (<$ifh>)
  { if (m/^\.C(?:\s*(\d+))?$/)
    { $buf = _fmt_columns($slf, $ifh, $1);
    }
    elsif (m/^\.I\s*'(.*)'(?:\s+(\d+))?$/)
    { $buf = wrap_string($slf, _clr_string($1), _read_para($ifh), $2);
    }
    elsif (m/^\.M\s*(\d+)\s*'((.*?)\|)?(.*)'$/)
    { my ($col, $fmt, $max, $pre, $txt, @max, @tbl);

      $col = $1;
      $txt = $4;
      if (defined($2))
      { $pre = $3;
        $buf = wrap_string($slf, _clr_string($pre), _clr_string($txt));
      }
      else
      { $pre = q{};
        $buf = _clr_string($txt).qq{\n};
        $buf =~ s/\\([0-3][0-7]{2}|0x[0-9A-Fa-f]{2})/chr(oct($1))/eg;
      }
      $pre =~ s/\S/ /g;
      if ($col > 1)
      { for (1..$col)
        { push(@max, 0);
        }
        while (<$ifh>)
        { my ($lgt, $rec, $str, @lin);

          s/[\n\r\s]+$//;
          last unless length($_);
          @lin = split(/\|/, $_, $col);
          next unless defined($txt = pop(@lin));
          push(@tbl, $rec = [_clr_string($txt)]);
          for (my $off = $col ; --$off > 0 ; )    ## no critic (Loop)
          { unshift(@{$rec}, $str = _clr_string(pop(@lin)));
            $max[$off] = $lgt if $max[$off] < ($lgt = length($str));
          }
        }
        $fmt = $pre.q{  };
        for (my $off = 1 ; $off < $col ; ++$off)  ## no critic (Loop)
        { $max[$off] += 2;
          $fmt .= q{%-}.$1.q{s} if $max[$off] =~ m/^(\d+)$/;
        }
        foreach my $rec (@tbl)
        { $txt = pop(@{$rec});
          $buf .= wrap_string($slf, sprintf($fmt, @{$rec}), $txt);
        }
      }
    }
    elsif (m/^\.N\s*(\d+)$/)
    { next unless $1 > 0;  ## no critic (Unless)
      $buf = qq{\n} x $1;
    }
    elsif (m/^\.P(?:\s*(\d+))?$/)
    { $buf = wrap_string($slf, q{}, _read_para($ifh), $1);
    }
    elsif (m/^\.[RT]\s*'(.*)'$/)
    { $buf = _clr_string($1).qq{\n};
      $buf =~ s/\\([0-3][0-7]{2}|0x[0-9A-Fa-f]{2})/chr(oct($1))/eg;
    }
    elsif (m/^\.S$/)
    { $buf = $slf->{'_sep'}.qq{\n};
    }
    elsif (!m/^(?:#|\.Q)/)
    { $buf = wrap_string($slf, q{}, _clr_string($_));
    }
    syswrite($ofh, $buf, length($buf));
    ++$cnt;
  }
  $ifh->close;

  # Return the number of line treated
  return $cnt;
}

=head2 S<$h-E<gt>dsp_string($prefix,$text[,$next])>

This method displays a string. The string is wrapped according to the screen
width and the prefix is added on each screen line. On continuous lines, spaces
replace non-space characters. The last argument indicates the number of line
feeds to add at the end of the string (1 by default).

=cut

sub dsp_string
{ my ($slf, $pre, $txt, $nxt) = @_;
  my ($buf);

  return 0 unless $slf->{'_out'} && defined($pre) && defined($txt);
  $buf = wrap_string($slf, $pre, $txt, $nxt);
  return syswrite($slf->{'agt'}->get_screen, $buf, length($buf));
}

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

This method displays a text. The text can contain variables that are resolved
through attributes specified as a hash. When the variable is not defined,
settings and properties are used. RDA restricts the property resolution to the
following property groups: C<CFG>, C<COL>, C<DFT>, C<ENV>, C<OUT>, C<RDA>,
C<REG>, C<RUN>, C<SET>, and C<STA>.

When the flag is set or is not specified, it displays the report through a
pager. It returns the number of lines effectively treated.

=cut

sub dsp_text
{ my ($slf, $nam, $var, $flg) = @_;

  return 0 unless defined($nam);
  $nam = "common-$nam" unless $nam =~ m/-/;
  return _dsp_text($slf,
    $slf->{'cfg'}->get_text->get_detail($nam, []), $var, $flg);
}

sub _dsp_text
{ my ($slf, $txt, $var, $flg) = @_;
  my ($buf, $lin);

  $buf = q{};
  $var = {} unless ref($var) eq 'HASH';
  foreach my $det (@{$txt})
  { $lin = $det;
    $lin =~ s{[\n\r\s]+$}{};
    $buf .= $tb_cmd{exists($tb_cmd{$1}) ? $1 : q{-}}
      if $lin =~ s{^\[(\w)\]\s?}{};
    $lin =~ s{\$\{((\w+\.)*\w+)(\/(\w)(\w)?)?\}}
             {_enc_value($slf, $var, $1, $4 || 'V', $5 || 'F')}eg;
    $buf .= qq{$lin\n\n};
  }
  return $slf->dsp_report($buf, $flg);
}

sub _enc_value
{ my ($slf, $tbl, $key, $mod, $fmt) = @_;
  my ($str);

  $str = q{?};
  if (exists($tbl->{$key}))
  { $str = $tbl->{$key};
  }
  elsif ($key =~ m/^CFG\.(\w+)$/)
  { $str = $slf->{'cfg'}->get_group($1);
  }
  elsif ($key =~ m/^COL\.((\w+\.)*\w+)$/)
  { $str = &{$tb_fmt{exists($tb_fmt{$fmt}) ? $fmt : 'F'}}(
      $slf->{'agt'}->get_collector->get_element($mod, $1, q{?}));
  }
  elsif ($key =~ m/^DFT\.((\w+\.)*\w+)$/)
  { $str = &{$tb_fmt{exists($tb_fmt{$fmt}) ? $fmt : 'F'}}(
      $slf->{'agt'}->get_collector->get_element($mod, "DEFAULT.$1", q{?}));
  }
  elsif ($key =~ m/^ENV\.(\w+)$/)
  { $str = $slf->{'agt'}->get_env($1, q{?});
  }
  elsif ($key =~ m/^OUT\.(\w+)$/)
  { $str = $slf->{'agt'}->get_collector->get_path($1);
  }
  elsif ($key =~ m/^RDA\.(\w+)$/)
  { $str = $slf->{'cfg'}->get_value($1, q{?});
  }
  elsif ($key =~ m/^REG\.(\w+)$/)
  { $str = $slf->{'agt'}->get_registry($1, q{?});
  }
  elsif ($key =~ m/^RUN\.((\w+\.)*\w+)$/)
  { $str = &{$tb_fmt{exists($tb_fmt{$fmt}) ? $fmt : 'F'}}(
      $slf->{'agt'}->get_run->get_element($mod, $1, q{?}));
  }
  elsif ($key =~ m/^SET\.((\w+\.)*\w+)$/)
  { $str = &{$tb_fmt{exists($tb_fmt{$fmt}) ? $fmt : 'F'}}(
      $slf->{'agt'}->get_collector->get_element($mod, "SETUP.$1", q{?}));
  }
  elsif ($key =~ m/^STA\.((\w+\.)*\w+)$/)
  { $str = &{$tb_fmt{exists($tb_fmt{$fmt}) ? $fmt : 'F'}}(
      $slf->{'agt'}->get_collector->get_element($mod, "STATUS.$1", q{?}));
  }
  else
  { $str = &{$tb_fmt{exists($tb_fmt{$fmt}) ? $fmt : 'F'}}(
      $slf->{'agt'}->get_collector->get_element($mod, $key, q{?}));
  }
  $str =~ s{\\}{\\134}g;
  return $str;
}

=head2 S<$h-E<gt>explain($error)>

This method returns the explanation of the specified error as a report script.

=cut

sub explain
{ my ($slf, $err) = @_;
  my ($buf, $det, $fmt, $lgt, $lin, $max, $txt);

  # Alter the text control on first call
  unless (exists($slf->{'_txt'}))
  { $RDA::Text::CONTROL = undef;
    $slf->{'cfg'}->set_text($slf->{'_txt'} =
      RDA::Text->new($slf->{'cfg'}, $slf->{'agt'}));
    $slf->{'_txt'}->set_info('flg', 1);
  }

  # Define the explanation formats on first use
  if (exists($slf->{'_fmt'}))
  { $fmt = $slf->{'_fmt'};
  }
  else
  { $slf->{'_fmt'} = $fmt = {q{-} => qq{\n}};
    $max = length($txt = get_string('Action'));
    $fmt->{'A'} = qq{\n\n.I '$txt'\n};
    $lgt = length($txt = get_string('Cause'));
    $fmt->{'C'} = qq{\n\n.I '$txt'\n};
    $max = $lgt if $max < $lgt;
    $txt = $SPC x $max;
    $fmt->{'B'} = qq{\n\n.I '$txt\001- '\n};
    $fmt->{'P'} = qq{\n\n.I '$txt'\n};
  }

  # Normalize the message reference
  if ($err =~ m/^([A-Z]+)-(\d+)$/i)
  { $err = sprintf('%s-%05d', uc($1), $2);
  }
  elsif ($err =~ m/^(\d+)$/)
  { $err = sprintf('RDA-%05d', $1);
  }
  else
  { die get_string('BAD_ERROR', $err);
  }

  # Get the message details
  $txt = RDA::Text->new;
  die get_string('NO_EXPLAIN', $err)
    unless ref($det = $txt->get_detail($err));

  # Display the error explanation
  $buf = qq{.P\n}.$txt->get_format($err);
  $buf =~ s{[\n\r\s]+$}{};  #
  foreach my $det (@{$det})
  { $lin = $det;
    $lin =~ s{[\n\r\s]+$}{};  #
    $lin =~ s{^\[(\w)\]\s?}{$fmt->{exists($fmt->{$1}) ? $1 : q{-}}}e;
    $buf .= $lin;
  }
  $buf .= qq{\n\n};

  # Return the explanation report
  return $buf;
}

=head1 TEXT METHODS

=head2 S<$h-E<gt>wrap_string($prefix,$text[,$next])>

This method wraps a string. The string is wrapped according to the screen
width. The prefix is added on each screen line. Non-space characters in the
prefix are replaced by spaces on continuous lines. The last argument indicates
the number of line feeds to add at the end of the string (1 by default).

It supports the C<\nnn> and C<\Oxnn> character encoding in both prefix and
text.

=cut

sub wrap_string
{ my ($slf, $pre, $txt, $nxt) = @_;
  my ($buf, $cnt, $col, $lgt, $str, @lin);

  $buf = q{};
  $pre =~ s/\001//;
  $pre =~ s/\\([0-3][0-7]{2}|0x[0-9A-Fa-f]{2})/chr(oct($1))/eg;
  $col = $slf->{'_col'} - length($pre);
  $cnt = (@lin = split(/\n|\\012/, $txt));
  $nxt = 1 unless defined($nxt);
  foreach my $lin (@lin)
  { --$cnt;
    $str = q{};
    $lgt = $col;
    $lin =~ s/[\r\s]+$//;
    foreach my $wrd (split(/\s+/, $lin))
    { $wrd =~ s/\\([0-3][0-7]{2}|0x[0-9A-Fa-f]{2})/chr(oct($1))/eg;
      $wrd =~ s/\240/ /g;
      $lgt += length($wrd) + 1;
      if ($lgt > $col)
      { if (length($str))
        { $buf .= $pre.$str.qq{\n};
          $pre =~ s/\S/ /g;
        }
        $lgt = length($wrd);
        $str = $wrd;
      }
      else
      { $str .= $SPC;
        $str .= $wrd;
      }
    }
    if (length($str))
    { $str .= qq{\n} if $cnt || $nxt > 0;
      $buf .= $pre.$str;
      $pre =~ s/\S/ /g;
    }
    elsif ($cnt || $nxt > 0)
    { $buf .= qq{\n};
    }
  }
  $buf .= qq{\n} x $nxt if --$nxt > 0;
  return $buf;
}

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

# Remove string formatting
sub _clr_string
{ my ($str) = @_;

  $str =~ s{``(.*?)``}{$1}sg;
  $str =~ s{~~(.*?)~~}{$1}sg;
  $str =~ s{\*\*(.*?)\*\*}{$1}sg;
  $str =~ s{\!\!(\w+):(.*?)\!(.*?)\!\!}{$3}sg;
  return $str;
}

# Format a paragraph in columns
sub _fmt_columns
{ my ($slf, $ifh, $sep) = @_;
  my ($buf, $cnt, $col, $lgt, $lin, $max, $pre, $str, $txt, @tbl);

  $buf = q{};
  $cnt = $max = 0;
  $sep = 0 unless defined($sep);
  while (defined($lin = $ifh->getline))
  { last if $lin =~ m/^$/;  ## no critic (Fixed)
    push(@tbl, $lin);
    $lin =~ s{\001}{};
    $lin =~ s{\\([0-3][0-7]{2}|0x[0-9A-Fa-f]{2})}{chr(oct($1))}eg;
    $max = $lgt if ($lgt = length($lin)) > $max;
    ++$cnt;
  }
  if ($max && ($col = int($slf->{'_col'} / ($max + $sep))))
  { for (; $cnt % $col ; ++$cnt)                          ## no critic (Loop)
    { push(@tbl, q{});
    }
    $lgt = $cnt / $col;
  }
  if ($col > 1)
  { $sep = $SPC x $sep;
    for (my $row = 0 ; $row < $lgt ; ++$row)              ## no critic (Loop)
    { $str = q{};
      for (my $off = $row ;  $off < $cnt ; $off += $lgt)  ## no critic (Loop)
      { $txt = $tbl[$off];
        $txt =~ s{\001}{};
        $txt =~ s{\\([0-3][0-7]{2}|0x[0-9A-Fa-f]{2})}{chr(oct($1))}eg;
        $str .= $sep;
        $str .= sprintf(q{%-*s}, $max, $txt);
      }
      $str =~ s{\s+$}{};
      $buf .= $str.qq{\n};
    }
  }
  else
  { foreach my $row (@tbl)
    { ($pre, $txt) = split(/\001/, $row, 2);
      $buf .= defined($txt)
        ? wrap_string($slf, $pre, $txt, 1)
        : wrap_string($slf, q{},  $pre, 1);
    }
  }
  return $buf;
}

# Read a paragraph
sub _read_para
{ local $/ = q{};  # Treat multiple empty lines as a single empty line
  return _clr_string(shift->getline);
}

# --- Conversion mechanims ----------------------------------------------------

sub _fmt_val_bullet
{ my ($str);

  $str = join(qq{\n\n}.$tb_cmd{'b'}, @_);
  $str =~ s{\|}{\n}g;
  return $str;
}

sub _fmt_val_comma
{ return join(q{,}, @_);
}

sub _fmt_val_dot
{ return join(q{.}, @_);
}

sub _fmt_val_first
{ return $_[0];
}

sub _fmt_val_last
{ return $_[-1];
}

sub _fmt_val_none
{ return join(q{}, @_);
}

sub _fmt_val_pipe
{ return join(q{|}, @_);
}

sub _fmt_val_quote
{ return join($SPC, map {RDA::Object::Rda->quote($_)} @_);
}

sub _fmt_val_space
{ return join($SPC, @_);
}

sub _fmt_val_text
{ return join(q{, }, @_);
}

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

# Initialize the display control
sub _begin_display
{ my ($pkg) = @_;

  $pkg->set_top('DSP', $pkg->get_agent->get_display);
  return;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Handle::Memory|RDA::Handle::Memory>,
L<RDA::Handle::Vector|RDA::Handle::Vector>,
L<RDA::Object|RDA::Object>,
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