1. # TODO:
  2. # * $?USAGE
  3. # * Create $?USAGE at compile time
  4. # * Make $?USAGE available globally
  5. # * Command-line parsing
  6. # * Allow both = and space before argument of double-dash args
  7. # * Comma-separated list values
  8. # * Allow exact Perl 6 forms, quoted away from shell
  9. # * Fix remaining XXXX
  10. my sub MAIN_HELPER($retval = 0) {
  11. # Do we have a MAIN at all?
  12. my $m = callframe(1).my<&MAIN>;
  13. return $retval unless $m;
  14. my $no-named-after = !$*MAIN-ALLOW-NAMED-ANYWHERE;
  15. sub thevalue(\a) {
  16. ((my $type := ::(a)) andthen Metamodel::EnumHOW.ACCEPTS($type.HOW))
  17. ?? $type
  18. !! val(a)
  19. }
  20. # Convert raw command line args into positional and named args for MAIN
  21. my sub process-cmd-args(@args is copy) {
  22. my $positional := nqp::create(IterationBuffer);
  23. my %named;
  24. while ?@args {
  25. my str $passed-value = @args.shift;
  26. # rest considered to be non-parsed
  27. if nqp::iseq_s($passed-value,'--') {
  28. nqp::push($positional, thevalue($_)) for @args;
  29. last;
  30. }
  31. # no longer accepting nameds
  32. elsif $no-named-after && nqp::isgt_i(nqp::elems($positional),0) {
  33. nqp::push($positional, thevalue($passed-value));
  34. }
  35. # named
  36. elsif $passed-value
  37. ~~ /^ [ '--' | '-' | ':' ] ('/'?) (<-[0..9\.]> .*) $/ { # 'hlfix
  38. my str $arg = $1.Str;
  39. my $split := nqp::split("=",$arg);
  40. # explicit value
  41. if nqp::isgt_i(nqp::elems($split),1) {
  42. my str $name = nqp::shift($split);
  43. %named.push: $name => $0.chars
  44. ?? thevalue(nqp::join("=",$split)) but False
  45. !! thevalue(nqp::join("=",$split));
  46. }
  47. # implicit value
  48. else {
  49. %named.push: $arg => !($0.chars);
  50. }
  51. }
  52. # positional
  53. else {
  54. nqp::push($positional, thevalue($passed-value));
  55. }
  56. }
  57. nqp::p6bindattrinvres(
  58. nqp::create(List),List,'$!reified',$positional
  59. ),%named;
  60. }
  61. # Generate $?USAGE string (default usage info for MAIN)
  62. my sub gen-usage() {
  63. my @help-msgs;
  64. my Pair @arg-help;
  65. my sub strip_path_prefix($name) {
  66. my $SPEC := $*SPEC;
  67. my ($vol, $dir, $base) = $SPEC.splitpath($name);
  68. $dir = $SPEC.canonpath($dir);
  69. for $SPEC.path() -> $elem {
  70. if $SPEC.catpath($vol, $elem, $base).IO.x {
  71. return $base if $SPEC.canonpath($elem) eq $dir;
  72. # Shadowed command found in earlier PATH element
  73. return $name;
  74. }
  75. }
  76. # Not in PATH
  77. $name;
  78. }
  79. my $prog-name = %*ENV<PERL6_PROGRAM_NAME>:exists
  80. ?? %*ENV<PERL6_PROGRAM_NAME>
  81. !! $*PROGRAM-NAME;
  82. $prog-name = $prog-name eq '-e'
  83. ?? "-e '...'"
  84. !! strip_path_prefix($prog-name);
  85. for $m.candidates -> $sub {
  86. next if $sub.?is-hidden-from-USAGE;
  87. my @required-named;
  88. my @optional-named;
  89. my @positional;
  90. my $docs;
  91. for $sub.signature.params -> $param {
  92. my $argument;
  93. if $param.named {
  94. if $param.slurpy {
  95. if $param.name { # ignore anon *%
  96. $argument = "--<$param.usage-name()>=...";
  97. @optional-named.push("[$argument]");
  98. }
  99. }
  100. else {
  101. my @names = $param.named_names.reverse;
  102. $argument = @names.map({($^n.chars == 1 ?? '-' !! '--') ~ $^n}).join('|');
  103. if $param.type !=== Bool {
  104. $argument ~= "=<{$param.type.^name}>";
  105. if Metamodel::EnumHOW.ACCEPTS($param.type.HOW) {
  106. my $options = $param.type.^enum_values.keys.sort.Str;
  107. $argument ~= $options.chars > 50
  108. ?? ' (' ~ substr($options,0,50) ~ '...'
  109. !! " ($options)"
  110. }
  111. }
  112. if $param.optional {
  113. @optional-named.push("[$argument]");
  114. }
  115. else {
  116. @required-named.push($argument);
  117. }
  118. }
  119. }
  120. else {
  121. my $constraints = $param.constraint_list.map(*.gist).join(' ');
  122. my $simple-const = $constraints && $constraints !~~ /^_block/;
  123. $argument = $param.name ?? "<$param.usage-name()>" !!
  124. $simple-const ?? $constraints !!
  125. '<' ~ $param.type.^name ~ '>' ;
  126. $argument = "[$argument ...]" if $param.slurpy;
  127. $argument = "[$argument]" if $param.optional;
  128. $argument .= trans(["'"] => [q|'"'"'|]) if $argument.contains("'");
  129. $argument = "'$argument'" if $argument.contains(' ' | '"');
  130. @positional.push($argument);
  131. }
  132. @arg-help.push($argument => $param.WHY.contents) if $param.WHY and (@arg-help.grep:{ .key eq $argument}) == Empty; # Use first defined
  133. }
  134. if $sub.WHY {
  135. $docs = '-- ' ~ $sub.WHY.contents
  136. }
  137. my $msg = join(' ', $prog-name, @required-named, @optional-named, @positional, $docs // '');
  138. @help-msgs.push($msg);
  139. }
  140. if @arg-help {
  141. @help-msgs.push('');
  142. my $offset = max(@arg-help.map: { .key.chars }) + 4;
  143. @help-msgs.append(@arg-help.map: { ' ' ~ .key ~ ' ' x ($offset - .key.chars) ~ .value });
  144. }
  145. my $usage = "Usage:\n" ~ @help-msgs.map(' ' ~ *).join("\n");
  146. $usage;
  147. }
  148. sub has-unexpected-named-arguments($signature, %named-arguments) {
  149. my @named-params = $signature.params.grep: *.named;
  150. return False if @named-params.grep: *.slurpy;
  151. my %accepts-argument = @named-params.map({ .named_names.Slip }) Z=> 1 xx *;
  152. for %named-arguments.keys -> $name {
  153. return True if !%accepts-argument{$name}
  154. }
  155. False;
  156. }
  157. # Process command line arguments
  158. my ($p, $n) := process-cmd-args(@*ARGS);
  159. # Generate default $?USAGE message
  160. my $usage;
  161. my $?USAGE := Proxy.new(
  162. FETCH => -> | { $usage || ($usage = gen-usage()) },
  163. STORE => -> | { }
  164. );
  165. # Get a list of candidates that match according to the dispatcher
  166. my @matching_candidates = $m.cando(Capture.new(list => $p, hash => $n));
  167. # Sort out all that would fail due to binding
  168. @matching_candidates .=grep: {!has-unexpected-named-arguments($_.signature, $n)};
  169. # If there are still some candidates left, try to dispatch to MAIN
  170. if +@matching_candidates {
  171. $m(|@($p), |%($n));
  172. return;
  173. }
  174. # We could not find the correct MAIN to dispatch to!
  175. # Let's try to run a user defined USAGE sub
  176. my $h = callframe(1).my<&USAGE>;
  177. if $h {
  178. $h();
  179. return;
  180. }
  181. # We could not find a user defined USAGE sub!
  182. # Let's display the default USAGE message
  183. if $n<help> {
  184. $*OUT.say($?USAGE);
  185. exit 1;
  186. }
  187. else {
  188. $*ERR.say($?USAGE);
  189. exit 2;
  190. }
  191. }
  192. Rakudo::Internals.REGISTER-DYNAMIC: '$*MAIN-ALLOW-NAMED-ANYWHERE', {
  193. PROCESS::<$MAIN-ALLOW-NAMED-ANYWHERE> := 0;
  194. }