File Coverage

blib/lib/Siebel/Srvrmgr/Daemon.pm

Criterion	Covered	Total	%
statement	144	191	75.3
branch	42	90	46.6
condition	12	15	80.0
subroutine	26	31	83.8
pod	10	10	100.0
total	234	337	69.4

package Siebel::Srvrmgr::Daemon;

=pod

=head1 NAME

Siebel::Srvrmgr::Daemon - super class for sessions with Siebel srvrmgr program

=head1 SYNOPSIS

    package MyDaemon;
    extends 'Siebel::Srvrmgr::Daemon';

=head1 DESCRIPTION

This is a super class, and alone it does not provide any functionaly to use srvrmgr to send commands and process returned data.

The "private" method C<_setup_commands> must be overrided by subclasses of it or commands will not be sent to C<srvrmgr>.

Logging of this class can be enabled by using L<Siebel::Srvrmgr> logging feature.

The logic behind this class is easy: you can submit a pair of command/action to the class. It will then connect to the server by executing C<srvrmgr>, submit the command
to the server and recover the output generated. The action will be executed having this output as parameter. Anything could be considered as an action, from simple
storing the output to even generating new commands to be executed in the server.

A command is an instance of L<Siebel::Srvrmgr::Daemon::Command> class. Any "list" command is supported, and also C<load preferences> and C<exit>. Anything else
is considered dangerous and will generated an exception. Beware that you will need to have an L<Siebel::Srvrmgr::ListParser::Output> class available to be
able to parse the command output.

An action can be any class but is obligatory to create a subclass of L<Siebel::Srvrmgr::Daemon::Action> base class. See the <commands>
attribute for details.

Implementation details are reserved to subclasses of Siebel::Srvrmgr::Daemon: be sure to check them for real usage cenarios.

=cut

use Moose 2.0401;
use Siebel::Srvrmgr::Regexes qw(SIEBEL_ERROR);
use Siebel::Srvrmgr::ListParser;
use Siebel::Srvrmgr;
use Scalar::Util qw(weaken blessed);
use Siebel::Srvrmgr::Types;
use Fcntl ':flock';    # import LOCK_* constants
use Config;
use Carp;
use File::Spec;
use Data::Dumper;

our $VERSION = '0.29'; # VERSION

my $SIG_INT   = 0;
my $SIG_PIPE  = 0;
my $SIG_ALARM = 0;

# :TODO      :19/08/2013 16:19:19:: enable Taint Mode

=pod

=head1 ATTRIBUTES

=head2 commands

An array reference containing one or more references of L<Siebel::Srvrmgr::Daemon::Commands> class.

The commands will be executed in the exactly order as given by the indexes in the array reference (as FIFO).

This is a required attribute during object creation with the C<new> method.

=cut

has commands => (
    isa      => 'ArrayRef[Siebel::Srvrmgr::Daemon::Command]',
    is       => 'rw',
    required => 1,
    reader   => 'get_commands',
    writer   => 'set_commands',
    trigger  => sub { my $self = shift; $self->_setup_commands() }
);

=pod

=head2 time_zone

Required attribute.

A string representing the time zone to be considered for all date/time values recovered from C<srvrmgr>.

See L<DateTime::TimeZone> C<all_names> methods to list the available time zones that you can use. The on-liner
below will show you them so you can find a proper value:

    perl -MDateTime::TimeZone -e 'foreach ( DateTime::TimeZone->all_names ) { print "$_\n" }'

=cut

has time_zone =>
  ( isa => 'Str', is => 'ro', required => 1, reader => 'get_time_zone' );

=pod

=head2 alarm_timeout

An integer value that will raise an ALARM signal generated by C<alarm>. The default value is 30 seconds. This is avoid leaving
the daemon blocking forever waiting for something to read.

This attribute will be reset every time a read can be done from the STDOUT or STDERR from srvrmgr.

=cut

has alarm_timeout => (
    is      => 'Int',
    is      => 'rw',
    writer  => 'set_alarm',
    reader  => 'get_alarm',
    default => 30
);

=pod

=head2 use_perl

A boolean attribute used mostly for testing of this class.

If true, if will prepend the complete path of the Perl interpreter to the parameters before calling the C<srvrmgr> program (of course the "srvrmgr" must
be itself a Perl script).

It defaults to false.

=cut

has use_perl =>
  ( isa => 'Bool', is => 'ro', reader => 'use_perl', default => 0 );

=head2 child_runs

An integer representing the number of times the child object was used in C<run> invocations. This is reset to zero if a new child process is created.

