#
# Copyright (c) 2001-2014 NetApp, Inc., All Rights Reserved
#   Any use, modification, or distribution is prohibited
#   without prior written consent from NetApp, Inc.
#

## @summary Cleanup Manager
## @author dl-nacl-dev@netapp.com
## @status shared
## @pod here

=head1 NAME

NACL::Cleanup

=head1 DESCRIPTION

The C<NACL::Cleanup> subsystem provides an interface to easily undo operations
performed by the script, so that once the script/test-case completes, the
testbed is returned to its original state. C<NACL::Cleanup> takes care of
registering elements to be cleaned up and performing the appropriate action
to clean them up.

=head1 SYNOPSIS


There are multiple ways of using the cleanup manager:

1) Automatically register for cleanup

    sub init {
        ...
        $Cleanup_Obj = NACL::Cleanup->new(random_db => 1);
        $Cleanup_Obj->set_as_private_singleton();
        NACL::Cleanup->enable();
    }
    
    sub tc1 {
        ...
        # Gets automatically registered for cleanup
        NACL::STask::Aggregate->create(...);
    }
    
    sub tc2 {
        ...
        # Gets automatically registered for cleanup
        NACL::STask::Volume->create(...);
    }
    
    sub cleanup {
        ...
        # Both the aggregate and volume get purged
        $Cleanup_Obj->run();
    }

By using the C<enable> method, all tasks that support cleanup automatically
get registered for cleanup. With this call, it is not necessary to pass
any additional cleanup options in the STask calls for the elements to get
registered for cleanup. Using C<set_as_private_singleton> is necessary to
specify the cleanup manager object the elements should get registered to.

2) Explicitly specify which elements should be registered

    sub init {
        ...
        $Cleanup_Obj = NACL::Cleanup->new(random_db => 1);
        $Cleanup_Obj->set_as_private_singleton();
    }
    
    sub tc1 {
        ...
        # Gets registered for cleanup
        NACL::STask::Aggregate->create(..., nacltask_cleanup_manager => $Cleanup_Obj);
    }
    
    sub tc2 {
        ...
        # Since nacltask_cleanup_manager/nacltask_to_cleanup are not specified,
        # this does NOT get registered for cleanup
        NACL::STask::Volume->create(...);
    }
    
    sub cleanup {
        ...
        # Only the aggregate gets purged, since only that was registered.
        $Cleanup_Obj->run();
    }

=head2 new

Instantiates a new Cleanup object.
Will create a new resource list.

=over

=item Synopsis

# Create a new Cleanup DB with a random name
    my $CObj = NACL::Cleanup->new( random_db => 1 );

    # Explicitly supply the name of the Cleanup DB to use. It is recommended
    # to use the above "random_db" form where possible.
    my $CObj = NACL::Cleanup->new( db_name => $name_of_db );

    # This form is B<DEPRECATED>
    # Calling new() with no options returns a reference to a Cleanup DB
    # which is global to the entire ntest run. This is deprecated because
    # when scripts are run in parallel, it will result in scripts cleaning
    # up elements of other scripts. It is recommended to use either of the
    # above two forms of the call.
    my $cleanup_obj = NACL::Cleanup->new();


=item Exceptions Thrown

=over

=item NATE::BaseException

Throws this exception in the event that, there is a problem in reading the
requested DB ResourceList file. This is also thrown when any DBI calls fail.

=back

=item Examples

  my $CObj = NACL::Cleanup->new();

If NATE_DB_DRIVER is a sqlite, creates a new resource list located at "$LOGDIR/resourceList.db".
If NATE_DB_DRIVER is a mysql, creates a new database with the name resourceList".

- or -

  my $CObj = NACL::Cleanup->new( db_name => "myresourcelist.db" );

If NATE_DB_DRIVER is a sqlite, creates a new resource list located at "$LOGDIR/myresourcelist.db.db".
If NATE_DB_DRIVER is a mysql, creates a new database with the name myresourcelist.db".
=item Arguments

=over

=item C<< db_name >>

(Optional) Name of ResourceList database.  Defaults to "resourceList/resourceList.db".

=item C<< random_db >>

(Optional) If this attribute is passed a value "1", library will generate resource
database with a random, unique name in the logdirectory. It will also make sure 
there does not exists a file already with the generated random name.

=back

=over

=item C<< MySQL specific parameters >>

=over

=item C<<port>>

The port number to use for the connection to MySQL DB.

=item C<<host>>

Name of the host where the MySQL server is running.

=item C<<user>>

The user name used to connect to MySQL.

=item C<<password>>

The password name used to connect to MySQL.

=back

=back

=back

=head2 register

(Instance method) Inserts the data into various tables.

Example:

    $resource_obj->register(
        command     => $command_data,
        package     => $package_data,
        primary_key => $primady_keys_data,
        host        => $host_data,
        group       => $group_data,
        argument    => $argument_data,
    );

=over

=item Options

=over

=item C<< command >>

(Required) Reference to an hash having data for "command" table.

=item C<< package >>

(Required) Reference to an hash having data for "package" table.

=item C<< primary_key >>

(Required) Reference to an hash having data for "primary_key" table.

=item C<< host >>

(Required) Reference to an hash having data for "host" table.

=item C<< group >>

(Optional) Reference to an hash having data for "group" table.

=item C<< argument >>

(Optional) Reference to an hash having data for "argument" table.

