view release on metacpan or  search on metacpan

lib/App/DistSync.pm  view on Meta::CPAN

=head2 sync

    $ds->sync or die ("Sync error");

Synchronization of the specified directory with the remote resources (mirrors)

=head2 ua

    my $ua = $ds->ua;

Returns the UserAgent instance (LWP::UserAgent)

=head2 verbose

    warn "Error details\n" if $ds->verbose;

This method returns verbose flag

=head1 HISTORY

See C<Changes> file

=head1 TO DO

See C<TODO> file

=head1 SEE ALSO

L<LWP::Simple>

=head1 AUTHOR

Serż Minus (Sergey Lepenkov) L<https://www.serzik.com> E<lt>abalama@cpan.orgE<gt>

=head1 COPYRIGHT

Copyright (C) 1998-2026 D&D Corporation

=head1 LICENSE

This program is distributed under the terms of the Artistic License Version 2.0

See the C<LICENSE> file or L<https://opensource.org/license/artistic-2-0> for details

=cut

our $VERSION = '1.11';

our $DEBUG //= !!$ENV{DISTSYNC_DEBUG};

use Carp;
use Cwd qw/abs_path getcwd/;
use FindBin qw($Script);
use File::Basename qw/dirname/;
use File::Copy qw/mv/;
use File::Spec;
use File::Path qw/mkpath/;
use Sys::Hostname;
use URI;
use LWP::UserAgent qw//;
use HTTP::Request qw//;
use HTTP::Date qw//;
use HTTP::Status qw//;

use App::DistSync::Util qw/
        debug qrreconstruct touch spew slurp
        fdelete read_yaml write_yaml
        maniread manifind maniwrite
    /;

use constant {
    TEMPFILE    => sprintf("distsync_%s.tmp", $$),
    TIMEOUT     => 30,
    METAFILE    => 'META',
    MANIFEST    => 'MANIFEST',
    MANISKIP    => 'MANIFEST.SKIP',
    MANITEMP    => 'MANIFEST.TEMP',
    MANILOCK    => 'MANIFEST.LOCK',
    MANIDEL     => 'MANIFEST.DEL',
    MIRRORS     => 'MIRRORS',
    README      => 'README',
    SKIPFILES   => [qw/
        META MANIFEST MIRRORS README
        MANIFEST.SKIP MANIFEST.LOCK MANIFEST.TEMP MANIFEST.DEL
    /],
    SKIPMODE    => 1,
    LIMIT       => '+1m', # '+1m' Limit gt and lt
    EXPIRE      => '+3d', # '+3d' For deleting
    FREEZE      => '+1d', # '+1d' For META test
};

# Methods
sub new {
    my $class = shift;
    my %props = @_;

    # Check directory
    my $dir = $props{dir} // getcwd();
    croak("Directory '$dir' not exists") unless length($dir) && (-d $dir or -l $dir);
    $props{dir} = $dir = abs_path($dir);

    # General
    $props{started} = $props{stamp} = time;
    $props{pid} ||= $$;
    $props{timeout} //= TIMEOUT;
    $props{verbose} ||= 0;
    $props{insecure} ||= 0;
    $props{proxy} //= '';
    $props{url} = '';
    $props{hostname} = hostname();

    # Files
    $props{file_meta}       = File::Spec->catfile($dir, METAFILE);
    $props{file_manifest}   = File::Spec->catfile($dir, MANIFEST);
    $props{file_maniskip}   = File::Spec->catfile($dir, MANISKIP);
    $props{file_manilock}   = File::Spec->catfile($dir, MANILOCK);
    $props{file_manitemp}   = File::Spec->catfile($dir, MANITEMP);
    $props{file_manidel}    = File::Spec->catfile($dir, MANIDEL);
    $props{file_mirrors}    = File::Spec->catfile($dir, MIRRORS);
    $props{file_readme}     = File::Spec->catfile($dir, README);
    $props{file_temp}       = File::Spec->catfile(File::Spec->tmpdir(), TEMPFILE);

lib/App/DistSync.pm  view on Meta::CPAN

    return 0 unless maniwrite($self->{file_manifest}, $new_manifest);

    # Creating new META file
    debug("Generating new META file");
    # NOTE! The status in the META file is set only after the final directory structure
    # has been successfully generated. This change distinguishes already "working"
    # resources from those that have just been initialized.
    my $now = time;
    my $new_meta = {
            project     => ref($self),
            version     => $self->VERSION,
            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) {