[Bio] / FigKernelPackages / FileLocking.pm Repository:
ViewVC logotype

Annotation of /FigKernelPackages/FileLocking.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (view) (download) (as text)

1 : overbeek 1.1
2 :     package FileLocking;
3 :    
4 : olson 1.4
5 :     #
6 :     # This is a SAS component.
7 : overbeek 1.1 #
8 :     # Package that uses fcntl to implement flock. Use this on systems that use
9 :     # GPFS to properly implement file locking between machines.
10 :     #
11 :     # Allows for a global override of flock.
12 :     #
13 :    
14 :     use Data::Dumper;
15 :     use strict;
16 :     use Carp;
17 :     use Fcntl qw/:DEFAULT :seek :flock/;
18 : olson 1.3
19 :     our $have_FcntlLock;
20 :    
21 :     BEGIN {
22 :     eval {
23 :     require File::FcntlLock;
24 :     $have_FcntlLock++;
25 :     };
26 :     }
27 :    
28 : overbeek 1.1 use Symbol 'qualify_to_ref';
29 :    
30 :     use vars qw(@ISA @EXPORT_OK @EXPORT);
31 :    
32 :     require Exporter;
33 : olson 1.3 @ISA = qw(Exporter);
34 : overbeek 1.1
35 : olson 1.3 #@EXPORT_OK = qw(flock lock_file unlock_file lock_file_shared);
36 : olson 1.2 @EXPORT = qw(lock_file unlock_file lock_file_shared);
37 : overbeek 1.1
38 : olson 1.4 #
39 :     # Conditional require for FIG_Config. If not present
40 :     # (eg we're in servers client code distribution) we default to using flock.
41 :     #
42 :     eval {
43 :     require FIG_Config;
44 :     };
45 : overbeek 1.1
46 :     sub import {
47 :     my $pkg = shift;
48 :     return unless @_;
49 :    
50 :     my $sym = shift;
51 :     my $where = ($sym =~ s/^GLOBAL_// ? 'CORE::GLOBAL' : caller(0));
52 :     # print "IMPORT $pkg @_ to $where\n";
53 :     $pkg->export($where, $sym, @_);
54 :     }
55 :    
56 :     sub lock_file(*)
57 :     {
58 :     my($fh) = @_;
59 :    
60 :     $fh = qualify_to_ref($fh, caller());
61 :    
62 :     return FileLocking::flock($fh, LOCK_EX);
63 :     }
64 :    
65 : olson 1.2 sub lock_file_shared(*)
66 :     {
67 :     my($fh) = @_;
68 :    
69 :     $fh = qualify_to_ref($fh, caller());
70 :    
71 :     return FileLocking::flock($fh, LOCK_SH);
72 :     }
73 :    
74 : overbeek 1.1 sub unlock_file(*)
75 :     {
76 :     my($fh) = @_;
77 :    
78 :     $fh = qualify_to_ref($fh, caller());
79 :    
80 :     return FileLocking::flock($fh, LOCK_UN);
81 :     }
82 :    
83 :    
84 :     sub flock(*$)
85 :     {
86 :     my($fh, $op) = @_;
87 :    
88 :     $fh = qualify_to_ref($fh, caller());
89 :    
90 :     if ($FIG_Config::fcntl_locking)
91 :     {
92 :     return fcntl_flock($fh, $op);
93 :     }
94 :     else
95 :     {
96 :     return CORE::flock($fh, $op);
97 :     }
98 :     }
99 :    
100 :     sub fcntl_flock(*$)
101 :     {
102 :     my($fh, $op) = @_;
103 :    
104 :     $fh = qualify_to_ref($fh, caller());
105 : olson 1.3
106 : overbeek 1.1 # print "flock: fh='$fh' op='$op' fno=" . fileno($fh) . "\n";
107 :    
108 : olson 1.3 if ($have_FcntlLock)
109 : overbeek 1.1 {
110 : olson 1.3 my $fs = new File::FcntlLock;
111 :     if ($op == LOCK_EX)
112 :     {
113 :     $fs->l_type( F_WRLCK );
114 :     $fs->l_whence( SEEK_SET );
115 :     $fs->l_start( 0 );
116 :     $fs->l_len( 0 );
117 :    
118 :     my $rc = $fs->lock($fh, F_SETLKW);
119 :     return $rc;
120 :     }
121 :     elsif ($op == LOCK_SH)
122 :     {
123 :     $fs->l_type( F_RDLCK );
124 :     $fs->l_whence( SEEK_SET );
125 :     $fs->l_start( 0 );
126 :     $fs->l_len( 0 );
127 :    
128 :     my $rc = $fs->lock($fh, F_SETLKW);
129 :     return $rc;
130 :     }
131 :     elsif ($op == LOCK_UN)
132 :     {
133 :     $fs->l_type( F_UNLCK );
134 :     $fs->l_whence( SEEK_SET );
135 :     $fs->l_start( 0 );
136 :     $fs->l_len( 0 );
137 :    
138 :     my $rc = $fs->lock($fh, F_SETLKW);
139 :     return $rc;
140 :     }
141 :     else
142 :     {
143 :     confess "flock: invalid operation $op";
144 :     }
145 : overbeek 1.1 }
146 :     else
147 :     {
148 : olson 1.3
149 :     if ($op == LOCK_EX)
150 :     {
151 :     my $arg = pack("ssl!l!", F_WRLCK, SEEK_SET, 0, 0);
152 :     my $rc = fcntl($fh, F_SETLKW, $arg);
153 :     # print "flock: LOCK_EX returns $rc\n";
154 :     return $rc;
155 :     }
156 :     elsif ($op == LOCK_SH)
157 :     {
158 :     my $arg = pack("ssl!l!", F_RDLCK, SEEK_SET, 0, 0);
159 :     my $rc = fcntl($fh, F_SETLKW, $arg);
160 :     # print "flock: LOCK_SH returns $rc\n";
161 :     return $rc;
162 :     }
163 :     elsif ($op == LOCK_UN)
164 :     {
165 :     my $arg = pack("ssl!l!", F_UNLCK, SEEK_SET, 0, 0);
166 :     my $rc = fcntl($fh, F_SETLKW, $arg);
167 :     # print "flock: LOCK_UN returns $rc\n";
168 :     return $rc;
169 :     }
170 :     else
171 :     {
172 :     confess "flock: invalid operation $op";
173 :     }
174 : overbeek 1.1 }
175 :     }
176 :    
177 :     1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3