lib/BackupPC/Attrib.pm

   1 #============================================================= -*-perl-*-
   2 #
   3 # BackupPC::Attrib package
   4 #
   5 # DESCRIPTION
   6 #
   7 #   This library defines a BackupPC::Attrib class for maintaining
   8 #   file attribute data.  One object instance stores attributes for
   9 #   all the files in a single directory.
  10 #
  11 # AUTHOR
  12 #   Craig Barratt  <cbarratt@users.sourceforge.net>
  13 #
  14 # COPYRIGHT
  15 #   Copyright (C) 2001  Craig Barratt
  16 #
  17 #   This program is free software; you can redistribute it and/or modify
  18 #   it under the terms of the GNU General Public License as published by
  19 #   the Free Software Foundation; either version 2 of the License, or
  20 #   (at your option) any later version.
  21 #
  22 #   This program is distributed in the hope that it will be useful,
  23 #   but WITHOUT ANY WARRANTY; without even the implied warranty of
  24 #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  25 #   GNU General Public License for more details.
  26 #
  27 #   You should have received a copy of the GNU General Public License
  28 #   along with this program; if not, write to the Free Software
  29 #   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  30 #
  31 #========================================================================
  32 #
  33 # Version 1.5.0, released 2 Aug 2002.
  34 #
  35 # See http://backuppc.sourceforge.net.
  36 #
  37 #========================================================================
  38
  39 package BackupPC::Attrib;
  40
  41 use strict;
  42
  43 use Carp;
  44 use File::Path;
  45 use BackupPC::FileZIO;
  46 require Exporter;
  47
  48 use vars qw( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS );
  49
  50 #
  51 # These must match the file types used by tar
  52 #
  53 use constant BPC_FTYPE_FILE     => 0;
  54 use constant BPC_FTYPE_HARDLINK => 1;
  55 use constant BPC_FTYPE_SYMLINK  => 2;
  56 use constant BPC_FTYPE_CHARDEV  => 3;
  57 use constant BPC_FTYPE_BLOCKDEV => 4;
  58 use constant BPC_FTYPE_DIR      => 5;
  59 use constant BPC_FTYPE_FIFO     => 6;
  60 use constant BPC_FTYPE_SOCKET   => 8;
  61 use constant BPC_FTYPE_UNKNOWN  => 9;
  62
  63 my @FILE_TYPES = qw(
  64                   BPC_FTYPE_FILE
  65                   BPC_FTYPE_HARDLINK
  66                   BPC_FTYPE_SYMLINK
  67                   BPC_FTYPE_CHARDEV
  68                   BPC_FTYPE_BLOCKDEV
  69                   BPC_FTYPE_DIR
  70                   BPC_FTYPE_FIFO
  71                   BPC_FTYPE_SOCKET
  72                   BPC_FTYPE_UNKNOWN
  73              );
  74
  75 #
  76 # The indexes in this list must match the numbers above
  77 #
  78 my @FileType2Text = (
  79     "file",
  80     "hardlink",
  81     "symlink",
  82     "chardev",
  83     "blockdev",
  84     "dir",
  85     "fifo",
  86     "?",
  87     "socket",
  88 );
  89
  90 #
  91 # Type of attribute file.  This is saved as a magic number at the
  92 # start of the file.  Later there might be other types.
  93 #
  94 use constant BPC_ATTRIB_TYPE_UNIX => 0x17555555;
  95
  96 my @ATTRIB_TYPES = qw(
  97                   BPC_ATTRIB_TYPE_UNIX
  98              );
  99
 100 @ISA = qw(Exporter);
 101
 102 @EXPORT    = qw( );
 103
 104 @EXPORT_OK = (
 105                   @FILE_TYPES,
 106                   @ATTRIB_TYPES,
 107              );
 108
 109 %EXPORT_TAGS = (
 110     'all'    => [ @EXPORT_OK ],
 111 );
 112
 113 #
 114 # These fields are packed using the "w" pack format (variable length
 115 # base 128). We use two values to store up to 64 bit size: sizeDiv4GB
 116 # is size / 4GB and sizeMod4GB is size % 4GB (although perl can
 117 # only represent around 2^52, the size of an IEEE double mantissa).
 118 #
 119 my @FldsUnixW = qw(type mode uid gid sizeDiv4GB sizeMod4GB);
 120
 121 #
 122 # These fields are packed using the "N" pack format (32 bit integer)
 123 #
 124 my @FldsUnixN = qw(mtime);
 125
 126 sub new
 127 {
 128     my($class, $options) = @_;
 129
 130     my $self = bless {
 131         type  => BPC_ATTRIB_TYPE_UNIX,
 132         %$options,
 133         files => { },
 134     }, $class;
 135     return $self;
 136 }
 137
 138 sub set
 139 {
 140     my($a, $fileName, $attrib) = @_;
 141
 142     $a->{files}{$fileName} = $attrib;
 143 }
 144
 145 sub get
 146 {
 147     my($a, $fileName) = @_;
 148     return $a->{files}{$fileName};
 149 }
 150
 151 sub fileType2Text
 152 {
 153     my($a, $type) = @_;
 154     return "?" if ( $type < 0 || $type >= @FileType2Text );
 155     return $FileType2Text[$type];
 156 }
 157
 158 sub fileCount
 159 {
 160     my($a) = @_;
 161
 162     return scalar(keys(%{$a->{files}}));
 163 }
 164
 165 sub delete
 166 {
 167     my($a, $fileName) = @_;
 168     if ( defined($fileName) ) {
 169         delete($a->{files}{$fileName});
 170     } else {
 171         $a->{files} = { };
 172     }
 173 }
 174
 175 #
 176 # Given the directory, return the full path of the attribute file.
 177 #
 178 sub fileName
 179 {
 180     my($a, $dir, $file) = @_;
 181
 182     $file = "attrib" if ( !defined($file) );
 183     return "$dir/$file";
 184 }
 185
 186 sub read
 187 {
 188     my($a, $dir, $file) = @_;
 189     my($data);
 190
 191     $file = $a->fileName($dir, $file);
 192     my $fd = BackupPC::FileZIO->open($file, 0, $a->{compress});
 193     if ( !$fd ) {
 194         $a->{_errStr} = "Can't open $file";
 195         return;
 196     }
 197     $fd->read(\$data, 65536);
 198     if ( length($data) < 4 ) {
 199         $a->{_errStr} = "Can't read magic number from $file";
 200         $fd->close;
 201         return;
 202     }
 203     (my $magic, $data) = unpack("N a*", $data);
 204     if ( $magic != $a->{type} ) {
 205         $a->{_errStr} = sprintf("Wrong magic number in $file"
 206                                . " (got 0x%x, expected 0x%x)",
 207                                    $magic, $a->{type});
 208         $fd->close;
 209         return;
 210     }
 211     while ( length($data) ) {
 212         my $newData;
 213         if ( length($data) < 4 ) {
 214             $fd->read(\$newData, 65536);
 215             $data .= $newData;
 216             if ( length($data) < 4 ) {
 217                 $a->{_errStr} = "Can't read file length from $file";
 218                 $fd->close;
 219                 return;
 220             }
 221         }
 222         (my $len, $data) = unpack("w a*", $data);
 223         if ( length($data) < $len ) {
 224             $fd->read(\$newData, $len + 65536);
 225             $data .= $newData;
 226             if ( length($data) < $len ) {
 227                 $a->{_errStr} = "Can't read file name (length $len)"
 228                            . " from $file";
 229                 $fd->close;
 230                 return;
 231             }
 232         }
 233         (my $fileName, $data) = unpack("a$len a*", $data);
 234         my $nFldsW = @FldsUnixW;
 235         my $nFldsN = @FldsUnixN;
 236         if ( length($data) < 5 * $nFldsW + 4 * $nFldsN ) {
 237             $fd->read(\$newData, 65536);
 238             $data .= $newData;
 239         }
 240         (
 241             @{$a->{files}{$fileName}}{@FldsUnixW},
 242             @{$a->{files}{$fileName}}{@FldsUnixN},
 243             $data
 244         ) = unpack("w$nFldsW N$nFldsN a*", $data);
 245         if ( $a->{files}{$fileName}{$FldsUnixN[-1]} eq "" ) {
 246             $a->{_errStr} = "Can't read attributes for $fileName"
 247                           . " from $file";
 248             $fd->close;
 249             return;
 250         }
 251         #
 252         # Convert the two 32 bit size values into a single size
 253         #
 254         $a->{files}{$fileName}{size} = $a->{files}{$fileName}{sizeMod4GB}
 255                     + $a->{files}{$fileName}{sizeDiv4GB} * 4096 * 1024 * 1024;
 256     }
 257     $fd->close;
 258     $a->{_errStr} = "";
 259     return 1;
 260 }
 261
 262 sub writeData
 263 {
 264     my($a) = @_;
 265     my($data);
 266
 267     $data = pack("N", BPC_ATTRIB_TYPE_UNIX);
 268     foreach my $file ( sort(keys(%{$a->{files}})) ) {
 269         my $nFldsW = @FldsUnixW;
 270         my $nFldsN = @FldsUnixN;
 271         #
 272         # Convert the size into two 32 bit size values.
 273         #
 274         $a->{files}{$file}{sizeMod4GB}
 275                     = $a->{files}{$file}{size} % (4096 * 1024 * 1024);
 276         $a->{files}{$file}{sizeDiv4GB}
 277                     = int($a->{files}{$file}{size} / (4096 * 1024 * 1024));
 278         $data .= pack("w a* w$nFldsW N$nFldsN", length($file), $file,
 279                                @{$a->{files}{$file}}{@FldsUnixW},
 280                                @{$a->{files}{$file}}{@FldsUnixN},
 281                     );
 282     }
 283     return $data;
 284 }
 285
 286 sub write
 287 {
 288     my($a, $dir, $file) = @_;
 289     my($data) = $a->writeData;
 290
 291     $file = $a->fileName($dir, $file);
 292     mkpath($dir, 0, 0777) if ( !-d $dir );
 293     my $fd = BackupPC::FileZIO->open($file, 1, $a->{compress});
 294     if ( !$fd ) {
 295         $a->{_errStr} = "Can't open/write to $file";
 296         return;
 297     }
 298     if ( $fd->write(\$data) != length($data) ) {
 299         $a->{_errStr} = "Can't write to $file";
 300         $fd->close;
 301         return;
 302     }
 303     $fd->close;
 304     $a->{_errStr} = "";
 305     return 1;
 306 }
 307
 308 sub merge
 309 {
 310     my($a1, $a2) = @_;
 311
 312     foreach my $f ( keys(%{$a2->{files}}) ) {
 313         next if ( defined($a1->{files}{$f}) );
 314         $a1->{files}{$f} = $a2->{files}{$f};
 315     }
 316 }
 317
 318 sub errStr
 319 {
 320     my($a) = @_;
 321
 322     return $a->{_errStr};
 323 }
 324
 325 1;