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