* Changes in preparation for 3.2.0beta1...
[BackupPC.git] / lib / BackupPC / Lib.pm
index 12cb6e1..cb66a10 100644 (file)
@@ -11,7 +11,7 @@
 #   Craig Barratt  <cbarratt@users.sourceforge.net>
 #
 # COPYRIGHT
-#   Copyright (C) 2001-2003  Craig Barratt
+#   Copyright (C) 2001-2009  Craig Barratt
 #
 #   This program is free software; you can redistribute it and/or modify
 #   it under the terms of the GNU General Public License as published by
@@ -29,7 +29,7 @@
 #
 #========================================================================
 #
-# Version 3.0.0beta1, released 30 Jul 2006.
+# Version 3.2.0beta0, released 5 April 2009.
 #
 # See http://backuppc.sourceforge.net.
 #
@@ -41,15 +41,51 @@ use strict;
 
 use vars qw(%Conf %Lang);
 use BackupPC::Storage;
-use Fcntl qw/:flock/;
+use Fcntl ':mode';
 use Carp;
-use DirHandle ();
 use File::Path;
 use File::Compare;
 use Socket;
 use Cwd;
 use Digest::MD5;
 use Config;
+use Encode qw/from_to encode_utf8/;
+
+use vars qw( $IODirentOk $IODirentLoaded );
+use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+
+require Exporter;
+require DynaLoader;
+
+@ISA = qw(Exporter DynaLoader);
+@EXPORT_OK = qw( BPC_DT_UNKNOWN
+                 BPC_DT_FIFO
+                 BPC_DT_CHR
+                 BPC_DT_DIR
+                 BPC_DT_BLK
+                 BPC_DT_REG
+                 BPC_DT_LNK
+                 BPC_DT_SOCK
+               );
+@EXPORT = qw( );
+%EXPORT_TAGS = ('BPC_DT_ALL' => [@EXPORT, @EXPORT_OK]);
+
+BEGIN {
+    eval "use IO::Dirent qw( readdirent DT_DIR );";
+    $IODirentLoaded = 1 if ( !$@ );
+};
+
+#
+# The need to match the constants in IO::Dirent
+#
+use constant BPC_DT_UNKNOWN =>   0;
+use constant BPC_DT_FIFO    =>   1;    ## named pipe (fifo)
+use constant BPC_DT_CHR     =>   2;    ## character special
+use constant BPC_DT_DIR     =>   4;    ## directory
+use constant BPC_DT_BLK     =>   6;    ## block special
+use constant BPC_DT_REG     =>   8;    ## regular
+use constant BPC_DT_LNK     =>  10;    ## symbolic link
+use constant BPC_DT_SOCK    =>  12;    ## socket
 
 sub new
 {
@@ -66,7 +102,7 @@ sub new
     #
     # Set defaults for $topDir and $installDir.
     #
-    $topDir     = '/tera0/backup/BackupPC' if ( $topDir eq "" );
+    $topDir     = '/data/BackupPC' if ( $topDir eq "" );
     $installDir = '/usr/local/BackupPC'    if ( $installDir eq "" );
 
     #
@@ -79,7 +115,7 @@ sub new
             useFHS     => $useFHS,
             TopDir     => $topDir,
             InstallDir => $installDir,
-            ConfDir    => $confDir eq "" ? '/etc/BackupPC' : $confDir,
+            ConfDir    => $confDir eq "" ? '/data/BackupPC/conf' : $confDir,
             LogDir     => '/var/log/BackupPC',
         };
     } else {
@@ -94,7 +130,7 @@ sub new
 
     my $bpc = bless {
        %$paths,
-        Version => '3.0.0beta1',
+        Version => '3.2.0beta0',
     }, $class;
 
     $bpc->{storage} = BackupPC::Storage->new($paths);
@@ -103,8 +139,6 @@ sub new
     # Clean up %ENV and setup other variables.
     #
     delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
-    $bpc->{PoolDir}  = "$bpc->{TopDir}/pool";
-    $bpc->{CPoolDir} = "$bpc->{TopDir}/cpool";
     if ( defined(my $error = $bpc->ConfigRead()) ) {
         print(STDERR $error, "\n");
         return;
@@ -118,6 +152,8 @@ sub new
         $paths->{$dir} = $bpc->{$dir} = $bpc->{Conf}{$dir};
     }
     $bpc->{storage}->setPaths($paths);
+    $bpc->{PoolDir}  = "$bpc->{TopDir}/pool";
+    $bpc->{CPoolDir} = "$bpc->{TopDir}/cpool";
 
     #
     # Verify we are running as the correct user
@@ -328,9 +364,9 @@ sub ConfigRead
     # Read host config file
     #
     if ( $host ne "" ) {
-       ($mesg, $config) = $bpc->{storage}->ConfigDataRead($host);
+       ($mesg, $config) = $bpc->{storage}->ConfigDataRead($host, $config);
        return $mesg if ( defined($mesg) );
-       $bpc->{Conf} = { %{$bpc->{Conf}}, %$config };
+       $bpc->{Conf} = $config;
     }
 
     #
@@ -360,6 +396,12 @@ sub ConfigRead
        return $mesg;
     }
     $bpc->{Lang} = \%Lang;
