# Report.pm: Class Used for Managing Reports

package RDA::Object::Report;

# $Id: Report.pm,v 1.46 2015/08/27 19:23:33 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Object/Report.pm,v 1.46 2015/08/27 19:23:33 RDA Exp $
#
# Change History
# 20150827  MSC  Extend the write_diff method.

=head1 NAME

RDA::Object::Report - Class Used for Managing Reports

=head1 SYNOPSIS

 require RDA::Object::Report;

=head1 DESCRIPTION

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

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use File::Copy;
  use IO::File;
  use IO::Handle;
  use RDA::Text qw(get_string);
  use RDA::Driver::Diff;
  use RDA::Driver::Sgml;
  use RDA::Handle::Null;
  use RDA::Object;
  use RDA::Object::Buffer;
  use RDA::Object::Message;
  use RDA::Object::Rda qw($APPEND $CREATE $EXE_PERMS $FIL_PERMS $TMP_PERMS);
  use RDA::SDCL::Block qw($CONT $SPC_BLK $SPC_REF $SPC_VAL);
}

# Define the global public variables
use vars qw($STRINGS $VERSION @ISA %SDCL);
$VERSION = sprintf('%d.%02d', q$Revision: 1.46 $ =~ /(\d+)\.(\d+)/);
@ISA     = qw(RDA::Object Exporter);
%SDCL    = (
  als => {
    ## no critic (Interpolation)
    'addBlock'       => ['${CUR.O_REPORT}', 'add_block'],
    'addEntry'       => ['${CUR.O_REPORT}', 'add_entry'],
    'alignOwner'     => ['${CUR.O_REPORT}', 'align_owner'],
    'beginBlock'     => ['${CUR.O_REPORT}', 'begin_block'],
    'convertReport'  => ['${CUR.O_REPORT}', 'convert'],
    'dupBlock'       => ['${CUR.O_REPORT}', 'dup_block'],
    'endBlock'       => ['${CUR.O_REPORT}', 'end_block'],
    'getHtmlLink'    => ['${CUR.O_REPORT}', 'get_html'],
    'getRawLink'     => ['${CUR.O_REPORT}', 'get_raw'],
    'getWriteLength' => ['${CUR.O_REPORT}', 'get_length'],
    'getXmlLink'     => ['${CUR.O_REPORT}', 'get_xml'],
    'hasOutput'      => ['${CUR.O_REPORT}', 'has_output'],
    'isActive'       => ['${CUR.O_REPORT}', 'is_active'],
    'isCreated'      => ['${CUR.O_REPORT}', 'is_created'],
    'isSkipped'      => ['${CUR.O_REPORT}', 'is_skipped'],
    'renderReport'   => ['${CUR.O_REPORT}', 'render'],
    'statDir'        => ['${CUR.O_REPORT}', 'stat_dir'],
    'statFile'       => ['${CUR.O_REPORT}', 'stat_file'],
    'writeCatalog'   => ['${CUR.O_REPORT}', 'write_catalog'],
    'writeComment'   => ['${CUR.O_REPORT}', 'write_comment'],
    'writeData'      => ['${CUR.O_REPORT}', 'write_data'],
    'writeDiff'      => ['${CUR.O_REPORT}', 'write_diff'],
    'writeExplorer'  => ['${CUR.O_REPORT}', 'write_explorer'],
    'writeExtract'   => ['${CUR.O_REPORT}', 'write_extract'],
    'writeFile'      => ['${CUR.O_REPORT}', 'write_file'],
    'writeFilter'    => ['${CUR.O_REPORT}', 'write_filter'],
    'writeLines'     => ['${CUR.O_REPORT}', 'write_lines'],
    'writeTail'      => ['${CUR.O_REPORT}', 'write_tail'],
    'writeVerbatim'  => ['${CUR.O_REPORT}', 'write_verbatim'],
    },
  cmd => {
    'end'      => [\&_exe_end,      \&_get_object, 0,   0],
    'close'    => [\&_exe_close,    \&_get_object, 0,   0],
    'prefix'   => [\&_exe_prefix,   \&_get_object, 'B', 0],
    'title'    => [\&_exe_title,    \&_get_list,   0,   0],
    'unprefix' => [\&_exe_unprefix, \&_get_object, 0,   0],
    'untitle'  => [\&_exe_untitle,  \&_get_value,  0,   0],
    'write'    => [\&_exe_write,    \&_get_list,   0,   0],
    },
  dep => [qw(RDA::Object::Output)],
  inc => [qw(RDA::Object)],
  met => {
    'add_block'      => {ret => 0},
    'add_entry'      => {ret => 0},
    'align_owner'    => {ret => 0},
    'begin_block'    => {ret => 0},
    'clone'          => {ret => 0},
    'convert'        => {ret => 0},
    'close'          => {ret => 0},
    'create'         => {ret => 0},
    'dup_block'      => {ret => 0},
    'end_block'      => {ret => 0},
    'get_file'       => {ret => 0},
    'get_html'       => {ret => 0},
    'get_info'       => {ret => 0},
    'get_length'     => {ret => 0},
    'get_path'       => {ret => 0},
    'get_raw'        => {ret => 0},
    'get_report'     => {ret => 0},
    'get_xml'        => {ret => 0},
    'has_output'     => {ret => 0},
    'is_active'      => {ret => 0},
    'is_cloned'      => {ret => 0},
    'is_created'     => {ret => 0},
    'is_locked'      => {ret => 0},
    'is_skipped'     => {ret => 0},
    'pop_lines'      => {ret => 0},
    'push_lines'     => {ret => 0},
    'render'         => {ret => 0},
    'set_info'       => {ret => 0},
    'share'          => {ret => 0},
    'stat_dir'       => {ret => 0},
    'stat_file'      => {ret => 0},
    'unlink'         => {ret => 0},
    'unprefix'       => {ret => 0},
    'update'         => {ret => 0},
    'write'          => {ret => 0, evl => 'L'},
    'write_catalog'  => {ret => 0},
    'write_comment'  => {ret => 0, evl => 'L'},
    'write_data'     => {ret => 0},
    'write_diff'     => {ret => 0},
    'write_explorer' => {ret => 0},
    'write_extract'  => {ret => 0},
    'write_file'     => {ret => 0},
    'write_filter'   => {ret => 0},
    'write_lines'    => {ret => 0},
    'write_tail'     => {ret => 0},
    'write_verbatim' => {ret => 0},
    },
  );

# Define the global private constants
my $REPORT = qr/^RDA::Object::(Pipe|Report)$/i;

# Define the global private variables
my @tb_bit = qw(
  --- --x -w- -wx r-- r-x rw- rwx
  --S --s -wS -ws r-S r-s rwS rws);