=cut

has child_runs => (
    isa     => 'Int',
    is      => 'ro',
    reader  => 'get_child_runs',
    writer  => '_set_child_runs',
    default => 0
);

=head2 clear_raw

A boolean attribute that defines if the raw data recovered from C<srvrmgr> should be kept or discarded as soon as possibly.

Having a default value of true, it should help reducing memory usage or debugging, if set false.

=cut

has clear_raw => (
    is      => 'rw',
    isa     => 'Bool',
    reader  => 'clear_raw',
    writer  => 'set_clear_raw',
    default => 1
);

=head2 has_lock

Optional parameter.

This is a boolean attribute (in the sense of Perl) that identifies if the L<Daemon> needs to use a lock or not. Default is false.

Using a lock is useful to avoid two instances of the same C<Daemon> running. See also C<lock_dir> attribute.

=cut

has has_lock => ( is => 'ro', isa => 'Bool', default => 0 );

=head2 lock_dir

Optional parameter.

This parameter is used to determine the location in the filesystem to create the lock file.

Expects a string as parameter. The directory must be readable and writable to the user running the C<Daemon>.

It defaults to the "home" directory of the user. The sense of "home" is the following as defined by the platform:

This attribute is lazy and defined by the C<_define_lock_dir> "private" method.

=over

=item *

Microsoft Windows: C<$ENV{HOMEDIR}>

=item *

UNIX-like: C<$ENV{HOME}>

=back

=cut

has lock_dir => (
    is      => 'rw',
    isa     => 'Str',
    reader  => 'get_lock_dir',
    writer  => 'set_lock_dir',
    lazy    => 1,
    builder => '_define_lock_dir'
);

=pod

=head2 cmd_stack

This is an array reference with the stack of commands to be executed. It is maintained automatically by the class, so the attribute is read-only.

=cut

has cmd_stack => (
    isa    => 'ArrayRef',
    is     => 'ro',
    writer => '_set_cmd_stack',
    reader => 'get_cmd_stack'
);

=pod

=head1 METHODS

=head2 get_time_zone

Returns the content of the attribute C<time_zone>.

=head2 get_cmd_stack

Returns the content of the attribute C<cmd_stack>.

=head2 clear_raw

Getter for the C<clear_raw> attribute.

=head2 set_clear_raw

Setter for the C<clear_raw> attribute.

=head2 get_alarm

Returns the content of the C<alarm_timeout> attribute.

=head2 set_alarm

Sets the attribute C<alarm_timeout>. Expects an integer as parameter, in seconds.

=head2 get_child_runs

Returns the value of the attribute C<child_runs>.

=head2 use_perl

Returns the content of the attribute C<use_perl>.

=head2 get_buffer_size

Returns the value of the attribute C<ipc_buffer_size>.

=head2 set_buffer_size

Sets the attribute C<ipc_buffer_size>. Expects an integer as parameter, multiple of 1024.

=head2 get_commands

Returns the content of the attribute C<commands>.

=head2 set_commands

Set the content of the attribute C<commands>. Expects an array reference as parameter.

=head2 get_pid

Returns the content of C<pid> attribute as an integer.

=head2 BUILD

L<Moose> BUILD method is used by this class to install signal handlers for the following signals:

=over

=item *

INT

=item *

PIPE

=item *

ALRM

=back

Also the method sets the environment variable C<SIEBEL_TZ> if a time zone was set.

If the logging is set to C<DEBUG> level all attribute values will be logged.

=cut

sub BUILD {
    my $self = shift;
    $SIG{INT}  = sub { $SIG_INT   = 1 };
    $SIG{PIPE} = sub { $SIG_PIPE  = 1 };
    $SIG{ALRM} = sub { $SIG_ALARM = 1 };
    $ENV{SIEBEL_TZ} = $self->get_time_zone();

    my $logger = Siebel::Srvrmgr->gimme_logger( blessed($self) );

    if ( $logger->is_debug() ) {
        $logger->debug('This instance attributes values:');

        foreach my $attrib ( $self->meta->get_all_attributes() ) {
            my $getter = $attrib->get_read_method();
            my $value  = $self->$getter;
            $value = 'UNDEFINED' unless ( defined($value) );

            if ( ref($value) ne '' ) {
                $logger->debug(
                    'attribute ' . $attrib->name() . ' = ' . Dumper($value) );
            }
            else {
                $logger->debug(
                    'attribute ' . $attrib->name() . ' = ' . $value );
            }

        }

    }

}