+
+    #
+    # Make sure IncrLevels is defined
+    #
+    $bpc->{Conf}{IncrLevels} = [1] if ( !defined($bpc->{Conf}{IncrLevels}) );
+
     return;
 }
 
@@ -404,11 +446,135 @@ sub HostsMTime
     return $bpc->{storage}->HostsMTime();
 }
 
+#
+# Read a directory and return the entries in sorted inode order.
+# This relies on the IO::Dirent module being installed.  If not,
+# the inode data is empty and the default directory order is
+# returned.
+#
+# The returned data is a list of hashes with entries {name, type, inode, nlink}.
+# The returned data includes "." and "..".
+#
+# $need is a hash of file attributes we need: type, inode, or nlink.
+# If set, these parameters are added to the returned hash.
+#
+# To support browsing pre-3.0.0 backups where the charset encoding
+# is typically iso-8859-1, the charsetLegacy option can be set in
+# $need to convert the path from utf8 and convert the names to utf8.
+#
+# If IO::Dirent is successful if will get type and inode for free.
+# Otherwise, a stat is done on each file, which is more expensive.
+#
+sub dirRead
+{
+    my($bpc, $path, $need) = @_;
+    my(@entries, $addInode);
+
+    from_to($path, "utf8", $need->{charsetLegacy})
+                        if ( $need->{charsetLegacy} ne "" );
+    return if ( !opendir(my $fh, $path) );
+    if ( $IODirentLoaded && !$IODirentOk ) {
+        #
+        # Make sure the IO::Dirent really works - some installs
+        # on certain file systems (eg: XFS) don't return a valid type.
+        #
+        if ( opendir(my $fh, $bpc->{TopDir}) ) {
+            my $dt_dir = eval("DT_DIR");
+            foreach my $e ( readdirent($fh) ) {
+                if ( $e->{name} eq "." && $e->{type} == $dt_dir ) {
+                    $IODirentOk = 1;
+                    last;
+                }
+            }
+            closedir($fh);
+        }
+        #
+        # if it isn't ok then don't check again.
+        #
+        $IODirentLoaded = 0 if ( !$IODirentOk );
+    }
+    if ( $IODirentOk ) {
+        @entries = sort({ $a->{inode} <=> $b->{inode} } readdirent($fh));
+        map { $_->{type} = 0 + $_->{type} } @entries;   # make type numeric
+    } else {
+        @entries = map { { name => $_} } readdir($fh);
+    }
+    closedir($fh);
+    if ( defined($need) ) {
+        for ( my $i = 0 ; $i < @entries ; $i++ ) {
+            next if ( (!$need->{inode} || defined($entries[$i]{inode}))
+                   && (!$need->{type}  || defined($entries[$i]{type}))
+                   && (!$need->{nlink} || defined($entries[$i]{nlink})) );
+            my @s = stat("$path/$entries[$i]{name}");
+            $entries[$i]{nlink} = $s[3] if ( $need->{nlink} );
+            if ( $need->{inode} && !defined($entries[$i]{inode}) ) {
+                $addInode = 1;
+                $entries[$i]{inode} = $s[1];
+            }
+            if ( $need->{type} && !defined($entries[$i]{type}) ) {
+                my $mode = S_IFMT($s[2]);
+                $entries[$i]{type} = BPC_DT_FIFO if ( S_ISFIFO($mode) );
+                $entries[$i]{type} = BPC_DT_CHR  if ( S_ISCHR($mode) );
+                $entries[$i]{type} = BPC_DT_DIR  if ( S_ISDIR($mode) );
+                $entries[$i]{type} = BPC_DT_BLK  if ( S_ISBLK($mode) );
+                $entries[$i]{type} = BPC_DT_REG  if ( S_ISREG($mode) );
+                $entries[$i]{type} = BPC_DT_LNK  if ( S_ISLNK($mode) );
+                $entries[$i]{type} = BPC_DT_SOCK if ( S_ISSOCK($mode) );
+            }
+        }
+    }
+    #
+    # Sort the entries if inodes were added (the IO::Dirent case already
+    # sorted above)
+    #
+    @entries = sort({ $a->{inode} <=> $b->{inode} } @entries) if ( $addInode );
+    #
+    # for browing pre-3.0.0 backups, map iso-8859-1 to utf8 if requested
+    #
+    if ( $need->{charsetLegacy} ne "" ) {
+        for ( my $i = 0 ; $i < @entries ; $i++ ) {
+            from_to($entries[$i]{name}, $need->{charsetLegacy}, "utf8");
+        }
+    }
+    return \@entries;
+}
+
+#
+# Same as dirRead, but only returns the names (which will be sorted in
+# inode order if IO::Dirent is installed)
+#
+sub dirReadNames
+{
+    my($bpc, $path, $need) = @_;
+
+    my $entries = $bpc->dirRead($path, $need);
+    return if ( !defined($entries) );
+    my @names = map { $_->{name} } @$entries;
+    return \@names;
+}
+
+sub find
+{
+    my($bpc, $param, $dir, $dontDoCwd) = @_;
+
+    return if ( !chdir($dir) );
+    my $entries = $bpc->dirRead(".", {inode => 1, type => 1});
+    #print Dumper($entries);
+    foreach my $f ( @$entries ) {
+        next if ( $f->{name} eq ".." || $f->{name} eq "." && $dontDoCwd );
+        $param->{wanted}($f->{name}, "$dir/$f->{name}");
+        next if ( $f->{type} != BPC_DT_DIR || $f->{name} eq "." );
+        chdir($f->{name});
+        $bpc->find($param, "$dir/$f->{name}", 1);
+        return if ( !chdir("..") );
+    }
+}
+
 #
 # Stripped down from File::Path.  In particular we don't print
 # many warnings and we try three times to delete each directory
 # and file -- for some reason the original File::Path rmtree
