App-SimpleBackuper

 view release on metacpan or  search on metacpan

bin/simple-backuper  view on Meta::CPAN

	'cfg=s', 'db=s', 'backup-name=s', 'path=s', 'storage=s', 'destination=s', 'priv-key=s', 'write', 'verbose', 'quiet'
) or usage();

my $command = shift;

$options{cfg} //= '~/.simple-backuper/config' if $command and grep {$command eq $_} qw(backup storage-check storage-fix stats);

my %state = (profile => {total => - Time::HiRes::time});

if($options{cfg}) {
	$options{cfg} =~ s/^~/(getpwuid($>))[7]/e;
	open(my $h, "<", $options{cfg}) or usage("Can't read config '$options{cfg}': $!");
	my $config;
	try {
		$config = JSON::PP->new->utf8->relaxed(1)->decode(join('', <$h>));
	} catch {
		usage("Error while parsing json in config '$options{cfg}': $!");
	};
	close($h);
	$options{$_} ||= $config->{$_} foreach qw(db storage compression_level public_key space_limit files);
	
	exists $options{compression_level} or usage("Config doesn't contains 'compression_level'");
	$options{compression_level} =~ /^\d$/
		and $options{compression_level} >= 1
		and $options{compression_level} <= 9
		or usage("Bad value of 'compression_level' in config. Must be 1 to 9");
	
	exists $options{public_key} or usage("Config doesn't contains 'public_key'");
	$options{public_key} =~ s/^~/(getpwuid($>))[7]/e;
	open($h, '<', $options{public_key}) or usage("Can't read public_key file '$options{public_key}': $!");
	$state{rsa} = Crypt::OpenSSL::RSA->new_public_key( join('', <$h>) );
	close($h);
	
	exists $options{space_limit} or usage("Config diesn't contains 'space_limit'");
	if($options{space_limit} =~ /^(\d+)(k|m|g|t)$/i) {
		$options{space_limit} = $1 * {k => 1e3, m => 1e6, g => 1e9, t => 1e12}->{lc $2};
	} else {
		usage("Bad value of space_limit ($options{space_limit}). It should be a number with K, M, G or T at the end");
	}
	
	exists $options{files} or usage("Config doesn't contains 'files'");
	ref($options{files}) eq 'HASH' or usage("'files' in config should be an object");
	usage("File rule '$_' priority in config should be a number") foreach grep {$options{files}->{ $_ } !~ /^\d+$/} keys %{$options{files}};
	{
		my %files_rules;
		while(my($mask, $priority) = each %{ $options{files} }) {
			$mask =~ s/^~([^\/]*)/(getpwuid($1 ? getpwnam($1) : $<))[7]/e;
			$mask =~ s/\/$//;
			Encode::_utf8_off($mask);
			$files_rules{ $mask } = $priority;
		}
		$options{files} = \%files_rules;
	}
}