=head2 cmds_vs_tree

This method compares the number of C<commands> defined in a instance of this class with the number of nodes passed as parameter.

If their are equal, the number is returned. If their are different (and there is a problem with the parsed output of srvrmgr) this method
returns C<undef>.

=cut

sub cmds_vs_tree {
    my ( $self, $nodes_num ) = @_;
    my $cmds_num = scalar( @{ $self->get_commands() } );

    if ( $cmds_num == $nodes_num ) {
        return $nodes_num;
    }
    else {
        return;
    }

}

=head2 check_cmd

This methods expects as parameter a string representing a C<srvrmgr> command.

The command will be checked and if considered insecure, an exception will be raised.

Commands considered secure are:

=over

=item *

load preferences

=item *

list <anything>

=item *

exit

=item *

set delimiter

=back

This method is also used internally through the C<_setup_commands> method.

=cut

sub check_cmd {
    my ( $self, $cmd ) = @_;
    confess( 'Invalid command received for execution: '
          . Dumper( $self->get_cmd_stack() ) )
      unless ( defined($cmd) );
    confess("Insecure command from command stack [$cmd]. Execution aborted")
      unless ( ( $cmd =~ /^load/ )
        or ( $cmd =~ /^list/ )
        or ( $cmd =~ /^set\sdelimiter\s[[:graph:]]/ )
        or ( $cmd =~ /^exit/ ) );
    return 1;
}

=pod

=head2 shift_command

Does a C<shift> in the C<commands> attribute.

Does not expects any parameter. Returns the C<shift>ed L<Siebel::Srvrmgr::Daemon::Command> instance or C<undef> if there is only B<one>
command left (which is not C<shift>ed).

This method is useful specially if the Daemon will keep executing commands, but setup commands (like C<load preferences>) are not necessary to be executed
again.

=cut

sub shift_command {
    my $self     = shift;
    my $cmds_ref = $self->get_commands();

    if ( scalar( @{$cmds_ref} ) > 1 ) {
        my $shifted = shift( @{$cmds_ref} );
        $self->set_commands($cmds_ref);    # must trigger the attribute
        return $shifted;
    }
    else {
        $self->set_commands( [] );         # must trigger the attribute
        return;
    }

}

=pod

=head2 push_command

Does a C<push> in the C<commands> attribute.

Expects as parameter a L<Siebel::Srvrmgr::Daemon::Command> instance.

=cut

sub push_command {
    my ( $self, $command ) = @_;
    confess 'must received a Siebel::Srvrmgr::Daemon::Command as parameter'
      unless ( blessed($command) eq 'Siebel::Srvrmgr::Daemon::Command' );
    my $cmds_ref = $self->get_commands();
    push( @{$cmds_ref}, $command );
    $self->set_commands($cmds_ref);    # must trigger the attribute
}

=pod

=head2 run

This is the method used to execute commands in srvrmgr program and must be overrided by subclasses of Siebel::Srvrmgr::Daemon.
Subclasses should invoke L<Moose> C<super> to when doing override because this implementation will apply lock control when appropriate.
Expects as parameters a L<Siebel::Srvrmgr::Connection>, or it will C<confess> with an exception.

=cut

sub run {
    my ( $self ) = @_;
    # :TODO:11-12-2016 20:43:19:: wtf is this?
#    my $class = blessed($self);
#
#    if ( defined($class) ) {
#        confess
#"Only subclasses of Siebel::Srvrmgr::Daemon can executed this method (received '$class')"
#          unless ( $self->isa('Siebel::Srvrmgr::Daemon') );
#    }
#    else {
#        confess
#"Only subclasses of Siebel::Srvrmgr::Daemon can executed this method (received unblessed '$self')";
#    }

    if ( $self->has_lock ) {
        $self->_create_lock;
    }

}

=pod

=head2 normalize_eol

Expects an array reference as parameter.

Changes any EOL character to LF from each index value.

See perlport -> Issues -> Newlines for details on this.

=cut

sub normalize_eol {
    my ( $self, $data_ref ) = @_;
    my $ref_type = ref($data_ref);
    confess 'data parameter must be an array or scalar reference'
      unless ( ( $ref_type eq 'ARRAY' ) or ( $ref_type eq 'SCALAR' ) );
    my $c_regex = qr/\o{15}?\o{12}/;

    if ( $ref_type eq 'ARRAY' ) {
        local $/ = "\o{12}";

        foreach ( @{$data_ref} ) {
            s/$c_regex/\n/g;
        }

    }
    else {
        $$data_ref =~ s/$c_regex/\n/g;
    }

}