-# didn't always completely remove a directory tree on the NetApp.
+# didn't always completely remove a directory tree on a NetApp.
 #
 # Warning: this routine changes the cwd.
 #
@@ -433,13 +599,11 @@ sub RmTreeQuiet
        #
        if ( !unlink($root) ) {
             if ( -d $root ) {
-                my $d = DirHandle->new($root);
+                my $d = $bpc->dirReadNames($root);
                if ( !defined($d) ) {
                    print(STDERR "Can't read $pwd/$root: $!\n");
                } else {
-                   @files = $d->read;
-                   $d->close;
-                   @files = grep $_!~/^\.{1,2}$/, @files;
+                   @files = grep $_ !~ /^\.{1,2}$/, @$d;
                    $bpc->RmTreeQuiet("$pwd/$root", \@files);
                    chdir($pwd);
                    rmdir($root) || rmdir($root);
@@ -460,7 +624,15 @@ sub RmTreeDefer
     my($i, $f);
 
     return if ( !-e $file );
-    mkpath($trashDir, 0, 0777) if ( !-d $trashDir );
+    if ( !-d $trashDir ) {
+        eval { mkpath($trashDir, 0, 0777) };
+        if ( $@ ) {
+            #
+            # There's no good place to send this error - use stderr
+            #
+            print(STDERR "RmTreeDefer: can't create directory $trashDir");
+        }
+    }
     for ( $i = 0 ; $i < 1000 ; $i++ ) {
         $f = sprintf("%s/%d_%d_%d", $trashDir, time, $$, $i);
         next if ( -e $f );
@@ -490,10 +662,8 @@ sub RmTreeTrashEmpty
 
     $cwd = $1 if ( $cwd =~ /(.*)/ );
     return if ( !-d $trashDir );
-    my $d = DirHandle->new($trashDir) or carp "Can't read $trashDir: $!";
-    @files = $d->read;
-    $d->close;
-    @files = grep $_!~/^\.{1,2}$/, @files;
+    my $d = $bpc->dirReadNames($trashDir) or carp "Can't read $trashDir: $!";
+    @files = grep $_ !~ /^\.{1,2}$/, @$d;
     return 0 if ( !@files );
     $bpc->RmTreeQuiet($trashDir, \@files);
     foreach my $f ( @files ) {
@@ -590,7 +760,10 @@ sub ServerMesg
 {
     my($bpc, $mesg) = @_;
     return if ( !defined(my $fh = $bpc->{ServerFD}) );
+    $mesg =~ s/\n/\\n/g;
+    $mesg =~ s/\r/\\r/g;
     my $md5 = Digest::MD5->new;
+    $mesg = encode_utf8($mesg);
     $md5->add($bpc->{ServerSeed} . $bpc->{ServerMesgCnt}
             . $bpc->{Conf}{ServerMesgSecret} . $mesg);
     print($fh $md5->b64digest . " $mesg\n");
@@ -738,7 +911,10 @@ sub MakeFileLink
         } elsif ( $newFile && -f $name && (stat($name))[3] == 1 ) {
             my($newDir);
             ($newDir = $rawFile) =~ s{(.*)/.*}{$1};
-            mkpath($newDir, 0, 0777) if ( !-d $newDir );
+            if ( !-d $newDir ) {
+                eval { mkpath($newDir, 0, 0777) };
+                return -5 if ( $@ );
+            }
             return -4 if ( !link($name, $rawFile) );
             return 2;
         } else {
@@ -747,6 +923,33 @@ sub MakeFileLink
     }
 }
 
+#
+# Tests if we can create a hardlink from a file in directory
+# $newDir to a file in directory $targetDir.  A temporary
+# file in $targetDir is created and an attempt to create a
+# hardlink of the same name in $newDir is made.  The temporary
+# files are removed.
+#
+# Like link(), returns true on success and false on failure.
+#
+sub HardlinkTest
+{
+    my($bpc, $targetDir, $newDir) = @_;
+
+    my($targetFile, $newFile, $fd);
+    for ( my $i = 0 ; ; $i++ ) {
+        $targetFile = "$targetDir/.TestFileLink.$$.$i";
+        $newFile    = "$newDir/.TestFileLink.$$.$i";
+        last if ( !-e $targetFile && !-e $newFile );
+    }
+    return 0 if ( !open($fd, ">", $targetFile) );
+    close($fd);
+    my $ret = link($targetFile, $newFile);
+    unlink($targetFile);
+    unlink($newFile);
+    return $ret;
+}
+
 sub CheckHostAlive
 {
     my($bpc, $host) = @_;
@@ -843,6 +1046,10 @@ sub NetBiosInfoGet
     };
     $nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupCmd}, $args);
     foreach ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef, $args)) ) {
+        #
+        # skip <GROUP> and other non <ACTIVE> entries
+        #
+        next if ( /<\w{2}> - <GROUP>/i );
         next if ( !/^\s*([\w\s-]+?)\s*<(\w{2})\> - .*<ACTIVE>/i );
         $netBiosHostName ||= $1 if ( $2 eq "00" );  # host is first 00
         $netBiosUserName   = $1 if ( $2 eq "03" );  # user is last 03
@@ -1026,22 +1233,27 @@ sub cmdVarSubstitute
         }
     }
     #
