for -M:Foo, extended and revised

From: "Robin Barker" <Robin.Barker@npl.co.uk>
Message-ID: <46A0F33545E63740BC7563DE59CA9C6D093A61@exchsvr2.npl.ad.local>

p4raw-id: //depot/perl@33407

2 files changed, 48 insertions, 7 deletions

diff --git a/perl.c b/perl.c
index a7f6ab5416..1abb48dbcf 100644
--- a/perl.c
+++ b/perl.c
@@ -3025,6 +3025,7 @@ Perl_moreswitches(pTHX_ const char *s)
 {
     dVAR;
     UV rschar;
+    const char option = *s; /* used to remember option in -m/-M code */
 
     PERL_ARGS_ASSERT_MORESWITCHES;
 
@@ -3224,6 +3225,7 @@ Perl_moreswitches(pTHX_ const char *s)
 	    const char *end;
 	    SV *sv;
 	    const char *use = "use ";
+	    bool colon = FALSE;
 	    /* -M-foo == 'no foo'	*/
 	    /* Leading space on " no " is deliberate, to make both
 	       possibilities the same length.  */
@@ -3231,19 +3233,30 @@ Perl_moreswitches(pTHX_ const char *s)
 	    sv = newSVpvn(use,4);
 	    start = s;
 	    /* We allow -M'Module qw(Foo Bar)'	*/
-	    while(isALNUM(*s) || *s==':') ++s;
+	    while(isALNUM(*s) || *s==':') {
+		if( *s++ == ':' ) {
+		    if( *s == ':' ) 
+			s++;
+		    else
+			colon = TRUE;
+		}
+	    }
+	    if (s == start)
+		Perl_croak(aTHX_ "Module name required with -%c option",
+				    option);
+	    if (colon) 
+		Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: "
+				    "contains single ':'",
+				    s - start, start, option);
 	    end = s + strlen(s);
 	    if (*s != '=') {
 		sv_catpvn(sv, start, end - start);
-		if (*(start-1) == 'm') {
+		if (option == 'm') {
 		    if (*s != '\0')
 			Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
 		    sv_catpvs( sv, " ()");
 		}
 	    } else {
-                if (s == start)
-                    Perl_croak(aTHX_ "Module name required with -%c option",
-			       s[-1]);
 		sv_catpvn(sv, start, s-start);
 		/* Use NUL as q''-delimiter.  */
 		sv_catpvs(sv, " split(/,/,q\0");
@@ -3255,7 +3268,7 @@ Perl_moreswitches(pTHX_ const char *s)
 	    Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
 	}
 	else
-	    Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
+	    Perl_croak(aTHX_ "Missing argument to -%c", option);
 	return s;
     case 'n':
 	PL_minus_n = TRUE;
diff --git a/t/run/switches.t b/t/run/switches.t
index 4af3141fd7..b3fd9347e6 100644
--- a/t/run/switches.t
+++ b/t/run/switches.t
@@ -11,7 +11,7 @@ BEGIN {
 
 BEGIN { require "./test.pl"; }
 
-plan(tests => 62);
+plan(tests => 68);
 
 use Config;
 
@@ -194,6 +194,34 @@ SWTESTPM
     );
     is( $r, '<swtest><foo><bar>', '-m with import parameters' );
     push @tmpfiles, $filename;
+
+    is( runperl( switches => [ '-MTie::Hash' ], stderr => 1, prog => 1 ),
+	  '', "-MFoo::Bar allowed" );
+
+    like( runperl( switches => [ '-M:swtest' ], stderr => 1,
+		   prog => 'die "oops"' ),
+	  qr/Invalid module name [\w:]+ with -M option\b/,
+          "-M:Foo not allowed" );
+
+    like( runperl( switches => [ '-mA:B:C' ], stderr => 1,
+		   prog => 'die "oops"' ),
+	  qr/Invalid module name [\w:]+ with -m option\b/,
+          "-mFoo:Bar not allowed" );
+
+    like( runperl( switches => [ '-m-A:B:C' ], stderr => 1,
+		   prog => 'die "oops"' ),
+	  qr/Invalid module name [\w:]+ with -m option\b/,
+          "-m-Foo:Bar not allowed" );
+
+    like( runperl( switches => [ '-m-' ], stderr => 1,
+		   prog => 'die "oops"' ),
+	  qr/Module name required with -m option\b/,
+  	  "-m- not allowed" );
+
+    like( runperl( switches => [ '-M-=' ], stderr => 1,
+		   prog => 'die "oops"' ),
+	  qr/Module name required with -M option\b/,
+  	  "-M- not allowed" );
 }
 
 # Tests for -V