=pod

=head2 create_parser

Returns an instance of a L<Siebel::Srvrmgr::ListParser> class.

Optionally, it can receive as parameter a string representing the field delimiter that is expected. If received,
the parameter will be used to create the instance.

=cut

sub create_parser {
    my ( $self, $delimiter ) = @_;

    if ( defined($delimiter) ) {
        return Siebel::Srvrmgr::ListParser->new(
            {
                clear_raw       => $self->clear_raw(),
                field_delimiter => $delimiter
            }
        );
    }
    else {
        return Siebel::Srvrmgr::ListParser->new(
            { clear_raw => $self->clear_raw() } );
    }

}

# :WORKAROUND:06/08/2013 21:05:32:: if a perl script will be executed (like for automated testing of this distribution)
# then the perl interpreter must be part of the command path to avoid calling cmd.exe in Microsoft Windows
sub _define_params {
    my ( $self, $params_ref ) = @_;
    unshift( @{$params_ref}, $Config{perlpath} ) if ( $self->use_perl() );
    return $params_ref;
}

=head2 get_lock_file

Returns the complete path to the lock file as a string.

=cut

sub get_lock_file {
    my $self     = shift;
    my $filename = blessed($self);
    $filename =~ s/\:{2}/_/g;
    return File::Spec->catfile( $self->get_lock_dir, ( $filename . '.lock' ) );
}

our $adm_60070    = qr/^SBL-ADM-60070.*/;
our $adm_02043    = qr/^SBL-ADM-02043.*/;
our $adm_02071    = qr/^SBL-ADM-02071.*/;
our $adm_02049    = qr/^SBL-ADM-02049.*/;
our $adm_02751    = qr/^SBL-ADM-02751.*/;
our $siebel_error = SIEBEL_ERROR;

# Fatal error (2555922): (null), exiting...
our $fatal_error = qr/Fatal error.*exiting\.\.\./;

# this method will check for errors and warnings, specially if read from STDERR.
# the first parameter is the data to be check, which can be an array reference or scalar, both will be checked the same way
# the seconds parameter tells if the data was read from STDERR or not. If read from STDERR, data will be logged as warnings
# if no critical error was detected
sub _check_error {

    my $self     = shift;
    my $content  = shift;
    my $is_error = shift;    #boolean

    my $logger = Siebel::Srvrmgr->gimme_logger( blessed($self) );

# :WORKAROUND: to enable the code to process both scalar and array reference data
# without duplicating code

    unless ( ref($content) eq 'ARRAY' ) {

        my $temp = $content;
        $content = [$temp];

    }

    foreach my $line ( @{$content} ) {

        if ( $line =~ $fatal_error ) {

            $logger->logdie("Failed to connect to: [$line]");

        }

        if ( $line =~ $siebel_error ) {

          SWITCH: {

                if ( $line =~ $adm_60070 ) {

                    if ( $logger->is_warn() ) {

                        $logger->warn(
"Found [$line]. Trying to get additional information from next line"
                        );
                        return 1;

                    }
                }

                if ( $line =~ $adm_02043 ) {
                    $logger->logdie('Could not find the Siebel Server');
                }

                if ( $line =~ $adm_02071 ) {
                    $logger->logdie('Could not find the Siebel Enterprise');
                }

                if ( $line =~ $adm_02049 ) {
                    $logger->logdie('Generic error');
                }

                if ( $line =~ $adm_02751 ) {
                    $logger->logdie('Unable to open file');
                }
                else {
                    $logger->logdie(
                        "Unknown error [$line], aborting execution");
                }

            }

        }
        else {

            $logger->debug(
"Got $line. Since it doesn't look like a Siebel error, I will try to keep running"
            ) if ( $logger->is_debug );

            $logger->warn($line) if ( $logger->is_warn() and $is_error );

            return 1;

        }

    }

}

=pod

=head2 DEMOLISH

This method is invoked before the object instance is destroyed. It does really few things like writting messages to the define configuration of
L<Log::Log4perl> logger. It will also log if ALRM, INT or PIPE signals were received.

Subclasses may want to C<override> the method "private" C<_my_cleanup> to do their properly laundry since the definition of C<_my_cleanup> for this class
is just to C<return> true. C<_my_cleanup> is called with a reference of a L<Log::Log4perl::Logger> instance for usage.

=cut