=back

=item Exceptions thrown

=over

=item NATE::BaseException

Throws this exception in the event any of the DBI calls fail.

=back

=back

=cut

package NACL::Cleanup;

use strict;
use warnings;

use NACL::Cleanup::Database;
use Params::Validate qw(validate validate_with  :types);
use NATE::Log qw(log_global);
my $Log = log_global();
my $may_enter = $Log->may_enter();
my $may_exit  = $Log->may_exit();
use NATE::BaseException qw(:try);
use NACL::ComponentUtils qw(Dumper);
use NATE::ParamSet qw(param_global);
use NACL::Exceptions::CleanupFailed qw(:try);
use NACL::GeneralUtils qw(random_name_generator);
use Scalar::Util qw(blessed);
use Storable qw(thaw);
use File::Spec;
use Encode qw(decode_utf8 encode_utf8);
my $nate_params = NATE::ParamSet::param_global;

use Class::MethodMaker [
    new    => [ '-init', 'new' ],
    scalar => [
        { '-static' => 1, '-default_ctor' => \&_get_default_db_name }, 'dsn'
    ],
    scalar => [
        {-static => 1},
        '_cleanup_enabled'
    ],
    scalar => [{ -type => 'NACL::Cleanup::Database' }, 'db' ],
    scalar => 'random_db',
];

sub init {
    $Log->enter() if $may_enter;
    my $self = shift;
    my %opts = validate_with(
        params => \@_,
        spec   => {
            %{ $self->_cleanup_validate_spec() },
            'db_name'  => { type => SCALAR, default => $self->dsn() },
        },
        allow_extra => 1
    );
    my $db = NACL::Cleanup::Database->new( %opts );
    $self->db($db);
    $Log->exit() if $may_exit;
}
=head2 enable

This enables automatic registration of elements for cleanup. This means that
all subsequent calls to STask methods that are cleanup-supported will
automatically register for cleanup without needing to supply
nacltask_cleanup_manager/nacltask_to_cleanup in the STask call.

    NACL::Cleanup->enable();

    # All these calls register for cleanup
    NACL::STask::Volume->create();
    NACL::STask::Vserver->create();
    ...
    
    # This can be disabled by calling disable().
    NACL::Cleanup->disable();

=cut

sub enable {
    $Log->enter() if $may_enter;
    my ($pkg) = @_;
    $pkg->_cleanup_enabled(1);
    $Log->exit() if $may_exit;
}

=head2 disable

    NACL::Cleanup->disable();

Disable automatic cleanup registration.

=cut

sub disable {
    $Log->enter() if $may_enter;
    my ($pkg) = @_;
    $pkg->_cleanup_enabled(0);
    $Log->exit() if $may_exit;
}


=head2 run

  Iterates through the elements stored in the resource database and does the 
  cleanup on those elements. The cleanup of the registered elements happens 
  by identifying the dependencies of the elements and executing the cleanup 
  in the top to down order through the hierarchy.

  e.g. If the Resource database has entries for aggregates and volumes, the
  dependencies will be identified, which indicates that volumes depend on
  vservers. If the vservers registered for cleanup, first all the volumes 
  belonging to a vserver are cleaned up before running cleanup on vserver.

=over

=item Exceptions Thrown

=over

=item NATE::BaseException

Throws this exception if any of the DBI calls fail,
if any of the libraries required are not present for loading or
if any other errors were encountered during cleanup.

=item NACL::Exceptions::CleanupFailed

This exception will be thrown when cleanup fails to run on some or all the
elements registered for cleanup. In addition to the attributes 
that exception  generally contain, this exception 
also contains an additional attribute called C<cleanup_failed_for>.
This is an array reference, which will hold all the  
for which the cleanup failed along with the exception object  
for each of those failures.

for more details on this exception, please refer to L<NACL::Exceptions::CleanupFailed|lib-NACL-Exceptions-CleanupFailed-pm>

=back

=item Examples

  Typical use is in a TCD test script.
  Place the run in the cleanup block of the TCD test script.

  use TCD;
  ...
  sub cleanup {
    $Cleanup_Obj->run();
  }

=item Arguments

=over

=item C<< continue_on_failure >>

(Optional default: 1) 
When this option is enabled, cleanup subsystem will try to do cleanup for all the
registered elements and at the end it throws NACL::Exceptions::CleanupFailed exception 
if there are any failures.

When this options is set to '0', throws the exception which gets thrown by underlying 
layers when it encounters the first failure.

=item C<< delete_resource_on_cleanup >>

(Optional) Delete the resource from the list once cleanup is done.
Defaults to 1.


=item C<< max_connection_retry_count >>

(Optional, default 5)
Retry count for connection when running the cleanup methods, if the 
"continue_on_failure" is set to 1.
Note: If it fails to connect even after the max_connection_retry_count,
      library will not throw any exception but continues. Also, the object
      entry from the resource db is not removed.

=item C<< connection_retry_interval >>

(Optional, default 5 seconds)
Time interval between each retry for connection when running the cleanup methods. 
Option is in effect only if "continue_on_failure" is set to 1.

=item C<< mcc_config_check => 0|1 >>

If specified as 1, then check for MCC config diffs before running cleanup.
L<< NACL::STask::Vserver->config_diff|lib-NACL-STask-Vserver-pm/config_diff >>
is used for this. If there are config diffs, or if the MCC queues did not
drain in time, then a C<NACL::STask::Exceptions::VserverConfigDiffsPresent>
is thrown.

