# upgrade.pm: upgrade command library

package RDA::Request::UPGRADE;

# $Id: UPGRADE.pm,v 1.21 2015/08/25 14:17:19 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Request/UPGRADE.pm,v 1.21 2015/08/25 14:17:19 RDA Exp $
#
# Change History
# 20150825  MSC  Upgrade modules.

=head1 NAME

RDA::Request::UPGRADE - Upgrade Command Library

=head1 SYNOPSIS

 require RDA::Request::UPGRADE;

=head1 DESCRIPTION

The objects of the C<RDA::Request::UPGRADE> class are used to execute upgrade
requests.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use IO::File;
  use RDA::Text qw(get_string);
  use RDA::Handle::Data;
  use RDA::Object;
  use RDA::Object::Access qw(check_dsn check_sid norm_credential);
  use RDA::Object::Message;
  use RDA::Object::Rda;
}

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

# Define the global private constants

# Define the global private variables
my @tb_usr = (
  qr/^ODI_REPOS_USER_/i,
  );
my %tb_cls = (
  'OH' => '20120609',
  );
my %tb_cmd = (
  'UPGRADE.COLLECTOR' => \&_do_collector,
  'UPGRADE.FILES'     => \&_do_files,
  'UPGRADE.INPUT'     => \&_do_input,
  'UPGRADE.SETUP'     => \&_do_setup,
  );
my %tb_mod = (
  'BI:DCbi'         => '20140117',
  'BI:DCeas'        => '20140430',
  'BI:DCepm'        => '20140430',
  'BI:DCepma'       => '20140430',
  'BI:DCess'        => '20140430',
  'BI:DCesst'       => '20140430',
  'BI:DCfcm'        => '20140430',
  'BI:DCfdm'        => '20140430',
  'BI:DChcm'        => '20140430',
  'BI:DChdm'        => '20140430',
  'BI:DChdrm'       => '20140430',
  'BI:DChfm'        => '20140430',
  'BI:DChfr'        => '20140430',
  'BI:DChir'        => '20140429',
  'BI:DChpc'        => '20140430',
  'BI:DChpl'        => '20140430',
  'BI:DChps'        => '20140430',
  'BI:DChpsv'       => '20140430',
  'BI:DChsf'        => '20140430',
  'BI:DChss'        => '20140530',
  'BI:DChsv'        => '20140430',
  'BI:DChwa'        => '20140430',
  'BI:DCpr'         => '20140430',
  'DB:DClog'        => '20150825',
  'EXPLORER:DCxplr' => '20141020',
  'OFM:DCbam'       => '20140407',
  'OFM:DCdev'       => '20140701',
  'OFM:DCecm'       => '20140407',
  'OFM:DCinfra'     => '20140826',
  'OFM:DCipm'       => '20140407',
  'OFM:DCiwps'      => '20140205',
  'OFM:DCiws'       => '20140205',
  'OFM:DCoam'       => '20140401',
  'OFM:DCodc'       => '20140624',
  'OFM:DCodi'       => '20140701',
  'OFM:DCoim'       => '20140409',
  'OFM:DCosb'       => '20140826',
  'OFM:DCoua'       => '20130801',
  'OFM:DCoud'       => '20140516',
  'OFM:DCowb'       => '20140521',
  'OFM:DCowsm'      => '20140407',
  'OFM:DCses'       => '20140407',
  'OFM:DCsoa'       => '20140826',
  'OFM:DCucm'       => '20140407',
  'OFM:DCuoa'       => '20130801',
  'OFM:DCwc'        => '20140428',
  'OFM:DCws'        => '20140407',
  'OFM:DCwls'       => '20140826',
  'OFM:DCwreq'      => '20140701',
  'OS:DCperf'       => '20140725',
  'RDA:DCbegin'     => '20120609',
  'RDA:DCconfig'    => '20150825',
  'RDA:DCend'       => '20120609',
  );

my %tb_usr = map {$_ => 1} qw(
  ACSSBL_PIN             ACSSBL_UID       CONTENT_REPOS_USER
  DBC_REPOS_USER         DG_BROKER_USER   DPE_DPS_SYSTEM
  DPS_DIRECTORY_MANAGER  EM_REPOS_USER    EPM_REGISTRY
  ESSBASE_USER           GUARDIAN_USER    IFS_REPOS_USER
  LDAP_ORCLADMIN         OES_DBA_USER     OUD_ADMIN
  OUD_DIRECTORY_MANAGER  OVMM_REPOS_USER  RMAN_EXPORT_USER
  SEBL_GATE_USER         TTEN_UID
  );

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

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

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

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

