This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
op.c: Remove assert exception for OP_REPEAT
[perl5.git] / vms / vms.c
diff --git a/vms/vms.c b/vms/vms.c
index 324cfa1..cfc9cb7 100644 (file)
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -1033,9 +1033,14 @@ Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
       }
     }
     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
-    else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
-             retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
+    else if (retsts == LIB$_NOSUCHSYM ||
              retsts == SS$_NOLOGNAM) {
+     /* Unsuccessful lookup is normal -- no need to set errno */
+     return 0;
+    }
+    else if (retsts == LIB$_INVSYMNAM ||
+             retsts == SS$_IVLOGNAM   ||
+             retsts == SS$_IVLOGTAB) {
       set_errno(EINVAL);  set_vaxc_errno(retsts);
     }
     else _ckvmssts_noperl(retsts);
@@ -1077,7 +1082,7 @@ Perl_my_getenv(pTHX_ const char *lnm, bool sys)
     static char *__my_getenv_eqv = NULL;
     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
     unsigned long int idx = 0;
-    int success, secure, saverr, savvmserr;
+    int success, secure;
     int midx, flags;
     SV *tmpsv;
 
@@ -1127,7 +1132,6 @@ Perl_my_getenv(pTHX_ const char *lnm, bool sys)
       if (sys) {
         /* Impose security constraints only if tainting */
         secure = PL_curinterp ? TAINTING_get : will_taint;
-        saverr = errno;  savvmserr = vaxc$errno;
       }
       else {
         secure = 0;
@@ -1159,10 +1163,6 @@ Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 
       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
 
-      /* Discard NOLOGNAM on internal calls since we're often looking
-       * for an optional name, and this "error" often shows up as the
-       * (bogus) exit status for a die() call later on.  */
-      if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
       return success ? eqv : NULL;
     }
 
@@ -1179,7 +1179,7 @@ Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
     unsigned long idx = 0;
     int midx, flags;
     static char *__my_getenv_len_eqv = NULL;
-    int secure, saverr, savvmserr;
+    int secure;
     SV *tmpsv;
     
     midx = my_maxidx(lnm) + 1;
@@ -1226,7 +1226,6 @@ Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
       if (sys) {
         /* Impose security constraints only if tainting */
         secure = PL_curinterp ? TAINTING_get : will_taint;
-        saverr = errno;  savvmserr = vaxc$errno;
       }
       else {
         secure = 0;
@@ -1264,10 +1263,6 @@ Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
        }
       }
 
-      /* Discard NOLOGNAM on internal calls since we're often looking
-       * for an optional name, and this "error" often shows up as the
-       * (bogus) exit status for a die() call later on.  */
-      if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
       return *len ? buf : NULL;
     }
 
@@ -7099,13 +7094,11 @@ static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
   PerlMem_free(tmp);
   for (; cp2 <= dirend; cp2++) {
     if ((*cp2 == '^')) {
-       /* EFS file escape, pass the next character as is */
-       /* Fix me: HEX encoding for Unicode not implemented */
-       *(cp1++) = *(++cp2);
-        /* An escaped dot stays as is -- don't convert to slash */
-        if (*cp2 == '.') cp2++;
+        /* EFS file escape -- unescape it. */
+        cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added) - 1;
+        cp1 += outchars_added;
     }
-    if (*cp2 == ':') {
+    else if (*cp2 == ':') {
       *(cp1++) = '/';
       if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
     }
@@ -8596,7 +8589,12 @@ static char *int_tovmsspec
          VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
        }
       }
-      else                  *(cp1++) =  *cp2;
+      else {
+        int out_cnt;
+        cp2 += copy_expand_unix_filename_escape(cp1, cp2, &out_cnt, utf8_flag);
+        cp2--; /* we're in a loop that will increment this */
+        cp1 += out_cnt;
+      }
       infront = 1;
     }
   }