Checking for MCC config diffs can also be done at run-time, by providing the
command-line parameter C<NACL_MCC_CONFIG_CHECK>.

=back

=back

=cut

sub run {
    my ( $self, @args ) = @_;
    $Log->enter() if $may_enter;
    my %opts = validate(
        @args,
        {   continue_on_failure =>
                { type => SCALAR, optional => 1, default => 1 },
            delete_resource_on_cleanup =>
                { type => SCALAR, optional => 1, default => 1 },
            max_connection_retry_count => { type => SCALAR,   default => 5 },
            connection_retry_interval  => { type => SCALAR,   default => 5 },
            objects                    => { type => ARRAYREF, default => [] },
            mcc_config_check => { type => SCALAR, optional => 1 },
        },
    );

    my $db                         = $self->db();
    my $continue_on_failure        = delete $opts{continue_on_failure};
    my $delete_resource_on_cleanup = delete $opts{delete_resource_on_cleanup};
    my $objects                    = delete $opts{objects};
    my $retry_count      = delete $opts{'max_connection_retry_count'};
    my $retry_interval   = delete $opts{'connection_retry_interval'};
    my $mcc_config_check = delete $opts{mcc_config_check}
        // param_global()->get('NACL_MCC_CONFIG_CHECK');
    my ( @cleanup_failed_for, @elements_to_purge );
    my $elements_by_history
        = $self->_get_elements_by_history( 'objects' => $objects );
    my $failure_count     = 0;
    my $history_row_count = ( scalar @{$elements_by_history} - 1 );

    my ( %config_diffs, %queues_not_drained, $config_diff_msg );

    if ($mcc_config_check) {

        # Get all command_interface objects and de-serialize them
        my $table_data = $db->_get_table_data( table => 'Host' );
        my @cis;
        foreach my $entry (@$table_data) {
            push @cis, thaw( $entry->{cmd_interface} );
        }
        foreach my $ci (@cis) {

            # MCC checking applicable only for ONTAP command_interface
            # objects and if in an MCC environment
            if (   $ci->isa('NACL::C::CommandInterface::ONTAP')
                && $ci->is_in_mcc_environment )
            {
                require NACL::STask::Vserver;
                require NACL::STask::Exceptions::VserverConfigDiffsPresent;
                require NACL::STask::Exceptions::MCCQueuesNotDrained;
                my $ci_name = $ci->name();
                $Log->comment( 'mcc_config_check was set to 1, so '
                        . "checking vserver config diff on $ci_name" );
                try {
                    NACL::STask::Vserver->config_diff(
                        command_interface => $ci,
                        vserver           => '*',
                    );
                    $Log->comment("No config diff found for $ci_name");
                }
                catch NACL::STask::Exceptions::VserverConfigDiffsPresent
                    with {
                    $config_diffs{$ci_name} = $_[0];
                    $Log->comment("WARN: Config diff found for $ci_name!");
                }
                catch NACL::STask::Exceptions::MCCQueuesNotDrained with {
                    $queues_not_drained{$ci_name} = $_[0];
                    $Log->comment("WARN: Queue not drained for $ci_name!");
                }
                otherwise {};
            }
        }

        if ( keys %config_diffs ) {
            $config_diff_msg
                = 'Config diff found for the following '
                . 'command_interfaces: '
                . join( ', ', keys %config_diffs )
                . ". Config diffs:\n";
            foreach my $exception ( values %config_diffs ) {
                $config_diff_msg .= $exception->text() . "\n";
            }
        }
        if ( keys %queues_not_drained ) {
            $config_diff_msg
                .= 'MCC Queues not drained for the following '
                . 'command_interfaces: '
                . join( ', ', keys %queues_not_drained )
                . "Errors:\n";
            foreach my $exception ( values %queues_not_drained ) {
                $config_diff_msg .= $exception->text() . "\n";
            }
        }
    }

    for ( my $index = 0; $index <= $history_row_count; ++$index ) {
        my $element_data      = $elements_by_history->[$index];
        my $command_seq_id    = delete $element_data->{'command_seq_id'};
        my $retry             = $retry_count;
        my $cleanup_succeeded = 0;
        while ( ( --$retry > 0 ) && ( !$cleanup_succeeded ) ) {
            require NACL::APISet::Exceptions::ConnectionFailedException;
            require NACL::C::Exceptions::DoesNotExist;
            try {
                while (my ($key, $val) = each $element_data->{'primary_keys'}) {
                   if (!ref $val) {
                       $element_data->{'primary_keys'}->{$key} = decode_utf8($val);
                   }
                }
                my $pks_updated;
                $self->_run_cleanup( %{$element_data},
                    'primary_keys_updated' => \$pks_updated );
                $cleanup_succeeded = 1;
                if ($pks_updated) {
                    $elements_by_history = $self->_get_elements_by_history(
                        'objects' => $objects );
                    $history_row_count
                        = ( scalar @{$elements_by_history} - 1 );
                    $index        = $failure_count;
                    $element_data = $elements_by_history->[$index];
                }
            }
            catch NACL::APISet::Exceptions::ConnectionFailedException with {
                my $exception = shift;
                if ( $continue_on_failure && $retry ) {
                    $Log->debug(
                        "Encountered connection failure, reconnecting ... attempt: $retry"
                    ) if ( $Log->may_debug() );
                    Tharn::sleep $retry_interval;
                } else {
                    $Log->exit() if $may_exit;
                    $exception->throw();
                }
            }
            catch NACL::C::Exceptions::DoesNotExist with {
                my $exception = shift;
                my $msg
                    = "Caught "
                    . ref($exception)
                    . " and is ignored by cleanup as expected";
                $Log->debug($msg);
            }
            catch NATE::BaseException with {
                my $exception = shift;
                if ($continue_on_failure) {
                    my $stacktrace = $exception->stacktrace();
                    $Log->comment( "Cleanup failed!" . $stacktrace );
                    push @cleanup_failed_for,
                        {
                        'primary_keys' => $element_data->{'primary_keys'},
                        'exception'    => $exception,
                        'class'        => $element_data->{'package'},
                        };
                    ++$failure_count;
                } else {
                    $Log->exit() if $may_exit;
                    NACL::Exceptions::CleanupFailed->throw(
                        "Encountered a failure, aborting the cleanup...",
                        'cleanup_failed_for' => [
                            {   'primary_keys' =>
                                    $element_data->{'primary_keys'},
                                'exception' => $exception
                            }
                        ]
                    );
                }
                $retry = 0;
            };
        }

        next if ( !$cleanup_succeeded );
        if ($delete_resource_on_cleanup) {
            my $host_id
                = $self->db()
                ->_get_host_id(
                'name' => $element_data->{'command_interface'}->name() );
            push @elements_to_purge,
                {
                'primary_keys' => $element_data->{'primary_keys'},
                'package'      => $element_data->{'package'},
                'host_id'      => $host_id
                };
            $self->db()
                ->_purge_a_element_history(
                'command_seq_id' => $command_seq_id );
            $Log->debug( "Deleted resource "
                    . Dumper( $element_data->{'primary_keys'} ) )
                if ( $Log->may_debug() );
        }
    }

    if ( scalar @cleanup_failed_for ) {

        my $exception_text;
        foreach my $failure (@cleanup_failed_for) {
            my $text  = $failure->{exception}->text();
            my $class = $failure->{'class'};
            $exception_text .= "Class: " . $class . ": $text\n";

            # If the element is not cleaned up, do not purge the element entry
            # Hence make sure to delete that primary keys from the array
            # @elements_to_purge
            my $failed_for_primary_keys = $failure->{'primary_keys'};
            foreach my $element_to_purge (@elements_to_purge) {
                my $p_keys = $element_to_purge->{'primary_keys'};
                local $Data::Dumper::Sortkeys = 1;
                if ( Dumper($p_keys) eq Dumper($failed_for_primary_keys) ) {
                    @elements_to_purge = grep {
                        Dumper( $_->{'primary_keys'} ) ne
                            Dumper($failed_for_primary_keys)
                    } @elements_to_purge;
                }
            }
        }
        foreach my $element_to_purge (@elements_to_purge) {
            my $primary_keys_to_purge = $element_to_purge->{'primary_keys'};
            my $pkg                   = $element_to_purge->{'package'};
            my $host_id               = $element_to_purge->{'host_id'};
            $db->_purge_an_element(
                'primary_keys' => $primary_keys_to_purge,
                'package'      => $pkg,
                'host_id'      => $host_id
            );
        }
        $Log->warn($config_diff_msg) if ($config_diff_msg);
        $Log->exit() if $may_exit;
        NACL::Exceptions::CleanupFailed->throw(
            "Cleanup failed!\n" . $exception_text . "\n",
            'cleanup_failed_for' => \@cleanup_failed_for
        );
    } else {
        $self->purge_db() if ($delete_resource_on_cleanup);
        if ($config_diff_msg) {
            my @state_objs;
            foreach my $exception ( values %config_diffs ) {
                push @state_objs, $exception->state_objs();
            }
            $Log->exit() if $may_exit;
            NACL::STask::Exceptions::VserverConfigDiffsPresent->throw(
                $config_diff_msg, state_objs => \@state_objs );
        }
    }
    $Log->exit() if $may_exit;
}

