1use strict; 2use warnings; 3use utf8; 4use Test::More; 5use Test::Fatal; 6use Test::FailWarnings -allow_deps => 1; 7binmode(Test::More->builder->$_, ":utf8") for qw/output failure_output todo_output/; 8 9use Encode; 10use Path::Tiny; 11use Test::DZil; 12use List::Util 'first'; 13 14use Dist::Zilla::File::InMemory; 15use Dist::Zilla::File::OnDisk; 16use Dist::Zilla::File::FromCode; 17 18my %sample = ( 19 dolmen => "Olivier Mengué", 20 keedi =>"김도형 - Keedi Kim", 21); 22 23my $sample = join("\n", values %sample); 24my $encoded_sample = encode("UTF-8", $sample); 25my $db_sample = $sample x 2; 26my $db_encoded_sample = $encoded_sample x 2; 27my $latin1_dolmen = encode("latin1", $sample{dolmen}); 28 29my $tzil = Builder->from_config( 30 { dist_root => 't/does_not_exist' }, 31 { 32 add_files => { 33 path(qw(source dist.ini)) => simple_ini( 34 'GatherDir', 35 ), 36 path(qw(source lib DZT Sample.pm)) => "package DZT::Sample;\n\n1", 37 }, 38 }, 39); 40 41{ 42 # this trickery is so the caller appears to be whatever called new_file() 43 my $gatherdir = first { $_->isa('Dist::Zilla::Plugin::GatherDir') } @{ $tzil->plugins }; 44 my $add_file = $gatherdir->can('add_file'); 45 46 my $i = 0; 47 sub new_file { 48 my ($objref, $class, @args) = @_; 49 my $obj = $class->new( 50 name => 'foo_' . $i++ . '.txt', 51 @args, 52 ); 53 ok($obj, "created a $class"); 54 $$objref = $obj; 55 56 # equivalent to: $gatherdir->add_file($obj); 57 @_ = ($gatherdir, $obj); goto &$add_file; 58 } 59} 60 61sub test_mutable_roundtrip { 62 my ($obj) = @_; 63 64 ok( $obj->DOES("Dist::Zilla::Role::MutableFile"), "does MutableFile role" ); 65 66 # assumes object content starts as $sample 67 is( $obj->content, $sample, "get content" ); 68 is( $obj->encoded_content, $encoded_sample, "get encoded_content" ); 69 70 # set content, check content & encoded_content 71 ok( $obj->content($db_sample), "set content"); 72 is( $obj->content, $db_sample, "get content"); 73 is( $obj->encoded_content, $db_encoded_sample, "get encoded_content"); 74 75 # set encoded_content, check encoded_content & content 76 ok( $obj->encoded_content($encoded_sample), "set encoded_content"); 77 is( $obj->encoded_content, $encoded_sample, "get encoded_content"); 78 is( $obj->content, $sample, "get content"); 79} 80 81sub test_content_from_bytes { 82 my ($obj, $source_re) = @_; 83 # assumes object encoded_content is encoded sample 84 is( $obj->encoded_content, $encoded_sample, "get encoded_content" ); 85 my $err = exception { $obj->content }; 86 like( 87 $err, 88 qr/can't decode text from 'bytes'/i, 89 "get content from bytes should throw error" 90 ); 91 # Match only the first line of the stack trace 92 like( $err, qr/^[^\n]+$source_re/s, "error shows encoded_content source" ); 93} 94 95sub test_latin1 { 96 my ($obj) = @_; 97 # assumes encoded_content is $latin1_dolmen and encoding 98 # is already set to 'latin1" 99 is( $obj->encoded_content, $latin1_dolmen, "get encoded_content" ); 100 is( $obj->content, $sample{dolmen}, "get content" ); 101} 102 103subtest "OnDisk" => sub { 104 my $class = "Dist::Zilla::File::OnDisk"; 105 106 subtest "UTF-8 file" => sub { 107 my $tempfile = Path::Tiny->tempfile; 108 109 ok( $tempfile->spew_utf8($sample), "create UTF-8 encoded tempfile" ); 110 my $obj; 111 new_file(\$obj, $class, name => "$tempfile"); 112 test_mutable_roundtrip($obj); 113 }; 114 115 subtest "binary file" => sub { 116 my $tempfile = Path::Tiny->tempfile; 117 118 ok( $tempfile->spew_raw($encoded_sample), "create binary tempfile" ); 119 my $obj; 120 new_file(\$obj, $class, name => "$tempfile"); 121 ok( $obj->encoding("bytes"), "set encoding to 'bytes'"); 122 test_content_from_bytes($obj, qr/encoded_content added by \S+ \(\S+ line \d+\)/); 123 }; 124 125 subtest "latin1 file" => sub { 126 my $tempfile = Path::Tiny->tempfile; 127 128 ok( 129 $tempfile->spew( { binmode => ":encoding(latin1)"}, $sample{dolmen} ), 130 "create latin1 tempfile" 131 ); 132 my $obj; 133 new_file(\$obj, $class, name => "$tempfile", encoding => 'latin1'); 134 test_latin1($obj); 135 }; 136 137}; 138 139subtest "InMemory" => sub { 140 my $class = "Dist::Zilla::File::InMemory"; 141 142 subtest "UTF-8 string" => sub { 143 my $obj; 144 new_file(\$obj, $class, content => $sample); 145 test_mutable_roundtrip($obj); 146 }; 147 148 subtest "binary string" => sub { 149 my ($obj, $line); 150 new_file(\$obj, $class, encoded_content => $encoded_sample); $line = __LINE__; 151 ok( $obj->encoding("bytes"), "set encoding to 'bytes'"); 152 test_content_from_bytes($obj, qr/encoded_content added by \S+ \(\S+ line $line\)/); 153 }; 154 155 subtest "latin1 string" => sub { 156 my $obj; 157 new_file(\$obj, $class, encoded_content => $latin1_dolmen, encoding => "latin1"); 158 test_latin1($obj); 159 }; 160 161}; 162 163subtest "FromCode" => sub { 164 my $class = "Dist::Zilla::File::FromCode"; 165 166 subtest "UTF-8 string" => sub { 167 my $obj; 168 new_file(\$obj, $class, code => sub { $sample }); 169 is( $obj->content, $sample, "content" ); 170 is( $obj->encoded_content, $encoded_sample, "encoded_content" ); 171 }; 172 173 subtest "content immutable" => sub { 174 my $obj; 175 new_file(\$obj, $class, code => sub { $sample }); 176 like( 177 exception { $obj->content($sample) }, 178 qr/cannot set content/, 179 "changing content should throw error" 180 ); 181 like( 182 exception { $obj->encoded_content($encoded_sample) }, 183 qr/cannot set encoded_content/, 184 "changing encoded_content should throw error" 185 ); 186 }; 187 188 subtest "binary string" => sub { 189 my ($obj, $line); 190 new_file(\$obj, $class, code_return_type => 'bytes', code => sub { $encoded_sample }); $line = __LINE__; 191 test_content_from_bytes($obj, qr/bytes from coderef added by \S+ \(main line $line\)/); 192 }; 193 194 subtest "latin1 string" => sub { 195 my $obj; 196 new_file(\$obj, $class, ( 197 code_return_type => 'bytes', 198 code => sub { $latin1_dolmen }, 199 encoding => 'latin1', 200 ) 201 ); 202 test_latin1($obj); 203 }; 204 205}; 206 207done_testing; 208