#!/usr/bin/perl
use strict;
#################### main pod documentation begin ###################

=head1 NAME

  Zymonic - Test script to verify locking works within the system
  as needed.

=head1 SYNOPSIS

=head1 DESCRIPTION

This script will take in a table name then verify that
only one 'user' at a time can get a lock on it.

=head1 SUPPORT

As in the license, Zymonic is provided without warranty or support
unless purchased separately, however... If you email
zymonic-support@zednax.com your issue will   be noted and may
receive a response.

For security issues, please contact zymonic-security@zednax.com and
someone will respond within 8 working hours.


=head1 AUTHOR

    Alex Masidlover et al.
    CPAN ID: MODAUTHOR
    Zednax Limited
    alex.masidlover@zednax.com
    http://www.zednax.com

=head1 COPYRIGHT

This program is free software licensed under the...

    Zymonic Public License 1.0

The full text of the license can be found in the
LICENSE file included with this module.

Other licenses may be acceptable if including
parts of Zymonic in larger projects, please
contact Zednax for details. 

=head1 SEE ALSO

perl(1).

=cut

#################### main pod documentation end ###################

# modules
use File::Slurp;
use Sys::Hostname;

use Zymonic::Script;
use Zymonic::Table;
use Zymonic::Utils qw(get_array);

# start a zymonic script
my $s = Zymonic::Script->new(
    args => {
        table     => { type => 'string', required => 'true', description => 'ZName of the table to use', },
        users     => { type => 'int',    default  => 2,      description => 'Number of simultaneous users', },
        record_id => {
            type => 'int',
            description =>
'ID of the record to use. NOTE: can only current use tables with a single ID field. If not set then will create a new one.',
        },
        attempts => { type => 'int', default => 1, description => 'Number of times to run.', },
        wait_for_lock =>
          { type => 'string', default => 'N', description => 'Set to "Y" to force users to wait to acquire lock', },
    },
    init_session => '',
    init_auth    => 'true',
    init_locking => 'true',
);

# file names used as semaphores with child processes
my $run_file     = 'locking_records.run';
my $attempt_file = 'locking_records.attempt';
my $wait_file    = 'locking_records.wait';
my $lock_file    = 'locking_records.lock';

main();
exit(0);

#################### subroutine header begin ####################

=head2 main 

 Usage     : main();
 Purpose   : main script functionality
 Returns   : nothing
 Argument  : nothing
 Throws    : nothing
 Comment   : 


See Also   :

=cut

#################### subroutine header end ###################

sub main
{
    # get table
    my $table_zname    = $s->get_arg('table');
    my $table_def      = $s->{config}->get_def( 'Table', $table_zname );
    my $table_sql_name = $s->get_sql_name($table_def);

    # always has a single id, so grab that as id to output
    my $record_id = get_record_id();
    my $record_id_str = $record_id->{ ( keys %{$record_id} )[0] };

    # grab the current lock and quit if it has one
    my $lock_args = $s->get_table_record_lock_args( $table_zname, $table_sql_name, $record_id );
    my $lock_value = $s->{locking}->get_current_lock( 'record', $lock_args );
    $s->{locking}->full_verify_lock( 'record', $lock_args ) if $lock_value;
    $lock_value = $s->{locking}->get_current_lock( 'record', $lock_args );
    if ($lock_value)
    {
        print "Table $table_zname ($record_id_str) is already locked, cannot test: $lock_value\n";
        exit(1);
    }

    # start the run file so children now to keep running
    write_file( $run_file, $$ );

    # fork into desired number of 'users'
    my @child_pids = ();
    my $count      = $s->get_arg('users');
    foreach my $i ( 1 .. $count )
    {
        my $pid = fork();
        if ($pid)
        {
            push( @child_pids, $pid );
        }
        elsif ( $pid == 0 )
        {
            user_attempt( $table_zname, $table_sql_name, $record_id, $lock_args );
            exit(0);
        }
        else
        {
            die "Unable to fork\n";
        }
    }
    print "Started 'users' " . join( ', ', @child_pids ) . "\n";

    my $attempts = $s->get_arg('attempts');
    foreach my $attempt ( 1 .. $attempts )
    {
        print "--\nAttempt $attempt\n";
        attempt( \@child_pids, $lock_args );
    }

    # once done clear the run file to stop children
    print "--\nWaiting for 'users' to stop\n";
    unlink($run_file);
    foreach my $child_pid (@child_pids)
    {
        waitpid( $child_pid, 0 );
    }
    print "Done\n";
}

#################### subroutine header begin ####################

=head2 attempt() 

 Usage     : attempt();
 Purpose   : Runs an attempt
 Returns   : nothing
 Argument  : nothing
 Throws    : nothing
 Comment   : 


See Also   :

=cut

#################### subroutine header end ###################