# Helper method to run all the cleanup methods on an element.
sub _run_through_elem_history {
    my ( $self, @args ) = @_;
    my %opts = validate(
        @args,
        {   'primary_keys' => { type => HASHREF },
            'package'      => { type => SCALAR },
            'command_interface' =>
                { isa => 'NACL::C::CommandInterface::ONTAP' },
            'cmd_args' => { type => ARRAYREF },
        },
    );
    my $primary_keys = delete $opts{'primary_keys'};
    my $ci           = delete $opts{'command_interface'};
    my $cmd_args     = delete $opts{'cmd_args'};
    my $package      = delete $opts{'package'};
    eval "require $package";
    my $obj = $package->new( 'command_interface' => $ci, %{$primary_keys} );

    foreach my $cmd_arg ( @{$cmd_args} ) {
        my ( $command, $arguments ) = each %{$cmd_arg};
        $obj->cleanup( 'command' => $command, 'arguments' => $arguments );
    }
}

# Helper method to run all the cleanup methods on an element.
sub _run_cleanup {
    my ( $self, @args ) = @_;
    $Log->enter() if $may_enter;
    my %opts = validate(
        @args,
        {   'primary_keys'         => { type => HASHREF },
            'package'              => { type => SCALAR },
            'command_interface'    => { isa  => 'NACL::C::CommandInterface' },
            'arguments'            => { type => HASHREF },
            'command'              => { type => SCALAR },
            'primary_keys_updated' => { type => SCALARREF },
        },
    );
    my $primary_keys         = delete $opts{'primary_keys'};
    my $ci                   = delete $opts{'command_interface'};
    my $command              = delete $opts{'command'};
    my $package              = delete $opts{'package'};
    my $arguments            = delete $opts{'arguments'};
    my $primary_keys_updated = delete $opts{'primary_keys_updated'};
    $$primary_keys_updated = 0;
    eval "require $package";
    my $obj;

RETRY:    
    use warnings;
    try {
        $obj = $package->new( 'command_interface' => $ci, %{$primary_keys} );
        $obj->cleanup( 'command' => $command, 'arguments' => $arguments );
    } catch NATE::BaseException with {
        my $exception = shift;
        my $error = $exception->text();
        if($error =~ /stale\sconnection/i){
           $Log->comment("Encountered a stale connection. Trying to reconnect...");
            $ci->refresh_command_interface( 'max_reconnect' => 5 );
            no warnings qw(exiting);
            goto RETRY;
        }else{
            $Log->exit() if $may_exit;
            $exception->throw();
        }
    };
    
    my $host_id = $self->db()->_get_host_id( 'name' => $ci->name() );

    if ( $command eq "rename" ) {
        my $primary_keys_after_rename
            = $obj->_get_primary_keys_w_or_wo_ci_from_pkg_or_obj(
            'want_ci' => 0 );
        $self->_update_primary_keys(
            'primary_keys_to_update' => $primary_keys_after_rename,
            'existing_primary_keys'  => $primary_keys,
            'host_id'                => $host_id,
            'package'                => $package
        );
        $$primary_keys_updated = 1;
    }
    $Log->exit() if $may_exit;
}

