1#!/usr/bin/perl
2#============================================================= -*-perl-*-
3#
4# BackupPC_dump: Dump a single client.
5#
6# DESCRIPTION
7#
8#   Usage: BackupPC_dump [-i] [-f] [-F] [-I] [-d] [-e] [-v] <client>
9#
10#   Flags:
11#
12#     -i   Do an incremental dump, overriding any scheduling (but a full
13#          dump will be done if no dumps have yet succeeded)
14#
15#     -f   Do a full dump, overriding any scheduling.
16#
17#     -I   Do an increment dump if the regular schedule requires a
18#          full or incremental, otherwise do nothing (a full is done
19#          if no dumps have yet succeeded)
20#
21#     -F   Do a full dump if the regular schedule requires a
22#          full or incremental, otherwise do nothing
23#
24#     -d   Host is a DHCP pool address, and the client argument
25#          just an IP address.  We lookup the NetBios name from
26#          the IP address.
27#
28#     -e   Just do an dump expiry check for the client.  Don't do anything
29#          else.  This is used periodically by BackupPC to make sure that
30#          dhcp hosts have correctly expired old backups.  Without this,
31#          dhcp hosts that are no longer on the network will not expire
32#          old backups.
33#
34#     -v   verbose.  for manual usage: prints failure reasons in more detail.
35#
36#   BackupPC_dump is run periodically by BackupPC to backup $client.
37#   The file $TopDir/pc/$client/backups is read to decide whether a
38#   full or incremental backup needs to be run.  If no backup is
39#   scheduled, or a ping to $client fails, then BackupPC_dump quits.
40#
41#   The backup is done using the selected XferMethod (smb, tar, rsync,
42#   backuppcd etc), extracting the dump into $TopDir/pc/$client/new.
43#   The xfer output is put into $TopDir/pc/$client/XferLOG.
44#
45#   If the dump succeeds (based on parsing the output of the XferMethod):
46#     - $TopDir/pc/$client/new is renamed to $TopDir/pc/$client/nnn, where
47#           nnn is the next sequential dump number.
48#     - $TopDir/pc/$client/XferLOG is renamed to $TopDir/pc/$client/XferLOG.nnn.
49#     - $TopDir/pc/$client/backups is updated.
50#
51#   If the dump fails:
52#     - $TopDir/pc/$client/new is moved to $TopDir/trash for later removal.
53#     - $TopDir/pc/$client/XferLOG is renamed to $TopDir/pc/$client/XferLOG.bad
54#           for later viewing.
55#
56#   BackupPC_dump communicates to BackupPC via printing to STDOUT.
57#
58# AUTHOR
59#   Craig Barratt  <cbarratt@users.sourceforge.net>
60#
61# COPYRIGHT
62#   Copyright (C) 2001-2017  Craig Barratt
63#
64#   This program is free software; you can redistribute it and/or modify
65#   it under the terms of the GNU General Public License as published by
66#   the Free Software Foundation; either version 2 of the License, or
67#   (at your option) any later version.
68#
69#   This program is distributed in the hope that it will be useful,
70#   but WITHOUT ANY WARRANTY; without even the implied warranty of
71#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
72#   GNU General Public License for more details.
73#
74#   You should have received a copy of the GNU General Public License
75#   along with this program; if not, write to the Free Software
76#   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
77#
78#========================================================================
79#
80# Version 3.3.2, released 25 Jan 2017.
81#
82# See http://backuppc.sourceforge.net.
83#
84#========================================================================
85
86use strict;
87no  utf8;
88use lib "__INSTALLDIR__/lib";
89use BackupPC::Lib;
90use BackupPC::FileZIO;
91use BackupPC::Storage;
92use BackupPC::Xfer;
93use Encode;
94use Socket;
95use File::Path;
96use File::Find;
97use Getopt::Std;
98
99###########################################################################
100# Initialize
101###########################################################################
102
103die("BackupPC::Lib->new failed\n") if ( !(my $bpc = BackupPC::Lib->new) );
104my $TopDir = $bpc->TopDir();
105my $BinDir = $bpc->BinDir();
106my %Conf   = $bpc->Conf();
107my $NeedPostCmd;
108my $Hosts;
109my $SigName;
110my $Abort;
111
112$bpc->ChildInit();
113
114my %opts;
115if ( !getopts("defivFI", \%opts) || @ARGV != 1 ) {
116    print("usage: $0 [-d] [-e] [-f] [-i] [-F] [-I] [-v] <client>\n");
117    exit(1);
118}
119if ( $ARGV[0] !~ /^([\w\.\s-]+)$/ ) {
120    print("$0: bad client name '$ARGV[0]'\n");
121    exit(1);
122}
123if ( (defined($opts{f}) + defined($opts{i}) + defined($opts{F}) + defined($opts{I})) > 1 ) {
124    print("$0: exiting because you can only use one of -f, -i, -F, and -I\n");
125    exit(1);
126}
127
128my $client = $1;   # BackupPC's client name (might not be real host name)
129my $hostIP;        # this is the IP address
130my $host;          # this is the real host name
131
132my($clientURI, $user);
133
134$bpc->verbose(1) if ( $opts{v} );
135
136if ( $opts{d} ) {
137    #
138    # The client name $client is simply a DHCP address.  We need to check
139    # if there is any machine at this address, and if so, get the actual
140    # host name via NetBios using nmblookup.
141    #
142    $hostIP = $client;
143    if ( $bpc->CheckHostAlive($hostIP) < 0 ) {
144	print(STDERR "Exiting because CheckHostAlive($hostIP) failed\n")
145			    if ( $opts{v} );
146	exit(1);
147    }
148    if ( $Conf{NmbLookupCmd} eq "" ) {
149	print(STDERR "Exiting because \$Conf{NmbLookupCmd} is empty\n")
150			    if ( $opts{v} );
151	exit(1);
152    }
153    ($client, $user) = $bpc->NetBiosInfoGet($hostIP);
154    if ( $client !~ /^([\w\.\s-]+)$/ ) {
155	print(STDERR "Exiting because NetBiosInfoGet($hostIP) returned"
156                   . " '$client', an invalid host name\n") if ( $opts{v} );
157	exit(1)
158    }
159    $Hosts = $bpc->HostInfoRead($client);
160    $host = $client;
161} else {
162    $Hosts = $bpc->HostInfoRead($client);
163}
164if ( !defined($Hosts->{$client}) ) {
165    print(STDERR "Exiting because host $client does not exist in the"
166               . " hosts file\n") if ( $opts{v} );
167    exit(1)
168}
169
170my $Dir     = "$TopDir/pc/$client";
171my @xferPid = ();
172my $tarPid  = -1;
173my $completionPercent;
174
175#
176# Re-read config file, so we can include the PC-specific config
177#
178$clientURI = $bpc->uriEsc($client);
179if ( defined(my $error = $bpc->ConfigRead($client)) ) {
180    print("dump failed: Can't read PC's config file: $error\n");
181    exit(1);
182}
183%Conf = $bpc->Conf();
184
185#
186# Catch various signals
187#
188$SIG{INT}  = \&catch_signal;
189$SIG{ALRM} = \&catch_signal;
190$SIG{TERM} = \&catch_signal;
191$SIG{PIPE} = \&catch_signal;
192$SIG{STOP} = \&catch_signal;
193$SIG{TSTP} = \&catch_signal;
194$SIG{TTIN} = \&catch_signal;
195my $Pid = $$;
196
197#
198# Make sure we eventually timeout if there is no activity from
199# the data transport program.
200#
201alarm($Conf{ClientTimeout});
202
203mkpath($Dir, 0, 0777) if ( !-d $Dir );
204if ( !-f "$Dir/LOCK" ) {
205    open(LOCK, ">", "$Dir/LOCK") && close(LOCK);
206}
207
208my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
209my $logPath = sprintf("$Dir/LOG.%02d%04d", $mon + 1, $year + 1900);
210
211if ( !-f $logPath ) {
212    #
213    # Compress and prune old log files
214    #
215    my $lastLog = $Conf{MaxOldPerPCLogFiles} - 1;
216    foreach my $file ( $bpc->sortedPCLogFiles($client) ) {
217        if ( $lastLog <= 0 ) {
218            unlink($file);
219            next;
220        }
221        $lastLog--;
222        next if ( $file =~ /\.z$/ || !$Conf{CompressLevel} );
223        BackupPC::FileZIO->compressCopy($file,
224                                        "$file.z",
225                                        undef,
226                                        $Conf{CompressLevel}, 1);
227    }
228}
229
230open(LOG, ">>", $logPath);
231select(LOG); $| = 1; select(STDOUT);
232
233#
234# For the -e option we just expire backups and quit
235#
236if ( $opts{e} ) {
237    BackupExpire($client);
238    exit(0);
239}
240
241#
242# For archive hosts we don't bother any further
243#
244if ($Conf{XferMethod} eq "archive" ) {
245    print(STDERR "Exiting because the XferMethod is set to archive\n")
246                if ( $opts{v} );
247    exit(0);
248}
249
250###########################################################################
251# Figure out what to do and do it
252###########################################################################
253
254#
255# See if we should skip this host during a certain range
256# of times.
257#
258my $err = $bpc->ServerConnect($Conf{ServerHost}, $Conf{ServerPort});
259if ( $err ne "" ) {
260    print("Can't connect to server ($err)\n");
261    print(LOG $bpc->timeStamp, "Can't connect to server ($err)\n");
262    exit(1);
263}
264my $reply = $bpc->ServerMesg("status host($clientURI)");
265$reply = $1 if ( $reply =~ /(.*)/s );
266my(%StatusHost);
267eval($reply);
268$bpc->ServerDisconnect();
269
270#
271# For DHCP tell BackupPC which host this is
272#
273if ( $opts{d} ) {
274    if ( $StatusHost{activeJob} ) {
275        # oops, something is already running for this host
276	print(STDERR "Exiting because backup is already running for $client\n")
277			if ( $opts{v} );
278        exit(0);
279    }
280    print("DHCP $hostIP $clientURI\n");
281}
282
283my($needLink, @Backups, $type);
284my($incrBaseTime, $incrBaseBkupNum, $incrBaseLevel, $incrLevel);
285my $lastFullTime = 0;
286my $lastIncrTime = 0;
287my $partialIdx = -1;
288my $partialNum;
289my $partialFileCnt;
290my $lastBkupNum;
291my $lastPartial = 0;
292
293#
294# Maintain backward compatibility with $Conf{FullPeriod} == -1 or -2
295# meaning disable backups
296#
297$Conf{BackupsDisable} = -$Conf{FullPeriod}
298            if ( !$Conf{BackupsDisable} && $Conf{FullPeriod} < 0 );
299
300if ( $Conf{BackupsDisable} == 1 && !$opts{f} && !$opts{i}
301        || $Conf{BackupsDisable} == 2 ) {
302    print(STDERR "Exiting because backups are disabled with"
303       . " \$Conf{BackupsDisable} = $Conf{BackupsDisable}\n") if ( $opts{v} );
304    #
305    # Tell BackupPC to ignore old failed backups on hosts that
306    # have backups disabled.
307    #
308    print("backups disabled\n")
309		if ( defined($StatusHost{errorTime})
310		     && $StatusHost{reason} ne "Reason_backup_done"
311		     && time - $StatusHost{errorTime} > 4 * 24 * 3600 );
312    NothingToDo($needLink);
313}
314
315if ( !$opts{i} && !$opts{f} && $Conf{BlackoutGoodCnt} >= 0
316             && $StatusHost{aliveCnt} >= $Conf{BlackoutGoodCnt} ) {
317    my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
318    my($currHours) = $hour + $min / 60 + $sec / 3600;
319    my $blackout;
320
321    foreach my $p ( @{$Conf{BlackoutPeriods}} ) {
322        #
323        # Allow blackout to span midnight (specified by hourBegin
324        # being greater than hourEnd)
325        #
326        next if ( ref($p->{weekDays}) ne "ARRAY"
327                    || !defined($p->{hourBegin})
328                    || !defined($p->{hourEnd})
329                );
330        my $matchWday = $wday;
331        if ( $p->{hourBegin} > $p->{hourEnd} ) {
332            $blackout = $p->{hourBegin} <= $currHours
333                          || $currHours <= $p->{hourEnd};
334            if ( $currHours <= $p->{hourEnd} ) {
335                #
336                # This is after midnight, so decrement the weekday for the
337                # weekday check (eg: Monday 11pm-1am means Monday 2300 to
338                # Tuesday 0100, not Monday 2300-2400 plus Monday 0000-0100).
339                #
340                $matchWday--;
341                $matchWday += 7 if ( $matchWday < 0 );
342            }
343        } else {
344            $blackout = $p->{hourBegin} <= $currHours
345                          && $currHours <= $p->{hourEnd};
346        }
347        if ( $blackout && grep($_ == $matchWday, @{$p->{weekDays}}) ) {
348#           print(LOG $bpc->timeStamp, "skipping because of blackout"
349#                      . " (alive $StatusHost{aliveCnt} times)\n");
350            print(STDERR "Skipping $client because of blackout\n")
351                            if ( $opts{v} );
352            NothingToDo($needLink);
353        }
354    }
355}
356
357if ( !$opts{i} && !$opts{f} && $StatusHost{backoffTime} > time ) {
358    printf(LOG "%sskipping because of user requested delay (%.1f hours left)\n",
359                $bpc->timeStamp, ($StatusHost{backoffTime} - time) / 3600);
360    NothingToDo($needLink);
361}
362
363#
364# Now see if there are any old backups we should delete
365#
366BackupExpire($client);
367
368my(@lastIdxByLevel, $incrCntSinceFull);
369
370#
371# Read Backup information, and find times of the most recent full and
372# incremental backups.  Also figure out which backup we will use
373# as a starting point for an incremental.
374#
375@Backups = $bpc->BackupInfoRead($client);
376for ( my $i = 0 ; $i < @Backups ; $i++ ) {
377    $needLink = 1 if ( $Backups[$i]{nFilesNew} eq ""
378                        || -f "$Dir/NewFileList.$Backups[$i]{num}" );
379    if ( $Backups[$i]{type} eq "full" ) {
380        $incrCntSinceFull = 0;
381        $lastBkupNum = $Backups[$i]{num};
382        $lastIdxByLevel[0] = $i;
383	if ( $lastFullTime < $Backups[$i]{startTime} ) {
384	    $lastFullTime = $Backups[$i]{startTime};
385	}
386    } elsif ( $Backups[$i]{type} eq "incr" ) {
387        $incrCntSinceFull++;
388        $lastBkupNum = $Backups[$i]{num};
389        $lastIdxByLevel[$Backups[$i]{level}] = $i;
390        $lastIncrTime = $Backups[$i]{startTime}
391                if ( $lastIncrTime < $Backups[$i]{startTime} );
392    } elsif ( $Backups[$i]{type} eq "partial" ) {
393        $partialIdx     = $i;
394        $lastPartial    = $Backups[$i]{startTime};
395        $partialNum     = $Backups[$i]{num};
396        $partialFileCnt = $Backups[$i]{nFiles};
397    }
398}
399
400#
401# Decide whether we do nothing, or a full or incremental backup.
402#
403my $needs_full = (time - $lastFullTime > $Conf{FullPeriod} * 24 * 3600
404               && time - $lastIncrTime > $Conf{IncrPeriod} * 24 * 3600);
405my $needs_incr = (time - $lastIncrTime > $Conf{IncrPeriod} * 24 * 3600
406               && time - $lastFullTime > $Conf{IncrPeriod} * 24 * 3600);
407
408if ( $lastFullTime == 0
409        || $opts{f}
410        || (!$opts{i} && !$opts{I} && $needs_full)
411        || ( $opts{F} && $needs_incr) ) {
412    $type = "full";
413    $incrLevel = 0;
414    $incrBaseBkupNum = $lastBkupNum;
415} elsif ( $opts{i}
416        || $needs_incr
417        || ($opts{I} && $needs_full) ) {
418    $type = "incr";
419    #
420    # For an incremental backup, figure out which level we should
421    # do and the index of the reference backup, which is the most
422    # recent backup at any lower level.
423    #
424    @{$Conf{IncrLevels}} = [$Conf{IncrLevels}]
425                            unless ref($Conf{IncrLevels}) eq "ARRAY";
426    @{$Conf{IncrLevels}} = [1] if ( !@{$Conf{IncrLevels}} );
427    $incrCntSinceFull = $incrCntSinceFull % @{$Conf{IncrLevels}};
428    $incrLevel = $Conf{IncrLevels}[$incrCntSinceFull];
429    for ( my $i = 0 ; $i < $incrLevel ; $i++ ) {
430        my $idx = $lastIdxByLevel[$i];
431        next if ( !defined($idx) );
432        if ( !defined($incrBaseTime)
433                || $Backups[$idx]{startTime} > $incrBaseTime ) {
434            $incrBaseBkupNum = $Backups[$idx]{num};
435            $incrBaseLevel   = $Backups[$idx]{level};
436            $incrBaseTime    = $Backups[$idx]{startTime};
437        }
438    }
439    #
440    # Can't find any earlier lower-level backup!  Shouldn't
441    # happen - just do full instead
442    #
443    if ( !defined($incrBaseBkupNum) || $incrLevel < 1 ) {
444        $type = "full";
445        $incrBaseBkupNum = $lastBkupNum;
446    }
447} else {
448    NothingToDo($needLink);
449}
450
451#
452# Create top-level directories if they don't exist
453#
454foreach my $dir ( (
455            "$Conf{TopDir}",
456            "$Conf{TopDir}/pool",
457            "$Conf{TopDir}/cpool",
458            "$Conf{TopDir}/pc",
459            "$Conf{TopDir}/trash",
460        ) ) {
461    next if ( -d $dir );
462    mkpath($dir, 0, 0750);
463    if ( !-d $dir ) {
464        print("Failed to create $dir\n");
465        printf(LOG "%sFailed to create directory %s\n", $bpc->timeStamp, $dir);
466        print("link $clientURI\n") if ( $needLink );
467        exit(1);
468    } else {
469        printf(LOG "%sCreated directory %s\n", $bpc->timeStamp, $dir);
470    }
471}
472
473if ( !$bpc->HardlinkTest($Dir, "$TopDir/cpool") ) {
474    print(LOG $bpc->timeStamp, "Can't create a test hardlink between a file"
475               . " in $Dir and $TopDir/cpool.  Either these are different"
476               . " file systems, or this file system doesn't support hardlinks,"
477               . " or these directories don't exist, or there is a permissions"
478               . " problem, or the file system is out of inodes or full.  Use"
479               . " df, df -i, and ls -ld to check each of these possibilities."
480               . " Quitting...\n");
481    print("test hardlink between $Dir and $TopDir/cpool failed\n");
482    print("link $clientURI\n") if ( $needLink );
483    exit(1);
484}
485
486if ( !$opts{d} ) {
487    #
488    # In the non-DHCP case, make sure the host can be looked up
489    # via NS, or otherwise find the IP address via NetBios.
490    #
491    if ( $Conf{ClientNameAlias} ne "" ) {
492        $host = $Conf{ClientNameAlias};
493    } else {
494        $host = $client;
495    }
496    if ( !defined(gethostbyname($host)) ) {
497        #
498        # Ok, NS doesn't know about it.  Maybe it is a NetBios name
499        # instead.
500        #
501	print(STDERR "Name server doesn't know about $host; trying NetBios\n")
502			if ( $opts{v} );
503        if ( !defined($hostIP = $bpc->NetBiosHostIPFind($host)) ) {
504	    print(LOG $bpc->timeStamp, "Can't find host $host via netbios\n");
505            print("host not found\n");
506            exit(1);
507        }
508    } else {
509        $hostIP = $host;
510    }
511}
512
513#
514# Check if $host is alive
515#
516my $delay = $bpc->CheckHostAlive($hostIP);
517if ( $delay < 0 ) {
518    print(LOG $bpc->timeStamp, "no ping response\n");
519    print("no ping response\n");
520    print("link $clientURI\n") if ( $needLink );
521    exit(1);
522} elsif ( $delay > $Conf{PingMaxMsec} ) {
523    printf(LOG "%sping too slow: %.4gmsec\n", $bpc->timeStamp, $delay);
524    printf("ping too slow: %.4gmsec (threshold is %gmsec)\n",
525                    $delay, $Conf{PingMaxMsec});
526    print("link $clientURI\n") if ( $needLink );
527    exit(1);
528}
529
530#
531# Make sure it is really the machine we expect (only for fixed addresses,
532# since we got the DHCP address above).
533#
534if ( !$opts{d} && (my $errMsg = CorrectHostCheck($hostIP, $host)) ) {
535    print(LOG $bpc->timeStamp, "dump failed: $errMsg\n");
536    print("dump failed: $errMsg\n");
537    exit(1);
538} elsif ( $opts{d} ) {
539    print(LOG $bpc->timeStamp, "$host is dhcp $hostIP, user is $user\n");
540}
541
542#
543# Get a clean directory $Dir/new
544#
545$bpc->RmTreeDefer("$TopDir/trash", "$Dir/new") if ( -d "$Dir/new" );
546
547#
548# Setup file extension for compression and open XferLOG output file
549#
550if ( $Conf{CompressLevel} && !BackupPC::FileZIO->compOk ) {
551    print(LOG $bpc->timeStamp, "dump failed: can't find Compress::Zlib\n");
552    print("dump failed: can't find Compress::Zlib\n");
553    exit(1);
554}
555my $fileExt = $Conf{CompressLevel} > 0 ? ".z" : "";
556my $XferLOG = BackupPC::FileZIO->open("$Dir/XferLOG$fileExt", 1,
557                                     $Conf{CompressLevel});
558if ( !defined($XferLOG) ) {
559    print(LOG $bpc->timeStamp, "dump failed: unable to open/create"
560			     . " $Dir/XferLOG$fileExt\n");
561    print("dump failed: unable to open/create $Dir/XferLOG$fileExt\n");
562    exit(1);
563}
564
565#
566# Ignore the partial dump in the case of an incremental
567# or when the partial is too old.  A partial is a partial full.
568#
569if ( $type ne "full" || time - $lastPartial > $Conf{PartialAgeMax} * 24*3600 ) {
570    $partialNum = undef;
571    $partialIdx = -1;
572}
573
574#
575# If this is a partial, copy the old XferLOG file
576#
577if ( $partialNum ) {
578    my($compress, $fileName);
579    if ( -f "$Dir/XferLOG.$partialNum.z" ) {
580	$fileName = "$Dir/XferLOG.$partialNum.z";
581	$compress = 1;
582    } elsif ( -f "$Dir/XferLOG.$partialNum" ) {
583	$fileName = "$Dir/XferLOG.$partialNum";
584	$compress = 0;
585    }
586    if ( my $oldLOG = BackupPC::FileZIO->open($fileName, 0, $compress) ) {
587	my $data;
588	while ( $oldLOG->read(\$data, 65536) > 0 ) {
589	    $XferLOG->write(\$data);
590	}
591	$oldLOG->close;
592    }
593}
594
595$XferLOG->writeTeeStderr(1) if ( $opts{v} );
596unlink("$Dir/NewFileList") if ( -f "$Dir/NewFileList" );
597
598my $startTime     = time();
599my $tarErrs       = 0;
600my $nFilesExist   = 0;
601my $sizeExist     = 0;
602my $sizeExistComp = 0;
603my $nFilesTotal   = 0;
604my $sizeTotal     = 0;
605my($logMsg, %stat, $xfer, $ShareNames, $noFilesErr);
606my $newFilesFH;
607
608$ShareNames = BackupPC::Xfer::getShareNames(\%Conf);
609
610#
611# Run an optional pre-dump command
612#
613UserCommandRun("DumpPreUserCmd");
614if ( $? && $Conf{UserCmdCheckStatus} ) {
615    print(LOG $bpc->timeStamp,
616            "DumpPreUserCmd returned error status $?... exiting\n");
617    $XferLOG->write(\"DumpPreUserCmd returned error status $?... exiting\n");
618    $stat{hostError} = "DumpPreUserCmd returned error status $?";
619    BackupFailCleanup();
620}
621$NeedPostCmd = 1;
622
623#
624# Now backup each of the shares
625#
626my $shareDuplicate = {};
627for my $shareName ( @$ShareNames ) {
628    local(*RH, *WH);
629
630    #
631    # Convert $shareName to utf8 octets
632    #
633    $shareName = encode("utf8", $shareName);
634    $stat{xferOK} = $stat{hostAbort} = undef;
635    $stat{hostError} = $stat{lastOutputLine} = undef;
636    if ( $shareName eq "" ) {
637        print(LOG $bpc->timeStamp,
638                  "unexpected empty share name skipped\n");
639        next;
640    }
641    if ( $shareDuplicate->{$shareName} ) {
642        print(LOG $bpc->timeStamp,
643                  "unexpected repeated share name $shareName skipped\n");
644        next;
645    }
646    $shareDuplicate->{$shareName} = 1;
647
648    UserCommandRun("DumpPreShareCmd", $shareName);
649    if ( $? && $Conf{UserCmdCheckStatus} ) {
650        print(LOG $bpc->timeStamp,
651                "DumpPreShareCmd returned error status $?... exiting\n");
652        UserCommandRun("DumpPostUserCmd") if ( $NeedPostCmd );
653        $XferLOG->write(\"DumpPreShareCmd returned error status $?... exiting\n");
654        $stat{hostError} = "DumpPreShareCmd returned error status $?";
655        BackupFailCleanup();
656    }
657
658    $xfer = BackupPC::Xfer::create($Conf{XferMethod}, $bpc);
659    if ( !defined($xfer) ) {
660        my $errStr = BackupPC::Xfer::errStr();
661        print(LOG $bpc->timeStamp, "dump failed: $errStr\n");
662        UserCommandRun("DumpPostShareCmd", $shareName) if ( $NeedPostCmd );
663        UserCommandRun("DumpPostUserCmd") if ( $NeedPostCmd );
664        $XferLOG->write(\"BackupPC::Xfer::create failed: $errStr\n");
665        $stat{hostError} = $errStr;
666        BackupFailCleanup();
667    }
668
669    my $useTar = $xfer->useTar;
670
671    if ( $useTar ) {
672	#
673	# This xfer method outputs a tar format file, so we start a
674	# BackupPC_tarExtract to extract the data.
675	#
676	# Create a socketpair to connect the Xfer method to BackupPC_tarExtract
677	# WH is the write handle for writing, provided to the transport
678	# program, and RH is the other end of the socket for reading,
679	# provided to BackupPC_tarExtract.
680	#
681        if ( socketpair(RH, WH, AF_UNIX, SOCK_STREAM, PF_UNSPEC) ) {
682	    shutdown(RH, 1);	# no writing to this socket
683	    shutdown(WH, 0);	# no reading from this socket
684	    setsockopt(RH, SOL_SOCKET, SO_RCVBUF, 8 * 65536);
685	    setsockopt(WH, SOL_SOCKET, SO_SNDBUF, 8 * 65536);
686	} else {
687	    #
688	    # Default to pipe() if socketpair() doesn't work.
689	    #
690	    pipe(RH, WH);
691	}
692
693	#
694	# fork a child for BackupPC_tarExtract.  TAR is a file handle
695	# on which we (the parent) read the stdout & stderr from
696	# BackupPC_tarExtract.
697	#
698	if ( !defined($tarPid = open(TAR, "-|")) ) {
699	    print(LOG $bpc->timeStamp, "can't fork to run tar\n");
700	    print("can't fork to run tar\n");
701	    close(RH);
702	    close(WH);
703	    last;
704	}
705	binmode(TAR);
706	if ( !$tarPid ) {
707	    #
708	    # This is the tar child.  Close the write end of the pipe,
709	    # clone STDERR to STDOUT, clone STDIN from RH, and then
710	    # exec BackupPC_tarExtract.
711	    #
712	    setpgrp 0,0;
713	    close(WH);
714	    close(STDERR);
715	    open(STDERR, ">&STDOUT");
716	    close(STDIN);
717	    open(STDIN, "<&RH");
718	    alarm(0);
719	    exec("$BinDir/BackupPC_tarExtract", $client, $shareName,
720			 $Conf{CompressLevel});
721	    print(LOG $bpc->timeStamp,
722			"can't exec $BinDir/BackupPC_tarExtract\n");
723	    exit(0);
724	}
725    } elsif ( !defined($newFilesFH) ) {
726	#
727	# We need to create the NewFileList output file
728	#
729	local(*NEW_FILES);
730	open(NEW_FILES, ">", "$TopDir/pc/$client/NewFileList")
731		     || die("can't open $TopDir/pc/$client/NewFileList");
732	$newFilesFH = *NEW_FILES;
733	binmode(NEW_FILES);
734    }
735
736    #
737    # Run the transport program
738    #
739    $xfer->args({
740        host         => $host,
741        client       => $client,
742        hostIP       => $hostIP,
743        shareName    => $shareName,
744        pipeRH       => *RH,
745        pipeWH       => *WH,
746        XferLOG      => $XferLOG,
747	newFilesFH   => $newFilesFH,
748        outDir       => $Dir,
749        type         => $type,
750        incrBaseTime => $incrBaseTime,
751        incrBaseBkupNum => $incrBaseBkupNum,
752	backups      => \@Backups,
753	compress     => $Conf{CompressLevel},
754	XferMethod   => $Conf{XferMethod},
755	logLevel     => $Conf{XferLogLevel},
756        partialNum   => $partialNum,
757	pidHandler   => \&pidHandler,
758	completionPercent => \&completionPercent,
759    });
760
761    if ( !defined($logMsg = $xfer->start()) ) {
762        my $errStr = "xfer start failed: " . $xfer->errStr . "\n";
763        print(LOG $bpc->timeStamp, $errStr);
764        #
765        # kill off the tar process, first nicely then forcefully
766        #
767	if ( $tarPid > 0 ) {
768	    kill($bpc->sigName2num("INT"), $tarPid);
769	    sleep(1);
770	    kill($bpc->sigName2num("KILL"), $tarPid);
771	}
772	if ( @xferPid ) {
773	    kill($bpc->sigName2num("INT"), @xferPid);
774	    sleep(1);
775	    kill($bpc->sigName2num("KILL"), @xferPid);
776	}
777	UserCommandRun("DumpPostShareCmd", $shareName) if ( $NeedPostCmd );
778	UserCommandRun("DumpPostUserCmd") if ( $NeedPostCmd );
779        $XferLOG->write(\"xfer start failed: $errStr\n");
780        $stat{hostError} = $errStr;
781        BackupFailCleanup();
782    }
783
784    @xferPid = $xfer->xferPid;
785
786    if ( $useTar ) {
787	#
788	# The parent must close both handles on the pipe since the children
789	# are using these handles now.
790	#
791	close(RH);
792	close(WH);
793    }
794    print(LOG $bpc->timeStamp, $logMsg, "\n");
795    $XferLOG->write(\"$logMsg\n");
796    print("started $type dump, share=$shareName\n");
797
798    pidHandler(@xferPid);
799
800    if ( $useTar ) {
801	#
802	# Parse the output of the transfer program and BackupPC_tarExtract
803	# while they run.  Since we might be reading from two or more children
804	# we use a select.
805	#
806	my($FDread, $tarOut, $mesg);
807	vec($FDread, fileno(TAR), 1) = 1;
808	$xfer->setSelectMask(\$FDread);
809
810	SCAN: while ( 1 ) {
811	    my $ein = $FDread;
812	    last if ( $FDread =~ /^\0*$/ );
813	    select(my $rout = $FDread, undef, $ein, undef);
814            if ( vec($rout, fileno(TAR), 1) ) {
815                if ( sysread(TAR, $mesg, 8192) <= 0 ) {
816                    vec($FDread, fileno(TAR), 1) = 0;
817                    close(TAR);
818                } else {
819                    $tarOut .= $mesg;
820                }
821            }
822            while ( $tarOut =~ /(.*?)[\n\r]+(.*)/s ) {
823                $_ = $1;
824                $tarOut = $2;
825                if ( /^  / ) {
826                    $XferLOG->write(\"$_\n");
827                } else {
828                    $XferLOG->write(\"tarExtract: $_\n");
829                }
830                if ( /^BackupPC_tarExtact aborting \((.*)\)/ ) {
831                    $stat{hostError} = $1;
832                }
833                if ( /^Done: (\d+) errors, (\d+) filesExist, (\d+) sizeExist, (\d+) sizeExistComp, (\d+) filesTotal, (\d+) sizeTotal/ ) {
834                    $tarErrs       += $1;
835                    $nFilesExist   += $2;
836                    $sizeExist     += $3;
837                    $sizeExistComp += $4;
838                    $nFilesTotal   += $5;
839                    $sizeTotal     += $6;
840                }
841            }
842	    last if ( !$xfer->readOutput(\$FDread, $rout) );
843	    while ( my $str = $xfer->logMsgGet ) {
844		print(LOG $bpc->timeStamp, "xfer: $str\n");
845	    }
846	    if ( $xfer->getStats->{fileCnt} == 1 ) {
847		#
848		# Make sure it is still the machine we expect.  We do this while
849		# the transfer is running to avoid a potential race condition if
850		# the ip address was reassigned by dhcp just before we started
851		# the transfer.
852		#
853		if ( my $errMsg = CorrectHostCheck($hostIP, $host) ) {
854		    $stat{hostError} = $errMsg if ( $stat{hostError} eq "" );
855		    last SCAN;
856		}
857	    }
858	}
859    } else {
860	#
861	# otherwise the xfer module does everything for us
862	#
863	my @results = $xfer->run();
864	$tarErrs       += $results[0];
865	$nFilesExist   += $results[1];
866	$sizeExist     += $results[2];
867	$sizeExistComp += $results[3];
868	$nFilesTotal   += $results[4];
869	$sizeTotal     += $results[5];
870    }
871
872    #
873    # Merge the xfer status (need to accumulate counts)
874    #
875    my $newStat = $xfer->getStats;
876    # MAKSYM 14082016: forcing the right file count if some bytes were transferred; ensures compatibility with at least Samba-4.3
877    $newStat->{fileCnt} = $nFilesTotal if ( $useTar && $newStat->{fileCnt} == 0 && $xfer->getStats->{byteCnt} > 0 );
878    if ( $newStat->{fileCnt} == 0 ) {
879       $noFilesErr ||= "No files dumped for share $shareName";
880    }
881    foreach my $k ( (keys(%stat), keys(%$newStat)) ) {
882        next if ( !defined($newStat->{$k}) );
883        if ( $k =~ /Cnt$/ ) {
884            $stat{$k} += $newStat->{$k};
885            delete($newStat->{$k});
886            next;
887        }
888        if ( !defined($stat{$k}) ) {
889            $stat{$k} = $newStat->{$k};
890            delete($newStat->{$k});
891            next;
892        }
893    }
894
895    if ( $NeedPostCmd ) {
896        UserCommandRun("DumpPostShareCmd", $shareName);
897        if ( $? && $Conf{UserCmdCheckStatus} ) {
898            print(LOG $bpc->timeStamp,
899                    "DumpPostShareCmd returned error status $?... exiting\n");
900            $stat{hostError} = "DumpPostShareCmd returned error status $?";
901        }
902    }
903
904    $stat{xferOK} = 0 if ( $stat{hostError} || $stat{hostAbort} );
905    if ( !$stat{xferOK} ) {
906        #
907        # kill off the transfer program, first nicely then forcefully
908        #
909	if ( @xferPid ) {
910	    kill($bpc->sigName2num("INT"), @xferPid);
911	    sleep(1);
912	    kill($bpc->sigName2num("KILL"), @xferPid);
913	}
914        #
915        # kill off the tar process, first nicely then forcefully
916        #
917	if ( $tarPid > 0 ) {
918	    kill($bpc->sigName2num("INT"), $tarPid);
919	    sleep(1);
920	    kill($bpc->sigName2num("KILL"), $tarPid);
921	}
922        #
923        # don't do any more shares on this host
924        #
925        last;
926    }
927    #
928    # Wait for any child processes to exit
929    #
930    # 1 while ( wait() >= 0 );
931}
932
933#
934# If this is a full, and any share had zero files then consider the dump bad
935#
936if ( $type eq "full" && $stat{hostError} eq ""
937	    && length($noFilesErr) && $Conf{BackupZeroFilesIsFatal} ) {
938    $stat{hostError} = $noFilesErr;
939    $stat{xferOK} = 0;
940}
941
942$stat{xferOK} = 0 if ( $Abort );
943
944#
945# If there is no "new" directory then the backup is bad
946#
947if ( $stat{xferOK} && !-d "$Dir/new" ) {
948    $stat{hostError} = "No backup directory $Dir/new"
949                            if ( $stat{hostError} eq "" );
950    $stat{xferOK} = 0;
951}
952
953#
954# Do one last check to make sure it is still the machine we expect.
955#
956if ( $stat{xferOK} && (my $errMsg = CorrectHostCheck($hostIP, $host)) ) {
957    $stat{hostError} = $errMsg;
958    $stat{xferOK} = 0;
959}
960
961UserCommandRun("DumpPostUserCmd") if ( $NeedPostCmd );
962if ( $? && $Conf{UserCmdCheckStatus} ) {
963    print(LOG $bpc->timeStamp,
964            "DumpPostUserCmd returned error status $?... exiting\n");
965    $stat{hostError} = "DumpPostUserCmd returned error status $?";
966    $stat{xferOK} = 0;
967}
968close($newFilesFH) if ( defined($newFilesFH) );
969
970my $endTime = time();
971
972#
973# If the dump failed, clean up
974#
975if ( !$stat{xferOK} ) {
976    $stat{hostError} = $stat{lastOutputLine} if ( $stat{hostError} eq "" );
977    if ( $stat{hostError} ) {
978        print(LOG $bpc->timeStamp,
979                  "Got fatal error during xfer ($stat{hostError})\n");
980	$XferLOG->write(\"Got fatal error during xfer ($stat{hostError})\n");
981    }
982    if ( !$Abort ) {
983	#
984	# wait a short while and see if the system is still alive
985	#
986	sleep(5);
987	if ( $bpc->CheckHostAlive($hostIP) < 0 ) {
988	    $stat{hostAbort} = 1;
989	}
990	if ( $stat{hostAbort} ) {
991	    $stat{hostError} = "lost network connection during backup";
992	}
993	print(LOG $bpc->timeStamp, "Backup aborted ($stat{hostError})\n");
994	$XferLOG->write(\"Backup aborted ($stat{hostError})\n");
995    } else {
996	$XferLOG->write(\"Backup aborted by user signal\n");
997    }
998
999    #
1000    # Close the log file and call BackupFailCleanup, which exits.
1001    #
1002    BackupFailCleanup();
1003}
1004
1005my $newNum = BackupSave();
1006
1007my $otherCount = $stat{xferErrCnt} - $stat{xferBadFileCnt}
1008                                   - $stat{xferBadShareCnt};
1009$stat{fileCnt}         ||= 0;
1010$stat{byteCnt}         ||= 0;
1011$stat{xferErrCnt}      ||= 0;
1012$stat{xferBadFileCnt}  ||= 0;
1013$stat{xferBadShareCnt} ||= 0;
1014print(LOG $bpc->timeStamp,
1015          "$type backup $newNum complete, $stat{fileCnt} files,"
1016        . " $stat{byteCnt} bytes,"
1017        . " $stat{xferErrCnt} xferErrs ($stat{xferBadFileCnt} bad files,"
1018        . " $stat{xferBadShareCnt} bad shares, $otherCount other)\n");
1019
1020BackupExpire($client);
1021
1022print("$type backup complete\n");
1023
1024###########################################################################
1025# Subroutines
1026###########################################################################
1027
1028sub NothingToDo
1029{
1030    my($needLink) = @_;
1031
1032    print("nothing to do\n");
1033    print("link $clientURI\n") if ( $needLink );
1034    exit(0);
1035}
1036
1037sub catch_signal
1038{
1039    my $sigName = shift;
1040
1041    #
1042    # The first time we receive a signal we try to gracefully
1043    # abort the backup.  This allows us to keep a partial dump
1044    # with the in-progress file deleted and attribute caches
1045    # flushed to disk etc.
1046    #
1047    if ( !length($SigName) ) {
1048	my $reason;
1049	if ( $sigName eq "INT" ) {
1050	    $reason = "aborted by user (signal=$sigName)";
1051	} else {
1052	    $reason = "aborted by signal=$sigName";
1053	}
1054	if ( $Pid == $$ ) {
1055	    #
1056	    # Parent logs a message
1057	    #
1058	    print(LOG $bpc->timeStamp,
1059		    "Aborting backup up after signal $sigName\n");
1060
1061	    #
1062	    # Tell xfer to abort, but only if we actually started one
1063	    #
1064	    $xfer->abort($reason) if ( defined($xfer) );
1065
1066	    #
1067	    # Send ALRMs to BackupPC_tarExtract if we are using it
1068	    #
1069	    if ( $tarPid > 0 ) {
1070		kill($bpc->sigName2num("ARLM"), $tarPid);
1071	    }
1072
1073	    #
1074	    # Schedule a 20 second timer in case the clean
1075	    # abort doesn't complete
1076	    #
1077	    alarm(20);
1078	} else {
1079	    #
1080	    # Children ignore anything other than ALRM and INT
1081	    #
1082	    if ( $sigName ne "ALRM" && $sigName ne "INT" ) {
1083		return;
1084	    }
1085
1086	    #
1087	    # The child also tells xfer to abort
1088	    #
1089	    $xfer->abort($reason);
1090
1091	    #
1092	    # Schedule a 15 second timer in case the clean
1093	    # abort doesn't complete
1094	    #
1095	    alarm(15);
1096	}
1097	$SigName = $sigName;
1098	$Abort = 1;
1099	return;
1100    }
1101
1102    #
1103    # This is a second signal: time to clean up.
1104    #
1105    if ( $Pid != $$ && ($sigName eq "ALRM" || $sigName eq "INT") ) {
1106	#
1107	# Children quit quietly on ALRM or INT
1108	#
1109	exit(1)
1110    }
1111
1112    #
1113    # Ignore other signals in children
1114    #
1115    return if ( $Pid != $$ );
1116
1117    $SIG{$sigName} = 'IGNORE';
1118    UserCommandRun("DumpPostUserCmd") if ( $NeedPostCmd );
1119    $XferLOG->write(\"exiting after signal $sigName\n");
1120    if ( @xferPid ) {
1121        kill($bpc->sigName2num("INT"), @xferPid);
1122	sleep(1);
1123	kill($bpc->sigName2num("KILL"), @xferPid);
1124    }
1125    if ( $tarPid > 0 ) {
1126        kill($bpc->sigName2num("INT"), $tarPid);
1127	sleep(1);
1128	kill($bpc->sigName2num("KILL"), $tarPid);
1129    }
1130    if ( $sigName eq "INT" ) {
1131        $stat{hostError} = "aborted by user (signal=$sigName)";
1132    } else {
1133        $stat{hostError} = "received signal=$sigName";
1134    }
1135    BackupFailCleanup();
1136}
1137
1138sub CheckForNewFiles
1139{
1140    if ( -f _ && $File::Find::name !~ /\/fattrib$/ ) {
1141        $nFilesTotal++;
1142    } elsif ( -d _ ) {
1143	#
1144	# No need to check entire tree
1145	#
1146        $File::Find::prune = 1 if ( $nFilesTotal );
1147    }
1148}
1149
1150sub BackupFailCleanup
1151{
1152    my $fileExt = $Conf{CompressLevel} > 0 ? ".z" : "";
1153    my $keepPartial = 0;
1154
1155    #
1156    # We keep this backup if it is a full and we actually backed
1157    # up some files.  If the prior backup was a partial too, we
1158    # only keep this backup if it has more files than the previous
1159    # partial.
1160    #
1161    if ( $type eq "full" ) {
1162	if ( $nFilesTotal == 0 && $xfer->getStats->{fileCnt} == 0 ) {
1163	    #
1164	    # Xfer didn't report any files, but check in the new
1165	    # directory just in case.
1166	    #
1167	    find(\&CheckForNewFiles, "$Dir/new");
1168        }
1169        my $str;
1170        if ( $nFilesTotal > $partialFileCnt
1171                || $xfer->getStats->{fileCnt} > $partialFileCnt ) {
1172            #
1173            # If the last backup wasn't a partial then
1174            # $partialFileCnt is undefined, so the above
1175            # test is simply $nFilesTotal > 0
1176            #
1177	    $keepPartial = 1;
1178            if ( $partialFileCnt ) {
1179                $str = "Saving this as a partial backup\n";
1180            } else {
1181                $str = sprintf("Saving this as a partial backup, replacing the"
1182                         . " prior one (got %d and %d files versus %d)\n",
1183                         $nFilesTotal, $xfer->getStats->{fileCnt}, $partialFileCnt);
1184            }
1185	} else {
1186            $str = sprintf("Not saving this as a partial backup since it has fewer"
1187                     . " files than the prior one (got %d and %d files versus %d)\n",
1188                     $nFilesTotal, $xfer->getStats->{fileCnt}, $partialFileCnt);
1189        }
1190        $XferLOG->write(\$str);
1191    }
1192
1193    #
1194    # Don't keep partials if they are disabled
1195    #
1196    $keepPartial = 0 if ( $Conf{PartialAgeMax} < 0 );
1197
1198    if ( !$keepPartial ) {
1199        #
1200        # No point in saving this dump; get rid of eveything.
1201        #
1202        $XferLOG->close();
1203        unlink("$Dir/timeStamp.level0")    if ( -f "$Dir/timeStamp.level0" );
1204        unlink("$Dir/SmbLOG.bad")          if ( -f "$Dir/SmbLOG.bad" );
1205        unlink("$Dir/SmbLOG.bad$fileExt")  if ( -f "$Dir/SmbLOG.bad$fileExt" );
1206        unlink("$Dir/XferLOG.bad")         if ( -f "$Dir/XferLOG.bad" );
1207        unlink("$Dir/XferLOG.bad$fileExt") if ( -f "$Dir/XferLOG.bad$fileExt" );
1208        unlink("$Dir/NewFileList")         if ( -f "$Dir/NewFileList" );
1209        rename("$Dir/XferLOG$fileExt", "$Dir/XferLOG.bad$fileExt");
1210        $bpc->RmTreeDefer("$TopDir/trash", "$Dir/new") if ( -d "$Dir/new" );
1211        print("dump failed: $stat{hostError}\n");
1212        $XferLOG->close();
1213        print("link $clientURI\n") if ( $needLink );
1214        exit(1);
1215    }
1216    #
1217    # Ok, now we should save this as a partial dump
1218    #
1219    $type = "partial";
1220    my $newNum = BackupSave();
1221    print("dump failed: $stat{hostError}\n");
1222    print("link $clientURI\n") if ( $needLink );
1223    print(LOG $bpc->timeStamp, "Saved partial dump $newNum\n");
1224    exit(2);
1225}
1226
1227#
1228# Decide which old backups should be expired by moving them
1229# to $TopDir/trash.
1230#
1231sub BackupExpire
1232{
1233    my($client) = @_;
1234    my($Dir) = "$TopDir/pc/$client";
1235    my(@Backups) = $bpc->BackupInfoRead($client);
1236    my($cntFull, $cntIncr, $firstFull, $firstIncr, $oldestIncr,
1237       $oldestFull, $changes);
1238
1239    if ( $Conf{FullKeepCnt} <= 0 ) {
1240        print(LOG $bpc->timeStamp,
1241                  "Invalid value for \$Conf{FullKeepCnt}=$Conf{FullKeepCnt}\n");
1242	print(STDERR
1243            "Invalid value for \$Conf{FullKeepCnt}=$Conf{FullKeepCnt}\n")
1244			    if ( $opts{v} );
1245        return;
1246    }
1247    while ( 1 ) {
1248	$cntFull = $cntIncr = 0;
1249	$oldestIncr = $oldestFull = 0;
1250	for ( my $i = 0 ; $i < @Backups ; $i++ ) {
1251	    if ( $Backups[$i]{type} eq "full" ) {
1252		$firstFull = $i if ( $cntFull == 0 );
1253		$cntFull++;
1254	    } elsif ( $Backups[$i]{type} eq "incr" ) {
1255		$firstIncr = $i if ( $cntIncr == 0 );
1256		$cntIncr++;
1257	    }
1258	}
1259	$oldestIncr = (time - $Backups[$firstIncr]{startTime}) / (24 * 3600)
1260                        if ( $cntIncr > 0 );
1261	$oldestFull = (time - $Backups[$firstFull]{startTime}) / (24 * 3600)
1262                        if ( $cntFull > 0 );
1263
1264        #
1265        # With multi-level incrementals, several of the following
1266        # incrementals might depend upon this one, so we have to
1267        # delete all of the them.  Figure out if that is possible
1268        # by counting the number of consecutive incrementals that
1269        # are unfilled and have a level higher than this one.
1270        #
1271        my $cntIncrDel = 1;
1272        my $earliestIncr = $oldestIncr;
1273
1274        if ( defined($firstIncr) ) {
1275            for ( my $i = $firstIncr + 1 ; $i < @Backups ; $i++ ) {
1276                last if ( $Backups[$i]{level} <= $Backups[$firstIncr]{level}
1277                       || !$Backups[$i]{noFill} );
1278                $cntIncrDel++;
1279                $earliestIncr = (time - $Backups[$i]{startTime}) / (24 * 3600);
1280            }
1281        }
1282
1283	if ( $cntIncr >= $Conf{IncrKeepCnt} + $cntIncrDel
1284		|| ($cntIncr >= $Conf{IncrKeepCntMin} + $cntIncrDel
1285		    && $earliestIncr > $Conf{IncrAgeMax}) ) {
1286            #
1287            # Only delete an incr backup if the Conf settings are satisfied
1288            # for all $cntIncrDel incrementals.  Since BackupRemove() does
1289            # a splice() we need to do the deletes in the reverse order.
1290            #
1291            for ( my $i = $firstIncr + $cntIncrDel - 1 ;
1292                    $i >= $firstIncr ; $i-- ) {
1293                print(LOG $bpc->timeStamp,
1294                          "removing incr backup $Backups[$i]{num}\n");
1295                BackupRemove($client, \@Backups, $i);
1296                $changes++;
1297            }
1298            next;
1299        }
1300
1301        #
1302        # Delete any old full backups, according to $Conf{FullKeepCntMin}
1303	# and $Conf{FullAgeMax}.
1304        #
1305	# First make sure that $Conf{FullAgeMax} is at least bigger
1306	# than $Conf{FullPeriod} * $Conf{FullKeepCnt}, including
1307	# the exponential array case.
1308        #
1309	my $fullKeepCnt = $Conf{FullKeepCnt};
1310	$fullKeepCnt = [$fullKeepCnt] if ( ref($fullKeepCnt) ne "ARRAY" );
1311	my $fullAgeMax;
1312	my $fullPeriod = int(0.5 + $Conf{FullPeriod});
1313        $fullPeriod = 7 if ( $fullPeriod <= 0 );
1314	for ( my $i = 0 ; $i < @$fullKeepCnt ; $i++ ) {
1315	    $fullAgeMax += $fullKeepCnt->[$i] * $fullPeriod;
1316	    $fullPeriod *= 2;
1317	}
1318	$fullAgeMax += $fullPeriod;	# add some buffer
1319
1320        if ( $cntFull > $Conf{FullKeepCntMin}
1321               && $oldestFull > $Conf{FullAgeMax}
1322               && $oldestFull > $fullAgeMax
1323	       && $Conf{FullKeepCntMin} > 0
1324	       && $Conf{FullAgeMax} > 0
1325               && (@Backups <= $firstFull + 1
1326                        || !$Backups[$firstFull + 1]{noFill}) ) {
1327            #
1328            # Only delete a full backup if the Conf settings are satisfied.
1329            # We also must make sure that either this backup is the most
1330            # recent one, or the next backup is filled.
1331            # (We can't deleted a full backup if the next backup is not
1332            # filled.)
1333            #
1334	    print(LOG $bpc->timeStamp,
1335                   "removing old full backup $Backups[$firstFull]{num}\n");
1336            BackupRemove($client, \@Backups, $firstFull);
1337            $changes++;
1338            next;
1339        }
1340
1341        #
1342        # Do new-style full backup expiry, which includes the the case
1343	# where $Conf{FullKeepCnt} is an array.
1344        #
1345        last if ( !BackupFullExpire($client, \@Backups) );
1346        $changes++;
1347    }
1348    $bpc->BackupInfoWrite($client, @Backups) if ( $changes );
1349}
1350
1351#
1352# Handle full backup expiry, using exponential periods.
1353#
1354sub BackupFullExpire
1355{
1356    my($client, $Backups) = @_;
1357    my $fullCnt = 0;
1358    my $fullPeriod = $Conf{FullPeriod};
1359    my $origFullPeriod = $fullPeriod;
1360    my $fullKeepCnt = $Conf{FullKeepCnt};
1361    my $fullKeepIdx = 0;
1362    my(@delete, @fullList);
1363
1364    #
1365    # Don't delete anything if $Conf{FullPeriod} or $Conf{FullKeepCnt} are
1366    # not defined - possibly a corrupted config.pl file.
1367    #
1368    return if ( !defined($Conf{FullPeriod}) || !defined($Conf{FullKeepCnt}) );
1369
1370    #
1371    # If regular backups are still disabled with $Conf{FullPeriod} < 0,
1372    # we still expire backups based on a typical FullPeriod value - weekly.
1373    #
1374    $fullPeriod = 7 if ( $fullPeriod <= 0 );
1375
1376    $fullKeepCnt = [$fullKeepCnt] if ( ref($fullKeepCnt) ne "ARRAY" );
1377
1378    for ( my $i = 0 ; $i < @$Backups ; $i++ ) {
1379        next if ( $Backups->[$i]{type} ne "full" );
1380        push(@fullList, $i);
1381    }
1382    for ( my $k = @fullList - 1 ; $k >= 0 ; $k-- ) {
1383        my $i = $fullList[$k];
1384        my $prevFull = $fullList[$k-1] if ( $k > 0 );
1385        #
1386        # Don't delete any full that is followed by an unfilled backup,
1387        # since it is needed for restore.
1388        #
1389        my $noDelete = $i + 1 < @$Backups ? $Backups->[$i+1]{noFill} : 0;
1390
1391        if ( !$noDelete &&
1392              ($fullKeepIdx >= @$fullKeepCnt
1393              || $k > 0
1394                 && $fullKeepIdx > 0
1395                 && $Backups->[$i]{startTime} - $Backups->[$prevFull]{startTime}
1396                             < ($fullPeriod - $origFullPeriod / 2) * 24 * 3600
1397               )
1398            ) {
1399            #
1400            # Delete the full backup
1401            #
1402            #print("Deleting backup $i ($prevFull)\n");
1403            unshift(@delete, $i);
1404        } else {
1405            $fullCnt++;
1406            while ( $fullKeepIdx < @$fullKeepCnt
1407                     && $fullCnt >= $fullKeepCnt->[$fullKeepIdx] ) {
1408                $fullKeepIdx++;
1409                $fullCnt = 0;
1410                $fullPeriod = 2 * $fullPeriod;
1411            }
1412        }
1413    }
1414    #
1415    # Now actually delete the backups
1416    #
1417    for ( my $i = @delete - 1 ; $i >= 0 ; $i-- ) {
1418        print(LOG $bpc->timeStamp,
1419               "removing full backup $Backups->[$delete[$i]]{num}\n");
1420        BackupRemove($client, $Backups, $delete[$i]);
1421    }
1422    return @delete;
1423}
1424
1425#
1426# Removes any partial backups
1427#
1428sub BackupPartialRemove
1429{
1430    my($client, $Backups) = @_;
1431
1432    for ( my $i = @$Backups - 1 ; $i >= 0 ; $i-- ) {
1433        next if ( $Backups->[$i]{type} ne "partial" );
1434        BackupRemove($client, $Backups, $i);
1435    }
1436}
1437
1438sub BackupSave
1439{
1440    my @Backups = $bpc->BackupInfoRead($client);
1441    my $num  = -1;
1442    my $newFilesFH;
1443
1444    #
1445    # Since we got a good backup we should remove any partial dumps
1446    # (the new backup might also be a partial, but that's ok).
1447    #
1448    BackupPartialRemove($client, \@Backups);
1449    $needLink = 1 if ( -f "$Dir/NewFileList" );
1450
1451    #
1452    # Number the new backup
1453    #
1454    for ( my $i = 0 ; $i < @Backups ; $i++ ) {
1455        $num = $Backups[$i]{num} if ( $num < $Backups[$i]{num} );
1456    }
1457    $num++;
1458    $bpc->RmTreeDefer("$TopDir/trash", "$Dir/$num") if ( -d "$Dir/$num" );
1459    if ( !rename("$Dir/new", "$Dir/$num") ) {
1460        print(LOG $bpc->timeStamp, "Rename $Dir/new -> $Dir/$num failed\n");
1461        $stat{xferOK} = 0;
1462        return;
1463    }
1464
1465    #
1466    # Add the new backup information to the backup file
1467    #
1468    my $i = @Backups;
1469    $Backups[$i]{num}           = $num;
1470    $Backups[$i]{type}          = $type;
1471    $Backups[$i]{startTime}     = $startTime;
1472    $Backups[$i]{endTime}       = $endTime;
1473    $Backups[$i]{size}          = $sizeTotal;
1474    $Backups[$i]{nFiles}        = $nFilesTotal;
1475    $Backups[$i]{xferErrs}      = $stat{xferErrCnt} || 0;
1476    $Backups[$i]{xferBadFile}   = $stat{xferBadFileCnt} || 0;
1477    $Backups[$i]{xferBadShare}  = $stat{xferBadShareCnt} || 0;
1478    $Backups[$i]{nFilesExist}   = $nFilesExist;
1479    $Backups[$i]{sizeExist}     = $sizeExist;
1480    $Backups[$i]{sizeExistComp} = $sizeExistComp;
1481    $Backups[$i]{tarErrs}       = $tarErrs;
1482    $Backups[$i]{compress}      = $Conf{CompressLevel};
1483    $Backups[$i]{noFill}        = $type eq "incr" ? 1 : 0;
1484    $Backups[$i]{level}         = $incrLevel;
1485    $Backups[$i]{mangle}        = 1;     # name mangling always on for v1.04+
1486    $Backups[$i]{xferMethod}    = $Conf{XferMethod};
1487    $Backups[$i]{charset}       = $Conf{ClientCharset};
1488    $Backups[$i]{version}       = $bpc->Version();
1489    #
1490    # Save the main backups file
1491    #
1492    $bpc->BackupInfoWrite($client, @Backups);
1493    #
1494    # Save just this backup's info in case the main backups file
1495    # gets corrupted
1496    #
1497    BackupPC::Storage->backupInfoWrite($Dir, $Backups[$i]{num},
1498                                             $Backups[$i]);
1499
1500    unlink("$Dir/timeStamp.level0") if ( -f "$Dir/timeStamp.level0" );
1501    foreach my $ext ( qw(bad bad.z) ) {
1502	next if ( !-f "$Dir/XferLOG.$ext" );
1503	unlink("$Dir/XferLOG.$ext.old") if ( -f "$Dir/XferLOG.$ext" );
1504	rename("$Dir/XferLOG.$ext", "$Dir/XferLOG.$ext.old");
1505    }
1506
1507    #
1508    # Now remove the bad files, replacing them if possible with links to
1509    # earlier backups.
1510    #
1511    foreach my $f ( $xfer->getBadFiles ) {
1512	my $j;
1513	my $shareM = $bpc->fileNameEltMangle($f->{share});
1514	my $fileM  = $bpc->fileNameMangle($f->{file});
1515	unlink("$Dir/$num/$shareM/$fileM");
1516	for ( $j = $i - 1 ; $j >= 0 ; $j-- ) {
1517	    my $file;
1518	    if ( $Backups[$j]{mangle} ) {
1519		$file = "$shareM/$fileM";
1520	    } else {
1521		$file = "$f->{share}/$f->{file}";
1522	    }
1523	    next if ( !-f "$Dir/$Backups[$j]{num}/$file" );
1524
1525            my($exists, $digest, $origSize, $outSize, $errs)
1526                                = BackupPC::PoolWrite::LinkOrCopy(
1527                                      $bpc,
1528                                      "$Dir/$Backups[$j]{num}/$file",
1529                                      $Backups[$j]{compress},
1530                                      "$Dir/$num/$shareM/$fileM",
1531                                      $Conf{CompressLevel});
1532            if ( !$exists ) {
1533                #
1534                # the hard link failed, most likely because the target
1535                # file has too many links.  We have copied the file
1536                # instead, so add this to the new file list.
1537                #
1538                if ( !defined($newFilesFH) ) {
1539                    my $str = "Appending to NewFileList for $shareM/$fileM\n";
1540                    $XferLOG->write(\$str);
1541                    open($newFilesFH, ">>", "$TopDir/pc/$client/NewFileList")
1542                         || die("can't open $TopDir/pc/$client/NewFileList");
1543                    binmode($newFilesFH);
1544                }
1545                if ( -f "$Dir/$num/$shareM/$fileM" ) {
1546                    print($newFilesFH "$digest $origSize $shareM/$fileM\n");
1547                } else {
1548                    my $str = "Unable to link/copy $num/$f->{share}/$f->{file}"
1549                            . " to $Backups[$j]{num}/$f->{share}/$f->{file}\n";
1550                    $XferLOG->write(\$str);
1551                }
1552	    } else {
1553		my $str = "Bad file $num/$f->{share}/$f->{file} replaced"
1554                        . " by link to"
1555                        . " $Backups[$j]{num}/$f->{share}/$f->{file}\n";
1556		$XferLOG->write(\$str);
1557	    }
1558	    last;
1559	}
1560	if ( $j < 0 ) {
1561	    my $str = "Removed bad file $num/$f->{share}/$f->{file}"
1562                    . " (no older copy to link to)\n";
1563	    $XferLOG->write(\$str);
1564	}
1565    }
1566    close($newFilesFH) if ( defined($newFilesFH) );
1567    $XferLOG->close();
1568    rename("$Dir/XferLOG$fileExt", "$Dir/XferLOG.$num$fileExt");
1569    rename("$Dir/NewFileList", "$Dir/NewFileList.$num");
1570
1571    return $num;
1572}
1573
1574#
1575# Removes a specific backup
1576#
1577sub BackupRemove
1578{
1579    my($client, $Backups, $idx) = @_;
1580    my($Dir) = "$TopDir/pc/$client";
1581
1582    if ( $Backups->[$idx]{num} eq "" ) {
1583        print("BackupRemove: ignoring empty backup number for idx $idx\n");
1584        return;
1585    }
1586
1587    $bpc->RmTreeDefer("$TopDir/trash",
1588                      "$Dir/$Backups->[$idx]{num}");
1589    unlink("$Dir/SmbLOG.$Backups->[$idx]{num}")
1590                if ( -f "$Dir/SmbLOG.$Backups->[$idx]{num}" );
1591    unlink("$Dir/SmbLOG.$Backups->[$idx]{num}.z")
1592                if ( -f "$Dir/SmbLOG.$Backups->[$idx]{num}.z" );
1593    unlink("$Dir/XferLOG.$Backups->[$idx]{num}")
1594                if ( -f "$Dir/XferLOG.$Backups->[$idx]{num}" );
1595    unlink("$Dir/XferLOG.$Backups->[$idx]{num}.z")
1596                if ( -f "$Dir/XferLOG.$Backups->[$idx]{num}.z" );
1597    splice(@{$Backups}, $idx, 1);
1598}
1599
1600sub CorrectHostCheck
1601{
1602    my($hostIP, $host) = @_;
1603    return if ( $hostIP eq $host && !$Conf{FixedIPNetBiosNameCheck}
1604		|| $Conf{NmbLookupCmd} eq "" );
1605    my($netBiosHost, $netBiosUser) = $bpc->NetBiosInfoGet($hostIP);
1606    return "host $host has mismatching netbios name $netBiosHost"
1607		if ( lc($netBiosHost) ne lc(substr($host, 0, 15)) );
1608    return;
1609}
1610
1611#
1612# The Xfer method might tell us from time to time about processes
1613# it forks.  We tell BackupPC about this (for status displays) and
1614# keep track of the pids in case we cancel the backup
1615#
1616sub pidHandler
1617{
1618    @xferPid = @_;
1619    @xferPid = grep(/./, @xferPid);
1620    return if ( !@xferPid && $tarPid < 0 );
1621    my @pids = @xferPid;
1622    push(@pids, $tarPid) if ( $tarPid > 0 );
1623    my $str = join(",", @pids);
1624    $XferLOG->write(\"Xfer PIDs are now $str\n") if ( defined($XferLOG) );
1625    print("xferPids $str\n");
1626}
1627
1628#
1629# The Xfer method might tell us from time to time about progress
1630# in the backup or restore
1631#
1632sub completionPercent
1633{
1634    my($percent) = @_;
1635
1636    $percent = 100 if ( $percent > 100 );
1637    $percent =   0 if ( $percent <   0 );
1638    if ( !defined($completionPercent)
1639        || int($completionPercent + 0.5) != int($percent) ) {
1640            printf("completionPercent %.0f\n", $percent);
1641    }
1642    $completionPercent = $percent;
1643}
1644
1645#
1646# Run an optional pre- or post-dump command
1647#
1648sub UserCommandRun
1649{
1650    my($cmdType, $sharename) = @_;
1651
1652    return if ( !defined($Conf{$cmdType}) );
1653    my $vars = {
1654        xfer       => $xfer,
1655        client     => $client,
1656        host       => $host,
1657        hostIP     => $hostIP,
1658	user       => $Hosts->{$client}{user},
1659	moreUsers  => $Hosts->{$client}{moreUsers},
1660        share      => $ShareNames->[0],
1661        shares     => $ShareNames,
1662        XferMethod => $Conf{XferMethod},
1663        sshPath    => $Conf{SshPath},
1664        LOG        => *LOG,
1665        XferLOG    => $XferLOG,
1666        stat       => \%stat,
1667        xferOK     => $stat{xferOK} || 0,
1668	hostError  => $stat{hostError},
1669	type	   => $type,
1670	cmdType	   => $cmdType,
1671    };
1672
1673    if ($cmdType eq 'DumpPreShareCmd' || $cmdType eq 'DumpPostShareCmd') {
1674	$vars->{share} = $sharename;
1675    }
1676
1677    my $cmd = $bpc->cmdVarSubstitute($Conf{$cmdType}, $vars);
1678    $XferLOG->write(\"Executing $cmdType: @$cmd\n");
1679    #
1680    # Run the user's command, dumping the stdout/stderr into the
1681    # Xfer log file.  Also supply the optional $vars and %Conf in
1682    # case the command is really perl code instead of a shell
1683    # command.
1684    #
1685    $bpc->cmdSystemOrEval($cmd,
1686	    sub {
1687		$XferLOG->write(\$_[0]);
1688                print(LOG $bpc->timeStamp, "Output from $cmdType: ", $_[0]);
1689	    },
1690	    $vars, \%Conf);
1691}
1692