# Output.pm: Class Used for Reporting Control

package RDA::Object::Output;

# $Id: Output.pm,v 1.38 2015/09/24 17:52:18 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Object/Output.pm,v 1.38 2015/09/24 17:52:18 RDA Exp $
#
# Change History
# 20150924  MSC  Treat trm files like trc files.

=head1 NAME

RDA::Object::Output - Class Used for Reporting Control

=head1 SYNOPSIS

 require RDA::Object::Output;

=head1 DESCRIPTION

The objects of the C<RDA::Object::Output> class are used for reporting
control. It is a subclass of L<RDA::Object|RDA::Object>.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use File::Copy qw(copy);
  use IO::File;
  use RDA::Text qw(get_string);
  use RDA::Object;
  use RDA::Object::Content qw($RE_DC);
  use RDA::Object::Pipe;
  use RDA::Object::Rda qw($CREATE $DIR_PERMS $FIL_PERMS);
  use RDA::Object::Report;
  use RDA::Object::Toc;
  use RDA::SDCL::Block qw($CONT $SPC_REF $SPC_VAL);
}

# Define the global public variables
use vars qw($STRINGS $VERSION @DELETE @DUMP @ISA %SDCL);
$VERSION = sprintf('%d.%02d', q$Revision: 1.38 $ =~ /(\d+)\.(\d+)/);
@DELETE  = qw(flt rpt);
@DUMP    = (
  hsh => {
    'RDA::Handle::Filter' => 1,
    },
  );
@ISA     = qw(RDA::Object Exporter);
%SDCL    = (
  als => {
    ## no critic (Interpolation)
    'addMetaDir'     => ['$[OUT]', 'add_dir'],
    'addMetaFile'    => ['$[OUT]', 'add_file'],
    'addMetaLstat'   => ['$[OUT]', 'add_lstat'],
    'addMetaStat'    => ['$[OUT]', 'add_stat'],
    'enableExplorer' => ['$[OUT]', 'enable_explorer'],
    'enableIndex'    => ['$[OUT]', 'enable_index'],
    'findShares'     => ['$[OUT]', 'find_shares'],
    'getLink'        => ['$[OUT]', 'get_link'],
    'getShare'       => ['$[OUT]', 'get_share'],
    'isCollected'    => ['$[OUT]', 'is_collected'],
    'isFiltered'     => ['$[OUT]', 'is_filtered'],
    'isRendered'     => ['$[OUT]', 'is_rendered'],
    'purge'          => ['$[OUT]', 'purge'],
    'setAbbr'        => ['$[OUT]', 'set_abbr'],
    'setCfm'         => ['$[OUT]', 'set_cfm'],
    'setMeta'        => ['$[OUT]', 'set_meta'],
    'setPrefix'      => ['$[OUT]', 'set_prefix'],
    'setShare'       => ['$[OUT]', 'set_share'],
    'testOutput'     => ['$[OUT]', 'test'],
    },
  beg => \&_begin_control,
  cmd => {
    'data'    => [\&_exe_report,  \&_get_data,   0, 0],
    'output'  => [\&_exe_report,  \&_get_output, 0, 0],
    'report'  => [\&_exe_report,  \&_get_report, 0, 0],
    'resume'  => [\&_exe_resume,  \&_get_name,   0, 0],
    'share'   => [\&_exe_share,   \&_get_list,   0, 0],
    'suspend' => [\&_exe_suspend, \&_get_name,   0, 0],
    },
  end => \&_end_control,
  flg => 1,
  inc => [qw(RDA::Object)],
  met => {
    'add_dir'         => {ret => 0},
    'add_file'        => {ret => 0},
    'add_home'        => {ret => 0},
    'add_lstat'       => {ret => 0},
    'add_report'      => {ret => 0},
    'add_stat'        => {ret => 0},
    'add_temp'        => {ret => 0},
    'check_free'      => {ret => 0},
    'check_space'     => {ret => 0},
    'decr_free'       => {ret => 0},
    'enable_explorer' => {ret => 0},
    'enable_index'    => {ret => 0},
    'end_report'      => {ret => 0},
    'end_temp'        => {ret => 0},
    'filter'          => {ret => 0},
    'find_shares'     => {ret => 1},
    'get_abbr'        => {ret => 0},
    'get_cfm'         => {ret => 0},
    'get_current'     => {ret => 0},
    'get_file_cfm'    => {ret => 0},
    'get_info'        => {ret => 0},
    'get_link'        => {ret => 0},
    'get_name'        => {ret => 0},
    'get_owner'       => {ret => 0},
    'get_prefix'      => {ret => 0},
    'get_share'       => {ret => 0},
    'get_tag_cfm'     => {ret => 0},
    'has_explorer'    => {ret => 0},
    'has_index'       => {ret => 0},
    'in_job'          => {ret => 0},
    'is_collected'    => {ret => 0},
    'is_filtered'     => {ret => 0},
    'is_rendered'     => {ret => 0},
    'purge'           => {ret => 0},
    'set_abbr'        => {ret => 0},
    'set_cfm'         => {ret => 0},
    'set_info'        => {ret => 0},
    'set_meta'        => {ret => 0},
    'set_prefix'      => {ret => 0},
    'set_share'       => {ret => 0},
    'test'            => {ret => 0},
    'test_free'       => {ret => 0},
    'wait'            => {ret => 0},
    },
  top => 'OUT',
  );

# Define the global private constants
my $ALS_OID = 0;  # Report identifier
my $ALS_FIL = 1;  # Report file name
my $ALS_DIR = 2;  # Directory type
my $ALS_NAM = 3;  # Report name
my $ALS_SET = 4;  # Alias fields

my $DFT_CFM = 2;  # Default customer file management level;

my $SHR_GID = 0;  # Share group identifier
my $SHR_OID = 1;  # Report identifier
my $SHR_MOD = 2;  # Module name
my $SHR_DIR = 3;  # Report directory type
my $SHR_NAM = 4;  # Report name
my $SHR_EXT = 5;  # Report extension
my $SHR_FMT = 6;  # Report file name format
my $SHR_FIL = 7;  # Report file name
my $SHR_LNK = 8;  # Share link
my $SHR_SET = 9;  # Share fields

# Define the global private variables
my %tb_end = (
  'RDA::Object::Pipe'   => \&end_pipe,
  'RDA::Object::Report' => \&end_report,
  );
my %tb_imp = (
  als => 2,
  cat => 2,
  cln => 1,
  def => $SHR_SET + 3,
  exp => 3,
  hom => 1,
  idx => 3,
  spc => 0,
  sta => 1,
  );
my %tb_res = (
  fil => \&_load_fil,
  rpt => \&_load_rpt,
  tag => \&_load_tag,
  );
my %tb_toc = (
  C => \&_save_collect,
  E => \&_save_empty,
  R => \&_save_section,
  S => \&_save_section,
  T => \&_save_top,
  );

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

=head2 S<$h = RDA::Object::Output-E<gt>new($collector[,$flag])>

=for stopwords postprocessing

The global reporting control object constructor. It takes the collector
reference as an argument. Setting the flag disables any output postprocessing.

=head2 S<$out-E<gt>new($package)>

The local reporting control object constructor. It takes a package reference,
which is used for providing the module name and version.

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

=over 12

=item S<    B<'abr' > > Abbreviation of the current module (L)

=item S<    B<'agt' > > Reference to the agent object (G,L)

=item S<    B<'als' > > Alias definition hash (L)

=item S<    B<'bas' > > Maximum length of the report basename (G,L)

=item S<    B<'blk' > > Block entries (L)

=item S<    B<'cas' > > Indicates a case-sensitive context (G,L)

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

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

=item S<    B<'cln' > > Cloned reports (L)

=item S<    B<'col' > > Reference to the collector object (G,L)

=item S<    B<'cur' > > Reference to the current report (L)

=item S<    B<'dat' > > Report directory name (G,L)

=item S<    B<'def' > > Local share definitions (L)

=item S<    B<'dft' > > Reference to the output control item (G,L)

=item S<    B<'dup' > > Duplicated report hash (L)

=item S<    B<'emu' > > Link emulation indicator (G,L)

=item S<    B<'end' > > How long to wait for asynchronous report completion (G)

=item S<    B<'exp' > > Oracle Explorer entries (L)

=item S<    B<'flg' > > Collection indicator (L)

=item S<    B<'flt' > > Filter control object reference (G,L)

=item S<    B<'idx' > > Index entries (L)

=item S<    B<'job' > > Job identifier (G,L)

=item S<    B<'lgt' > > Maximum length of the report name (L)

=item S<    B<'lst' > > Reference to the most recent report or pipe defined (L)

=item S<    B<'met' > > Meta directory indicator (G,L)

=item S<    B<'mrc' > > Multi-run collection indicator (L)

=item S<    B<'nam' > > Collector name (L)

=item S<    B<'oid' > > Setup name (G) / Package name (L)

=item S<    B<'own' > > Ownership alignment indicator (L)

=item S<    B<'pid' > > Report subprocess identifiers (G,L)

=item S<    B<'pip' > > Pipe hash (L)

=item S<    B<'pkg' > > Package object reference (L)

=item S<    B<'pre' > > Current report prefix (L)

=item S<    B<'prv' > > Previous run table of content (G,L)

=item S<    B<'rel' > > Software release (G,L)

=item S<    B<'res' > > Collection restrictions (G,L)

=item S<    B<'rev' > > Reverse mapping hash (L)

=item S<    B<'rnd' > > Render object reference (G,L)

=item S<    B<'rpt' > > Report hash (L)

=item S<    B<'shr' > > Share definition cache (L)

=item S<    B<'sht' > > Short definitions (L)

=item S<    B<'spc' > > Disk space used by all reports (L)

=item S<    B<'sta' > > File status information hash (L)

=item S<    B<'tmp' > > Temporary file hash (L)

=item S<    B<'toc' > > Reference to the table of contents object (L)

=item S<    B<'typ' > > Object type (G,L,N)

=item S<    B<'ver' > > Package version (L)

=item S<    B<'xpl' > > Oracle Explorer indicator (G,L)

=item S<    B<'_dfa'> > Disk free space available (L)

=item S<    B<'_dfc'> > Disk free initialization counter (G,L)

=item S<    B<'_dff'> > Disk free check function at module level (G,L)

=item S<    B<'_dfm'> > Disk free minimum size (G,L)

=item S<    B<'_dfp'> > Disk free path (G,L)

=item S<    B<'_dfr'> > Disk free check function at report level (G,L)

=item S<    B<'_dft'> > Disk free type (G,L)

=item S<    B<'_exp'> > Section Oracle Explorer entries (L)

=item S<    B<'_gid'> > Group identifier of the report directory owner (G,L)

=item S<    B<'_idx'> > Section index entries (L)

=item S<    B<'_opn'> > Hash containing suspended report files (L)

=item S<    B<'_pip'> > Pipe sequence number (L)

=item S<    B<'_rpt'> > Report file sequence number (L)

=item S<    B<'_sct'> > Section reports (L)

=item S<    B<'_spl'> > Report space limit (L)

=item S<    B<'_tmp'> > Temporary file sequence number (L)

=item S<    B<'_uid'> > User identifier of the report directory owner (G,L)

=back

Internal keys are prefixed by an underscore.

=cut

