view release on metacpan or  search on metacpan

lib/Brackup/Target/Filesystem.pm  view on Meta::CPAN

    return $self;
}

sub new_from_backup_header {
    my ($class, $header) = @_;
    my $self = bless {}, $class;
    $self->{path} = $header->{"BackupPath"} or
        die "No BackupPath specified in the backup metafile.\n";
    $self->{nocolons} = $header->{"NoColons"} or 0;
    unless (-d $self->{path}) {
        die "Restore path $self->{path} doesn't exist.\n";
    }
    return $self;
}

sub nocolons {
    my ($self) = @_;
    return $self->{nocolons};
}

sub backup_header {
    my $self = shift;
    return {
        "BackupPath" => $self->{path},
        "NoColons" => $self->{nocolons}?"1":"0",
    };
}

# 1.05 and before stored files on disk as: xxxx/xxxx/xxxxxxxxxx.brackup
# (that is, two levels of directories, each 4 hex digits long, or 65536
# files per directory, which is 2x what ext3 can store, leading to errors.
# in 1.06 and above, xx/xx/xxxxxx is used.  that is, two levels of 2 hex
# digits.  this function
sub _upgrade_layout {
    my $self = shift;
    my $clean_limit = shift; # optional; if set, max top-level dirs to clean

    my $root = $self->{path};

    opendir(my $dh, $root) or die "Error opening $root: $!";

    # read the current state of things in the root directory
    # (which is presumably maxed out on files, at 32k or whatnot)
    my %exist_twodir;    # two_dir -> 1 (which two-letter directories exist)
    my %exist_fourdir;   # four_dir -> 1 (which four-letter directories exist)
    my %four_of_two;     # two_dir -> [ four_dir, four_dir, ... ]
    while (my $dir = readdir($dh)) {
        next unless -d "$root/$dir";
        if ($dir =~ /^[0-9a-f]{2}$/) {
            $exist_twodir{$dir} = 1;
            next;
        }
        if ($dir =~ /^([0-9a-f]{2})([0-9a-f]{2})$/) {
            $exist_fourdir{"$1$2"} = 1;
            push @{ $four_of_two{$1} ||= [] }, "$1$2";
        }
    }

    # for each 4-digit directory, sorted by number of four-digit directories
    # that exist for their leading 2-digit prefix (to most quickly free up
    # a link in root, in 2 iterations),
    # see if the "01/" directory exists (the leading two bytes).
    # if not,
    #    move it to some random other 'xxxx' directory,
    #    as, say, "abcd/tmp-was-root-0123".
    # now, for either the "0123" directory or "tmp-was-root-0123"
    # directory, file all chunks, and move them to the
    # right locations "01/23/*.chunk", making "01/23" if needed.
    # (shouldn't be any out-of-link problems down one level)
    my @four_dirs = map {
        sort @{ $four_of_two{$_} }
    }
    sort {
        scalar(@{ $four_of_two{$b} }) <=> scalar(@{ $four_of_two{$a} })
    } keys %four_of_two;
    my $n_done;
    while (my $four_dir = shift @four_dirs) {
        my $leading_two = substr($four_dir, 0, 2);
        my $migrate_source;
        if ($exist_twodir{$leading_two}) {
            # top-level destination already exists.  no need for more
            # links in the top-level
            $migrate_source = $four_dir;
        } elsif (@four_dirs) {
            # we need to move four_dir away, into another four_dir,
            # to make room to create a new two_dir in the root
            my $holder_four_dir = $four_dirs[0];
            $migrate_source = "$holder_four_dir/tmp-was-root-$four_dir";
            my $temp_dir = "$root/$migrate_source";
            rename "$root/$four_dir", $temp_dir
                or die "Rename of $root/$four_dir -> $temp_dir failed: $!";
        } else {
            # no four_dirs left?  then I bet we aren't out of links
            # anymore.  just migrate.
            $migrate_source = $four_dir;
        }

        $self->_upgrade_chunks_in_directory($four_dir, $migrate_source);
        if (-e "$root/$four_dir") {
            die "Upgrade of $root/$four_dir/* didn't seem to have worked.";
        }
        $n_done++;
        last if $clean_limit && $n_done >= $clean_limit;
    }
}

sub _upgrade_chunks_in_directory {
    my $self = shift;
    my $four_dig = shift;  # first four hex digits of all files being moved
    my $rel_dir = shift;   # directory (relative to root) to move files from, and then remove
    die "not relative" unless $rel_dir =~ m!^[^/]!;

    my $root = $self->{path};

    my ($hex12, $hex34) = $four_dig =~ /^([0-9a-f]{2})([0-9a-f]{2})$/
        or die "four_dig not four hex digits";

    my $dest_dir0 = "$root/$hex12";
    my $dest_dir  = "$root/$hex12/$hex34";
    for ($dest_dir0, $dest_dir) {
        next if -d $_;