view release on metacpan or  search on metacpan

lib/WebFetch.pm  view on Meta::CPAN

# write new content for save operation
# internal method used by save()
sub _save_write_content
{
    my ( $self, $savable, $new_content ) = @_;

    # write content to the "new content" file
    ## no critic (InputOutput::RequireBriefOpen)
    my $new_file;
    if ( not open( $new_file, ">:encoding(UTF-8)", "$new_content" ) ) {
        $savable->{error} = "cannot open $new_content: $!";
        return 0;
    }
    if ( not print $new_file $savable->{content} ) {
        $savable->{error} = "failed to write to " . $new_content . ": $!";
        close $new_file;
        return 0;
    }
    if ( not close $new_file ) {

        # this can happen with NFS errors
        $savable->{error} = "failed to close " . $new_content . ": $!";
        return 0;
    }
    return 1;
}

# save previous main content as old backup
# internal method used by save()
sub _save_main_to_backup
{
    my ( $self, $savable, $main_content, $old_content ) = @_;

    # move the main content to the old content - now it's a backup
    if ( -f $main_content ) {
        if ( not rename $main_content, $old_content ) {
            $savable->{error} = "cannot rename " . $main_content . " to " . $old_content . ": $!";
            return 0;
        }
    }
    return 1;
}

# chgrp and chmod the "new content" before final installation
# internal method used by save()
sub _save_file_mode
{
    my ( $self, $savable, $new_content ) = @_;

    # chgrp the "new content" before final installation
    if ( exists $savable->{group} ) {
        my $gid = $savable->{group};
        if ( $gid !~ /^[0-9]+$/ox ) {
            $gid = ( getgrnam($gid) )[2];
            if ( not defined $gid ) {
                $savable->{error} = "cannot chgrp " . $new_content . ": " . $savable->{group} . " does not exist";
                return 0;
            }
        }
        if ( not chown $>, $gid, $new_content ) {
            $savable->{error} = "cannot chgrp " . $new_content . " to " . $savable->{group} . ": $!";
            return 0;
        }
    }

    # chmod the "new content" before final installation
    if ( exists $savable->{mode} ) {
        if ( not chmod oct( $savable->{mode} ), $new_content ) {
            $savable->{error} = "cannot chmod " . $new_content . " to " . $savable->{mode} . ": $!";
            return 0;
        }
    }
    return 1;
}

# index lookup via legacy DB file
# returns 1 if item was found in index, 0 if it had to be added to index
# internal method used by _save_check_index()
sub _save_check_index_db
{
    my ( $self, $savable ) = @_;
    my $was_in_index  = 0;
    my $index_db_path = $self->{dir} . "/" . $index_file{db};

    # check if DB_File module is available
    my $db_available = 0;
    try {
        ## no critic (BuiltinFunctions::ProhibitStringyEval)
        eval "require $db_class" or croak $@;
        $db_available = 1;
    };

    # look up content in DB index
    if ( $db_available and ( exists $savable->{url} ) and ( exists $savable->{index} ) ) {
        tie my %id_index, 'DB_File', $index_db_path, &DB_File::O_CREAT | &DB_File::O_RDWR;
        my ( $timestamp, $filename );
        if ( exists $id_index{ $savable->{url} } ) {
            ( $timestamp, $filename ) =
                split /#/x, $id_index{ $savable->{url} };
            $was_in_index = 1;
        } else {
            $timestamp = time;
            $id_index{ $savable->{url} } =
                $timestamp . "#" . $savable->{file};
        }
        untie %id_index;
    }
    return $was_in_index;
}

# index lookup via YAML file
# returns 1 if item was found in index, 0 if it had to be added to index
# internal method used by _save_check_index()
sub _save_check_index_yaml
{
    my ( $self, $savable ) = @_;
    my $was_in_index    = 0;
    my $index_lock_path = $self->{dir} . "/" . $index_file{lock};
    my $index_yaml_path = $self->{dir} . "/" . $index_file{yaml};