my @tb_idx = qw(T F P H);
my @tb_mon = qw(? Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
my %tb_add = (
  E => ['exp', \&_val_explorer, 0],
  X => ['exp', \&_val_explorer, 1],
  );
my %tb_blk = (
  E => \&_add_explorer,
  L => \&_add_cfm,
  T => \&_add_tags,
  X => \&_add_xplr,
  );
my %tb_cat = (
  F => q{},
  H => q{(Head)},
  P => q{(Partial)},
  T => q{(Tail)},
  );
my %tb_dsc = (
  Cygwin  => {cnv => \&_w_convert,
              nat => \&_w_native,
              nrm => \&_w_norm,
             },
  Unix    => {cnv => \&_u_convert,
              nat => \&_u_native,
              nrm => \&_u_norm,
             },
  Vms     => {cnv => \&_v_convert,
              nat => \&_v_native,
              nrm => \&_v_norm,
             },
  Windows => {cnv => \&_w_convert,
              nat => \&_w_native,
              nrm => \&_w_norm,
             },
  );
my %tb_dup = (
  E => [\&_dup_explorer, 0],
  X => [\&_dup_explorer, 1],
  );
my %tb_err = (
  B => get_string('DAT_ERROR'),
  C => get_string('RPT_ERROR'),
  D => get_string('DAT_ERROR'),
  E => get_string('EXT_ERROR'),
  F => get_string('RPT_ERROR'),
  R => get_string('REF_ERROR'),
  S => get_string('SMP_ERROR'),
  T => get_string('TMP_ERROR'),
  );
my %tb_idx = (
  H => '---+ Oracle Home Files',
  O => '---+ Other Files',
  );
my %tb_ini = (
  B => \&_init_bin,
  C => \&_init_report,
  D => \&_init_data,
  E => \&_init_extern,
  F => \&_init_file,
  R => \&_init_ref,
  S => \&_init_sample,
  T => \&_init_temp,
  );
my %tb_mon = (
  JAN => 1,
  FEB => 2,
  MAR => 3,
  APR => 4,
  MAY => 5,
  JUN => 6,
  JUL => 7,
  AUG => 8,
  SEP => 9,
  OCT => 10,
  NOV => 11,
  DEC => 12,
  );

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

=head2 S<$h = RDA::Object::Report-E<gt>new($out,$oid,$typ,$pre,$nam,$dyn,...)>

The report file object constructor. This method takes the report control object
reference, the object identifier, the report type, the report prefix, the
report name, and the dynamic name indicator as arguments.

It supports the following report types:

=for stopwords Extern

=over 9

=item B<    'B' > Binary data file

=item B<    'C' > Collection report file

=item B<    'D' > Data file

=item B<    'E' > Extern file

=item B<    'F' > Collection file

=item B<    'R' > Reference file

=item B<    'S' > Sample file

=item B<    'T' > Temporary file

=back

It is represented by a blessed hash reference. The following special keys are
used:

=over 12

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

=item S<    B<'add' > > Catalog requests

=item S<    B<'aft' > > List of lines to insert after an output

=item S<    B<'bkp' > > Suspended filter control object reference

=item S<    B<'bef' > > List of lines to insert before an output

=item S<    B<'bin' > > Binary mode indicator

=item S<    B<'cat' > > Catalog entries

=item S<    B<'cfm' > > Customer file management level

=item S<    B<'cln' > > Clone indicator

=item S<    B<'cls' > > Verbatim block closing indicator

=item S<    B<'cod' > > Code to execute before next write operation

=item S<    B<'col' > > Reference to the collector object

=item S<    B<'dir' > > Directory type

=item S<    B<'dyn' > > Dynamic name indicator

=item S<    B<'eof' > > Indicates whether all writes should be done at file end

=item S<    B<'ext' > > Report file name extension

=item S<    B<'fil' > > Report file name

=item S<    B<'flg' > > Report file creation flag

=item S<    B<'flt' > > Filter control object reference

=item S<    B<'fmt' > > File name format

=item S<    B<'gid' > > Expected group identifier

=item S<    B<'idx' > > Index indicator

=item S<    B<'ini' > > File permissions at opening time

=item S<    B<'lck' > > Lock indicator

=item S<    B<'lgt' > > File length

=item S<    B<'lst' > > List of associated files

=item S<    B<'mod' > > Required file permissions at closing time

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

=item S<    B<'ofh' > > Report file handle

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

=item S<    B<'out' > > Reference to the report control object

=item S<    B<'pid' > > Subprocess identifier

=item S<    B<'pre' > > Report prefix

=item S<    B<'pth' > > File path

=item S<    B<'rnd' > > Direct rendering handle

=item S<    B<'sig' > > Signature elements

=item S<    B<'siz' > > Block size

=item S<    B<'skp' > > Skip indicator

=item S<    B<'spc' > > Disk space used

=item S<    B<'typ' > > Report file type

=item S<    B<'uid' > > Expected user identifier

=item S<    B<'vrb' > > Verbatim block indicator

=back

=cut

sub new  ## no critic (Args)
{ my ($cls, $out, $oid, $typ, $pre, $nam, $dyn, $vrb, $cfm, $skp, @arg) = @_;

  die get_string('BAD_TYPE', $typ) unless exists($tb_ini{$typ = uc($typ)});

  # Create the report file object
  my $slf = bless {
    abr => $out->get_info('abr'),
    add => {},
    bin => 0,
    blk => q{},
    cat => {},
    cfm => $cfm,
    col => $out->get_info('col'),
    dir => 'C',
    dyn => $dyn,
    eof => 0,
    fmt => 0,
    idx => 1,
    ini => $FIL_PERMS,
    lck => 0,
    lst => [],
    nam => $nam,
    oid => $oid,
    out => $out,
    pre => $pre,
    skp => $skp,
    siz => 0,
    spc => 0,
    tag => [],
    typ => $typ,
    vrb => $vrb,
    }, ref($cls) || $cls;

  # Perform type-specific initialization
  &{$tb_ini{$typ}}($slf, @arg);

  # Test directory validity
  $slf->{'col'}->get_dir($slf->{'dir'});

  # Propagate ownership alignment
  $slf->align_owner if $typ ne 'T' && $out->get_info('own');

  # Take care about file name capitalisation
  $slf->{'fil'} = lc($slf->{'fil'}) unless $out->get_info('cas');

  # Return the object reference
  return $slf;
}

sub _init_bin
{ my ($slf, $lgt, $ext) = @_;
  my ($out);

  $out = $slf->{'out'};
  $slf->{'bin'} = 1;
  $slf->{'dir'} = 'M' if $out->get_info('mrc');
  $slf->{'ext'} = defined($ext) ? $ext : '.dat';
  if ($out->get_info('flt'))
  { $slf->{'fil'} = $slf->{'oid'}.$slf->{'ext'};
    $slf->{'fmt'} = 0;
  }
  else
  { $slf->{'fil'} =
      $slf->{'oid'}.substr(q{_}.$slf->{'nam'}, 0, $lgt).$slf->{'ext'};
    $slf->{'fmt'} = -1;
  }
  return;
}

sub _init_data
{ my ($slf, $lgt, $ext) = @_;
  my ($out, $flt);

  $out = $slf->{'out'};
  $slf->{'dir'} = 'M' if $out->get_info('mrc');
  $slf->{'ext'} = defined($ext) ? $ext : '.dat';
  if ($flt = $out->get_info('flt'))
  { $slf->{'flt'} = $flt;
    $slf->{'fil'} = $slf->{'oid'}.$slf->{'ext'};
    $slf->{'fmt'} = 0;
  }
  else
  { $slf->{'fil'} =
      $slf->{'oid'}.substr(q{_}.$slf->{'nam'}, 0, $lgt).$slf->{'ext'};
    $slf->{'fmt'} = -1;
  }
  return;
}

sub _init_extern
{ my ($slf, $lgt, $ext) = @_;
  my ($flt);

  $slf->{'dir'} = 'E';
  $slf->{'ext'} = defined($ext) ? $ext : '.txt';
  $slf->{'flt'} = $flt if ($flt = $slf->{'out'}->get_info('flt'));
  if ($flt && $slf->{'dyn'})
  { $slf->{'fil'} = $slf->{'oid'}.$slf->{'ext'};
    $slf->{'fmt'} = 0;
  }
  elsif (length($slf->{'nam'}) - 7 < $lgt)
  { $slf->{'fil'} = $slf->{'abr'}.$slf->{'pre'}.$slf->{'nam'}.$slf->{'ext'};
    $slf->{'fmt'} = 1;
  }
  else
  { $slf->{'fil'} =
      $slf->{'oid'}.substr(q{_}.$slf->{'nam'}, 0, $lgt).$slf->{'ext'};
    $slf->{'fmt'} = -1;
  }
  return;
}

sub _init_file
{ my ($slf, $lgt, $ext) = @_;
  my ($out, $flt);

  $out = $slf->{'out'};
  $slf->{'sig'} = {
    rel => $out->get_info('rel'),
    mod => $out->get_oid,
    ver => $out->get_info('ver')};
  $slf->{'dir'} = 'M' if $out->get_info('mrc');
  $slf->{'ext'} = '.txt';
  if ($flt = $out->get_info('flt'))
  { $slf->{'flt'} = $flt;
    $slf->{'fil'} = $slf->{'oid'}.$slf->{'ext'};
    $slf->{'fmt'} = 0;
  }
  else
  { $slf->{'fil'} =
      $slf->{'oid'}.substr(q{_}.$slf->{'nam'}, 0, $lgt).$slf->{'ext'};
    $slf->{'fmt'} = -1;
  }
  _gen_signature($slf);
  return;
}

sub _init_ref
{ my ($slf, $lgt, $ext) = @_;
  my ($flt);

  $slf->{'dir'} = 'R';
  $slf->{'ext'} = defined($ext) ? $ext : '.txt';
  $slf->{'flt'} = $flt if ($flt = $slf->{'out'}->get_info('flt'));
  if ($flt && $slf->{'dyn'})
  { $slf->{'fil'} = $slf->{'oid'}.$slf->{'ext'};
    $slf->{'fmt'} = 0;
  }
  elsif (length($slf->{'nam'}) - 7 < $lgt)
  { $slf->{'fil'} = $slf->{'abr'}.$slf->{'pre'}.$slf->{'nam'}.$slf->{'ext'};
    $slf->{'fmt'} = 1;
  }
  else
  { $slf->{'fil'} =
      $slf->{'oid'}.substr(q{_}.$slf->{'nam'}, 0, $lgt).$slf->{'ext'};
    $slf->{'fmt'} = -1;
  }
  $slf->{'idx'} = $slf->{'fmt'};
  return;
}

sub _init_report
{ my ($slf, $lgt, $ext) = @_;
  my ($flt, $out, $rnd);

  $out = $slf->{'out'};
  $slf->{'sig'} = {
    rel => $out->get_info('rel'),
    mod => $out->get_oid,
    ver => $out->get_info('ver')};
  $slf->{'dir'} = 'M' if $out->get_info('mrc');
  $slf->{'ext'} = '.txt';
  if ($flt = $out->get_info('flt'))
  { $slf->{'flt'} = $flt;
  }
  elsif ($rnd = $out->get_info('rnd'))
  { $slf->{'rnd'} = $rnd
      if ($rnd = $rnd->get_handle($slf->{'abr'}, $slf->{'nam'}));
  }
  if ($flt && $slf->{'dyn'})
  { $slf->{'fil'} = $slf->{'oid'}.$slf->{'ext'};
    $slf->{'fmt'} = 0;
  }
  elsif (length($slf->{'nam'}) - 7 < $lgt)
  { $slf->{'fil'} = $slf->{'abr'}.$slf->{'pre'}.$slf->{'nam'}.$slf->{'ext'};
    $slf->{'fmt'} = 1;
  }
  else
  { $slf->{'fil'} =
      $slf->{'oid'}.substr(q{_}.$slf->{'nam'}, 0, $lgt).$slf->{'ext'};
    $slf->{'fmt'} = -1;
  }
  _gen_signature($slf);
  return;
}

sub _init_sample
{ my ($slf, $lgt, $ext) = @_;
  my ($flt);

  $slf->{'dir'} = 'S';
  $slf->{'ext'} = defined($ext) ? $ext : '.txt';
  $slf->{'flt'} = $flt if ($flt = $slf->{'out'}->get_info('flt'));
  if ($flt && $slf->{'dyn'})
  { $slf->{'fil'} = $slf->{'oid'}.$slf->{'ext'};
    $slf->{'fmt'} = 0;
  }
  elsif (length($slf->{'nam'}) - 7 < $lgt)
  { $slf->{'fil'} = $slf->{'abr'}.$slf->{'pre'}.$slf->{'nam'}.$slf->{'ext'};
    $slf->{'fmt'} = 1;
  }
  else
  { $slf->{'fil'} =
      $slf->{'oid'}.substr(q{_}.$slf->{'nam'}, 0, $lgt).$slf->{'ext'};
    $slf->{'fmt'} = -1;
  }
  return;
}

sub _init_temp
{ my ($slf, $lgt, $ext, $flg) = @_;

  $slf->{'dir'} = 'T';
  $slf->{'ext'} = defined($ext) ? $ext : '.tmp';
  $slf->{'fil'} =
    $slf->{'oid'}.substr(q{_}.$slf->{'nam'}, 0, $lgt).$slf->{'ext'};
  $slf->{'idx'} = 0;
  $slf->{'pth'} = RDA::Object::Rda->cat_file(
    $slf->{'col'}->get_dir($slf->{'dir'}), $slf->{'fil'});
  if (defined($flg))
  { $slf->{'ini'} = $TMP_PERMS;
    $slf->{'mod'} = $EXE_PERMS if $flg;
  }
  return;
}

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

  $slf->{'bef'} = [
    '<!-- Oracle Remote Diagnostic Agent / Data Collection Results '.
      $slf->{'sig'}->{'rel'}.' -->',
    sprintf('<!-- Module:%s Version:%.2f Report:%s OS:%s -->',
      $slf->{'sig'}->{'mod'}, $slf->{'sig'}->{'ver'}, $slf->{'nam'}, $^O)
    ]
    if exists($slf->{'sig'});
  return;
}

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

This method indicates that the user and group identifiers of the report must
be aligned to those of the report directory on the report closure. That
alignment also applies to the rendered and converted files. It returns the
number of files already converted.

=cut

sub align_owner
{ my ($slf) = @_;
  my ($uid, $gid, @fil);

  ($uid, $gid) = $slf->{'out'}->get_owner;
  if (defined($uid))
  { # Store the user and group identifiers of the report directory
    $slf->{'uid'} = $uid;
    $slf->{'gid'} = $gid;

    # Adjust existing files
    if (exists($slf->{'flg'}))
    { @fil = @{$slf->{'lst'}};
      unshift(@fil, $slf->{'pth'}) unless exists($slf->{'ofh'});
      return chown($uid, $gid, @fil) if @fil;
    }
  }
  return 0;
}

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

This method clones a locked report for using it in the current context. It
discards any prefix and lines to insert before and after the output.

=cut

sub clone
{ my ($slf) = @_;
  my ($cln, $oid, $tbl, $tmp);

  # Abort when the report is already ended
  die get_string('ENDED') unless exists($slf->{'lck'});

  # Abort when the report is not locked
  $oid = $slf->{'oid'};
  $tmp = $slf->{'typ'} eq 'T';
  $tbl = $slf->{'out'}->get_info($tmp ? 'tmp' : 'rpt');
  die get_string('CLONE_ACTIVE')
    unless $slf->{'lck'} && !exists($tbl->{$oid});  ## no critic (Unless)
  die get_string('CLONE_NEW')
    unless exists($slf->{'flg'});

  # Clone the object
  $cln = bless {%{$slf}}, ref($slf);
  $cln->{'cln'} = 1 unless $tmp;
  $cln->{'lck'} = 0;
  delete($cln->{'aft'});
  delete($cln->{'bef'});
  delete($cln->{'cod'});
  $tbl->{$oid} = $cln;

  # Return the clone object reference
  return $cln;
}

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

This method closes the report file. Unless the flag is set, it deletes any
prefix treatment.

When previously requested, it aligns the user and group identifiers of the
report file to those of the report directory. For temporary files, the file
permissions could be adapted.

=cut

sub close  ## no critic (Ambiguous,Builtin)
{ my ($slf, $flg) = @_;

  # Abort when the report is already ended
  die get_string('ENDED') unless exists($slf->{'lck'});

  # Delete any prefix treatment
  delete($slf->{'cod'}) unless $flg;

  # Close the file
  delete($slf->{'ofh'})->close if exists($slf->{'ofh'});

  # Adjust the permissions and ownership
  if (exists($slf->{'flg'}))
  { chmod($slf->{'mod'}, $slf->{'pth'})
      if exists($slf->{'mod'});
    chown($slf->{'uid'}, $slf->{'gid'}, $slf->{'pth'})
      if exists($slf->{'uid'});
  }

  # Update the disk space used
  update($slf, -1) unless $slf->{'typ'} eq 'T';
  return;
}

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