@@ -8700,7 +8698,7 @@ static char *int_tovmsspec
     case '|':
     case '<':
     case '>':
-       if (cp2 > path && *(cp2-1) != '^') /* not previously escaped */
+       if (cp2 >= path && *(cp2-1) != '^') /* not previously escaped */
            *(cp1++) = '^';
        *(cp1++) = *(cp2++);
        break;
@@ -9355,46 +9353,6 @@ int rms_sts;
     _ckvmssts_noperl(lib$find_file_end(&context));
 }
 
-static int child_st[2];/* Event Flag set when child process completes  */
-
-static unsigned short child_chan;/* I/O Channel for Pipe Mailbox               */
-
-static unsigned long int exit_handler(void)
-{
-short iosb[4];
-
-    if (0 == child_st[0])
-       {
-#ifdef ARGPROC_DEBUG
-       PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
-#endif
-       fflush(stdout);     /* Have to flush pipe for binary data to    */
-                           /* terminate properly -- <tp@mccall.com>    */
-       sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
-       sys$dassgn(child_chan);
-       fclose(stdout);
-       sys$synch(0, child_st);
-       }
-    return(1);
-}
-
-static void sig_child(int chan)
-{
-#ifdef ARGPROC_DEBUG
-    PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
-#endif
-    if (child_st[0] == 0)
-       child_st[0] = 1;
-}
-
-static struct exit_control_block exit_block =
-    {
-    0,
-    exit_handler,
-    1,
-    &exit_block.exit_status,
-    0
-    };
 
 static void 
 pipe_and_fork(pTHX_ char **cmargv)
@@ -9682,7 +9640,7 @@ vms_image_init(int *argcp, char ***argvp)
     tabvec[tabidx]->dsc$w_length  = len;
     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_S;
-    tabvec[tabidx]->dsc$a_pointer = PerlMem_malloc(len + 1);
+    tabvec[tabidx]->dsc$a_pointer = (char *)PerlMem_malloc(len + 1);
     if (tabvec[tabidx]->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
     my_strlcpy(tabvec[tabidx]->dsc$a_pointer, eqv, len + 1);
   }