-    # Merge variables into @tarClientCmd
+    # Merge variables into @cmd
     #
     foreach my $arg ( @$template ) {
+        #
+        # Replace $VAR with ${VAR} so that both types of variable
+        # substitution are supported
+        #
+        $arg =~ s[\$(\w+)]{\${$1}}g;
         #
         # Replace scalar variables first
         #
-        $arg =~ s{\$(\w+)(\+?)}{
+        $arg =~ s[\${(\w+)}(\+?)]{
             exists($vars->{$1}) && ref($vars->{$1}) ne "ARRAY"
                 ? ($2 eq "+" ? $bpc->shellEscape($vars->{$1}) : $vars->{$1})
-                : "\$$1$2"
+                : "\${$1}$2"
         }eg;
         #
         # Now replicate any array arguments; this just works for just one
         # array var in each argument.
         #
-        if ( $arg =~ m{(.*)\$(\w+)(\+?)(.*)} && ref($vars->{$2}) eq "ARRAY" ) {
+        if ( $arg =~ m[(.*)\${(\w+)}(\+?)(.*)] && ref($vars->{$2}) eq "ARRAY" ) {
             my $pre  = $1;
             my $var  = $2;
             my $esc  = $3;
@@ -1237,9 +1449,12 @@ sub compareLOGName
 
     if ( length($na) >= 5 && length($nb) >= 5 ) {
         #
-        # Both new style.  Bigger numbers are more recent.
+        # Both new style: format is MMYYYY.  Bigger dates are
+        # more recent.
         #
-        return $nb - $na;
+        my $ma = $2 * 12 + $1 if ( $na =~ /(\d+)(\d{4})/ );
+        my $mb = $2 * 12 + $1 if ( $nb =~ /(\d+)(\d{4})/ );
+        return $mb - $ma;
     } elsif ( length($na) >= 5 && length($nb) < 5 ) {
         return -1;
     } elsif ( length($na) < 5 && length($nb) >= 5 ) {
@@ -1275,7 +1490,40 @@ sub sortedPCLogFiles
         }
         closedir(DIR);
     }
-    return sort(compareLOGName @files);
+    return sort compareLOGName @files;
+}
+
+#
+# converts a glob-style pattern into a perl regular expression.
+#
+sub glob2re
+{
+    my ( $bpc, $glob ) = @_;
+    my ( $char, $subst );
+
+    # $escapeChars escapes characters with no special glob meaning but
+    # have meaning in regexps.
+    my $escapeChars = [ '.', '/', ];
+
+    # $charMap is where we implement the special meaning of glob
+    # patterns and translate them to regexps.
+    my $charMap = {
+                    '?' => '[^/]',
+                    '*' => '[^/]*', };
+
+    # multiple forward slashes are equivalent to one slash.  We should
+    # never have to use this.
+    $glob =~ s/\/+/\//;
+
+    foreach $char (@$escapeChars) {
+        $glob =~ s/\Q$char\E/\\$char/g;
+    }
+
+    while ( ( $char, $subst ) = each(%$charMap) ) {
+        $glob =~ s/(?<!\\)\Q$char\E/$subst/g;
+    }
+
+    return $glob;
 }
 
 1;