]>
Commit | Line | Data |
---|---|---|
ca3269f4 | 1 | package PVE::APIClient::Tools; |
565bbc73 DM |
2 | |
3 | use strict; | |
4 | use warnings; | |
5 | use POSIX qw(EINTR EEXIST EOPNOTSUPP); | |
6 | use base 'Exporter'; | |
7 | ||
8 | use IO::File; | |
a8d03417 | 9 | use Text::ParseWords; |
b8b2e694 DM |
10 | use Fcntl qw(:DEFAULT :flock); |
11 | use Scalar::Util 'weaken'; | |
565bbc73 DM |
12 | |
13 | our @EXPORT_OK = qw( | |
14 | $IPV6RE | |
15 | $IPV4RE | |
16 | split_list | |
17 | file_set_contents | |
18 | file_get_contents | |
cff6d4f9 | 19 | extract_param |
565bbc73 DM |
20 | ); |
21 | ||
22 | my $IPV4OCTET = "(?:25[0-5]|(?:2[0-4]|1[0-9]|[1-9])?[0-9])"; | |
23 | our $IPV4RE = "(?:(?:$IPV4OCTET\\.){3}$IPV4OCTET)"; | |
24 | my $IPV6H16 = "(?:[0-9a-fA-F]{1,4})"; | |
25 | my $IPV6LS32 = "(?:(?:$IPV4RE|$IPV6H16:$IPV6H16))"; | |
26 | ||
27 | our $IPV6RE = "(?:" . | |
28 | "(?:(?:" . "(?:$IPV6H16:){6})$IPV6LS32)|" . | |
29 | "(?:(?:" . "::(?:$IPV6H16:){5})$IPV6LS32)|" . | |
30 | "(?:(?:(?:" . "$IPV6H16)?::(?:$IPV6H16:){4})$IPV6LS32)|" . | |
31 | "(?:(?:(?:(?:$IPV6H16:){0,1}$IPV6H16)?::(?:$IPV6H16:){3})$IPV6LS32)|" . | |
32 | "(?:(?:(?:(?:$IPV6H16:){0,2}$IPV6H16)?::(?:$IPV6H16:){2})$IPV6LS32)|" . | |
33 | "(?:(?:(?:(?:$IPV6H16:){0,3}$IPV6H16)?::(?:$IPV6H16:){1})$IPV6LS32)|" . | |
34 | "(?:(?:(?:(?:$IPV6H16:){0,4}$IPV6H16)?::" . ")$IPV6LS32)|" . | |
35 | "(?:(?:(?:(?:$IPV6H16:){0,5}$IPV6H16)?::" . ")$IPV6H16)|" . | |
36 | "(?:(?:(?:(?:$IPV6H16:){0,6}$IPV6H16)?::" . ")))"; | |
37 | ||
38 | our $IPRE = "(?:$IPV4RE|$IPV6RE)"; | |
39 | ||
b8b2e694 DM |
40 | sub run_with_timeout { |
41 | my ($timeout, $code, @param) = @_; | |
42 | ||
43 | die "got timeout\n" if $timeout <= 0; | |
44 | ||
45 | my $prev_alarm = alarm 0; # suspend outer alarm early | |
46 | ||
47 | my $sigcount = 0; | |
48 | ||
49 | my $res; | |
50 | ||
51 | eval { | |
52 | local $SIG{ALRM} = sub { $sigcount++; die "got timeout\n"; }; | |
53 | local $SIG{PIPE} = sub { $sigcount++; die "broken pipe\n" }; | |
54 | local $SIG{__DIE__}; # see SA bug 4631 | |
55 | ||
56 | alarm($timeout); | |
57 | ||
58 | eval { $res = &$code(@param); }; | |
59 | ||
60 | alarm(0); # avoid race conditions | |
61 | ||
62 | die $@ if $@; | |
63 | }; | |
64 | ||
65 | my $err = $@; | |
66 | ||
67 | alarm $prev_alarm; | |
68 | ||
69 | # this shouldn't happen anymore? | |
70 | die "unknown error" if $sigcount && !$err; # seems to happen sometimes | |
71 | ||
72 | die $err if $err; | |
73 | ||
74 | return $res; | |
75 | } | |
76 | ||
77 | # flock: we use one file handle per process, so lock file | |
78 | # can be nested multiple times and succeeds for the same process. | |
79 | # | |
80 | # Since this is the only way we lock now and we don't have the old | |
81 | # 'lock(); code(); unlock();' pattern anymore we do not actually need to | |
82 | # count how deep we're nesting. Therefore this hash now stores a weak reference | |
83 | # to a boolean telling us whether we already have a lock. | |
84 | ||
85 | my $lock_handles = {}; | |
86 | ||
87 | sub lock_file_full { | |
88 | my ($filename, $timeout, $shared, $code, @param) = @_; | |
89 | ||
90 | $timeout = 10 if !$timeout; | |
91 | ||
92 | my $mode = $shared ? LOCK_SH : LOCK_EX; | |
93 | ||
94 | my $lockhash = ($lock_handles->{$$} //= {}); | |
95 | ||
96 | # Returns a locked file handle. | |
97 | my $get_locked_file = sub { | |
98 | my $fh = IO::File->new(">>$filename") | |
99 | or die "can't open file - $!\n"; | |
100 | ||
101 | if (!flock($fh, $mode|LOCK_NB)) { | |
102 | print STDERR "trying to acquire lock...\n"; | |
103 | my $success; | |
104 | while(1) { | |
105 | $success = flock($fh, $mode); | |
106 | # try again on EINTR (see bug #273) | |
107 | if ($success || ($! != EINTR)) { | |
108 | last; | |
109 | } | |
110 | } | |
111 | if (!$success) { | |
112 | print STDERR " failed\n"; | |
113 | die "can't acquire lock '$filename' - $!\n"; | |
114 | } | |
115 | print STDERR " OK\n"; | |
116 | } | |
117 | ||
118 | return $fh; | |
119 | }; | |
120 | ||
121 | my $res; | |
122 | my $checkptr = $lockhash->{$filename}; | |
123 | my $check = 0; # This must not go out of scope before running the code. | |
124 | my $local_fh; # This must stay local | |
125 | if (!$checkptr || !$$checkptr) { | |
126 | # We cannot create a weak reference in a single atomic step, so we first | |
127 | # create a false-value, then create a reference to it, then weaken it, | |
128 | # and after successfully locking the file we change the boolean value. | |
129 | # | |
130 | # The reason for this is that if an outer SIGALRM throws an exception | |
131 | # between creating the reference and weakening it, a subsequent call to | |
132 | # lock_file_full() will see a leftover full reference to a valid | |
133 | # variable. This variable must be 0 in order for said call to attempt to | |
134 | # lock the file anew. | |
135 | # | |
136 | # An externally triggered exception elsewhere in the code will cause the | |
137 | # weak reference to become 'undef', and since the file handle is only | |
138 | # stored in the local scope in $local_fh, the file will be closed by | |
139 | # perl's cleanup routines as well. | |
140 | # | |
141 | # This still assumes that an IO::File handle can properly deal with such | |
142 | # exceptions thrown during its own destruction, but that's up to perls | |
143 | # guts now. | |
144 | $lockhash->{$filename} = \$check; | |
145 | weaken $lockhash->{$filename}; | |
146 | $local_fh = eval { run_with_timeout($timeout, $get_locked_file) }; | |
147 | if ($@) { | |
148 | $@ = "can't lock file '$filename' - $@"; | |
149 | return undef; | |
150 | } | |
151 | $check = 1; | |
152 | } | |
153 | $res = eval { &$code(@param); }; | |
154 | return undef if $@; | |
155 | return $res; | |
156 | } | |
157 | ||
158 | ||
159 | sub lock_file { | |
160 | my ($filename, $timeout, $code, @param) = @_; | |
161 | ||
162 | return lock_file_full($filename, $timeout, 0, $code, @param); | |
163 | } | |
164 | ||
565bbc73 DM |
165 | sub file_set_contents { |
166 | my ($filename, $data, $perm) = @_; | |
167 | ||
168 | $perm = 0644 if !defined($perm); | |
169 | ||
170 | my $tmpname = "$filename.tmp.$$"; | |
171 | ||
172 | eval { | |
173 | my ($fh, $tries) = (undef, 0); | |
174 | while (!$fh && $tries++ < 3) { | |
175 | $fh = IO::File->new($tmpname, O_WRONLY|O_CREAT|O_EXCL, $perm); | |
176 | if (!$fh && $! == EEXIST) { | |
177 | unlink($tmpname) or die "unable to delete old temp file: $!\n"; | |
178 | } | |
179 | } | |
180 | die "unable to open file '$tmpname' - $!\n" if !$fh; | |
181 | die "unable to write '$tmpname' - $!\n" unless print $fh $data; | |
182 | die "closing file '$tmpname' failed - $!\n" unless close $fh; | |
183 | }; | |
184 | my $err = $@; | |
185 | ||
186 | if ($err) { | |
187 | unlink $tmpname; | |
188 | die $err; | |
189 | } | |
190 | ||
191 | if (!rename($tmpname, $filename)) { | |
192 | my $msg = "close (rename) atomic file '$filename' failed: $!\n"; | |
193 | unlink $tmpname; | |
194 | die $msg; | |
195 | } | |
196 | } | |
197 | ||
198 | sub file_get_contents { | |
199 | my ($filename, $max) = @_; | |
200 | ||
201 | my $fh = IO::File->new($filename, "r") || | |
202 | die "can't open '$filename' - $!\n"; | |
203 | ||
204 | my $content = safe_read_from($fh, $max, 0, $filename); | |
205 | ||
206 | close $fh; | |
207 | ||
208 | return $content; | |
209 | } | |
210 | ||
211 | sub file_read_firstline { | |
212 | my ($filename) = @_; | |
213 | ||
214 | my $fh = IO::File->new ($filename, "r"); | |
215 | return undef if !$fh; | |
216 | my $res = <$fh>; | |
217 | chomp $res if $res; | |
218 | $fh->close; | |
219 | return $res; | |
220 | } | |
221 | ||
222 | sub safe_read_from { | |
223 | my ($fh, $max, $oneline, $filename) = @_; | |
224 | ||
225 | $max = 32768 if !$max; | |
226 | ||
227 | my $subject = defined($filename) ? "file '$filename'" : 'input'; | |
228 | ||
229 | my $br = 0; | |
230 | my $input = ''; | |
231 | my $count; | |
232 | while ($count = sysread($fh, $input, 8192, $br)) { | |
233 | $br += $count; | |
234 | die "$subject too long - aborting\n" if $br > $max; | |
235 | if ($oneline && $input =~ m/^(.*)\n/) { | |
236 | $input = $1; | |
237 | last; | |
238 | } | |
239 | } | |
240 | die "unable to read $subject - $!\n" if !defined($count); | |
241 | ||
242 | return $input; | |
243 | } | |
244 | ||
245 | sub split_list { | |
246 | my $listtxt = shift || ''; | |
247 | ||
248 | return split (/\0/, $listtxt) if $listtxt =~ m/\0/; | |
249 | ||
250 | $listtxt =~ s/[,;]/ /g; | |
251 | $listtxt =~ s/^\s+//; | |
252 | ||
253 | my @data = split (/\s+/, $listtxt); | |
254 | ||
255 | return @data; | |
256 | } | |
257 | ||
a8d03417 DM |
258 | # split an shell argument string into an array, |
259 | sub split_args { | |
260 | my ($str) = @_; | |
261 | ||
262 | return $str ? [ Text::ParseWords::shellwords($str) ] : []; | |
263 | } | |
264 | ||
cff6d4f9 DM |
265 | sub extract_param { |
266 | my ($param, $key) = @_; | |
267 | ||
268 | my $res = $param->{$key}; | |
269 | delete $param->{$key}; | |
270 | ||
271 | return $res; | |
272 | } | |
273 | ||
565bbc73 | 274 | 1; |