App-DistSync
view release on metacpan or search on metacpan
lib/App/DistSync.pm view on Meta::CPAN
sub pid { shift->{pid} }
sub ua { shift->{ua} }
sub init { # Initialization
my $self = shift;
my $stamp = scalar(localtime($self->{started}));
my $status = 1;
# MANIFEST.SKIP
printf "%s... ", $self->{file_maniskip};
if (touch($self->{file_maniskip}) && (-e $self->{file_maniskip}) && -z $self->{file_maniskip}) {
my @content = (
"# Generated on $stamp",
"# List of files that should not be synchronized",
"#",
"# Format of file:",
"#",
"# dir1/dir2/.../dirn/foo.txt any comment, for example blah-blah-blah",
"# bar.txt any comment, for example blah-blah-blah",
"# baz.txt",
"# 'spaced dir1/foo.txt' any comment, for example blah-blah-blah",
"# 'spaced dir1/foo.txt' any comment, for example blah-blah-blah",
"# !!perl/regexp (?i-xsm:\\.bak\$) avoid all bak files",
"#",
"# See also MANIFEST.SKIP file of ExtUtils::Manifest v1.68 or later",
"#",
"",
"# Avoid version control files.",
"!!perl/regexp (?i-xsm:\\bRCS\\b)",
"!!perl/regexp (?i-xsm:\\bCVS\\b)",
"!!perl/regexp (?i-xsm:\\bSCCS\\b)",
"!!perl/regexp (?i-xsm:,v\$)",
"!!perl/regexp (?i-xsm:\\B\\.svn\\b)",
"!!perl/regexp (?i-xsm:\\B\\.git\\b)",
"!!perl/regexp (?i-xsm:\\B\\.gitignore\\b)",
"!!perl/regexp (?i-xsm:\\b_darcs\\b)",
"!!perl/regexp (?i-xsm:\\B\\.cvsignore\$)",
"",
"# Avoid temp and backup files.",
"!!perl/regexp (?i-xsm:~\$)",
"!!perl/regexp (?i-xsm:\\.(old|bak|back|tmp|temp|rej)\$)",
"!!perl/regexp (?i-xsm:\\#\$)",
"!!perl/regexp (?i-xsm:\\b\\.#)",
"!!perl/regexp (?i-xsm:\\.#)",
"!!perl/regexp (?i-xsm:\\..*\\.sw.?\$)",
"",
"# Avoid prove files",
"!!perl/regexp (?i-xsm:\\B\\.prove\$)",
"",
"# Avoid MYMETA files",
"!!perl/regexp (?i-xsm:^MYMETA\\.)",
"",
"# Avoid Apache and building files",
"!!perl/regexp (?i-xsm:\\B\\.ht.+\$)",
"!!perl/regexp (?i-xsm:\\B\\.exists\$)",
"",
"# Skip TEMP files",
"!!perl/regexp (?i-xsm:\\.TEMP\\-\\d+\$)",
"\n",
);
if (spew($self->{file_maniskip}, join("\n", @content))) {
say "ok";
} else {
say "fail";
$status = 0;
}
} else {
say "skip";
}
# MANIFEST.DEL
printf "%s... ", $self->{file_manidel};
if (touch($self->{file_manidel}) && (-e $self->{file_manidel}) && -z $self->{file_manidel}) {
my @content = (
"# Generated on $stamp",
"# List of files that must be deleted. By default, the files will be",
"# deleted after 3 days.",
"#",
"# Format of file:",
"#",
"# dir1/dir2/.../dirn/foo.txt 1d",
"# bar.txt 2M",
"# baz.txt",
"# 'spaced dir1/foo.txt' 1m",
"# 'spaced dir1/foo.txt' 2y",
"#",
"\n",
);
if (spew($self->{file_manidel}, join("\n", @content))) {
say "ok";
} else {
say "fail";
$status = 0;
}
} else {
say "skip";
}
# MIRRORS
printf "%s... ", $self->{file_mirrors};
if (touch($self->{file_mirrors}) && (-e $self->{file_mirrors}) && -z $self->{file_mirrors}) {
my @content = (
"# Generated on $stamp",
"# List of addresses (URIs) of remote storage (mirrors).",
"# Must be specified at least two mirrors",
"#",
"# Format of file:",
"#",
"# http://www.example.com/dir1 any comment, for example blah-blah-blah",
"# http://www.example.com/dir2 any comment, for example blah-blah-blah",
"# 'http://www.example.com/dir2' any comment, for example blah-blah-blah",
"#",
"\n",
);
if (spew($self->{file_mirrors}, join("\n", @content))) {
say "ok";
} else {
say "fail";
$status = 0;
}
} else {
say "skip";
}
# README
printf "%s... ", $self->{file_readme};
if (touch($self->{file_readme}) && (-e $self->{file_readme}) && -z $self->{file_readme}) {
my @content = (
"# This file contains information about the resource (mirror) in the free form.",
"#",
"# Initialization date : $stamp",
"# Resource's directory : " . $self->dir,
"#",
"\n",
);
if (spew($self->{file_readme}, join("\n", @content))) {
say "ok";
} else {
say "fail";
$status = 0;
}
} else {
say "skip";
}
return $status;
}
sub sync { # Synchronization. Main proccess
my $self = shift;
my $status = 0;
my %skips; # { file => /regexp/|file } List of skipped files
my $manifest = maniread($self->{file_manifest}) // {}; # {file => [epoch, size, wday, month, day, time, year]}
my %sync_list; # {file => [{url, mtime, size}]} List of files to sync
my %delete_list; # {file => count} List of files to delete
# Filling the list of exclusion files using the MANIFEST.SKIP file and
# the list of system files from the SKIPFILES constant
{
debug("Getting the list of skipped files");
my @skip_keys = @{(SKIPFILES)};
my $maniskip = maniread($self->{file_maniskip}, SKIPMODE); # MANIFEST.SKIP
push @skip_keys, keys %$maniskip if ref($maniskip) eq 'HASH';
for (@skip_keys) {$skips{$_} = qrreconstruct($_)}
debug("Found %d keys in the list of skipped files", scalar(keys %skips));
#debug(Data::Dumper::Dumper(\%skips)) && return 0;
}
# Deleting files listed in the MANIFEST.DEL file but not in the exclusion list
{
debug("Deleting files from list: %s", MANIDEL);
my $delfile = $self->{file_manidel}; # MANIFEST.DEL
my $deltime = $self->{mtime_manidel}; # Modify time in seconds
my $dellist = maniread($delfile) // {}; # { file => expire };
my $expire = 0;
foreach (values %$dellist) {
my $dt = _expire($_->[0] || 0);
$_ = [$dt];
$expire = $dt if $dt > $expire;
}
$expire = _expire(EXPIRE) unless $expire > 0;
debug("The file '$delfile' will expire on %s", scalar(localtime($deltime + $expire)))
if $deltime;
#debug(Data::Dumper::Dumper($dellist)) && return 0;
if ($deltime && (time - $deltime) > $expire) { # MANIFEST.DEL is expired!
# Delete files physically if they exist physically and are not on the exclusion list!
foreach my $k (keys %$dellist) {
if (_skipcheck(\%skips, $k)) { # The file is in the exclusion list.
debug("> [SKIPPED] %s", $k);
next;
}
my $f = File::Spec->canonpath(File::Spec->catfile($self->dir, $k));
if (-e $f) {
fdelete($f);
debug("> [DELETED] %s", $k);
} else {
debug("> [SKIPPED] %s (%s)", $k, $f);
}
}
# Deleting the MANIFEST.DEL file and immediately creating a new one
fdelete($delfile);
touch($delfile);
} else {
lib/App/DistSync.pm view on Meta::CPAN
hostname => $self->{hostname},
directory => $self->dir,
script => $Script,
start => $self->{stamp},
finish => $now,
pid => $self->pid,
uri => $self->{url} || 'localhost',
url => $self->{url} || 'localhost',
date => scalar(localtime(time)),
'time' => $now - $self->{stamp},
status => 1,
};
return 0 unless write_yaml($self->{file_meta}, $new_meta);
# Return
return $status;
}
sub fetch { # Returns structire {status, mtime, size, code, url}
my $self = shift;
my $url = shift; # Base url
my $obj = shift; # The tail of path
my $file = shift // ''; # File to download
my $ua = $self->ua;
# Empty response
my $ret = {
status => 0, # Status
mtime => 0, # Last-Modified in ctime format or 0
size => 0, # Content-length
code => 0, # Status code
message => '',
url => '',
};
# Check file
unless (length($file)) {
carp "File path to download is not specified";
return $ret;
}
# Make new URI
my $uri = URI->new($url);
my $curpath = $uri->path();
my $newpath = $curpath . (defined $obj ? "/$obj" : '');
$newpath =~ s/\/{2,}/\//;
$uri->path($newpath);
$ret->{url} = $uri->as_string;
# First request: get HEAD information
my $request = HTTP::Request->new(HEAD => $uri);
my $response = $ua->request($request);
my $content_type = scalar $response->header('Content-Type');
my $document_length = scalar $response->header('Content-Length');
my $modified_time = HTTP::Date::str2time($response->header('Last-Modified'));
my $expires = HTTP::Date::str2time($response->header('Expires'));
my $server = scalar $response->header('Server');
$ret->{code} = $response->code;
$ret->{message} = $response->message;
if ($self->verbose) {
if (!$DEBUG && !$response->is_success) {
say sprintf "> HEAD %s", $uri->as_string;
say sprintf "< %s", $response->status_line;
}
debug("> HEAD %s", $uri->as_string);
debug("< %s", $response->status_line);
if ($response->is_success) {
debug("< Content-Type : %s", $content_type // '');
debug("< Content-Length : %s", $document_length || 0);
debug("< Last-Modified : %s", $modified_time ? scalar(localtime($modified_time)) : '');
debug("< Expires : %s", $expires ? scalar(localtime($expires)) : '');
debug("< Server : %s", $server // '');
} else {
debug("< Empty response");
}
}
# Status
unless ($response->is_success) {
debug("Can't fetch %s. %s", $uri->as_string, $response->status_line);
return $ret;
}
# Size
$ret->{size} = $document_length || 0;
# Modified time
$ret->{mtime} = $modified_time // 0;
unless ($ret->{mtime}) {
debug("Can't fetch %s. Header 'Last-Modified' not received", $uri->as_string);
return $ret;
}
# Safe file mirroring
my $temp = sprintf "%s.tmp", $file;
if (-e $file) {
unless (mv($file, $temp)) {
printf STDERR "Can't move file \"%s\" to \"%s\": %s\n", $file, $temp, $!;
return $ret;
}
}
# Request
$response = $ua->mirror($uri, $file);
$ret->{code} = $response->code;;
$ret->{message} = $response->message;
if ($self->verbose) {
debug("> GET %s", $uri->as_string) or say sprintf "> GET %s", $uri->as_string;
debug("< %s", $response->status_line) or say sprintf "< %s", $response->status_line;
}
if ($response->is_success) {
if (-e $file && (-s $file) == $ret->{size}) {
$ret->{status} = 1;
fdelete($temp);
}
} else {
debug("Can't fetch %s. %s", $uri->as_string, $response->status_line);
return $ret;
}
# Move temp file to original name
if (!$ret->{status} && -e $temp) {
unless (mv($temp, $file)) {
printf "Can't move file \"%s\" to \"%s\": %s", $temp, $file, $!;
}
}
return $ret;
}
sub status { # Show statistic information
my $self = shift;
# Read MIRRORS file
my $mirrors_mani = maniread($self->{file_mirrors}) // {}; # MIRRORS
my @mirrors = sort {$a cmp $b} keys %$mirrors_mani;
unless (scalar(@mirrors)) {
say STDERR sprintf "File %s is empty", MIRRORS;
return;
}
# Go!
foreach my $url (@mirrors) {
say sprintf "RESOURCE \"%s\"", $url;
my $self_mode = 0;
# Downloading the MANIFEST.LOCK file, skipping the mirror resource if this
# file was successfully downloaded from the resource
{
debug("Fetching %s", MANILOCK);
my $fetch_lock = $self->fetch($url, MANILOCK, $self->{file_manitemp});
if ($fetch_lock->{status}) { # Ok
if ($self->_check_lockfile($self->{file_manitemp})) {
$self->{url} = $url;
$self_mode = 1;
} else {
say STDERR "Remote resource is in a state of updating. Please wait";
next;
}
}
}
# Downloading the META file and analyzing the resource (checking the resource
# status and update date). If the check fails, the resource is skipped.
{
debug("Fetching %s", METAFILE);
my $meta = $self->fetch($url, METAFILE, $self->{file_manitemp});
if ($meta->{status}) { # Ok
my $remote_meta = read_yaml($self->{file_manitemp}) // '';
if (((ref($remote_meta) eq 'ARRAY') || ref($remote_meta) eq 'YAML::Tiny')) {
$remote_meta = $remote_meta->[0] || {};
}
unless ($remote_meta && ref($remote_meta) eq 'HASH') {
say STDERR "Remote resource is unreadable. Please contact the administrator of this resource";
next;
}
unless ($remote_meta->{status}) {
say STDERR "Remote resource is broken. Please contact the administrator of this resource";
next;
}
# Show information
my $remote_url = $remote_meta->{url} || $remote_meta->{uri} || '';
my $remote_date = $meta->{mtime} || 0;
my $remote_datef = $remote_date ? scalar(localtime($remote_date)) : 'UNKNOWN';
my $remote_ok = (time - $remote_date) > _expire(FREEZE) ? 0 : 1;
say sprintf " Resource URL : %s%s", $remote_url, $self_mode ? " (LOCAL RESOURCE)" : '';
say sprintf " Status : %s", $remote_ok ? "OK" : "EXPIRED";
say sprintf " Date : %s", $remote_meta->{date} // 'UNKNOWN';
say sprintf " Modified : %s", $remote_datef;
say sprintf " Hostname : %s", $remote_meta->{hostname} // '';
say sprintf " Directory : %s", $remote_meta->{directory} // '';
say sprintf " Project : %s v%s", $remote_meta->{project} || ref($self), $remote_meta->{version} // '';
say sprintf " Script : %s", $remote_meta->{script} // $Script;
say sprintf " Time : %d sec", $remote_meta->{'time'} || 0;
unless ($remote_ok) {
say STDERR sprintf "NOTE! The resource is expired. Last updated: %s", $remote_datef;
next
}
} else {
printf STDERR "Can't download \"%s\": %s\n", $meta->{url}, $meta->{message};
}
}
}
return 1;
}
sub mkmani {
my $self = shift;
my %skips; # { file => /regexp/|file } List of skipped files
# Filling the list of exclusion files using the MANIFEST.SKIP file and
# the list of system files from the SKIPFILES constant
{
debug("Getting the list of skipped files");
my @skip_keys = @{(SKIPFILES)};
my $maniskip = maniread($self->{file_maniskip}, SKIPMODE); # MANIFEST.SKIP
push @skip_keys, keys %$maniskip if ref($maniskip) eq 'HASH';
for (@skip_keys) {$skips{$_} = qrreconstruct($_)}
debug("Found %d keys in the list of skipped files", scalar(keys %skips));
}
# Getting list files from MANIFEST.DEL file but not in the exclusion list
{
debug("Getting list files from: %s", MANIDEL);
my $delfile = $self->{file_manidel}; # MANIFEST.DEL
my $dellist = maniread($delfile) // {}; # { file => expire };
#debug(Data::Dumper::Dumper($dellist));
# Check by exclusion list
foreach my $k (keys %$dellist) {
if (_skipcheck(\%skips, $k)) { # The file is in the exclusion list.
debug("> [SKIPPED] %s", $k);
next;
}
# Adding files listed in MANIFEST.DEL to the exclusion list
$skips{$k} = qrreconstruct($k);
}
#debug(Data::Dumper::Dumper(\%skips));
}
# Cteating MANIFEST file
debug("Generating new manifest");
my $new_manifest = manifind($self->dir);
# We select files excluding files listed in the exclusion list
foreach my $k (keys %$new_manifest) {
my $nskip = _skipcheck(\%skips, $k);
delete $new_manifest->{$k} if $nskip;
debug("> [%s] %s", $nskip ? "SKIPPED" : " ADDED ", $k);
}
#debug(Data::Dumper::Dumper($new_manifest));
# Save the created file
debug("Saving manifest to %s", MANIFEST);
return 0 unless maniwrite($self->{file_manifest}, $new_manifest);
# Ok
return 1;
}
sub _check_lockfile { # Checking if a file is private
my $self = shift;
my $file = shift;
my $pid = $self->pid;
return 0 unless $file && -e $file;
my $fh;
unless (open($fh, "<", $file)) {
debug("Can't open file %s to read: %s", $file, $!);
return 0;
}
my $l;
chomp($l = <$fh>); $l //= "";
unless (close $fh) {
debug("Can't close file %s: %s", $file, $!);
return 0;
}
my ($r_pid, $r_stamp, $r_name) = split(/#/, $l);
return 0 unless $r_pid && ($r_pid =~ /^[0-9]{1,11}$/);
return 1 if kill(0, $r_pid) && $pid == $r_pid;
return 0;
}
sub _show_summary {
my $self = shift;
my $now = time;
say "SHORT SUMMARY";
printf " Local URL : %s\n", $self->{url} // 'undefined';
printf " Hostname : %s\n", $self->{hostname};
printf " Directory : %s\n", $self->dir;
printf " Insecure mode : %s\n", $self->{insecure} ? 'Yes' : 'No';
printf " Proxy : %s\n", $self->{proxy} || 'none';
printf " Started : %s\n", scalar(localtime($self->{started}));
printf " Finished : %s\n", scalar(localtime($now));
printf " Time : %d sec\n", $now - $self->{started};
return 1;
}
# Functions
sub _expire { # Parse expiration time
my $str = shift || 0;
return 0 unless defined $str;
return $1 if $str =~ m/^[-+]?(\d+)$/;
my %_map = (
s => 1,
m => 60,
h => 3600,
d => 86400,
w => 604800,
M => 2592000,
y => 31536000
);
my ($koef, $d) = $str =~ m/^([+-]?\d+)([smhdwMy])$/;
unless ( defined($koef) && defined($d) ) {
carp "expire(): couldn't parse '$str' into \$koef and \$d parts. Possible invalid syntax";
return 0;
}
return $koef * $_map{ $d };
}
sub _skipcheck {
my $sl = shift; # Link to %skip
my $st = shift; # Test string
return 0 unless $sl && defined($st) && ref($sl) eq 'HASH';
return 1 if exists $sl->{$st} && defined $sl->{$st}; # Catched! - Because a direct match was found
# Let's run through all the values and look for only regular expressions among them.
if (grep {(ref($_) eq 'Regexp') && $st =~ $_} values %$sl) {
# Performance optimization. Such tests would be redundant for the next check.
$sl->{$st} = 1;
# Catched!
return 1;
}
return 0; # Not Found
}
1;
__END__
( run in 1.130 second using v1.01-cache-2.11-cpan-d7a12ab2c7f )