# Period.pm: Class Regrouping Common Period-Based Collection Methods

package RDA::Limit::Period;

# $Id: Period.pm,v 1.6 2015/11/13 15:54:14 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Limit/Period.pm,v 1.6 2015/11/13 15:54:14 RDA Exp $
#
# Change History
# 20151113  MSC  Modify Timing handle creation.

=head1 NAME

RDA::Limit::Period - Class Regrouping Common Period-Based Collection Methods

=head1 SYNOPSIS

 require RDA::Limit::Period;

=head1 DESCRIPTION

The C<RDA::Limit::Period> class regroups common methods for collections based
on a time period.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use RDA::Text qw(get_string);
  use RDA::Handle::Timing;
  use RDA::Limit::Common;
  use RDA::Object::Buffer;
  use RDA::Object::Timing qw(%TB_MON);
  use RDA::Object::View;
  use Time::Local qw(timegm timelocal);
}

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

# Define the global private constants
my %tb_dft = (
  h   => 2,
  m   => 1,
  s   => 0,
  D   => 3,
  M   => 4,
  Y   => 5,
  );
my %tb_rul = (
  hh   => [2,     0],
  mi   => [1,     0],
  ss   => [0,     0],
  DD   => [3,     0],
  MM   => [4,    -1],
  MON  => [4,    -1, sub {return $TB_MON{lc($_[0])}}],
  YY   => [5,   100],
  YYYY => [5, -1900],
  );
my %tb_tim = (
  ## no critic (Interpolation)
  chk_gmtime    => [0, '$tim->check_time(timegm(@tim))'],
  chk_localtime => [1, '$tim->check_time(timelocal(@tim))'],
  );

# Define the global private variables

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

=head2 S<$h-E<gt>get_file_limit($context)>

This methods defines the approach for selecting file based on its last
modification time included in a time period.

=cut

sub get_file_limit
{ my ($slf, $ctx) = @_;
  my ($ctl, $def);

  # Use a time extracted from the file path as criteria
  return (sub { my ($blk, $fil, $tim) = @_;
                my ($ref, $ret, $val, @pth, @tim);

                return 0 unless (@pth = ($fil =~ $ctl->{'pat'}));
                @tim = @{$ctl->{'dft'}};
                foreach my $rul (@{$ctl->{'rul'}})
                { if (!defined($rul->[3]))
                  { $tim[$rul->[1]] = $pth[$rul->[0]] + $rul->[2];
                  }
                  elsif (($ref = ref($rul->[3])) eq 'CODE')
                  { $tim[$rul->[1]] = $val + $rul->[2]
                      if defined($val = &{$rul->[3]}($pth[$rul->[0]]));
                  }
                  elsif ($ref eq 'HASH')
                  { $tim[$rul->[1]] = $val + $rul->[2]
                      if defined($val = $rul->[3]->{$pth[$rul->[0]]});
                  }
                }
                $ret = eval $ctl->{'exe'};  ## no critic (Eval)
                return $@ || $ret == 0;
              },
          $slf->{'_tim'})
    if defined($def = eval {$slf->get_hash($ctx, 'pth')})
    && defined($ctl = _gen_pth_control($def));

  # Use the last modification date as criteria
  return (sub { my ($blk, $fil, $tim) = @_;
                my (@sta);

                return 0 unless (@sta = stat($fil));
                $blk->check_stat($fil, @sta);
                return $tim->check_time($sta[9]) == 0;
              },
          $slf->{'_tim'});
}

sub _gen_pth_control
{ my ($def) = @_;
  my ($ctl, $off, @dft);

  $ctl = {dft => [0, 0, 0, 0, 0, 100]};
  return unless
    defined($ctl->{'pat'} = RDA::Object::View->is_pattern($def->{'pat'}, 1)) &&
    exists($def->{'fmt'}) &&
    $def->{'fmt'} =~ m{^(\w+)=(\w*(?:/\w*)*)(:([YMDhms]+))?$} &&
    exists($tb_tim{$1});
  ($ctl->{'loc'}, $ctl->{'exe'}) = @{$tb_tim{$1}};
  if ($3)
  { @dft = $ctl->{'loc'} ? localtime : gmtime;
    foreach my $dft (unpack('a*', $4))
    { return unless exists($tb_dft{$dft});
      $ctl->{'dft'}->[$tb_dft{$dft}] = $dft[$tb_dft{$dft}];
    }
  }
  $off = 0;
  foreach my $rul (split(/\//, $2))
  { if (exists($tb_rul{$rul}))
    { push(@{$ctl->{'rul'}}, [$off, @{$tb_rul{$rul}}]);
    }
    elsif (length($rul))
    { return;
    }
    ++$off;
  }
  return exists($ctl->{'rul'}) ? $ctl : undef;
}

=head2 S<$h-E<gt>open_alert_log($file[,$vms])>

This methods returns a buffer on the specified alert log file. It returns an
undefined value in case of errors.

=cut

sub open_alert_log
{ my ($slf, $fil, $flg) = @_;
  my ($hnd);

  return ($hnd = RDA::Handle::Timing->new($fil, $slf->{'_tim'},
    ($fil =~ m/\.xml$/) ? \&_check_xml :
    $flg                ? \&_check_vms :
                          \&_check_db))
    ? RDA::Object::Buffer->new('B', $hnd, $fil)
    : undef;
}

=head2 S<$h-E<gt>open_listener_log($file)>

This methods returns a buffer on the specified listener log file. It returns an
undefined value in case of errors.

=cut

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

  return ($hnd = RDA::Handle::Timing->new($fil, $slf->{'_tim'},
    ($fil =~ m/\.xml$/) ? \&_check_xml :
                          \&_check_db))
    ? RDA::Object::Buffer->new('B', $hnd, $fil)
    : undef;
}

# --- Check routines ----------------------------------------------------------

# Extract and check DB time stamp
#  Wed Sep 26 11:34:02 2012
sub _check_db
{ my ($slf, $buf, $dft) = @_;

  return
    ($buf =~ m/^((Mon|Tue|Wed|Thu|Fri|Sat|Sun)\s.*?\d{4})/mo)
    ? *$slf->{'tim'}->check_db($1)
    : $dft;
}

# Extract and check VMS DB time stamp
#   16-FEB-2006 10:31:05.95:
sub _check_vms
{ my ($slf, $buf, $dft) = @_;

  return
    ($buf =~ m/^\s?(\d{1,2}-[A-Za-z]{3}-\d{4}\s+\d{2}:\d{2}:\d{2})\.\d+:/mo)
    ? *$slf->{'tim'}->check_db($1)
    : $dft;
}

# Extract and check XML time stamp
#   <msg time='2012-09-26T11:34:02.534+05:30' ...
sub _check_xml
{ my ($slf, $buf, $dft) = @_;

  return ($buf =~ m/^<msg time='(.*?)'/mo)
    ? *$slf->{'tim'}->check_odl($1)
    : $dft;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Limit::Common|RDA::Limit::Common>,
L<RDA::Object::Buffer|RDA::Object::Buffer>,
L<RDA::Object::Limit|RDA::Object::Limit>,
L<RDA::Object::Timing|RDA::Object::Timing>,
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