# Upgrade.pm: Upgrade Command Package

package RDA::UI::Upgrade;

# $Id: Upgrade.pm,v 1.19 2015/08/10 17:45:13 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/UI/Upgrade.pm,v 1.19 2015/08/10 17:45:13 RDA Exp $
#
# Change History
# 20150810  MSC  Add the prepare command.

=head1 NAME

RDA::UI::Upgrade - Upgrade Command Package

=head1 SYNOPSIS

 <rda> <options> -XUpgrade <command> <switches> <arg> ...

 <sdci> <options> -XUpgrade <command> <switches> <arg> ...

=head1 DESCRIPTION

The following commands are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use File::Copy qw(copy move);
  use IO::File;
  use RDA::Text qw(get_string);
  use RDA::Options;
  use RDA::Object qw(decode);
  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.19 $ =~ /(\d+)\.(\d+)/);
@ISA     = qw(Exporter);

# Define the global private constants

# Define the global private variables
my @tb_adj = (
  ['D_RDA'     => qr/^(i?rda\.|sdci\.|DISCLAIM|README_)/],
  ['D_RDA_INC' => [qw(RDA IRDA Convert)]],
  ['D_RDA_HOM' => [qw(admin da engine tools)]],
  'D_RDA_ADM',
  'D_RDA_CHK',
  'D_RDA_COL',
  'D_RDA_CSS',
  'D_RDA_DAT',
  'D_RDA_DFW',
  'D_RDA_MOD',
  'D_RDA_MSG',
  'D_RDA_POD',
  'D_RDA_REL',
  'D_RDA_TST',
  );
my %tb_eng = (
  'rda_darwin'  => 'rda_macp',
  'rda_linux'   => 'rda_lin32',
  'rda_sunos'   => 'rda_sols',
  'rda_win.exe' => \&_upd_win_engine,
  );

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

=head2 S<adjust>

This command adjusts the owner permissions of all RDA files and directories to
allow a software update.

=cut

sub adjust
{ my ($agt, @arg) = @_;
  my ($act, $cfg, $err, $top, %dup);

  # Treat the options
  RDA::Options::getopts(q{}, \@arg);

  # Adjust the permissions
  $cfg = $agt->get_config;
  $err = 0;
  foreach my $grp (@tb_adj)
  { if (ref($grp))
    { ($grp, $act) = @{$grp};
      next unless -d ($top = $cfg->get_group($grp));
      if (ref($act) eq 'ARRAY')
      { foreach my $sub (@{$act})
        { $err += _adjust_dir(\%dup, $cfg, $cfg->cat_dir($top, $sub));
        }
      }
      else
      { if (opendir(DIR, $top))
        { foreach my $fil (readdir(DIR))
          { $err += _adjust_file($cfg, $cfg->cat_file($top, $fil))
              if $fil =~ $act;
          }
          closedir(DIR);
        }
      }
    }
    else
    { $err += _adjust_dir(\%dup, $cfg, $cfg->get_group($grp));
    }
  }

  # Indicate the completion status
  return $err ? 1 : 0;
}

sub _adjust_dir
{ my ($dup, $cfg, $dir) = @_;
  my ($err, $pth, @sub);

  $err = 0;
  unless (exists($dup->{$dir}))
  { $dup->{$dir} = 1;
    if (opendir(DIR, $dir))
    { $err += _adjust_file($cfg, $dir);
      foreach my $fil (readdir(DIR))
      { next if $fil =~ m/^\.+$/;
        $err += _adjust_file($cfg, $pth = $cfg->cat_file($dir, $fil));
        push(@sub, $fil) if -d $pth;
      }
      closedir(DIR);
      foreach my $sub (@sub)
      { $err += _adjust_dir($dup, $cfg, $cfg->cat_dir($dir, $sub));
      }
    }
  }
  return $err;
}