sub new  ## no critic (Complex)
{ my ($cls, $obj, $flg) = @_;
  my ($slf);

  if (ref($cls))
  { my ($abr, $nam, $val);

    # Create a local reporting control object
    $slf = bless {
      als  => {},
      cfm  => $DFT_CFM,
      cln  => {},
      def  => {},
      dup  => {},
      exp  => {},
      idx  => {},
      job  => q{},
      mod  => 0,
      mrc  => 0,
      nam  => $cls->{'oid'},
      oid  => $obj->get_oid,
      own  => 0,
      pip  => {},
      pkg  => $obj,
      pre  => q{},
      rev  => {},
      rpt  => {},
      shr  => {},
      spc  => 0,
      sta  => {},
      tmp  => {},
      typ  => 'L',
      ver  => $obj->get_info('ver', 0),
      _opn => {},
      _pip => 0,
      _rpt => 0,
      _tmp => 0,
      }, ref($cls);

    # Take a copy of parameters
    foreach my $key (qw(agt bas cas cfg col dat dft emu flt met rel res rnd xpl
                        _dfa _dff _dfm _dfp _dfr _dft))
    { $slf->{$key} = $cls->{$key} if exists($cls->{$key});
    }

    # Complete the report control initialization
    if (defined($abr = $obj->get_info('abr')))
    { $slf->{'abr'} = $abr;
      $slf->{'flg'} = 1;
    }
    else
    { $slf->{'abr'} = 'TOOL_DFT_';
      $slf->{'flg'} = 0;
    }
    $slf->{'lgt'} = _adjust_length($slf);
    $slf->{'blk'}->{$slf->{'abr'}} = [];

    if (defined($nam = $obj->get_info('nam')))
    { # Load the customer file management level
      $slf->{'cfm'} = _get_cfm($slf, $nam);

      # Control the space management
      $val = $slf->{'dft'}->get_first('B_NO_QUOTA')
        ? 0
        : int(1048576 * $slf->{'col'}->get_first("STATUS.$nam.R_MIB", 0));
      $slf->{'_spc'} = $val if $val > 0;
    }
    $slf->check_free(0) if $cls->{'_dfc'}++;
  }
  elsif ($obj)
  { my ($cfg, $dft, $dir, $flt, $lgt, $sub, $val, $tbl, @tbl);

    # Create a global reporting control object
    $cfg = $obj->get_config;
    $dft = $obj->find('OUTPUT', 1);
    $slf = bless {
      abr  => 'TOOL_DFT_',
      agt  => $obj->get_agent,
      bas  => $cfg->get_value('N_BASENAME', 38),
      cas  => $cfg->get_value('B_CASE', 1),
      cfg  => $cfg,
      col  => $obj,
      dat  => $obj->get_info('dat'),
      dft  => $dft,
      emu  => $dft->get_first('B_SHARE', 1),
      end  => $dft->get_first('N_WAIT', 120),
      job  => q{},
      met  => $dft->get_first('B_META', 0),
      oid  => $obj->get_oid,
      pid  => {},
      rel  => $cfg->get_version,
      res  => {},
      typ  => 'G',
      xpl  => $dft->get_first('B_EXPLORER', 0),
      _dfa => 0,
      _dfc => 0,
      _dft => $dft->get_first('W_FREE_CHECK', 'M'),
      }, $cls;

    # Prepare output postprocessing
    unless ($flg)
    { if (($flt = $obj->find('FILTER')) && $flt->get_first('B_ENABLED'))
      { # Create the filter
        eval {
          require RDA::Handle::Filter;
          $slf->{'flt'} = RDA::Handle::Filter->new($flt);
          };
        die get_string('ERR_FILTER', $@) if $@;

        # Load the meta directives
        if (@tbl = $obj->get_value('OUTPUT.REFINE.D_META'))
        { $slf->{'res'}->{'met'} = $tbl = {};
          for (@tbl)
          { $tbl->{$_} = 1;
          }
        }
        else
        { $slf->{'met'} = 0;
        }
      }
      elsif ($val = $dft->get_first('T_RENDER'))
      { eval {
          require RDA::Handle::Render;
          $slf->{'rnd'} = RDA::Handle::Render->new($slf, $val);
          };
      }
    }

    # Clean the diagnostic data directory
    if ($dft->set_value('B_CLEAN'))
    { if (opendir(DAT, $slf->{'dat'}))
      { $val = qr/^(([A-Z][A-Z\d]*_){2})A\.fil$/i;
        foreach my $fil (readdir(DAT))
        { $obj->delete_reports($1, 1) if $fil =~ $val && !$obj->is_enabled($1);
        }
        closedir(DAT);
      }
    }

    # Enable the space management
    _chk_free($slf, $dft->get_first('R_FREE', 0));
  }
  else
  { # Create an output blocking object
    $slf = bless {
      typ => 'N',
      }, $cls;
  }

  # Return the object reference
  return $slf;
}

# Adjust variable part length limit
sub _adjust_length
{ my ($slf, $job) = @_;
  my ($lgt);

  $job = $slf->{'job'} unless defined($job);
  $lgt = $slf->{'bas'} - length($slf->{'abr'}) - length($slf->{'pre'})
    - length($job) - 6;
  return ($lgt > 1) ? $lgt : 0;
}

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

This method closes the report files.

=cut

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

  if ($slf->{'typ'} eq 'L')
  { # End reports and temporary files
    foreach my $obj (values(%{$slf->{'rpt'}}), values(%{$slf->{'tmp'}}))
    { $obj->close(1) if $obj->is_active;
    }

    # Close the table of content file
    $slf->{'toc'}->close(1) if exists($slf->{'toc'});

    # Check the free space
    $slf->check_free(0);
  }
  return;
}

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

This method deletes the report control object.

=cut

sub delete_object  ## no critic (Complex)
{ my ($slf, $tim) = @_;

  if ($slf->{'typ'} eq 'L')
  { my ($abr, $buf, $dir, $gid, $obj, $ofh, $pth, $tbl, $uid, @tbl);

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

    # Clear suspended reports
    $slf->{'_opn'} = {};

    # End pipes, reports, and temporary files
    foreach my $oid (keys(%{$slf->{'pip'}}))
    { $slf->end_pipe($oid);
      delete($slf->{'pip'}->{$oid})->delete_object;
    }
    foreach my $oid (keys(%{$slf->{'rpt'}}))
    { $slf->end_report($oid);
      delete($slf->{'rpt'}->{$oid})->delete_object;
    }
    foreach my $oid (keys(%{$slf->{'tmp'}}))
    { $slf->end_temp($oid);
      delete($slf->{'tmp'}->{$oid})->delete_object;
    }

    # End the table of content
    if (exists($slf->{'toc'}))
    { delete($slf->{'toc'})->delete_object;
      $slf->{'pkg'}->set_top('TOC');
    }

    # Save details for collection modules
    if ($slf->{'flg'})
    { $ofh = IO::File->new;

      # Check ownership alignment
      ($uid, $gid) = $slf->get_owner if $slf->{'own'};

      # Adjust the ownership of the mrc directory
      chown($uid, $gid, $dir)
        if defined($uid) && defined($dir = $slf->{'col'}->has_dir('M'));

      # Save the alias definition
      $pth = RDA::Object::Rda->cat_file($slf->{'dat'}, $abr.'A.fil');
      if (@tbl = keys(%{$slf->{'als'}}))
      { if ($ofh->open($pth, $CREATE, $FIL_PERMS))
        { foreach my $key (sort @tbl)
          { foreach my $dir (sort keys(%{$slf->{'als'}->{$key}}))
            { $buf = join(q{|}, $key, $dir, $slf->{'als'}->{$key}->{$dir});
              $ofh->syswrite($buf, length($buf));
            }
          }
          $ofh->close;
          chown($uid, $gid, $pth) if defined($uid);
        }
      }
      else
      { 1 while unlink($pth);
      }

      # Save the file status information entries
      $pth = RDA::Object::Rda->cat_file($slf->{'dat'}, $abr.'D.fil');
      if (@tbl = keys(%{$slf->{'sta'}}))
      { if ($ofh->open($pth, $CREATE, $FIL_PERMS))
        { foreach my $key (sort @tbl)
          { $buf = join(q{|}, RDA::Object::encode($key), $slf->{'sta'}->{$key});
            $ofh->syswrite($buf, length($buf));
          }
          $ofh->close;
          chown($uid, $gid, $pth) if defined($uid);
        }
      }
      else
      { 1 while unlink($pth);
      }

      # Save the Oracle Explorer entries
      $pth = RDA::Object::Rda->cat_file($slf->{'dat'}, $abr.'E.fil');
      if (@tbl = keys(%{$slf->{'exp'}}))
      { if ($ofh->open($pth, $CREATE, $FIL_PERMS))
        { foreach my $key (sort @tbl)
          { foreach my $oid (sort keys(%{$slf->{'exp'}->{$key}}))
            { foreach my $dir (sort keys(%{$slf->{'exp'}->{$key}->{$oid}}))
              { foreach my $rec (@{$slf->{'exp'}->{$key}->{$oid}->{$dir}})
                { $ofh->syswrite($rec, length($rec));
                }
              }
            }
          }
          $ofh->close;
          chown($uid, $gid, $pth) if defined($uid);
        }
      }
      else
      { 1 while unlink($pth);
      }

      # Save the index entries
      $pth = RDA::Object::Rda->cat_file($slf->{'dat'}, $abr.'I.fil');
      if (@tbl = keys(%{$slf->{'idx'}}))
      { if ($ofh->open($pth, $CREATE, $FIL_PERMS))
        { if ($tbl = $slf->{'cfg'}->purge_shorts)
          { foreach my $key (keys(%{$tbl}))
            { $slf->{'sht'}->{$key} =
                q{S|}.RDA::Object::encode($key).q{|}.
                      RDA::Object::encode($tbl->{$key}).qq{|\n};
            }
          }
          if (exists($slf->{'sht'}))
          { foreach my $key (sort {length($a) <=> length($b)}
                                  keys(%{$slf->{'sht'}}))
            { $buf = $slf->{'sht'}->{$key};
              $ofh->syswrite($buf, length($buf));
            }
          }
          foreach my $key (sort @tbl)
          { $buf = qq{A|$key|\n};
            $ofh->syswrite($buf, length($buf));
            if (exists($slf->{'idx'}->{$key}->{q{@}}))
            { $buf = q{H|}.$slf->{'idx'}->{$key}->{q{@}}.qq{|\n};
              $ofh->syswrite($buf, length($buf));
            }
            foreach my $oid (sort keys(%{$slf->{'idx'}->{$key}}))
            { next if $oid eq q{@};
              foreach my $dir (sort keys(%{$slf->{'idx'}->{$key}->{$oid}}))
              { foreach my $rec (@{$slf->{'idx'}->{$key}->{$oid}->{$dir}})
                { $ofh->syswrite($rec, length($rec));
                }
              }
            }
          }
          $ofh->close;
          chown($uid, $gid, $pth) if defined($uid);
        }
      }
      else
      { 1 while unlink($pth);
      }

      # Save the share definitions
      if (@tbl = keys(%{$slf->{'def'}}))
      { foreach my $abr (sort @tbl)
        { $pth = RDA::Object::Rda->cat_file($slf->{'dat'}, $abr.'S.fil');
          if ($ofh->open($pth, $CREATE, $FIL_PERMS))
          { foreach my $oid (sort keys(%{$slf->{'def'}->{$abr}}))
            { foreach my $grp (sort keys(%{$slf->{'def'}->{$abr}->{$oid}}))
              { $buf = join(q{|}, @{$slf->{'def'}->{$abr}->{$oid}->{$grp}},
                  qq{\n});
                $ofh->syswrite($buf, length($buf));
              }
            }
            $ofh->close;
            chown($uid, $gid, $pth) if defined($uid);
          }
        }
      }
    }

    # Clear the internal tables
    $slf->{'als'} = {};
    $slf->{'def'} = {};
    $slf->{'idx'} = {};
    $slf->{'sta'} = {};

    # Log the limits
    $slf->{'col'}->log('l', $slf->{'oid'}, $slf->{'spc'}, $tim)
      if defined($tim);
  }
  elsif ($slf->{'typ'} eq 'G')
  { # Stop direct rendering
    $slf->{'rnd'}->end if exists($slf->{'rnd'});
  }

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

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

This method extracts the alias, file, index, and share information.

=cut

sub extract  ## no critic (Complex)
{ my ($slf) = @_;
  my ($buf, $tbl, @tbl);

  $buf = q{};

  # Close all reports
  $slf->close;

  # Save the alias definitions
  foreach my $key (keys(%{$slf->{'als'}}))
  { foreach my $dir (keys(%{$tbl = $slf->{'als'}->{$key}}))
    { $buf .= join("\001", 'als', $key, $dir, $tbl->{$dir});
    }
  }
  $slf->{'als'} = {};

  # Save the share definitions
  foreach my $abr (keys(%{$slf->{'def'}}))
  { foreach my $oid (keys(%{$slf->{'def'}->{$abr}}))
    { foreach my $gid (keys(%{$tbl = $slf->{'def'}->{$abr}->{$oid}}))
      { $buf .= join("\001", 'def', $abr, $oid, $gid, @{$tbl->{$gid}}, qq{\n});
      }
    }
  }
  $slf->{'def'} = {};

  # Save the Oracle Explorer entries
  foreach my $abr (keys(%{$slf->{'exp'}}))
  { foreach my $oid (keys(%{$slf->{'exp'}->{$abr}}))
    { foreach my $dir (keys(%{$tbl = $slf->{'exp'}->{$abr}->{$oid}}))
      { foreach my $rec (@{$tbl->{$dir}})
        { $buf .= join("\001", 'exp', $abr, $oid, $dir, $rec);
        }
      }
    }
  }
  $slf->{'exp'} = {};

  # Save the short definitions
  foreach my $key (keys(%{$slf->{'sht'}}))
  { $buf .= join("\001", 'sht', $key, $slf->{'sht'}->{$key});
  }

  # Save the index entries
  foreach my $abr (keys(%{$slf->{'idx'}}))
  { $buf .= join("\001", 'dir', $abr, $slf->{'idx'}->{$abr}->{q{@}})
      if exists($slf->{'idx'}->{$abr}->{q{@}});
    foreach my $oid (keys(%{$slf->{'idx'}->{$abr}}))
    { next if $oid eq q{@};
      foreach my $dir (keys(%{$tbl = $slf->{'idx'}->{$abr}->{$oid}}))
      { foreach my $rec (@{$tbl->{$dir}})
        { $buf .= join("\001", 'idx', $abr, $oid, $dir, $rec);
        }
      }
    }
  }
  $slf->{'idx'} = {};

  # Save the file status information
  foreach my $key (keys(%{$tbl = $slf->{'sta'}}))
  { $buf .= join("\001", 'sta', RDA::Object::encode($key), $tbl->{$key});
  }
  $slf->{'sta'} = {};

  # Save the cloned report list and related catalog entries
  foreach my $oid (keys(%{$slf->{'rpt'}}))
  { next unless $slf->{'rpt'}->{$oid}->is_cloned;
    $buf .= join("\001", 'cln', $oid, qq{\n});
    foreach my $key (keys(%{$tbl = $slf->{'rpt'}->{$oid}->get_info('cat')}))
    { foreach my $rec (@{$tbl->{$key}})
      { $buf .= join("\001", 'cat', $oid, $key, $rec);
      }
    }
  }

  # Save the report space
  $buf .= join("\001", 'spc', $slf->{'spc'}) if $slf->{'spc'};

  # Return the extracted definition
  return $buf;
}

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

This method returns the abbreviation of the current module.

=cut

sub get_abbr
{ return shift->{'abr'};
}

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

This method returns the path of the current report directory (the report
directory or the multi-run collection directory). When the flag is set, it
creates missing directories also.

=cut

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

  return $slf->{'col'}->get_dir($slf->{'mrc'} ? 'M' : 'C', $flg);
}

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

