1package Dist::Zilla::Tester 6.024;
2# ABSTRACT: a testing-enabling stand-in for Dist::Zilla
3
4use Moose;
5extends 'Dist::Zilla::Dist::Builder';
6
7# BEGIN BOILERPLATE
8use v5.20.0;
9use warnings;
10use utf8;
11no feature 'switch';
12use experimental qw(postderef postderef_qq); # This experiment gets mainlined.
13# END BOILERPLATE
14
15use autodie;
16use Dist::Zilla::Chrome::Test;
17use File::pushd ();
18use File::Spec;
19use File::Temp;
20use Dist::Zilla::Path;
21
22use Sub::Exporter::Util ();
23use Sub::Exporter -setup => {
24  exports => [
25    Builder => sub { $_[0]->can('builder') },
26    Minter  => sub { $_[0]->can('minter')  },
27  ],
28
29  groups  => [ default => [ qw(Builder Minter) ] ],
30};
31
32use namespace::autoclean -except => 'import';
33
34sub from_config {
35  my ($self, @arg) = @_;
36
37  # The only thing using a local time zone should be NextRelease.  Normally it
38  # defaults to "local," but since some users won't have an automatically
39  # determinable time zone, we'll switch to not-local times for testing.
40  # -- rjbs, 2015-11-26
41  local $Dist::Zilla::Plugin::NextRelease::DEFAULT_TIME_ZONE = 'GMT';
42
43  return $self->builder->from_config(@arg);
44}
45
46sub builder { 'Dist::Zilla::Tester::_Builder' }
47
48sub minter { 'Dist::Zilla::Tester::_Minter' }
49
50{
51  package
52    Dist::Zilla::Tester::_Role;
53
54  use Moose::Role;
55
56  has tempdir_root => (
57    is => 'rw', isa => 'Str|Undef',
58    writer => '_set_tempdir_root',
59  );
60  has tempdir_obj => (
61    is => 'ro', isa => 'File::Temp::Dir',
62    clearer => '_clear_tempdir_obj',
63    writer => '_set_tempdir_obj',
64  );
65
66  sub DEMOLISH {}
67  around DEMOLISH => sub {
68    my $orig = shift;
69    my $self = shift;
70
71    # File::Temp deletes the directory when it goes out of scope
72    $self->_clear_tempdir_obj;
73
74    rmdir $self->tempdir_root if $self->tempdir_root;
75    return $self->$orig(@_);
76  };
77
78  has tempdir => (
79    is   => 'ro',
80    writer   => '_set_tempdir',
81    init_arg => undef,
82  );
83
84  sub clear_log_events {
85    my ($self) = @_;
86    $self->chrome->logger->clear_events;
87  }
88
89  sub log_events {
90    my ($self) = @_;
91    $self->chrome->logger->events;
92  }
93
94  sub log_messages {
95    my ($self) = @_;
96    [ map {; $_->{message} } @{ $self->chrome->logger->events } ];
97  }
98
99  sub slurp_file {
100    my ($self, $filename) = @_;
101
102    Dist::Zilla::Path::path(
103      $self->tempdir->child($filename)
104    )->slurp_utf8;
105  }
106
107  sub slurp_file_raw {
108    my ($self, $filename) = @_;
109
110    Dist::Zilla::Path::path(
111      $self->tempdir->child($filename)
112    )->slurp_raw;
113  }
114
115  sub _metadata_generator_id { 'Dist::Zilla::Tester' }
116
117  no Moose::Role;
118}
119
120{
121  package Dist::Zilla::Tester::_Builder 6.024;
122
123  use Moose;
124  extends 'Dist::Zilla::Dist::Builder';
125  with 'Dist::Zilla::Tester::_Role';
126
127  use File::Copy::Recursive 0.41 qw(dircopy);
128  use Dist::Zilla::Path;
129
130  our $Log_Events = [];
131  sub most_recent_log_events {
132    return @{ $Log_Events }
133  }
134
135  around from_config => sub {
136    my ($orig, $self, $arg, $tester_arg) = @_;
137
138    confess "dist_root required for from_config" unless $arg->{dist_root};
139
140    my $source = $arg->{dist_root};
141
142    my $tempdir_root = exists $tester_arg->{tempdir_root}
143                     ? $tester_arg->{tempdir_root}
144                     : 'tmp';
145
146    mkdir $tempdir_root if defined $tempdir_root and not -d $tempdir_root;
147
148    my $tempdir_obj = File::Temp->newdir(
149      CLEANUP => 1,
150      (defined $tempdir_root ? (DIR => $tempdir_root) : ()),
151    );
152
153    my $tempdir = path( path($tempdir_obj)->absolute) ;
154
155    my $root = $tempdir->child('source');
156    $root->mkpath;
157
158    dircopy($source, $root);
159
160    if ($tester_arg->{also_copy}) {
161      while (my ($src, $dest) = each %{ $tester_arg->{also_copy} }) {
162        dircopy($src, $tempdir->child($dest));
163      }
164    }
165
166    if (my $files = $tester_arg->{add_files}) {
167      while (my ($name, $content) = each %$files) {
168        die "Unix path '$name' does not seem to be portable to the current OS"
169          if !unix_path_seems_portable($name);
170        my $fn = $tempdir->child($name);
171        $fn->parent->mkpath;
172        Dist::Zilla::Path::path($fn)->spew_utf8($content);
173      }
174    }
175
176    local $arg->{dist_root} = "$root";
177    local $arg->{chrome} = Dist::Zilla::Chrome::Test->new;
178
179    $Log_Events = $arg->{chrome}->logger->events;
180
181    local @INC = @INC;
182
183    my $had_dot;
184    if ($INC[-1] eq '.') {
185      $had_dot = 1;
186      pop @INC;
187    }
188
189    @INC = map {; ref($_) ? $_ : File::Spec->rel2abs($_) } @INC;
190
191    push @INC, '.' if $had_dot;
192
193    # We do this so that . in @INC will find plugins like [=inc::YourFace]
194    # -- rjbs, 2016-04-24
195    my $wd = File::pushd::pushd($arg->{dist_root});
196
197
198    local $ENV{DZIL_GLOBAL_CONFIG_ROOT};
199    $ENV{DZIL_GLOBAL_CONFIG_ROOT} = $tester_arg->{global_config_root}
200      if defined $tester_arg->{global_config_root};
201
202    my $zilla = $self->$orig($arg);
203
204    $zilla->_set_tempdir_root($tempdir_root);
205    $zilla->_set_tempdir_obj($tempdir_obj);
206    $zilla->_set_tempdir($tempdir);
207
208    return $zilla;
209  };
210
211  around build_in => sub {
212    my ($orig, $self, $target) = @_;
213
214    # Sometimes, we can't get a local time zone.  When that happens, we're just
215    # going to pretend to be in UTC.  We don't do this during actual runtime
216    # because the user can fix their own environment, but we'll let them do
217    # that after they get the software installed. -- rjbs, 2020-01-26
218    my $ok = eval { DateTime::TimeZone->new(name => 'local'); 1 };
219    local $ENV{TZ} = $ok ? $ENV{TZ} : 'UTC';
220
221    # XXX: We *must eliminate* the need for this!  It's only here because right
222    # now building a dist with (root <> cwd) doesn't work. -- rjbs, 2010-03-08
223    my $wd = File::pushd::pushd($self->root);
224
225    $target ||= do {
226      my $target = path($self->tempdir)->child('build');
227      $target->mkpath;
228      $target;
229    };
230
231    return $self->$orig($target);
232  };
233
234  around ['test', 'release'] => sub {
235    my ($orig, $self) = @_;
236
237    # XXX: We *must eliminate* the need for this!  It's only here because right
238    # now building a dist with (root <> cwd) doesn't work. -- rjbs, 2010-03-08
239    my $wd = File::pushd::pushd($self->root);
240
241    return $self->$orig;
242  };
243
244  no Moose;
245
246  sub unix_path_seems_portable {
247    return 1 if $^O eq "linux"; # this check only makes sense on non-unixes
248
249    my ($unix_path) = @_;
250
251    # split the  $unix_path into 3 strings: $volume, $directories, $file; with:
252    my @native_parts = File::Spec->splitpath($unix_path); # current OS rules
253    my @unix_parts = File::Spec::Unix->splitpath($unix_path); # unix rules
254    return unless join(qq{\0}, @native_parts) eq join(qq{\0}, @unix_parts);
255
256    # split the $directories string into a list of the sub-directories; with:
257    my @native_dirs = File::Spec->splitdir($native_parts[1]); # current OS rules
258    my @unix_dirs = File::Spec::Unix->splitdir($unix_parts[1]); # unix rules
259    return unless join(qq{\0}, @native_dirs) eq join(qq{\0}, @unix_dirs);
260
261    return 1;
262  }
263}
264
265{
266  package Dist::Zilla::Tester::_Minter 6.024;
267
268  use Moose;
269  extends 'Dist::Zilla::Dist::Minter';
270  with 'Dist::Zilla::Tester::_Role';
271
272  use File::Copy::Recursive 0.41 qw(dircopy);
273  use Dist::Zilla::Path;
274
275  our $Log_Events = [];
276  sub most_recent_log_events {
277    return @{ $Log_Events }
278  }
279
280  sub _mint_target_dir {
281    my ($self) = @_;
282
283    my $name = $self->name;
284    my $dir  = $self->tempdir->child('mint')->absolute;
285
286    $self->log_fatal("$dir already exists") if -e $dir;
287
288    return $dir;
289  }
290
291  sub _setup_global_config {
292    my ($self, $dir, $arg) = @_;
293
294    my $config_base = path($dir)->child('config');
295
296    my $stash_registry = {};
297
298    require Dist::Zilla::MVP::Assembler::GlobalConfig;
299    require Dist::Zilla::MVP::Section;
300    my $assembler = Dist::Zilla::MVP::Assembler::GlobalConfig->new({
301      chrome => $arg->{chrome},
302      stash_registry => $stash_registry,
303      section_class  => 'Dist::Zilla::MVP::Section', # make this DZMA default
304    });
305
306    require Dist::Zilla::MVP::Reader::Finder;
307    my $reader = Dist::Zilla::MVP::Reader::Finder->new;
308
309    my $seq = $reader->read_config($config_base, { assembler => $assembler });
310
311    return $stash_registry;
312  }
313
314  around _new_from_profile => sub {
315    my ($orig, $self, $profile_data, $arg, $tester_arg) = @_;
316
317    # Sometimes, we can't get a local time zone.  When that happens, we're just
318    # going to pretend to be in UTC.  We don't do this during actual runtime
319    # because the user can fix their own environment, but we'll let them do
320    # that after they get the software installed. -- rjbs, 2020-01-26
321    my $ok = eval { DateTime::TimeZone->new(name => 'local'); 1 };
322    local $ENV{TZ} = $ok ? $ENV{TZ} : 'UTC';
323
324    my $tempdir_root = exists $tester_arg->{tempdir_root}
325                     ? $tester_arg->{tempdir_root}
326                     : 'tmp';
327
328    mkdir $tempdir_root if defined $tempdir_root and not -d $tempdir_root;
329
330    my $tempdir_obj = File::Temp->newdir(
331        CLEANUP => 1,
332        (defined $tempdir_root ? (DIR => $tempdir_root) : ()),
333    );
334    my $tempdir = path($tempdir_obj)->absolute;
335
336    local $arg->{chrome} = Dist::Zilla::Chrome::Test->new;
337    $Log_Events = $arg->{chrome}->logger->events;
338
339    local @INC = map {; ref($_) ? $_ : File::Spec->rel2abs($_) } @INC;
340
341    my $global_config_root = path($tester_arg->{global_config_root})->absolute;
342
343    local $ENV{DZIL_GLOBAL_CONFIG_ROOT} = $global_config_root;
344
345    my $global_stashes = $self->_setup_global_config(
346      $global_config_root,
347      { chrome => $arg->{chrome} },
348    );
349
350    local $arg->{_global_stashes} = $global_stashes;
351
352    my $zilla = $self->$orig($profile_data, $arg);
353
354    $zilla->_set_tempdir_root($tempdir_root);
355    $zilla->_set_tempdir_obj($tempdir_obj);
356    $zilla->_set_tempdir($tempdir);
357
358    return $zilla;
359  };
360}
361
362no Moose; # XXX: namespace::autoclean caused problems -- rjbs, 2011-08-19
363__PACKAGE__->meta->make_immutable;
3641;
365
366__END__
367
368=pod
369
370=encoding UTF-8
371
372=head1 NAME
373
374Dist::Zilla::Tester - a testing-enabling stand-in for Dist::Zilla
375
376=head1 VERSION
377
378version 6.024
379
380=head1 PERL VERSION
381
382This module should work on any version of perl still receiving updates from
383the Perl 5 Porters.  This means it should work on any version of perl released
384in the last two to three years.  (That is, if the most recently released
385version is v5.40, then this module should work on both v5.40 and v5.38.)
386
387Although it may work on older versions of perl, no guarantee is made that the
388minimum required version will not be increased.  The version may be increased
389for any reason, and there is no promise that patches will be accepted to lower
390the minimum required perl.
391
392=head1 AUTHOR
393
394Ricardo SIGNES �� <rjbs@semiotic.systems>
395
396=head1 COPYRIGHT AND LICENSE
397
398This software is copyright (c) 2021 by Ricardo SIGNES.
399
400This is free software; you can redistribute it and/or modify it under
401the same terms as the Perl 5 programming language system itself.
402
403=cut
404