sub _adjust_file
{ my ($cfg, $pth) = @_;
  my ($mod);

  return 1 unless defined($pth = $cfg->is_path($pth)) &&
                  defined($mod = (stat($pth))[2]);
  ## no critic (Bit,Number,Zero)
  return chmod(($mod & 07777) | 0700, $pth) ? 0 : 1 if -d $pth;
  return chmod(($mod & 07777) | 0600, $pth) ? 0 : 1 if -f $pth;
  return 0;
}

=head2 S<collector>

This command upgrades the result set definition.

=cut

sub collector
{ my ($agt, @arg) = @_;

  # Treat the options
  RDA::Options::getopts(q{}, \@arg);

  # Upgrade the result set definition
  return $agt->get_collector->save;
}

=head2 S<engine E<lt>dstE<gt> E<lt>srcE<gt>>

This command updates F<rda.exe> or F<sdci.exe> when a more recent version of
the compile engine is available.

=cut

sub engine  ## no critic (Complex)
{ my ($agt, @arg) = @_;
  my ($dsp, $exe, $src);

  # Treat the options
  RDA::Options::getopts(q{}, \@arg);

  # Treat the command
  $dsp = $agt->is_verbose;
  if (defined($exe = RDA::Object::Rda->is_path(shift(@arg))) &&
      defined($src = RDA::Object::Rda->is_path(shift(@arg))) &&
      -r ($src = _upd_engine($agt, $src, $dsp)))
  { my ($cfg, $dir, $dst, $eng, $lck, $sta, @dfs, @sfs);

    # Initialization
    $cfg = $agt->get_config;
    $dir = $cfg->dirname($exe = $cfg->cat_file($exe));
    $eng = $cfg->basename($src = $cfg->cat_file($src));
    $sta = 0;

    # Disable some signals
    local $SIG{'HUP'}  = 'IGNORE' if exists($SIG{'HUP'});
    local $SIG{'INT'}  = 'IGNORE' if exists($SIG{'INT'});
    local $SIG{'KILL'} = 'IGNORE' if exists($SIG{'KILL'});
    local $SIG{'PIPE'} = 'IGNORE' if exists($SIG{'PIPE'});
    local $SIG{'STOP'} = 'IGNORE' if exists($SIG{'STOP'});
    local $SIG{'TERM'} = 'IGNORE' if exists($SIG{'TERM'});
    local $SIG{'QUIT'} = 'IGNORE' if exists($SIG{'QUIT'});

    # Perform the operation
    eval {
      $dsp->dsp_line(get_string('V_AddLock')) if $dsp;
      if ($sta = _upd_lock($lck = $cfg->cat_file($dir, 'sdci.lck')))
      { if (! -e $exe)
        { $dsp->dsp_line(get_string('V_Copy', $eng)) if $dsp;
          copy($src, $exe);
          chmod(0555, $exe);  ## no critic (Number)
        }
        elsif ((@dfs = stat($exe)) && (@sfs = stat($src))
          && ($dfs[9] < $sfs[9] || $dfs[7] != $sfs[7]))
        { $dst = $cfg->cat_file($dir, $eng);
          $dsp->dsp_line(get_string('V_Copy', $eng)) if $dsp;
          copy($src, $dst) or die get_string('ERR_COPY', $!);
          $dsp->dsp_line(get_string('V_Replace', $eng)) if $dsp;
          1 while unlink($exe);
          move($dst, $exe) or die get_string('ERR_MOVE', $!);
          chmod(0555, $exe);  ## no critic (Number)
        }
      }
      else
      { $dsp->dsp_line(get_string('V_DelWait')) if $dsp;
        sleep(2) while (-e $lck);
      }
    };
    $dsp->dsp_line($@) if $@ && $dsp;

    # Delete the lock file
    if ($sta > 0)
    { $dsp->dsp_line(get_string('V_DelLock')) if $dsp;
      1 while unlink($lck);
    }
  }

  # Indicate a successful completion
  return 0;
}