This method returns the context owner. In list contexts, it returns both user
and group identifiers. In scalar contexts, it returns the user identifier. When
the context does not yet exists, it returns an empty list or an undefined
value, respectively.

=cut

sub get_owner
{ return shift->{'agt'}->get_owner;
}

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

This method returns a string combining the module abbreviation and the current
report prefix.

=cut

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

  return $slf->{'abr'}.$slf->{'pre'};
}

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

This method indicates whether the report control is currently working for a
job.

=cut

sub in_job
{ return shift->{'job'};
}

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

This method indicates whether the report file is rendered immediately. When
applied to the report control object, it indicates if direct rendering has been
requested.

=cut

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

=head2 S<$h-E<gt>load($ifh)>

This method loads extracted alias, file, index, and share information.

=cut

sub load
{ my ($slf, $ifh) = @_;
  my ($key, $lin, $str, $typ, @rec);

  $lin = 0;
  while (defined($str = $ifh->getline))
  { ++$lin;
    ($typ, $key, @rec) = split(/\001/, $str, -1);
    die get_string('ERR_LOAD', $lin) unless $typ && exists($tb_imp{$typ})
      && (scalar @rec) == $tb_imp{$typ} && $key;
    if ($typ eq 'als')
    { $slf->{'als'}->{$key}->{$rec[0]} = $rec[1];
    }
    elsif ($typ eq 'cat')
    { $slf->{'rpt'}->{$key}->add_entry($rec[0], $rec[1]);
    }
    elsif ($typ eq 'cln')
    { $slf->{'rpt'}->{$key}->update(1) if exists($slf->{'rpt'}->{$key});
    }
    elsif ($typ eq 'def')
    { my ($gid, $oid);

      pop(@rec);
      push(@{$slf->{'shr'}->{$key}},
        $slf->{'def'}->{$key}->{$oid}->{$gid} = [@rec])
        if ($oid = shift(@rec)) && ($gid = shift(@rec));
    }
    elsif ($typ eq 'exp')
    { push(@{$slf->{'exp'}->{$key}->{$rec[0]}->{$rec[1]}}, $rec[2]);
    }
    elsif ($typ eq 'hom')
    { $slf->{'idx'}->{$key}->{q{@}} = $rec[0];
    }
    elsif ($typ eq 'idx')
    { push(@{$slf->{'idx'}->{$key}->{$rec[0]}->{$rec[1]}}, $rec[2]);
    }
    elsif ($typ eq 'sht')
    { $slf->{'sht'}->{$key} = $rec[0];
    }
    elsif ($typ eq 'spc')
    { $slf->{'spc'} += $key;
    }
    elsif ($typ eq 'sta')
    { $key = RDA::Object::decode($1) if $key =~ m/^"([^"]*)"$/;
      $slf->{$typ}->{$key} = $rec[0];
    }
  }
  $ifh->close;

  # Return the object reference
  return $slf;
}

=head2 S<$h-E<gt>resume($bkp)>

This method resumes some object activities. It returns a list containing the
object reference and the previous values of the restored attributes.

=cut

sub resume
{ my ($slf, $rec) = @_;
  my ($bkp);

  die get_string('BAD_RESUME')
    unless $slf->{'typ'} eq 'L' && ref($rec) eq 'HASH';

  # End pipes, reports, and temporary files
  foreach my $oid (keys(%{$slf->{'pip'}}))
  { $slf->end_pipe($oid);
    delete($slf->{'pip'}->{$oid})->delete_object;
  }
  foreach my $oid (keys(%{$slf->{'rpt'}}))
  { $slf->end_report($oid);
    delete($slf->{'rpt'}->{$oid})->delete_object;
  }
  foreach my $oid (keys(%{$slf->{'tmp'}}))
  { $slf->end_temp($oid);
    delete($slf->{'tmp'}->{$oid})->delete_object;
  }

  # End the table of content
  delete($slf->{'toc'})->delete_object if exists($slf->{'toc'});

  # Restore the attributes
  $bkp = _switch($slf, {}, $rec);

  # Unlock the reports and temporary files
  foreach my $obj (values(%{$slf->{'pip'}}),
                   values(%{$slf->{'rpt'}}),
                   values(%{$slf->{'tmp'}}))
  { $obj->unlock;
  }

  # Return previous values
  return $bkp;
}

sub _switch
{ my ($slf, $bkp, $rec) = @_;

  # Restore saved attributes
  foreach my $key (keys(%{$rec}))
  { $slf->{$key} = $bkp->{$key} if exists($bkp->{$key});
    if (defined($rec->{$key}))
    { ($slf->{$key}, $bkp->{$key}) = ($rec->{$key}, $slf->{$key});
    }
    else
    { $bkp->{$key} = delete($slf->{$key});
    }
  }

  # Return the value of the modified attributes
  return $bkp;
}

=head2 S<$h-E<gt>set_abbr([$abbr])>

This method defines a new abbreviation when it contains two words, each
starting with a letter, followed by alphanumeric characters, and ended by an
underscore. Otherwise, it remains unchanged.

It returns the previous abbreviation.

=cut

sub set_abbr
{ my ($slf, $abr) = @_;
  my ($old);

  $old = $slf->{'abr'};
  if (defined($abr))
  { die get_string('BAD_MRC') if exists($slf->{'_sct'});
    $abr =~ s/_*$/_/;
    if ($abr =~ m/^(([A-Z][A-Z\d]*_){2})$/i)
    { $slf->{'abr'} = $1;
      $slf->{'lgt'} = _adjust_length($slf);
      $slf->{'blk'}->{$1} = [] unless exists($slf->{'blk'}->{$1});
    }
  }
  return $old;
}

=head2 S<$h-E<gt>set_cfm([$level])>

This method defines a new customer file management level when the argument
is a single-digit value. Otherwise, it remains unchanged.

It returns the previous level.

=cut

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

  $old = $slf->{'cfm'};
  $slf->{'cfm'} = $lvl if defined($lvl) && $lvl =~ m/^\d$/;;
  return $old;
}

=head2 S<$h-E<gt>set_prefix([$prefix])>

This method defines a new report prefix when the prefix is an empty string or
starts with a letter followed by alphanumeric characters. Otherwise, it remains
unchanged.

It returns the previous prefix.

=cut

sub set_prefix
{ my ($slf, $pre) = @_;
  my ($old);

  $old = $slf->{'pre'};
  if (defined($pre))
  { if ($pre eq q{})
    { $slf->{'pre'} = q{};
      $slf->{'lgt'} = _adjust_length($slf);
    }
    else
    { $pre =~ s/_*$/_/;
      if ($pre =~ m/^(([A-Z][A-Z\d]*_)+)$/i)
      { $slf->{'pre'} = $1;
        $slf->{'lgt'} = _adjust_length($slf);
      }
    }
  }
  return $old;
}

=head2 S<$h-E<gt>suspend($job[,$fork])>

This method suspends some report activities for the specified job. It returns
previous attributes.

=cut

