From: John E. Malmberg <wb8tyw@qsl.net>
Date: Mon, 20 Aug 2007 21:55:07 +0000 (-0500)
Subject: [patch@31735] Module-load/require fixes for VMS
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4492be7a152d0913edcc816c5354cda7f7039baf;p=p5sagit%2Fp5-mst-13.2.git

[patch@31735] Module-load/require fixes for VMS
From: "John E. Malmberg" <wb8tyw@qsl.net>
	Message-id: <46CA540B.4070001@qsl.net>

Avoid double module loads by populating %INC keys in unix format.

p4raw-id: //depot/perl@31746
---

diff --git a/lib/Module/Load/Conditional/t/01_Module_Load_Conditional.t b/lib/Module/Load/Conditional/t/01_Module_Load_Conditional.t
index 66a7fe1..678d40a 100644
--- a/lib/Module/Load/Conditional/t/01_Module_Load_Conditional.t
+++ b/lib/Module/Load/Conditional/t/01_Module_Load_Conditional.t
@@ -54,8 +54,9 @@ use_ok( 'Module::Load::Conditional' );
 	@rv_path = File::Spec::Unix->splitpath($rv->{file});
     } else {
 	@rv_path = File::Spec->splitpath($rv->{file});
+ 	@rv_path = ($rv_path[0],
+		    File::Spec->splitdir($rv_path[1]), $rv_path[2]);
     }
-    @rv_path = ($rv_path[0], File::Spec->splitdir($rv_path[1]), $rv_path[2]);
 
     # First element could be blank for some system types like VMS
     shift @rv_path if $rv_path[0] eq '';
@@ -169,7 +170,6 @@ SKIP:{
     {   package A::B::C::D; 
         $A::B::C::D::VERSION = $$; 
         $INC{'A/B/C/D.pm'}   = $$.$$;
-	$INC{'[.A.B.C]D.pm'} = $$.$$ if $^O eq 'VMS';
     }
     
     my $href = check_install( module => 'A::B::C::D', version => 0 );
diff --git a/lib/Module/Load/t/01_Module-Load.t b/lib/Module/Load/t/01_Module-Load.t
index f811447..74d2b05 100644
--- a/lib/Module/Load/t/01_Module-Load.t
+++ b/lib/Module/Load/t/01_Module-Load.t
@@ -18,6 +18,9 @@ use Test::More tests => 13;
     my $mod = 'Must::Be::Loaded';
     my $file = Module::Load::_to_file($mod,1);
 
+    # %INC on VMS has all keys in UNIX format
+    $file = VMS::Filespec::unixify($file) if $^O eq 'VMS';
+
     eval { load $mod };
 
     is( $@, '', qq[Loading module '$mod'] );
diff --git a/pp_ctl.c b/pp_ctl.c
index 9bbccd6..08965bf 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3066,6 +3066,9 @@ PP(pp_require)
     SV *sv;
     const char *name;
     STRLEN len;
+    char * unixname;
+    STRLEN unixlen;
+    int vms_unixname = 0;
     const char *tryname = NULL;
     SV *namesv = NULL;
     const I32 gimme = GIMME_V;
@@ -3115,8 +3118,31 @@ PP(pp_require)
     if (!(name && len > 0 && *name))
 	DIE(aTHX_ "Null filename used");
     TAINT_PROPER("require");
+
+
+#ifdef VMS
+    /* The key in the %ENV hash is in the syntax of file passed as the argument
+     * usually this is in UNIX format, but sometimes in VMS format, which
+     * can result in a module being pulled in more than once.
+     * To prevent this, the key must be stored in UNIX format if the VMS
+     * name can be translated to UNIX.
+     */
+    if ((unixname = tounixspec(name, NULL)) != NULL) {
+	unixlen = strlen(unixname);
+	vms_unixname = 1;
+    }
+    else
+#endif
+    {
+        /* if not VMS or VMS name can not be translated to UNIX, pass it
+	 * through.
+	 */
+	unixname = (char *) name;
+	unixlen = len;
+    }
     if (PL_op->op_type == OP_REQUIRE) {
-	SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
+	SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
+					  unixname, unixlen, 0);
 	if ( svp ) {
 	    if (*svp != &PL_sv_undef)
 		RETPUSHYES;
@@ -3146,8 +3172,7 @@ PP(pp_require)
 	AV * const ar = GvAVn(PL_incgv);
 	I32 i;
 #ifdef VMS
-	char *unixname;
-	if ((unixname = tounixspec(name, NULL)) != NULL)
+	if (vms_unixname)
 #endif
 	{
 	    namesv = newSV(0);
@@ -3372,11 +3397,13 @@ PP(pp_require)
     /* name is never assigned to again, so len is still strlen(name)  */
     /* Check whether a hook in @INC has already filled %INC */
     if (!hook_sv) {
-	(void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
+	(void)hv_store(GvHVn(PL_incgv),
+		       unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
     } else {
-	SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
+	SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
 	if (!svp)
-	    (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc_simple(hook_sv), 0 );
+	    (void)hv_store(GvHVn(PL_incgv),
+			   unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
     }
 
     ENTER;