# Adjust engine name
sub _upd_engine
{ my ($agt, $src, $dsp) = @_;
  my ($bas, $dir);

  ($dir, $bas) = RDA::Object::Rda->parse_path($src);
  return $src unless exists($tb_eng{$bas});
  $bas = (ref($tb_eng{$bas}) eq 'CODE')
    ? &{$tb_eng{$bas}}($agt, $bas, $dsp)
    : $tb_eng{$bas};
  $dsp->dsp_line(get_string('V_Engine', $bas)) if $dsp;
  return RDA::Object::Rda->cat_file($dir, $bas);
}

sub _upd_win_engine
{ my ($agt, $bas, $dsp) = @_;

  return ($agt->get_env('RDA_WIN64') ||
    -d RDA::Object::Rda->cat_dir($agt->get_env('SYSTEMROOT', 'C:\windows'),
                                 'SysWOW64'))
    ? 'rda_win64.exe'
    : 'rda_win32.exe';
}

# Take a lock
sub _upd_lock
{ my ($fil) = @_;
  my ($lck);

  # Check if open constants are available
  eval 'require Fcntl';
  return -1 if $@;

  # Create the lock file
  $lck = IO::File->new;
  ## no critic (Bit,Call,Explicit)
  unless ($lck->open($fil, Fcntl::O_CREAT() | Fcntl::O_EXCL()))
  { die get_string('ERR_LOCK', $fil, $!) unless $! =~ m/File exists/i;
    return 0;
  }
  $lck->close;
  return 1;
}


=head2 S<files>

This command removes the obsolete files.

=cut

sub files
{ my ($agt, @arg) = @_;

  # Treat the options
  RDA::Options::getopts(q{}, \@arg);

  # Remove the obsolete files
  return $agt->submit(q{.}, 'UPGRADE.FILES');
}

=head2 S<help>

This command displays the command syntax and the related explanations.

=cut

sub help
{ return shift->submit(q{.}, 'DISPLAY.DSP_POD', package => __PACKAGE__);
}

=head2 S<prepare E<lt>dirE<gt>>

This command prepares the specified target directory for an upgrade.

=cut

sub prepare  ## no critic (Complex)
{ my ($agt, @arg) = @_;
  my ($cfg, $cwd, $dsp, $dst, $ifh, $pth, $rda, $ret, $tbl, $val);

  # Treat the options
  RDA::Options::getopts(q{}, \@arg);

  # Validate the argument
  $cfg = $agt->get_config;
  $dsp = $agt->is_verbose;
  $ifh = IO::File->new;
  return 10 unless defined($dst = shift(@arg));
  $cwd = $cfg->get_group('D_CWD');
  $dst = $cfg->clean_path([$cwd, $dst, q{}], 1)
    unless $cfg->is_absolute($dst = $cfg->cat_dir($dst));
  $dsp->dsp_line(get_string('V_TgtDir', $dst)) if $dsp;
  return 11 if $dst eq $cwd;
  return 12 unless -d $dst && -x $dst;
  $rda = $cfg->quote($cfg->cat_file($dst, $cfg->is_unix ? 'rda.sh' :
                                          $cfg->is_vms  ? 'rda.com' :
                                                          'rda.cmd'));

  # Check the target version
  ($val) = `$rda -XRda version 2>/dev/null`;
  return 20 unless defined($val) && $val =~ m/^\d+\.\d{2}\-(\d{8})/;
  $dsp->dsp_line(get_string('V_TgtBld', $1)) if $dsp;
  return 21 unless $1 < $cfg->get_value('N_BUILD');  ## no critic (Unless)

  # Check if upgrades are allowed
  if (-f ($pth = $cfg->cat_file($dst, 'rda.cfg')))
  { return 30 unless $ifh->open(q{<}.$pth);
    $tbl = _load_config($ifh);
    return 31 if exists($tbl->{'B_NO_UPGRADE'});
  }

  # Check compiled engine availability
  return 40 + $ret
    if $tbl && ($ret = _has_ce($agt, $cfg, $dsp, $dst, $tbl));
  if (-f 'rda.cfg')
  { return 50 unless $ifh->open(q{<}.$pth);
    return 50 + $ret
      if ($ret = _has_ce($agt, $cfg, $dsp, $dst, _load_config($ifh)));
  }
  if (-f ($pth = $cfg->cat_file($dst, 'engine', 'rda.cfg')))
  { return 60 unless $ifh->open(q{<}.$pth);
    return 60 + $ret
      if ($ret = _has_ce($agt, $cfg, $dsp, $dst, _load_config($ifh), 'engine'));
  }

  # Adjust the target directory
  return system("$rda -XUpgrade adjust 2>/dev/null")
}

