Change 34997 by [EMAIL PROTECTED] on 2008/12/03 21:39:10
Integrate:
[ 33993]
Make Perl_vms_start_glob() decline politely when passed an empty
argument.
[ 34052]
Subject: [EMAIL PROTECTED] Enable getgrgid on VMS
From: "John E. Malmberg" <[EMAIL PROTECTED]>
Date: Thu, 12 Jun 2008 19:50:01 -0500
Message-id: <[EMAIL PROTECTED]>
With some revisions.
[ 34562]
When testing the case sensitivity settings of the process
on VMS, be a little more sensitive to older versions that
don't have the capability.
[ 34666]
Subject: [EMAIL PROTECTED] vms.c setup_cmddsc
From: "John E. Malmberg" <[EMAIL PROTECTED]>
Message-id: <[EMAIL PROTECTED]>
Date: Wed, 29 Oct 2008 22:02:43 -0500
Remove trailing dot when efs_charset is in effect.
[ 34667]
Subject: Re: [EMAIL PROTECTED] VMS exec handling / cwd realpath fixes
From: "John E. Malmberg" <[EMAIL PROTECTED]>
Date: Wed, 29 Oct 2008 22:21:38 -0500
Message-id: <[EMAIL PROTECTED]>
Convert symlink target to UNIX format on VMS. (Cwd changes not
included here.)
[ 34668]
Try to demangle the mess created by 34667 (the "resubmittal" was
actually
not at all like the original patch I tested).
[ 34790]
Subject: [EMAIL PROTECTED] Get posix exit mode working/tested on VMS
From: "John E. Malmberg" <[EMAIL PROTECTED]>
Date: Sun, 09 Nov 2008 00:46:03 -0600
Message-id: <[EMAIL PROTECTED]>
[ 34901]
Subject: [EMAIL PROTECTED] vms readdir() fixes for UNIX/EFS mode
From: "John E. Malmberg" <[EMAIL PROTECTED]>
Date: Sat, 22 Nov 2008 11:31:58 -0600
Message-id: <[EMAIL PROTECTED]>
Affected files ...
... //depot/maint-5.10/perl/perl.h#18 integrate
... //depot/maint-5.10/perl/t/op/groups.t#3 integrate
... //depot/maint-5.10/perl/t/run/exit.t#3 integrate
... //depot/maint-5.10/perl/vms/vms.c#7 integrate
... //depot/maint-5.10/perl/vms/vmsish.h#2 integrate
Differences ...
==== //depot/maint-5.10/perl/perl.h#18 (text) ====
Index: perl/perl.h
--- perl/perl.h#17~34989~ 2008-12-03 02:48:40.000000000 -0800
+++ perl/perl.h 2008-12-03 13:39:10.000000000 -0800
@@ -2937,9 +2937,9 @@
PL_statusvalue_vms == SS$_NORMAL; \
else \
if (MY_POSIX_EXIT) \
- PL_statusvalue_vms = \
- (C_FAC_POSIX | (evalue << 3 ) | (evalue == 1)? \
- (STS$K_ERROR | STS$M_INHIB_MSG) : 1); \
+ PL_statusvalue_vms = \
+ (C_FAC_POSIX | (evalue << 3 ) | \
+ ((evalue == 1) ? (STS$K_ERROR | STS$M_INHIB_MSG) : 1)); \
else \
PL_statusvalue_vms = SS$_ABORT; \
} else { /* forgive them Perl, for they have sinned */ \
@@ -2965,6 +2965,9 @@
* actual exit code will can be retrieved by the calling program or
* shell.
*
+ * A POSIX exit code is from 0 to 255. If the exit code is higher
+ * than this, it needs to be assumed that it is a VMS exit code and
+ * passed through.
*/
# define STATUS_EXIT_SET(n) \
@@ -2972,9 +2975,10 @@
I32 evalue = (I32)n; \
PL_statusvalue = evalue; \
if (MY_POSIX_EXIT) \
- PL_statusvalue_vms = \
- (C_FAC_POSIX | (evalue << 3 ) | (evalue == 1)? \
- (STS$K_ERROR | STS$M_INHIB_MSG) : 1); \
+ if (evalue > 255) PL_statusvalue_vms = evalue; else { \
+ PL_statusvalue_vms = \
+ (C_FAC_POSIX | (evalue << 3 ) | \
+ ((evalue == 1) ? (STS$K_ERROR | STS$M_INHIB_MSG) : 1));} \
else \
PL_statusvalue_vms = evalue ? evalue : SS$_NORMAL; \
set_vaxc_errno(PL_statusvalue_vms); \
==== //depot/maint-5.10/perl/t/op/groups.t#3 (xtext) ====
Index: perl/t/op/groups.t
--- perl/t/op/groups.t#2~33823~ 2008-05-12 03:24:27.000000000 -0700
+++ perl/t/op/groups.t 2008-12-03 13:39:10.000000000 -0800
@@ -1,7 +1,7 @@
#!./perl
$ENV{PATH} ="/bin:/usr/bin:/usr/xpg4/bin:/usr/ucb" .
- exists $ENV{PATH} ? ":$ENV{PATH}" : "";
+ exists $ENV{PATH} ? ":$ENV{PATH}" : "" unless $^O eq 'VMS';
$ENV{LC_ALL} = "C"; # so that external utilities speak English
$ENV{LANGUAGE} = 'C'; # GNU locale extension
@@ -27,7 +27,8 @@
exit 0;
}
-quit() if (($^O eq 'MSWin32' || $^O eq 'NetWare') or $^O =~ /lynxos/i);
+quit() if (($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS')
+ or $^O =~ /lynxos/i);
# We have to find a command that prints all (effective
# and real) group names (not ids). The known commands are:
==== //depot/maint-5.10/perl/t/run/exit.t#3 (text) ====
Index: perl/t/run/exit.t
--- perl/t/run/exit.t#2~34065~ 2008-06-16 08:41:01.000000000 -0700
+++ perl/t/run/exit.t 2008-12-03 13:39:10.000000000 -0800
@@ -20,6 +20,24 @@
$numtests = ($^O eq 'VMS') ? 16 : ($^O eq 'MacOS') ? 0 : 17;
}
+
+my $vms_exit_mode = 0;
+
+if ($^O eq 'VMS') {
+ if (eval 'require VMS::Feature') {
+ $vms_exit_mode = !(VMS::Feature::current("posix_exit"));
+ } else {
+ my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} =~ /^[ET1]/i;
+ my $posix_ex = $ENV{'PERL_VMS_POSIX_EXIT'} =~ /^[ET1]/i;
+ if (($unix_rpt || $posix_ex) ) {
+ $vms_exit_mode = 0;
+ } else {
+ $vms_exit_mode = 1;
+ }
+ }
+ $numtests = 29 unless $vms_exit_mode;
+}
+
require "test.pl";
plan(tests => $numtests);
@@ -34,7 +52,7 @@
is( $exit, $?, 'Normal exit $?' );
is( ${^CHILD_ERROR_NATIVE}, $native_success, 'Normal exit
${^CHILD_ERROR_NATIVE}' );
-if ($^O ne 'VMS') {
+if (!$vms_exit_mode) {
my $posix_ok = eval { require POSIX; };
my $wait_macros_ok = defined &POSIX::WIFEXITED;
eval { POSIX::WIFEXITED() };
@@ -52,7 +70,11 @@
}
SKIP: {
- skip("Skip signals and core dump tests on Win32", 7) if $^O eq 'MSWin32';
+ skip("Skip signals and core dump tests on Win32 and VMS", 7)
+ if ($^O eq 'MSWin32' || $^O eq 'VMS');
+
+ #TODO VMS will backtrace on this test and exits with code of 0
+ #instead of 15.
$exit = run('kill 15, $$; sleep(1);');
@@ -69,7 +91,9 @@
}
}
-} else {
+}
+
+if ($^O eq 'VMS') {
# On VMS, successful returns from system() are reported 0, VMS errors that
# can not be translated to UNIX are reported as EVMSERR, which has a value
@@ -139,7 +163,7 @@
# status codes to SS$_ABORT on exit, but passes through unmodified UNIX
# status codes that exit() is called with by scripts.
-$exit_arg = (44 & 7) if $^O eq 'VMS';
+$exit_arg = (44 & 7) if $vms_exit_mode;
is( $exit >> 8, $exit_arg, 'Changing $? in END block' );
}
==== //depot/maint-5.10/perl/vms/vms.c#7 (text) ====
Index: perl/vms/vms.c
--- perl/vms/vms.c#6~34477~ 2008-10-14 00:11:27.000000000 -0700
+++ perl/vms/vms.c 2008-12-03 13:39:10.000000000 -0800
@@ -352,6 +352,7 @@
int vms_vtf7_filenames = 0;
int gnv_unix_shell = 0;
static int vms_unlink_all_versions = 0;
+static int vms_posix_exit = 0;
/* bug workarounds if needed */
int decc_bug_readdir_efs1 = 0;
@@ -9629,11 +9630,32 @@
&vs_spec,
&vs_len);
- /* Drop NULL extensions on UNIX file specification */
- if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
- (e_len == 1) && decc_readdir_dropdotnotype)) {
- e_len = 0;
- e_spec[0] = '\0';
+ if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
+
+ /* In Unix report mode, remove the ".dir;1" from the name */
+ /* if it is a real directory. */
+ if (decc_filename_unix_report || decc_efs_charset) {
+ if ((e_len == 4) && (vs_len == 2) && (vs_spec[1] == '1')) {
+ if ((toupper(e_spec[1]) == 'D') &&
+ (toupper(e_spec[2]) == 'I') &&
+ (toupper(e_spec[3]) == 'R')) {
+ Stat_t statbuf;
+ int ret_sts;
+
+ ret_sts = stat(buff, (stat_t *)&statbuf);
+ if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
+ e_len = 0;
+ e_spec[0] = 0;
+ }
+ }
+ }
+ }
+
+ /* Drop NULL extensions on UNIX file specification */
+ if ((e_len == 1) && decc_readdir_dropdotnotype) {
+ e_len = 0;
+ e_spec[0] = '\0';
+ }
}
strncpy(dd->entry.d_name, n_spec, n_len + e_len);
@@ -9892,6 +9914,19 @@
*cp2 = '\0';
if (do_tovmsspec(resspec,cp,0,NULL)) {
s = vmsspec;
+
+ /* When a UNIX spec with no file type is translated to VMS, */
+ /* A trailing '.' is appended under ODS-5 rules. */
+ /* Here we do not want that trailing "." as it prevents */
+ /* Looking for a implied ".exe" type. */
+ if (decc_efs_charset) {
+ int i;
+ i = strlen(vmsspec);
+ if (vmsspec[i-1] == '.') {
+ vmsspec[i-1] = '\0';
+ }
+ }
+
if (*rest) {
for (cp2 = vmsspec + strlen(vmsspec);
*rest && cp2 - vmsspec < sizeof vmsspec;
@@ -12758,6 +12793,11 @@
unsigned long int lff_flags = 0;
int rms_sts;
+ if (!SvOK(tmpglob)) {
+ SETERRNO(ENOENT,RMS$_FNF);
+ return NULL;
+ }
+
#ifdef VMS_LONGNAME_SUPPORT
lff_flags = LIB$M_FIL_LONG_NAMES;
#endif
@@ -12975,14 +13015,41 @@
/*
* A thin wrapper around decc$symlink to make sure we follow the
* standard and do not create a symlink with a zero-length name.
+ *
+ * Also in ODS-2 mode, existing tests assume that the link target
+ * will be converted to UNIX format.
*/
-/*{{{ int my_symlink(const char *path1, const char *path2)*/
-int my_symlink(const char *path1, const char *path2) {
- if (!path2 || !*path2) {
+/*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
+int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
+ if (!link_name || !*link_name) {
SETERRNO(ENOENT, SS$_NOSUCHFILE);
return -1;
}
- return symlink(path1, path2);
+
+ if (decc_efs_charset) {
+ return symlink(contents, link_name);
+ } else {
+ int sts;
+ char * utarget;
+
+ /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
+ /* because in order to work, the symlink target must be in UNIX format */
+
+ /* As symbolic links can hold things other than files, we will only do */
+ /* the conversion in in ODS-2 mode */
+
+ Newx(utarget, VMS_MAXRSS + 1, char);
+ if (do_tounixspec(contents, utarget, 0, NULL) == NULL) {
+
+ /* This should not fail, as an untranslatable filename */
+ /* should be passed through */
+ utarget = (char *)contents;
+ }
+ sts = symlink(utarget, link_name);
+ Safefree(utarget);
+ return sts;
+ }
+
}
/*}}}*/
@@ -13018,9 +13085,7 @@
VMSISH_HUSHED = 0;
- /* fix me later to track running under GNV */
- /* this allows some limited testing */
- MY_POSIX_EXIT = decc_filename_unix_report;
+ MY_POSIX_EXIT = vms_posix_exit;
x = (float)ix;
MY_INV_RAND_MAX = 1./x;
@@ -13182,8 +13247,101 @@
if (haslower) __mystrtolower(rslt);
}
}
- }
+ } else {
+
+ /* Now for some hacks to deal with backwards and forward */
+ /* compatibilty */
+ if (!decc_efs_charset) {
+
+ /* 1. ODS-2 mode wants to do a syntax only translation */
+ rslt = do_rmsexpand(filespec, outbuf,
+ 0, NULL, 0, NULL, utf8_fl);
+ } else {
+ if (decc_filename_unix_report) {
+ char * dir_name;
+ char * vms_dir_name;
+ char * file_name;
+
+ /* 2. ODS-5 / UNIX report mode should return a failure */
+ /* if the parent directory also does not exist */
+ /* Otherwise, get the real path for the parent */
+ /* and add the child to it.
+
+ /* basename / dirname only available for VMS 7.0+ */
+ /* So we may need to implement them as common routines */
+
+ Newx(dir_name, VMS_MAXRSS + 1, char);
+ Newx(vms_dir_name, VMS_MAXRSS + 1, char);
+ dir_name[0] = '\0';
+ file_name = NULL;
+
+ /* First try a VMS parse */
+ sts = vms_split_path
+ (filespec,
+ &v_spec,
+ &v_len,
+ &r_spec,
+ &r_len,
+ &d_spec,
+ &d_len,
+ &n_spec,
+ &n_len,
+ &e_spec,
+ &e_len,
+ &vs_spec,
+ &vs_len);
+
+ if (sts == 0) {
+ /* This is VMS */
+
+ int dir_len = v_len + r_len + d_len + n_len;
+ if (dir_len > 0) {
+ strncpy(dir_name, filespec, dir_len);
+ dir_name[dir_len] = '\0';
+ file_name = (char *)&filespec[dir_len + 1];
+ }
+ } else {
+ /* This must be UNIX */
+ char * tchar;
+
+ tchar = strrchr(filespec, '/');
+
+ if (tchar != NULL) {
+ int dir_len = tchar - filespec;
+ strncpy(dir_name, filespec, dir_len);
+ dir_name[dir_len] = '\0';
+ file_name = (char *) &filespec[dir_len + 1];
+ }
+ }
+
+ /* Dir name is defaulted */
+ if (dir_name[0] == 0) {
+ dir_name[0] = '.';
+ dir_name[1] = '\0';
+ }
+
+ /* Need realpath for the directory */
+ sts = vms_fid_to_name(vms_dir_name,
+ VMS_MAXRSS + 1,
+ dir_name);
+
+ if (sts == 0) {
+ /* Now need to pathify it.
+ char *tdir = do_pathify_dirspec(vms_dir_name,
+ outbuf, utf8_fl);
+
+ /* And now add the original filespec to it */
+ if (file_name != NULL) {
+ strcat(outbuf, file_name);
+ }
+ return outbuf;
+ }
+ Safefree(vms_dir_name);
+ Safefree(dir_name);
+ }
+ }
+ }
Safefree(vms_spec);
}
return rslt;
@@ -13401,7 +13559,6 @@
gnv_unix_shell = 0;
status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
if ($VMS_STATUS_SUCCESS(status)) {
- if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
gnv_unix_shell = 1;
set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
set_feature_default("DECC$EFS_CHARSET", 1);
@@ -13410,9 +13567,7 @@
set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
vms_unlink_all_versions = 1;
- }
- else
- gnv_unix_shell = 0;
+ vms_posix_exit = 1;
}
#endif
@@ -13483,8 +13638,10 @@
s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
if (s >= 0) {
decc_filename_unix_report = decc$feature_get_value(s, 1);
- if (decc_filename_unix_report > 0)
+ if (decc_filename_unix_report > 0) {
decc_filename_unix_report = 1;
+ vms_posix_exit = 1;
+ }
else
decc_filename_unix_report = 0;
}
@@ -13596,7 +13753,7 @@
}
#endif
-#if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
+#if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) &&
!defined(__VAX)
/* Report true case tolerance */
/*----------------------------*/
@@ -13612,6 +13769,17 @@
#endif
+ /* USE POSIX/DCL Exit codes - Recommended, but needs to default to */
+ /* for strict backward compatibilty */
+ status = sys_trnlnm
+ ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
+ if ($VMS_STATUS_SUCCESS(status)) {
+ if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
+ vms_posix_exit = 1;
+ else
+ vms_posix_exit = 0;
+ }
+
/* CRTL can be initialized past this point, but not before. */
/* DECC$CRTL_INIT(); */
==== //depot/maint-5.10/perl/vms/vmsish.h#2 (text) ====
Index: perl/vms/vmsish.h
--- perl/vms/vmsish.h#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/vms/vmsish.h 2008-12-03 13:39:10.000000000 -0800
@@ -276,7 +276,7 @@
#define my_endpwent() Perl_my_endpwent(aTHX)
#define my_getlogin Perl_my_getlogin
#ifdef HAS_SYMLINK
-# define my_symlink Perl_my_symlink
+# define my_symlink(a, b) Perl_my_symlink(aTHX_ a, b)
#endif
#define init_os_extras Perl_init_os_extras
#define vms_realpath(a, b, c) Perl_vms_realpath(aTHX_ a,b,c)
@@ -449,7 +449,11 @@
* getgrgid() routines are available to get group entries.
* The getgrent() has a separate definition, HAS_GETGRENT.
*/
+#if __CRTL_VER >= 70302000
+#define HAS_GROUP /**/
+#else
#undef HAS_GROUP /**/
+#endif
/* HAS_PASSWD
* This symbol, if defined, indicates that the getpwnam() and
@@ -968,7 +972,7 @@
int my_fclose (FILE *);
int my_fwrite (const void *, size_t, size_t, FILE *);
#ifdef HAS_SYMLINK
-int my_symlink(const char *path1, const char *path2);
+int Perl_my_symlink(pTHX_ const char *path1, const char *path2);
#endif
int Perl_my_flush (pTHX_ FILE *);
struct passwd * Perl_my_getpwnam (pTHX_ const char *name);
End of Patch.
