# PrRegRd.pm: Interface to IntegRate Framework Registry

package RDA::Extern::PrRegRd;

# $Id: PrRegRd.pm,v 1.18 2015/07/01 05:58:01 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Extern/PrRegRd.pm,v 1.18 2015/07/01 05:58:01 RDA Exp $
#
# Change History
# 20140630  MSC  Eliminate warnings from some Perl versions.

=for stopwords IntegRate

=head1 NAME

RDA::Extern::PrRegRd - Interface to IntegRate Framework Registry

=head1 SYNOPSIS

 require RDA::Extern::PrRegRd;

=head1 DESCRIPTION

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use IO::File;
  use RDA::Text qw(get_string);
  use RDA::Extern::RegEntry;
  use RDA::Object::Rda;
  use RDA::Object::Lex;
}

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

# Define the global private variables
my $ROOT_NAME  = 'ifw';       # Name of the root node in the pipeline registry
my $ROOT_TIMOS = 'timosMgr';  # Name of the root node in the timos registry

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

=head2 S<RDA::Extern::PrRegRd-E<gt>check_package>

This method checks if the package can be initialized to extract information
from registry files. It returns an empty string when successful, otherwise, the
error message.

=cut

sub check_package
{ return q{};
}

=head2 S<RDA::Extern::PrRegRd::read_registry($context,$registry)>

This method extracts registry information and returns it as a hash reference.

=cut

sub read_registry  ## no critic (Complex)
{ my ($ctx, $reg) = @_;
  my ($fmt, $grp, $inf, $mod, $nod, $top);
  $inf = {};

  # Parse Registry
  eval {$top = _new_registry($ctx, $ROOT_NAME, $reg)};
  die $@ if $@;

  # Read Info-Registry
  $nod = _get_node($top, 'Registry');
  $inf->{'Info'} = _read_infos($ctx, $nod);

  # Read Process-Log
  $nod = _get_node($top, 'ProcessLog');
  $nod = _get_node($nod, 'Module');
  $nod = _get_node($nod, 'ITO');
  $inf->{'Process'} = _read_infos($ctx, $nod);

  # Read Formats
  $nod = _get_node($top, 'Pipelines');
  foreach my $fmt ($nod->get_childs)
  { next if $fmt->get_oid() eq 'Instances';

    # Read Format-Log
    $nod = _get_node($fmt, 'PipelineLog');
    $nod = _get_node($nod, 'Module');
    $nod = _get_node($nod, 'ITO');
    push(@{$inf->{'FormatLogs'}}, _read_infos($ctx, $nod));

    # Read Format-Descs
    $nod = _get_node($fmt, 'EdrFactory');
    $nod = _get_node($nod, 'Description');
    $inf->{'FormatDescs'}->{_read_value($ctx, $nod)} = 0;

    if ($grp = _get_node($fmt, 'DataDescription', 1))
    { my ($cnf, $nam, $spc);

      foreach my $itm ($grp->get_childs)
      { if (($nam = _get_node($itm, 'ModuleName', 1)) &&
            ($mod = _get_node($itm, 'Module', 1)))
        { $nam = $nam->get_value();
          if ($nam eq 'Standard')
          { foreach my $typ (qw(StreamFormats InputMapping OutputMapping))
            { next unless ($nod = _get_node($mod, $typ, 1));
              foreach my $chl ($nod->get_childs)
              { $inf->{'FormatDescs'}->{_read_value($ctx, $chl)} = 0;
              }
            }
          }
          elsif ($nam eq 'ASN')
          { foreach my $typ (qw(StreamFormats InputMapping OutputMapping))
            { next unless ($nod = _get_node($mod, $typ, 1));
              foreach my $chl ($nod->get_childs)
              { if (($cnf = _get_node($chl, 'ConfFile', 1)) &&
                    ($spc = _get_node($chl, 'SpecFile', 1)))
                { $inf->{'FormatDescs'}->{_read_value($ctx, $cnf)} = 0;
                  $inf->{'FormatDescs'}->{_read_value($ctx, $spc)} = 0;
                }
              }
            }
          }
        }
        else
        { $nam = $itm->get_oid();
          if ($nam eq 'StreamFormats' ||
              $nam eq 'InputMapping' ||
              $nam eq 'OutputMapping')
          { foreach my $chl ($itm->get_childs)
            { $inf->{'FormatDescs'}->{_read_value($ctx, $chl)} = 0;
            }
          }
        }
      }
    }

    $nod = _get_node($fmt, 'Input');
    $nod = _get_node($nod, 'InputModule');
    $nod = _get_node($nod, 'Module');
    $inf->{'FormatDescs'}->{_read_value($ctx, $nod)} = 0
      if ($nod = _get_node($nod, 'Grammar', 1));

    $grp = _get_node($fmt, 'Output');
    $nod = _get_node($grp, 'OutputCollection');
    foreach my $mod ($nod->get_childs)
    { $nod = _get_node($mod, 'Module');
      $inf->{'FormatDescs'}->{_read_value($ctx, $nod)} = 0
        if ($nod = _get_node($nod, 'Grammar', 1));
    }
    $nod = _get_node($grp, 'OutputLog');
    push(@{$inf->{'StreamLogs'}}, _read_infos($ctx, $nod));
  }

  # Return collected information
  return $inf;
}