@@ -13930,7 +13888,7 @@ set_feature_default(const char *name, int value)
      */
     if (value > 0) {
         status = simple_trnlnm(name, val_str, sizeof(val_str));
-        if ($VMS_STATUS_SUCCESS(status)) {
+        if (status) {
             val_str[0] = _toupper(val_str[0]);
             if (val_str[0] == 'D' || val_str[0] == '0' || val_str[0] == 'F')
                return 0;
@@ -13983,7 +13941,7 @@ vmsperl_set_features(void)
     /* Allow an exception to bring Perl into the VMS debugger */
     vms_debug_on_exception = 0;
     status = simple_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
-    if ($VMS_STATUS_SUCCESS(status)) {
+    if (status) {
        val_str[0] = _toupper(val_str[0]);
        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
         vms_debug_on_exception = 1;
@@ -13994,7 +13952,7 @@ vmsperl_set_features(void)
     /* Debug unix/vms file translation routines */
     vms_debug_fileify = 0;
     status = simple_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
-    if ($VMS_STATUS_SUCCESS(status)) {
+    if (status) {
        val_str[0] = _toupper(val_str[0]);
         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
            vms_debug_fileify = 1;
@@ -14014,7 +13972,7 @@ vmsperl_set_features(void)
     /* enable it so that the impact can be studied.                     */
     vms_bug_stat_filename = 0;
     status = simple_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
-    if ($VMS_STATUS_SUCCESS(status)) {
+    if (status) {
        val_str[0] = _toupper(val_str[0]);
         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
            vms_bug_stat_filename = 1;
@@ -14026,7 +13984,7 @@ vmsperl_set_features(void)
     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
     vms_vtf7_filenames = 0;
     status = simple_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
-    if ($VMS_STATUS_SUCCESS(status)) {
+    if (status) {
        val_str[0] = _toupper(val_str[0]);
        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
         vms_vtf7_filenames = 1;
@@ -14036,9 +13994,8 @@ vmsperl_set_features(void)
 
     /* unlink all versions on unlink() or rename() */
     vms_unlink_all_versions = 0;
-    status = simple_trnlnm
-       ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
-    if ($VMS_STATUS_SUCCESS(status)) {
+    status = simple_trnlnm("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
+    if (status) {
        val_str[0] = _toupper(val_str[0]);
        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
         vms_unlink_all_versions = 1;
@@ -14050,7 +14007,7 @@ vmsperl_set_features(void)
     /* Detect running under GNV Bash or other UNIX like shell */
     gnv_unix_shell = 0;
     status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
-    if ($VMS_STATUS_SUCCESS(status)) {
+    if (status) {
         gnv_unix_shell = 1;
         set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
         set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
@@ -14058,6 +14015,9 @@ vmsperl_set_features(void)
         set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
         vms_unlink_all_versions = 1;
         vms_posix_exit = 1;
+        /* Reverse default ordering of PERL_ENV_TABLES. */
+        defenv[0] = &crtlenvdsc;
+        defenv[1] = &fildevdsc;
     }
     /* Some reasonable defaults that are not CRTL defaults */
     set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
@@ -14070,7 +14030,7 @@ vmsperl_set_features(void)
     /* PCP mode requires creating /dev/null special device file */
     decc_bug_devnull = 0;
     status = simple_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
-    if ($VMS_STATUS_SUCCESS(status)) {
+    if (status) {
        val_str[0] = _toupper(val_str[0]);
        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
           decc_bug_devnull = 1;
@@ -14151,7 +14111,7 @@ vmsperl_set_features(void)
 #else
     status = simple_trnlnm
        ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
-    if ($VMS_STATUS_SUCCESS(status)) {
+    if (status) {
        val_str[0] = _toupper(val_str[0]);
        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
           decc_disable_to_vms_logname_translation = 1;
@@ -14160,7 +14120,7 @@ vmsperl_set_features(void)
 
 #ifndef __VAX
     status = simple_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
-    if ($VMS_STATUS_SUCCESS(status)) {
+    if (status) {
        val_str[0] = _toupper(val_str[0]);
        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
           decc_efs_case_preserve = 1;
@@ -14169,14 +14129,14 @@ vmsperl_set_features(void)
 #endif
 
     status = simple_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
-    if ($VMS_STATUS_SUCCESS(status)) {
+    if (status) {
        val_str[0] = _toupper(val_str[0]);
        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
           decc_filename_unix_report = 1;
        }
     }
     status = simple_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
-    if ($VMS_STATUS_SUCCESS(status)) {
+    if (status) {
        val_str[0] = _toupper(val_str[0]);
        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
           decc_filename_unix_only = 1;
@@ -14184,14 +14144,14 @@ vmsperl_set_features(void)
        }
     }
     status = simple_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
-    if ($VMS_STATUS_SUCCESS(status)) {
+    if (status) {
        val_str[0] = _toupper(val_str[0]);
        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
           decc_filename_unix_no_version = 1;
        }
     }
     status = simple_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
-    if ($VMS_STATUS_SUCCESS(status)) {
+    if (status) {
        val_str[0] = _toupper(val_str[0]);
        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
           decc_readdir_dropdotnotype = 1;
@@ -14217,9 +14177,8 @@ vmsperl_set_features(void)
 
     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
     /* for strict backward compatibility */
-    status = simple_trnlnm
-       ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
-    if ($VMS_STATUS_SUCCESS(status)) {
+    status = simple_trnlnm("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
+    if (status) {
        val_str[0] = _toupper(val_str[0]);
        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
         vms_posix_exit = 1;
Unnamed repository; edit this file 'description' to name the repository.