View | Details | Raw Unified | Return to bug 25109
Collapse All | Expand All

(-)a/Koha/Script.pm (+97 lines)
Lines 35-41 This class should be used in all scripts. It sets the interface and userenv appr Link Here
35
35
36
=cut
36
=cut
37
37
38
use File::Basename;
39
use Fcntl qw(:flock);
40
38
use C4::Context;
41
use C4::Context;
42
use Koha::Exceptions;
43
use Koha::Exceptions::Exception;
39
44
40
sub import {
45
sub import {
41
    my $class = shift;
46
    my $class = shift;
Lines 67-72 sub import { Link Here
67
    }
72
    }
68
}
73
}
69
74
75
=head1 API
76
77
=head2 Class methods
78
79
=head3 new
80
81
    my $script = Koha::Script->new(
82
        {
83
            script    => $0, # mandatory
84
          [ lock_name => 'my_script' ]
85
        }
86
    );
87
88
Create a new Koha::Script object. The I<script> parameter is mandatory,
89
and will usually be passed I<$0> in the caller script. The I<lock_name>
90
parameter is optional, and is used to generate the lock file if passed.
91
92
=cut
93
94
sub new {
95
    my ($class, $params) = @_;
96
    my $script   = $params->{script};
97
98
    Koha::Exceptions::MissingParameter->throw(
99
        "The 'script' parameter is mandatory. You should usually pass \$0"
100
    ) unless $script;
101
102
    my $self = { script => $script };
103
    $self->{lock_name} = $params->{lock_name}
104
        if exists $params->{lock_name} and $params->{lock_name};
105
106
    bless $self, $class;
107
    return $self;
108
}
109
110
=head3 lock_exec
111
112
    # die if cannot get the lock
113
    try {
114
        $script->lock_exec;
115
    }
116
    catch {
117
        die "$_";
118
    };
119
120
    # wait for the lock to be released
121
    $script->lock_exec({ wait => 1 });
122
123
This method sets an execution lock to prevent concurrent execution of the caller
124
script. If passed the I<wait> parameter with a true value, it will make the caller
125
wait until it can be granted the lock (flock's LOCK_NB behaviour). It will
126
otherwise throw an exception immediately.
127
128
=cut
129
130
sub lock_exec {
131
    my ($self, $params) = @_;
132
133
    $self->_initialize_locking
134
        unless $self->{lock_file};
135
136
    my $lock_params = ($params->{wait}) ? LOCK_EX : LOCK_EX | LOCK_NB;
137
138
    open our $lock_handle, '>', $self->{lock_file}
139
        or Koha::Exceptions::Exception->throw("Unable to open the lock file ".$self->{lock_file}.": $!");
140
    $self->{lock_handle} = $lock_handle;
141
    flock( $lock_handle, $lock_params )
142
        or Koha::Exceptions::Exception->throw("Unable to acquire the lock ".$self->{lock_file}.": $!");
143
}
144
145
=head2 Internal methods
146
147
=head3 _initialize_locking
148
149
    $self->_initialize_locking
150
151
This method initializes the locking configuration.
152
153
=cut
154
155
sub _initialize_locking {
156
    my ($self) = @_;
157
158
    my $lock_dir = C4::Context->config('lock_dir')
159
        // C4::Context->temporary_directory();
160
161
    my $lock_name = $self->{lock_name} // fileparse( $self->{script} );
162
    $self->{lock_file} = "$lock_dir/$lock_name";
163
164
    return $self;
165
}
166
70
=head1 AUTHOR
167
=head1 AUTHOR
71
168
72
Martin Renvoize <martin.renvoize@ptfs-europe.com>
169
Martin Renvoize <martin.renvoize@ptfs-europe.com>
(-)a/t/Koha/Script.t (-1 / +26 lines)
Lines 17-26 Link Here
17
17
18
use Modern::Perl;
18
use Modern::Perl;
19
19
20
use Test::More tests => 3;
20
use Test::More tests => 4;
21
use Test::Exception;
21
22
22
BEGIN { use_ok('Koha::Script') }
23
BEGIN { use_ok('Koha::Script') }
23
24
25
use File::Basename;
26
24
use C4::Context;
27
use C4::Context;
25
28
26
my $userenv = C4::Context->userenv;
29
my $userenv = C4::Context->userenv;
Lines 44-47 is_deeply( Link Here
44
my $interface = C4::Context->interface;
47
my $interface = C4::Context->interface;
45
is( $interface, 'commandline', "Context interface set correctly with no flags" );
48
is( $interface, 'commandline', "Context interface set correctly with no flags" );
46
49
50
subtest 'lock_exec() tests' => sub {
51
    plan tests => 2;
52
53
    # Launch the sleep script
54
    my $pid = fork();
55
    if ( $pid == 0 ) {
56
        system( dirname(__FILE__) . '/sleep.pl 2>&1' );
57
        exit;
58
    }
59
60
    sleep 1; # Make sure we start after the fork
61
    my $command = dirname(__FILE__) . '/sleep.pl';
62
    my $result  = `$command 2>&1`;
63
64
    like( $result, qr{Unable to acquire the lock.*}, 'Exception found' );
65
66
    throws_ok
67
        { Koha::Script->new({ lock_name => 'blah' }); }
68
        'Koha::Exceptions::MissingParameter',
69
        'Not passing the "script" parameter makes it raise an exception';
70
};
71
47
1;
72
1;
(-)a/t/Koha/sleep.pl (-1 / +19 lines)
Line 0 Link Here
0
- 
1
#!/usr/bin/perl
2
3
use Modern::Perl;
4
5
use Koha::Script;
6
use Fcntl qw(:flock);
7
use Try::Tiny;
8
9
# # Lock execution
10
my $script = Koha::Script->new({ script => 'sleep.pl' });
11
12
$script->lock_exec;
13
14
# Sleep for a while, we need to force the concurrent access to the
15
# lock file
16
sleep 2;
17
18
# Normal exit
19
1;

Return to bug 25109