This method ends the report and converts it in XML. When previously requested,
it aligns the user and group identifiers of the generated file to those of the
report directory. It returns the path of the generated file on successful
completion. Otherwise, it returns an undefined value.

=cut

sub convert
{ my ($slf) = @_;
  my ($pth, @pth);

  # End the report when still active
  $slf->{'out'}->end_report($slf) if exists($slf->{'lck'});

  # Convert the report
  return unless exists($slf->{'flg'});
  return $slf->{'pth'} unless $slf->{'fil'} =~ m/\.txt$/i;
  @pth = $slf->{'col'}->submit(q{.},
    RDA::Object::Message->new('CONVERT.GEN_XML',
      reports => $slf->{'fil'},
      type    => $slf->{'dir'},
      verbose => 0))->get_value('reports');
  push(@{$slf->{'lst'}}, @pth);
  chown($slf->{'uid'}, $slf->{'gid'}, @pth) if exists($slf->{'uid'});
  return $pth[0];
}

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

This method forces the creation of a report. It writes the lines to insert
before any output.

=cut

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

  # Abort when the report is already ended
  die get_string('ENDED') unless exists($slf->{'lck'});

  # Create the file when not yet done
  unless (exists($slf->{'flg'}) || $slf->{'skp'})
  { # Create or open the file
    $slf->get_handle(1);

    # Put the start lines
    $slf->write(join(qq{\n}, @{delete($slf->{'bef'})}, q{}))
      if exists($slf->{'bef'});

    # Indicate the file creation
    $slf->{'flg'} = 0;
  }
  return 1;
}

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

This method returns the path of the report directory.

=cut

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

  return $slf->{'col'}->get_dir($slf->{'dir'});
}

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

This method returns the path to the report file. When the flag is set, it
returns an absolute path.

=cut

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

  return $flg
    ? $slf->{'col'}->get_absolute($slf->{'dir'}, $slf->{'fil'})
    : $slf->{'col'}->get_relative($slf->{'dir'}, $slf->{'fil'});
}

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

This method returns the file handle of the report file. It creates the file
on the first call. Unless the flag is set, it executes prefix blocks when
present.

=cut

sub get_handle  ## no critic (Complex)
{ my ($slf, $flg) = @_;
  my ($buf, $ofh, $pth, $val);

  # Abort when the object is ended or locked
  die get_string('ENDED') unless exists($slf->{'lck'});
  die get_string('LOCKED') if $slf->{'lck'};

  # Get the report file handle
  if (exists($slf->{'ofh'}))
  { $ofh = $slf->{'ofh'};
  }
  elsif ($slf->{'skp'})
  { $slf->{'ofh'} = $ofh = RDA::Handle::Null->new;
  }
  else
  { # Wait for asynchronous command completion
    $slf->wait(1);

    # Create or open the file
    $pth = $slf->get_path;
    $ofh = exists($slf->{'flt'}) ? $slf->{'flt'}->new :
           exists($slf->{'rnd'}) ? $slf->{'rnd'} :
                                   IO::File->new;
    if (exists($slf->{'flg'}) || $slf->{'eof'})
    { $ofh->open($pth, $APPEND, $slf->{'ini'})
        or die sprintf("%s '%s' (%s)\n",
                       $tb_err{$slf->{'typ'}}, $slf->{'fil'}, $!);
      sysseek($ofh, 0, 2);
    }
    else
    { $ofh->open($pth, $CREATE, $slf->{'ini'})
        or die sprintf("%s '%s' (%s)\n",
                       $tb_err{$slf->{'typ'}}, $slf->{'fil'}, $!);
    }
    binmode($ofh) if $slf->{'bin'};
    $slf->{'ofh'} = $ofh;
  }

  # Put the suffix lines
  if ($val = delete($slf->{'aft'}))
  { $val = [$val] unless ref($val) eq 'ARRAY';
    _write($ofh, $slf,
      join(q{}, grep {defined($_) && !ref($_)} @{$val}).qq{\n});
  }

  # Perform all pre-treatments
  unless ($flg)
  { # Put the start lines
    _write($ofh, $slf, join(qq{\n}, @{delete($slf->{'bef'})}, q{}))
      if exists($slf->{'bef'});

    # When required, execute the prefix code block
    die get_string('ERR_PREFIX') if exists($slf->{'cod'})
      && delete($slf->{'cod'})->exec_block('prefix ['.$slf->{'fil'}.q{]});

    # Report the file as created only after prefix block execution
    $slf->{'flg'} = 1 unless $slf->{'skp'};
  }

  # Return the file handle
  return $ofh;
}

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

This method returns the link to the rendered file. Unless the flag is set, it
generates a link from the index. It returns an undefined value for a temporary
file.

=cut

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

  unless ($slf->{'typ'} eq 'T')
  { $fil = $slf->{'col'}->get_name($slf->{'dir'}, $slf->{'fil'});
    $fil = "../$fil" if $flg;
    $fil =~ s/\.(dat|txt)/.htm/i;
  }
  return $fil;
}

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

This method returns the report path. The directories are created when
required. When the flag is set, it adapts the creation mode.

=cut

sub get_path
{ my ($slf, $flg) = @_;
  my ($mod, $pth);

  if (exists($slf->{'flg'}))
  { $mod = $flg ? '>' : q{};
    $pth = $slf->{'pth'};
  }
  elsif (exists($slf->{'lck'}))
  { # Create the report directory when needed
    $pth = $slf->{'col'}->get_dir($slf->{'dir'}, 1);

    # Adapt the opening mode
    $mod = q{};
    $slf->{'flg'} = 1 if $flg;
    $slf->{'pth'} = $pth = RDA::Object::Rda->cat_file($pth, $slf->{'fil'});
  }
  else
  { # Abort when the report is already ended
    die get_string('ENDED');
  }
  return $mod.$pth;
}

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

This method returns the report name. It returns an undefined value for a
temporary file.

=cut

sub get_report
{ my ($slf) = @_;
  my ($fil);

  unless ($slf->{'typ'} eq 'T')
  { $fil = $slf->{'col'}->get_name($slf->{'dir'}, $slf->{'fil'});
    $fil =~ s/\.(dat|txt)/.htm/i;
  }
  return $fil;
}

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

This method returns the link to the raw file. Unless the flag is set, it
generates a link from the index. It returns an undefined value for a temporary
file.

=cut

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

  unless ($slf->{'typ'} eq 'T')
  { $fil = $slf->{'col'}->get_name($slf->{'dir'}, $slf->{'fil'});
    $fil = "../$fil" if $flg;
  }
  return $fil;
}

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

This method returns the link to the XML conversion. Unless the flag is set, it
generates a link from the index. It returns an undefined value for a temporary
file.

=cut

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

  unless ($slf->{'typ'} eq 'T')
  { $fil = $slf->{'col'}->get_name($slf->{'dir'}, $slf->{'fil'});
    $fil = "../$fil" if $flg;
    $fil =~ s/\.(dat|txt)/.xml/i;
  }
  return $fil;
}

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

This method indicates whether lines have been written in the report file since
the last prefix command. When the flag is set, it clears any prefix also.

It becomes false after file closure.

=cut

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

  if (exists($slf->{'cod'}))
  { delete($slf->{'cod'}) if $flg;
    return 0;
  }
  return $slf->{'skp'}         ? 0 :
         exists($slf->{'ofh'}) ? 1 :
                                 0;
}

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

This method indicates whether the object is not yet ended.

=cut

sub is_active
{ return exists(shift->{'lck'}) ? 1 : 0;
}

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

This method indicates whether the object is cloned.

=cut

sub is_cloned
{ return shift->{'cln'} ? 1 : 0;
}

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

This method indicates whether the report file has been created. It reports
whether the file has not yet been created in the prefix block that is executed
for the first line written to the report file.

When the flag is set, it clears any prefix also.

=cut

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

  delete($slf->{'cod'}) if $flg;
  return exists($slf->{'flg'}) ? 1 : 0;
}

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

This method indicates whether the object is locked.

=cut

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

  return exists($slf->{'flg'}) ? $slf->{'lck'} : 0;
}

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

This method indicates whether the report is skipped.

=cut

sub is_skipped
{ return shift->{'skp'};
}

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

This method removes recent lines from the list of lines to insert before or
after an output. It returns the last string removed from the stack.

=cut

sub pop_lines
{ my ($slf, $key, $cnt) = @_;
  my ($lin);

  # Abort when the report is already ended
  die get_string('ENDED') unless exists($slf->{'lck'});

  # Pop lines
  if (($key eq 'aft' || $key eq 'bef') && exists($slf->{$key}))
  { $cnt = 1 unless defined($cnt);
    $lin = pop(@{$slf->{$key}}) while $cnt-- > 0;
    delete($slf->{$key}) unless scalar @{$slf->{$key}};
  }
  return $lin;
}

=head2 S<$h-E<gt>push_lines($key,$line...)>

This method adds lines in the list of lines to insert before or after an
output. You can specify the extra lines as array references.

=cut

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

  # Abort when the report is already ended
  die get_string('ENDED') unless exists($slf->{'lck'});

  # Push specified lines
  if ($key eq 'aft' || $key eq 'bef')
  { foreach my $arg (@arg)
    { $arg = [$arg] unless ref($arg) eq 'ARRAY';
      foreach my $lin (@{$arg})
      { push(@{$slf->{$key}}, $lin) if defined($lin) && !ref($lin);
      }
    }
  }
  return;
}

=head2 S<$h-E<gt>render([$title[,theme]])>

This method ends the report and renders it. When previously requested, it
aligns the user and group identifiers of the generated file to those of the
report directory. It returns the path of the generated file on successful
completion. Otherwise, it returns an undefined value.

=cut

sub render
{ my ($slf, $ttl, $thm) = @_;
  my (@pth);

  # End the report when still active
  $slf->{'out'}->end_report($slf) if exists($slf->{'lck'});

  # Generate the report
  return unless exists($slf->{'flg'});
  return $slf->{'pth'} unless $slf->{'fil'} =~ m/\.(dat|txt)$/i;
  @pth = $slf->{'col'}->submit(q{.},
    RDA::Object::Message->new('RENDER.GEN_HTML',
      align   => 0,
      reports => $slf->{'fil'},
      theme   => $thm,
      title   => $ttl,
      type    => $slf->{'dir'},
      verbose => 0))->get_value('reports');
  push(@{$slf->{'lst'}}, @pth);
  chown($slf->{'uid'}, $slf->{'gid'}, @pth) if exists($slf->{'uid'});
  return $pth[0];
}

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

This method unlinks the associated file. It returns the number of versions
removed.

=cut

sub unlink  ## no critic (Builtin)
{ my ($slf) = @_;
  my ($cnt);

  # Close the file
  $slf->close;

  # Delete the stored lines
  delete($slf->{'aft'});
  delete($slf->{'bef'});
  _gen_signature($slf);

  # Delete all catalog entries
  $slf->{'cat'} = {};

  # Resume output filtering
  $slf->{'flt'} = delete($slf->{'bkp'}) if exists($slf->{'bkp'});

  # Unlink the file
  $cnt = 0;
  if (exists($slf->{'pth'}))
  { delete($slf->{'flg'});
    ++$cnt while unlink($slf->{'pth'});
    foreach my $pth (@{$slf->{'lst'}})
    { ++$cnt while unlink($pth);
    }
  }
  return $cnt;
}

=head2 S<$h-E<gt>write($str[,$size])>

This method writes a string in the report file. It returns the number of bytes
actually written, or an undefined value if there was an error.

