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.