The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package PerlLocks;
use strict;

# Containing a record for each lock, that will be:
#   { owned => 1/0,
#     waiting => [list of request numbers],
#     waiting_signal => [list of request numbers],
#   }
my %variables;

sub new {
    my $class = shift;
    return bless {}, $class;
}

sub AcceptRequest {
    my ($self, $params) = @_;
    my ($operation, $lock_name) = split(' ', $params->{request}, 2);
    my $requestNumber = $params->{requestNumber};
    my $record;
    if (exists $variables{$lock_name}) {
        $record = $variables{$lock_name};
    } else {
        $record = { owned => 0, waiting => [], waiting_signal => [] };
        $variables{$lock_name} = $record;
    }
    
    if ($operation eq 'lock') {
        if ($record->{owned}) {
            push @{ $record->{waiting} }, $requestNumber;
            return $STAF::DelayedAnswer;
        } else {
            $record->{owned} = 1;
            return (0, "OK");
        }
    }
    
    if ($operation eq 'release') {
        $self->Release($record);
        return (0, "OK");
    }

    if ($operation eq 'cond_wait') {
        push @{ $record->{waiting_signal} }, $requestNumber;
        $self->Release($record);
        return $STAF::DelayedAnswer;
    }

    if ($operation eq 'cond_signal') {
        my $other_requestNumber = shift @{ $record->{waiting_signal} };
        push @{ $record->{waiting} }, $other_requestNumber;
        return (0, "OK");
    }

    if ($operation eq 'cond_broadcast') {
        push @{ $record->{waiting} }, @{ $record->{waiting_signal} };
        @{ $record->{waiting_signal} } = ();
        return (0, "OK");
    }
    
    return (1, "Unknown command");
}

sub Release {
    my ($self, $record) = @_;
    if (@{ $record->{waiting} }) {
        my $other_requestNumber = shift @{ $record->{waiting} };
        STAF::DelayedAnswer($other_requestNumber, 0, "OK");
    } else {
        $record->{owned} = 0;
    }
}

1;