=cut

sub write  ## no critic (Builtin)
{ my ($slf) = @_;

  return _write($slf->get_handle, @_);
}

*syswrite = \&write;

sub _write
{ my ($ofh, $slf, $buf, $lgt) = @_;
  my ($inc, $ret);
  local $SIG{'PIPE'} = 'IGNORE';

  $lgt = length($buf) unless defined($lgt);
  $slf->{'out'}->decr_free($lgt);
  exists($slf->{'flt'}) ? $ofh->sysseek(0, 2) : sysseek($ofh, 0, 2)
    if $slf->{'eof'};
  if (defined($ret = $ofh->syswrite($buf, $lgt)))
  { $slf->{'siz'} += $ret;
    $slf->{'out'}->decr_free($inc) if ($inc = $ret - $lgt);
  }
  return $ret;
}

=head1 INTERNAL METHODS

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

This method deletes a report. The report file is ended when required.

=cut

sub delete_object
{ # End the report when not yet done
  $_[0]->end if exists($_[0]->{'lck'});

  # Delete the object
  $_[0]->SUPER::delete_object;
  return;
}

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

This method terminates the report. It returns the object reference.

=cut

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

  # End the report
  if (exists($slf->{'lck'}))
  { if ($slf->{'typ'} eq 'T')
    { $slf->unlink;
    }
    else
    { $slf->close;
    }
    delete($slf->{'lck'});
  }

  # Return the object reference
  return $slf;
}

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

This method locks the object. It ignores the request on ended objects.

=cut

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

  if (exists($slf->{'lck'}))
  { # Close the file
    delete($slf->{'ofh'})->close if exists($slf->{'ofh'});

    # Indicate that the object is locked
    $slf->{'lck'} = 1;
  }
  return;
}

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

This method resumes the output filtering.

=cut

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

  if (exists($slf->{'bkp'}))
  { $flg = exists($slf->{'ofh'});
    $slf->close(1);
    $slf->{'flt'} = delete($slf->{'bkp'});
    $slf->get_handle(1) if $flg;
  }
  return;
}

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

This method suspends the output filtering.

=cut

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

  if (exists($slf->{'flt'}))
  { $slf->close(1);
    $slf->{'bkp'} = delete($slf->{'flt'});
  }
  return;
}

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

This method unlocks the object.

=cut

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

  $slf->{'lck'} = 0 if exists($slf->{'lck'});
  return;
}

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

This method updates the disk space consumed by the report when the report is
open. It discards contributions from clone reports.

=cut

sub update
{ my ($slf, $flg) = @_;
  my ($inc, $siz);

  if (($flg || exists($slf->{'ofh'}))
    && exists($slf->{'flg'})
    && exists($slf->{'lck'})
    && exists($slf->{'out'})
    && exists($slf->{'pth'})
    && !exists($slf->{'cln'})
    && defined($siz = (stat($slf->{'pth'}))[7]))
  { $slf->{'out'}->update_space($inc = $siz - $slf->{'spc'});
    $slf->{'siz'} += $inc if $flg > 0;
    $slf->{'spc'} = $siz;
  }
  return;
}

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

This method waits for the completion of the associated background process (cf.
asynchronous operating system command execution). Unless the flag is set, lines
to put after are written to the report and the report is closed.

It returns the report reference.

=cut

sub wait  ## no critic (Builtin)
{ my ($slf, $flg) = @_;
  my ($pid);

  # Abort when the report is already ended
  die get_string('ENDED') unless exists($slf->{'lck'});

  # Wait for the subprocess completion
  if ($pid = delete($slf->{'pid'}))
  { eval {sleep(1) while kill(0, $pid)};
  }

  # When appropriate, execute post treatments
  unless ($flg)
  { # Add the suffix lines
    $slf->get_handle(1) if exists($slf->{'aft'});

    # Close the report file
    $slf->close;
  }

  # Return the report reference
  return $slf;
}

=head1 BLOCK MANAGEMENT METHODS

=head2 S<$h-E<gt>add_block($catalog,$detail...)>

This method adds the current (or next) block in the specified catalog at report
closure.

It supports the following catalog:

=over 9

=item B<    'E' >

To define a contribution to an Oracle Explorer report.

=item B<    'L' >

To alter the customer file management level of the block.

=item B<    'T' >

To associate one or more tags to the block. You can specify the tags as a list
or as a reference to a tag array. It replaces all groups of non-alphanumeric
characters in tags with an underscore.

=item B<    'X' >

To define a contribution to an Oracle Explorer report, filtering invalid
characters out the report names.

=back

=cut

sub add_block
{ my ($slf, $cat, @det) = @_;

  die get_string('NO_CATALOG')        unless defined($cat);
  die get_string('BAD_CATALOG', $cat) unless exists($tb_blk{$cat});
  return &{$tb_blk{$cat}}($slf, @det);
}

sub _add_cfm
{ my ($slf, $lvl) = @_;

  return unless defined($lvl);
  die get_string('BAD_CFM', $lvl)
    unless $lvl =~ m/^\d$/ && $lvl <= $slf->{'cfm'};  ## no critic (Unless)
  return $slf->{'add'}->{'cfm'} = $lvl;
}

sub _add_explorer
{ my ($slf, @det) = @_;

  return unless $slf->{'out'}->has_explorer;
  return $slf->{'add'}->{'exp'} = _val_explorer(0, @det);
}

sub _add_tags
{ my ($slf, @det) = @_;

  if (@det)
  { @det = @{$det[0]} if ref($det[0]) eq 'ARRAY';
    return $slf->{'add'}->{'tag'} = [@det] if (@det = map {_fmt_tag($_)} @det);
  }
  return;
}

sub _add_xplr
{ my ($slf, @det) = @_;

  return unless $slf->{'out'}->has_explorer;
  return $slf->{'add'}->{'exp'} = _val_explorer(1, @det);
}

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

  if (defined($str) && !ref($str))
  { $str = q{_}.$str.q{_};
    $str =~ s/[\_\W]+/_/g;
    return ($str) unless $str eq q{_} || $str eq q{};
  }
  return ();
}

sub _val_explorer
{ my ($flt, $typ, $nam, $alt) = @_;

  die get_string('EXP_TYPE')
    unless $typ && index('BDEGLOT', $typ) >= 0;  ## no critic (Unless)
  die get_string('EXP_NAME', $nam) if _val_report(\$nam, $flt);
  if ($typ eq 'L')
  { my ($lvl, $pre, @lvl);

    @lvl = ($nam =~ m{(/)}g);
    $lvl = @lvl;
    $pre = ($alt =~ s{^((\.\.\/){0,$lvl})}{}) ? $1 : q{};
    die get_string('EXP_NAME', $alt) if _val_report(\$alt, $flt);
    return [$typ, q{}, q{}, qq{$nam|$pre$alt} ];
  }
  return
    ($typ eq 'G') ? [$typ, q{},    q{},    $nam] :
    defined($alt) ? [$typ, q{<R>}, q{<B>}, $nam, RDA::Object::encode($alt)] :
                    [$typ, q{<R>}, q{<B>}, $nam];
}

