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