In pp_ctl.c, on VMS, normally the path used for the %INC key is in UNIX
filename syntax, however if require is given a VMS format filename, it
stores it as the %INC key.
The load conditional code does a require using the VMS format, and since
it does not match the key in UNIX format, modules can be loaded twice.
This showed up by causing the extract tests to emit diagnostics about
routines being overridden.
This patch forces the %INC key to be in UNIX format so that the modules
will not be loaded twice.
In 01_Module_Load.t, on VMS, the $file for the module will now be
returned in UNIX format.
In 01_Module_Load_Conditional.t, some work arounds are needed for issues
with VMS handling of UNIX pathnames incorrectly.
Also, a hack needed for VMS is no longer needed because of the fix to
pp_ctl.c.
-John
[EMAIL PROTECTED]
Personal Opinion Only
--- /rsync_root/perl/pp_ctl.c Wed Jul 11 04:01:24 2007
+++ pp_ctl.c Sun Aug 19 21:34:26 2007
@@ -3066,6 +3066,9 @@
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 @@
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 @@
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 @@
/* 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;
--- /rsync_root/perl/lib/Module/Load/t/01_Module-Load.t Fri Aug 11 07:53:17 2006
+++ lib/Module/Load/t/01_Module-Load.t Mon Aug 20 08:03:30 2007
@@ -18,6 +18,9 @@
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'] );
--- /rsync_root/perl/lib/Module/Load/Conditional/t/01_Module_Load_Conditional.t
Fri Aug 17 05:56:59 2007
+++ lib/Module/Load/Conditional/t/01_Module_Load_Conditional.t Mon Aug 20
20:08:03 2007
@@ -54,8 +54,9 @@
@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 @@
{ 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 );
