view release on metacpan or  search on metacpan

t/010-write_file.t  view on Meta::CPAN

# CHECKSUM - that the module can generate a checksum, and then obtain
# the same checksum on the data written to disk. Obviously, this
# requires that the code, disks, and any stray cosmic rays all work
# together...
SKIP: {
    eval { require Digest::SHA1; };
    skip( "lack Digest::SHA1 so sorry", 2 ) if $@;

    my $really_important = "Can't corrupt this\n http://xkcd.com/108/ \n";

    is( test_write_file(
            {   file     => File::Spec->catfile( $work_dir, 'checksum' ),
                input    => \$really_important,
                CHECKSUM => 1
            }
        ),
        $really_important,
        'Digest::SHA1 internal generated checksum'
    );

    # next, supply our own checksum
    my $digest   = Digest::SHA1->new;
    my $checksum = $digest->add($really_important)->hexdigest;

    is( test_write_file(
            {   file     => File::Spec->catfile( $work_dir, 'checksum2' ),
                input    => \$really_important,
                checksum => $checksum,
                CHECKSUM => 1
            }
        ),
        $really_important,
        'Digest::SHA1 external supplied checksum'
    );
}

SKIP: {
    skip( "not on this OS", 4 ) if $^O =~ m/Win32/;

    # mode -
    for my $mode (qw(0600 0700)) {
        my $octo_mode = oct($mode);

        my $octmode_test_file = File::Spec->catfile( $work_dir, "octmode$mode" );
        test_write_file(
            { file => $octmode_test_file, input => \"whatever", mode => $octo_mode } );
        my $file_mode = ( stat $octmode_test_file )[2] & 07777;
        is( $file_mode, $octo_mode, "test octal mode $mode" );

        my $stringmode_test_file = File::Spec->catfile( $work_dir, "stringmode$mode" );
        test_write_file(
            { file => $stringmode_test_file, input => \"whatever", mode => $mode } );
        $file_mode = ( stat $stringmode_test_file )[2] & 07777;
        is( $file_mode, $octo_mode, "test string mode $mode" );

    }
}

# owner - confirm that the module code is not buggy, as cannot expect to
# have the rights to chown a file to a different account. Might be able
# to test the group code, as the group could vary, depending on whether
# BSD or Solaris directory group id semantics are in play, but detecting
# that would be annoying.
SKIP: {
    my ( $user_name, $user_uid, $group_name, $group_gid );
    # getpwuid unimplemented on a certain OS, try to skip.
    eval {
        $user_name  = getpwuid($<) || undef;
        $user_uid   = $<           || '';
        $group_name = getgrgid($() || undef;
        $group_gid  = $(           || '';
    };

    skip( "no suitable login data to test owner option", 5 )
      unless defined $user_name
      and $user_uid =~ m/^[0-9]+$/
      and defined $group_name
      and $group_gid =~ m/^[0-9]+$/;

    my @owner_strings = (
        $user_uid, $user_name, "$user_uid:$group_gid", "$user_name:$group_gid",
        "$user_name:$group_name"
    );

    for my $owner (@owner_strings) {
        my $test_name = $owner;
        $test_name =~ tr/:./ab/;    # keep special chars out of filenames

        my $test_file = File::Spec->catfile( $work_dir, "owner$test_name" );

        test_write_file(
            { file => $test_file, input => \"whatever", owner => $owner } );

        # mostly just testing that the above call does not blow up...
        my ( $file_uid, $file_gid ) = ( stat $test_file )[ 4, 5 ];
        is( "$user_uid:$group_gid", "$file_uid:$file_gid", qq{owner set to "$owner"} );
    }
}

# utime - confirm that the module code is not buggy
SKIP: {
    # atime is not supported on FAT / Win32
    skip( "not on this OS", 2 ) if $^O =~ m/Win32/;

    my $mtime     = 1000;
    my $test_file = File::Spec->catfile( $work_dir, "mtime" );
    my $now       = time();
    test_write_file(
        { file => $test_file, input => \"whatever", mtime => $mtime } );

    # TODO parse `mount` output for noatime, or module that checks for that?
    my ( $file_atime, $file_mtime ) = ( stat $test_file )[ 8, 9 ];
    diag("notice: filesystem mounted noatime may fail atime test");
    ok( $file_atime >= $now, "atime is now (not modified)" );

    is( $file_mtime, $mtime, "mtime set with mtime $mtime" );
}

# backup
SKIP: {