Skip to content

Commit

Permalink
Migrate USAGE -> GENERATE-USAGE
Browse files Browse the repository at this point in the history 
GENERATE-USAGE is a part of Raku for a while now and not just
a Rakudo implementation detail.

This patch is a compromise for changing USAGE to conditionally
set the exit status in the same way that GENERATE-USAGE does.

This change causes older USAGE-oriented tests to fail, but rather
than adjust these tests to the new behavior it was deemed a
smoother transition to migrate them to GENERATE-USAGE, which as
stated has been around for quite some time now.

This patch does admittedly re-raise the question of how to
_properly_ account to for version-to-version (or even
release-to-release) shifts in behavior. But rather than revert
a useful and minimal adjustment to USAGE's exit status and blocking
its adoption on remediating this major issue, the approach taken
in this commit was adopted.
  • Loading branch information
@ab5tract
ab5tract committed Apr 29, 2024
1 parent 8fe5a2f commit 918f55a
Show file tree
Hide file tree
Showing 3 changed files with 38 additions and 30 deletions.
7 changes: 7 additions & 0 deletions 6.c/S06-other/main-refactored.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -188,6 +188,9 @@ for @named-anywhere-ok -> \args, @expected, %expected {

# --- Checking correct parsing, failed dispatch and old USAGE ------------------
for @basic-ok -> \args, @expected, %expected {
# Ignore exits (Rakudo pre-2024.05 always returns 0, after returns 0 or 2)
# assign to anonymous state var to avoid ''useless use in sink'
my &*EXIT = { $ = $_ };

my $main-called;
sub MAIN("NEVER MATCHES") { $main-called = True } # NOT called by RUN-MAIN
Expand All @@ -202,6 +205,10 @@ for @basic-ok -> \args, @expected, %expected {
}

for @named-anywhere-ok -> \args, @expected, %expected {
# Ignore exits (Rakudo pre-2024.05 always returns 0, after returns 0 or 2)
# assign to anonymous state var to avoid ''useless use in sink'
my &*EXIT = { $ = $_ };

my %*SUB-MAIN-OPTS = named-anywhere => 1;

my $main-called;
Expand Down
47 changes: 24 additions & 23 deletions S06-other/main-usage.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -6,26 +6,27 @@ plan 48;

# Basic functionality

is_run 'sub MAIN($x) { }; sub USAGE() { print "USAGE() called" }',
{out => 'USAGE() called'},
'a user-defined USAGE sub is called if MAIN dispatch fails';
# normally it is GENERATE-USAGE(&main, |c), but we don't care about the parameters at all
is_run 'sub MAIN($x) { }; sub GENERATE-USAGE(|) { "GENERATE-USAGE() called" }',
{err => "GENERATE-USAGE() called\n", status => 2},
'a user-defined GENERATE-USAGE sub is called if MAIN dispatch fails';

is_run 'sub MAIN() { print "MAIN() called" }; sub USAGE() { print "USAGE() called" }',
is_run 'sub MAIN() { print "MAIN() called" }; sub GENERATE-USAGE(|) { "GENERATE-USAGE() called" }',
{out => 'MAIN() called', status => 0},
'a user-defined USAGE sub is not called if MAIN dispatch succeeds';
'a user-defined GENERATE-USAGE sub is not called if MAIN dispatch succeeds';

is_run 'sub MAIN( $a = nosuchsub()) { }; sub USAGE { say 42 }',
is_run 'sub MAIN( $a = nosuchsub()) { }; sub GENERATE-USAGE { say 42 }',
{ out => '', err => /nosuchsub/},
'if the MAIN dispatch results in an error, that error should be printed, not USAGE';
'if the MAIN dispatch results in an error, that error should be printed, not GENERATE-USAGE';

is_run 'sub MAIN($foo) { }', { err => /<< foo >>/, out => ''},
'auto-generated USAGE message goes to $*ERR and contains parameter name';
'auto-generated GENERATE-USAGE message goes to $*ERR and contains parameter name';

is_run 'sub MAIN(\bar) { }', {err => /<< bar >>/},
'auto-generated USAGE should handle sigilles parameters';
'auto-generated GENERATE-USAGE should handle sigilles parameters';

is_run 'sub MAIN($bar) { }', {out => /<< bar >>/}, :args['--help'],
'--help option sends auto-generated USAGE message to $*OUT';
'--help option sends auto-generated GENERATE-USAGE message to $*OUT';

is_run 'sub MAIN(Bool :$x) { say "yes" if $x }',
{out => "yes\n", err => '', status => 0}, :args['--x'], 'boolean option +';
Expand Down Expand Up @@ -94,37 +95,37 @@ subtest 'Valid arg with tab then space value' => {
}

subtest 'Extra arg with zero length value' => {
my $proc = run :out, :err, $*EXECUTABLE, '-e', 'sub MAIN() { }; sub USAGE() { "USG".note }', '-y=';
my $proc = run :out, :err, $*EXECUTABLE, '-e', 'sub MAIN() { }; sub GENERATE-USAGE(|) { "USG" }', '-y=';
ok $proc.err.slurp(:close).match(/USG/);
is $proc.out.slurp(:close), '';
}

subtest 'Extra arg with single space value' => {
my $proc = run :out, :err, $*EXECUTABLE, '-e', 'sub MAIN() { }; sub USAGE() { "USG".note }', '-y= ';
my $proc = run :out, :err, $*EXECUTABLE, '-e', 'sub MAIN() { }; sub GENERATE-USAGE(|) { "USG" }', '-y= ';
ok $proc.err.slurp(:close).match(/USG/);
is $proc.out.slurp(:close), '';
}

subtest 'Extra arg with two space value' => {
my $proc = run :out, :err, $*EXECUTABLE, '-e', 'sub MAIN() { }; sub USAGE() { "USG".note }', '-y= ';
my $proc = run :out, :err, $*EXECUTABLE, '-e', 'sub MAIN() { }; sub GENERATE-USAGE(|) { "USG" }', '-y= ';
ok $proc.err.slurp(:close).match(/USG/);
is $proc.out.slurp(:close), '';
}

subtest 'Extra arg with newline value' => {
my $proc = run :out, :err, $*EXECUTABLE, '-e', 'sub MAIN() { }; sub USAGE() { "USG".note }', "-y=\n";
my $proc = run :out, :err, $*EXECUTABLE, '-e', 'sub MAIN() { }; sub GENERATE-USAGE(|) { "USG" }', "-y=\n";
ok $proc.err.slurp(:close).match(/USG/);
is $proc.out.slurp(:close), '';
}

subtest 'Extra arg with tab value' => {
my $proc = run :out, :err, $*EXECUTABLE, '-e', 'sub MAIN() { }; sub USAGE() { "USG".note }', "-y=\t";
my $proc = run :out, :err, $*EXECUTABLE, '-e', 'sub MAIN() { }; sub GENERATE-USAGE(|) { "USG" }', "-y=\t";
ok $proc.err.slurp(:close).match(/USG/);
is $proc.out.slurp(:close), '';
}

subtest 'Extra arg with newline value' => {
my $proc = run :out, :err, $*EXECUTABLE, '-e', 'sub MAIN() { }; sub USAGE() { "USG".note }', "-y=\t ";
my $proc = run :out, :err, $*EXECUTABLE, '-e', 'sub MAIN() { }; sub GENERATE-USAGE(|) { "USG" }', "-y=\t ";
ok $proc.err.slurp(:close).match(/USG/);
is $proc.out.slurp(:close), '';
}
Expand Down Expand Up @@ -209,8 +210,8 @@ is_run 'sub MAIN (Str $value) { print "String $value" }',
'passing an integer matches MAIN(Str)';

# https://github.com/Raku/old-issue-tracker/issues/5262
is_run 'sub MAIN(*@arg where { False }) { }; sub USAGE { print "USAGE called" }',
{out => 'USAGE called', err => ''},
is_run 'sub MAIN(*@arg where { False }) { }; sub GENERATE-USAGE(|) { "GENERATE-USAGE called" }',
{out => '', err => "GENERATE-USAGE called\n"},
"failed constraint check doesn't leak internal exception out to the user";

# https://github.com/Raku/old-issue-tracker/issues/5155
Expand All @@ -224,9 +225,9 @@ subtest '$*USAGE tests' => {
# https://irclog.perlgeek.de/perl6-dev/2017-09-23#i_15206569
plan 4;

is_run ｢sub MAIN($meow, :$moo) {}; sub USAGE { $*USAGE.uc.say }｣,
{:out(/MEOW/ & /MOO/), :err(''), :0status },
'default $*USAGE is available inside `sub USAGE`';
is_run ｢sub MAIN($meow, :$moo) {}; sub GENERATE-USAGE(|) { $*USAGE.uc }｣,
{:out(''), :err(/MEOW/ & /MOO/), :2status },
'default $*USAGE is available inside `sub GENERATE-USAGE`';

is_run ｢sub MAIN($meow, :$moo) {$*USAGE.uc.say; $meow.say; $moo.say}｣,
:args<--moo=31337 42>,
Expand All @@ -239,8 +240,8 @@ subtest '$*USAGE tests' => {

is_run ｢
sub MAIN ($foo) {}
sub USAGE { try $*USAGE = "meow"; $! and "PASS".print }
｣, {:out<PASS>, :err(''), :0status },
sub GENERATE-USAGE(|) { try $*USAGE = "meow"; $! and "PASS" }
｣, {:out(''), :err("PASS\n"), :2status },
'trying to assign to $*USAGE inside sub MAIN throws';
}

Expand Down
14 changes: 7 additions & 7 deletions S06-other/main.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -56,29 +56,29 @@ subtest '%*SUB-MAIN-OPTS<named-anywhere>', {

is_run ｢
sub MAIN ($a, $b, :$c, :$d) { print "fail" }
sub USAGE { print "pass" }
｣, :args[<1 --c=2 3 --d=4>], {:out<pass>, :err('')},
sub GENERATE-USAGE(|) { "pass" }
｣, :args[<1 --c=2 3 --d=4>], {:out(''), :err("pass\n"), :2status},
'no opts set does not allow named args anywhere';

is_run ｢
(my %*SUB-MAIN-OPTS)<named-anywhere> = False;
sub MAIN ($a, $b, :$c, :$d) { print "fail" }
sub USAGE { print "pass" }
｣, :args[<1 --c=2 3 --d=4>], {:out<pass>, :err('')},
sub GENERATE-USAGE(|) { "pass" }
｣, :args[<1 --c=2 3 --d=4>], {:out(''), :err("pass\n"), :2status},
'<named-anywhere> set to false does not allow named args anywhere';

is_run ｢
(my %*SUB-MAIN-OPTS)<named-anywhere> = True;
sub MAIN ($a, $b, :$c, :$d) { print "pass" }
sub USAGE { print "fail" }
sub GENERATE-USAGE(|) { print "fail" }
｣, :args[<1 --c=2 3 --d=4>], {:out<pass>, :err(''), :0status},
'<named-anywhere> set to true allows named args anywhere';
}

# https://github.com/rakudo/rakudo/issues/3929
{
is_run 'sub MAIN($a is rw) { }; sub USAGE() { print "usage" }', :args[],
{ :out<usage>, :err{ .contains("'is rw'") }, :0status },
is_run 'sub MAIN($a is rw) { }; sub GENERATE-USAGE(|) { print "usage" }', :args[],
{ :out<usage>, :err{ .contains("'is rw'") }, :2status },
'Worry about "is rw" on parameters of MAIN';
}

Expand Down

0 comments on commit 918f55a

Please sign in to comment.