Added short arguments parsing to MAIN

Signed-off-by: Moritz Lenz <moritz@faui2k3.org>
rakudo · Aug 13, 2010 · 0839993 · 0839993
1 parent 44f0ec0
commit 0839993
Showing 1 changed file with 44 additions and 15 deletions.
diff --git a/src/core/MAIN.pm b/src/core/MAIN.pm
@@ -13,12 +13,22 @@ our sub MAIN_HELPER($retval, $MAIN?) {
     unless $m {
         return $retval;
     }
-    
+
     # We found MAIN, let's process the command line arguments accordingly
-    my $process-cmd-args =  sub (@args is copy, %named) {
+    my sub process-cmd-args (@args is copy, %named-type , %alias) {
         my (@positional-arguments, %named-arguments , $negate);
         while ( @args )  {
             my $passed_value = @args.shift;
+            if substr($passed_value,0,1) eq '-' && $passed_value.substr(1,1) ne '-' {
+                my $short = $passed_value.substr(1,1);
+                my $long = %alias{ ~$short };
+                if $long {
+                    my $value=$passed_value.substr(2);
+                    $value = '=' ~ $value if $value.chars && $value.substr(0,1) ne '=';
+                    $passed_value = "--$long$value";
+                }
+            }
+
             if substr($passed_value,0,2) eq '--' {
                 my $arg = $passed_value.substr(2);
                 if $arg.match(/^\//) {
@@ -29,10 +39,10 @@ our sub MAIN_HELPER($retval, $MAIN?) {
                 if $arg eq '' {
                     @positional-arguments.push: @args;
                     last;
-                } elsif %named{$arg} ~~ Bool {
+                } elsif %named-type{$arg} ~~ Bool {
                     %named-arguments{$arg}=not $negate;
                     $negate='';
-                } elsif %named{$arg} ~~ Array || ($passed_value.match( /\=/ ) &&  %named{$arg.split('=', 2)[0]} ~~ Array ) {
+                } elsif %named-type{$arg} ~~ Array || ($passed_value.match( /\=/ ) &&  %named-type{$arg.split('=', 2)[0]} ~~ Array ) {
                     if $passed_value.match( /\=/ ) {
                         my ($name , $value) = $arg.split('=', 2);
                         if $negate {$negate=$name;}
@@ -67,21 +77,34 @@ our sub MAIN_HELPER($retval, $MAIN?) {
         }
 
         return @positional-arguments, {%named-arguments};
-    };
-
+    }
+
+    #Returns a hash with the short name as key and long name as value
+    my sub get-aliases ( $possible ) {
+        my %possible = |$possible;
+        for %possible -> $pair {
+            next if $pair.key.chars == 1;
+            if %possible.delete($pair.key).chars == 1 {
+                %possible.push($pair.invert)
+            }
+        }
+        return %possible;
+    }
+
     my @subs = $m ~~ Multi  ?? $m.candidates !! ($m);
     #TODO: We are calling the FIRST matching MAIN sub, we should be calling the BEST matching MAIN sub.
     for @subs -> $main {
         my @named-params = $main.signature.params.grep: {.named && .type ~~ Bool};
-        my %named-params = @named-params».name».substr(1) Z=> @named-params».type;
-        my @positional = $process-cmd-args(@*ARGS, %named-params);
-        my %named = @positional.pop;
-        if Capture.new(|@positional, |%named) ~~ $main.signature { 
+        my %named-params-type = @named-params>>.name>>.substr(1) Z=> @named-params>>.type;
+        my %alias = get-aliases($main.signature.params.grep({.named_names.elems == 2})>>.named_names);
+        my @positional  = process-cmd-args(@*ARGS, %named-params-type , %alias);
+        my  %named = @positional.pop;
+        if Capture.new(|@positional, |%named) ~~ $main.signature {
             $main(|@positional, |%named);
             return ;
         }
     }
-    
+
     #We could not find the correct main to dispatch to! Let's try to run the user defined USAGE sub
     my $h = Q:PIR {
         $P0 = getinterp
@@ -95,20 +118,25 @@ our sub MAIN_HELPER($retval, $MAIN?) {
     done_usage:
     };
     return $h() if $h ;
-    
+
     #We could not find a user defined USAGE sub! Let's display a default USAGE message
     my @help-msgs;
+    my @aliases;
     my @mains = $m ~~ Multi  ?? $m.candidates !! ($m);
     for @mains -> $sub {
         my $sig = $sub.signature;
         my @arguments , @help-msgs;
         for $sig.params -> $param {
             my $argument;
-            if ($param.named) {
+            if $param.named {
+                my $param-name = $param.name.substr(1); #Remove $
+                my %alias = ( $param.named_names.elems == 2  ?? get-aliases( $param.named_names ) !! () );
+                my $long-name = %alias{$param-name} // $param-name;
                 $argument = "--"
-                        ~ $param.name.substr(1)
-                        ~ ($param.type ~~ Bool ?? '' !! "=value-of-{$param.name.substr(1)}")
+                        ~ $long-name
+                        ~ ($param.type ~~ Bool ?? '' !! '=value-of-' ~ $long-name )
                         ;
+                push @aliases , "  -%alias.pairs[0].key() instead of --$long-name" if %alias ;
             } else {
                 $argument = ($param.name ?? $param.name.substr(1) !! ~$param.constraints  );
                 $argument = 'param' if $argument.match(/^_block\d+$/) ; #TODO: fixme
@@ -127,6 +155,7 @@ our sub MAIN_HELPER($retval, $MAIN?) {
         @help-msgs.push( $msg );
     }
     my $msg = ("Usage:\n" ~ @help-msgs.join("\nor\n") );
+    $msg ~= "\nYou can use\n" ~ @aliases.join("\n") if @aliases;
     if (@*ARGS ~~ ['--help']) {
         $*OUT.say($msg);
     } else {