sub attempt
{
    my $child_pids = shift;
    my $lock_args  = shift;

    # setup wait file so all processes go at the same time
    write_file( $wait_file, $$ );

    # setup files to set all children attempting
    map { write_file( "$attempt_file.$_", $$ ); } @{$child_pids};

    # now clear wait file so they all start going
    unlink($wait_file);

    # wait for all the attempt files to go
    map {
        while ( -f "$attempt_file.$_" ) { sleep(0.001); }
    } @{$child_pids};

    # if we're not waiting for locks, check now that the correct user got the lock
    if ( $s->get_arg('wait_for_lock') eq 'true' )
    {
        print "Locking test finished - check that all users above eventually got locks\n";
    }
    else
    {

        # lookup lock PID
        unless ( -f $lock_file )
        {
            print "Locking test failed - no 'user' got a lock\n";
        }
        my $lock_pid = read_file($lock_file) || '';
        chomp($lock_pid);
        unlink($lock_file);

        # check we now have a lock
        my $expected_pid_value  = 'ZZPID' . hostname() . ',' . $lock_pid;
        my $expected_lock_value = "${expected_pid_value}:::${expected_pid_value}";
        my $actual_lock_value   = $s->{locking}->get_current_lock( 'record', $lock_args );
        if ( $expected_lock_value && $actual_lock_value && $expected_lock_value eq $actual_lock_value )
        {
            print "Locking test passed!\n";
        }
        else
        {
            print "Locking test failed - expected=$expected_lock_value, actual=$actual_lock_value\n";
        }
    }

    # unlock it now
    $s->{locking}->clear_lock( 'record', $lock_args );
}

#################### subroutine header begin ####################

=head2 user_attempt 

 Usage     : user_attempt();
 Purpose   : Ran by each user in attempt to get the locks
 Returns   : nothing
 Argument  : nothing
 Throws    : nothing
 Comment   : 


See Also   :

=cut

#################### subroutine header end ###################

sub user_attempt
{
    my $table_zname       = shift;
    my $table_sql_name    = shift;
    my $record_id         = shift;
    my $user_attempt_file = "$attempt_file.$$";
    my $wait_for_lock     = $s->get_arg('wait_for_lock') eq 'true';

    # loop until run file is gone
    while ( -f $run_file )
    {
        while ( !-f $user_attempt_file && -f $run_file )
        {
            sleep(0.01);
        }

        # check now that run file wasn't removed while we were waiting above
        if ( !-f $run_file )
        {
            last;
        }

        # wait for the wait file to disapper, so we all go at the same time
        while ( -f $wait_file )
        {
            sleep(0.000001);
        }

        my $keep_trying = 'true';
        my $count       = 0;
        while ($keep_trying)
        {
            ++$count;

            # child needs to get the lock
            my $got_lock = $s->lock_table_records( $table_zname, $table_sql_name, [$record_id] );
            my $msg = '';
            if ($got_lock)
            {
                write_file( $lock_file, $$ );

                # flag so we don't try and get it again
                $keep_trying = '';

                # if wait for lock set, keep lock for a little bit (simulate user actions), then unlock it
                if ($wait_for_lock)
                {
                    print "User $$ - Got lock after $count attempt(s)\n";
                    my $wait = sprintf( "%.2f", rand() + 1 );
                    sleep($wait);
                    $s->unlock_table_records( $table_zname, $table_sql_name, [$record_id] );
                    $msg = "Unlocked after $wait s";
                }
                else
                {
                    $msg = 'Got lock';
                }
            }
            else
            {
                # only show message if not waiting
                $msg = $s->lock_table_record_fail_message( $table_zname, $table_sql_name, $record_id )
                  unless $wait_for_lock;
            }
            print "User $$ - $msg\n" if $msg;

            # if waiting for lock, give it a little then try again
            # if not clear flag so all processes only try once
            if ($wait_for_lock)
            {
                sleep(0.5);
            }
            else
            {
                $keep_trying = '';
            }
        }

        # once done clear the attempt file to wait and clear down caches
        unlink($user_attempt_file);
        $s->{locking}->clear_caches();
    }

    print "User $$ - stopped\n";
    exit(0);
}

#################### subroutine header begin ####################

=head2 get_record_id 

 Usage     : get_record_id();
 Purpose   : Gets the record_id to test locking on
 Returns   : hashref record id
 Argument  : nothing
 Throws    : nothing
 Comment   : 


See Also   :

=cut

#################### subroutine header end ###################

sub get_record_id
{
    # first need to lookup table to get keyfields
    my $table_zname = $s->get_arg('table');
    my $table       = $s->get_table($table_zname);
    my @keyfields   = $table->keyfields();
    unless ( @keyfields == 1 )
    {
        print "Table $table_zname does not have a single key field, cannot test locking on it.\n";
        exit(1);
    }
    my $id = $s->get_arg('record_id');
    if ($id)
    {
        return { $keyfields[0] => $id };
    }

    # if there is no record id specified, create new record
    my $record_id = $table->quick_add_record( {}, 'no_check_perms', 'no_set_perms', 'no_new_placeholer' );

    # delete the record so it doesn't show in system, but will still be in the table for these locking tests
    $table->delete_record( $record_id, 'no_perms' );

    my $id = $record_id->{ $keyfields[0] };
    print "Created Record ID $id\n";
    return $record_id;
}