Dev-Util

 view release on metacpan or  search on metacpan

lib/Dev/Util/Backup.pm  view on Meta::CPAN

    croak "$filename is not a file\n" unless ( -e $filename );

    #backup file will have _yyyymmdd extention added to it
    my $newfile = _backup($filename);

    #preserve mode, atime, and utime of old file
    if ($PRESERVE_FILE_ATTRS) {
        my @stat = stat $filename;

        utime( $stat[8], $stat[9], $newfile );
        chmod $stat[2], $newfile;

        #preserve ownership if possible
        chown $stat[4], $stat[5], $newfile
            if ( $REAL_USER_ID == 0 || $REAL_USER_ID == $stat[4] );
    }

    return $newfile;
}

# Backup directory -- takes file name, optional compression level (2-9) and

lib/Dev/Util/Sem.pm  view on Meta::CPAN

    local $SIG{ ALRM } = sub { die "Timeout aquiring the lock on $filespec\n" };
    alarm $timeout if ( $timeout > 0 );

    $filespec =~ s{^.*/}{};
    $filespec = $lock_dir_parent . $filespec;

    my $fh = FileHandle->new;
    $fh->open( '>' . $filespec )
        or Carp::croak("Can't open semaphore file $filespec: $!\n");
    chmod 0666, $filespec;    # assuming you want it a+rw

    flock $fh, LOCK_EX;

    alarm 0;
    return bless { file => $filespec, 'fh' => $fh }, ref($class) || $class;
}

sub unlock {
    close( delete $_[0]{ 'fh' } or return 0 );
    unlink( $_[0]{ file } );

t/06-file.t  view on Meta::CPAN

is( file_exists($tf), 1, 'file_exists - exigent file returns true' );
is( file_exists($no_file), 0,
    'file_exists - non-existant file returns false' );

#======================================#
#            file_readable             #
#======================================#

my $mode = oct(0000);
my $chmod_zero_result = chmod $mode, $tff;
SKIP: {
    skip "Root user - test not valid",          1 if ( $REAL_USER_ID == 0 );
    skip "Could not make test file unreadable", 1 unless ($chmod_zero_result);
    is( file_readable($tff), 0,
        'file_readable - non-readable file returns false' );
}
$mode = oct(400);
my $chmod_400_result = chmod $mode, $tff;
SKIP: {
    skip "Could not make test file readable", 1 unless ($chmod_400_result);
    is( file_readable($tff), 1, 'file_readable - readable file returns true' );
}

#======================================#
#            file_writable             #
#======================================#

SKIP: {
    skip "Root user - test not valid", 1 if ( $REAL_USER_ID == 0 );
    is( file_writable($tff), 0,
        'file_writable - non-writable file returns false' );
}
my $chmod_200_result = $mode = oct(200);
chmod $mode, $tff;
SKIP: {
    skip "Could not make test file writable", 1 unless ($chmod_200_result);
    is( file_writable($tf), 1, 'file_writable - writable file returns true' );
}

#======================================#
#           file_executable            #
#======================================#

is( file_executable($tff), 0,
    'file_executable - non-executable file returns false' );
$mode = oct(100);
my $chmod_100_result = chmod $mode, $tff;
SKIP: {
    skip "Could not make test file executable", 1 unless ($chmod_100_result);
    is( file_executable($tff), 1,
        'file_executable - executable file returns true' );
}

#======================================#
#            file_is_empty             #
#======================================#

is( file_is_empty($dnf), 1, 'file_is_empty - empty file returns true' );
is( file_is_empty($tff), 0, 'file_is_empty - non-empty file returns false' );

t/06-file.t  view on Meta::CPAN

}

#======================================#
#            file_is_setuid            #
#======================================#

is( file_is_setuid($tff), 0,
    'file_is_setuid - non-setuid file returns false' );

$mode = oct(4444);
my $chmod_suid_result = chmod $mode, $tff;
SKIP: {
    skip "Could not set setuid bit on test file", 1 unless ($chmod_suid_result);
    is( file_is_setuid($tff), 1, 'file_is_setuid - setuid file returns true' );
}

#======================================#
#            file_is_setgid            #
#======================================#

is( file_is_setgid($tff), 0,
    'file_is_setgid - non-setgid file returns false' );

$mode = oct(2444);
my $chmod_guid_result = chmod $mode, $tff;
SKIP: {
    skip "setgid not supported on Darwin in /tmp unless in wheel group", 1
        if ( is_mac() );
    skip "Could not set setgid bit on test file", 1 unless ($chmod_guid_result);
    is( file_is_setgid($tff), 1, 'file_is_setgid - setgid file returns true' );
}

#======================================#
#            file_is_sticky            #
#======================================#

is( file_is_sticky($tff), 0,
    'file_is_sticky - non-sticky file returns false' );

$mode = oct(1444);
my $chmod_sticky_result = chmod $mode, $tff;
SKIP: {
    skip "Set sticky not supported on Solaris in /tmp", 1 if ( is_sunos() );
    skip "Could not set sticky bit on test file", 1 unless ($chmod_sticky_result);
    is( file_is_sticky($tff), 1, 'file_is_sticky - sticky file returns true' );
}

#======================================#
#            file_is_ascii             #
#======================================#

is( file_is_ascii($tf),  1, 'file_is_ascii - ascii file returns true' );
is( file_is_ascii($trf), 0, 'file_is_ascii - non-ascii file returns false' );

t/06-file.t  view on Meta::CPAN

#======================================#

is( dir_exists($td),     1, 'dir_exists - exigent dir returns true' );
is( dir_exists($no_dir), 0, 'dir_exists - non-existant dir returns false' );

#======================================#
#             dir_readable             #
#======================================#

$mode = oct(000);
chmod $mode, $td;
SKIP: {
    skip "Root user - test not valid", 1 if ( $REAL_USER_ID == 0 );
    is( dir_readable($td), 0, 'dir_readable - non-readable dir returns false' );
}
$mode = oct(400);
chmod $mode, $td;
is( dir_readable($td), 1, 'dir_readable - readable dir returns true' );

#======================================#
#            dir_writable              #
#======================================#
SKIP: {
    skip "Root user - test not valid", 1 if ( $REAL_USER_ID == 0 );
    is( dir_writable($td), 0, 'dir_writable - non-writable dir returns false' );
}
$mode = oct(200);
chmod $mode, $td;
is( dir_writable($td), 1, 'dir_writable - writable dir returns true' );

#======================================#
#            dir_executable            #
#======================================#
SKIP: {
    skip "Root user - test not valid", 1 if ( $REAL_USER_ID == 0 );
    is( dir_executable($td), 0,
        'dir_executable - non-executable dir returns false' );
}
$mode = oct(100);
chmod $mode, $td;
is( dir_executable($td), 1, 'dir_executable - executable dir returns true' );
$mode = oct(700);
chmod $mode, $td;

#======================================#
#           dir_suffix_slash           #
#======================================#

my $test_dir_w  = '/abc/def/';
my $test_dir_wo = '/abc/def';
is( dir_suffix_slash($test_dir_w),
    $test_dir_w,
    "dir_suffix_slash - don't change dir if has trailing slash" );