App-SimpleBackuper
view release on metacpan or search on metacpan
lib/App/SimpleBackuper/Backup.pm view on Meta::CPAN
use Const::Fast;
use App::SimpleBackuper::BackupDB;
use App::SimpleBackuper::_format;
use App::SimpleBackuper::_BlockDelete;
use App::SimpleBackuper::_BlocksInfo;
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;
if(! $group) {
$group = {id => ++$last_uid_gid, name => $group_name};
$uids_gids->upsert({ id => $group->{id} }, $group );
#printf "new owner group added (unix gid %d, name %s, internal gid %d)\n", $gid, $group_name, $group->{id};
}
$gid = $group->{id};
return $uid, $gid;
}
sub _get_block_to_delete {
my($state) = @_;
if(ref($state->{blocks2delete_prio2size2chunks}) eq 'HASH') {
$state->{blocks2delete_prio2size2chunks} = [
map {$state->{blocks2delete_prio2size2chunks}->{ $_ }}
sort {$a <=> $b}
keys %{ $state->{blocks2delete_prio2size2chunks} }
lib/App/SimpleBackuper/Backup.pm view on Meta::CPAN
my $file = $files->find_by_parent_id_name($file_id, $path_node);
$file //= {
parent_id => $file_id,
id => ++$state->{last_file_id},
name => $path_node,
versions => [ {
backup_id_min => $state->{last_backup_id},
backup_id_max => 0,
uid => 0,
gid => 0,
size => 0,
mode => 0,
mtime => 0,
block_id => 0,
symlink_to => undef,
parts => [],
} ],
};
$dirs2upd{join('/', @cur_path) || '/'} = {
lib/App/SimpleBackuper/Backup.pm view on Meta::CPAN
App::SimpleBackuper::BackupDB($options, $state);
$last_db_save = time;
}
}
while(my($full_path, $dir2upd) = each %dirs2upd) {
print "Updating dir $full_path..." if $options->{verbose};
my $file = $files->find_by_parent_id_name($dir2upd->{parent_id}, $dir2upd->{filename});
my @stat = lstat($full_path);
if(@stat and $file->{versions}->[-1]->{backup_id_max} != $state->{last_backup_id}) {
my($uid, $gid) =_proc_uid_gid($stat[4], $stat[5], $state->{db}->{uids_gids});
if($file->{versions}->[-1]->{backup_id_max} == $state->{last_backup_id} - 1) {
$file->{versions}->[-1] = {
%{ $file->{versions}->[-1] },
backup_id_max => $state->{last_backup_id},
uid => $uid,
gid => $gid,
size => $stat[7],
mode => $stat[2],
mtime => $stat[9],
block_id => 0,
symlink_to => undef,
parts => [],
};
} else {
push @{ $file->{versions} }, {
backup_id_min => $state->{last_backup_id},
backup_id_max => $state->{last_backup_id},
uid => $uid,
gid => $gid,
size => $stat[7],
mode => $stat[2],
mtime => $stat[9],
block_id => 0,
symlink_to => undef,
parts => [],
}
}
$files->upsert({ id => $file->{id}, parent_id => $file->{parent_id} }, $file);
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); {
my($filename) = $task->[0] =~ /([^\/]+)\/?$/;
$file = $files->find_by_parent_id_name($task->[2], $filename);
if($file) {
print ", is old file #$file->{id}" if $options->{verbose};
if($file->{versions}->[-1]->{backup_id_max} == $state->{last_backup_id}) {
print ", is already backuped.\n" if $options->{verbose};
return;
lib/App/SimpleBackuper/Backup.pm view on Meta::CPAN
print ", is new file #$file->{id}" if $options->{verbose};
}
}
$state->{bytes_processed} += $file->{versions}->[-1]->{size} if @{ $file->{versions} };
my %version = (
backup_id_min => $state->{last_backup_id},
backup_id_max => $state->{last_backup_id},
uid => $uid,
gid => $gid,
size => $stat[7],
mode => $stat[2],
mtime => $stat[9],
block_id => undef,
symlink_to => undef,
parts => [],
);
if(S_ISDIR $stat[2]) {
print ", is directory.\n" if $options->{verbose};
lib/App/SimpleBackuper/Backup.pm view on Meta::CPAN
}
# If file version not changed, use old version with wider backup ids range
if( @{ $file->{versions} }
and (
$file->{versions}->[-1]->{backup_id_max} + 1 == $state->{last_backup_id}
or $file->{versions}->[-1]->{backup_id_max} == $state->{last_backup_id}
)
and $file->{versions}->[-1]->{uid} == $version{uid}
and $file->{versions}->[-1]->{gid} == $version{gid}
and $file->{versions}->[-1]->{size} == $version{size}
and $file->{versions}->[-1]->{mode} == $version{mode}
and $file->{versions}->[-1]->{mtime}== $version{mtime}
and (
defined $file->{versions}->[-1]->{symlink_to} == defined $version{symlink_to}
and (
! defined $version{symlink_to}
or $file->{versions}->[-1]->{symlink_to} eq $version{symlink_to}
)
)
lib/App/SimpleBackuper/DB.pm view on Meta::CPAN
}
sub new {
my($class, $dump_ref) = @_;
my $self = bless {
backups => App::SimpleBackuper::DB::BackupsTable->new(),
files => App::SimpleBackuper::DB::FilesTable->new(),
parts => App::SimpleBackuper::DB::PartsTable->new(),
blocks => App::SimpleBackuper::DB::BlocksTable->new(),
uids_gids => App::SimpleBackuper::DB::UidsGidsTable->new(),
} => $class;
if($dump_ref) {
$self->{dump} = $$dump_ref;
$self->{offset} = 0;
my $format_version = $self->_unpack_tmpl('J');
my $parse_method = "parse_format_v$format_version";
die "Unsupported database format version $format_version" if ! $self->can($parse_method);
$self->$parse_method();
lib/App/SimpleBackuper/DB.pm view on Meta::CPAN
sub dump {
my($self) = @_;
my $dump_method = "dump_format_v$FORMAT_VERSION";
return $self->$dump_method();
}
sub parse_format_v2 {
my($self) = @_;
my($backups_cnt, $files_cnt, $parts_cnt, $blocks_cnt, $uids_gids_cnt) = $self->_unpack_tmpl("JJJJJ");
$self->{backups} = App::SimpleBackuper::DB::BackupsTable->new($backups_cnt);
$self->{backups} ->[$_ - 1] = $self->_unpack_record() for 1 .. $backups_cnt;
$self->{files} = App::SimpleBackuper::DB::FilesTable->new($files_cnt);
$self->{files} ->[$_ - 1] = $self->_unpack_record() for 1 .. $files_cnt;
$self->{parts} = App::SimpleBackuper::DB::PartsTable->new($parts_cnt);
$self->{parts} ->[$_ - 1] = $self->_unpack_record() for 1 .. $parts_cnt;
$self->{blocks} = App::SimpleBackuper::DB::BlocksTable->new($blocks_cnt);
$self->{blocks} ->[$_ - 1] = $self->_unpack_record() for 1 .. $blocks_cnt;
$self->{uids_gids} = App::SimpleBackuper::DB::UidsGidsTable->new($uids_gids_cnt);
$self->{uids_gids} ->[$_ - 1] = $self->_unpack_record() for 1 .. $uids_gids_cnt;
}
sub dump_format_v2 {
my($self) = @_;
return \ join('',
pack("JJJJJJ", $FORMAT_VERSION, map {scalar @{ $self->{$_} }} qw(backups files parts blocks uids_gids)),
map { pack("Ja".length($_), length($_), $_) } map {@{ $self->{$_} }} qw(backups files parts blocks uids_gids)
);
}
sub parse_format_v1 {
my($self) = @_;
my($backups_cnt, $files_cnt, $uids_gids_cnt) = $self->_unpack_tmpl("JJJ");
$self->{backups} = App::SimpleBackuper::DB::BackupsTable->new($backups_cnt);
foreach(my $q = 0; $q < $backups_cnt; $q++) {
# upgrade backups format
my $record = $self->_unpack_record();
$record = $self->{backups}->unpack_format_v1($record);
$record = $self->{backups}->pack($record);
$self->{backups}->[ $q ] = $record;
}
$self->{files} = App::SimpleBackuper::DB::FilesTable->new($files_cnt);
$self->{files} ->[$_ - 1] = $self->_unpack_record() for 1 .. $files_cnt;
$self->{uids_gids} = App::SimpleBackuper::DB::UidsGidsTable->new($uids_gids_cnt);
$self->{uids_gids} ->[$_ - 1] = $self->_unpack_record() for 1 .. $uids_gids_cnt;
delete $self->{ $_ } foreach qw(dump offset);
my %backups_files_cnt = map {$self->{backups}->unpack($_)->{id} => 0} @{ $self->{backups} };
for my $q (0 .. $#{ $self->{files} }) {
my $file = $self->{files}->unpack( $self->{files}->[ $q ] );
foreach my $version (@{ $file->{versions} }) {
foreach my $backup_id ( $version->{backup_id_min} .. $version->{backup_id_max} ) {
$backups_files_cnt{ $backup_id }++;
lib/App/SimpleBackuper/DB.pm view on Meta::CPAN
my $backup = $self->{backups}->find_row({ id => $backup_id });
$backup->{files_cnt} = $files_cnt;
$self->{backups}->upsert({ id => $backup_id }, $backup );
}
}
sub dump_format_v1 {
my $self = shift;
return \ join('',
pack("JJJJ", $FORMAT_VERSION, scalar @{ $self->{backups} }, scalar @{ $self->{files} }, scalar @{ $self->{uids_gids} }),
map { pack("Ja".length($_), length($_), $_) } @{ $self->{backups} }, @{ $self->{files} }, @{ $self->{uids_gids} }
);
}
1;
lib/App/SimpleBackuper/DB/FilesTable.pm view on Meta::CPAN
use Data::Dumper;
use App::SimpleBackuper::DB::PartsTable;
sub _pack_version {
my($version) = @_;
my $p = __PACKAGE__->packer()
->pack(J => 1 => $version->{backup_id_min})
->pack(J => 1 => $version->{backup_id_max})
->pack(J => 1 => $version->{uid})
->pack(J => 1 => $version->{gid})
->pack(J => 1 => $version->{size})
->pack(J => 1 => $version->{mode})
->pack(J => 1 => $version->{mtime})
->pack(J => 1 => $version->{block_id})
->pack(J => 1 => length($version->{symlink_to} // ''))
;
$p->pack(a => length($version->{symlink_to}) => $version->{symlink_to} // '') if $version->{symlink_to};
foreach my $part ( @{ $version->{parts} } ) {
lib/App/SimpleBackuper/DB/FilesTable.pm view on Meta::CPAN
sub _unpack_version {
my($version) = @_;
my $p = __PACKAGE__->packer($version);
my %version = (
backup_id_min => $p->unpack(J => 1),
backup_id_max => $p->unpack(J => 1),
uid => $p->unpack(J => 1),
gid => $p->unpack(J => 1),
size => $p->unpack(J => 1),
mode => $p->unpack(J => 1),
mtime => $p->unpack(J => 1),
block_id => $p->unpack(J => 1),
parts => [],
);
my $symlink_to_length = $p->unpack(J => 1);
$version{symlink_to} = $symlink_to_length ? $p->unpack(a => $symlink_to_length) : undef;
lib/App/SimpleBackuper/Info.pm view on Meta::CPAN
use strict;
use warnings;
use Time::HiRes qw(time);
use App::SimpleBackuper::_print_table;
use App::SimpleBackuper::_format;
sub Info {
my($options, $state) = @_;
my($backups, $files, $uids_gids) = @{ $state->{db} }{qw(backups files uids_gids)};
my $parent_file;
my @path = split(/\//, $options->{path} // '/', -1);
pop @path if @path and $path[-1] eq '';
my $file_id = 0;
$state->{profile}->{walk2path} -= time;
foreach my $path_node (@path) {
my $file = $files->find_by_parent_id_name($file_id, $path_node);
return {error => 'NOT_FOUND'} if ! $file;
$file_id = $file->{id};
$parent_file = $file;
}
$state->{profile}->{walk2path} += time;
my @versions;
foreach my $version (@{ $parent_file->{versions} }) {
my @backups = map {$backups->find_row({id => $_})} $version->{backup_id_min} .. $version->{backup_id_max};
@backups = map {$_->{name}} @backups;
my $user = $uids_gids->find_row({id => $version->{uid}});
$user = $user->{name};
my $group = $uids_gids->find_row({id => $version->{gid}});
$group = $group->{name};
push @versions, {
backups => \@backups,
user => $user,
group => $group,
size => fmt_weight($version->{size}),
mode => $version->{mode},
mtime => fmt_datetime($version->{mtime}),
};
}
lib/App/SimpleBackuper/Restore.pm view on Meta::CPAN
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}) {
print "\tin backup this symlink refers to $version->{symlink_to} but on FS - to $symlink_to.\n" if $options->{verbose};
lib/App/SimpleBackuper/Restore.pm view on Meta::CPAN
}
} 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}) {
print "\tin backup it's file with size ".fmt_weight($version->{size}).", but on FS - ".fmt_weight($version->{size}).".\n" if $options->{verbose};
lib/App/SimpleBackuper/Restore.pm view on Meta::CPAN
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}, $!);
}
}
my($db_user) = map {$_->{name}}
grep {$_->{id} == $version->{uid}}
map { $state->{db}->{uids_gids}->unpack($_) }
@{ $state->{db}->{uids_gids} }
;
my($db_group) = map {$_->{name}}
grep {$_->{id} == $version->{gid}}
map { $state->{db}->{uids_gids}->unpack($_) }
@{ $state->{db}->{uids_gids} }
;
if(($fs_user ne $db_user or $fs_group ne $db_group) and ! S_ISLNK $version->{mode}) {
print "\tin backup it owned by $db_user:$db_group but on FS - by $fs_user:$fs_group.\n" if $options->{verbose};
chown scalar(getpwnam $db_user), scalar getgrnam($db_group), $fs_path if $options->{write};
}
if(S_ISDIR $version->{mode}) {
foreach my $subfile (sort {$a->{name} cmp $b->{name}} map {@$_} $state->{db}->{files}->find_all({parent_id => $file->{id}})) {
_proc_file($options, $state, $subfile, $backup_path.'/'.$subfile->{name}, $fs_path.'/'.$subfile->{name});
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
sub _write {
my ($sftp, $rfh, $off, $cb) = @_;
$sftp->_clear_error_and_status;
my $rfid = $sftp->_rfid($rfh);
defined $rfid or return undef;
my $qsize = $sftp->{_queue_size};
my @msgid;
my @written;
my $written = 0;
my $end;
while (!$end or @msgid) {
while (!$end and @msgid < $qsize) {
my $data = $cb->();
if (defined $data and length $data) {
my $id = $sftp->_queue_new_msg(SSH2_FXP_WRITE, str => $rfid,
int64 => $off + $written, str => $data);
push @written, $written;
$written += length $data;
push @msgid, $id;
}
else {
$end = 1;
}
}
my $eid = shift @msgid;
my $last = shift @written;
unless ($sftp->_check_status_ok($eid,
SFTP_ERR_REMOTE_WRITE_FAILED,
"Couldn't write to remote file")) {
# discard responses to queued requests:
$sftp->_get_msg_by_id($_) for @msgid;
return $last;
}
}
return $written;
}
sub write {
@_ == 3 or croak 'Usage: $sftp->write($fh, $data)';
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
}
my $pos = $rfh->_pos;
my $qsize = $sftp->{_queue_size};
my $bsize = $sftp->{_block_size};
do {
local $sftp->{_autodie};
my @msgid;
my $askoff = length $$bin;
my $ensure_eof;
while (!defined $len or length $$bin < $len) {
while ((!defined $len or $askoff < $len) and @msgid < $qsize) {
my $id = $sftp->_queue_new_msg(SSH2_FXP_READ, str=> $rfid,
int64 => $pos + $askoff, int32 => $bsize);
push @msgid, $id;
$askoff += $bsize;
}
my $eid = shift @msgid;
my $msg = $sftp->_get_msg_and_check(SSH2_FXP_DATA, $eid,
SFTP_ERR_REMOTE_READ_FAILED,
"Couldn't read from remote file")
or last;
my $data = $msg->get_str;
$$bin .= $data;
if (length $data < $bsize) {
unless (defined $len) {
$ensure_eof = $sftp->_queue_new_msg(SSH2_FXP_READ, str=> $rfid,
int64 => $pos + length $$bin, int32 => 1);
}
last;
}
}
$sftp->_get_msg_by_id($_) for @msgid;
if ($ensure_eof and
$sftp->_get_msg_and_check(SSH2_FXP_DATA, $ensure_eof,
SFTP_ERR_REMOTE_READ_FAILED,
"Couldn't read from remote file")) {
$sftp->_set_error(SFTP_ERR_REMOTE_BLOCK_TOO_SMALL,
"Received block was too small");
}
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
return undef
}
}
}
my $converter = _gen_converter $conversion;
my $rfid = $sftp->_rfid($rfh);
defined $rfid or die "internal error: rfid not defined";
my @msgid;
my @askoff;
my $loff = $askoff;
my $adjustment = 0;
local $\;
my $slow_start = ($size == -1 ? $queue_size - 1 : 0);
my $safe_block_size = $sftp->{_min_block_size} >= $block_size;
do {
# Disable autodie here in order to do not leave unhandled
# responses queued on the connection in case of failure.
local $sftp->{_autodie};
# Again, once this point is reached, all code paths should end
# through the CLEANUP block.
while (1) {
# request a new block if queue is not full
while (!@msgid or ( ($size == -1 or $size + $block_size > $askoff) and
@msgid < $queue_size - $slow_start and
$safe_block_size ) ) {
my $id = $sftp->_queue_new_msg(SSH2_FXP_READ, str=> $rfid,
int64 => $askoff, int32 => $block_size);
push @msgid, $id;
push @askoff, $askoff;
$askoff += $block_size;
}
$slow_start-- if $slow_start;
my $eid = shift @msgid;
my $roff = shift @askoff;
my $msg = $sftp->_get_msg_and_check(SSH2_FXP_DATA, $eid,
SFTP_ERR_REMOTE_READ_FAILED,
"Couldn't read from remote file");
unless ($msg) {
$sftp->_set_error if $sftp->{_status} == SSH2_FX_EOF;
last;
}
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
if (length($data) and !$dont_save) {
unless (print $fh $data) {
$sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,
"unable to write data to local file $local", $!);
last;
}
}
}
$sftp->_get_msg_by_id($_) for @msgid;
goto CLEANUP if $sftp->{_error};
# if a converter is in place, and aditional call has to be
# performed in order to flush any pending buffered data
if ($converter) {
my $data = '';
my $adjustment_before = $adjustment;
$adjustment += $converter->($data);
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
my $rfid = $sftp->_rfid($rfh);
defined $rfid or die "internal error: rfid is undef";
# In append mode we add the size of the remote file in
# writeoff, if lsize is undef, we initialize it to $writeoff:
$lsize += $writeoff if ($append or not defined $lsize);
# when a converter is used, the EOF can become delayed by the
# buffering introduced, we use $eof_t to account for that.
my ($eof, $eof_t);
my @msgid;
OK: while (1) {
if (!$eof and @msgid < $queue_size) {
my ($data, $len);
if ($converter) {
while (!$eof_t and length $converted_input < $block_size) {
my $read = CORE::read($fh, my $input, $block_size * 4);
unless ($read) {
unless (defined $read) {
$sftp->_set_error(SFTP_ERR_LOCAL_READ_ERROR,
"Couldn't read from local file '$local'", $!);
last OK;
}
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
if ($len) {
if ($sparse and $data =~ /^\x{00}*$/s) {
$last_block_was_zeros = 1;
$debug and $debug & 16384 and _debug "skipping zeros block at offset $writeoff, length $len";
}
else {
$debug and $debug & 16384 and _debug "writing block at offset $writeoff, length $len";
my $id = $sftp->_queue_new_msg(SSH2_FXP_WRITE, str => $rfid,
int64 => $writeoff, str => $data);
push @msgid, $id;
$last_block_was_zeros = 0;
}
$writeoff = $nextoff;
}
}
last if ($eof and !@msgid);
next unless ($eof
or @msgid >= $queue_size
or $sftp->_do_io(0));
my $id = shift @msgid;
unless ($sftp->_check_status_ok($id,
SFTP_ERR_REMOTE_WRITE_FAILED,
"Couldn't write to remote file")) {
last OK;
}
}
CORE::close $fh unless $local_is_fh;
$sftp->_get_msg_by_id($_) for @msgid;
$sftp->truncate($rfh, $writeoff)
if $last_block_was_zeros and not $sftp->{_error};
$sftp->_close_save_status($rfh);
goto CLEANUP if $sftp->{_error};
# set perm for servers that does not support setting
# permissions on open files and also atime and mtime:
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
$dir = '.' unless defined $dir;
$dir = $sftp->_rel2abs($dir);
my $rdh = $sftp->opendir($dir);
return unless defined $rdh;
my $rdid = $sftp->_rdid($rdh);
defined $rdid or return undef;
my @dir;
my @msgid;
do {
local $sftp->{_autodie};
OK: while (1) {
push @msgid, $sftp->_queue_str_request(SSH2_FXP_READDIR, $rdid)
while (@msgid < $queue_size);
my $id = shift @msgid;
my $msg = $sftp->_get_msg_and_check(SSH2_FXP_NAME, $id,
SFTP_ERR_REMOTE_READDIR_FAILED,
"Couldn't read directory '$dir'" ) or last;
my $count = $msg->get_int32 or last;
if ($cheap) {
for (1..$count) {
my $fn = $sftp->_fs_decode($msg->get_str);
push @dir, $fn if (!defined $cheap_wanted or $fn =~ $cheap_wanted);
$msg->skip_str;
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
}
if (!$wanted or $delayed_wanted or $wanted->($sftp, $entry)) {
push @dir, (($names_only and !$delayed_wanted) ? $fn : $entry);
}
}
}
$queue_size++ if $queue_size < $max_queue_size;
}
$sftp->_set_error if $sftp->{_status} == SSH2_FX_EOF;
$sftp->_get_msg_by_id($_) for @msgid;
$sftp->_closedir_save_status($rdh) if $rdh;
};
unless ($sftp->{_error}) {
if ($delayed_wanted) {
@dir = grep { $wanted->($sftp, $_) } @dir;
@dir = map { defined $_->{realpath}
? $_->{realpath}
: $_->{filename} } @dir
if $names_only;
}
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
remote file handles.
Returns true on success and undef on failure.
=item $sftp-E<gt>fsetstat($handle, $attrs)
this method is deprecated.
=item $sftp-E<gt>truncate($path_or_fh, $size)
=item $sftp-E<gt>chown($path_or_fh, $uid, $gid)
=item $sftp-E<gt>chmod($path_or_fh, $perm)
=item $sftp-E<gt>utime($path_or_fh, $atime, $mtime)
Shortcuts around C<setstat> method.
=item $sftp-E<gt>remove($path)
Sends a C<SSH_FXP_REMOVE> command to remove the remote file
local/lib/perl5/Net/SFTP/Foreign/Attributes.pm view on Meta::CPAN
use Net::SFTP::Foreign::Buffer;
sub new {
my $class = shift;
return bless { flags => 0}, $class;
}
sub new_from_stat {
if (@_ > 1) {
my ($class, undef, undef, $mode, undef,
$uid, $gid, undef, $size, $atime, $mtime) = @_;
my $self = $class->new;
$self->set_perm($mode);
$self->set_ugid($uid, $gid);
$self->set_size($size);
$self->set_amtime($atime, $mtime);
return $self;
}
return undef;
}
sub new_from_buffer {
my ($class, $buf) = @_;
my $self = $class->new;
my $flags = $self->{flags} = $buf->get_int32_untaint;
if ($flags & SSH2_FILEXFER_ATTR_SIZE) {
$self->{size} = $buf->get_int64_untaint;
}
if ($flags & SSH2_FILEXFER_ATTR_UIDGID) {
$self->{uid} = $buf->get_int32_untaint;
$self->{gid} = $buf->get_int32_untaint;
}
if ($flags & SSH2_FILEXFER_ATTR_PERMISSIONS) {
$self->{perm} = $buf->get_int32_untaint;
}
if ($flags & SSH2_FILEXFER_ATTR_ACMODTIME) {
$self->{atime} = $buf->get_int32_untaint;
$self->{mtime} = $buf->get_int32_untaint;
}
local/lib/perl5/Net/SFTP/Foreign/Attributes.pm view on Meta::CPAN
}
sub as_buffer {
my $a = shift;
my $buf = Net::SFTP::Foreign::Buffer->new(int32 => $a->{flags});
if ($a->{flags} & SSH2_FILEXFER_ATTR_SIZE) {
$buf->put_int64(int $a->{size});
}
if ($a->{flags} & SSH2_FILEXFER_ATTR_UIDGID) {
$buf->put(int32 => $a->{uid}, int32 => $a->{gid});
}
if ($a->{flags} & SSH2_FILEXFER_ATTR_PERMISSIONS) {
$buf->put_int32($a->{perm});
}
if ($a->{flags} & SSH2_FILEXFER_ATTR_ACMODTIME) {
$buf->put(int32 => $a->{atime}, int32 => $a->{mtime});
}
if ($a->{flags} & SSH2_FILEXFER_ATTR_EXTENDED) {
my $pairs = $a->{extended};
$buf->put_int32(int(@$pairs / 2));
local/lib/perl5/Net/SFTP/Foreign/Attributes.pm view on Meta::CPAN
$self->{size} = $size;
}
else {
$self->{flags} &= ~SSH2_FILEXFER_ATTR_SIZE;
delete $self->{size}
}
}
sub uid { shift->{uid} }
sub gid { shift->{gid} }
sub set_ugid {
my ($self, $uid, $gid) = @_;
if (defined $uid and defined $gid) {
$self->{flags} |= SSH2_FILEXFER_ATTR_UIDGID;
$self->{uid} = $uid;
$self->{gid} = $gid;
}
elsif (!defined $uid and !defined $gid) {
$self->{flags} &= ~SSH2_FILEXFER_ATTR_UIDGID;
delete $self->{uid};
delete $self->{gid};
}
else {
croak "wrong arguments for set_ugid"
}
}
sub perm { shift->{perm} }
sub set_perm {
my ($self, $perm) = @_;
if (defined $perm) {
$self->{flags} |= SSH2_FILEXFER_ATTR_PERMISSIONS;
$self->{perm} = $perm;
local/lib/perl5/Net/SFTP/Foreign/Attributes.pm view on Meta::CPAN
=head1 NAME
Net::SFTP::Foreign::Attributes - File/directory attribute container
=head1 SYNOPSIS
use Net::SFTP::Foreign;
my $a1 = Net::SFTP::Foreign::Attributes->new();
$a1->set_size($size);
$a1->set_ugid($uid, $gid);
my $a2 = $sftp->stat($file)
or die "remote stat command failed: ".$sftp->status;
my $size = $a2->size;
my $mtime = $a2->mtime;
=head1 DESCRIPTION
I<Net::SFTP::Foreign::Attributes> encapsulates file/directory
local/lib/perl5/Net/SFTP/Foreign/Attributes.pm view on Meta::CPAN
returns the value of the flags field.
=item $attrs-E<gt>size
returns the values of the size field or undef if it is not set.
=item $attrs-E<gt>uid
returns the value of the uid field or undef if it is not set.
=item $attrs-E<gt>gid
returns the value of the gid field or undef if it is not set.
=item $attrs-E<gt>perm
returns the value of the permissions field or undef if it is not set.
See also L<perlfunc/stat> for instructions on how to process the
returned value with the L<Fcntl> module.
For instance, the following code checks if some attributes object
corresponds to a directory:
local/lib/perl5/Net/SFTP/Foreign/Attributes.pm view on Meta::CPAN
=item $attrs-E<gt>set_size($size)
sets the value of the size field, or if $size is undef removes the
field. The flags field is adjusted accordingly.
=item $attrs-E<gt>set_perm($perm)
sets the value of the permissions field or removes it if the value is
undefined. The flags field is also adjusted.
=item $attr-E<gt>set_ugid($uid, $gid)
sets the values of the uid and gid fields, or removes them if they are
undefined values. The flags field is adjusted.
This pair of fields can not be set separately because they share the
same bit on the flags field and so both have to be set or not.
=item $attr-E<gt>set_amtime($atime, $mtime)
sets the values of the atime and mtime fields or remove them if they
are undefined values. The flags field is also adjusted.
local/lib/perl5/Net/SFTP/Foreign/Attributes/Compat.pm view on Meta::CPAN
package Net::SFTP::Foreign::Attributes::Compat;
our $VERSION = '0.01';
use strict;
use warnings;
use Net::SFTP::Foreign::Attributes;
our @ISA = qw(Net::SFTP::Foreign::Attributes);
my @fields = qw( flags size uid gid perm atime mtime );
for my $f (@fields) {
no strict 'refs';
*$f = sub { @_ > 1 ? $_[0]->{$f} = $_[1] : $_[0]->{$f} || 0 }
}
sub new {
my ($class, %param) = @_;
my $a = $class->SUPER::new();
if (my $stat = $param{Stat}) {
$a->set_size($stat->[7]);
$a->set_ugid($stat->[4], $stat->[5]);
$a->set_perm($stat->[2]);
$a->set_amtime($stat->[8], $stat->[9]);
}
$a;
}
1;
__END__
=head1 NAME
t/Actions.t view on Meta::CPAN
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,
quiet => 1,
t/DB/FilesTable.t view on Meta::CPAN
const my $file => {
parent_id => 555,
id => 666,
name => 'MyFile.JPG',
versions => [
{
backup_id_min => 5,
backup_id_max => 6,
uid => 111,
gid => 112,
size => 9999999,
mode => 1234,
mtime => time,
block_id => 222,
symlink_to => '/path/to/target',
parts => [
{
hash => 'cf83e1357eefb8bdf1542850d66d8007d620e4050b5715dc83f4a921d36ce9ce47d0d13c5d85f2b0ff8318d2877eec2f63b931bd47417a81a538327af927da3e',
size => 888,
aes_key => pack("C32", map {int rand 256} 1..32),
t/DB/FilesTable.t view on Meta::CPAN
{
'uid' => 2,
'parts' => [],
'size' => 4096,
'backup_id_min' => 1,
'backup_id_max' => 1,
'symlink_to' => undef,
'block_id' => 0,
'mode' => 16832,
'mtime' => 1596767600,
'gid' => 2
},
{
'size' => 4096,
'uid' => 2,
'parts' => [],
'backup_id_max' => 2,
'backup_id_min' => 2,
'block_id' => 0,
'symlink_to' => undef,
'gid' => 2,
'mtime' => 1598206902,
'mode' => 16832
}
],
'id' => 7077
};
is_deeply( App::SimpleBackuper::DB::FilesTable->unpack( App::SimpleBackuper::DB::FilesTable->pack($file2) ), $file2);
};
};
( run in 0.753 second using v1.01-cache-2.11-cpan-5735350b133 )