# helper method to delete all the connections in command_interface
sub _disconnect {
    my @args = @_;
    my %opts = validate_with(
        params      => \@args,
        spec        => { 'command_interface' => { type => OBJECT }, },
        allow_extra => 1,
    );
    my $command_interface = $opts{'command_interface'};
    foreach my $apiset ( $command_interface->_apisets_values() ) {

        # disconnect only for CLI connections
        if ( $apiset->{interface} eq 'CLI' ) {
            $apiset->get_connection()->destroy();
        }
    }
}

=head2 purge_db

  It purges all the data contained in all the tables by truncating the tables.

=over

=item Examples

  use TCD;
  ...
  sub cleanup {
    $Cleanup_Obj->run();
    $Cleanup_Obj->purge_db();
  }

=item Arguments

N/A

=back

=cut

sub purge_db {
    $Log->enter() if $may_enter;
    my $self = shift;
    $self->db()->_truncate_database();
    $Log->exit() if $may_exit;
}

=head2 get

B<DEPRECATED>.

Usage of this method is deprecated.

=cut

sub get {
    $Log->enter() if $may_enter;
    my ( $self, @args ) = @_;
    my %opts = validate_with(
        params => \@args,
        spec   => { 'objects' => { type => ARRAYREF, default => [] }, },
    );

    $Log->warn('Usage of NACL::Cleanup::get is deprecated.');
    my $objs_ref = $self->_get(%opts);

    $Log->exit() if $may_exit;
    return $objs_ref;
}

=head2 remove

B<DEPRECATED>.

=cut

sub remove {
    $Log->enter() if $may_enter;
    my ( $self, @args ) = @_;
    my %opts = validate_with(
        params => \@args,
        spec   => { 'objects' => { type => ARRAYREF }, },
    );

    $Log->warn('Usage of NACL::Cleanup::remove is deprecated.');

    my $objs = $self->_remove(%opts);

    $Log->exit() if $may_exit;
    return $objs;
}

sub add {
    NATE::BaseException->throw(
        "\"NACL::Cleanup::add\" method is not supported");
}

sub update {
    NATE::BaseException->throw(
        "\"NACL::Cleanup::update\" method is not supported");
}

=head2 load

Loads an existing Resource database and instantiates a cleanup object.

=over

=item Synopsis

  my $CObj = NACL::Cleanup->load( db_name => $name_of_db );

=item Exceptions Thrown

=over

=item NATE::BaseException

Throws this exception in the event that, there is a problem in reading the
requested DB ResourceList file and if both the directory where the resource
database file exists and the resource database file doesn't have a read and
write permissions.

=back

=item Examples

  my $CObj = NACL::Cleanup->load( db_name => "/u/user/myresourcelist.db" );

Loads an existing resource list from "/u/user/myresourcelist.db".

=item Arguments

=over

=item C<< db_name >>

(Required) Name of existing ResourceList database file. Please note that, the
specified value for the parameter "db_name" should be an absolute path to the
resource database file.

=back

=back

=cut
sub load {
    $Log->enter() if $may_enter;
    my ( $pkg, @args ) = @_;
    my %opts
        = validate( @args, { db_name => { type => SCALAR, optional => 0 }, },
        );
    my $self = $pkg->new(
        'db_name'       => $opts{db_name},
        'deploy_schema' => 0
    );

    $Log->exit() if $may_exit;
    return $self;
}

=head2 set_as_private_singleton

