Skip to content
Permalink
Browse files

Make handling of MAIN completely pluggable and documentable

But keep the old interface working as to not break any ecosystem modules
that rely on the old interface.

An ecosystem module now has 3 intercept vectors it can use:

- provide a sub RUN-MAIN
This allows *COMPLETE* control over the handling of MAIN.  It gets a Callable
that is the MAIN that should be executed (so no callframe gymnastics needed
anymore), the return value of the mainline execution (currently always Nil)
and additional named variables: :in-as-argsfiles which will be True if STDIN
should be treated as $*ARGFILES.

If RUN-MAIN is not provided, a default one will be run that looks for
subroutines of the old interface, such as MAIN_HELPER and USAGE.  If
found, will execute following the "old" semantics.

- provide a sub ARGS-TO-CAPTURE
This allows control on how the command line arguments are converted to a
capture.  If specified, it should receive a Callable (which is the MAIN
that will be executed), and an array of command line arguments.  It should
return a Capture object.  This should allow most GetOpt:: modules to severely
simplify their logic, as they usually are only interested in that part, not
in the actual dispatch part.

- provide a sub GENERATE-USAGE
If available, this sub will be called to generate any usage information for
the user.  It should accept a Callable as the first parameter (which is the
MAIN that couldn't get executed because the dispatch failed) and any other
parameters from the Capture that was generated from the command line
arguments.  It should return a string with the usage information  If no
GENERATE-USAGE sub could be found, it will check for the existence of a USAGE
sub (assuming the old interface) and call that if available: this is expected
to actually print the usage.  If neither is available, then the default usage
generation will be used and printed on STDOUT/STDERR as appropriate with the
correct exit() value.

The plan is to mark the old interface for DEPRECATED as soon as with hit 6.d,
to be removed with 6.e.  This should allow module developers to provide a
6.d version of their GetOpt::... modules that would only need to provide the
new interface.
  • Loading branch information...
lizmat committed Oct 11, 2018
1 parent 73b7c60 commit fbfccfa2ff30f6093176fa34da038442d8d427d5
Showing with 83 additions and 47 deletions.
  1. +17 −9 src/Perl6/Actions.nqp
  2. +66 −38 src/core/Main.pm6
@@ -1343,17 +1343,25 @@ class Perl6::Actions is HLL::Actions does STDActions {
$outer.name('<unit-outer>');

# If the unit defines &MAIN, and this is in the mainline,
# add a &MAIN_HELPER.
if !$*W.is_precompilation_mode && +(@*MODULES // []) == 0 && $unit.symbol('&MAIN') {
# add a call to &RUN-MAIN
if !$*W.is_precompilation_mode
&& !$*INSIDE-EVAL
&& +(@*MODULES // []) == 0
&& $unit.symbol('&MAIN') -> $main {
$mainline := QAST::Op.new(
:op('call'),
:name('&MAIN_HELPER'),
QAST::WVal.new( # $*IN as $*ARGSFILES
value => $*W.find_symbol: [
'Bool', $*W.lang-ver-before('d') ?? 'False' !! 'True'
]),
$mainline,
:op('call'),
:name('&RUN-MAIN'),
QAST::WVal.new(:value($main<value>)),
$mainline # run the mainline and get its result
);
unless $*W.lang-ver-before('d') {
$mainline.push(
QAST::WVal.new( # $*IN as $*ARGSFILES
value => $*W.find_symbol(['Bool','True'], :setting-only),
:named('in-as-argsfiles')
)
);
}
}

# If our caller wants to know the mainline ctx, provide it here.
@@ -5,16 +5,47 @@
# * Allow exact Perl 6 forms, quoted away from shell
# * Fix remaining XXXX

my sub MAIN_HELPER($IN-as-ARGSFILES, $retval = 0) {
# Do we have a MAIN at all?
my $main := callframe(1).my<&MAIN>;
return $retval unless $main;
my sub RUN-MAIN(&main, $mainline, :$in-as-argsfiles) {

my %SUB-MAIN-OPTS := %*SUB-MAIN-OPTS // {};
# Set up basic info
my %caller-my := callframe(1).my;
my $provided-a-to-c := %caller-my<&ARGS-TO-CAPTURE>;
my $provided-g-u := %caller-my<&GENERATE-USAGE>;

my &args-to-capture := $provided-a-to-c // &default-args-to-capture;
my %sub-main-opts := %*SUB-MAIN-OPTS // {};

# Set up proxy for old-style usage
my $usage-produced;
my $*USAGE := Proxy.new(
FETCH => -> | {
# DEPRECATED MESSAGE HERE
$usage-produced //= default-generate-usage(\())
},
STORE => -> | {
die 'Cannot assign to $*USAGE. Please use `sub USAGE {}` to '
~ 'output custom usage message'
}
);

# Module loaded that depends on the old MAIN_HELPER interface and
# does not provide the new interface?
if !$provided-a-to-c && %caller-my<&MAIN_HELPER> -> &main_helper {
# DEPRECATED message here

# Make MAIN available at callframe(1) when executing main_helper
# but return if there is nothing to call (old semantics)
return $mainline unless my &MAIN := %caller-my<&MAIN>;

# Call the MAIN_HELPER, it should do everything
return &main_helper.count == 2
?? main_helper($in-as-argsfiles,$mainline) # post 2018.06 interface
!! main_helper($mainline) # original interface
}

# Convert raw command line args into positional and named args for MAIN
my sub ARGS-TO-CAPTURE($, @args is copy --> Capture:D) {
my $no-named-after = nqp::isfalse(%SUB-MAIN-OPTS<named-anywhere>);
sub default-args-to-capture($, @args is copy --> Capture:D) {
my $no-named-after = nqp::isfalse(%sub-main-opts<named-anywhere>);

my $positional := nqp::create(IterationBuffer);
my %named;
@@ -68,8 +99,8 @@ my sub MAIN_HELPER($IN-as-ARGSFILES, $retval = 0) {
}

# Generate $?USAGE string (default usage info for MAIN)
my sub gen-usage($capture) {
my $no-named-after = nqp::isfalse(%SUB-MAIN-OPTS<named-anywhere>);
sub default-generate-usage($capture) {
my $no-named-after = nqp::isfalse(%sub-main-opts<named-anywhere>);

my @help-msgs;
my Pair @arg-help;
@@ -96,7 +127,7 @@ my sub MAIN_HELPER($IN-as-ARGSFILES, $retval = 0) {

# Select candidates for which to create USAGE string
sub usage-candidates($capture) {
my @candidates = $main.candidates;
my @candidates = &main.candidates;
my @positionals = $capture.list;

my @candos;
@@ -105,13 +136,15 @@ my sub MAIN_HELPER($IN-as-ARGSFILES, $retval = 0) {
# Find candidates on which all these positionals match
@candos = @candidates.grep: -> $sub {
my @params = $sub.signature.params;
(^@positionals).first( -> int $i {
!(@params[$i].constraints.ACCEPTS(@positionals[$i]))
} ).defined.not;
if @positionals <= @params {
(^@positionals).first( -> int $i {
!(@params[$i].constraints.ACCEPTS(@positionals[$i]))
} ).defined.not
}
}
@positionals.pop;
}
(@candos || $main.candidates)
(@candos || @candidates)
.grep: { nqp::not_i(nqp::can($_,'is-hidden-from-USAGE')) }
}

@@ -223,53 +256,48 @@ my sub MAIN_HELPER($IN-as-ARGSFILES, $retval = 0) {
}

# Process command line arguments
my $capture :=
(callframe(1).my<&ARGS-TO-CAPTURE> // &ARGS-TO-CAPTURE)($main, @*ARGS);

# Generate default $?USAGE message
my $usage;
my $*USAGE := Proxy.new(
FETCH => -> | { $usage ||= gen-usage($capture) },
STORE => -> | {
die 'Cannot assign to $*USAGE. Please use `sub USAGE {}` to '
~ 'output custom usage message'
}
);
my $capture := args-to-capture(&main, @*ARGS);

# Get a list of candidates that match according to the dispatcher
my @matching_candidates = $main.cando($capture);
my @matching_candidates = &main.cando($capture);

# Sort out all that would fail due to binding
@matching_candidates .=
grep: { !has-unexpected-named-arguments(.signature, $capture.hash) };

# If there are still some candidates left, try to dispatch to MAIN
if @matching_candidates {
if $IN-as-ARGSFILES {
if $in-as-argsfiles {
my $*ARGFILES := IO::ArgFiles.new: (my $in := $*IN),
:nl-in($in.nl-in), :chomp($in.chomp), :encoding($in.encoding),
:bin(nqp::hllbool(nqp::isfalse($in.encoding)));
$main(|$capture).sink;
main(|$capture).sink;
}
else {
$main(|$capture).sink;
main(|$capture).sink;
}
}

# We could not find the correct MAIN to dispatch to!
# Let's try to run a user defined USAGE sub
elsif callframe(1).my<&USAGE> -> $usage {
$usage();

# No new-style GENERATE-USAGE was provided, and no new style
# ARGS-TO-CAPTURE was provided either, so try to run a user defined
# USAGE sub of the old interface.
elsif !$provided-g-u && !$provided-a-to-c && %caller-my<&USAGE> -> &usage {
# DEPRECATED message here
usage;
}

# We could not find a user defined USAGE sub!
# Let's display the default USAGE message
# Display the default USAGE message on either STDOUT/STDERR
elsif $capture<help> {
$*OUT.say($*USAGE);
$*OUT.say: $provided-g-u
?? $provided-g-u(&main,|$capture)
!! default-generate-usage($capture);
exit 0;
}
else {
$*ERR.say($*USAGE);
$*ERR.say: $provided-g-u
?? $provided-g-u(&main,|$capture)
!! default-generate-usage($capture);
exit 2;
}
}

0 comments on commit fbfccfa

Please sign in to comment.
You can’t perform that action at this time.