# Daemon.pm: Class Used for Objects to Control Background Collections

package RDA::Driver::Daemon;

# $Id: Daemon.pm,v 1.9 2015/04/29 13:44:49 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Driver/Daemon.pm,v 1.9 2015/04/29 13:44:49 RDA Exp $
#
# Change History
# 20150424  MSC  Introduce the control and slave agent concepts.

=head1 NAME

RDA::Driver::Daemon - Class Used for Objects to Control Background Collections

=head1 SYNOPSIS

 require RDA::Daemon;

=head1 DESCRIPTION

The objects of the C<RDA::Driver::Daemon> class are used to control background
collections.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use File::Copy qw(move);
  use IO::File;
  use POSIX;
  use RDA::Text qw(get_string);
  use RDA::Object::Content qw($RE_DC $RE_TRC);
  use RDA::Object::Rda qw($APPEND $CREATE $FIL_PERMS);
}

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

# Define the global private constants
my $FRK = "Parent exit\n";

# Define the global private variables

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

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

The object constructor. It takes the agent reference as an argument.

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

=over 12

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

=item S<    B<'_bas'> > Maximum length of the report basename

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

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

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

=item S<    B<'_ctl'> > Configuration and control directory

=item S<    B<'_def'> > Reference to the SAMPLE item

=item S<    B<'_lck'> > Reference to the lock control object

=item S<    B<'_mod'> > Module hash

=item S<    B<'_oid'> > Setup name

=item S<    B<'_run'> > Reference to the run-time item

=item S<    B<'_set'> > Reference to the SETUP item

=item S<    B<'_top'> > RDA top directory

=back

Internal keys are prefixed by an underscore.

=cut

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

  # Create the daemon object and return its reference
  $cfg = $agt->get_config;
  $col = $agt->get_collector;
  return bless {
    _agt => $agt,
    _bas => $cfg->get_info('N_BASENAME', 38),
    _cfg => $cfg,
    _cnt => $col->get_content,
    _col => $col,
    _ctl => defined($dir = $agt->get_env('RDA_PID'))
      ? $dir
      : $cfg->get_group('D_CWD'),
    _def => $col->find('SAMPLE', 1),
    _mod => {},
    _oid => $col->get_oid,
    _run => $col->get_info('run'),
    _set => $col->get_info('set'),
    _top => $cfg->get_group('D_RDA'),
    }, ref($cls) || $cls;
}

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

This method requests the data collection running in the background to stop.

=cut

sub halt_bgnd
{ my ($slf) = @_;
  my ($ctl, $end);

  $slf->{'_col'}->log('h');
  if (-f ($ctl = RDA::Object::Rda->cat_file($slf->{'_ctl'},
    $slf->{'_oid'}.'.pid')))
  { $end = $ctl;
    $end =~ s/pid$/end/i;
    rename($ctl, $end) or die get_string('ERR_HALT', $!);
  }
  return;
}

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

This method kills any data collection that is running in the background.

=cut

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

  $slf->{'_col'}->log('k');
  _kill_bgnd($slf, '.pid') || _kill_bgnd($slf, '.end');
  return;
}

sub _kill_bgnd
{ my ($slf, $ext) = @_;
  my ($cnt, $ifh, $pth);

  $cnt = 0;
  $ifh = IO::File->new;
  $pth = RDA::Object::Rda->cat_file($slf->{'_ctl'}, $slf->{'_oid'}.$ext);
  if ($ifh->open(q{<}.$pth))
  { my $pid = <$ifh>;
    $ifh->close;
    $pid =~ s/[\n\r]+$//;
    kill(15, $pid) if $pid;
    ++$cnt while unlink($pth);
  }
  return $cnt;
}

1;

=head2 S<$h-E<gt>run_bgnd($out,[$group,$module,...])>

This method attempts to transform the current process into a daemon and starts
the data collection loop. It redirects the standard output to the specified
output file. You can provide an alternative module list as arguments.

=cut