This will set the instance to be a private singleton. By setting this,
there will not be any need to passing the object to any NACL::STask 
method calls while registering for the cleanup. Once it is set, all the
cleanup data will be stored in the db to which the cleanup instance points 
to. If user has a need to have another instance, then they need to explicitly
pass the cleanup instance to the NACL::STask method calls.

=over

=item Synopsis

my $CObj = NACL::Cleanup->new( random_db => 1 );
$CObj->set_as_private_singleton();

my $second_CObj = NACL::Cleanup->new( random_db => 1 );

=item Examples

my $CObj = NACL::Cleanup->new( random_db => 1 );
$CObj->set_as_private_singleton();

=item Arguments

=over

N/A

=back

=back

=cut

sub set_as_private_singleton {
    $Log->enter() if $may_enter;
    my ($self) = @_;
    $self->dsn($self->db()->db_name());
    $Log->exit() if $may_exit;
}

sub STORABLE_freeze {
    my ( $self, $cloning ) = @_;
    my $data          = {};
    my $db            = $self->db();
    my $conn_params   = $db->get_connection_params();
    my $freeze_params = { %{$conn_params}, 'deploy_schema' => 0 };
    my $dummy         = "";

    return ( $dummy, $freeze_params );
}

sub STORABLE_thaw {
    my ( $self, $cloning, $dummy, $params ) = @_;
    my $pkg = ref $self;

    %$self = %{ $pkg->new( %{$params} ) };
}

sub _get_default_db_name {
    NACL::Cleanup::Database->_db_name_with_unique_id('name' => 'resourceList');
}

sub insert_new_element {
    $Log->enter() if $may_enter;
    my ( $self, @args ) = @_;
    my %opts = validate_with(
        params => \@args,
        spec   => {
            command     => { type => HASHREF },
            package     => { type => HASHREF },
            primary_key => { type => HASHREF },
            host        => { type => HASHREF, optional => 1 },
            group       => { type => HASHREF, optional => 1 },
            argument    => { type => HASHREF, optional => 1 },
        }
    );

    my %ids;
    my $db = $self->db();

    foreach my $table (qw/host command package group/) {
        if ( $opts{$table} ) {
            my $insert_sub = '_insert_into_' . $table;
            my $id         = $db->$insert_sub( %{ $opts{$table} } );
            $ids{ $table . '_id' } = $id;
        }
    }

    my %element_data;
    foreach my $col (qw/group_id host_id package_id/) {
        if ( defined $ids{$col} ) {
            $element_data{$col} = $ids{$col};
        }
    }

    unless (
        $ids{'element_id'} = $db->_get_element_id(
            'query'   => $opts{'primary_key'},
            'package' => $opts{package}->{package},
            'host_id' => $element_data{'host_id'}
        )
        )
    {
        $ids{'element_id'} = $db->_insert_into_Element(%element_data);
    }

    my %command_history_data;
    foreach my $col (qw/element_id command_id/) {
        if ( defined $ids{$col} ) {
            $command_history_data{$col} = $ids{$col};
        }
    }
    $ids{'command_seq_id'}
        = $db->_insert_into_command_history(%command_history_data);
    my %attributes = %{ $opts{'primary_key'} };
    while (my ($key, $val) = each %attributes) {
       if (!ref $val) {
          $attributes{$key} = encode_utf8($val);
       }
    }
    $db->_insert_into_primary_key(
        'element_id' => $ids{'element_id'},
        'package_id' => $ids{'package_id'},
        'attributes' => \%attributes
    );

    if ( defined $opts{'argument'} ) {
        my %argument = %{ $opts{'argument'} };
        $db->_insert_into_argument(
            'command_seq_id' => $ids{'command_seq_id'},
            'arguments'      => \%argument
        );
    }

    $Log->exit() if $may_exit;
}

sub register {
    $Log->enter() if $may_enter;
    my ( $self, @args ) = @_;
    my %opts = validate_with(
        params => \@args,
        spec   => {
            command     => { type => HASHREF },
            package     => { type => HASHREF },
            primary_key => { type => HASHREF },
            host        => { type => HASHREF },
            group       => { type => HASHREF, optional => 1 },
            argument    => { type => HASHREF, default => {} },
        }
    );

    my $db      = $self->db();
    my $host_id = $db->_get_host_id(
        'name' => $opts{'host'}->{'cmd_interface'}->name() );
    my %attributes = %{ $opts{'primary_key'} };
    my $element_id = $db->_get_element_id(
        'query'   => \%attributes,
        'package' => $opts{'package'}->{'package'},
        'host_id' => $host_id,
    );

    if ($element_id) {
        $Log->debug( "Element with the element id: "
                . $element_id
                . " with the primary keys: \n"
                . Dumper( $opts{'primary_key'} )
                . "\n already exists." )
            if ( $Log->may_debug() );
        $db->update_element(
            command    => $opts{'command'}->{command},
            element_id => $element_id,
            arguments  => $opts{'argument'}
        );
    } else {
        $self->insert_new_element(%opts);
    }
}