=over 10

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

=back

Internal keys are prefixed by an underscore.

=cut

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

  # Create the library object
  $slf = bless {
    _agt => $agt,
    }, $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>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 UPGRADE COMMANDS

=head2 UPGRADE.COLLECTOR - Collector upgrade command

This command upgrades the result set definition to the current build. It
supports the following attributes:

=over 8

=item B<  build>

Specifies the new build number.

=item B<  save>

When true, saves the configuration at command completion.

=item B<  trace>

When true, traces the upgrade operations.

=back

=cut

sub _do_collector
{ my ($slf, $req) = @_;
  my ($agt, $bkp, $bld, $col, $ctl, $cur, $flg, $new, $run, $sta, $tgt, $trc);

  eval {
    $agt = $slf->{'_agt'};
    $col = $agt->get_collector;
    $sta = $col->get_info('sta');

    # Determine the current setup build
    $bld = $req->get_first('build', $agt->get_config->get_build);
    die get_string('BAD_BUILD') unless $bld =~ m/^\d{6,8}$/;
    $cur = '0' unless defined($cur = $col->set_value('CONFIG.N_BUILD', $bld));

    # Set temporarily the auto-configure flag
    $flg =  $col->set_info('yes', 1);
    $bkp->{'B_SEL'} = $sta->set_value('B_SEL', {});
    $bkp->{'N_TRC'} = $sta->set_value('N_TRC', {});
    $bkp->{'R_CFG'} = $sta->set_value('R_CFG', {});
    $bkp->{'R_RUN'} = $sta->set_value('R_RUN', {});

    # Check the trace requirements
    if ($req->get_first('trace'))
    { $trc = 'T:';
      $col->set_temp('TRACE.N_CLASS', 9);
    }
    else
    { $trc = q{};
    }

    # Upgrade the result set definition
    if ($cur lt '20131004')
    { $col->set_value('SETUP.N_LVL', 6)
        if $col->get_first('SETUP.N_LVL', 0) == 1;
    }
    if ($cur lt '20130719')
    { # Update the domain targets
      $ctl = $col->get_target;
      foreach my $itm ($col->get_items('DOM'))
      { my ($dom, $nam, $top);

        next if $itm->is_defined('D_DOMAIN_ROOT')
             && $itm->is_defined('T_DOMAIN_NAME');
        $tgt = $ctl->add_target($itm);
        $dom = RDA::Object::Rda->short($tgt->get_domain('dom'), 1);
        $nam = $tgt->get_domain('nam');
        $top = $tgt->get_domain('top');
        $ctl->define_target($agt, $itm,
          {D_DOMAIN_HOME=>$dom,
           D_DOMAIN_ROOT=>$top,
           T_DOMAIN_NAME=>$nam}, 1);
      }
    }

    # Update the targets
    foreach my $cls (sort keys(%tb_cls))
    { next unless $cur lt $tb_cls{$cls};  ## no critic (Unless)
      $ctl = $col->get_target;
      foreach my $itm ($col->get_items($cls))
      { $ctl->define_target($agt, $itm, {}, 1);
      }
    }

    # Update individual modules
    foreach my $mod (sort keys(%tb_mod))
    { $col->add_setup([], 0, 1, $trc.$mod)
        if $cur lt $tb_mod{$mod} && $col->is_configured($mod);
    }
    $col->end_setup(0);

    # Restore the queues and the auto-configure flag
    $col->set_info('yes', $flg);
    $sta->set_value('B_SEL', $bkp->{'B_SEL'});
    $sta->set_value('N_TRC', $bkp->{'N_TRC'});
    $sta->set_value('R_CFG', $bkp->{'R_CFG'});
    $new = $sta->set_value('R_RUN', $bkp->{'R_RUN'});
    $run = $sta->tie_value('R_RUN', {});
    foreach my $key (keys(%{$new}))
    { $run->{$key} = $new->{$key} unless exists($run->{$key});
    }
    $sta->untie_value('R_RUN');

    # Save the setup
    $col->save if $req->get_first('save');
    };

  # Clear any trace
  $col->clear_temp('TRACE.N_CLASS');

  # Provide the response
  return $req->reply($@, 'Collector');
}