sub run_bgnd  ## no critic (Complex)
{ my ($slf, $out, $grp, @arg) = @_;
  my ($cnt, $col, $ctl, $cur, $dat, $def, $dlt, $lck, $min, $nxt, $ofh, $rat,
      $run, $set, $tim, $trc, $val, @mod, %mod);

  $col = $slf->{'_col'};
  $dat = $col->get_data;
  $def = $slf->{'_def'};
  $run = $slf->{'_run'};
  $set = $slf->{'_set'};
  $slf->{'_mod'} = {};
  $trc = $slf->{'_agt'} if $col->get_trace('SAMPLE');

  # Prepare the pattern list
  foreach my $arg (@arg)
  { my ($abr, $mod, $nam);

    $mod = ($arg =~ $RE_TRC) ? $2 : $arg;
    $mod = $slf->{'_cnt'}->get_module('DC', $grp, $mod);
    next unless $mod =~ $RE_DC;
    push(@mod, $mod) unless $mod{$mod};
    $nam = qq{$2.$3};
    $abr = uc(qq{$2\_$3\_});
    $slf->{'_mod'}->{$nam} = {
      cat => qr{^$abr([ADI])\.fil$}i,
      fil => $abr.'A.fil',
      flg => $set->get_first("$nam.B_APPEND", 1),
      mod => $mod,
      pre => $abr,
      rpt => qr{^$abr.+(\.\w+)$}i,
      seq => 0,
      toc => qr{^$abr(\w*_)?TF?\.toc$}i,
      };
  }

  # Prepare the initial data collection
  $col->add_collect([], @mod);

  # Prepare the sampling environment
  $col->get_dir('A', 1);
  $col->get_dir('R', 1);
  $col->get_dir('S', 1);
  $dlt = $def->get_first('N_DELTA',300);
  $min = $def->get_first('N_SLEEP',60);
  $rat = 3600 * $def->get_first('N_RATE', 0);

  # Try to transform the process in a daemon
  $ctl = RDA::Object::Rda->cat_file($slf->{'_ctl'}, $slf->{'_oid'}.'.pid');
  $ofh = IO::File->new;
  $ofh->open($ctl, $CREATE, $FIL_PERMS)
    or die get_string('ERR_CONTROL', $!);
  open(STDIN, '<'.RDA::Object::Rda->dev_null)  ## no critic (Open)
    or die get_string('ERR_INPUT', $!);
  eval "fork() && die '$FRK'";  ## no critic (Eval)
  if ($@ eq $FRK)
  { $ofh->close;
    return 0;
  }
  open(STDOUT, ">$out")                        ## no critic (Open)
    or die get_string('ERR_OUTPUT', $!);
  eval 'setsid()';                             ## no critic (Eval)
  print {$ofh} "$$\n";
  $ofh->close;
  $ctl =~s/pid$/end/i;
  _log($slf, 'f');

  # Perform an initial data collection and archiving
  $cur = RDA::Object::Rda->get_timestamp($tim = time);
  $cur =~ s/_//;
  $lck = '-B-'.$col->get_oid;
  $run->set_value('SAMPLE.N_CURRENT', $cur);
  $run->set_value('SAMPLE.N_COUNT', $cnt = 0);
  $trc->trace("Initial archive [$cur]") if $trc;

  _lock($slf, $lck);
  _do_archive($slf, $col->get_dir('A'), $col->get_dir('S'), $tim, $cur);
  $trc->trace("Initial collection [$cur]") if $trc;
  $col->end_collect(0);
  _wait($slf);
  $trc->trace('Set the reference') if $trc;
  _do_unlink($slf, $col->get_dir('R'));
  _do_move($slf, $col->get_dir('R'), $col->get_dir('C'), $dat);
  _unlock($slf, $lck);
  $tim = _get_next($tim + $dlt, $min);

  # Perform sample loop
  while (_chk_end($slf, $ctl))
  { # Sleep until next sample
    $trc->trace('Next sample at '.RDA::Object::Rda->get_timestamp($tim))
      if $trc;
    $val = $tim - time;
    if ($val > 20)
    { $trc->trace('Sleep 15') if $trc;
      sleep(15);
      next;
    }
    elsif ($val > 0)
    { $trc->trace("Sleep $val") if $trc;
      sleep($val);
    }

    # Check if a halt request has been posted
    last unless _chk_end($slf, $ctl);

    # Collect a new sample
    $cur = RDA::Object::Rda->get_timestamp($tim = time);
    $cur =~ s/_//;
    $run->set_value('SAMPLE.N_CURRENT', $cur);
    $run->set_value('SAMPLE.N_COUNT', ++$cnt);
    $trc->trace("Sample #$cnt [$cur]") if $trc;
    $col->set_element('T', 'DEFAULT.B_NO_PARALLEL', 1);
    foreach my $mod (@mod)
    { $col->collect($mod, 0);
    }
    $run->clear;
    $col->reset_job;
    $col->get_element('C', 'DEFAULT.B_NO_PARALLEL');
    _wait($slf, $lck);
    $trc->trace("Add results #$cnt [$cur]") if $trc;
    _do_concat($slf, $col->get_dir('S'), $col->get_dir('C'), $dat, $cur);
    _unlock($slf, $lck);

    # Check if a halt request has been posted
    last unless $slf->_chk_end($ctl);

    # Perform sample archiving when required
    $nxt = $def->get_first('G_LAST', 0) + $rat;
    if ($tim < $nxt)
    { $trc->trace('Next archive at '.RDA::Object::Rda->get_timestamp($nxt))
        if $trc;
    }
    else
    { $trc->trace("Archive [$cur]") if $trc;
      _lock($slf, $lck);
      _do_archive($slf, $col->get_dir('A'), $col->get_dir('S'), $tim, $cur);
      _unlock($slf, $lck);
    }
    $tim = _get_next($tim + $dlt, $min);
  }
  return 1;
}

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