# Get a subnode
sub _get_node
{ my ($nod, $ent, $opt) = @_;
  my ($sub);

  $sub = $nod->find_node($ent);
  die '  RegistryEntry not found: '.$nod->get_oid.".$ent\n"
    unless defined($sub) || $opt;
  return $sub;
}

# Read infos
sub _read_infos
{ my ($ctx, $nod) = @_;
  my ($inf, $nam, $pre, $pth, $rpt, $suf);

  $pth = _get_node($nod, 'FilePath');
  $nam = _get_node($nod, 'FileName', 1);
  $pre = _get_node($nod, 'FilePrefix', 1);
  $suf = _get_node($nod, 'FileSuffix', 1);
  $inf = {
    Name   => defined($nam) ? $nam->get_value : undef,
    Path   => $pth->get_value,
    Prefix => defined($pre) ? $pre->get_value : q{},
    Suffix => defined($suf) ? $suf->get_value : q{},
  };

  $nam = defined($inf->{'Name'}) ? $inf->{'Name'} : '<default>';
  $rpt->write(q{  }.RDA::Object::Rda->cat_file($inf->{'Path'},
    $inf->{'Prefix'}.$nam.$inf->{'Suffix'})."\n")
    if ($rpt = $ctx->get_report);
  return $inf;
}

# Read a value
sub _read_value
{ my ($ctx, $nod) = @_;
  my ($rpt);

  my $dat = $nod->get_value();

  $rpt->write("  $dat\n") if ($rpt = $ctx->get_report);
  return $dat;
}

=head2 S<RDA::Extern::PrRegRd::read_timos($context,$registry)>

This method extracts C<timos> registry information and returns it as a hash
reference.

=cut

sub read_timos
{ my ($ctx, $reg) = @_;
  my ($fmt, $grp, $inf, $nod, $top);

  $inf = {};

  # Parse Registry
  eval {$top = _new_registry($ctx, $ROOT_TIMOS, $reg)};
  die $@ if $@;

  # Get the pin log file
  $nod = _get_node($top, 'PinLogFile');
  $inf->{'PinLog'}->{_read_value($ctx, $nod)} = 0;

  # Get the log server file
  $nod = _get_node($top, 'LogServer');
  $nod = _get_node($nod, 'Module');
  $nod = _get_node($nod, 'ITO');
  $inf->{'LogServer'} = _read_infos($ctx, $nod);

  # Return collected information
  return $inf;
}

=head2 S<RDA::Extern::PrRegRd::set_reg_sets($agt,$int)>

This method creates settings for multi-home registries.

=cut