sub _val_report
{ my ($nam, $flt) = @_;

  return 1 unless defined($$nam);
  return 2 if ref($$nam);
  $$nam =~ s{[\\\/]+}{/}g;
  $$nam =~ s{^(\.*/)+}{}g;
  $$nam =~ s{/(\./)+}{/}g;
  $$nam =~ s{[^\-\+\=\#\@\.\,\:\/A-Za-z0-9]+}{_}g if $flt;
  for (split(/\//, $$nam, -1))
  { return 3 unless $flt || m/^[\+\-\=\#\@\.\,\:\w]+$/;
    return 4 if m/^\.*$/;
  }
  return 0;
}

=head2 S<$h-E<gt>add_entry($catalog,$record)>

This method adds an entry in the specified catalog at report closure.

It supports the following catalog:

=over 9

=item B<    'E' > Oracle Explorer

=back

=cut

sub add_entry
{ my ($slf, $cat, @det) = @_;

  die get_string('NO_CATALOG')        unless defined($cat);
  die get_string('BAD_CATALOG', $cat) unless exists($tb_add{$cat});
  return _add_entry($slf, $tb_add{$cat}->[0],
    join(q{|}, @{&{$tb_add{$cat}->[1]}($tb_add{$cat}->[2], @det)}, qq{\n}));
}

sub _add_entry
{ my ($slf, $cat, $rec) = @_;

  return $slf->{'skp'}
    ? 0
    : push(@{$slf->{'cat'}->{$cat}}, $rec);
}

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

This method indicates the begin of a block. When the flag is set, it opens a
C<verbatim> section in the report.

=cut

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

  # When applicable, open a verbatim section in the report
  if ($flg)
  { $slf->write($tag ? "<verbatim:$tag>\n" : "<verbatim>\n");
    $slf->{'cls'} = $flg;
  }
  elsif (!exists($slf->{'ofh'}))
  { $slf->get_handle;
  }

  # Initialize the block
  return $slf->{'siz'} = 0;
}

=head2 S<$h-E<gt>dup_block($catalog,$detail...)>

This method generates a new entry from the last entry of the specified catalog.

It supports the following catalog:

=over 9

=item B<    'E' > Oracle Explorer

=back

=cut

sub dup_block
{ my ($slf, $cat, @det) = @_;
  my ($new);

  die get_string('NO_CATALOG')        unless defined($cat);
  die get_string('BAD_CATALOG', $cat) unless exists($tb_dup{$cat});
  return &{$tb_dup{$cat}->[0]}($slf, $tb_dup{$cat}->[1], @det);
}

sub _dup_explorer
{ my ($slf, $flt, $typ, $nam) = @_;
  my ($new, $rec, @rec);

  $new = _val_explorer($flt, $typ, $nam);
  return 0 unless $slf->{'out'}->has_explorer &&
                  ($rec = $slf->{'cat'}->{'exp'}->[-1]);
  @rec = split(/\|/, $rec);
  $rec[0] = $new->[0];
  $rec[3] = $new->[3];
  return _add_entry($slf, 'exp', join(q{|}, @rec));
}

=head2 S<$h-E<gt>end_block([$idx])>

This method indicates the end of a block. You can specify the index
contribution as an argument.

=cut

sub end_block
{ my ($slf, $idx, @cat) = @_;
  my ($blk, $off, $siz, $tbl, $url, @tag);

  # Treat catalog requests
  if (defined($url = $slf->get_report))
  { # Treat new requests
    foreach my $cat (@cat)
    { $slf->add_block(@{$cat}) if ref($cat) eq 'ARRAY';
    }

    # Determine the customer file management level for the block
    $tbl = $slf->{'add'};
    push(@tag, exists($tbl->{'cfm'})
      ? delete($tbl->{'cfm'})
      : $slf->{'cfm'});
    push(@tag, @{delete($tbl->{'tag'})}) if exists($tbl->{'tag'});
  }

  # Determine the block characteristics
  $blk =
    (!($siz = $slf->{'siz'})) ?
      join(q{/}, 0, 0, $slf->{'dir'}, $slf->{'fil'}, @tag) :
    defined($off = exists($slf->{'flt'}) ? $slf->get_handle->sysseek(0, 1)
                                         : sysseek($slf->get_handle, 0, 1)) ?
      join(q{/}, $off - $siz, $siz, $slf->{'dir'}, $slf->{'fil'}, @tag) :
    q{};

  # Add the catalog entries
  if (defined($url))
  { # Add the requested entries
    foreach my $key (keys(%{$tbl}))
    { _add_entry($slf, $key,
        join(q{|}, (map {($_ eq '<B>') ? $blk :
                        ($_ eq '<F>') ? $slf->get_file :
                        ($_ eq '<R>') ? $url :
                                        $_} @{delete($tbl->{$key})}), qq{\n}));
    }

    # Create the index entry
    _add_index($slf, $url, $blk, $idx) if ref($idx) eq 'ARRAY';
  }

  # When applicable, close the verbatim section in the report
  $slf->write("</verbatim>\n") if delete($slf->{'cls'});
  return;
}

sub _add_index
{ my ($slf, $url, $blk, $idx) = @_;
  my ($fmt, $pth, $rec, $typ, @arg);

  # Validate the arguments
  ($rec, $pth, $typ, $fmt) = @{$idx};
  return 0 unless $rec && $rec =~ m/^[BCEF]$/ && $pth && $slf->{'idx'};
  if ($rec eq 'F')
  { return 0 unless -f $pth;
    $pth = $slf->{'col'}->get_config->get_file('D_CWD', $pth)
      unless RDA::Object::Rda->is_absolute($pth);
    unless ($slf->{'out'}->add_file($pth))
    { $pth = $slf->{'flt'}->filter($pth) if exists($slf->{'flt'});
    }
    push(@arg, (defined($typ) && $typ =~ m/^[FHPT]$/) ? $typ : 'F');
    push(@arg, (defined($fmt) && $fmt =~ m/^[DT]$/)   ? $fmt : 'T');
  }
  elsif ($rec eq 'C' || $rec eq 'E')
  { $pth = $slf->{'flt'}->filter($pth) if exists($slf->{'flt'});
  }

  # Add the index entry
  return _add_entry($slf, 'idx', join(q{|}, $rec, $url, $blk,
    RDA::Object::encode($pth), @arg, qq{\n}));
}

=head1 PREFIX MANAGEMENT METHODS

=head2 S<$h-E<gt>deprefix($blk)>

This method suppresses the execution of a code block contained in the specified
block.

=cut

sub deprefix
{ my ($slf, $blk) = @_;

  delete($slf->{'cod'}) if exists($slf->{'lck'})
    && exists($slf->{'cod'}) && $slf->{'cod'}->get_package == $blk;
  return;
}

=head2 S<$h-E<gt>prefix($blk)>

This method specifies a code block to execute when writing to the report file.

=cut

sub prefix
{ my ($slf, $blk) = @_;

  # Abort when the report is already ended
  die get_string('ENDED') unless exists($slf->{'lck'});

  # Set the prefix
  return $slf->{'cod'} = $blk;
}

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

This method suppresses the execution of a code block when writing to the
report file.

=cut

sub unprefix
{ delete(shift->{'cod'});
  return;
}

=head1 SHARE METHODS

=head2 S<$h-E<gt>share($group,$link)>

This method shares the current report and adds it in the specified group with
the specified link text. Temporary files cannot be shared.

It returns a true value when the operation is successful. Otherwise, it returns
a false value.

=cut

sub share
{ my ($slf, $grp, $lnk) = @_;

  # Abort when the report is already ended
  die get_string('ENDED') unless exists($slf->{'lck'});

  # Define the share
  return ($slf->{'typ'} eq 'T' || $slf->{'skp'})
    ? 0
    : $slf->{'out'}->add_share($slf, $grp, $lnk);
}

=head1 REPORTING METHODS

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

This method returns the number of lines of the last file or buffer that has
been read completely.

=cut

sub get_length
{ return shift->{'lgt'};
}

=head2 S<$h-E<gt>stat_dir($opt,$dir)>

This method writes the content of a directory with the status information of
each file into the report file. It supports the following attributes:

=over 9

=item B<    'a' > Does not hide entries starting with C<.>

=item B<    'n' > Sorts by name (ascending)

=item B<    't' > Sorts by modification time (descending)

=back

It returns the number of files displayed, or 0 if the directory cannot be
opened, or -1 if no files are displayed.

=cut

sub stat_dir
{ my ($slf, $opt, $dir) = @_;
  my ($all, $fct, $max, $out, @tbl);

  # Abort if we can access to that directory
  return 0 unless $dir && -d $dir;

  # Decode the options
  $opt = q{} unless defined($opt);
  $all = index($opt, 'a') >= 0;
  $fct = (index($opt, 't') >= 0) ? q{t} :
         (index($opt, 'n') <  0) ? q{-} :
         $slf->{'_vms'}          ? q{v} :
                                   q{n};

  # Read the directory content
  $max = [0, 0, 0, 0, 0];
  $out = $slf->{'out'};
  if (RDA::Object::Rda->is_vms)
  { _get_vms_stat(\@tbl, $dir, 1, $max)
  }
  else
  { return 0 unless opendir(DIR, $dir);
    foreach my $nam (readdir(DIR))
    { _get_stat(\@tbl, $out, RDA::Object::Rda->cat_file($dir, $nam), $nam, $max)
        if $all || $nam !~ m/^\./;
    }
    closedir(DIR);
  }

  # Produce the directory listing
  return -1 unless @tbl;
  return _write_stat($slf, \@tbl, $max, $fct, $dir);
}

=head2 S<$h-E<gt>stat_file($opt,$file,...)>

This method reports the status information of the specified files. It supports
the following attributes are:

=over 9

=item B<    'b' > Displays the basename of the file only (default)

=item B<    'p' > Keeps the full path of the file

=back

It returns the number of files that have been successfully treated.

=cut

sub stat_file
{ my ($slf, $opt, @fil) = @_;
  my ($all, $flg, $max, $out, $vms, @tbl);

  # Decode the options
  $opt = 'b' unless defined($opt);
  $flg = index($opt, 'p') < 0;

  # Get the status information
  $max = [0, 0, 0, 0, 0];
  $out = $slf->{'out'};
  $vms = RDA::Object::Rda->is_vms;
  foreach my $fil (@fil)
  { if ($vms)
    { _get_vms_stat(\@tbl, $fil, $flg, $max);
    }
    else
    { _get_stat(\@tbl, $out, $fil,
        ($flg ? RDA::Object::Rda->basename($fil) : $fil), $max);
    }
  }

  # Write the status information in the report file
  return 0 unless @tbl;
  return _write_stat($slf, \@tbl, $max, q{});
}

# Decode date/time
sub _dec_dat
{ my ($str) = @_;

  return ($str =~ m/^(\d{1,2})-(\w{3})-(\d{4})\s+(\d{2}):(\d{2}):(\d{2})/)
    ? sprintf('%04d%02d%02d%02d%02d%02d',
              $3, $tb_mon{uc($2)} || 0, $1, $4, $5, $6)
    : 0;
}

# Convert the mode in its symbolic format
sub _fmt_bit
{ my ($val, $flg) = @_;
  $val += 8 if $flg;
  return $tb_bit[$val];
}

sub _fmt_mod
{ my $mod = shift;

  ## no critic (Bit,Number,Zero)
  return substr("?pc?d?b?-?l?s?w?", ($mod >> 12) & 017, 1)
    ._fmt_bit(($mod >> 6) & 07, $mod & 04000)
    ._fmt_bit(($mod >> 3) & 07, $mod & 02000)
    ._fmt_bit($mod & 07,        $mod & 01000);
}

# Simplify the date/time
sub _fmt_dat
{ my ($str) = @_;

  return q{} unless $str;
  return sprintf('  %s %2d %s:%s %s', $tb_mon[substr($str, 4, 2)],
    substr($str, 6, 2), substr($str, 8, 2), substr($str, 10, 2),
    substr($str, 0, 4)) if length($str) == 14;
  $str = gmtime($str);
  return q{  }.substr($str, 4, 12).q{ }.substr($str, 20, 4).q{ UTC};
}

# Resolve the group ID
sub _fmt_gid
{ my $gid = shift;
  my $str;

  eval {$str = getgrgid($gid)};
  return $gid ? "$gid" : q{} if $@ || !defined($str);
  return $str;
}

# Resolve the user ID
sub _fmt_uid
{ my $uid = shift;
  my $str;

  eval {$str = getpwuid($uid)};
  return $uid ? "$uid" : q{} if $@ || !defined($str);
  return $str;
}

# Get status information
sub _get_stat
{ my ($tbl, $out, $fil, $nam, $max) = @_;
  my ($grp, $lgt, $siz, $usr, @sta);

  # Get the status information
  return unless (@sta = lstat($fil));
  $out->add_lstat($fil, @sta);

  # Show symbolic links
  eval {$nam .= q{ -> }.readlink($fil)} if -l $fil;

  # Resolve the user and group IDs
  $usr = _fmt_uid($sta[4]);
  $grp = _fmt_gid($sta[5]);

  # Get the size or the device information
  $siz = (-b $fil || -c $fil)
    ? sprintf('[0x%x]', $sta[6])
    : sprintf('%d',     $sta[7]);

  # Adjust the information for the column sizes
  if ($max)
  { $max->[0] = 10;
    $max->[1] = $sta[3] if $sta[3] > $max->[1];
    $max->[2] = $lgt if ($lgt = length($usr)) > $max->[2];
    $max->[3] = $lgt if ($lgt = length($grp)) > $max->[3];
    $max->[4] = $lgt if ($lgt = length($siz)) > $max->[4];
  }

  # Add the record to the list
  return push(@{$tbl},
    [ _fmt_mod($sta[2]),
      $sta[3],
      $usr,
      $grp,
      $siz,
      $sta[10],
      $sta[9],
      $nam
    ]);
}

sub _get_vms_stat
{ my ($tbl, $pth, $flg, $max) = @_;
  my ($ifh, $lgt, $rec, @sta);

  # Get the status information
  $ifh = IO::Handle->new;
  if (open($ifh,   ## no critic (Handle,Open)
    q{dir/size/date=modified/owner/prot/noheading/notrailing/width=}.
    qq{(filename=1) $pth |}))
  { while (<$ifh>)
    { s/[\n\r\s]+$//;
      if (m/^\%DIRECT-W-NOFILES,/i)
      { next;
      }
      elsif (m/^\S/)
      { s/^.*\]// if $flg;
        $rec = [ q{}, 1, q{}, q{}, 0, 0, 0, $_ ];
        push(@{$tbl}, $rec);
      }
      elsif ($rec)
      { @sta = split(/\s+/, $_);
        if ((scalar @sta) == 6)
        { my ($grp, $usr);

          # Extract the information and update the record
          ($usr, $grp) = ($2, $1) if $sta[4] =~ m/^\[(.*),(.*)]$/;
          $rec->[0] = $sta[5];
          $rec->[2] = $usr || $sta[4];
          $rec->[3] = $grp || q{};
          $rec->[4] = $sta[1];
          $rec->[6] = _dec_dat($sta[2].q{ }.$sta[3]);

          # Adjust the information for the column sizes
          if ($max)
          { $max->[0] = $lgt if ($lgt = length($sta[5])) > $max->[0];
            $max->[1] = 1;
            $max->[2] = $lgt if ($lgt = length($usr)) > $max->[2];
            $max->[3] = $lgt if ($lgt = length($grp)) > $max->[3];
            $max->[4] = $lgt if ($lgt = length($sta[1])) > $max->[4];
          }
          $rec = undef;
        }
        else
        { $rec->[6] .= $_;
        }
      }
    }
    $ifh->close;
  }
  return;
}

# Display the status information
sub _write_stat
{ my ($slf, $tbl, $max, $fct, $dir) = @_;
  my ($buf, $nam);

  # Get the report file handle
  return 0 unless $slf->get_handle;

  # Determine the column sizes
  $max->[1] = length(sprintf('%d', $max->[1]));
  $max->[2]++ if $max->[2];
  $max->[3]++ if $max->[3];

  # Sort the files
  if ($fct eq 'n')
  { $tbl = [sort {$a->[7] cmp $b->[7]} @{$tbl}];
  }
  elsif ($fct eq 't')
  { $tbl = [sort {$b->[6] <=> $a->[6] ||  ## no critic (Reverse)
                  $a->[7] cmp $b->[7]} @{$tbl}];
  }
  elsif ($fct eq 'v')
  { $tbl = [sort {lc($a->[7]) cmp lc($b->[7])} @{$tbl}];
  }

  # Produce the directory listing
  $buf = qq{<verbatim:stat>\n};
  $buf .= qq{$dir:\n} if $dir;
  foreach my $sta (@{$tbl})
  { $nam = $sta->[7];
    $nam =~ s/[\000-\037]/?/g;
    $buf .= sprintf(" %-*s %*d %-*s%-*s%*s%s%s  %s\n",
      $max->[0], $sta->[0],
      $max->[1], $sta->[1], $max->[2], $sta->[2],
      $max->[3], $sta->[3], $max->[4], $sta->[4],
      _fmt_dat($sta->[5]), _fmt_dat($sta->[6]), $nam);
  }
  $buf .= qq{</verbatim>\n};
  $slf->write($buf);

  # Indicate the number of files
  return scalar @{$tbl};
}

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

This method writes the catalog of collected files. It returns the number of
entries that it generated.

=cut

sub write_catalog
{ my ($slf) = @_;
  my ($cfg, $cnt, $col, $dir, $dsc, $fct, $ifh, $nam, $pth, $typ, @rec);

  # Initialization
  $col = $slf->{'col'};
  $cfg = $col->get_config;
  $dir = $col->get_data;
  $ifh = IO::File->new;

  # Parse the index files
  $cnt = 0;
  $dsc = {%{$tb_dsc{$cfg->get_family}}, idx => [undef, {}, {}]};
  $fct = $dsc->{'nrm'};
  if (opendir(DIR, $dir))
  { foreach my $fil (sort readdir(DIR))
    { next unless $fil =~ m/_I.fil$/;
      if ($ifh->open('<'.$cfg->cat_file($dir, $fil)))
      { $nam = uc(substr($fil, 0, -6));
        $nam =~ s/_/./;
        while (<$ifh>)
        { ($typ, @rec) = split(/\|/);
          if ($typ eq 'S')
          { _add_dir($dsc, &$fct($pth), &$fct(_dec_path($rec[1])))
              if RDA::Object::Rda->is_absolute($pth = _dec_path($rec[0]));
          }
          elsif ($typ eq 'F')
          { $typ = exists($tb_cat{$rec[3]}) ? $tb_cat{$rec[3]} : q{};
            push(@{_add_file($dsc, &$fct(_dec_path($rec[2])))->[1]},
              q{[[../}.$rec[0].qq{][_blank][$nam]]$typ});
            ++$cnt;
          }
        }
        $ifh->close;
      }
    }
    closedir(DIR)
  }

  # Produce the catalog
  if ($cnt && $slf->get_handle)
  { $slf->write(qq{|*Path*|*Location*|\n});
    _write_catalog($slf, $dsc->{'nat'}, $dsc->{'idx'});
    $slf->write(qq{[[#Top][Back to top]]\n});
  }

  # Return the number of entries
  return $cnt;
}

# Add a directory entry
sub _add_dir
{ my ($dsc, $pth, $alt) = @_;
  my ($cur, $fct, $fil, $lvl, $new, $syn, @dir, @syn);

  @dir = split(/\//, $pth, -1);    # Needs all fields to support '/'
  if (defined($alt))
  { @syn = split(/\//, $alt, -1);  # Needs all fields to support '/'
    @syn = () unless (scalar @dir) == (scalar @syn);
  }
  $cur = $dsc->{'idx'};
  $fct = $dsc->{'cnv'};
  $lvl = 0;
  foreach my $itm (@dir)
  { $syn = shift(@syn);
    next unless length($itm) || $lvl == 0;
    die get_string('BAD_DIR', $pth) unless ref($cur->[1]) eq 'HASH';

    # Check for tree improvement
    $itm = &$fct($cur, $itm, $itm);
    if (defined($syn))
    { $syn = &$fct($cur, $syn, $syn);
      if ($syn ne $itm && exists($cur->[1]->{$syn}))
      { if (exists($cur->[1]->{$itm}))
        { _merge_nodes($cur->[1]->{$itm}, delete($cur->[1]->{$syn}), $pth);
        }
        else
        { $cur->[1]->{$itm} = delete($cur->[1]->{$syn});
        }
        $cur->[2]->{lc($syn)} = $itm;
      }
    }

    # Create new node when needed
    unless (exists($cur->[1]->{$itm}))
    { $cur->[1]->{$itm}  = $new = [undef, {}, {}, $itm];
      $new->[1]->{q{.}}  = $new;
      $new->[1]->{q{..}} = $cur;

      if (defined($syn))
      { $syn = &$fct($cur, $syn, $syn);
        $cur->[2]->{lc($syn)} = $itm if $syn ne $itm;
      }
    }

    # Make it the current node
    $cur = $cur->[1]->{$itm};
    $lvl++;
  }
  return $cur;
}

# Add a file entry
sub _add_file
{ my ($dsc, $pth) = @_;
  my ($cur, $dir, $fil, $lvl, $sub, @dir);

  if ($pth =~ m{^(.*)/(.*)$})
  { ($cur, $fil) = (_add_dir($dsc, $1), $2);
    die get_string('BAD_DIR', $pth) unless ref($cur->[1]) eq 'HASH';
  }
  else
  { ($cur, $fil) = ($dsc->{'idx'}, $pth);
  }

  # Return an existing record
  if (defined($sub = &{$dsc->{'cnv'}}($cur, $fil)))
  { $cur = $cur->[1]->{$sub};
    if (ref($cur->[1]) eq 'HASH')
    { die get_string('BAD_FILE', $pth) if (scalar keys(%{$cur->[1]})) > 2;
      $cur->[1] = [];
    }
    return $cur;
  }

  # Create a new file node
  return $cur->[1]->{$fil} = [];
}

# Decode a path
sub _dec_path
{ my ($pth) = @_;

  $pth = RDA::Object::decode($1) if $pth =~ m/^"([^"]*)"$/;
  return $pth;
}

# Merge nodes
sub _merge_nodes
{ my ($dst, $src, $pth) = @_;
  my ($cur, @key);

  # Merge directory information
  $dst->[0] = $src->[0] unless defined($dst->[0]);

  # Merge entries
  if (ref($src->[1]) eq 'HASH')
  { delete($src->[1]->{q{.}});
    delete($src->[1]->{q{..}});
    if (@key = keys(%{$src->[1]}))
    { die get_string('BAD_DIR', $pth) unless ref($dst->[1]) eq 'HASH';
      foreach my $key (@key)
      { $cur = $src->[1]->{$key};
        $cur->[1]->{q{..}} = $dst if ref($cur->[1]) eq 'HASH';
        if (exists($dst->[1]->{$key}))
        { _merge_nodes($dst->[1]->{$key}, $cur, $pth);
        }
        else
        { $dst->[1]->{$key} = $cur;
        }
      }
      foreach my $key (keys(%{$src->[2]}))
      { $dst->[2]->{$key} = $src->[2]->{$key};
      }
    }
  }
  elsif (ref($dst->[1]) eq 'HASH')
  { die get_string('BAD_FILE', $pth) if (scalar @{$dst->[1]}) > 2;
    $dst->[1] = $src->[1];
    $dst->[2] = undef;
  }
  else
  { push(@{$dst->[1]}, @{$src->[1]});
  }

  # Delete the source entry
  undef @{$src};
  return;
}

# Write a directory contribution
sub _write_catalog
{ my ($slf, $fct, $cur, @dir) = @_;
  my ($pth, $rec);

  foreach my $key (sort keys(%{$cur->[1]}))
  { next if $key eq q{.} || $key eq q{..};
    $rec = $cur->[1]->{$key};
    if (ref($rec->[1]) eq 'HASH')
    { _write_catalog($slf, $fct, $rec, @dir, $key);
    }
    else
    { $pth = &$fct(@dir, $key);
      $pth =~ s/[\000-\037]/?/g;
      $slf->write(q{|}.RDA::Driver::Sgml::encode($pth).q{ |}
        .join('%BR%', @{$rec->[1]})." |\n");
    }
  }
  return;
}

=head2 S<$h-E<gt>write_comment($text)>

This method inserts a text as a comment block in the report file. It returns a
true value for a successful completion. Otherwise, it returns a false value.

=cut

sub write_comment
{ my ($slf, $txt, $idx, @cat) = @_;

  return 0 unless defined($txt);

  # Write the comment
  $txt =~ s/\n?$/\n/;
  $slf->write("<comment>\n");
  $slf->begin_block;
  $slf->write($txt);
  $slf->end_block($idx, @cat);
  $slf->write("</comment>\n");

  # Indicate the successful completion
  return 1;
}

=head2 S<$h-E<gt>write_data($file)>

This method writes the content of a file or a buffer in the report file without
any transformation. It returns a true value for a successful
completion. Otherwise, it returns a false value.

=cut

sub write_data
{ my ($slf, $fil, $idx, @cat) = @_;
  my ($cfm, $ifh, $pth);

  return 0 unless $fil;
  return _write_data($slf, $fil->get_handle(1), 0, 0,
                     ref($idx) ? $idx : $fil->get_index('F', 'D'), @cat)
    if ref($fil) eq 'RDA::Object::Buffer';
  ($cfm, @cat) = _adjust_file($slf, $fil, $idx, @cat);
  return 0 if $cfm > $slf->{'cfm'};
  $ifh = IO::File->new;
  $slf->{'out'}->add_file($fil);
  return $ifh->open("<$fil")
    ? _write_data($slf, $ifh, 1, 0,
                  ref($idx) ? $idx : ['F', $fil, 'F', 'D'], @cat)
    : 0;
}

sub _write_data
{ my ($slf, $ifh, $flg, $vrb, $idx, @cat) = @_;
  my ($buf, $lgt, $off, $pre);

  # Get the report file handle
  return 0 unless $slf->get_handle;

  # Write the file to the report file without any transformation
  binmode($ifh);
  $slf->begin_block($vrb);
  if (exists($slf->{'flt'}))
  { while ($lgt = $ifh->sysread($buf, 32768))
    { $lgt = length($buf = $pre.$buf) if defined($pre);
      if (($off = 1 + rindex($buf, qq{\n})) > 0)
      { $slf->write($buf, $off);
        $pre = ($off < $lgt) ? substr($buf, $off) : undef;
      }
      else
      { $pre = $buf;
      }
    }
    $slf->write($pre, length($pre)) if defined($pre);
  }
  else
  { $slf->write($buf, $lgt)
      while ($lgt = $ifh->sysread($buf, 32768));
  }
  $slf->end_block($idx, @cat);
  $ifh->close if $flg;

  # Indicate the successful completion
  return 1;
}

=head2 S<$h-E<gt>write_diff($file1,$file2,$options)>

This method compares two files and reports the differences. It supports the
following options:

=over 9

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

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

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

=item B<   'j' > Joins continuation lines

=item B<   's' > Ignores simple line swabs

=item B<   't' > Expands tabs to spaces

=item B<   'w' > Ignores all white spaces

=back

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

=cut

## no critic (Numbered)
sub write_diff
{ my ($slf, $fil1, $fil2, $opt) = @_;

  return RDA::Driver::Diff::diff_files($fil1, $fil2, $opt, $slf);
}
## use critic

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

This method writes the catalog of Oracle Explorer reports for the current
module. It returns the number of entries that it generated.

=cut

sub write_explorer
{ my ($slf) = @_;
  my ($cnt, $rec, $tbl, %tbl);

  # Analyze the catalog
  foreach my $abr (values(%{$slf->{'out'}->get_info('exp', {})}))
  { foreach my $dir (values(%{$abr}))
    { foreach my $rpt (values(%{$dir}))
      { foreach my $rec (@{$rpt})
        { my ($typ, $lnk, undef, $nam) = split(/\|/, $rec);
          next if $typ eq 'L';
          my ($grp, $det) = split(/\//, $nam, 2);
          next unless defined($det);
          $tbl{$grp}->{$det}->{"$lnk|$typ"} =
            "[[../$lnk][_blank][$lnk]]($typ)";
        }
      }
    }
  }

  # Produce the report
  $cnt = exists($tbl{q{}})
    ? _write_set($slf, 'Top Reports', delete($tbl{q{}}))
    : 0;
  foreach my $grp (sort keys(%tbl))
  { $cnt = _write_set($slf, "Result Set $grp", $tbl{$grp});
  }

  # Return the number of report entries
  return $cnt;
}

sub _write_set
{ my ($slf, $ttl, $tbl) = @_;
  my ($cnt, $rec);

  # Write a set
  $cnt = 0;
  $slf->write("---+ $ttl\n|*Report*|*Contributors*|\n");
  foreach my $key (sort keys(%{$tbl}))
  { $slf->write("|$key |"
      .join('%BR%', map {$rec->{$_}} sort keys(%{$rec= $tbl->{$key}}))
      ." |\n");
    ++$cnt;
  }
  $slf->write("[[#Top][Back to top]]\n");

  # Return the number of report entries
  return $cnt;
}

=head2 S<$h-E<gt>write_extract($file,$pattern,$length)>

This method extracts a block from a file or a buffer. It uses the specified
pattern to find the beginning of the block. It writes the first capture buffer
from the pattern and the number of bytes in report file. It returns a true
value for a successful completion. Otherwise, it returns a false value.

=cut

sub write_extract
{ my ($slf, $fil, $pat, $lgt, $idx, @cat) = @_;
  my ($cfm, $ifh);

  return 0 unless $fil;
  return _write_extract($slf, $fil->get_handle(1), 0, $pat, $lgt,
                        ref($idx) ? $idx : $fil->get_index('P', 'D'), @cat)
    if ref($fil) eq 'RDA::Object::Buffer';
  ($cfm, @cat) = _adjust_file($slf, $fil, $idx, @cat);
  return 0 if $cfm > $slf->{'cfm'};
  $ifh = IO::File->new;
  $slf->{'out'}->add_file($fil);
  return $ifh->open("<$fil")
    ? _write_extract($slf, $ifh, 1, $pat, $lgt,
                     ref($idx) ? $idx : ['F', $fil, 'P', 'D'], @cat)
    : 0;
}

sub _write_extract
{ my ($slf, $ifh, $flg, $pat, $siz, $idx, @cat) = @_;
  my ($buf, $hdr, $lgt, $off, $pre);

  # Get the report file handle
  return 0 unless $slf->get_handle;

  # Search for the beginning of the block
  binmode($ifh);
  return 0 unless (($hdr, $pre) = _find_extract($ifh, $pat, $flg));

  # Write the block to the report file without any transformation
  $slf->begin_block;
  $slf->write($hdr, length($hdr));
  if (exists($slf->{'flt'}))
  { while ($siz > 0 && ($lgt = $ifh->sysread($buf, 32768)))
    { $buf = $pre.$buf if defined($pre);
      if (($off = 1 + rindex($buf, qq{\n})) > 0)
      { $siz -= $slf->write($buf, ($siz < $off) ? $siz : $off);
        $pre = ($off < $lgt) ? substr($buf, $off) : undef;
      }
      else
      { $pre = $buf;
      }
    }
    $slf->write($pre, ($siz < ($off = length($pre))) ? $siz : $off)
      if defined($pre);
  }
  else
  { $siz -= $slf->write($pre, ($siz < $lgt) ? $siz : $lgt)
      if ($lgt = length($pre));
    $siz -= $slf->write($buf, ($siz < $lgt) ? $siz : $lgt)
      while ($siz > 0 && ($lgt = $ifh->sysread($buf, 32768)));
  }
  $slf->end_block($idx, @cat);
  $ifh->close if $flg;

  # Indicate the successful completion
  return 1;
}

sub _find_extract
{ my ($ifh, $pat, $flg) = @_;
  my ($buf, $lgt, $min, $off);

  $buf = q{};
  $min = ($pat =~ s/^\*(\d+)\*//) ? $1 : length($pat) - 1;
  $off = 0;
  while ($lgt = $ifh->sysread($buf, 32768, $off))
  { return (defined($1) ? $1 : q{}, $buf) if $buf =~ s/^.*?$pat//s;
    if ($min < 1)
    { $buf = q{};
    }
    elsif ($min < ($off += $lgt))
    { $buf = substr($buf, -$min);
      $off = $min;
    }
  }
  $ifh->close if $flg;
  return ();
}

=head2 S<$h-E<gt>write_file($file)>

This method writes the content of a file or a buffer in the report file. It
returns a true value for a successful completion. Otherwise, it returns a false
value.

It stores the number of lines contained in the file is stored. This number is
accessible by the C<get_length> method.

=cut

sub write_file
{ my ($slf, $fil, $idx, @cat) = @_;
  my ($cfm, $ifh);

  return 0 unless $fil;
  return _write_file($slf, $fil->get_handle(1), $fil->get_wiki, 0,
                     ref($idx) ? $idx : $fil->get_index('F', 'T'), @cat)
    if ref($fil) eq 'RDA::Object::Buffer';
  ($cfm, @cat) = _adjust_file($slf, $fil, $idx, @cat);
  return 0 if $cfm > $slf->{'cfm'};
  $ifh = IO::File->new;
  $slf->{'out'}->add_file($fil);
  return $ifh->open("<$fil")
    ? _write_file($slf, $ifh, $slf->{'vrb'}, 1,
                  ref($idx) ? $idx : ['F', $fil, 'F', 'T'], @cat)
    : 0;
}

sub _adjust_file
{ my ($slf, $fil, $idx, @src) = @_;
  my ($cfm, $lvl, @dst);

  return ($slf->{'cfm'}, @src) unless exists($slf->{'flt'});

  # Get the level from the file
  $cfm =
    (ref($idx) ne 'ARRAY') ?
      $slf->{'out'}->get_file_cfm($fil) :
    (defined($idx->[0]) && $idx->[0] eq 'F' && defined($idx->[1])) ?
      $slf->{'out'}->get_file_cfm($idx->[1]) :
    $slf->{'cfm'};

  # Adjust the catalog entries
  foreach my $rec (@src)
  { next unless ref($rec) eq 'ARRAY';
    if ($rec->[0] eq 'L')
    { $cfm = $lvl if defined($lvl = $rec->[1]) && $lvl > $cfm;
    }
    else
    { push(@dst, $rec);
    }
  }
  push(@dst, ['L', $cfm]);
  return ($cfm, @dst);
}

sub _write_file
{ my ($slf, $ifh, $vrb, $flg, $idx, @cat) = @_;
  my ($cnt);

  # Get the report file handle
  return 0 unless $slf->get_handle;

  # Write the file to the report file, taking care on end-of-lines
  $slf->begin_block($vrb);
  $cnt = 0;
  while (<$ifh>)
  { s/[\r\n]+$//;
    s/^\000+$//;
    ++$cnt;
    $slf->write("$_\n");
  }
  $slf->end_block($idx, @cat);
  $ifh->close if $flg;
  $slf->{'lgt'} = $cnt;

  # Indicate the successful completion
  return 1;
}

=head2 S<$h-E<gt>write_filter($file,$re[,$alt])>

This method writes the content of a file or a buffer in the report file. It
applies the specified regular expression on each line. It ignores case
distinctions between the file and pattern. You can provide the replacement
string as an extra argument.

It returns a true value for a successful completion. Otherwise, it returns a
false value.

It stores the number of lines contained in the file is stored. That number is
accessible by the C<get_length> method.

=cut

sub write_filter
{ my ($slf, $fil, $re, $alt, $idx, @cat) = @_;
  my ($cfm, $ifh);

  return 0 unless $fil;
  return _write_filter($slf, $fil->get_handle(1), $fil->get_wiki, 0, $re, $alt,
                       ref($idx) ? $idx : $fil->get_index('F', 'T'), @cat)
    if ref($fil) eq 'RDA::Object::Buffer';
  ($cfm, @cat) = _adjust_file($slf, $fil, $idx, @cat);
  return 0 if $cfm > $slf->{'cfm'};
  $ifh = IO::File->new;
  $slf->{'out'}->add_file($fil);
  return $ifh->open("<$fil")
    ? _write_filter($slf, $ifh, $slf->{'vrb'}, 1, $re, $alt,
                    ref($idx) ? $idx : ['F', $fil, 'F', 'T'], @cat)
    : 0;
}

sub _write_filter
{ my ($slf, $ifh, $vrb, $flg, $re, $alt, $idx, @cat) = @_;
  my ($cnt);

  # Get the report file handle
  return 0 unless $slf->get_handle;

  # Write the file to the report file, taking care on end-of-lines
  $slf->begin_block($vrb);
  $alt = q{...} unless defined($alt);
  $cnt = 0;
  while (<$ifh>)
  { s{[\r\n]+$}{};
    s{^\000+$}{};
    s{$re}{$1$alt}ig if $re;
    ++$cnt;
    $slf->write(qq{$_\n});
  }
  $slf->end_block($idx, @cat);
  $ifh->close if $flg;
  $slf->{'lgt'} = $cnt;

  # Indicate the successful completion
  return 1;
}

=head2 S<$h-E<gt>write_lines($file[,$min[,$max]])>

This method writes a line range from a file or a buffer. It assumes the first
and last lines as defaults for the range definition. Lines are numbered
starting with one. It returns a true value for a successful
completion. Otherwise, it returns a false value.

You can use negative line numbers in line buffers to specify lines from the
buffer end.

=cut

sub write_lines
{ my ($slf, $fil, $min, $max, $idx, @cat) = @_;
  my ($cfm, $ifh, $typ, $vrb);

  return 0 unless $fil;
  if (ref($fil) eq 'RDA::Object::Buffer')
  { $typ = $fil->get_type;
    return ($typ eq 'L')
      ? _write_buffer($slf, $fil->get_handle(1), $fil->get_wiki,
                      $min, $max, $idx, @cat)
      : _write_lines($slf, $fil->get_handle(1), $fil->get_wiki, $typ,
                     $min, $max,
                     ref($idx) ? $idx : $fil->get_index(q{}, 'T'), @cat);
  }
  ($cfm, @cat) = _adjust_file($slf, $fil, $idx, @cat);
  return 0 if $cfm > $slf->{'cfm'};
  $ifh = IO::File->new;
  $slf->{'out'}->add_file($fil);
  return $ifh->open("<$fil")
    ? _write_lines($slf, $ifh, $slf->{'vrb'}, q{},
                   $min, $max, ref($idx) ? $idx : ['F', $fil, q{}, 'T'], @cat)
    : 0;
}

sub _write_buffer
{ my ($slf, $ifh, $vrb, $min, $max, $idx, @cat) = @_;
  my ($buf, $ofh);

  # Validate the range
  $buf =  $ifh->getbuf;
  $min = (!defined($min))                   ? 0 :
         ($min > 0)                         ? $min - 1 :
         ($min < 0 && ($#$buf + $min) >= 0) ? $#$buf + $min + 1 :
                                              0;
  $max = (!defined($max))                   ? $#$buf :
         ($max > 0)                         ? $max - 1 :
         ($max < 0 && ($#$buf + $max) >= 0) ? $#$buf + $max + 1 :
                                              0;
  $max = $#$buf if $max > $#$buf;

  # Add the lines to the report
  unless ($min > $max)  ## no critic (Unless)
  { foreach my $lin (@{$buf}[$min..$max])
    { # Open the report if needed
      unless ($ofh)
      { return 0 unless ($ofh = $slf->get_handle);
        $slf->begin_block($vrb);
      }

      # Write the line
      $slf->write(qq{$lin\n});
    }
    $slf->end_block($idx, @cat) if $ofh;
  }

  # Indicate the successful completion
  return 1;
}

sub _write_lines
{ my ($slf, $ifh, $vrb, $flg, $min, $max, $idx, @cat) = @_;
  my ($cnt, $lin, $ofh, $typ);

  # Validate the range
  $min = 1 unless defined($min);
  if (defined($max) && $max > 0)
  { $min = $max + $min if $min < 0;
  }
  else
  { $max = undef;
  }
  $typ = ($min > 1) ? 0 : 1;

  # Add the lines to the report
  $cnt = 0;
  while (<$ifh>)
  { next if ++$cnt < $min;
    if (defined($max) && $cnt > $max)
    { $typ += 2;
      last;
    }

    # Open the report if needed
    unless ($ofh)
    { return 0 unless ($ofh = $slf->get_handle);
      $slf->begin_block($vrb);
    }

    # Write the line
    s/[\r\n]+$//;
    s/^\000+$//;
    $slf->write("$_\n");
  }
  if ($ofh)
  { $idx->[2] = $tb_idx[$typ] if $idx && $idx->[0] eq 'F';
    $slf->end_block($idx, @cat);
  }

  # Close the file
  $ifh->close unless $flg;

  # Indicate the successful completion
  return 1;
}

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

This method writes the tail of a file or a buffer in the report file. By
default, it writes the 10 last lines. It returns a true value for a successful
completion. Otherwise, it returns a false value.

It stores the number of lines contained in the file is stored. That number is
accessible by the C<get_length> method.

=cut

sub write_tail
{ my ($slf, $fil, $lgt, $idx, @cat) = @_;
  my ($cfm, $ifh);

  return 0 unless $fil;
  return _write_tail($slf, $fil->get_handle(1), $fil->get_wiki, 0, $lgt,
                     ref($idx) ? $idx : $fil->get_handle('F', 'T'), @cat)
    if ref($fil) eq 'RDA::Object::Buffer';
  ($cfm, @cat) = _adjust_file($slf, $fil, $idx, @cat);
  return 0 if $cfm > $slf->{'cfm'};
  $ifh = IO::File->new;
  $slf->{'out'}->add_file($fil);
  return $ifh->open("<$fil")
    ? _write_tail($slf, $ifh, $slf->{'vrb'}, 1, $lgt,
                  ref($idx) ? $idx : ['F', $fil, 'F', 'T'], @cat)
    : 0;
}

sub _write_tail
{ my ($slf, $ifh, $vrb, $flg, $lgt, $idx, @cat) = @_;
  my ($cnt, $typ, @buf);

  # Read the file keeping the last lines in a buffer
  $cnt = 0;
  $lgt = 10 unless defined($lgt);
  while (<$ifh>)
  { push(@buf, m/^\000+[\r\n]+$/ ? q{} : $_);
    $typ = shift(@buf) if (scalar @buf) > $lgt;
    ++$cnt;
  }
  $ifh->close if $flg;
  $slf->{'lgt'} = $cnt;

  # Get the report file handle
  return 0 unless $cnt && $slf->get_handle;

  # Write the last lines of the file in the report file.
  $slf->begin_block($vrb);
  for (@buf)
  { s/[\r\n]+$//;
    $slf->write("$_\n");
  }
  $idx->[2] = 'T'
    if defined($typ) && $idx && $idx->[0] eq 'F' && $idx->[2] eq 'F';
  $slf->end_block($idx, @cat);

  # Indicate the successful completion
  return 1;
}

=head2 S<$h-E<gt>write_verbatim($file)>

This method writes the content of a file or a buffer in the report file as a
verbatim block but without cleaning the lines. It returns a true value for a
successful completion. Otherwise, it returns a false value.

=cut

sub write_verbatim
{ my ($slf, $fil, $idx, @cat) = @_;
  my ($cfm, $ifh);

  return 0 unless $fil;
  return _write_data($slf, $fil->get_handle(1), 0, 1,
                     ref($idx) ? $idx : $fil->get_index('F', 'T'), @cat)
    if ref($fil) eq 'RDA::Object::Buffer';
  ($cfm, @cat) = _adjust_file($slf, $fil, $idx, @cat);
  return 0 if $cfm > $slf->{'cfm'};
  $ifh = IO::File->new;
  $slf->{'out'}->add_file($fil);
  return $ifh->open("<$fil")
    ? _write_data($slf, $ifh, 1, 1,
                  ref($idx) ? $idx : ['F', $fil, 'F', 'T'], @cat)
    : 0;
}

# --- UNIX-specific routines --------------------------------------------------

# Convert the directory element
sub _u_convert
{ my ($cur, $sub, $dft) = @_;

  return exists($cur->[1]->{$sub}) ? $sub : $dft;
}

# Create a native path
sub _u_native
{ return RDA::Object::Rda->cat_dir(@_);
}

# Normalize the path
sub _u_norm
{ return shift;
}

# --- VMS-specific routines ---------------------------------------------------

# Convert the directory element
sub _v_convert
{ my ($cur, $sub, $dft) = @_;
  my ($ref, $tbl);

  $tbl = $cur->[1];
  return $sub if exists($tbl->{$sub});
  $ref = lc($sub);
  foreach my $dir (keys(%{$tbl}))
  { return $dir if lc($dir) eq $ref;
  }
  return $dft;
}

# Create a native path
sub _v_native
{ my ($drv, @pth) = @_;

  if ($drv eq 'root')
  { $drv = q{};
  }
  elsif ($drv !~ m/:$/)
  { unshift(@pth, $drv);
    $drv = q{};
  }
  return $drv.q{[}.join(q{.}, @pth).q{]};
}

# Normalize the path
sub _v_norm
{ my ($pth) = @_;
  my (@tbl);

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

# --- Windows-specific routines -----------------------------------------------

# Convert the directory element
sub _w_convert
{ my ($cur, $sub, $dft) = @_;
  my ($ref, $tbl);

  $tbl = $cur->[1];
  return $sub if exists($tbl->{$sub});
  $ref = lc($sub);
  return $cur->[2]->{$ref} if exists($cur->[2]->{$ref});
  foreach my $dir (keys(%{$tbl}))
  { return $dir if lc($dir) eq $ref;
  }
  return $dft;
}

# Create a native path
sub _w_native
{ my (@pth) = @_;
  my ($pth);

  return
    (@pth && $pth[0] =~ m/:$/)
      ? RDA::Object::Rda->cat_native(@pth, q{}) :
    length($pth = join(q{/}, @pth))
      ? $pth :
    q{/};
}

# Normalize the path
sub _w_norm
{ my ($pth) = @_;

  $pth =~ s{\\}{/}g;
  $pth =~ s{^/cygdrive/([a-z])/}{\u$1:/}i;
  $pth =~ s{^([a-z]):}{\u$1:};
  return $pth;
}

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

# Define the parse methods
sub _get_list
{ my ($slf, $spc, $str) = @_;
  my ($val);

  if ($$str =~ s/^\173\s*//)
  { $spc->[$SPC_REF] = $val if ($val = $slf->parse_value($str));
    die get_string('END_BRACE') unless $$str =~ s/^\175\s*//;
  }
  $spc->[$SPC_VAL] = $slf->parse_list($str);
  return;
}

sub _get_object
{ my ($slf, $spc, $str) = @_;
  my ($val);

  $spc->[$SPC_REF] = $val if ($val = $slf->parse_value($str));
  return;
}

sub _get_value
{ my ($slf, $spc, $str) = @_;
  my ($val);

  if ($$str =~ s/^\173\s*//)
  { $spc->[$SPC_REF] = $val if ($val = $slf->parse_value($str));
    die get_string('END_BRACE') unless $$str =~ s/^\175\s*//;
  }
  $spc->[$SPC_VAL] = $slf->parse_value($str);
  return;
}

# Close the report
sub _exe_close
{ my ($slf, $spc) = @_;
  my ($obj);

  # Identify the report
  $obj = defined($obj = $spc->[$SPC_REF])
    ? $obj->eval_as_scalar
    : $slf->get_report;
  die get_string('NO_REPORT') unless ref($obj) =~ $REPORT;

  # Close the report
  $obj->close;

  # Indicate a successful completion
  return $CONT;
}

# End a report
sub _exe_end
{ my ($slf, $spc) = @_;
  my ($obj);

  # Identify the report
  $obj = defined($obj = $spc->[$SPC_REF])
    ? $obj->eval_as_scalar
    : $slf->get_report;
  die get_string('NO_REPORT') unless ref($obj) =~ $REPORT;

  # End the report
  $slf->get_output->end_report($obj);

  # Indicate the successful completion
  return $CONT;
}

# Define a prefix block
sub _exe_prefix
{ my ($slf, $spc) = @_;
  my ($obj);

  # Identify the report
  $obj = defined($obj = $spc->[$SPC_REF])
    ? $obj->eval_as_scalar
    : $slf->get_report;
  die get_string('NO_REPORT') unless ref($obj) =~ $REPORT;

  # Set the prefix
  $obj->prefix($spc->[$SPC_BLK]);

  # Indicate a successful completion
  return $CONT;
}

# Add a line in the before buffer
sub _exe_title
{ my ($slf, $spc) = @_;
  my ($obj, $lin);

  # Identify the report
  $obj = defined($obj = $spc->[$SPC_REF])
    ? $obj->eval_as_scalar
    : $slf->get_report;
  die get_string('NO_REPORT') unless ref($obj) =~ $REPORT;

  # Write the line
  $lin = $spc->[$SPC_VAL]->eval_as_line;
  $lin =~ s/[\n\r\s]+$//;
  $obj->push_lines('bef', $lin);

  # Indicate a successful completion
  return $CONT;
}

# Clear a prefix block
sub _exe_unprefix
{ my ($slf, $spc) = @_;
  my ($obj);

  # Identify the report
  $obj = defined($obj = $spc->[$SPC_REF])
    ? $obj->eval_as_scalar
    : $slf->get_report;
  die get_string('NO_REPORT') unless ref($obj) =~ $REPORT;

  # Clear the prefix
  $obj->unprefix;

  # Indicate a successful completion
  return $CONT;
}

# Pop lines from the before buffer
sub _exe_untitle
{ my ($slf, $spc) = @_;
  my ($obj);

  # Identify the report
  $obj = defined($obj = $spc->[$SPC_REF])
    ? $obj->eval_as_scalar
    : $slf->get_report;
  die get_string('NO_REPORT') unless ref($obj) =~ $REPORT;

  # Clear the prefix
  $obj->pop_lines('bef', defined($spc->[$SPC_VAL])
    ? $spc->[$SPC_VAL]->eval_as_number
    : 1);

  # Indicate a successful completion
  return $CONT;
}

# Write a line in the report file
sub _exe_write
{ my ($slf, $spc) = @_;
  my ($obj);

  # Identify the report
  $obj = defined($obj = $spc->[$SPC_REF])
    ? $obj->eval_as_scalar
    : $slf->get_report;
  die get_string('NO_REPORT') unless ref($obj) =~ $REPORT;

  # Write the line
  $obj->write($spc->[$SPC_VAL]->eval_as_line);

  # Indicate a successful completion
  return $CONT;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Driver::Diff|RDA::Driver::Diff>,
L<RDA::Driver::Sgml|RDA::Driver::Sgml>,
L<RDA::Handle::Filter|RDA::Handle::Filter>,
L<RDA::Handle::Null|RDA::Handle::Null>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Buffer|RDA::Object::Buffer>,
L<RDA::Object::Message|RDA::Object::Message>,
L<RDA::Object::Output|RDA::Object::Output>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::SDCL::Block|RDA::SDCL::Block>,
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