sub _get_elements_by_history {
    $Log->enter() if $may_enter;
    my ( $self, @args ) = @_;
    my %opts = validate_with(
        params => \@args,
        spec   => { objects => { type => ARRAYREF, default => [] }, }
    );
    my ( $filter_elements, $element_ids_for_cleanup );
    my $db     = $self->db();
    my $schema = $db->schema();

    if ( scalar @{ $opts{'objects'} } ) {
        $element_ids_for_cleanup = $db->_get_element_ids_to_cleanup(%opts);
        $filter_elements         = 1;
    }
    my $rs = $schema->resultset('CommandHistory')->search(
        {},
        {   prefetch => ['command'],
            columns  => [
                'me.id', { 'command' => 'command.command' },
                'me.element_id'
            ],
            order_by => { -desc => 'me.id' }
        }
    );

    my @element_data;
    foreach my $row ( $rs->all ) {
        my %columns = $row->get_columns();
        if ( $filter_elements
            && !$element_ids_for_cleanup->{ $columns{'element_id'} } )
        {
            next;
        }

        my $command      = $columns{'command'};
        my $primary_keys = $self->_get_primary_keys(
            'element_id' => $columns{'element_id'} );
        my $arguments = $self->_get_arguments_by_seq(
            'command_seq_id' => $columns{'id'} );
        my $package
            = $db->_get_package( 'element_id' => $columns{'element_id'} );
        my $ci = $db->_get_command_interface(
            'element_id' => $columns{'element_id'} );
        push @element_data,
            {
            'primary_keys'      => $primary_keys,
            'command'           => $command,
            'arguments'         => $arguments,
            'package'           => $package,
            'command_interface' => $ci,
            'command_seq_id'    => $columns{'id'}
            };
    }

    $Log->exit() if $may_exit;
    return \@element_data;
}

sub _get_arguments_by_seq {
    $Log->enter() if $may_enter;
    my ( $self, @args ) = @_;
    my %opts = validate_with(
        params => \@args,
        spec   => { 'command_seq_id' => { type => SCALAR }, }
    );
    my $id        = delete $opts{'command_seq_id'};
    my $db        = $self->db();
    my $arguments = {};

    my $rs;

    $self->db()->_dbi_call_wrapper(
        'code_ref' => sub {
            $rs = $db->schema()->resultset('Argument')->search(
                { 'command_seq.id' => $id },
                { prefetch         => ['command_seq'], }
            );
        }
    );

    if ($rs) {
        while ( my $row = $rs->next() ) {
            my $argument = $row->get_column('argument');
            $arguments->{$argument} = $self->_get_value_from_arguments($row);
        }
    }
    $Log->enter() if $may_enter;
    return $arguments;
}

sub _get_command_args_in_seq {
    $Log->enter() if $may_enter;
    my ( $self, @args ) = @_;

    my %opts = validate_with(
        params => \@args,
        spec   => { 'element_id' => { type => SCALAR }, }
    );
    my $element_id = $opts{'element_id'};
    my $schema     = $self->db()->schema();
    my @table_data;
    my $rs;

    $self->db()->_dbi_call_wrapper(
        'code_ref' => sub {
            $rs = $schema->resultset('CommandHistory')->search(
                { 'me.element_id' => $element_id },
                {   prefetch => ['command'],
                    order_by => { -desc => 'me.id' }
                }
            );
        }
    );
    while ( my $row = $rs->next ) {
        my $id      = $row->get_column('id');
        my $command = $row->command->get_column('command');
        my $args_rs;
        $self->db()->_dbi_call_wrapper(
            'code_ref' => sub {
                $args_rs = $schema->resultset('Argument')->search(
                    { 'command_seq.id' => $id },
                    { prefetch         => ['command_seq'], }
                );
            }
        );
        if ( $args_rs == 0 ) {
            push @table_data, { $command => {} };
        } else {
            my %arg_value;
            while ( my $arg_row = $args_rs->next() ) {
                $arg_value{ $arg_row->get_column('argument') }
                    = $self->_get_value_from_arguments($row);
            }
            push @table_data, { $command => \%arg_value };
        }
    }
    $Log->exit() if $may_exit;
    return \@table_data;
}

sub _get {
    $Log->enter() if $may_enter;
    my ( $self, @args ) = @_;
    my %opts
        = validate( @args,
        { objects => { type => ARRAYREF, default => [] }, },
        );
    my $db = $self->db();
    my ( %element_data, @objects, $filter_objects, $elements_to_cleanup );

    if ( scalar @{ $opts{'objects'} } ) {
        $elements_to_cleanup = $db->_get_element_ids_to_cleanup(%opts);
        $filter_objects      = 1;
    }

    my $primay_keys = $db->_get_table_data(
        'table'  => "PrimaryKey",
        'select' => [qw/element_id attribute value/]
    );
    foreach my $row ( @{$primay_keys} ) {
        my $element_id = $row->{'element_id'};
        if ( $filter_objects
            && !$elements_to_cleanup->{$element_id} )
        {
            next;
        }

        if ( defined $element_data{$element_id} ) {
            $element_data{$element_id} = {
                %{ $element_data{$element_id} },
                $row->{'attribute'} => $row->{'value'}
            };
        } else {
            my $ci
                = $db->_get_command_interface( 'element_id' => $element_id );
            my $package = $db->_get_package( 'element_id' => $element_id );
            $element_data{$element_id} = {
                $row->{'attribute'} => $row->{'value'},
                'command_interface' => $ci,
                'package'           => $package
            };
        }
    }

    foreach my $data ( values %element_data ) {
        my $package = delete $data->{'package'};
        my $obj     = $package->new( %{$data} );
        push @objects, $obj;
    }

    $Log->exit() if $may_exit;
    return \@objects;
}

