vms/vms.c

   1 /* vms.c
   2  *
   3  * VMS-specific routines for perl5
   4  *
   5  * Last revised: 20-Aug-1999 by Charles Bailey  bailey@newman.upenn.edu
   6  * Version: 5.5.60
   7  */
   8
   9 #include <acedef.h>
  10 #include <acldef.h>
  11 #include <armdef.h>
  12 #include <atrdef.h>
  13 #include <chpdef.h>
  14 #include <clidef.h>
  15 #include <climsgdef.h>
  16 #include <descrip.h>
  17 #include <dvidef.h>
  18 #include <fibdef.h>
  19 #include <float.h>
  20 #include <fscndef.h>
  21 #include <iodef.h>
  22 #include <jpidef.h>
  23 #include <kgbdef.h>
  24 #include <libclidef.h>
  25 #include <libdef.h>
  26 #include <lib$routines.h>
  27 #include <lnmdef.h>
  28 #include <prvdef.h>
  29 #include <psldef.h>
  30 #include <rms.h>
  31 #include <shrdef.h>
  32 #include <ssdef.h>
  33 #include <starlet.h>
  34 #include <strdef.h>
  35 #include <str$routines.h>
  36 #include <syidef.h>
  37 #include <uaidef.h>
  38 #include <uicdef.h>
  39
  40 /* Older versions of ssdef.h don't have these */
  41 #ifndef SS$_INVFILFOROP
  42 #  define SS$_INVFILFOROP 3930
  43 #endif
  44 #ifndef SS$_NOSUCHOBJECT
  45 #  define SS$_NOSUCHOBJECT 2696
  46 #endif
  47
  48 /* Don't replace system definitions of vfork, getenv, and stat,
  49  * code below needs to get to the underlying CRTL routines. */
  50 #define DONT_MASK_RTL_CALLS
  51 #include "EXTERN.h"
  52 #include "perl.h"
  53 #include "XSUB.h"
  54 /* Anticipating future expansion in lexical warnings . . . */
  55 #ifndef WARN_INTERNAL
  56 #  define WARN_INTERNAL WARN_MISC
  57 #endif
  58
  59 /* gcc's header files don't #define direct access macros
  60  * corresponding to VAXC's variant structs */
  61 #ifdef __GNUC__
  62 #  define uic$v_format uic$r_uic_form.uic$v_format
  63 #  define uic$v_group uic$r_uic_form.uic$v_group
  64 #  define uic$v_member uic$r_uic_form.uic$v_member
  65 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
  66 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
  67 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
  68 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
  69 #endif
  70
  71 #if defined(NEED_AN_H_ERRNO)
  72 dEXT int h_errno;
  73 #endif
  74
  75 struct itmlst_3 {
  76   unsigned short int buflen;
  77   unsigned short int itmcode;
  78   void *bufadr;
  79   unsigned short int *retlen;
  80 };
  81
  82 #define do_fileify_dirspec(a,b,c)       mp_do_fileify_dirspec(aTHX_ a,b,c)
  83 #define do_pathify_dirspec(a,b,c)       mp_do_pathify_dirspec(aTHX_ a,b,c)
  84 #define do_tovmsspec(a,b,c)             mp_do_tovmsspec(aTHX_ a,b,c)
  85 #define do_tovmspath(a,b,c)             mp_do_tovmspath(aTHX_ a,b,c)
  86 #define do_rmsexpand(a,b,c,d,e)         mp_do_rmsexpand(aTHX_ a,b,c,d,e)
  87 #define do_tounixspec(a,b,c)            mp_do_tounixspec(aTHX_ a,b,c)
  88 #define do_tounixpath(a,b,c)            mp_do_tounixpath(aTHX_ a,b,c)
  89 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
  90 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
  91
  92 static char *__mystrtolower(char *str)
  93 {
  94   if (str) for (; *str; ++str) *str= tolower(*str);
  95   return str;
  96 }
  97
  98 static struct dsc$descriptor_s fildevdsc =
  99   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 100 static struct dsc$descriptor_s crtlenvdsc =
 101   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 102 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 103 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 104 static struct dsc$descriptor_s **env_tables = defenv;
 105 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 106
 107 /* True if we shouldn't treat barewords as logicals during directory */
 108 /* munching */
 109 static int no_translate_barewords;
 110
 111 /* Temp for subprocess commands */
 112 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
 113
 114 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 115 int
 116 Perl_vmstrnenv(pTHX_ const char *lnm, char *eqv, unsigned long int idx,
 117   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 118 {
 119     char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
 120     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 121     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 122     unsigned char acmode;
 123     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 124                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 125     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 126                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 127                                  {0, 0, 0, 0}};
 128     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 129 #if defined(USE_THREADS)
 130     /* We jump through these hoops because we can be called at */
 131     /* platform-specific initialization time, which is before anything is */
 132     /* set up--we can't even do a plain dTHX since that relies on the */
 133     /* interpreter structure to be initialized */
 134     struct perl_thread *thr;
 135     if (PL_curinterp) {
 136       thr = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
 137     } else {
 138       thr = NULL;
 139     }
 140 #endif
 141
 142     if (!lnm || !eqv || idx > LNM$_MAX_INDEX) {
 143       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 144     }
 145     for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 146       *cp2 = _toupper(*cp1);
 147       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 148         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 149         return 0;
 150       }
 151     }
 152     lnmdsc.dsc$w_length = cp1 - lnm;
 153     lnmdsc.dsc$a_pointer = uplnm;
 154     uplnm[lnmdsc.dsc$w_length] = '\0';
 155     secure = flags & PERL__TRNENV_SECURE;
 156     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 157     if (!tabvec || !*tabvec) tabvec = env_tables;
 158
 159     for (curtab = 0; tabvec[curtab]; curtab++) {
 160       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 161         if (!ivenv && !secure) {
 162           char *eq, *end;
 163           int i;
 164           if (!environ) {
 165             ivenv = 1;
 166             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 167             continue;
 168           }
 169           retsts = SS$_NOLOGNAM;
 170           for (i = 0; environ[i]; i++) {
 171             if ((eq = strchr(environ[i],'=')) &&
 172                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 173               eq++;
 174               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 175               if (!eqvlen) continue;
 176               retsts = SS$_NORMAL;
 177               break;
 178             }
 179           }
 180           if (retsts != SS$_NOLOGNAM) break;
 181         }
 182       }
 183       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 184                !str$case_blind_compare(&tmpdsc,&clisym)) {
 185         if (!ivsym && !secure) {
 186           unsigned short int deflen = LNM$C_NAMLENGTH;
 187           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 188           /* dynamic dsc to accomodate possible long value */
 189           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 190           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 191           if (retsts & 1) {
 192             if (eqvlen > 1024) {
 193               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 194               eqvlen = 1024;
 195               /* Special hack--we might be called before the interpreter's */
 196               /* fully initialized, in which case either thr or PL_curcop */
 197               /* might be bogus. We have to check, since ckWARN needs them */
 198               /* both to be valid if running threaded */
 199 #if defined(USE_THREADS)
 200               if (thr && PL_curcop) {
 201 #endif
 202                 if (ckWARN(WARN_MISC)) {
 203                   Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
 204                 }
 205 #if defined(USE_THREADS)
 206               } else {
 207                   Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
 208               }
 209 #endif
 210
 211             }
 212             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 213           }
 214           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 215           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 216           if (retsts == LIB$_NOSUCHSYM) continue;
 217           break;
 218         }
 219       }
 220       else if (!ivlnm) {
 221         retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 222         if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 223         if (retsts == SS$_NOLOGNAM) continue;
 224         /* PPFs have a prefix */
 225         if (
 226 #if INTSIZE == 4
 227              *((int *)uplnm) == *((int *)"SYS$")                    &&
 228 #endif
 229              eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 230              ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 231                (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 232                (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 233                (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 234           memcpy(eqv,eqv+4,eqvlen-4);
 235           eqvlen -= 4;
 236         }
 237         break;
 238       }
 239     }
 240     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 241     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 242              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 243              retsts == SS$_NOLOGNAM) {
 244       set_errno(EINVAL);  set_vaxc_errno(retsts);
 245     }
 246     else _ckvmssts(retsts);
 247     return 0;
 248 }  /* end of vmstrnenv */
 249 /*}}}*/
 250
 251 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
 252 /* Define as a function so we can access statics. */
 253 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
 254 {
 255   return vmstrnenv(lnm,eqv,idx,fildev,
 256 #ifdef SECURE_INTERNAL_GETENV
 257                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
 258 #else
 259                    0
 260 #endif
 261                                                                               );
 262 }
 263 /*}}}*/
 264
 265 /* my_getenv
 266  * Note: Uses Perl temp to store result so char * can be returned to
 267  * caller; this pointer will be invalidated at next Perl statement
 268  * transition.
 269  * We define this as a function rather than a macro in terms of my_getenv_len()
 270  * so that it'll work when PL_curinterp is undefined (and we therefore can't
 271  * allocate SVs).
 272  */
 273 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
 274 char *
 275 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 276 {
 277     static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
 278     char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
 279     unsigned long int idx = 0;
 280     int trnsuccess;
 281     SV *tmpsv;
 282
 283     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 284       /* Set up a temporary buffer for the return value; Perl will
 285        * clean it up at the next statement transition */
 286       tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
 287       if (!tmpsv) return NULL;
 288       eqv = SvPVX(tmpsv);
 289     }
 290     else eqv = __my_getenv_eqv;  /* Assume no interpreter ==> single thread */
 291     for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 292     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
 293       getcwd(eqv,LNM$C_NAMLENGTH);
 294       return eqv;
 295     }
 296     else {
 297       if ((cp2 = strchr(lnm,';')) != NULL) {
 298         strcpy(uplnm,lnm);
 299         uplnm[cp2-lnm] = '\0';
 300         idx = strtoul(cp2+1,NULL,0);
 301         lnm = uplnm;
 302       }
 303       /* Impose security constraints only if tainting */
 304       if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
 305       if (vmstrnenv(lnm,eqv,idx,
 306                     sys ? fildev : NULL,
 307 #ifdef SECURE_INTERNAL_GETENV
 308                     sys ? PERL__TRNENV_SECURE : 0
 309 #else
 310                                                 0
 311 #endif
 312                                                  )) return eqv;
 313       else return Nullch;
 314     }
 315
 316 }  /* end of my_getenv() */
 317 /*}}}*/
 318
 319
 320 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
 321 char *
 322 my_getenv_len(const char *lnm, unsigned long *len, bool sys)
 323 {
 324     dTHX;
 325     char *buf, *cp1, *cp2;
 326     unsigned long idx = 0;
 327     static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
 328     SV *tmpsv;
 329
 330     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 331       /* Set up a temporary buffer for the return value; Perl will
 332        * clean it up at the next statement transition */
 333       tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
 334       if (!tmpsv) return NULL;
 335       buf = SvPVX(tmpsv);
 336     }
 337     else buf = __my_getenv_len_eqv;  /* Assume no interpreter ==> single thread */
 338     for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 339     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
 340       getcwd(buf,LNM$C_NAMLENGTH);
 341       *len = strlen(buf);
 342       return buf;
 343     }
 344     else {
 345       if ((cp2 = strchr(lnm,';')) != NULL) {
 346         strcpy(buf,lnm);
 347         buf[cp2-lnm] = '\0';
 348         idx = strtoul(cp2+1,NULL,0);
 349         lnm = buf;
 350       }
 351       /* Impose security constraints only if tainting */
 352       if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
 353       if ((*len = vmstrnenv(lnm,buf,idx,
 354                            sys ? fildev : NULL,
 355 #ifdef SECURE_INTERNAL_GETENV
 356                            sys ? PERL__TRNENV_SECURE : 0
 357 #else
 358                                                        0
 359 #endif
 360                                                          )))
 361           return buf;
 362       else
 363           return Nullch;
 364     }
 365
 366 }  /* end of my_getenv_len() */
 367 /*}}}*/
 368
 369 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
 370
 371 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
 372
 373 /*{{{ void prime_env_iter() */
 374 void
 375 prime_env_iter(void)
 376 /* Fill the %ENV associative array with all logical names we can
 377  * find, in preparation for iterating over it.
 378  */
 379 {
 380   dTHX;
 381   static int primed = 0;
 382   HV *seenhv = NULL, *envhv;
 383   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
 384   unsigned short int chan;
 385 #ifndef CLI$M_TRUSTED
 386 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
 387 #endif
 388   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
 389   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
 390   long int i;
 391   bool have_sym = FALSE, have_lnm = FALSE;
 392   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 393   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
 394   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
 395   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 396   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
 397 #ifdef USE_THREADS
 398   static perl_mutex primenv_mutex;
 399   MUTEX_INIT(&primenv_mutex);
 400 #endif
 401
 402   if (primed || !PL_envgv) return;
 403   MUTEX_LOCK(&primenv_mutex);
 404   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
 405   envhv = GvHVn(PL_envgv);
 406   /* Perform a dummy fetch as an lval to insure that the hash table is
 407    * set up.  Otherwise, the hv_store() will turn into a nullop. */
 408   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
 409
 410   for (i = 0; env_tables[i]; i++) {
 411      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
 412          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
 413      if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
 414   }
 415   if (have_sym || have_lnm) {
 416     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
 417     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
 418     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
 419     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
 420   }
 421
 422   for (i--; i >= 0; i--) {
 423     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
 424       char *start;
 425       int j;
 426       for (j = 0; environ[j]; j++) {
 427         if (!(start = strchr(environ[j],'='))) {
 428           if (ckWARN(WARN_INTERNAL))
 429             Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
 430         }
 431         else {
 432           start++;
 433           (void) hv_store(envhv,environ[j],start - environ[j] - 1,
 434                           newSVpv(start,0),0);
 435         }
 436       }
 437       continue;
 438     }
 439     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
 440              !str$case_blind_compare(&tmpdsc,&clisym)) {
 441       strcpy(cmd,"Show Symbol/Global *");
 442       cmddsc.dsc$w_length = 20;
 443       if (env_tables[i]->dsc$w_length == 12 &&
 444           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
 445           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
 446       flags = defflags | CLI$M_NOLOGNAM;
 447     }
 448     else {
 449       strcpy(cmd,"Show Logical *");
 450       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
 451         strcat(cmd," /Table=");
 452         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
 453         cmddsc.dsc$w_length = strlen(cmd);
 454       }
 455       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
 456       flags = defflags | CLI$M_NOCLISYM;
 457     }
 458
 459     /* Create a new subprocess to execute each command, to exclude the
 460      * remote possibility that someone could subvert a mbx or file used
 461      * to write multiple commands to a single subprocess.
 462      */
 463     do {
 464       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
 465                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
 466       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
 467       defflags &= ~CLI$M_TRUSTED;
 468     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
 469     _ckvmssts(retsts);
 470     if (!buf) New(1322,buf,mbxbufsiz + 1,char);
 471     if (seenhv) SvREFCNT_dec(seenhv);
 472     seenhv = newHV();
 473     while (1) {
 474       char *cp1, *cp2, *key;
 475       unsigned long int sts, iosb[2], retlen, keylen;
 476       register U32 hash;
 477
 478       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
 479       if (sts & 1) sts = iosb[0] & 0xffff;
 480       if (sts == SS$_ENDOFFILE) {
 481         int wakect = 0;
 482         while (substs == 0) { sys$hiber(); wakect++;}
 483         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
 484         _ckvmssts(substs);
 485         break;
 486       }
 487       _ckvmssts(sts);
 488       retlen = iosb[0] >> 16;
 489       if (!retlen) continue;  /* blank line */
 490       buf[retlen] = '\0';
 491       if (iosb[1] != subpid) {
 492         if (iosb[1]) {
 493           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
 494         }
 495         continue;
 496       }
 497       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
 498         Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
 499
 500       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
 501       if (*cp1 == '(' || /* Logical name table name */
 502           *cp1 == '='    /* Next eqv of searchlist  */) continue;
 503       if (*cp1 == '"') cp1++;
 504       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
 505       key = cp1;  keylen = cp2 - cp1;
 506       if (keylen && hv_exists(seenhv,key,keylen)) continue;
 507       while (*cp2 && *cp2 != '=') cp2++;
 508       while (*cp2 && *cp2 == '=') cp2++;
 509       while (*cp2 && *cp2 == ' ') cp2++;
 510       if (*cp2 == '"') {  /* String translation; may embed "" */
 511         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
 512         cp2++;  cp1--; /* Skip "" surrounding translation */
 513       }
 514       else {  /* Numeric translation */
 515         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
 516         cp1--;  /* stop on last non-space char */
 517       }
 518       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
 519         Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
 520         continue;
 521       }
 522       PERL_HASH(hash,key,keylen);
 523       hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
 524       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
 525     }
 526     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
 527       /* get the PPFs for this process, not the subprocess */
 528       char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
 529       char eqv[LNM$C_NAMLENGTH+1];
 530       int trnlen, i;
 531       for (i = 0; ppfs[i]; i++) {
 532         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
 533         hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
 534       }
 535     }
 536   }
 537   primed = 1;
 538   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
 539   if (buf) Safefree(buf);
 540   if (seenhv) SvREFCNT_dec(seenhv);
 541   MUTEX_UNLOCK(&primenv_mutex);
 542   return;
 543
 544 }  /* end of prime_env_iter */
 545 /*}}}*/
 546
 547
 548 /*{{{ int  vmssetenv(char *lnm, char *eqv)*/
 549 /* Define or delete an element in the same "environment" as
 550  * vmstrnenv().  If an element is to be deleted, it's removed from
 551  * the first place it's found.  If it's to be set, it's set in the
 552  * place designated by the first element of the table vector.
 553  * Like setenv() returns 0 for success, non-zero on error.
 554  */
 555 int
 556 vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
 557 {
 558     char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
 559     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
 560     unsigned long int retsts, usermode = PSL$C_USER;
 561     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
 562                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 563                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 564     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 565     $DESCRIPTOR(local,"_LOCAL");
 566     dTHX;
 567
 568     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 569       *cp2 = _toupper(*cp1);
 570       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 571         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 572         return SS$_IVLOGNAM;
 573       }
 574     }
 575     lnmdsc.dsc$w_length = cp1 - lnm;
 576     if (!tabvec || !*tabvec) tabvec = env_tables;
 577
 578     if (!eqv) {  /* we're deleting n element */
 579       for (curtab = 0; tabvec[curtab]; curtab++) {
 580         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 581         int i;
 582           for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
 583             if ((cp1 = strchr(environ[i],'=')) &&
 584                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
 585 #ifdef HAS_SETENV
 586               return setenv(lnm,eqv,1) ? vaxc$errno : 0;
 587             }
 588           }
 589           ivenv = 1; retsts = SS$_NOLOGNAM;
 590 #else
 591               if (ckWARN(WARN_INTERNAL))
 592                 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
 593               ivenv = 1; retsts = SS$_NOSUCHPGM;
 594               break;
 595             }
 596           }
 597 #endif
 598         }
 599         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 600                  !str$case_blind_compare(&tmpdsc,&clisym)) {
 601           unsigned int symtype;
 602           if (tabvec[curtab]->dsc$w_length == 12 &&
 603               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
 604               !str$case_blind_compare(&tmpdsc,&local))
 605             symtype = LIB$K_CLI_LOCAL_SYM;
 606           else symtype = LIB$K_CLI_GLOBAL_SYM;
 607           retsts = lib$delete_symbol(&lnmdsc,&symtype);
 608           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 609           if (retsts == LIB$_NOSUCHSYM) continue;
 610           break;
 611         }
 612         else if (!ivlnm) {
 613           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
 614           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 615           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
 616           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
 617           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
 618         }
 619       }
 620     }
 621     else {  /* we're defining a value */
 622       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
 623 #ifdef HAS_SETENV
 624         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
 625 #else
 626         if (ckWARN(WARN_INTERNAL))
 627           Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
 628         retsts = SS$_NOSUCHPGM;
 629 #endif
 630       }
 631       else {
 632         eqvdsc.dsc$a_pointer = eqv;
 633         eqvdsc.dsc$w_length  = strlen(eqv);
 634         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
 635             !str$case_blind_compare(&tmpdsc,&clisym)) {
 636           unsigned int symtype;
 637           if (tabvec[0]->dsc$w_length == 12 &&
 638               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
 639                !str$case_blind_compare(&tmpdsc,&local))
 640             symtype = LIB$K_CLI_LOCAL_SYM;
 641           else symtype = LIB$K_CLI_GLOBAL_SYM;
 642           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
 643         }
 644         else {
 645           if (!*eqv) eqvdsc.dsc$w_length = 1;
 646           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
 647             eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
 648             if (ckWARN(WARN_MISC)) {
 649               Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
 650             }
 651           }
 652           retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
 653         }
 654       }
 655     }
 656     if (!(retsts & 1)) {
 657       switch (retsts) {
 658         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
 659         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
 660           set_errno(EVMSERR); break;
 661         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
 662         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
 663           set_errno(EINVAL); break;
 664         case SS$_NOPRIV:
 665           set_errno(EACCES);
 666         default:
 667           _ckvmssts(retsts);
 668           set_errno(EVMSERR);
 669        }
 670        set_vaxc_errno(retsts);
 671        return (int) retsts || 44; /* retsts should never be 0, but just in case */
 672     }
 673     else {
 674       /* We reset error values on success because Perl does an hv_fetch()
 675        * before each hv_store(), and if the thing we're setting didn't
 676        * previously exist, we've got a leftover error message.  (Of course,
 677        * this fails in the face of
 678        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
 679        * in that the error reported in $! isn't spurious,
 680        * but it's right more often than not.)
 681        */
 682       set_errno(0); set_vaxc_errno(retsts);
 683       return 0;
 684     }
 685
 686 }  /* end of vmssetenv() */
 687 /*}}}*/
 688
 689 /*{{{ void  my_setenv(char *lnm, char *eqv)*/
 690 /* This has to be a function since there's a prototype for it in proto.h */
 691 void
 692 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
 693 {
 694   if (lnm && *lnm && strlen(lnm) == 7) {
 695     char uplnm[8];
 696     int i;
 697     for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
 698     if (!strcmp(uplnm,"DEFAULT")) {
 699       if (eqv && *eqv) chdir(eqv);
 700       return;
 701     }
 702   }
 703   (void) vmssetenv(lnm,eqv,NULL);
 704 }
 705 /*}}}*/
 706
 707
 708
 709 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
 710 /* my_crypt - VMS password hashing
 711  * my_crypt() provides an interface compatible with the Unix crypt()
 712  * C library function, and uses sys$hash_password() to perform VMS
 713  * password hashing.  The quadword hashed password value is returned
 714  * as a NUL-terminated 8 character string.  my_crypt() does not change
 715  * the case of its string arguments; in order to match the behavior
 716  * of LOGINOUT et al., alphabetic characters in both arguments must
 717  *  be upcased by the caller.
 718  */
 719 char *
 720 my_crypt(const char *textpasswd, const char *usrname)
 721 {
 722 #   ifndef UAI$C_PREFERRED_ALGORITHM
 723 #     define UAI$C_PREFERRED_ALGORITHM 127
 724 #   endif
 725     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
 726     unsigned short int salt = 0;
 727     unsigned long int sts;
 728     struct const_dsc {
 729         unsigned short int dsc$w_length;
 730         unsigned char      dsc$b_type;
 731         unsigned char      dsc$b_class;
 732         const char *       dsc$a_pointer;
 733     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
 734        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
 735     struct itmlst_3 uailst[3] = {
 736         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
 737         { sizeof salt, UAI$_SALT,    &salt, 0},
 738         { 0,           0,            NULL,  NULL}};
 739     static char hash[9];
 740
 741     usrdsc.dsc$w_length = strlen(usrname);
 742     usrdsc.dsc$a_pointer = usrname;
 743     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
 744       switch (sts) {
 745         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
 746           set_errno(EACCES);
 747           break;
 748         case RMS$_RNF:
 749           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
 750           break;
 751         default:
 752           set_errno(EVMSERR);
 753       }
 754       set_vaxc_errno(sts);
 755       if (sts != RMS$_RNF) return NULL;
 756     }
 757
 758     txtdsc.dsc$w_length = strlen(textpasswd);
 759     txtdsc.dsc$a_pointer = textpasswd;
 760     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
 761       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
 762     }
 763
 764     return (char *) hash;
 765
 766 }  /* end of my_crypt() */
 767 /*}}}*/
 768
 769
 770 static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
 771 static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
 772 static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
 773
 774 /*{{{int do_rmdir(char *name)*/
 775 int
 776 Perl_do_rmdir(pTHX_ char *name)
 777 {
 778     char dirfile[NAM$C_MAXRSS+1];
 779     int retval;
 780     Stat_t st;
 781
 782     if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
 783     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
 784     else retval = kill_file(dirfile);
 785     return retval;
 786
 787 }  /* end of do_rmdir */
 788 /*}}}*/
 789
 790 /* kill_file
 791  * Delete any file to which user has control access, regardless of whether
 792  * delete access is explicitly allowed.
 793  * Limitations: User must have write access to parent directory.
 794  *              Does not block signals or ASTs; if interrupted in midstream
 795  *              may leave file with an altered ACL.
 796  * HANDLE WITH CARE!
 797  */
 798 /*{{{int kill_file(char *name)*/
 799 int
 800 kill_file(char *name)
 801 {
 802     char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
 803     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
 804     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
 805     dTHX;
 806     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
 807     struct myacedef {
 808       unsigned char myace$b_length;
 809       unsigned char myace$b_type;
 810       unsigned short int myace$w_flags;
 811       unsigned long int myace$l_access;
 812       unsigned long int myace$l_ident;
 813     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
 814                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
 815       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
 816      struct itmlst_3
 817        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
 818                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
 819        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
 820        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
 821        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
 822        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
 823
 824     /* Expand the input spec using RMS, since the CRTL remove() and
 825      * system services won't do this by themselves, so we may miss
 826      * a file "hiding" behind a logical name or search list. */
 827     if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
 828     if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
 829     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
 830     /* If not, can changing protections help? */
 831     if (vaxc$errno != RMS$_PRV) return -1;
 832
 833     /* No, so we get our own UIC to use as a rights identifier,
 834      * and the insert an ACE at the head of the ACL which allows us
 835      * to delete the file.
 836      */
 837     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
 838     fildsc.dsc$w_length = strlen(rspec);
 839     fildsc.dsc$a_pointer = rspec;
 840     cxt = 0;
 841     newace.myace$l_ident = oldace.myace$l_ident;
 842     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
 843       switch (aclsts) {
 844         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
 845           set_errno(ENOENT); break;
 846         case RMS$_DIR:
 847           set_errno(ENOTDIR); break;
 848         case RMS$_DEV:
 849           set_errno(ENODEV); break;
 850         case RMS$_SYN: case SS$_INVFILFOROP:
 851           set_errno(EINVAL); break;
 852         case RMS$_PRV:
 853           set_errno(EACCES); break;
 854         default:
 855           _ckvmssts(aclsts);
 856       }
 857       set_vaxc_errno(aclsts);
 858       return -1;
 859     }
 860     /* Grab any existing ACEs with this identifier in case we fail */
 861     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
 862     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
 863                     || fndsts == SS$_NOMOREACE ) {
 864       /* Add the new ACE . . . */
 865       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
 866         goto yourroom;
 867       if ((rmsts = remove(name))) {
 868         /* We blew it - dir with files in it, no write priv for
 869          * parent directory, etc.  Put things back the way they were. */
 870         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
 871           goto yourroom;
 872         if (fndsts & 1) {
 873           addlst[0].bufadr = &oldace;
 874           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
 875             goto yourroom;
 876         }
 877       }
 878     }
 879
 880     yourroom:
 881     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
 882     /* We just deleted it, so of course it's not there.  Some versions of
 883      * VMS seem to return success on the unlock operation anyhow (after all
 884      * the unlock is successful), but others don't.
 885      */
 886     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
 887     if (aclsts & 1) aclsts = fndsts;
 888     if (!(aclsts & 1)) {
 889       set_errno(EVMSERR);
 890       set_vaxc_errno(aclsts);
 891       return -1;
 892     }
 893
 894     return rmsts;
 895
 896 }  /* end of kill_file() */
 897 /*}}}*/
 898
 899
 900 /*{{{int my_mkdir(char *,Mode_t)*/
 901 int
 902 my_mkdir(char *dir, Mode_t mode)
 903 {
 904   STRLEN dirlen = strlen(dir);
 905   dTHX;
 906
 907   /* zero length string sometimes gives ACCVIO */
 908   if (dirlen == 0) return -1;
 909
 910   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
 911    * null file name/type.  However, it's commonplace under Unix,
 912    * so we'll allow it for a gain in portability.
 913    */
 914   if (dir[dirlen-1] == '/') {
 915     char *newdir = savepvn(dir,dirlen-1);
 916     int ret = mkdir(newdir,mode);
 917     Safefree(newdir);
 918     return ret;
 919   }
 920   else return mkdir(dir,mode);
 921 }  /* end of my_mkdir */
 922 /*}}}*/
 923
 924 /*{{{int my_chdir(char *)*/
 925 int
 926 my_chdir(char *dir)
 927 {
 928   STRLEN dirlen = strlen(dir);
 929   dTHX;
 930
 931   /* zero length string sometimes gives ACCVIO */
 932   if (dirlen == 0) return -1;
 933
 934   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
 935    * that implies
 936    * null file name/type.  However, it's commonplace under Unix,
 937    * so we'll allow it for a gain in portability.
 938    */
 939   if (dir[dirlen-1] == '/') {
 940     char *newdir = savepvn(dir,dirlen-1);
 941     int ret = chdir(newdir);
 942     Safefree(newdir);
 943     return ret;
 944   }
 945   else return chdir(dir);
 946 }  /* end of my_chdir */
 947 /*}}}*/
 948
 949 static void
 950 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
 951 {
 952   static unsigned long int mbxbufsiz;
 953   long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
 954   dTHX;
 955
 956   if (!mbxbufsiz) {
 957     /*
 958      * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
 959      * preprocessor consant BUFSIZ from stdio.h as the size of the
 960      * 'pipe' mailbox.
 961      */
 962     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
 963     if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
 964   }
 965   _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
 966
 967   _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
 968   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
 969
 970 }  /* end of create_mbx() */
 971
 972 /*{{{  my_popen and my_pclose*/
 973 struct pipe_details
 974 {
 975     struct pipe_details *next;
 976     PerlIO *fp;  /* stdio file pointer to pipe mailbox */
 977     int pid;   /* PID of subprocess */
 978     int mode;  /* == 'r' if pipe open for reading */
 979     int done;  /* subprocess has completed */
 980     unsigned long int completion;  /* termination status of subprocess */
 981 };
 982
 983 struct exit_control_block
 984 {
 985     struct exit_control_block *flink;
 986     unsigned long int   (*exit_routine)();
 987     unsigned long int arg_count;
 988     unsigned long int *status_address;
 989     unsigned long int exit_status;
 990 };
 991
 992 static struct pipe_details *open_pipes = NULL;
 993 static $DESCRIPTOR(nl_desc, "NL:");
 994 static int waitpid_asleep = 0;
 995
 996 /* Send an EOF to a mbx.  N.B.  We don't check that fp actually points
 997  * to a mbx; that's the caller's responsibility.
 998  */
 999 static unsigned long int
