# CONVERT.pm: XML Conversion Command Library

package RDA::Request::CONVERT;

# $Id: CONVERT.pm,v 1.37 2015/09/24 18:02:54 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Request/CONVERT.pm,v 1.37 2015/09/24 18:02:54 RDA Exp $
#
# Change History
# 20150922  MSC  Fix the report modification check.

=head1 NAME

RDA::Request::CONVERT - XML Conversion Command Library

=head1 SYNOPSIS

 require RDA::Request::CONVERT;

=head1 DESCRIPTION

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

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use IO::File;
  use RDA::Text qw(get_string);
  use RDA::Error;
  use RDA::Handle::Data;
  use RDA::Handle::Vector;
  use RDA::Object;
  use RDA::Object::Content qw($RE_ABR $RE_DC);
  use RDA::Object::Message;
  use RDA::Object::Rda qw($CREATE $FIL_PERMS);
  use RDA::Object::View;
  use RDA::Driver::Archive;
  use RDA::Driver::Convert qw(cnv_value rpl_enc rpl_none rpl_var);
  use RDA::Driver::Sgml;
}

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

# Define the global private constants
my $CUR = RDA::Object::Rda->current_dir;
my $LGT = 128;
my $SCT = {q{*} => 'sdp_section'};
my $SIG =
  qr/^<!--\s*Module:(\S+)\s+Version:(\S+)\s+Report:(\S+)\s+OS:(\S+)\s+-->$/;
my $TBL = {q{*} => 'sdp_table'};
my $WRK = q{cnv.xml};

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

# Define the global private variables
my %tb_beg = (
  q{*} => q{<sdp_list},
  q{1} => q{<sdp_seq type='1'},
  q{A} => q{<sdp_seq type='A'},
  q{a} => q{<sdp_seq type='a'},
  q{I} => q{<sdp_seq type='I'},
  q{i} => q{<sdp_seq type='i'},
  );
my %tb_cmd = (
  'CONVERT.ADD_MOS'    => \&_do_mos,
  'CONVERT.CHECK'      => \&_do_check,
  'CONVERT.DEFINE'     => \&_do_define,
  'CONVERT.DISPLAY'    => \&_do_display,
  'CONVERT.GEN_BUNDLE' => \&_do_bundle,
  'CONVERT.GEN_XML'    => \&_do_xml,
  'CONVERT.LIST'       => \&_do_list,
  'CONVERT.XREF'       => \&_do_xref,
  );
my %tb_end = (
  q{*} => q{</sdp_list>},
  q{1} => q{</sdp_seq>},
  q{A} => q{</sdp_seq>},
  q{a} => q{</sdp_seq>},
  q{I} => q{</sdp_seq>},
  q{i} => q{</sdp_seq>},
  );

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

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

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

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

The XML conversion bundle object constructor.

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

=over 10

=item S<  B<'_abr'> > Abbreviation list (B)

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

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

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

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

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

=item S<  B<'_cnv'> > Reference to the conversion control object (L)

=item S<  B<'_col'> > Reference to the collector object (L)

=item S<  B<'_cpm'> > Code page mapping (L)

=item S<  B<'_ctl'> > Reference to the input/output control object (L)

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

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

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

=item S<  B<'_dsc'> > Bundle description (B)

=item S<  B<'_dsp'> > Reference to the display control object when verbose (L)

=item S<  B<'_end'> > End tag (L)

=item S<  B<'_flt'> > Current filter (L)

=item S<  B<'_gen'> > Generation function (L)

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

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

=item S<  B<'_nbc'> > Number of converted files (L)

=item S<  B<'_out'> > Output directory (L)

=item S<  B<'_pre'> > Last prefix (L)

=item S<  B<'_row'> > Table row hash (L)

=item S<  B<'_sel'> > Selection pattern (L)

=item S<  B<'_sub'> > Subdirectory definition hash (L)

=item S<  B<'_tbl'> > Table end tag (L)

=item S<  B<'_tid'> > Table identifier hash (L)

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

=item S<  B<'_txt'> > Text array (L)

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

=item S<  B<'_ver'> > Software version (L)

=back

Internal keys are prefixed by an underscore.

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

Alternate object constructor that can only be used to check the XML conversion
bundle definitions. It takes the data directory as an argument.

=cut

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

  if ($ref = ref($cls))
  { # Create the bundle definition object
    $slf = bless {
      _alt => {},
      _lib => $cls,
      _typ => 'B',
      }, $ref;
  }
  else
  { # Create the conversion control object
    $cfg = $agt->get_config;
    $col = $agt->get_collector;
    $slf = bless {
      _agt => $agt,
      _cas => $cfg->get_value('B_CASE', 1),
      _cfg => $cfg,
      _cnt => $agt->get_content,
      _cnv => RDA::Driver::Convert->new($agt, $cfg, $col),
      _col => $col,
      _def => {},
      _dsp => $agt->is_verbose,
      _lvl => $agt->get_level,
      _sub => {'C' => $col->get_sub('C') || $CUR,
               'M' => $col->get_sub('M') || $CUR,
              },
      _top => $cfg->get_group('D_RDA_COL'),
      _typ => 'L',
      _ver => $cfg->get_version,
      }, ref($cls) || $cls;
  }

  # Return the object reference
  return $slf;
}

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

This method deletes the library object.

=cut

sub delete_object
{ RDA::Object::dump_caller($_[0], 'Commands') if $RDA::Object::DELETE;
  undef %{$_[0]};
  undef $_[0];
  return;
}

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

This method dumps the library object.

=cut

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

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

This method executes the command specified in the message.

=cut

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

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

=head1 XML CONVERSION COMMANDS

=head2 CONVERT.ADD_MOS - Define a MOS Wiki directive

This command adds or modifies a C<MOS> Wiki directive. You cannot modify
internal entries. It supports the following attributes:

=over 8

=item B<  type>

Specifies its type, which contains uppercase letters only.

=item B<  text>

Specifies the associated text.

=item B<  url>

Specifies the associated URL.

=back

=cut