{
	$options{db} ||= '~/.simple-backuper/db';
	$options{db} =~ s/^~/(getpwuid($>))[7]/e;
	
	if(! -e $options{db} and $command and grep {$command eq $_} qw(backup storage-check storage-fix stats)) {
		print "Initializing new database...\t";
		my $db_file = App::SimpleBackuper::RegularFile->new($options{db}, \%options);
		$db_file->set_write_mode();
		$db_file->data_ref( App::SimpleBackuper::DB->new()->dump() );
		$db_file->compress();
		$db_file->write();
		print "done.\n";
	}

lib/App/SimpleBackuper/Backup.pm  view on Meta::CPAN

const my $SIZE_OF_TOP_FILES => 10;
const my $SAVE_DB_PERIOD => 60 * 60;
const my $PRINT_PROGRESS_PERIOD => 60;

sub _proc_uid_gid($$$) {
	my($uid, $gid, $uids_gids) = @_;
	
	my $last_uid_gid = @$uids_gids ? $uids_gids->unpack( $uids_gids->[-1] )->{id} : 0;
	
	my $user_name = getpwuid($uid);
	my($user) = grep { $_->{name} eq $user_name } map { $uids_gids->unpack($_) } @$uids_gids;
	if(! $user) {
		$user = {id => ++$last_uid_gid, name => $user_name};
		$uids_gids->upsert({ id => $user->{id} }, $user );
		#printf "new owner user added (unix uid %d, name %s, internal uid %d)\n", $uid, $user_name, $user->{id};
	}
	$uid = $user->{id};
	
	my $group_name = getgrgid($gid);
	my($group) = grep { $_->{name} eq $group_name } map { $uids_gids->unpack($_) } @$uids_gids;

lib/App/SimpleBackuper/Backup.pm  view on Meta::CPAN

	$file_time_spent -= time;
	my @stat = lstat($task->[0]);
	$file_time_spent += time;
	$state->{profile}->{fs} += time;
	$state->{profile}->{fs_lstat} += time;
	if(! @stat) {
		print ". Not exists\n" if $options->{verbose};
		return;
	}
	else {
		printf ", stat: %s:%s %o %s modified at %s", scalar getpwuid($stat[4]), scalar getgrgid($stat[5]), $stat[2], fmt_weight($stat[7]), fmt_datetime($stat[9]) if $options->{verbose};
	}
	
	
	my($backups, $blocks, $files, $parts, $uids_gids) = @{ $state->{db} }{qw(backups blocks files parts uids_gids)};
	
	
	my($uid, $gid) = _proc_uid_gid($stat[4], $stat[5], $uids_gids);
	
	
	my($file); {

lib/App/SimpleBackuper/Restore.pm  view on Meta::CPAN

	my($version) = grep {$_->{backup_id_min} <= $state->{backup_id} and $_->{backup_id_max} >= $state->{backup_id}}
		@{ $file->{versions} };
	if(! $version) {
		print "\tnot exists in this backup.\n" if $options->{verbose};
		return;
	}
	
	my @stat = lstat($fs_path);
	my($fs_user, $fs_group);
	if(@stat) {
		$fs_user = getpwuid($stat[4]);
		$fs_group = getpwuid($stat[5]);
	}
	
	if(S_ISDIR $version->{mode}) {
		my $need2mkdir;
		if(@stat) {
			if(! S_ISDIR $stat[2]) {
				print "\tin backup it's dir but on FS it's not.\n" if $options->{verbose};
				unlink $fs_path if $options->{write};
				$need2mkdir = 1;
			}
		} else {
			$need2mkdir = 1;
		}
		
		if($need2mkdir) {
			mkdir($fs_path, $version->{mode}) or die "Can't mkdir $fs_path: $!" if $options->{write};
			$fs_user = scalar getpwuid $<;
			$fs_group = scalar getgrgid $(;
			$stat[2] = $version->{mode};
		}
	}
	elsif(S_ISLNK $version->{mode}) {
		my $need2link;
		if(@stat) {
			if(S_ISLNK $stat[2]) {
				my $symlink_to = readlink($fs_path) // die "Can't read symlink $fs_path: $!";
				if($symlink_to ne $version->{symlink_to}) {

lib/App/SimpleBackuper/Restore.pm  view on Meta::CPAN

				$need2link = 1;
			}
		} else {
			$need2link = 1;
		}
		
		if($need2link) {
			if($options->{write}) {
				symlink($version->{symlink_to}, $fs_path) or die "Can't make symlink $fs_path -> $version->{symlink_to}: $!";
			}
			$fs_user = scalar getpwuid $<;
			$fs_group = scalar getgrgid $(;
		}
	}
	elsif(S_ISREG $version->{mode}) {
		my $need2rewrite_whole_file;
		if(@stat) {
			if(S_ISREG $stat[2]) {
				my $reg_file = App::SimpleBackuper::RegularFile->new($fs_path, $options);
				my $file_writer;
				if($stat[7] != $version->{size}) {

lib/App/SimpleBackuper/Restore.pm  view on Meta::CPAN

					for my $part_number (0 .. $#{ $version->{parts} }) {
						print "\tpart #$part_number hash is ".fmt_hex2base64($version->{parts}->[ $part_number ]->{hash}).": " if $options->{verbose};
						_restore_part($options, $reg_file, $state->{storage}, $version->{parts}->[ $part_number ], $part_number);
					}
				} else {
					$reg_file->set_write_mode();
				}
			} else {
				print "\tfile will be restored.\n" if $options->{verbose};
			}
			$fs_user = scalar getpwuid $<;
			$fs_group = scalar getgrgid $(;
		}
	}
	
	
	if((! @stat or $stat[2] != $version->{mode}) and ! S_ISLNK $version->{mode}) {
		printf "\tin backup it has mode %o but on FS - %o.\n", $version->{mode}, $stat[2] // 0 if $options->{verbose};
		if($options->{write}) {
			chmod($version->{mode}, $fs_path) or die sprintf("Can't chmod %s to %o: %s", $fs_path, $version->{mode}, $!);
		}

local/lib/perl5/ExtUtils/Helpers/Unix.pm  view on Meta::CPAN

		}
	}
	chmod $current_mode | oct(111), $filename;
	return;
}

sub detildefy {
	my $value = shift;
	# tilde with optional username
	for ($value) {
		s{ ^ ~ (?= /|$)}          [ $ENV{HOME} || (getpwuid $>)[7] ]ex or # tilde without user name
		s{ ^ ~ ([^/]+) (?= /|$) } { (getpwnam $1)[7] || "~$1" }ex;        # tilde with user name
	}
	return $value;
}

1;

# ABSTRACT: Unix specific helper bits

__END__

local/lib/perl5/Module/Build/Platform/Unix.pm  view on Meta::CPAN

# Open group says username should be portable filename characters,
# but some Unix OS working with ActiveDirectory wind up with user-names
# with back-slashes in the name.  The new code below is very liberal
# in what it accepts.
sub _detildefy {
  my ($self, $value) = @_;
  $value =~ s[^~([^/]+)?(?=/|$)]   # tilde with optional username
    [$1 ?
     (eval{(getpwnam $1)[7]} || "~$1") :
     ($ENV{HOME} || eval{(getpwuid $>)[7]} || glob("~"))
    ]ex;
  return $value;
}

1;
__END__


=head1 NAME

t/Actions.t  view on Meta::CPAN

		[ { name => 'tmp', oldest_backup => 'test', newest_backup => 'test'} ];
	
	is_deeply App::SimpleBackuper::Info({%options, path => '/'}, \%state)->{subfiles},
		[ { name => 'tmp', oldest_backup => 'test', newest_backup => 'test'} ];
	
	is_deeply App::SimpleBackuper::Info({%options, path => '/not-existent'}, \%state), {error => 'NOT_FOUND'};
	
	my $result = App::SimpleBackuper::Info({%options, path => '/tmp/simple-backuper-test/src'}, \%state);
	is_deeply $result->{subfiles}, [ { name => 'a.file', oldest_backup => 'test', newest_backup => 'test'} ];
	my @lstat = lstat('/tmp/simple-backuper-test/src');
	is $result->{versions}->[0]->{user}, scalar getpwuid($lstat[4]);
	is $result->{versions}->[0]->{group}, scalar getgrgid($lstat[5]);
	is_deeply $result->{versions}->[0]->{backups}, ['test'];
	
	
	ok ! App::SimpleBackuper::Restore({
		db					=> '/tmp/simple-backuper-test/db',
		'backup-name'		=> 'test',
		path				=> '/tmp/simple-backuper-test/src',
		destination			=> '/tmp/simple-backuper-test/dst',
		write				=> 1,