1000 pipe_eof(FILE *fp, int immediate)
1001 {
1002   char devnam[NAM$C_MAXRSS+1], *cp;
1003   unsigned long int chan, iosb[2], retsts, retsts2;
1004   struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
1005   dTHX;
1006
1007   if (fgetname(fp,devnam,1)) {
1008     /* It oughta be a mailbox, so fgetname should give just the device
1009      * name, but just in case . . . */
1010     if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
1011     devdsc.dsc$w_length = strlen(devnam);
1012     _ckvmssts(sys$assign(&devdsc,&chan,0,0));
1013     retsts = sys$qiow(0,chan,IO$_WRITEOF|(immediate?IO$M_NOW|IO$M_NORSWAIT:0),
1014              iosb,0,0,0,0,0,0,0,0);
1015     if (retsts & 1) retsts = iosb[0];
1016     retsts2 = sys$dassgn(chan);  /* Be sure to deassign the channel */
1017     if (retsts & 1) retsts = retsts2;
1018     _ckvmssts(retsts);
1019     return retsts;
1020   }
1021   else _ckvmssts(vaxc$errno);  /* Should never happen */
1022   return (unsigned long int) vaxc$errno;
1023 }
1024
1025 static unsigned long int
1026 pipe_exit_routine()
1027 {
1028     struct pipe_details *info;
1029     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1030     int sts, did_stuff;
1031     dTHX;
1032
1033     /*
1034      first we try sending an EOF...ignore if doesn't work, make sure we
1035      don't hang
1036     */
1037     did_stuff = 0;
1038     info = open_pipes;
1039
1040     while (info) {
1041       int need_eof;
1042       _ckvmssts(sys$setast(0));
1043       need_eof = info->mode != 'r' && !info->done;
1044       _ckvmssts(sys$setast(1));
1045       if (need_eof) {
1046         if (pipe_eof(info->fp, 1) & 1) did_stuff = 1;
1047       }
1048       info = info->next;
1049     }
1050     if (did_stuff) sleep(1);   /* wait for EOF to have an effect */
1051
1052     did_stuff = 0;
1053     info = open_pipes;
1054     while (info) {
1055       _ckvmssts(sys$setast(0));
1056       if (!info->done) { /* Tap them gently on the shoulder . . .*/
1057         sts = sys$forcex(&info->pid,0,&abort);
1058         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1059         did_stuff = 1;
1060       }
1061       _ckvmssts(sys$setast(1));
1062       info = info->next;
1063     }
1064     if (did_stuff) sleep(1);    /* wait for them to respond */
1065
1066     info = open_pipes;
1067     while (info) {
1068       _ckvmssts(sys$setast(0));
1069       if (!info->done) {  /* We tried to be nice . . . */
1070         sts = sys$delprc(&info->pid,0);
1071         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1072         info->done = 1; /* so my_pclose doesn't try to write EOF */
1073       }
1074       _ckvmssts(sys$setast(1));
1075       info = info->next;
1076     }
1077
1078     while(open_pipes) {
1079       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1080       else if (!(sts & 1)) retsts = sts;
1081     }
1082     return retsts;
1083 }
1084
1085 static struct exit_control_block pipe_exitblock =
1086        {(struct exit_control_block *) 0,
1087         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1088
1089
1090 static void
1091 popen_completion_ast(struct pipe_details *thispipe)
1092 {
1093   thispipe->done = TRUE;
1094   if (waitpid_asleep) {
1095     waitpid_asleep = 0;
1096     sys$wake(0,0);
1097   }
1098 }
1099
1100 static unsigned long int setup_cmddsc(char *cmd, int check_img);
1101 static void vms_execfree(pTHX);
1102
1103 static PerlIO *
1104 safe_popen(char *cmd, char *mode)
1105 {
1106     static int handler_set_up = FALSE;
1107     char mbxname[64];
1108     unsigned short int chan;
1109     unsigned long int sts, flags=1;  /* nowait - gnu c doesn't allow &1 */
1110     dTHX;
1111     struct pipe_details *info;
1112     struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
1113                                       DSC$K_CLASS_S, mbxname},
1114                             cmddsc = {0, DSC$K_DTYPE_T,
1115                                       DSC$K_CLASS_S, 0};
1116
1117
1118     if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
1119     New(1301,info,1,struct pipe_details);
1120
1121     /* create mailbox */
1122     create_mbx(&chan,&namdsc);
1123
1124     /* open a FILE* onto it */
1125     info->fp = PerlIO_open(mbxname, mode);
1126
1127     /* give up other channel onto it */
1128     _ckvmssts(sys$dassgn(chan));
1129
1130     if (!info->fp)
1131         return Nullfp;
1132
1133     info->mode = *mode;
1134     info->done = FALSE;
1135     info->completion=0;
1136
1137     if (*mode == 'r') {
1138       _ckvmssts(lib$spawn(&VMScmd, &nl_desc, &namdsc, &flags,
1139                      0  /* name */, &info->pid, &info->completion,
1140                      0, popen_completion_ast,info,0,0,0));
1141     }
1142     else {
1143       _ckvmssts(lib$spawn(&VMScmd, &namdsc, 0 /* sys$output */, &flags,
1144                      0  /* name */, &info->pid, &info->completion,
1145                      0, popen_completion_ast,info,0,0,0));
1146     }
1147
1148     vms_execfree(aTHX);
1149     if (!handler_set_up) {
1150       _ckvmssts(sys$dclexh(&pipe_exitblock));
1151       handler_set_up = TRUE;
1152     }
1153     info->next=open_pipes;  /* prepend to list */
1154     open_pipes=info;
1155
1156     PL_forkprocess = info->pid;
1157     return info->fp;
1158 }  /* end of safe_popen */
1159
1160
1161 /*{{{  FILE *my_popen(char *cmd, char *mode)*/
1162 FILE *
1163 Perl_my_popen(pTHX_ char *cmd, char *mode)
1164 {
1165     TAINT_ENV();
1166     TAINT_PROPER("popen");
1167     PERL_FLUSHALL_FOR_CHILD;
1168     return safe_popen(cmd,mode);
1169 }
1170
1171 /*}}}*/
1172
1173 /*{{{  I32 my_pclose(FILE *fp)*/
1174 I32 Perl_my_pclose(pTHX_ FILE *fp)
1175 {
1176     struct pipe_details *info, *last = NULL;
1177     unsigned long int retsts;
1178     int need_eof;
1179
1180     for (info = open_pipes; info != NULL; last = info, info = info->next)
1181         if (info->fp == fp) break;
1182
1183     if (info == NULL) {  /* no such pipe open */
1184       set_errno(ECHILD); /* quoth POSIX */
1185       set_vaxc_errno(SS$_NONEXPR);
1186       return -1;
1187     }
1188
1189     /* If we were writing to a subprocess, insure that someone reading from
1190      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
1191      * produce an EOF record in the mailbox.  */
1192     _ckvmssts(sys$setast(0));
1193     need_eof = info->mode != 'r' && !info->done;
1194     _ckvmssts(sys$setast(1));
1195     if (need_eof) pipe_eof(info->fp,0);
1196     PerlIO_close(info->fp);
1197
1198     if (info->done) retsts = info->completion;
1199     else waitpid(info->pid,(int *) &retsts,0);
1200
1201     /* remove from list of open pipes */
1202     _ckvmssts(sys$setast(0));
1203     if (last) last->next = info->next;
1204     else open_pipes = info->next;
1205     _ckvmssts(sys$setast(1));
1206     Safefree(info);
1207
1208     return retsts;
1209
1210 }  /* end of my_pclose() */
1211
1212 /* sort-of waitpid; use only with popen() */
1213 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
1214 Pid_t
1215 my_waitpid(Pid_t pid, int *statusp, int flags)
1216 {
1217     struct pipe_details *info;
1218     dTHX;
1219
1220     for (info = open_pipes; info != NULL; info = info->next)
1221         if (info->pid == pid) break;
1222
1223     if (info != NULL) {  /* we know about this child */
1224       while (!info->done) {
1225         waitpid_asleep = 1;
1226         sys$hiber();
1227       }
1228
1229       *statusp = info->completion;
1230       return pid;
1231     }
1232     else {  /* we haven't heard of this child */
1233       $DESCRIPTOR(intdsc,"0 00:00:01");
1234       unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
1235       unsigned long int interval[2],sts;
1236
1237       if (ckWARN(WARN_EXEC)) {
1238         _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
1239         _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
1240         if (ownerpid != mypid)
1241           Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
1242       }
1243
1244       _ckvmssts(sys$bintim(&intdsc,interval));
1245       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
1246         _ckvmssts(sys$schdwk(0,0,interval,0));
1247         _ckvmssts(sys$hiber());
1248       }
1249       _ckvmssts(sts);
1250
1251       /* There's no easy way to find the termination status a child we're
1252        * not aware of beforehand.  If we're really interested in the future,
1253        * we can go looking for a termination mailbox, or chase after the
1254        * accounting record for the process.
1255        */
1256       *statusp = 0;
1257       return pid;
1258     }
1259
1260 }  /* end of waitpid() */
1261 /*}}}*/
1262 /*}}}*/
1263 /*}}}*/
1264
1265 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
1266 char *
1267 my_gconvert(double val, int ndig, int trail, char *buf)
1268 {
1269   static char __gcvtbuf[DBL_DIG+1];
1270   char *loc;
1271
1272   loc = buf ? buf : __gcvtbuf;
1273
1274 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
1275   if (val < 1) {
1276     sprintf(loc,"%.*g",ndig,val);
1277     return loc;
1278   }
1279 #endif
1280
1281   if (val) {
1282     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
1283     return gcvt(val,ndig,loc);
1284   }
1285   else {
1286     loc[0] = '0'; loc[1] = '\0';
1287     return loc;
1288   }
1289
1290 }
1291 /*}}}*/
1292
1293
1294 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
1295 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
1296  * to expand file specification.  Allows for a single default file
1297  * specification and a simple mask of options.  If outbuf is non-NULL,
1298  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
1299  * the resultant file specification is placed.  If outbuf is NULL, the
1300  * resultant file specification is placed into a static buffer.
1301  * The third argument, if non-NULL, is taken to be a default file
1302  * specification string.  The fourth argument is unused at present.
1303  * rmesexpand() returns the address of the resultant string if
1304  * successful, and NULL on error.
1305  */
1306 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
1307
1308 static char *
1309 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
1310 {
1311   static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
1312   char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
1313   char esa[NAM$C_MAXRSS], *cp, *out = NULL;
1314   struct FAB myfab = cc$rms_fab;
1315   struct NAM mynam = cc$rms_nam;
1316   STRLEN speclen;
1317   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
1318
1319   if (!filespec || !*filespec) {
1320     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
1321     return NULL;
1322   }
1323   if (!outbuf) {
1324     if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
1325     else    outbuf = __rmsexpand_retbuf;
1326   }
1327   if ((isunix = (strchr(filespec,'/') != NULL))) {
1328     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
1329     filespec = vmsfspec;
1330   }
1331
1332   myfab.fab$l_fna = filespec;
1333   myfab.fab$b_fns = strlen(filespec);
1334   myfab.fab$l_nam = &mynam;
1335
1336   if (defspec && *defspec) {
1337     if (strchr(defspec,'/') != NULL) {
1338       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
1339       defspec = tmpfspec;
1340     }
1341     myfab.fab$l_dna = defspec;
1342     myfab.fab$b_dns = strlen(defspec);
1343   }
1344
1345   mynam.nam$l_esa = esa;
1346   mynam.nam$b_ess = sizeof esa;
1347   mynam.nam$l_rsa = outbuf;
1348   mynam.nam$b_rss = NAM$C_MAXRSS;
1349
1350   retsts = sys$parse(&myfab,0,0);
1351   if (!(retsts & 1)) {
1352     mynam.nam$b_nop |= NAM$M_SYNCHK;
1353     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
1354       retsts = sys$parse(&myfab,0,0);
1355       if (retsts & 1) goto expanded;
1356     }
1357     mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
1358     (void) sys$parse(&myfab,0,0);  /* Free search context */
1359     if (out) Safefree(out);
1360     set_vaxc_errno(retsts);
1361     if      (retsts == RMS$_PRV) set_errno(EACCES);
1362     else if (retsts == RMS$_DEV) set_errno(ENODEV);
1363     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
1364     else                         set_errno(EVMSERR);
1365     return NULL;
1366   }
1367   retsts = sys$search(&myfab,0,0);
1368   if (!(retsts & 1) && retsts != RMS$_FNF) {
1369     mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1370     myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);  /* Free search context */
1371     if (out) Safefree(out);
1372     set_vaxc_errno(retsts);
1373     if      (retsts == RMS$_PRV) set_errno(EACCES);
1374     else                         set_errno(EVMSERR);
1375     return NULL;
1376   }
1377
1378   /* If the input filespec contained any lowercase characters,
1379    * downcase the result for compatibility with Unix-minded code. */
1380   expanded:
1381   for (out = myfab.fab$l_fna; *out; out++)
1382     if (islower(*out)) { haslower = 1; break; }
1383   if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
1384   else                 { out = esa;    speclen = mynam.nam$b_esl; }
1385   /* Trim off null fields added by $PARSE
1386    * If type > 1 char, must have been specified in original or default spec
1387    * (not true for version; $SEARCH may have added version of existing file).
1388    */
1389   trimver  = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
1390   trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
1391              (mynam.nam$l_ver - mynam.nam$l_type == 1);
1392   if (trimver || trimtype) {
1393     if (defspec && *defspec) {
1394       char defesa[NAM$C_MAXRSS];
1395       struct FAB deffab = cc$rms_fab;
1396       struct NAM defnam = cc$rms_nam;
1397
1398       deffab.fab$l_nam = &defnam;
1399       deffab.fab$l_fna = defspec;  deffab.fab$b_fns = myfab.fab$b_dns;
1400       defnam.nam$l_esa = defesa;   defnam.nam$b_ess = sizeof defesa;
1401       defnam.nam$b_nop = NAM$M_SYNCHK;
1402       if (sys$parse(&deffab,0,0) & 1) {
1403         if (trimver)  trimver  = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
1404         if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
1405       }
1406     }
1407     if (trimver) speclen = mynam.nam$l_ver - out;
1408     if (trimtype) {
1409       /* If we didn't already trim version, copy down */
1410       if (speclen > mynam.nam$l_ver - out)
1411         memcpy(mynam.nam$l_type, mynam.nam$l_ver,
1412                speclen - (mynam.nam$l_ver - out));
1413       speclen -= mynam.nam$l_ver - mynam.nam$l_type;
1414     }
1415   }
1416   /* If we just had a directory spec on input, $PARSE "helpfully"
1417    * adds an empty name and type for us */
1418   if (mynam.nam$l_name == mynam.nam$l_type &&
1419       mynam.nam$l_ver  == mynam.nam$l_type + 1 &&
1420       !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
1421     speclen = mynam.nam$l_name - out;
1422   out[speclen] = '\0';
1423   if (haslower) __mystrtolower(out);
1424
1425   /* Have we been working with an expanded, but not resultant, spec? */
1426   /* Also, convert back to Unix syntax if necessary. */
1427   if (!mynam.nam$b_rsl) {
1428     if (isunix) {
1429       if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
1430     }
1431     else strcpy(outbuf,esa);
1432   }
1433   else if (isunix) {
1434     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
1435     strcpy(outbuf,tmpfspec);
1436   }
1437   mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1438   mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
1439   myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);  /* Free search context */
1440   return outbuf;
1441 }
1442 /*}}}*/
1443 /* External entry points */
1444 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
1445 { return do_rmsexpand(spec,buf,0,def,opt); }
1446 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
1447 { return do_rmsexpand(spec,buf,1,def,opt); }
1448
1449
1450 /*
1451 ** The following routines are provided to make life easier when
1452 ** converting among VMS-style and Unix-style directory specifications.
1453 ** All will take input specifications in either VMS or Unix syntax. On
1454 ** failure, all return NULL.  If successful, the routines listed below
1455 ** return a pointer to a buffer containing the appropriately
1456 ** reformatted spec (and, therefore, subsequent calls to that routine
1457 ** will clobber the result), while the routines of the same names with
1458 ** a _ts suffix appended will return a pointer to a mallocd string
1459 ** containing the appropriately reformatted spec.
1460 ** In all cases, only explicit syntax is altered; no check is made that
1461 ** the resulting string is valid or that the directory in question
1462 ** actually exists.
1463 **
1464 **   fileify_dirspec() - convert a directory spec into the name of the
1465 **     directory file (i.e. what you can stat() to see if it's a dir).
1466 **     The style (VMS or Unix) of the result is the same as the style
1467 **     of the parameter passed in.
1468 **   pathify_dirspec() - convert a directory spec into a path (i.e.
1469 **     what you prepend to a filename to indicate what directory it's in).
1470 **     The style (VMS or Unix) of the result is the same as the style
1471 **     of the parameter passed in.
1472 **   tounixpath() - convert a directory spec into a Unix-style path.
1473 **   tovmspath() - convert a directory spec into a VMS-style path.
1474 **   tounixspec() - convert any file spec into a Unix-style file spec.
1475 **   tovmsspec() - convert any file spec into a VMS-style spec.
1476 **
1477 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
1478 ** Permission is given to distribute this code as part of the Perl
1479 ** standard distribution under the terms of the GNU General Public
1480 ** License or the Perl Artistic License.  Copies of each may be
1481 ** found in the Perl standard distribution.
1482  */
1483
1484 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
1485 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
1486 {
1487     static char __fileify_retbuf[NAM$C_MAXRSS+1];
1488     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
1489     char *retspec, *cp1, *cp2, *lastdir;
1490     char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
1491
1492     if (!dir || !*dir) {
1493       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1494     }
1495     dirlen = strlen(dir);
1496     while (dirlen && dir[dirlen-1] == '/') --dirlen;
1497     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
1498       strcpy(trndir,"/sys$disk/000000");
1499       dir = trndir;
1500       dirlen = 16;
1501     }
1502     if (dirlen > NAM$C_MAXRSS) {
1503       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
1504     }
1505     if (!strpbrk(dir+1,"/]>:")) {
1506       strcpy(trndir,*dir == '/' ? dir + 1: dir);
1507       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
1508       dir = trndir;
1509       dirlen = strlen(dir);
1510     }
1511     else {
1512       strncpy(trndir,dir,dirlen);
1513       trndir[dirlen] = '\0';
1514       dir = trndir;
1515     }
1516     /* If we were handed a rooted logical name or spec, treat it like a
1517      * simple directory, so that
1518      *    $ Define myroot dev:[dir.]
1519      *    ... do_fileify_dirspec("myroot",buf,1) ...
1520      * does something useful.
1521      */
1522     if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
1523       dir[--dirlen] = '\0';
1524       dir[dirlen-1] = ']';
1525     }
1526
1527     if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
1528       /* If we've got an explicit filename, we can just shuffle the string. */
1529       if (*(cp1+1)) hasfilename = 1;
1530       /* Similarly, we can just back up a level if we've got multiple levels
1531          of explicit directories in a VMS spec which ends with directories. */
1532       else {
1533         for (cp2 = cp1; cp2 > dir; cp2--) {
1534           if (*cp2 == '.') {
1535             *cp2 = *cp1; *cp1 = '\0';
1536             hasfilename = 1;
1537             break;
1538           }
1539           if (*cp2 == '[' || *cp2 == '<') break;
1540         }
1541       }
1542     }
1543
1544     if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
1545       if (dir[0] == '.') {
1546         if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
1547           return do_fileify_dirspec("[]",buf,ts);
1548         else if (dir[1] == '.' &&
1549                  (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
1550           return do_fileify_dirspec("[-]",buf,ts);
1551       }
1552       if (dirlen && dir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
1553         dirlen -= 1;                 /* to last element */
1554         lastdir = strrchr(dir,'/');
1555       }
1556       else if ((cp1 = strstr(dir,"/.")) != NULL) {
1557         /* If we have "/." or "/..", VMSify it and let the VMS code
1558          * below expand it, rather than repeating the code to handle
1559          * relative components of a filespec here */
1560         do {
1561           if (*(cp1+2) == '.') cp1++;
1562           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
1563             if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1564             if (strchr(vmsdir,'/') != NULL) {
1565               /* If do_tovmsspec() returned it, it must have VMS syntax
1566                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
1567                * the time to check this here only so we avoid a recursion
1568                * loop; otherwise, gigo.
1569                */
1570               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);  return NULL;
1571             }
1572             if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1573             return do_tounixspec(trndir,buf,ts);
1574           }
1575           cp1++;
1576         } while ((cp1 = strstr(cp1,"/.")) != NULL);
1577         lastdir = strrchr(dir,'/');
1578       }
1579       else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
1580         /* Ditto for specs that end in an MFD -- let the VMS code
1581          * figure out whether it's a real device or a rooted logical. */
1582         dir[dirlen] = '/'; dir[dirlen+1] = '\0';
1583         if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1584         if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1585         return do_tounixspec(trndir,buf,ts);
1586       }
1587       else {
1588         if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1589              !(lastdir = cp1 = strrchr(dir,']')) &&
1590              !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1591         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
1592           int ver; char *cp3;
1593           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
1594               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
1595               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1596               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
1597               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1598                             (ver || *cp3)))))) {
1599             set_errno(ENOTDIR);
1600             set_vaxc_errno(RMS$_DIR);
1601             return NULL;
1602           }
1603           dirlen = cp2 - dir;
1604         }
1605       }
1606       /* If we lead off with a device or rooted logical, add the MFD
1607          if we're specifying a top-level directory. */
1608       if (lastdir && *dir == '/') {
1609         addmfd = 1;
1610         for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1611           if (*cp1 == '/') {
1612             addmfd = 0;
1613             break;
1614           }
1615         }
1616       }
1617       retlen = dirlen + (addmfd ? 13 : 6);
1618       if (buf) retspec = buf;
1619       else if (ts) New(1309,retspec,retlen+1,char);
1620       else retspec = __fileify_retbuf;
1621       if (addmfd) {
1622         dirlen = lastdir - dir;
1623         memcpy(retspec,dir,dirlen);
1624         strcpy(&retspec[dirlen],"/000000");
1625         strcpy(&retspec[dirlen+7],lastdir);
1626       }
1627       else {
1628         memcpy(retspec,dir,dirlen);
1629         retspec[dirlen] = '\0';
1630       }
1631       /* We've picked up everything up to the directory file name.
1632          Now just add the type and version, and we're set. */
1633       strcat(retspec,".dir;1");
1634       return retspec;
1635     }
1636     else {  /* VMS-style directory spec */
1637       char esa[NAM$C_MAXRSS+1], term, *cp;
1638       unsigned long int sts, cmplen, haslower = 0;
1639       struct FAB dirfab = cc$rms_fab;
1640       struct NAM savnam, dirnam = cc$rms_nam;
1641
1642       dirfab.fab$b_fns = strlen(dir);
1643       dirfab.fab$l_fna = dir;
1644       dirfab.fab$l_nam = &dirnam;
1645       dirfab.fab$l_dna = ".DIR;1";
1646       dirfab.fab$b_dns = 6;
1647       dirnam.nam$b_ess = NAM$C_MAXRSS;
1648       dirnam.nam$l_esa = esa;
1649
1650       for (cp = dir; *cp; cp++)
1651         if (islower(*cp)) { haslower = 1; break; }
1652       if (!((sts = sys$parse(&dirfab))&1)) {
1653         if (dirfab.fab$l_sts == RMS$_DIR) {
1654           dirnam.nam$b_nop |= NAM$M_SYNCHK;
1655           sts = sys$parse(&dirfab) & 1;
1656         }
1657         if (!sts) {
1658           set_errno(EVMSERR);
1659           set_vaxc_errno(dirfab.fab$l_sts);
1660           return NULL;
1661         }
1662       }
1663       else {
1664         savnam = dirnam;
1665         if (sys$search(&dirfab)&1) {  /* Does the file really exist? */
1666           /* Yes; fake the fnb bits so we'll check type below */
1667           dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1668         }
1669         else { /* No; just work with potential name */
1670           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
1671           else {
1672             set_errno(EVMSERR);  set_vaxc_errno(dirfab.fab$l_sts);
1673             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
1674             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
1675             return NULL;
1676           }
1677         }
1678       }
1679       if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1680         cp1 = strchr(esa,']');
1681         if (!cp1) cp1 = strchr(esa,'>');
1682         if (cp1) {  /* Should always be true */
1683           dirnam.nam$b_esl -= cp1 - esa - 1;
1684           memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1685         }
1686       }
1687       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
1688         /* Yep; check version while we're at it, if it's there. */
1689         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1690         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1691           /* Something other than .DIR[;1].  Bzzt. */
1692           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
1693           dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
1694           set_errno(ENOTDIR);
1695           set_vaxc_errno(RMS$_DIR);
1696           return NULL;
1697         }
1698       }
1699       esa[dirnam.nam$b_esl] = '\0';
1700       if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1701         /* They provided at least the name; we added the type, if necessary, */
1702         if (buf) retspec = buf;                            /* in sys$parse() */
1703         else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
1704         else retspec = __fileify_retbuf;
1705         strcpy(retspec,esa);
1706         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
1707         dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
1708         return retspec;
1709       }
1710       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1711         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1712         *cp1 = '\0';
1713         dirnam.nam$b_esl -= 9;
1714       }
1715       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1716       if (cp1 == NULL) { /* should never happen */
1717         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
1718         dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
1719         return NULL;
1720       }
1721       term = *cp1;
1722       *cp1 = '\0';
1723       retlen = strlen(esa);
1724       if ((cp1 = strrchr(esa,'.')) != NULL) {
1725         /* There's more than one directory in the path.  Just roll back. */
1726         *cp1 = term;
1727         if (buf) retspec = buf;
1728         else if (ts) New(1311,retspec,retlen+7,char);
1729         else retspec = __fileify_retbuf;
1730         strcpy(retspec,esa);
1731       }
1732       else {
1733         if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1734           /* Go back and expand rooted logical name */
1735           dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1736           if (!(sys$parse(&dirfab) & 1)) {
1737             dirnam.nam$l_rlf = NULL;
1738             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
1739             set_errno(EVMSERR);
1740             set_vaxc_errno(dirfab.fab$l_sts);
1741             return NULL;
1742           }
1743           retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1744           if (buf) retspec = buf;
1745           else if (ts) New(1312,retspec,retlen+16,char);
1746           else retspec = __fileify_retbuf;
1747           cp1 = strstr(esa,"][");
1748           dirlen = cp1 - esa;
1749           memcpy(retspec,esa,dirlen);
1750           if (!strncmp(cp1+2,"000000]",7)) {
1751             retspec[dirlen-1] = '\0';
1752             for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1753             if (*cp1 == '.') *cp1 = ']';
1754             else {
1755               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1756               memcpy(cp1+1,"000000]",7);
1757             }
1758           }
1759           else {
1760             memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1761             retspec[retlen] = '\0';
1762             /* Convert last '.' to ']' */
1763             for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1764             if (*cp1 == '.') *cp1 = ']';
1765             else {
1766               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1767               memcpy(cp1+1,"000000]",7);
1768             }
1769           }
1770         }
1771         else {  /* This is a top-level dir.  Add the MFD to the path. */
1772           if (buf) retspec = buf;
1773           else if (ts) New(1312,retspec,retlen+16,char);
1774           else retspec = __fileify_retbuf;
1775           cp1 = esa;
1776           cp2 = retspec;
1777           while (*cp1 != ':') *(cp2++) = *(cp1++);
1778           strcpy(cp2,":[000000]");
1779           cp1 += 2;
1780           strcpy(cp2+9,cp1);
1781         }
1782       }
1783       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
1784       dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
1785       /* We've set up the string up through the filename.  Add the
1786          type and version, and we're done. */
1787       strcat(retspec,".DIR;1");
1788
1789       /* $PARSE may have upcased filespec, so convert output to lower
1790        * case if input contained any lowercase characters. */
1791       if (haslower) __mystrtolower(retspec);
1792       return retspec;
1793     }
1794 }  /* end of do_fileify_dirspec() */
1795 /*}}}*/
1796 /* External entry points */
1797 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
1798 { return do_fileify_dirspec(dir,buf,0); }
1799 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
1800 { return do_fileify_dirspec(dir,buf,1); }
1801
1802 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1803 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
1804 {
1805     static char __pathify_retbuf[NAM$C_MAXRSS+1];
1806     unsigned long int retlen;
1807     char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1808
1809     if (!dir || !*dir) {
1810       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1811     }
1812
1813     if (*dir) strcpy(trndir,dir);
1814     else getcwd(trndir,sizeof trndir - 1);
1815
1816     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
1817            && my_trnlnm(trndir,trndir,0)) {
1818       STRLEN trnlen = strlen(trndir);
1819
1820       /* Trap simple rooted lnms, and return lnm:[000000] */
1821       if (!strcmp(trndir+trnlen-2,".]")) {
1822         if (buf) retpath = buf;
1823         else if (ts) New(1318,retpath,strlen(dir)+10,char);
1824         else retpath = __pathify_retbuf;
1825         strcpy(retpath,dir);
1826         strcat(retpath,":[000000]");
1827         return retpath;
1828       }
1829     }
1830     dir = trndir;
1831
1832     if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1833       if (*dir == '.' && (*(dir+1) == '\0' ||
1834                           (*(dir+1) == '.' && *(dir+2) == '\0')))
1835         retlen = 2 + (*(dir+1) != '\0');
1836       else {
1837         if ( !(cp1 = strrchr(dir,'/')) &&
1838              !(cp1 = strrchr(dir,']')) &&
1839              !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1840         if ((cp2 = strchr(cp1,'.')) != NULL &&
1841             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
1842              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
1843               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1844               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1845           int ver; char *cp3;
1846           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
1847               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
1848               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1849               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
1850               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1851                             (ver || *cp3)))))) {
1852             set_errno(ENOTDIR);
1853             set_vaxc_errno(RMS$_DIR);
1854             return NULL;
1855           }
1856           retlen = cp2 - dir + 1;
1857         }
1858         else {  /* No file type present.  Treat the filename as a directory. */
1859           retlen = strlen(dir) + 1;
1860         }
1861       }
1862       if (buf) retpath = buf;
1863       else if (ts) New(1313,retpath,retlen+1,char);
1864       else retpath = __pathify_retbuf;
1865       strncpy(retpath,dir,retlen-1);
1866       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1867         retpath[retlen-1] = '/';      /* with '/', add it. */
1868         retpath[retlen] = '\0';
1869       }
1870       else retpath[retlen-1] = '\0';
1871     }
1872     else {  /* VMS-style directory spec */
1873       char esa[NAM$C_MAXRSS+1], *cp;
1874       unsigned long int sts, cmplen, haslower;
1875       struct FAB dirfab = cc$rms_fab;
1876       struct NAM savnam, dirnam = cc$rms_nam;
1877
1878       /* If we've got an explicit filename, we can just shuffle the string. */
1879       if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1880              (cp1 = strrchr(dir,'>')) != NULL     ) && *(cp1+1)) {
1881         if ((cp2 = strchr(cp1,'.')) != NULL) {
1882           int ver; char *cp3;
1883           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
1884               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
1885               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1886               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
1887               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1888                             (ver || *cp3)))))) {
1889             set_errno(ENOTDIR);
1890             set_vaxc_errno(RMS$_DIR);
1891             return NULL;
1892           }
1893         }
1894         else {  /* No file type, so just draw name into directory part */
1895           for (cp2 = cp1; *cp2; cp2++) ;
1896         }
1897         *cp2 = *cp1;
1898         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
1899         *cp1 = '.';
1900         /* We've now got a VMS 'path'; fall through */
1901       }
1902       dirfab.fab$b_fns = strlen(dir);
1903       dirfab.fab$l_fna = dir;
1904       if (dir[dirfab.fab$b_fns-1] == ']' ||
1905           dir[dirfab.fab$b_fns-1] == '>' ||
1906           dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1907         if (buf) retpath = buf;
1908         else if (ts) New(1314,retpath,strlen(dir)+1,char);
1909         else retpath = __pathify_retbuf;
1910         strcpy(retpath,dir);
1911         return retpath;
1912       }
1913       dirfab.fab$l_dna = ".DIR;1";
1914       dirfab.fab$b_dns = 6;
1915       dirfab.fab$l_nam = &dirnam;
1916       dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1917       dirnam.nam$l_esa = esa;
1918
1919       for (cp = dir; *cp; cp++)
1920         if (islower(*cp)) { haslower = 1; break; }
1921
1922       if (!(sts = (sys$parse(&dirfab)&1))) {
1923         if (dirfab.fab$l_sts == RMS$_DIR) {
1924           dirnam.nam$b_nop |= NAM$M_SYNCHK;
1925           sts = sys$parse(&dirfab) & 1;
1926         }
1927         if (!sts) {
1928           set_errno(EVMSERR);
1929           set_vaxc_errno(dirfab.fab$l_sts);
1930           return NULL;
1931         }
1932       }
1933       else {
1934         savnam = dirnam;
1935         if (!(sys$search(&dirfab)&1)) {  /* Does the file really exist? */
1936           if (dirfab.fab$l_sts != RMS$_FNF) {
1937             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
1938             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
1939             set_errno(EVMSERR);
1940             set_vaxc_errno(dirfab.fab$l_sts);
1941             return NULL;
1942           }
1943           dirnam = savnam; /* No; just work with potential name */
1944         }
1945       }
1946       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
1947         /* Yep; check version while we're at it, if it's there. */
1948         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1949         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1950           /* Something other than .DIR[;1].  Bzzt. */
1951           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
1952           dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
1953           set_errno(ENOTDIR);
1954           set_vaxc_errno(RMS$_DIR);
1955           return NULL;
1956         }
1957       }
1958       /* OK, the type was fine.  Now pull any file name into the
1959          directory path. */
1960       if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1961       else {
1962         cp1 = strrchr(esa,'>');
1963         *dirnam.nam$l_type = '>';
1964       }
1965       *cp1 = '.';
1966       *(dirnam.nam$l_type + 1) = '\0';
1967       retlen = dirnam.nam$l_type - esa + 2;
1968       if (buf) retpath = buf;
1969       else if (ts) New(1314,retpath,retlen,char);
1970       else retpath = __pathify_retbuf;
1971       strcpy(retpath,esa);
1972       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
1973       dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
1974       /* $PARSE may have upcased filespec, so convert output to lower
1975        * case if input contained any lowercase characters. */
1976       if (haslower) __mystrtolower(retpath);
1977     }
1978
1979     return retpath;
1980 }  /* end of do_pathify_dirspec() */
1981 /*}}}*/
1982 /* External entry points */
1983 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
1984 { return do_pathify_dirspec(dir,buf,0); }
1985 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
1986 { return do_pathify_dirspec(dir,buf,1); }
1987
1988 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1989 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
1990 {
1991   static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1992   char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1993   int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1994
1995   if (spec == NULL) return NULL;
1996   if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1997   if (buf) rslt = buf;
1998   else if (ts) {
1999     retlen = strlen(spec);
2000     cp1 = strchr(spec,'[');
2001     if (!cp1) cp1 = strchr(spec,'<');
2002     if (cp1) {
2003       for (cp1++; *cp1; cp1++) {
2004         if (*cp1 == '-') expand++; /* VMS  '-' ==> Unix '../' */
2005         if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
2006           { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
2007       }
2008     }
2009     New(1315,rslt,retlen+2+2*expand,char);
2010   }
2011   else rslt = __tounixspec_retbuf;
2012   if (strchr(spec,'/') != NULL) {
2013     strcpy(rslt,spec);
2014     return rslt;
2015   }
2016
2017   cp1 = rslt;
2018   cp2 = spec;
2019   dirend = strrchr(spec,']');
2020   if (dirend == NULL) dirend = strrchr(spec,'>');
2021   if (dirend == NULL) dirend = strchr(spec,':');
2022   if (dirend == NULL) {
2023     strcpy(rslt,spec);
2024     return rslt;
2025   }
2026   if (*cp2 != '[' && *cp2 != '<') {
2027     *(cp1++) = '/';
2028   }
2029   else {  /* the VMS spec begins with directories */
2030     cp2++;
2031     if (*cp2 == ']' || *cp2 == '>') {
2032       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
2033       return rslt;
2034     }
2035     else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
2036       if (getcwd(tmp,sizeof tmp,1) == NULL) {
2037         if (ts) Safefree(rslt);
2038         return NULL;
2039       }
2040       do {
2041         cp3 = tmp;
2042         while (*cp3 != ':' && *cp3) cp3++;
2043         *(cp3++) = '\0';
2044         if (strchr(cp3,']') != NULL) break;
2045       } while (vmstrnenv(tmp,tmp,0,fildev,0));
2046       if (ts && !buf &&
2047           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
2048         retlen = devlen + dirlen;
2049         Renew(rslt,retlen+1+2*expand,char);
2050         cp1 = rslt;
2051       }
2052       cp3 = tmp;
2053       *(cp1++) = '/';
2054       while (*cp3) {
2055         *(cp1++) = *(cp3++);
2056         if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
2057       }
2058       *(cp1++) = '/';
2059     }
2060     else if ( *cp2 == '.') {
2061       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
2062         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
2063         cp2 += 3;
2064       }
2065       else cp2++;
2066     }
2067   }
2068   for (; cp2 <= dirend; cp2++) {
2069     if (*cp2 == ':') {
2070       *(cp1++) = '/';
2071       if (*(cp2+1) == '[') cp2++;
2072     }
2073     else if (*cp2 == ']' || *cp2 == '>') {
2074       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
2075     }
2076     else if (*cp2 == '.') {
2077       *(cp1++) = '/';
2078       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
2079         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
2080                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
2081         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
2082             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
2083       }
2084       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
2085         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
2086         cp2 += 2;
2087       }
2088     }
2089     else if (*cp2 == '-') {
2090       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
2091         while (*cp2 == '-') {
2092           cp2++;
2093           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
2094         }
2095         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
2096           if (ts) Safefree(rslt);                        /* filespecs like */
2097           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
2098           return NULL;
2099         }
2100       }
2101       else *(cp1++) = *cp2;
2102     }
2103     else *(cp1++) = *cp2;
2104   }
2105   while (*cp2) *(cp1++) = *(cp2++);
2106   *cp1 = '\0';
2107
2108   return rslt;
2109
2110 }  /* end of do_tounixspec() */
2111 /*}}}*/
2112 /* External entry points */
2113 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
2114 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
2115
2116 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
2117 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
2118   static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
2119   char *rslt, *dirend;
2120   register char *cp1, *cp2;
2121   unsigned long int infront = 0, hasdir = 1;
2122
2123   if (path == NULL) return NULL;
2124   if (buf) rslt = buf;
2125   else if (ts) New(1316,rslt,strlen(path)+9,char);
2126   else rslt = __tovmsspec_retbuf;
2127   if (strpbrk(path,"]:>") ||
2128       (dirend = strrchr(path,'/')) == NULL) {
2129     if (path[0] == '.') {
2130       if (path[1] == '\0') strcpy(rslt,"[]");
2131       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
2132       else strcpy(rslt,path); /* probably garbage */
2133     }
2134     else strcpy(rslt,path);
2135     return rslt;
2136   }
2137   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
2138     if (!*(dirend+2)) dirend +=2;
2139     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
2140     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
2141   }
2142   cp1 = rslt;
2143   cp2 = path;
2144   if (*cp2 == '/') {
2145     char trndev[NAM$C_MAXRSS+1];
2146     int islnm, rooted;
2147     STRLEN trnend;
2148
2149     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
2150     if (!*(cp2+1)) {
2151       if (!buf & ts) Renew(rslt,18,char);
2152       strcpy(rslt,"sys$disk:[000000]");
2153       return rslt;
2154     }
2155     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
2156     *cp1 = '\0';
2157     islnm =  my_trnlnm(rslt,trndev,0);
2158     trnend = islnm ? strlen(trndev) - 1 : 0;
2159     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
2160     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
2161     /* If the first element of the path is a logical name, determine
2162      * whether it has to be translated so we can add more directories. */
2163     if (!islnm || rooted) {
2164       *(cp1++) = ':';
2165       *(cp1++) = '[';
2166       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
2167       else cp2++;
2168     }
2169     else {
2170       if (cp2 != dirend) {
2171         if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
2172         strcpy(rslt,trndev);
2173         cp1 = rslt + trnend;
2174         *(cp1++) = '.';
2175         cp2++;
2176       }
2177       else {
2178         *(cp1++) = ':';
2179         hasdir = 0;
2180       }
2181     }
2182   }
2183   else {
2184     *(cp1++) = '[';
2185     if (*cp2 == '.') {
2186       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
2187         cp2 += 2;         /* skip over "./" - it's redundant */
2188         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
2189       }
2190       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2191         *(cp1++) = '-';                                 /* "../" --> "-" */
2192         cp2 += 3;
2193       }
2194       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
2195                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
2196         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2197         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
2198         cp2 += 4;
2199       }
2200       if (cp2 > dirend) cp2 = dirend;
2201     }
2202     else *(cp1++) = '.';
2203   }
2204   for (; cp2 < dirend; cp2++) {
2205     if (*cp2 == '/') {
2206       if (*(cp2-1) == '/') continue;
2207       if (*(cp1-1) != '.') *(cp1++) = '.';
2208       infront = 0;
2209     }
2210     else if (!infront && *cp2 == '.') {
2211       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
2212       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
2213       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2214         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
2215         else if (*(cp1-2) == '[') *(cp1-1) = '-';
2216         else {  /* back up over previous directory name */
2217           cp1--;
2218           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
2219           if (*(cp1-1) == '[') {
2220             memcpy(cp1,"000000.",7);
2221             cp1 += 7;
2222           }
2223         }
2224         cp2 += 2;
2225         if (cp2 == dirend) break;
2226       }
2227       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
2228                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
2229         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
2230         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2231         if (!*(cp2+3)) {
2232           *(cp1++) = '.';  /* Simulate trailing '/' */
2233           cp2 += 2;  /* for loop will incr this to == dirend */
2234         }
2235         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
2236       }
2237       else *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
2238     }
2239     else {
2240       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
2241       if (*cp2 == '.')      *(cp1++) = '_';
2242       else                  *(cp1++) =  *cp2;
2243       infront = 1;
2244     }
2245   }
2246   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
2247   if (hasdir) *(cp1++) = ']';
2248   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
2249   while (*cp2) *(cp1++) = *(cp2++);
2250   *cp1 = '\0';
2251
2252   return rslt;
2253
2254 }  /* end of do_tovmsspec() */
2255 /*}}}*/
2256 /* External entry points */
2257 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
2258 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
2259
2260 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
2261 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
2262   static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
2263   int vmslen;
2264   char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
2265
2266   if (path == NULL) return NULL;
2267   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2268   if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
2269   if (buf) return buf;
2270   else if (ts) {
2271     vmslen = strlen(vmsified);
2272     New(1317,cp,vmslen+1,char);
2273     memcpy(cp,vmsified,vmslen);
2274     cp[vmslen] = '\0';
2275     return cp;
2276   }
2277   else {
2278     strcpy(__tovmspath_retbuf,vmsified);
2279     return __tovmspath_retbuf;
2280   }
2281
2282 }  /* end of do_tovmspath() */
2283 /*}}}*/
2284 /* External entry points */
2285 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
2286 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
2287
2288
2289 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
2290 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
2291   static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
2292   int unixlen;
2293   char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
2294
2295   if (path == NULL) return NULL;
2296   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2297   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
2298   if (buf) return buf;
2299   else if (ts) {
2300     unixlen = strlen(unixified);
2301     New(1317,cp,unixlen+1,char);
2302     memcpy(cp,unixified,unixlen);
2303     cp[unixlen] = '\0';
2304     return cp;
2305   }
2306   else {
2307     strcpy(__tounixpath_retbuf,unixified);
2308     return __tounixpath_retbuf;
2309   }
2310
2311 }  /* end of do_tounixpath() */
2312 /*}}}*/
2313 /* External entry points */
2314 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
2315 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
2316
2317 /*
2318  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
2319  *
2320  *****************************************************************************
2321  *                                                                           *
2322  *  Copyright (C) 1989-1994 by                                               *
2323  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
2324  *                                                                           *
2325  *  Permission is hereby  granted for the reproduction of this software,     *
2326  *  on condition that this copyright notice is included in the reproduction, *
2327  *  and that such reproduction is not for purposes of profit or material     *
2328  *  gain.                                                                    *
2329  *                                                                           *
2330  *  27-Aug-1994 Modified for inclusion in perl5                              *
2331  *              by Charles Bailey  bailey@newman.upenn.edu                   *
2332  *****************************************************************************
2333  */
2334
2335 /*
2336  * getredirection() is intended to aid in porting C programs
2337  * to VMS (Vax-11 C).  The native VMS environment does not support
2338  * '>' and '<' I/O redirection, or command line wild card expansion,
2339  * or a command line pipe mechanism using the '|' AND background
2340  * command execution '&'.  All of these capabilities are provided to any
2341  * C program which calls this procedure as the first thing in the
2342  * main program.
2343  * The piping mechanism will probably work with almost any 'filter' type
2344  * of program.  With suitable modification, it may useful for other
2345  * portability problems as well.
2346  *
2347  * Author:  Mark Pizzolato      mark@infocomm.com
2348  */
2349 struct list_item
2350     {
2351     struct list_item *next;
2352     char *value;
2353     };
2354
2355 static void add_item(struct list_item **head,
2356                      struct list_item **tail,
2357                      char *value,
2358                      int *count);
2359
2360 static void mp_expand_wild_cards(pTHX_ char *item,
2361                                 struct list_item **head,
2362                                 struct list_item **tail,
2363                                 int *count);
2364
2365 static int background_process(int argc, char **argv);
2366
2367 static void pipe_and_fork(char **cmargv);
2368
2369 /*{{{ void getredirection(int *ac, char ***av)*/
2370 static void
2371 mp_getredirection(pTHX_ int *ac, char ***av)
2372 /*
2373  * Process vms redirection arg's.  Exit if any error is seen.
2374  * If getredirection() processes an argument, it is erased
2375  * from the vector.  getredirection() returns a new argc and argv value.
2376  * In the event that a background command is requested (by a trailing "&"),
2377  * this routine creates a background subprocess, and simply exits the program.
2378  *
2379  * Warning: do not try to simplify the code for vms.  The code
2380  * presupposes that getredirection() is called before any data is
2381  * read from stdin or written to stdout.
2382  *
2383  * Normal usage is as follows:
2384  *
2385  *      main(argc, argv)
2386  *      int             argc;
2387  *      char            *argv[];
2388  *      {
2389  *              getredirection(&argc, &argv);
2390  *      }
2391  */
2392 {
2393     int                 argc = *ac;     /* Argument Count         */
2394     char                **argv = *av;   /* Argument Vector        */
2395     char                *ap;            /* Argument pointer       */
2396     int                 j;              /* argv[] index           */
2397     int                 item_count = 0; /* Count of Items in List */
2398     struct list_item    *list_head = 0; /* First Item in List       */
2399     struct list_item    *list_tail;     /* Last Item in List        */
2400     char                *in = NULL;     /* Input File Name          */
2401     char                *out = NULL;    /* Output File Name         */
2402     char                *outmode = "w"; /* Mode to Open Output File */
2403     char                *err = NULL;    /* Error File Name          */
2404     char                *errmode = "w"; /* Mode to Open Error File  */
2405     int                 cmargc = 0;     /* Piped Command Arg Count  */
2406     char                **cmargv = NULL;/* Piped Command Arg Vector */
2407
2408     /*
2409      * First handle the case where the last thing on the line ends with
2410      * a '&'.  This indicates the desire for the command to be run in a
2411      * subprocess, so we satisfy that desire.
2412      */
2413     ap = argv[argc-1];
2414     if (0 == strcmp("&", ap))
2415         exit(background_process(--argc, argv));
2416     if (*ap && '&' == ap[strlen(ap)-1])
2417         {
2418         ap[strlen(ap)-1] = '\0';
2419         exit(background_process(argc, argv));
2420         }
2421     /*
2422      * Now we handle the general redirection cases that involve '>', '>>',
2423      * '<', and pipes '|'.
2424      */
2425     for (j = 0; j < argc; ++j)
2426         {
2427         if (0 == strcmp("<", argv[j]))
2428             {
2429             if (j+1 >= argc)
2430                 {
2431                 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
2432                 exit(LIB$_WRONUMARG);
2433                 }
2434             in = argv[++j];
2435             continue;
2436             }
2437         if ('<' == *(ap = argv[j]))
2438             {
2439             in = 1 + ap;
2440             continue;
2441             }
2442         if (0 == strcmp(">", ap))
2443             {
2444             if (j+1 >= argc)
2445                 {
2446                 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
2447                 exit(LIB$_WRONUMARG);
2448                 }
2449             out = argv[++j];
2450             continue;
2451             }
2452         if ('>' == *ap)
2453             {
2454             if ('>' == ap[1])
2455                 {
2456                 outmode = "a";
2457                 if ('\0' == ap[2])
2458                     out = argv[++j];
2459                 else
2460                     out = 2 + ap;
2461                 }
2462             else
2463                 out = 1 + ap;
2464             if (j >= argc)
2465                 {
2466                 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
2467                 exit(LIB$_WRONUMARG);
2468                 }
2469             continue;
2470             }
2471         if (('2' == *ap) && ('>' == ap[1]))
2472             {
2473             if ('>' == ap[2])
2474                 {
2475                 errmode = "a";
2476                 if ('\0' == ap[3])
2477                     err = argv[++j];
2478                 else
2479                     err = 3 + ap;
2480                 }
2481             else
2482                 if ('\0' == ap[2])
2483                     err = argv[++j];
2484                 else
2485                     err = 2 + ap;
2486             if (j >= argc)
2487                 {
2488                 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
2489                 exit(LIB$_WRONUMARG);
2490                 }
2491             continue;
2492             }
2493         if (0 == strcmp("|", argv[j]))
2494             {
2495             if (j+1 >= argc)
2496                 {
2497                 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
2498                 exit(LIB$_WRONUMARG);
2499                 }
2500             cmargc = argc-(j+1);
2501             cmargv = &argv[j+1];
2502             argc = j;
2503             continue;
2504             }
2505         if ('|' == *(ap = argv[j]))
2506             {
2507             ++argv[j];
2508             cmargc = argc-j;
2509             cmargv = &argv[j];
2510             argc = j;
2511             continue;
2512             }
2513         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
2514         }
2515     /*
2516      * Allocate and fill in the new argument vector, Some Unix's terminate
2517      * the list with an extra null pointer.
2518      */
2519     New(1302, argv, item_count+1, char *);
2520     *av = argv;
2521     for (j = 0; j < item_count; ++j, list_head = list_head->next)
2522         argv[j] = list_head->value;
2523     *ac = item_count;
2524     if (cmargv != NULL)
2525         {
2526         if (out != NULL)
2527             {
2528             PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
2529             exit(LIB$_INVARGORD);
2530             }
2531         pipe_and_fork(cmargv);
2532         }
2533
2534     /* Check for input from a pipe (mailbox) */
2535
2536     if (in == NULL && 1 == isapipe(0))
2537         {
2538         char mbxname[L_tmpnam];
2539         long int bufsize;
2540         long int dvi_item = DVI$_DEVBUFSIZ;
2541         $DESCRIPTOR(mbxnam, "");
2542         $DESCRIPTOR(mbxdevnam, "");
2543
2544         /* Input from a pipe, reopen it in binary mode to disable       */
2545         /* carriage control processing.                                 */
2546
2547         PerlIO_getname(stdin, mbxname);
2548         mbxnam.dsc$a_pointer = mbxname;
2549         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
2550         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
2551         mbxdevnam.dsc$a_pointer = mbxname;
2552         mbxdevnam.dsc$w_length = sizeof(mbxname);
2553         dvi_item = DVI$_DEVNAM;
2554         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
2555         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
2556         set_errno(0);
2557         set_vaxc_errno(1);
2558         freopen(mbxname, "rb", stdin);
2559         if (errno != 0)
2560             {
2561             PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
2562             exit(vaxc$errno);
2563             }
2564         }
2565     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
2566         {
2567         PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
2568         exit(vaxc$errno);
2569         }
2570     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
2571         {
2572         PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
2573         exit(vaxc$errno);
2574         }
2575     if (err != NULL) {
2576         if (strcmp(err,"&1") == 0) {
2577             dup2(fileno(stdout), fileno(Perl_debug_log));
2578         } else {
2579         FILE *tmperr;
2580         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
2581             {
2582             PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
2583             exit(vaxc$errno);
2584             }
2585             fclose(tmperr);
2586             if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
2587                 {
2588                 exit(vaxc$errno);
2589                 }
2590         }
2591         }
2592 #ifdef ARGPROC_DEBUG
2593     PerlIO_printf(Perl_debug_log, "Arglist:\n");
2594     for (j = 0; j < *ac;  ++j)
2595         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
2596 #endif
2597    /* Clear errors we may have hit expanding wildcards, so they don't
2598       show up in Perl's $! later */
2599    set_errno(0); set_vaxc_errno(1);
2600 }  /* end of getredirection() */
2601 /*}}}*/
2602
2603 static void add_item(struct list_item **head,
2604                      struct list_item **tail,
2605                      char *value,
2606                      int *count)
2607 {
2608     if (*head == 0)
2609         {
2610         New(1303,*head,1,struct list_item);
2611         *tail = *head;
2612         }
2613     else {
2614         New(1304,(*tail)->next,1,struct list_item);
2615         *tail = (*tail)->next;
2616         }
2617     (*tail)->value = value;
2618     ++(*count);
2619 }
2620
2621 static void mp_expand_wild_cards(pTHX_ char *item,
2622                               struct list_item **head,
2623                               struct list_item **tail,
2624                               int *count)
2625 {
2626 int expcount = 0;
2627 unsigned long int context = 0;
2628 int isunix = 0;
2629 char *had_version;
2630 char *had_device;
2631 int had_directory;
2632 char *devdir,*cp;
2633 char vmsspec[NAM$C_MAXRSS+1];
2634 $DESCRIPTOR(filespec, "");
2635 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2636 $DESCRIPTOR(resultspec, "");
2637 unsigned long int zero = 0, sts;
2638
2639     for (cp = item; *cp; cp++) {
2640         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
2641         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
2642     }
2643     if (!*cp || isspace(*cp))
2644         {
2645         add_item(head, tail, item, count);
2646         return;
2647         }
2648     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2649     resultspec.dsc$b_class = DSC$K_CLASS_D;
2650     resultspec.dsc$a_pointer = NULL;
2651     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2652       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2653     if (!isunix || !filespec.dsc$a_pointer)
2654       filespec.dsc$a_pointer = item;
2655     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2656     /*
2657      * Only return version specs, if the caller specified a version
2658      */
2659     had_version = strchr(item, ';');
2660     /*
2661      * Only return device and directory specs, if the caller specifed either.
2662      */
2663     had_device = strchr(item, ':');
2664     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2665
2666     while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2667                                   &defaultspec, 0, 0, &zero))))
2668         {
2669         char *string;
2670         char *c;
2671
2672         New(1305,string,resultspec.dsc$w_length+1,char);
2673         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2674         string[resultspec.dsc$w_length] = '\0';
2675         if (NULL == had_version)
2676             *((char *)strrchr(string, ';')) = '\0';
2677         if ((!had_directory) && (had_device == NULL))
2678             {
2679             if (NULL == (devdir = strrchr(string, ']')))
2680                 devdir = strrchr(string, '>');
2681             strcpy(string, devdir + 1);
2682             }
2683         /*
2684          * Be consistent with what the C RTL has already done to the rest of
2685          * the argv items and lowercase all of these names.
2686          */
2687         for (c = string; *c; ++c)
2688             if (isupper(*c))
2689                 *c = tolower(*c);
2690         if (isunix) trim_unixpath(string,item,1);
2691         add_item(head, tail, string, count);
2692         ++expcount;
2693         }
2694     if (sts != RMS$_NMF)
2695         {
2696         set_vaxc_errno(sts);
2697         switch (sts)
2698             {
2699             case RMS$_FNF: case RMS$_DNF:
2700                 set_errno(ENOENT); break;
2701             case RMS$_DIR:
2702                 set_errno(ENOTDIR); break;
2703             case RMS$_DEV:
2704                 set_errno(ENODEV); break;
2705             case RMS$_FNM: case RMS$_SYN:
2706                 set_errno(EINVAL); break;
2707             case RMS$_PRV:
2708                 set_errno(EACCES); break;
2709             default:
2710                 _ckvmssts_noperl(sts);
2711             }
2712         }
2713     if (expcount == 0)
2714         add_item(head, tail, item, count);
2715     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2716     _ckvmssts_noperl(lib$find_file_end(&context));
2717 }
2718
2719 static int child_st[2];/* Event Flag set when child process completes   */
2720
2721 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
2722
2723 static unsigned long int exit_handler(int *status)
2724 {
2725 short iosb[4];
2726
2727     if (0 == child_st[0])
2728         {
2729 #ifdef ARGPROC_DEBUG
2730         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2731 #endif
2732         fflush(stdout);     /* Have to flush pipe for binary data to    */
2733                             /* terminate properly -- <tp@mccall.com>    */
2734         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2735         sys$dassgn(child_chan);
2736         fclose(stdout);
2737         sys$synch(0, child_st);
2738         }
2739     return(1);
2740 }
2741
2742 static void sig_child(int chan)
2743 {
2744 #ifdef ARGPROC_DEBUG
2745     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2746 #endif
2747     if (child_st[0] == 0)
2748         child_st[0] = 1;
2749 }
2750
2751 static struct exit_control_block exit_block =
2752     {
2753     0,
2754     exit_handler,
2755     1,
2756     &exit_block.exit_status,
2757     0
2758     };
2759
2760 static void pipe_and_fork(char **cmargv)
2761 {
2762     char subcmd[2048];
2763     $DESCRIPTOR(cmddsc, "");
2764     static char mbxname[64];
2765     $DESCRIPTOR(mbxdsc, mbxname);
2766     int pid, j;
2767     unsigned long int zero = 0, one = 1;
2768
2769     strcpy(subcmd, cmargv[0]);
2770     for (j = 1; NULL != cmargv[j]; ++j)
2771         {
2772         strcat(subcmd, " \"");
2773         strcat(subcmd, cmargv[j]);
2774         strcat(subcmd, "\"");
2775         }
2776     cmddsc.dsc$a_pointer = subcmd;
2777     cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2778
2779         create_mbx(&child_chan,&mbxdsc);
2780 #ifdef ARGPROC_DEBUG
2781     PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2782     PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2783 #endif
2784     _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2785                                0, &pid, child_st, &zero, sig_child,
2786                                &child_chan));
2787 #ifdef ARGPROC_DEBUG
2788     PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2789 #endif
2790     sys$dclexh(&exit_block);
2791     if (NULL == freopen(mbxname, "wb", stdout))
2792         {
2793         PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2794         }
2795 }
2796
2797 static int background_process(int argc, char **argv)
2798 {
2799 char command[2048] = "$";
2800 $DESCRIPTOR(value, "");
2801 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2802 static $DESCRIPTOR(null, "NLA0:");
2803 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2804 char pidstring[80];
2805 $DESCRIPTOR(pidstr, "");
2806 int pid;
2807 unsigned long int flags = 17, one = 1, retsts;
2808
2809     strcat(command, argv[0]);
2810     while (--argc)
2811         {
2812         strcat(command, " \"");
2813         strcat(command, *(++argv));
2814         strcat(command, "\"");
2815         }
2816     value.dsc$a_pointer = command;
2817     value.dsc$w_length = strlen(value.dsc$a_pointer);
2818     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2819     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2820     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2821         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2822     }
2823     else {
2824         _ckvmssts_noperl(retsts);
2825     }
2826 #ifdef ARGPROC_DEBUG
2827     PerlIO_printf(Perl_debug_log, "%s\n", command);
2828 #endif
2829     sprintf(pidstring, "%08X", pid);
2830     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2831     pidstr.dsc$a_pointer = pidstring;
2832     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2833     lib$set_symbol(&pidsymbol, &pidstr);
2834     return(SS$_NORMAL);
2835 }
2836 /*}}}*/
2837 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2838
2839
2840 /* OS-specific initialization at image activation (not thread startup) */
2841 /* Older VAXC header files lack these constants */
2842 #ifndef JPI$_RIGHTS_SIZE
2843 #  define JPI$_RIGHTS_SIZE 817
2844 #endif
2845 #ifndef KGB$M_SUBSYSTEM
2846 #  define KGB$M_SUBSYSTEM 0x8
2847 #endif
2848
2849 /*{{{void vms_image_init(int *, char ***)*/
2850 void
2851 vms_image_init(int *argcp, char ***argvp)
2852 {
2853   char eqv[LNM$C_NAMLENGTH+1] = "";
2854   unsigned int len, tabct = 8, tabidx = 0;
2855   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
2856   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
2857   unsigned short int dummy, rlen;
2858   struct dsc$descriptor_s **tabvec;
2859   dTHX;
2860   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
2861                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
2862                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
2863                                  {          0,                0,    0,      0} };
2864
2865   _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
2866   _ckvmssts(iosb[0]);
2867   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
2868     if (iprv[i]) {           /* Running image installed with privs? */
2869       _ckvmssts(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
2870       will_taint = TRUE;
2871       break;
2872     }
2873   }
2874   /* Rights identifiers might trigger tainting as well. */
2875   if (!will_taint && (rlen || rsz)) {
2876     while (rlen < rsz) {
2877       /* We didn't get all the identifiers on the first pass.  Allocate a
2878        * buffer much larger than $GETJPI wants (rsz is size in bytes that
2879        * were needed to hold all identifiers at time of last call; we'll
2880        * allocate that many unsigned long ints), and go back and get 'em.
2881        */
2882       if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
2883       jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
2884       jpilist[1].buflen = rsz * sizeof(unsigned long int);
2885       _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
2886       _ckvmssts(iosb[0]);
2887     }
2888     mask = jpilist[1].bufadr;
2889     /* Check attribute flags for each identifier (2nd longword); protected
2890      * subsystem identifiers trigger tainting.
2891      */
2892     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
2893       if (mask[i] & KGB$M_SUBSYSTEM) {
2894         will_taint = TRUE;
2895         break;
2896       }
2897     }
2898     if (mask != rlst) Safefree(mask);
2899   }
2900   /* We need to use this hack to tell Perl it should run with tainting,
2901    * since its tainting flag may be part of the PL_curinterp struct, which
2902    * hasn't been allocated when vms_image_init() is called.
2903    */
2904   if (will_taint) {
2905     char ***newap;
2906     New(1320,newap,*argcp+2,char **);
2907     newap[0] = argvp[0];
2908     *newap[1] = "-T";
2909     Copy(argvp[1],newap[2],*argcp-1,char **);
2910     /* We orphan the old argv, since we don't know where it's come from,
2911      * so we don't know how to free it.
2912      */
2913     *argcp++; argvp = newap;
2914   }
2915   else {  /* Did user explicitly request tainting? */
2916     int i;
2917     char *cp, **av = *argvp;
2918     for (i = 1; i < *argcp; i++) {
2919       if (*av[i] != '-') break;
2920       for (cp = av[i]+1; *cp; cp++) {
2921         if (*cp == 'T') { will_taint = 1; break; }
2922         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
2923                   strchr("DFIiMmx",*cp)) break;
2924       }
2925       if (will_taint) break;
2926     }
2927   }
2928
2929   for (tabidx = 0;
2930        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
2931        tabidx++) {
2932     if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
2933     else if (tabidx >= tabct) {
2934       tabct += 8;
2935       Renew(tabvec,tabct,struct dsc$descriptor_s *);
2936     }
2937     New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
2938     tabvec[tabidx]->dsc$w_length  = 0;
2939     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
2940     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
2941     tabvec[tabidx]->dsc$a_pointer = NULL;
2942     _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
2943   }
2944   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
2945
2946   getredirection(argcp,argvp);
2947 #if defined(USE_THREADS) && defined(__DECC)
2948   {
2949 # include <reentrancy.h>
2950   (void) decc$set_reentrancy(C$C_MULTITHREAD);
2951   }
2952 #endif
2953   return;
2954 }
2955 /*}}}*/
2956
2957
2958 /* trim_unixpath()
2959  * Trim Unix-style prefix off filespec, so it looks like what a shell
2960  * glob expansion would return (i.e. from specified prefix on, not
2961  * full path).  Note that returned filespec is Unix-style, regardless
2962  * of whether input filespec was VMS-style or Unix-style.
2963  *
2964  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2965  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
2966  * vector of options; at present, only bit 0 is used, and if set tells
2967  * trim unixpath to try the current default directory as a prefix when
2968  * presented with a possibly ambiguous ... wildcard.
2969  *
2970  * Returns !=0 on success, with trimmed filespec replacing contents of
2971  * fspec, and 0 on failure, with contents of fpsec unchanged.
2972  */
2973 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2974 int
2975 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
2976 {
2977   char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2978        *template, *base, *end, *cp1, *cp2;
2979   register int tmplen, reslen = 0, dirs = 0;
2980
2981   if (!wildspec || !fspec) return 0;
2982   if (strpbrk(wildspec,"]>:") != NULL) {
2983     if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2984     else template = unixwild;
2985   }
2986   else template = wildspec;
2987   if (strpbrk(fspec,"]>:") != NULL) {
2988     if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2989     else base = unixified;
2990     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2991      * check to see that final result fits into (isn't longer than) fspec */
2992     reslen = strlen(fspec);
2993   }
2994   else base = fspec;
2995
2996   /* No prefix or absolute path on wildcard, so nothing to remove */
2997   if (!*template || *template == '/') {
2998     if (base == fspec) return 1;
2999     tmplen = strlen(unixified);
3000     if (tmplen > reslen) return 0;  /* not enough space */
3001     /* Copy unixified resultant, including trailing NUL */
3002     memmove(fspec,unixified,tmplen+1);
3003     return 1;
3004   }
3005
3006   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
3007   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
3008     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
3009     for (cp1 = end ;cp1 >= base; cp1--)
3010       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
3011         { cp1++; break; }
3012     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
3013     return 1;
3014   }
3015   else {
3016     char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
3017     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
3018     int ells = 1, totells, segdirs, match;
3019     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
3020                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3021
3022     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
3023     totells = ells;
3024     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
3025     if (ellipsis == template && opts & 1) {
3026       /* Template begins with an ellipsis.  Since we can't tell how many
3027        * directory names at the front of the resultant to keep for an
3028        * arbitrary starting point, we arbitrarily choose the current
3029        * default directory as a starting point.  If it's there as a prefix,
3030        * clip it off.  If not, fall through and act as if the leading
3031        * ellipsis weren't there (i.e. return shortest possible path that
3032        * could match template).
3033        */
3034       if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
3035       for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
3036         if (_tolower(*cp1) != _tolower(*cp2)) break;
3037       segdirs = dirs - totells;  /* Min # of dirs we must have left */
3038       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
3039       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
3040         memcpy(fspec,cp2+1,end - cp2);
3041         return 1;
3042       }
3043     }
3044     /* First off, back up over constant elements at end of path */
3045     if (dirs) {
3046       for (front = end ; front >= base; front--)
3047          if (*front == '/' && !dirs--) { front++; break; }
3048     }
3049     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
3050          cp1++,cp2++) *cp2 = _tolower(*cp1);  /* Make lc copy for match */
3051     if (cp1 != '\0') return 0;  /* Path too long. */
3052     lcend = cp2;
3053     *cp2 = '\0';  /* Pick up with memcpy later */
3054     lcfront = lcres + (front - base);
3055     /* Now skip over each ellipsis and try to match the path in front of it. */
3056     while (ells--) {
3057       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
3058         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
3059             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
3060       if (cp1 < template) break; /* template started with an ellipsis */
3061       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
3062         ellipsis = cp1; continue;
3063       }
3064       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
3065       nextell = cp1;
3066       for (segdirs = 0, cp2 = tpl;
3067            cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
3068            cp1++, cp2++) {
3069          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
3070          else *cp2 = _tolower(*cp1);  /* else lowercase for match */
3071          if (*cp2 == '/') segdirs++;
3072       }
3073       if (cp1 != ellipsis - 1) return 0; /* Path too long */
3074       /* Back up at least as many dirs as in template before matching */
3075       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
3076         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
3077       for (match = 0; cp1 > lcres;) {
3078         resdsc.dsc$a_pointer = cp1;
3079         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
3080           match++;
3081           if (match == 1) lcfront = cp1;
3082         }
3083         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
3084       }
3085       if (!match) return 0;  /* Can't find prefix ??? */
3086       if (match > 1 && opts & 1) {
3087         /* This ... wildcard could cover more than one set of dirs (i.e.
3088          * a set of similar dir names is repeated).  If the template
3089          * contains more than 1 ..., upstream elements could resolve the
3090          * ambiguity, but it's not worth a full backtracking setup here.
3091          * As a quick heuristic, clip off the current default directory
3092          * if it's present to find the trimmed spec, else use the
3093          * shortest string that this ... could cover.
3094          */
3095         char def[NAM$C_MAXRSS+1], *st;
3096
3097         if (getcwd(def, sizeof def,0) == NULL) return 0;
3098         for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
3099           if (_tolower(*cp1) != _tolower(*cp2)) break;
3100         segdirs = dirs - totells;  /* Min # of dirs we must have left */
3101         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
3102         if (*cp1 == '\0' && *cp2 == '/') {
3103           memcpy(fspec,cp2+1,end - cp2);
3104           return 1;
3105         }
3106         /* Nope -- stick with lcfront from above and keep going. */
3107       }
3108     }
3109     memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
3110     return 1;
3111     ellipsis = nextell;
3112   }
3113
3114 }  /* end of trim_unixpath() */
3115 /*}}}*/
3116
3117
3118 /*
3119  *  VMS readdir() routines.
3120  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
3121  *
3122  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
3123  *  Minor modifications to original routines.
3124  */
3125
3126     /* Number of elements in vms_versions array */
3127 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
3128
3129 /*
3130  *  Open a directory, return a handle for later use.
3131  */
3132 /*{{{ DIR *opendir(char*name) */
3133 DIR *
3134 Perl_opendir(pTHX_ char *name)
3135 {
3136     DIR *dd;
3137     char dir[NAM$C_MAXRSS+1];
3138     Stat_t sb;
3139
3140     if (do_tovmspath(name,dir,0) == NULL) {
3141       return NULL;
3142     }
3143     if (flex_stat(dir,&sb) == -1) return NULL;
3144     if (!S_ISDIR(sb.st_mode)) {
3145       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
3146       return NULL;
3147     }
3148     if (!cando_by_name(S_IRUSR,0,dir)) {
3149       set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
3150       return NULL;
3151     }
3152     /* Get memory for the handle, and the pattern. */
3153     New(1306,dd,1,DIR);
3154     New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
3155
3156     /* Fill in the fields; mainly playing with the descriptor. */
3157     (void)sprintf(dd->pattern, "%s*.*",dir);
3158     dd->context = 0;
3159     dd->count = 0;
3160     dd->vms_wantversions = 0;
3161     dd->pat.dsc$a_pointer = dd->pattern;
3162     dd->pat.dsc$w_length = strlen(dd->pattern);
3163     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
3164     dd->pat.dsc$b_class = DSC$K_CLASS_S;
3165
3166     return dd;
3167 }  /* end of opendir() */
3168 /*}}}*/
3169
3170 /*
3171  *  Set the flag to indicate we want versions or not.
3172  */
3173 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
3174 void
3175 vmsreaddirversions(DIR *dd, int flag)
3176 {
3177     dd->vms_wantversions = flag;
3178 }
3179 /*}}}*/
3180
3181 /*
3182  *  Free up an opened directory.
3183  */
3184 /*{{{ void closedir(DIR *dd)*/
3185 void
3186 closedir(DIR *dd)
3187 {
3188     (void)lib$find_file_end(&dd->context);
3189     Safefree(dd->pattern);
3190     Safefree((char *)dd);
3191 }
3192 /*}}}*/
3193
3194 /*
3195  *  Collect all the version numbers for the current file.
3196  */
3197 static void
3198 collectversions(dd)
3199     DIR *dd;
3200 {
3201     struct dsc$descriptor_s     pat;
3202     struct dsc$descriptor_s     res;
3203     struct dirent *e;
3204     char *p, *text, buff[sizeof dd->entry.d_name];
3205     int i;
3206     unsigned long context, tmpsts;
3207     dTHX;
3208
3209     /* Convenient shorthand. */
3210     e = &dd->entry;
3211
3212     /* Add the version wildcard, ignoring the "*.*" put on before */
3213     i = strlen(dd->pattern);
3214     New(1308,text,i + e->d_namlen + 3,char);
3215     (void)strcpy(text, dd->pattern);
3216     (void)sprintf(&text[i - 3], "%s;*", e->d_name);
3217
3218     /* Set up the pattern descriptor. */
3219     pat.dsc$a_pointer = text;
3220     pat.dsc$w_length = i + e->d_namlen - 1;
3221     pat.dsc$b_dtype = DSC$K_DTYPE_T;
3222     pat.dsc$b_class = DSC$K_CLASS_S;
3223
3224     /* Set up result descriptor. */
3225     res.dsc$a_pointer = buff;
3226     res.dsc$w_length = sizeof buff - 2;
3227     res.dsc$b_dtype = DSC$K_DTYPE_T;
3228     res.dsc$b_class = DSC$K_CLASS_S;
3229
3230     /* Read files, collecting versions. */
3231     for (context = 0, e->vms_verscount = 0;
3232          e->vms_verscount < VERSIZE(e);
3233          e->vms_verscount++) {
3234         tmpsts = lib$find_file(&pat, &res, &context);
3235         if (tmpsts == RMS$_NMF || context == 0) break;
3236         _ckvmssts(tmpsts);
3237         buff[sizeof buff - 1] = '\0';
3238         if ((p = strchr(buff, ';')))
3239             e->vms_versions[e->vms_verscount] = atoi(p + 1);
3240         else
3241             e->vms_versions[e->vms_verscount] = -1;
3242     }
3243
3244     _ckvmssts(lib$find_file_end(&context));
3245     Safefree(text);
3246
3247 }  /* end of collectversions() */
3248
3249 /*
3250  *  Read the next entry from the directory.
3251  */
3252 /*{{{ struct dirent *readdir(DIR *dd)*/
3253 struct dirent *
3254 readdir(DIR *dd)
3255 {
3256     struct dsc$descriptor_s     res;
3257     char *p, buff[sizeof dd->entry.d_name];
3258     unsigned long int tmpsts;
3259
3260     /* Set up result descriptor, and get next file. */
3261     res.dsc$a_pointer = buff;
3262     res.dsc$w_length = sizeof buff - 2;
3263     res.dsc$b_dtype = DSC$K_DTYPE_T;
3264     res.dsc$b_class = DSC$K_CLASS_S;
3265     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
3266     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
3267     if (!(tmpsts & 1)) {
3268       set_vaxc_errno(tmpsts);
3269       switch (tmpsts) {
3270         case RMS$_PRV:
3271           set_errno(EACCES); break;
3272         case RMS$_DEV:
3273           set_errno(ENODEV); break;
3274         case RMS$_DIR:
3275           set_errno(ENOTDIR); break;
3276         case RMS$_FNF: case RMS$_DNF:
3277           set_errno(ENOENT); break;
3278         default:
3279           set_errno(EVMSERR);
3280       }
3281       return NULL;
3282     }
3283     dd->count++;
3284     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
3285     buff[sizeof buff - 1] = '\0';
3286     for (p = buff; *p; p++) *p = _tolower(*p);
3287     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
3288     *p = '\0';
3289
3290     /* Skip any directory component and just copy the name. */
3291     if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
3292     else (void)strcpy(dd->entry.d_name, buff);
3293
3294     /* Clobber the version. */
3295     if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
3296
3297     dd->entry.d_namlen = strlen(dd->entry.d_name);
3298     dd->entry.vms_verscount = 0;
3299     if (dd->vms_wantversions) collectversions(dd);
3300     return &dd->entry;
3301
3302 }  /* end of readdir() */
3303 /*}}}*/
3304
3305 /*
3306  *  Return something that can be used in a seekdir later.
3307  */
3308 /*{{{ long telldir(DIR *dd)*/
3309 long
3310 telldir(DIR *dd)
3311 {
3312     return dd->count;
3313 }
3314 /*}}}*/
3315
3316 /*
3317  *  Return to a spot where we used to be.  Brute force.
3318  */
3319 /*{{{ void seekdir(DIR *dd,long count)*/
3320 void
3321 seekdir(DIR *dd, long count)
3322 {
3323     int vms_wantversions;
3324     dTHX;
3325
3326     /* If we haven't done anything yet... */
3327     if (dd->count == 0)
3328         return;
3329
3330     /* Remember some state, and clear it. */
3331     vms_wantversions = dd->vms_wantversions;
3332     dd->vms_wantversions = 0;
3333     _ckvmssts(lib$find_file_end(&dd->context));
3334     dd->context = 0;
3335
3336     /* The increment is in readdir(). */
3337     for (dd->count = 0; dd->count < count; )
3338         (void)readdir(dd);
3339
3340     dd->vms_wantversions = vms_wantversions;
3341
3342 }  /* end of seekdir() */
3343 /*}}}*/
3344
3345 /* VMS subprocess management
3346  *
3347  * my_vfork() - just a vfork(), after setting a flag to record that
3348  * the current script is trying a Unix-style fork/exec.
3349  *
3350  * vms_do_aexec() and vms_do_exec() are called in response to the
3351  * perl 'exec' function.  If this follows a vfork call, then they
3352  * call out the the regular perl routines in doio.c which do an
3353  * execvp (for those who really want to try this under VMS).
3354  * Otherwise, they do exactly what the perl docs say exec should
3355  * do - terminate the current script and invoke a new command
3356  * (See below for notes on command syntax.)
3357  *
3358  * do_aspawn() and do_spawn() implement the VMS side of the perl
3359  * 'system' function.
3360  *
3361  * Note on command arguments to perl 'exec' and 'system': When handled
3362  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
3363  * are concatenated to form a DCL command string.  If the first arg
3364  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
3365  * the the command string is handed off to DCL directly.  Otherwise,
3366  * the first token of the command is taken as the filespec of an image
3367  * to run.  The filespec is expanded using a default type of '.EXE' and
3368  * the process defaults for device, directory, etc., and if found, the resultant
3369  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3370  * the command string as parameters.  This is perhaps a bit complicated,
3371  * but I hope it will form a happy medium between what VMS folks expect
3372  * from lib$spawn and what Unix folks expect from exec.
3373  */
3374
3375 static int vfork_called;
3376
3377 /*{{{int my_vfork()*/
3378 int
3379 my_vfork()
3380 {
3381   vfork_called++;
3382   return vfork();
3383 }
3384 /*}}}*/
3385
3386
3387 static void
3388 vms_execfree(pTHX) {
3389   if (PL_Cmd) {
3390     if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
3391     PL_Cmd = Nullch;
3392   }
3393   if (VMScmd.dsc$a_pointer) {
3394     Safefree(VMScmd.dsc$a_pointer);
3395     VMScmd.dsc$w_length = 0;
3396     VMScmd.dsc$a_pointer = Nullch;
3397   }
3398 }
3399
3400 static char *
3401 setup_argstr(SV *really, SV **mark, SV **sp)
3402 {
3403   dTHX;
3404   char *junk, *tmps = Nullch;
3405   register size_t cmdlen = 0;
3406   size_t rlen;
3407   register SV **idx;
3408   STRLEN n_a;
3409
3410   idx = mark;
3411   if (really) {
3412     tmps = SvPV(really,rlen);
3413     if (*tmps) {
3414       cmdlen += rlen + 1;
3415       idx++;
3416     }
3417   }
3418
3419   for (idx++; idx <= sp; idx++) {
3420     if (*idx) {
3421       junk = SvPVx(*idx,rlen);
3422       cmdlen += rlen ? rlen + 1 : 0;
3423     }
3424   }
3425   New(401,PL_Cmd,cmdlen+1,char);
3426
3427   if (tmps && *tmps) {
3428     strcpy(PL_Cmd,tmps);
3429     mark++;
3430   }
3431   else *PL_Cmd = '\0';
3432   while (++mark <= sp) {
3433     if (*mark) {
3434       char *s = SvPVx(*mark,n_a);
3435       if (!*s) continue;
3436       if (*PL_Cmd) strcat(PL_Cmd," ");
3437       strcat(PL_Cmd,s);
3438     }
3439   }
3440   return PL_Cmd;
3441
3442 }  /* end of setup_argstr() */
3443
3444
3445 static unsigned long int
3446 setup_cmddsc(char *cmd, int check_img)
3447 {
3448   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
3449   $DESCRIPTOR(defdsc,".EXE");
3450   $DESCRIPTOR(defdsc2,".");
3451   $DESCRIPTOR(resdsc,resspec);
3452   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3453   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
3454   register char *s, *rest, *cp, *wordbreak;
3455   register int isdcl;
3456   dTHX;
3457
3458   if (strlen(cmd) >
3459       (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
3460     return LIB$_INVARG;
3461   s = cmd;
3462   while (*s && isspace(*s)) s++;
3463
3464   if (*s == '@' || *s == '$') {
3465     vmsspec[0] = *s;  rest = s + 1;
3466     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
3467   }
3468   else { cp = vmsspec; rest = s; }
3469   if (*rest == '.' || *rest == '/') {
3470     char *cp2;
3471     for (cp2 = resspec;
3472          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
3473          rest++, cp2++) *cp2 = *rest;
3474     *cp2 = '\0';
3475     if (do_tovmsspec(resspec,cp,0)) {
3476       s = vmsspec;
3477       if (*rest) {
3478         for (cp2 = vmsspec + strlen(vmsspec);
3479              *rest && cp2 - vmsspec < sizeof vmsspec;
3480              rest++, cp2++) *cp2 = *rest;
3481         *cp2 = '\0';
3482       }
3483     }
3484   }
3485   /* Intuit whether verb (first word of cmd) is a DCL command:
3486    *   - if first nonspace char is '@', it's a DCL indirection
3487    * otherwise
3488    *   - if verb contains a filespec separator, it's not a DCL command
3489    *   - if it doesn't, caller tells us whether to default to a DCL
3490    *     command, or to a local image unless told it's DCL (by leading '$')
3491    */
3492   if (*s == '@') isdcl = 1;
3493   else {
3494     register char *filespec = strpbrk(s,":<[.;");
3495     rest = wordbreak = strpbrk(s," \"\t/");
3496     if (!wordbreak) wordbreak = s + strlen(s);
3497     if (*s == '$') check_img = 0;
3498     if (filespec && (filespec < wordbreak)) isdcl = 0;
3499     else isdcl = !check_img;
3500   }
3501
3502   if (!isdcl) {
3503     imgdsc.dsc$a_pointer = s;
3504     imgdsc.dsc$w_length = wordbreak - s;
3505     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3506     if (!(retsts&1)) {
3507         _ckvmssts(lib$find_file_end(&cxt));
3508         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
3509     if (!(retsts & 1) && *s == '$') {
3510           _ckvmssts(lib$find_file_end(&cxt));
3511       imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
3512       retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3513           if (!(retsts&1)) {
3514       _ckvmssts(lib$find_file_end(&cxt));
3515             retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
3516           }
3517     }
3518     }
3519     _ckvmssts(lib$find_file_end(&cxt));
3520
3521     if (retsts & 1) {
3522       FILE *fp;
3523       s = resspec;
3524       while (*s && !isspace(*s)) s++;
3525       *s = '\0';
3526
3527       /* check that it's really not DCL with no file extension */
3528       fp = fopen(resspec,"r","ctx=bin,shr=get");
3529       if (fp) {
3530         char b[4] = {0,0,0,0};
3531         read(fileno(fp),b,4);
3532         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
3533         fclose(fp);
3534       }
3535       if (check_img && isdcl) return RMS$_FNF;
3536
3537       if (cando_by_name(S_IXUSR,0,resspec)) {
3538         New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
3539         if (!isdcl) {
3540         strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
3541         } else {
3542             strcpy(VMScmd.dsc$a_pointer,"@");
3543         }
3544         strcat(VMScmd.dsc$a_pointer,resspec);
3545         if (rest) strcat(VMScmd.dsc$a_pointer,rest);
3546         VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
3547         return retsts;
3548       }
3549       else retsts = RMS$_PRV;
3550     }
3551   }
3552   /* It's either a DCL command or we couldn't find a suitable image */
3553   VMScmd.dsc$w_length = strlen(cmd);
3554   if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
3555   else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
3556   if (!(retsts & 1)) {
3557     /* just hand off status values likely to be due to user error */
3558     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
3559         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
3560        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
3561     else { _ckvmssts(retsts); }
3562   }
3563
3564   return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
3565
3566 }  /* end of setup_cmddsc() */
3567
3568
3569 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
3570 bool
3571 vms_do_aexec(SV *really,SV **mark,SV **sp)
3572 {
3573   dTHX;
3574   if (sp > mark) {
3575     if (vfork_called) {           /* this follows a vfork - act Unixish */
3576       vfork_called--;
3577       if (vfork_called < 0) {
3578         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3579         vfork_called = 0;
3580       }
3581       else return do_aexec(really,mark,sp);
3582     }
3583                                            /* no vfork - act VMSish */
3584     return vms_do_exec(setup_argstr(really,mark,sp));
3585
3586   }
3587
3588   return FALSE;
3589 }  /* end of vms_do_aexec() */
3590 /*}}}*/
3591
3592 /* {{{bool vms_do_exec(char *cmd) */
3593 bool
3594 vms_do_exec(char *cmd)
3595 {
3596
3597   dTHX;
3598   if (vfork_called) {             /* this follows a vfork - act Unixish */
3599     vfork_called--;
3600     if (vfork_called < 0) {
3601       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3602       vfork_called = 0;
3603     }
3604     else return do_exec(cmd);
3605   }
3606
3607   {                               /* no vfork - act VMSish */
3608     unsigned long int retsts;
3609
3610     TAINT_ENV();
3611     TAINT_PROPER("exec");
3612     if ((retsts = setup_cmddsc(cmd,1)) & 1)
3613       retsts = lib$do_command(&VMScmd);
3614
3615     switch (retsts) {
3616       case RMS$_FNF: case RMS$_DNF:
3617         set_errno(ENOENT); break;
3618       case RMS$_DIR:
3619         set_errno(ENOTDIR); break;
3620       case RMS$_DEV:
3621         set_errno(ENODEV); break;
3622       case RMS$_PRV:
3623         set_errno(EACCES); break;
3624       case RMS$_SYN:
3625         set_errno(EINVAL); break;
3626       case CLI$_BUFOVF:
3627         set_errno(E2BIG); break;
3628       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3629         _ckvmssts(retsts); /* fall through */
3630       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3631         set_errno(EVMSERR);
3632     }
3633     set_vaxc_errno(retsts);
3634     if (ckWARN(WARN_EXEC)) {
3635       Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
3636              VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
3637     }
3638     vms_execfree(aTHX);
3639   }
3640
3641   return FALSE;
3642
3643 }  /* end of vms_do_exec() */
3644 /*}}}*/
3645
3646 unsigned long int do_spawn(char *);
3647
3648 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
3649 unsigned long int
3650 do_aspawn(void *really,void **mark,void **sp)
3651 {
3652   dTHX;
3653   if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
3654
3655   return SS$_ABORT;
3656 }  /* end of do_aspawn() */
3657 /*}}}*/
3658
3659 /* {{{unsigned long int do_spawn(char *cmd) */
3660 unsigned long int
3661 do_spawn(char *cmd)
3662 {
3663   unsigned long int sts, substs, hadcmd = 1;
3664   dTHX;
3665
3666   TAINT_ENV();
3667   TAINT_PROPER("spawn");
3668   if (!cmd || !*cmd) {
3669     hadcmd = 0;
3670     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
3671   }
3672   else if ((sts = setup_cmddsc(cmd,0)) & 1) {
3673     sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
3674   }
3675
3676   if (!(sts & 1)) {
3677     switch (sts) {
3678       case RMS$_FNF:  case RMS$_DNF:
3679         set_errno(ENOENT); break;
3680       case RMS$_DIR:
3681         set_errno(ENOTDIR); break;
3682       case RMS$_DEV:
3683         set_errno(ENODEV); break;
3684       case RMS$_PRV:
3685         set_errno(EACCES); break;
3686       case RMS$_SYN:
3687         set_errno(EINVAL); break;
3688       case CLI$_BUFOVF:
3689         set_errno(E2BIG); break;
3690       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3691         _ckvmssts(sts); /* fall through */
3692       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3693         set_errno(EVMSERR);
3694     }
3695     set_vaxc_errno(sts);
3696     if (ckWARN(WARN_EXEC)) {
3697       Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
3698              hadcmd ? VMScmd.dsc$w_length :  0,
3699              hadcmd ? VMScmd.dsc$a_pointer : "",
3700              Strerror(errno));
3701     }
3702   }
3703   vms_execfree(aTHX);
3704   return substs;
3705
3706 }  /* end of do_spawn() */
3707 /*}}}*/
3708
3709 /*
3710  * A simple fwrite replacement which outputs itmsz*nitm chars without
3711  * introducing record boundaries every itmsz chars.
3712  */
3713 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
3714 int
3715 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
3716 {
3717   register char *cp, *end;
3718
3719   end = (char *)src + itmsz * nitm;
3720
3721   while ((char *)src <= end) {
3722     for (cp = src; cp <= end; cp++) if (!*cp) break;
3723     if (fputs(src,dest) == EOF) return EOF;
3724     if (cp < end)
3725       if (fputc('\0',dest) == EOF) return EOF;
3726     src = cp + 1;
3727   }
3728
3729   return 1;
3730
3731 }  /* end of my_fwrite() */
3732 /*}}}*/
3733
3734 /*{{{ int my_flush(FILE *fp)*/
3735 int
3736 my_flush(FILE *fp)
3737 {
3738     int res;
3739     if ((res = fflush(fp)) == 0 && fp) {
3740 #ifdef VMS_DO_SOCKETS
3741         Stat_t s;
3742         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
3743 #endif
3744             res = fsync(fileno(fp));
3745     }
3746     return res;
3747 }
3748 /*}}}*/
3749
3750 /*
3751  * Here are replacements for the following Unix routines in the VMS environment:
3752  *      getpwuid    Get information for a particular UIC or UID
3753  *      getpwnam    Get information for a named user
3754  *      getpwent    Get information for each user in the rights database
3755  *      setpwent    Reset search to the start of the rights database
3756  *      endpwent    Finish searching for users in the rights database
3757  *
3758  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
3759  * (defined in pwd.h), which contains the following fields:-
3760  *      struct passwd {
3761  *              char        *pw_name;    Username (in lower case)
3762  *              char        *pw_passwd;  Hashed password
3763  *              unsigned int pw_uid;     UIC
3764  *              unsigned int pw_gid;     UIC group  number
3765  *              char        *pw_unixdir; Default device/directory (VMS-style)
3766  *              char        *pw_gecos;   Owner name
3767  *              char        *pw_dir;     Default device/directory (Unix-style)
3768  *              char        *pw_shell;   Default CLI name (eg. DCL)
3769  *      };
3770  * If the specified user does not exist, getpwuid and getpwnam return NULL.
3771  *
3772  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
3773  * not the UIC member number (eg. what's returned by getuid()),
3774  * getpwuid() can accept either as input (if uid is specified, the caller's
3775  * UIC group is used), though it won't recognise gid=0.
3776  *
3777  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
3778  * information about other users in your group or in other groups, respectively.
3779  * If the required privilege is not available, then these routines fill only
3780  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
3781  * string).
3782  *
3783  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
3784  */
3785
3786 /* sizes of various UAF record fields */
3787 #define UAI$S_USERNAME 12
3788 #define UAI$S_IDENT    31
3789 #define UAI$S_OWNER    31
3790 #define UAI$S_DEFDEV   31
3791 #define UAI$S_DEFDIR   63
3792 #define UAI$S_DEFCLI   31
3793 #define UAI$S_PWD       8
3794
3795 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
3796                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
3797                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
3798
3799 static char __empty[]= "";
3800 static struct passwd __passwd_empty=
3801     {(char *) __empty, (char *) __empty, 0, 0,
3802      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
3803 static int contxt= 0;
3804 static struct passwd __pwdcache;
3805 static char __pw_namecache[UAI$S_IDENT+1];
3806
3807 /*
3808  * This routine does most of the work extracting the user information.
3809  */
3810 static int fillpasswd (const char *name, struct passwd *pwd)
3811 {
3812     dTHX;
3813     static struct {
3814         unsigned char length;
3815         char pw_gecos[UAI$S_OWNER+1];
3816     } owner;
3817     static union uicdef uic;
3818     static struct {
3819         unsigned char length;
3820         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3821     } defdev;
3822     static struct {
3823         unsigned char length;
3824         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3825     } defdir;
3826     static struct {
3827         unsigned char length;
3828         char pw_shell[UAI$S_DEFCLI+1];
3829     } defcli;
3830     static char pw_passwd[UAI$S_PWD+1];
3831
3832     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3833     struct dsc$descriptor_s name_desc;
3834     unsigned long int sts;
3835
3836     static struct itmlst_3 itmlst[]= {
3837         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
3838         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
3839         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
3840         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
3841         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
3842         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
3843         {0,                0,           NULL,    NULL}};
3844
3845     name_desc.dsc$w_length=  strlen(name);
3846     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
3847     name_desc.dsc$b_class=   DSC$K_CLASS_S;
3848     name_desc.dsc$a_pointer= (char *) name;
3849
3850 /*  Note that sys$getuai returns many fields as counted strings. */
3851     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3852     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3853       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3854     }
3855     else { _ckvmssts(sts); }
3856     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
3857
3858     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
3859     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3860     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3861     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3862     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3863     owner.pw_gecos[lowner]=            '\0';
3864     defdev.pw_dir[ldefdev+ldefdir]= '\0';
3865     defcli.pw_shell[ldefcli]=          '\0';
3866     if (valid_uic(uic)) {
3867         pwd->pw_uid= uic.uic$l_uic;
3868         pwd->pw_gid= uic.uic$v_group;
3869     }
3870     else
3871       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
3872     pwd->pw_passwd=  pw_passwd;
3873     pwd->pw_gecos=   owner.pw_gecos;
3874     pwd->pw_dir=     defdev.pw_dir;
3875     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3876     pwd->pw_shell=   defcli.pw_shell;
3877     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3878         int ldir;
3879         ldir= strlen(pwd->pw_unixdir) - 1;
3880         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3881     }
3882     else
3883         strcpy(pwd->pw_unixdir, pwd->pw_dir);
3884     __mystrtolower(pwd->pw_unixdir);
3885     return 1;
3886 }
3887
3888 /*
3889  * Get information for a named user.
3890 */
3891 /*{{{struct passwd *getpwnam(char *name)*/
3892 struct passwd *my_getpwnam(char *name)
3893 {
3894     struct dsc$descriptor_s name_desc;
3895     union uicdef uic;
3896     unsigned long int status, sts;
3897     dTHX;
3898
3899     __pwdcache = __passwd_empty;
3900     if (!fillpasswd(name, &__pwdcache)) {
3901       /* We still may be able to determine pw_uid and pw_gid */
3902       name_desc.dsc$w_length=  strlen(name);
3903       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
3904       name_desc.dsc$b_class=   DSC$K_CLASS_S;
3905       name_desc.dsc$a_pointer= (char *) name;
3906       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3907         __pwdcache.pw_uid= uic.uic$l_uic;
3908         __pwdcache.pw_gid= uic.uic$v_group;
3909       }
3910       else {
3911         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3912           set_vaxc_errno(sts);
3913           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3914           return NULL;
3915         }
3916         else { _ckvmssts(sts); }
3917       }
3918     }
3919     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3920     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3921     __pwdcache.pw_name= __pw_namecache;
3922     return &__pwdcache;
3923 }  /* end of my_getpwnam() */
3924 /*}}}*/
3925
3926 /*
3927  * Get information for a particular UIC or UID.
3928  * Called by my_getpwent with uid=-1 to list all users.
3929 */
3930 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3931 struct passwd *my_getpwuid(Uid_t uid)
3932 {
3933     const $DESCRIPTOR(name_desc,__pw_namecache);
3934     unsigned short lname;
3935     union uicdef uic;
3936     unsigned long int status;
3937     dTHX;
3938
3939     if (uid == (unsigned int) -1) {
3940       do {
3941         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3942         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3943           set_vaxc_errno(status);
3944           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3945           my_endpwent();
3946           return NULL;
3947         }
3948         else { _ckvmssts(status); }
3949       } while (!valid_uic (uic));
3950     }
3951     else {
3952       uic.uic$l_uic= uid;
3953       if (!uic.uic$v_group)
3954         uic.uic$v_group= PerlProc_getgid();
3955       if (valid_uic(uic))
3956         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3957       else status = SS$_IVIDENT;
3958       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3959           status == RMS$_PRV) {
3960         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3961         return NULL;
3962       }
3963       else { _ckvmssts(status); }
3964     }
3965     __pw_namecache[lname]= '\0';
3966     __mystrtolower(__pw_namecache);
3967
3968     __pwdcache = __passwd_empty;
3969     __pwdcache.pw_name = __pw_namecache;
3970
3971 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3972     The identifier's value is usually the UIC, but it doesn't have to be,
3973     so if we can, we let fillpasswd update this. */
3974     __pwdcache.pw_uid =  uic.uic$l_uic;
3975     __pwdcache.pw_gid =  uic.uic$v_group;
3976
3977     fillpasswd(__pw_namecache, &__pwdcache);
3978     return &__pwdcache;
3979
3980 }  /* end of my_getpwuid() */
3981 /*}}}*/
3982
3983 /*
3984  * Get information for next user.
3985 */
3986 /*{{{struct passwd *my_getpwent()*/
3987 struct passwd *my_getpwent()
3988 {
3989     return (my_getpwuid((unsigned int) -1));
3990 }
3991 /*}}}*/
3992
3993 /*
3994  * Finish searching rights database for users.
3995 */
3996 /*{{{void my_endpwent()*/
3997 void my_endpwent()
3998 {
3999     dTHX;
4000     if (contxt) {
4001       _ckvmssts(sys$finish_rdb(&contxt));
4002       contxt= 0;
4003     }
4004 }
4005 /*}}}*/
4006
4007 #ifdef HOMEGROWN_POSIX_SIGNALS
4008   /* Signal handling routines, pulled into the core from POSIX.xs.
4009    *
4010    * We need these for threads, so they've been rolled into the core,
4011    * rather than left in POSIX.xs.
4012    *
4013    * (DRS, Oct 23, 1997)
4014    */
4015
4016   /* sigset_t is atomic under VMS, so these routines are easy */
4017 /*{{{int my_sigemptyset(sigset_t *) */
4018 int my_sigemptyset(sigset_t *set) {
4019     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4020     *set = 0; return 0;
4021 }
4022 /*}}}*/
4023
4024
4025 /*{{{int my_sigfillset(sigset_t *)*/
4026 int my_sigfillset(sigset_t *set) {
4027     int i;
4028     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4029     for (i = 0; i < NSIG; i++) *set |= (1 << i);
4030     return 0;
4031 }
4032 /*}}}*/
4033
4034
4035 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
4036 int my_sigaddset(sigset_t *set, int sig) {
4037     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4038     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
4039     *set |= (1 << (sig - 1));
4040     return 0;
4041 }
4042 /*}}}*/
4043
4044
4045 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
4046 int my_sigdelset(sigset_t *set, int sig) {
4047     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4048     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
4049     *set &= ~(1 << (sig - 1));
4050     return 0;
4051 }
4052 /*}}}*/
4053
4054
4055 /*{{{int my_sigismember(sigset_t *set, int sig)*/
4056 int my_sigismember(sigset_t *set, int sig) {
4057     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4058     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
4059     *set & (1 << (sig - 1));
4060 }
4061 /*}}}*/
4062
4063
4064 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
4065 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
4066     sigset_t tempmask;
4067
4068     /* If set and oset are both null, then things are badly wrong. Bail out. */
4069     if ((oset == NULL) && (set == NULL)) {
4070       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
4071       return -1;
4072     }
4073
4074     /* If set's null, then we're just handling a fetch. */
4075     if (set == NULL) {
4076         tempmask = sigblock(0);
4077     }
4078     else {
4079       switch (how) {
4080       case SIG_SETMASK:
4081         tempmask = sigsetmask(*set);
4082         break;
4083       case SIG_BLOCK:
4084         tempmask = sigblock(*set);
4085         break;
4086       case SIG_UNBLOCK:
4087         tempmask = sigblock(0);
4088         sigsetmask(*oset & ~tempmask);
4089         break;
4090       default:
4091         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4092         return -1;
4093       }
4094     }
4095
4096     /* Did they pass us an oset? If so, stick our holding mask into it */
4097     if (oset)
4098       *oset = tempmask;
4099
4100     return 0;
4101 }
4102 /*}}}*/
4103 #endif  /* HOMEGROWN_POSIX_SIGNALS */
4104
4105
4106 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
4107  * my_utime(), and flex_stat(), all of which operate on UTC unless
4108  * VMSISH_TIMES is true.
4109  */
4110 /* method used to handle UTC conversions:
4111  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
4112  */
4113 static int gmtime_emulation_type;
4114 /* number of secs to add to UTC POSIX-style time to get local time */
4115 static long int utc_offset_secs;
4116
4117 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
4118  * in vmsish.h.  #undef them here so we can call the CRTL routines
4119  * directly.
4120  */
4121 #undef gmtime
4122 #undef localtime
4123 #undef time
4124
4125 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
4126 #  define RTL_USES_UTC 1
4127 #endif
4128
4129 /*
4130  * DEC C previous to 6.0 corrupts the behavior of the /prefix
4131  * qualifier with the extern prefix pragma.  This provisional
4132  * hack circumvents this prefix pragma problem in previous
4133  * precompilers.
4134  */
4135 #if defined(__VMS_VER) && __VMS_VER >= 70000000
4136 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
4137 #    pragma __extern_prefix save
4138 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
4139 #    define gmtime decc$__utctz_gmtime
4140 #    define localtime decc$__utctz_localtime
4141 #    define time decc$__utc_time
4142 #    pragma __extern_prefix restore
4143
4144      struct tm *gmtime(), *localtime();
4145
4146 #  endif
4147 #endif
4148
4149
4150 static time_t toutc_dst(time_t loc) {
4151   struct tm *rsltmp;
4152
4153   if ((rsltmp = localtime(&loc)) == NULL) return -1;
4154   loc -= utc_offset_secs;
4155   if (rsltmp->tm_isdst) loc -= 3600;
4156   return loc;
4157 }
4158 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
4159        ((gmtime_emulation_type || my_time(NULL)), \
4160        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
4161        ((secs) - utc_offset_secs))))
4162
4163 static time_t toloc_dst(time_t utc) {
4164   struct tm *rsltmp;
4165
4166   utc += utc_offset_secs;
4167   if ((rsltmp = localtime(&utc)) == NULL) return -1;
4168   if (rsltmp->tm_isdst) utc += 3600;
4169   return utc;
4170 }
4171 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
4172        ((gmtime_emulation_type || my_time(NULL)), \
4173        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
4174        ((secs) + utc_offset_secs))))
4175
4176
4177 /* my_time(), my_localtime(), my_gmtime()
4178  * By default traffic in UTC time values, using CRTL gmtime() or
4179  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
4180  * Note: We need to use these functions even when the CRTL has working
4181  * UTC support, since they also handle C<use vmsish qw(times);>
4182  *
4183  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
4184  * Modified by Charles Bailey <bailey@newman.upenn.edu>
4185  */
4186
4187 /*{{{time_t my_time(time_t *timep)*/
4188 time_t my_time(time_t *timep)
4189 {
4190   dTHX;
4191   time_t when;
4192   struct tm *tm_p;
4193
4194   if (gmtime_emulation_type == 0) {
4195     int dstnow;
4196     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
4197                               /* results of calls to gmtime() and localtime() */
4198                               /* for same &base */
4199
4200     gmtime_emulation_type++;
4201     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
4202       char off[LNM$C_NAMLENGTH+1];;
4203
4204       gmtime_emulation_type++;
4205       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
4206         gmtime_emulation_type++;
4207         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
4208       }
4209       else { utc_offset_secs = atol(off); }
4210     }
4211     else { /* We've got a working gmtime() */
4212       struct tm gmt, local;
4213
4214       gmt = *tm_p;
4215       tm_p = localtime(&base);
4216       local = *tm_p;
4217       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
4218       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
4219       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
4220       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
4221     }
4222   }
4223
4224   when = time(NULL);
4225 # ifdef VMSISH_TIME
4226 # ifdef RTL_USES_UTC
4227   if (VMSISH_TIME) when = _toloc(when);
4228 # else
4229   if (!VMSISH_TIME) when = _toutc(when);
4230 # endif
4231 # endif
4232   if (timep != NULL) *timep = when;
4233   return when;
4234
4235 }  /* end of my_time() */
4236 /*}}}*/
4237
4238
4239 /*{{{struct tm *my_gmtime(const time_t *timep)*/
4240 struct tm *
4241 my_gmtime(const time_t *timep)
4242 {
4243   dTHX;
4244   char *p;
4245   time_t when;
4246   struct tm *rsltmp;
4247
4248   if (timep == NULL) {
4249     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4250     return NULL;
4251   }
4252   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
4253
4254   when = *timep;
4255 # ifdef VMSISH_TIME
4256   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
4257 #  endif
4258 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
4259   return gmtime(&when);
4260 # else
4261   /* CRTL localtime() wants local time as input, so does no tz correction */
4262   rsltmp = localtime(&when);
4263   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
4264   return rsltmp;
4265 #endif
4266 }  /* end of my_gmtime() */
4267 /*}}}*/
4268
4269
4270 /*{{{struct tm *my_localtime(const time_t *timep)*/
4271 struct tm *
4272 my_localtime(const time_t *timep)
4273 {
4274   dTHX;
4275   time_t when;
4276   struct tm *rsltmp;
4277
4278   if (timep == NULL) {
4279     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4280     return NULL;
4281   }
4282   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
4283   if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
4284
4285   when = *timep;
4286 # ifdef RTL_USES_UTC
4287 # ifdef VMSISH_TIME
4288   if (VMSISH_TIME) when = _toutc(when);
4289 # endif
4290   /* CRTL localtime() wants UTC as input, does tz correction itself */
4291   return localtime(&when);
4292 # else
4293 # ifdef VMSISH_TIME
4294   if (!VMSISH_TIME) when = _toloc(when);   /*  Input was UTC */
4295 # endif
4296 # endif
4297   /* CRTL localtime() wants local time as input, so does no tz correction */
4298   rsltmp = localtime(&when);
4299   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
4300   return rsltmp;
4301
4302 } /*  end of my_localtime() */
4303 /*}}}*/
4304
4305 /* Reset definitions for later calls */
4306 #define gmtime(t)    my_gmtime(t)
4307 #define localtime(t) my_localtime(t)
4308 #define time(t)      my_time(t)
4309
4310
4311 /* my_utime - update modification time of a file
4312  * calling sequence is identical to POSIX utime(), but under
4313  * VMS only the modification time is changed; ODS-2 does not
4314  * maintain access times.  Restrictions differ from the POSIX
4315  * definition in that the time can be changed as long as the
4316  * caller has permission to execute the necessary IO$_MODIFY $QIO;
4317  * no separate checks are made to insure that the caller is the
4318  * owner of the file or has special privs enabled.
4319  * Code here is based on Joe Meadows' FILE utility.
4320  */
4321
4322 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
4323  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
4324  * in 100 ns intervals.
4325  */
4326 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
4327
4328 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
4329 int my_utime(char *file, struct utimbuf *utimes)
4330 {
4331   dTHX;
4332   register int i;
4333   long int bintime[2], len = 2, lowbit, unixtime,
4334            secscale = 10000000; /* seconds --> 100 ns intervals */
4335   unsigned long int chan, iosb[2], retsts;
4336   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
4337   struct FAB myfab = cc$rms_fab;
4338   struct NAM mynam = cc$rms_nam;
4339 #if defined (__DECC) && defined (__VAX)
4340   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
4341    * at least through VMS V6.1, which causes a type-conversion warning.
4342    */
4343 #  pragma message save
4344 #  pragma message disable cvtdiftypes
4345 #endif
4346   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
4347   struct fibdef myfib;
4348 #if defined (__DECC) && defined (__VAX)
4349   /* This should be right after the declaration of myatr, but due
4350    * to a bug in VAX DEC C, this takes effect a statement early.
4351    */
4352 #  pragma message restore
4353 #endif
4354   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
4355                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
4356                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
4357
4358   if (file == NULL || *file == '\0') {
4359     set_errno(ENOENT);
4360     set_vaxc_errno(LIB$_INVARG);
4361     return -1;
4362   }
4363   if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
4364
4365   if (utimes != NULL) {
4366     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
4367      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
4368      * Since time_t is unsigned long int, and lib$emul takes a signed long int
4369      * as input, we force the sign bit to be clear by shifting unixtime right
4370      * one bit, then multiplying by an extra factor of 2 in lib$emul().
4371      */
4372     lowbit = (utimes->modtime & 1) ? secscale : 0;
4373     unixtime = (long int) utimes->modtime;
4374 #   ifdef VMSISH_TIME
4375     /* If input was UTC; convert to local for sys svc */
4376     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
4377 #   endif
4378     unixtime >>= 1;  secscale <<= 1;
4379     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
4380     if (!(retsts & 1)) {
4381       set_errno(EVMSERR);
4382       set_vaxc_errno(retsts);
4383       return -1;
4384     }
4385     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
4386     if (!(retsts & 1)) {
4387       set_errno(EVMSERR);
4388       set_vaxc_errno(retsts);
4389       return -1;
4390     }
4391   }
4392   else {
4393     /* Just get the current time in VMS format directly */
4394     retsts = sys$gettim(bintime);
4395     if (!(retsts & 1)) {
4396       set_errno(EVMSERR);
4397       set_vaxc_errno(retsts);
4398       return -1;
4399     }
4400   }
4401
4402   myfab.fab$l_fna = vmsspec;
4403   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
4404   myfab.fab$l_nam = &mynam;
4405   mynam.nam$l_esa = esa;
4406   mynam.nam$b_ess = (unsigned char) sizeof esa;
4407   mynam.nam$l_rsa = rsa;
4408   mynam.nam$b_rss = (unsigned char) sizeof rsa;
4409
4410   /* Look for the file to be affected, letting RMS parse the file
4411    * specification for us as well.  I have set errno using only
4412    * values documented in the utime() man page for VMS POSIX.
4413    */
4414   retsts = sys$parse(&myfab,0,0);
4415   if (!(retsts & 1)) {
4416     set_vaxc_errno(retsts);
4417     if      (retsts == RMS$_PRV) set_errno(EACCES);
4418     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4419     else                         set_errno(EVMSERR);
4420     return -1;
4421   }
4422   retsts = sys$search(&myfab,0,0);
4423   if (!(retsts & 1)) {
4424     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
4425     myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
4426     set_vaxc_errno(retsts);
4427     if      (retsts == RMS$_PRV) set_errno(EACCES);
4428     else if (retsts == RMS$_FNF) set_errno(ENOENT);
4429     else                         set_errno(EVMSERR);
4430     return -1;
4431   }
4432
4433   devdsc.dsc$w_length = mynam.nam$b_dev;
4434   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
4435
4436   retsts = sys$assign(&devdsc,&chan,0,0);
4437   if (!(retsts & 1)) {
4438     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
4439     myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
4440     set_vaxc_errno(retsts);
4441     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
4442     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
4443     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
4444     else                               set_errno(EVMSERR);
4445     return -1;
4446   }
4447
4448   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
4449   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
4450
4451   memset((void *) &myfib, 0, sizeof myfib);
4452 #ifdef __DECC
4453   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
4454   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
4455   /* This prevents the revision time of the file being reset to the current
4456    * time as a result of our IO$_MODIFY $QIO. */
4457   myfib.fib$l_acctl = FIB$M_NORECORD;
4458 #else
4459   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
4460   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
4461   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
4462 #endif
4463   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
4464   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
4465   myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
4466   _ckvmssts(sys$dassgn(chan));
4467   if (retsts & 1) retsts = iosb[0];
4468   if (!(retsts & 1)) {
4469     set_vaxc_errno(retsts);
4470     if (retsts == SS$_NOPRIV) set_errno(EACCES);
4471     else                      set_errno(EVMSERR);
4472     return -1;
4473   }
4474
4475   return 0;
4476 }  /* end of my_utime() */
4477 /*}}}*/
4478
4479 /*
4480  * flex_stat, flex_fstat
4481  * basic stat, but gets it right when asked to stat
4482  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
4483  */
4484
4485 /* encode_dev packs a VMS device name string into an integer to allow
4486  * simple comparisons. This can be used, for example, to check whether two
4487  * files are located on the same device, by comparing their encoded device
4488  * names. Even a string comparison would not do, because stat() reuses the
4489  * device name buffer for each call; so without encode_dev, it would be
4490  * necessary to save the buffer and use strcmp (this would mean a number of
4491  * changes to the standard Perl code, to say nothing of what a Perl script
4492  * would have to do.
4493  *
4494  * The device lock id, if it exists, should be unique (unless perhaps compared
4495  * with lock ids transferred from other nodes). We have a lock id if the disk is
4496  * mounted cluster-wide, which is when we tend to get long (host-qualified)
4497  * device names. Thus we use the lock id in preference, and only if that isn't
4498  * available, do we try to pack the device name into an integer (flagged by
4499  * the sign bit (LOCKID_MASK) being set).
4500  *
4501  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
4502  * name and its encoded form, but it seems very unlikely that we will find
4503  * two files on different disks that share the same encoded device names,
4504  * and even more remote that they will share the same file id (if the test
4505  * is to check for the same file).
4506  *
4507  * A better method might be to use sys$device_scan on the first call, and to
4508  * search for the device, returning an index into the cached array.
4509  * The number returned would be more intelligable.
4510  * This is probably not worth it, and anyway would take quite a bit longer
4511  * on the first call.
4512  */
4513 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
4514 static mydev_t encode_dev (const char *dev)
4515 {
4516   int i;
4517   unsigned long int f;
4518   mydev_t enc;
4519   char c;
4520   const char *q;
4521   dTHX;
4522
4523   if (!dev || !dev[0]) return 0;
4524
4525 #if LOCKID_MASK
4526   {
4527     struct dsc$descriptor_s dev_desc;
4528     unsigned long int status, lockid, item = DVI$_LOCKID;
4529
4530     /* For cluster-mounted disks, the disk lock identifier is unique, so we
4531        can try that first. */
4532     dev_desc.dsc$w_length =  strlen (dev);
4533     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
4534     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
4535     dev_desc.dsc$a_pointer = (char *) dev;
4536     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
4537     if (lockid) return (lockid & ~LOCKID_MASK);
4538   }
4539 #endif
4540
4541   /* Otherwise we try to encode the device name */
4542   enc = 0;
4543   f = 1;
4544   i = 0;
4545   for (q = dev + strlen(dev); q--; q >= dev) {
4546     if (isdigit (*q))
4547       c= (*q) - '0';
4548     else if (isalpha (toupper (*q)))
4549       c= toupper (*q) - 'A' + (char)10;
4550     else
4551       continue; /* Skip '$'s */
4552     i++;
4553     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
4554     if (i>1) f *= 36;
4555     enc += f * (unsigned long int) c;
4556   }
4557   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
4558
4559 }  /* end of encode_dev() */
4560
4561 static char namecache[NAM$C_MAXRSS+1];
4562
4563 static int
4564 is_null_device(name)
4565     const char *name;
4566 {
4567     dTHX;
4568     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
4569        The underscore prefix, controller letter, and unit number are
4570        independently optional; for our purposes, the colon punctuation
4571        is not.  The colon can be trailed by optional directory and/or
4572        filename, but two consecutive colons indicates a nodename rather
4573        than a device.  [pr]  */
4574   if (*name == '_') ++name;
4575   if (tolower(*name++) != 'n') return 0;
4576   if (tolower(*name++) != 'l') return 0;
4577   if (tolower(*name) == 'a') ++name;
4578   if (*name == '0') ++name;
4579   return (*name++ == ':') && (*name != ':');
4580 }
4581
4582 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
4583 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
4584  * subset of the applicable information.
4585  */
4586 bool
4587 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
4588 {
4589   if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
4590   else {
4591     char fname[NAM$C_MAXRSS+1];
4592     unsigned long int retsts;
4593     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4594                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4595
4596     /* If the struct mystat is stale, we're OOL; stat() overwrites the
4597        device name on successive calls */
4598     devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
4599     devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
4600     namdsc.dsc$a_pointer = fname;
4601     namdsc.dsc$w_length = sizeof fname - 1;
4602
4603     retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
4604                              &namdsc,&namdsc.dsc$w_length,0,0);
4605     if (retsts & 1) {
4606       fname[namdsc.dsc$w_length] = '\0';
4607       return cando_by_name(bit,effective,fname);
4608     }
4609     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
4610       Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
4611       return FALSE;
4612     }
4613     _ckvmssts(retsts);
4614     return FALSE;  /* Should never get to here */
4615   }
4616 }  /* end of cando() */
4617 /*}}}*/
4618
4619
4620 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
4621 I32
4622 cando_by_name(I32 bit, Uid_t effective, char *fname)
4623 {
4624   static char usrname[L_cuserid];
4625   static struct dsc$descriptor_s usrdsc =
4626          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
4627   char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
4628   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
4629   unsigned short int retlen;
4630   dTHX;
4631   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4632   union prvdef curprv;
4633   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
4634          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
4635   struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
4636          {0,0,0,0}};
4637
4638   if (!fname || !*fname) return FALSE;
4639   /* Make sure we expand logical names, since sys$check_access doesn't */
4640   if (!strpbrk(fname,"/]>:")) {
4641     strcpy(fileified,fname);
4642     while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
4643     fname = fileified;
4644   }
4645   if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
4646   retlen = namdsc.dsc$w_length = strlen(vmsname);
4647   namdsc.dsc$a_pointer = vmsname;
4648   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
4649       vmsname[retlen-1] == ':') {
4650     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
4651     namdsc.dsc$w_length = strlen(fileified);
4652     namdsc.dsc$a_pointer = fileified;
4653   }
4654
4655   if (!usrdsc.dsc$w_length) {
4656     cuserid(usrname);
4657     usrdsc.dsc$w_length = strlen(usrname);
4658   }
4659
4660   switch (bit) {
4661     case S_IXUSR: case S_IXGRP: case S_IXOTH:
4662       access = ARM$M_EXECUTE; break;
4663     case S_IRUSR: case S_IRGRP: case S_IROTH:
4664       access = ARM$M_READ; break;
4665     case S_IWUSR: case S_IWGRP: case S_IWOTH:
4666       access = ARM$M_WRITE; break;
4667     case S_IDUSR: case S_IDGRP: case S_IDOTH:
4668       access = ARM$M_DELETE; break;
4669     default:
4670       return FALSE;
4671   }
4672
4673   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
4674   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
4675       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
4676       retsts == RMS$_DIR        || retsts == RMS$_DEV) {
4677     set_vaxc_errno(retsts);
4678     if (retsts == SS$_NOPRIV) set_errno(EACCES);
4679     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
4680     else set_errno(ENOENT);
4681     return FALSE;
4682   }
4683   if (retsts == SS$_NORMAL) {
4684     if (!privused) return TRUE;
4685     /* We can get access, but only by using privs.  Do we have the
4686        necessary privs currently enabled? */
4687     _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
4688     if ((privused & CHP$M_BYPASS) &&  !curprv.prv$v_bypass)  return FALSE;
4689     if ((privused & CHP$M_SYSPRV) &&  !curprv.prv$v_sysprv &&
4690                                       !curprv.prv$v_bypass)  return FALSE;
4691     if ((privused & CHP$M_GRPPRV) &&  !curprv.prv$v_grpprv &&
4692          !curprv.prv$v_sysprv &&      !curprv.prv$v_bypass)  return FALSE;
4693     if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
4694     return TRUE;
4695   }
4696   if (retsts == SS$_ACCONFLICT) {
4697     return TRUE;
4698   }
4699
4700 #if defined(__ALPHA) && defined(__VMS_VER) && __VMS_VER == 70100022 &&  defined(__DECC_VER) && __DECC_VER == 6009001
4701   /* XXX Hideous kluge to accomodate error in specific version of RTL;
4702      we hope it'll be buried soon */
4703   if (retsts == 114762) return TRUE;
4704 #endif
4705   _ckvmssts(retsts);
4706
4707   return FALSE;  /* Should never get here */
4708
4709 }  /* end of cando_by_name() */
4710 /*}}}*/
4711
4712
4713 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
4714 int
4715 flex_fstat(int fd, Stat_t *statbufp)
4716 {
4717   dTHX;
4718   if (!fstat(fd,(stat_t *) statbufp)) {
4719     if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
4720     statbufp->st_dev = encode_dev(statbufp->st_devnam);
4721 #   ifdef RTL_USES_UTC
4722 #   ifdef VMSISH_TIME
4723     if (VMSISH_TIME) {
4724       statbufp->st_mtime = _toloc(statbufp->st_mtime);
4725       statbufp->st_atime = _toloc(statbufp->st_atime);
4726       statbufp->st_ctime = _toloc(statbufp->st_ctime);
4727     }
4728 #   endif
4729 #   else
4730 #   ifdef VMSISH_TIME
4731     if (!VMSISH_TIME) { /* Return UTC instead of local time */
4732 #   else
4733     if (1) {
4734 #   endif
4735       statbufp->st_mtime = _toutc(statbufp->st_mtime);
4736       statbufp->st_atime = _toutc(statbufp->st_atime);
4737       statbufp->st_ctime = _toutc(statbufp->st_ctime);
4738     }
4739 #endif
4740     return 0;
4741   }
4742   return -1;
4743
4744 }  /* end of flex_fstat() */
4745 /*}}}*/
4746
4747 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
4748 int
4749 flex_stat(const char *fspec, Stat_t *statbufp)
4750 {
4751     dTHX;
4752     char fileified[NAM$C_MAXRSS+1];
4753     char temp_fspec[NAM$C_MAXRSS+300];
4754     int retval = -1;
4755
4756     strcpy(temp_fspec, fspec);
4757     if (statbufp == (Stat_t *) &PL_statcache)
4758       do_tovmsspec(temp_fspec,namecache,0);
4759     if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
4760       memset(statbufp,0,sizeof *statbufp);
4761       statbufp->st_dev = encode_dev("_NLA0:");
4762       statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
4763       statbufp->st_uid = 0x00010001;
4764       statbufp->st_gid = 0x0001;
4765       time((time_t *)&statbufp->st_mtime);
4766       statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
4767       return 0;
4768     }
4769
4770     /* Try for a directory name first.  If fspec contains a filename without
4771      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
4772      * and sea:[wine.dark]water. exist, we prefer the directory here.
4773      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
4774      * not sea:[wine.dark]., if the latter exists.  If the intended target is
4775      * the file with null type, specify this by calling flex_stat() with
4776      * a '.' at the end of fspec.
4777      */
4778     if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
4779       retval = stat(fileified,(stat_t *) statbufp);
4780       if (!retval && statbufp == (Stat_t *) &PL_statcache)
4781         strcpy(namecache,fileified);
4782     }
4783     if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
4784     if (!retval) {
4785       statbufp->st_dev = encode_dev(statbufp->st_devnam);
4786 #     ifdef RTL_USES_UTC
4787 #     ifdef VMSISH_TIME
4788       if (VMSISH_TIME) {
4789         statbufp->st_mtime = _toloc(statbufp->st_mtime);
4790         statbufp->st_atime = _toloc(statbufp->st_atime);
4791         statbufp->st_ctime = _toloc(statbufp->st_ctime);
4792       }
4793 #     endif
4794 #     else
4795 #     ifdef VMSISH_TIME
4796       if (!VMSISH_TIME) { /* Return UTC instead of local time */
4797 #     else
4798       if (1) {
4799 #     endif
4800         statbufp->st_mtime = _toutc(statbufp->st_mtime);
4801         statbufp->st_atime = _toutc(statbufp->st_atime);
4802         statbufp->st_ctime = _toutc(statbufp->st_ctime);
4803       }
4804 #     endif
4805     }
4806     return retval;
4807
4808 }  /* end of flex_stat() */
4809 /*}}}*/
4810
4811
4812 /*{{{char *my_getlogin()*/
4813 /* VMS cuserid == Unix getlogin, except calling sequence */
4814 char *
4815 my_getlogin()
4816 {
4817     static char user[L_cuserid];
4818     return cuserid(user);
4819 }
4820 /*}}}*/
4821
4822
4823 /*  rmscopy - copy a file using VMS RMS routines
4824  *
4825  *  Copies contents and attributes of spec_in to spec_out, except owner
4826  *  and protection information.  Name and type of spec_in are used as
4827  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
4828  *  should try to propagate timestamps from the input file to the output file.
4829  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
4830  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
4831  *  propagated to the output file at creation iff the output file specification
4832  *  did not contain an explicit name or type, and the revision date is always
4833  *  updated at the end of the copy operation.  If it is greater than 0, then
4834  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
4835  *  other than the revision date should be propagated, and bit 1 indicates
4836  *  that the revision date should be propagated.
4837  *
4838  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
4839  *
4840  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
4841  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
4842  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
4843  * as part of the Perl standard distribution under the terms of the
4844  * GNU General Public License or the Perl Artistic License.  Copies
4845  * of each may be found in the Perl standard distribution.
4846  */
4847 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
4848 int
4849 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
4850 {
4851     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
4852          rsa[NAM$C_MAXRSS], ubf[32256];
4853     unsigned long int i, sts, sts2;
4854     struct FAB fab_in, fab_out;
4855     struct RAB rab_in, rab_out;
4856     struct NAM nam;
4857     struct XABDAT xabdat;
4858     struct XABFHC xabfhc;
4859     struct XABRDT xabrdt;
4860     struct XABSUM xabsum;
4861
4862     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
4863         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
4864       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4865       return 0;
4866     }
4867
4868     fab_in = cc$rms_fab;
4869     fab_in.fab$l_fna = vmsin;
4870     fab_in.fab$b_fns = strlen(vmsin);
4871     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
4872     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
4873     fab_in.fab$l_fop = FAB$M_SQO;
4874     fab_in.fab$l_nam =  &nam;
4875     fab_in.fab$l_xab = (void *) &xabdat;
4876
4877     nam = cc$rms_nam;
4878     nam.nam$l_rsa = rsa;
4879     nam.nam$b_rss = sizeof(rsa);
4880     nam.nam$l_esa = esa;
4881     nam.nam$b_ess = sizeof (esa);
4882     nam.nam$b_esl = nam.nam$b_rsl = 0;
4883
4884     xabdat = cc$rms_xabdat;        /* To get creation date */
4885     xabdat.xab$l_nxt = (void *) &xabfhc;
4886
4887     xabfhc = cc$rms_xabfhc;        /* To get record length */
4888     xabfhc.xab$l_nxt = (void *) &xabsum;
4889
4890     xabsum = cc$rms_xabsum;        /* To get key and area information */
4891
4892     if (!((sts = sys$open(&fab_in)) & 1)) {
4893       set_vaxc_errno(sts);
4894       switch (sts) {
4895         case RMS$_FNF: case RMS$_DNF:
4896           set_errno(ENOENT); break;
4897         case RMS$_DIR:
4898           set_errno(ENOTDIR); break;
4899         case RMS$_DEV:
4900           set_errno(ENODEV); break;
4901         case RMS$_SYN:
4902           set_errno(EINVAL); break;
4903         case RMS$_PRV:
4904           set_errno(EACCES); break;
4905         default:
4906           set_errno(EVMSERR);
4907       }
4908       return 0;
4909     }
4910
4911     fab_out = fab_in;
4912     fab_out.fab$w_ifi = 0;
4913     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
4914     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
4915     fab_out.fab$l_fop = FAB$M_SQO;
4916     fab_out.fab$l_fna = vmsout;
4917     fab_out.fab$b_fns = strlen(vmsout);
4918     fab_out.fab$l_dna = nam.nam$l_name;
4919     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
4920
4921     if (preserve_dates == 0) {  /* Act like DCL COPY */
4922       nam.nam$b_nop = NAM$M_SYNCHK;
4923       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
4924       if (!((sts = sys$parse(&fab_out)) & 1)) {
4925         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
4926         set_vaxc_errno(sts);
4927         return 0;
4928       }
4929       fab_out.fab$l_xab = (void *) &xabdat;
4930       if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
4931     }
4932     fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
4933     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
4934       preserve_dates =0;      /* bitmask from this point forward   */
4935
4936     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
4937     if (!((sts = sys$create(&fab_out)) & 1)) {
4938       set_vaxc_errno(sts);
4939       switch (sts) {
4940         case RMS$_DNF:
4941           set_errno(ENOENT); break;
4942         case RMS$_DIR:
4943           set_errno(ENOTDIR); break;
4944         case RMS$_DEV:
4945           set_errno(ENODEV); break;
4946         case RMS$_SYN:
4947           set_errno(EINVAL); break;
4948         case RMS$_PRV:
4949           set_errno(EACCES); break;
4950         default:
4951           set_errno(EVMSERR);
4952       }
4953       return 0;
4954     }
4955     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
4956     if (preserve_dates & 2) {
4957       /* sys$close() will process xabrdt, not xabdat */
4958       xabrdt = cc$rms_xabrdt;
4959 #ifndef __GNUC__
4960       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
4961 #else
4962       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
4963        * is unsigned long[2], while DECC & VAXC use a struct */
4964       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
4965 #endif
4966       fab_out.fab$l_xab = (void *) &xabrdt;
4967     }
4968
4969     rab_in = cc$rms_rab;
4970     rab_in.rab$l_fab = &fab_in;
4971     rab_in.rab$l_rop = RAB$M_BIO;
4972     rab_in.rab$l_ubf = ubf;
4973     rab_in.rab$w_usz = sizeof ubf;
4974     if (!((sts = sys$connect(&rab_in)) & 1)) {
4975       sys$close(&fab_in); sys$close(&fab_out);
4976       set_errno(EVMSERR); set_vaxc_errno(sts);
4977       return 0;
4978     }
4979
4980     rab_out = cc$rms_rab;
4981     rab_out.rab$l_fab = &fab_out;
4982     rab_out.rab$l_rbf = ubf;
4983     if (!((sts = sys$connect(&rab_out)) & 1)) {
4984       sys$close(&fab_in); sys$close(&fab_out);
4985       set_errno(EVMSERR); set_vaxc_errno(sts);
4986       return 0;
4987     }
4988
4989     while ((sts = sys$read(&rab_in))) {  /* always true  */
4990       if (sts == RMS$_EOF) break;
4991       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
4992       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
4993         sys$close(&fab_in); sys$close(&fab_out);
4994         set_errno(EVMSERR); set_vaxc_errno(sts);
4995         return 0;
4996       }
4997     }
4998
4999     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
5000     sys$close(&fab_in);  sys$close(&fab_out);
5001     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
5002     if (!(sts & 1)) {
5003       set_errno(EVMSERR); set_vaxc_errno(sts);
5004       return 0;
5005     }
5006
5007     return 1;
5008
5009 }  /* end of rmscopy() */
5010 /*}}}*/
5011
5012
5013 /***  The following glue provides 'hooks' to make some of the routines
5014  * from this file available from Perl.  These routines are sufficiently
5015  * basic, and are required sufficiently early in the build process,
5016  * that's it's nice to have them available to miniperl as well as the
5017  * full Perl, so they're set up here instead of in an extension.  The
5018  * Perl code which handles importation of these names into a given
5019  * package lives in [.VMS]Filespec.pm in @INC.
5020  */
5021
5022 void
5023 rmsexpand_fromperl(pTHX_ CV *cv)
5024 {
5025   dXSARGS;
5026   char *fspec, *defspec = NULL, *rslt;
5027   STRLEN n_a;
5028
5029   if (!items || items > 2)
5030     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
5031   fspec = SvPV(ST(0),n_a);
5032   if (!fspec || !*fspec) XSRETURN_UNDEF;
5033   if (items == 2) defspec = SvPV(ST(1),n_a);
5034
5035   rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
5036   ST(0) = sv_newmortal();
5037   if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
5038   XSRETURN(1);
5039 }
5040
5041 void
5042 vmsify_fromperl(pTHX_ CV *cv)
5043 {
5044   dXSARGS;
5045   char *vmsified;
5046   STRLEN n_a;
5047
5048   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
5049   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
5050   ST(0) = sv_newmortal();
5051   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
5052   XSRETURN(1);
5053 }
5054
5055 void
5056 unixify_fromperl(pTHX_ CV *cv)
5057 {
5058   dXSARGS;
5059   char *unixified;
5060   STRLEN n_a;
5061
5062   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
5063   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
5064   ST(0) = sv_newmortal();
5065   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
5066   XSRETURN(1);
5067 }
5068
5069 void
5070 fileify_fromperl(pTHX_ CV *cv)
5071 {
5072   dXSARGS;
5073   char *fileified;
5074   STRLEN n_a;
5075
5076   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
5077   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
5078   ST(0) = sv_newmortal();
5079   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
5080   XSRETURN(1);
5081 }
5082
5083 void
5084 pathify_fromperl(pTHX_ CV *cv)
5085 {
5086   dXSARGS;
5087   char *pathified;
5088   STRLEN n_a;
5089
5090   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
5091   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
5092   ST(0) = sv_newmortal();
5093   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
5094   XSRETURN(1);
5095 }
5096
5097 void
5098 vmspath_fromperl(pTHX_ CV *cv)
5099 {
5100   dXSARGS;
5101   char *vmspath;
5102   STRLEN n_a;
5103
5104   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
5105   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
5106   ST(0) = sv_newmortal();
5107   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
5108   XSRETURN(1);
5109 }
5110
5111 void
5112 unixpath_fromperl(pTHX_ CV *cv)
5113 {
5114   dXSARGS;
5115   char *unixpath;
5116   STRLEN n_a;
5117
5118   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
5119   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
5120   ST(0) = sv_newmortal();
5121   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
5122   XSRETURN(1);
5123 }
5124
5125 void
5126 candelete_fromperl(pTHX_ CV *cv)
5127 {
5128   dXSARGS;
5129   char fspec[NAM$C_MAXRSS+1], *fsp;
5130   SV *mysv;
5131   IO *io;
5132   STRLEN n_a;
5133
5134   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
5135
5136   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
5137   if (SvTYPE(mysv) == SVt_PVGV) {
5138     if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
5139       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5140       ST(0) = &PL_sv_no;
5141       XSRETURN(1);
5142     }
5143     fsp = fspec;
5144   }
5145   else {
5146     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
5147       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5148       ST(0) = &PL_sv_no;
5149       XSRETURN(1);
5150     }
5151   }
5152
5153   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
5154   XSRETURN(1);
5155 }
5156
5157 void
5158 rmscopy_fromperl(pTHX_ CV *cv)
5159 {
5160   dXSARGS;
5161   char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
5162   int date_flag;
5163   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
5164                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5165   unsigned long int sts;
5166   SV *mysv;
5167   IO *io;
5168   STRLEN n_a;
5169
5170   if (items < 2 || items > 3)
5171     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
5172
5173   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
5174   if (SvTYPE(mysv) == SVt_PVGV) {
5175     if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
5176       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5177       ST(0) = &PL_sv_no;
5178       XSRETURN(1);
5179     }
5180     inp = inspec;
5181   }
5182   else {
5183     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
5184       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5185       ST(0) = &PL_sv_no;
5186       XSRETURN(1);
5187     }
5188   }
5189   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
5190   if (SvTYPE(mysv) == SVt_PVGV) {
5191     if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
5192       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5193       ST(0) = &PL_sv_no;
5194       XSRETURN(1);
5195     }
5196     outp = outspec;
5197   }
5198   else {
5199     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
5200       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5201       ST(0) = &PL_sv_no;
5202       XSRETURN(1);
5203     }
5204   }
5205   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
5206
5207   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
5208   XSRETURN(1);
5209 }
5210
5211 void
5212 init_os_extras()
5213 {
5214   char* file = __FILE__;
5215   dTHX;
5216   char temp_buff[512];
5217   if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
5218     no_translate_barewords = TRUE;
5219   } else {
5220     no_translate_barewords = FALSE;
5221   }
5222
5223   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
5224   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
5225   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
5226   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
5227   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
5228   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
5229   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
5230   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
5231   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
5232
5233   return;
5234 }
5235
5236 /*  End of vms.c */