sub _load_config
{ my ($ifh) = @_;
  my ($cfg, $key, $val);

  $cfg = {};
  while (<$ifh>)
  { if (m/^(D_[A-Z][_A-Z]*[A-Z]+)="([^"]*)"/)
    { $cfg->{$1} = RDA::Object::Rda->cat_dir(decode($2));
    }
    elsif (m/^(F_[A-Z][_A-Z]*[A-Z]+)="([^"]*)"/)
    { $cfg->{$1} = RDA::Object::Rda->cat_file(decode($2));
    }
    elsif (m/^(N_[A-Z][_A-Z]*[A-Z]+)="([^"]*)"/)
    { ($key, $val) = ($1, decode($2));
      $cfg->{$key} = $val if $val =~ m/^\d+$/;
    }
    elsif (m/^(R_[A-Z][_A-Z]*[A-Z]+)="([^"]*)"/)
    { ($key, $val) = ($1, decode($2));
      $cfg->{$key} = $val if $val =~ m/^[-+]?(\d+(\.\d*)?|\.\d+)$/;
    }
    elsif (m/^([BT]_[A-Z][_A-Z]*[A-Z]+)="([^"]*)"/)
    { $cfg->{$1} = decode($2);
    }
    elsif (m/^(NO_[A-Z]+)="([^"]*)"/)
    { $cfg->{"B_$1"} = decode($2);
    }
    elsif (m/^(RDA_ENG|RDA_EXE)="([^"]*)"/)
    { $cfg->{$1} = RDA::Object::Rda->cat_file($2);
    }
  }
  $ifh->close;
  return $cfg;
}

sub _has_ce
{ my ($agt, $cfg, $dsp, $dst, $tbl, @sub) = @_;
  my ($hom, $nam);

  if (exists($tbl->{'RDA_ENG'}) && length($tbl->{'RDA_ENG'}))
  { return 1 unless exists($tbl->{'RDA_EXE'}) && length($tbl->{'RDA_EXE'});
    return 2 unless exists($tbl->{'D_RDA'});
    $hom = $cfg->clean_path([$dst, @sub, $hom, q{}], 1)
      unless $cfg->is_absolute($hom = $tbl->{'D_RDA'});
    $dsp->dsp_line(get_string('V_TgtHom', $hom)) if $dsp;
    return 3 unless $hom eq $dst;
    return 4 unless length($nam = $cfg->basename($tbl->{'RDA_ENG'}));
    $nam = (ref($tb_eng{$nam}) eq 'CODE')
      ? &{$tb_eng{$nam}}($agt, $nam, $dsp)
      : $tb_eng{$nam}
      if exists($tb_eng{$nam});
    $dsp->dsp_line(get_string('V_TgtCE', $nam)) if $dsp;
    return 5 unless -f $cfg->get_file('D_RDA', "engine/$nam");
  }
  return 0;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Message|RDA::Object::Message>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Options|RDA::Options>,
L<RDA::Request::DISPLAY|RDA::Request::DISPLAY>,
L<RDA::SDCL::Block|RDA::SDCL::Block>,
L<RDA::SDSL::Module|RDA::SDSL::Module>,
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