# Check if a halt request has been posted
sub _chk_end
{ my ($slf, $pth) = @_;

  # Continue unless an halt request is detected
  return 1 unless -f $pth;

  # Remove the control file
  0 while unlink($pth);

  # Indicate that the collection should stop
  return 0;
}

# Perform sample archiving
sub _do_archive
{ my ($slf, $arc, $smp, $tim, $cur) = @_;
  my ($cfg, $col, $def, $flg, $max, $pth, $rsp, $vol, %man,%tbl);

  $col = $slf->{'_col'};
  $def = $slf->{'_def'};

  # Archive the sample files
  if (_chk_package($smp))
  { $cfg = $slf->{'_cfg'};
    %man = ('Build-Number' => $cfg->get_build,
            'Date'         => $cfg->get_gmtime,
            'Modules'      => join(', ', sort keys(%{$slf->{'_mod'}})),
            'Sample'       => $cur,
           );
    unless ($col->get_value('FILTER.B_ENABLED'))
    { $man{'Machine'}      = $cfg->get_host;
      $man{'OS-Name'}      = $cfg->get_os;
      $man{'OS-Version'}   = $cfg->uname('r'); # [
      $man{'Perl-Version'} = $];
      $man{'User'}         = $cfg->get_user;
    }
    $rsp = $col->submit(q{.}, 'PACKAGE.FILES',
      directory => $smp,
      location  => $arc,
      manifest  => [%man],
      name      => "RDA_smp_$cur");

    # When there are no errors, clean up the sample directory
    if ($rsp->is_success)
    { $cfg->clean_dir($smp);
      foreach my $rec (values(%{$slf->{'_mod'}}))
      { $rec->{'seq'} = 0;
        delete($rec->{'nam'});
        delete($rec->{'oid'});
      }
    }
    else
    { _log($slf, 'E', $rsp->is_error);
    }
  }

  # Cleanup the archive directory
  if (opendir(DIR, $arc))
  { # Get the archive files
    foreach my $fil (grep {m/^RDA_smp_/i} readdir(DIR))
    { $pth = RDA::Object::Rda->cat_file($arc, $fil);
      $tbl{$fil} = [$pth, (stat($pth))[7]];
    }
    closedir(DIR);

    # Keep more recent archives
    $max = $def->get_first('N_KEEP',0);
    $vol = 1048576 * $def->get_first('N_SIZE',0);
    $flg = 0;
    foreach my $fil (reverse sort keys(%tbl))
    { if ($vol > 0)
      { $vol -= $tbl{$fil}->[1];
        $flg = 1 if $vol <= 0;
      }
      if ($flg)
      { 1 while unlink($tbl{$fil}->[0]);
      }
      if ($max > 0)
      { # Must we still keep the next one ?
        $flg = 1 unless --$max > 0;  ## no critic (Unless)
      }
    }
  }

  # Save the result set definition file
  $def->set_value('G_LAST', $tim);
  $col->save;
  return;
}