sub suspend
{ my ($slf, $job, $frk) = @_;
  my (@tbl);

  die get_string('BAD_SUSPEND')
    if $slf->{'typ'} ne 'L' || $slf->{'job'};

  # Handle forked contexts
  if ($frk)
  { # Close pipes
    foreach my $oid (keys(%{$slf->{'pip'}}))
    { delete($slf->{'pip'}->{$oid})->delete_object;
    }

    # Update the job identifier
    $slf->{'col'}->get_output->{'job'} = $job;
  }

  # Lock pipes, reports, and temporary files
  foreach my $obj (values(%{$slf->{'pip'}}),
                   values(%{$slf->{'rpt'}}),
                   values(%{$slf->{'tmp'}}))
  { $obj->lock;
  }

  # Close the table of content file
  $slf->{'toc'}->close(1) if exists($slf->{'toc'});

  # Add space management contribution
  push(@tbl, _spc => $slf->{'_spc'} - $slf->{'spc'})
    if exists($slf->{'_spc'});

  # Switch object attributes
  return _switch($slf, {}, {
    abr  => $slf->{'abr'},
    als  => {},
    blk  => {$slf->{'abr'} => []},
    cur  => undef,
    def  => {},
    dup  => {},
    exp  => {},
    idx  => {},
    job  => $job,
    lgt  => _adjust_length($slf, $job),
    met  => $slf->{'met'},
    pid  => {},
    pip  => {},
    pre  => $slf->{'pre'},
    rpt  => {},
    shr  => {},
    spc  => 0,
    sta  => {},
    tmp  => {},
    toc  => undef,
    _opn => {},
    _pip => 0,
    _rpt => 0,
    _tmp => 0,
    @tbl,
    });
}

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

This method determines if it can create and remove files from the report
directory. It creates the directory if it does not exist already. It returns
an error message in case of a problem, or an undefined value on successful
completion.

=cut

sub test
{ my ($slf) = @_;
  my ($ofh, $pth, $val);

  # Test if the report group is compatible with basename constraint
  return get_string('ERR_LENGTH')
    if length($slf->{'abr'}) + 8 > $slf->{'bas'};

  # Create the report directory when needed
  eval {$pth = $slf->{'col'}->get_dir('C', 1)};
  if ($val = $@)
  { $val =~ s/[\n\r\s]+$//;
    return $val;
  }

  # Try to create a test file
  $ofh = IO::File->new;
  $pth = RDA::Object::Rda->cat_file($pth, $slf->{'abr'}.'_test.txt');
  return get_string('TEST_CREATE', $!)
    unless $ofh->open($pth, $CREATE, $FIL_PERMS);
  $ofh->close;

  # Unlink the file and indicate the completion status
  $val = 0;
  ++$val while unlink($pth);
  return $val ? undef : get_string('TEST_UNLINK', $!);
}

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

This method waits for the completion of report subprocesses.

=cut

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

  if (exists($slf->{'rpt'}))
  { foreach my $rpt (values(%{$slf->{'rpt'}}))
    { $rpt->wait;
    }
  }

  if (exists($slf->{'pid'}))
  { my ($cnt, $lim);

    $lim = $cnt = ($slf->{'end'} > 0) ? $slf->{'end'} : 0;
    foreach my $pid (keys(%{$slf->{'pid'}}))
    { eval {
        while (kill(0, $pid))
        { die "Timeout\n" if $lim && $cnt-- <= 0;
          sleep(1);
        }
        delete($slf->{'pid'}->{$pid});
      };
    }
    foreach my $pid (keys(%{$slf->{'pid'}}))
    { eval {RDA::Object::Rda->kill_child($pid)};
    }
    delete($slf->{'pid'});
  }
  return;
}

=head1 FILE INDEX METHODS

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

This method associates an Oracle home directory entry to the current
abbreviation.

=cut

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

  return 0 unless $pth && -d $pth;
  $slf->{'idx'}->{$slf->{'abr'}}->{q{@}} = join(q{|}, 'H', $pth, qq{\n});
  return 1;
}

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

This method enables the Oracle Explorer catalog and index creation regardless
the execution context. When the flag is set, it aligns as much as possible the
owner of the produced files to the owner of the report directory.

=cut

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

  $slf->{'own'} = 1 if $flg && defined($slf->{'agt'}->get_owner($flg));
  return $slf->{'flg'} = $slf->{'xpl'} = 1;
}

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

This method enables the index creation regardless the execution context. When
the flag is set, it aligns as much as possible the owner of the produced files
to the owner of the report directory.

=cut

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

  $slf->{'own'} = 1 if $flg && defined($slf->{'agt'}->get_owner($flg));
  return $slf->{'flg'} = 1;
}

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

This method indicates whether an Oracle Explorer catalog can be produced.

=cut

sub has_explorer
{ return shift->{'xpl'};
}

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

This method indicates whether an index can be produced.

=cut

sub has_index
{ return shift->{'flg'};
}

=head1 FILTERING METHODS

=head2 S<$h-E<gt>filter($str)>

This method filters sensitive information out of the specified string.

=cut

sub filter
{ my ($slf, $str) = @_;

  return exists($slf->{'flt'}) ? $slf->{'flt'}->filter($str) : $str;
}

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

This method returns the customer file management level of the current module.

=cut

sub get_cfm
{ return shift->{'cfm'};
}

sub _get_cfm
{ my ($slf, $nam) = @_;
  my ($dft, $cfm);

  $dft = $slf->{'col'}->get_first("STATUS.$nam.N_CFM", $DFT_CFM);
  if (exists($slf->{'flt'}))
  { $cfm = $slf->{'col'}->get_first("OUTPUT.REFINE.$nam.N_MOD", $DFT_CFM);
    return $cfm if $cfm > $dft
  }
  return $dft
}

=head2 S<$h-E<gt>get_file_cfm($fil)>

This method returns the customer file management level of the specified file.

=cut

sub get_file_cfm
{ my ($slf, $fil) = @_;
  my ($res);

  if (exists($slf->{'flt'}))
  { # Load the restriction on first request
    $res = _need_restrictions($slf, 'fil');

    # Return the custom level when specified
    return $res->{$fil}
      if exists($res->{$fil = RDA::Object::Rda->native($fil, 1)});
  }
  return $DFT_CFM;
}

=head2 S<$h-E<gt>get_tag_cfm($tag,...)>

This method returns the customer file management level of the specified tags.

=cut

sub get_tag_cfm
{ my ($slf, @tag) = @_;
  my ($cfm, $res);

  $cfm = $DFT_CFM;
  if (exists($slf->{'flt'}))
  { # Load the restriction on first request
    $res = _need_restrictions($slf, 'tag');

    # Get the maximum level
    foreach my $tag (@tag)
    { $cfm = $res->{$tag}
        if exists($res->{$tag}) && $res->{$tag} > $cfm;
    }
  }
  return $cfm;
}

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

This method indicates whether the specified report would be collected in the
current module from a customer file level perspective. Accurate results depends
on specifying the exact report name and the same level than specified at report
creation.

=cut

sub is_collected
{ my ($slf, $nam, $cfm) = @_;
  my ($lim, $res);

  return 0 unless $nam;
  if (exists($slf->{'flt'}))
  { # Load the restriction on first request
    $res = _need_restrictions($slf, 'rpt');
    $lim = $slf->{'res'}->{'cfm'};

    # Apply the module restrictions
    return 0 if (defined($cfm) ? $cfm : $slf->{'cfm'}) > $lim;

    # Apply the report restrictions
    return 0
      if exists($res->{$slf->{'abr'}})
      && exists($res->{$slf->{'abr'}}->{$nam})
      && $res->{$slf->{'abr'}}->{$nam} > $lim;
  }
  return 1;
}

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

This method indicates if sensitive information are filtered out.

=cut

sub is_filtered
{ return exists(shift->{'flt'});
}

=head2 S<$h-E<gt>log_timeout($req,$rpt)>

This method logs a timeout event in the event log. It applies the filtering
rules to the request command.

=cut

sub log_timeout
{ my ($slf, $req, $rpt) = @_;
  my ($cmd);
  $cmd = join(q{ }, $req->get_value('command'));
  $cmd = $slf->{'flt'}->filter($cmd) if exists($slf->{'flt'});
  $slf->{'col'}->log('t', $slf->{'oid'}, $req->get_first('ids', $rpt->get_file),
    $req->get_info('msg'), $cmd);
  return;
}

# Load required restrictions
sub _need_restrictions
{ my ($slf, $typ) = @_;
  my ($res);

  $res = $slf->{'res'};
  return exists($res->{$typ})  ? $res->{$typ} :
         exists($tb_res{$typ}) ? &{$tb_res{$typ}}($slf, $res) :
                                 {};
}

sub _load_fil
{ my ($slf, $res) = @_;
  my ($tbl);

  eval {$tbl = $slf->{'col'}->get_definition->get_hash('OUTPUT.REFINE.N_FIL')};
  return $res->{'fil'} = $@ ? {} : $tbl;
}

sub _load_rpt
{ my ($slf, $res) = @_;
  my ($top, $tbl);

  $res->{'cfm'} = $slf->{'col'}->get_first('OUTPUT.REFINE.N_CFM', 3);
  $res->{'rpt'} = $tbl = {};
  if ($top = $slf->{'col'}->find('OUTPUT.REFINE'))
  { foreach my $mod ($top->grep('^N_RPT$', 'or'))
    { eval {$tbl->{"$1_$2_"} = $top->get_hash("$mod.N_RPT")}
        if $mod ne 'RDA.END' && $mod =~ m/^(\w+)\.(\w+)$/;
    }
  }
  return $tbl;
}

sub _load_tag
{ my ($slf, $res) = @_;
  my ($tbl);

  eval {$tbl = $slf->{'col'}->get_definition->get_hash('OUTPUT.REFINE.N_TAG')};
  return $res->{'tag'} = $@ ? {} : $tbl;
}

=head1 META DIRECTORY MANAGEMENT METHODS

=head2 S<$h-E<gt>add_dir($dir)>

This method gets file status information for each file contained in the
specified directory and stores it in the meta directory repository.

=cut

sub add_dir
{ my ($slf, $dir) = @_;
  my ($cur, $lnk, $nxt, $pth, %dup);

  return 0 unless $slf->need_meta($dir) && opendir(MET, $dir);
  $dir = $slf->{'cfg'}->get_file('D_CWD', $dir)
    unless RDA::Object::Rda->is_absolute($dir);
  foreach my $fil (sort readdir(MET))
  { $pth = RDA::Object::Rda->cat_file($dir, $fil);
    next if exists($slf->{'sta'}->{$pth});
    eval {
      %dup = ($cur => 1);
      for ($cur = $pth ; -l $cur ; $cur = $nxt)  ## no critic (Loop)
      { die "Bad link\n" unless defined($lnk = readlink($cur));
        $nxt = RDA::Object::Rda->cat_file($lnk);
        $nxt = RDA::Object::Rda->clean_path([RDA::Object::Rda->dirname($cur),
          $nxt], 1) unless RDA::Object::Rda->is_absolute($nxt);
        $slf->{'sta'}->{$cur} = join(q{|}, lstat($cur),
          RDA::Object::encode($lnk), RDA::Object::encode($nxt), qq{\n});
        die "Link loop\n" if exists($dup{$nxt});
        $dup{$nxt} = 1;
      }
      };
    if (!$@)
    { $slf->{'sta'}->{$cur} = join(q{|}, stat($pth), qq{\n});
    }
    elsif (!exists($slf->{'sta'}->{$pth}))
    { $slf->{'sta'}->{$pth} = join(q{|}, stat($pth), qq{\n});
    }
  }
  closedir(MET);
  return 1;
}

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

