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

(-)a/Koha/Script.pm (+61 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
=head2 new
76
77
Constructor
78
79
=cut
80
81
sub new {
82
    my ($class, $params) = @_;
83
    my $script   = $params->{script};
84
    my $use_lock = $params->{use_lock};
85
86
    Koha::Exceptions::MissingParameter->throw(
87
        "The 'script' parameter is mandatory. You should usually pass \$0"
88
    ) unless $script;
89
90
    my $self = {
91
        script => $script,
92
    };
93
94
    if ($use_lock) {
95
        my $lock_dir = C4::Context->config('lock_dir')
96
          // C4::Context->temporary_directory();
97
98
        my $lock_name = $params->{lock_name} // fileparse( $script );
99
        $self->{lock_file} = "$lock_dir/$lock_name";
100
    }
101
102
    bless $self, $class;
103
    return $self;
104
}
105
106
=head2 lock_exec
107
108
    my $script = Koha::Script->new({ script => $0, use_lock => 1[, lock_name => 'my_script'] });
109
    try {
110
        $script->lock_exec;
111
    }
112
    catch {
113
        die "$_";
114
    };
115
    $script->lock_exec({ wait => 1 });
116
117
=cut
118
119
sub lock_exec {
120
    my ($self, $params) = @_;
121
122
    my $lock_params = ($params->{wait}) ? LOCK_EX : LOCK_EX | LOCK_NB;
123
124
    open our $lock_handle, '>', $self->{lock_file}
125
        or Koha::Exceptions::Exception->throw("Unable to open the lock file ".$self->{lock_file}.": $!");
126
    $self->{lock_handle} = $lock_handle;
127
    flock( $lock_handle, $lock_params )
128
        or Koha::Exceptions::Exception->throw("Unable to acquire the lock");
129
}
130
70
=head1 AUTHOR
131
=head1 AUTHOR
71
132
72
Martin Renvoize <martin.renvoize@ptfs-europe.com>
133
Martin Renvoize <martin.renvoize@ptfs-europe.com>
(-)a/t/Koha/Script.t (-1 / +19 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
21
22
BEGIN { use_ok('Koha::Script') }
22
BEGIN { use_ok('Koha::Script') }
23
23
24
use File::Basename;
25
24
use C4::Context;
26
use C4::Context;
25
27
26
my $userenv = C4::Context->userenv;
28
my $userenv = C4::Context->userenv;
Lines 44-47 is_deeply( Link Here
44
my $interface = C4::Context->interface;
46
my $interface = C4::Context->interface;
45
is( $interface, 'commandline', "Context interface set correctly with no flags" );
47
is( $interface, 'commandline', "Context interface set correctly with no flags" );
46
48
49
subtest 'lock_exec() tests' => sub {
50
    plan tests => 1;
51
52
    # Launch the sleep script
53
    my $pid = fork();
54
    if ( $pid == 0 ) {
55
        system( dirname(__FILE__) . '/sleep.pl' );
56
        exit;
57
    }
58
59
    my $command = dirname(__FILE__) . '/sleep.pl';
60
    my $result  = `$command 2>&1`;
61
62
    is( $result, 'Unable to acquire the lock', 'Exception found' );
63
};
64
47
1;
65
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 => $0, use_lock => 1 });
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