vms/vms.c

   1 /* vms.c
   2  *
   3  * VMS-specific routines for perl5
   4  * Version: 5.7.0
   5  *
   6  * August 2005 Convert VMS status code to UNIX status codes
   7  * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
   8  *             and Perl_cando by Craig Berry
   9  * 29-Aug-2000 Charles Lane's piping improvements rolled in
  10  * 20-Aug-1999 revisions by Charles Bailey  bailey@newman.upenn.edu
  11  */
  12
  13 #include <acedef.h>
  14 #include <acldef.h>
  15 #include <armdef.h>
  16 #include <atrdef.h>
  17 #include <chpdef.h>
  18 #include <clidef.h>
  19 #include <climsgdef.h>
  20 #include <descrip.h>
  21 #include <devdef.h>
  22 #include <dvidef.h>
  23 #include <fibdef.h>
  24 #include <float.h>
  25 #include <fscndef.h>
  26 #include <iodef.h>
  27 #include <jpidef.h>
  28 #include <kgbdef.h>
  29 #include <libclidef.h>
  30 #include <libdef.h>
  31 #include <lib$routines.h>
  32 #include <lnmdef.h>
  33 #include <msgdef.h>
  34 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  35 #include <ppropdef.h>
  36 #endif
  37 #include <prvdef.h>
  38 #include <psldef.h>
  39 #include <rms.h>
  40 #include <shrdef.h>
  41 #include <ssdef.h>
  42 #include <starlet.h>
  43 #include <strdef.h>
  44 #include <str$routines.h>
  45 #include <syidef.h>
  46 #include <uaidef.h>
  47 #include <uicdef.h>
  48 #include <stsdef.h>
  49 #include <rmsdef.h>
  50 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
  51 #include <efndef.h>
  52 #define NO_EFN EFN$C_ENF
  53 #else
  54 #define NO_EFN 0;
  55 #endif
  56
  57 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  58 int   decc$feature_get_index(const char *name);
  59 char* decc$feature_get_name(int index);
  60 int   decc$feature_get_value(int index, int mode);
  61 int   decc$feature_set_value(int index, int mode, int value);
  62 #else
  63 #include <unixlib.h>
  64 #endif
  65
  66 #pragma member_alignment save
  67 #pragma nomember_alignment longword
  68 struct item_list_3 {
  69         unsigned short len;
  70         unsigned short code;
  71         void * bufadr;
  72         unsigned short * retadr;
  73 };
  74 #pragma member_alignment restore
  75
  76 /* More specific prototype than in starlet_c.h makes programming errors
  77    more visible.
  78  */
  79 #ifdef sys$getdviw
  80 #undef sys$getdviw
  81 #endif
  82 int sys$getdviw
  83        (unsigned long efn,
  84         unsigned short chan,
  85         const struct dsc$descriptor_s * devnam,
  86         const struct item_list_3 * itmlst,
  87         void * iosb,
  88         void * (astadr)(unsigned long),
  89         void * astprm,
  90         void * nullarg);
  91
  92 #if __CRTL_VER >= 70300000 && !defined(__VAX)
  93
  94 static int set_feature_default(const char *name, int value)
  95 {
  96     int status;
  97     int index;
  98
  99     index = decc$feature_get_index(name);
 100
 101     status = decc$feature_set_value(index, 1, value);
 102     if (index == -1 || (status == -1)) {
 103       return -1;
 104     }
 105
 106     status = decc$feature_get_value(index, 1);
 107     if (status != value) {
 108       return -1;
 109     }
 110
 111 return 0;
 112 }
 113 #endif
 114
 115 /* Older versions of ssdef.h don't have these */
 116 #ifndef SS$_INVFILFOROP
 117 #  define SS$_INVFILFOROP 3930
 118 #endif
 119 #ifndef SS$_NOSUCHOBJECT
 120 #  define SS$_NOSUCHOBJECT 2696
 121 #endif
 122
 123 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 124 #define PERLIO_NOT_STDIO 0
 125
 126 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 127  * code below needs to get to the underlying CRTL routines. */
 128 #define DONT_MASK_RTL_CALLS
 129 #include "EXTERN.h"
 130 #include "perl.h"
 131 #include "XSUB.h"
 132 /* Anticipating future expansion in lexical warnings . . . */
 133 #ifndef WARN_INTERNAL
 134 #  define WARN_INTERNAL WARN_MISC
 135 #endif
 136
 137 #ifdef VMS_LONGNAME_SUPPORT
 138 #include <libfildef.h>
 139 #endif
 140
 141 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 142 #  define RTL_USES_UTC 1
 143 #endif
 144
 145
 146 /* gcc's header files don't #define direct access macros
 147  * corresponding to VAXC's variant structs */
 148 #ifdef __GNUC__
 149 #  define uic$v_format uic$r_uic_form.uic$v_format
 150 #  define uic$v_group uic$r_uic_form.uic$v_group
 151 #  define uic$v_member uic$r_uic_form.uic$v_member
 152 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 153 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 154 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 155 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 156 #endif
 157
 158 #if defined(NEED_AN_H_ERRNO)
 159 dEXT int h_errno;
 160 #endif
 161
 162 #ifdef __DECC
 163 #pragma message disable pragma
 164 #pragma member_alignment save
 165 #pragma nomember_alignment longword
 166 #pragma message save
 167 #pragma message disable misalgndmem
 168 #endif
 169 struct itmlst_3 {
 170   unsigned short int buflen;
 171   unsigned short int itmcode;
 172   void *bufadr;
 173   unsigned short int *retlen;
 174 };
 175
 176 struct filescan_itmlst_2 {
 177     unsigned short length;
 178     unsigned short itmcode;
 179     char * component;
 180 };
 181
 182 struct vs_str_st {
 183     unsigned short length;
 184     char str[65536];
 185 };
 186
 187 #ifdef __DECC
 188 #pragma message restore
 189 #pragma member_alignment restore
 190 #endif
 191
 192 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 193 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 194 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 195 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 196 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 197 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 198 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 199 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 200 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 201 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 202 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 203
 204 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 205 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 206 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 207 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 208
 209 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 210 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 211
 212 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 213  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 214  * the Perl facility.
 215  */
 216 #define PERL_LNM_MAX_ITER 10
 217
 218   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 219 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 220 #define MAX_DCL_SYMBOL          (8192)
 221 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 222 #else
 223 #define MAX_DCL_SYMBOL          (1024)
 224 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 225 #endif
 226
 227 static char *__mystrtolower(char *str)
 228 {
 229   if (str) for (; *str; ++str) *str= tolower(*str);
 230   return str;
 231 }
 232
 233 static struct dsc$descriptor_s fildevdsc =
 234   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 235 static struct dsc$descriptor_s crtlenvdsc =
 236   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 237 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 238 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 239 static struct dsc$descriptor_s **env_tables = defenv;
 240 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 241
 242 /* True if we shouldn't treat barewords as logicals during directory */
 243 /* munching */
 244 static int no_translate_barewords;
 245
 246 #ifndef RTL_USES_UTC
 247 static int tz_updated = 1;
 248 #endif
 249
 250 /* DECC Features that may need to affect how Perl interprets
 251  * displays filename information
 252  */
 253 static int decc_disable_to_vms_logname_translation = 1;
 254 static int decc_disable_posix_root = 1;
 255 int decc_efs_case_preserve = 0;
 256 static int decc_efs_charset = 0;
 257 static int decc_filename_unix_no_version = 0;
 258 static int decc_filename_unix_only = 0;
 259 int decc_filename_unix_report = 0;
 260 int decc_posix_compliant_pathnames = 0;
 261 int decc_readdir_dropdotnotype = 0;
 262 static int vms_process_case_tolerant = 1;
 263 int vms_vtf7_filenames = 0;
 264 int gnv_unix_shell = 0;
 265
 266 /* bug workarounds if needed */
 267 int decc_bug_readdir_efs1 = 0;
 268 int decc_bug_devnull = 1;
 269 int decc_bug_fgetname = 0;
 270 int decc_dir_barename = 0;
 271
 272 static int vms_debug_on_exception = 0;
 273
 274 /* Is this a UNIX file specification?
 275  *   No longer a simple check with EFS file specs
 276  *   For now, not a full check, but need to
 277  *   handle POSIX ^UP^ specifications
 278  *   Fixing to handle ^/ cases would require
 279  *   changes to many other conversion routines.
 280  */
 281
 282 static int is_unix_filespec(const char *path)
 283 {
 284 int ret_val;
 285 const char * pch1;
 286
 287     ret_val = 0;
 288     if (strncmp(path,"\"^UP^",5) != 0) {
 289         pch1 = strchr(path, '/');
 290         if (pch1 != NULL)
 291             ret_val = 1;
 292         else {
 293
 294             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 295             if (decc_filename_unix_report || decc_filename_unix_only) {
 296             if (strcmp(path,".") == 0)
 297                 ret_val = 1;
 298             }
 299         }
 300     }
 301     return ret_val;
 302 }
 303
 304 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 305  */
 306
 307 static void ucs2_to_vtf7
 308    (char *outspec,
 309     unsigned long ucs2_char,
 310     int * output_cnt)
 311 {
 312 unsigned char * ucs_ptr;
 313 int hex;
 314
 315     ucs_ptr = (unsigned char *)&ucs2_char;
 316
 317     outspec[0] = '^';
 318     outspec[1] = 'U';
 319     hex = (ucs_ptr[1] >> 4) & 0xf;
 320     if (hex < 0xA)
 321         outspec[2] = hex + '0';
 322     else
 323         outspec[2] = (hex - 9) + 'A';
 324     hex = ucs_ptr[1] & 0xF;
 325     if (hex < 0xA)
 326         outspec[3] = hex + '0';
 327     else {
 328         outspec[3] = (hex - 9) + 'A';
 329     }
 330     hex = (ucs_ptr[0] >> 4) & 0xf;
 331     if (hex < 0xA)
 332         outspec[4] = hex + '0';
 333     else
 334         outspec[4] = (hex - 9) + 'A';
 335     hex = ucs_ptr[1] & 0xF;
 336     if (hex < 0xA)
 337         outspec[5] = hex + '0';
 338     else {
 339         outspec[5] = (hex - 9) + 'A';
 340     }
 341     *output_cnt = 6;
 342 }
 343
 344
 345 /* This handles the conversion of a UNIX extended character set to a ^
 346  * escaped VMS character.
 347  * in a UNIX file specification.
 348  *
 349  * The output count variable contains the number of characters added
 350  * to the output string.
 351  *
 352  * The return value is the number of characters read from the input string
 353  */
 354 static int copy_expand_unix_filename_escape
 355   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 356 {
 357 int count;
 358 int scnt;
 359 int utf8_flag;
 360
 361     utf8_flag = 0;
 362     if (utf8_fl)
 363       utf8_flag = *utf8_fl;
 364
 365     count = 0;
 366     *output_cnt = 0;
 367     if (*inspec >= 0x80) {
 368         if (utf8_fl && vms_vtf7_filenames) {
 369         unsigned long ucs_char;
 370
 371             ucs_char = 0;
 372
 373             if ((*inspec & 0xE0) == 0xC0) {
 374                 /* 2 byte Unicode */
 375                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 376                 if (ucs_char >= 0x80) {
 377                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 378                     return 2;
 379                 }
 380             } else if ((*inspec & 0xF0) == 0xE0) {
 381                 /* 3 byte Unicode */
 382                 ucs_char = ((inspec[0] & 0xF) << 12) +
 383                    ((inspec[1] & 0x3f) << 6) +
 384                    (inspec[2] & 0x3f);
 385                 if (ucs_char >= 0x800) {
 386                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 387                     return 3;
 388                 }
 389
 390 #if 0 /* I do not see longer sequences supported by OpenVMS */
 391       /* Maybe some one can fix this later */
 392             } else if ((*inspec & 0xF8) == 0xF0) {
 393                 /* 4 byte Unicode */
 394                 /* UCS-4 to UCS-2 */
 395             } else if ((*inspec & 0xFC) == 0xF8) {
 396                 /* 5 byte Unicode */
 397                 /* UCS-4 to UCS-2 */
 398             } else if ((*inspec & 0xFE) == 0xFC) {
 399                 /* 6 byte Unicode */
 400                 /* UCS-4 to UCS-2 */
 401 #endif
 402             }
 403         }
 404
 405         /* High bit set, but not a unicode character! */
 406
 407         /* Non printing DECMCS or ISO Latin-1 character? */
 408         if (*inspec <= 0x9F) {
 409         int hex;
 410             outspec[0] = '^';
 411             outspec++;
 412             hex = (*inspec >> 4) & 0xF;
 413             if (hex < 0xA)
 414                 outspec[1] = hex + '0';
 415             else {
 416                 outspec[1] = (hex - 9) + 'A';
 417             }
 418             hex = *inspec & 0xF;
 419             if (hex < 0xA)
 420                 outspec[2] = hex + '0';
 421             else {
 422                 outspec[2] = (hex - 9) + 'A';
 423             }
 424             *output_cnt = 3;
 425             return 1;
 426         } else if (*inspec == 0xA0) {
 427             outspec[0] = '^';
 428             outspec[1] = 'A';
 429             outspec[2] = '0';
 430             *output_cnt = 3;
 431             return 1;
 432         } else if (*inspec == 0xFF) {
 433             outspec[0] = '^';
 434             outspec[1] = 'F';
 435             outspec[2] = 'F';
 436             *output_cnt = 3;
 437             return 1;
 438         }
 439         *outspec = *inspec;
 440         *output_cnt = 1;
 441         return 1;
 442     }
 443
 444     /* Is this a macro that needs to be passed through?
 445      * Macros start with $( and an alpha character, followed
 446      * by a string of alpha numeric characters ending with a )
 447      * If this does not match, then encode it as ODS-5.
 448      */
 449     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 450     int tcnt;
 451
 452         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 453             tcnt = 3;
 454             outspec[0] = inspec[0];
 455             outspec[1] = inspec[1];
 456             outspec[2] = inspec[2];
 457
 458             while(isalnum(inspec[tcnt]) ||
 459                   (inspec[2] == '.') || (inspec[2] == '_')) {
 460                 outspec[tcnt] = inspec[tcnt];
 461                 tcnt++;
 462             }
 463             if (inspec[tcnt] == ')') {
 464                 outspec[tcnt] = inspec[tcnt];
 465                 tcnt++;
 466                 *output_cnt = tcnt;
 467                 return tcnt;
 468             }
 469         }
 470     }
 471
 472     switch (*inspec) {
 473     case 0x7f:
 474         outspec[0] = '^';
 475         outspec[1] = '7';
 476         outspec[2] = 'F';
 477         *output_cnt = 3;
 478         return 1;
 479         break;
 480     case '?':
 481         if (decc_efs_charset == 0)
 482           outspec[0] = '%';
 483         else
 484           outspec[0] = '?';
 485         *output_cnt = 1;
 486         return 1;
 487         break;
 488     case '.':
 489     case '~':
 490     case '!':
 491     case '#':
 492     case '&':
 493     case '\'':
 494     case '`':
 495     case '(':
 496     case ')':
 497     case '+':
 498     case '@':
 499     case '{':
 500     case '}':
 501     case ',':
 502     case ';':
 503     case '[':
 504     case ']':
 505     case '%':
 506     case '^':
 507     case '=':
 508         /* Assume that this is to be escaped */
 509         outspec[0] = '^';
 510         outspec[1] = *inspec;
 511         *output_cnt = 2;
 512         return 1;
 513         break;
 514     case ' ': /* space */
 515         /* Assume that this is to be escaped */
 516         outspec[0] = '^';
 517         outspec[1] = '_';
 518         *output_cnt = 2;
 519         return 1;
 520         break;
 521     default:
 522         *outspec = *inspec;
 523         *output_cnt = 1;
 524         return 1;
 525         break;
 526     }
 527 }
 528
 529
 530 /* This handles the expansion of a '^' prefix to the proper character
 531  * in a UNIX file specification.
 532  *
 533  * The output count variable contains the number of characters added
 534  * to the output string.
 535  *
 536  * The return value is the number of characters read from the input
 537  * string
 538  */
 539 static int copy_expand_vms_filename_escape
 540   (char *outspec, const char *inspec, int *output_cnt)
 541 {
 542 int count;
 543 int scnt;
 544
 545     count = 0;
 546     *output_cnt = 0;
 547     if (*inspec == '^') {
 548         inspec++;
 549         switch (*inspec) {
 550         case '.':
 551             /* Non trailing dots should just be passed through */
 552             *outspec = *inspec;
 553             count++;
 554             (*output_cnt)++;
 555             break;
 556         case '_': /* space */
 557             *outspec = ' ';
 558             inspec++;
 559             count++;
 560             (*output_cnt)++;
 561             break;
 562         case 'U': /* Unicode - FIX-ME this is wrong. */
 563             inspec++;
 564             count++;
 565             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 566             if (scnt == 4) {
 567                 unsigned int c1, c2;
 568                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 569                 outspec[0] == c1 & 0xff;
 570                 outspec[1] == c2 & 0xff;
 571                 if (scnt > 1) {
 572                     (*output_cnt) += 2;
 573                     count += 4;
 574                 }
 575             }
 576             else {
 577                 /* Error - do best we can to continue */
 578                 *outspec = 'U';
 579                 outspec++;
 580                 (*output_cnt++);
 581                 *outspec = *inspec;
 582                 count++;
 583                 (*output_cnt++);
 584             }
 585             break;
 586         default:
 587             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 588             if (scnt == 2) {
 589                 /* Hex encoded */
 590                 unsigned int c1;
 591                 scnt = sscanf(inspec, "%2x", &c1);
 592                 outspec[0] = c1 & 0xff;
 593                 if (scnt > 0) {
 594                     (*output_cnt++);
 595                     count += 2;
 596                 }
 597             }
 598             else {
 599                 *outspec = *inspec;
 600                 count++;
 601                 (*output_cnt++);
 602             }
 603         }
 604     }
 605     else {
 606         *outspec = *inspec;
 607         count++;
 608         (*output_cnt)++;
 609     }
 610     return count;
 611 }
 612
 613
 614 int SYS$FILESCAN
 615    (const struct dsc$descriptor_s * srcstr,
 616     struct filescan_itmlst_2 * valuelist,
 617     unsigned long * fldflags,
 618     struct dsc$descriptor_s *auxout,
 619     unsigned short * retlen);
 620
 621 /* vms_split_path - Verify that the input file specification is a
 622  * VMS format file specification, and provide pointers to the components of
 623  * it.  With EFS format filenames, this is virtually the only way to
 624  * parse a VMS path specification into components.
 625  *
 626  * If the sum of the components do not add up to the length of the
 627  * string, then the passed file specification is probably a UNIX style
 628  * path.
 629  */
 630 static int vms_split_path
 631    (const char * path,
 632     char * * volume,
 633     int * vol_len,
 634     char * * root,
 635     int * root_len,
 636     char * * dir,
 637     int * dir_len,
 638     char * * name,
 639     int * name_len,
 640     char * * ext,
 641     int * ext_len,
 642     char * * version,
 643     int * ver_len)
 644 {
 645 struct dsc$descriptor path_desc;
 646 int status;
 647 unsigned long flags;
 648 int ret_stat;
 649 struct filescan_itmlst_2 item_list[9];
 650 const int filespec = 0;
 651 const int nodespec = 1;
 652 const int devspec = 2;
 653 const int rootspec = 3;
 654 const int dirspec = 4;
 655 const int namespec = 5;
 656 const int typespec = 6;
 657 const int verspec = 7;
 658
 659     /* Assume the worst for an easy exit */
 660     ret_stat = -1;
 661     *volume = NULL;
 662     *vol_len = 0;
 663     *root = NULL;
 664     *root_len = 0;
 665     *dir = NULL;
 666     *dir_len;
 667     *name = NULL;
 668     *name_len = 0;
 669     *ext = NULL;
 670     *ext_len = 0;
 671     *version = NULL;
 672     *ver_len = 0;
 673
 674     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 675     path_desc.dsc$w_length = strlen(path);
 676     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 677     path_desc.dsc$b_class = DSC$K_CLASS_S;
 678
 679     /* Get the total length, if it is shorter than the string passed
 680      * then this was probably not a VMS formatted file specification
 681      */
 682     item_list[filespec].itmcode = FSCN$_FILESPEC;
 683     item_list[filespec].length = 0;
 684     item_list[filespec].component = NULL;
 685
 686     /* If the node is present, then it gets considered as part of the
 687      * volume name to hopefully make things simple.
 688      */
 689     item_list[nodespec].itmcode = FSCN$_NODE;
 690     item_list[nodespec].length = 0;
 691     item_list[nodespec].component = NULL;
 692
 693     item_list[devspec].itmcode = FSCN$_DEVICE;
 694     item_list[devspec].length = 0;
 695     item_list[devspec].component = NULL;
 696
 697     /* root is a special case,  adding it to either the directory or
 698      * the device components will probalby complicate things for the
 699      * callers of this routine, so leave it separate.
 700      */
 701     item_list[rootspec].itmcode = FSCN$_ROOT;
 702     item_list[rootspec].length = 0;
 703     item_list[rootspec].component = NULL;
 704
 705     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 706     item_list[dirspec].length = 0;
 707     item_list[dirspec].component = NULL;
 708
 709     item_list[namespec].itmcode = FSCN$_NAME;
 710     item_list[namespec].length = 0;
 711     item_list[namespec].component = NULL;
 712
 713     item_list[typespec].itmcode = FSCN$_TYPE;
 714     item_list[typespec].length = 0;
 715     item_list[typespec].component = NULL;
 716
 717     item_list[verspec].itmcode = FSCN$_VERSION;
 718     item_list[verspec].length = 0;
 719     item_list[verspec].component = NULL;
 720
 721     item_list[8].itmcode = 0;
 722     item_list[8].length = 0;
 723     item_list[8].component = NULL;
 724
 725     status = SYS$FILESCAN
 726        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 727         &flags, NULL, NULL);
 728     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 729
 730     /* If we parsed it successfully these two lengths should be the same */
 731     if (path_desc.dsc$w_length != item_list[filespec].length)
 732         return ret_stat;
 733
 734     /* If we got here, then it is a VMS file specification */
 735     ret_stat = 0;
 736
 737     /* set the volume name */
 738     if (item_list[nodespec].length > 0) {
 739         *volume = item_list[nodespec].component;
 740         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 741     }
 742     else {
 743         *volume = item_list[devspec].component;
 744         *vol_len = item_list[devspec].length;
 745     }
 746
 747     *root = item_list[rootspec].component;
 748     *root_len = item_list[rootspec].length;
 749
 750     *dir = item_list[dirspec].component;
 751     *dir_len = item_list[dirspec].length;
 752
 753     /* Now fun with versions and EFS file specifications
 754      * The parser can not tell the difference when a "." is a version
 755      * delimiter or a part of the file specification.
 756      */
 757     if ((decc_efs_charset) &&
 758         (item_list[verspec].length > 0) &&
 759         (item_list[verspec].component[0] == '.')) {
 760         *name = item_list[namespec].component;
 761         *name_len = item_list[namespec].length + item_list[typespec].length;
 762         *ext = item_list[verspec].component;
 763         *ext_len = item_list[verspec].length;
 764         *version = NULL;
 765         *ver_len = 0;
 766     }
 767     else {
 768         *name = item_list[namespec].component;
 769         *name_len = item_list[namespec].length;
 770         *ext = item_list[typespec].component;
 771         *ext_len = item_list[typespec].length;
 772         *version = item_list[verspec].component;
 773         *ver_len = item_list[verspec].length;
 774     }
 775     return ret_stat;
 776 }
 777
 778
 779 /* my_maxidx
 780  * Routine to retrieve the maximum equivalence index for an input
 781  * logical name.  Some calls to this routine have no knowledge if
 782  * the variable is a logical or not.  So on error we return a max
 783  * index of zero.
 784  */
 785 /*{{{int my_maxidx(const char *lnm) */
 786 static int
 787 my_maxidx(const char *lnm)
 788 {
 789     int status;
 790     int midx;
 791     int attr = LNM$M_CASE_BLIND;
 792     struct dsc$descriptor lnmdsc;
 793     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 794                                 {0, 0, 0, 0}};
 795
 796     lnmdsc.dsc$w_length = strlen(lnm);
 797     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 798     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 799     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 800
 801     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 802     if ((status & 1) == 0)
 803        midx = 0;
 804
 805     return (midx);
 806 }
 807 /*}}}*/
 808
 809 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 810 int
 811 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 812   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 813 {
 814     const char *cp1;
 815     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 816     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 817     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 818     int midx;
 819     unsigned char acmode;
 820     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 821                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 822     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 823                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 824                                  {0, 0, 0, 0}};
 825     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 826 #if defined(PERL_IMPLICIT_CONTEXT)
 827     pTHX = NULL;
 828     if (PL_curinterp) {
 829       aTHX = PERL_GET_INTERP;
 830     } else {
 831       aTHX = NULL;
 832     }
 833 #endif
 834
 835     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 836       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 837     }
 838     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 839       *cp2 = _toupper(*cp1);
 840       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 841         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 842         return 0;
 843       }
 844     }
 845     lnmdsc.dsc$w_length = cp1 - lnm;
 846     lnmdsc.dsc$a_pointer = uplnm;
 847     uplnm[lnmdsc.dsc$w_length] = '\0';
 848     secure = flags & PERL__TRNENV_SECURE;
 849     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 850     if (!tabvec || !*tabvec) tabvec = env_tables;
 851
 852     for (curtab = 0; tabvec[curtab]; curtab++) {
 853       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 854         if (!ivenv && !secure) {
 855           char *eq, *end;
 856           int i;
 857           if (!environ) {
 858             ivenv = 1;
 859             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 860             continue;
 861           }
 862           retsts = SS$_NOLOGNAM;
 863           for (i = 0; environ[i]; i++) {
 864             if ((eq = strchr(environ[i],'=')) &&
 865                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 866                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 867               eq++;
 868               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 869               if (!eqvlen) continue;
 870               retsts = SS$_NORMAL;
 871               break;
 872             }
 873           }
 874           if (retsts != SS$_NOLOGNAM) break;
 875         }
 876       }
 877       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 878                !str$case_blind_compare(&tmpdsc,&clisym)) {
 879         if (!ivsym && !secure) {
 880           unsigned short int deflen = LNM$C_NAMLENGTH;
 881           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 882           /* dynamic dsc to accomodate possible long value */
 883           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 884           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 885           if (retsts & 1) {
 886             if (eqvlen > MAX_DCL_SYMBOL) {
 887               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 888               eqvlen = MAX_DCL_SYMBOL;
 889               /* Special hack--we might be called before the interpreter's */
 890               /* fully initialized, in which case either thr or PL_curcop */
 891               /* might be bogus. We have to check, since ckWARN needs them */
 892               /* both to be valid if running threaded */
 893                 if (ckWARN(WARN_MISC)) {
 894                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 895                 }
 896             }
 897             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 898           }
 899           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 900           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 901           if (retsts == LIB$_NOSUCHSYM) continue;
 902           break;
 903         }
 904       }
 905       else if (!ivlnm) {
 906         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 907           midx = my_maxidx(lnm);
 908           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 909             lnmlst[1].bufadr = cp2;
 910             eqvlen = 0;
 911             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 912             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 913             if (retsts == SS$_NOLOGNAM) break;
 914             /* PPFs have a prefix */
 915             if (
 916 #if INTSIZE == 4
 917                  *((int *)uplnm) == *((int *)"SYS$")                    &&
 918 #endif
 919                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 920                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 921                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 922                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 923                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 924               memmove(eqv,eqv+4,eqvlen-4);
 925               eqvlen -= 4;
 926             }
 927             cp2 += eqvlen;
 928             *cp2 = '\0';
 929           }
 930           if ((retsts == SS$_IVLOGNAM) ||
 931               (retsts == SS$_NOLOGNAM)) { continue; }
 932         }
 933         else {
 934           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 935           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 936           if (retsts == SS$_NOLOGNAM) continue;
 937           eqv[eqvlen] = '\0';
 938         }
 939         eqvlen = strlen(eqv);
 940         break;
 941       }
 942     }
 943     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 944     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 945              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 946              retsts == SS$_NOLOGNAM) {
 947       set_errno(EINVAL);  set_vaxc_errno(retsts);
 948     }
 949     else _ckvmssts(retsts);
 950     return 0;
 951 }  /* end of vmstrnenv */
 952 /*}}}*/
 953
 954 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
 955 /* Define as a function so we can access statics. */
 956 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
 957 {
 958   return vmstrnenv(lnm,eqv,idx,fildev,
 959 #ifdef SECURE_INTERNAL_GETENV
 960                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
 961 #else
 962                    0
 963 #endif
 964                                                                               );
 965 }
 966 /*}}}*/
 967
 968 /* my_getenv
 969  * Note: Uses Perl temp to store result so char * can be returned to
 970  * caller; this pointer will be invalidated at next Perl statement
 971  * transition.
 972  * We define this as a function rather than a macro in terms of my_getenv_len()
 973  * so that it'll work when PL_curinterp is undefined (and we therefore can't
 974  * allocate SVs).
 975  */
 976 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
 977 char *
 978 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 979 {
 980     const char *cp1;
 981     static char *__my_getenv_eqv = NULL;
 982     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
 983     unsigned long int idx = 0;
 984     int trnsuccess, success, secure, saverr, savvmserr;
 985     int midx, flags;
 986     SV *tmpsv;
 987
 988     midx = my_maxidx(lnm) + 1;
 989
 990     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 991       /* Set up a temporary buffer for the return value; Perl will
 992        * clean it up at the next statement transition */
 993       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 994       if (!tmpsv) return NULL;
 995       eqv = SvPVX(tmpsv);
 996     }
 997     else {
 998       /* Assume no interpreter ==> single thread */
 999       if (__my_getenv_eqv != NULL) {
1000         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1001       }
1002       else {
1003         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1004       }
1005       eqv = __my_getenv_eqv;
1006     }
1007
1008     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1009     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1010       int len;
1011       getcwd(eqv,LNM$C_NAMLENGTH);
1012
1013       len = strlen(eqv);
1014
1015       /* Get rid of "000000/ in rooted filespecs */
1016       if (len > 7) {
1017         char * zeros;
1018         zeros = strstr(eqv, "/000000/");
1019         if (zeros != NULL) {
1020           int mlen;
1021           mlen = len - (zeros - eqv) - 7;
1022           memmove(zeros, &zeros[7], mlen);
1023           len = len - 7;
1024           eqv[len] = '\0';
1025         }
1026       }
1027       return eqv;
1028     }
1029     else {
1030       /* Impose security constraints only if tainting */
1031       if (sys) {
1032         /* Impose security constraints only if tainting */
1033         secure = PL_curinterp ? PL_tainting : will_taint;
1034         saverr = errno;  savvmserr = vaxc$errno;
1035       }
1036       else {
1037         secure = 0;
1038       }
1039
1040       flags =
1041 #ifdef SECURE_INTERNAL_GETENV
1042               secure ? PERL__TRNENV_SECURE : 0
1043 #else
1044               0
1045 #endif
1046       ;
1047
1048       /* For the getenv interface we combine all the equivalence names
1049        * of a search list logical into one value to acquire a maximum
1050        * value length of 255*128 (assuming %ENV is using logicals).
1051        */
1052       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1053
1054       /* If the name contains a semicolon-delimited index, parse it
1055        * off and make sure we only retrieve the equivalence name for
1056        * that index.  */
1057       if ((cp2 = strchr(lnm,';')) != NULL) {
1058         strcpy(uplnm,lnm);
1059         uplnm[cp2-lnm] = '\0';
1060         idx = strtoul(cp2+1,NULL,0);
1061         lnm = uplnm;
1062         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1063       }
1064
1065       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1066
1067       /* Discard NOLOGNAM on internal calls since we're often looking
1068        * for an optional name, and this "error" often shows up as the
1069        * (bogus) exit status for a die() call later on.  */
1070       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1071       return success ? eqv : Nullch;
1072     }
1073
1074 }  /* end of my_getenv() */
1075 /*}}}*/
1076
1077
1078 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1079 char *
1080 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1081 {
1082     const char *cp1;
1083     char *buf, *cp2;
1084     unsigned long idx = 0;
1085     int midx, flags;
1086     static char *__my_getenv_len_eqv = NULL;
1087     int secure, saverr, savvmserr;
1088     SV *tmpsv;
1089
1090     midx = my_maxidx(lnm) + 1;
1091
1092     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1093       /* Set up a temporary buffer for the return value; Perl will
1094        * clean it up at the next statement transition */
1095       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1096       if (!tmpsv) return NULL;
1097       buf = SvPVX(tmpsv);
1098     }
1099     else {
1100       /* Assume no interpreter ==> single thread */
1101       if (__my_getenv_len_eqv != NULL) {
1102         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1103       }
1104       else {
1105         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1106       }
1107       buf = __my_getenv_len_eqv;
1108     }
1109
1110     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1111     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1112     char * zeros;
1113
1114       getcwd(buf,LNM$C_NAMLENGTH);
1115       *len = strlen(buf);
1116
1117       /* Get rid of "000000/ in rooted filespecs */
1118       if (*len > 7) {
1119       zeros = strstr(buf, "/000000/");
1120       if (zeros != NULL) {
1121         int mlen;
1122         mlen = *len - (zeros - buf) - 7;
1123         memmove(zeros, &zeros[7], mlen);
1124         *len = *len - 7;
1125         buf[*len] = '\0';
1126         }
1127       }
1128       return buf;
1129     }
1130     else {
1131       if (sys) {
1132         /* Impose security constraints only if tainting */
1133         secure = PL_curinterp ? PL_tainting : will_taint;
1134         saverr = errno;  savvmserr = vaxc$errno;
1135       }
1136       else {
1137         secure = 0;
1138       }
1139
1140       flags =
1141 #ifdef SECURE_INTERNAL_GETENV
1142               secure ? PERL__TRNENV_SECURE : 0
1143 #else
1144               0
1145 #endif
1146       ;
1147
1148       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1149
1150       if ((cp2 = strchr(lnm,';')) != NULL) {
1151         strcpy(buf,lnm);
1152         buf[cp2-lnm] = '\0';
1153         idx = strtoul(cp2+1,NULL,0);
1154         lnm = buf;
1155         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1156       }
1157
1158       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1159
1160       /* Get rid of "000000/ in rooted filespecs */
1161       if (*len > 7) {
1162       char * zeros;
1163         zeros = strstr(buf, "/000000/");
1164         if (zeros != NULL) {
1165           int mlen;
1166           mlen = *len - (zeros - buf) - 7;
1167           memmove(zeros, &zeros[7], mlen);
1168           *len = *len - 7;
1169           buf[*len] = '\0';
1170         }
1171       }
1172
1173       /* Discard NOLOGNAM on internal calls since we're often looking
1174        * for an optional name, and this "error" often shows up as the
1175        * (bogus) exit status for a die() call later on.  */
1176       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1177       return *len ? buf : Nullch;
1178     }
1179
1180 }  /* end of my_getenv_len() */
1181 /*}}}*/
1182
1183 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1184
1185 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1186
1187 /*{{{ void prime_env_iter() */
1188 void
1189 prime_env_iter(void)
1190 /* Fill the %ENV associative array with all logical names we can
1191  * find, in preparation for iterating over it.
1192  */
1193 {
1194   static int primed = 0;
1195   HV *seenhv = NULL, *envhv;
1196   SV *sv = NULL;
1197   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
1198   unsigned short int chan;
1199 #ifndef CLI$M_TRUSTED
1200 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1201 #endif
1202   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1203   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1204   long int i;
1205   bool have_sym = FALSE, have_lnm = FALSE;
1206   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1207   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1208   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1209   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1210   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1211 #if defined(PERL_IMPLICIT_CONTEXT)
1212   pTHX;
1213 #endif
1214 #if defined(USE_ITHREADS)
1215   static perl_mutex primenv_mutex;
1216   MUTEX_INIT(&primenv_mutex);
1217 #endif
1218
1219 #if defined(PERL_IMPLICIT_CONTEXT)
1220     /* We jump through these hoops because we can be called at */
1221     /* platform-specific initialization time, which is before anything is */
1222     /* set up--we can't even do a plain dTHX since that relies on the */
1223     /* interpreter structure to be initialized */
1224     if (PL_curinterp) {
1225       aTHX = PERL_GET_INTERP;
1226     } else {
1227       aTHX = NULL;
1228     }
1229 #endif
1230
1231   if (primed || !PL_envgv) return;
1232   MUTEX_LOCK(&primenv_mutex);
1233   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1234   envhv = GvHVn(PL_envgv);
1235   /* Perform a dummy fetch as an lval to insure that the hash table is
1236    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1237   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1238
1239   for (i = 0; env_tables[i]; i++) {
1240      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1241          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1242      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1243   }
1244   if (have_sym || have_lnm) {
1245     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1246     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1247     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1248     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1249   }
1250
1251   for (i--; i >= 0; i--) {
1252     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1253       char *start;
1254       int j;
1255       for (j = 0; environ[j]; j++) {
1256         if (!(start = strchr(environ[j],'='))) {
1257           if (ckWARN(WARN_INTERNAL))
1258             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1259         }
1260         else {
1261           start++;
1262           sv = newSVpv(start,0);
1263           SvTAINTED_on(sv);
1264           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1265         }
1266       }
1267       continue;
1268     }
1269     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1270              !str$case_blind_compare(&tmpdsc,&clisym)) {
1271       strcpy(cmd,"Show Symbol/Global *");
1272       cmddsc.dsc$w_length = 20;
1273       if (env_tables[i]->dsc$w_length == 12 &&
1274           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1275           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1276       flags = defflags | CLI$M_NOLOGNAM;
1277     }
1278     else {
1279       strcpy(cmd,"Show Logical *");
1280       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1281         strcat(cmd," /Table=");
1282         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1283         cmddsc.dsc$w_length = strlen(cmd);
1284       }
1285       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1286       flags = defflags | CLI$M_NOCLISYM;
1287     }
1288
1289     /* Create a new subprocess to execute each command, to exclude the
1290      * remote possibility that someone could subvert a mbx or file used
1291      * to write multiple commands to a single subprocess.
1292      */
1293     do {
1294       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1295                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1296       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1297       defflags &= ~CLI$M_TRUSTED;
1298     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1299     _ckvmssts(retsts);
1300     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1301     if (seenhv) SvREFCNT_dec(seenhv);
1302     seenhv = newHV();
1303     while (1) {
1304       char *cp1, *cp2, *key;
1305       unsigned long int sts, iosb[2], retlen, keylen;
1306       register U32 hash;
1307
1308       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1309       if (sts & 1) sts = iosb[0] & 0xffff;
1310       if (sts == SS$_ENDOFFILE) {
1311         int wakect = 0;
1312         while (substs == 0) { sys$hiber(); wakect++;}
1313         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1314         _ckvmssts(substs);
1315         break;
1316       }
1317       _ckvmssts(sts);
1318       retlen = iosb[0] >> 16;
1319       if (!retlen) continue;  /* blank line */
1320       buf[retlen] = '\0';
1321       if (iosb[1] != subpid) {
1322         if (iosb[1]) {
1323           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1324         }
1325         continue;
1326       }
1327       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1328         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1329
1330       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1331       if (*cp1 == '(' || /* Logical name table name */
1332           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1333       if (*cp1 == '"') cp1++;
1334       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1335       key = cp1;  keylen = cp2 - cp1;
1336       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1337       while (*cp2 && *cp2 != '=') cp2++;
1338       while (*cp2 && *cp2 == '=') cp2++;
1339       while (*cp2 && *cp2 == ' ') cp2++;
1340       if (*cp2 == '"') {  /* String translation; may embed "" */
1341         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1342         cp2++;  cp1--; /* Skip "" surrounding translation */
1343       }
1344       else {  /* Numeric translation */
1345         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1346         cp1--;  /* stop on last non-space char */
1347       }
1348       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1349         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1350         continue;
1351       }
1352       PERL_HASH(hash,key,keylen);
1353
1354       if (cp1 == cp2 && *cp2 == '.') {
1355         /* A single dot usually means an unprintable character, such as a null
1356          * to indicate a zero-length value.  Get the actual value to make sure.
1357          */
1358         char lnm[LNM$C_NAMLENGTH+1];
1359         char eqv[MAX_DCL_SYMBOL+1];
1360         int trnlen;
1361         strncpy(lnm, key, keylen);
1362         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1363         sv = newSVpvn(eqv, strlen(eqv));
1364       }
1365       else {
1366         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1367       }
1368
1369       SvTAINTED_on(sv);
1370       hv_store(envhv,key,keylen,sv,hash);
1371       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1372     }
1373     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1374       /* get the PPFs for this process, not the subprocess */
1375       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1376       char eqv[LNM$C_NAMLENGTH+1];
1377       int trnlen, i;
1378       for (i = 0; ppfs[i]; i++) {
1379         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1380         sv = newSVpv(eqv,trnlen);
1381         SvTAINTED_on(sv);
1382         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1383       }
1384     }
1385   }
1386   primed = 1;
1387   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1388   if (buf) Safefree(buf);
1389   if (seenhv) SvREFCNT_dec(seenhv);
1390   MUTEX_UNLOCK(&primenv_mutex);
1391   return;
1392
1393 }  /* end of prime_env_iter */
1394 /*}}}*/
1395
1396
1397 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1398 /* Define or delete an element in the same "environment" as
1399  * vmstrnenv().  If an element is to be deleted, it's removed from
1400  * the first place it's found.  If it's to be set, it's set in the
1401  * place designated by the first element of the table vector.
1402  * Like setenv() returns 0 for success, non-zero on error.
1403  */
1404 int
1405 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1406 {
1407     const char *cp1;
1408     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1409     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1410     int nseg = 0, j;
1411     unsigned long int retsts, usermode = PSL$C_USER;
1412     struct itmlst_3 *ile, *ilist;
1413     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1414                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1415                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1416     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1417     $DESCRIPTOR(local,"_LOCAL");
1418
1419     if (!lnm) {
1420         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1421         return SS$_IVLOGNAM;
1422     }
1423
1424     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1425       *cp2 = _toupper(*cp1);
1426       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1427         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1428         return SS$_IVLOGNAM;
1429       }
1430     }
1431     lnmdsc.dsc$w_length = cp1 - lnm;
1432     if (!tabvec || !*tabvec) tabvec = env_tables;
1433
1434     if (!eqv) {  /* we're deleting n element */
1435       for (curtab = 0; tabvec[curtab]; curtab++) {
1436         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1437         int i;
1438           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1439             if ((cp1 = strchr(environ[i],'=')) &&
1440                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1441                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1442 #ifdef HAS_SETENV
1443               return setenv(lnm,"",1) ? vaxc$errno : 0;
1444             }
1445           }
1446           ivenv = 1; retsts = SS$_NOLOGNAM;
1447 #else
1448               if (ckWARN(WARN_INTERNAL))
1449                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1450               ivenv = 1; retsts = SS$_NOSUCHPGM;
1451               break;
1452             }
1453           }
1454 #endif
1455         }
1456         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1457                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1458           unsigned int symtype;
1459           if (tabvec[curtab]->dsc$w_length == 12 &&
1460               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1461               !str$case_blind_compare(&tmpdsc,&local))
1462             symtype = LIB$K_CLI_LOCAL_SYM;
1463           else symtype = LIB$K_CLI_GLOBAL_SYM;
1464           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1465           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1466           if (retsts == LIB$_NOSUCHSYM) continue;
1467           break;
1468         }
1469         else if (!ivlnm) {
1470           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1471           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1472           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1473           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1474           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1475         }
1476       }
1477     }
1478     else {  /* we're defining a value */
1479       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1480 #ifdef HAS_SETENV
1481         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1482 #else
1483         if (ckWARN(WARN_INTERNAL))
1484           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1485         retsts = SS$_NOSUCHPGM;
1486 #endif
1487       }
1488       else {
1489         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1490         eqvdsc.dsc$w_length  = strlen(eqv);
1491         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1492             !str$case_blind_compare(&tmpdsc,&clisym)) {
1493           unsigned int symtype;
1494           if (tabvec[0]->dsc$w_length == 12 &&
1495               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1496                !str$case_blind_compare(&tmpdsc,&local))
1497             symtype = LIB$K_CLI_LOCAL_SYM;
1498           else symtype = LIB$K_CLI_GLOBAL_SYM;
1499           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1500         }
1501         else {
1502           if (!*eqv) eqvdsc.dsc$w_length = 1;
1503           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1504
1505             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1506             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1507               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1508                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1509               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1510               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1511             }
1512
1513             Newx(ilist,nseg+1,struct itmlst_3);
1514             ile = ilist;
1515             if (!ile) {
1516               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1517               return SS$_INSFMEM;
1518             }
1519             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1520
1521             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1522               ile->itmcode = LNM$_STRING;
1523               ile->bufadr = c;
1524               if ((j+1) == nseg) {
1525                 ile->buflen = strlen(c);
1526                 /* in case we are truncating one that's too long */
1527                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1528               }
1529               else {
1530                 ile->buflen = LNM$C_NAMLENGTH;
1531               }
1532             }
1533
1534             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1535             Safefree (ilist);
1536           }
1537           else {
1538             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1539           }
1540         }
1541       }
1542     }
1543     if (!(retsts & 1)) {
1544       switch (retsts) {
1545         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1546         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1547           set_errno(EVMSERR); break;
1548         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1549         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1550           set_errno(EINVAL); break;
1551         case SS$_NOPRIV:
1552           set_errno(EACCES); break;
1553         default:
1554           _ckvmssts(retsts);
1555           set_errno(EVMSERR);
1556        }
1557        set_vaxc_errno(retsts);
1558        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1559     }
1560     else {
1561       /* We reset error values on success because Perl does an hv_fetch()
1562        * before each hv_store(), and if the thing we're setting didn't
1563        * previously exist, we've got a leftover error message.  (Of course,
1564        * this fails in the face of
1565        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1566        * in that the error reported in $! isn't spurious,
1567        * but it's right more often than not.)
1568        */
1569       set_errno(0); set_vaxc_errno(retsts);
1570       return 0;
1571     }
1572
1573 }  /* end of vmssetenv() */
1574 /*}}}*/
1575
1576 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1577 /* This has to be a function since there's a prototype for it in proto.h */
1578 void
1579 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1580 {
1581     if (lnm && *lnm) {
1582       int len = strlen(lnm);
1583       if  (len == 7) {
1584         char uplnm[8];
1585         int i;
1586         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1587         if (!strcmp(uplnm,"DEFAULT")) {
1588           if (eqv && *eqv) my_chdir(eqv);
1589           return;
1590         }
1591     }
1592 #ifndef RTL_USES_UTC
1593     if (len == 6 || len == 2) {
1594       char uplnm[7];
1595       int i;
1596       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1597       uplnm[len] = '\0';
1598       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1599       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1600     }
1601 #endif
1602   }
1603   (void) vmssetenv(lnm,eqv,NULL);
1604 }
1605 /*}}}*/
1606
1607 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1608 /*  vmssetuserlnm
1609  *  sets a user-mode logical in the process logical name table
1610  *  used for redirection of sys$error
1611  */
1612 void
1613 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1614 {
1615     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1616     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1617     unsigned long int iss, attr = LNM$M_CONFINE;
1618     unsigned char acmode = PSL$C_USER;
1619     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1620                                  {0, 0, 0, 0}};
1621     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1622     d_name.dsc$w_length = strlen(name);
1623
1624     lnmlst[0].buflen = strlen(eqv);
1625     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1626
1627     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1628     if (!(iss&1)) lib$signal(iss);
1629 }
1630 /*}}}*/
1631
1632
1633 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1634 /* my_crypt - VMS password hashing
1635  * my_crypt() provides an interface compatible with the Unix crypt()
1636  * C library function, and uses sys$hash_password() to perform VMS
1637  * password hashing.  The quadword hashed password value is returned
1638  * as a NUL-terminated 8 character string.  my_crypt() does not change
1639  * the case of its string arguments; in order to match the behavior
1640  * of LOGINOUT et al., alphabetic characters in both arguments must
1641  *  be upcased by the caller.
1642  *
1643  * - fix me to call ACM services when available
1644  */
1645 char *
1646 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1647 {
1648 #   ifndef UAI$C_PREFERRED_ALGORITHM
1649 #     define UAI$C_PREFERRED_ALGORITHM 127
1650 #   endif
1651     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1652     unsigned short int salt = 0;
1653     unsigned long int sts;
1654     struct const_dsc {
1655         unsigned short int dsc$w_length;
1656         unsigned char      dsc$b_type;
1657         unsigned char      dsc$b_class;
1658         const char *       dsc$a_pointer;
1659     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1660        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1661     struct itmlst_3 uailst[3] = {
1662         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1663         { sizeof salt, UAI$_SALT,    &salt, 0},
1664         { 0,           0,            NULL,  NULL}};
1665     static char hash[9];
1666
1667     usrdsc.dsc$w_length = strlen(usrname);
1668     usrdsc.dsc$a_pointer = usrname;
1669     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1670       switch (sts) {
1671         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1672           set_errno(EACCES);
1673           break;
1674         case RMS$_RNF:
1675           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1676           break;
1677         default:
1678           set_errno(EVMSERR);
1679       }
1680       set_vaxc_errno(sts);
1681       if (sts != RMS$_RNF) return NULL;
1682     }
1683
1684     txtdsc.dsc$w_length = strlen(textpasswd);
1685     txtdsc.dsc$a_pointer = textpasswd;
1686     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1687       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1688     }
1689
1690     return (char *) hash;
1691
1692 }  /* end of my_crypt() */
1693 /*}}}*/
1694
1695
1696 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1697 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1698 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1699
1700 /* fixup barenames that are directories for internal use.
1701  * There have been problems with the consistent handling of UNIX
1702  * style directory names when routines are presented with a name that
1703  * has no directory delimitors at all.  So this routine will eventually
1704  * fix the issue.
1705  */
1706 static char * fixup_bare_dirnames(const char * name)
1707 {
1708   if (decc_disable_to_vms_logname_translation) {
1709 /* fix me */
1710   }
1711   return NULL;
1712 }
1713
1714 /* mp_do_kill_file
1715  * A little hack to get around a bug in some implemenation of remove()
1716  * that do not know how to delete a directory
1717  *
1718  * Delete any file to which user has control access, regardless of whether
1719  * delete access is explicitly allowed.
1720  * Limitations: User must have write access to parent directory.
1721  *              Does not block signals or ASTs; if interrupted in midstream
1722  *              may leave file with an altered ACL.
1723  * HANDLE WITH CARE!
1724  */
1725 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1726 static int
1727 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1728 {
1729     char *vmsname, *rspec;
1730     char *remove_name;
1731     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1732     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1733     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1734     struct myacedef {
1735       unsigned char myace$b_length;
1736       unsigned char myace$b_type;
1737       unsigned short int myace$w_flags;
1738       unsigned long int myace$l_access;
1739       unsigned long int myace$l_ident;
1740     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1741                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1742       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1743      struct itmlst_3
1744        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1745                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1746        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1747        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1748        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1749        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1750
1751     /* Expand the input spec using RMS, since the CRTL remove() and
1752      * system services won't do this by themselves, so we may miss
1753      * a file "hiding" behind a logical name or search list. */
1754     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1755     if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1756
1757     if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1758       PerlMem_free(vmsname);
1759       return -1;
1760     }
1761
1762     if (decc_posix_compliant_pathnames) {
1763       /* In POSIX mode, we prefer to remove the UNIX name */
1764       rspec = vmsname;
1765       remove_name = (char *)name;
1766     }
1767     else {
1768       rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
1769       if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
1770       if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1771         PerlMem_free(rspec);
1772         PerlMem_free(vmsname);
1773         return -1;
1774       }
1775       PerlMem_free(vmsname);
1776       remove_name = rspec;
1777     }
1778
1779 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1780     if (dirflag != 0) {
1781         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1782           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1783           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1784
1785           do_pathify_dirspec(name, remove_name, 0, NULL);
1786           if (!rmdir(remove_name)) {
1787
1788             PerlMem_free(remove_name);
1789             PerlMem_free(rspec);
1790             return 0;   /* Can we just get rid of it? */
1791           }
1792         }
1793         else {
1794           if (!rmdir(remove_name)) {
1795             PerlMem_free(rspec);
1796             return 0;   /* Can we just get rid of it? */
1797           }
1798         }
1799     }
1800     else
1801 #endif
1802       if (!remove(remove_name)) {
1803         PerlMem_free(rspec);
1804         return 0;   /* Can we just get rid of it? */
1805       }
1806
1807     /* If not, can changing protections help? */
1808     if (vaxc$errno != RMS$_PRV) {
1809       PerlMem_free(rspec);
1810       return -1;
1811     }
1812
1813     /* No, so we get our own UIC to use as a rights identifier,
1814      * and the insert an ACE at the head of the ACL which allows us
1815      * to delete the file.
1816      */
1817     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1818     fildsc.dsc$w_length = strlen(rspec);
1819     fildsc.dsc$a_pointer = rspec;
1820     cxt = 0;
1821     newace.myace$l_ident = oldace.myace$l_ident;
1822     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1823       switch (aclsts) {
1824         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1825           set_errno(ENOENT); break;
1826         case RMS$_DIR:
1827           set_errno(ENOTDIR); break;
1828         case RMS$_DEV:
1829           set_errno(ENODEV); break;
1830         case RMS$_SYN: case SS$_INVFILFOROP:
1831           set_errno(EINVAL); break;
1832         case RMS$_PRV:
1833           set_errno(EACCES); break;
1834         default:
1835           _ckvmssts(aclsts);
1836       }
1837       set_vaxc_errno(aclsts);
1838       PerlMem_free(rspec);
1839       return -1;
1840     }
1841     /* Grab any existing ACEs with this identifier in case we fail */
1842     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1843     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1844                     || fndsts == SS$_NOMOREACE ) {
1845       /* Add the new ACE . . . */
1846       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1847         goto yourroom;
1848
1849 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1850       if (dirflag != 0)
1851         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1852           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1853           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1854
1855           do_pathify_dirspec(name, remove_name, 0, NULL);
1856           rmsts = rmdir(remove_name);
1857           PerlMem_free(remove_name);
1858         }
1859         else {
1860         rmsts = rmdir(remove_name);
1861         }
1862       else
1863 #endif
1864         rmsts = remove(remove_name);
1865       if (rmsts) {
1866         /* We blew it - dir with files in it, no write priv for
1867          * parent directory, etc.  Put things back the way they were. */
1868         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1869           goto yourroom;
1870         if (fndsts & 1) {
1871           addlst[0].bufadr = &oldace;
1872           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1873             goto yourroom;
1874         }
1875       }
1876     }
1877
1878     yourroom:
1879     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1880     /* We just deleted it, so of course it's not there.  Some versions of
1881      * VMS seem to return success on the unlock operation anyhow (after all
1882      * the unlock is successful), but others don't.
1883      */
1884     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1885     if (aclsts & 1) aclsts = fndsts;
1886     if (!(aclsts & 1)) {
1887       set_errno(EVMSERR);
1888       set_vaxc_errno(aclsts);
1889       PerlMem_free(rspec);
1890       return -1;
1891     }
1892
1893     PerlMem_free(rspec);
1894     return rmsts;
1895
1896 }  /* end of kill_file() */
1897 /*}}}*/
1898
1899
1900 /*{{{int do_rmdir(char *name)*/
1901 int
1902 Perl_do_rmdir(pTHX_ const char *name)
1903 {
1904     char dirfile[NAM$C_MAXRSS+1];
1905     int retval;
1906     Stat_t st;
1907
1908     if (do_fileify_dirspec(name,dirfile,0,NULL) == NULL) return -1;
1909     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1910     else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1911     return retval;
1912
1913 }  /* end of do_rmdir */
1914 /*}}}*/
1915
1916 /* kill_file
1917  * Delete any file to which user has control access, regardless of whether
1918  * delete access is explicitly allowed.
1919  * Limitations: User must have write access to parent directory.
1920  *              Does not block signals or ASTs; if interrupted in midstream
1921  *              may leave file with an altered ACL.
1922  * HANDLE WITH CARE!
1923  */
1924 /*{{{int kill_file(char *name)*/
1925 int
1926 Perl_kill_file(pTHX_ const char *name)
1927 {
1928     char rspec[NAM$C_MAXRSS+1];
1929     char *tspec;
1930     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1931     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1932     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1933     struct myacedef {
1934       unsigned char myace$b_length;
1935       unsigned char myace$b_type;
1936       unsigned short int myace$w_flags;
1937       unsigned long int myace$l_access;
1938       unsigned long int myace$l_ident;
1939     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1940                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1941       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1942      struct itmlst_3
1943        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1944                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1945        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1946        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1947        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1948        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1949
1950     /* Expand the input spec using RMS, since the CRTL remove() and
1951      * system services won't do this by themselves, so we may miss
1952      * a file "hiding" behind a logical name or search list. */
1953     tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
1954     if (tspec == NULL) return -1;
1955     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
1956     /* If not, can changing protections help? */
1957     if (vaxc$errno != RMS$_PRV) return -1;
1958
1959     /* No, so we get our own UIC to use as a rights identifier,
1960      * and the insert an ACE at the head of the ACL which allows us
1961      * to delete the file.
1962      */
1963     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1964     fildsc.dsc$w_length = strlen(rspec);
1965     fildsc.dsc$a_pointer = rspec;
1966     cxt = 0;
1967     newace.myace$l_ident = oldace.myace$l_ident;
1968     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1969       switch (aclsts) {
1970         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1971           set_errno(ENOENT); break;
1972         case RMS$_DIR:
1973           set_errno(ENOTDIR); break;
1974         case RMS$_DEV:
1975           set_errno(ENODEV); break;
1976         case RMS$_SYN: case SS$_INVFILFOROP:
1977           set_errno(EINVAL); break;
1978         case RMS$_PRV:
1979           set_errno(EACCES); break;
1980         default:
1981           _ckvmssts(aclsts);
1982       }
1983       set_vaxc_errno(aclsts);
1984       return -1;
1985     }
1986     /* Grab any existing ACEs with this identifier in case we fail */
1987     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1988     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1989                     || fndsts == SS$_NOMOREACE ) {
1990       /* Add the new ACE . . . */
1991       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1992         goto yourroom;
1993       if ((rmsts = remove(name))) {
1994         /* We blew it - dir with files in it, no write priv for
1995          * parent directory, etc.  Put things back the way they were. */
1996         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1997           goto yourroom;
1998         if (fndsts & 1) {
1999           addlst[0].bufadr = &oldace;
2000           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2001             goto yourroom;
2002         }
2003       }
2004     }
2005
2006     yourroom:
2007     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2008     /* We just deleted it, so of course it's not there.  Some versions of
2009      * VMS seem to return success on the unlock operation anyhow (after all
2010      * the unlock is successful), but others don't.
2011      */
2012     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2013     if (aclsts & 1) aclsts = fndsts;
2014     if (!(aclsts & 1)) {
2015       set_errno(EVMSERR);
2016       set_vaxc_errno(aclsts);
2017       return -1;
2018     }
2019
2020     return rmsts;
2021
2022 }  /* end of kill_file() */
2023 /*}}}*/
2024
2025
2026 /*{{{int my_mkdir(char *,Mode_t)*/
2027 int
2028 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2029 {
2030   STRLEN dirlen = strlen(dir);
2031
2032   /* zero length string sometimes gives ACCVIO */
2033   if (dirlen == 0) return -1;
2034
2035   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2036    * null file name/type.  However, it's commonplace under Unix,
2037    * so we'll allow it for a gain in portability.
2038    */
2039   if (dir[dirlen-1] == '/') {
2040     char *newdir = savepvn(dir,dirlen-1);
2041     int ret = mkdir(newdir,mode);
2042     Safefree(newdir);
2043     return ret;
2044   }
2045   else return mkdir(dir,mode);
2046 }  /* end of my_mkdir */
2047 /*}}}*/
2048
2049 /*{{{int my_chdir(char *)*/
2050 int
2051 Perl_my_chdir(pTHX_ const char *dir)
2052 {
2053   STRLEN dirlen = strlen(dir);
2054
2055   /* zero length string sometimes gives ACCVIO */
2056   if (dirlen == 0) return -1;
2057   const char *dir1;
2058
2059   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2060    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2061    * so that existing scripts do not need to be changed.
2062    */
2063   dir1 = dir;
2064   while ((dirlen > 0) && (*dir1 == ' ')) {
2065     dir1++;
2066     dirlen--;
2067   }
2068
2069   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2070    * that implies
2071    * null file name/type.  However, it's commonplace under Unix,
2072    * so we'll allow it for a gain in portability.
2073    *
2074    * - Preview- '/' will be valid soon on VMS
2075    */
2076   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2077     char *newdir = savepvn(dir1,dirlen-1);
2078     int ret = chdir(newdir);
2079     Safefree(newdir);
2080     return ret;
2081   }
2082   else return chdir(dir1);
2083 }  /* end of my_chdir */
2084 /*}}}*/
2085
2086
2087 /*{{{FILE *my_tmpfile()*/
2088 FILE *
2089 my_tmpfile(void)
2090 {
2091   FILE *fp;
2092   char *cp;
2093
2094   if ((fp = tmpfile())) return fp;
2095
2096   cp = PerlMem_malloc(L_tmpnam+24);
2097   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2098
2099   if (decc_filename_unix_only == 0)
2100     strcpy(cp,"Sys$Scratch:");
2101   else
2102     strcpy(cp,"/tmp/");
2103   tmpnam(cp+strlen(cp));
2104   strcat(cp,".Perltmp");
2105   fp = fopen(cp,"w+","fop=dlt");
2106   PerlMem_free(cp);
2107   return fp;
2108 }
2109 /*}}}*/
2110
2111
2112 #ifndef HOMEGROWN_POSIX_SIGNALS
2113 /*
2114  * The C RTL's sigaction fails to check for invalid signal numbers so we
2115  * help it out a bit.  The docs are correct, but the actual routine doesn't
2116  * do what the docs say it will.
2117  */
2118 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2119 int
2120 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2121                    struct sigaction* oact)
2122 {
2123   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2124         SETERRNO(EINVAL, SS$_INVARG);
2125         return -1;
2126   }
2127   return sigaction(sig, act, oact);
2128 }
2129 /*}}}*/
2130 #endif
2131
2132 #ifdef KILL_BY_SIGPRC
2133 #include <errnodef.h>
2134
2135 /* We implement our own kill() using the undocumented system service
2136    sys$sigprc for one of two reasons:
2137
2138    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2139    target process to do a sys$exit, which usually can't be handled
2140    gracefully...certainly not by Perl and the %SIG{} mechanism.
2141
2142    2.) If the kill() in the CRTL can't be called from a signal
2143    handler without disappearing into the ether, i.e., the signal
2144    it purportedly sends is never trapped. Still true as of VMS 7.3.
2145
2146    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2147    in the target process rather than calling sys$exit.
2148
2149    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2150    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2151    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2152    with condition codes C$_SIG0+nsig*8, catching the exception on the
2153    target process and resignaling with appropriate arguments.
2154
2155    But we don't have that VMS 7.0+ exception handler, so if you
2156    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2157
2158    Also note that SIGTERM is listed in the docs as being "unimplemented",
2159    yet always seems to be signaled with a VMS condition code of 4 (and
2160    correctly handled for that code).  So we hardwire it in.
2161
2162    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2163    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2164    than signalling with an unrecognized (and unhandled by CRTL) code.
2165 */
2166
2167 #define _MY_SIG_MAX 28
2168
2169 static unsigned int
2170 Perl_sig_to_vmscondition_int(int sig)
2171 {
2172     static unsigned int sig_code[_MY_SIG_MAX+1] =
2173     {
2174         0,                  /*  0 ZERO     */
2175         SS$_HANGUP,         /*  1 SIGHUP   */
2176         SS$_CONTROLC,       /*  2 SIGINT   */
2177         SS$_CONTROLY,       /*  3 SIGQUIT  */
2178         SS$_RADRMOD,        /*  4 SIGILL   */
2179         SS$_BREAK,          /*  5 SIGTRAP  */
2180         SS$_OPCCUS,         /*  6 SIGABRT  */
2181         SS$_COMPAT,         /*  7 SIGEMT   */
2182 #ifdef __VAX
2183         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2184 #else
2185         SS$_HPARITH,        /*  8 SIGFPE AXP */
2186 #endif
2187         SS$_ABORT,          /*  9 SIGKILL  */
2188         SS$_ACCVIO,         /* 10 SIGBUS   */
2189         SS$_ACCVIO,         /* 11 SIGSEGV  */
2190         SS$_BADPARAM,       /* 12 SIGSYS   */
2191         SS$_NOMBX,          /* 13 SIGPIPE  */
2192         SS$_ASTFLT,         /* 14 SIGALRM  */
2193         4,                  /* 15 SIGTERM  */
2194         0,                  /* 16 SIGUSR1  */
2195         0,                  /* 17 SIGUSR2  */
2196         0,                  /* 18 */
2197         0,                  /* 19 */
2198         0,                  /* 20 SIGCHLD  */
2199         0,                  /* 21 SIGCONT  */
2200         0,                  /* 22 SIGSTOP  */
2201         0,                  /* 23 SIGTSTP  */
2202         0,                  /* 24 SIGTTIN  */
2203         0,                  /* 25 SIGTTOU  */
2204         0,                  /* 26 */
2205         0,                  /* 27 */
2206         0                   /* 28 SIGWINCH  */
2207     };
2208
2209 #if __VMS_VER >= 60200000
2210     static int initted = 0;
2211     if (!initted) {
2212         initted = 1;
2213         sig_code[16] = C$_SIGUSR1;
2214         sig_code[17] = C$_SIGUSR2;
2215 #if __CRTL_VER >= 70000000
2216         sig_code[20] = C$_SIGCHLD;
2217 #endif
2218 #if __CRTL_VER >= 70300000
2219         sig_code[28] = C$_SIGWINCH;
2220 #endif
2221     }
2222 #endif
2223
2224     if (sig < _SIG_MIN) return 0;
2225     if (sig > _MY_SIG_MAX) return 0;
2226     return sig_code[sig];
2227 }
2228
2229 unsigned int
2230 Perl_sig_to_vmscondition(int sig)
2231 {
2232 #ifdef SS$_DEBUG
2233     if (vms_debug_on_exception != 0)
2234         lib$signal(SS$_DEBUG);
2235 #endif
2236     return Perl_sig_to_vmscondition_int(sig);
2237 }
2238
2239
2240 int
2241 Perl_my_kill(int pid, int sig)
2242 {
2243     dTHX;
2244     int iss;
2245     unsigned int code;
2246     int sys$sigprc(unsigned int *pidadr,
2247                      struct dsc$descriptor_s *prcname,
2248                      unsigned int code);
2249
2250      /* sig 0 means validate the PID */
2251     /*------------------------------*/
2252     if (sig == 0) {
2253         const unsigned long int jpicode = JPI$_PID;
2254         pid_t ret_pid;
2255         int status;
2256         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2257         if ($VMS_STATUS_SUCCESS(status))
2258            return 0;
2259         switch (status) {
2260         case SS$_NOSUCHNODE:
2261         case SS$_UNREACHABLE:
2262         case SS$_NONEXPR:
2263            errno = ESRCH;
2264            break;
2265         case SS$_NOPRIV:
2266            errno = EPERM;
2267            break;
2268         default:
2269            errno = EVMSERR;
2270         }
2271         vaxc$errno=status;
2272         return -1;
2273     }
2274
2275     code = Perl_sig_to_vmscondition_int(sig);
2276
2277     if (!code) {
2278         SETERRNO(EINVAL, SS$_BADPARAM);
2279         return -1;
2280     }
2281
2282     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2283      * signals are to be sent to multiple processes.
2284      *  pid = 0 - all processes in group except ones that the system exempts
2285      *  pid = -1 - all processes except ones that the system exempts
2286      *  pid = -n - all processes in group (abs(n)) except ...
2287      * For now, just report as not supported.
2288      */
2289
2290     if (pid <= 0) {
2291         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2292         return -1;
2293     }
2294
2295     iss = sys$sigprc((unsigned int *)&pid,0,code);
2296     if (iss&1) return 0;
2297
2298     switch (iss) {
2299       case SS$_NOPRIV:
2300         set_errno(EPERM);  break;
2301       case SS$_NONEXPR:
2302       case SS$_NOSUCHNODE:
2303       case SS$_UNREACHABLE:
2304         set_errno(ESRCH);  break;
2305       case SS$_INSFMEM:
2306         set_errno(ENOMEM); break;
2307       default:
2308         _ckvmssts(iss);
2309         set_errno(EVMSERR);
2310     }
2311     set_vaxc_errno(iss);
2312
2313     return -1;
2314 }
2315 #endif
2316
2317 /* Routine to convert a VMS status code to a UNIX status code.
2318 ** More tricky than it appears because of conflicting conventions with
2319 ** existing code.
2320 **
2321 ** VMS status codes are a bit mask, with the least significant bit set for
2322 ** success.
2323 **
2324 ** Special UNIX status of EVMSERR indicates that no translation is currently
2325 ** available, and programs should check the VMS status code.
2326 **
2327 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2328 ** decoding.
2329 */
2330
2331 #ifndef C_FACILITY_NO
2332 #define C_FACILITY_NO 0x350000
2333 #endif
2334 #ifndef DCL_IVVERB
2335 #define DCL_IVVERB 0x38090
2336 #endif
2337
2338 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2339 {
2340 int facility;
2341 int fac_sp;
2342 int msg_no;
2343 int msg_status;
2344 int unix_status;
2345
2346   /* Assume the best or the worst */
2347   if (vms_status & STS$M_SUCCESS)
2348     unix_status = 0;
2349   else
2350     unix_status = EVMSERR;
2351
2352   msg_status = vms_status & ~STS$M_CONTROL;
2353
2354   facility = vms_status & STS$M_FAC_NO;
2355   fac_sp = vms_status & STS$M_FAC_SP;
2356   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2357
2358   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2359     switch(msg_no) {
2360     case SS$_NORMAL:
2361         unix_status = 0;
2362         break;
2363     case SS$_ACCVIO:
2364         unix_status = EFAULT;
2365         break;
2366     case SS$_DEVOFFLINE:
2367         unix_status = EBUSY;
2368         break;
2369     case SS$_CLEARED:
2370         unix_status = ENOTCONN;
2371         break;
2372     case SS$_IVCHAN:
2373     case SS$_IVLOGNAM:
2374     case SS$_BADPARAM:
2375     case SS$_IVLOGTAB:
2376     case SS$_NOLOGNAM:
2377     case SS$_NOLOGTAB:
2378     case SS$_INVFILFOROP:
2379     case SS$_INVARG:
2380     case SS$_NOSUCHID:
2381     case SS$_IVIDENT:
2382         unix_status = EINVAL;
2383         break;
2384     case SS$_UNSUPPORTED:
2385         unix_status = ENOTSUP;
2386         break;
2387     case SS$_FILACCERR:
2388     case SS$_NOGRPPRV:
2389     case SS$_NOSYSPRV:
2390         unix_status = EACCES;
2391         break;
2392     case SS$_DEVICEFULL:
2393         unix_status = ENOSPC;
2394         break;
2395     case SS$_NOSUCHDEV:
2396         unix_status = ENODEV;
2397         break;
2398     case SS$_NOSUCHFILE:
2399     case SS$_NOSUCHOBJECT:
2400         unix_status = ENOENT;
2401         break;
2402     case SS$_ABORT:                                 /* Fatal case */
2403     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2404     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2405         unix_status = EINTR;
2406         break;
2407     case SS$_BUFFEROVF:
2408         unix_status = E2BIG;
2409         break;
2410     case SS$_INSFMEM:
2411         unix_status = ENOMEM;
2412         break;
2413     case SS$_NOPRIV:
2414         unix_status = EPERM;
2415         break;
2416     case SS$_NOSUCHNODE:
2417     case SS$_UNREACHABLE:
2418         unix_status = ESRCH;
2419         break;
2420     case SS$_NONEXPR:
2421         unix_status = ECHILD;
2422         break;
2423     default:
2424         if ((facility == 0) && (msg_no < 8)) {
2425           /* These are not real VMS status codes so assume that they are
2426           ** already UNIX status codes
2427           */
2428           unix_status = msg_no;
2429           break;
2430         }
2431     }
2432   }
2433   else {
2434     /* Translate a POSIX exit code to a UNIX exit code */
2435     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2436         unix_status = (msg_no & 0x07F8) >> 3;
2437     }
2438     else {
2439
2440          /* Documented traditional behavior for handling VMS child exits */
2441         /*--------------------------------------------------------------*/
2442         if (child_flag != 0) {
2443
2444              /* Success / Informational return 0 */
2445             /*----------------------------------*/
2446             if (msg_no & STS$K_SUCCESS)
2447                 return 0;
2448
2449              /* Warning returns 1 */
2450             /*-------------------*/
2451             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2452                 return 1;
2453
2454              /* Everything else pass through the severity bits */
2455             /*------------------------------------------------*/
2456             return (msg_no & STS$M_SEVERITY);
2457         }
2458
2459          /* Normal VMS status to ERRNO mapping attempt */
2460         /*--------------------------------------------*/
2461         switch(msg_status) {
2462         /* case RMS$_EOF: */ /* End of File */
2463         case RMS$_FNF:  /* File Not Found */
2464         case RMS$_DNF:  /* Dir Not Found */
2465                 unix_status = ENOENT;
2466                 break;
2467         case RMS$_RNF:  /* Record Not Found */
2468                 unix_status = ESRCH;
2469                 break;
2470         case RMS$_DIR:
2471                 unix_status = ENOTDIR;
2472                 break;
2473         case RMS$_DEV:
2474                 unix_status = ENODEV;
2475                 break;
2476         case RMS$_IFI:
2477         case RMS$_FAC:
2478         case RMS$_ISI:
2479                 unix_status = EBADF;
2480                 break;
2481         case RMS$_FEX:
2482                 unix_status = EEXIST;
2483                 break;
2484         case RMS$_SYN:
2485         case RMS$_FNM:
2486         case LIB$_INVSTRDES:
2487         case LIB$_INVARG:
2488         case LIB$_NOSUCHSYM:
2489         case LIB$_INVSYMNAM:
2490         case DCL_IVVERB:
2491                 unix_status = EINVAL;
2492                 break;
2493         case CLI$_BUFOVF:
2494         case RMS$_RTB:
2495         case CLI$_TKNOVF:
2496         case CLI$_RSLOVF:
2497                 unix_status = E2BIG;
2498                 break;
2499         case RMS$_PRV:  /* No privilege */
2500         case RMS$_ACC:  /* ACP file access failed */
2501         case RMS$_WLK:  /* Device write locked */
2502                 unix_status = EACCES;
2503                 break;
2504         /* case RMS$_NMF: */  /* No more files */
2505         }
2506     }
2507   }
2508
2509   return unix_status;
2510 }
2511
2512 /* Try to guess at what VMS error status should go with a UNIX errno
2513  * value.  This is hard to do as there could be many possible VMS
2514  * error statuses that caused the errno value to be set.
2515  */
2516
2517 int Perl_unix_status_to_vms(int unix_status)
2518 {
2519 int test_unix_status;
2520
2521      /* Trivial cases first */
2522     /*---------------------*/
2523     if (unix_status == EVMSERR)
2524         return vaxc$errno;
2525
2526      /* Is vaxc$errno sane? */
2527     /*---------------------*/
2528     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2529     if (test_unix_status == unix_status)
2530         return vaxc$errno;
2531
2532      /* If way out of range, must be VMS code already */
2533     /*-----------------------------------------------*/
2534     if (unix_status > EVMSERR)
2535         return unix_status;
2536
2537      /* If out of range, punt */
2538     /*-----------------------*/
2539     if (unix_status > __ERRNO_MAX)
2540         return SS$_ABORT;
2541
2542
2543      /* Ok, now we have to do it the hard way. */
2544     /*----------------------------------------*/
2545     switch(unix_status) {
2546     case 0:     return SS$_NORMAL;
2547     case EPERM: return SS$_NOPRIV;
2548     case ENOENT: return SS$_NOSUCHOBJECT;
2549     case ESRCH: return SS$_UNREACHABLE;
2550     case EINTR: return SS$_ABORT;
2551     /* case EIO: */
2552     /* case ENXIO:  */
2553     case E2BIG: return SS$_BUFFEROVF;
2554     /* case ENOEXEC */
2555     case EBADF: return RMS$_IFI;
2556     case ECHILD: return SS$_NONEXPR;
2557     /* case EAGAIN */
2558     case ENOMEM: return SS$_INSFMEM;
2559     case EACCES: return SS$_FILACCERR;
2560     case EFAULT: return SS$_ACCVIO;
2561     /* case ENOTBLK */
2562     case EBUSY: return SS$_DEVOFFLINE;
2563     case EEXIST: return RMS$_FEX;
2564     /* case EXDEV */
2565     case ENODEV: return SS$_NOSUCHDEV;
2566     case ENOTDIR: return RMS$_DIR;
2567     /* case EISDIR */
2568     case EINVAL: return SS$_INVARG;
2569     /* case ENFILE */
2570     /* case EMFILE */
2571     /* case ENOTTY */
2572     /* case ETXTBSY */
2573     /* case EFBIG */
2574     case ENOSPC: return SS$_DEVICEFULL;
2575     case ESPIPE: return LIB$_INVARG;
2576     /* case EROFS: */
2577     /* case EMLINK: */
2578     /* case EPIPE: */
2579     /* case EDOM */
2580     case ERANGE: return LIB$_INVARG;
2581     /* case EWOULDBLOCK */
2582     /* case EINPROGRESS */
2583     /* case EALREADY */
2584     /* case ENOTSOCK */
2585     /* case EDESTADDRREQ */
2586     /* case EMSGSIZE */
2587     /* case EPROTOTYPE */
2588     /* case ENOPROTOOPT */
2589     /* case EPROTONOSUPPORT */
2590     /* case ESOCKTNOSUPPORT */
2591     /* case EOPNOTSUPP */
2592     /* case EPFNOSUPPORT */
2593     /* case EAFNOSUPPORT */
2594     /* case EADDRINUSE */
2595     /* case EADDRNOTAVAIL */
2596     /* case ENETDOWN */
2597     /* case ENETUNREACH */
2598     /* case ENETRESET */
2599     /* case ECONNABORTED */
2600     /* case ECONNRESET */
2601     /* case ENOBUFS */
2602     /* case EISCONN */
2603     case ENOTCONN: return SS$_CLEARED;
2604     /* case ESHUTDOWN */
2605     /* case ETOOMANYREFS */
2606     /* case ETIMEDOUT */
2607     /* case ECONNREFUSED */
2608     /* case ELOOP */
2609     /* case ENAMETOOLONG */
2610     /* case EHOSTDOWN */
2611     /* case EHOSTUNREACH */
2612     /* case ENOTEMPTY */
2613     /* case EPROCLIM */
2614     /* case EUSERS  */
2615     /* case EDQUOT  */
2616     /* case ENOMSG  */
2617     /* case EIDRM */
2618     /* case EALIGN */
2619     /* case ESTALE */
2620     /* case EREMOTE */
2621     /* case ENOLCK */
2622     /* case ENOSYS */
2623     /* case EFTYPE */
2624     /* case ECANCELED */
2625     /* case EFAIL */
2626     /* case EINPROG */
2627     case ENOTSUP:
2628         return SS$_UNSUPPORTED;
2629     /* case EDEADLK */
2630     /* case ENWAIT */
2631     /* case EILSEQ */
2632     /* case EBADCAT */
2633     /* case EBADMSG */
2634     /* case EABANDONED */
2635     default:
2636         return SS$_ABORT; /* punt */
2637     }
2638
2639   return SS$_ABORT; /* Should not get here */
2640 }
2641
2642
2643 /* default piping mailbox size */
2644 #define PERL_BUFSIZ        512
2645
2646
2647 static void
2648 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2649 {
2650   unsigned long int mbxbufsiz;
2651   static unsigned long int syssize = 0;
2652   unsigned long int dviitm = DVI$_DEVNAM;
2653   char csize[LNM$C_NAMLENGTH+1];
2654   int sts;
2655
2656   if (!syssize) {
2657     unsigned long syiitm = SYI$_MAXBUF;
2658     /*
2659      * Get the SYSGEN parameter MAXBUF
2660      *
2661      * If the logical 'PERL_MBX_SIZE' is defined
2662      * use the value of the logical instead of PERL_BUFSIZ, but
2663      * keep the size between 128 and MAXBUF.
2664      *
2665      */
2666     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2667   }
2668
2669   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2670       mbxbufsiz = atoi(csize);
2671   } else {
2672       mbxbufsiz = PERL_BUFSIZ;
2673   }
2674   if (mbxbufsiz < 128) mbxbufsiz = 128;
2675   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2676
2677   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2678
2679   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2680   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2681
2682 }  /* end of create_mbx() */
2683
2684
2685 /*{{{  my_popen and my_pclose*/
2686
2687 typedef struct _iosb           IOSB;
2688 typedef struct _iosb*         pIOSB;
2689 typedef struct _pipe           Pipe;
2690 typedef struct _pipe*         pPipe;
2691 typedef struct pipe_details    Info;
2692 typedef struct pipe_details*  pInfo;
2693 typedef struct _srqp            RQE;
2694 typedef struct _srqp*          pRQE;
2695 typedef struct _tochildbuf      CBuf;
2696 typedef struct _tochildbuf*    pCBuf;
2697
2698 struct _iosb {
2699     unsigned short status;
2700     unsigned short count;
2701     unsigned long  dvispec;
2702 };
2703
2704 #pragma member_alignment save
2705 #pragma nomember_alignment quadword
2706 struct _srqp {          /* VMS self-relative queue entry */
2707     unsigned long qptr[2];
2708 };
2709 #pragma member_alignment restore
2710 static RQE  RQE_ZERO = {0,0};
2711
2712 struct _tochildbuf {
2713     RQE             q;
2714     int             eof;
2715     unsigned short  size;
2716     char            *buf;
2717 };
2718
2719 struct _pipe {
2720     RQE            free;
2721     RQE            wait;
2722     int            fd_out;
2723     unsigned short chan_in;
2724     unsigned short chan_out;
2725     char          *buf;
2726     unsigned int   bufsize;
2727     IOSB           iosb;
2728     IOSB           iosb2;
2729     int           *pipe_done;
2730     int            retry;
2731     int            type;
2732     int            shut_on_empty;
2733     int            need_wake;
2734     pPipe         *home;
2735     pInfo          info;
2736     pCBuf          curr;
2737     pCBuf          curr2;
2738 #if defined(PERL_IMPLICIT_CONTEXT)
2739     void            *thx;           /* Either a thread or an interpreter */
2740                                     /* pointer, depending on how we're built */
2741 #endif
2742 };
2743
2744
2745 struct pipe_details
2746 {
2747     pInfo           next;
2748     PerlIO *fp;  /* file pointer to pipe mailbox */
2749     int useFILE; /* using stdio, not perlio */
2750     int pid;   /* PID of subprocess */
2751     int mode;  /* == 'r' if pipe open for reading */
2752     int done;  /* subprocess has completed */
2753     int waiting; /* waiting for completion/closure */
2754     int             closing;        /* my_pclose is closing this pipe */
2755     unsigned long   completion;     /* termination status of subprocess */
2756     pPipe           in;             /* pipe in to sub */
2757     pPipe           out;            /* pipe out of sub */
2758     pPipe           err;            /* pipe of sub's sys$error */
2759     int             in_done;        /* true when in pipe finished */
2760     int             out_done;
2761     int             err_done;
2762 };
2763
2764 struct exit_control_block
2765 {
2766     struct exit_control_block *flink;
2767     unsigned long int   (*exit_routine)();
2768     unsigned long int arg_count;
2769     unsigned long int *status_address;
2770     unsigned long int exit_status;
2771 };
2772
2773 typedef struct _closed_pipes    Xpipe;
2774 typedef struct _closed_pipes*  pXpipe;
2775
2776 struct _closed_pipes {
2777     int             pid;            /* PID of subprocess */
2778     unsigned long   completion;     /* termination status of subprocess */
2779 };
2780 #define NKEEPCLOSED 50
2781 static Xpipe closed_list[NKEEPCLOSED];
2782 static int   closed_index = 0;
2783 static int   closed_num = 0;
2784
2785 #define RETRY_DELAY     "0 ::0.20"
2786 #define MAX_RETRY              50
2787
2788 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2789 static unsigned long mypid;
2790 static unsigned long delaytime[2];
2791
2792 static pInfo open_pipes = NULL;
2793 static $DESCRIPTOR(nl_desc, "NL:");
2794
2795 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2796
2797
2798
2799 static unsigned long int
2800 pipe_exit_routine(pTHX)
2801 {
2802     pInfo info;
2803     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2804     int sts, did_stuff, need_eof, j;
2805
2806     /*
2807         flush any pending i/o
2808     */
2809     info = open_pipes;
2810     while (info) {
2811         if (info->fp) {
2812            if (!info->useFILE)
2813                PerlIO_flush(info->fp);   /* first, flush data */
2814            else
2815                fflush((FILE *)info->fp);
2816         }
2817         info = info->next;
2818     }
2819
2820     /*
2821      next we try sending an EOF...ignore if doesn't work, make sure we
2822      don't hang
2823     */
2824     did_stuff = 0;
2825     info = open_pipes;
2826
2827     while (info) {
2828       int need_eof;
2829       _ckvmssts_noperl(sys$setast(0));
2830       if (info->in && !info->in->shut_on_empty) {
2831         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2832                           0, 0, 0, 0, 0, 0));
2833         info->waiting = 1;
2834         did_stuff = 1;
2835       }
2836       _ckvmssts_noperl(sys$setast(1));
2837       info = info->next;
2838     }
2839
2840     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2841
2842     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2843         int nwait = 0;
2844
2845         info = open_pipes;
2846         while (info) {
2847           _ckvmssts_noperl(sys$setast(0));
2848           if (info->waiting && info->done)
2849                 info->waiting = 0;
2850           nwait += info->waiting;
2851           _ckvmssts_noperl(sys$setast(1));
2852           info = info->next;
2853         }
2854         if (!nwait) break;
2855         sleep(1);
2856     }
2857
2858     did_stuff = 0;
2859     info = open_pipes;
2860     while (info) {
2861       _ckvmssts_noperl(sys$setast(0));
2862       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2863         sts = sys$forcex(&info->pid,0,&abort);
2864         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2865         did_stuff = 1;
2866       }
2867       _ckvmssts_noperl(sys$setast(1));
2868       info = info->next;
2869     }
2870
2871     /* again, wait for effect */
2872
2873     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2874         int nwait = 0;
2875
2876         info = open_pipes;
2877         while (info) {
2878           _ckvmssts_noperl(sys$setast(0));
2879           if (info->waiting && info->done)
2880                 info->waiting = 0;
2881           nwait += info->waiting;
2882           _ckvmssts_noperl(sys$setast(1));
2883           info = info->next;
2884         }
2885         if (!nwait) break;
2886         sleep(1);
2887     }
2888
2889     info = open_pipes;
2890     while (info) {
2891       _ckvmssts_noperl(sys$setast(0));
2892       if (!info->done) {  /* We tried to be nice . . . */
2893         sts = sys$delprc(&info->pid,0);
2894         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2895       }
2896       _ckvmssts_noperl(sys$setast(1));
2897       info = info->next;
2898     }
2899
2900     while(open_pipes) {
2901       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2902       else if (!(sts & 1)) retsts = sts;
2903     }
2904     return retsts;
2905 }
2906
2907 static struct exit_control_block pipe_exitblock =
2908        {(struct exit_control_block *) 0,
2909         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2910
2911 static void pipe_mbxtofd_ast(pPipe p);
2912 static void pipe_tochild1_ast(pPipe p);
2913 static void pipe_tochild2_ast(pPipe p);
2914
2915 static void
2916 popen_completion_ast(pInfo info)
2917 {
2918   pInfo i = open_pipes;
2919   int iss;
2920   int sts;
2921   pXpipe x;
2922
2923   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2924   closed_list[closed_index].pid = info->pid;
2925   closed_list[closed_index].completion = info->completion;
2926   closed_index++;
2927   if (closed_index == NKEEPCLOSED)
2928     closed_index = 0;
2929   closed_num++;
2930
2931   while (i) {
2932     if (i == info) break;
2933     i = i->next;
2934   }
2935   if (!i) return;       /* unlinked, probably freed too */
2936
2937   info->done = TRUE;
2938
2939 /*
2940     Writing to subprocess ...
2941             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2942
2943             chan_out may be waiting for "done" flag, or hung waiting
2944             for i/o completion to child...cancel the i/o.  This will
2945             put it into "snarf mode" (done but no EOF yet) that discards
2946             input.
2947
2948     Output from subprocess (stdout, stderr) needs to be flushed and
2949     shut down.   We try sending an EOF, but if the mbx is full the pipe
2950     routine should still catch the "shut_on_empty" flag, telling it to
2951     use immediate-style reads so that "mbx empty" -> EOF.
2952
2953
2954 */
2955   if (info->in && !info->in_done) {               /* only for mode=w */
2956         if (info->in->shut_on_empty && info->in->need_wake) {
2957             info->in->need_wake = FALSE;
2958             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2959         } else {
2960             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2961         }
2962   }
2963
2964   if (info->out && !info->out_done) {             /* were we also piping output? */
2965       info->out->shut_on_empty = TRUE;
2966       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2967       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2968       _ckvmssts_noperl(iss);
2969   }
2970
2971   if (info->err && !info->err_done) {        /* we were piping stderr */
2972         info->err->shut_on_empty = TRUE;
2973         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2974         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2975         _ckvmssts_noperl(iss);
2976   }
2977   _ckvmssts_noperl(sys$setef(pipe_ef));
2978
2979 }
2980
2981 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2982 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2983
2984 /*
2985     we actually differ from vmstrnenv since we use this to
2986     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2987     are pointing to the same thing
2988 */
2989
2990 static unsigned short
2991 popen_translate(pTHX_ char *logical, char *result)
2992 {
2993     int iss;
2994     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2995     $DESCRIPTOR(d_log,"");
2996     struct _il3 {
2997         unsigned short length;
2998         unsigned short code;
2999         char *         buffer_addr;
3000         unsigned short *retlenaddr;
3001     } itmlst[2];
3002     unsigned short l, ifi;
3003
3004     d_log.dsc$a_pointer = logical;
3005     d_log.dsc$w_length  = strlen(logical);
3006
3007     itmlst[0].code = LNM$_STRING;
3008     itmlst[0].length = 255;
3009     itmlst[0].buffer_addr = result;
3010     itmlst[0].retlenaddr = &l;
3011
3012     itmlst[1].code = 0;
3013     itmlst[1].length = 0;
3014     itmlst[1].buffer_addr = 0;
3015     itmlst[1].retlenaddr = 0;
3016
3017     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3018     if (iss == SS$_NOLOGNAM) {
3019         iss = SS$_NORMAL;
3020         l = 0;
3021     }
3022     if (!(iss&1)) lib$signal(iss);
3023     result[l] = '\0';
3024 /*
3025     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3026     strip it off and return the ifi, if any
3027 */
3028     ifi  = 0;
3029     if (result[0] == 0x1b && result[1] == 0x00) {
3030         memmove(&ifi,result+2,2);
3031         strcpy(result,result+4);
3032     }
3033     return ifi;     /* this is the RMS internal file id */
3034 }
3035
3036 static void pipe_infromchild_ast(pPipe p);
3037
3038 /*
3039     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3040     inside an AST routine without worrying about reentrancy and which Perl
3041     memory allocator is being used.
3042
3043     We read data and queue up the buffers, then spit them out one at a
3044     time to the output mailbox when the output mailbox is ready for one.
3045
3046 */
3047 #define INITIAL_TOCHILDQUEUE  2
3048
3049 static pPipe
3050 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3051 {
3052     pPipe p;
3053     pCBuf b;
3054     char mbx1[64], mbx2[64];
3055     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3056                                       DSC$K_CLASS_S, mbx1},
3057                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3058                                       DSC$K_CLASS_S, mbx2};
3059     unsigned int dviitm = DVI$_DEVBUFSIZ;
3060     int j, n;
3061
3062     n = sizeof(Pipe);
3063     _ckvmssts(lib$get_vm(&n, &p));
3064
3065     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3066     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3067     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3068
3069     p->buf           = 0;
3070     p->shut_on_empty = FALSE;
3071     p->need_wake     = FALSE;
3072     p->type          = 0;
3073     p->retry         = 0;
3074     p->iosb.status   = SS$_NORMAL;
3075     p->iosb2.status  = SS$_NORMAL;
3076     p->free          = RQE_ZERO;
3077     p->wait          = RQE_ZERO;
3078     p->curr          = 0;
3079     p->curr2         = 0;
3080     p->info          = 0;
3081 #ifdef PERL_IMPLICIT_CONTEXT
3082     p->thx           = aTHX;
3083 #endif
3084
3085     n = sizeof(CBuf) + p->bufsize;
3086
3087     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3088         _ckvmssts(lib$get_vm(&n, &b));
3089         b->buf = (char *) b + sizeof(CBuf);
3090         _ckvmssts(lib$insqhi(b, &p->free));
3091     }
3092
3093     pipe_tochild2_ast(p);
3094     pipe_tochild1_ast(p);
3095     strcpy(wmbx, mbx1);
3096     strcpy(rmbx, mbx2);
3097     return p;
3098 }
3099
3100 /*  reads the MBX Perl is writing, and queues */
3101
3102 static void
3103 pipe_tochild1_ast(pPipe p)
3104 {
3105     pCBuf b = p->curr;
3106     int iss = p->iosb.status;
3107     int eof = (iss == SS$_ENDOFFILE);
3108     int sts;
3109 #ifdef PERL_IMPLICIT_CONTEXT
3110     pTHX = p->thx;
3111 #endif
3112
3113     if (p->retry) {
3114         if (eof) {
3115             p->shut_on_empty = TRUE;
3116             b->eof     = TRUE;
3117             _ckvmssts(sys$dassgn(p->chan_in));
3118         } else  {
3119             _ckvmssts(iss);
3120         }
3121
3122         b->eof  = eof;
3123         b->size = p->iosb.count;
3124         _ckvmssts(sts = lib$insqhi(b, &p->wait));
3125         if (p->need_wake) {
3126             p->need_wake = FALSE;
3127             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3128         }
3129     } else {
3130         p->retry = 1;   /* initial call */
3131     }
3132
3133     if (eof) {                  /* flush the free queue, return when done */
3134         int n = sizeof(CBuf) + p->bufsize;
3135         while (1) {
3136             iss = lib$remqti(&p->free, &b);
3137             if (iss == LIB$_QUEWASEMP) return;
3138             _ckvmssts(iss);
3139             _ckvmssts(lib$free_vm(&n, &b));
3140         }
3141     }
3142
3143     iss = lib$remqti(&p->free, &b);
3144     if (iss == LIB$_QUEWASEMP) {
3145         int n = sizeof(CBuf) + p->bufsize;
3146         _ckvmssts(lib$get_vm(&n, &b));
3147         b->buf = (char *) b + sizeof(CBuf);
3148     } else {
3149        _ckvmssts(iss);
3150     }
3151
3152     p->curr = b;
3153     iss = sys$qio(0,p->chan_in,
3154              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3155              &p->iosb,
3156              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3157     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3158     _ckvmssts(iss);
3159 }
3160
3161
3162 /* writes queued buffers to output, waits for each to complete before
3163    doing the next */
3164
3165 static void
3166 pipe_tochild2_ast(pPipe p)
3167 {
3168     pCBuf b = p->curr2;
3169     int iss = p->iosb2.status;
3170     int n = sizeof(CBuf) + p->bufsize;
3171     int done = (p->info && p->info->done) ||
3172               iss == SS$_CANCEL || iss == SS$_ABORT;
3173 #if defined(PERL_IMPLICIT_CONTEXT)
3174     pTHX = p->thx;
3175 #endif
3176
3177     do {
3178         if (p->type) {         /* type=1 has old buffer, dispose */
3179             if (p->shut_on_empty) {
3180                 _ckvmssts(lib$free_vm(&n, &b));
3181             } else {
3182                 _ckvmssts(lib$insqhi(b, &p->free));
3183             }
3184             p->type = 0;
3185         }
3186
3187         iss = lib$remqti(&p->wait, &b);
3188         if (iss == LIB$_QUEWASEMP) {
3189             if (p->shut_on_empty) {
3190                 if (done) {
3191                     _ckvmssts(sys$dassgn(p->chan_out));
3192                     *p->pipe_done = TRUE;
3193                     _ckvmssts(sys$setef(pipe_ef));
3194                 } else {
3195                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3196                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3197                 }
3198                 return;
3199             }
3200             p->need_wake = TRUE;
3201             return;
3202         }
3203         _ckvmssts(iss);
3204         p->type = 1;
3205     } while (done);
3206
3207
3208     p->curr2 = b;
3209     if (b->eof) {
3210         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3211             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3212     } else {
3213         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3214             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3215     }
3216
3217     return;
3218
3219 }
3220
3221
3222 static pPipe
3223 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3224 {
3225     pPipe p;
3226     char mbx1[64], mbx2[64];
3227     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3228                                       DSC$K_CLASS_S, mbx1},
3229                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3230                                       DSC$K_CLASS_S, mbx2};
3231     unsigned int dviitm = DVI$_DEVBUFSIZ;
3232
3233     int n = sizeof(Pipe);
3234     _ckvmssts(lib$get_vm(&n, &p));
3235     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3236     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3237
3238     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3239     n = p->bufsize * sizeof(char);
3240     _ckvmssts(lib$get_vm(&n, &p->buf));
3241     p->shut_on_empty = FALSE;
3242     p->info   = 0;
3243     p->type   = 0;
3244     p->iosb.status = SS$_NORMAL;
3245 #if defined(PERL_IMPLICIT_CONTEXT)
3246     p->thx = aTHX;
3247 #endif
3248     pipe_infromchild_ast(p);
3249
3250     strcpy(wmbx, mbx1);
3251     strcpy(rmbx, mbx2);
3252     return p;
3253 }
3254
3255 static void
3256 pipe_infromchild_ast(pPipe p)
3257 {
3258     int iss = p->iosb.status;
3259     int eof = (iss == SS$_ENDOFFILE);
3260     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3261     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3262 #if defined(PERL_IMPLICIT_CONTEXT)
3263     pTHX = p->thx;
3264 #endif
3265
3266     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3267         _ckvmssts(sys$dassgn(p->chan_out));
3268         p->chan_out = 0;
3269     }
3270
3271     /* read completed:
3272             input shutdown if EOF from self (done or shut_on_empty)
3273             output shutdown if closing flag set (my_pclose)
3274             send data/eof from child or eof from self
3275             otherwise, re-read (snarf of data from child)
3276     */
3277
3278     if (p->type == 1) {
3279         p->type = 0;
3280         if (myeof && p->chan_in) {                  /* input shutdown */
3281             _ckvmssts(sys$dassgn(p->chan_in));
3282             p->chan_in = 0;
3283         }
3284
3285         if (p->chan_out) {
3286             if (myeof || kideof) {      /* pass EOF to parent */
3287                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3288                               pipe_infromchild_ast, p,
3289                               0, 0, 0, 0, 0, 0));
3290                 return;
3291             } else if (eof) {       /* eat EOF --- fall through to read*/
3292
3293             } else {                /* transmit data */
3294                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3295                               pipe_infromchild_ast,p,
3296                               p->buf, p->iosb.count, 0, 0, 0, 0));
3297                 return;
3298             }
3299         }
3300     }
3301
3302     /*  everything shut? flag as done */
3303
3304     if (!p->chan_in && !p->chan_out) {
3305         *p->pipe_done = TRUE;
3306         _ckvmssts(sys$setef(pipe_ef));
3307         return;
3308     }
3309
3310     /* write completed (or read, if snarfing from child)
3311             if still have input active,
3312                queue read...immediate mode if shut_on_empty so we get EOF if empty
3313             otherwise,
3314                check if Perl reading, generate EOFs as needed
3315     */
3316
3317     if (p->type == 0) {
3318         p->type = 1;
3319         if (p->chan_in) {
3320             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3321                           pipe_infromchild_ast,p,
3322                           p->buf, p->bufsize, 0, 0, 0, 0);
3323             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3324             _ckvmssts(iss);
3325         } else {           /* send EOFs for extra reads */
3326             p->iosb.status = SS$_ENDOFFILE;
3327             p->iosb.dvispec = 0;
3328             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3329                       0, 0, 0,
3330                       pipe_infromchild_ast, p, 0, 0, 0, 0));
3331         }
3332     }
3333 }
3334
3335 static pPipe
3336 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3337 {
3338     pPipe p;
3339     char mbx[64];
3340     unsigned long dviitm = DVI$_DEVBUFSIZ;
3341     struct stat s;
3342     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3343                                       DSC$K_CLASS_S, mbx};
3344     int n = sizeof(Pipe);
3345
3346     /* things like terminals and mbx's don't need this filter */
3347     if (fd && fstat(fd,&s) == 0) {
3348         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3349         char device[65];
3350         unsigned short dev_len;
3351         struct dsc$descriptor_s d_dev;
3352         char * cptr;
3353         struct item_list_3 items[3];
3354         int status;
3355         unsigned short dvi_iosb[4];
3356
3357         cptr = getname(fd, out, 1);
3358         if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3359         d_dev.dsc$a_pointer = out;
3360         d_dev.dsc$w_length = strlen(out);
3361         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3362         d_dev.dsc$b_class = DSC$K_CLASS_S;
3363
3364         items[0].len = 4;
3365         items[0].code = DVI$_DEVCHAR;
3366         items[0].bufadr = &devchar;
3367         items[0].retadr = NULL;
3368         items[1].len = 64;
3369         items[1].code = DVI$_FULLDEVNAM;
3370         items[1].bufadr = device;
3371         items[1].retadr = &dev_len;
3372         items[2].len = 0;
3373         items[2].code = 0;
3374
3375         status = sys$getdviw
3376                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3377         _ckvmssts(status);
3378         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3379             device[dev_len] = 0;
3380
3381             if (!(devchar & DEV$M_DIR)) {
3382                 strcpy(out, device);
3383                 return 0;
3384             }
3385         }
3386     }
3387
3388     _ckvmssts(lib$get_vm(&n, &p));
3389     p->fd_out = dup(fd);
3390     create_mbx(aTHX_ &p->chan_in, &d_mbx);
3391     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3392     n = (p->bufsize+1) * sizeof(char);
3393     _ckvmssts(lib$get_vm(&n, &p->buf));
3394     p->shut_on_empty = FALSE;
3395     p->retry = 0;
3396     p->info  = 0;
3397     strcpy(out, mbx);
3398
3399     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3400                   pipe_mbxtofd_ast, p,
3401                   p->buf, p->bufsize, 0, 0, 0, 0));
3402
3403     return p;
3404 }
3405
3406 static void
3407 pipe_mbxtofd_ast(pPipe p)
3408 {
3409     int iss = p->iosb.status;
3410     int done = p->info->done;
3411     int iss2;
3412     int eof = (iss == SS$_ENDOFFILE);
3413     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3414     int err = !(iss&1) && !eof;
3415 #if defined(PERL_IMPLICIT_CONTEXT)
3416     pTHX = p->thx;
3417 #endif
3418
3419     if (done && myeof) {               /* end piping */
3420         close(p->fd_out);
3421         sys$dassgn(p->chan_in);
3422         *p->pipe_done = TRUE;
3423         _ckvmssts(sys$setef(pipe_ef));
3424         return;
3425     }
3426
3427     if (!err && !eof) {             /* good data to send to file */
3428         p->buf[p->iosb.count] = '\n';
3429         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3430         if (iss2 < 0) {
3431             p->retry++;
3432             if (p->retry < MAX_RETRY) {
3433                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3434                 return;
3435             }
3436         }
3437         p->retry = 0;
3438     } else if (err) {
3439         _ckvmssts(iss);
3440     }
3441
3442
3443     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3444           pipe_mbxtofd_ast, p,
3445           p->buf, p->bufsize, 0, 0, 0, 0);
3446     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3447     _ckvmssts(iss);
3448 }
3449
3450
3451 typedef struct _pipeloc     PLOC;
3452 typedef struct _pipeloc*   pPLOC;
3453
3454 struct _pipeloc {
3455     pPLOC   next;
3456     char    dir[NAM$C_MAXRSS+1];
3457 };
3458 static pPLOC  head_PLOC = 0;
3459
3460 void
3461 free_pipelocs(pTHX_ void *head)
3462 {
3463     pPLOC p, pnext;
3464     pPLOC *pHead = (pPLOC *)head;
3465
3466     p = *pHead;
3467     while (p) {
3468         pnext = p->next;
3469         PerlMem_free(p);
3470         p = pnext;
3471     }
3472     *pHead = 0;
3473 }
3474
3475 static void
3476 store_pipelocs(pTHX)
3477 {
3478     int    i;
3479     pPLOC  p;
3480     AV    *av = 0;
3481     SV    *dirsv;
3482     GV    *gv;
3483     char  *dir, *x;
3484     char  *unixdir;
3485     char  temp[NAM$C_MAXRSS+1];
3486     STRLEN n_a;
3487
3488     if (head_PLOC)
3489         free_pipelocs(aTHX_ &head_PLOC);
3490
3491 /*  the . directory from @INC comes last */
3492
3493     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3494     if (p == NULL) _ckvmssts(SS$_INSFMEM);
3495     p->next = head_PLOC;
3496     head_PLOC = p;
3497     strcpy(p->dir,"./");
3498
3499 /*  get the directory from $^X */
3500
3501     unixdir = PerlMem_malloc(VMS_MAXRSS);
3502     if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3503
3504 #ifdef PERL_IMPLICIT_CONTEXT
3505     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3506 #else
3507     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3508 #endif
3509         strcpy(temp, PL_origargv[0]);
3510         x = strrchr(temp,']');
3511         if (x == NULL) {
3512         x = strrchr(temp,'>');
3513           if (x == NULL) {
3514             /* It could be a UNIX path */
3515             x = strrchr(temp,'/');
3516           }
3517         }
3518         if (x)
3519           x[1] = '\0';
3520         else {
3521           /* Got a bare name, so use default directory */
3522           temp[0] = '.';
3523           temp[1] = '\0';
3524         }
3525
3526         if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3527             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3528             if (p == NULL) _ckvmssts(SS$_INSFMEM);
3529             p->next = head_PLOC;
3530             head_PLOC = p;
3531             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3532             p->dir[NAM$C_MAXRSS] = '\0';
3533         }
3534     }
3535
3536 /*  reverse order of @INC entries, skip "." since entered above */
3537
3538 #ifdef PERL_IMPLICIT_CONTEXT
3539     if (aTHX)
3540 #endif
3541     if (PL_incgv) av = GvAVn(PL_incgv);
3542
3543     for (i = 0; av && i <= AvFILL(av); i++) {
3544         dirsv = *av_fetch(av,i,TRUE);
3545
3546         if (SvROK(dirsv)) continue;
3547         dir = SvPVx(dirsv,n_a);
3548         if (strcmp(dir,".") == 0) continue;
3549         if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3550             continue;
3551
3552         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3553         p->next = head_PLOC;
3554         head_PLOC = p;
3555         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3556         p->dir[NAM$C_MAXRSS] = '\0';
3557     }
3558
3559 /* most likely spot (ARCHLIB) put first in the list */
3560
3561 #ifdef ARCHLIB_EXP
3562     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3563         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3564         if (p == NULL) _ckvmssts(SS$_INSFMEM);
3565         p->next = head_PLOC;
3566         head_PLOC = p;
3567         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3568         p->dir[NAM$C_MAXRSS] = '\0';
3569     }
3570 #endif
3571     PerlMem_free(unixdir);
3572 }
3573
3574 static I32
3575 Perl_cando_by_name_int
3576    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3577 #if !defined(PERL_IMPLICIT_CONTEXT)
3578 #define cando_by_name_int               Perl_cando_by_name_int
3579 #else
3580 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3581 #endif
3582
3583 static char *
3584 find_vmspipe(pTHX)
3585 {
3586     static int   vmspipe_file_status = 0;
3587     static char  vmspipe_file[NAM$C_MAXRSS+1];
3588
3589     /* already found? Check and use ... need read+execute permission */
3590
3591     if (vmspipe_file_status == 1) {
3592         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3593          && cando_by_name_int
3594            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3595             return vmspipe_file;
3596         }
3597         vmspipe_file_status = 0;
3598     }
3599
3600     /* scan through stored @INC, $^X */
3601
3602     if (vmspipe_file_status == 0) {
3603         char file[NAM$C_MAXRSS+1];
3604         pPLOC  p = head_PLOC;
3605
3606         while (p) {
3607             char * exp_res;
3608             int dirlen;
3609             strcpy(file, p->dir);
3610             dirlen = strlen(file);
3611             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3612             file[NAM$C_MAXRSS] = '\0';
3613             p = p->next;
3614
3615             exp_res = do_rmsexpand
3616                 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3617             if (!exp_res) continue;
3618
3619             if (cando_by_name_int
3620                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3621              && cando_by_name_int
3622                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3623                 vmspipe_file_status = 1;
3624                 return vmspipe_file;
3625             }
3626         }
3627         vmspipe_file_status = -1;   /* failed, use tempfiles */
3628     }
3629
3630     return 0;
3631 }
3632
3633 static FILE *
3634 vmspipe_tempfile(pTHX)
3635 {
3636     char file[NAM$C_MAXRSS+1];
3637     FILE *fp;
3638     static int index = 0;
3639     Stat_t s0, s1;
3640     int cmp_result;
3641
3642     /* create a tempfile */
3643
3644     /* we can't go from   W, shr=get to  R, shr=get without
3645        an intermediate vulnerable state, so don't bother trying...
3646
3647        and lib$spawn doesn't shr=put, so have to close the write
3648
3649        So... match up the creation date/time and the FID to
3650        make sure we're dealing with the same file
3651
3652     */
3653
3654     index++;
3655     if (!decc_filename_unix_only) {
3656       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3657       fp = fopen(file,"w");
3658       if (!fp) {
3659         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3660         fp = fopen(file,"w");
3661         if (!fp) {
3662             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3663             fp = fopen(file,"w");
3664         }
3665       }
3666      }
3667      else {
3668       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3669       fp = fopen(file,"w");
3670       if (!fp) {
3671         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3672         fp = fopen(file,"w");
3673         if (!fp) {
3674           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3675           fp = fopen(file,"w");
3676         }
3677       }
3678     }
3679     if (!fp) return 0;  /* we're hosed */
3680
3681     fprintf(fp,"$! 'f$verify(0)'\n");
3682     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3683     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3684     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3685     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3686     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3687     fprintf(fp,"$ perl_del    = \"delete\"\n");
3688     fprintf(fp,"$ pif         = \"if\"\n");
3689     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3690     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3691     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3692     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3693     fprintf(fp,"$!  --- build command line to get max possible length\n");
3694     fprintf(fp,"$c=perl_popen_cmd0\n");
3695     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3696     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3697     fprintf(fp,"$x=perl_popen_cmd3\n");
3698     fprintf(fp,"$c=c+x\n");
3699     fprintf(fp,"$ perl_on\n");
3700     fprintf(fp,"$ 'c'\n");
3701     fprintf(fp,"$ perl_status = $STATUS\n");
3702     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3703     fprintf(fp,"$ perl_exit 'perl_status'\n");
3704     fsync(fileno(fp));
3705
3706     fgetname(fp, file, 1);
3707     fstat(fileno(fp), (struct stat *)&s0);
3708     fclose(fp);
3709
3710     if (decc_filename_unix_only)
3711         do_tounixspec(file, file, 0, NULL);
3712     fp = fopen(file,"r","shr=get");
3713     if (!fp) return 0;
3714     fstat(fileno(fp), (struct stat *)&s1);
3715
3716     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3717     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3718         fclose(fp);
3719         return 0;
3720     }
3721
3722     return fp;
3723 }
3724
3725
3726
3727 static PerlIO *
3728 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3729 {
3730     static int handler_set_up = FALSE;
3731     unsigned long int sts, flags = CLI$M_NOWAIT;
3732     /* The use of a GLOBAL table (as was done previously) rendered
3733      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3734      * environment.  Hence we've switched to LOCAL symbol table.
3735      */
3736     unsigned int table = LIB$K_CLI_LOCAL_SYM;
3737     int j, wait = 0, n;
3738     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3739     char *in, *out, *err, mbx[512];
3740     FILE *tpipe = 0;
3741     char tfilebuf[NAM$C_MAXRSS+1];
3742     pInfo info = NULL;
3743     char cmd_sym_name[20];
3744     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3745                                       DSC$K_CLASS_S, symbol};
3746     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3747                                       DSC$K_CLASS_S, 0};
3748     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3749                                       DSC$K_CLASS_S, cmd_sym_name};
3750     struct dsc$descriptor_s *vmscmd;
3751     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3752     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3753     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3754
3755     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
3756
3757     /* once-per-program initialization...
3758        note that the SETAST calls and the dual test of pipe_ef
3759        makes sure that only the FIRST thread through here does
3760        the initialization...all other threads wait until it's
3761        done.
3762
3763        Yeah, uglier than a pthread call, it's got all the stuff inline
3764        rather than in a separate routine.
3765     */
3766
3767     if (!pipe_ef) {
3768         _ckvmssts(sys$setast(0));
3769         if (!pipe_ef) {
3770             unsigned long int pidcode = JPI$_PID;
3771             $DESCRIPTOR(d_delay, RETRY_DELAY);
3772             _ckvmssts(lib$get_ef(&pipe_ef));
3773             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3774             _ckvmssts(sys$bintim(&d_delay, delaytime));
3775         }
3776         if (!handler_set_up) {
3777           _ckvmssts(sys$dclexh(&pipe_exitblock));
3778           handler_set_up = TRUE;
3779         }
3780         _ckvmssts(sys$setast(1));
3781     }
3782
3783     /* see if we can find a VMSPIPE.COM */
3784
3785     tfilebuf[0] = '@';
3786     vmspipe = find_vmspipe(aTHX);
3787     if (vmspipe) {
3788         strcpy(tfilebuf+1,vmspipe);
3789     } else {        /* uh, oh...we're in tempfile hell */
3790         tpipe = vmspipe_tempfile(aTHX);
3791         if (!tpipe) {       /* a fish popular in Boston */
3792             if (ckWARN(WARN_PIPE)) {
3793                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3794             }
3795         return Nullfp;
3796         }
3797         fgetname(tpipe,tfilebuf+1,1);
3798     }
3799     vmspipedsc.dsc$a_pointer = tfilebuf;
3800     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
3801
3802     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3803     if (!(sts & 1)) {
3804       switch (sts) {
3805         case RMS$_FNF:  case RMS$_DNF:
3806           set_errno(ENOENT); break;
3807         case RMS$_DIR:
3808           set_errno(ENOTDIR); break;
3809         case RMS$_DEV:
3810           set_errno(ENODEV); break;
3811         case RMS$_PRV:
3812           set_errno(EACCES); break;
3813         case RMS$_SYN:
3814           set_errno(EINVAL); break;
3815         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3816           set_errno(E2BIG); break;
3817         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3818           _ckvmssts(sts); /* fall through */
3819         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3820           set_errno(EVMSERR);
3821       }
3822       set_vaxc_errno(sts);
3823       if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3824         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3825       }
3826       *psts = sts;
3827       return Nullfp;
3828     }
3829     n = sizeof(Info);
3830     _ckvmssts(lib$get_vm(&n, &info));
3831
3832     strcpy(mode,in_mode);
3833     info->mode = *mode;
3834     info->done = FALSE;
3835     info->completion = 0;
3836     info->closing    = FALSE;
3837     info->in         = 0;
3838     info->out        = 0;
3839     info->err        = 0;
3840     info->fp         = Nullfp;
3841     info->useFILE    = 0;
3842     info->waiting    = 0;
3843     info->in_done    = TRUE;
3844     info->out_done   = TRUE;
3845     info->err_done   = TRUE;
3846
3847     in = PerlMem_malloc(VMS_MAXRSS);
3848     if (in == NULL) _ckvmssts(SS$_INSFMEM);
3849     out = PerlMem_malloc(VMS_MAXRSS);
3850     if (out == NULL) _ckvmssts(SS$_INSFMEM);
3851     err = PerlMem_malloc(VMS_MAXRSS);
3852     if (err == NULL) _ckvmssts(SS$_INSFMEM);
3853
3854     in[0] = out[0] = err[0] = '\0';
3855
3856     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
3857         info->useFILE = 1;
3858         strcpy(p,p+1);
3859     }
3860     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
3861         wait = 1;
3862         strcpy(p,p+1);
3863     }
3864
3865     if (*mode == 'r') {             /* piping from subroutine */
3866
3867         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3868         if (info->out) {
3869             info->out->pipe_done = &info->out_done;
3870             info->out_done = FALSE;
3871             info->out->info = info;
3872         }
3873         if (!info->useFILE) {
3874         info->fp  = PerlIO_open(mbx, mode);
3875         } else {
3876             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3877             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3878         }
3879
3880         if (!info->fp && info->out) {
3881             sys$cancel(info->out->chan_out);
3882
3883             while (!info->out_done) {
3884                 int done;
3885                 _ckvmssts(sys$setast(0));
3886                 done = info->out_done;
3887                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3888                 _ckvmssts(sys$setast(1));
3889                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3890             }
3891
3892             if (info->out->buf) {
3893                 n = info->out->bufsize * sizeof(char);
3894                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3895             }
3896             n = sizeof(Pipe);
3897             _ckvmssts(lib$free_vm(&n, &info->out));
3898             n = sizeof(Info);
3899             _ckvmssts(lib$free_vm(&n, &info));
3900             *psts = RMS$_FNF;
3901             return Nullfp;
3902         }
3903
3904         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3905         if (info->err) {
3906             info->err->pipe_done = &info->err_done;
3907             info->err_done = FALSE;
3908             info->err->info = info;
3909         }
3910
3911     } else if (*mode == 'w') {      /* piping to subroutine */
3912
3913         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3914         if (info->out) {
3915             info->out->pipe_done = &info->out_done;
3916             info->out_done = FALSE;
3917             info->out->info = info;
3918         }
3919
3920         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3921         if (info->err) {
3922             info->err->pipe_done = &info->err_done;
3923             info->err_done = FALSE;
3924             info->err->info = info;
3925         }
3926
3927         info->in = pipe_tochild_setup(aTHX_ in,mbx);
3928         if (!info->useFILE) {
3929             info->fp  = PerlIO_open(mbx, mode);
3930         } else {
3931             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3932             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3933         }
3934
3935         if (info->in) {
3936             info->in->pipe_done = &info->in_done;
3937             info->in_done = FALSE;
3938             info->in->info = info;
3939         }
3940
3941         /* error cleanup */
3942         if (!info->fp && info->in) {
3943             info->done = TRUE;
3944             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3945                               0, 0, 0, 0, 0, 0, 0, 0));
3946
3947             while (!info->in_done) {
3948                 int done;
3949                 _ckvmssts(sys$setast(0));
3950                 done = info->in_done;
3951                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3952                 _ckvmssts(sys$setast(1));
3953                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3954             }
3955
3956             if (info->in->buf) {
3957                 n = info->in->bufsize * sizeof(char);
3958                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3959             }
3960             n = sizeof(Pipe);
3961             _ckvmssts(lib$free_vm(&n, &info->in));
3962             n = sizeof(Info);
3963             _ckvmssts(lib$free_vm(&n, &info));
3964             *psts = RMS$_FNF;
3965             return Nullfp;
3966         }
3967
3968
3969     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
3970         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3971         if (info->out) {
3972             info->out->pipe_done = &info->out_done;
3973             info->out_done = FALSE;
3974             info->out->info = info;
3975         }
3976
3977         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3978         if (info->err) {
3979             info->err->pipe_done = &info->err_done;
3980             info->err_done = FALSE;
3981             info->err->info = info;
3982         }
3983     }
3984
3985     symbol[MAX_DCL_SYMBOL] = '\0';
3986
3987     strncpy(symbol, in, MAX_DCL_SYMBOL);
3988     d_symbol.dsc$w_length = strlen(symbol);
3989     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3990
3991     strncpy(symbol, err, MAX_DCL_SYMBOL);
3992     d_symbol.dsc$w_length = strlen(symbol);
3993     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3994
3995     strncpy(symbol, out, MAX_DCL_SYMBOL);
3996     d_symbol.dsc$w_length = strlen(symbol);
3997     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
3998
3999     /* Done with the names for the pipes */
4000     PerlMem_free(err);
4001     PerlMem_free(out);
4002     PerlMem_free(in);
4003
4004     p = vmscmd->dsc$a_pointer;
4005     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4006     if (*p == '$') p++;                         /* remove leading $ */
4007     while (*p == ' ' || *p == '\t') p++;
4008
4009     for (j = 0; j < 4; j++) {
4010         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4011         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4012
4013     strncpy(symbol, p, MAX_DCL_SYMBOL);
4014     d_symbol.dsc$w_length = strlen(symbol);
4015     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4016
4017         if (strlen(p) > MAX_DCL_SYMBOL) {
4018             p += MAX_DCL_SYMBOL;
4019         } else {
4020             p += strlen(p);
4021         }
4022     }
4023     _ckvmssts(sys$setast(0));
4024     info->next=open_pipes;  /* prepend to list */
4025     open_pipes=info;
4026     _ckvmssts(sys$setast(1));
4027     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4028      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4029      * have SYS$COMMAND if we need it.
4030      */
4031     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4032                       0, &info->pid, &info->completion,
4033                       0, popen_completion_ast,info,0,0,0));
4034
4035     /* if we were using a tempfile, close it now */
4036
4037     if (tpipe) fclose(tpipe);
4038
4039     /* once the subprocess is spawned, it has copied the symbols and
4040        we can get rid of ours */
4041
4042     for (j = 0; j < 4; j++) {
4043         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4044         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4045     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4046     }
4047     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
4048     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4049     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4050     vms_execfree(vmscmd);
4051
4052 #ifdef PERL_IMPLICIT_CONTEXT
4053     if (aTHX)
4054 #endif
4055     PL_forkprocess = info->pid;
4056
4057     if (wait) {
4058          int done = 0;
4059          while (!done) {
4060              _ckvmssts(sys$setast(0));
4061              done = info->done;
4062              if (!done) _ckvmssts(sys$clref(pipe_ef));
4063              _ckvmssts(sys$setast(1));
4064              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4065          }
4066         *psts = info->completion;
4067 /* Caller thinks it is open and tries to close it. */
4068 /* This causes some problems, as it changes the error status */
4069 /*        my_pclose(info->fp); */
4070     } else {
4071         *psts = SS$_NORMAL;
4072     }
4073     return info->fp;
4074 }  /* end of safe_popen */
4075
4076
4077 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4078 PerlIO *
4079 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4080 {
4081     int sts;
4082     TAINT_ENV();
4083     TAINT_PROPER("popen");
4084     PERL_FLUSHALL_FOR_CHILD;
4085     return safe_popen(aTHX_ cmd,mode,&sts);
4086 }
4087
4088 /*}}}*/
4089
4090 /*{{{  I32 my_pclose(PerlIO *fp)*/
4091 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4092 {
4093     pInfo info, last = NULL;
4094     unsigned long int retsts;
4095     int done, iss, n;
4096
4097     for (info = open_pipes; info != NULL; last = info, info = info->next)
4098         if (info->fp == fp) break;
4099
4100     if (info == NULL) {  /* no such pipe open */
4101       set_errno(ECHILD); /* quoth POSIX */
4102       set_vaxc_errno(SS$_NONEXPR);
4103       return -1;
4104     }
4105
4106     /* If we were writing to a subprocess, insure that someone reading from
4107      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4108      * produce an EOF record in the mailbox.
4109      *
4110      *  well, at least sometimes it *does*, so we have to watch out for
4111      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4112      */
4113      if (info->fp) {
4114         if (!info->useFILE)
4115             PerlIO_flush(info->fp);   /* first, flush data */
4116         else
4117             fflush((FILE *)info->fp);
4118     }
4119
4120     _ckvmssts(sys$setast(0));
4121      info->closing = TRUE;
4122      done = info->done && info->in_done && info->out_done && info->err_done;
4123      /* hanging on write to Perl's input? cancel it */
4124      if (info->mode == 'r' && info->out && !info->out_done) {
4125         if (info->out->chan_out) {
4126             _ckvmssts(sys$cancel(info->out->chan_out));
4127             if (!info->out->chan_in) {   /* EOF generation, need AST */
4128                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4129             }
4130         }
4131      }
4132      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4133          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4134                            0, 0, 0, 0, 0, 0));
4135     _ckvmssts(sys$setast(1));
4136     if (info->fp) {
4137      if (!info->useFILE)
4138         PerlIO_close(info->fp);
4139      else
4140         fclose((FILE *)info->fp);
4141     }
4142      /*
4143         we have to wait until subprocess completes, but ALSO wait until all
4144         the i/o completes...otherwise we'll be freeing the "info" structure
4145         that the i/o ASTs could still be using...
4146      */
4147
4148      while (!done) {
4149          _ckvmssts(sys$setast(0));
4150          done = info->done && info->in_done && info->out_done && info->err_done;
4151          if (!done) _ckvmssts(sys$clref(pipe_ef));
4152          _ckvmssts(sys$setast(1));
4153          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4154      }
4155      retsts = info->completion;
4156
4157     /* remove from list of open pipes */
4158     _ckvmssts(sys$setast(0));
4159     if (last) last->next = info->next;
4160     else open_pipes = info->next;
4161     _ckvmssts(sys$setast(1));
4162
4163     /* free buffers and structures */
4164
4165     if (info->in) {
4166         if (info->in->buf) {
4167             n = info->in->bufsize * sizeof(char);
4168             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4169         }
4170         n = sizeof(Pipe);
4171         _ckvmssts(lib$free_vm(&n, &info->in));
4172     }
4173     if (info->out) {
4174         if (info->out->buf) {
4175             n = info->out->bufsize * sizeof(char);
4176             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4177         }
4178         n = sizeof(Pipe);
4179         _ckvmssts(lib$free_vm(&n, &info->out));
4180     }
4181     if (info->err) {
4182         if (info->err->buf) {
4183             n = info->err->bufsize * sizeof(char);
4184             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4185         }
4186         n = sizeof(Pipe);
4187         _ckvmssts(lib$free_vm(&n, &info->err));
4188     }
4189     n = sizeof(Info);
4190     _ckvmssts(lib$free_vm(&n, &info));
4191
4192     return retsts;
4193
4194 }  /* end of my_pclose() */
4195
4196 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4197   /* Roll our own prototype because we want this regardless of whether
4198    * _VMS_WAIT is defined.
4199    */
4200   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4201 #endif
4202 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4203    created with popen(); otherwise partially emulate waitpid() unless
4204    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4205    Also check processes not considered by the CRTL waitpid().
4206  */
4207 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4208 Pid_t
4209 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4210 {
4211     pInfo info;
4212     int done;
4213     int sts;
4214     int j;
4215
4216     if (statusp) *statusp = 0;
4217
4218     for (info = open_pipes; info != NULL; info = info->next)
4219         if (info->pid == pid) break;
4220
4221     if (info != NULL) {  /* we know about this child */
4222       while (!info->done) {
4223           _ckvmssts(sys$setast(0));
4224           done = info->done;
4225           if (!done) _ckvmssts(sys$clref(pipe_ef));
4226           _ckvmssts(sys$setast(1));
4227           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4228       }
4229
4230       if (statusp) *statusp = info->completion;
4231       return pid;
4232     }
4233
4234     /* child that already terminated? */
4235
4236     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4237         if (closed_list[j].pid == pid) {
4238             if (statusp) *statusp = closed_list[j].completion;
4239             return pid;
4240         }
4241     }
4242
4243     /* fall through if this child is not one of our own pipe children */
4244
4245 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4246
4247       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4248        * in 7.2 did we get a version that fills in the VMS completion
4249        * status as Perl has always tried to do.
4250        */
4251
4252       sts = __vms_waitpid( pid, statusp, flags );
4253
4254       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4255          return sts;
4256
4257       /* If the real waitpid tells us the child does not exist, we
4258        * fall through here to implement waiting for a child that
4259        * was created by some means other than exec() (say, spawned
4260        * from DCL) or to wait for a process that is not a subprocess
4261        * of the current process.
4262        */
4263
4264 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4265
4266     {
4267       $DESCRIPTOR(intdsc,"0 00:00:01");
4268       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4269       unsigned long int pidcode = JPI$_PID, mypid;
4270       unsigned long int interval[2];
4271       unsigned int jpi_iosb[2];
4272       struct itmlst_3 jpilist[2] = {
4273           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4274           {                      0,         0,                 0, 0}
4275       };
4276
4277       if (pid <= 0) {
4278         /* Sorry folks, we don't presently implement rooting around for
4279            the first child we can find, and we definitely don't want to
4280            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4281          */
4282         set_errno(ENOTSUP);
4283         return -1;
4284       }
4285
4286       /* Get the owner of the child so I can warn if it's not mine. If the
4287        * process doesn't exist or I don't have the privs to look at it,
4288        * I can go home early.
4289        */
4290       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4291       if (sts & 1) sts = jpi_iosb[0];
4292       if (!(sts & 1)) {
4293         switch (sts) {
4294             case SS$_NONEXPR:
4295                 set_errno(ECHILD);
4296                 break;
4297             case SS$_NOPRIV:
4298                 set_errno(EACCES);
4299                 break;
4300             default:
4301                 _ckvmssts(sts);
4302         }
4303         set_vaxc_errno(sts);
4304         return -1;
4305       }
4306
4307       if (ckWARN(WARN_EXEC)) {
4308         /* remind folks they are asking for non-standard waitpid behavior */
4309         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4310         if (ownerpid != mypid)
4311           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4312                       "waitpid: process %x is not a child of process %x",
4313                       pid,mypid);
4314       }
4315
4316       /* simply check on it once a second until it's not there anymore. */
4317
4318       _ckvmssts(sys$bintim(&intdsc,interval));
4319       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4320             _ckvmssts(sys$schdwk(0,0,interval,0));
4321             _ckvmssts(sys$hiber());
4322       }
4323       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4324
4325       _ckvmssts(sts);
4326       return pid;
4327     }
4328 }  /* end of waitpid() */
4329 /*}}}*/
4330 /*}}}*/
4331 /*}}}*/
4332
4333 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4334 char *
4335 my_gconvert(double val, int ndig, int trail, char *buf)
4336 {
4337   static char __gcvtbuf[DBL_DIG+1];
4338   char *loc;
4339
4340   loc = buf ? buf : __gcvtbuf;
4341
4342 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4343   if (val < 1) {
4344     sprintf(loc,"%.*g",ndig,val);
4345     return loc;
4346   }
4347 #endif
4348
4349   if (val) {
4350     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4351     return gcvt(val,ndig,loc);
4352   }
4353   else {
4354     loc[0] = '0'; loc[1] = '\0';
4355     return loc;
4356   }
4357
4358 }
4359 /*}}}*/
4360
4361 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4362 static int rms_free_search_context(struct FAB * fab)
4363 {
4364 struct NAM * nam;
4365
4366     nam = fab->fab$l_nam;
4367     nam->nam$b_nop |= NAM$M_SYNCHK;
4368     nam->nam$l_rlf = NULL;
4369     fab->fab$b_dns = 0;
4370     return sys$parse(fab, NULL, NULL);
4371 }
4372
4373 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4374 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4375 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4376 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4377 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4378 #define rms_nam_esll(nam) nam.nam$b_esl
4379 #define rms_nam_esl(nam) nam.nam$b_esl
4380 #define rms_nam_name(nam) nam.nam$l_name
4381 #define rms_nam_namel(nam) nam.nam$l_name
4382 #define rms_nam_type(nam) nam.nam$l_type
4383 #define rms_nam_typel(nam) nam.nam$l_type
4384 #define rms_nam_ver(nam) nam.nam$l_ver
4385 #define rms_nam_verl(nam) nam.nam$l_ver
4386 #define rms_nam_rsll(nam) nam.nam$b_rsl
4387 #define rms_nam_rsl(nam) nam.nam$b_rsl
4388 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4389 #define rms_set_fna(fab, nam, name, size) \
4390         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4391 #define rms_get_fna(fab, nam) fab.fab$l_fna
4392 #define rms_set_dna(fab, nam, name, size) \
4393         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4394 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4395 #define rms_set_esa(fab, nam, name, size) \
4396         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4397 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4398         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4399 #define rms_set_rsa(nam, name, size) \
4400         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4401 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4402         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4403 #define rms_nam_name_type_l_size(nam) \
4404         (nam.nam$b_name + nam.nam$b_type)
4405 #else
4406 static int rms_free_search_context(struct FAB * fab)
4407 {
4408 struct NAML * nam;
4409
4410     nam = fab->fab$l_naml;
4411     nam->naml$b_nop |= NAM$M_SYNCHK;
4412     nam->naml$l_rlf = NULL;
4413     nam->naml$l_long_defname_size = 0;
4414
4415     fab->fab$b_dns = 0;
4416     return sys$parse(fab, NULL, NULL);
4417 }
4418
4419 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4420 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4421 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4422 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4423 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4424 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4425 #define rms_nam_esl(nam) nam.naml$b_esl
4426 #define rms_nam_name(nam) nam.naml$l_name
4427 #define rms_nam_namel(nam) nam.naml$l_long_name
4428 #define rms_nam_type(nam) nam.naml$l_type
4429 #define rms_nam_typel(nam) nam.naml$l_long_type
4430 #define rms_nam_ver(nam) nam.naml$l_ver
4431 #define rms_nam_verl(nam) nam.naml$l_long_ver
4432 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4433 #define rms_nam_rsl(nam) nam.naml$b_rsl
4434 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4435 #define rms_set_fna(fab, nam, name, size) \
4436         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4437         nam.naml$l_long_filename_size = size; \
4438         nam.naml$l_long_filename = name;}
4439 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4440 #define rms_set_dna(fab, nam, name, size) \
4441         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4442         nam.naml$l_long_defname_size = size; \
4443         nam.naml$l_long_defname = name; }
4444 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4445 #define rms_set_esa(fab, nam, name, size) \
4446         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4447         nam.naml$l_long_expand_alloc = size; \
4448         nam.naml$l_long_expand = name; }
4449 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4450         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4451         nam.naml$l_long_expand = l_name; \
4452         nam.naml$l_long_expand_alloc = l_size; }
4453 #define rms_set_rsa(nam, name, size) \
4454         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4455         nam.naml$l_long_result = name; \
4456         nam.naml$l_long_result_alloc = size; }
4457 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4458         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4459         nam.naml$l_long_result = l_name; \
4460         nam.naml$l_long_result_alloc = l_size; }
4461 #define rms_nam_name_type_l_size(nam) \
4462         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4463 #endif
4464
4465
4466 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4467 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4468  * to expand file specification.  Allows for a single default file
4469  * specification and a simple mask of options.  If outbuf is non-NULL,
4470  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4471  * the resultant file specification is placed.  If outbuf is NULL, the
4472  * resultant file specification is placed into a static buffer.
4473  * The third argument, if non-NULL, is taken to be a default file
4474  * specification string.  The fourth argument is unused at present.
4475  * rmesexpand() returns the address of the resultant string if
4476  * successful, and NULL on error.
4477  *
4478  * New functionality for previously unused opts value:
4479  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4480  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
4481  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
4482  */
4483 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
4484
4485 static char *
4486 mp_do_rmsexpand
4487    (pTHX_ const char *filespec,
4488     char *outbuf,
4489     int ts,
4490     const char *defspec,
4491     unsigned opts,
4492     int * fs_utf8,
4493     int * dfs_utf8)
4494 {
4495   static char __rmsexpand_retbuf[VMS_MAXRSS];
4496   char * vmsfspec, *tmpfspec;
4497   char * esa, *cp, *out = NULL;
4498   char * tbuf;
4499   char * esal;
4500   char * outbufl;
4501   struct FAB myfab = cc$rms_fab;
4502   rms_setup_nam(mynam);
4503   STRLEN speclen;
4504   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4505   int sts;
4506
4507   /* temp hack until UTF8 is actually implemented */
4508   if (fs_utf8 != NULL)
4509     *fs_utf8 = 0;
4510
4511   if (!filespec || !*filespec) {
4512     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4513     return NULL;
4514   }
4515   if (!outbuf) {
4516     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4517     else    outbuf = __rmsexpand_retbuf;
4518   }
4519
4520   vmsfspec = NULL;
4521   tmpfspec = NULL;
4522   outbufl = NULL;
4523
4524   isunix = 0;
4525   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
4526     isunix = is_unix_filespec(filespec);
4527     if (isunix) {
4528       vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4529       if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4530       if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
4531         PerlMem_free(vmsfspec);
4532         if (out)
4533            Safefree(out);
4534         return NULL;
4535       }
4536       filespec = vmsfspec;
4537
4538       /* Unless we are forcing to VMS format, a UNIX input means
4539        * UNIX output, and that requires long names to be used
4540        */
4541       if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4542         opts |= PERL_RMSEXPAND_M_LONG;
4543       else {
4544         isunix = 0;
4545       }
4546     }
4547   }
4548
4549   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4550   rms_bind_fab_nam(myfab, mynam);
4551
4552   if (defspec && *defspec) {
4553     int t_isunix;
4554     t_isunix = is_unix_filespec(defspec);
4555     if (t_isunix) {
4556       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4557       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4558       if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
4559         PerlMem_free(tmpfspec);
4560         if (vmsfspec != NULL)
4561             PerlMem_free(vmsfspec);
4562         if (out)
4563            Safefree(out);
4564         return NULL;
4565       }
4566       defspec = tmpfspec;
4567     }
4568     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4569   }
4570
4571   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4572   if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4573 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4574   esal = PerlMem_malloc(VMS_MAXRSS);
4575   if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4576 #endif
4577   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
4578
4579   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4580     rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4581   }
4582   else {
4583 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4584     outbufl = PerlMem_malloc(VMS_MAXRSS);
4585     if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4586     rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4587 #else
4588     rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4589 #endif
4590   }
4591
4592 #ifdef NAM$M_NO_SHORT_UPCASE
4593   if (decc_efs_case_preserve)
4594     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4595 #endif
4596
4597   /* First attempt to parse as an existing file */
4598   retsts = sys$parse(&myfab,0,0);
4599   if (!(retsts & STS$K_SUCCESS)) {
4600
4601     /* Could not find the file, try as syntax only if error is not fatal */
4602     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4603     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4604       retsts = sys$parse(&myfab,0,0);
4605       if (retsts & STS$K_SUCCESS) goto expanded;
4606     }
4607
4608      /* Still could not parse the file specification */
4609     /*----------------------------------------------*/
4610     sts = rms_free_search_context(&myfab); /* Free search context */
4611     if (out) Safefree(out);
4612     if (tmpfspec != NULL)
4613         PerlMem_free(tmpfspec);
4614     if (vmsfspec != NULL)
4615         PerlMem_free(vmsfspec);
4616     if (outbufl != NULL)
4617         PerlMem_free(outbufl);
4618     PerlMem_free(esa);
4619     PerlMem_free(esal);
4620     set_vaxc_errno(retsts);
4621     if      (retsts == RMS$_PRV) set_errno(EACCES);
4622     else if (retsts == RMS$_DEV) set_errno(ENODEV);
4623     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4624     else                         set_errno(EVMSERR);
4625     return NULL;
4626   }
4627   retsts = sys$search(&myfab,0,0);
4628   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4629     sts = rms_free_search_context(&myfab); /* Free search context */
4630     if (out) Safefree(out);
4631     if (tmpfspec != NULL)
4632         PerlMem_free(tmpfspec);
4633     if (vmsfspec != NULL)
4634         PerlMem_free(vmsfspec);
4635     if (outbufl != NULL)
4636         PerlMem_free(outbufl);
4637     PerlMem_free(esa);
4638     PerlMem_free(esal);
4639     set_vaxc_errno(retsts);
4640     if      (retsts == RMS$_PRV) set_errno(EACCES);
4641     else                         set_errno(EVMSERR);
4642     return NULL;
4643   }
4644
4645   /* If the input filespec contained any lowercase characters,
4646    * downcase the result for compatibility with Unix-minded code. */
4647   expanded:
4648   if (!decc_efs_case_preserve) {
4649     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4650       if (islower(*tbuf)) { haslower = 1; break; }
4651   }
4652
4653    /* Is a long or a short name expected */
4654   /*------------------------------------*/
4655   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4656     if (rms_nam_rsll(mynam)) {
4657         tbuf = outbuf;
4658         speclen = rms_nam_rsll(mynam);
4659     }
4660     else {
4661         tbuf = esal; /* Not esa */
4662         speclen = rms_nam_esll(mynam);
4663     }
4664   }
4665   else {
4666     if (rms_nam_rsl(mynam)) {
4667         tbuf = outbuf;
4668         speclen = rms_nam_rsl(mynam);
4669     }
4670     else {
4671         tbuf = esa; /* Not esal */
4672         speclen = rms_nam_esl(mynam);
4673     }
4674   }
4675   tbuf[speclen] = '\0';
4676
4677   /* Trim off null fields added by $PARSE
4678    * If type > 1 char, must have been specified in original or default spec
4679    * (not true for version; $SEARCH may have added version of existing file).
4680    */
4681   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4682   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4683     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4684              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4685   }
4686   else {
4687     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4688              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4689   }
4690   if (trimver || trimtype) {
4691     if (defspec && *defspec) {
4692       char *defesal = NULL;
4693       defesal = PerlMem_malloc(NAML$C_MAXRSS + 1);
4694       if (defesal != NULL) {
4695         struct FAB deffab = cc$rms_fab;
4696         rms_setup_nam(defnam);
4697
4698         rms_bind_fab_nam(deffab, defnam);
4699
4700         /* Cast ok */
4701         rms_set_fna
4702             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4703
4704         rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4705
4706         rms_clear_nam_nop(defnam);
4707         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4708 #ifdef NAM$M_NO_SHORT_UPCASE
4709         if (decc_efs_case_preserve)
4710           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4711 #endif
4712         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4713           if (trimver) {
4714              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4715           }
4716           if (trimtype) {
4717             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4718           }
4719         }
4720         PerlMem_free(defesal);
4721       }
4722     }
4723     if (trimver) {
4724       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4725         if (*(rms_nam_verl(mynam)) != '\"')
4726           speclen = rms_nam_verl(mynam) - tbuf;
4727       }
4728       else {
4729         if (*(rms_nam_ver(mynam)) != '\"')
4730           speclen = rms_nam_ver(mynam) - tbuf;
4731       }
4732     }
4733     if (trimtype) {
4734       /* If we didn't already trim version, copy down */
4735       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4736         if (speclen > rms_nam_verl(mynam) - tbuf)
4737           memmove
4738            (rms_nam_typel(mynam),
4739             rms_nam_verl(mynam),
4740             speclen - (rms_nam_verl(mynam) - tbuf));
4741           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
4742       }
4743       else {
4744         if (speclen > rms_nam_ver(mynam) - tbuf)
4745           memmove
4746            (rms_nam_type(mynam),
4747             rms_nam_ver(mynam),
4748             speclen - (rms_nam_ver(mynam) - tbuf));
4749           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
4750       }
4751     }
4752   }
4753
4754    /* Done with these copies of the input files */
4755   /*-------------------------------------------*/
4756   if (vmsfspec != NULL)
4757         PerlMem_free(vmsfspec);
4758   if (tmpfspec != NULL)
4759         PerlMem_free(tmpfspec);
4760
4761   /* If we just had a directory spec on input, $PARSE "helpfully"
4762    * adds an empty name and type for us */
4763   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4764     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
4765         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
4766         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4767       speclen = rms_nam_namel(mynam) - tbuf;
4768   }
4769   else {
4770     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
4771         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
4772         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4773       speclen = rms_nam_name(mynam) - tbuf;
4774   }
4775
4776   /* Posix format specifications must have matching quotes */
4777   if (speclen < (VMS_MAXRSS - 1)) {
4778     if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
4779       if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
4780         tbuf[speclen] = '\"';
4781         speclen++;
4782       }
4783     }
4784   }
4785   tbuf[speclen] = '\0';
4786   if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
4787
4788   /* Have we been working with an expanded, but not resultant, spec? */
4789   /* Also, convert back to Unix syntax if necessary. */
4790
4791   if (!rms_nam_rsll(mynam)) {
4792     if (isunix) {
4793       if (do_tounixspec(esa,outbuf,0,fs_utf8) == NULL) {
4794         if (out) Safefree(out);
4795         PerlMem_free(esal);
4796         PerlMem_free(esa);
4797         if (outbufl != NULL)
4798             PerlMem_free(outbufl);
4799         return NULL;
4800       }
4801     }
4802     else strcpy(outbuf,esa);
4803   }
4804   else if (isunix) {
4805     tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4806     if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4807     if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) {
4808         if (out) Safefree(out);
4809         PerlMem_free(esa);
4810         PerlMem_free(esal);
4811         PerlMem_free(tmpfspec);
4812         if (outbufl != NULL)
4813             PerlMem_free(outbufl);
4814         return NULL;
4815     }
4816     strcpy(outbuf,tmpfspec);
4817     PerlMem_free(tmpfspec);
4818   }
4819
4820   rms_set_rsal(mynam, NULL, 0, NULL, 0);
4821   sts = rms_free_search_context(&myfab); /* Free search context */
4822   PerlMem_free(esa);
4823   PerlMem_free(esal);
4824   if (outbufl != NULL)
4825      PerlMem_free(outbufl);
4826   return outbuf;
4827 }
4828 /*}}}*/
4829 /* External entry points */
4830 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4831 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
4832 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4833 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
4834 char *Perl_rmsexpand_utf8
4835   (pTHX_ const char *spec, char *buf, const char *def,
4836    unsigned opt, int * fs_utf8, int * dfs_utf8)
4837 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
4838 char *Perl_rmsexpand_utf8_ts
4839   (pTHX_ const char *spec, char *buf, const char *def,
4840    unsigned opt, int * fs_utf8, int * dfs_utf8)
4841 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
4842
4843
4844 /*
4845 ** The following routines are provided to make life easier when
4846 ** converting among VMS-style and Unix-style directory specifications.
4847 ** All will take input specifications in either VMS or Unix syntax. On
4848 ** failure, all return NULL.  If successful, the routines listed below
4849 ** return a pointer to a buffer containing the appropriately
4850 ** reformatted spec (and, therefore, subsequent calls to that routine
4851 ** will clobber the result), while the routines of the same names with
4852 ** a _ts suffix appended will return a pointer to a mallocd string
4853 ** containing the appropriately reformatted spec.
4854 ** In all cases, only explicit syntax is altered; no check is made that
4855 ** the resulting string is valid or that the directory in question
4856 ** actually exists.
4857 **
4858 **   fileify_dirspec() - convert a directory spec into the name of the
4859 **     directory file (i.e. what you can stat() to see if it's a dir).
4860 **     The style (VMS or Unix) of the result is the same as the style
4861 **     of the parameter passed in.
4862 **   pathify_dirspec() - convert a directory spec into a path (i.e.
4863 **     what you prepend to a filename to indicate what directory it's in).
4864 **     The style (VMS or Unix) of the result is the same as the style
4865 **     of the parameter passed in.
4866 **   tounixpath() - convert a directory spec into a Unix-style path.
4867 **   tovmspath() - convert a directory spec into a VMS-style path.
4868 **   tounixspec() - convert any file spec into a Unix-style file spec.
4869 **   tovmsspec() - convert any file spec into a VMS-style spec.
4870 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
4871 **
4872 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
4873 ** Permission is given to distribute this code as part of the Perl
4874 ** standard distribution under the terms of the GNU General Public
4875 ** License or the Perl Artistic License.  Copies of each may be
4876 ** found in the Perl standard distribution.
4877  */
4878
4879 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
4880 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
4881 {
4882     static char __fileify_retbuf[VMS_MAXRSS];
4883     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
4884     char *retspec, *cp1, *cp2, *lastdir;
4885     char *trndir, *vmsdir;
4886     unsigned short int trnlnm_iter_count;
4887     int sts;
4888     if (utf8_fl != NULL)
4889         *utf8_fl = 0;
4890
4891     if (!dir || !*dir) {
4892       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4893     }
4894     dirlen = strlen(dir);
4895     while (dirlen && dir[dirlen-1] == '/') --dirlen;
4896     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
4897       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4898         dir = "/sys$disk";
4899         dirlen = 9;
4900       }
4901       else
4902         dirlen = 1;
4903     }
4904     if (dirlen > (VMS_MAXRSS - 1)) {
4905       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
4906       return NULL;
4907     }
4908     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
4909     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
4910     if (!strpbrk(dir+1,"/]>:")  &&
4911         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
4912       strcpy(trndir,*dir == '/' ? dir + 1: dir);
4913       trnlnm_iter_count = 0;
4914       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4915         trnlnm_iter_count++;
4916         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4917       }
4918       dirlen = strlen(trndir);
4919     }
4920     else {
4921       strncpy(trndir,dir,dirlen);
4922       trndir[dirlen] = '\0';
4923     }
4924
4925     /* At this point we are done with *dir and use *trndir which is a
4926      * copy that can be modified.  *dir must not be modified.
4927      */
4928
4929     /* If we were handed a rooted logical name or spec, treat it like a
4930      * simple directory, so that
4931      *    $ Define myroot dev:[dir.]
4932      *    ... do_fileify_dirspec("myroot",buf,1) ...
4933      * does something useful.
4934      */
4935     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4936       trndir[--dirlen] = '\0';
4937       trndir[dirlen-1] = ']';
4938     }
4939     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4940       trndir[--dirlen] = '\0';
4941       trndir[dirlen-1] = '>';
4942     }
4943
4944     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4945       /* If we've got an explicit filename, we can just shuffle the string. */
4946       if (*(cp1+1)) hasfilename = 1;
4947       /* Similarly, we can just back up a level if we've got multiple levels
4948          of explicit directories in a VMS spec which ends with directories. */
4949       else {
4950         for (cp2 = cp1; cp2 > trndir; cp2--) {
4951           if (*cp2 == '.') {
4952             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4953 /* fix-me, can not scan EFS file specs backward like this */
4954               *cp2 = *cp1; *cp1 = '\0';
4955               hasfilename = 1;
4956               break;
4957             }
4958           }
4959           if (*cp2 == '[' || *cp2 == '<') break;
4960         }
4961       }
4962     }
4963
4964     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
4965     if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
4966     cp1 = strpbrk(trndir,"]:>");
4967     if (hasfilename || !cp1) { /* Unix-style path or filename */
4968       if (trndir[0] == '.') {
4969         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
4970           PerlMem_free(trndir);
4971           PerlMem_free(vmsdir);
4972           return do_fileify_dirspec("[]",buf,ts,NULL);
4973         }
4974         else if (trndir[1] == '.' &&
4975                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
4976           PerlMem_free(trndir);
4977           PerlMem_free(vmsdir);
4978           return do_fileify_dirspec("[-]",buf,ts,NULL);
4979         }
4980       }
4981       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
4982         dirlen -= 1;                 /* to last element */
4983         lastdir = strrchr(trndir,'/');
4984       }
4985       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4986         /* If we have "/." or "/..", VMSify it and let the VMS code
4987          * below expand it, rather than repeating the code to handle
4988          * relative components of a filespec here */
4989         do {
4990           if (*(cp1+2) == '.') cp1++;
4991           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4992             char * ret_chr;
4993             if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
4994                 PerlMem_free(trndir);
4995                 PerlMem_free(vmsdir);
4996                 return NULL;
4997             }
4998             if (strchr(vmsdir,'/') != NULL) {
4999               /* If do_tovmsspec() returned it, it must have VMS syntax
5000                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
5001                * the time to check this here only so we avoid a recursion
5002                * loop; otherwise, gigo.
5003                */
5004               PerlMem_free(trndir);
5005               PerlMem_free(vmsdir);
5006               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
5007               return NULL;
5008             }
5009             if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5010                 PerlMem_free(trndir);
5011                 PerlMem_free(vmsdir);
5012                 return NULL;
5013             }
5014             ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5015             PerlMem_free(trndir);
5016             PerlMem_free(vmsdir);
5017             return ret_chr;
5018           }
5019           cp1++;
5020         } while ((cp1 = strstr(cp1,"/.")) != NULL);
5021         lastdir = strrchr(trndir,'/');
5022       }
5023       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5024         char * ret_chr;
5025         /* Ditto for specs that end in an MFD -- let the VMS code
5026          * figure out whether it's a real device or a rooted logical. */
5027
5028         /* This should not happen any more.  Allowing the fake /000000
5029          * in a UNIX pathname causes all sorts of problems when trying
5030          * to run in UNIX emulation.  So the VMS to UNIX conversions
5031          * now remove the fake /000000 directories.
5032          */
5033
5034         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5035         if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5036             PerlMem_free(trndir);
5037             PerlMem_free(vmsdir);
5038             return NULL;
5039         }
5040         if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5041             PerlMem_free(trndir);
5042             PerlMem_free(vmsdir);
5043             return NULL;
5044         }
5045         ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5046         PerlMem_free(trndir);
5047         PerlMem_free(vmsdir);
5048         return ret_chr;
5049       }
5050       else {
5051
5052         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5053              !(lastdir = cp1 = strrchr(trndir,']')) &&
5054              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5055         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
5056           int ver; char *cp3;
5057
5058           /* For EFS or ODS-5 look for the last dot */
5059           if (decc_efs_charset) {
5060               cp2 = strrchr(cp1,'.');
5061           }
5062           if (vms_process_case_tolerant) {
5063               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5064                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5065                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5066                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5067                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5068                             (ver || *cp3)))))) {
5069                   PerlMem_free(trndir);
5070                   PerlMem_free(vmsdir);
5071                   set_errno(ENOTDIR);
5072                   set_vaxc_errno(RMS$_DIR);
5073                   return NULL;
5074               }
5075           }
5076           else {
5077               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5078                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5079                   !*(cp2+3) || *(cp2+3) != 'R' ||
5080                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5081                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5082                             (ver || *cp3)))))) {
5083                  PerlMem_free(trndir);
5084                  PerlMem_free(vmsdir);
5085                  set_errno(ENOTDIR);
5086                  set_vaxc_errno(RMS$_DIR);
5087                  return NULL;
5088               }
5089           }
5090           dirlen = cp2 - trndir;
5091         }
5092       }
5093
5094       retlen = dirlen + 6;
5095       if (buf) retspec = buf;
5096       else if (ts) Newx(retspec,retlen+1,char);
5097       else retspec = __fileify_retbuf;
5098       memcpy(retspec,trndir,dirlen);
5099       retspec[dirlen] = '\0';
5100
5101       /* We've picked up everything up to the directory file name.
5102          Now just add the type and version, and we're set. */
5103       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5104         strcat(retspec,".dir;1");
5105       else
5106         strcat(retspec,".DIR;1");
5107       PerlMem_free(trndir);
5108       PerlMem_free(vmsdir);
5109       return retspec;
5110     }
5111     else {  /* VMS-style directory spec */
5112
5113       char *esa, term, *cp;
5114       unsigned long int sts, cmplen, haslower = 0;
5115       unsigned int nam_fnb;
5116       char * nam_type;
5117       struct FAB dirfab = cc$rms_fab;
5118       rms_setup_nam(savnam);
5119       rms_setup_nam(dirnam);
5120
5121       esa = PerlMem_malloc(VMS_MAXRSS + 1);
5122       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5123       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5124       rms_bind_fab_nam(dirfab, dirnam);
5125       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5126       rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
5127 #ifdef NAM$M_NO_SHORT_UPCASE
5128       if (decc_efs_case_preserve)
5129         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5130 #endif
5131
5132       for (cp = trndir; *cp; cp++)
5133         if (islower(*cp)) { haslower = 1; break; }
5134       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5135         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5136           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5137           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5138         }
5139         if (!sts) {
5140           PerlMem_free(esa);
5141           PerlMem_free(trndir);
5142           PerlMem_free(vmsdir);
5143           set_errno(EVMSERR);
5144           set_vaxc_errno(dirfab.fab$l_sts);
5145           return NULL;
5146         }
5147       }
5148       else {
5149         savnam = dirnam;
5150         /* Does the file really exist? */
5151         if (sys$search(&dirfab)& STS$K_SUCCESS) {
5152           /* Yes; fake the fnb bits so we'll check type below */
5153         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
5154         }
5155         else { /* No; just work with potential name */
5156           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
5157           else {
5158             int fab_sts;
5159             fab_sts = dirfab.fab$l_sts;
5160             sts = rms_free_search_context(&dirfab);
5161             PerlMem_free(esa);
5162             PerlMem_free(trndir);
5163             PerlMem_free(vmsdir);
5164             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
5165             return NULL;
5166           }
5167         }
5168       }
5169       esa[rms_nam_esll(dirnam)] = '\0';
5170       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5171         cp1 = strchr(esa,']');
5172         if (!cp1) cp1 = strchr(esa,'>');
5173         if (cp1) {  /* Should always be true */
5174           rms_nam_esll(dirnam) -= cp1 - esa - 1;
5175           memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5176         }
5177       }
5178       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5179         /* Yep; check version while we're at it, if it's there. */
5180         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5181         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5182           /* Something other than .DIR[;1].  Bzzt. */
5183           sts = rms_free_search_context(&dirfab);
5184           PerlMem_free(esa);
5185           PerlMem_free(trndir);
5186           PerlMem_free(vmsdir);
5187           set_errno(ENOTDIR);
5188           set_vaxc_errno(RMS$_DIR);
5189           return NULL;
5190         }
5191       }
5192
5193       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5194         /* They provided at least the name; we added the type, if necessary, */
5195         if (buf) retspec = buf;                            /* in sys$parse() */
5196         else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5197         else retspec = __fileify_retbuf;
5198         strcpy(retspec,esa);
5199         sts = rms_free_search_context(&dirfab);
5200         PerlMem_free(trndir);
5201         PerlMem_free(esa);
5202         PerlMem_free(vmsdir);
5203         return retspec;
5204       }
5205       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5206         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5207         *cp1 = '\0';
5208         rms_nam_esll(dirnam) -= 9;
5209       }
5210       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5211       if (cp1 == NULL) { /* should never happen */
5212         sts = rms_free_search_context(&dirfab);
5213         PerlMem_free(trndir);
5214         PerlMem_free(esa);
5215         PerlMem_free(vmsdir);
5216         return NULL;
5217       }
5218       term = *cp1;
5219       *cp1 = '\0';
5220       retlen = strlen(esa);
5221       cp1 = strrchr(esa,'.');
5222       /* ODS-5 directory specifications can have extra "." in them. */
5223       /* Fix-me, can not scan EFS file specifications backwards */
5224       while (cp1 != NULL) {
5225         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5226           break;
5227         else {
5228            cp1--;
5229            while ((cp1 > esa) && (*cp1 != '.'))
5230              cp1--;
5231         }
5232         if (cp1 == esa)
5233           cp1 = NULL;
5234       }
5235
5236       if ((cp1) != NULL) {
5237         /* There's more than one directory in the path.  Just roll back. */
5238         *cp1 = term;
5239         if (buf) retspec = buf;
5240         else if (ts) Newx(retspec,retlen+7,char);
5241         else retspec = __fileify_retbuf;
5242         strcpy(retspec,esa);
5243       }
5244       else {
5245         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5246           /* Go back and expand rooted logical name */
5247           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5248 #ifdef NAM$M_NO_SHORT_UPCASE
5249           if (decc_efs_case_preserve)
5250             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5251 #endif
5252           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5253             sts = rms_free_search_context(&dirfab);
5254             PerlMem_free(esa);
5255             PerlMem_free(trndir);
5256             PerlMem_free(vmsdir);
5257             set_errno(EVMSERR);
5258             set_vaxc_errno(dirfab.fab$l_sts);
5259             return NULL;
5260           }
5261           retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5262           if (buf) retspec = buf;
5263           else if (ts) Newx(retspec,retlen+16,char);
5264           else retspec = __fileify_retbuf;
5265           cp1 = strstr(esa,"][");
5266           if (!cp1) cp1 = strstr(esa,"]<");
5267           dirlen = cp1 - esa;
5268           memcpy(retspec,esa,dirlen);
5269           if (!strncmp(cp1+2,"000000]",7)) {
5270             retspec[dirlen-1] = '\0';
5271             /* fix-me Not full ODS-5, just extra dots in directories for now */
5272             cp1 = retspec + dirlen - 1;
5273             while (cp1 > retspec)
5274             {
5275               if (*cp1 == '[')
5276                 break;
5277               if (*cp1 == '.') {
5278                 if (*(cp1-1) != '^')
5279                   break;
5280               }
5281               cp1--;
5282             }
5283             if (*cp1 == '.') *cp1 = ']';
5284             else {
5285               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5286               memmove(cp1+1,"000000]",7);
5287             }
5288           }
5289           else {
5290             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5291             retspec[retlen] = '\0';
5292             /* Convert last '.' to ']' */
5293             cp1 = retspec+retlen-1;
5294             while (*cp != '[') {
5295               cp1--;
5296               if (*cp1 == '.') {
5297                 /* Do not trip on extra dots in ODS-5 directories */
5298                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5299                 break;
5300               }
5301             }
5302             if (*cp1 == '.') *cp1 = ']';
5303             else {
5304               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5305               memmove(cp1+1,"000000]",7);
5306             }
5307           }
5308         }
5309         else {  /* This is a top-level dir.  Add the MFD to the path. */
5310           if (buf) retspec = buf;
5311           else if (ts) Newx(retspec,retlen+16,char);
5312           else retspec = __fileify_retbuf;
5313           cp1 = esa;
5314           cp2 = retspec;
5315           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5316           strcpy(cp2,":[000000]");
5317           cp1 += 2;
5318           strcpy(cp2+9,cp1);
5319         }
5320       }
5321       sts = rms_free_search_context(&dirfab);
5322       /* We've set up the string up through the filename.  Add the
5323          type and version, and we're done. */
5324       strcat(retspec,".DIR;1");
5325
5326       /* $PARSE may have upcased filespec, so convert output to lower
5327        * case if input contained any lowercase characters. */
5328       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5329       PerlMem_free(trndir);
5330       PerlMem_free(esa);
5331       PerlMem_free(vmsdir);
5332       return retspec;
5333     }
5334 }  /* end of do_fileify_dirspec() */
5335 /*}}}*/
5336 /* External entry points */
5337 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5338 { return do_fileify_dirspec(dir,buf,0,NULL); }
5339 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5340 { return do_fileify_dirspec(dir,buf,1,NULL); }
5341 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
5342 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
5343 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
5344 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
5345
5346 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5347 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
5348 {
5349     static char __pathify_retbuf[VMS_MAXRSS];
5350     unsigned long int retlen;
5351     char *retpath, *cp1, *cp2, *trndir;
5352     unsigned short int trnlnm_iter_count;
5353     STRLEN trnlen;
5354     int sts;
5355     if (utf8_fl != NULL)
5356         *utf8_fl = 0;
5357
5358     if (!dir || !*dir) {
5359       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5360     }
5361
5362     trndir = PerlMem_malloc(VMS_MAXRSS);
5363     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5364     if (*dir) strcpy(trndir,dir);
5365     else getcwd(trndir,VMS_MAXRSS - 1);
5366
5367     trnlnm_iter_count = 0;
5368     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5369            && my_trnlnm(trndir,trndir,0)) {
5370       trnlnm_iter_count++;
5371       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5372       trnlen = strlen(trndir);
5373
5374       /* Trap simple rooted lnms, and return lnm:[000000] */
5375       if (!strcmp(trndir+trnlen-2,".]")) {
5376         if (buf) retpath = buf;
5377         else if (ts) Newx(retpath,strlen(dir)+10,char);
5378         else retpath = __pathify_retbuf;
5379         strcpy(retpath,dir);
5380         strcat(retpath,":[000000]");
5381         PerlMem_free(trndir);
5382         return retpath;
5383       }
5384     }
5385
5386     /* At this point we do not work with *dir, but the copy in
5387      * *trndir that is modifiable.
5388      */
5389
5390     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5391       if (*trndir == '.' && (*(trndir+1) == '\0' ||
5392                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5393         retlen = 2 + (*(trndir+1) != '\0');
5394       else {
5395         if ( !(cp1 = strrchr(trndir,'/')) &&
5396              !(cp1 = strrchr(trndir,']')) &&
5397              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5398         if ((cp2 = strchr(cp1,'.')) != NULL &&
5399             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
5400              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
5401               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5402               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5403           int ver; char *cp3;
5404
5405           /* For EFS or ODS-5 look for the last dot */
5406           if (decc_efs_charset) {
5407             cp2 = strrchr(cp1,'.');
5408           }
5409           if (vms_process_case_tolerant) {
5410               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5411                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5412                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5413                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5414                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5415                             (ver || *cp3)))))) {
5416                 PerlMem_free(trndir);
5417                 set_errno(ENOTDIR);
5418                 set_vaxc_errno(RMS$_DIR);
5419                 return NULL;
5420               }
5421           }
5422           else {
5423               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5424                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5425                   !*(cp2+3) || *(cp2+3) != 'R' ||
5426                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5427                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5428                             (ver || *cp3)))))) {
5429                 PerlMem_free(trndir);
5430                 set_errno(ENOTDIR);
5431                 set_vaxc_errno(RMS$_DIR);
5432                 return NULL;
5433               }
5434           }
5435           retlen = cp2 - trndir + 1;
5436         }
5437         else {  /* No file type present.  Treat the filename as a directory. */
5438           retlen = strlen(trndir) + 1;
5439         }
5440       }
5441       if (buf) retpath = buf;
5442       else if (ts) Newx(retpath,retlen+1,char);
5443       else retpath = __pathify_retbuf;
5444       strncpy(retpath, trndir, retlen-1);
5445       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5446         retpath[retlen-1] = '/';      /* with '/', add it. */
5447         retpath[retlen] = '\0';
5448       }
5449       else retpath[retlen-1] = '\0';
5450     }
5451     else {  /* VMS-style directory spec */
5452       char *esa, *cp;
5453       unsigned long int sts, cmplen, haslower;
5454       struct FAB dirfab = cc$rms_fab;
5455       int dirlen;
5456       rms_setup_nam(savnam);
5457       rms_setup_nam(dirnam);
5458
5459       /* If we've got an explicit filename, we can just shuffle the string. */
5460       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5461              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
5462         if ((cp2 = strchr(cp1,'.')) != NULL) {
5463           int ver; char *cp3;
5464           if (vms_process_case_tolerant) {
5465               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5466                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5467                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5468                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5469                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5470                             (ver || *cp3)))))) {
5471                PerlMem_free(trndir);
5472                set_errno(ENOTDIR);
5473                set_vaxc_errno(RMS$_DIR);
5474                return NULL;
5475              }
5476           }
5477           else {
5478               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5479                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5480                   !*(cp2+3) || *(cp2+3) != 'R' ||
5481                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5482                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5483                             (ver || *cp3)))))) {
5484                PerlMem_free(trndir);
5485                set_errno(ENOTDIR);
5486                set_vaxc_errno(RMS$_DIR);
5487                return NULL;
5488              }
5489           }
5490         }
5491         else {  /* No file type, so just draw name into directory part */
5492           for (cp2 = cp1; *cp2; cp2++) ;
5493         }
5494         *cp2 = *cp1;
5495         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
5496         *cp1 = '.';
5497         /* We've now got a VMS 'path'; fall through */
5498       }
5499
5500       dirlen = strlen(trndir);
5501       if (trndir[dirlen-1] == ']' ||
5502           trndir[dirlen-1] == '>' ||
5503           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5504         if (buf) retpath = buf;
5505         else if (ts) Newx(retpath,strlen(trndir)+1,char);
5506         else retpath = __pathify_retbuf;
5507         strcpy(retpath,trndir);
5508         PerlMem_free(trndir);
5509         return retpath;
5510       }
5511       rms_set_fna(dirfab, dirnam, trndir, dirlen);
5512       esa = PerlMem_malloc(VMS_MAXRSS);
5513       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5514       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5515       rms_bind_fab_nam(dirfab, dirnam);
5516       rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5517 #ifdef NAM$M_NO_SHORT_UPCASE
5518       if (decc_efs_case_preserve)
5519           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5520 #endif
5521
5522       for (cp = trndir; *cp; cp++)
5523         if (islower(*cp)) { haslower = 1; break; }
5524
5525       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5526         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5527           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5528           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5529         }
5530         if (!sts) {
5531           PerlMem_free(trndir);
5532           PerlMem_free(esa);
5533           set_errno(EVMSERR);
5534           set_vaxc_errno(dirfab.fab$l_sts);
5535           return NULL;
5536         }
5537       }
5538       else {
5539         savnam = dirnam;
5540         /* Does the file really exist? */
5541         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5542           if (dirfab.fab$l_sts != RMS$_FNF) {
5543             int sts1;
5544             sts1 = rms_free_search_context(&dirfab);
5545             PerlMem_free(trndir);
5546             PerlMem_free(esa);
5547             set_errno(EVMSERR);
5548             set_vaxc_errno(dirfab.fab$l_sts);
5549             return NULL;
5550           }
5551           dirnam = savnam; /* No; just work with potential name */
5552         }
5553       }
5554       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5555         /* Yep; check version while we're at it, if it's there. */
5556         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5557         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5558           int sts2;
5559           /* Something other than .DIR[;1].  Bzzt. */
5560           sts2 = rms_free_search_context(&dirfab);
5561           PerlMem_free(trndir);
5562           PerlMem_free(esa);
5563           set_errno(ENOTDIR);
5564           set_vaxc_errno(RMS$_DIR);
5565           return NULL;
5566         }
5567       }
5568       /* OK, the type was fine.  Now pull any file name into the
5569          directory path. */
5570       if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5571       else {
5572         cp1 = strrchr(esa,'>');
5573         *(rms_nam_typel(dirnam)) = '>';
5574       }
5575       *cp1 = '.';
5576       *(rms_nam_typel(dirnam) + 1) = '\0';
5577       retlen = (rms_nam_typel(dirnam)) - esa + 2;
5578       if (buf) retpath = buf;
5579       else if (ts) Newx(retpath,retlen,char);
5580       else retpath = __pathify_retbuf;
5581       strcpy(retpath,esa);
5582       PerlMem_free(esa);
5583       sts = rms_free_search_context(&dirfab);
5584       /* $PARSE may have upcased filespec, so convert output to lower
5585        * case if input contained any lowercase characters. */
5586       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5587     }
5588
5589     PerlMem_free(trndir);
5590     return retpath;
5591 }  /* end of do_pathify_dirspec() */
5592 /*}}}*/
5593 /* External entry points */
5594 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5595 { return do_pathify_dirspec(dir,buf,0,NULL); }
5596 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5597 { return do_pathify_dirspec(dir,buf,1,NULL); }
5598 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
5599 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
5600 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
5601 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
5602
5603 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
5604 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
5605 {
5606   static char __tounixspec_retbuf[VMS_MAXRSS];
5607   char *dirend, *rslt, *cp1, *cp3, *tmp;
5608   const char *cp2;
5609   int devlen, dirlen, retlen = VMS_MAXRSS;
5610   int expand = 1; /* guarantee room for leading and trailing slashes */
5611   unsigned short int trnlnm_iter_count;
5612   int cmp_rslt;
5613   if (utf8_fl != NULL)
5614     *utf8_fl = 0;
5615
5616   if (spec == NULL) return NULL;
5617   if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
5618   if (buf) rslt = buf;
5619   else if (ts) {
5620     Newx(rslt, VMS_MAXRSS, char);
5621   }
5622   else rslt = __tounixspec_retbuf;
5623
5624   /* New VMS specific format needs translation
5625    * glob passes filenames with trailing '\n' and expects this preserved.
5626    */
5627   if (decc_posix_compliant_pathnames) {
5628     if (strncmp(spec, "\"^UP^", 5) == 0) {
5629       char * uspec;
5630       char *tunix;
5631       int tunix_len;
5632       int nl_flag;
5633
5634       tunix = PerlMem_malloc(VMS_MAXRSS);
5635       if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5636       strcpy(tunix, spec);
5637       tunix_len = strlen(tunix);
5638       nl_flag = 0;
5639       if (tunix[tunix_len - 1] == '\n') {
5640         tunix[tunix_len - 1] = '\"';
5641         tunix[tunix_len] = '\0';
5642         tunix_len--;
5643         nl_flag = 1;
5644       }
5645       uspec = decc$translate_vms(tunix);
5646       PerlMem_free(tunix);
5647       if ((int)uspec > 0) {
5648         strcpy(rslt,uspec);
5649         if (nl_flag) {
5650           strcat(rslt,"\n");
5651         }
5652         else {
5653           /* If we can not translate it, makemaker wants as-is */
5654           strcpy(rslt, spec);
5655         }
5656         return rslt;
5657       }
5658     }
5659   }
5660
5661   cmp_rslt = 0; /* Presume VMS */
5662   cp1 = strchr(spec, '/');
5663   if (cp1 == NULL)
5664     cmp_rslt = 0;
5665
5666     /* Look for EFS ^/ */
5667     if (decc_efs_charset) {
5668       while (cp1 != NULL) {
5669         cp2 = cp1 - 1;
5670         if (*cp2 != '^') {
5671           /* Found illegal VMS, assume UNIX */
5672           cmp_rslt = 1;
5673           break;
5674         }
5675       cp1++;
5676       cp1 = strchr(cp1, '/');
5677     }
5678   }
5679
5680   /* Look for "." and ".." */
5681   if (decc_filename_unix_report) {
5682     if (spec[0] == '.') {
5683       if ((spec[1] == '\0') || (spec[1] == '\n')) {
5684         cmp_rslt = 1;
5685       }
5686       else {
5687         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5688           cmp_rslt = 1;
5689         }
5690       }
5691     }
5692   }
5693   /* This is already UNIX or at least nothing VMS understands */
5694   if (cmp_rslt) {
5695     strcpy(rslt,spec);
5696     return rslt;
5697   }
5698
5699   cp1 = rslt;
5700   cp2 = spec;
5701   dirend = strrchr(spec,']');
5702   if (dirend == NULL) dirend = strrchr(spec,'>');
5703   if (dirend == NULL) dirend = strchr(spec,':');
5704   if (dirend == NULL) {
5705     strcpy(rslt,spec);
5706     return rslt;
5707   }
5708
5709   /* Special case 1 - sys$posix_root = / */
5710 #if __CRTL_VER >= 70000000
5711   if (!decc_disable_posix_root) {
5712     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5713       *cp1 = '/';
5714       cp1++;
5715       cp2 = cp2 + 15;
5716       }
5717   }
5718 #endif
5719
5720   /* Special case 2 - Convert NLA0: to /dev/null */
5721 #if __CRTL_VER < 70000000
5722   cmp_rslt = strncmp(spec,"NLA0:", 5);
5723   if (cmp_rslt != 0)
5724      cmp_rslt = strncmp(spec,"nla0:", 5);
5725 #else
5726   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5727 #endif
5728   if (cmp_rslt == 0) {
5729     strcpy(rslt, "/dev/null");
5730     cp1 = cp1 + 9;
5731     cp2 = cp2 + 5;
5732     if (spec[6] != '\0') {
5733       cp1[9] == '/';
5734       cp1++;
5735       cp2++;
5736     }
5737   }
5738
5739    /* Also handle special case "SYS$SCRATCH:" */
5740 #if __CRTL_VER < 70000000
5741   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5742   if (cmp_rslt != 0)
5743      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5744 #else
5745   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5746 #endif
5747   tmp = PerlMem_malloc(VMS_MAXRSS);
5748   if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
5749   if (cmp_rslt == 0) {
5750   int islnm;
5751
5752     islnm = my_trnlnm(tmp, "TMP", 0);
5753     if (!islnm) {
5754       strcpy(rslt, "/tmp");
5755       cp1 = cp1 + 4;
5756       cp2 = cp2 + 12;
5757       if (spec[12] != '\0') {
5758         cp1[4] == '/';
5759         cp1++;
5760         cp2++;
5761       }
5762     }
5763   }
5764
5765   if (*cp2 != '[' && *cp2 != '<') {
5766     *(cp1++) = '/';
5767   }
5768   else {  /* the VMS spec begins with directories */
5769     cp2++;
5770     if (*cp2 == ']' || *cp2 == '>') {
5771       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
5772       PerlMem_free(tmp);
5773       return rslt;
5774     }
5775     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
5776       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
5777         if (ts) Safefree(rslt);
5778         PerlMem_free(tmp);
5779         return NULL;
5780       }
5781       trnlnm_iter_count = 0;
5782       do {
5783         cp3 = tmp;
5784         while (*cp3 != ':' && *cp3) cp3++;
5785         *(cp3++) = '\0';
5786         if (strchr(cp3,']') != NULL) break;
5787         trnlnm_iter_count++;
5788         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
5789       } while (vmstrnenv(tmp,tmp,0,fildev,0));
5790       if (ts && !buf &&
5791           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
5792         retlen = devlen + dirlen;
5793         Renew(rslt,retlen+1+2*expand,char);
5794         cp1 = rslt;
5795       }
5796       cp3 = tmp;
5797       *(cp1++) = '/';
5798       while (*cp3) {
5799         *(cp1++) = *(cp3++);
5800         if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
5801             PerlMem_free(tmp);
5802             return NULL; /* No room */
5803         }
5804       }
5805       *(cp1++) = '/';
5806     }
5807     if ((*cp2 == '^')) {
5808         /* EFS file escape, pass the next character as is */
5809         /* Fix me: HEX encoding for UNICODE not implemented */
5810         cp2++;
5811     }
5812     else if ( *cp2 == '.') {
5813       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5814         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5815         cp2 += 3;
5816       }
5817       else cp2++;
5818     }
5819   }
5820   PerlMem_free(tmp);
5821   for (; cp2 <= dirend; cp2++) {
5822     if ((*cp2 == '^')) {
5823         /* EFS file escape, pass the next character as is */
5824         /* Fix me: HEX encoding for UNICODE not implemented */
5825         cp2++;
5826         *(cp1++) = *cp2;
5827     }
5828     if (*cp2 == ':') {
5829       *(cp1++) = '/';
5830       if (*(cp2+1) == '[') cp2++;
5831     }
5832     else if (*cp2 == ']' || *cp2 == '>') {
5833       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5834     }
5835     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
5836       *(cp1++) = '/';
5837       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5838         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5839                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5840         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5841             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5842       }
5843       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5844         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5845         cp2 += 2;
5846       }
5847     }
5848     else if (*cp2 == '-') {
5849       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5850         while (*cp2 == '-') {
5851           cp2++;
5852           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5853         }
5854         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5855           if (ts) Safefree(rslt);                        /* filespecs like */
5856           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
5857           return NULL;
5858         }
5859       }
5860       else *(cp1++) = *cp2;
5861     }
5862     else *(cp1++) = *cp2;
5863   }
5864   while (*cp2) *(cp1++) = *(cp2++);
5865   *cp1 = '\0';
5866
5867   /* This still leaves /000000/ when working with a
5868    * VMS device root or concealed root.
5869    */
5870   {
5871   int ulen;
5872   char * zeros;
5873
5874       ulen = strlen(rslt);
5875
5876       /* Get rid of "000000/ in rooted filespecs */
5877       if (ulen > 7) {
5878         zeros = strstr(rslt, "/000000/");
5879         if (zeros != NULL) {
5880           int mlen;
5881           mlen = ulen - (zeros - rslt) - 7;
5882           memmove(zeros, &zeros[7], mlen);
5883           ulen = ulen - 7;
5884           rslt[ulen] = '\0';
5885         }
5886       }
5887   }
5888
5889   return rslt;
5890
5891 }  /* end of do_tounixspec() */
5892 /*}}}*/
5893 /* External entry points */
5894 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
5895   { return do_tounixspec(spec,buf,0, NULL); }
5896 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
5897   { return do_tounixspec(spec,buf,1, NULL); }
5898 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
5899   { return do_tounixspec(spec,buf,0, utf8_fl); }
5900 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
5901   { return do_tounixspec(spec,buf,1, utf8_fl); }
5902
5903 #if __CRTL_VER >= 70200000 && !defined(__VAX)
5904
5905 /*
5906  This procedure is used to identify if a path is based in either
5907  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
5908  it returns the OpenVMS format directory for it.
5909
5910  It is expecting specifications of only '/' or '/xxxx/'
5911
5912  If a posix root does not exist, or 'xxxx' is not a directory
5913  in the posix root, it returns a failure.
5914
5915  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
5916
5917  It is used only internally by posix_to_vmsspec_hardway().
5918  */
5919
5920 static int posix_root_to_vms
5921   (char *vmspath, int vmspath_len,
5922    const char *unixpath,
5923    const int * utf8_fl) {
5924 int sts;
5925 struct FAB myfab = cc$rms_fab;
5926 struct NAML mynam = cc$rms_naml;
5927 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5928  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5929 char *esa;
5930 char *vms_delim;
5931 int dir_flag;
5932 int unixlen;
5933
5934     dir_flag = 0;
5935     unixlen = strlen(unixpath);
5936     if (unixlen == 0) {
5937       vmspath[0] = '\0';
5938       return RMS$_FNF;
5939     }
5940
5941 #if __CRTL_VER >= 80200000
5942   /* If not a posix spec already, convert it */
5943   if (decc_posix_compliant_pathnames) {
5944     if (strncmp(unixpath,"\"^UP^",5) != 0) {
5945       sprintf(vmspath,"\"^UP^%s\"",unixpath);
5946     }
5947     else {
5948       /* This is already a VMS specification, no conversion */
5949       unixlen--;
5950       strncpy(vmspath,unixpath, vmspath_len);
5951     }
5952   }
5953   else
5954 #endif
5955   {
5956   int path_len;
5957   int i,j;
5958
5959      /* Check to see if this is under the POSIX root */
5960      if (decc_disable_posix_root) {
5961         return RMS$_FNF;
5962      }
5963
5964      /* Skip leading / */
5965      if (unixpath[0] == '/') {
5966         unixpath++;
5967         unixlen--;
5968      }
5969
5970
5971      strcpy(vmspath,"SYS$POSIX_ROOT:");
5972
5973      /* If this is only the / , or blank, then... */
5974      if (unixpath[0] == '\0') {
5975         /* by definition, this is the answer */
5976         return SS$_NORMAL;
5977      }
5978
5979      /* Need to look up a directory */
5980      vmspath[15] = '[';
5981      vmspath[16] = '\0';
5982
5983      /* Copy and add '^' escape characters as needed */
5984      j = 16;
5985      i = 0;
5986      while (unixpath[i] != 0) {
5987      int k;
5988
5989         j += copy_expand_unix_filename_escape
5990             (&vmspath[j], &unixpath[i], &k, utf8_fl);
5991         i += k;
5992      }
5993
5994      path_len = strlen(vmspath);
5995      if (vmspath[path_len - 1] == '/')
5996         path_len--;
5997      vmspath[path_len] = ']';
5998      path_len++;
5999      vmspath[path_len] = '\0';
6000
6001   }
6002   vmspath[vmspath_len] = 0;
6003   if (unixpath[unixlen - 1] == '/')
6004   dir_flag = 1;
6005   esa = PerlMem_malloc(VMS_MAXRSS);
6006   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6007   myfab.fab$l_fna = vmspath;
6008   myfab.fab$b_fns = strlen(vmspath);
6009   myfab.fab$l_naml = &mynam;
6010   mynam.naml$l_esa = NULL;
6011   mynam.naml$b_ess = 0;
6012   mynam.naml$l_long_expand = esa;
6013   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
6014   mynam.naml$l_rsa = NULL;
6015   mynam.naml$b_rss = 0;
6016   if (decc_efs_case_preserve)
6017     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6018 #ifdef NAML$M_OPEN_SPECIAL
6019   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6020 #endif
6021
6022   /* Set up the remaining naml fields */
6023   sts = sys$parse(&myfab);
6024
6025   /* It failed! Try again as a UNIX filespec */
6026   if (!(sts & 1)) {
6027     PerlMem_free(esa);
6028     return sts;
6029   }
6030
6031    /* get the Device ID and the FID */
6032    sts = sys$search(&myfab);
6033    /* on any failure, returned the POSIX ^UP^ filespec */
6034    if (!(sts & 1)) {
6035       PerlMem_free(esa);
6036       return sts;
6037    }
6038    specdsc.dsc$a_pointer = vmspath;
6039    specdsc.dsc$w_length = vmspath_len;
6040
6041    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6042    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6043    sts = lib$fid_to_name
6044       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6045
6046   /* on any failure, returned the POSIX ^UP^ filespec */
6047   if (!(sts & 1)) {
6048      /* This can happen if user does not have permission to read directories */
6049      if (strncmp(unixpath,"\"^UP^",5) != 0)
6050        sprintf(vmspath,"\"^UP^%s\"",unixpath);
6051      else
6052        strcpy(vmspath, unixpath);
6053   }
6054   else {
6055     vmspath[specdsc.dsc$w_length] = 0;
6056
6057     /* Are we expecting a directory? */
6058     if (dir_flag != 0) {
6059     int i;
6060     char *eptr;
6061
6062       eptr = NULL;
6063
6064       i = specdsc.dsc$w_length - 1;
6065       while (i > 0) {
6066       int zercnt;
6067         zercnt = 0;
6068         /* Version must be '1' */
6069         if (vmspath[i--] != '1')
6070           break;
6071         /* Version delimiter is one of ".;" */
6072         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6073           break;
6074         i--;
6075         if (vmspath[i--] != 'R')
6076           break;
6077         if (vmspath[i--] != 'I')
6078           break;
6079         if (vmspath[i--] != 'D')
6080           break;
6081         if (vmspath[i--] != '.')
6082           break;
6083         eptr = &vmspath[i+1];
6084         while (i > 0) {
6085           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6086             if (vmspath[i-1] != '^') {
6087               if (zercnt != 6) {
6088                 *eptr = vmspath[i];
6089                 eptr[1] = '\0';
6090                 vmspath[i] = '.';
6091                 break;
6092               }
6093               else {
6094                 /* Get rid of 6 imaginary zero directory filename */
6095                 vmspath[i+1] = '\0';
6096               }
6097             }
6098           }
6099           if (vmspath[i] == '0')
6100             zercnt++;
6101           else
6102             zercnt = 10;
6103           i--;
6104         }
6105         break;
6106       }
6107     }
6108   }
6109   PerlMem_free(esa);
6110   return sts;
6111 }
6112
6113 /* /dev/mumble needs to be handled special.
6114    /dev/null becomes NLA0:, And there is the potential for other stuff
6115    like /dev/tty which may need to be mapped to something.
6116 */
6117
6118 static int
6119 slash_dev_special_to_vms
6120    (const char * unixptr,
6121     char * vmspath,
6122     int vmspath_len)
6123 {
6124 char * nextslash;
6125 int len;
6126 int cmp;
6127 int islnm;
6128
6129     unixptr += 4;
6130     nextslash = strchr(unixptr, '/');
6131     len = strlen(unixptr);
6132     if (nextslash != NULL)
6133         len = nextslash - unixptr;
6134     cmp = strncmp("null", unixptr, 5);
6135     if (cmp == 0) {
6136         if (vmspath_len >= 6) {
6137             strcpy(vmspath, "_NLA0:");
6138             return SS$_NORMAL;
6139         }
6140     }
6141 }
6142
6143
6144 /* The built in routines do not understand perl's special needs, so
6145     doing a manual conversion from UNIX to VMS
6146
6147     If the utf8_fl is not null and points to a non-zero value, then
6148     treat 8 bit characters as UTF-8.
6149
6150     The sequence starting with '$(' and ending with ')' will be passed
6151     through with out interpretation instead of being escaped.
6152
6153   */
6154 static int posix_to_vmsspec_hardway
6155   (char *vmspath, int vmspath_len,
6156    const char *unixpath,
6157    int dir_flag,
6158    int * utf8_fl) {
6159
6160 char *esa;
6161 const char *unixptr;
6162 const char *unixend;
6163 char *vmsptr;
6164 const char *lastslash;
6165 const char *lastdot;
6166 int unixlen;
6167 int vmslen;
6168 int dir_start;
6169 int dir_dot;
6170 int quoted;
6171 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6172 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6173
6174   if (utf8_fl != NULL)
6175     *utf8_fl = 0;
6176
6177   unixptr = unixpath;
6178   dir_dot = 0;
6179
6180   /* Ignore leading "/" characters */
6181   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
6182     unixptr++;
6183   }
6184   unixlen = strlen(unixptr);
6185
6186   /* Do nothing with blank paths */
6187   if (unixlen == 0) {
6188     vmspath[0] = '\0';
6189     return SS$_NORMAL;
6190   }
6191
6192   quoted = 0;
6193   /* This could have a "^UP^ on the front */
6194   if (strncmp(unixptr,"\"^UP^",5) == 0) {
6195     quoted = 1;
6196     unixptr+= 5;
6197     unixlen-= 5;
6198   }
6199
6200   lastslash = strrchr(unixptr,'/');
6201   lastdot = strrchr(unixptr,'.');
6202   unixend = strrchr(unixptr,'\"');
6203   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
6204     unixend = unixptr + unixlen;
6205   }
6206
6207   /* last dot is last dot or past end of string */
6208   if (lastdot == NULL)
6209     lastdot = unixptr + unixlen;
6210
6211   /* if no directories, set last slash to beginning of string */
6212   if (lastslash == NULL) {
6213     lastslash = unixptr;
6214   }
6215   else {
6216     /* Watch out for trailing "." after last slash, still a directory */
6217     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
6218       lastslash = unixptr + unixlen;
6219     }
6220
6221     /* Watch out for traiing ".." after last slash, still a directory */
6222     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
6223       lastslash = unixptr + unixlen;
6224     }
6225
6226     /* dots in directories are aways escaped */
6227     if (lastdot < lastslash)
6228       lastdot = unixptr + unixlen;
6229   }
6230
6231   /* if (unixptr < lastslash) then we are in a directory */
6232
6233   dir_start = 0;
6234
6235   vmsptr = vmspath;
6236   vmslen = 0;
6237
6238   /* Start with the UNIX path */
6239   if (*unixptr != '/') {
6240     /* relative paths */
6241
6242     /* If allowing logical names on relative pathnames, then handle here */
6243     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
6244         !decc_posix_compliant_pathnames) {
6245     char * nextslash;
6246     int seg_len;
6247     char * trn;
6248     int islnm;
6249
6250         /* Find the next slash */
6251         nextslash = strchr(unixptr,'/');
6252
6253         esa = PerlMem_malloc(vmspath_len);
6254         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6255
6256         trn = PerlMem_malloc(VMS_MAXRSS);
6257         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6258
6259         if (nextslash != NULL) {
6260
6261             seg_len = nextslash - unixptr;
6262             strncpy(esa, unixptr, seg_len);
6263             esa[seg_len] = 0;
6264         }
6265         else {
6266             strcpy(esa, unixptr);
6267             seg_len = strlen(unixptr);
6268         }
6269         /* trnlnm(section) */
6270         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
6271
6272         if (islnm) {
6273             /* Now fix up the directory */
6274
6275             /* Split up the path to find the components */
6276             sts = vms_split_path
6277                   (trn,
6278                    &v_spec,
6279                    &v_len,
6280                    &r_spec,
6281                    &r_len,
6282                    &d_spec,
6283                    &d_len,
6284                    &n_spec,
6285                    &n_len,
6286                    &e_spec,
6287                    &e_len,
6288                    &vs_spec,
6289                    &vs_len);
6290
6291             while (sts == 0) {
6292             char * strt;
6293             int cmp;
6294
6295                 /* A logical name must be a directory  or the full
6296                    specification.  It is only a full specification if
6297                    it is the only component */
6298                 if ((unixptr[seg_len] == '\0') ||
6299                     (unixptr[seg_len+1] == '\0')) {
6300
6301                     /* Is a directory being required? */
6302                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
6303                         /* Not a logical name */
6304                         break;
6305                     }
6306
6307
6308                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
6309                         /* This must be a directory */
6310                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
6311                             strcpy(vmsptr, esa);
6312                             vmslen=strlen(vmsptr);
6313                             vmsptr[vmslen] = ':';
6314                             vmslen++;
6315                             vmsptr[vmslen] = '\0';
6316                             return SS$_NORMAL;
6317                         }
6318                     }
6319
6320                 }
6321
6322
6323                 /* must be dev/directory - ignore version */
6324                 if ((n_len + e_len) != 0)
6325                     break;
6326
6327                 /* transfer the volume */
6328                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
6329                     strncpy(vmsptr, v_spec, v_len);
6330                     vmsptr += v_len;
6331                     vmsptr[0] = '\0';
6332                     vmslen += v_len;
6333                 }
6334
6335                 /* unroot the rooted directory */
6336                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
6337                     r_spec[0] = '[';
6338                     r_spec[r_len - 1] = ']';
6339
6340                     /* This should not be there, but nothing is perfect */
6341                     if (r_len > 9) {
6342                         cmp = strcmp(&r_spec[1], "000000.");
6343                         if (cmp == 0) {
6344                             r_spec += 7;
6345                             r_spec[7] = '[';
6346                             r_len -= 7;
6347                             if (r_len == 2)
6348                                 r_len = 0;
6349                         }
6350                     }
6351                     if (r_len > 0) {
6352                         strncpy(vmsptr, r_spec, r_len);
6353                         vmsptr += r_len;
6354                         vmslen += r_len;
6355                         vmsptr[0] = '\0';
6356                     }
6357                 }
6358                 /* Bring over the directory. */
6359                 if ((d_len > 0) &&
6360                     ((d_len + vmslen) < vmspath_len)) {
6361                     d_spec[0] = '[';
6362                     d_spec[d_len - 1] = ']';
6363                     if (d_len > 9) {
6364                         cmp = strcmp(&d_spec[1], "000000.");
6365                         if (cmp == 0) {
6366                             d_spec += 7;
6367                             d_spec[7] = '[';
6368                             d_len -= 7;
6369                             if (d_len == 2)
6370                                 d_len = 0;
6371                         }
6372                     }
6373
6374                     if (r_len > 0) {
6375                         /* Remove the redundant root */
6376                         if (r_len > 0) {
6377                             /* remove the ][ */
6378                             vmsptr--;
6379                             vmslen--;
6380                             d_spec++;
6381                             d_len--;
6382                         }
6383                         strncpy(vmsptr, d_spec, d_len);
6384                             vmsptr += d_len;
6385                             vmslen += d_len;
6386                             vmsptr[0] = '\0';
6387                     }
6388                 }
6389                 break;
6390             }
6391         }
6392
6393         PerlMem_free(esa);
6394         PerlMem_free(trn);
6395     }
6396
6397     if (lastslash > unixptr) {
6398     int dotdir_seen;
6399
6400       /* skip leading ./ */
6401       dotdir_seen = 0;
6402       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
6403         dotdir_seen = 1;
6404         unixptr++;
6405         unixptr++;
6406       }
6407
6408       /* Are we still in a directory? */
6409       if (unixptr <= lastslash) {
6410         *vmsptr++ = '[';
6411         vmslen = 1;
6412         dir_start = 1;
6413
6414         /* if not backing up, then it is relative forward. */
6415         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
6416               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
6417           *vmsptr++ = '.';
6418           vmslen++;
6419           dir_dot = 1;
6420           }
6421        }
6422        else {
6423          if (dotdir_seen) {
6424            /* Perl wants an empty directory here to tell the difference
6425             * between a DCL commmand and a filename
6426             */
6427           *vmsptr++ = '[';
6428           *vmsptr++ = ']';
6429           vmslen = 2;
6430         }
6431       }
6432     }
6433     else {
6434       /* Handle two special files . and .. */
6435       if (unixptr[0] == '.') {
6436         if (&unixptr[1] == unixend) {
6437           *vmsptr++ = '[';
6438           *vmsptr++ = ']';
6439           vmslen += 2;
6440           *vmsptr++ = '\0';
6441           return SS$_NORMAL;
6442         }
6443         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
6444           *vmsptr++ = '[';
6445           *vmsptr++ = '-';
6446           *vmsptr++ = ']';
6447           vmslen += 3;
6448           *vmsptr++ = '\0';
6449           return SS$_NORMAL;
6450         }
6451       }
6452     }
6453   }
6454   else {        /* Absolute PATH handling */
6455   int sts;
6456   char * nextslash;
6457   int seg_len;
6458     /* Need to find out where root is */
6459
6460     /* In theory, this procedure should never get an absolute POSIX pathname
6461      * that can not be found on the POSIX root.
6462      * In practice, that can not be relied on, and things will show up
6463      * here that are a VMS device name or concealed logical name instead.
6464      * So to make things work, this procedure must be tolerant.
6465      */
6466     esa = PerlMem_malloc(vmspath_len);
6467     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6468
6469     sts = SS$_NORMAL;
6470     nextslash = strchr(&unixptr[1],'/');
6471     seg_len = 0;
6472     if (nextslash != NULL) {
6473     int cmp;
6474       seg_len = nextslash - &unixptr[1];
6475       strncpy(vmspath, unixptr, seg_len + 1);
6476       vmspath[seg_len+1] = 0;
6477       cmp = 1;
6478       if (seg_len == 3) {
6479         cmp = strncmp(vmspath, "dev", 4);
6480         if (cmp == 0) {
6481             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
6482             if (sts = SS$_NORMAL)
6483                 return SS$_NORMAL;
6484         }
6485       }
6486       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
6487     }
6488
6489     if ($VMS_STATUS_SUCCESS(sts)) {
6490       /* This is verified to be a real path */
6491
6492       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
6493       if ($VMS_STATUS_SUCCESS(sts)) {
6494         strcpy(vmspath, esa);
6495         vmslen = strlen(vmspath);
6496         vmsptr = vmspath + vmslen;
6497         unixptr++;
6498         if (unixptr < lastslash) {
6499         char * rptr;
6500           vmsptr--;
6501           *vmsptr++ = '.';
6502           dir_start = 1;
6503           dir_dot = 1;
6504           if (vmslen > 7) {
6505           int cmp;
6506             rptr = vmsptr - 7;
6507             cmp = strcmp(rptr,"000000.");
6508             if (cmp == 0) {
6509               vmslen -= 7;
6510               vmsptr -= 7;
6511               vmsptr[1] = '\0';
6512             } /* removing 6 zeros */
6513           } /* vmslen < 7, no 6 zeros possible */
6514         } /* Not in a directory */
6515       } /* Posix root found */
6516       else {
6517         /* No posix root, fall back to default directory */
6518         strcpy(vmspath, "SYS$DISK:[");
6519         vmsptr = &vmspath[10];
6520         vmslen = 10;
6521         if (unixptr > lastslash) {
6522            *vmsptr = ']';
6523            vmsptr++;
6524            vmslen++;
6525         }
6526         else {
6527            dir_start = 1;
6528         }
6529       }
6530     } /* end of verified real path handling */
6531     else {
6532     int add_6zero;
6533     int islnm;
6534
6535       /* Ok, we have a device or a concealed root that is not in POSIX
6536        * or we have garbage.  Make the best of it.
6537        */
6538
6539       /* Posix to VMS destroyed this, so copy it again */
6540       strncpy(vmspath, &unixptr[1], seg_len);
6541       vmspath[seg_len] = 0;
6542       vmslen = seg_len;
6543       vmsptr = &vmsptr[vmslen];
6544       islnm = 0;
6545
6546       /* Now do we need to add the fake 6 zero directory to it? */
6547       add_6zero = 1;
6548       if ((*lastslash == '/') && (nextslash < lastslash)) {
6549         /* No there is another directory */
6550         add_6zero = 0;
6551       }
6552       else {
6553       int trnend;
6554       int cmp;
6555
6556         /* now we have foo:bar or foo:[000000]bar to decide from */
6557         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6558
6559         if (!islnm && !decc_posix_compliant_pathnames) {
6560
6561             cmp = strncmp("bin", vmspath, 4);
6562             if (cmp == 0) {
6563                 /* bin => SYS$SYSTEM: */
6564                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
6565             }
6566             else {
6567                 /* tmp => SYS$SCRATCH: */
6568                 cmp = strncmp("tmp", vmspath, 4);
6569                 if (cmp == 0) {
6570                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
6571                 }
6572             }
6573         }
6574
6575         trnend = islnm ? islnm - 1 : 0;
6576
6577         /* if this was a logical name, ']' or '>' must be present */
6578         /* if not a logical name, then assume a device and hope. */
6579         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6580
6581         /* if log name and trailing '.' then rooted - treat as device */
6582         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6583
6584         /* Fix me, if not a logical name, a device lookup should be
6585          * done to see if the device is file structured.  If the device
6586          * is not file structured, the 6 zeros should not be put on.
6587          *
6588          * As it is, perl is occasionally looking for dev:[000000]tty.
6589          * which looks a little strange.
6590          *
6591          * Not that easy to detect as "/dev" may be file structured with
6592          * special device files.
6593          */
6594
6595         if ((add_6zero == 0) && (*nextslash == '/') &&
6596             (&nextslash[1] == unixend)) {
6597           /* No real directory present */
6598           add_6zero = 1;
6599         }
6600       }
6601
6602       /* Put the device delimiter on */
6603       *vmsptr++ = ':';
6604       vmslen++;
6605       unixptr = nextslash;
6606       unixptr++;
6607
6608       /* Start directory if needed */
6609       if (!islnm || add_6zero) {
6610         *vmsptr++ = '[';
6611         vmslen++;
6612         dir_start = 1;
6613       }
6614
6615       /* add fake 000000] if needed */
6616       if (add_6zero) {
6617         *vmsptr++ = '0';
6618         *vmsptr++ = '0';
6619         *vmsptr++ = '0';
6620         *vmsptr++ = '0';
6621         *vmsptr++ = '0';
6622         *vmsptr++ = '0';
6623         *vmsptr++ = ']';
6624         vmslen += 7;
6625         dir_start = 0;
6626       }
6627
6628     } /* non-POSIX translation */
6629     PerlMem_free(esa);
6630   } /* End of relative/absolute path handling */
6631
6632   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
6633   int dash_flag;
6634   int in_cnt;
6635   int out_cnt;
6636
6637     dash_flag = 0;
6638
6639     if (dir_start != 0) {
6640
6641       /* First characters in a directory are handled special */
6642       while ((*unixptr == '/') ||
6643              ((*unixptr == '.') &&
6644               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
6645                 (&unixptr[1]==unixend)))) {
6646       int loop_flag;
6647
6648         loop_flag = 0;
6649
6650         /* Skip redundant / in specification */
6651         while ((*unixptr == '/') && (dir_start != 0)) {
6652           loop_flag = 1;
6653           unixptr++;
6654           if (unixptr == lastslash)
6655             break;
6656         }
6657         if (unixptr == lastslash)
6658           break;
6659
6660         /* Skip redundant ./ characters */
6661         while ((*unixptr == '.') &&
6662                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
6663           loop_flag = 1;
6664           unixptr++;
6665           if (unixptr == lastslash)
6666             break;
6667           if (*unixptr == '/')
6668             unixptr++;
6669         }
6670         if (unixptr == lastslash)
6671           break;
6672
6673         /* Skip redundant ../ characters */
6674         while ((*unixptr == '.') && (unixptr[1] == '.') &&
6675              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
6676           /* Set the backing up flag */
6677           loop_flag = 1;
6678           dir_dot = 0;
6679           dash_flag = 1;
6680           *vmsptr++ = '-';
6681           vmslen++;
6682           unixptr++; /* first . */
6683           unixptr++; /* second . */
6684           if (unixptr == lastslash)
6685             break;
6686           if (*unixptr == '/') /* The slash */
6687             unixptr++;
6688         }
6689         if (unixptr == lastslash)
6690           break;
6691
6692         /* To do: Perl expects /.../ to be translated to [...] on VMS */
6693         /* Not needed when VMS is pretending to be UNIX. */
6694
6695         /* Is this loop stuck because of too many dots? */
6696         if (loop_flag == 0) {
6697           /* Exit the loop and pass the rest through */
6698           break;
6699         }
6700       }
6701
6702       /* Are we done with directories yet? */
6703       if (unixptr >= lastslash) {
6704
6705         /* Watch out for trailing dots */
6706         if (dir_dot != 0) {
6707             vmslen --;
6708             vmsptr--;
6709         }
6710         *vmsptr++ = ']';
6711         vmslen++;
6712         dash_flag = 0;
6713         dir_start = 0;
6714         if (*unixptr == '/')
6715           unixptr++;
6716       }
6717       else {
6718         /* Have we stopped backing up? */
6719         if (dash_flag) {
6720           *vmsptr++ = '.';
6721           vmslen++;
6722           dash_flag = 0;
6723           /* dir_start continues to be = 1 */
6724         }
6725         if (*unixptr == '-') {
6726           *vmsptr++ = '^';
6727           *vmsptr++ = *unixptr++;
6728           vmslen += 2;
6729           dir_start = 0;
6730
6731           /* Now are we done with directories yet? */
6732           if (unixptr >= lastslash) {
6733
6734             /* Watch out for trailing dots */
6735             if (dir_dot != 0) {
6736               vmslen --;
6737               vmsptr--;
6738             }
6739
6740             *vmsptr++ = ']';
6741             vmslen++;
6742             dash_flag = 0;
6743             dir_start = 0;
6744           }
6745         }
6746       }
6747     }
6748
6749     /* All done? */
6750     if (unixptr >= unixend)
6751       break;
6752
6753     /* Normal characters - More EFS work probably needed */
6754     dir_start = 0;
6755     dir_dot = 0;
6756
6757     switch(*unixptr) {
6758     case '/':
6759         /* remove multiple / */
6760         while (unixptr[1] == '/') {
6761            unixptr++;
6762         }
6763         if (unixptr == lastslash) {
6764           /* Watch out for trailing dots */
6765           if (dir_dot != 0) {
6766             vmslen --;
6767             vmsptr--;
6768           }
6769           *vmsptr++ = ']';
6770         }
6771         else {
6772           dir_start = 1;
6773           *vmsptr++ = '.';
6774           dir_dot = 1;
6775
6776           /* To do: Perl expects /.../ to be translated to [...] on VMS */
6777           /* Not needed when VMS is pretending to be UNIX. */
6778
6779         }
6780         dash_flag = 0;
6781         if (unixptr != unixend)
6782           unixptr++;
6783         vmslen++;
6784         break;
6785     case '.':
6786         if ((unixptr < lastdot) || (unixptr < lastslash) ||
6787             (&unixptr[1] == unixend)) {
6788           *vmsptr++ = '^';
6789           *vmsptr++ = '.';
6790           vmslen += 2;
6791           unixptr++;
6792
6793           /* trailing dot ==> '^..' on VMS */
6794           if (unixptr == unixend) {
6795             *vmsptr++ = '.';
6796             vmslen++;
6797             unixptr++;
6798           }
6799           break;
6800         }
6801
6802         *vmsptr++ = *unixptr++;
6803         vmslen ++;
6804         break;
6805     case '"':
6806         if (quoted && (&unixptr[1] == unixend)) {
6807             unixptr++;
6808             break;
6809         }
6810         in_cnt = copy_expand_unix_filename_escape
6811                 (vmsptr, unixptr, &out_cnt, utf8_fl);
6812         vmsptr += out_cnt;
6813         unixptr += in_cnt;
6814         break;
6815     case '~':
6816     case ';':
6817     case '\\':
6818     case '?':
6819     case ' ':
6820     default:
6821         in_cnt = copy_expand_unix_filename_escape
6822                 (vmsptr, unixptr, &out_cnt, utf8_fl);
6823         vmsptr += out_cnt;
6824         unixptr += in_cnt;
6825         break;
6826     }
6827   }
6828
6829   /* Make sure directory is closed */
6830   if (unixptr == lastslash) {
6831     char *vmsptr2;
6832     vmsptr2 = vmsptr - 1;
6833
6834     if (*vmsptr2 != ']') {
6835       *vmsptr2--;
6836
6837       /* directories do not end in a dot bracket */
6838       if (*vmsptr2 == '.') {
6839         vmsptr2--;
6840
6841         /* ^. is allowed */
6842         if (*vmsptr2 != '^') {
6843           vmsptr--; /* back up over the dot */
6844         }
6845       }
6846       *vmsptr++ = ']';
6847     }
6848   }
6849   else {
6850     char *vmsptr2;
6851     /* Add a trailing dot if a file with no extension */
6852     vmsptr2 = vmsptr - 1;
6853     if ((vmslen > 1) &&
6854         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
6855         (*vmsptr2 != ')') && (*lastdot != '.')) {
6856         *vmsptr++ = '.';
6857         vmslen++;
6858     }
6859   }
6860
6861   *vmsptr = '\0';
6862   return SS$_NORMAL;
6863 }
6864 #endif
6865
6866  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
6867 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
6868 {
6869 char * result;
6870 int utf8_flag;
6871
6872    /* If a UTF8 flag is being passed, honor it */
6873    utf8_flag = 0;
6874    if (utf8_fl != NULL) {
6875      utf8_flag = *utf8_fl;
6876     *utf8_fl = 0;
6877    }
6878
6879    if (utf8_flag) {
6880      /* If there is a possibility of UTF8, then if any UTF8 characters
6881         are present, then they must be converted to VTF-7
6882       */
6883      result = strcpy(rslt, path); /* FIX-ME */
6884    }
6885    else
6886      result = strcpy(rslt, path);
6887
6888    return result;
6889 }
6890
6891
6892 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
6893 static char *mp_do_tovmsspec
6894    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
6895   static char __tovmsspec_retbuf[VMS_MAXRSS];
6896   char *rslt, *dirend;
6897   char *lastdot;
6898   char *vms_delim;
6899   register char *cp1;
6900   const char *cp2;
6901   unsigned long int infront = 0, hasdir = 1;
6902   int rslt_len;
6903   int no_type_seen;
6904   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6905   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6906
6907   if (path == NULL) return NULL;
6908   rslt_len = VMS_MAXRSS-1;
6909   if (buf) rslt = buf;
6910   else if (ts) Newx(rslt, VMS_MAXRSS, char);
6911   else rslt = __tovmsspec_retbuf;
6912
6913   /* '.' and '..' are "[]" and "[-]" for a quick check */
6914   if (path[0] == '.') {
6915     if (path[1] == '\0') {
6916       strcpy(rslt,"[]");
6917       if (utf8_flag != NULL)
6918         *utf8_flag = 0;
6919       return rslt;
6920     }
6921     else {
6922       if (path[1] == '.' && path[2] == '\0') {
6923         strcpy(rslt,"[-]");
6924         if (utf8_flag != NULL)
6925            *utf8_flag = 0;
6926         return rslt;
6927       }
6928     }
6929   }
6930
6931    /* Posix specifications are now a native VMS format */
6932   /*--------------------------------------------------*/
6933 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6934   if (decc_posix_compliant_pathnames) {
6935     if (strncmp(path,"\"^UP^",5) == 0) {
6936       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
6937       return rslt;
6938     }
6939   }
6940 #endif
6941
6942   /* This is really the only way to see if this is already in VMS format */
6943   sts = vms_split_path
6944        (path,
6945         &v_spec,
6946         &v_len,
6947         &r_spec,
6948         &r_len,
6949         &d_spec,
6950         &d_len,
6951         &n_spec,
6952         &n_len,
6953         &e_spec,
6954         &e_len,
6955         &vs_spec,
6956         &vs_len);
6957   if (sts == 0) {
6958     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
6959        replacement, because the above parse just took care of most of
6960        what is needed to do vmspath when the specification is already
6961        in VMS format.
6962
6963        And if it is not already, it is easier to do the conversion as
6964        part of this routine than to call this routine and then work on
6965        the result.
6966      */
6967
6968     /* If VMS punctuation was found, it is already VMS format */
6969     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
6970       if (utf8_flag != NULL)
6971         *utf8_flag = 0;
6972       strcpy(rslt, path);
6973       return rslt;
6974     }
6975     /* Now, what to do with trailing "." cases where there is no
6976        extension?  If this is a UNIX specification, and EFS characters
6977        are enabled, then the trailing "." should be converted to a "^.".
6978        But if this was already a VMS specification, then it should be
6979        left alone.
6980
6981        So in the case of ambiguity, leave the specification alone.
6982      */
6983
6984
6985     /* If there is a possibility of UTF8, then if any UTF8 characters
6986         are present, then they must be converted to VTF-7
6987      */
6988     if (utf8_flag != NULL)
6989       *utf8_flag = 0;
6990     strcpy(rslt, path);
6991     return rslt;
6992   }
6993
6994   dirend = strrchr(path,'/');
6995
6996   if (dirend == NULL) {
6997      /* If we get here with no UNIX directory delimiters, then this is
6998         not a complete file specification, either garbage a UNIX glob
6999         specification that can not be converted to a VMS wildcard, or
7000         it a UNIX shell macro.  MakeMaker wants these passed through AS-IS,
7001         so apparently other programs expect this also.
7002
7003         utf8 flag setting needs to be preserved.
7004       */
7005       strcpy(rslt, path);
7006       return rslt;
7007   }
7008
7009 /* If POSIX mode active, handle the conversion */
7010 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7011   if (decc_efs_charset) {
7012     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7013     return rslt;
7014   }
7015 #endif
7016
7017   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
7018     if (!*(dirend+2)) dirend +=2;
7019     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7020     if (decc_efs_charset == 0) {
7021       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7022     }
7023   }
7024
7025   cp1 = rslt;
7026   cp2 = path;
7027   lastdot = strrchr(cp2,'.');
7028   if (*cp2 == '/') {
7029     char *trndev;
7030     int islnm, rooted;
7031     STRLEN trnend;
7032
7033     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7034     if (!*(cp2+1)) {
7035       if (decc_disable_posix_root) {
7036         strcpy(rslt,"sys$disk:[000000]");
7037       }
7038       else {
7039         strcpy(rslt,"sys$posix_root:[000000]");
7040       }
7041       if (utf8_flag != NULL)
7042         *utf8_flag = 0;
7043       return rslt;
7044     }
7045     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7046     *cp1 = '\0';
7047     trndev = PerlMem_malloc(VMS_MAXRSS);
7048     if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7049     islnm =  my_trnlnm(rslt,trndev,0);
7050
7051      /* DECC special handling */
7052     if (!islnm) {
7053       if (strcmp(rslt,"bin") == 0) {
7054         strcpy(rslt,"sys$system");
7055         cp1 = rslt + 10;
7056         *cp1 = 0;
7057         islnm =  my_trnlnm(rslt,trndev,0);
7058       }
7059       else if (strcmp(rslt,"tmp") == 0) {
7060         strcpy(rslt,"sys$scratch");
7061         cp1 = rslt + 11;
7062         *cp1 = 0;
7063         islnm =  my_trnlnm(rslt,trndev,0);
7064       }
7065       else if (!decc_disable_posix_root) {
7066         strcpy(rslt, "sys$posix_root");
7067         cp1 = rslt + 13;
7068         *cp1 = 0;
7069         cp2 = path;
7070         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7071         islnm =  my_trnlnm(rslt,trndev,0);
7072       }
7073       else if (strcmp(rslt,"dev") == 0) {
7074         if (strncmp(cp2,"/null", 5) == 0) {
7075           if ((cp2[5] == 0) || (cp2[5] == '/')) {
7076             strcpy(rslt,"NLA0");
7077             cp1 = rslt + 4;
7078             *cp1 = 0;
7079             cp2 = cp2 + 5;
7080             islnm =  my_trnlnm(rslt,trndev,0);
7081           }
7082         }
7083       }
7084     }
7085
7086     trnend = islnm ? strlen(trndev) - 1 : 0;
7087     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7088     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7089     /* If the first element of the path is a logical name, determine
7090      * whether it has to be translated so we can add more directories. */
7091     if (!islnm || rooted) {
7092       *(cp1++) = ':';
7093       *(cp1++) = '[';
7094       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7095       else cp2++;
7096     }
7097     else {
7098       if (cp2 != dirend) {
7099         strcpy(rslt,trndev);
7100         cp1 = rslt + trnend;
7101         if (*cp2 != 0) {
7102           *(cp1++) = '.';
7103           cp2++;
7104         }
7105       }
7106       else {
7107         if (decc_disable_posix_root) {
7108           *(cp1++) = ':';
7109           hasdir = 0;
7110         }
7111       }
7112     }
7113     PerlMem_free(trndev);
7114   }
7115   else {
7116     *(cp1++) = '[';
7117     if (*cp2 == '.') {
7118       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7119         cp2 += 2;         /* skip over "./" - it's redundant */
7120         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
7121       }
7122       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7123         *(cp1++) = '-';                                 /* "../" --> "-" */
7124         cp2 += 3;
7125       }
7126       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7127                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7128         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7129         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7130         cp2 += 4;
7131       }
7132       else if ((cp2 != lastdot) || (lastdot < dirend)) {
7133         /* Escape the extra dots in EFS file specifications */
7134         *(cp1++) = '^';
7135       }
7136       if (cp2 > dirend) cp2 = dirend;
7137     }
7138     else *(cp1++) = '.';
7139   }
7140   for (; cp2 < dirend; cp2++) {
7141     if (*cp2 == '/') {
7142       if (*(cp2-1) == '/') continue;
7143       if (*(cp1-1) != '.') *(cp1++) = '.';
7144       infront = 0;
7145     }
7146     else if (!infront && *cp2 == '.') {
7147       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7148       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
7149       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7150         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7151         else if (*(cp1-2) == '[') *(cp1-1) = '-';
7152         else {  /* back up over previous directory name */
7153           cp1--;
7154           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7155           if (*(cp1-1) == '[') {
7156             memcpy(cp1,"000000.",7);
7157             cp1 += 7;
7158           }
7159         }
7160         cp2 += 2;
7161         if (cp2 == dirend) break;
7162       }
7163       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7164                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7165         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7166         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7167         if (!*(cp2+3)) {
7168           *(cp1++) = '.';  /* Simulate trailing '/' */
7169           cp2 += 2;  /* for loop will incr this to == dirend */
7170         }
7171         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
7172       }
7173       else {
7174         if (decc_efs_charset == 0)
7175           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
7176         else {
7177           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
7178           *(cp1++) = '.';
7179         }
7180       }
7181     }
7182     else {
7183       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
7184       if (*cp2 == '.') {
7185         if (decc_efs_charset == 0)
7186           *(cp1++) = '_';
7187         else {
7188           *(cp1++) = '^';
7189           *(cp1++) = '.';
7190         }
7191       }
7192       else                  *(cp1++) =  *cp2;
7193       infront = 1;
7194     }
7195   }
7196   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
7197   if (hasdir) *(cp1++) = ']';
7198   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
7199   /* fixme for ODS5 */
7200   no_type_seen = 0;
7201   if (cp2 > lastdot)
7202     no_type_seen = 1;
7203   while (*cp2) {
7204     switch(*cp2) {
7205     case '?':
7206         if (decc_efs_charset == 0)
7207           *(cp1++) = '%';
7208         else
7209           *(cp1++) = '?';
7210         cp2++;
7211     case ' ':
7212         *(cp1)++ = '^';
7213         *(cp1)++ = '_';
7214         cp2++;
7215         break;
7216     case '.':
7217         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
7218             decc_readdir_dropdotnotype) {
7219           *(cp1)++ = '^';
7220           *(cp1)++ = '.';
7221           cp2++;
7222
7223           /* trailing dot ==> '^..' on VMS */
7224           if (*cp2 == '\0') {
7225             *(cp1++) = '.';
7226             no_type_seen = 0;
7227           }
7228         }
7229         else {
7230           *(cp1++) = *(cp2++);
7231           no_type_seen = 0;
7232         }
7233         break;
7234     case '$':
7235          /* This could be a macro to be passed through */
7236         *(cp1++) = *(cp2++);
7237         if (*cp2 == '(') {
7238         const char * save_cp2;
7239         char * save_cp1;
7240         int is_macro;
7241
7242             /* paranoid check */
7243             save_cp2 = cp2;
7244             save_cp1 = cp1;
7245             is_macro = 0;
7246
7247             /* Test through */
7248             *(cp1++) = *(cp2++);
7249             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7250                 *(cp1++) = *(cp2++);
7251                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7252                     *(cp1++) = *(cp2++);
7253                 }
7254                 if (*cp2 == ')') {
7255                     *(cp1++) = *(cp2++);
7256                     is_macro = 1;
7257                 }
7258             }
7259             if (is_macro == 0) {
7260                 /* Not really a macro - never mind */
7261                 cp2 = save_cp2;
7262                 cp1 = save_cp1;
7263             }
7264         }
7265         break;
7266     case '\"':
7267     case '~':
7268     case '`':
7269     case '!':
7270     case '#':
7271     case '%':
7272     case '^':
7273     case '&':
7274     case '(':
7275     case ')':
7276     case '=':
7277     case '+':
7278     case '\'':
7279     case '@':
7280     case '[':
7281     case ']':
7282     case '{':
7283     case '}':
7284     case ':':
7285     case '\\':
7286     case '|':
7287     case '<':
7288     case '>':
7289         *(cp1++) = '^';
7290         *(cp1++) = *(cp2++);
7291         break;
7292     case ';':
7293         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
7294          * which is wrong.  UNIX notation should be ".dir." unless
7295          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
7296          * changing this behavior could break more things at this time.
7297          * efs character set effectively does not allow "." to be a version
7298          * delimiter as a further complication about changing this.
7299          */
7300         if (decc_filename_unix_report != 0) {
7301           *(cp1++) = '^';
7302         }
7303         *(cp1++) = *(cp2++);
7304         break;
7305     default:
7306         *(cp1++) = *(cp2++);
7307     }
7308   }
7309   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
7310   char *lcp1;
7311     lcp1 = cp1;
7312     lcp1--;
7313      /* Fix me for "^]", but that requires making sure that you do
7314       * not back up past the start of the filename
7315       */
7316     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
7317       *cp1++ = '.';
7318   }
7319   *cp1 = '\0';
7320
7321   if (utf8_flag != NULL)
7322     *utf8_flag = 0;
7323   return rslt;
7324
7325 }  /* end of do_tovmsspec() */
7326 /*}}}*/
7327 /* External entry points */
7328 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
7329   { return do_tovmsspec(path,buf,0,NULL); }
7330 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
7331   { return do_tovmsspec(path,buf,1,NULL); }
7332 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7333   { return do_tovmsspec(path,buf,0,utf8_fl); }
7334 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7335   { return do_tovmsspec(path,buf,1,utf8_fl); }
7336
7337 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
7338 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7339   static char __tovmspath_retbuf[VMS_MAXRSS];
7340   int vmslen;
7341   char *pathified, *vmsified, *cp;
7342
7343   if (path == NULL) return NULL;
7344   pathified = PerlMem_malloc(VMS_MAXRSS);
7345   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7346   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7347     PerlMem_free(pathified);
7348     return NULL;
7349   }
7350
7351   vmsified = NULL;
7352   if (buf == NULL)
7353      Newx(vmsified, VMS_MAXRSS, char);
7354   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
7355     PerlMem_free(pathified);
7356     if (vmsified) Safefree(vmsified);
7357     return NULL;
7358   }
7359   PerlMem_free(pathified);
7360   if (buf) {
7361     return buf;
7362   }
7363   else if (ts) {
7364     vmslen = strlen(vmsified);
7365     Newx(cp,vmslen+1,char);
7366     memcpy(cp,vmsified,vmslen);
7367     cp[vmslen] = '\0';
7368     Safefree(vmsified);
7369     return cp;
7370   }
7371   else {
7372     strcpy(__tovmspath_retbuf,vmsified);
7373     Safefree(vmsified);
7374     return __tovmspath_retbuf;
7375   }
7376
7377 }  /* end of do_tovmspath() */
7378 /*}}}*/
7379 /* External entry points */
7380 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
7381   { return do_tovmspath(path,buf,0, NULL); }
7382 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
7383   { return do_tovmspath(path,buf,1, NULL); }
7384 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
7385   { return do_tovmspath(path,buf,0,utf8_fl); }
7386 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
7387   { return do_tovmspath(path,buf,1,utf8_fl); }
7388
7389
7390 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
7391 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7392   static char __tounixpath_retbuf[VMS_MAXRSS];
7393   int unixlen;
7394   char *pathified, *unixified, *cp;
7395
7396   if (path == NULL) return NULL;
7397   pathified = PerlMem_malloc(VMS_MAXRSS);
7398   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7399   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7400     PerlMem_free(pathified);
7401     return NULL;
7402   }
7403
7404   unixified = NULL;
7405   if (buf == NULL) {
7406       Newx(unixified, VMS_MAXRSS, char);
7407   }
7408   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
7409     PerlMem_free(pathified);
7410     if (unixified) Safefree(unixified);
7411     return NULL;
7412   }
7413   PerlMem_free(pathified);
7414   if (buf) {
7415     return buf;
7416   }
7417   else if (ts) {
7418     unixlen = strlen(unixified);
7419     Newx(cp,unixlen+1,char);
7420     memcpy(cp,unixified,unixlen);
7421     cp[unixlen] = '\0';
7422     Safefree(unixified);
7423     return cp;
7424   }
7425   else {
7426     strcpy(__tounixpath_retbuf,unixified);
7427     Safefree(unixified);
7428     return __tounixpath_retbuf;
7429   }
7430
7431 }  /* end of do_tounixpath() */
7432 /*}}}*/
7433 /* External entry points */
7434 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
7435   { return do_tounixpath(path,buf,0,NULL); }
7436 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
7437   { return do_tounixpath(path,buf,1,NULL); }
7438 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7439   { return do_tounixpath(path,buf,0,utf8_fl); }
7440 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7441   { return do_tounixpath(path,buf,1,utf8_fl); }
7442
7443 /*
7444  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
7445  *
7446  *****************************************************************************
7447  *                                                                           *
7448  *  Copyright (C) 1989-1994 by                                               *
7449  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
7450  *                                                                           *
7451  *  Permission is hereby  granted for the reproduction of this software,     *
7452  *  on condition that this copyright notice is included in the reproduction, *
7453  *  and that such reproduction is not for purposes of profit or material     *
7454  *  gain.                                                                    *
7455  *                                                                           *
7456  *  27-Aug-1994 Modified for inclusion in perl5                              *
7457  *              by Charles Bailey  bailey@newman.upenn.edu                   *
7458  *****************************************************************************
7459  */
7460
7461 /*
7462  * getredirection() is intended to aid in porting C programs
7463  * to VMS (Vax-11 C).  The native VMS environment does not support
7464  * '>' and '<' I/O redirection, or command line wild card expansion,
7465  * or a command line pipe mechanism using the '|' AND background
7466  * command execution '&'.  All of these capabilities are provided to any
7467  * C program which calls this procedure as the first thing in the
7468  * main program.
7469  * The piping mechanism will probably work with almost any 'filter' type
7470  * of program.  With suitable modification, it may useful for other
7471  * portability problems as well.
7472  *
7473  * Author:  Mark Pizzolato      mark@infocomm.com
7474  */
7475 struct list_item
7476     {
7477     struct list_item *next;
7478     char *value;
7479     };
7480
7481 static void add_item(struct list_item **head,
7482                      struct list_item **tail,
7483                      char *value,
7484                      int *count);
7485
7486 static void mp_expand_wild_cards(pTHX_ char *item,
7487                                 struct list_item **head,
7488                                 struct list_item **tail,
7489                                 int *count);
7490
7491 static int background_process(pTHX_ int argc, char **argv);
7492
7493 static void pipe_and_fork(pTHX_ char **cmargv);
7494
7495 /*{{{ void getredirection(int *ac, char ***av)*/
7496 static void
7497 mp_getredirection(pTHX_ int *ac, char ***av)
7498 /*
7499  * Process vms redirection arg's.  Exit if any error is seen.
7500  * If getredirection() processes an argument, it is erased
7501  * from the vector.  getredirection() returns a new argc and argv value.
7502  * In the event that a background command is requested (by a trailing "&"),
7503  * this routine creates a background subprocess, and simply exits the program.
7504  *
7505  * Warning: do not try to simplify the code for vms.  The code
7506  * presupposes that getredirection() is called before any data is
7507  * read from stdin or written to stdout.
7508  *
7509  * Normal usage is as follows:
7510  *
7511  *      main(argc, argv)
7512  *      int             argc;
7513  *      char            *argv[];
7514  *      {
7515  *              getredirection(&argc, &argv);
7516  *      }
7517  */
7518 {
7519     int                 argc = *ac;     /* Argument Count         */
7520     char                **argv = *av;   /* Argument Vector        */
7521     char                *ap;            /* Argument pointer       */
7522     int                 j;              /* argv[] index           */
7523     int                 item_count = 0; /* Count of Items in List */
7524     struct list_item    *list_head = 0; /* First Item in List       */
7525     struct list_item    *list_tail;     /* Last Item in List        */
7526     char                *in = NULL;     /* Input File Name          */
7527     char                *out = NULL;    /* Output File Name         */
7528     char                *outmode = "w"; /* Mode to Open Output File */
7529     char                *err = NULL;    /* Error File Name          */
7530     char                *errmode = "w"; /* Mode to Open Error File  */
7531     int                 cmargc = 0;     /* Piped Command Arg Count  */
7532     char                **cmargv = NULL;/* Piped Command Arg Vector */
7533
7534     /*
7535      * First handle the case where the last thing on the line ends with
7536      * a '&'.  This indicates the desire for the command to be run in a
7537      * subprocess, so we satisfy that desire.
7538      */
7539     ap = argv[argc-1];
7540     if (0 == strcmp("&", ap))
7541        exit(background_process(aTHX_ --argc, argv));
7542     if (*ap && '&' == ap[strlen(ap)-1])
7543         {
7544         ap[strlen(ap)-1] = '\0';
7545        exit(background_process(aTHX_ argc, argv));
7546         }
7547     /*
7548      * Now we handle the general redirection cases that involve '>', '>>',
7549      * '<', and pipes '|'.
7550      */
7551     for (j = 0; j < argc; ++j)
7552         {
7553         if (0 == strcmp("<", argv[j]))
7554             {
7555             if (j+1 >= argc)
7556                 {
7557                 fprintf(stderr,"No input file after < on command line");
7558                 exit(LIB$_WRONUMARG);
7559                 }
7560             in = argv[++j];
7561             continue;
7562             }
7563         if ('<' == *(ap = argv[j]))
7564             {
7565             in = 1 + ap;
7566             continue;
7567             }
7568         if (0 == strcmp(">", ap))
7569             {
7570             if (j+1 >= argc)
7571                 {
7572                 fprintf(stderr,"No output file after > on command line");
7573                 exit(LIB$_WRONUMARG);
7574                 }
7575             out = argv[++j];
7576             continue;
7577             }
7578         if ('>' == *ap)
7579             {
7580             if ('>' == ap[1])
7581                 {
7582                 outmode = "a";
7583                 if ('\0' == ap[2])
7584                     out = argv[++j];
7585                 else
7586                     out = 2 + ap;
7587                 }
7588             else
7589                 out = 1 + ap;
7590             if (j >= argc)
7591                 {
7592                 fprintf(stderr,"No output file after > or >> on command line");
7593                 exit(LIB$_WRONUMARG);
7594                 }
7595             continue;
7596             }
7597         if (('2' == *ap) && ('>' == ap[1]))
7598             {
7599             if ('>' == ap[2])
7600                 {
7601                 errmode = "a";
7602                 if ('\0' == ap[3])
7603                     err = argv[++j];
7604                 else
7605                     err = 3 + ap;
7606                 }
7607             else
7608                 if ('\0' == ap[2])
7609                     err = argv[++j];
7610                 else
7611                     err = 2 + ap;
7612             if (j >= argc)
7613                 {
7614                 fprintf(stderr,"No output file after 2> or 2>> on command line");
7615                 exit(LIB$_WRONUMARG);
7616                 }
7617             continue;
7618             }
7619         if (0 == strcmp("|", argv[j]))
7620             {
7621             if (j+1 >= argc)
7622                 {
7623                 fprintf(stderr,"No command into which to pipe on command line");
7624                 exit(LIB$_WRONUMARG);
7625                 }
7626             cmargc = argc-(j+1);
7627             cmargv = &argv[j+1];
7628             argc = j;
7629             continue;
7630             }
7631         if ('|' == *(ap = argv[j]))
7632             {
7633             ++argv[j];
7634             cmargc = argc-j;
7635             cmargv = &argv[j];
7636             argc = j;
7637             continue;
7638             }
7639         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7640         }
7641     /*
7642      * Allocate and fill in the new argument vector, Some Unix's terminate
7643      * the list with an extra null pointer.
7644      */
7645     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7646     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7647     *av = argv;
7648     for (j = 0; j < item_count; ++j, list_head = list_head->next)
7649         argv[j] = list_head->value;
7650     *ac = item_count;
7651     if (cmargv != NULL)
7652         {
7653         if (out != NULL)
7654             {
7655             fprintf(stderr,"'|' and '>' may not both be specified on command line");
7656             exit(LIB$_INVARGORD);
7657             }
7658         pipe_and_fork(aTHX_ cmargv);
7659         }
7660
7661     /* Check for input from a pipe (mailbox) */
7662
7663     if (in == NULL && 1 == isapipe(0))
7664         {
7665         char mbxname[L_tmpnam];
7666         long int bufsize;
7667         long int dvi_item = DVI$_DEVBUFSIZ;
7668         $DESCRIPTOR(mbxnam, "");
7669         $DESCRIPTOR(mbxdevnam, "");
7670
7671         /* Input from a pipe, reopen it in binary mode to disable       */
7672         /* carriage control processing.                                 */
7673
7674         fgetname(stdin, mbxname);
7675         mbxnam.dsc$a_pointer = mbxname;
7676         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7677         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7678         mbxdevnam.dsc$a_pointer = mbxname;
7679         mbxdevnam.dsc$w_length = sizeof(mbxname);
7680         dvi_item = DVI$_DEVNAM;
7681         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7682         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
7683         set_errno(0);
7684         set_vaxc_errno(1);
7685         freopen(mbxname, "rb", stdin);
7686         if (errno != 0)
7687             {
7688             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
7689             exit(vaxc$errno);
7690             }
7691         }
7692     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
7693         {
7694         fprintf(stderr,"Can't open input file %s as stdin",in);
7695         exit(vaxc$errno);
7696         }
7697     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
7698         {
7699         fprintf(stderr,"Can't open output file %s as stdout",out);
7700         exit(vaxc$errno);
7701         }
7702         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
7703
7704     if (err != NULL) {
7705         if (strcmp(err,"&1") == 0) {
7706             dup2(fileno(stdout), fileno(stderr));
7707             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
7708         } else {
7709         FILE *tmperr;
7710         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
7711             {
7712             fprintf(stderr,"Can't open error file %s as stderr",err);
7713             exit(vaxc$errno);
7714             }
7715             fclose(tmperr);
7716            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
7717                 {
7718                 exit(vaxc$errno);
7719                 }
7720             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
7721         }
7722         }
7723 #ifdef ARGPROC_DEBUG
7724     PerlIO_printf(Perl_debug_log, "Arglist:\n");
7725     for (j = 0; j < *ac;  ++j)
7726         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
7727 #endif
7728    /* Clear errors we may have hit expanding wildcards, so they don't
7729       show up in Perl's $! later */
7730    set_errno(0); set_vaxc_errno(1);
7731 }  /* end of getredirection() */
7732 /*}}}*/
7733
7734 static void add_item(struct list_item **head,
7735                      struct list_item **tail,
7736                      char *value,
7737                      int *count)
7738 {
7739     if (*head == 0)
7740         {
7741         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7742         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7743         *tail = *head;
7744         }
7745     else {
7746         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7747         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7748         *tail = (*tail)->next;
7749         }
7750     (*tail)->value = value;
7751     ++(*count);
7752 }
7753
7754 static void mp_expand_wild_cards(pTHX_ char *item,
7755                               struct list_item **head,
7756                               struct list_item **tail,
7757                               int *count)
7758 {
7759 int expcount = 0;
7760 unsigned long int context = 0;
7761 int isunix = 0;
7762 int item_len = 0;
7763 char *had_version;
7764 char *had_device;
7765 int had_directory;
7766 char *devdir,*cp;
7767 char *vmsspec;
7768 $DESCRIPTOR(filespec, "");
7769 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
7770 $DESCRIPTOR(resultspec, "");
7771 unsigned long int lff_flags = 0;
7772 int sts;
7773 int rms_sts;
7774
7775 #ifdef VMS_LONGNAME_SUPPORT
7776     lff_flags = LIB$M_FIL_LONG_NAMES;
7777 #endif
7778
7779     for (cp = item; *cp; cp++) {
7780         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
7781         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
7782     }
7783     if (!*cp || isspace(*cp))
7784         {
7785         add_item(head, tail, item, count);
7786         return;
7787         }
7788     else
7789         {
7790      /* "double quoted" wild card expressions pass as is */
7791      /* From DCL that means using e.g.:                  */
7792      /* perl program """perl.*"""                        */
7793      item_len = strlen(item);
7794      if ( '"' == *item && '"' == item[item_len-1] )
7795        {
7796        item++;
7797        item[item_len-2] = '\0';
7798        add_item(head, tail, item, count);
7799        return;
7800        }
7801      }
7802     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
7803     resultspec.dsc$b_class = DSC$K_CLASS_D;
7804     resultspec.dsc$a_pointer = NULL;
7805     vmsspec = PerlMem_malloc(VMS_MAXRSS);
7806     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7807     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
7808       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
7809     if (!isunix || !filespec.dsc$a_pointer)
7810       filespec.dsc$a_pointer = item;
7811     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
7812     /*
7813      * Only return version specs, if the caller specified a version
7814      */
7815     had_version = strchr(item, ';');
7816     /*
7817      * Only return device and directory specs, if the caller specifed either.
7818      */
7819     had_device = strchr(item, ':');
7820     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
7821
7822     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
7823                                  (&filespec, &resultspec, &context,
7824                                   &defaultspec, 0, &rms_sts, &lff_flags)))
7825         {
7826         char *string;
7827         char *c;
7828
7829         string = PerlMem_malloc(resultspec.dsc$w_length+1);
7830         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7831         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
7832         string[resultspec.dsc$w_length] = '\0';
7833         if (NULL == had_version)
7834             *(strrchr(string, ';')) = '\0';
7835         if ((!had_directory) && (had_device == NULL))
7836             {
7837             if (NULL == (devdir = strrchr(string, ']')))
7838                 devdir = strrchr(string, '>');
7839             strcpy(string, devdir + 1);
7840             }
7841         /*
7842          * Be consistent with what the C RTL has already done to the rest of
7843          * the argv items and lowercase all of these names.
7844          */
7845         if (!decc_efs_case_preserve) {
7846             for (c = string; *c; ++c)
7847             if (isupper(*c))
7848                 *c = tolower(*c);
7849         }
7850         if (isunix) trim_unixpath(string,item,1);
7851         add_item(head, tail, string, count);
7852         ++expcount;
7853     }
7854     PerlMem_free(vmsspec);
7855     if (sts != RMS$_NMF)
7856         {
7857         set_vaxc_errno(sts);
7858         switch (sts)
7859             {
7860             case RMS$_FNF: case RMS$_DNF:
7861                 set_errno(ENOENT); break;
7862             case RMS$_DIR:
7863                 set_errno(ENOTDIR); break;
7864             case RMS$_DEV:
7865                 set_errno(ENODEV); break;
7866             case RMS$_FNM: case RMS$_SYN:
7867                 set_errno(EINVAL); break;
7868             case RMS$_PRV:
7869                 set_errno(EACCES); break;
7870             default:
7871                 _ckvmssts_noperl(sts);
7872             }
7873         }
7874     if (expcount == 0)
7875         add_item(head, tail, item, count);
7876     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
7877     _ckvmssts_noperl(lib$find_file_end(&context));
7878 }
7879
7880 static int child_st[2];/* Event Flag set when child process completes   */
7881
7882 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
7883
7884 static unsigned long int exit_handler(int *status)
7885 {
7886 short iosb[4];
7887
7888     if (0 == child_st[0])
7889         {
7890 #ifdef ARGPROC_DEBUG
7891         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
7892 #endif
7893         fflush(stdout);     /* Have to flush pipe for binary data to    */
7894                             /* terminate properly -- <tp@mccall.com>    */
7895         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
7896         sys$dassgn(child_chan);
7897         fclose(stdout);
7898         sys$synch(0, child_st);
7899         }
7900     return(1);
7901 }
7902
7903 static void sig_child(int chan)
7904 {
7905 #ifdef ARGPROC_DEBUG
7906     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
7907 #endif
7908     if (child_st[0] == 0)
7909         child_st[0] = 1;
7910 }
7911
7912 static struct exit_control_block exit_block =
7913     {
7914     0,
7915     exit_handler,
7916     1,
7917     &exit_block.exit_status,
7918     0
7919     };
7920
7921 static void
7922 pipe_and_fork(pTHX_ char **cmargv)
7923 {
7924     PerlIO *fp;
7925     struct dsc$descriptor_s *vmscmd;
7926     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
7927     int sts, j, l, ismcr, quote, tquote = 0;
7928
7929     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
7930     vms_execfree(vmscmd);
7931
7932     j = l = 0;
7933     p = subcmd;
7934     q = cmargv[0];
7935     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
7936               && toupper(*(q+2)) == 'R' && !*(q+3);
7937
7938     while (q && l < MAX_DCL_LINE_LENGTH) {
7939         if (!*q) {
7940             if (j > 0 && quote) {
7941                 *p++ = '"';
7942                 l++;
7943             }
7944             q = cmargv[++j];
7945             if (q) {
7946                 if (ismcr && j > 1) quote = 1;
7947                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
7948                 *p++ = ' ';
7949                 l++;
7950                 if (quote || tquote) {
7951                     *p++ = '"';
7952                     l++;
7953                 }
7954             }
7955         } else {
7956             if ((quote||tquote) && *q == '"') {
7957                 *p++ = '"';
7958                 l++;
7959             }
7960             *p++ = *q++;
7961             l++;
7962         }
7963     }
7964     *p = '\0';
7965
7966     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
7967     if (fp == Nullfp) {
7968         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
7969     }
7970 }
7971
7972 static int background_process(pTHX_ int argc, char **argv)
7973 {
7974 char command[MAX_DCL_SYMBOL + 1] = "$";
7975 $DESCRIPTOR(value, "");
7976 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
7977 static $DESCRIPTOR(null, "NLA0:");
7978 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
7979 char pidstring[80];
7980 $DESCRIPTOR(pidstr, "");
7981 int pid;
7982 unsigned long int flags = 17, one = 1, retsts;
7983 int len;
7984
7985     strcat(command, argv[0]);
7986     len = strlen(command);
7987     while (--argc && (len < MAX_DCL_SYMBOL))
7988         {
7989         strcat(command, " \"");
7990         strcat(command, *(++argv));
7991         strcat(command, "\"");
7992         len = strlen(command);
7993         }
7994     value.dsc$a_pointer = command;
7995     value.dsc$w_length = strlen(value.dsc$a_pointer);
7996     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
7997     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
7998     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
7999         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8000     }
8001     else {
8002         _ckvmssts_noperl(retsts);
8003     }
8004 #ifdef ARGPROC_DEBUG
8005     PerlIO_printf(Perl_debug_log, "%s\n", command);
8006 #endif
8007     sprintf(pidstring, "%08X", pid);
8008     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8009     pidstr.dsc$a_pointer = pidstring;
8010     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8011     lib$set_symbol(&pidsymbol, &pidstr);
8012     return(SS$_NORMAL);
8013 }
8014 /*}}}*/
8015 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8016
8017
8018 /* OS-specific initialization at image activation (not thread startup) */
8019 /* Older VAXC header files lack these constants */
8020 #ifndef JPI$_RIGHTS_SIZE
8021 #  define JPI$_RIGHTS_SIZE 817
8022 #endif
8023 #ifndef KGB$M_SUBSYSTEM
8024 #  define KGB$M_SUBSYSTEM 0x8
8025 #endif
8026
8027 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8028
8029 /*{{{void vms_image_init(int *, char ***)*/
8030 void
8031 vms_image_init(int *argcp, char ***argvp)
8032 {
8033   char eqv[LNM$C_NAMLENGTH+1] = "";
8034   unsigned int len, tabct = 8, tabidx = 0;
8035   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8036   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8037   unsigned short int dummy, rlen;
8038   struct dsc$descriptor_s **tabvec;
8039 #if defined(PERL_IMPLICIT_CONTEXT)
8040   pTHX = NULL;
8041 #endif
8042   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
8043                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
8044                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8045                                  {          0,                0,    0,      0} };
8046
8047 #ifdef KILL_BY_SIGPRC
8048     Perl_csighandler_init();
8049 #endif
8050
8051   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8052   _ckvmssts_noperl(iosb[0]);
8053   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8054     if (iprv[i]) {           /* Running image installed with privs? */
8055       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
8056       will_taint = TRUE;
8057       break;
8058     }
8059   }
8060   /* Rights identifiers might trigger tainting as well. */
8061   if (!will_taint && (rlen || rsz)) {
8062     while (rlen < rsz) {
8063       /* We didn't get all the identifiers on the first pass.  Allocate a
8064        * buffer much larger than $GETJPI wants (rsz is size in bytes that
8065        * were needed to hold all identifiers at time of last call; we'll
8066        * allocate that many unsigned long ints), and go back and get 'em.
8067        * If it gave us less than it wanted to despite ample buffer space,
8068        * something's broken.  Is your system missing a system identifier?
8069        */
8070       if (rsz <= jpilist[1].buflen) {
8071          /* Perl_croak accvios when used this early in startup. */
8072          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8073                          rsz, (unsigned long) jpilist[1].buflen,
8074                          "Check your rights database for corruption.\n");
8075          exit(SS$_ABORT);
8076       }
8077       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8078       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8079       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8080       jpilist[1].buflen = rsz * sizeof(unsigned long int);
8081       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8082       _ckvmssts_noperl(iosb[0]);
8083     }
8084     mask = jpilist[1].bufadr;
8085     /* Check attribute flags for each identifier (2nd longword); protected
8086      * subsystem identifiers trigger tainting.
8087      */
8088     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8089       if (mask[i] & KGB$M_SUBSYSTEM) {
8090         will_taint = TRUE;
8091         break;
8092       }
8093     }
8094     if (mask != rlst) PerlMem_free(mask);
8095   }
8096
8097   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8098    * logical, some versions of the CRTL will add a phanthom /000000/
8099    * directory.  This needs to be removed.
8100    */
8101   if (decc_filename_unix_report) {
8102   char * zeros;
8103   int ulen;
8104     ulen = strlen(argvp[0][0]);
8105     if (ulen > 7) {
8106       zeros = strstr(argvp[0][0], "/000000/");
8107       if (zeros != NULL) {
8108         int mlen;
8109         mlen = ulen - (zeros - argvp[0][0]) - 7;
8110         memmove(zeros, &zeros[7], mlen);
8111         ulen = ulen - 7;
8112         argvp[0][0][ulen] = '\0';
8113       }
8114     }
8115     /* It also may have a trailing dot that needs to be removed otherwise
8116      * it will be converted to VMS mode incorrectly.
8117      */
8118     ulen--;
8119     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8120       argvp[0][0][ulen] = '\0';
8121   }
8122
8123   /* We need to use this hack to tell Perl it should run with tainting,
8124    * since its tainting flag may be part of the PL_curinterp struct, which
8125    * hasn't been allocated when vms_image_init() is called.
8126    */
8127   if (will_taint) {
8128     char **newargv, **oldargv;
8129     oldargv = *argvp;
8130     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8131     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8132     newargv[0] = oldargv[0];
8133     newargv[1] = PerlMem_malloc(3 * sizeof(char));
8134     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8135     strcpy(newargv[1], "-T");
8136     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8137     (*argcp)++;
8138     newargv[*argcp] = NULL;
8139     /* We orphan the old argv, since we don't know where it's come from,
8140      * so we don't know how to free it.
8141      */
8142     *argvp = newargv;
8143   }
8144   else {  /* Did user explicitly request tainting? */
8145     int i;
8146     char *cp, **av = *argvp;
8147     for (i = 1; i < *argcp; i++) {
8148       if (*av[i] != '-') break;
8149       for (cp = av[i]+1; *cp; cp++) {
8150         if (*cp == 'T') { will_taint = 1; break; }
8151         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8152                   strchr("DFIiMmx",*cp)) break;
8153       }
8154       if (will_taint) break;
8155     }
8156   }
8157
8158   for (tabidx = 0;
8159        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8160        tabidx++) {
8161     if (!tabidx) {
8162       tabvec = (struct dsc$descriptor_s **)
8163             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8164       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8165     }
8166     else if (tabidx >= tabct) {
8167       tabct += 8;
8168       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
8169       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8170     }
8171     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8172     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8173     tabvec[tabidx]->dsc$w_length  = 0;
8174     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
8175     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
8176     tabvec[tabidx]->dsc$a_pointer = NULL;
8177     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
8178   }
8179   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
8180
8181   getredirection(argcp,argvp);
8182 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
8183   {
8184 # include <reentrancy.h>
8185   decc$set_reentrancy(C$C_MULTITHREAD);
8186   }
8187 #endif
8188   return;
8189 }
8190 /*}}}*/
8191
8192
8193 /* trim_unixpath()
8194  * Trim Unix-style prefix off filespec, so it looks like what a shell
8195  * glob expansion would return (i.e. from specified prefix on, not
8196  * full path).  Note that returned filespec is Unix-style, regardless
8197  * of whether input filespec was VMS-style or Unix-style.
8198  *
8199  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
8200  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
8201  * vector of options; at present, only bit 0 is used, and if set tells
8202  * trim unixpath to try the current default directory as a prefix when
8203  * presented with a possibly ambiguous ... wildcard.
8204  *
8205  * Returns !=0 on success, with trimmed filespec replacing contents of
8206  * fspec, and 0 on failure, with contents of fpsec unchanged.
8207  */
8208 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
8209 int
8210 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
8211 {
8212   char *unixified, *unixwild,
8213        *template, *base, *end, *cp1, *cp2;
8214   register int tmplen, reslen = 0, dirs = 0;
8215
8216   unixwild = PerlMem_malloc(VMS_MAXRSS);
8217   if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
8218   if (!wildspec || !fspec) return 0;
8219   template = unixwild;
8220   if (strpbrk(wildspec,"]>:") != NULL) {
8221     if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
8222         PerlMem_free(unixwild);
8223         return 0;
8224     }
8225   }
8226   else {
8227     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
8228     unixwild[VMS_MAXRSS-1] = 0;
8229   }
8230   unixified = PerlMem_malloc(VMS_MAXRSS);
8231   if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
8232   if (strpbrk(fspec,"]>:") != NULL) {
8233     if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
8234         PerlMem_free(unixwild);
8235         PerlMem_free(unixified);
8236         return 0;
8237     }
8238     else base = unixified;
8239     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
8240      * check to see that final result fits into (isn't longer than) fspec */
8241     reslen = strlen(fspec);
8242   }
8243   else base = fspec;
8244
8245   /* No prefix or absolute path on wildcard, so nothing to remove */
8246   if (!*template || *template == '/') {
8247     PerlMem_free(unixwild);
8248     if (base == fspec) {
8249         PerlMem_free(unixified);
8250         return 1;
8251     }
8252     tmplen = strlen(unixified);
8253     if (tmplen > reslen) {
8254         PerlMem_free(unixified);
8255         return 0;  /* not enough space */
8256     }
8257     /* Copy unixified resultant, including trailing NUL */
8258     memmove(fspec,unixified,tmplen+1);
8259     PerlMem_free(unixified);
8260     return 1;
8261   }
8262
8263   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
8264   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
8265     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
8266     for (cp1 = end ;cp1 >= base; cp1--)
8267       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
8268         { cp1++; break; }
8269     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
8270     PerlMem_free(unixified);
8271     PerlMem_free(unixwild);
8272     return 1;
8273   }
8274   else {
8275     char *tpl, *lcres;
8276     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
8277     int ells = 1, totells, segdirs, match;
8278     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
8279                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8280
8281     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
8282     totells = ells;
8283     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
8284     tpl = PerlMem_malloc(VMS_MAXRSS);
8285     if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
8286     if (ellipsis == template && opts & 1) {
8287       /* Template begins with an ellipsis.  Since we can't tell how many
8288        * directory names at the front of the resultant to keep for an
8289        * arbitrary starting point, we arbitrarily choose the current
8290        * default directory as a starting point.  If it's there as a prefix,
8291        * clip it off.  If not, fall through and act as if the leading
8292        * ellipsis weren't there (i.e. return shortest possible path that
8293        * could match template).
8294        */
8295       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
8296           PerlMem_free(tpl);
8297           PerlMem_free(unixified);
8298           PerlMem_free(unixwild);
8299           return 0;
8300       }
8301       if (!decc_efs_case_preserve) {
8302         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8303           if (_tolower(*cp1) != _tolower(*cp2)) break;
8304       }
8305       segdirs = dirs - totells;  /* Min # of dirs we must have left */
8306       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
8307       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
8308         memmove(fspec,cp2+1,end - cp2);
8309         PerlMem_free(tpl);
8310         PerlMem_free(unixified);
8311         PerlMem_free(unixwild);
8312         return 1;
8313       }
8314     }
8315     /* First off, back up over constant elements at end of path */
8316     if (dirs) {
8317       for (front = end ; front >= base; front--)
8318          if (*front == '/' && !dirs--) { front++; break; }
8319     }
8320     lcres = PerlMem_malloc(VMS_MAXRSS);
8321     if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
8322     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
8323          cp1++,cp2++) {
8324             if (!decc_efs_case_preserve) {
8325                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
8326             }
8327             else {
8328                 *cp2 = *cp1;
8329             }
8330     }
8331     if (cp1 != '\0') {
8332         PerlMem_free(tpl);
8333         PerlMem_free(unixified);
8334         PerlMem_free(unixwild);
8335         PerlMem_free(lcres);
8336         return 0;  /* Path too long. */
8337     }
8338     lcend = cp2;
8339     *cp2 = '\0';  /* Pick up with memcpy later */
8340     lcfront = lcres + (front - base);
8341     /* Now skip over each ellipsis and try to match the path in front of it. */
8342     while (ells--) {
8343       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
8344         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
8345             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
8346       if (cp1 < template) break; /* template started with an ellipsis */
8347       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
8348         ellipsis = cp1; continue;
8349       }
8350       wilddsc.dsc$a_pointer = tpl;
8351       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
8352       nextell = cp1;
8353       for (segdirs = 0, cp2 = tpl;
8354            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
8355            cp1++, cp2++) {
8356          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
8357          else {
8358             if (!decc_efs_case_preserve) {
8359               *cp2 = _tolower(*cp1);  /* else lowercase for match */
8360             }
8361             else {
8362               *cp2 = *cp1;  /* else preserve case for match */
8363             }
8364          }
8365          if (*cp2 == '/') segdirs++;
8366       }
8367       if (cp1 != ellipsis - 1) {
8368           PerlMem_free(tpl);
8369           PerlMem_free(unixified);
8370           PerlMem_free(unixwild);
8371           PerlMem_free(lcres);
8372           return 0; /* Path too long */
8373       }
8374       /* Back up at least as many dirs as in template before matching */
8375       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
8376         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
8377       for (match = 0; cp1 > lcres;) {
8378         resdsc.dsc$a_pointer = cp1;
8379         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
8380           match++;
8381           if (match == 1) lcfront = cp1;
8382         }
8383         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
8384       }
8385       if (!match) {
8386         PerlMem_free(tpl);
8387         PerlMem_free(unixified);
8388         PerlMem_free(unixwild);
8389         PerlMem_free(lcres);
8390         return 0;  /* Can't find prefix ??? */
8391       }
8392       if (match > 1 && opts & 1) {
8393         /* This ... wildcard could cover more than one set of dirs (i.e.
8394          * a set of similar dir names is repeated).  If the template
8395          * contains more than 1 ..., upstream elements could resolve the
8396          * ambiguity, but it's not worth a full backtracking setup here.
8397          * As a quick heuristic, clip off the current default directory
8398          * if it's present to find the trimmed spec, else use the
8399          * shortest string that this ... could cover.
8400          */
8401         char def[NAM$C_MAXRSS+1], *st;
8402
8403         if (getcwd(def, sizeof def,0) == NULL) {
8404             Safefree(unixified);
8405             Safefree(unixwild);
8406             Safefree(lcres);
8407             Safefree(tpl);
8408             return 0;
8409         }
8410         if (!decc_efs_case_preserve) {
8411           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8412             if (_tolower(*cp1) != _tolower(*cp2)) break;
8413         }
8414         segdirs = dirs - totells;  /* Min # of dirs we must have left */
8415         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
8416         if (*cp1 == '\0' && *cp2 == '/') {
8417           memmove(fspec,cp2+1,end - cp2);
8418           PerlMem_free(tpl);
8419           PerlMem_free(unixified);
8420           PerlMem_free(unixwild);
8421           PerlMem_free(lcres);
8422           return 1;
8423         }
8424         /* Nope -- stick with lcfront from above and keep going. */
8425       }
8426     }
8427     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
8428     PerlMem_free(tpl);
8429     PerlMem_free(unixified);
8430     PerlMem_free(unixwild);
8431     PerlMem_free(lcres);
8432     return 1;
8433     ellipsis = nextell;
8434   }
8435
8436 }  /* end of trim_unixpath() */
8437 /*}}}*/
8438
8439
8440 /*
8441  *  VMS readdir() routines.
8442  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
8443  *
8444  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
8445  *  Minor modifications to original routines.
8446  */
8447
8448 /* readdir may have been redefined by reentr.h, so make sure we get
8449  * the local version for what we do here.
8450  */
8451 #ifdef readdir
8452 # undef readdir
8453 #endif
8454 #if !defined(PERL_IMPLICIT_CONTEXT)
8455 # define readdir Perl_readdir
8456 #else
8457 # define readdir(a) Perl_readdir(aTHX_ a)
8458 #endif
8459
8460     /* Number of elements in vms_versions array */
8461 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
8462
8463 /*
8464  *  Open a directory, return a handle for later use.
8465  */
8466 /*{{{ DIR *opendir(char*name) */
8467 DIR *
8468 Perl_opendir(pTHX_ const char *name)
8469 {
8470     DIR *dd;
8471     char *dir;
8472     Stat_t sb;
8473     int unix_flag;
8474
8475     unix_flag = 0;
8476     if (decc_efs_charset) {
8477         unix_flag = is_unix_filespec(name);
8478     }
8479
8480     Newx(dir, VMS_MAXRSS, char);
8481     if (do_tovmspath(name,dir,0,NULL) == NULL) {
8482       Safefree(dir);
8483       return NULL;
8484     }
8485     /* Check access before stat; otherwise stat does not
8486      * accurately report whether it's a directory.
8487      */
8488     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
8489       /* cando_by_name has already set errno */
8490       Safefree(dir);
8491       return NULL;
8492     }
8493     if (flex_stat(dir,&sb) == -1) return NULL;
8494     if (!S_ISDIR(sb.st_mode)) {
8495       Safefree(dir);
8496       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
8497       return NULL;
8498     }
8499     /* Get memory for the handle, and the pattern. */
8500     Newx(dd,1,DIR);
8501     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
8502
8503     /* Fill in the fields; mainly playing with the descriptor. */
8504     sprintf(dd->pattern, "%s*.*",dir);
8505     Safefree(dir);
8506     dd->context = 0;
8507     dd->count = 0;
8508     dd->flags = 0;
8509     if (unix_flag)
8510         dd->flags = PERL_VMSDIR_M_UNIXSPECS;
8511     dd->pat.dsc$a_pointer = dd->pattern;
8512     dd->pat.dsc$w_length = strlen(dd->pattern);
8513     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
8514     dd->pat.dsc$b_class = DSC$K_CLASS_S;
8515 #if defined(USE_ITHREADS)
8516     Newx(dd->mutex,1,perl_mutex);
8517     MUTEX_INIT( (perl_mutex *) dd->mutex );
8518 #else
8519     dd->mutex = NULL;
8520 #endif
8521
8522     return dd;
8523 }  /* end of opendir() */
8524 /*}}}*/
8525
8526 /*
8527  *  Set the flag to indicate we want versions or not.
8528  */
8529 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
8530 void
8531 vmsreaddirversions(DIR *dd, int flag)
8532 {
8533     if (flag)
8534         dd->flags |= PERL_VMSDIR_M_VERSIONS;
8535     else
8536         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8537 }
8538 /*}}}*/
8539
8540 /*
8541  *  Free up an opened directory.
8542  */
8543 /*{{{ void closedir(DIR *dd)*/
8544 void
8545 Perl_closedir(DIR *dd)
8546 {
8547     int sts;
8548
8549     sts = lib$find_file_end(&dd->context);
8550     Safefree(dd->pattern);
8551 #if defined(USE_ITHREADS)
8552     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
8553     Safefree(dd->mutex);
8554 #endif
8555     Safefree(dd);
8556 }
8557 /*}}}*/
8558
8559 /*
8560  *  Collect all the version numbers for the current file.
8561  */
8562 static void
8563 collectversions(pTHX_ DIR *dd)
8564 {
8565     struct dsc$descriptor_s     pat;
8566     struct dsc$descriptor_s     res;
8567     struct dirent *e;
8568     char *p, *text, *buff;
8569     int i;
8570     unsigned long context, tmpsts;
8571
8572     /* Convenient shorthand. */
8573     e = &dd->entry;
8574
8575     /* Add the version wildcard, ignoring the "*.*" put on before */
8576     i = strlen(dd->pattern);
8577     Newx(text,i + e->d_namlen + 3,char);
8578     strcpy(text, dd->pattern);
8579     sprintf(&text[i - 3], "%s;*", e->d_name);
8580
8581     /* Set up the pattern descriptor. */
8582     pat.dsc$a_pointer = text;
8583     pat.dsc$w_length = i + e->d_namlen - 1;
8584     pat.dsc$b_dtype = DSC$K_DTYPE_T;
8585     pat.dsc$b_class = DSC$K_CLASS_S;
8586
8587     /* Set up result descriptor. */
8588     Newx(buff, VMS_MAXRSS, char);
8589     res.dsc$a_pointer = buff;
8590     res.dsc$w_length = VMS_MAXRSS - 1;
8591     res.dsc$b_dtype = DSC$K_DTYPE_T;
8592     res.dsc$b_class = DSC$K_CLASS_S;
8593
8594     /* Read files, collecting versions. */
8595     for (context = 0, e->vms_verscount = 0;
8596          e->vms_verscount < VERSIZE(e);
8597          e->vms_verscount++) {
8598         unsigned long rsts;
8599         unsigned long flags = 0;
8600
8601 #ifdef VMS_LONGNAME_SUPPORT
8602         flags = LIB$M_FIL_LONG_NAMES;
8603 #endif
8604         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
8605         if (tmpsts == RMS$_NMF || context == 0) break;
8606         _ckvmssts(tmpsts);
8607         buff[VMS_MAXRSS - 1] = '\0';
8608         if ((p = strchr(buff, ';')))
8609             e->vms_versions[e->vms_verscount] = atoi(p + 1);
8610         else
8611             e->vms_versions[e->vms_verscount] = -1;
8612     }
8613
8614     _ckvmssts(lib$find_file_end(&context));
8615     Safefree(text);
8616     Safefree(buff);
8617
8618 }  /* end of collectversions() */
8619
8620 /*
8621  *  Read the next entry from the directory.
8622  */
8623 /*{{{ struct dirent *readdir(DIR *dd)*/
8624 struct dirent *
8625 Perl_readdir(pTHX_ DIR *dd)
8626 {
8627     struct dsc$descriptor_s     res;
8628     char *p, *buff;
8629     unsigned long int tmpsts;
8630     unsigned long rsts;
8631     unsigned long flags = 0;
8632     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8633     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8634
8635     /* Set up result descriptor, and get next file. */
8636     Newx(buff, VMS_MAXRSS, char);
8637     res.dsc$a_pointer = buff;
8638     res.dsc$w_length = VMS_MAXRSS - 1;
8639     res.dsc$b_dtype = DSC$K_DTYPE_T;
8640     res.dsc$b_class = DSC$K_CLASS_S;
8641
8642 #ifdef VMS_LONGNAME_SUPPORT
8643     flags = LIB$M_FIL_LONG_NAMES;
8644 #endif
8645
8646     tmpsts = lib$find_file
8647         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8648     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
8649     if (!(tmpsts & 1)) {
8650       set_vaxc_errno(tmpsts);
8651       switch (tmpsts) {
8652         case RMS$_PRV:
8653           set_errno(EACCES); break;
8654         case RMS$_DEV:
8655           set_errno(ENODEV); break;
8656         case RMS$_DIR:
8657           set_errno(ENOTDIR); break;
8658         case RMS$_FNF: case RMS$_DNF:
8659           set_errno(ENOENT); break;
8660         default:
8661           set_errno(EVMSERR);
8662       }
8663       Safefree(buff);
8664       return NULL;
8665     }
8666     dd->count++;
8667     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8668     if (!decc_efs_case_preserve) {
8669       buff[VMS_MAXRSS - 1] = '\0';
8670       for (p = buff; *p; p++) *p = _tolower(*p);
8671     }
8672     else {
8673       /* we don't want to force to lowercase, just null terminate */
8674       buff[res.dsc$w_length] = '\0';
8675     }
8676     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
8677     *p = '\0';
8678
8679     /* Skip any directory component and just copy the name. */
8680     sts = vms_split_path
8681        (buff,
8682         &v_spec,
8683         &v_len,
8684         &r_spec,
8685         &r_len,
8686         &d_spec,
8687         &d_len,
8688         &n_spec,
8689         &n_len,
8690         &e_spec,
8691         &e_len,
8692         &vs_spec,
8693         &vs_len);
8694
8695     /* Drop NULL extensions on UNIX file specification */
8696     if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
8697         (e_len == 1) && decc_readdir_dropdotnotype)) {
8698         e_len = 0;
8699         e_spec[0] = '\0';
8700     }
8701
8702     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
8703     dd->entry.d_name[n_len + e_len] = '\0';
8704     dd->entry.d_namlen = strlen(dd->entry.d_name);
8705
8706     /* Convert the filename to UNIX format if needed */
8707     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
8708
8709         /* Translate the encoded characters. */
8710         /* Fixme: unicode handling could result in embedded 0 characters */
8711         if (strchr(dd->entry.d_name, '^') != NULL) {
8712             char new_name[256];
8713             char * q;
8714             int cnt;
8715             p = dd->entry.d_name;
8716             q = new_name;
8717             while (*p != 0) {
8718                 int x, y;
8719                 x = copy_expand_vms_filename_escape(q, p, &y);
8720                 p += x;
8721                 q += y;
8722                 /* fix-me */
8723                 /* if y > 1, then this is a wide file specification */
8724                 /* Wide file specifications need to be passed in Perl */
8725                 /* counted strings apparently with a unicode flag */
8726             }
8727             *q = 0;
8728             strcpy(dd->entry.d_name, new_name);
8729         }
8730     }
8731
8732     dd->entry.vms_verscount = 0;
8733     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
8734     Safefree(buff);
8735     return &dd->entry;
8736
8737 }  /* end of readdir() */
8738 /*}}}*/
8739
8740 /*
8741  *  Read the next entry from the directory -- thread-safe version.
8742  */
8743 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
8744 int
8745 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
8746 {
8747     int retval;
8748
8749     MUTEX_LOCK( (perl_mutex *) dd->mutex );
8750
8751     entry = readdir(dd);
8752     *result = entry;
8753     retval = ( *result == NULL ? errno : 0 );
8754
8755     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
8756
8757     return retval;
8758
8759 }  /* end of readdir_r() */
8760 /*}}}*/
8761
8762 /*
8763  *  Return something that can be used in a seekdir later.
8764  */
8765 /*{{{ long telldir(DIR *dd)*/
8766 long
8767 Perl_telldir(DIR *dd)
8768 {
8769     return dd->count;
8770 }
8771 /*}}}*/
8772
8773 /*
8774  *  Return to a spot where we used to be.  Brute force.
8775  */
8776 /*{{{ void seekdir(DIR *dd,long count)*/
8777 void
8778 Perl_seekdir(pTHX_ DIR *dd, long count)
8779 {
8780     int old_flags;
8781
8782     /* If we haven't done anything yet... */
8783     if (dd->count == 0)
8784         return;
8785
8786     /* Remember some state, and clear it. */
8787     old_flags = dd->flags;
8788     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8789     _ckvmssts(lib$find_file_end(&dd->context));
8790     dd->context = 0;
8791
8792     /* The increment is in readdir(). */
8793     for (dd->count = 0; dd->count < count; )
8794         readdir(dd);
8795
8796     dd->flags = old_flags;
8797
8798 }  /* end of seekdir() */
8799 /*}}}*/
8800
8801 /* VMS subprocess management
8802  *
8803  * my_vfork() - just a vfork(), after setting a flag to record that
8804  * the current script is trying a Unix-style fork/exec.
8805  *
8806  * vms_do_aexec() and vms_do_exec() are called in response to the
8807  * perl 'exec' function.  If this follows a vfork call, then they
8808  * call out the regular perl routines in doio.c which do an
8809  * execvp (for those who really want to try this under VMS).
8810  * Otherwise, they do exactly what the perl docs say exec should
8811  * do - terminate the current script and invoke a new command
8812  * (See below for notes on command syntax.)
8813  *
8814  * do_aspawn() and do_spawn() implement the VMS side of the perl
8815  * 'system' function.
8816  *
8817  * Note on command arguments to perl 'exec' and 'system': When handled
8818  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
8819  * are concatenated to form a DCL command string.  If the first arg
8820  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
8821  * the command string is handed off to DCL directly.  Otherwise,
8822  * the first token of the command is taken as the filespec of an image
8823  * to run.  The filespec is expanded using a default type of '.EXE' and
8824  * the process defaults for device, directory, etc., and if found, the resultant
8825  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
8826  * the command string as parameters.  This is perhaps a bit complicated,
8827  * but I hope it will form a happy medium between what VMS folks expect
8828  * from lib$spawn and what Unix folks expect from exec.
8829  */
8830
8831 static int vfork_called;
8832
8833 /*{{{int my_vfork()*/
8834 int
8835 my_vfork()
8836 {
8837   vfork_called++;
8838   return vfork();
8839 }
8840 /*}}}*/
8841
8842
8843 static void
8844 vms_execfree(struct dsc$descriptor_s *vmscmd)
8845 {
8846   if (vmscmd) {
8847       if (vmscmd->dsc$a_pointer) {
8848           PerlMem_free(vmscmd->dsc$a_pointer);
8849       }
8850       PerlMem_free(vmscmd);
8851   }
8852 }
8853
8854 static char *
8855 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
8856 {
8857   char *junk, *tmps = Nullch;
8858   register size_t cmdlen = 0;
8859   size_t rlen;
8860   register SV **idx;
8861   STRLEN n_a;
8862
8863   idx = mark;
8864   if (really) {
8865     tmps = SvPV(really,rlen);
8866     if (*tmps) {
8867       cmdlen += rlen + 1;
8868       idx++;
8869     }
8870   }
8871
8872   for (idx++; idx <= sp; idx++) {
8873     if (*idx) {
8874       junk = SvPVx(*idx,rlen);
8875       cmdlen += rlen ? rlen + 1 : 0;
8876     }
8877   }
8878   Newx(PL_Cmd, cmdlen+1, char);
8879
8880   if (tmps && *tmps) {
8881     strcpy(PL_Cmd,tmps);
8882     mark++;
8883   }
8884   else *PL_Cmd = '\0';
8885   while (++mark <= sp) {
8886     if (*mark) {
8887       char *s = SvPVx(*mark,n_a);
8888       if (!*s) continue;
8889       if (*PL_Cmd) strcat(PL_Cmd," ");
8890       strcat(PL_Cmd,s);
8891     }
8892   }
8893   return PL_Cmd;
8894
8895 }  /* end of setup_argstr() */
8896
8897
8898 static unsigned long int
8899 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
8900                    struct dsc$descriptor_s **pvmscmd)
8901 {
8902   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
8903   char image_name[NAM$C_MAXRSS+1];
8904   char image_argv[NAM$C_MAXRSS+1];
8905   $DESCRIPTOR(defdsc,".EXE");
8906   $DESCRIPTOR(defdsc2,".");
8907   $DESCRIPTOR(resdsc,resspec);
8908   struct dsc$descriptor_s *vmscmd;
8909   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8910   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
8911   register char *s, *rest, *cp, *wordbreak;
8912   char * cmd;
8913   int cmdlen;
8914   register int isdcl;
8915
8916   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8917   if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
8918
8919   /* Make a copy for modification */
8920   cmdlen = strlen(incmd);
8921   cmd = PerlMem_malloc(cmdlen+1);
8922   if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
8923   strncpy(cmd, incmd, cmdlen);
8924   cmd[cmdlen] = 0;
8925   image_name[0] = 0;
8926   image_argv[0] = 0;
8927
8928   vmscmd->dsc$a_pointer = NULL;
8929   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
8930   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
8931   vmscmd->dsc$w_length = 0;
8932   if (pvmscmd) *pvmscmd = vmscmd;
8933
8934   if (suggest_quote) *suggest_quote = 0;
8935
8936   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
8937     PerlMem_free(cmd);
8938     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
8939   }
8940
8941   s = cmd;
8942
8943   while (*s && isspace(*s)) s++;
8944
8945   if (*s == '@' || *s == '$') {
8946     vmsspec[0] = *s;  rest = s + 1;
8947     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
8948   }
8949   else { cp = vmsspec; rest = s; }
8950   if (*rest == '.' || *rest == '/') {
8951     char *cp2;
8952     for (cp2 = resspec;
8953          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
8954          rest++, cp2++) *cp2 = *rest;
8955     *cp2 = '\0';
8956     if (do_tovmsspec(resspec,cp,0,NULL)) {
8957       s = vmsspec;
8958       if (*rest) {
8959         for (cp2 = vmsspec + strlen(vmsspec);
8960              *rest && cp2 - vmsspec < sizeof vmsspec;
8961              rest++, cp2++) *cp2 = *rest;
8962         *cp2 = '\0';
8963       }
8964     }
8965   }
8966   /* Intuit whether verb (first word of cmd) is a DCL command:
8967    *   - if first nonspace char is '@', it's a DCL indirection
8968    * otherwise
8969    *   - if verb contains a filespec separator, it's not a DCL command
8970    *   - if it doesn't, caller tells us whether to default to a DCL
8971    *     command, or to a local image unless told it's DCL (by leading '$')
8972    */
8973   if (*s == '@') {
8974       isdcl = 1;
8975       if (suggest_quote) *suggest_quote = 1;
8976   } else {
8977     register char *filespec = strpbrk(s,":<[.;");
8978     rest = wordbreak = strpbrk(s," \"\t/");
8979     if (!wordbreak) wordbreak = s + strlen(s);
8980     if (*s == '$') check_img = 0;
8981     if (filespec && (filespec < wordbreak)) isdcl = 0;
8982     else isdcl = !check_img;
8983   }
8984
8985   if (!isdcl) {
8986     int rsts;
8987     imgdsc.dsc$a_pointer = s;
8988     imgdsc.dsc$w_length = wordbreak - s;
8989     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8990     if (!(retsts&1)) {
8991         _ckvmssts(lib$find_file_end(&cxt));
8992         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
8993       if (!(retsts & 1) && *s == '$') {
8994         _ckvmssts(lib$find_file_end(&cxt));
8995         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
8996         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8997         if (!(retsts&1)) {
8998           _ckvmssts(lib$find_file_end(&cxt));
8999           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9000         }
9001       }
9002     }
9003     _ckvmssts(lib$find_file_end(&cxt));
9004
9005     if (retsts & 1) {
9006       FILE *fp;
9007       s = resspec;
9008       while (*s && !isspace(*s)) s++;
9009       *s = '\0';
9010
9011       /* check that it's really not DCL with no file extension */
9012       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9013       if (fp) {
9014         char b[256] = {0,0,0,0};
9015         read(fileno(fp), b, 256);
9016         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9017         if (isdcl) {
9018           int shebang_len;
9019
9020           /* Check for script */
9021           shebang_len = 0;
9022           if ((b[0] == '#') && (b[1] == '!'))
9023              shebang_len = 2;
9024 #ifdef ALTERNATE_SHEBANG
9025           else {
9026             shebang_len = strlen(ALTERNATE_SHEBANG);
9027             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9028               char * perlstr;
9029                 perlstr = strstr("perl",b);
9030                 if (perlstr == NULL)
9031                   shebang_len = 0;
9032             }
9033             else
9034               shebang_len = 0;
9035           }
9036 #endif
9037
9038           if (shebang_len > 0) {
9039           int i;
9040           int j;
9041           char tmpspec[NAM$C_MAXRSS + 1];
9042
9043             i = shebang_len;
9044              /* Image is following after white space */
9045             /*--------------------------------------*/
9046             while (isprint(b[i]) && isspace(b[i]))
9047                 i++;
9048
9049             j = 0;
9050             while (isprint(b[i]) && !isspace(b[i])) {
9051                 tmpspec[j++] = b[i++];
9052                 if (j >= NAM$C_MAXRSS)
9053                    break;
9054             }
9055             tmpspec[j] = '\0';
9056
9057              /* There may be some default parameters to the image */
9058             /*---------------------------------------------------*/
9059             j = 0;
9060             while (isprint(b[i])) {
9061                 image_argv[j++] = b[i++];
9062                 if (j >= NAM$C_MAXRSS)
9063                    break;
9064             }
9065             while ((j > 0) && !isprint(image_argv[j-1]))
9066                 j--;
9067             image_argv[j] = 0;
9068
9069             /* It will need to be converted to VMS format and validated */
9070             if (tmpspec[0] != '\0') {
9071               char * iname;
9072
9073                /* Try to find the exact program requested to be run */
9074               /*---------------------------------------------------*/
9075               iname = do_rmsexpand
9076                  (tmpspec, image_name, 0, ".exe",
9077                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
9078               if (iname != NULL) {
9079                 if (cando_by_name_int
9080                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9081                   /* MCR prefix needed */
9082                   isdcl = 0;
9083                 }
9084                 else {
9085                    /* Try again with a null type */
9086                   /*----------------------------*/
9087                   iname = do_rmsexpand
9088                     (tmpspec, image_name, 0, ".",
9089                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
9090                   if (iname != NULL) {
9091                     if (cando_by_name_int
9092                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9093                       /* MCR prefix needed */
9094                       isdcl = 0;
9095                     }
9096                   }
9097                 }
9098
9099                  /* Did we find the image to run the script? */
9100                 /*------------------------------------------*/
9101                 if (isdcl) {
9102                   char *tchr;
9103
9104                    /* Assume DCL or foreign command exists */
9105                   /*--------------------------------------*/
9106                   tchr = strrchr(tmpspec, '/');
9107                   if (tchr != NULL) {
9108                     tchr++;
9109                   }
9110                   else {
9111                     tchr = tmpspec;
9112                   }
9113                   strcpy(image_name, tchr);
9114                 }
9115               }
9116             }
9117           }
9118         }
9119         fclose(fp);
9120       }
9121       if (check_img && isdcl) return RMS$_FNF;
9122
9123       if (cando_by_name(S_IXUSR,0,resspec)) {
9124         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9125         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9126         if (!isdcl) {
9127             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9128             if (image_name[0] != 0) {
9129                 strcat(vmscmd->dsc$a_pointer, image_name);
9130                 strcat(vmscmd->dsc$a_pointer, " ");
9131             }
9132         } else if (image_name[0] != 0) {
9133             strcpy(vmscmd->dsc$a_pointer, image_name);
9134             strcat(vmscmd->dsc$a_pointer, " ");
9135         } else {
9136             strcpy(vmscmd->dsc$a_pointer,"@");
9137         }
9138         if (suggest_quote) *suggest_quote = 1;
9139
9140         /* If there is an image name, use original command */
9141         if (image_name[0] == 0)
9142             strcat(vmscmd->dsc$a_pointer,resspec);
9143         else {
9144             rest = cmd;
9145             while (*rest && isspace(*rest)) rest++;
9146         }
9147
9148         if (image_argv[0] != 0) {
9149           strcat(vmscmd->dsc$a_pointer,image_argv);
9150           strcat(vmscmd->dsc$a_pointer, " ");
9151         }
9152         if (rest) {
9153            int rest_len;
9154            int vmscmd_len;
9155
9156            rest_len = strlen(rest);
9157            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9158            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9159               strcat(vmscmd->dsc$a_pointer,rest);
9160            else
9161              retsts = CLI$_BUFOVF;
9162         }
9163         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9164         PerlMem_free(cmd);
9165         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9166       }
9167       else
9168         retsts = RMS$_PRV;
9169     }
9170   }
9171   /* It's either a DCL command or we couldn't find a suitable image */
9172   vmscmd->dsc$w_length = strlen(cmd);
9173
9174   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
9175   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
9176   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
9177
9178   PerlMem_free(cmd);
9179
9180   /* check if it's a symbol (for quoting purposes) */
9181   if (suggest_quote && !*suggest_quote) {
9182     int iss;
9183     char equiv[LNM$C_NAMLENGTH];
9184     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9185     eqvdsc.dsc$a_pointer = equiv;
9186
9187     iss = lib$get_symbol(vmscmd,&eqvdsc);
9188     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
9189   }
9190   if (!(retsts & 1)) {
9191     /* just hand off status values likely to be due to user error */
9192     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
9193         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
9194        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
9195     else { _ckvmssts(retsts); }
9196   }
9197
9198   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9199
9200 }  /* end of setup_cmddsc() */
9201
9202
9203 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
9204 bool
9205 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
9206 {
9207 bool exec_sts;
9208 char * cmd;
9209
9210   if (sp > mark) {
9211     if (vfork_called) {           /* this follows a vfork - act Unixish */
9212       vfork_called--;
9213       if (vfork_called < 0) {
9214         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9215         vfork_called = 0;
9216       }
9217       else return do_aexec(really,mark,sp);
9218     }
9219                                            /* no vfork - act VMSish */
9220     cmd = setup_argstr(aTHX_ really,mark,sp);
9221     exec_sts = vms_do_exec(cmd);
9222     Safefree(cmd);  /* Clean up from setup_argstr() */
9223     return exec_sts;
9224   }
9225
9226   return FALSE;
9227 }  /* end of vms_do_aexec() */
9228 /*}}}*/
9229
9230 /* {{{bool vms_do_exec(char *cmd) */
9231 bool
9232 Perl_vms_do_exec(pTHX_ const char *cmd)
9233 {
9234   struct dsc$descriptor_s *vmscmd;
9235
9236   if (vfork_called) {             /* this follows a vfork - act Unixish */
9237     vfork_called--;
9238     if (vfork_called < 0) {
9239       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9240       vfork_called = 0;
9241     }
9242     else return do_exec(cmd);
9243   }
9244
9245   {                               /* no vfork - act VMSish */
9246     unsigned long int retsts;
9247
9248     TAINT_ENV();
9249     TAINT_PROPER("exec");
9250     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
9251       retsts = lib$do_command(vmscmd);
9252
9253     switch (retsts) {
9254       case RMS$_FNF: case RMS$_DNF:
9255         set_errno(ENOENT); break;
9256       case RMS$_DIR:
9257         set_errno(ENOTDIR); break;
9258       case RMS$_DEV:
9259         set_errno(ENODEV); break;
9260       case RMS$_PRV:
9261         set_errno(EACCES); break;
9262       case RMS$_SYN:
9263         set_errno(EINVAL); break;
9264       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9265         set_errno(E2BIG); break;
9266       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9267         _ckvmssts(retsts); /* fall through */
9268       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9269         set_errno(EVMSERR);
9270     }
9271     set_vaxc_errno(retsts);
9272     if (ckWARN(WARN_EXEC)) {
9273       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
9274              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
9275     }
9276     vms_execfree(vmscmd);
9277   }
9278
9279   return FALSE;
9280
9281 }  /* end of vms_do_exec() */
9282 /*}}}*/
9283
9284 unsigned long int Perl_do_spawn(pTHX_ const char *);
9285
9286 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
9287 unsigned long int
9288 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
9289 {
9290 unsigned long int sts;
9291 char * cmd;
9292
9293   if (sp > mark) {
9294     cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
9295     sts = do_spawn(cmd);
9296     /* pp_sys will clean up cmd */
9297     return sts;
9298   }
9299   return SS$_ABORT;
9300 }  /* end of do_aspawn() */
9301 /*}}}*/
9302
9303 /* {{{unsigned long int do_spawn(char *cmd) */
9304 unsigned long int
9305 Perl_do_spawn(pTHX_ const char *cmd)
9306 {
9307   unsigned long int sts, substs;
9308
9309   /* The caller of this routine expects to Safefree(PL_Cmd) */
9310   Newx(PL_Cmd,10,char);
9311
9312   TAINT_ENV();
9313   TAINT_PROPER("spawn");
9314   if (!cmd || !*cmd) {
9315     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
9316     if (!(sts & 1)) {
9317       switch (sts) {
9318         case RMS$_FNF:  case RMS$_DNF:
9319           set_errno(ENOENT); break;
9320         case RMS$_DIR:
9321           set_errno(ENOTDIR); break;
9322         case RMS$_DEV:
9323           set_errno(ENODEV); break;
9324         case RMS$_PRV:
9325           set_errno(EACCES); break;
9326         case RMS$_SYN:
9327           set_errno(EINVAL); break;
9328         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9329           set_errno(E2BIG); break;
9330         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9331           _ckvmssts(sts); /* fall through */
9332         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9333           set_errno(EVMSERR);
9334       }
9335       set_vaxc_errno(sts);
9336       if (ckWARN(WARN_EXEC)) {
9337         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
9338                     Strerror(errno));
9339       }
9340     }
9341     sts = substs;
9342   }
9343   else {
9344     PerlIO * fp;
9345     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
9346     if (fp != NULL)
9347       my_pclose(fp);
9348   }
9349   return sts;
9350 }  /* end of do_spawn() */
9351 /*}}}*/
9352
9353
9354 static unsigned int *sockflags, sockflagsize;
9355
9356 /*
9357  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
9358  * routines found in some versions of the CRTL can't deal with sockets.
9359  * We don't shim the other file open routines since a socket isn't
9360  * likely to be opened by a name.
9361  */
9362 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
9363 FILE *my_fdopen(int fd, const char *mode)
9364 {
9365   FILE *fp = fdopen(fd, mode);
9366
9367   if (fp) {
9368     unsigned int fdoff = fd / sizeof(unsigned int);
9369     Stat_t sbuf; /* native stat; we don't need flex_stat */
9370     if (!sockflagsize || fdoff > sockflagsize) {
9371       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
9372       else           Newx  (sockflags,fdoff+2,unsigned int);
9373       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
9374       sockflagsize = fdoff + 2;
9375     }
9376     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
9377       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
9378   }
9379   return fp;
9380
9381 }
9382 /*}}}*/
9383
9384
9385 /*
9386  * Clear the corresponding bit when the (possibly) socket stream is closed.
9387  * There still a small hole: we miss an implicit close which might occur
9388  * via freopen().  >> Todo
9389  */
9390 /*{{{ int my_fclose(FILE *fp)*/
9391 int my_fclose(FILE *fp) {
9392   if (fp) {
9393     unsigned int fd = fileno(fp);
9394     unsigned int fdoff = fd / sizeof(unsigned int);
9395
9396     if (sockflagsize && fdoff <= sockflagsize)
9397       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
9398   }
9399   return fclose(fp);
9400 }
9401 /*}}}*/
9402
9403
9404 /*
9405  * A simple fwrite replacement which outputs itmsz*nitm chars without
9406  * introducing record boundaries every itmsz chars.
9407  * We are using fputs, which depends on a terminating null.  We may
9408  * well be writing binary data, so we need to accommodate not only
9409  * data with nulls sprinkled in the middle but also data with no null
9410  * byte at the end.
9411  */
9412 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
9413 int
9414 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
9415 {
9416   register char *cp, *end, *cpd, *data;
9417   register unsigned int fd = fileno(dest);
9418   register unsigned int fdoff = fd / sizeof(unsigned int);
9419   int retval;
9420   int bufsize = itmsz * nitm + 1;
9421
9422   if (fdoff < sockflagsize &&
9423       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
9424     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
9425     return nitm;
9426   }
9427
9428   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
9429   memcpy( data, src, itmsz*nitm );
9430   data[itmsz*nitm] = '\0';
9431
9432   end = data + itmsz * nitm;
9433   retval = (int) nitm; /* on success return # items written */
9434
9435   cpd = data;
9436   while (cpd <= end) {
9437     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
9438     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
9439     if (cp < end)
9440       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
9441     cpd = cp + 1;
9442   }
9443
9444   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
9445   return retval;
9446
9447 }  /* end of my_fwrite() */
9448 /*}}}*/
9449
9450 /*{{{ int my_flush(FILE *fp)*/
9451 int
9452 Perl_my_flush(pTHX_ FILE *fp)
9453 {
9454     int res;
9455     if ((res = fflush(fp)) == 0 && fp) {
9456 #ifdef VMS_DO_SOCKETS
9457         Stat_t s;
9458         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
9459 #endif
9460             res = fsync(fileno(fp));
9461     }
9462 /*
9463  * If the flush succeeded but set end-of-file, we need to clear
9464  * the error because our caller may check ferror().  BTW, this
9465  * probably means we just flushed an empty file.
9466  */
9467     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
9468
9469     return res;
9470 }
9471 /*}}}*/
9472
9473 /*
9474  * Here are replacements for the following Unix routines in the VMS environment:
9475  *      getpwuid    Get information for a particular UIC or UID
9476  *      getpwnam    Get information for a named user
9477  *      getpwent    Get information for each user in the rights database
9478  *      setpwent    Reset search to the start of the rights database
9479  *      endpwent    Finish searching for users in the rights database
9480  *
9481  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
9482  * (defined in pwd.h), which contains the following fields:-
9483  *      struct passwd {
9484  *              char        *pw_name;    Username (in lower case)
9485  *              char        *pw_passwd;  Hashed password
9486  *              unsigned int pw_uid;     UIC
9487  *              unsigned int pw_gid;     UIC group  number
9488  *              char        *pw_unixdir; Default device/directory (VMS-style)
9489  *              char        *pw_gecos;   Owner name
9490  *              char        *pw_dir;     Default device/directory (Unix-style)
9491  *              char        *pw_shell;   Default CLI name (eg. DCL)
9492  *      };
9493  * If the specified user does not exist, getpwuid and getpwnam return NULL.
9494  *
9495  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
9496  * not the UIC member number (eg. what's returned by getuid()),
9497  * getpwuid() can accept either as input (if uid is specified, the caller's
9498  * UIC group is used), though it won't recognise gid=0.
9499  *
9500  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
9501  * information about other users in your group or in other groups, respectively.
9502  * If the required privilege is not available, then these routines fill only
9503  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
9504  * string).
9505  *
9506  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
9507  */
9508
9509 /* sizes of various UAF record fields */
9510 #define UAI$S_USERNAME 12
9511 #define UAI$S_IDENT    31
9512 #define UAI$S_OWNER    31
9513 #define UAI$S_DEFDEV   31
9514 #define UAI$S_DEFDIR   63
9515 #define UAI$S_DEFCLI   31
9516 #define UAI$S_PWD       8
9517
9518 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
9519                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
9520                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
9521
9522 static char __empty[]= "";
9523 static struct passwd __passwd_empty=
9524     {(char *) __empty, (char *) __empty, 0, 0,
9525      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
9526 static int contxt= 0;
9527 static struct passwd __pwdcache;
9528 static char __pw_namecache[UAI$S_IDENT+1];
9529
9530 /*
9531  * This routine does most of the work extracting the user information.
9532  */
9533 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
9534 {
9535     static struct {
9536         unsigned char length;
9537         char pw_gecos[UAI$S_OWNER+1];
9538     } owner;
9539     static union uicdef uic;
9540     static struct {
9541         unsigned char length;
9542         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
9543     } defdev;
9544     static struct {
9545         unsigned char length;
9546         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
9547     } defdir;
9548     static struct {
9549         unsigned char length;
9550         char pw_shell[UAI$S_DEFCLI+1];
9551     } defcli;
9552     static char pw_passwd[UAI$S_PWD+1];
9553
9554     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
9555     struct dsc$descriptor_s name_desc;
9556     unsigned long int sts;
9557
9558     static struct itmlst_3 itmlst[]= {
9559         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
9560         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
9561         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
9562         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
9563         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
9564         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
9565         {0,                0,           NULL,    NULL}};
9566
9567     name_desc.dsc$w_length=  strlen(name);
9568     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9569     name_desc.dsc$b_class=   DSC$K_CLASS_S;
9570     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
9571
9572 /*  Note that sys$getuai returns many fields as counted strings. */
9573     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
9574     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
9575       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
9576     }
9577     else { _ckvmssts(sts); }
9578     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
9579
9580     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
9581     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
9582     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
9583     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
9584     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
9585     owner.pw_gecos[lowner]=            '\0';
9586     defdev.pw_dir[ldefdev+ldefdir]= '\0';
9587     defcli.pw_shell[ldefcli]=          '\0';
9588     if (valid_uic(uic)) {
9589         pwd->pw_uid= uic.uic$l_uic;
9590         pwd->pw_gid= uic.uic$v_group;
9591     }
9592     else
9593       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
9594     pwd->pw_passwd=  pw_passwd;
9595     pwd->pw_gecos=   owner.pw_gecos;
9596     pwd->pw_dir=     defdev.pw_dir;
9597     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
9598     pwd->pw_shell=   defcli.pw_shell;
9599     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
9600         int ldir;
9601         ldir= strlen(pwd->pw_unixdir) - 1;
9602         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
9603     }
9604     else
9605         strcpy(pwd->pw_unixdir, pwd->pw_dir);
9606     if (!decc_efs_case_preserve)
9607         __mystrtolower(pwd->pw_unixdir);
9608     return 1;
9609 }
9610
9611 /*
9612  * Get information for a named user.
9613 */
9614 /*{{{struct passwd *getpwnam(char *name)*/
9615 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
9616 {
9617     struct dsc$descriptor_s name_desc;
9618     union uicdef uic;
9619     unsigned long int status, sts;
9620
9621     __pwdcache = __passwd_empty;
9622     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
9623       /* We still may be able to determine pw_uid and pw_gid */
9624       name_desc.dsc$w_length=  strlen(name);
9625       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9626       name_desc.dsc$b_class=   DSC$K_CLASS_S;
9627       name_desc.dsc$a_pointer= (char *) name;
9628       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9629         __pwdcache.pw_uid= uic.uic$l_uic;
9630         __pwdcache.pw_gid= uic.uic$v_group;
9631       }
9632       else {
9633         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9634           set_vaxc_errno(sts);
9635           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9636           return NULL;
9637         }
9638         else { _ckvmssts(sts); }
9639       }
9640     }
9641     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9642     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9643     __pwdcache.pw_name= __pw_namecache;
9644     return &__pwdcache;
9645 }  /* end of my_getpwnam() */
9646 /*}}}*/
9647
9648 /*
9649  * Get information for a particular UIC or UID.
9650  * Called by my_getpwent with uid=-1 to list all users.
9651 */
9652 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9653 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9654 {
9655     const $DESCRIPTOR(name_desc,__pw_namecache);
9656     unsigned short lname;
9657     union uicdef uic;
9658     unsigned long int status;
9659
9660     if (uid == (unsigned int) -1) {
9661       do {
9662         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9663         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9664           set_vaxc_errno(status);
9665           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9666           my_endpwent();
9667           return NULL;
9668         }
9669         else { _ckvmssts(status); }
9670       } while (!valid_uic (uic));
9671     }
9672     else {
9673       uic.uic$l_uic= uid;
9674       if (!uic.uic$v_group)
9675         uic.uic$v_group= PerlProc_getgid();
9676       if (valid_uic(uic))
9677         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9678       else status = SS$_IVIDENT;
9679       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9680           status == RMS$_PRV) {
9681         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9682         return NULL;
9683       }
9684       else { _ckvmssts(status); }
9685     }
9686     __pw_namecache[lname]= '\0';
9687     __mystrtolower(__pw_namecache);
9688
9689     __pwdcache = __passwd_empty;
9690     __pwdcache.pw_name = __pw_namecache;
9691
9692 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
9693     The identifier's value is usually the UIC, but it doesn't have to be,
9694     so if we can, we let fillpasswd update this. */
9695     __pwdcache.pw_uid =  uic.uic$l_uic;
9696     __pwdcache.pw_gid =  uic.uic$v_group;
9697
9698     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
9699     return &__pwdcache;
9700
9701 }  /* end of my_getpwuid() */
9702 /*}}}*/
9703
9704 /*
9705  * Get information for next user.
9706 */
9707 /*{{{struct passwd *my_getpwent()*/
9708 struct passwd *Perl_my_getpwent(pTHX)
9709 {
9710     return (my_getpwuid((unsigned int) -1));
9711 }
9712 /*}}}*/
9713
9714 /*
9715  * Finish searching rights database for users.
9716 */
9717 /*{{{void my_endpwent()*/
9718 void Perl_my_endpwent(pTHX)
9719 {
9720     if (contxt) {
9721       _ckvmssts(sys$finish_rdb(&contxt));
9722       contxt= 0;
9723     }
9724 }
9725 /*}}}*/
9726
9727 #ifdef HOMEGROWN_POSIX_SIGNALS
9728   /* Signal handling routines, pulled into the core from POSIX.xs.
9729    *
9730    * We need these for threads, so they've been rolled into the core,
9731    * rather than left in POSIX.xs.
9732    *
9733    * (DRS, Oct 23, 1997)
9734    */
9735
9736   /* sigset_t is atomic under VMS, so these routines are easy */
9737 /*{{{int my_sigemptyset(sigset_t *) */
9738 int my_sigemptyset(sigset_t *set) {
9739     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9740     *set = 0; return 0;
9741 }
9742 /*}}}*/
9743
9744
9745 /*{{{int my_sigfillset(sigset_t *)*/
9746 int my_sigfillset(sigset_t *set) {
9747     int i;
9748     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9749     for (i = 0; i < NSIG; i++) *set |= (1 << i);
9750     return 0;
9751 }
9752 /*}}}*/
9753
9754
9755 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
9756 int my_sigaddset(sigset_t *set, int sig) {
9757     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9758     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9759     *set |= (1 << (sig - 1));
9760     return 0;
9761 }
9762 /*}}}*/
9763
9764
9765 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
9766 int my_sigdelset(sigset_t *set, int sig) {
9767     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9768     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9769     *set &= ~(1 << (sig - 1));
9770     return 0;
9771 }
9772 /*}}}*/
9773
9774
9775 /*{{{int my_sigismember(sigset_t *set, int sig)*/
9776 int my_sigismember(sigset_t *set, int sig) {
9777     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9778     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9779     return *set & (1 << (sig - 1));
9780 }
9781 /*}}}*/
9782
9783
9784 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
9785 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
9786     sigset_t tempmask;
9787
9788     /* If set and oset are both null, then things are badly wrong. Bail out. */
9789     if ((oset == NULL) && (set == NULL)) {
9790       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
9791       return -1;
9792     }
9793
9794     /* If set's null, then we're just handling a fetch. */
9795     if (set == NULL) {
9796         tempmask = sigblock(0);
9797     }
9798     else {
9799       switch (how) {
9800       case SIG_SETMASK:
9801         tempmask = sigsetmask(*set);
9802         break;
9803       case SIG_BLOCK:
9804         tempmask = sigblock(*set);
9805         break;
9806       case SIG_UNBLOCK:
9807         tempmask = sigblock(0);
9808         sigsetmask(*oset & ~tempmask);
9809         break;
9810       default:
9811         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9812         return -1;
9813       }
9814     }
9815
9816     /* Did they pass us an oset? If so, stick our holding mask into it */
9817     if (oset)
9818       *oset = tempmask;
9819
9820     return 0;
9821 }
9822 /*}}}*/
9823 #endif  /* HOMEGROWN_POSIX_SIGNALS */
9824
9825
9826 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
9827  * my_utime(), and flex_stat(), all of which operate on UTC unless
9828  * VMSISH_TIMES is true.
9829  */
9830 /* method used to handle UTC conversions:
9831  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
9832  */
9833 static int gmtime_emulation_type;
9834 /* number of secs to add to UTC POSIX-style time to get local time */
9835 static long int utc_offset_secs;
9836
9837 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
9838  * in vmsish.h.  #undef them here so we can call the CRTL routines
9839  * directly.
9840  */
9841 #undef gmtime
9842 #undef localtime
9843 #undef time
9844
9845
9846 /*
9847  * DEC C previous to 6.0 corrupts the behavior of the /prefix
9848  * qualifier with the extern prefix pragma.  This provisional
9849  * hack circumvents this prefix pragma problem in previous
9850  * precompilers.
9851  */
9852 #if defined(__VMS_VER) && __VMS_VER >= 70000000
9853 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
9854 #    pragma __extern_prefix save
9855 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
9856 #    define gmtime decc$__utctz_gmtime
9857 #    define localtime decc$__utctz_localtime
9858 #    define time decc$__utc_time
9859 #    pragma __extern_prefix restore
9860
9861      struct tm *gmtime(), *localtime();
9862
9863 #  endif
9864 #endif
9865
9866
9867 static time_t toutc_dst(time_t loc) {
9868   struct tm *rsltmp;
9869
9870   if ((rsltmp = localtime(&loc)) == NULL) return -1;
9871   loc -= utc_offset_secs;
9872   if (rsltmp->tm_isdst) loc -= 3600;
9873   return loc;
9874 }
9875 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
9876        ((gmtime_emulation_type || my_time(NULL)), \
9877        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
9878        ((secs) - utc_offset_secs))))
9879
9880 static time_t toloc_dst(time_t utc) {
9881   struct tm *rsltmp;
9882
9883   utc += utc_offset_secs;
9884   if ((rsltmp = localtime(&utc)) == NULL) return -1;
9885   if (rsltmp->tm_isdst) utc += 3600;
9886   return utc;
9887 }
9888 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
9889        ((gmtime_emulation_type || my_time(NULL)), \
9890        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
9891        ((secs) + utc_offset_secs))))
9892
9893 #ifndef RTL_USES_UTC
9894 /*
9895
9896     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
9897         DST starts on 1st sun of april      at 02:00  std time
9898             ends on last sun of october     at 02:00  dst time
9899     see the UCX management command reference, SET CONFIG TIMEZONE
9900     for formatting info.
9901
9902     No, it's not as general as it should be, but then again, NOTHING
9903     will handle UK times in a sensible way.
9904 */
9905
9906
9907 /*
9908     parse the DST start/end info:
9909     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
9910 */
9911
9912 static char *
9913 tz_parse_startend(char *s, struct tm *w, int *past)
9914 {
9915     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
9916     int ly, dozjd, d, m, n, hour, min, sec, j, k;
9917     time_t g;
9918
9919     if (!s)    return 0;
9920     if (!w) return 0;
9921     if (!past) return 0;
9922
9923     ly = 0;
9924     if (w->tm_year % 4        == 0) ly = 1;
9925     if (w->tm_year % 100      == 0) ly = 0;
9926     if (w->tm_year+1900 % 400 == 0) ly = 1;
9927     if (ly) dinm[1]++;
9928
9929     dozjd = isdigit(*s);
9930     if (*s == 'J' || *s == 'j' || dozjd) {
9931         if (!dozjd && !isdigit(*++s)) return 0;
9932         d = *s++ - '0';
9933         if (isdigit(*s)) {
9934             d = d*10 + *s++ - '0';
9935             if (isdigit(*s)) {
9936                 d = d*10 + *s++ - '0';
9937             }
9938         }
9939         if (d == 0) return 0;
9940         if (d > 366) return 0;
9941         d--;
9942         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
9943         g = d * 86400;
9944         dozjd = 1;
9945     } else if (*s == 'M' || *s == 'm') {
9946         if (!isdigit(*++s)) return 0;
9947         m = *s++ - '0';
9948         if (isdigit(*s)) m = 10*m + *s++ - '0';
9949         if (*s != '.') return 0;
9950         if (!isdigit(*++s)) return 0;
9951         n = *s++ - '0';
9952         if (n < 1 || n > 5) return 0;
9953         if (*s != '.') return 0;
9954         if (!isdigit(*++s)) return 0;
9955         d = *s++ - '0';
9956         if (d > 6) return 0;
9957     }
9958
9959     if (*s == '/') {
9960         if (!isdigit(*++s)) return 0;
9961         hour = *s++ - '0';
9962         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
9963         if (*s == ':') {
9964             if (!isdigit(*++s)) return 0;
9965             min = *s++ - '0';
9966             if (isdigit(*s)) min = 10*min + *s++ - '0';
9967             if (*s == ':') {
9968                 if (!isdigit(*++s)) return 0;
9969                 sec = *s++ - '0';
9970                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
9971             }
9972         }
9973     } else {
9974         hour = 2;
9975         min = 0;
9976         sec = 0;
9977     }
9978
9979     if (dozjd) {
9980         if (w->tm_yday < d) goto before;
9981         if (w->tm_yday > d) goto after;
9982     } else {
9983         if (w->tm_mon+1 < m) goto before;
9984         if (w->tm_mon+1 > m) goto after;
9985
9986         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
9987         k = d - j; /* mday of first d */
9988         if (k <= 0) k += 7;
9989         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
9990         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
9991         if (w->tm_mday < k) goto before;
9992         if (w->tm_mday > k) goto after;
9993     }
9994
9995     if (w->tm_hour < hour) goto before;
9996     if (w->tm_hour > hour) goto after;
9997     if (w->tm_min  < min)  goto before;
9998     if (w->tm_min  > min)  goto after;
9999     if (w->tm_sec  < sec)  goto before;
10000     goto after;
10001
10002 before:
10003     *past = 0;
10004     return s;
10005 after:
10006     *past = 1;
10007     return s;
10008 }
10009
10010
10011
10012
10013 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
10014
10015 static char *
10016 tz_parse_offset(char *s, int *offset)
10017 {
10018     int hour = 0, min = 0, sec = 0;
10019     int neg = 0;
10020     if (!s) return 0;
10021     if (!offset) return 0;
10022
10023     if (*s == '-') {neg++; s++;}
10024     if (*s == '+') s++;
10025     if (!isdigit(*s)) return 0;
10026     hour = *s++ - '0';
10027     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10028     if (hour > 24) return 0;
10029     if (*s == ':') {
10030         if (!isdigit(*++s)) return 0;
10031         min = *s++ - '0';
10032         if (isdigit(*s)) min = min*10 + (*s++ - '0');
10033         if (min > 59) return 0;
10034         if (*s == ':') {
10035             if (!isdigit(*++s)) return 0;
10036             sec = *s++ - '0';
10037             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10038             if (sec > 59) return 0;
10039         }
10040     }
10041
10042     *offset = (hour*60+min)*60 + sec;
10043     if (neg) *offset = -*offset;
10044     return s;
10045 }
10046
10047 /*
10048     input time is w, whatever type of time the CRTL localtime() uses.
10049     sets dst, the zone, and the gmtoff (seconds)
10050
10051     caches the value of TZ and UCX$TZ env variables; note that
10052     my_setenv looks for these and sets a flag if they're changed
10053     for efficiency.
10054
10055     We have to watch out for the "australian" case (dst starts in
10056     october, ends in april)...flagged by "reverse" and checked by
10057     scanning through the months of the previous year.
10058
10059 */
10060
10061 static int
10062 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10063 {
10064     time_t when;
10065     struct tm *w2;
10066     char *s,*s2;
10067     char *dstzone, *tz, *s_start, *s_end;
10068     int std_off, dst_off, isdst;
10069     int y, dststart, dstend;
10070     static char envtz[1025];  /* longer than any logical, symbol, ... */
10071     static char ucxtz[1025];
10072     static char reversed = 0;
10073
10074     if (!w) return 0;
10075
10076     if (tz_updated) {
10077         tz_updated = 0;
10078         reversed = -1;  /* flag need to check  */
10079         envtz[0] = ucxtz[0] = '\0';
10080         tz = my_getenv("TZ",0);
10081         if (tz) strcpy(envtz, tz);
10082         tz = my_getenv("UCX$TZ",0);
10083         if (tz) strcpy(ucxtz, tz);
10084         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
10085     }
10086     tz = envtz;
10087     if (!*tz) tz = ucxtz;
10088
10089     s = tz;
10090     while (isalpha(*s)) s++;
10091     s = tz_parse_offset(s, &std_off);
10092     if (!s) return 0;
10093     if (!*s) {                  /* no DST, hurray we're done! */
10094         isdst = 0;
10095         goto done;
10096     }
10097
10098     dstzone = s;
10099     while (isalpha(*s)) s++;
10100     s2 = tz_parse_offset(s, &dst_off);
10101     if (s2) {
10102         s = s2;
10103     } else {
10104         dst_off = std_off - 3600;
10105     }
10106
10107     if (!*s) {      /* default dst start/end?? */
10108         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
10109             s = strchr(ucxtz,',');
10110         }
10111         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
10112     }
10113     if (*s != ',') return 0;
10114
10115     when = *w;
10116     when = _toutc(when);      /* convert to utc */
10117     when = when - std_off;    /* convert to pseudolocal time*/
10118
10119     w2 = localtime(&when);
10120     y = w2->tm_year;
10121     s_start = s+1;
10122     s = tz_parse_startend(s_start,w2,&dststart);
10123     if (!s) return 0;
10124     if (*s != ',') return 0;
10125
10126     when = *w;
10127     when = _toutc(when);      /* convert to utc */
10128     when = when - dst_off;    /* convert to pseudolocal time*/
10129     w2 = localtime(&when);
10130     if (w2->tm_year != y) {   /* spans a year, just check one time */
10131         when += dst_off - std_off;
10132         w2 = localtime(&when);
10133     }
10134     s_end = s+1;
10135     s = tz_parse_startend(s_end,w2,&dstend);
10136     if (!s) return 0;
10137
10138     if (reversed == -1) {  /* need to check if start later than end */
10139         int j, ds, de;
10140
10141         when = *w;
10142         if (when < 2*365*86400) {
10143             when += 2*365*86400;
10144         } else {
10145             when -= 365*86400;
10146         }
10147         w2 =localtime(&when);
10148         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
10149
10150         for (j = 0; j < 12; j++) {
10151             w2 =localtime(&when);
10152             tz_parse_startend(s_start,w2,&ds);
10153             tz_parse_startend(s_end,w2,&de);
10154             if (ds != de) break;
10155             when += 30*86400;
10156         }
10157         reversed = 0;
10158         if (de && !ds) reversed = 1;
10159     }
10160
10161     isdst = dststart && !dstend;
10162     if (reversed) isdst = dststart  || !dstend;
10163
10164 done:
10165     if (dst)    *dst = isdst;
10166     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
10167     if (isdst)  tz = dstzone;
10168     if (zone) {
10169         while(isalpha(*tz))  *zone++ = *tz++;
10170         *zone = '\0';
10171     }
10172     return 1;
10173 }
10174
10175 #endif /* !RTL_USES_UTC */
10176
10177 /* my_time(), my_localtime(), my_gmtime()
10178  * By default traffic in UTC time values, using CRTL gmtime() or
10179  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
10180  * Note: We need to use these functions even when the CRTL has working
10181  * UTC support, since they also handle C<use vmsish qw(times);>
10182  *
10183  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
10184  * Modified by Charles Bailey <bailey@newman.upenn.edu>
10185  */
10186
10187 /*{{{time_t my_time(time_t *timep)*/
10188 time_t Perl_my_time(pTHX_ time_t *timep)
10189 {
10190   time_t when;
10191   struct tm *tm_p;
10192
10193   if (gmtime_emulation_type == 0) {
10194     int dstnow;
10195     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
10196                               /* results of calls to gmtime() and localtime() */
10197                               /* for same &base */
10198
10199     gmtime_emulation_type++;
10200     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
10201       char off[LNM$C_NAMLENGTH+1];;
10202
10203       gmtime_emulation_type++;
10204       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
10205         gmtime_emulation_type++;
10206         utc_offset_secs = 0;
10207         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
10208       }
10209       else { utc_offset_secs = atol(off); }
10210     }
10211     else { /* We've got a working gmtime() */
10212       struct tm gmt, local;
10213
10214       gmt = *tm_p;
10215       tm_p = localtime(&base);
10216       local = *tm_p;
10217       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
10218       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
10219       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
10220       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
10221     }
10222   }
10223
10224   when = time(NULL);
10225 # ifdef VMSISH_TIME
10226 # ifdef RTL_USES_UTC
10227   if (VMSISH_TIME) when = _toloc(when);
10228 # else
10229   if (!VMSISH_TIME) when = _toutc(when);
10230 # endif
10231 # endif
10232   if (timep != NULL) *timep = when;
10233   return when;
10234
10235 }  /* end of my_time() */
10236 /*}}}*/
10237
10238
10239 /*{{{struct tm *my_gmtime(const time_t *timep)*/
10240 struct tm *
10241 Perl_my_gmtime(pTHX_ const time_t *timep)
10242 {
10243   char *p;
10244   time_t when;
10245   struct tm *rsltmp;
10246
10247   if (timep == NULL) {
10248     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10249     return NULL;
10250   }
10251   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10252
10253   when = *timep;
10254 # ifdef VMSISH_TIME
10255   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
10256 #  endif
10257 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
10258   return gmtime(&when);
10259 # else
10260   /* CRTL localtime() wants local time as input, so does no tz correction */
10261   rsltmp = localtime(&when);
10262   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
10263   return rsltmp;
10264 #endif
10265 }  /* end of my_gmtime() */
10266 /*}}}*/
10267
10268
10269 /*{{{struct tm *my_localtime(const time_t *timep)*/
10270 struct tm *
10271 Perl_my_localtime(pTHX_ const time_t *timep)
10272 {
10273   time_t when, whenutc;
10274   struct tm *rsltmp;
10275   int dst, offset;
10276
10277   if (timep == NULL) {
10278     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10279     return NULL;
10280   }
10281   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10282   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
10283
10284   when = *timep;
10285 # ifdef RTL_USES_UTC
10286 # ifdef VMSISH_TIME
10287   if (VMSISH_TIME) when = _toutc(when);
10288 # endif
10289   /* CRTL localtime() wants UTC as input, does tz correction itself */
10290   return localtime(&when);
10291
10292 # else /* !RTL_USES_UTC */
10293   whenutc = when;
10294 # ifdef VMSISH_TIME
10295   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
10296   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
10297 # endif
10298   dst = -1;
10299 #ifndef RTL_USES_UTC
10300   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
10301       when = whenutc - offset;                   /* pseudolocal time*/
10302   }
10303 # endif
10304   /* CRTL localtime() wants local time as input, so does no tz correction */
10305   rsltmp = localtime(&when);
10306   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
10307   return rsltmp;
10308 # endif
10309
10310 } /*  end of my_localtime() */
10311 /*}}}*/
10312
10313 /* Reset definitions for later calls */
10314 #define gmtime(t)    my_gmtime(t)
10315 #define localtime(t) my_localtime(t)
10316 #define time(t)      my_time(t)
10317
10318
10319 /* my_utime - update modification/access time of a file
10320  *
10321  * VMS 7.3 and later implementation
10322  * Only the UTC translation is home-grown. The rest is handled by the
10323  * CRTL utime(), which will take into account the relevant feature
10324  * logicals and ODS-5 volume characteristics for true access times.
10325  *
10326  * pre VMS 7.3 implementation:
10327  * The calling sequence is identical to POSIX utime(), but under
10328  * VMS with ODS-2, only the modification time is changed; ODS-2 does
10329  * not maintain access times.  Restrictions differ from the POSIX
10330  * definition in that the time can be changed as long as the
10331  * caller has permission to execute the necessary IO$_MODIFY $QIO;
10332  * no separate checks are made to insure that the caller is the
10333  * owner of the file or has special privs enabled.
10334  * Code here is based on Joe Meadows' FILE utility.
10335  *
10336  */
10337
10338 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
10339  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
10340  * in 100 ns intervals.
10341  */
10342 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
10343
10344 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
10345 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
10346 {
10347 #if __CRTL_VER >= 70300000
10348   struct utimbuf utc_utimes, *utc_utimesp;
10349
10350   if (utimes != NULL) {
10351     utc_utimes.actime = utimes->actime;
10352     utc_utimes.modtime = utimes->modtime;
10353 # ifdef VMSISH_TIME
10354     /* If input was local; convert to UTC for sys svc */
10355     if (VMSISH_TIME) {
10356       utc_utimes.actime = _toutc(utimes->actime);
10357       utc_utimes.modtime = _toutc(utimes->modtime);
10358     }
10359 # endif
10360     utc_utimesp = &utc_utimes;
10361   }
10362   else {
10363     utc_utimesp = NULL;
10364   }
10365
10366   return utime(file, utc_utimesp);
10367
10368 #else /* __CRTL_VER < 70300000 */
10369
10370   register int i;
10371   int sts;
10372   long int bintime[2], len = 2, lowbit, unixtime,
10373            secscale = 10000000; /* seconds --> 100 ns intervals */
10374   unsigned long int chan, iosb[2], retsts;
10375   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
10376   struct FAB myfab = cc$rms_fab;
10377   struct NAM mynam = cc$rms_nam;
10378 #if defined (__DECC) && defined (__VAX)
10379   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
10380    * at least through VMS V6.1, which causes a type-conversion warning.
10381    */
10382 #  pragma message save
10383 #  pragma message disable cvtdiftypes
10384 #endif
10385   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
10386   struct fibdef myfib;
10387 #if defined (__DECC) && defined (__VAX)
10388   /* This should be right after the declaration of myatr, but due
10389    * to a bug in VAX DEC C, this takes effect a statement early.
10390    */
10391 #  pragma message restore
10392 #endif
10393   /* cast ok for read only parameter */
10394   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
10395                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
10396                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
10397
10398   if (file == NULL || *file == '\0') {
10399     SETERRNO(ENOENT, LIB$_INVARG);
10400     return -1;
10401   }
10402
10403   /* Convert to VMS format ensuring that it will fit in 255 characters */
10404   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
10405       SETERRNO(ENOENT, LIB$_INVARG);
10406       return -1;
10407   }
10408   if (utimes != NULL) {
10409     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
10410      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
10411      * Since time_t is unsigned long int, and lib$emul takes a signed long int
10412      * as input, we force the sign bit to be clear by shifting unixtime right
10413      * one bit, then multiplying by an extra factor of 2 in lib$emul().
10414      */
10415     lowbit = (utimes->modtime & 1) ? secscale : 0;
10416     unixtime = (long int) utimes->modtime;
10417 #   ifdef VMSISH_TIME
10418     /* If input was UTC; convert to local for sys svc */
10419     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
10420 #   endif
10421     unixtime >>= 1;  secscale <<= 1;
10422     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
10423     if (!(retsts & 1)) {
10424       SETERRNO(EVMSERR, retsts);
10425       return -1;
10426     }
10427     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
10428     if (!(retsts & 1)) {
10429       SETERRNO(EVMSERR, retsts);
10430       return -1;
10431     }
10432   }
10433   else {
10434     /* Just get the current time in VMS format directly */
10435     retsts = sys$gettim(bintime);
10436     if (!(retsts & 1)) {
10437       SETERRNO(EVMSERR, retsts);
10438       return -1;
10439     }
10440   }
10441
10442   myfab.fab$l_fna = vmsspec;
10443   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
10444   myfab.fab$l_nam = &mynam;
10445   mynam.nam$l_esa = esa;
10446   mynam.nam$b_ess = (unsigned char) sizeof esa;
10447   mynam.nam$l_rsa = rsa;
10448   mynam.nam$b_rss = (unsigned char) sizeof rsa;
10449   if (decc_efs_case_preserve)
10450       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10451
10452   /* Look for the file to be affected, letting RMS parse the file
10453    * specification for us as well.  I have set errno using only
10454    * values documented in the utime() man page for VMS POSIX.
10455    */
10456   retsts = sys$parse(&myfab,0,0);
10457   if (!(retsts & 1)) {
10458     set_vaxc_errno(retsts);
10459     if      (retsts == RMS$_PRV) set_errno(EACCES);
10460     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
10461     else                         set_errno(EVMSERR);
10462     return -1;
10463   }
10464   retsts = sys$search(&myfab,0,0);
10465   if (!(retsts & 1)) {
10466     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10467     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10468     set_vaxc_errno(retsts);
10469     if      (retsts == RMS$_PRV) set_errno(EACCES);
10470     else if (retsts == RMS$_FNF) set_errno(ENOENT);
10471     else                         set_errno(EVMSERR);
10472     return -1;
10473   }
10474
10475   devdsc.dsc$w_length = mynam.nam$b_dev;
10476   /* cast ok for read only parameter */
10477   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
10478
10479   retsts = sys$assign(&devdsc,&chan,0,0);
10480   if (!(retsts & 1)) {
10481     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10482     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10483     set_vaxc_errno(retsts);
10484     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
10485     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
10486     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
10487     else                               set_errno(EVMSERR);
10488     return -1;
10489   }
10490
10491   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
10492   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
10493
10494   memset((void *) &myfib, 0, sizeof myfib);
10495 #if defined(__DECC) || defined(__DECCXX)
10496   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
10497   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
10498   /* This prevents the revision time of the file being reset to the current
10499    * time as a result of our IO$_MODIFY $QIO. */
10500   myfib.fib$l_acctl = FIB$M_NORECORD;
10501 #else
10502   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
10503   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
10504   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
10505 #endif
10506   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
10507   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10508   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10509   _ckvmssts(sys$dassgn(chan));
10510   if (retsts & 1) retsts = iosb[0];
10511   if (!(retsts & 1)) {
10512     set_vaxc_errno(retsts);
10513     if (retsts == SS$_NOPRIV) set_errno(EACCES);
10514     else                      set_errno(EVMSERR);
10515     return -1;
10516   }
10517
10518   return 0;
10519
10520 #endif /* #if __CRTL_VER >= 70300000 */
10521
10522 }  /* end of my_utime() */
10523 /*}}}*/
10524
10525 /*
10526  * flex_stat, flex_lstat, flex_fstat
10527  * basic stat, but gets it right when asked to stat
10528  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
10529  */
10530
10531 #ifndef _USE_STD_STAT
10532 /* encode_dev packs a VMS device name string into an integer to allow
10533  * simple comparisons. This can be used, for example, to check whether two
10534  * files are located on the same device, by comparing their encoded device
10535  * names. Even a string comparison would not do, because stat() reuses the
10536  * device name buffer for each call; so without encode_dev, it would be
10537  * necessary to save the buffer and use strcmp (this would mean a number of
10538  * changes to the standard Perl code, to say nothing of what a Perl script
10539  * would have to do.
10540  *
10541  * The device lock id, if it exists, should be unique (unless perhaps compared
10542  * with lock ids transferred from other nodes). We have a lock id if the disk is
10543  * mounted cluster-wide, which is when we tend to get long (host-qualified)
10544  * device names. Thus we use the lock id in preference, and only if that isn't
10545  * available, do we try to pack the device name into an integer (flagged by
10546  * the sign bit (LOCKID_MASK) being set).
10547  *
10548  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
10549  * name and its encoded form, but it seems very unlikely that we will find
10550  * two files on different disks that share the same encoded device names,
10551  * and even more remote that they will share the same file id (if the test
10552  * is to check for the same file).
10553  *
10554  * A better method might be to use sys$device_scan on the first call, and to
10555  * search for the device, returning an index into the cached array.
10556  * The number returned would be more intelligible.
10557  * This is probably not worth it, and anyway would take quite a bit longer
10558  * on the first call.
10559  */
10560 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
10561 static mydev_t encode_dev (pTHX_ const char *dev)
10562 {
10563   int i;
10564   unsigned long int f;
10565   mydev_t enc;
10566   char c;
10567   const char *q;
10568
10569   if (!dev || !dev[0]) return 0;
10570
10571 #if LOCKID_MASK
10572   {
10573     struct dsc$descriptor_s dev_desc;
10574     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
10575
10576     /* For cluster-mounted disks, the disk lock identifier is unique, so we
10577        can try that first. */
10578     dev_desc.dsc$w_length =  strlen (dev);
10579     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
10580     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
10581     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
10582     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
10583     if (!$VMS_STATUS_SUCCESS(status)) {
10584       switch (status) {
10585         case SS$_NOSUCHDEV:
10586           SETERRNO(ENODEV, status);
10587           return 0;
10588         default:
10589           _ckvmssts(status);
10590       }
10591     }
10592     if (lockid) return (lockid & ~LOCKID_MASK);
10593   }
10594 #endif
10595
10596   /* Otherwise we try to encode the device name */
10597   enc = 0;
10598   f = 1;
10599   i = 0;
10600   for (q = dev + strlen(dev); q--; q >= dev) {
10601     if (*q == ':')
10602         break;
10603     if (isdigit (*q))
10604       c= (*q) - '0';
10605     else if (isalpha (toupper (*q)))
10606       c= toupper (*q) - 'A' + (char)10;
10607     else
10608       continue; /* Skip '$'s */
10609     i++;
10610     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
10611     if (i>1) f *= 36;
10612     enc += f * (unsigned long int) c;
10613   }
10614   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
10615
10616 }  /* end of encode_dev() */
10617 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10618         device_no = encode_dev(aTHX_ devname)
10619 #else
10620 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10621         device_no = new_dev_no
10622 #endif
10623
10624 static int
10625 is_null_device(name)
10626     const char *name;
10627 {
10628   if (decc_bug_devnull != 0) {
10629     if (strncmp("/dev/null", name, 9) == 0)
10630       return 1;
10631   }
10632     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
10633        The underscore prefix, controller letter, and unit number are
10634        independently optional; for our purposes, the colon punctuation
10635        is not.  The colon can be trailed by optional directory and/or
10636        filename, but two consecutive colons indicates a nodename rather
10637        than a device.  [pr]  */
10638   if (*name == '_') ++name;
10639   if (tolower(*name++) != 'n') return 0;
10640   if (tolower(*name++) != 'l') return 0;
10641   if (tolower(*name) == 'a') ++name;
10642   if (*name == '0') ++name;
10643   return (*name++ == ':') && (*name != ':');
10644 }
10645
10646
10647 static I32
10648 Perl_cando_by_name_int
10649    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
10650 {
10651   static char usrname[L_cuserid];
10652   static struct dsc$descriptor_s usrdsc =
10653          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
10654   char vmsname[NAM$C_MAXRSS+1];
10655   char *fileified;
10656   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
10657   unsigned short int retlen, trnlnm_iter_count;
10658   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10659   union prvdef curprv;
10660   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
10661          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
10662          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
10663   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
10664          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
10665          {0,0,0,0}};
10666   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10667          {0,0,0,0}};
10668   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10669
10670   if (!fname || !*fname) return FALSE;
10671   /* Make sure we expand logical names, since sys$check_access doesn't */
10672
10673   fileified = NULL;
10674   if ((opts & PERL_RMSEXPAND_M_VMS_IN) != 0) {
10675     fileified = PerlMem_malloc(VMS_MAXRSS);
10676     if (!strpbrk(fname,"/]>:")) {
10677       strcpy(fileified,fname);
10678       trnlnm_iter_count = 0;
10679       while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
10680         trnlnm_iter_count++;
10681         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
10682       }
10683       fname = fileified;
10684     }
10685     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
10686       PerlMem_free(fileified);
10687       return FALSE;
10688     }
10689     retlen = namdsc.dsc$w_length = strlen(vmsname);
10690     namdsc.dsc$a_pointer = vmsname;
10691     if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
10692       vmsname[retlen-1] == ':') {
10693       if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) return FALSE;
10694       namdsc.dsc$w_length = strlen(fileified);
10695       namdsc.dsc$a_pointer = fileified;
10696     }
10697   }
10698   else {
10699     retlen = namdsc.dsc$w_length = strlen(fname);
10700     namdsc.dsc$a_pointer = (char *)fname; /* cast ok */
10701   }
10702
10703   switch (bit) {
10704     case S_IXUSR: case S_IXGRP: case S_IXOTH:
10705       access = ARM$M_EXECUTE;
10706       flags = CHP$M_READ;
10707       break;
10708     case S_IRUSR: case S_IRGRP: case S_IROTH:
10709       access = ARM$M_READ;
10710       flags = CHP$M_READ | CHP$M_USEREADALL;
10711       break;
10712     case S_IWUSR: case S_IWGRP: case S_IWOTH:
10713       access = ARM$M_WRITE;
10714       flags = CHP$M_READ | CHP$M_WRITE;
10715       break;
10716     case S_IDUSR: case S_IDGRP: case S_IDOTH:
10717       access = ARM$M_DELETE;
10718       flags = CHP$M_READ | CHP$M_WRITE;
10719       break;
10720     default:
10721       if (fileified != NULL)
10722         PerlMem_free(fileified);
10723       return FALSE;
10724   }
10725
10726   /* Before we call $check_access, create a user profile with the current
10727    * process privs since otherwise it just uses the default privs from the
10728    * UAF and might give false positives or negatives.  This only works on
10729    * VMS versions v6.0 and later since that's when sys$create_user_profile
10730    * became available.
10731    */
10732
10733   /* get current process privs and username */
10734   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
10735   _ckvmssts(iosb[0]);
10736
10737 #if defined(__VMS_VER) && __VMS_VER >= 60000000
10738
10739   /* find out the space required for the profile */
10740   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
10741                                     &usrprodsc.dsc$w_length,0));
10742
10743   /* allocate space for the profile and get it filled in */
10744   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
10745   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
10746   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
10747                                     &usrprodsc.dsc$w_length,0));
10748
10749   /* use the profile to check access to the file; free profile & analyze results */
10750   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
10751   PerlMem_free(usrprodsc.dsc$a_pointer);
10752   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
10753
10754 #else
10755
10756   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
10757
10758 #endif
10759
10760   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
10761       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
10762       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
10763     set_vaxc_errno(retsts);
10764     if (retsts == SS$_NOPRIV) set_errno(EACCES);
10765     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
10766     else set_errno(ENOENT);
10767     if (fileified != NULL)
10768       PerlMem_free(fileified);
10769     return FALSE;
10770   }
10771   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
10772     if (fileified != NULL)
10773       PerlMem_free(fileified);
10774     return TRUE;
10775   }
10776   _ckvmssts(retsts);
10777
10778   if (fileified != NULL)
10779     PerlMem_free(fileified);
10780   return FALSE;  /* Should never get here */
10781
10782 }
10783
10784 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
10785 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
10786  * subset of the applicable information.
10787  */
10788 bool
10789 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
10790 {
10791   return cando_by_name_int
10792         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
10793 }  /* end of cando() */
10794 /*}}}*/
10795
10796
10797 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
10798 I32
10799 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
10800 {
10801    return cando_by_name_int(bit, effective, fname, 0);
10802
10803 }  /* end of cando_by_name() */
10804 /*}}}*/
10805
10806
10807 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
10808 int
10809 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
10810 {
10811   if (!fstat(fd,(stat_t *) statbufp)) {
10812     char *cptr;
10813     char *vms_filename;
10814     vms_filename = PerlMem_malloc(VMS_MAXRSS);
10815     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
10816
10817     /* Save name for cando by name in VMS format */
10818     cptr = getname(fd, vms_filename, 1);
10819
10820     /* This should not happen, but just in case */
10821     if (cptr == NULL) {
10822         statbufp->st_devnam[0] = 0;
10823     }
10824     else {
10825         /* Make sure that the saved name fits in 255 characters */
10826         cptr = do_rmsexpand
10827                        (vms_filename,
10828                         statbufp->st_devnam,
10829                         0,
10830                         NULL,
10831                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
10832                         NULL,
10833                         NULL);
10834         if (cptr == NULL)
10835             statbufp->st_devnam[0] = 0;
10836     }
10837     PerlMem_free(vms_filename);
10838
10839     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10840     VMS_DEVICE_ENCODE
10841         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
10842
10843 #   ifdef RTL_USES_UTC
10844 #   ifdef VMSISH_TIME
10845     if (VMSISH_TIME) {
10846       statbufp->st_mtime = _toloc(statbufp->st_mtime);
10847       statbufp->st_atime = _toloc(statbufp->st_atime);
10848       statbufp->st_ctime = _toloc(statbufp->st_ctime);
10849     }
10850 #   endif
10851 #   else
10852 #   ifdef VMSISH_TIME
10853     if (!VMSISH_TIME) { /* Return UTC instead of local time */
10854 #   else
10855     if (1) {
10856 #   endif
10857       statbufp->st_mtime = _toutc(statbufp->st_mtime);
10858       statbufp->st_atime = _toutc(statbufp->st_atime);
10859       statbufp->st_ctime = _toutc(statbufp->st_ctime);
10860     }
10861 #endif
10862     return 0;
10863   }
10864   return -1;
10865
10866 }  /* end of flex_fstat() */
10867 /*}}}*/
10868
10869 #if !defined(__VAX) && __CRTL_VER >= 80200000
10870 #ifdef lstat
10871 #undef lstat
10872 #endif
10873 #else
10874 #ifdef lstat
10875 #undef lstat
10876 #endif
10877 #define lstat(_x, _y) stat(_x, _y)
10878 #endif
10879
10880 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
10881
10882 static int
10883 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
10884 {
10885     char fileified[VMS_MAXRSS];
10886     char temp_fspec[VMS_MAXRSS];
10887     char *save_spec;
10888     int retval = -1;
10889     int saved_errno, saved_vaxc_errno;
10890
10891     if (!fspec) return retval;
10892     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
10893     strcpy(temp_fspec, fspec);
10894
10895     if (decc_bug_devnull != 0) {
10896       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
10897         memset(statbufp,0,sizeof *statbufp);
10898         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
10899         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
10900         statbufp->st_uid = 0x00010001;
10901         statbufp->st_gid = 0x0001;
10902         time((time_t *)&statbufp->st_mtime);
10903         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
10904         return 0;
10905       }
10906     }
10907
10908     /* Try for a directory name first.  If fspec contains a filename without
10909      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
10910      * and sea:[wine.dark]water. exist, we prefer the directory here.
10911      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
10912      * not sea:[wine.dark]., if the latter exists.  If the intended target is
10913      * the file with null type, specify this by calling flex_stat() with
10914      * a '.' at the end of fspec.
10915      *
10916      * If we are in Posix filespec mode, accept the filename as is.
10917      */
10918 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10919   if (decc_posix_compliant_pathnames == 0) {
10920 #endif
10921     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
10922       if (lstat_flag == 0)
10923         retval = stat(fileified,(stat_t *) statbufp);
10924       else
10925         retval = lstat(fileified,(stat_t *) statbufp);
10926       save_spec = fileified;
10927     }
10928     if (retval) {
10929       if (lstat_flag == 0)
10930         retval = stat(temp_fspec,(stat_t *) statbufp);
10931       else
10932         retval = lstat(temp_fspec,(stat_t *) statbufp);
10933       save_spec = temp_fspec;
10934     }
10935 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10936   } else {
10937     if (lstat_flag == 0)
10938       retval = stat(temp_fspec,(stat_t *) statbufp);
10939     else
10940       retval = lstat(temp_fspec,(stat_t *) statbufp);
10941       save_spec = temp_fspec;
10942   }
10943 #endif
10944     if (!retval) {
10945     char * cptr;
10946       cptr = do_rmsexpand
10947        (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
10948       if (cptr == NULL)
10949         statbufp->st_devnam[0] = 0;
10950
10951       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10952       VMS_DEVICE_ENCODE
10953         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
10954 #     ifdef RTL_USES_UTC
10955 #     ifdef VMSISH_TIME
10956       if (VMSISH_TIME) {
10957         statbufp->st_mtime = _toloc(statbufp->st_mtime);
10958         statbufp->st_atime = _toloc(statbufp->st_atime);
10959         statbufp->st_ctime = _toloc(statbufp->st_ctime);
10960       }
10961 #     endif
10962 #     else
10963 #     ifdef VMSISH_TIME
10964       if (!VMSISH_TIME) { /* Return UTC instead of local time */
10965 #     else
10966       if (1) {
10967 #     endif
10968         statbufp->st_mtime = _toutc(statbufp->st_mtime);
10969         statbufp->st_atime = _toutc(statbufp->st_atime);
10970         statbufp->st_ctime = _toutc(statbufp->st_ctime);
10971       }
10972 #     endif
10973     }
10974     /* If we were successful, leave errno where we found it */
10975     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
10976     return retval;
10977
10978 }  /* end of flex_stat_int() */
10979
10980
10981 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
10982 int
10983 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
10984 {
10985    return flex_stat_int(fspec, statbufp, 0);
10986 }
10987 /*}}}*/
10988
10989 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
10990 int
10991 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
10992 {
10993    return flex_stat_int(fspec, statbufp, 1);
10994 }
10995 /*}}}*/
10996
10997
10998 /*{{{char *my_getlogin()*/
10999 /* VMS cuserid == Unix getlogin, except calling sequence */
11000 char *
11001 my_getlogin(void)
11002 {
11003     static char user[L_cuserid];
11004     return cuserid(user);
11005 }
11006 /*}}}*/
11007
11008
11009 /*  rmscopy - copy a file using VMS RMS routines
11010  *
11011  *  Copies contents and attributes of spec_in to spec_out, except owner
11012  *  and protection information.  Name and type of spec_in are used as
11013  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
11014  *  should try to propagate timestamps from the input file to the output file.
11015  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
11016  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
11017  *  propagated to the output file at creation iff the output file specification
11018  *  did not contain an explicit name or type, and the revision date is always
11019  *  updated at the end of the copy operation.  If it is greater than 0, then
11020  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11021  *  other than the revision date should be propagated, and bit 1 indicates
11022  *  that the revision date should be propagated.
11023  *
11024  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11025  *
11026  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11027  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
11028  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
11029  * as part of the Perl standard distribution under the terms of the
11030  * GNU General Public License or the Perl Artistic License.  Copies
11031  * of each may be found in the Perl standard distribution.
11032  */ /* FIXME */
11033 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11034 int
11035 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11036 {
11037     char *vmsin, * vmsout, *esa, *esa_out,
11038          *rsa, *ubf;
11039     unsigned long int i, sts, sts2;
11040     int dna_len;
11041     struct FAB fab_in, fab_out;
11042     struct RAB rab_in, rab_out;
11043     rms_setup_nam(nam);
11044     rms_setup_nam(nam_out);
11045     struct XABDAT xabdat;
11046     struct XABFHC xabfhc;
11047     struct XABRDT xabrdt;
11048     struct XABSUM xabsum;
11049
11050     vmsin = PerlMem_malloc(VMS_MAXRSS);
11051     if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11052     vmsout = PerlMem_malloc(VMS_MAXRSS);
11053     if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11054     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11055         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11056       PerlMem_free(vmsin);
11057       PerlMem_free(vmsout);
11058       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11059       return 0;
11060     }
11061
11062     esa = PerlMem_malloc(VMS_MAXRSS);
11063     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11064     fab_in = cc$rms_fab;
11065     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11066     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11067     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
11068     fab_in.fab$l_fop = FAB$M_SQO;
11069     rms_bind_fab_nam(fab_in, nam);
11070     fab_in.fab$l_xab = (void *) &xabdat;
11071
11072     rsa = PerlMem_malloc(VMS_MAXRSS);
11073     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
11074     rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
11075     rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
11076     rms_nam_esl(nam) = 0;
11077     rms_nam_rsl(nam) = 0;
11078     rms_nam_esll(nam) = 0;
11079     rms_nam_rsll(nam) = 0;
11080 #ifdef NAM$M_NO_SHORT_UPCASE
11081     if (decc_efs_case_preserve)
11082         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
11083 #endif
11084
11085     xabdat = cc$rms_xabdat;        /* To get creation date */
11086     xabdat.xab$l_nxt = (void *) &xabfhc;
11087
11088     xabfhc = cc$rms_xabfhc;        /* To get record length */
11089     xabfhc.xab$l_nxt = (void *) &xabsum;
11090
11091     xabsum = cc$rms_xabsum;        /* To get key and area information */
11092
11093     if (!((sts = sys$open(&fab_in)) & 1)) {
11094       PerlMem_free(vmsin);
11095       PerlMem_free(vmsout);
11096       PerlMem_free(esa);
11097       PerlMem_free(rsa);
11098       set_vaxc_errno(sts);
11099       switch (sts) {
11100         case RMS$_FNF: case RMS$_DNF:
11101           set_errno(ENOENT); break;
11102         case RMS$_DIR:
11103           set_errno(ENOTDIR); break;
11104         case RMS$_DEV:
11105           set_errno(ENODEV); break;
11106         case RMS$_SYN:
11107           set_errno(EINVAL); break;
11108         case RMS$_PRV:
11109           set_errno(EACCES); break;
11110         default:
11111           set_errno(EVMSERR);
11112       }
11113       return 0;
11114     }
11115
11116     nam_out = nam;
11117     fab_out = fab_in;
11118     fab_out.fab$w_ifi = 0;
11119     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
11120     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
11121     fab_out.fab$l_fop = FAB$M_SQO;
11122     rms_bind_fab_nam(fab_out, nam_out);
11123     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
11124     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
11125     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
11126     esa_out = PerlMem_malloc(VMS_MAXRSS);
11127     if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
11128     rms_set_rsa(nam_out, NULL, 0);
11129     rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
11130
11131     if (preserve_dates == 0) {  /* Act like DCL COPY */
11132       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
11133       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
11134       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
11135         PerlMem_free(vmsin);
11136         PerlMem_free(vmsout);
11137         PerlMem_free(esa);
11138         PerlMem_free(rsa);
11139         PerlMem_free(esa_out);
11140         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
11141         set_vaxc_errno(sts);
11142         return 0;
11143       }
11144       fab_out.fab$l_xab = (void *) &xabdat;
11145       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
11146         preserve_dates = 1;
11147     }
11148     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
11149       preserve_dates =0;      /* bitmask from this point forward   */
11150
11151     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
11152     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
11153       PerlMem_free(vmsin);
11154       PerlMem_free(vmsout);
11155       PerlMem_free(esa);
11156       PerlMem_free(rsa);
11157       PerlMem_free(esa_out);
11158       set_vaxc_errno(sts);
11159       switch (sts) {
11160         case RMS$_DNF:
11161           set_errno(ENOENT); break;
11162         case RMS$_DIR:
11163           set_errno(ENOTDIR); break;
11164         case RMS$_DEV:
11165           set_errno(ENODEV); break;
11166         case RMS$_SYN:
11167           set_errno(EINVAL); break;
11168         case RMS$_PRV:
11169           set_errno(EACCES); break;
11170         default:
11171           set_errno(EVMSERR);
11172       }
11173       return 0;
11174     }
11175     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
11176     if (preserve_dates & 2) {
11177       /* sys$close() will process xabrdt, not xabdat */
11178       xabrdt = cc$rms_xabrdt;
11179 #ifndef __GNUC__
11180       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
11181 #else
11182       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
11183        * is unsigned long[2], while DECC & VAXC use a struct */
11184       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
11185 #endif
11186       fab_out.fab$l_xab = (void *) &xabrdt;
11187     }
11188
11189     ubf = PerlMem_malloc(32256);
11190     if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
11191     rab_in = cc$rms_rab;
11192     rab_in.rab$l_fab = &fab_in;
11193     rab_in.rab$l_rop = RAB$M_BIO;
11194     rab_in.rab$l_ubf = ubf;
11195     rab_in.rab$w_usz = 32256;
11196     if (!((sts = sys$connect(&rab_in)) & 1)) {
11197       sys$close(&fab_in); sys$close(&fab_out);
11198       PerlMem_free(vmsin);
11199       PerlMem_free(vmsout);
11200       PerlMem_free(esa);
11201       PerlMem_free(ubf);
11202       PerlMem_free(rsa);
11203       PerlMem_free(esa_out);
11204       set_errno(EVMSERR); set_vaxc_errno(sts);
11205       return 0;
11206     }
11207
11208     rab_out = cc$rms_rab;
11209     rab_out.rab$l_fab = &fab_out;
11210     rab_out.rab$l_rbf = ubf;
11211     if (!((sts = sys$connect(&rab_out)) & 1)) {
11212       sys$close(&fab_in); sys$close(&fab_out);
11213       PerlMem_free(vmsin);
11214       PerlMem_free(vmsout);
11215       PerlMem_free(esa);
11216       PerlMem_free(ubf);
11217       PerlMem_free(rsa);
11218       PerlMem_free(esa_out);
11219       set_errno(EVMSERR); set_vaxc_errno(sts);
11220       return 0;
11221     }
11222
11223     while ((sts = sys$read(&rab_in))) {  /* always true  */
11224       if (sts == RMS$_EOF) break;
11225       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
11226       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
11227         sys$close(&fab_in); sys$close(&fab_out);
11228         PerlMem_free(vmsin);
11229         PerlMem_free(vmsout);
11230         PerlMem_free(esa);
11231         PerlMem_free(ubf);
11232         PerlMem_free(rsa);
11233         PerlMem_free(esa_out);
11234         set_errno(EVMSERR); set_vaxc_errno(sts);
11235         return 0;
11236       }
11237     }
11238
11239
11240     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
11241     sys$close(&fab_in);  sys$close(&fab_out);
11242     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
11243     if (!(sts & 1)) {
11244       PerlMem_free(vmsin);
11245       PerlMem_free(vmsout);
11246       PerlMem_free(esa);
11247       PerlMem_free(ubf);
11248       PerlMem_free(rsa);
11249       PerlMem_free(esa_out);
11250       set_errno(EVMSERR); set_vaxc_errno(sts);
11251       return 0;
11252     }
11253
11254     PerlMem_free(vmsin);
11255     PerlMem_free(vmsout);
11256     PerlMem_free(esa);
11257     PerlMem_free(ubf);
11258     PerlMem_free(rsa);
11259     PerlMem_free(esa_out);
11260     return 1;
11261
11262 }  /* end of rmscopy() */
11263 /*}}}*/
11264
11265
11266 /***  The following glue provides 'hooks' to make some of the routines
11267  * from this file available from Perl.  These routines are sufficiently
11268  * basic, and are required sufficiently early in the build process,
11269  * that's it's nice to have them available to miniperl as well as the
11270  * full Perl, so they're set up here instead of in an extension.  The
11271  * Perl code which handles importation of these names into a given
11272  * package lives in [.VMS]Filespec.pm in @INC.
11273  */
11274
11275 void
11276 rmsexpand_fromperl(pTHX_ CV *cv)
11277 {
11278   dXSARGS;
11279   char *fspec, *defspec = NULL, *rslt;
11280   STRLEN n_a;
11281   int fs_utf8, dfs_utf8;
11282
11283   fs_utf8 = 0;
11284   dfs_utf8 = 0;
11285   if (!items || items > 2)
11286     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
11287   fspec = SvPV(ST(0),n_a);
11288   fs_utf8 = SvUTF8(ST(0));
11289   if (!fspec || !*fspec) XSRETURN_UNDEF;
11290   if (items == 2) {
11291     defspec = SvPV(ST(1),n_a);
11292     dfs_utf8 = SvUTF8(ST(1));
11293   }
11294   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
11295   ST(0) = sv_newmortal();
11296   if (rslt != NULL) {
11297     sv_usepvn(ST(0),rslt,strlen(rslt));
11298     if (fs_utf8) {
11299         SvUTF8_on(ST(0));
11300     }
11301   }
11302   XSRETURN(1);
11303 }
11304
11305 void
11306 vmsify_fromperl(pTHX_ CV *cv)
11307 {
11308   dXSARGS;
11309   char *vmsified;
11310   STRLEN n_a;
11311   int utf8_fl;
11312
11313   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
11314   utf8_fl = SvUTF8(ST(0));
11315   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11316   ST(0) = sv_newmortal();
11317   if (vmsified != NULL) {
11318     sv_usepvn(ST(0),vmsified,strlen(vmsified));
11319     if (utf8_fl) {
11320         SvUTF8_on(ST(0));
11321     }
11322   }
11323   XSRETURN(1);
11324 }
11325
11326 void
11327 unixify_fromperl(pTHX_ CV *cv)
11328 {
11329   dXSARGS;
11330   char *unixified;
11331   STRLEN n_a;
11332   int utf8_fl;
11333
11334   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
11335   utf8_fl = SvUTF8(ST(0));
11336   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11337   ST(0) = sv_newmortal();
11338   if (unixified != NULL) {
11339     sv_usepvn(ST(0),unixified,strlen(unixified));
11340     if (utf8_fl) {
11341         SvUTF8_on(ST(0));
11342     }
11343   }
11344   XSRETURN(1);
11345 }
11346
11347 void
11348 fileify_fromperl(pTHX_ CV *cv)
11349 {
11350   dXSARGS;
11351   char *fileified;
11352   STRLEN n_a;
11353   int utf8_fl;
11354
11355   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
11356   utf8_fl = SvUTF8(ST(0));
11357   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11358   ST(0) = sv_newmortal();
11359   if (fileified != NULL) {
11360     sv_usepvn(ST(0),fileified,strlen(fileified));
11361     if (utf8_fl) {
11362         SvUTF8_on(ST(0));
11363     }
11364   }
11365   XSRETURN(1);
11366 }
11367
11368 void
11369 pathify_fromperl(pTHX_ CV *cv)
11370 {
11371   dXSARGS;
11372   char *pathified;
11373   STRLEN n_a;
11374   int utf8_fl;
11375
11376   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
11377   utf8_fl = SvUTF8(ST(0));
11378   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11379   ST(0) = sv_newmortal();
11380   if (pathified != NULL) {
11381     sv_usepvn(ST(0),pathified,strlen(pathified));
11382     if (utf8_fl) {
11383         SvUTF8_on(ST(0));
11384     }
11385   }
11386   XSRETURN(1);
11387 }
11388
11389 void
11390 vmspath_fromperl(pTHX_ CV *cv)
11391 {
11392   dXSARGS;
11393   char *vmspath;
11394   STRLEN n_a;
11395   int utf8_fl;
11396
11397   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
11398   utf8_fl = SvUTF8(ST(0));
11399   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11400   ST(0) = sv_newmortal();
11401   if (vmspath != NULL) {
11402     sv_usepvn(ST(0),vmspath,strlen(vmspath));
11403     if (utf8_fl) {
11404         SvUTF8_on(ST(0));
11405     }
11406   }
11407   XSRETURN(1);
11408 }
11409
11410 void
11411 unixpath_fromperl(pTHX_ CV *cv)
11412 {
11413   dXSARGS;
11414   char *unixpath;
11415   STRLEN n_a;
11416   int utf8_fl;
11417
11418   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
11419   utf8_fl = SvUTF8(ST(0));
11420   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11421   ST(0) = sv_newmortal();
11422   if (unixpath != NULL) {
11423     sv_usepvn(ST(0),unixpath,strlen(unixpath));
11424     if (utf8_fl) {
11425         SvUTF8_on(ST(0));
11426     }
11427   }
11428   XSRETURN(1);
11429 }
11430
11431 void
11432 candelete_fromperl(pTHX_ CV *cv)
11433 {
11434   dXSARGS;
11435   char *fspec, *fsp;
11436   SV *mysv;
11437   IO *io;
11438   STRLEN n_a;
11439
11440   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
11441
11442   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11443   Newx(fspec, VMS_MAXRSS, char);
11444   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
11445   if (SvTYPE(mysv) == SVt_PVGV) {
11446     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
11447       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11448       ST(0) = &PL_sv_no;
11449       Safefree(fspec);
11450       XSRETURN(1);
11451     }
11452     fsp = fspec;
11453   }
11454   else {
11455     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
11456       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11457       ST(0) = &PL_sv_no;
11458       Safefree(fspec);
11459       XSRETURN(1);
11460     }
11461   }
11462
11463   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
11464   Safefree(fspec);
11465   XSRETURN(1);
11466 }
11467
11468 void
11469 rmscopy_fromperl(pTHX_ CV *cv)
11470 {
11471   dXSARGS;
11472   char *inspec, *outspec, *inp, *outp;
11473   int date_flag;
11474   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
11475                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11476   unsigned long int sts;
11477   SV *mysv;
11478   IO *io;
11479   STRLEN n_a;
11480
11481   if (items < 2 || items > 3)
11482     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
11483
11484   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11485   Newx(inspec, VMS_MAXRSS, char);
11486   if (SvTYPE(mysv) == SVt_PVGV) {
11487     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
11488       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11489       ST(0) = &PL_sv_no;
11490       Safefree(inspec);
11491       XSRETURN(1);
11492     }
11493     inp = inspec;
11494   }
11495   else {
11496     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
11497       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11498       ST(0) = &PL_sv_no;
11499       Safefree(inspec);
11500       XSRETURN(1);
11501     }
11502   }
11503   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
11504   Newx(outspec, VMS_MAXRSS, char);
11505   if (SvTYPE(mysv) == SVt_PVGV) {
11506     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
11507       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11508       ST(0) = &PL_sv_no;
11509       Safefree(inspec);
11510       Safefree(outspec);
11511       XSRETURN(1);
11512     }
11513     outp = outspec;
11514   }
11515   else {
11516     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
11517       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11518       ST(0) = &PL_sv_no;
11519       Safefree(inspec);
11520       Safefree(outspec);
11521       XSRETURN(1);
11522     }
11523   }
11524   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
11525
11526   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11527   Safefree(inspec);
11528   Safefree(outspec);
11529   XSRETURN(1);
11530 }
11531
11532 /* The mod2fname is limited to shorter filenames by design, so it should
11533  * not be modified to support longer EFS pathnames
11534  */
11535 void
11536 mod2fname(pTHX_ CV *cv)
11537 {
11538   dXSARGS;
11539   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11540        workbuff[NAM$C_MAXRSS*1 + 1];
11541   int total_namelen = 3, counter, num_entries;
11542   /* ODS-5 ups this, but we want to be consistent, so... */
11543   int max_name_len = 39;
11544   AV *in_array = (AV *)SvRV(ST(0));
11545
11546   num_entries = av_len(in_array);
11547
11548   /* All the names start with PL_. */
11549   strcpy(ultimate_name, "PL_");
11550
11551   /* Clean up our working buffer */
11552   Zero(work_name, sizeof(work_name), char);
11553
11554   /* Run through the entries and build up a working name */
11555   for(counter = 0; counter <= num_entries; counter++) {
11556     /* If it's not the first name then tack on a __ */
11557     if (counter) {
11558       strcat(work_name, "__");
11559     }
11560     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11561                            PL_na));
11562   }
11563
11564   /* Check to see if we actually have to bother...*/
11565   if (strlen(work_name) + 3 <= max_name_len) {
11566     strcat(ultimate_name, work_name);
11567   } else {
11568     /* It's too darned big, so we need to go strip. We use the same */
11569     /* algorithm as xsubpp does. First, strip out doubled __ */
11570     char *source, *dest, last;
11571     dest = workbuff;
11572     last = 0;
11573     for (source = work_name; *source; source++) {
11574       if (last == *source && last == '_') {
11575         continue;
11576       }
11577       *dest++ = *source;
11578       last = *source;
11579     }
11580     /* Go put it back */
11581     strcpy(work_name, workbuff);
11582     /* Is it still too big? */
11583     if (strlen(work_name) + 3 > max_name_len) {
11584       /* Strip duplicate letters */
11585       last = 0;
11586       dest = workbuff;
11587       for (source = work_name; *source; source++) {
11588         if (last == toupper(*source)) {
11589         continue;
11590         }
11591         *dest++ = *source;
11592         last = toupper(*source);
11593       }
11594       strcpy(work_name, workbuff);
11595     }
11596
11597     /* Is it *still* too big? */
11598     if (strlen(work_name) + 3 > max_name_len) {
11599       /* Too bad, we truncate */
11600       work_name[max_name_len - 2] = 0;
11601     }
11602     strcat(ultimate_name, work_name);
11603   }
11604
11605   /* Okay, return it */
11606   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11607   XSRETURN(1);
11608 }
11609
11610 void
11611 hushexit_fromperl(pTHX_ CV *cv)
11612 {
11613     dXSARGS;
11614
11615     if (items > 0) {
11616         VMSISH_HUSHED = SvTRUE(ST(0));
11617     }
11618     ST(0) = boolSV(VMSISH_HUSHED);
11619     XSRETURN(1);
11620 }
11621
11622
11623 PerlIO *
11624 Perl_vms_start_glob
11625    (pTHX_ SV *tmpglob,
11626     IO *io)
11627 {
11628     PerlIO *fp;
11629     struct vs_str_st *rslt;
11630     char *vmsspec;
11631     char *rstr;
11632     char *begin, *cp;
11633     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11634     PerlIO *tmpfp;
11635     STRLEN i;
11636     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11637     struct dsc$descriptor_vs rsdsc;
11638     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
11639     unsigned long hasver = 0, isunix = 0;
11640     unsigned long int lff_flags = 0;
11641     int rms_sts;
11642
11643 #ifdef VMS_LONGNAME_SUPPORT
11644     lff_flags = LIB$M_FIL_LONG_NAMES;
11645 #endif
11646     /* The Newx macro will not allow me to assign a smaller array
11647      * to the rslt pointer, so we will assign it to the begin char pointer
11648      * and then copy the value into the rslt pointer.
11649      */
11650     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
11651     rslt = (struct vs_str_st *)begin;
11652     rslt->length = 0;
11653     rstr = &rslt->str[0];
11654     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
11655     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
11656     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
11657     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
11658
11659     Newx(vmsspec, VMS_MAXRSS, char);
11660
11661         /* We could find out if there's an explicit dev/dir or version
11662            by peeking into lib$find_file's internal context at
11663            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
11664            but that's unsupported, so I don't want to do it now and
11665            have it bite someone in the future. */
11666         /* Fix-me: vms_split_path() is the only way to do this, the
11667            existing method will fail with many legal EFS or UNIX specifications
11668          */
11669
11670     cp = SvPV(tmpglob,i);
11671
11672     for (; i; i--) {
11673         if (cp[i] == ';') hasver = 1;
11674         if (cp[i] == '.') {
11675             if (sts) hasver = 1;
11676             else sts = 1;
11677         }
11678         if (cp[i] == '/') {
11679             hasdir = isunix = 1;
11680             break;
11681         }
11682         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
11683             hasdir = 1;
11684             break;
11685         }
11686     }
11687     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
11688         Stat_t st;
11689         int stat_sts;
11690         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
11691         if (!stat_sts && S_ISDIR(st.st_mode)) {
11692             wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
11693             ok = (wilddsc.dsc$a_pointer != NULL);
11694         }
11695         else {
11696             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
11697             ok = (wilddsc.dsc$a_pointer != NULL);
11698         }
11699         if (ok)
11700             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
11701
11702         /* If not extended character set, replace ? with % */
11703         /* With extended character set, ? is a wildcard single character */
11704         if (!decc_efs_case_preserve) {
11705             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
11706                 if (*cp == '?') *cp = '%';
11707         }
11708         sts = SS$_NORMAL;
11709         while (ok && $VMS_STATUS_SUCCESS(sts)) {
11710          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
11711          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
11712
11713             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
11714                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
11715             if (!$VMS_STATUS_SUCCESS(sts))
11716                 break;
11717
11718             /* with varying string, 1st word of buffer contains result length */
11719             rstr[rslt->length] = '\0';
11720
11721              /* Find where all the components are */
11722              v_sts = vms_split_path
11723                        (rstr,
11724                         &v_spec,
11725                         &v_len,
11726                         &r_spec,
11727                         &r_len,
11728                         &d_spec,
11729                         &d_len,
11730                         &n_spec,
11731                         &n_len,
11732                         &e_spec,
11733                         &e_len,
11734                         &vs_spec,
11735                         &vs_len);
11736
11737             /* If no version on input, truncate the version on output */
11738             if (!hasver && (vs_len > 0)) {
11739                 *vs_spec = '\0';
11740                 vs_len = 0;
11741
11742                 /* No version & a null extension on UNIX handling */
11743                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
11744                     e_len = 0;
11745                     *e_spec = '\0';
11746                 }
11747             }
11748
11749             if (!decc_efs_case_preserve) {
11750                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
11751             }
11752
11753             if (hasdir) {
11754                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
11755                 begin = rstr;
11756             }
11757             else {
11758                 /* Start with the name */
11759                 begin = n_spec;
11760             }
11761             strcat(begin,"\n");
11762             ok = (PerlIO_puts(tmpfp,begin) != EOF);
11763         }
11764         if (cxt) (void)lib$find_file_end(&cxt);
11765         if (ok && sts != RMS$_NMF &&
11766             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
11767         if (!ok) {
11768             if (!(sts & 1)) {
11769                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
11770             }
11771             PerlIO_close(tmpfp);
11772             fp = NULL;
11773         }
11774         else {
11775             PerlIO_rewind(tmpfp);
11776             IoTYPE(io) = IoTYPE_RDONLY;
11777             IoIFP(io) = fp = tmpfp;
11778             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
11779         }
11780     }
11781     Safefree(vmsspec);
11782     Safefree(rslt);
11783     return fp;
11784 }
11785
11786 #ifdef HAS_SYMLINK
11787 static char *
11788 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec, const int *utf8_fl);
11789
11790 void
11791 vms_realpath_fromperl(pTHX_ CV *cv)
11792 {
11793   dXSARGS;
11794   char *fspec, *rslt_spec, *rslt;
11795   STRLEN n_a;
11796
11797   if (!items || items != 1)
11798     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
11799
11800   fspec = SvPV(ST(0),n_a);
11801   if (!fspec || !*fspec) XSRETURN_UNDEF;
11802
11803   Newx(rslt_spec, VMS_MAXRSS + 1, char);
11804   rslt = do_vms_realpath(fspec, rslt_spec, NULL);
11805   ST(0) = sv_newmortal();
11806   if (rslt != NULL)
11807     sv_usepvn(ST(0),rslt,strlen(rslt));
11808   else
11809     Safefree(rslt_spec);
11810   XSRETURN(1);
11811 }
11812 #endif
11813
11814 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11815 int do_vms_case_tolerant(void);
11816
11817 void
11818 vms_case_tolerant_fromperl(pTHX_ CV *cv)
11819 {
11820   dXSARGS;
11821   ST(0) = boolSV(do_vms_case_tolerant());
11822   XSRETURN(1);
11823 }
11824 #endif
11825
11826 void
11827 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
11828                           struct interp_intern *dst)
11829 {
11830     memcpy(dst,src,sizeof(struct interp_intern));
11831 }
11832
11833 void
11834 Perl_sys_intern_clear(pTHX)
11835 {
11836 }
11837
11838 void
11839 Perl_sys_intern_init(pTHX)
11840 {
11841     unsigned int ix = RAND_MAX;
11842     double x;
11843
11844     VMSISH_HUSHED = 0;
11845
11846     /* fix me later to track running under GNV */
11847     /* this allows some limited testing */
11848     MY_POSIX_EXIT = decc_filename_unix_report;
11849
11850     x = (float)ix;
11851     MY_INV_RAND_MAX = 1./x;
11852 }
11853
11854 void
11855 init_os_extras(void)
11856 {
11857   dTHX;
11858   char* file = __FILE__;
11859   if (decc_disable_to_vms_logname_translation) {
11860     no_translate_barewords = TRUE;
11861   } else {
11862     no_translate_barewords = FALSE;
11863   }
11864
11865   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
11866   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
11867   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
11868   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
11869   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
11870   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
11871   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
11872   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
11873   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
11874   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
11875   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
11876 #ifdef HAS_SYMLINK
11877   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
11878 #endif
11879 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11880   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
11881 #endif
11882
11883   store_pipelocs(aTHX);         /* will redo any earlier attempts */
11884
11885   return;
11886 }
11887
11888 #ifdef HAS_SYMLINK
11889
11890 #if __CRTL_VER == 80200000
11891 /* This missed getting in to the DECC SDK for 8.2 */
11892 char *realpath(const char *file_name, char * resolved_name, ...);
11893 #endif
11894
11895 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
11896 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
11897  * The perl fallback routine to provide realpath() is not as efficient
11898  * on OpenVMS.
11899  */
11900 static char *
11901 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
11902 {
11903     return realpath(filespec, outbuf);
11904 }
11905
11906 /*}}}*/
11907 /* External entry points */
11908 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
11909 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
11910 #else
11911 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
11912 { return NULL; }
11913 #endif
11914
11915
11916 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11917 /* case_tolerant */
11918
11919 /*{{{int do_vms_case_tolerant(void)*/
11920 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
11921  * controlled by a process setting.
11922  */
11923 int do_vms_case_tolerant(void)
11924 {
11925     return vms_process_case_tolerant;
11926 }
11927 /*}}}*/
11928 /* External entry points */
11929 int Perl_vms_case_tolerant(void)
11930 { return do_vms_case_tolerant(); }
11931 #else
11932 int Perl_vms_case_tolerant(void)
11933 { return vms_process_case_tolerant; }
11934 #endif
11935
11936
11937  /* Start of DECC RTL Feature handling */
11938
11939 static int sys_trnlnm
11940    (const char * logname,
11941     char * value,
11942     int value_len)
11943 {
11944     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
11945     const unsigned long attr = LNM$M_CASE_BLIND;
11946     struct dsc$descriptor_s name_dsc;
11947     int status;
11948     unsigned short result;
11949     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
11950                                 {0, 0, 0, 0}};
11951
11952     name_dsc.dsc$w_length = strlen(logname);
11953     name_dsc.dsc$a_pointer = (char *)logname;
11954     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11955     name_dsc.dsc$b_class = DSC$K_CLASS_S;
11956
11957     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
11958
11959     if ($VMS_STATUS_SUCCESS(status)) {
11960
11961          /* Null terminate and return the string */
11962         /*--------------------------------------*/
11963         value[result] = 0;
11964     }
11965
11966     return status;
11967 }
11968
11969 static int sys_crelnm
11970    (const char * logname,
11971     const char * value)
11972 {
11973     int ret_val;
11974     const char * proc_table = "LNM$PROCESS_TABLE";
11975     struct dsc$descriptor_s proc_table_dsc;
11976     struct dsc$descriptor_s logname_dsc;
11977     struct itmlst_3 item_list[2];
11978
11979     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
11980     proc_table_dsc.dsc$w_length = strlen(proc_table);
11981     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11982     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
11983
11984     logname_dsc.dsc$a_pointer = (char *) logname;
11985     logname_dsc.dsc$w_length = strlen(logname);
11986     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11987     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
11988
11989     item_list[0].buflen = strlen(value);
11990     item_list[0].itmcode = LNM$_STRING;
11991     item_list[0].bufadr = (char *)value;
11992     item_list[0].retlen = NULL;
11993
11994     item_list[1].buflen = 0;
11995     item_list[1].itmcode = 0;
11996
11997     ret_val = sys$crelnm
11998                        (NULL,
11999                         (const struct dsc$descriptor_s *)&proc_table_dsc,
12000                         (const struct dsc$descriptor_s *)&logname_dsc,
12001                         NULL,
12002                         (const struct item_list_3 *) item_list);
12003
12004     return ret_val;
12005 }
12006
12007 /* C RTL Feature settings */
12008
12009 static int set_features
12010    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
12011     int (* cli_routine)(void),  /* Not documented */
12012     void *image_info)           /* Not documented */
12013 {
12014     int status;
12015     int s;
12016     int dflt;
12017     char* str;
12018     char val_str[10];
12019 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12020     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12021     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12022     unsigned long case_perm;
12023     unsigned long case_image;
12024 #endif
12025
12026     /* Allow an exception to bring Perl into the VMS debugger */
12027     vms_debug_on_exception = 0;
12028     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12029     if ($VMS_STATUS_SUCCESS(status)) {
12030        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12031          vms_debug_on_exception = 1;
12032        else
12033          vms_debug_on_exception = 0;
12034     }
12035
12036     /* Create VTF-7 filenames from UNICODE instead of UTF-8 */
12037     vms_vtf7_filenames = 0;
12038     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
12039     if ($VMS_STATUS_SUCCESS(status)) {
12040        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12041          vms_vtf7_filenames = 1;
12042        else
12043          vms_vtf7_filenames = 0;
12044     }
12045
12046     /* Dectect running under GNV Bash or other UNIX like shell */
12047 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12048     gnv_unix_shell = 0;
12049     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
12050     if ($VMS_STATUS_SUCCESS(status)) {
12051        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12052          gnv_unix_shell = 1;
12053          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
12054          set_feature_default("DECC$EFS_CHARSET", 1);
12055          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
12056          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
12057          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
12058          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
12059        }
12060        else
12061          gnv_unix_shell = 0;
12062     }
12063 #endif
12064
12065     /* hacks to see if known bugs are still present for testing */
12066
12067     /* Readdir is returning filenames in VMS syntax always */
12068     decc_bug_readdir_efs1 = 1;
12069     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
12070     if ($VMS_STATUS_SUCCESS(status)) {
12071        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12072          decc_bug_readdir_efs1 = 1;
12073        else
12074          decc_bug_readdir_efs1 = 0;
12075     }
12076
12077     /* PCP mode requires creating /dev/null special device file */
12078     decc_bug_devnull = 0;
12079     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
12080     if ($VMS_STATUS_SUCCESS(status)) {
12081        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12082           decc_bug_devnull = 1;
12083        else
12084           decc_bug_devnull = 0;
12085     }
12086
12087     /* fgetname returning a VMS name in UNIX mode */
12088     decc_bug_fgetname = 1;
12089     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
12090     if ($VMS_STATUS_SUCCESS(status)) {
12091       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12092         decc_bug_fgetname = 1;
12093       else
12094         decc_bug_fgetname = 0;
12095     }
12096
12097     /* UNIX directory names with no paths are broken in a lot of places */
12098     decc_dir_barename = 1;
12099     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
12100     if ($VMS_STATUS_SUCCESS(status)) {
12101       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12102         decc_dir_barename = 1;
12103       else
12104         decc_dir_barename = 0;
12105     }
12106
12107 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12108     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
12109     if (s >= 0) {
12110         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
12111         if (decc_disable_to_vms_logname_translation < 0)
12112             decc_disable_to_vms_logname_translation = 0;
12113     }
12114
12115     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
12116     if (s >= 0) {
12117         decc_efs_case_preserve = decc$feature_get_value(s, 1);
12118         if (decc_efs_case_preserve < 0)
12119             decc_efs_case_preserve = 0;
12120     }
12121
12122     s = decc$feature_get_index("DECC$EFS_CHARSET");
12123     if (s >= 0) {
12124         decc_efs_charset = decc$feature_get_value(s, 1);
12125         if (decc_efs_charset < 0)
12126             decc_efs_charset = 0;
12127     }
12128
12129     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
12130     if (s >= 0) {
12131         decc_filename_unix_report = decc$feature_get_value(s, 1);
12132         if (decc_filename_unix_report > 0)
12133             decc_filename_unix_report = 1;
12134         else
12135             decc_filename_unix_report = 0;
12136     }
12137
12138     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
12139     if (s >= 0) {
12140         decc_filename_unix_only = decc$feature_get_value(s, 1);
12141         if (decc_filename_unix_only > 0) {
12142             decc_filename_unix_only = 1;
12143         }
12144         else {
12145             decc_filename_unix_only = 0;
12146         }
12147     }
12148
12149     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
12150     if (s >= 0) {
12151         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
12152         if (decc_filename_unix_no_version < 0)
12153             decc_filename_unix_no_version = 0;
12154     }
12155
12156     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
12157     if (s >= 0) {
12158         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
12159         if (decc_readdir_dropdotnotype < 0)
12160             decc_readdir_dropdotnotype = 0;
12161     }
12162
12163     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
12164     if ($VMS_STATUS_SUCCESS(status)) {
12165         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
12166         if (s >= 0) {
12167             dflt = decc$feature_get_value(s, 4);
12168             if (dflt > 0) {
12169                 decc_disable_posix_root = decc$feature_get_value(s, 1);
12170                 if (decc_disable_posix_root <= 0) {
12171                     decc$feature_set_value(s, 1, 1);
12172                     decc_disable_posix_root = 1;
12173                 }
12174             }
12175             else {
12176                 /* Traditionally Perl assumes this is off */
12177                 decc_disable_posix_root = 1;
12178                 decc$feature_set_value(s, 1, 1);
12179             }
12180         }
12181     }
12182
12183 #if __CRTL_VER >= 80200000
12184     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
12185     if (s >= 0) {
12186         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
12187         if (decc_posix_compliant_pathnames < 0)
12188             decc_posix_compliant_pathnames = 0;
12189         if (decc_posix_compliant_pathnames > 4)
12190             decc_posix_compliant_pathnames = 0;
12191     }
12192
12193 #endif
12194 #else
12195     status = sys_trnlnm
12196         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
12197     if ($VMS_STATUS_SUCCESS(status)) {
12198         val_str[0] = _toupper(val_str[0]);
12199         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12200            decc_disable_to_vms_logname_translation = 1;
12201         }
12202     }
12203
12204 #ifndef __VAX
12205     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
12206     if ($VMS_STATUS_SUCCESS(status)) {
12207         val_str[0] = _toupper(val_str[0]);
12208         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12209            decc_efs_case_preserve = 1;
12210         }
12211     }
12212 #endif
12213
12214     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
12215     if ($VMS_STATUS_SUCCESS(status)) {
12216         val_str[0] = _toupper(val_str[0]);
12217         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12218            decc_filename_unix_report = 1;
12219         }
12220     }
12221     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
12222     if ($VMS_STATUS_SUCCESS(status)) {
12223         val_str[0] = _toupper(val_str[0]);
12224         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12225            decc_filename_unix_only = 1;
12226            decc_filename_unix_report = 1;
12227         }
12228     }
12229     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
12230     if ($VMS_STATUS_SUCCESS(status)) {
12231         val_str[0] = _toupper(val_str[0]);
12232         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12233            decc_filename_unix_no_version = 1;
12234         }
12235     }
12236     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
12237     if ($VMS_STATUS_SUCCESS(status)) {
12238         val_str[0] = _toupper(val_str[0]);
12239         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12240            decc_readdir_dropdotnotype = 1;
12241         }
12242     }
12243 #endif
12244
12245 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12246
12247      /* Report true case tolerance */
12248     /*----------------------------*/
12249     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
12250     if (!$VMS_STATUS_SUCCESS(status))
12251         case_perm = PPROP$K_CASE_BLIND;
12252     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
12253     if (!$VMS_STATUS_SUCCESS(status))
12254         case_image = PPROP$K_CASE_BLIND;
12255     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
12256         (case_image == PPROP$K_CASE_SENSITIVE))
12257         vms_process_case_tolerant = 0;
12258
12259 #endif
12260
12261
12262     /* CRTL can be initialized past this point, but not before. */
12263 /*    DECC$CRTL_INIT(); */
12264
12265     return SS$_NORMAL;
12266 }
12267
12268 #ifdef __DECC
12269 /* DECC dependent attributes */
12270 #if __DECC_VER < 60560002
12271 #define relative
12272 #define not_executable
12273 #else
12274 #define relative ,rel
12275 #define not_executable ,noexe
12276 #endif
12277 #pragma nostandard
12278 #pragma extern_model save
12279 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
12280 #endif
12281         const __align (LONGWORD) int spare[8] = {0};
12282 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
12283 /*                        NOWRT, LONG */
12284 #ifdef __DECC
12285 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
12286         nowrt,noshr relative not_executable
12287 #endif
12288 const long vms_cc_features = (const long)set_features;
12289
12290 /*
12291 ** Force a reference to LIB$INITIALIZE to ensure it
12292 ** exists in the image.
12293 */
12294 int lib$initialize(void);
12295 #ifdef __DECC
12296 #pragma extern_model strict_refdef
12297 #endif
12298     int lib_init_ref = (int) lib$initialize;
12299
12300 #ifdef __DECC
12301 #pragma extern_model restore
12302 #pragma standard
12303 #endif
12304
12305 /*  End of vms.c */