This method gets the file information and stores it in the meta directory
repository.

=cut

sub add_file
{ my ($slf, $pth) = @_;
  my ($cur, $lnk, $nxt, %dup);

  return 0 unless $slf->need_meta(RDA::Object::Rda->dirname($pth));
  $pth = $slf->{'cfg'}->get_file('D_CWD', $pth)
    unless RDA::Object::Rda->is_absolute($pth);
  unless (exists($slf->{'sta'}->{$pth}))
  { eval {
      for ($dup{$cur = $pth} = 1 ; -l $cur ; $cur = $nxt)  ## no critic (Loop)
      { die "Bad link\n" unless defined($lnk = readlink($cur));
        $nxt = RDA::Object::Rda->cat_file($lnk);
        $nxt = RDA::Object::Rda->clean_path([RDA::Object::Rda->dirname($cur),
          $nxt], 1) unless RDA::Object::Rda->is_absolute($nxt);
        $slf->{'sta'}->{$cur} = join(q{|}, lstat($cur),
          RDA::Object::encode($lnk), RDA::Object::encode($nxt), qq{\n});
        die "Link loop\n" if exists($dup{$nxt});
        $dup{$nxt} = 1;
      }
      };
    if (!$@)
    { $slf->{'sta'}->{$cur} = join(q{|}, stat($pth), qq{\n});
    }
    elsif (!exists($slf->{'sta'}->{$pth}))
    { $slf->{'sta'}->{$pth} = join(q{|}, stat($pth), qq{\n});
    }
  }
  return 1;
}

=head2 S<$h-E<gt>add_lstat($path,@stat)>

This method stores specified file status information in the meta directory
repository.

=cut

sub add_lstat
{ my ($slf, $pth, @sta) = @_;
  my ($cur, $lnk, $nxt, %dup);

  return 0 unless $slf->need_meta(RDA::Object::Rda->dirname($pth));
  $pth = $slf->{'cfg'}->get_file('D_CWD', $pth)
    unless RDA::Object::Rda->is_absolute($pth);
  unless (exists($slf->{'sta'}->{$pth}))
  { eval {
      for ($dup{$cur = $pth} = 1 ; -l $cur ;)  ## no critic (Loop)
      { die "Bad link\n" unless defined($lnk = readlink($cur));
        $nxt = RDA::Object::Rda->cat_file($lnk);
        $nxt = RDA::Object::Rda->clean_path([RDA::Object::Rda->dirname($cur),
          $nxt], 1) unless RDA::Object::Rda->is_absolute($nxt);
        $slf->{'sta'}->{$cur} = join(q{|}, @sta,
          RDA::Object::encode($lnk), RDA::Object::encode($nxt), qq{\n});
        die "Link loop\n" if exists($dup{$nxt});
        $dup{$nxt} = 1;
        @sta = lstat($cur = $nxt);
      }
      };
    if (!$@)
    { $slf->{'sta'}->{$cur} = join(q{|}, @sta, qq{\n});
    }
    elsif (!exists($slf->{'sta'}->{$cur}))
    { $slf->{'sta'}->{$cur} = join(q{|}, stat($pth), qq{\n});
    }
  }
  return 1;
}

=head2 S<$h-E<gt>add_stat($path,@stat)>

This method stores specified file status information in the meta directory
repository.

=cut

sub add_stat
{ my ($slf, $pth, @sta) = @_;
  my ($cur, $lnk, $nxt, %dup);

  return 0 unless $slf->need_meta(RDA::Object::Rda->dirname($pth));
  $pth = $slf->{'cfg'}->get_file('D_CWD', $pth)
    unless RDA::Object::Rda->is_absolute($pth);
  unless (exists($slf->{'sta'}->{$pth}))
  { eval {
      for ($dup{$cur = $pth} = 1 ; -l $cur ; $cur = $nxt)  ## no critic (Loop)
      { die "Bad link\n" unless defined($lnk = readlink($cur));
        $nxt = RDA::Object::Rda->cat_file($lnk);
        $nxt = RDA::Object::Rda->clean_path([RDA::Object::Rda->dirname($cur),
          $nxt], 1) unless RDA::Object::Rda->is_absolute($nxt);
        $slf->{'sta'}->{$cur} = join(q{|}, lstat($cur),
          RDA::Object::encode($lnk), RDA::Object::encode($nxt), qq{\n});
        die "Link loop\n" if exists($dup{$nxt});
        $dup{$nxt} = 1;
      }
      };
    if (!$@)
    { $slf->{'sta'}->{$cur} = join(q{|}, @sta, qq{\n});
    }
    elsif (!exists($slf->{'sta'}->{$pth}))
    { $slf->{'sta'}->{$pth} = join(q{|}, @sta, qq{\n});
    }
  }
  return 1;
}

=head2 S<$h-E<gt>need_meta($dir)>

This method checks whether RDA can store file information in the meta
directory repository for the specified directory. Full paths must be used.

=cut

sub need_meta
{ my ($slf, $dir) = @_;

  return 0 unless $slf->{'met'};
  return 1 unless exists($slf->{'res'}->{'met'});
  return exists($slf->{'res'}->{'met'}->{RDA::Object::Rda->native($dir)});
}

=head2 S<$h-E<gt>set_meta($flag)>

This method specifies whether RDA can store file information in the meta
directory repository. This functionality is disabled when a security filter
is active.

=cut

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

  $old = $slf->{'met'};
  $slf->{'met'} = $flg if defined($flg) && !exists($slf->{'flt'});
  return $old;
}

=head1 SECTION MANAGEMENT METHODS

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

This method initiates the capture of the table of content lines.

=cut

sub begin_capture
{ return shift->{'toc'}->begin_capture;
}

=head2 S<$h-E<gt>begin_section($name,$type)>

This method initiates the treatment of a new section.

=cut

sub begin_section
{ my ($slf, $nam, $typ) = @_;

  # Enable report capture
  $slf->{'_exp'} = [];
  $slf->{'_idx'} = [];
  $slf->{'_sct'} = [];

  # Start table of content output buffering
  return $slf->{'toc'}->begin_capture;
}

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

This method accepts or reject the section.

=cut

sub end_section  ## no critic (Complex)
{ my ($slf, $nam, $typ, $flg, $prv) = @_;
  my ($abr, $col, $dir, $exp, $fil, $idx, $oid, $pth, $rec, $tbl, @det);

  # Create the section record
  $exp = delete($slf->{'_exp'});
  $idx = delete($slf->{'_idx'});
  $tbl = delete($slf->{'_sct'});
  if ($flg)
  { # End section reports
    if ($typ)
    { $rec = {
        lin => $slf->{'toc'}->get_capture,
        nam => $nam,
        rpt => [],
        typ => 'R',
        };

      # End all reports created in the section
      foreach my $rpt (@{$tbl})
      { push(@{$rec->{'rpt'}}, join(q{|}, $rpt->get_info('abr'),
          $rpt->get_oid, $rpt->get_info('dir'), $rpt->get_info('fil')))
          if $rpt->is_created;
        $slf->end_report($rpt);
      }
    }
    else
    { $rec = {
        lin => $slf->{'toc'}->get_capture,
        nam => $nam,
        rpt => [],
        typ => 'S',
        };

      # Render all reports created in the section
      foreach my $rpt (@{$tbl})
      { if ($rpt->is_created)
        { push(@{$rec->{'rpt'}}, join(q{|}, $rpt->get_info('abr'),
            $rpt->get_oid, $rpt->get_info('dir'),
            $rpt->get_info('fil')));
          $rpt->render;
        }
        else
        { $slf->end_report($rpt);
        }
      }
    }

    # Accept catalog entries
    foreach my $rec (@{$exp})
    { ($abr, $oid, $dir, @det) = @{$rec};
      push(@{$slf->{'exp'}->{$abr}->{$oid}->{$dir}}, @det);
    }
    foreach my $rec (@{$idx})
    { ($abr, $oid, $dir, @det) = @{$rec};
      push(@{$slf->{'idx'}->{$abr}->{$oid}->{$dir}}, @det);
    }
  }
  else
  { $rec = {
      lin => [],
      nam => $nam,
      rpt => [],
      typ => 'E',
      };

    # Delete section reports
    foreach my $rpt (@{$tbl})
    { $slf->end_report($rpt);
      $pth = $rpt->get_file(1);
      1 while unlink($pth);
      foreach my $pth (@{$rpt->get_info('lst')})
      { 1 while unlink($pth);
      }
      delete($slf->{'als'}->{$rpt->get_oid}->{$rpt->get_info('dir')});
    }
  }

  # Delete previous reports from common sections
  if (ref($prv))
  { $col = $slf->{'col'};
    foreach my $rpt (@{$prv})
    { ($abr, $oid, $dir, $fil) = split(/\|/, $rpt, 4);

      # Delete the index entries
      delete($slf->{'als'}->{$oid}->{$dir});
      delete($slf->{'exp'}->{$abr}->{$oid}->{$dir});
      delete($slf->{'idx'}->{$abr}->{$oid}->{$dir});

      # Remove the file
      $fil = RDA::Object::Rda->cat_file($col->get_dir($dir), $fil);
      1 while unlink($fil);
      $fil =~ s/\.(dat|txt)$/.htm/i;
      1 while unlink($fil);
      $fil =~ s/\.htm$/.xml/i;
      1 while unlink($fil);
    }
  }

  # Return the section record
  return $rec;
}

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

This method gets the content of the capture buffer.

=cut

sub get_section
{ return shift->{'toc'}->get_capture,
}

=head2 S<$h-E<gt>load_index($rec,$type)>

This method loads the index tables with previous run information.

=cut

sub load_index
{ my ($slf, $rec, $typ) = @_;
  my ($abr, $dir, $key, $ref, $rev, $rpt, $sub, $tbl, @det);

  # Load the alias entries
  $rev = $slf->{'rev'};
  if (exists($rec->{'als'}))
  { $tbl = $slf->{'als'};
    $ref = $typ ? 'C' : 'M';
    foreach my $lin (@{$rec->{'als'}})
    { ($key, $dir, @det) = split(/\|/, $lin);
      next if $dir eq $ref;

      # Define the alias entry
      $tbl->{$key}->{$dir} = join(q{|}, @det);

      # Define the reverse map entry
      next unless defined($sub = $slf->{'col'}->get_sub($dir));
      $rpt = RDA::Object::Rda->cat_file($sub, $det[0]);
      $rpt =~ s/\.(dat|txt)$/.htm/i;
      $rev->{$rpt} = [$key, $dir];
    }
  }

  # Load the Oracle Explorer entries
  if (exists($rec->{'exp'}))
  { $abr = $slf->{'abr'};
    $tbl = $slf->{'exp'};
    foreach my $lin (@{$rec->{'exp'}})
    { ($key, $ref) = split(/\|/, $lin, 3);
      if (exists($rev->{$ref}))
      { ($key, $dir) = @{$rev->{$ref}};
        push(@{$tbl->{$abr}->{$key}->{$dir}}, $lin);
        $rev->{$ref}->[2] = $abr;
      }
    }
  }

  # Load the index entries
  if (exists($rec->{'idx'}))
  { $abr = $slf->{'abr'};
    $tbl = $slf->{'idx'};
    foreach my $lin (@{$rec->{'idx'}})
    { ($key, $ref) = split(/\|/, $lin, 3);
      if ($key eq 'A')
      { $abr = $ref;
      }
      elsif ($key eq 'H')
      { $tbl->{$abr}->{q{@}} = $ref;
      }
      elsif ($key eq 'S')
      { $slf->{'sht'}->{$ref} = $lin;
      }
      elsif (exists($rev->{$ref}))
      { ($key, $dir) = @{$rev->{$ref}};
        push(@{$tbl->{$abr}->{$key}->{$dir}}, $lin);
        $rev->{$ref}->[2] = $abr;
      }
    }
  }

  # Save the file status information entries
  if (exists($rec->{'sta'}))
  { $tbl = $slf->{'sta'};
    foreach my $lin (@{$rec->{'sta'}})
    { ($key, $lin) = split(/\|/, $lin, 2);
      $key = RDA::Object::decode($1) if $key =~ m/^"([^"]*)"$/;
      $tbl->{$key} = $lin;
    }
  }
  return;
}