sub _remove {
    $Log->enter() if $may_enter;
    my ( $self, @args ) = @_;
    my %opts = validate_with(
        params => \@args,
        spec   => { 'objects' => { type => ARRAYREF }, },
    );

    my @objects = @{ delete $opts{'objects'} };
    my $db      = $self->db();
    my @removed_elements;
    foreach my $object (@objects) {
        my $primary_keys
            = $object->_get_primary_keys_w_or_wo_ci_from_pkg_or_obj(
            want_ci => 0 );
        my $package = ref($object);
        my $host_id = $db->_get_host_id(
            'name' => $object->{'command_interface'}->name() );
        my $element_id = $db->_get_element_id(
            'query'   => $primary_keys,
            'package' => $package,
            'host_id' => $host_id
        );
        if ( !$element_id ) {
            $Log->debug(
                "Couldn't find the element with the following primary keys in the resource Db: \n"
                    . Dumper($primary_keys) )
                if ( $Log->may_debug() );
        } else {
            push @removed_elements, $object;
            my $rs = $db->fetch(
                'table'  => 'CommandHistory',
                'where'  => { 'me.element_id' => $element_id },
                'select' => ['id']
            );
            foreach my $row ( $rs->all ) {
                my %columns = $row->get_columns();
                $db->_purge_a_element_history(
                    'command_seq_id' => $columns{'id'} );
            }
            $db->_purge_an_element(
                'primary_keys' => $primary_keys,
                'package'      => $package,
                'host_id'      => $host_id
            );
        }
    }

    $Log->exit() if $may_exit;
    return \@removed_elements;
}

sub _update_primary_keys {
    $Log->enter() if $may_enter;
    my ( $self, @args ) = @_;

    my %opts = validate_with(
        params => \@args,
        spec   => {
            'primary_keys_to_update' => { type => HASHREF },
            'existing_primary_keys'  => { type => HASHREF },
            'package'                => { type => SCALAR },
            'host_id'                => { type => SCALAR },
        },
        allow_extra => 1,
    );
    my $primary_keys_to_update = $opts{'primary_keys_to_update'};
    my $existing_primary_keys  = $opts{'existing_primary_keys'};
    my $package                = $opts{'package'};
    my $host_id                = $opts{'host_id'};
    my $db                     = $self->db();

    my $element_id = $db->_get_element_id(
        'query'   => $existing_primary_keys,
        'package' => $package,
        'host_id' => $host_id
    );
    my $table = 'PrimaryKey';

    while ( my ( $key, $val ) = each %{$primary_keys_to_update} ) {
        my $where = {
            'me.element_id' => $element_id,
            'me.value'      => $existing_primary_keys->{$key},
            'me.attribute'  => $key,
        };
        my $data = { 'value' => $val };
        $db->_do_update_txn(
            'table' => $table,
            'data'  => $data,
            'where' => $where
        );
    }

    $Log->exit() if $may_exit;
}

sub _get_primary_keys {
    $Log->enter() if $may_enter;
    my ( $self, @args ) = @_;
    my %opts = validate_with(
        params => \@args,
        spec   => { 'element_id' => { type => SCALAR }, }
    );
    my $element_id      = $opts{'element_id'};
    my $primary_keys_rs = $self->db()->fetch(
        'table' => 'PrimaryKey',
        'where' => { 'element_id' => $element_id }
    );
    my %primary_keys;
    while ( my $row = $primary_keys_rs->next() ) {
        my $attribute = $row->attribute();
        my $value     = $row->value();

        $primary_keys{$attribute} = $value;
    }
    $Log->exit() if $may_exit;
    return \%primary_keys;
}

sub _cleanup_validate_spec {
    return {
        random_db     => { type => SCALAR, default  => 0 },
        port          => { type => SCALAR, optional => 1 },
        host          => { type => SCALAR, optional => 1 },
        user          => { type => SCALAR, optional => 1 },
        password      => { type => SCALAR, optional => 1 },
        deploy_schema => { type => SCALAR, optional => 1 },
    };
}

sub resourceList_filename {
    my ($self) = @_;
    my $db_obj = $self->db();
    return $db_obj->db_name();

}

# Static method which expects database name and db handle 
# (only in case of mysql) as arguements
sub does_cleanup_db_exists {
    my @args  = @_;
    $Log->enter() if $may_enter;
    my %opts = validate_with(
        params => \@args,
        spec   => {
            'db_name' => { type => SCALAR },
            'dbh'     => { scalar => [ { -type => 'DBI::db' }, 'dbh' ], optional => 1 },
        },
        allow_extra => 1,
    );
    my $exists = NACL::Cleanup::Database->does_database_exists(%opts);
    $Log->exit() if $may_exit;
    return $exists;
}

sub DESTROY {
    my $self = shift;
    my $db = $self->db();
    $db->clear_ci_hash() if $db;
}

# If the original value was a scalar, then we turn it into a reference
# and then freeze it. Hence, we need to check if the value returned is a
# scalar-ref, and if so, then de-reference it to get the original value.
sub _get_value_from_arguments {
    $Log->enter() if $may_enter;
    my ($self, $row) = @_;
    my $value = thaw ($row->get_column('value'));
    if (ref $value eq 'SCALAR') {
        # Original value was a scalar, but we stored it as a scalar-ref in
        # the DB.
        $value = $$value;
    }
    $Log->exit() if $may_exit;
    return $value;
}

1;