sub _do_mos
{ my ($slf, $req) = @_;
  my ($abr, $txt, $typ, $url);
  eval {
    die get_string('BAD_MOS_TYPE')
      unless defined($typ = $req->get_first('type')) && $typ =~ m{^[A-Z]+$};
    die get_string('BAD_MOS_TEXT', $typ)
      unless defined($txt = $req->get_first('text')) && $txt =~ m{\%s};
    die get_string('BAD_MOS_URL', $typ)
      unless defined($url = $req->get_first('url'))
          && $url =~ m{^https?://[^:/]+(:\d+)?/.*%s};
    die get_string('ERR_MOS_TYPE', $typ)
      if $slf->{'_cnv'}->add_mos($txt, $typ, $url);
  };
  return $req->reply($@, 'AddMos');
}

=head2 CONVERT.CHECK - Check command

This command checks a XML conversion bundle definition file. It supports the
following attribute:

=over 14

=item B<  definition>

Specifies the file to check.

=back

=cut

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

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

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

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

=head2 PROFILE.DEFINE - Define command

This command load the bundles definitions provided as data.

=cut

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

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

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

=head2 CONVERT.DISPLAY - Display command

This command displays the manual page of the specified XML conversion bundle. It
supports the following attributes:

=over 10

=item B<  groups>

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

=item B<  name>

Specifies the XML conversion bundle.

=back

=cut

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

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

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

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

=head2 CONVERT.GEN_BUNDLE - XML bundle command

This method transforms formatting specifications for all files included in the
specified conversion bundle in a XML file. It supports the following
attributes:

=over 11

=item B<  attach>

When true, attaches the conversion results to the response message and does
not store the results permanently unless specified by an C<output> attribute.

=item B<  bundle>

Specifies the bundle definition instead of a bundle name.

=item B<  groups>

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

=item B<  name>

Specifies the conversion bundle name.

=item B<  output>

Specifies the result file path (F<convert.xml> by default).

=item B<  set>

Specifies an optional archive result set identifier.

=item B<  verbose>

When specified, controls the conversion verbosity.

=back

=cut

sub _do_bundle  ## no critic (Complex)
{ my ($slf, $req) = @_;
  my ($arc, $col, $ctl, $dat, $dsp, $flg, $grp, $nam, $ofh, $tgt, @def);

  # Validate the attributes
  $col = $slf->{'_col'};
  if (defined($nam = $req->get_first('set'))
    && defined($ctl = $slf->{'_agt'}->get_registry('WEB.ARC'))
    && defined($ctl = $ctl->get_archive($nam)))
  { $arc = 1;
    $slf->{'_ctl'} = $ctl;
    $slf->{'_dir'} = $CUR;
  }
  else
  { $arc = 0;
    $slf->{'_ctl'} = $ctl = $slf;
    $slf->{'_dir'} = $col->get_data;
  }
  if (@def = $req->get_value('bundle'))
  { unshift(@def, '0.[Data]');
    $nam = $req->get_first('name',q{});
  }
  elsif (!defined($nam = $req->get_first('name')))
  { return $req->error('NoName')
  }
  $dat = $req->get_first('attach');
  $dsp = _is_verbose($slf, $req->get_first('verbose'));

  # Produce the result file
  $ofh = IO::File->new;
  $slf->{'_nbc'} = 0;
  $slf->{'_pre'} = q{};
  eval {
    my ($def, $hdr, $ifh, $pat, $pre, $src, $sub, %tbl);

    # Get the bundle definition
    if (@def)
    { $def = $slf->parse(RDA::Handle::Vector->new([@def]), 'RDA',
        'ERR_DEFINE', 'bundle')->{'Data'};
    }
    else
    { $grp = $req->get_value('groups');
      $def = $slf->get_bundle($grp, $nam);
    }
    die get_string('NO_BUNDLE', $nam) unless ref($def);
    $slf->{'_flt'} = $def;

    # Get the context information
    $src = $col->get_oid;
    $slf->{'_cnv'}->set_trace($col->get_trace('CONVERT'));
    $slf->{'_gen'} = \&_gen_bundle;

    # Open the result file
    $dsp->dsp_line(get_string('V_Bundle')) if $dsp;
    if (defined($tgt = RDA::Object::Rda->is_path($req->get_first('output'))))
    { $tgt =~ s/(\.xml)?$/.xml/i;
      $tgt = RDA::Object::Rda->cat_file($col->get_data, $1, $tgt)
        if $tgt =~ s/^\[(collect|extern|mrc)\]//;
    }
    elsif ($dat)
    { $col->clean_work($WRK);
      $tgt = $col->get_work($WRK, 1);
    }
    else
    { $tgt = 'convert.xml';
    }
    $ofh->open($tgt, $CREATE, $FIL_PERMS)
      or die get_string('ERR_CREATE', $tgt, $!);
    binmode($ofh);
    print {$ofh} "<?xml version='1.0' encoding='utf-8'?>\n<".join(q{ },
      'sdp_bundle', "type='$nam'",
       map {substr($_, 4).q{='}.$req->get_first($_).q{'}}
         $req->grep('^set_\w+')).">\n";
    $flg = 1;

    # Filter the reports
    if (exists($def->{'_abr'}))
    { $pat = join(q{|}, keys(%{$def->{'_abr'}}));
      $slf->{'_sel'} = qr/^($pat)/i;
    }
    else
    { $slf->{'_sel'} = qr/^([A-Z][A-Z\d]*_[A-Z][A-Z\d]*)_/i;
    }
    foreach my $fil (_get_reports($slf, $slf->{'_dir'}, \&_sel_report))
    { push(@{$tbl{uc("$1 $2 ")}}, $fil)
        if $fil =~ m/^([^_]+)_([^_]+)_/;
    }

    # Convert files
    foreach my $key (sort keys(%tbl))
    { $pre = $key;
      $pre =~ s/\s/_/g;
      $slf->{'_cur'} = $pre;
      foreach my $fil (sort @{$tbl{$key}})
      { defined($ifh = $ctl->find_report('M', $fil)) or
        defined($ifh = $ctl->find_report('C', $fil)) or
        defined($ifh = $ctl->find_handle($fil)) or
        die get_string($arc ? 'ERR_EXTRACT' : 'ERR_OPEN', $fil, $!);
        binmode($ifh);
        $slf->_gen_xml($ofh, $ifh, $dsp, {file  => $fil, os => $^O});
        $ifh->close;
      }
    }
    $dsp->dsp_line(get_string('VI_Nothing')) if $dsp && !$slf->{'_nbc'};
    };

  # Close the result file
  if ($flg)
  { if (length($slf->{'_pre'}))
    { foreach my $tag (reverse split(/_/, $slf->{'_pre'}))
      { print {$ofh} "</$tag>\n"
      }
    }
    print {$ofh} "</sdp_bundle>\n";
  }
  $ofh->close;

  # Indicate the completion status
  return
    $req->add_error($@)->has_errors ?
      $req->error('Bundle') :
    $dat ?
      $req->new('OK.Bundle', count => $slf->{'_nbc'})->add_file($tgt) :
    $req->new('OK.Bundle', count => $slf->{'_nbc'});
}

=head2 CONVERT.GEN_XML - XML generation command

This method transforms formatting specifications in a XML file. You can
specify the reports by their names or by their file names.

It supports the following attributes:

=over 13

=item B<  attach>

When true, attaches the last conversion to the response message and does not
store the conversion results permanently.

=item B<  directory>

Specifies the report directory (the current directory by default).

=item B<  files>

Lists the files to convert in XML.

=item B<  output>

Specifies the output directory (the current directory by default).

=item B<  verbose>

When specified, controls the conversion verbosity.

=back

or the following attributes:

=over 11

=item B<  attach>

When true, attaches the last conversion to the response message.

=item B<  force>

When true, regenerates all XML files.

=item B<  output>

Specifies the output directory (the current directory by default).

=item B<  reports>

Lists the reports to convert in XML.

=item B<  set>

Specifies an optional archive result set identifier.

=item B<  type>

Specifies an optional report type.

=item B<  verbose>

When specified, controls the conversion verbosity.

=back

=cut

sub _do_xml  ## no critic (Complex)
{ my ($slf, $req) = @_;
  my ($arc, $col, $ctl, $dat, $dir, $dsp, $dst, $fil, $hdr, $ifh, $nam, $ofh,
      $out, $rpt, $sub, @inf, @tbl);

  $col = $slf->{'_col'};
  $dsp = _is_verbose($slf, $req->get_first('verbose'));
  $ifh = IO::File->new;
  $ofh = IO::File->new;
  $slf->{'_nbc'} = 0;
  $slf->{'_gen'} = \&_gen_single;
  if ($dat = $req->get_first('attach'))
  { $col->clean_work($WRK);
    $fil = $col->get_work($WRK, 1);
  }
  eval {
    $dsp->dsp_line(get_string('V_Reports')) if $dsp;
    if (@tbl = $req->get_value('files'))
    { $slf->{'_ctl'} = $ctl = $slf;
      $slf->{'_dir'} = $dir =
        RDA::Object::Rda->is_path($req->get_first('directory')) ||
        $CUR;
      $slf->{'_out'} = $out =
        RDA::Object::Rda->is_path($req->get_first(['output','directory'])) ||
        $CUR;
      $rpt = [];
      @inf = (os => $^O);
      $slf->{'_cnv'}->set_trace($slf->{'_col'}->get_trace('CONVERT'));
      foreach my $src (@tbl)
      { # Determine the output file name
        next unless defined($src = RDA::Object::Rda->is_path($src));
        $dst = $slf->{'_cas'} ? $src : lc($src);
        $dst =~ s/\.txt$/.xml/i;

        # Generate the XML file
        $ifh->open(q{<}.(RDA::Object::Rda->is_absolute($src)
          ? $src
          : RDA::Object::Rda->cat_file($dir, $src)))
          or die get_string('ERR_OPEN', $src, $!);
        $fil = RDA::Object::Rda->is_absolute($dst)
          ? $dst
          : RDA::Object::Rda->cat_file($out, $dst)
          unless $dat;
        $ofh->open($fil, $CREATE, $FIL_PERMS)
          or die get_string('ERR_CREATE', $dst, $!);
        binmode($ifh);
        binmode($ofh);
        $slf->_gen_xml($ofh, $ifh, $dsp, {file => $src, @inf});
        $ifh->close;
        $ofh->close;
        push(@{$rpt}, $fil);
      }
    }
    else
    { # Get the request context information
      if (defined($nam = $req->get_first('set'))
        && defined($ctl = $slf->{'_agt'}->get_registry('WEB.ARC'))
        && defined($ctl = $ctl->get_archive($nam)))
      { $arc = 1;
        $slf->{'_ctl'} = $ctl;
        $slf->{'_dir'} = $dir = $CUR;
        $slf->{'_out'} = $out =
          RDA::Object::Rda->is_path($req->get_first('output')) || $dir;
      }
      else
      { $arc = 0;
        $slf->{'_ctl'} = $ctl = $slf;
        $slf->{'_dir'} = $dir =
        $slf->{'_out'} = $out = $col->get_data;
      }
      $rpt = [];
      @inf = (os => $^O);
      $slf->{'_cnv'}->set_trace($col->get_trace('CONVERT'));

      # Get the report list
      if (@tbl = $req->get_value('reports'))
      { @tbl = map {RDA::Object::Rda->is_path(m/\.txt$/i ? $_ : "$_.txt")} @tbl;
        @tbl = map {RDA::Object::Rda->cat_file($sub, $_)} @tbl
          if defined($sub = $req->get_first('type'))
          && defined($sub = $slf->{'_col'}->get_sub($sub));
      }
      else
      { @tbl = _get_reports($slf, $dir,
          $req->get_first('force') ? \&_all_report :
          $arc                     ? \&_chk_archive :
                                     \&_chk_report);
      }

      # Convert the reports
      foreach my $src (@tbl)
      { # Determine the output file name
        $dst = $slf->{'_cas'} ? $src : lc($src);
        $dst =~ s/\.txt$/.xml/i;

        # Generate the XML file
        if (defined($ifh = $ctl->find_report('M', $src)))
        { $sub = $slf->{'_sub'}->{'M'};
          $fil = $arc
            ? RDA::Object::Rda->cat_file($out, $dst)
            : RDA::Object::Rda->cat_file($out, $sub, $dst)
            unless $dat;
          $ofh->open($fil, $CREATE, $FIL_PERMS)
            or die get_string('ERR_CREATE', $fil, $!);
        }
        elsif (defined($ifh = $ctl->find_report('C', $src)))
        { $sub = $slf->{'_sub'}->{'C'};
          $fil = $arc
            ? RDA::Object::Rda->cat_file($out, $dst)
            : RDA::Object::Rda->cat_file($out, $sub, $dst)
            unless $dat;
          $ofh->open($fil, $CREATE, $FIL_PERMS)
            or die get_string('ERR_CREATE', $fil, $!);
        }
        elsif (defined($ifh = $ctl->find_handle($src)))
        { $sub = RDA::Object::Rda->dirname($src);
          $src = RDA::Object::Rda->basename($src);
          $fil = $arc
            ? RDA::Object::Rda->cat_file($out, RDA::Object::Rda->basename($dst))
            : RDA::Object::Rda->cat_file($out, $dst)
            unless $dat;
          $ofh->open($fil, $CREATE, $FIL_PERMS)
            or die get_string('ERR_CREATE', $fil, $!);
        }
        else
        { # Text:ERR_EXTRACT  Text:ERR_OPEN
          die get_string($arc ? 'ERR_EXTRACT' : 'ERR_OPEN', $src, $!);
        }
        binmode($ifh);
        binmode($ofh);
        $slf->_gen_xml($ofh, $ifh, $dsp, {file => $src, sub => $sub, @inf});
        $ifh->close;
        $ofh->close;
        push(@{$rpt}, $fil);
      }
    }
    $dsp->dsp_line(get_string('VI_Nothing')) if $dsp && !$slf->{'_nbc'};
    };

  # Indicate the completion status
  return
    $req->add_error($@)->has_errors
      ? $req->error('Xml') :
    $dat
      ? $req->new('OK.Xml')->add_file($fil) :
    $req->new('OK.Xml', reports => $rpt);
}

=head2 CONVERT.LIST - List command

This command lists all corresponding XML conversion bundles. It supports the
following attributes:

=over 15

=item B<  groups>

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

=item B<  description>

When true, includes the description as data.

=back

=cut

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

  # Get the list of XML conversion bundles
  eval {
    # Select the XML conversion bundle definition files
    $grp = $req->get_value('groups');
    $def = $slf->get_bundles($grp);
    @tbl = sort keys(%{$def});

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

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

=head2 CONVERT.XREF - Cross-reference command

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

=over 14

=item B<  all>

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

=item B<  definition>

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

=item B<  groups>

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

=back

=cut

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

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

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

=head1 XML CONVERSION CONTROL METHODS

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

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

=cut

sub get_bundle
{ my @tbl = _get_bundle(@_);

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

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

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

  # Validate the XML conversion bundle name
  die get_string('BAD_BUNDLE', $bnd) unless $bnd =~ m/^(\w+\.)*(\w+)$/;
  $nam = $2;

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

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

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

This method returns a reference to a hash containing the XML conversion bundles
and their definition.

=cut

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

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

  # Select the relevant bundle names
  $def = {};
  foreach my $grp (keys(%{$sel}))
  { _filter($def, $sel->{$grp}, $grp) unless $grp eq 'RDA' || $grp eq q{};
  }
  foreach my $grp ('RDA', '_DAT_', '_ENV_', q{})
  { _filter($def, $sel->{$grp}, $grp, 1) if exists($sel->{$grp});
  }

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

  # Return the bundle list
  return $def;
}

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

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

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

This method loads the XML conversion bundle definitions from the specified file
and returns a definition hash.

=cut

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

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

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

This method parses the XML conversion bundle definitions from the specified
input file handle and returns a definition hash.

=cut

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

  # Load the conversion bundle definition
  $cas = $slf->{'_cas'};
  $cnt = $slf->{'_cnt'};
  $def = {Default => $slf->new};
  $err = RDA::Error->new;
  $pos = 0;
  $lin = q{};
  while (<$ifh>)
  { # Trim leading spaces
    s/^\s+//;
    s/[\r\n]+$//;
    $lin .= $_;

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

    # Parse the line
    eval {
      $pos = $1 if $lin =~ s/^(\d+)\.*\s*//;
      if ($cur && $lin =~ s/^\*\s*=\s*//)
      { my (@pat, @tbl);

        ($key, @pat) = split(/\//, $lin);
        unless ($key =~ m/^[A-Z][A-Z\d]*_[A-Z][A-Z\d]*_$/)
        { $key = $cnt->get_module('DC', $grp, $key);
          die get_string('BAD_ABBR', $key) unless $key =~ $RE_DC;
          $key = $2.q{_}.uc($3).q{_};
        }

        # Get the filter list
        $cur->{'_abr'}->{$key} = []
          unless exists($cur->{'_abr'}) && exists($cur->{'_abr'}->{$key});
        $val = $cur->{'_abr'}->{$key};

        # Load the filter item
        if (@pat)
        { foreach my $pat (@pat)
          { next unless $pat;
            die get_string('BAD_PATTERN', $pat) unless $pat =~ s/^([\-\+])//;
            push(@tbl, [$1, RDA::Object::View->is_match($pat)]);
          }
          push(@{$val}, [@tbl]);
        }
        else
        { push(@{$val}, q{});
        }
      }
      elsif ($cur && $lin =~ s/^\?(\w*)\s*=\s*//)
      { $key = length($1) ? "_dsc_$1" : '_dsc';
        $val = _decode(\$lin, get_string('BAD_DESC'));
        $cur->{$key} = $val;
        $cur->{lc($key)} = $val unless $cas;
      }
      elsif ($lin =~ s/^\[([\w\|]+)\]$//)
      { $cur = $slf->new;
        foreach my $key (split(/\|/, $1))
        { $def->{$key} = $cur;
          unless ($cas)
          { $str = lc($key);
            $cur->{'_alt'}->{$str} = $key;
            $def->{$str} = $cur;
          }
        }
      }
      elsif ($lin !~ m/^(?:#.*)?$/)
      { die get_string('BAD_SPEC');
      }
    };

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

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

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

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

  # Return the XML conversion bundle definitions
  return $def;
}

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

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

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

This method selects the relevant bundle definitions.

=cut

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

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

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

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

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

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

  # Return the selected definitions
  return $sel;
}

=head2 S<$h-E<gt>xref($select)>

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

=cut

sub xref
{ my ($slf, $sel, $flg, $nam) = @_;
  my ($buf, $cfg, $cnt, $def, $mod, $typ, $uid, $xrf, @key);

  # Get the module list
  $cfg = $slf->{'_cfg'};
  $cnt = $slf->{'_cnt'};
  $slf = $slf->{'_lib'} if exists($slf->{'_lib'});
  $xrf = {
    typ => {q{(*)} => get_string('XrefAllReports'),
            q{(f)} => get_string('XrefFiltered'),
           }
    };
  foreach my $mod ($cnt->get_modules('DC'))
  { $xrf->{'mod'}->{$mod} = [];
  }

  # Analyze the bundles
  foreach my $grp (sort keys(%{$sel}))
  { foreach my $nam (keys(%{$sel->{$grp}}))
    { $def = $sel->{$grp}->{$nam};
      next unless $flg || $def->get_title($nam);
      $uid = $grp.q{.}.$nam;
      if (exists($def->{'_abr'}))
      { $xrf->{'def'}->{$uid} = [];
        foreach my $pre (keys(%{$def->{'_abr'}}))
        { $typ = 'f';
          foreach my $cnd (@{$def->{'_abr'}->{$pre}})
          { $typ = q{*} unless ref($cnd);
          }
          $mod = $cnt->get_module('DC', [], ($pre =~ $RE_ABR) ? "$1.$2" : $pre);
          if (exists($xrf->{'mod'}->{$mod}))
          { push(@{$xrf->{'mod'}->{$mod}}, "$uid($typ)");
            push(@{$xrf->{'def'}->{$uid}}, "$mod($typ)");
          }
          else
          { push(@{$xrf->{'oth'}->{$pre}}, "$uid($typ)");
            push(@{$xrf->{'def'}->{$uid}}, "$pre($typ)");
          }
          $xrf->{'use'}->{qq{($typ)}} = 1;
        }
      }
      else
      { $xrf->{'def'}->{$uid} = ['<all>'];
        push(@{$xrf->{'mod'}->{'<all>'}}, "$uid(*)");
        $xrf->{'use'}->{q{(*)}} = 1;
      }
    }
  }
  if ($def = delete($xrf->{'mod'}->{'<all>'}))
  { foreach my $pre (keys(%{$xrf->{'mod'}}))
    { push(@{$xrf->{'mod'}->{$pre}}, @{$def});
    }
  }

  # Produce the cross-reference
  # Text:XrefDefined Text:XrefReferenced Text:XrefOther
  $buf = _dsp_name($nam || get_string('Xref')).$RPT_NXT;
  $buf .= _xref($xrf->{'def'}, $xrf->{'def'}, 'XrefDefined',    'bundle');
  $buf .= _xref($xrf->{'mod'}, $xrf->{'mod'}, 'XrefReferenced', 'collect');
  $buf .= _xref($xrf->{'oth'}, $xrf->{'oth'}, 'XrefOther');
  if (@key = keys(%{$xrf->{'use'}}))
  { $buf .= _dsp_table(get_string('XrefNotes'));
    foreach my $nam (sort @key)
    { $buf .= _dsp_row(qq{``$nam``}, $xrf->{'typ'}->{$nam});
    }
    $buf .= $RPT_EOT;
  }
  return $buf;
}

# Display a result set
sub _xref
{ my ($key, $val, $ttl, $typ) = @_;
  my ($buf, @key);

  return q{} unless ref($key) && (@key = grep {@{$val->{$_}}} keys(%{$key}));

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

=head1 BUNDLE DEFINITION METHODS

=head2 S<$h-E<gt>display($name)>

This method displays the manual page of the specified bundle entry.

=cut

sub display
{ my ($slf, $nam, $flg) = @_;
  my ($buf, $cnt, $mod, $tbl, $typ, %dsc);

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

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

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

  # Display the modules and their descriptions
  if (exists($slf->{'_abr'}))
  { # Classify the modules
    foreach my $pre (keys(%{$slf->{'_abr'}}))
    { $typ = 'Some';
      foreach my $cnd (@{$slf->{'_abr'}->{$pre}})
      { $typ = 'All' unless ref($cnd);
      }
      $mod = $cnt->get_module('DC', [], ($pre =~ $RE_ABR) ? qq{$1.$2} : $pre);
      if ($mod =~ $RE_DC)
      { $dsc{qq{DspMod$typ}}->{$mod} = _dsp_row(
          q{!!collect:}.$mod.q{!}.$mod.q{!!}, $cnt->get_desc('DC', $mod,
          q{\040}));  ## no critic (Interpolation)
      }
      else
      { $dsc{qq{DspTool$typ}}->{$pre} = _dsp_row(qq{``$pre``},
          q{\040});   ## no critic (Interpolation)
      }
    }

    # Display the module list
    $buf .= _dsp_title(get_string('TtlModules'));
    foreach my $typ (sort keys(%dsc))
    { $buf .= _dsp_table($RPT_TXT, get_string($typ, $nam));
        # Text:DspModAll Text:DspModSome Text:DspToolAll Text:DspToolSome
      foreach my $abr (sort keys(%{$dsc{$typ}}))
      { $buf .= $dsc{$typ}->{$abr};
      }
      $buf .= $RPT_EOT;
    }
  }

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

  # Return the result
  return $buf;
}

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

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

=cut

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

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

# --- Report selection routines -----------------------------------------------

# Retrieve all reports that must be converted
sub _get_reports
{ my ($slf, $top, $fct) = @_;
  my ($cat, $pat, %tbl);

  # Scan the directory for report files
  $pat = qr/^[A-Za-z]\w*(-\d+)?\.txt$/i;
  foreach my $nam (keys(%{$cat = $slf->{'_ctl'}->get_reports($pat)}))
  { $tbl{$nam} = 0 if $nam =~ $pat && &$fct($slf, $nam, $cat->{$nam});
  }

  # Return the files found
  return (sort keys(%tbl));
}

# Get all reports
sub _all_report
{ return 1;
}

# Compare the modification times for an archived report
sub _chk_archive
{ my ($slf, $nam, $fil) = @_;
  my ($dmt, $pth, $smt);

  $smt = $slf->{'_ctl'}->get_time($fil);
  $pth = RDA::Object::Rda->cat_file($slf->{'_out'}, $nam);
  $pth =~ s/\.txt$/.xml/i;
  $dmt = (stat($fil))[9];
  return ($smt && $dmt && $smt <= $dmt) ? 0 : 1;
}

# Compare the modification times
sub _chk_report
{ my ($slf, $nam, $fil) = @_;
  my ($dmt, $pth, $smt);

  $smt = (stat($fil))[9];
  $fil =~ s/\.txt$/.xml/i;
  $dmt = (stat($fil))[9];
  return ($smt && $dmt && $smt <= $dmt) ? 0 : 1;
}

# Select the reports
sub _sel_report
{ my ($slf, $nam) = @_;

  return $nam =~ $slf->{'_sel'};
}

# --- Conversion routines -----------------------------------------------------

# Check if the file belongs to the bundle
sub _chk_bundle
{ my ($flt, $pre, $rpt) = @_;

  return 0 unless exists($flt->{'_abr'});
  if (exists($flt->{'_abr'}->{$pre}))
  { COND: foreach my $cnd (@{$flt->{'_abr'}->{$pre}})
    { if (ref($cnd))
      { foreach my $pat (@{$cnd})
        { next COND unless $pat->[0] eq q{-} xor $rpt =~ $pat->[1];
        }
      }
      return 0;
    }
  }
  return 1;
}

# Check cell content
sub _chk_cell
{ my ($str) = @_;

  return $str =~
    m/(\%END(COL|JSM|KMS|LIST|SEQ|TBL)\%|%MOS[^%]+%|\[\[.*\]\]|\{\{.*\}\})/;
}

# Generate report tags for a conversion bundle
sub _gen_bundle
{ my ($slf, $dst, $dsp, $ctx) = @_;

  if (ref($ctx))
  { my ($pre, $rpt);

    # Check if conditions are fulfilled
    if (exists($ctx->{'report'}))
    { $rpt = $ctx->{'report'};
    }
    else
    { $rpt = $ctx->{'file'};
      $rpt =~ s/^[^_]+_[^_]+_//;
      $rpt =~ s/\.txt$//i;
    }
    return 1 if _chk_bundle($slf->{'_flt'}, $slf->{'_cur'}, $rpt);
    $dsp->dsp_line(get_string('VI_Report', $ctx->{'file'})) if $dsp;
    ++$slf->{'_nbc'};

    # Detect module transition
    if ($slf->{'_cur'} ne $slf->{'_pre'})
    { my ($dsc, @cur, @new, @prv);

      # Determine changes
      @prv = split(/_/, $slf->{'_pre'});
      @new = split(/_/, $slf->{'_pre'} = $slf->{'_cur'});
      while (defined($new[0]) && defined($prv[0]) && $new[0] eq $prv[0])
      { push(@cur, shift(@new));
        shift(@prv);
      }

      # Close old groups
      foreach my $tag (reverse @prv)
      { print {$dst} "</$tag>\n";
      }

      # Open new groups
      foreach my $tag (@new)
      { push(@cur, $tag);
        if (exists($slf->{'_col'}) && defined($dsc =
          $slf->{'_col'}->get_first(join(q{.}, 'STATUS', @cur, 'T_DSC'))))
        { print {$dst} qq{<$tag description='$dsc'>\n};
        }
        else
        { print {$dst} qq{<$tag>\n};
        }
      }
    }

    # Indicate the new report
    $rpt = qq{sdp_report_$rpt};
    $rpt =~ s/[_\W]+/_/g;
    print {$dst} q{<}.join(q{ }, $slf->{'_end'} = substr($rpt, 0, $LGT),
        map {$_.q{='}.$ctx->{$_}.q{'}} sort keys(%{$ctx})).qq{>\n};
  }
  else
  { print {$dst} q{</}.$slf->{'_end'}.qq{>\n};
  }
  return 0;
}

# Generate report tags for a single file
sub _gen_single
{ my ($slf, $dst, $dsp, $ctx) = @_;
  my ($ifh, $set);

  if (ref($ctx))
  { $dsp->dsp_line(get_string('VI_Report', $ctx->{'file'})) if $dsp;
    ++$slf->{'_nbc'};

    # Determine the page character set
    if (exists($ctx->{'codepage'}))
    { $set = $ctx->{'codepage'};
      unless (exists($slf->{'_cpm'}))
      { $ifh = IO::File->new;
        if ($ifh->open(q{<}.$slf->{'_cfg'}->get_file('D_RDA_DAT', 'cp.txt')))
        { while(<$ifh>)
          { $slf->{'_cpm'}->{$1} = $2 if m/^(\d+)\s+(\S+)/;
          }
          $ifh->close;
        }
      }
      $set = exists($slf->{'_cpm'}->{$set})
        ? $slf->{'_cpm'}->{$set}
        : 'utf-8';
    }
    else
    { $set = exists($ctx->{'charset'})
        ? $ctx->{'charset'}
        : 'utf-8';
    }

    # Initialize the report
    print {$dst} qq{<?xml version='1.0' encoding='$set'?>\n<sdp_report }
      .join(q{ }, map {$_.q{='}.$ctx->{$_}.q{'}} sort keys(%{$ctx})).qq{>\n};
  }
  else
  { print {$dst} qq{</sdp_report>\n};
  }
  return 0;
}

# Generate the XML file
sub _gen_xml  ## no critic (Complex)
{ my ($slf, $dst, $src, $dsp, $ctx) = @_;
  my ($blk, $cel, $cnv, $eob, $hdr, $ifh, $lin, $lst, $lvl, $max, $rec, $sum,
      $tbl, $tid, $txt, @lvl, @sct);

  # Identify the report and load the conversion plug-ins
  while (defined($lin = _get_line($src)))
  { if ($lin =~ $SIG)
    { ($ctx->{'module'}, $ctx->{'version'}, $ctx->{'report'}, $ctx->{'os'})
        = ($1, $2, $3, $4);
    }
    elsif ($lin =~ m/^<\?\s*(\w+):(\S*)\s*\?>$/)
    { $ctx->{lc($1)} = $2;
    }
    elsif ($lin !~ m/^<!--.*?-->$/)
    { last;
    }
  }
  ($cnv = $slf->{'_cnv'})->init($ctx, $src);

  # Treat the input file
  $blk = $hdr = $lvl = $rec = $tbl = $tid = 0;
  $cel = $TBL;
  $eob = q{};
  $ifh = IO::File->new;
  $slf->{'_row'} = {};
  $slf->{'_tid'} = {};
  $slf->{'_txt'} = [];
  return if &{$slf->{'_gen'}}($slf, $dst, $dsp, $ctx);
  for (; defined($lin) ; $lin = _get_line($src))  ## no critic (Loop)
  { # Detect a context change
    if ($lvl)
    { # Close an open list
      unless ($lin =~ m/^( {3,})[\*1AaIi]/ && (length($1) % 3) == 0)
      { my ($typ);
        while ($typ = pop(@lvl))
        { print {$dst} $tb_end{$typ}.qq{\n};
        }
        $lvl = 0;
      }
    }
    elsif ($rec)
    { # Close an open table
      unless ($lin =~ m/^\|[^\|].*\|$/)
      { if (exists($cel->{q{>}}))
        { print {$dst} $txt if length($txt = &{$cel->{q{>}}}($cnv))
        }
        else
        { print {$dst} q{</}.$slf->{'_tbl'}.qq{>\n};
        }
        $rec = 0;
        $tid = $max;
      }
    }

    # Treat a line
    if ($blk)
    { if ($lin eq $eob)
      { print {$dst} qq{]]></sdp_block>\n} if defined(&$blk($cnv, q{}));
        $blk = 0;
      }
      elsif (defined($lin = &$blk($cnv, $lin)))
      { print {$dst} qq{$lin\n};
      }
    }
    elsif ($lin =~ m/^\|<([^>]*)>\|$/)
    { _prt_text($slf, $dst);
      unless ($rec)
      { ++$tbl;
        $sum = cnv_value($cnv->clr_var($1));
        $cel = $TBL unless ref($cel = $cnv->search('T', $sum)) eq 'HASH';
        if (exists($cel->{q{<}}))
        { print {$dst} $txt if length($txt = &{$cel->{q{<}}}($cnv, $sum))
        }
        else
        { $slf->{'_tbl'} = exists($cel->{q{*}}) ? $cel->{q{*}} : q{sdp_table};
          print {$dst} q{<}.$slf->{'_tbl'}.qq{ summary='$sum'>\n};
        }
        $sum = undef;
        $lst = $max = $tid + 1;
        ++$rec;
      }
    }
    elsif ($lin =~ s/^\|([^\|].*\|)$/$1/)
    { my ($col, $cur, $dir, $hid, $new, $row, $typ, @tbl, %tbl);
      _prt_text($slf, $dst);
      unless ($rec)
      { ++$tbl;
        $sum = qq{Table $tbl} unless defined($sum);
        $cel = $TBL unless ref($cel = $cnv->search('T', $sum)) eq 'HASH';
        if (exists($cel->{q{<}}))
        { print {$dst} $txt if length($txt = &{$cel->{q{<}}}($cnv, $sum))
        }
        else
        { $slf->{'_tbl'} = exists($cel->{q{*}}) ? $cel->{q{*}} : q{sdp_table};
          print {$dst} q{<}.$slf->{'_tbl'}.qq{ summary='$sum'>\n};
        }
        $sum = undef;
        $lst = $max = $tid + 1;
      }
      $new = $tid + 1;
      if (exists($cel->{q{-}}))
      { print {$dst} $txt if length($txt = &{$cel->{q{-}}}($cnv, $lin));
      }
      else
      { $col = $dir = $typ = 0;
        while ($lin =~ s/([^\|]+)(\|{1,})//)
        { $new = 0 if ($cur = length($2)) > 1;
          $txt = $1;
          $row = ($txt =~ s/^%(?:BOTTOM|MIDDLE|TOP|ROWS):[1-9]\d*%//) ? 1 : 0;
          $txt =~ s/^\s+//;
          $txt =~ s/^%NOWRAP%\s*//;
          $txt =~ s/\s+$//;
          if ($txt =~ s/^\*(.+)\*$/$1/)
          { ++$tid;
            $max = $tid if $tid > $max;
            $slf->{'_row'}->{$tid} = q{};
            $slf->{'_tid'}->{$tid} = $txt
              if length($txt = $cnv->cnv_attr($txt));
            $dir = 1;
          }
          else
          { $hid = ($dir) ? $tid : $lst + $col;
            $max = $tid = $hid if $hid > $max;
            unless (exists($slf->{'_tid'}->{$hid}))
            { $slf->{'_row'}->{$hid} = q{};
              $slf->{'_tid'}->{$hid} = qq{attr_$hid};
            }
            $txt = $slf->{'_row'}->{$hid} if $txt =~ m/^\^{3,}$/;
            if (exists($cel->{$slf->{'_tid'}->{$hid}}))
            { $typ = -1;
              $tbl{$hid} = &{$cel->{$slf->{'_tid'}->{$hid}}}($cnv, $txt);
            }
            elsif (exists($cel->{q{=}}))
            { $typ = 1;
              $tbl{$hid} = $cnv->rpl_var($txt);
            }
            else
            { $typ = _chk_cell($txt) ? -1 : 1
                unless $typ < 0;  ## no critic (Unless)
              $tbl{$hid} = $cnv->rpl_var($txt);
            }
            $slf->{'_row'}->{$hid} = $txt if $row;
            $dir = $new = 0;
          }
          $col += $cur;
        }
        $lst = $new if $new;
        if ($typ < 0)
        { print {$dst} qq{<sdp_cells>\n};
          foreach my $id (sort {$a <=> $b} keys(%tbl))
          { print {$dst} q{<sdp_cell id='}.$slf->{'_tid'}->{$id}.q{'>}
              .$tbl{$id}.qq{</sdp_cell>\n};
          }
          print {$dst} qq{</sdp_cells>\n};
        }
        elsif ($typ > 0)
        { print {$dst} join(q{ }, q{<sdp_row},
            map {$slf->{'_tid'}->{$_}.q{='}.cnv_value($tbl{$_}).q{'}}
            sort {$a <=> $b} keys(%tbl)).qq{/>\n};
        }
      }
      ++$rec;
    }
    elsif ($lin =~ m/^$/)  ## no critic (Fixed)
    { _prt_text($slf, $dst);
    }
    elsif ($lin =~ m/^-{3,}$/)
    { _prt_text($slf, $dst);
      print {$dst} q{<sdp_hr/>}, qq{\n};
    }
    elsif ($lin =~ m/^-{3}(\+{1,6})(!!)?\s*(.*)$/)
    { my ($cur, $sct, $toc);
      $cur = length($1);
      $toc = defined($2) ? 0 : 1;
      $sum = cnv_value($cnv->clr_var($3));
      _prt_text($slf, $dst);
      for (; $cur <= $hdr ; --$hdr)  ## no critic (Loop)
      { print {$dst} $txt if length($txt = $sct[$hdr]);
      }
      while (++$hdr < $cur)
      { $sct[$hdr] = qq{</sdp_section>\n};
        print {$dst} qq{<sdp_section level='$hdr'>\n};
      }
      $sct = $SCT unless ref($sct = $cnv->search('S', $sum)) eq 'HASH';
      if (exists($sct->{q{-}}))
      { if (length($txt = &{$sct->{q{-}}}($cnv, $sum, $cur, $toc)))
        { $sct = (exists($sct->{q{*}}) ? $sct : $SCT)->{q{*}};
          $sct[$hdr] = qq{</$sct>\n};
          print {$dst} $txt;
        }
        else
        { $sct[$hdr] = q{};
        }
      }
      else
      { $sct = (exists($sct->{q{*}}) ? $sct : $SCT)->{q{*}};
        $sct[$hdr] = qq{</$sct>\n};
        print {$dst} qq{<$sct level='$cur' title='$sum' toc='$toc'>\n}
      }
    }
    elsif ($lin =~ m/^-{3}(\#{1,6})\s*(.*)$/)
    { _prt_text($slf, $dst);
      print {$dst} q{<sdp_subtitle level='}.length($1).q{' text='}
        .cnv_value($cnv->clr_var($2)).qq{'/>\n};
    }
    elsif ($lin =~ m/^<verbatim(:(\w+))?>$/)
    { unless ($cnv->convert($dst, $src, defined($sum) ? $sum : q{-}, $2))
      { my $typ = $2 || q{verbatim};
        $blk = \&rpl_enc;
        $eob = q{</verbatim>};
        _prt_text($slf, $dst);
        print {$dst} qq{<sdp_block type='$typ'><![CDATA[};
      }
    }
    elsif ($lin eq q{<pre>})
    { $blk = \&rpl_none;
      $eob = q{</pre>};
      _prt_text($slf, $dst);
      print {$dst} q{<sdp_block type='pre'><![CDATA[};
    }
    elsif ($lin eq q{<code>})
    { $blk = \&rpl_var;
      $eob = q{</code>};
      _prt_text($slf, $dst);
      print {$dst} q{<sdp_block type='code'><![CDATA[};
    }
    elsif ($lin eq q{<comment>})
    { $blk = \&_skp_line;
      $eob = q{</comment>};
      _prt_text($slf, $dst);
    }
    elsif ($lin =~ m/^( {3,})([\*1AaIi])\s*(.*)$/ && (length($1) % 3) == 0)
    { my ($cur);
      $cur = int(length($1) / 3);
      _prt_text($slf, $dst);
      while ($lvl > $cur || ($lvl == $cur && $2 ne $lvl[-1]))
      { print {$dst} $tb_end{pop(@lvl)}.qq{\n};
        --$lvl;
      }
      while ($lvl < $cur)
      { print {$dst} $tb_beg{$2}.q{ level='}.++$lvl.qq{'>\n};
        push(@lvl, $2);
      }
      print {$dst} q{<sdp_item>}.$cnv->rpl_var($3).qq{</sdp_item>\n};
    }
    elsif ($lin =~ m/^#(\w+)(\s(-{3}(#{1,6})\s)?(.*))?$/)
    { _prt_text($slf, $dst);
      if ($3)
      { print {$dst} q{<sdp_subtitle level='}.length($4).q{' text='}
        .cnv_value($cnv->clr_var($5)).qq{'/>\n};
      }
      elsif ($4 && length($txt = $cnv->rpl_var($5)))
      { push(@{$slf->{'_txt'}}, $txt);
      }
    }
    elsif ($lin =~ m/^\%DATA\%$/)
    {
    }
    elsif ($lin =~ m/^\%TOC[\d\-]*\%$/)
    { _prt_text($slf, $dst);
    }
    elsif ($lin =~ m/^\%INCLUDE\{"([^"]+)"\}\%$/)
    { _prt_text($slf, $dst);
      if ($ifh->open(qq{<$1}))
      { while (<$ifh>)
        { print {$dst} $cnv->rpl_var($_);
        }
        $ifh->close;
      }
    }
    elsif ($lin =~ m/^\%PRE\{"([^"]+)"\}\%$/)
    { _prt_text($slf, $dst);
      if ($ifh->open(qq{<$1}))
      { print {$dst} q{<sdp_block type='pre'><![CDATA[};
        while (<$ifh>)
        { print {$dst} $cnv->rpl_none($_);
        }
        print {$dst} qq{]]></sdp_block>\n};
        $ifh->close;
      }
    }
    elsif ($lin =~ m/^\%VERBATIM\{"([^"]+)"\}\%$/)
    { _prt_text($slf, $dst);
      if ($ifh->open(qq{<$1}))
      { unless ($cnv->convert($dst, $ifh, defined($sum) ? $sum : q{-}))
        { print {$dst} q{<sdp_block type='verbatim'><![CDATA[};
          while (<$ifh>)
          { print {$dst} $cnv->rpl_enc($_);
          }
          print {$dst} qq{]]></sdp_block>\n};
        }
        $ifh->close;
      }
    }
    elsif ($lin =~ m/^<\?\s*(\w+):(\S*)\s*\?>$/)
    { $ctx->{lc($1)} = $2;
    }
    elsif ($lin !~ m/^<\?.*\?>$/)
    { push(@{$slf->{'_txt'}}, $txt) if length($txt = $cnv->rpl_var($lin));
    }
    $lin = q{};
  }

  # Terminate and close the XML file
  _prt_text($slf, $dst);
  if ($lvl) # Close an open list
  { my ($typ);
    while ($typ = pop(@lvl))
    { print {$dst} $tb_end{$typ}.qq{\n};
    }
  }
  elsif ($rec) # Close an open table
  { if (exists($cel->{q{>}}))
    { print {$dst} $txt if length($txt = &{$cel->{q{>}}}($cnv))
    }
    else
    { print {$dst} q{</}.$slf->{'_tbl'}.qq{>\n};
    }
  }
  elsif ($blk) # Close an open block
  { print {$dst} qq{]]></sdp_block>\n} if defined(&$blk($cnv, q{}));
  }
  print {$dst} $sct[$hdr--] while $hdr;
  return &{$slf->{'_gen'}}($slf, $dst, $dsp);
}

# Get an input line
sub _get_line
{ my ($ifh) = @_;
  my ($buf, $lin);

  return unless defined($buf = $ifh->getline);
  $buf =~ s/[\r\n]*$//;
  while ($buf =~ s/\\$//)
  { last unless defined($lin = $ifh->getline);
    $lin =~ s/[\r\n]*$//;
    $buf .= $lin unless $lin =~ m/^\000*$/;
  }
  $buf =~ s/\s+$//;
  return $buf;
}

# Print stored text
sub _prt_text
{ my ($slf, $dst) = @_;
  my ($str);

  if (@{$slf->{'_txt'}})
  { print {$dst} q{<sdp_para>}.join(q{ }, @{$slf->{'_txt'}}).qq{</sdp_para>\n};
    $slf->{'_txt'} = [];
  }
  return;
}

# Skip a line
sub _skp_line
{ return;
}

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

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

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

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

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

# Determine the verbosity
sub _is_verbose
{ my ($slf, $flg) = @_;

  return
    !defined($flg) ? $slf->{'_dsp'} :
    $flg           ? $slf->{'_agt'}->get_display:
                     undef;
}

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

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

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

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

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

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

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

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

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

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

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

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

=head1 DEFAULT INPUT/OUTPUT CONTROL INTERFACE

=head2 S<$h-E<gt>find_handle($nam)>

This method returns a file handle to the specified result.

=cut

sub find_handle
{ my ($slf, $nam) = @_;
  my ($ifh);

  $ifh = IO::File->new;
  return $ifh if $ifh->open(q{<}.
    RDA::Object::Rda->cat_file($slf->{'_dir'}, $nam));
  return;
}

=head2 S<$h-E<gt>find_report($typ,$rpt)>

This method returns a file handle to the specified report.

=cut

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

  $ifh = IO::File->new;
  return $ifh if $ifh->open(q{<}.
    RDA::Object::Rda->cat_file($slf->{'_dir'}, $slf->{'_sub'}->{$typ}, $nam));
  return;
}

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

This method returns a reference to a hash associating the reports with their
corresponding file.

=cut

sub get_reports
{ my ($slf, $pat) = @_;
  my ($cat, $dir, $pth);

  $cat = {};
  $dir = RDA::Object::Rda->cat_dir($slf->{'_dir'}, $slf->{'_sub'}->{'C'});
  if (opendir(DIR, $dir))
  { foreach my $nam (readdir(DIR))
    { $cat->{$nam} = $pth
        if $nam =~ $pat
        && -f ($pth = RDA::Object::Rda->cat_file($dir, $nam));
    }
    closedir(DIR);
  }
  $dir = RDA::Object::Rda->cat_dir($slf->{'_dir'}, $slf->{'_sub'}->{'M'});
  if (opendir(DIR, $dir))
  { foreach my $nam (readdir(DIR))
    { $cat->{$nam} = $pth
        if $nam =~ $pat
        && -f ($pth = RDA::Object::Rda->cat_file($dir, $nam));
    }
    closedir(DIR);
  }
  return $cat;
}

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

This method returns the last modify time of the file or an undefined value
when not found.

=cut

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

  return (stat($fil))[9];
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Driver::Archive|RDA::Driver::Archive>,
L<RDA::Driver::Convert|RDA::Driver::Convert>,
L<RDA::Driver::Header|RDA::Driver::Header>,
L<RDA::Driver::Rda|RDA::Driver::Rda>,
L<RDA::Driver::Results|RDA::Driver::Results>,
L<RDA::Driver::Sgml|RDA::Driver::Sgml>,
L<RDA::Error|RDA::Error>,
L<RDA::Handle::Data|RDA::Handle::Data>,
L<RDA::Handle::Vector|RDA::Handle::Vector>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Collect|RDA::Object::Collect>,
L<RDA::Object::Content|RDA::Object::Content>,
L<RDA::Object::Display|RDA::Object::Display>,
L<RDA::Object::Message|RDA::Object::Message>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Object::View|RDA::Object::View>,
L<RDA::Text|RDA::Text>

=head1 COPYRIGHT NOTICE

Copyright (c) 2002, 2016, Oracle and/or its affiliates. All rights reserved.

=head1 TRADEMARK NOTICE

Oracle and Java are registered trademarks of Oracle and/or its
affiliates. Other names may be trademarks of their respective owners.

=cut