1package Test2::Harness::TestFile; 2use strict; 3use warnings; 4 5our $VERSION = '1.000082'; 6 7use Carp qw/croak/; 8 9use Time::HiRes qw/time/; 10 11use List::Util 1.45 qw/uniq/; 12 13use Test2::Harness::Util qw/open_file clean_path/; 14 15use Test2::Harness::Util::UUID qw/gen_uuid/; 16 17use File::Spec; 18 19use Test2::Harness::Util::HashBase qw{ 20 <file +relative <_scanned <_headers +_shbang <is_binary <non_perl 21 input env_vars test_args 22 queue_args 23 job_class 24 comment 25 _category _stage _duration 26}; 27 28sub set_duration { $_[0]->set__duration(lc($_[1])) } 29sub set_category { $_[0]->set__category(lc($_[1])) } 30 31sub set_stage { $_[0]->set__stage($_[1]) } 32 33sub retry { $_[0]->headers->{retry} } 34sub set_retry { 35 my $self = shift; 36 my $val = @_ ? $_[0] : 1; 37 38 $self->scan; 39 40 $self->{+_HEADERS}->{retry} = $val; 41} 42 43sub retry_isolated { $_[0]->headers->{retry_isolated} } 44sub set_retry_isolated { 45 my $self = shift; 46 my $val = @_ ? $_[0] : 1; 47 48 $self->scan; 49 50 $self->{+_HEADERS}->{retry_isolated} = $val; 51} 52 53sub set_smoke { 54 my $self = shift; 55 my $val = @_ ? $_[0] : 1; 56 57 $self->scan; 58 59 $self->{+_HEADERS}->{features}->{smoke} = $val; 60} 61 62sub init { 63 my $self = shift; 64 65 my $file = $self->file; 66 67 # We want absolute path 68 $file = clean_path($file, 0); 69 $self->{+FILE} = $file; 70 71 $self->{+QUEUE_ARGS} ||= []; 72 73 croak "Invalid test file '$file'" unless -f $file; 74 75 if($self->{+IS_BINARY} = -B $file && !-z $file) { 76 $self->{+NON_PERL} = 1; 77 die "Cannot run binary test file '$file': file is not executable.\n" 78 unless $self->is_executable; 79 } 80} 81 82sub relative { 83 my $self = shift; 84 return $self->{+RELATIVE} //= File::Spec->abs2rel($self->{+FILE}); 85} 86 87my %DEFAULTS = ( 88 timeout => 1, 89 fork => 1, 90 preload => 1, 91 stream => 1, 92 run => 1, 93 isolation => 0, 94 smoke => 0, 95 io_events => 1, 96); 97 98sub check_feature { 99 my $self = shift; 100 my ($feature, $default) = @_; 101 102 $default = $DEFAULTS{$feature} unless defined $default; 103 104 return $default unless defined $self->headers->{features}->{$feature}; 105 return 1 if $self->headers->{features}->{$feature}; 106 return 0; 107} 108 109sub check_stage { 110 my $self = shift; 111 112 return $self->{+_STAGE} if $self->{+_STAGE}; 113 114 $self->_scan unless $self->{+_SCANNED}; 115 return $self->{+_HEADERS}->{stage} || undef; 116} 117 118sub meta { 119 my $self = shift; 120 my ($key) = @_; 121 122 $self->_scan unless $self->{+_SCANNED}; 123 my $meta = $self->{+_HEADERS}->{meta} or return (); 124 125 return () unless $key && $meta->{$key}; 126 127 return @{$meta->{$key}}; 128} 129 130sub check_duration { 131 my $self = shift; 132 133 return $self->{+_DURATION} if $self->{+_DURATION}; 134 135 $self->_scan unless $self->{+_SCANNED}; 136 my $duration = $self->{+_HEADERS}->{duration}; 137 return $duration if $duration; 138 139 my $timeout = $self->check_feature(timeout => 1); 140 141 # 'long' for anything with no timeout 142 return 'long' unless $timeout; 143 144 return 'medium'; 145} 146 147sub check_category { 148 my $self = shift; 149 150 return $self->{+_CATEGORY} if $self->{+_CATEGORY}; 151 152 $self->_scan unless $self->{+_SCANNED}; 153 my $category = $self->{+_HEADERS}->{category}; 154 155 return $category if $category; 156 157 my $isolate = $self->check_feature(isolation => 0); 158 159 # 'isolation' queue if isolation requested 160 return 'isolation' if $isolate; 161 162 return 'general'; 163} 164 165sub event_timeout { $_[0]->headers->{timeout}->{event} } 166sub post_exit_timeout { $_[0]->headers->{timeout}->{postexit} } 167 168sub conflicts_list { 169 return $_[0]->headers->{conflicts} || []; # Assure conflicts is always an array ref. 170} 171 172sub headers { 173 my $self = shift; 174 $self->_scan unless $self->{+_SCANNED}; 175 return {} unless $self->{+_HEADERS}; 176 return {%{$self->{+_HEADERS}}}; 177} 178 179sub shbang { 180 my $self = shift; 181 $self->_scan unless $self->{+_SCANNED}; 182 return {} unless $self->{+_SHBANG}; 183 return {%{$self->{+_SHBANG}}}; 184} 185 186sub switches { 187 my $self = shift; 188 189 my $shbang = $self->shbang or return []; 190 my $switches = $shbang->{switches} or return []; 191 192 return $switches; 193} 194 195sub is_executable { 196 my $self = shift; 197 my ($file) = @_; 198 $file //= $self->{+FILE}; 199 return -x $file; 200} 201 202sub scan { 203 my $self = shift; 204 $self->_scan(); 205 return; 206} 207 208sub _scan { 209 my $self = shift; 210 211 return if $self->{+_SCANNED}++; 212 return if $self->{+IS_BINARY}; 213 214 my $fh = open_file($self->{+FILE}); 215 my $comment = $self->{+COMMENT} // '#'; 216 217 my %headers; 218 for (my $ln = 1; my $line = <$fh>; $ln++) { 219 chomp($line); 220 next if $line =~ m/^\s*$/; 221 222 if ($ln == 1 && $line =~ m/^#!/) { 223 my $shbang = $self->_parse_shbang($line); 224 if ($shbang) { 225 $self->{+_SHBANG} = $shbang; 226 227 if ($shbang->{non_perl}) { 228 $self->{+NON_PERL} = 1; 229 230 die "Cannot run non-perl test file '" . $self->{+FILE} . "': file is not executable.\n" 231 unless $self->is_executable; 232 } 233 234 next; 235 } 236 } 237 238 # Uhg, breaking encapsulation between yath and the harness 239 if ($line =~ m/^\s*#\s*THIS IS A GENERATED YATH RUNNER TEST/) { 240 $headers{features}->{run} = 0; 241 next; 242 } 243 244 next if $line =~ m/^\s*#/ && $line !~ m/^\s*#\s*HARNESS-.+/; # Ignore commented lines which aren't HARNESS-? 245 next if $line =~ m/^\s*(use|require|BEGIN|package)\b/; # Only supports single line BEGINs 246 last unless $line =~ m/^\s*\Q$comment\E\s*HARNESS-(.+)$/; 247 248 my ($dir, $rest) = split /[-\s]+/, $1, 2; 249 $dir = lc($dir); 250 my @args; 251 if ($dir eq 'meta') { 252 @args = split /\s+/, $rest, 2; # Check for white space delimited 253 @args = split(/[-]+/, $rest, 2) if scalar @args == 1; # Check for dash delimited 254 $args[1] =~ s/\s+(?:#.*)?$//; # Strip trailing white space and comment if present 255 } 256 elsif ($rest) { 257 $rest =~ s/\s+(?:#.*)?$//; # Strip trailing white space and comment if present 258 @args = split /[-\s]+/, $rest; 259 } 260 261 if ($dir eq 'no') { 262 my $feature = lc(join '_' => @args); 263 if ($feature eq 'retry') { 264 $headers{retry} = 0 265 } else { 266 $headers{features}->{$feature} = 0; 267 } 268 } 269 elsif ($dir eq 'smoke') { 270 $headers{features}->{smoke} = 1; 271 } 272 elsif ($dir eq 'retry') { 273 $headers{retry} = 1 unless @args || defined $headers{retry}; 274 for my $arg (@args) { 275 if ($arg =~ m/^\d+$/) { 276 $headers{retry} = int $arg; 277 } 278 elsif ($arg =~ m/^iso/i) { 279 $headers{retry} //= 1; 280 $headers{retry_isolated} = 1; 281 } 282 else { 283 warn "Unknown 'HARNESS-RETRY' argument '$arg' at $self->{+FILE} line $ln.\n"; 284 } 285 } 286 } 287 elsif ($dir eq 'yes' || $dir eq 'use') { 288 my $feature = lc(join '_' => @args); 289 $headers{features}->{$feature} = 1; 290 } 291 elsif ($dir eq 'stage') { 292 my ($name) = @args; 293 $headers{stage} = $name; 294 } 295 elsif ($dir eq 'meta') { 296 my ($key, $val) = @args; 297 $key = lc($key); 298 push @{$headers{meta}->{$key}} => $val; 299 } 300 elsif ($dir eq 'duration' || $dir eq 'dur') { 301 my ($name) = @args; 302 $name = lc($name); 303 $headers{duration} = $name; 304 } 305 elsif ($dir eq 'category' || $dir eq 'cat') { 306 my ($name) = @args; 307 $name = lc($name); 308 if ($name =~ m/^(long|medium|short)$/i) { 309 $headers{duration} = $name; 310 } 311 else { 312 $headers{category} = $name; 313 } 314 } 315 elsif ($dir eq 'conflicts') { 316 my @conflicts_array; 317 318 foreach my $arg (@args) { 319 push @conflicts_array, lc($arg); 320 } 321 322 # Allow multiple lines with # HARNESS-CONFLICTS FOO 323 $headers{conflicts} ||= []; 324 push @{$headers{conflicts}}, @conflicts_array; 325 326 # Make sure no more than 1 conflict is ever present. 327 @{$headers{conflicts}} = uniq @{$headers{conflicts}}; 328 } 329 elsif ($dir eq 'timeout') { 330 my ($type, $num, $extra) = @args; 331 $type = lc($type); 332 $num = lc($num); 333 334 ($type, $num) = ('postexit', $extra) if $type eq 'post' && $num eq 'exit'; 335 336 warn "'" . uc($type) . "' is not a valid timeout type, use 'EVENT' or 'POSTEXIT' at $self->{+FILE} line $ln.\n" 337 unless $type =~ m/^(event|postexit)$/; 338 339 $headers{timeout}->{$type} = $num; 340 } 341 else { 342 warn "Unknown harness directive '$dir' at $self->{+FILE} line $ln.\n"; 343 } 344 } 345 346 $self->{+_HEADERS} = \%headers; 347} 348 349sub _parse_shbang { 350 my $self = shift; 351 my $line = shift; 352 353 return {} if !defined $line; 354 355 my %shbang; 356 357 # NOTE: Test this, the dashes should be included with the switches 358 my $shbang_re = qr{ 359 ^ 360 \#!.*perl.*? # the perl path 361 (?: \s (-.+) )? # the switches, maybe 362 \s* 363 $ 364 }xi; 365 366 if ($line =~ $shbang_re) { 367 my @switches = grep { m/\S/ } split /\s+/, $1 if defined $1; 368 $shbang{switches} = \@switches; 369 $shbang{line} = $line; 370 } 371 elsif ($line =~ m/^#!/ && $line !~ m/perl/i) { 372 $shbang{line} = $line; 373 $shbang{non_perl} = 1; 374 } 375 376 return \%shbang; 377} 378 379sub queue_item { 380 my $self = shift; 381 my ($job_name, $run_id, %inject) = @_; 382 383 die "The '$self->{+FILE}' test specifies that it should not be run by Test2::Harness.\n" 384 unless $self->check_feature(run => 1); 385 386 my $category = $self->check_category; 387 my $duration = $self->check_duration; 388 my $stage = $self->check_stage; 389 390 my $smoke = $self->check_feature(smoke => 0); 391 my $fork = $self->check_feature(fork => 1); 392 my $preload = $self->check_feature(preload => 1); 393 my $timeout = $self->check_feature(timeout => 1); 394 my $stream = $self->check_feature(stream => 1); 395 my $io_events = $self->check_feature(io_events => 1); 396 397 my $retry = $self->retry; 398 my $retry_isolated = $self->retry_isolated; 399 400 my $binary = $self->{+IS_BINARY} ? 1 : 0; 401 my $non_perl = $self->{+NON_PERL} ? 1 : 0; 402 403 my $et = $self->event_timeout; 404 my $pet = $self->post_exit_timeout; 405 406 my $job_class = $self->job_class; 407 408 my $input = $self->input; 409 my $test_args = $self->test_args; 410 411 my $env_vars = $self->env_vars; 412 if ($env_vars) { 413 my $mix = delete $inject{env_vars}; 414 $env_vars = {%$mix, %$env_vars} if $mix; 415 } 416 417 return { 418 binary => $binary, 419 category => $category, 420 conflicts => $self->conflicts_list, 421 duration => $duration, 422 file => $self->file, 423 rel_file => $self->relative, 424 job_id => gen_uuid(), 425 job_name => $job_name, 426 run_id => $run_id, 427 non_perl => $non_perl, 428 stage => $stage, 429 stamp => time, 430 switches => $self->switches, 431 use_fork => $fork, 432 use_preload => $preload, 433 use_stream => $stream, 434 use_timeout => $timeout, 435 smoke => $smoke, 436 io_events => $io_events, 437 rank => $self->rank, 438 439 defined($input) ? (input => $input) : (), 440 defined($env_vars) ? (env_vars => $env_vars) : (), 441 defined($test_args) ? (test_args => $test_args) : (), 442 defined($job_class) ? (job_class => $job_class) : (), 443 defined($retry) ? (retry => $retry) : (), 444 defined($retry_isolated) ? (retry_isolated => $retry_isolated) : (), 445 defined($et) ? (event_timeout => $et) : (), 446 defined($pet) ? (post_exit_timeout => $self->post_exit_timeout) : (), 447 448 @{$self->{+QUEUE_ARGS}}, 449 450 %inject, 451 }; 452} 453 454my %RANK = ( 455 smoke => 1, 456 immiscible => 10, 457 long => 20, 458 medium => 50, 459 short => 80, 460 isolation => 100, 461); 462 463sub rank { 464 my $self = shift; 465 466 return $RANK{smoke} if $self->check_feature('smoke'); 467 468 my $rank = $RANK{$self->check_category}; 469 $rank ||= $RANK{$self->check_duration}; 470 $rank ||= 1; 471 472 return $rank; 473} 474 4751; 476 477__END__ 478 479=pod 480 481=encoding UTF-8 482 483=head1 NAME 484 485Test2::Harness::TestFile - Abstraction of a test file and its meta-data. 486 487=head1 DESCRIPTION 488 489When Test2::Harness finds test files to run each one gets an instance of this 490class to represent it. This class will scan test files to find important meta 491data (binary vs script, inline harness directives, etc). The meta-data this 492class can find helps yath decide when and how to run the test. 493 494If you write a custom L<Test2::Harness::Finder> or use some 495L<Test2::Harness::Plugin> callbacks you may have to use, or even construct 496instances of this class. 497 498=head1 SYNOPSIS 499 500 use Test2::Harness::TestFile; 501 502 my $tf = Test2::Harness::TestFile->new(file => "path/to/file.t"); 503 504 # For an example 1, 1 works, but normally they are job_name and run_id. 505 my $meta_data = $tf->queue_item(1, 1); 506 507 508=head1 ATTRIBUTES 509 510=over 4 511 512=item $filename = $tf->file 513 514Set during object construction, and cannot be changed. 515 516=item $bool = $tf->is_binary 517 518Automatically set during construction, cannot be changed or set manually. 519 520=item $bool = $tf->non_perl 521 522Automatically set during construction, cannot be changed or set manually. 523 524=item $string = $tf->comment 525 526=item $tf->set_comment($string) 527 528Defaults to '#' can be set during construction, or changed if needed. 529 530This is used to tell yath what character(s) are used to denote a comment. This 531is necessary for finding harness directives. In perl the '#' character is used, 532and that is the default value. This is here to support non-perl tests. 533 534=item $class = $tf->job_class 535 536=item $tf->set_job_class($class) 537 538Default it undef (let the runner pick). You can change this if you want the 539test to run with a custom job subclass. 540 541=item $arrayref = $tf->queue_args 542 543=item $tf->set_queue_args(\@ARGS) 544 545Key/Value pairs to append to the queue_item() data. 546 547=back 548 549=head1 METHODS 550 551=over 4 552 553=item $cat = $tf->check_category() 554 555=item $tf->set_category($cat) 556 557This is how you find the category for a file. You can use C<set_category()> to 558assign/override a category. 559 560=item $dur = $tf->check_duration() 561 562=item $tf->set_duration($dur) 563 564Get the duration of the test file ('LONG', 'MEDIUM', 'SHORT'). You can override 565with C<set_duration()>. 566 567=item $stage = $tf->check_stage() 568 569=item $tf->set_stage($stage) 570 571Get the preload stage the test file thinks it should be run in. You can 572override with C<set_stage()>. 573 574=item $bool = $tf->check_feature($name) 575 576This checks for the C<# HARNESS-NO-NAME> or C<# HARNESS-USE-NAME> or 577C<# HARNESS-YES-NAME> directives. C<NO> will result in a false boolean. C<YES> 578and C<USE> will result in a ture boolean. If no directive is found then 579C<undef> will be returned. 580 581=item $arrayref = $tf->conflicts_list() 582 583Get a list of conflict markers. 584 585=item $seconds = $tf->event_timeout() 586 587If they test specifies an event timeout this will return it. 588 589=item %headers = $tf->headers() 590 591This returns the header data from the test file. 592 593=item $bool = $tf->is_executable() 594 595Check if the test file is executable or not. 596 597=item $data = $tf->meta($key) 598 599Get the meta-data for the specific key. 600 601=item $seconds = $tf->post_exit_timeout() 602 603If the test file has a custom post-exit timeout, this will return it. 604 605=item $hashref = $tf->queue_item($job_name, $run_id) 606 607This returns the data used to add the test file to the runner queue. 608 609=item $int = $tf->rank() 610 611Returns an integer value used to sort tests into an efficient run order. 612 613=item $path = $tf->relative() 614 615Relative path to the test file. 616 617=item $tf->scan() 618 619Scan the file and populate the header data. Return nothing, takes no arguments. 620Automatically run by things that require the scan data. Results are cached. 621 622=item $tf->set_smoke($bool) 623 624Set smoke status. Smoke tests go to the front of the line when tests are 625sorted. 626 627=item $hashref = $tf->shbang() 628 629Get data gathered from parsing the tests shbang line. 630 631=item $arrayref = $tf->switches() 632 633A list of switches passed to perl, usually from the shbang line. 634 635=back 636 637=head1 SOURCE 638 639The source code repository for Test2-Harness can be found at 640F<http://github.com/Test-More/Test2-Harness/>. 641 642=head1 MAINTAINERS 643 644=over 4 645 646=item Chad Granum E<lt>exodist@cpan.orgE<gt> 647 648=back 649 650=head1 AUTHORS 651 652=over 4 653 654=item Chad Granum E<lt>exodist@cpan.orgE<gt> 655 656=back 657 658=head1 COPYRIGHT 659 660Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. 661 662This program is free software; you can redistribute it and/or 663modify it under the same terms as Perl itself. 664 665See F<http://dev.perl.org/licenses/> 666 667=cut 668