| Commit | Line | Data |
|---|
| 39713df4 |
1 | ### This program tests Archive::Tar::File ### |
| 2 | |
| 3 | use Test::More 'no_plan'; |
| 4 | use strict; |
| 5 | |
| 6 | use File::Spec::Unix (); |
| 7 | |
| 8 | use Archive::Tar::File; |
| 9 | use Archive::Tar::Constant; |
| 10 | |
| 11 | my $all_chars = join '', "\r\n", map( chr, 0..255 ), "zzz\n\r"; |
| 12 | my $start_time = time() - 1 - TIME_OFFSET; |
| 13 | my $replace_contents = $all_chars x 42; |
| 14 | |
| 15 | my $rename_path = 'x/yy/42'; |
| 16 | my ($rename_dir, $rename_file) = dir_and_file( $rename_path ); |
| 17 | |
| 18 | my @test_files = ( |
| 19 | ### pathname contents optional hash of attributes ### |
| 20 | [ 'x/bIn1', $all_chars ], |
| 21 | [ 'bIn2', $all_chars x 2 ], |
| 22 | [ 'bIn0', '' ], |
| 01d11a1c |
23 | |
| 24 | ### we didnt handle 'false' filenames very well across A::T as of version |
| 25 | ### 1.32, as reported in #28687. Test for the handling of such files here. |
| 26 | [ 0, '', ], |
| 39713df4 |
27 | |
| 28 | ### keep this one as the last entry |
| 29 | [ 'x/yy/z', '', { type => DIR, |
| 30 | mode => 0777, |
| 31 | uid => 42, |
| 32 | gid => 43, |
| 33 | uname => 'Ford', |
| 34 | gname => 'Prefect', |
| 35 | mtime => $start_time } ], |
| 36 | ); |
| 37 | |
| 38 | ### new( data => ... ) tests ### |
| 39 | for my $f ( @test_files ) { |
| 40 | my $unix_path = $f->[0]; |
| 41 | my $contents = $f->[1]; |
| 42 | my $attr = $f->[2] || {}; |
| 43 | my ($dir, $file) = dir_and_file( $unix_path ); |
| 44 | |
| 45 | my $obj = Archive::Tar::File->new( data => $unix_path, $contents, $attr ); |
| 46 | |
| 47 | isa_ok( $obj, 'Archive::Tar::File', "Object created" ); |
| 48 | is( $obj->name, $file, " name '$file' ok" ); |
| 49 | is( $obj->prefix, $dir, " prefix '$dir' ok" ); |
| 50 | is( $obj->size, length($contents), " size ok" ); |
| 51 | is( $obj->mode, exists($attr->{mode}) ? $attr->{mode} : MODE, |
| 52 | " mode ok" ); |
| 53 | is( $obj->uid, exists($attr->{uid}) ? $attr->{uid} : UID, |
| 54 | " uid ok" ); |
| 55 | is( $obj->gid, exists($attr->{gid}) ? $attr->{gid} : GID, |
| 56 | " gid ok" ); |
| 57 | is( $obj->uname, exists($attr->{uname}) ? $attr->{uname} : UNAME->(UID ), |
| 58 | " uname ok" ); |
| 59 | is( $obj->gname, exists($attr->{gname}) ? $attr->{gname} : GNAME->( GID ), |
| 60 | " gname ok" ); |
| 61 | is( $obj->type, exists($attr->{type}) ? $attr->{type} : FILE, |
| 62 | " type ok" ); |
| 63 | if (exists($attr->{mtime})) { |
| 64 | is( $obj->mtime, $attr->{mtime}, " mtime matches" ); |
| 65 | } else { |
| 66 | cmp_ok( $obj->mtime, '>', $start_time, " mtime after start time" ); |
| 67 | } |
| 68 | ok( $obj->chksum, " chksum ok" ); |
| 69 | ok( $obj->version, " version ok" ); |
| 70 | ok( ! $obj->linkname, " linkname ok" ); |
| 71 | ok( ! $obj->devmajor, " devmajor ok" ); |
| 72 | ok( ! $obj->devminor, " devminor ok" ); |
| 73 | ok( ! $obj->raw, " raw ok" ); |
| 74 | |
| 75 | ### test type checkers |
| 76 | SKIP: { |
| 77 | skip "Attributes defined, may not be plainfile", 11 if keys %$attr; |
| 78 | |
| 79 | ok( $obj->is_file, " Object is a file" ); |
| 80 | |
| 81 | for my $name (qw[dir hardlink symlink chardev blockdev fifo |
| 82 | socket unknown longlink label ] |
| 83 | ) { |
| 84 | my $method = 'is_' . $name; |
| 85 | |
| 86 | ok(!$obj->$method(), " Object is not a '$name'"); |
| 87 | } |
| 88 | } |
| 89 | |
| 90 | ### Use "ok" not "is" to avoid binary data screwing up the screen ### |
| 91 | ok( $obj->get_content eq $contents, " get_content ok" ); |
| 92 | ok( ${$obj->get_content_by_ref} eq $contents, |
| 93 | " get_content_by_ref ok" ); |
| 94 | is( $obj->has_content, length($contents) ? 1 : 0, |
| 95 | " has_content ok" ); |
| 96 | ok( $obj->replace_content( $replace_contents ), |
| 97 | " replace_content ok" ); |
| 98 | ok( $obj->get_content eq $replace_contents, " get_content ok" ); |
| 99 | ok( $obj->replace_content( $contents ), " replace_content ok" ); |
| 100 | ok( $obj->get_content eq $contents, " get_content ok" ); |
| 101 | |
| 102 | ok( $obj->rename( $rename_path ), " rename ok" ); |
| 103 | is( $obj->name, $rename_file, " name '$file' ok" ); |
| 104 | is( $obj->prefix, $rename_dir, " prefix '$dir' ok" ); |
| 105 | ok( $obj->rename( $unix_path ), " rename ok" ); |
| 106 | is( $obj->name, $file, " name '$file' ok" ); |
| 107 | is( $obj->prefix, $dir, " prefix '$dir' ok" ); |
| 108 | |
| 109 | ### clone tests ### |
| 110 | my $clone = $obj->clone; |
| 111 | isnt( $obj, $clone, "Clone is different object" ); |
| 112 | is_deeply( $obj, $clone, " Clone holds same data" ); |
| 113 | } |
| 114 | |
| 115 | ### _downgrade_to_plainfile |
| 116 | { my $aref = $test_files[-1]; |
| 117 | my $unix_path = $aref->[0]; |
| 118 | my $contents = $aref->[1]; |
| 119 | my $attr = $aref->[2]; |
| 120 | |
| 121 | my $obj = Archive::Tar::File->new( data => $unix_path, $contents, $attr ); |
| 122 | |
| 123 | ### check if the object is as expected |
| 124 | isa_ok( $obj, 'Archive::Tar::File' ); |
| 125 | ok( $obj->is_dir, " Is a directory" ); |
| 126 | |
| 127 | ### do the downgrade |
| 128 | ok( $obj->_downgrade_to_plainfile, " Downgraded to plain file" ); |
| 129 | |
| 130 | ### now check if it's downgraded |
| 131 | ok( $obj->is_file, " Is now a file" ); |
| 132 | is( $obj->linkname, '', " No link entered" ); |
| 133 | is( $obj->mode, MODE, " Mode as expected" ); |
| 134 | } |
| 135 | |
| 136 | ### helper subs ### |
| 137 | sub dir_and_file { |
| 138 | my $unix_path = shift; |
| 139 | my ($vol, $dirs, $file) = File::Spec::Unix->splitpath( $unix_path ); |
| 140 | my $dir = File::Spec::Unix->catdir( grep { length } $vol, |
| 141 | File::Spec::Unix->splitdir( $dirs ) ); |
| 142 | return ( $dir, $file ); |
| 143 | } |
projects / p5sagit/p5-mst-13.2.git / blame