Bug 29790: Restore warning if deletion of serial item fails

[srvgit] / Koha / Script.pm

diff --git a/Koha/Script.pm b/Koha/Script.pm
index 4e8f5a6..d9e11ea 100644 (file)
--- a/Koha/Script.pm
+++ b/Koha/Script.pm
@@ -35,7 +35,12 @@ This class should be used in all scripts. It sets the interface and userenv appr
 
 =cut
 
+use File::Basename qw( fileparse );
+use Fcntl qw( LOCK_EX LOCK_NB );
+
 use C4::Context;
+use Koha::Exceptions;
+use Koha::Exceptions::Exception;
 
 sub import {
     my $class = shift;
@@ -47,7 +52,7 @@ sub import {
         # Set userenv
         C4::Context->_new_userenv(1);
         C4::Context->set_userenv(
-            undef, undef, undef, 'CRON', 'CRON', undef,
+            undef, undef, undef, 'CRON', 'CRON',
             undef, undef, undef, undef,  undef
         );
 
@@ -58,7 +63,7 @@ sub import {
     else {
         # Set userenv
         C4::Context->set_userenv(
-            undef, undef, undef, 'CLI', 'CLI', undef,
+            undef, undef, undef, 'CLI', 'CLI',
             undef, undef, undef, undef,  undef
         );
 
@@ -67,6 +72,98 @@ sub import {
     }
 }
 
+=head1 API
+
+=head2 Class methods
+
+=head3 new
+
+    my $script = Koha::Script->new(
+        {
+            script    => $0, # mandatory
+          [ lock_name => 'my_script' ]
+        }
+    );
+
+Create a new Koha::Script object. The I<script> parameter is mandatory,
+and will usually be passed I<$0> in the caller script. The I<lock_name>
+parameter is optional, and is used to generate the lock file if passed.
+
+=cut
+
+sub new {
+    my ($class, $params) = @_;
+    my $script   = $params->{script};
+
+    Koha::Exceptions::MissingParameter->throw(
+        "The 'script' parameter is mandatory. You should usually pass \$0"
+    ) unless $script;
+
+    my $self = { script => $script };
+    $self->{lock_name} = $params->{lock_name}
+        if exists $params->{lock_name} and $params->{lock_name};
+
+    bless $self, $class;
+    return $self;
+}
+
+=head3 lock_exec
+
+    # die if cannot get the lock
+    try {
+        $script->lock_exec;
+    }
+    catch {
+        die "$_";
+    };
+
+    # wait for the lock to be released
+    $script->lock_exec({ wait => 1 });
+
+This method sets an execution lock to prevent concurrent execution of the caller
+script. If passed the I<wait> parameter with a true value, it will make the caller
+wait until it can be granted the lock (flock's LOCK_NB behaviour). It will
+otherwise throw an exception immediately.
+
+=cut
+
+sub lock_exec {
+    my ($self, $params) = @_;
+
+    $self->_initialize_locking
+        unless $self->{lock_file};
+
+    my $lock_params = ($params->{wait}) ? LOCK_EX : LOCK_EX | LOCK_NB;
+
+    open my $lock_handle, '>', $self->{lock_file}
+        or Koha::Exceptions::Exception->throw("Unable to open the lock file ".$self->{lock_file}.": $!");
+    $self->{lock_handle} = $lock_handle;
+    flock( $lock_handle, $lock_params )
+        or Koha::Exceptions::Exception->throw("Unable to acquire the lock ".$self->{lock_file}.": $!");
+}
+
+=head2 Internal methods
+
+=head3 _initialize_locking
+
+    $self->_initialize_locking
+
+This method initializes the locking configuration.
+
+=cut
+
+sub _initialize_locking {
+    my ($self) = @_;
+
+    my $lock_dir = C4::Context->config('lockdir')
+        // C4::Context->temporary_directory();
+
+    my $lock_name = $self->{lock_name} // fileparse( $self->{script} );
+    $self->{lock_file} = "$lock_dir/$lock_name";
+
+    return $self;
+}
+
 =head1 AUTHOR
 
 Martin Renvoize <martin.renvoize@ptfs-europe.com>