=head2 S<$h-E<gt>load_run($abr)>

This method loads the information from the previous run.

=cut

sub load_run
{ my ($slf, $abr) = @_;
  my ($dat, $ifh, $par, $pth, $rec);

  # Determine the name of the table of content file
  $dat = $slf->{'dat'};
  $pth = $abr.'T.toc';
  $pth = lc($pth) unless $slf->{'cas'};
  $pth = RDA::Object::Rda->cat_file($dat, $pth);
  $ifh = IO::File->new;

  # Load the table of content
  $slf->{'prv'} = $rec = {col => {}, lin => [], typ => 'T'};
  if ($ifh->open("<$pth"))
  { while (<$ifh>)
    { if (m/^#---\[([CEFRS]):(.+)\]---/)
      { if ($1 eq 'R' || $1 eq 'S')
        { $par = $rec;
          push(@{$par->{'lin'}}, $par->{'sct'}->{$2} = $rec =
            {lin=> [], nam => $2, par => $par, rpt => [], typ => $1});
        }
        elsif ($1 eq 'E')
        { push(@{$rec->{'lin'}}, $rec->{'sct'}->{$2} =
            {lin=> [], nam => $2, par => $rec, rpt => [], typ => 'E'});
        }
        elsif ($1 eq 'F')
        { push(@{$rec->{'rpt'}}, $2);
        }
        else
        { $par = $rec;
          push(@{$par->{'lin'}}, $par->{'col'}->{$2} = $rec =
            {lin=> [], nam => $2, par => $par, sct => {}, typ => 'C'});
        }
      }
      elsif (m/^#---\[(?:[ce]:.+)?\]---/)
      { $rec = $rec->{'par'} if exists($rec->{'par'});
      }
      else
      { push(@{$rec->{'lin'}}, $_);
      }
    }
    $ifh->close;
  }

  # Load the alias definitions
  $pth = RDA::Object::Rda->cat_file($dat, $abr.'A.fil');
  if ($ifh->open("<$pth"))
  { $slf->{'prv'}->{'als'} = [$ifh->getlines];
    $ifh->close;
  }

  # Load the file status information entries
  $pth = RDA::Object::Rda->cat_file($dat, $abr.'D.fil');
  if ($ifh->open("<$pth"))
  { $slf->{'prv'}->{'sta'} = [$ifh->getlines];
    $ifh->close;
  }

  # Load the Oracle Explorer entries
  $pth = RDA::Object::Rda->cat_file($dat, $abr.'E.fil');
  if ($ifh->open("<$pth"))
  { $slf->{'prv'}->{'exp'} = [$ifh->getlines];
    $ifh->close;
  }

  # Load the index entries
  $pth = RDA::Object::Rda->cat_file($dat, $abr.'I.fil');
  if ($ifh->open("<$pth"))
  { $slf->{'prv'}->{'idx'} = [$ifh->getlines];
    $ifh->close;
  }

  # Return the table of content definition
  return $slf->{'prv'};
}

=head2 S<$h-E<gt>save_toc([$rec])>

This method saves a table of content.

=cut

sub save_toc
{ my ($slf, $rec) = @_;
  my ($toc);

  $rec = $slf->{'prv'} unless defined($rec);
  if (ref($toc = $slf->{'toc'}) && ref($rec))
  { # Disable the capture mode
    $toc->end_capture;

    # Save the record lines
    &{$tb_toc{$rec->{'typ'}}}($toc, $rec) if exists($tb_toc{$rec->{'typ'}});
  }
  return;
}

sub _save_collect
{ my ($toc, $rec) = @_;

  $toc->write(q{#---[C:}.$rec->{'nam'}.qq{]---\n});
  _save_lines($toc, $rec->{'lin'});
  $toc->write(q{#---[c:}.$rec->{'nam'}.qq{]---\n});
  return;
}

sub _save_empty
{ my ($toc, $rec) = @_;

  $toc->write(q{#---[E:}.$rec->{'nam'}.qq{]---\n});
  return;
}

sub _save_lines
{ my ($toc, $tbl) = @_;

  foreach my $lin (@{$tbl})
  { if (ref($lin))
    { &{$tb_toc{$lin->{'typ'}}}($toc, $lin) if exists($tb_toc{$lin->{'typ'}});
    }
    else
    { $toc->write($lin);
    }
  }
  return;
}

sub _save_section
{ my ($toc, $rec) = @_;

  $toc->write(q{#---[}.$rec->{'typ'}.q{:}.$rec->{'nam'}.qq{]---\n});
  _save_lines($toc, $rec->{'lin'});
  foreach my $rpt (@{$rec->{'rpt'}})
  { $toc->write(qq{#---[F:$rpt]---\n});
  }
  $toc->write(q{#---[e:}.$rec->{'nam'}.qq{]---\n});
  return;
}

sub _save_top
{ my ($toc, $rec) = @_;

  _save_lines($toc, $rec->{'lin'});
  return;
}

=head1 REPORT MANAGEMENT METHODS

=head2 S<$h-E<gt>add_report($type,$name[,$dyn[,$ext[,$flg[,$cfm]]]])>

This method creates a new report and returns the corresponding report
object. It supports the following report types:

=for stopwords Extern

=over 8

=item B<    'B' > Binary data file

=item B<    'C' > Collection report

=item B<    'D' > Data file

=item B<    'E' > Extern subdirectory report

=item B<    'F' > Collection file

=item B<    'R' > Reference report

=item B<    'S' > Sample report

=back

When the type is in lower case, it does not take it as current report and will
not be closed automatically when it creates a another report.

You can use a same name for multiple reports.

Verbatim blocks are used by default unless the flag is set.

=cut

sub add_report
{ my ($slf, $typ, $nam, $dyn, $ext, $flg, $cfm) = @_;
  my ($end, $oid, $res, $skp, $rpt);

  # Validate the arguments
  die get_string('NO_REPORT') unless $slf->{'typ'} eq 'L';
  if (index('BCDEFRS', $typ) < 0)
  { $typ = uc($typ);
    $end = 1;
    die get_string('BAD_TYPE', $typ) if index('BCDEFRS', $typ) < 0;
  }
  $nam =~ s/[_\W]+/_/g;
  ($nam) = $nam =~ /^([A-Za-z]\w*)$/ or die get_string('BAD_NAME');

  # Determine the customer file level for the report
  $cfm = $slf->{'cfm'} unless defined($cfm) && $cfm =~ m/^\d$/;
  $skp = 0;
  if (exists($slf->{'flt'}))
  { # Load the restrictions on first request
    $res = _need_restrictions($slf, 'rpt');

    # Adjust the level when required
    $cfm = $res->{$slf->{'abr'}}->{$nam}
      if exists($res->{$slf->{'abr'}})
      && exists($res->{$slf->{'abr'}}->{$nam})
      && $res->{$slf->{'abr'}}->{$nam} > $cfm;


    # Apply the report restrictions
    $skp = 1 if $cfm > $slf->{'res'}->{'cfm'};
  }

  # Terminate the current report
  _end_current($slf, delete($slf->{'cur'})) if exists($slf->{'cur'}) && !$end;

  # Create the report
  $oid = _gen_rpt_oid($slf, 'R');
  $slf->{'rpt'}->{$oid} = $slf->{'lst'} = $rpt = RDA::Object::Report->new($slf,
    $oid, $typ, $slf->{'pre'}, $nam, $dyn, $flg ? 0 : 1, $cfm, $skp,
    $slf->{'lgt'}, $ext);
  $slf->{'als'}->{$oid}->{$rpt->get_info('dir')} =
    join(q{|}, $rpt->get_info('fil'), $dyn ? q{} : $rpt->get_info('nam'),
              $cfm, qq{\n});
  $slf->{'cur'} = $rpt unless $end;

  # Capture the report
  push(@{$slf->{'_sct'}}, $rpt) if exists($slf->{'_sct'});

  # Return the report reference
  return $rpt;
}

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

  return &{$tb_end{ref($obj)}}($slf, $obj);
}

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

  return sprintf('%s%s%05d%s', $slf->{'abr'}, $typ, ++$slf->{'_rpt'},
    $slf->{'job'});
}

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

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

=cut

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

  foreach my $rpt (values(%{$slf->{'rpt'}}))
  { $rpt->deprefix($blk);
  }
  return;
}

=head2 S<$h-E<gt>end_report($report)>

This method ends the corresponding report. You can specify the report by its
object reference or its object identifier. It returns the report reference when
the operation is successful. Otherwise, it returns an undefined value.

=cut

sub end_report
{ my ($slf, $oid) = @_;
  my ($abr, $dir, $pid, $rpt, $tbl);

  $oid = $oid->get_oid if ref($oid);
  return unless defined($oid)
    && exists($slf->{'rpt'})
    && exists($slf->{'rpt'}->{$oid})
    && ($rpt = $slf->{'rpt'}->{$oid})->is_active;

  # Adjust the current and suspended reports
  delete($slf->{'cur'})
    if exists($slf->{'cur'}) && $slf->{'cur'} == $rpt;
  delete($slf->{'lst'})
    if exists($slf->{'lst'}) && $slf->{'lst'} == $rpt;
  foreach my $nam (keys(%{$tbl = $slf->{'_opn'}}))
  { delete($tbl->{$nam})
      if $tbl->{$nam} == $rpt;
  }

  # Update the reverse mapping and add catalog entries
  $abr = $rpt->get_info('abr');
  $dir = $rpt->get_info('dir');
  $tbl = $rpt->get_info('cat');
  $slf->{'rev'}->{$rpt->get_report} = [$oid, $dir, $abr];
  foreach my $key (keys(%{$tbl}))
  { if (exists($slf->{"_$key"}))
    { push(@{$slf->{"_$key"}}, [$abr, $oid, $dir, @{$tbl->{$key}}]);
    }
    else
    { push(@{$slf->{$key}->{$abr}->{$oid}->{$dir}}, @{$tbl->{$key}});
    }
  }

  # Delete any share definition if the file has not been created
  unless (defined($rpt->is_created))
  { foreach my $abr (keys(%{$slf->{'def'}}))
    { delete($slf->{'def'}->{$abr}->{$oid});
    }
  }

  # Store any remaining asynchronous subprocess
  if ($rpt->get_info('aft'))
  { $rpt->wait;
  }
  else
  { $slf->{'pid'}->{$pid} = 1 if ($pid = $rpt->set_info('pid'));
  }

  # End the report
  return $rpt->end;
}

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

This method returns the link that is associated with the specified report. It
is possible to refer to another module. When the flag is set, it adjusts the
link for multi-run collections.

=cut

sub get_link
{ my ($slf, $rpt, $mod, $flg) = @_;
  my ($lnk, $sub);

  $lnk = ($mod && $mod =~ $RE_DC)
    ? uc($2).q{_}.uc($3).q{_}.$rpt.'.htm'
    : $slf->{'abr'}.$rpt.'.htm';
  $lnk = $sub.q{/}.$lnk
    if $flg && $slf->{'mrc'} && defined($sub = $slf->{'col'}->get_sub('M'));
  return $slf->{'cas'} ? $lnk : lc($lnk);
}

=head2 S<$h-E<gt>get_name($type,$file)>

This method returns the report name.

=cut

sub get_name
{ my ($slf, $typ, $fil) = @_;
  my ($lnk, $sub);

  $lnk = defined($sub = $slf->{'col'}->get_sub($typ))
    ? $sub.q{/}.$fil
    : $fil;
  return $slf->{'cas'} ? $lnk : lc($lnk);
}

=head2 S<$h-E<gt>purge($type,$re,$day[,$sec[,flag]])>

This method removes all files that match the regular expression and that are
older than the specified age from the specified report subdirectory. Unless
the type is in lower case, the regular expression is automatically prefixed
with the module abbreviation and prefix. When the flag is set, it creates a
missing subdirectory.

It returns the number of removed files.

=cut

sub purge
{ my ($slf, $typ, $pat, $day, $sec, $flg) = @_;
  my ($abr, $cnt, $dir, $fil, $key, $ref);

  $cnt = 0;
  if ($typ && $pat && defined($day))
  { $key = uc($typ);
    if (defined($dir = $slf->{'col'}->get_dir($key)) && opendir(DIR, $dir))
    { $abr = $slf->{'abr'}.$slf->{'pre'};
      $sec = 0 unless defined($sec);
      $ref = time - $day * 86400 - $sec;
      ## no critic (Eval)
      $pat  = ($typ eq $key)
        ? eval "qr!^($abr$pat([\\000-\\377]*))\$!i"
        : eval "qr!^(([\\000-\\377]*)$pat([\\000-\\377]*))\$!i";
      foreach my $nam (readdir(DIR))
      { next unless $nam =~ $pat;
        $fil = RDA::Object::Rda->cat_file($dir, $1);
        next unless  ## no critic (Unless)
          RDA::Object::Rda->get_last_modify($fil, $ref) < $ref;
        ++$cnt while unlink($fil);
      }
      closedir(DIR);
    }
    elsif ($flg)
    { $slf->{'col'}->get_dir($key, 1);
    }
  }
  return $cnt;
}

=head1 REPORT SHARING METHODS

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

This method shares the current report and adds it in the specified group with
the specified link text. It returns a true value when the operation is
successful. Otherwise, it returns a false value.

=cut

sub add_share
{ my ($slf, $oid, $gid, $lnk) = @_;
  my ($abr, $def, $rpt);

  die get_string('ERR_MRC') if exists($slf->{'_sct'});

  $abr = $slf->{'abr'};
  $oid = $oid->get_oid if ref($oid);
  return 0 unless $gid && $lnk && exists($slf->{'rpt'})  ## no critic (Unless)
    && exists($slf->{'rpt'}->{$oid})
    && !exists($slf->{'def'}->{$abr}->{$oid}->{$gid});
  $rpt = $slf->{'rpt'}->{$oid};
  $gid =~ s/[_\W]+/_/g;
  $lnk =~ s/[\|\n\r\s]+/ /g;
  push(@{$slf->{'shr'}->{$abr}}, $slf->{'def'}->{$abr}->{$oid}->{$gid} =
    [$gid,
     $oid,
     $slf->{'oid'},
     $rpt->get_info('dir'),
     $rpt->get_info('nam'),
     $rpt->get_info('ext'),
     $rpt->get_info('fmt'),
     $rpt->get_info('fil'),
     $slf->filter($lnk)]);
  return 1;
}

=head2 S<$h-E<gt>find_block($tag[,module...])>

This method returns the description of the block identified by the specified
tag. When not found in the current module and in the specified modules, it
returns an undefined value.

=cut

sub find_block
{ my ($slf, $req, @mod) = @_;
  my ($abr, $def, $ifh, $rec, @rec);

  return unless defined($req);
  $req = q{_}.$req.q{_};
  $req =~ s/[\_\W]+/_/g;

  # Analyze index entries in the current module
  foreach my $abr (values(%{$slf->{'idx'}}))
  { foreach my $rpt (values(%{$abr}))
    { next unless ref($rpt) eq 'HASH';
      foreach my $dir (values(%{$rpt}))
      { foreach my $blk (@{$dir})
        { @rec = split(/\|/, $blk);
          @rec = split(/\//, $rec[2]);
          $rec = [splice(@rec, 0, 5)];
          foreach my $tag (@rec)
          { return $rec if $tag eq $req;
          }
        }
      }
    }
  }

  # Analyze index entries in the specified modules
  foreach my $mod (@mod)
  { next unless $mod =~ m/^([A-Z][A-Z\d]*)[\_\.]([A-Z][A-Z\d]*)_?$/i;
    $abr = uc("$1\_$2\_");

    # Load the index content
    if (exists($slf->{'blk'}->{$abr}))
    { $def = $slf->{'blk'}->{$abr};
    }
    else
    { $slf->{'blk'}->{$abr} = $def = [];
      $ifh = IO::File->new;
      if ($ifh->open('<'.RDA::Object::Rda->cat_file($slf->{'dat'},
        $abr.'I.fil')))
      { while (<$ifh>)
        { @rec = split(/\|/, $_);
          push(@{$def}, $rec[2]);
        }
        $ifh->close;
      }
    }

    # Analyze index entries
    foreach my $blk (@{$def})
    { @rec = split(/\//, $blk);
      $rec = [splice(@rec, 0, 5)];
      foreach my $tag (@rec)
      { return $rec if $tag eq $req;
      }
    }
  }
  return;
}

=head2 S<$h-E<gt>find_shares($group,$module...)>

This method returns the identifiers of all shared files that belong to the
specified group. It only searches the specified modules.

=cut

sub find_shares
{ my ($slf, $gid, @mod) = @_;
  my ($abr, $cnt, $def, $ifh, @rec, @tbl);

  if ($gid && exists($slf->{'shr'}))
  { $gid =~ s/[_\W]+/_/g;
    foreach my $mod (@mod)
    { next unless $mod =~ m/^([A-Z][A-Z\d]*)[\_\.]([A-Z][A-Z\d]*)_?$/i;
      $abr = uc("$1\_$2\_");

      # Load the module sharing definitions
      if (exists($slf->{'shr'}->{$abr}))
      { $def = $slf->{'shr'}->{$abr};
      }
      else
      { $slf->{'shr'}->{$abr} = $def = [];
        $ifh = IO::File->new;
        if ($ifh->open('<'.RDA::Object::Rda->cat_file($slf->{'dat'},
          $abr.'S.fil')))
        { while (<$ifh>)
          { @rec = split(/\|/, $_);
            pop(@rec);
            push(@{$def}, [@rec]);
          }
          $ifh->close;
        }
      }

      # Search for shared files
      $cnt = 0;
      foreach my $rec (@{$def})
      { push(@tbl, "$abr:$cnt") if $gid eq $rec->[0];
        ++$cnt;
      }
    }
  }
  return @tbl;
}

=head2 S<$h-E<gt>get_share($oid)>

This method returns the link text of the specified shared file.

=cut

sub get_share
{ my ($slf, $oid) = @_;
  my ($mod, $off);

  return unless $oid;
  ($mod, $off) = split(/\:/, $oid);
  return (exists($slf->{'shr'})
    && exists($slf->{'shr'}->{$mod}) && ref($slf->{'shr'}->{$mod}->[$off]))
    ? $slf->{'shr'}->{$mod}->[$off]->[$SHR_LNK]
    : undef;
}

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

This method creates a link inside the current module to the specified shared
file. It returns the report name when the operation is successful. Otherwise,
it returns an undefined value.

When the flag is set, it preserves the original file extension.

=cut

sub set_share
{ my ($slf, $oid, $flg) = @_;
  my ($abr, $def, $dir, $dst, $fil, $mod, $off, $ret, $src);

  # Get the sharing definition record
  return unless $oid;
  ($mod, $off) = split(/\:/, $oid);
  return unless exists($slf->{'shr'})
    && exists($slf->{'shr'}->{$mod}) && ref($slf->{'shr'}->{$mod}->[$off]);
  $def = $slf->{'shr'}->{$mod}->[$off];

  # Check if the file exists
  $dir = $slf->{'col'}->get_dir($def->[$SHR_DIR]);
  $src = RDA::Object::Rda->is_path(RDA::Object::Rda->cat_file($dir,
    $fil = $def->[$SHR_FIL]));
  return unless defined($src) && -f $src;

  # Link the file when referencing a report from another module
  $abr = $slf->{'abr'};
  if ($mod ne $abr)
  { if (exists($slf->{'dup'}->{$abr}->{$def->[$SHR_OID]}))
    { $fil = $slf->{'dup'}->{$abr}->{$def->[$SHR_OID]};
    }
    else
    { $fil = _gen_rpt_oid($slf, 'L');
      $fil .= substr(q{_}.$def->[$SHR_NAM], 0, $slf->{'lgt'})
        if $def->[$SHR_FMT];
      $fil .= $def->[$SHR_EXT];
      $fil = lc($fil) unless $slf->{'cas'};
      $dst = RDA::Object::Rda->is_path(RDA::Object::Rda->cat_file($dir, $fil));
      if (defined($dst) && ! -f $dst)
      { eval {$ret = link($src, $dst)};
        eval {$ret = copy($src, $dst)}
          unless $ret || !$slf->{'emu'};  ## no critic (Unless)
        return unless $ret;
      }
      $slf->{'dup'}->{$abr}->{$def->[$SHR_OID]} = $fil;
    }
  }

  # Return the report name
  $fil =~ s/\.(dat|txt)$/.htm/i unless $flg;
  return $slf->get_name($def->[$SHR_DIR], $fil);
}

=head1 SPACE MANAGEMENT METHODS

=head2 S<$h-E<gt>check_free($size)>

This method checks whether enough disk space is free after consuming the
specified size. It raises an error when that is no longer true.

=cut

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

  return &{$slf->{$flg ? '_dff' : '_dfr'}}($slf, $siz);
}

sub _chk_free
{ my ($slf, $val) = @_;

  # Determine the test function
  if ($val > 0)
  { $slf->{'_dfm'} = int(1048576 * $val);
    if (RDA::Object::Rda->is_unix || RDA::Object::Rda->is_cygwin)
    { return _set_free($slf) if defined(_ini_free_unix($slf));
    }
    elsif (RDA::Object::Rda->is_windows)
    { return _set_free($slf) if defined(_ini_free_dos($slf));
    }
  }

  # No check by default
  $slf->{'_dff'} = $slf->{'_dfr'} = \&_chk_free_none;
  return $slf->{'_dfm'} = 0;
}

sub _chk_free_dos
{ my ($slf, $siz) = @_;
  my ($val, @tbl);

  @tbl = `cmd /C dir /-C $slf->{'_dfp'}`;
  foreach my $lin (@tbl)
  { next unless $lin =~ m/^\s*0\s.*\s(\d+)\s[^\d]+$/;
    $slf->{'_dfa'} = $val = $1 - $slf->{'_dfm'} - $siz;
    die get_string('ERR_FREE') if $val < 0;
    return $val;
  }
  return;
}

sub _chk_free_hpux
{ my ($slf, $siz) = @_;
  my ($val, @tbl);

  @tbl = `df -k $slf->{'_dfp'}`;
  foreach my $lin (@tbl)
  { next unless $lin =~ m/\s(\d+)\s+free allocated Kb/;
    $slf->{'_dfa'} = $val = 1024 * $1 - $slf->{'_dfm'} - $siz;
    die get_string('ERR_FREE') if $val < 0;
    return $val;
  }
  return;
}

sub _chk_free_none
{ return;
}

sub _chk_free_unix
{ my ($slf, $siz) = @_;
  my ($val, @tbl);

  @tbl = `df -k $slf->{'_dfp'}`;
  foreach my $lin (@tbl)
  { next unless $lin =~ m/\s(\d+)\s+\d+\%\s/;
    $slf->{'_dfa'} = $val = 1024 * $1 - $slf->{'_dfm'} - $siz;
    die get_string('ERR_FREE') if $val < 0;
    return $val;
  }
  return;
}

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

  $slf->{'_dff'} = \&_chk_free_dos;
  $slf->{'_dfp'} = RDA::Object::Rda->quote(RDA::Object::Rda->cat_native(
    $slf->{'dat'}, 'RDA.log'));
  return &{$slf->{'_dff'}}($slf, 0);
}

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

  $slf->{'_dff'} = ($^O eq 'hpux') ? \&_chk_free_hpux : \&_chk_free_unix;
  $slf->{'_dfp'} = RDA::Object::Rda->quote($slf->{'dat'});
  return &{$slf->{'_dff'}}($slf, 0);
}

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

  return $slf->{'_dfr'} =
    ($slf->{'_dft'} eq 'E') ? $slf->{'_dff'} = \&_chk_free_none :
    ($slf->{'_dft'} eq 'R') ? $slf->{'_dff'} :
                              \&_chk_free_none;
}

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

This method indicates whether the disk space consumed by the module reports is
within the specified limit. It always returns zero when the space quota is
disabled.

=cut

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

  # Skip the test when there is no limit
  return 0 unless exists($slf->{'_spc'});

  # Update the space consumed
  foreach my $rpt (values(%{$slf->{'rpt'}}))
  { $rpt->update;
  }

  # Return the space margin
  return $slf->{'_spc'} - $slf->{'spc'};
}

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

This method decreases the estimated free disk space. Unless the flag is set, it
raises an error instead of returning a false value when free space is not
sufficient.

=cut

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

  $slf->{'_dfa'} -= $siz if $slf->{'_dfm'};
  return 1
    unless $slf->{'_dfa'} < 0;  ## no critic (Unless)
  return 0 if $flg;
  die get_string('ERR_FREE');
}

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

This method indicates whether the specified space is still available from the
estimated free disk space. Unless the flag is set, it raises an error instead
of returning a false value when free space is not sufficient.

=cut

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

  return 1
    unless $siz > $slf->{'_dfa'} && $slf->{'_dfm'};  ## no critic (Unless)
  return 0 if $flg;
  die get_string('ERR_FREE');
}

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

This method adds a report contribution to the total space consumed.

=cut

sub update_space
{ my ($slf, $siz) = @_;

  return $slf->{'spc'} += $siz;
}

=head1 TEMPORARY FILE MANAGEMENT METHODS

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

This method creates a new temporary file. You can specify the file extension as
an argument. C<.tmp> is used as default file extension. When the flag is set,
it makes the file executable when the file is closed.

It returns the corresponding object.

=cut

sub add_temp
{ my ($slf, $nam, $ext, $flg) = @_;
  my ($oid);

  die get_string('NO_TEMP') unless $slf->{'typ'} eq 'L';
  $nam =~ s/[_\W]+/_/g;
  ($nam) = $nam =~ m/^([A-Za-z]\w*)$/ or die get_string('BAD_NAME');
  $oid = sprintf('%sT%05d_%02d%s', $slf->{'abr'}, $$, ++$slf->{'_tmp'},
    $slf->{'job'});
  return $slf->{'tmp'}->{$oid} = RDA::Object::Report->new($slf, $oid, 'T',
    q{}, $nam, 0, 1, 0, 0, $slf->{'lgt'}, $ext, $flg);
}

=head2 S<$h-E<gt>end_temp($temp)>

This method ends the corresponding temporary file. You can specify the
temporary file by its object reference or its object identifier. It returns a
the report reference when the operation is successful. Otherwise, it returns
an undefined value.

=cut

sub end_temp
{ my ($slf, $oid) = @_;

  $oid = $oid->get_oid if ref($oid);
  return (defined($oid) && exists($slf->{'tmp'})
    && exists($slf->{'tmp'}->{$oid}))
    ? $slf->{'tmp'}->{$oid}->end
    : undef;
}

=head1 COMMAND PIPE MANAGEMENT METHODS

=head2 S<$h-E<gt>add_pipe($command)>

This method creates a pipe to the specified command. It returns a reference to
the corresponding object.

=cut

sub add_pipe
{ my ($slf, $cmd) = @_;
  my ($oid);

  die get_string('NO_PIPE') unless $slf->{'typ'} eq 'L';
  die get_string('NO_COMMAND') unless $cmd;

  # Terminate the current report
  _end_current($slf, delete($slf->{'cur'})) if exists($slf->{'cur'});

  # Create the new pipe
  $oid = sprintf('%sP%05d_%02d%s', $slf->{'abr'}, $$, ++$slf->{'_pip'},
    $slf->{'job'});
  return $slf->{'pip'}->{$oid} = $slf->{'lst'} = $slf->{'cur'} =
    RDA::Object::Pipe->new($slf, $oid, $cmd);
}

=head2 S<$h-E<gt>end_pipe($pipe)>

This method closes the corresponding pipe. You can specify the pipe object by
its reference or its object identifier. It returns a the pipe object reference
when the operation is successful. Otherwise, it returns an undefined value.

=cut

sub end_pipe
{ my ($slf, $oid) = @_;
  my ($obj, $tbl);

  $oid = $oid->get_oid if ref($oid);
  return unless defined($oid)
    && exists($slf->{'pip'}) && exists($slf->{'pip'}->{$oid});
  $obj = $slf->{'pip'}->{$oid};

  # Adjust the current and suspended reports
  delete($slf->{'cur'})
    if exists($slf->{'cur'}) && $slf->{'cur'} == $obj;
  delete($slf->{'lst'})
    if exists($slf->{'lst'}) && $slf->{'lst'} == $obj;
  foreach my $nam (keys(%{$tbl = $slf->{'_opn'}}))
  { delete($tbl->{$nam})
      if $tbl->{$nam} == $obj;
  }

  # Close the pipe
  $obj->close;
  return;
}

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

# Initialize the local report control
sub _begin_control
{ my ($pkg) = @_;
  my ($col, $out);

  $col = $pkg->get_collector;
  $col->get_config->purge_shorts;
  $out = $col->get_output->new($pkg);
  $pkg->set_info('out', 1) if exists($out->{'rnd'});
  $pkg->set_top('OUT', $out);
  return;
}

# Close all active reports
sub _end_control
{ my ($pkg) = @_;
  my ($tim);

  $tim = $pkg->get_info('beg');
  $pkg->set_top('OUT')->delete_object(defined($tim) ? time - $tim : undef);
  return;
}

# Define the parse methods
sub _get_data
{ _parse_output(['>', 1, 'D'], @_);
  return;
}

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

  $spc->[$SPC_VAL] = $slf->parse_list($str);
  return;
}

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

  die get_string('NO_NAME') unless $$str =~ s/^([A-Za-z]\w*)\s*//;
  $spc->[$SPC_REF] = $1;
  return;
}

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

  if ($$str =~ s/^\|\s*//)
  { _parse_output('P', @_);
  }
  else
  { my ($cfm, $flg, $mod);

    if ($$str =~ s/^(\[(\d)\])?(=)?(>+)\s*//)
    { $cfm = $2 if $1;
      $flg = defined($3);
      $mod = $4;
    }
    else
    { $mod = '>';
    }
    _parse_output(
      [$mod, $flg, ($$str =~ s/^([BCDEFRS])\s*,\s*//i) ? $1 : 'C', $cfm],
      @_);
  }
  return;
}

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

  ($$str =~ s/^\[(\d)\]\s*//)
    ? _parse_output(['>', 0, 'C', $1], @_)
    : _parse_output(['>', 0, 'C'], @_);
  return;
}

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

  if ($$str =~ s/^([A-Za-z]\w+)\s*(#.*)?$//)
  { $spc->[$SPC_REF] = $1;
  }
  elsif (ref($rec = $slf->parse_value($str)))
  { $spc->[$SPC_REF] = $rec;
  }
  else
  { die get_string('NO_NAME');
  }
  $spc->[$SPC_VAL] = $val;
  return;
}

# Specify a new report, closing the current one
sub _exe_report
{ my ($slf, $spc) = @_;
  my ($cfm, $dyn, $ext, $flg, $mod, $nam, $obj, $typ);

  if (ref($spc->[$SPC_VAL]))
  { # Add a new report
    ($mod, $flg, $typ, $cfm) = @{$spc->[$SPC_VAL]};
    if (ref($nam = $spc->[$SPC_REF]))
    { $nam = $nam->eval_as_string;
      $ext = $1
        if $typ =~ m/^[BDEMSR]$/i
        && $nam =~
             s/(\.(box|csv|dat|gif|htm|jar|log|png|tmp|tr[cm]|txt|xml|zip))$//;
      $dyn = 1;
    }
    $obj = $slf->get_output->add_report($typ, $nam, $dyn, $ext, $flg, $cfm);
    $obj->set_info('eof', 1) if $mod eq '>>';
  }
  else
  { # Add a new pipe
    $nam = $nam->eval_as_string
      if ref($nam = $spc->[$SPC_REF]) && !$nam->is_code(1);
    $obj = $slf->get_output->add_pipe($nam);
  }

  # Indicate the successful completion
  return $CONT;
}

# Resume the output to a report
sub _exe_resume
{ my ($slf, $spc) = @_;
  my ($cur, $out);

  # Close the current report file and suppress any prefix block
  $out = $slf->get_output;
  _end_current($out, delete($out->{'cur'})) if exists($out->{'cur'});

  # Restore the report file
  $out->{'cur'} = $cur
    if ($cur = delete($out->{'_opn'}->{$spc->[$SPC_REF]}));

  # Indicate the successful completion
  return $CONT;
}

# Share a report between modules
sub _exe_share
{ my ($slf, $spc) = @_;
  my ($gid, $lnk, $out);

  # Share the file
  $out = $slf->get_output;
  die get_string('NO_CURRENT') unless exists($out->{'cur'});
  ($gid, $lnk) = @{$spc->[$SPC_VAL]};
  $out->add_share($out->{'cur'}, $gid->eval_as_string, $lnk->eval_as_string)
    if ref($gid) && ref($lnk);

  # Indicate the successful completion
  return $CONT;
}

# Suspend the output to the current report
sub _exe_suspend
{ my ($slf, $spc) = @_;
  my ($out);

  $out = $slf->get_output;
  $out->{'_opn'}->{$spc->[$SPC_REF]} = delete($out->{'cur'})
    if exists($out->{'cur'});

  # Indicate the successful completion
  return $CONT;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Handle::Filter|RDA::Handle::Filter>,
L<RDA::Handle::Render|RDA::Handle::Render>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Content|RDA::Object::Content>,
L<RDA::Object::Pipe|RDA::Object::Pipe>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Object::Report|RDA::Object::Report>,
L<RDA::Object::Toc|RDA::Object::Toc>,
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