sub _chk_package
{ my ($dir) = @_;
  my ($fil, $flg);

  if (opendir(DIR, $dir))
  { while (defined($fil = readdir(DIR)))
    { if ($fil =~ m/\.\w+$/)
      { $flg = 1;
        last;
      }
    }
    closedir(DIR);
  }
  return $flg;
}

# Concatenate sample files
sub _do_concat  ## no critic (Complex)
{ my ($slf, $dst, $src, $dat, $cur) = @_;
  my ($buf, $cfh, $ctl, $dir, $ext, $fil, $ifh, $lgt, $nam, $ofh, $pth, $tgt);

  $cfh = IO::File->new;
  $ifh = IO::File->new;
  $ofh = IO::File->new;
  foreach my $mod (keys(%{$slf->{'_mod'}}))
  { $ctl = $slf->{'_mod'}->{$mod};

    # Treat the report catalog
    $pth = RDA::Object::Rda->cat_file($dat, $ctl->{'fil'});
    next unless $cfh->open("<$pth");
    while (<$cfh>)
    { (undef, $dir, $fil, $nam) = split(/\|/, $_, 5);
      next unless $dir eq 'C' && length($nam);
      if ($fil =~ $ctl->{'rpt'})      # TXT or DAT
      { $ext = lc($1);
        $pth = RDA::Object::Rda->cat_file($src, $fil);
        if ($ext ne '.txt')                # DAT
        { $tgt = RDA::Object::Rda->cat_file($dst, $fil);
          if (-f $tgt)
          { 1 while unlink($tgt);
          }
          else
          { $ctl->{'oid'}->{_get_oid($ctl)} = "S|$fil|$nam";
          }
          move($pth, $tgt);
        }
        elsif (!$ctl->{'flg'})                 # Not concatenated TXT
        { move($pth, _get_dest($slf, $ctl, $dst, "$nam\_$cur", $ext));
        }
        elsif (-s $pth && $ifh->open("<$pth"))  # Concatenated TXT
        { binmode($ifh);
          $tgt = exists($ctl->{'nam'}->{$nam})
            ? $ctl->{'nam'}->{$nam}
            : _get_dest($slf, $ctl, $dst, $nam, $ext);
          if ($ofh->open($tgt, $APPEND, $FIL_PERMS))
          { binmode($ofh);
            $buf = "---+ $cur\n";
            syswrite($ofh, $buf, length($buf));
            while ($lgt = $ifh->sysread($buf, 32768))
            { syswrite($ofh, $buf, $lgt);
            }
            $ofh->close;
          }
          $ifh->close;
        }
        1 while unlink($pth);
      }
    }
    $cfh->close;

    # Generate the sample list
    if (exists($ctl->{'oid'}))
    { $fil = RDA::Object::Rda->cat_file($dst, $ctl->{'fil'});
      $ofh->open($fil, $CREATE, $FIL_PERMS) or
        die get_string('ERR_CREATE', $fil, $!);
      foreach my $oid (sort keys(%{$ctl->{'oid'}}))
      { $buf = join(q{|}, $oid, $ctl->{'oid'}->{$oid}, qq{\n});
        $ofh->syswrite($buf, length($buf));
      }
      $ofh->close;
    }
  }
  return;
}

sub _get_dest
{ my ($slf, $ctl, $dst, $nam, $ext) = @_;
  my ($fil, $lgt, $oid);

  # Truncate when needed
  $lgt = $slf->{'_bas'};
  $oid = _get_oid($ctl);
  $fil = $ctl->{'pre'}.$nam;
  if (length($fil) > $lgt)
  { $lgt -= length($oid) + 1;
    $fil = ($lgt > 1) ? $oid.q{_}.substr($nam, 0, $lgt) : $oid;
  }
  $fil .= $ext;

  # Update the control structure
  $ctl->{'oid'}->{$oid} = "S|$fil|$nam";
  return $ctl->{'nam'}->{$nam} = RDA::Object::Rda->cat_file($dst, $fil);
}