=head2 UPGRADE.FILES - File upgrade command

This command removes the obsolete files.

=cut

sub _do_files
{ my ($slf, $req) = @_;
  my ($cfg, $cln, $cnt, $ifh, $pth);

  # Remove the obsolete engine files and directories
  $cfg = $slf->{'_agt'}->get_config;
  $cln = $cfg->get_file('D_RDA_DAT', 'clean.txt');
  $cnt = 0;
  $ifh = IO::File->new;
  if ($ifh->open('<'.$cln))
  { while (<$ifh>)
    { s/[\n\r\s]*$//;
      if (s/^fil:(D_RDA_[A-Z]+):\*\.(\w+)$//)
      { $cnt += _clean_dir($cfg, $cfg->get_group($1), $2);
      }
      elsif (s/^fil:(D_RDA_[A-Z]+):(.+)$//)
      { next unless -f ($pth = $cfg->get_file($1, $2));
        1 while unlink($pth);
        ++$cnt if -f $pth;
      }
      elsif (s/^dir:(D_RDA_[A-Z]+):(.+)$//)
      { next unless -d ($pth = $cfg->get_dir($1, $2));
        RDA::Object::Rda->delete_dir($pth);
        ++$cnt if -d $pth;
      }
    }
    $ifh->close;
  }

  # Remove the list of obsolete files on successful cleanup
  unless ($cnt)
  { 1 while unlink($cln);
    ++$cnt if -f $cln;
    $pth = $cfg->get_file('D_RDA_DAT', 'obsolete.txt');
    1 while unlink($pth);
    ++$cnt if -f $pth;
  }

  # Remove the obsolete content
  $cnt += $slf->{'_agt'}->get_content->clean('all');

  # Provide the response
  return $req->reply($@, 'Files', count => $cnt);
}

sub _clean_dir
{ my ($cfg, $dir, $ext) = @_;
  my ($cnt, $pat, $pth);

  $cnt = 0;
  $pat = qr/^(\w+\.$ext)$/i;
  if (opendir(CLN, $dir))
  { foreach my $fil (readdir(CLN))
    { next unless $fil =~ $pat;
      $pth = $cfg->cat_file($dir, $1);
      1 while unlink($pth);
      ++$cnt if -f $pth;
    }
    closedir(CLN);
  }
  return $cnt;
}

=head2 UPGRADE.INPUT - Input directive upgrade command

This command converts input directives into edit directives.

=cut

sub _do_input
{ my ($slf, $req) = @_;
  my ($agt, $cnt, $edt, $key, $sid, $str, $typ, $usr, $val, @tbl, %crd);

  eval {
    $agt = $slf->{'_agt'};
    $edt = $agt->get_info('edt');
    @tbl = $agt->get_input;

    # Analyze the input directives
    while (defined($str = shift(@tbl)))
    { if ($str =~ m/^(\w+)\s*=\s*(')(.*)'/ ||
          $str =~ m/^(\w+)\s*=\s*(")([^"]*)"/)
      { $key = uc($1);
        $val = ($2 eq q{"}) ? RDA::Object::decode($3) : $3;
        if ($key =~ m/^SQL_PASSWORD__([\+\w]+)__(.*)$/)
        { $usr = $2;
          $sid = $1;
          $sid =~ s/plus/\+/g;
          ++$cnt;
          $edt->{"COL/ACCESS.ORACLE.T_CRD_RDA4_$cnt"} = $val;
          $edt->{"COL/ACCESS.ORACLE.T_SID_RDA4_$cnt"} = $sid;
          $edt->{"COL/ACCESS.ORACLE.T_USR_RDA4_$cnt"} = $usr;
        }
        elsif ($key =~ m/^SQL_PASSWORD_/)
        { $usr = substr($key, 13);
          ++$cnt;
          $typ = _is_pseudo($usr) ? 'PSEUDO' : 'ORACLE';
          $edt->{"COL/ACCESS.$typ.T_CRD_RDA4_$cnt"} = $val;
          $edt->{"COL/ACCESS.$typ.T_USR_RDA4_$cnt"} = $usr;
        }
        elsif ($key =~ m/^DBI_PASS_(.*)$/)
        { $crd{$1}->[1] = $val;
        }
        elsif ($key =~ m/^DBI_USER_(.*)$/)
        { $crd{$1}->[0] = $val;
        }
        else
        { $edt->{$key} = $val;
        }
      }
      elsif ($str =~ s/^((\w+\/)?(\w+\.)*\w+)\s*=\s*//)
      { $typ = defined($2) ? uc($2) : q{};
        $key = uc($1);
        $val = eval {_input_value(\$str, \@tbl)};
        unless ($@)
        { if (ref($val))
          { if ($typ ne 'TGT/' || $key =~ m/^TGT\/[A-Z]{2,}_I\d+$/)
            { ++$cnt;
              $edt->{$key} = $val;
            }
          }
          elsif (defined($val) && $typ ne 'TGT/')
          { ++$cnt;
            $edt->{$key} = $val;
          }
        }
      }
    }

    # Convert credentials
    foreach my $uid (keys(%crd))
    { ($typ, $sid, $usr) = _get_authen($crd{$uid}->[0]);
      ++$cnt;
      $edt->{"COL/ACCESS.$typ.T_CRD_RDA4_$uid"} = $crd{$uid}->[1];
      $edt->{"COL/ACCESS.$typ.T_SID_RDA4_$uid"} = $sid;
      $edt->{"COL/ACCESS.$typ.T_USR_RDA4_$uid"} = $usr;
    }
    };

  # Provide the response
  return $req->reply($@, 'Input', count => $cnt);
}

sub _get_authen
{ my ($usr, $sid) = @_;
  my ($typ);

  if ($usr =~ m/^(\w+)(\@oracle|\@\+)?\@([\+\w]+(\.[\w\-]+)*)$/i ||
      $usr =~
        m/^(\w+)(\@oracle|\@\+)?\@([\w\.\-]+:\d+:([\+\.\w]*:)?[\+\.\w]+)$/i)
  { $usr = uc($1);
    $sid = check_sid($3);
    $typ = 'ORACLE';
  }
  elsif ($usr =~ m/^(\w+)\@(odbc|\-)\@(.+)$/i)
  { $usr = uc($1);
    $sid = check_dsn($3);
    $typ = 'ODBC';
  }
  elsif ($usr =~ m/^(\w+)\@([a-z]+)\@(.+)$/i && lc($2) ne 'oracle')
  { ($typ, $sid, $usr) = norm_credential($2, $3, $1);
  }
  else
  { $typ = (!defined($sid) && _is_pseudo(uc($usr))) ? 'PSEUDO' : 'ORACLE';
  }
  return ($typ, $sid, $usr);
}

sub _input_hash
{ my ($str, $tbl) = @_;
  my ($val);

  $val = {};
  _input_key($val, $str, $tbl) if $$str =~ m/^[\w\042\047]/;
  unless ($$str =~ m/^\175\s*/)
  { for (;;)  ## no critic (Loop)
    { unless (defined($$str = shift(@{$tbl})))
      { $$str = q{};
        last;
      }
      $$str =~ s/^\s+//;
      last if $$str =~ m/^\175\s*/;
      _input_key($val, $str, $tbl);
      last if $$str =~ m/^\175\s*/;
    }
  }
  return $val;
}

sub _input_key
{ my ($hsh, $str, $tbl) = @_;
  my ($key, $val);

  if ($$str =~ s/^(\w+)\s*=>\s*//)
  { $key = $1;
  }
  else
  { die "Bad key\n"
      unless defined($key = _input_scalar($str)) && $$str =~ s/^=>\s*//;
  }
  die "Bad value\n"
    unless defined($val = _input_scalar($str));
  return $hsh->{$key} = $val;
}

sub _input_list
{ my ($str, $tbl) = @_;
  my ($itm, $val);

  $val = [];
  push(@{$val}, $itm) if defined($itm = _input_value($str, $tbl));
  unless ($$str =~ s/^\051\s*//)
  { for (;;)  ## no critic (Loop)
    { unless (defined($$str = shift(@{$tbl})))
      { $$str = q{};
        last;
      }
      $$str =~ s/^\s+//;
      push(@{$val}, $itm) if defined($itm = _input_value($str, $tbl));
      last if $$str =~ s/^\051\s*//;
    }
  }
  return $val;
}

sub _input_scalar
{ my ($str, $dft) = @_;

  return
    ($$str =~ s/^'(.*)'\s*//)    ? $1 :
    ($$str =~ s/^"([^"]*)"\s*//) ? RDA::Object::decode($1) :
                                   $dft;
}

sub _input_value
{ my ($str, $tbl) = @_;

  return
    ($$str =~ s/^\050\s*//) ? _input_list($str, $tbl) :
    ($$str =~ s/^\173\s*//) ? _input_hash($str, $tbl) :
                              _input_scalar($str);
}

sub _is_pseudo
{ my ($usr) = @_;

  return 1 if exists($tb_usr{$usr});
  foreach my $pat (@tb_usr)
  { return 1 if $usr =~ $pat;
  }
  return 0;
}

=head2 UPGRADE.SETUP - Setup import command

This command imports a RDA 4 setup file. It supports the following attributes:

=over 8

=item B<  path>

Specifies the RDA 4 setup file path.

=item B<  save>

When true, saves the configuration at command completion.

=back

=cut

sub _do_setup
{ my ($slf, $req) = @_;
  my ($col, $ifh, $pth);

  eval {
    $col = $slf->{'_agt'}->get_collector;

    # Import the RDA 4 setup file
    if ($pth = $req->get_first('path'))
    { $ifh = IO::File->new;
      $ifh->open("<$pth") or die get_string('ERR_OPEN', $pth, $!);
      _import($ifh, $col);
    }
    elsif ($ifh = RDA::Handle::Data->new($req))
    { _import($ifh, $col);
    }

    # Save the setup
    $col->save if $req->get_first('save');
    };

  # Provide the response
  return $req->reply($@, 'Setup');
}

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

sub _import
{ my ($ifh, $col) = @_;
  my ($cur, $dsc, $itm, $key, $typ, $val,
      %det, %dsc, %mod, %sta, %typ, %val);

  # Parse the setup information
  while (<$ifh>)
  { # Trim the end-of-line
    s/[\r\n]+$//;

    # Treat the line
    if (m/^(\w+)='([^']*)'/ || m/^(\w+)="([^"]*)"/)
    { $key = $1;
      $val = $2;
      $val =~ s/&\#10;/\n/g;
      $val =~ s/&\#34;/"/g;
      $val =~ s/&\#39;/'/g;
      $dsc{$key} = $dsc if defined($dsc);
      $typ{$key} = $typ if defined($typ);
      $val{$key} = $val;
      push(@{$cur}, $key) if $cur;
      $dsc = $typ = undef;
    }
    elsif (m/^(\w+)=(.*)$/)
    { $dsc{$1} = $dsc if defined($dsc);
      $typ{$1} = $typ if defined($typ);
      $val{$1} = $2;
      push(@{$cur}, $1) if $cur;
      $dsc = $typ = undef;
    }
    elsif (m/^#([\?BDEFILMNPT])\.\s*(.*)$/)
    { $typ = $1;
      $dsc = $2;
    }
    elsif (m/^#\s*(\w+)=(done|obsolete|partial|pending|skip)/i)
    { $sta{$1} = lc($2);
    }
    elsif (m/^#\s*(\w+):\s*(.*)$/)
    { $mod{$1} = $2;
      $det{$1} = $cur = [];
      $sta{$1} = 'pending' unless exists($sta{$1});
    }
    elsif (!m/^\s*(?:#.*)?$/)
    { die get_string('BAD_SETUP');
    }
  }

  # Update the setup information inside the collection definition
  $itm = $col->get_info('set');
  $itm->set_value('W_MOD', \%det);
  $itm->set_value('T_DSC', \%dsc);
  $itm->set_value('M_NAM', \%mod);
  $itm->set_value('W_TYP', \%typ);
  $itm->set_value('T_VAL', \%val);

  $itm = $col->get_info('sta')->find('IMPORT', 1);
  foreach my $mod (keys(%sta))
  { $itm->set_value("S_RUN_$mod", $sta{$mod});
  }
  return;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Error|RDA::Error>,
L<RDA::Handle::Data|RDA::Handle::Data>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Access|RDA::Object::Access>,
L<RDA::Object::Collect|RDA::Object::Collect>,
L<RDA::Object::Item|RDA::Object::Item>,
L<RDA::Object::Message|RDA::Object::Message>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Object::Target|RDA::Object::Target>,
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