1#!/usr/bin/perl
2# Do not use warnings/strict, we want to avoid contamination of the
3
4# '-D' and '--dev-lib' MUST be handled well in advance of loading ANYTHING.
5# These will get re-processed later, but they MUST come even before App::Yath
6# is loaded.
7BEGIN {
8    local ($., $?, $@);
9    return if $^C;
10
11    package App::Yath::Script;
12
13    my $ORIG_TMP;
14    my $ORIG_TMP_PERMS;
15    my %ORIG_SIG = map { defined($SIG{$_}) ? ($_ => $SIG{$_}) : ()} keys %SIG;
16    my @ORIG_ARGV = @ARGV;
17    my @ORIG_INC = @INC;
18    my @DEVLIBS;
19    my %CONFIG;
20    my $NO_PLUGINS;
21
22    our $SCRIPT;
23
24    # ==START TESTABLE CODE FIND_CONFIG_FILES==
25
26    my ($config_file, $user_config_file);
27
28    # Would be nice if we could use File::Spec, but we cannot load ANYTHING yet.
29    my %no_stat = (mswin32 => 1, vms => 1, riscos => 1, os2 => 1, cygwin => 1);
30    my %seen;
31    my $dir = './';
32    for (1 .. 100) {    # If we are more than 100 deep we have other problems
33        if ($no_stat{lc($^O)}) {
34            opendir(my $dh, $dir) or die "$!";
35            my $key = join ':' => sort readdir($dh);
36            last if $seen{$key}++;
37        }
38        else {
39            my ($dev, $ino) = stat $dir;
40            last if $seen{$dev}{$ino}++;
41        }
42
43        $config_file      //= "${dir}.yath.rc"      if -f "${dir}.yath.rc";
44        $user_config_file //= "${dir}.yath.user.rc" if -f "${dir}.yath.user.rc";
45
46        last if $config_file && $user_config_file;
47
48        $dir .= "../";
49    }
50
51    # ==END TESTABLE CODE FIND_CONFIG_FILES==
52    # ==START TESTABLE CODE PARSE_CONFIG_FILES==
53
54    my (@CONFIG_ARGS, @TO_CLEAN);
55    for my $file ($config_file, $user_config_file) {
56        next unless $file && -f $file;
57
58        my $cmd;
59        open(my $fh, '<', $file) or die "Could not open config file '$file' for reading: $!";
60        while (my $line = <$fh>) {
61            chomp($line);
62            $cmd = $1 and next if $line =~ m/^\[(.*)\]$/;
63            $line =~ s/;.*$//g;
64            $line =~ s/^\s*//g;
65            $line =~ s/\s*$//g;
66            next unless length($line);
67
68            my ($key, $eq, $val);
69            if ($line =~ m/^(-\S)((?:rel|glob|relglob)\(.*\))$/) {   # Handle things like -Irel(...)
70                $key = $1;
71                $eq  = '';
72                $val = $2;
73            }
74            else {
75                ($key, $eq, $val) = split /(=|\s+)/, $line, 2;  # Covers most cases
76            }
77
78            my $is_pre;
79            if ($key =~ m/^-D/ || $key eq '--dev-lib') {
80                $eq = '=' if $val;
81                $is_pre = 1;
82            }
83
84            if ($key eq '--no-scan-plugins') {
85                $is_pre = 1;
86            }
87
88            my $need_to_clean;
89            if ($val && $val =~ s/(^|=)\s*rel\(\s*//) {
90                die "Syntax error in $file line $.: Expected ')'\n" unless $val =~ s/\s*\)$//;
91                my $path = $file;
92                $path =~ s{[^/]*$}{}g;
93                $val           = "${path}${val}";
94                $need_to_clean = 1;
95            }
96
97            my @all;
98
99            if ($val && $val =~ s/(^|=)\s*(rel)?glob\(\s*//) {
100                my $rel = $2;
101
102                die "Syntax error in $file line $.: Expected ')'\n" unless $val =~ s/\s*\)$//;
103
104                my $path = '';
105                if ($rel) {
106                    $path = $file;
107                    $path =~ s{[^/]*$}{}g;
108                }
109
110                # Avoid loading File::Glob in this process...
111                my $out = `$^X -e 'print join "\\n" => glob("${path}${val}")'`;
112                my @vals = split /\n/, $out;
113                @all = map {[$key, $eq, $_, 1]} @vals;
114            }
115            else {
116                @all = ([$key, $eq, $val, $need_to_clean]);
117            }
118
119            for my $set (@all) {
120                my ($key, $eq, $val, $need_to_clean) = @$set;
121                $eq //= '';
122
123                my @parts = $eq eq '=' ? ("${key}${eq}${val}") : (grep { defined $_ } $key, $val);
124
125                if ($is_pre) {
126                    push @CONFIG_ARGS => @parts;
127                }
128                else {
129                    $cmd //= '~';
130                    push @{$CONFIG{$cmd}} => @parts;
131                    push @TO_CLEAN => [$cmd, $#{$CONFIG{$cmd}}, $key, $eq, $val] if $need_to_clean;
132                }
133            }
134        }
135        close($fh);
136    }
137
138    unshift @ARGV => @CONFIG_ARGS;
139
140    # ==END TESTABLE CODE PARSE_CONFIG_FILES==
141    # ==START TESTABLE CODE PRE_PARSE_D_ARGS==
142
143    my (@libs, %done, @args, $maybe_exec);
144    while (@ARGV) {
145        my $arg = shift @ARGV;
146
147        if ($arg eq '--' || $arg eq '::') {
148            push @args => $arg;
149            last;
150        }
151
152        if ($arg eq '--no-dev-lib') {
153            @libs = ();
154            %done = ();
155            next;
156        }
157
158        if ($arg =~ m{^(?:(?:-D=?|--dev-lib=)(.*)|--dev-lib)$}) {
159            my @add = $1 ? ($1) : ();
160            unless (@add) {
161                @add        = ('lib', 'blib/lib', 'blib/arch');
162                $maybe_exec = $arg;
163            }
164
165            push @libs => grep { !$done{$_}++ } @add;
166            next;
167        }
168
169        if ($arg eq '--no-scan-plugins') {
170            $NO_PLUGINS = 1;
171            next;
172        }
173
174        push @args => $arg;
175    }
176    @ARGV = (@args, @ARGV);
177
178    unshift @INC => @libs;
179    unshift @DEVLIBS => @libs;
180
181    # ==END TESTABLE CODE PRE_PARSE_D_ARGS==
182    # ==START TESTABLE CODE EXEC==
183
184    # Now it is safe/ok to load things.
185    require Cwd;
186    require File::Spec;
187
188    $ORIG_TMP = File::Spec->tmpdir();
189    $ORIG_TMP_PERMS = ((stat($ORIG_TMP))[2] & 07777);
190    $SCRIPT = Cwd::realpath(__FILE__) // File::Spec->rel2abs(__FILE__);
191
192    if ($maybe_exec && -e 'scripts/yath') {
193        my $script = Cwd::realpath('scripts/yath') // File::Spec->rel2abs('scripts/yath');
194
195        if ($SCRIPT ne $script) {
196            warn "\n** $maybe_exec was used, and scripts/yath is present, using exec to switch to it. **\n\n";
197            exec($script, @ORIG_ARGV);
198            die("Should not see this, exec failed!");
199        }
200    }
201
202    # ==END TESTABLE CODE EXEC==
203    # ==START TESTABLE CODE CLEANUP_PATHS==
204
205    if (@libs || @TO_CLEAN) {
206        for (my $i = 0; $i < @libs; $i++) {
207            $DEVLIBS[$i] = $INC[$i] = Cwd::realpath($INC[$i]) // File::Spec->rel2abs($INC[$i]);
208        }
209
210        for my $clean (@TO_CLEAN) {
211            my ($cmd, $idx, $key, $eq, $val) = @$clean;
212            $val = Cwd::realpath($val) // File::Spec->rel2abs($val);
213
214            if ($eq eq '=') {
215                $CONFIG{$cmd}->[$idx] = "${key}${eq}${val}";
216            }
217            else {
218                $CONFIG{$cmd}->[$idx] = $val;
219            }
220        }
221    }
222
223    # ==END TESTABLE CODE CLEANUP_PATHS==
224    # ==START TESTABLE CODE CREATE_APP==
225
226    require App::Yath;
227    require Time::HiRes;
228    require Test2::Harness::Settings;
229
230    my %mixin = (config_file => '', user_config_file => '');
231    $mixin{config_file}      = Cwd::realpath($config_file)      // File::Spec->rel2abs($config_file)      if $config_file;
232    $mixin{user_config_file} = Cwd::realpath($user_config_file) // File::Spec->rel2abs($user_config_file) if $user_config_file;
233
234    my $settings = Test2::Harness::Settings->new(
235        harness => {
236            orig_tmp         => $ORIG_TMP,
237            orig_tmp_perms   => $ORIG_TMP_PERMS,
238            orig_sig         => \%ORIG_SIG,
239            orig_argv        => \@ORIG_ARGV,
240            orig_inc         => \@ORIG_INC,
241            script           => $SCRIPT,
242            no_scan_plugins  => $NO_PLUGINS,
243            dev_libs         => \@DEVLIBS,
244            start            => Time::HiRes::time(),
245            version          => $App::Yath::VERSION,
246            cwd              => Cwd::getcwd(),
247            %mixin,
248        },
249    );
250
251    my $app = App::Yath->new(
252        argv    => \@ARGV,
253        config  => \%CONFIG,
254        settings => $settings,
255    );
256
257    $app->generate_run_sub('App::Yath::Script::run');
258
259    # ==END TESTABLE CODE CREATE_APP==
260}
261
262exit(App::Yath::Script::run());
263
264__END__
265
266=pod
267
268=encoding UTF-8
269
270=head1 NAME
271
272yath - Primary Command Line Interface (CLI) for Test2::Harness
273
274=head1 DESCRIPTION
275
276This is the primary command line interface for App::Yath/Test2::Harness. Yath
277is essentially a shell around the components of L<Test2::Harness>.
278For usage instructions and examples,
279see L<App::Yath>.
280
281=head1 SOURCE
282
283The source code repository for Test2-Harness can be found at
284F<http://github.com/Test-More/Test2-Harness/>.
285
286=head1 MAINTAINERS
287
288=over 4
289
290=item Chad Granum E<lt>exodist@cpan.orgE<gt>
291
292=back
293
294=head1 AUTHORS
295
296=over 4
297
298=item Chad Granum E<lt>exodist@cpan.orgE<gt>
299
300=back
301
302=head1 COPYRIGHT
303
304Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>.
305
306This program is free software; you can redistribute it and/or
307modify it under the same terms as Perl itself.
308
309See F<http://dev.perl.org/licenses/>
310
311=cut
312