"Fossies" - the Fresh Open Source Software Archive 
Member "BackupPC-4.4.0/lib/BackupPC/Xfer/Protocol.pm" (20 Jun 2020, 10312 Bytes) of package /linux/privat/BackupPC-4.4.0.tar.gz:
As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style:
standard) with prefixed line numbers and
code folding option.
Alternatively you can here
view or
download the uninterpreted source code file.
For more information about "Protocol.pm" see the
Fossies "Dox" file reference documentation and the latest
Fossies "Diffs" side-by-side code changes report:
4.3.2_vs_4.4.0.
1 #============================================================= -*-perl-*-
2 #
3 # BackupPC::Xfer::Protocol package
4 #
5 # DESCRIPTION
6 #
7 # This library defines a BackupPC::Xfer::Protocol class which
8 # defines standard methods for the transfer protocols in BackupPC.
9 #
10 # AUTHOR
11 # Paul Mantz <pcmantz@zmanda.com>
12 #
13 # COPYRIGHT
14 # Copyright (C) 2001-2020 Craig Barratt
15 #
16 # This program is free software: you can redistribute it and/or modify
17 # it under the terms of the GNU General Public License as published by
18 # the Free Software Foundation, either version 3 of the License, or
19 # (at your option) any later version.
20 #
21 # This program is distributed in the hope that it will be useful,
22 # but WITHOUT ANY WARRANTY; without even the implied warranty of
23 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 # GNU General Public License for more details.
25 #
26 # You should have received a copy of the GNU General Public License
27 # along with this program. If not, see <http://www.gnu.org/licenses/>.
28 #
29 #========================================================================
30 #
31 # Version 4.4.0, released 20 Jun 2020.
32 #
33 # See http://backuppc.sourceforge.net.
34 #
35 #========================================================================
36
37 package BackupPC::Xfer::Protocol;
38
39 use strict;
40 use Data::Dumper;
41 use Encode qw/from_to encode/;
42
43 #
44 # usage:
45 # $t = BackupPC::Xfer::Protocol->new($args);
46 #
47 # new() is the constructor. There's nothing special going on here.
48 #
49 sub new
50 {
51 my($class, $bpc, $args) = @_;
52
53 $args ||= {};
54 my $t = bless {
55 bpc => $bpc,
56 conf => $bpc->{Conf},
57 host => "",
58 hostIP => "",
59 shareName => "",
60 pipeRH => undef,
61 pipeWH => undef,
62 badFiles => [],
63 logLevel => $bpc->{Conf}{XferLogLevel},
64
65 #
66 # Various stats
67 #
68 byteCnt => 0,
69 fileCnt => 0,
70 xferErrCnt => 0,
71 xferBadShareCnt => 0,
72 xferBadFileCnt => 0,
73 xferOK => 0,
74
75 #
76 # User's args
77 #
78 %$args,
79 }, $class;
80
81 return $t;
82 }
83
84 #
85 # usage:
86 # $t->args($args);
87 #
88 # args() can be used to send additional argument to the Xfer object
89 # via a hash reference.
90 #
91 sub args
92 {
93 my($t, $args) = @_;
94
95 foreach my $arg ( keys(%$args) ) {
96 $t->{$arg} = $args->{$arg};
97 }
98 }
99
100 #
101 # usage:
102 # $t->start();
103 #
104 # start() executes the actual data transfer. Must be implemented by
105 # the derived class.
106 #
107 sub start
108 {
109 my($t) = @_;
110
111 $t->{_errStr} = "start() not implemented by " . ref($t);
112 return;
113 }
114
115 #
116 #
117 #
118 sub run
119 {
120 my($t) = @_;
121
122 $t->{_errStr} = "run() not implemented by " . ref($t);
123 return;
124 }
125
126 #
127 # usage:
128 # $t->readOutput();
129 #
130 # This function is only used when $t->useTar() == 1.
131 #
132 sub readOutput
133 {
134 my($t) = @_;
135
136 $t->{_errStr} = "readOutput() not implemented by " . ref($t);
137 return;
138 }
139
140 #
141 # usage:
142 # $t->abort($reason);
143 #
144 # Aborts the current job.
145 #
146 sub abort
147 {
148 my($t, $reason) = @_;
149 my @xferPid = $t->xferPid;
150
151 $t->{abort} = 1;
152 $t->{abortReason} = $reason;
153 if ( @xferPid ) {
154 kill($t->{bpc}->sigName2num("INT"), @xferPid);
155 }
156 }
157
158 #
159 # usage:
160 # $t->subSelectMask
161 #
162 # This function sets a mask for files when ($t->useTar == 1).
163 #
164 sub setSelectMask
165 {
166 my($t) = @_;
167
168 $t->{_errStr} = "readOutput() not implemented by " . ref($t);
169 }
170
171 #
172 # usage:
173 # $t->errStr();
174 #
175 sub errStr
176 {
177 my($t) = @_;
178
179 return $t->{_errStr};
180 }
181
182 #
183 # usage:
184 # $pid = $t->xferPid();
185 #
186 # xferPid() returns the process id of the child forked process.
187 #
188 sub xferPid
189 {
190 my($t) = @_;
191
192 return ($t->{xferPid});
193 }
194
195 #
196 # usage:
197 # $t->logMsg($msg);
198 #
199 sub logMsg
200 {
201 my($t, $msg) = @_;
202
203 push(@{$t->{_logMsg}}, $msg);
204 }
205
206 #
207 # usage:
208 # $t->logMsgGet();
209 #
210 sub logMsgGet
211 {
212 my($t) = @_;
213
214 return shift(@{$t->{_logMsg}});
215 }
216
217 #
218 # usage:
219 # $t->getStats();
220 #
221 # This function returns xfer statistics. It Returns a hash ref giving
222 # various status information about the transfer.
223 #
224 sub getStats
225 {
226 my($t) = @_;
227
228 return {
229 map { $_ => $t->{$_} }
230 qw(byteCnt fileCnt xferErrCnt xferBadShareCnt xferBadFileCnt
231 xferOK hostAbort hostError lastOutputLine)
232 };
233 }
234
235 sub getBadFiles
236 {
237 my($t) = @_;
238
239 return @{$t->{badFiles}};
240 }
241
242 #
243 # useTar function. In order to work correctly, the protocol in
244 # question should overwrite the function if it needs to return true.
245 #
246 sub useTar
247 {
248 return 0;
249 }
250
251 ##############################################################################
252 # Logging Functions
253 ##############################################################################
254
255 #
256 # usage:
257 # $t->logWrite($msg [, $level])
258 #
259 # This function writes to XferLOG.
260 #
261 sub logWrite
262 {
263 my($t, $msg, $level) = @_;
264
265 my $XferLOG = $t->{XferLOG};
266 $level = 3 if ( !defined($level) );
267
268 return ($XferLOG->write(\$msg)) if ( $level <= $t->{logLevel} );
269 }
270
271 ##############################################################################
272 # Share name mapping
273 ##############################################################################
274 #
275 # shareName2Path() maps the share name to the actual client path using
276 # the optional $Conf{ClientShareName2Path} setting.
277 #
278 sub shareName2Path
279 {
280 my($t, $shareName) = @_;
281
282 return $shareName
283 if ( ref($t->{conf}{ClientShareName2Path}) ne "HASH"
284 || ($t->{conf}{ClientShareName2Path}{$shareName} eq "" && $t->{conf}{ClientShareName2Path}{"*"} eq "") );
285 return $t->{conf}{ClientShareName2Path}{$shareName} if ( $t->{conf}{ClientShareName2Path}{$shareName} ne "" );
286 return $t->{conf}{ClientShareName2Path}{"*"} if ( $t->{conf}{ClientShareName2Path}{"*"} ne "" );
287 return $shareName;
288 }
289
290 ##############################################################################
291 # File Inclusion/Exclusion
292 ##############################################################################
293
294 #
295 # loadInclExclRegexps() places the appropriate file include/exclude regexps
296 #
297 sub loadInclExclRegexps
298 {
299 my($t, $shareType) = @_;
300 my $bpc = $t->{bpc};
301 my $conf = $t->{conf};
302
303 my @BackupFilesOnly = ();
304 my @BackupFilesExclude = ();
305 my($shareName, $shareNameRE);
306
307 $shareName = $t->{shareName};
308 $shareName =~ s/\/*$//; # remove trailing slashes
309 $shareName = "/" if ( $shareName eq "" );
310
311 $t->{shareName} = $shareName;
312 $t->{shareNameRE} = $bpc->glob2re($shareName);
313
314 #
315 # load all relevant values into @BackupFilesOnly
316 #
317 if ( ref($conf->{BackupFilesOnly}) eq "HASH" ) {
318
319 foreach my $share ( ('*', $shareName) ) {
320 push @BackupFilesOnly, @{$conf->{BackupFilesOnly}{$share}}
321 if ( defined($conf->{BackupFilesOnly}{$share}) );
322 }
323
324 } elsif ( ref($conf->{BackupFilesOnly}) eq "ARRAY" ) {
325
326 push(@BackupFilesOnly, @{$conf->{BackupFilesOnly}});
327
328 } elsif ( !defined($conf->{BackupFilesOnly}) ) {
329
330 #
331 # do nothing
332 #
333
334 } else {
335
336 #
337 # not a legitimate entry for $conf->{BackupFilesOnly}
338 #
339 $t->{_errStr} = "Incorrect syntax in BackupFilesOnly for host $t->{Host}";
340
341 return;
342 }
343
344 #
345 # load all relevant values into @BackupFilesExclude
346 #
347 if ( ref($conf->{BackupFilesExclude}) eq "HASH" ) {
348
349 foreach my $share ( ('*', $shareName) ) {
350 push(
351 @BackupFilesExclude,
352 map {
353 ($_ =~ /^\//)
354 ? ($t->{shareNameRE} . $bpc->glob2re($_))
355 : ('.*\/' . $bpc->glob2re($_) . '(?=\/.*)?')
356 } @{$conf->{BackupFilesExclude}{$share}}
357 ) if ( defined($conf->{BackupFilesExclude}{$share}) );
358 }
359
360 } elsif ( ref($conf->{BackupFilesExclude}) eq "ARRAY" ) {
361
362 push(@BackupFilesExclude,
363 map { ($_ =~ /\//) ? ($bpc->glob2re($_)) : ('.*\/' . $bpc->glob2re($_) . '(?<=\/.*)?') }
364 @{$conf->{BackupFilesExclude}});
365
366 } elsif ( !defined($conf->{BackupFilesOnly}) ) {
367
368 #
369 # do nothing here
370 #
371
372 } else {
373
374 #
375 # not a legitimate entry for $conf->{BackupFilesExclude}
376 #
377 $t->{_errStr} = "Incorrect syntax in BackupFilesExclude for host $t->{Host}";
378 return;
379 }
380
381 #
382 # load the regular expressions into the xfer object
383 #
384 $t->{BackupFilesOnly} = (@BackupFilesOnly > 0) ? \@BackupFilesOnly : undef;
385 $t->{BackupFilesExclude} = (@BackupFilesExclude > 0) ? \@BackupFilesExclude : undef;
386
387 return 1;
388 }
389
390 sub checkIncludeExclude
391 {
392 my($t, $file) = @_;
393
394 return ($t->checkIncludeMatch($file) && !$t->checkExcludeMatch($file));
395 }
396
397 sub checkIncludeMatch
398 {
399 my($t, $file) = @_;
400
401 my $shareName = $t->{shareName};
402 my $includes = $t->{BackupFilesOnly} || return 1;
403 my $match = "";
404
405 foreach my $include ( @{$includes} ) {
406
407 #
408 # construct regexp elsewhere to avoid syntactical evil
409 #
410 $match = '^' . quotemeta($shareName . $include) . '(?=\/.*)?';
411
412 #
413 # return true if the include folder is a parent of the file,
414 # or the folder itself.
415 #
416 return 1 if ( $file =~ /$match/ );
417
418 $match = '^' . quotemeta($file) . '(?=\/.*)?';
419
420 #
421 # return true if the file is a parent of the include folder,
422 # or the folder itself.
423 #
424 return 1 if ( "$shareName$include" =~ /$match/ );
425 }
426 return 0;
427 }
428
429 sub checkExcludeMatch
430 {
431 my($t, $file) = @_;
432
433 my $shareName = $t->{shareName};
434 my $excludes = $t->{BackupFilesExclude} || return 0;
435 my $match = "";
436
437 foreach my $exclude ( @{$excludes} ) {
438
439 #
440 # construct regexp elsewhere to avoid syntactical evil
441 #
442 $match = '^' . quotemeta($shareName . $exclude) . '(?=\/.*)?';
443
444 #
445 # return true if the exclude folder is a parent of the file,
446 # or the folder itself.
447 #
448 return 1 if ( $file =~ /$match/ );
449
450 $match = '^' . quotemeta($file) . '(?=\/.*)?';
451
452 #
453 # return true if the file is a parent of the exclude folder,
454 # or the folder itself.
455 #
456 return 1 if ( "$shareName$exclude" =~ /$match/ );
457 }
458 return 0;
459 }
460
461 1;