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