# Log an event
sub _log
{ my ($slf, @evt) = @_;

  $slf->{'_col'}->log(@evt);
  $slf->{'_col'}->suspend_log;
  return;
}

# Move sample files
sub _do_move
{ my ($slf, $dst, $src, $dat) = @_;

  # Move the catalog and table of content files
  if (opendir(DIR, $dat))
  { foreach my $fil (readdir(DIR))
    { foreach my $rec (values(%{$slf->{'_mod'}}))
      { if ($fil =~ $rec->{'cat'} || $fil =~ $rec->{'toc'})
        { move(RDA::Object::Rda->cat_file($dat, $fil),
               RDA::Object::Rda->cat_file($dst, $fil));
          last;
        }
      }
    }
    closedir(DIR);
  }

  # Move the report files
  if (opendir(DIR, $src))
  { foreach my $fil (readdir(DIR))
    { foreach my $rec (values(%{$slf->{'_mod'}}))
      { if ($fil =~ $rec->{'rpt'})
        { move(RDA::Object::Rda->cat_file($src, $fil),
               RDA::Object::Rda->cat_file($dst, $fil));
          last;
        }
      }
    }
    closedir(DIR);
  }
  return;
}

# Remove sample files
sub _do_unlink
{ my ($slf, $dst) = @_;
  my ($pth);

  if (opendir(DIR, $dst))
  { foreach my $fil (readdir(DIR))
    { foreach my $rec (values(%{$slf->{'_mod'}}))
      { if ($fil =~ $rec->{'rpt'} ||
            $fil =~ $rec->{'cat'} ||
            $fil =~ $rec->{'toc'})
        { $pth = RDA::Object::Rda->cat_file($dst, $fil);
          1 while unlink($pth);
          last;
        }
      }
    }
    closedir(DIR);
  }
  return;
}

# Get a sample identifier
sub _get_oid
{ my ($ctl) = @_;

  return sprintf('%s%s%05d', $ctl->{'pre'}, $ctl->{'flg'} ? 'M' : 'S',
    ++$ctl->{'seq'});
}

# Get the lock control object
sub _get_lock
{ my ($slf) = @_;

  unless (exists($slf->{'_lck'}))
  { eval {
      require RDA::Object::Lock;
      $slf->{'_lck'} = RDA::Object::Lock->new($slf->{'_agt'},
        $slf->{'_out'}->get_dir('L', 1));
    };
    $slf->{'_lck'} = undef if $@;
  }
  return $slf->{'_lck'};
}

# Define when the next sample must be taken
sub _get_next
{ my ($nxt, $min) = @_;

  $min += time;
  return ($nxt < $min) ? $min : $nxt;
}

# Take a lock
sub _lock
{ my ($slf, $lck) = @_;
  my ($ctl);

  $ctl->lock($lck) if ref($ctl = _get_lock($slf));
  return;
}

# Release a lock
sub _unlock
{ my ($slf, $lck) = @_;
  my ($ctl);

  $ctl->unlock($lck) if ref($ctl = _get_lock($slf));
  return;
}

# Wait for thread execution completion
sub _wait
{ my ($slf, $lck) = @_;
  my ($ctl, $pid);

  # Wait until the thread lock can be get
  if (ref($ctl = _get_lock($slf)))
  { $ctl->wait;
    $ctl->lock($lck) if $lck;
  }
  return;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Collect|RDA::Object::Collect>,
L<RDA::Object::Content|RDA::Object::Content>,
L<RDA::Object::Item|RDA::Object::Item>,
L<RDA::Object::Log|RDA::Object::Log>,
L<RDA::Object::Lock|RDA::Object::Lock>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Request::PACKAGE|RDA::Request::PACKAGE>,
L<RDA::Request::RDA|RDA::Request::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