1# Copyright © 2011 Raphaël Hertzog <hertzog@debian.org> 2# Copyright © 2012 Guillem Jover <guillem@debian.org> 3# 4# This program is free software; you can redistribute it and/or modify 5# it under the terms of the GNU General Public License as published by 6# the Free Software Foundation; either version 2 of the License, or 7# (at your option) any later version. 8# 9# This program is distributed in the hope that it will be useful, 10# but WITHOUT ANY WARRANTY; without even the implied warranty of 11# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12# GNU General Public License for more details. 13# 14# You should have received a copy of the GNU General Public License 15# along with this program. If not, see <https://www.gnu.org/licenses/>. 16 17package Dpkg::Lock; 18 19use strict; 20use warnings; 21 22our $VERSION = '0.01'; 23our @EXPORT = qw( 24 file_lock 25); 26 27use Exporter qw(import); 28use Fcntl qw(:flock); 29 30use Dpkg::Gettext; 31use Dpkg::ErrorHandling; 32 33sub file_lock($$) { 34 my ($fh, $filename) = @_; 35 36 # A strict dependency on libfile-fcntllock-perl being it an XS module, 37 # and dpkg-dev indirectly making use of it, makes building new perl 38 # package which bump the perl ABI impossible as these packages cannot 39 # be installed alongside. 40 eval q{ 41 pop @INC if $INC[-1] eq '.'; 42 use File::FcntlLock; 43 }; 44 if ($@) { 45 # On Linux systems the flock() locks get converted to file-range 46 # locks on NFS mounts. 47 if ($^O ne 'linux') { 48 warning(g_('File::FcntlLock not available; using flock which is not NFS-safe')); 49 } 50 flock($fh, LOCK_EX) 51 or syserr(g_('failed to get a write lock on %s'), $filename); 52 } else { 53 eval q{ 54 my $fs = File::FcntlLock->new(l_type => F_WRLCK); 55 $fs->lock($fh, F_SETLKW) 56 or syserr(g_('failed to get a write lock on %s'), $filename); 57 } 58 } 59} 60 611; 62