sub set_reg_sets
{ my ($agt, $int) = @_;
  my ($cnt, $col, $dir, $fil, $set, @set, %tbl);

  # Get the previous settings
  $col = $agt->get_collector;
  foreach my $old ($col->get_value('SETUP.CGBU.BRM.W_REG_SETS'))
  { $dir = $col->get_value("SETUP.CGBU.BRM.D_INT_$old");
    $fil = $col->get_value("SETUP.CGBU.BRM.F_REG_$old");
    $tbl{$fil} = $dir if $dir && $fil;
  }

  # Generate the temporary settings
  $cnt = 0;
  foreach my $reg ($col->get_value('SETUP.CGBU.BRM.F_REGISTRY'))
  { push(@set, $set = 'REG'.++$cnt);
    $col->set_temp("SETUP.CGBU.BRM.F_REG_$set", $reg);
    if (exists($tbl{$reg}))
    { $dir = $tbl{$reg};
    }
    else
    { $dir = $int || q{};
      while (length($reg = RDA::Object::Rda->dirname($reg)) > 1)
      { if (-d RDA::Object::Rda->cat_dir($reg, 'log'))
        { $dir = $reg;
          last;
        }
      }
    }
    $col->set_temp("SETUP.CGBU.BRM.D_INT_$set", $dir);
  }
  return @set;
}

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

# Append to an existing registry
sub _append_registry
{ my ($ctx, $top, $reg) = @_;
  my ($adr, $ifh, $lex, $nod, $oid, $prv, $tok, $txt, $typ, @adr, @def);

  # Setup address pointer for the lexical analyzer
  push(@adr, $adr = $oid = $top->get_oid);
  $prv = 'EMPTY';

  # Open registry file
  $ifh = IO::File->new;
  $ifh->open("<$reg") or die "Cannot open registry $reg: $!\n";

  # Definition of the lexical analyzer for integRate registry.
  @def = (
    ## no critic (Interpolation)
    q{NEWLINE},      q{\n},          sub {$lex->end('assign'); return $_[1];},
    q{LEFTBRACKET},  q{\{},
    q{RIGHTBRACKET}, q{\}},
    q{WHITESPACE},   q{\s+},
    q{COMMENT},      q{\s*\#.*},     sub {$lex->end('assign'); return $_[1];},
    q{assign:VALUE}, q{[^\n\#=\{\}]+},
    q{IDENTIFIER},   q{[\w\*\.]+},
    q{ASSIGNMENT},   q{=},           sub {$lex->start('assign'); return $_[1];},
    q{ERROR},        q{.*},          sub {die qq{Cannot analyze: "$_[1]"\n}},
    );

  # Setup Registry
  $lex = RDA::Object::Lex->new($oid);
  $lex->set_trace($ctx->get_collector->get_trace('LEX'));
  $lex->init(@def);
  $lex->inclusive('assign');
  $lex->from($ifh);
  for (;;)  ## no critic (Loop)
  { $tok = $lex->get_next;
    last if $lex->eoi;

    $typ = $tok->get_oid;
    if ($typ eq 'LEFTBRACKET')
    { $prv = $typ;
    }
    elsif($typ eq 'RIGHTBRACKET')
    { pop(@adr) if $prv eq 'IDENTIFIER';
      $adr = pop(@adr);
      $prv = $typ;
    }
    elsif ($typ eq 'IDENTIFIER')
    { $adr = pop(@adr) if $prv eq 'IDENTIFIER';
      push(@adr, $adr);
      $txt = $tok->get_text;
      $adr = $adr.q{.}.$txt unless $txt eq $oid;
      $top->add_empty_node($adr);
      $prv = $typ;
    }
    elsif ($typ eq 'VALUE')
    { $nod = $top->find_deep_node($adr);
      $nod->set_value($tok->get_text);
      $adr = pop(@adr);
      $prv = $typ;
    }
  }

  # Return a reference to the registry node
  return $top;
}

# Setup new registry
sub _new_registry
{ my ($ctx, $oid, $reg) = @_;

  return _append_registry($ctx, RDA::Extern::RegEntry->new($oid), $reg);
}

1;

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Extern::RegEntry|RDA::Extern::RegEntry>,
L<RDA::Object::Lex|RDA::Object::Lex>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Text|RDA::Text>

=head1 COPYRIGHT NOTICE

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

=head1 TRADEMARK NOTICE

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

=cut