sub DEMOLISH {
    my $self = shift;
    my $logger = Siebel::Srvrmgr->gimme_logger( blessed($self) );
    $logger->info('Terminating daemon: preparing cleanup');
    $self->_my_cleanup();

    if ( $self->has_lock() ) {
        $self->_del_lock();
    }

    $logger->info('Cleanup is finished');

    if ( $logger->is_warn() ) {
        $logger->warn('Program termination was forced by ALRM signal')
          if ($SIG_ALARM);
        $logger->warn('Program termination was forced by INT signal')
          if ($SIG_INT);
        $logger->warn('Program termination was forced by PIPE signal')
          if ($SIG_PIPE);
    }

    $logger->info( ref($self) . ' says bye-bye' ) if ( $logger->is_info() );
    Log::Log4perl->remove_logger($logger);
}

=head1 CONSTANTS

The following constants are available in this class:

=over

=item LOCK_EX

=item LOCK_NB

=back

All of them from the L<Fcntl> module.

=cut

sub _create_lock {
    my $self = shift;
    my $logger = Siebel::Srvrmgr->gimme_logger( blessed($self) );
    my $lock_file = $self->get_lock_file;

    if ( -e $lock_file ) {
        open( my $in, '<', $lock_file )
          or $logger->logdie("Cannot read $lock_file: $!");
        flock( $in, LOCK_EX | LOCK_NB )
          or $logger->logdie("Could not get exclusive lock on $lock_file: $!");
        local $/ = undef;
        my $pid = <$in>;
        close($in);

        $logger->logdie(
            "Previous executing is still running (PID $pid), cannot execute")
          if ( $pid != $$ );

    }
    else {
        open( my $out, '>', $lock_file )
          or $logger->logdie("Cannot create $lock_file: $!");
        flock( $out, LOCK_EX | LOCK_NB )
          or $logger->logdie("Could not get exclusive lock on $lock_file: $!");
        print $out $$;
        close($out);
    }

}

sub _del_lock {
    my $self      = shift;
    my $lock_file = $self->get_lock_file;
    my $logger = Siebel::Srvrmgr->gimme_logger( blessed($self) );

    if ( -e $lock_file ) {
        unlink($lock_file)
          or $logger->logdie("Could not remove $lock_file: $!");
    }
    else {
        $logger->warn(
            'Could not find lock file to remove before program termination');
    }

}

sub _my_cleanup {

    return 1;

}

sub _define_lock_dir {

    my $lock_dir = undef;

  CASE: {

        if ( $Config{osname} =~ /^linux$/i ) {

            $lock_dir = $ENV{HOME};
            last CASE;

        }

        if ( $Config{osname} =~ /^aix$/i ) {

            $lock_dir = $ENV{HOME};
            last CASE;

        }

        if ( $Config{osname} =~ /^hpux$/i ) {

            $lock_dir = $ENV{HOME};
            last CASE;

        }

        if ( $Config{osname} =~ /^mswin32$/i ) {

            if ( defined( $ENV{HOMEDIR} ) ) {

                $lock_dir = $ENV{HOMEDIR};

            }
            else {

                $lock_dir = $ENV{USERPROFILE};

            }

            last CASE;

        }

        if ( $Config{osname} =~ /^solaris$/i ) {

            $lock_dir = $ENV{HOME};
            last CASE;

        }
        else {

            confess "don't know what to do with $Config{osname}";

        }

    }

    confess "could not defined a lock_dir for $Config{osname}"
      unless ( defined($lock_dir) );

    return $lock_dir;

}

sub _setup_commands {
    my $self = shift;

    foreach my $cmd ( @{ $self->get_commands } ) {
        $self->check_cmd( $cmd->get_command() );
    }

}

=pod

=head1 SEE ALSO

=over

=item *

L<Moose>

=item *

L<Siebel::Srvrmgr::Daemon::ActionFactory>

=item *

L<Siebel::Srvrmgr::ListParser>

=item *

L<Siebel::Srvrmgr::Regexes>

=item *

L<POSIX>

=item *

L<Siebel::Srvrmgr::Daemon::Command>

=item *

L<Fcntl>

=back

=head1 AUTHOR

Alceu Rodrigues de Freitas Junior, E<lt>[e-mail]<gt>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2012 of Alceu Rodrigues de Freitas Junior, E<lt>[e-mail]<gt>

This file is part of Siebel Monitoring Tools.

Siebel Monitoring Tools is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

Siebel Monitoring Tools is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with Siebel Monitoring Tools.  If not, see <http://www.gnu.org/licenses/>.

=cut

__PACKAGE__->meta->make_immutable;

1;