1 /* vms.c 2 * 3 * VMS-specific routines for perl5 4 * Version: 5.7.0 5 * 6 * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name, 7 * and Perl_cando by Craig Berry 8 * 29-Aug-2000 Charles Lane's piping improvements rolled in 9 * 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu 10 */ 11 12 #include <acedef.h> 13 #include <acldef.h> 14 #include <armdef.h> 15 #include <atrdef.h> 16 #include <chpdef.h> 17 #include <clidef.h> 18 #include <climsgdef.h> 19 #include <descrip.h> 20 #include <devdef.h> 21 #include <dvidef.h> 22 #include <fibdef.h> 23 #include <float.h> 24 #include <fscndef.h> 25 #include <iodef.h> 26 #include <jpidef.h> 27 #include <kgbdef.h> 28 #include <libclidef.h> 29 #include <libdef.h> 30 #include <lib$routines.h> 31 #include <lnmdef.h> 32 #include <msgdef.h> 33 #include <prvdef.h> 34 #include <psldef.h> 35 #include <rms.h> 36 #include <shrdef.h> 37 #include <ssdef.h> 38 #include <starlet.h> 39 #include <strdef.h> 40 #include <str$routines.h> 41 #include <syidef.h> 42 #include <uaidef.h> 43 #include <uicdef.h> 44 45 /* Older versions of ssdef.h don't have these */ 46 #ifndef SS$_INVFILFOROP 47 # define SS$_INVFILFOROP 3930 48 #endif 49 #ifndef SS$_NOSUCHOBJECT 50 # define SS$_NOSUCHOBJECT 2696 51 #endif 52 53 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */ 54 #define PERLIO_NOT_STDIO 0 55 56 /* Don't replace system definitions of vfork, getenv, and stat, 57 * code below needs to get to the underlying CRTL routines. */ 58 #define DONT_MASK_RTL_CALLS 59 #include "EXTERN.h" 60 #include "perl.h" 61 #include "XSUB.h" 62 /* Anticipating future expansion in lexical warnings . . . */ 63 #ifndef WARN_INTERNAL 64 # define WARN_INTERNAL WARN_MISC 65 #endif 66 67 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000 68 # define RTL_USES_UTC 1 69 #endif 70 71 72 /* gcc's header files don't #define direct access macros 73 * corresponding to VAXC's variant structs */ 74 #ifdef __GNUC__ 75 # define uic$v_format uic$r_uic_form.uic$v_format 76 # define uic$v_group uic$r_uic_form.uic$v_group 77 # define uic$v_member uic$r_uic_form.uic$v_member 78 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass 79 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv 80 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall 81 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv 82 #endif 83 84 #if defined(NEED_AN_H_ERRNO) 85 dEXT int h_errno; 86 #endif 87 88 struct itmlst_3 { 89 unsigned short int buflen; 90 unsigned short int itmcode; 91 void *bufadr; 92 unsigned short int *retlen; 93 }; 94 95 #define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c) 96 #define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c) 97 #define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c) 98 #define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c) 99 #define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e) 100 #define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c) 101 #define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c) 102 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d) 103 #define getredirection(a,b) mp_getredirection(aTHX_ a,b) 104 105 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */ 106 #define PERL_LNM_MAX_ALLOWED_INDEX 127 107 108 /* OpenVMS User's Guide says at least 9 iterative translations will be performed, 109 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for 110 * the Perl facility. 111 */ 112 #define PERL_LNM_MAX_ITER 10 113 114 #define MAX_DCL_SYMBOL 255 /* well, what *we* can set, at least*/ 115 #define MAX_DCL_LINE_LENGTH (4*MAX_DCL_SYMBOL-4) 116 117 static char *__mystrtolower(char *str) 118 { 119 if (str) for (; *str; ++str) *str= tolower(*str); 120 return str; 121 } 122 123 static struct dsc$descriptor_s fildevdsc = 124 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" }; 125 static struct dsc$descriptor_s crtlenvdsc = 126 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" }; 127 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL }; 128 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL }; 129 static struct dsc$descriptor_s **env_tables = defenv; 130 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */ 131 132 /* True if we shouldn't treat barewords as logicals during directory */ 133 /* munching */ 134 static int no_translate_barewords; 135 136 #ifndef RTL_USES_UTC 137 static int tz_updated = 1; 138 #endif 139 140 /* my_maxidx 141 * Routine to retrieve the maximum equivalence index for an input 142 * logical name. Some calls to this routine have no knowledge if 143 * the variable is a logical or not. So on error we return a max 144 * index of zero. 145 */ 146 /*{{{int my_maxidx(char *lnm) */ 147 static int 148 my_maxidx(char *lnm) 149 { 150 int status; 151 int midx; 152 int attr = LNM$M_CASE_BLIND; 153 struct dsc$descriptor lnmdsc; 154 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0}, 155 {0, 0, 0, 0}}; 156 157 lnmdsc.dsc$w_length = strlen(lnm); 158 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T; 159 lnmdsc.dsc$b_class = DSC$K_CLASS_S; 160 lnmdsc.dsc$a_pointer = lnm; 161 162 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst); 163 if ((status & 1) == 0) 164 midx = 0; 165 166 return (midx); 167 } 168 /*}}}*/ 169 170 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */ 171 int 172 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, 173 struct dsc$descriptor_s **tabvec, unsigned long int flags) 174 { 175 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2; 176 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure; 177 unsigned long int retsts, attr = LNM$M_CASE_BLIND; 178 int midx; 179 unsigned char acmode; 180 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0}, 181 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0}; 182 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0}, 183 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen}, 184 {0, 0, 0, 0}}; 185 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM"); 186 #if defined(PERL_IMPLICIT_CONTEXT) 187 pTHX = NULL; 188 # if defined(USE_5005THREADS) 189 /* We jump through these hoops because we can be called at */ 190 /* platform-specific initialization time, which is before anything is */ 191 /* set up--we can't even do a plain dTHX since that relies on the */ 192 /* interpreter structure to be initialized */ 193 if (PL_curinterp) { 194 aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv); 195 } else { 196 aTHX = NULL; 197 } 198 # else 199 if (PL_curinterp) { 200 aTHX = PERL_GET_INTERP; 201 } else { 202 aTHX = NULL; 203 } 204 205 # endif 206 #endif 207 208 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) { 209 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0; 210 } 211 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) { 212 *cp2 = _toupper(*cp1); 213 if (cp1 - lnm > LNM$C_NAMLENGTH) { 214 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM); 215 return 0; 216 } 217 } 218 lnmdsc.dsc$w_length = cp1 - lnm; 219 lnmdsc.dsc$a_pointer = uplnm; 220 uplnm[lnmdsc.dsc$w_length] = '\0'; 221 secure = flags & PERL__TRNENV_SECURE; 222 acmode = secure ? PSL$C_EXEC : PSL$C_USER; 223 if (!tabvec || !*tabvec) tabvec = env_tables; 224 225 for (curtab = 0; tabvec[curtab]; curtab++) { 226 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) { 227 if (!ivenv && !secure) { 228 char *eq, *end; 229 int i; 230 if (!environ) { 231 ivenv = 1; 232 Perl_warn(aTHX_ "Can't read CRTL environ\n"); 233 continue; 234 } 235 retsts = SS$_NOLOGNAM; 236 for (i = 0; environ[i]; i++) { 237 if ((eq = strchr(environ[i],'=')) && 238 lnmdsc.dsc$w_length == (eq - environ[i]) && 239 !strncmp(environ[i],uplnm,eq - environ[i])) { 240 eq++; 241 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen]; 242 if (!eqvlen) continue; 243 retsts = SS$_NORMAL; 244 break; 245 } 246 } 247 if (retsts != SS$_NOLOGNAM) break; 248 } 249 } 250 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) && 251 !str$case_blind_compare(&tmpdsc,&clisym)) { 252 if (!ivsym && !secure) { 253 unsigned short int deflen = LNM$C_NAMLENGTH; 254 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0}; 255 /* dynamic dsc to accomodate possible long value */ 256 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc)); 257 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0); 258 if (retsts & 1) { 259 if (eqvlen > 1024) { 260 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU); 261 eqvlen = 1024; 262 /* Special hack--we might be called before the interpreter's */ 263 /* fully initialized, in which case either thr or PL_curcop */ 264 /* might be bogus. We have to check, since ckWARN needs them */ 265 /* both to be valid if running threaded */ 266 #if defined(USE_5005THREADS) 267 if (thr && PL_curcop) { 268 #endif 269 if (ckWARN(WARN_MISC)) { 270 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm); 271 } 272 #if defined(USE_5005THREADS) 273 } else { 274 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm); 275 } 276 #endif 277 278 } 279 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen); 280 } 281 _ckvmssts(lib$sfree1_dd(&eqvdsc)); 282 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; } 283 if (retsts == LIB$_NOSUCHSYM) continue; 284 break; 285 } 286 } 287 else if (!ivlnm) { 288 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) { 289 midx = my_maxidx((char *) lnm); 290 for (idx = 0, cp1 = eqv; idx <= midx; idx++) { 291 lnmlst[1].bufadr = cp1; 292 eqvlen = 0; 293 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst); 294 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; } 295 if (retsts == SS$_NOLOGNAM) break; 296 /* PPFs have a prefix */ 297 if ( 298 #if INTSIZE == 4 299 *((int *)uplnm) == *((int *)"SYS$") && 300 #endif 301 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 && 302 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) || 303 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) || 304 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) || 305 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) { 306 memcpy(eqv,eqv+4,eqvlen-4); 307 eqvlen -= 4; 308 } 309 cp1 += eqvlen; 310 *cp1 = '\0'; 311 } 312 if ((retsts == SS$_IVLOGNAM) || 313 (retsts == SS$_NOLOGNAM)) { continue; } 314 } 315 else { 316 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst); 317 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; } 318 if (retsts == SS$_NOLOGNAM) continue; 319 eqv[eqvlen] = '\0'; 320 } 321 eqvlen = strlen(eqv); 322 break; 323 } 324 } 325 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; } 326 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM || 327 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB || 328 retsts == SS$_NOLOGNAM) { 329 set_errno(EINVAL); set_vaxc_errno(retsts); 330 } 331 else _ckvmssts(retsts); 332 return 0; 333 } /* end of vmstrnenv */ 334 /*}}}*/ 335 336 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/ 337 /* Define as a function so we can access statics. */ 338 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx) 339 { 340 return vmstrnenv(lnm,eqv,idx,fildev, 341 #ifdef SECURE_INTERNAL_GETENV 342 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0 343 #else 344 0 345 #endif 346 ); 347 } 348 /*}}}*/ 349 350 /* my_getenv 351 * Note: Uses Perl temp to store result so char * can be returned to 352 * caller; this pointer will be invalidated at next Perl statement 353 * transition. 354 * We define this as a function rather than a macro in terms of my_getenv_len() 355 * so that it'll work when PL_curinterp is undefined (and we therefore can't 356 * allocate SVs). 357 */ 358 /*{{{ char *my_getenv(const char *lnm, bool sys)*/ 359 char * 360 Perl_my_getenv(pTHX_ const char *lnm, bool sys) 361 { 362 static char *__my_getenv_eqv = NULL; 363 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv; 364 unsigned long int idx = 0; 365 int trnsuccess, success, secure, saverr, savvmserr; 366 int midx, flags; 367 SV *tmpsv; 368 369 midx = my_maxidx((char *) lnm) + 1; 370 371 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */ 372 /* Set up a temporary buffer for the return value; Perl will 373 * clean it up at the next statement transition */ 374 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1)); 375 if (!tmpsv) return NULL; 376 eqv = SvPVX(tmpsv); 377 } 378 else { 379 /* Assume no interpreter ==> single thread */ 380 if (__my_getenv_eqv != NULL) { 381 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char); 382 } 383 else { 384 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char); 385 } 386 eqv = __my_getenv_eqv; 387 } 388 389 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1); 390 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) { 391 getcwd(eqv,LNM$C_NAMLENGTH); 392 return eqv; 393 } 394 else { 395 /* Impose security constraints only if tainting */ 396 if (sys) { 397 /* Impose security constraints only if tainting */ 398 secure = PL_curinterp ? PL_tainting : will_taint; 399 saverr = errno; savvmserr = vaxc$errno; 400 } 401 else { 402 secure = 0; 403 } 404 405 flags = 406 #ifdef SECURE_INTERNAL_GETENV 407 secure ? PERL__TRNENV_SECURE : 0 408 #else 409 0 410 #endif 411 ; 412 413 /* For the getenv interface we combine all the equivalence names 414 * of a search list logical into one value to acquire a maximum 415 * value length of 255*128 (assuming %ENV is using logicals). 416 */ 417 flags |= PERL__TRNENV_JOIN_SEARCHLIST; 418 419 /* If the name contains a semicolon-delimited index, parse it 420 * off and make sure we only retrieve the equivalence name for 421 * that index. */ 422 if ((cp2 = strchr(lnm,';')) != NULL) { 423 strcpy(uplnm,lnm); 424 uplnm[cp2-lnm] = '\0'; 425 idx = strtoul(cp2+1,NULL,0); 426 lnm = uplnm; 427 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST; 428 } 429 430 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags); 431 432 /* Discard NOLOGNAM on internal calls since we're often looking 433 * for an optional name, and this "error" often shows up as the 434 * (bogus) exit status for a die() call later on. */ 435 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr); 436 return success ? eqv : Nullch; 437 } 438 439 } /* end of my_getenv() */ 440 /*}}}*/ 441 442 443 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/ 444 char * 445 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys) 446 { 447 char *buf, *cp1, *cp2; 448 unsigned long idx = 0; 449 int midx, flags; 450 static char *__my_getenv_len_eqv = NULL; 451 int secure, saverr, savvmserr; 452 SV *tmpsv; 453 454 midx = my_maxidx((char *) lnm) + 1; 455 456 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */ 457 /* Set up a temporary buffer for the return value; Perl will 458 * clean it up at the next statement transition */ 459 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1)); 460 if (!tmpsv) return NULL; 461 buf = SvPVX(tmpsv); 462 } 463 else { 464 /* Assume no interpreter ==> single thread */ 465 if (__my_getenv_len_eqv != NULL) { 466 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char); 467 } 468 else { 469 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char); 470 } 471 buf = __my_getenv_len_eqv; 472 } 473 474 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1); 475 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) { 476 getcwd(buf,LNM$C_NAMLENGTH); 477 *len = strlen(buf); 478 return buf; 479 } 480 else { 481 if (sys) { 482 /* Impose security constraints only if tainting */ 483 secure = PL_curinterp ? PL_tainting : will_taint; 484 saverr = errno; savvmserr = vaxc$errno; 485 } 486 else { 487 secure = 0; 488 } 489 490 flags = 491 #ifdef SECURE_INTERNAL_GETENV 492 secure ? PERL__TRNENV_SECURE : 0 493 #else 494 0 495 #endif 496 ; 497 498 flags |= PERL__TRNENV_JOIN_SEARCHLIST; 499 500 if ((cp2 = strchr(lnm,';')) != NULL) { 501 strcpy(buf,lnm); 502 buf[cp2-lnm] = '\0'; 503 idx = strtoul(cp2+1,NULL,0); 504 lnm = buf; 505 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST; 506 } 507 508 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags); 509 510 /* Discard NOLOGNAM on internal calls since we're often looking 511 * for an optional name, and this "error" often shows up as the 512 * (bogus) exit status for a die() call later on. */ 513 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr); 514 return *len ? buf : Nullch; 515 } 516 517 } /* end of my_getenv_len() */ 518 /*}}}*/ 519 520 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *); 521 522 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); } 523 524 /*{{{ void prime_env_iter() */ 525 void 526 prime_env_iter(void) 527 /* Fill the %ENV associative array with all logical names we can 528 * find, in preparation for iterating over it. 529 */ 530 { 531 static int primed = 0; 532 HV *seenhv = NULL, *envhv; 533 SV *sv = NULL; 534 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch; 535 unsigned short int chan; 536 #ifndef CLI$M_TRUSTED 537 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */ 538 #endif 539 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED; 540 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0; 541 long int i; 542 bool have_sym = FALSE, have_lnm = FALSE; 543 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0}; 544 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:"); 545 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES"); 546 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM"); 547 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam); 548 #if defined(PERL_IMPLICIT_CONTEXT) 549 pTHX; 550 #endif 551 #if defined(USE_5005THREADS) || defined(USE_ITHREADS) 552 static perl_mutex primenv_mutex; 553 MUTEX_INIT(&primenv_mutex); 554 #endif 555 556 #if defined(PERL_IMPLICIT_CONTEXT) 557 /* We jump through these hoops because we can be called at */ 558 /* platform-specific initialization time, which is before anything is */ 559 /* set up--we can't even do a plain dTHX since that relies on the */ 560 /* interpreter structure to be initialized */ 561 #if defined(USE_5005THREADS) 562 if (PL_curinterp) { 563 aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv); 564 } else { 565 aTHX = NULL; 566 } 567 #else 568 if (PL_curinterp) { 569 aTHX = PERL_GET_INTERP; 570 } else { 571 aTHX = NULL; 572 } 573 #endif 574 #endif 575 576 if (primed || !PL_envgv) return; 577 MUTEX_LOCK(&primenv_mutex); 578 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; } 579 envhv = GvHVn(PL_envgv); 580 /* Perform a dummy fetch as an lval to insure that the hash table is 581 * set up. Otherwise, the hv_store() will turn into a nullop. */ 582 (void) hv_fetch(envhv,"DEFAULT",7,TRUE); 583 584 for (i = 0; env_tables[i]; i++) { 585 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) && 586 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1; 587 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1; 588 } 589 if (have_sym || have_lnm) { 590 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM; 591 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0)); 592 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0)); 593 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length)); 594 } 595 596 for (i--; i >= 0; i--) { 597 if (!str$case_blind_compare(env_tables[i],&crtlenv)) { 598 char *start; 599 int j; 600 for (j = 0; environ[j]; j++) { 601 if (!(start = strchr(environ[j],'='))) { 602 if (ckWARN(WARN_INTERNAL)) 603 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]); 604 } 605 else { 606 start++; 607 sv = newSVpv(start,0); 608 SvTAINTED_on(sv); 609 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0); 610 } 611 } 612 continue; 613 } 614 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) && 615 !str$case_blind_compare(&tmpdsc,&clisym)) { 616 strcpy(cmd,"Show Symbol/Global *"); 617 cmddsc.dsc$w_length = 20; 618 if (env_tables[i]->dsc$w_length == 12 && 619 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) && 620 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *"); 621 flags = defflags | CLI$M_NOLOGNAM; 622 } 623 else { 624 strcpy(cmd,"Show Logical *"); 625 if (str$case_blind_compare(env_tables[i],&fildevdsc)) { 626 strcat(cmd," /Table="); 627 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length); 628 cmddsc.dsc$w_length = strlen(cmd); 629 } 630 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */ 631 flags = defflags | CLI$M_NOCLISYM; 632 } 633 634 /* Create a new subprocess to execute each command, to exclude the 635 * remote possibility that someone could subvert a mbx or file used 636 * to write multiple commands to a single subprocess. 637 */ 638 do { 639 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs, 640 0,&riseandshine,0,0,&clidsc,&clitabdsc); 641 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */ 642 defflags &= ~CLI$M_TRUSTED; 643 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED)); 644 _ckvmssts(retsts); 645 if (!buf) Newx(buf,mbxbufsiz + 1,char); 646 if (seenhv) SvREFCNT_dec(seenhv); 647 seenhv = newHV(); 648 while (1) { 649 char *cp1, *cp2, *key; 650 unsigned long int sts, iosb[2], retlen, keylen; 651 register U32 hash; 652 653 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0); 654 if (sts & 1) sts = iosb[0] & 0xffff; 655 if (sts == SS$_ENDOFFILE) { 656 int wakect = 0; 657 while (substs == 0) { sys$hiber(); wakect++;} 658 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */ 659 _ckvmssts(substs); 660 break; 661 } 662 _ckvmssts(sts); 663 retlen = iosb[0] >> 16; 664 if (!retlen) continue; /* blank line */ 665 buf[retlen] = '\0'; 666 if (iosb[1] != subpid) { 667 if (iosb[1]) { 668 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf); 669 } 670 continue; 671 } 672 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL)) 673 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf); 674 675 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ; 676 if (*cp1 == '(' || /* Logical name table name */ 677 *cp1 == '=' /* Next eqv of searchlist */) continue; 678 if (*cp1 == '"') cp1++; 679 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ; 680 key = cp1; keylen = cp2 - cp1; 681 if (keylen && hv_exists(seenhv,key,keylen)) continue; 682 while (*cp2 && *cp2 != '=') cp2++; 683 while (*cp2 && *cp2 == '=') cp2++; 684 while (*cp2 && *cp2 == ' ') cp2++; 685 if (*cp2 == '"') { /* String translation; may embed "" */ 686 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ; 687 cp2++; cp1--; /* Skip "" surrounding translation */ 688 } 689 else { /* Numeric translation */ 690 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ; 691 cp1--; /* stop on last non-space char */ 692 } 693 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) { 694 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf); 695 continue; 696 } 697 PERL_HASH(hash,key,keylen); 698 699 if (cp1 == cp2 && *cp2 == '.') { 700 /* A single dot usually means an unprintable character, such as a null 701 * to indicate a zero-length value. Get the actual value to make sure. 702 */ 703 char lnm[LNM$C_NAMLENGTH+1]; 704 char eqv[LNM$C_NAMLENGTH+1]; 705 strncpy(lnm, key, keylen); 706 int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0); 707 sv = newSVpvn(eqv, strlen(eqv)); 708 } 709 else { 710 sv = newSVpvn(cp2,cp1 - cp2 + 1); 711 } 712 713 SvTAINTED_on(sv); 714 hv_store(envhv,key,keylen,sv,hash); 715 hv_store(seenhv,key,keylen,&PL_sv_yes,hash); 716 } 717 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */ 718 /* get the PPFs for this process, not the subprocess */ 719 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL}; 720 char eqv[LNM$C_NAMLENGTH+1]; 721 int trnlen, i; 722 for (i = 0; ppfs[i]; i++) { 723 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0); 724 sv = newSVpv(eqv,trnlen); 725 SvTAINTED_on(sv); 726 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0); 727 } 728 } 729 } 730 primed = 1; 731 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan)); 732 if (buf) Safefree(buf); 733 if (seenhv) SvREFCNT_dec(seenhv); 734 MUTEX_UNLOCK(&primenv_mutex); 735 return; 736 737 } /* end of prime_env_iter */ 738 /*}}}*/ 739 740 741 /*{{{ int vmssetenv(char *lnm, char *eqv)*/ 742 /* Define or delete an element in the same "environment" as 743 * vmstrnenv(). If an element is to be deleted, it's removed from 744 * the first place it's found. If it's to be set, it's set in the 745 * place designated by the first element of the table vector. 746 * Like setenv() returns 0 for success, non-zero on error. 747 */ 748 int 749 Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) 750 { 751 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2, *c; 752 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0; 753 int nseg = 0, j; 754 unsigned long int retsts, usermode = PSL$C_USER; 755 struct itmlst_3 *ile, *ilist; 756 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm}, 757 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0}, 758 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0}; 759 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM"); 760 $DESCRIPTOR(local,"_LOCAL"); 761 762 if (!lnm) { 763 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM); 764 return SS$_IVLOGNAM; 765 } 766 767 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) { 768 *cp2 = _toupper(*cp1); 769 if (cp1 - lnm > LNM$C_NAMLENGTH) { 770 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM); 771 return SS$_IVLOGNAM; 772 } 773 } 774 lnmdsc.dsc$w_length = cp1 - lnm; 775 if (!tabvec || !*tabvec) tabvec = env_tables; 776 777 if (!eqv) { /* we're deleting n element */ 778 for (curtab = 0; tabvec[curtab]; curtab++) { 779 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) { 780 int i; 781 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */ 782 if ((cp1 = strchr(environ[i],'=')) && 783 lnmdsc.dsc$w_length == (cp1 - environ[i]) && 784 !strncmp(environ[i],lnm,cp1 - environ[i])) { 785 #ifdef HAS_SETENV 786 return setenv(lnm,"",1) ? vaxc$errno : 0; 787 } 788 } 789 ivenv = 1; retsts = SS$_NOLOGNAM; 790 #else 791 if (ckWARN(WARN_INTERNAL)) 792 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm); 793 ivenv = 1; retsts = SS$_NOSUCHPGM; 794 break; 795 } 796 } 797 #endif 798 } 799 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) && 800 !str$case_blind_compare(&tmpdsc,&clisym)) { 801 unsigned int symtype; 802 if (tabvec[curtab]->dsc$w_length == 12 && 803 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) && 804 !str$case_blind_compare(&tmpdsc,&local)) 805 symtype = LIB$K_CLI_LOCAL_SYM; 806 else symtype = LIB$K_CLI_GLOBAL_SYM; 807 retsts = lib$delete_symbol(&lnmdsc,&symtype); 808 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; } 809 if (retsts == LIB$_NOSUCHSYM) continue; 810 break; 811 } 812 else if (!ivlnm) { 813 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */ 814 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; } 815 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break; 816 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */ 817 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break; 818 } 819 } 820 } 821 else { /* we're defining a value */ 822 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) { 823 #ifdef HAS_SETENV 824 return setenv(lnm,eqv,1) ? vaxc$errno : 0; 825 #else 826 if (ckWARN(WARN_INTERNAL)) 827 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv); 828 retsts = SS$_NOSUCHPGM; 829 #endif 830 } 831 else { 832 eqvdsc.dsc$a_pointer = eqv; 833 eqvdsc.dsc$w_length = strlen(eqv); 834 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) && 835 !str$case_blind_compare(&tmpdsc,&clisym)) { 836 unsigned int symtype; 837 if (tabvec[0]->dsc$w_length == 12 && 838 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) && 839 !str$case_blind_compare(&tmpdsc,&local)) 840 symtype = LIB$K_CLI_LOCAL_SYM; 841 else symtype = LIB$K_CLI_GLOBAL_SYM; 842 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype); 843 } 844 else { 845 if (!*eqv) eqvdsc.dsc$w_length = 1; 846 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) { 847 848 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH; 849 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) { 850 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes", 851 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1)); 852 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1); 853 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1; 854 } 855 856 Newx(ilist,nseg+1,struct itmlst_3); 857 ile = ilist; 858 if (!ile) { 859 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM); 860 return SS$_INSFMEM; 861 } 862 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1))); 863 864 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) { 865 ile->itmcode = LNM$_STRING; 866 ile->bufadr = c; 867 if ((j+1) == nseg) { 868 ile->buflen = strlen(c); 869 /* in case we are truncating one that's too long */ 870 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH; 871 } 872 else { 873 ile->buflen = LNM$C_NAMLENGTH; 874 } 875 } 876 877 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist); 878 Safefree (ilist); 879 } 880 else { 881 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0); 882 } 883 } 884 } 885 } 886 if (!(retsts & 1)) { 887 switch (retsts) { 888 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM: 889 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB: 890 set_errno(EVMSERR); break; 891 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM: 892 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM: 893 set_errno(EINVAL); break; 894 case SS$_NOPRIV: 895 set_errno(EACCES); 896 default: 897 _ckvmssts(retsts); 898 set_errno(EVMSERR); 899 } 900 set_vaxc_errno(retsts); 901 return (int) retsts || 44; /* retsts should never be 0, but just in case */ 902 } 903 else { 904 /* We reset error values on success because Perl does an hv_fetch() 905 * before each hv_store(), and if the thing we're setting didn't 906 * previously exist, we've got a leftover error message. (Of course, 907 * this fails in the face of 908 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo'; 909 * in that the error reported in $! isn't spurious, 910 * but it's right more often than not.) 911 */ 912 set_errno(0); set_vaxc_errno(retsts); 913 return 0; 914 } 915 916 } /* end of vmssetenv() */ 917 /*}}}*/ 918 919 /*{{{ void my_setenv(char *lnm, char *eqv)*/ 920 /* This has to be a function since there's a prototype for it in proto.h */ 921 void 922 Perl_my_setenv(pTHX_ char *lnm,char *eqv) 923 { 924 if (lnm && *lnm) { 925 int len = strlen(lnm); 926 if (len == 7) { 927 char uplnm[8]; 928 int i; 929 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]); 930 if (!strcmp(uplnm,"DEFAULT")) { 931 if (eqv && *eqv) chdir(eqv); 932 return; 933 } 934 } 935 #ifndef RTL_USES_UTC 936 if (len == 6 || len == 2) { 937 char uplnm[7]; 938 int i; 939 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]); 940 uplnm[len] = '\0'; 941 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1; 942 if (!strcmp(uplnm,"TZ")) tz_updated = 1; 943 } 944 #endif 945 } 946 (void) vmssetenv(lnm,eqv,NULL); 947 } 948 /*}}}*/ 949 950 /*{{{static void vmssetuserlnm(char *name, char *eqv); */ 951 /* vmssetuserlnm 952 * sets a user-mode logical in the process logical name table 953 * used for redirection of sys$error 954 */ 955 void 956 Perl_vmssetuserlnm(pTHX_ char *name, char *eqv) 957 { 958 $DESCRIPTOR(d_tab, "LNM$PROCESS"); 959 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0}; 960 unsigned long int iss, attr = LNM$M_CONFINE; 961 unsigned char acmode = PSL$C_USER; 962 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0}, 963 {0, 0, 0, 0}}; 964 d_name.dsc$a_pointer = name; 965 d_name.dsc$w_length = strlen(name); 966 967 lnmlst[0].buflen = strlen(eqv); 968 lnmlst[0].bufadr = eqv; 969 970 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst); 971 if (!(iss&1)) lib$signal(iss); 972 } 973 /*}}}*/ 974 975 976 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/ 977 /* my_crypt - VMS password hashing 978 * my_crypt() provides an interface compatible with the Unix crypt() 979 * C library function, and uses sys$hash_password() to perform VMS 980 * password hashing. The quadword hashed password value is returned 981 * as a NUL-terminated 8 character string. my_crypt() does not change 982 * the case of its string arguments; in order to match the behavior 983 * of LOGINOUT et al., alphabetic characters in both arguments must 984 * be upcased by the caller. 985 */ 986 char * 987 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname) 988 { 989 # ifndef UAI$C_PREFERRED_ALGORITHM 990 # define UAI$C_PREFERRED_ALGORITHM 127 991 # endif 992 unsigned char alg = UAI$C_PREFERRED_ALGORITHM; 993 unsigned short int salt = 0; 994 unsigned long int sts; 995 struct const_dsc { 996 unsigned short int dsc$w_length; 997 unsigned char dsc$b_type; 998 unsigned char dsc$b_class; 999 const char * dsc$a_pointer; 1000 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}, 1001 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; 1002 struct itmlst_3 uailst[3] = { 1003 { sizeof alg, UAI$_ENCRYPT, &alg, 0}, 1004 { sizeof salt, UAI$_SALT, &salt, 0}, 1005 { 0, 0, NULL, NULL}}; 1006 static char hash[9]; 1007 1008 usrdsc.dsc$w_length = strlen(usrname); 1009 usrdsc.dsc$a_pointer = usrname; 1010 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) { 1011 switch (sts) { 1012 case SS$_NOGRPPRV: case SS$_NOSYSPRV: 1013 set_errno(EACCES); 1014 break; 1015 case RMS$_RNF: 1016 set_errno(ESRCH); /* There isn't a Unix no-such-user error */ 1017 break; 1018 default: 1019 set_errno(EVMSERR); 1020 } 1021 set_vaxc_errno(sts); 1022 if (sts != RMS$_RNF) return NULL; 1023 } 1024 1025 txtdsc.dsc$w_length = strlen(textpasswd); 1026 txtdsc.dsc$a_pointer = textpasswd; 1027 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) { 1028 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL; 1029 } 1030 1031 return (char *) hash; 1032 1033 } /* end of my_crypt() */ 1034 /*}}}*/ 1035 1036 1037 static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned); 1038 static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int); 1039 static char *mp_do_tovmsspec(pTHX_ char *, char *, int); 1040 1041 /*{{{int do_rmdir(char *name)*/ 1042 int 1043 Perl_do_rmdir(pTHX_ char *name) 1044 { 1045 char dirfile[NAM$C_MAXRSS+1]; 1046 int retval; 1047 Stat_t st; 1048 1049 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1; 1050 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1; 1051 else retval = kill_file(dirfile); 1052 return retval; 1053 1054 } /* end of do_rmdir */ 1055 /*}}}*/ 1056 1057 /* kill_file 1058 * Delete any file to which user has control access, regardless of whether 1059 * delete access is explicitly allowed. 1060 * Limitations: User must have write access to parent directory. 1061 * Does not block signals or ASTs; if interrupted in midstream 1062 * may leave file with an altered ACL. 1063 * HANDLE WITH CARE! 1064 */ 1065 /*{{{int kill_file(char *name)*/ 1066 int 1067 Perl_kill_file(pTHX_ char *name) 1068 { 1069 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1]; 1070 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE; 1071 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1; 1072 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; 1073 struct myacedef { 1074 unsigned char myace$b_length; 1075 unsigned char myace$b_type; 1076 unsigned short int myace$w_flags; 1077 unsigned long int myace$l_access; 1078 unsigned long int myace$l_ident; 1079 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 1080 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0}, 1081 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0}; 1082 struct itmlst_3 1083 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0}, 1084 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}}, 1085 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}}, 1086 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}}, 1087 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}}, 1088 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}}; 1089 1090 /* Expand the input spec using RMS, since the CRTL remove() and 1091 * system services won't do this by themselves, so we may miss 1092 * a file "hiding" behind a logical name or search list. */ 1093 if (do_tovmsspec(name,vmsname,0) == NULL) return -1; 1094 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1; 1095 if (!remove(rspec)) return 0; /* Can we just get rid of it? */ 1096 /* If not, can changing protections help? */ 1097 if (vaxc$errno != RMS$_PRV) return -1; 1098 1099 /* No, so we get our own UIC to use as a rights identifier, 1100 * and the insert an ACE at the head of the ACL which allows us 1101 * to delete the file. 1102 */ 1103 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0)); 1104 fildsc.dsc$w_length = strlen(rspec); 1105 fildsc.dsc$a_pointer = rspec; 1106 cxt = 0; 1107 newace.myace$l_ident = oldace.myace$l_ident; 1108 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) { 1109 switch (aclsts) { 1110 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT: 1111 set_errno(ENOENT); break; 1112 case RMS$_DIR: 1113 set_errno(ENOTDIR); break; 1114 case RMS$_DEV: 1115 set_errno(ENODEV); break; 1116 case RMS$_SYN: case SS$_INVFILFOROP: 1117 set_errno(EINVAL); break; 1118 case RMS$_PRV: 1119 set_errno(EACCES); break; 1120 default: 1121 _ckvmssts(aclsts); 1122 } 1123 set_vaxc_errno(aclsts); 1124 return -1; 1125 } 1126 /* Grab any existing ACEs with this identifier in case we fail */ 1127 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt); 1128 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY 1129 || fndsts == SS$_NOMOREACE ) { 1130 /* Add the new ACE . . . */ 1131 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1)) 1132 goto yourroom; 1133 if ((rmsts = remove(name))) { 1134 /* We blew it - dir with files in it, no write priv for 1135 * parent directory, etc. Put things back the way they were. */ 1136 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1)) 1137 goto yourroom; 1138 if (fndsts & 1) { 1139 addlst[0].bufadr = &oldace; 1140 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1)) 1141 goto yourroom; 1142 } 1143 } 1144 } 1145 1146 yourroom: 1147 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0); 1148 /* We just deleted it, so of course it's not there. Some versions of 1149 * VMS seem to return success on the unlock operation anyhow (after all 1150 * the unlock is successful), but others don't. 1151 */ 1152 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL; 1153 if (aclsts & 1) aclsts = fndsts; 1154 if (!(aclsts & 1)) { 1155 set_errno(EVMSERR); 1156 set_vaxc_errno(aclsts); 1157 return -1; 1158 } 1159 1160 return rmsts; 1161 1162 } /* end of kill_file() */ 1163 /*}}}*/ 1164 1165 1166 /*{{{int my_mkdir(char *,Mode_t)*/ 1167 int 1168 Perl_my_mkdir(pTHX_ char *dir, Mode_t mode) 1169 { 1170 STRLEN dirlen = strlen(dir); 1171 1172 /* zero length string sometimes gives ACCVIO */ 1173 if (dirlen == 0) return -1; 1174 1175 /* CRTL mkdir() doesn't tolerate trailing /, since that implies 1176 * null file name/type. However, it's commonplace under Unix, 1177 * so we'll allow it for a gain in portability. 1178 */ 1179 if (dir[dirlen-1] == '/') { 1180 char *newdir = savepvn(dir,dirlen-1); 1181 int ret = mkdir(newdir,mode); 1182 Safefree(newdir); 1183 return ret; 1184 } 1185 else return mkdir(dir,mode); 1186 } /* end of my_mkdir */ 1187 /*}}}*/ 1188 1189 /*{{{int my_chdir(char *)*/ 1190 int 1191 Perl_my_chdir(pTHX_ char *dir) 1192 { 1193 STRLEN dirlen = strlen(dir); 1194 1195 /* zero length string sometimes gives ACCVIO */ 1196 if (dirlen == 0) return -1; 1197 1198 /* some versions of CRTL chdir() doesn't tolerate trailing /, since 1199 * that implies 1200 * null file name/type. However, it's commonplace under Unix, 1201 * so we'll allow it for a gain in portability. 1202 */ 1203 if (dir[dirlen-1] == '/') { 1204 char *newdir = savepvn(dir,dirlen-1); 1205 int ret = chdir(newdir); 1206 Safefree(newdir); 1207 return ret; 1208 } 1209 else return chdir(dir); 1210 } /* end of my_chdir */ 1211 /*}}}*/ 1212 1213 1214 /*{{{FILE *my_tmpfile()*/ 1215 FILE * 1216 my_tmpfile(void) 1217 { 1218 FILE *fp; 1219 char *cp; 1220 1221 if ((fp = tmpfile())) return fp; 1222 1223 Newx(cp,L_tmpnam+24,char); 1224 strcpy(cp,"Sys$Scratch:"); 1225 tmpnam(cp+strlen(cp)); 1226 strcat(cp,".Perltmp"); 1227 fp = fopen(cp,"w+","fop=dlt"); 1228 Safefree(cp); 1229 return fp; 1230 } 1231 /*}}}*/ 1232 1233 1234 #ifndef HOMEGROWN_POSIX_SIGNALS 1235 /* 1236 * The C RTL's sigaction fails to check for invalid signal numbers so we 1237 * help it out a bit. The docs are correct, but the actual routine doesn't 1238 * do what the docs say it will. 1239 */ 1240 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/ 1241 int 1242 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act, 1243 struct sigaction* oact) 1244 { 1245 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) { 1246 SETERRNO(EINVAL, SS$_INVARG); 1247 return -1; 1248 } 1249 return sigaction(sig, act, oact); 1250 } 1251 /*}}}*/ 1252 #endif 1253 1254 #ifdef KILL_BY_SIGPRC 1255 #include <errnodef.h> 1256 1257 /* We implement our own kill() using the undocumented system service 1258 sys$sigprc for one of two reasons: 1259 1260 1.) If the kill() in an older CRTL uses sys$forcex, causing the 1261 target process to do a sys$exit, which usually can't be handled 1262 gracefully...certainly not by Perl and the %SIG{} mechanism. 1263 1264 2.) If the kill() in the CRTL can't be called from a signal 1265 handler without disappearing into the ether, i.e., the signal 1266 it purportedly sends is never trapped. Still true as of VMS 7.3. 1267 1268 sys$sigprc has the same parameters as sys$forcex, but throws an exception 1269 in the target process rather than calling sys$exit. 1270 1271 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg 1272 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't 1273 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc 1274 with condition codes C$_SIG0+nsig*8, catching the exception on the 1275 target process and resignaling with appropriate arguments. 1276 1277 But we don't have that VMS 7.0+ exception handler, so if you 1278 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well. 1279 1280 Also note that SIGTERM is listed in the docs as being "unimplemented", 1281 yet always seems to be signaled with a VMS condition code of 4 (and 1282 correctly handled for that code). So we hardwire it in. 1283 1284 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal 1285 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather 1286 than signalling with an unrecognized (and unhandled by CRTL) code. 1287 */ 1288 1289 #define _MY_SIG_MAX 17 1290 1291 unsigned int 1292 Perl_sig_to_vmscondition(int sig) 1293 { 1294 static unsigned int sig_code[_MY_SIG_MAX+1] = 1295 { 1296 0, /* 0 ZERO */ 1297 SS$_HANGUP, /* 1 SIGHUP */ 1298 SS$_CONTROLC, /* 2 SIGINT */ 1299 SS$_CONTROLY, /* 3 SIGQUIT */ 1300 SS$_RADRMOD, /* 4 SIGILL */ 1301 SS$_BREAK, /* 5 SIGTRAP */ 1302 SS$_OPCCUS, /* 6 SIGABRT */ 1303 SS$_COMPAT, /* 7 SIGEMT */ 1304 #ifdef __VAX 1305 SS$_FLTOVF, /* 8 SIGFPE VAX */ 1306 #else 1307 SS$_HPARITH, /* 8 SIGFPE AXP */ 1308 #endif 1309 SS$_ABORT, /* 9 SIGKILL */ 1310 SS$_ACCVIO, /* 10 SIGBUS */ 1311 SS$_ACCVIO, /* 11 SIGSEGV */ 1312 SS$_BADPARAM, /* 12 SIGSYS */ 1313 SS$_NOMBX, /* 13 SIGPIPE */ 1314 SS$_ASTFLT, /* 14 SIGALRM */ 1315 4, /* 15 SIGTERM */ 1316 0, /* 16 SIGUSR1 */ 1317 0 /* 17 SIGUSR2 */ 1318 }; 1319 1320 #if __VMS_VER >= 60200000 1321 static int initted = 0; 1322 if (!initted) { 1323 initted = 1; 1324 sig_code[16] = C$_SIGUSR1; 1325 sig_code[17] = C$_SIGUSR2; 1326 } 1327 #endif 1328 1329 if (sig < _SIG_MIN) return 0; 1330 if (sig > _MY_SIG_MAX) return 0; 1331 return sig_code[sig]; 1332 } 1333 1334 1335 int 1336 Perl_my_kill(int pid, int sig) 1337 { 1338 dTHX; 1339 int iss; 1340 unsigned int code; 1341 int sys$sigprc(unsigned int *pidadr, 1342 struct dsc$descriptor_s *prcname, 1343 unsigned int code); 1344 1345 code = Perl_sig_to_vmscondition(sig); 1346 1347 if (!pid || !code) { 1348 return -1; 1349 } 1350 1351 iss = sys$sigprc((unsigned int *)&pid,0,code); 1352 if (iss&1) return 0; 1353 1354 switch (iss) { 1355 case SS$_NOPRIV: 1356 set_errno(EPERM); break; 1357 case SS$_NONEXPR: 1358 case SS$_NOSUCHNODE: 1359 case SS$_UNREACHABLE: 1360 set_errno(ESRCH); break; 1361 case SS$_INSFMEM: 1362 set_errno(ENOMEM); break; 1363 default: 1364 _ckvmssts(iss); 1365 set_errno(EVMSERR); 1366 } 1367 set_vaxc_errno(iss); 1368 1369 return -1; 1370 } 1371 #endif 1372 1373 /* default piping mailbox size */ 1374 #define PERL_BUFSIZ 512 1375 1376 1377 static void 1378 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc) 1379 { 1380 unsigned long int mbxbufsiz; 1381 static unsigned long int syssize = 0; 1382 unsigned long int dviitm = DVI$_DEVNAM; 1383 char csize[LNM$C_NAMLENGTH+1]; 1384 1385 if (!syssize) { 1386 unsigned long syiitm = SYI$_MAXBUF; 1387 /* 1388 * Get the SYSGEN parameter MAXBUF 1389 * 1390 * If the logical 'PERL_MBX_SIZE' is defined 1391 * use the value of the logical instead of PERL_BUFSIZ, but 1392 * keep the size between 128 and MAXBUF. 1393 * 1394 */ 1395 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0)); 1396 } 1397 1398 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) { 1399 mbxbufsiz = atoi(csize); 1400 } else { 1401 mbxbufsiz = PERL_BUFSIZ; 1402 } 1403 if (mbxbufsiz < 128) mbxbufsiz = 128; 1404 if (mbxbufsiz > syssize) mbxbufsiz = syssize; 1405 1406 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0)); 1407 1408 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length)); 1409 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0'; 1410 1411 } /* end of create_mbx() */ 1412 1413 1414 /*{{{ my_popen and my_pclose*/ 1415 1416 typedef struct _iosb IOSB; 1417 typedef struct _iosb* pIOSB; 1418 typedef struct _pipe Pipe; 1419 typedef struct _pipe* pPipe; 1420 typedef struct pipe_details Info; 1421 typedef struct pipe_details* pInfo; 1422 typedef struct _srqp RQE; 1423 typedef struct _srqp* pRQE; 1424 typedef struct _tochildbuf CBuf; 1425 typedef struct _tochildbuf* pCBuf; 1426 1427 struct _iosb { 1428 unsigned short status; 1429 unsigned short count; 1430 unsigned long dvispec; 1431 }; 1432 1433 #pragma member_alignment save 1434 #pragma nomember_alignment quadword 1435 struct _srqp { /* VMS self-relative queue entry */ 1436 unsigned long qptr[2]; 1437 }; 1438 #pragma member_alignment restore 1439 static RQE RQE_ZERO = {0,0}; 1440 1441 struct _tochildbuf { 1442 RQE q; 1443 int eof; 1444 unsigned short size; 1445 char *buf; 1446 }; 1447 1448 struct _pipe { 1449 RQE free; 1450 RQE wait; 1451 int fd_out; 1452 unsigned short chan_in; 1453 unsigned short chan_out; 1454 char *buf; 1455 unsigned int bufsize; 1456 IOSB iosb; 1457 IOSB iosb2; 1458 int *pipe_done; 1459 int retry; 1460 int type; 1461 int shut_on_empty; 1462 int need_wake; 1463 pPipe *home; 1464 pInfo info; 1465 pCBuf curr; 1466 pCBuf curr2; 1467 #if defined(PERL_IMPLICIT_CONTEXT) 1468 void *thx; /* Either a thread or an interpreter */ 1469 /* pointer, depending on how we're built */ 1470 #endif 1471 }; 1472 1473 1474 struct pipe_details 1475 { 1476 pInfo next; 1477 PerlIO *fp; /* file pointer to pipe mailbox */ 1478 int useFILE; /* using stdio, not perlio */ 1479 int pid; /* PID of subprocess */ 1480 int mode; /* == 'r' if pipe open for reading */ 1481 int done; /* subprocess has completed */ 1482 int waiting; /* waiting for completion/closure */ 1483 int closing; /* my_pclose is closing this pipe */ 1484 unsigned long completion; /* termination status of subprocess */ 1485 pPipe in; /* pipe in to sub */ 1486 pPipe out; /* pipe out of sub */ 1487 pPipe err; /* pipe of sub's sys$error */ 1488 int in_done; /* true when in pipe finished */ 1489 int out_done; 1490 int err_done; 1491 }; 1492 1493 struct exit_control_block 1494 { 1495 struct exit_control_block *flink; 1496 unsigned long int (*exit_routine)(); 1497 unsigned long int arg_count; 1498 unsigned long int *status_address; 1499 unsigned long int exit_status; 1500 }; 1501 1502 typedef struct _closed_pipes Xpipe; 1503 typedef struct _closed_pipes* pXpipe; 1504 1505 struct _closed_pipes { 1506 int pid; /* PID of subprocess */ 1507 unsigned long completion; /* termination status of subprocess */ 1508 }; 1509 #define NKEEPCLOSED 50 1510 static Xpipe closed_list[NKEEPCLOSED]; 1511 static int closed_index = 0; 1512 static int closed_num = 0; 1513 1514 #define RETRY_DELAY "0 ::0.20" 1515 #define MAX_RETRY 50 1516 1517 static int pipe_ef = 0; /* first call to safe_popen inits these*/ 1518 static unsigned long mypid; 1519 static unsigned long delaytime[2]; 1520 1521 static pInfo open_pipes = NULL; 1522 static $DESCRIPTOR(nl_desc, "NL:"); 1523 1524 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */ 1525 1526 1527 1528 static unsigned long int 1529 pipe_exit_routine(pTHX) 1530 { 1531 pInfo info; 1532 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT; 1533 int sts, did_stuff, need_eof, j; 1534 1535 /* 1536 flush any pending i/o 1537 */ 1538 info = open_pipes; 1539 while (info) { 1540 if (info->fp) { 1541 if (!info->useFILE) 1542 PerlIO_flush(info->fp); /* first, flush data */ 1543 else 1544 fflush((FILE *)info->fp); 1545 } 1546 info = info->next; 1547 } 1548 1549 /* 1550 next we try sending an EOF...ignore if doesn't work, make sure we 1551 don't hang 1552 */ 1553 did_stuff = 0; 1554 info = open_pipes; 1555 1556 while (info) { 1557 int need_eof; 1558 _ckvmssts(sys$setast(0)); 1559 if (info->in && !info->in->shut_on_empty) { 1560 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0, 1561 0, 0, 0, 0, 0, 0)); 1562 info->waiting = 1; 1563 did_stuff = 1; 1564 } 1565 _ckvmssts(sys$setast(1)); 1566 info = info->next; 1567 } 1568 1569 /* wait for EOF to have effect, up to ~ 30 sec [default] */ 1570 1571 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) { 1572 int nwait = 0; 1573 1574 info = open_pipes; 1575 while (info) { 1576 _ckvmssts(sys$setast(0)); 1577 if (info->waiting && info->done) 1578 info->waiting = 0; 1579 nwait += info->waiting; 1580 _ckvmssts(sys$setast(1)); 1581 info = info->next; 1582 } 1583 if (!nwait) break; 1584 sleep(1); 1585 } 1586 1587 did_stuff = 0; 1588 info = open_pipes; 1589 while (info) { 1590 _ckvmssts(sys$setast(0)); 1591 if (!info->done) { /* Tap them gently on the shoulder . . .*/ 1592 sts = sys$forcex(&info->pid,0,&abort); 1593 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts); 1594 did_stuff = 1; 1595 } 1596 _ckvmssts(sys$setast(1)); 1597 info = info->next; 1598 } 1599 1600 /* again, wait for effect */ 1601 1602 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) { 1603 int nwait = 0; 1604 1605 info = open_pipes; 1606 while (info) { 1607 _ckvmssts(sys$setast(0)); 1608 if (info->waiting && info->done) 1609 info->waiting = 0; 1610 nwait += info->waiting; 1611 _ckvmssts(sys$setast(1)); 1612 info = info->next; 1613 } 1614 if (!nwait) break; 1615 sleep(1); 1616 } 1617 1618 info = open_pipes; 1619 while (info) { 1620 _ckvmssts(sys$setast(0)); 1621 if (!info->done) { /* We tried to be nice . . . */ 1622 sts = sys$delprc(&info->pid,0); 1623 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts); 1624 } 1625 _ckvmssts(sys$setast(1)); 1626 info = info->next; 1627 } 1628 1629 while(open_pipes) { 1630 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno; 1631 else if (!(sts & 1)) retsts = sts; 1632 } 1633 return retsts; 1634 } 1635 1636 static struct exit_control_block pipe_exitblock = 1637 {(struct exit_control_block *) 0, 1638 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0}; 1639 1640 static void pipe_mbxtofd_ast(pPipe p); 1641 static void pipe_tochild1_ast(pPipe p); 1642 static void pipe_tochild2_ast(pPipe p); 1643 1644 static void 1645 popen_completion_ast(pInfo info) 1646 { 1647 pInfo i = open_pipes; 1648 int iss; 1649 pXpipe x; 1650 1651 info->completion &= 0x0FFFFFFF; /* strip off "control" field */ 1652 closed_list[closed_index].pid = info->pid; 1653 closed_list[closed_index].completion = info->completion; 1654 closed_index++; 1655 if (closed_index == NKEEPCLOSED) 1656 closed_index = 0; 1657 closed_num++; 1658 1659 while (i) { 1660 if (i == info) break; 1661 i = i->next; 1662 } 1663 if (!i) return; /* unlinked, probably freed too */ 1664 1665 info->done = TRUE; 1666 1667 /* 1668 Writing to subprocess ... 1669 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe 1670 1671 chan_out may be waiting for "done" flag, or hung waiting 1672 for i/o completion to child...cancel the i/o. This will 1673 put it into "snarf mode" (done but no EOF yet) that discards 1674 input. 1675 1676 Output from subprocess (stdout, stderr) needs to be flushed and 1677 shut down. We try sending an EOF, but if the mbx is full the pipe 1678 routine should still catch the "shut_on_empty" flag, telling it to 1679 use immediate-style reads so that "mbx empty" -> EOF. 1680 1681 1682 */ 1683 if (info->in && !info->in_done) { /* only for mode=w */ 1684 if (info->in->shut_on_empty && info->in->need_wake) { 1685 info->in->need_wake = FALSE; 1686 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0)); 1687 } else { 1688 _ckvmssts_noperl(sys$cancel(info->in->chan_out)); 1689 } 1690 } 1691 1692 if (info->out && !info->out_done) { /* were we also piping output? */ 1693 info->out->shut_on_empty = TRUE; 1694 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0); 1695 if (iss == SS$_MBFULL) iss = SS$_NORMAL; 1696 _ckvmssts_noperl(iss); 1697 } 1698 1699 if (info->err && !info->err_done) { /* we were piping stderr */ 1700 info->err->shut_on_empty = TRUE; 1701 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0); 1702 if (iss == SS$_MBFULL) iss = SS$_NORMAL; 1703 _ckvmssts_noperl(iss); 1704 } 1705 _ckvmssts_noperl(sys$setef(pipe_ef)); 1706 1707 } 1708 1709 static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd); 1710 static void vms_execfree(struct dsc$descriptor_s *vmscmd); 1711 1712 /* 1713 we actually differ from vmstrnenv since we use this to 1714 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really* 1715 are pointing to the same thing 1716 */ 1717 1718 static unsigned short 1719 popen_translate(pTHX_ char *logical, char *result) 1720 { 1721 int iss; 1722 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE"); 1723 $DESCRIPTOR(d_log,""); 1724 struct _il3 { 1725 unsigned short length; 1726 unsigned short code; 1727 char * buffer_addr; 1728 unsigned short *retlenaddr; 1729 } itmlst[2]; 1730 unsigned short l, ifi; 1731 1732 d_log.dsc$a_pointer = logical; 1733 d_log.dsc$w_length = strlen(logical); 1734 1735 itmlst[0].code = LNM$_STRING; 1736 itmlst[0].length = 255; 1737 itmlst[0].buffer_addr = result; 1738 itmlst[0].retlenaddr = &l; 1739 1740 itmlst[1].code = 0; 1741 itmlst[1].length = 0; 1742 itmlst[1].buffer_addr = 0; 1743 itmlst[1].retlenaddr = 0; 1744 1745 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst); 1746 if (iss == SS$_NOLOGNAM) { 1747 iss = SS$_NORMAL; 1748 l = 0; 1749 } 1750 if (!(iss&1)) lib$signal(iss); 1751 result[l] = '\0'; 1752 /* 1753 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI) 1754 strip it off and return the ifi, if any 1755 */ 1756 ifi = 0; 1757 if (result[0] == 0x1b && result[1] == 0x00) { 1758 memcpy(&ifi,result+2,2); 1759 strcpy(result,result+4); 1760 } 1761 return ifi; /* this is the RMS internal file id */ 1762 } 1763 1764 static void pipe_infromchild_ast(pPipe p); 1765 1766 /* 1767 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate 1768 inside an AST routine without worrying about reentrancy and which Perl 1769 memory allocator is being used. 1770 1771 We read data and queue up the buffers, then spit them out one at a 1772 time to the output mailbox when the output mailbox is ready for one. 1773 1774 */ 1775 #define INITIAL_TOCHILDQUEUE 2 1776 1777 static pPipe 1778 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx) 1779 { 1780 pPipe p; 1781 pCBuf b; 1782 char mbx1[64], mbx2[64]; 1783 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T, 1784 DSC$K_CLASS_S, mbx1}, 1785 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T, 1786 DSC$K_CLASS_S, mbx2}; 1787 unsigned int dviitm = DVI$_DEVBUFSIZ; 1788 int j, n; 1789 1790 Newx(p, 1, Pipe); 1791 1792 create_mbx(aTHX_ &p->chan_in , &d_mbx1); 1793 create_mbx(aTHX_ &p->chan_out, &d_mbx2); 1794 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize)); 1795 1796 p->buf = 0; 1797 p->shut_on_empty = FALSE; 1798 p->need_wake = FALSE; 1799 p->type = 0; 1800 p->retry = 0; 1801 p->iosb.status = SS$_NORMAL; 1802 p->iosb2.status = SS$_NORMAL; 1803 p->free = RQE_ZERO; 1804 p->wait = RQE_ZERO; 1805 p->curr = 0; 1806 p->curr2 = 0; 1807 p->info = 0; 1808 #ifdef PERL_IMPLICIT_CONTEXT 1809 p->thx = aTHX; 1810 #endif 1811 1812 n = sizeof(CBuf) + p->bufsize; 1813 1814 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) { 1815 _ckvmssts(lib$get_vm(&n, &b)); 1816 b->buf = (char *) b + sizeof(CBuf); 1817 _ckvmssts(lib$insqhi(b, &p->free)); 1818 } 1819 1820 pipe_tochild2_ast(p); 1821 pipe_tochild1_ast(p); 1822 strcpy(wmbx, mbx1); 1823 strcpy(rmbx, mbx2); 1824 return p; 1825 } 1826 1827 /* reads the MBX Perl is writing, and queues */ 1828 1829 static void 1830 pipe_tochild1_ast(pPipe p) 1831 { 1832 pCBuf b = p->curr; 1833 int iss = p->iosb.status; 1834 int eof = (iss == SS$_ENDOFFILE); 1835 #ifdef PERL_IMPLICIT_CONTEXT 1836 pTHX = p->thx; 1837 #endif 1838 1839 if (p->retry) { 1840 if (eof) { 1841 p->shut_on_empty = TRUE; 1842 b->eof = TRUE; 1843 _ckvmssts(sys$dassgn(p->chan_in)); 1844 } else { 1845 _ckvmssts(iss); 1846 } 1847 1848 b->eof = eof; 1849 b->size = p->iosb.count; 1850 _ckvmssts(lib$insqhi(b, &p->wait)); 1851 if (p->need_wake) { 1852 p->need_wake = FALSE; 1853 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0)); 1854 } 1855 } else { 1856 p->retry = 1; /* initial call */ 1857 } 1858 1859 if (eof) { /* flush the free queue, return when done */ 1860 int n = sizeof(CBuf) + p->bufsize; 1861 while (1) { 1862 iss = lib$remqti(&p->free, &b); 1863 if (iss == LIB$_QUEWASEMP) return; 1864 _ckvmssts(iss); 1865 _ckvmssts(lib$free_vm(&n, &b)); 1866 } 1867 } 1868 1869 iss = lib$remqti(&p->free, &b); 1870 if (iss == LIB$_QUEWASEMP) { 1871 int n = sizeof(CBuf) + p->bufsize; 1872 _ckvmssts(lib$get_vm(&n, &b)); 1873 b->buf = (char *) b + sizeof(CBuf); 1874 } else { 1875 _ckvmssts(iss); 1876 } 1877 1878 p->curr = b; 1879 iss = sys$qio(0,p->chan_in, 1880 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0), 1881 &p->iosb, 1882 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0); 1883 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL; 1884 _ckvmssts(iss); 1885 } 1886 1887 1888 /* writes queued buffers to output, waits for each to complete before 1889 doing the next */ 1890 1891 static void 1892 pipe_tochild2_ast(pPipe p) 1893 { 1894 pCBuf b = p->curr2; 1895 int iss = p->iosb2.status; 1896 int n = sizeof(CBuf) + p->bufsize; 1897 int done = (p->info && p->info->done) || 1898 iss == SS$_CANCEL || iss == SS$_ABORT; 1899 #if defined(PERL_IMPLICIT_CONTEXT) 1900 pTHX = p->thx; 1901 #endif 1902 1903 do { 1904 if (p->type) { /* type=1 has old buffer, dispose */ 1905 if (p->shut_on_empty) { 1906 _ckvmssts(lib$free_vm(&n, &b)); 1907 } else { 1908 _ckvmssts(lib$insqhi(b, &p->free)); 1909 } 1910 p->type = 0; 1911 } 1912 1913 iss = lib$remqti(&p->wait, &b); 1914 if (iss == LIB$_QUEWASEMP) { 1915 if (p->shut_on_empty) { 1916 if (done) { 1917 _ckvmssts(sys$dassgn(p->chan_out)); 1918 *p->pipe_done = TRUE; 1919 _ckvmssts(sys$setef(pipe_ef)); 1920 } else { 1921 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, 1922 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0)); 1923 } 1924 return; 1925 } 1926 p->need_wake = TRUE; 1927 return; 1928 } 1929 _ckvmssts(iss); 1930 p->type = 1; 1931 } while (done); 1932 1933 1934 p->curr2 = b; 1935 if (b->eof) { 1936 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, 1937 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0)); 1938 } else { 1939 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK, 1940 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0)); 1941 } 1942 1943 return; 1944 1945 } 1946 1947 1948 static pPipe 1949 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx) 1950 { 1951 pPipe p; 1952 char mbx1[64], mbx2[64]; 1953 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T, 1954 DSC$K_CLASS_S, mbx1}, 1955 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T, 1956 DSC$K_CLASS_S, mbx2}; 1957 unsigned int dviitm = DVI$_DEVBUFSIZ; 1958 1959 Newx(p, 1, Pipe); 1960 create_mbx(aTHX_ &p->chan_in , &d_mbx1); 1961 create_mbx(aTHX_ &p->chan_out, &d_mbx2); 1962 1963 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize)); 1964 Newx(p->buf, p->bufsize, char); 1965 p->shut_on_empty = FALSE; 1966 p->info = 0; 1967 p->type = 0; 1968 p->iosb.status = SS$_NORMAL; 1969 #if defined(PERL_IMPLICIT_CONTEXT) 1970 p->thx = aTHX; 1971 #endif 1972 pipe_infromchild_ast(p); 1973 1974 strcpy(wmbx, mbx1); 1975 strcpy(rmbx, mbx2); 1976 return p; 1977 } 1978 1979 static void 1980 pipe_infromchild_ast(pPipe p) 1981 { 1982 int iss = p->iosb.status; 1983 int eof = (iss == SS$_ENDOFFILE); 1984 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0)); 1985 int kideof = (eof && (p->iosb.dvispec == p->info->pid)); 1986 #if defined(PERL_IMPLICIT_CONTEXT) 1987 pTHX = p->thx; 1988 #endif 1989 1990 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */ 1991 _ckvmssts(sys$dassgn(p->chan_out)); 1992 p->chan_out = 0; 1993 } 1994 1995 /* read completed: 1996 input shutdown if EOF from self (done or shut_on_empty) 1997 output shutdown if closing flag set (my_pclose) 1998 send data/eof from child or eof from self 1999 otherwise, re-read (snarf of data from child) 2000 */ 2001 2002 if (p->type == 1) { 2003 p->type = 0; 2004 if (myeof && p->chan_in) { /* input shutdown */ 2005 _ckvmssts(sys$dassgn(p->chan_in)); 2006 p->chan_in = 0; 2007 } 2008 2009 if (p->chan_out) { 2010 if (myeof || kideof) { /* pass EOF to parent */ 2011 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb, 2012 pipe_infromchild_ast, p, 2013 0, 0, 0, 0, 0, 0)); 2014 return; 2015 } else if (eof) { /* eat EOF --- fall through to read*/ 2016 2017 } else { /* transmit data */ 2018 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb, 2019 pipe_infromchild_ast,p, 2020 p->buf, p->iosb.count, 0, 0, 0, 0)); 2021 return; 2022 } 2023 } 2024 } 2025 2026 /* everything shut? flag as done */ 2027 2028 if (!p->chan_in && !p->chan_out) { 2029 *p->pipe_done = TRUE; 2030 _ckvmssts(sys$setef(pipe_ef)); 2031 return; 2032 } 2033 2034 /* write completed (or read, if snarfing from child) 2035 if still have input active, 2036 queue read...immediate mode if shut_on_empty so we get EOF if empty 2037 otherwise, 2038 check if Perl reading, generate EOFs as needed 2039 */ 2040 2041 if (p->type == 0) { 2042 p->type = 1; 2043 if (p->chan_in) { 2044 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb, 2045 pipe_infromchild_ast,p, 2046 p->buf, p->bufsize, 0, 0, 0, 0); 2047 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL; 2048 _ckvmssts(iss); 2049 } else { /* send EOFs for extra reads */ 2050 p->iosb.status = SS$_ENDOFFILE; 2051 p->iosb.dvispec = 0; 2052 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN, 2053 0, 0, 0, 2054 pipe_infromchild_ast, p, 0, 0, 0, 0)); 2055 } 2056 } 2057 } 2058 2059 static pPipe 2060 pipe_mbxtofd_setup(pTHX_ int fd, char *out) 2061 { 2062 pPipe p; 2063 char mbx[64]; 2064 unsigned long dviitm = DVI$_DEVBUFSIZ; 2065 struct stat s; 2066 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T, 2067 DSC$K_CLASS_S, mbx}; 2068 2069 /* things like terminals and mbx's don't need this filter */ 2070 if (fd && fstat(fd,&s) == 0) { 2071 unsigned long dviitm = DVI$_DEVCHAR, devchar; 2072 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T, 2073 DSC$K_CLASS_S, s.st_dev}; 2074 2075 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0)); 2076 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/ 2077 strcpy(out, s.st_dev); 2078 return 0; 2079 } 2080 } 2081 2082 Newx(p, 1, Pipe); 2083 p->fd_out = dup(fd); 2084 create_mbx(aTHX_ &p->chan_in, &d_mbx); 2085 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize)); 2086 Newx(p->buf, p->bufsize+1, char); 2087 p->shut_on_empty = FALSE; 2088 p->retry = 0; 2089 p->info = 0; 2090 strcpy(out, mbx); 2091 2092 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb, 2093 pipe_mbxtofd_ast, p, 2094 p->buf, p->bufsize, 0, 0, 0, 0)); 2095 2096 return p; 2097 } 2098 2099 static void 2100 pipe_mbxtofd_ast(pPipe p) 2101 { 2102 int iss = p->iosb.status; 2103 int done = p->info->done; 2104 int iss2; 2105 int eof = (iss == SS$_ENDOFFILE); 2106 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0)); 2107 int err = !(iss&1) && !eof; 2108 #if defined(PERL_IMPLICIT_CONTEXT) 2109 pTHX = p->thx; 2110 #endif 2111 2112 if (done && myeof) { /* end piping */ 2113 close(p->fd_out); 2114 sys$dassgn(p->chan_in); 2115 *p->pipe_done = TRUE; 2116 _ckvmssts(sys$setef(pipe_ef)); 2117 return; 2118 } 2119 2120 if (!err && !eof) { /* good data to send to file */ 2121 p->buf[p->iosb.count] = '\n'; 2122 iss2 = write(p->fd_out, p->buf, p->iosb.count+1); 2123 if (iss2 < 0) { 2124 p->retry++; 2125 if (p->retry < MAX_RETRY) { 2126 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p)); 2127 return; 2128 } 2129 } 2130 p->retry = 0; 2131 } else if (err) { 2132 _ckvmssts(iss); 2133 } 2134 2135 2136 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb, 2137 pipe_mbxtofd_ast, p, 2138 p->buf, p->bufsize, 0, 0, 0, 0); 2139 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL; 2140 _ckvmssts(iss); 2141 } 2142 2143 2144 typedef struct _pipeloc PLOC; 2145 typedef struct _pipeloc* pPLOC; 2146 2147 struct _pipeloc { 2148 pPLOC next; 2149 char dir[NAM$C_MAXRSS+1]; 2150 }; 2151 static pPLOC head_PLOC = 0; 2152 2153 void 2154 free_pipelocs(pTHX_ void *head) 2155 { 2156 pPLOC p, pnext; 2157 pPLOC *pHead = (pPLOC *)head; 2158 2159 p = *pHead; 2160 while (p) { 2161 pnext = p->next; 2162 Safefree(p); 2163 p = pnext; 2164 } 2165 *pHead = 0; 2166 } 2167 2168 static void 2169 store_pipelocs(pTHX) 2170 { 2171 int i; 2172 pPLOC p; 2173 AV *av = 0; 2174 SV *dirsv; 2175 GV *gv; 2176 char *dir, *x; 2177 char *unixdir; 2178 char temp[NAM$C_MAXRSS+1]; 2179 STRLEN n_a; 2180 2181 if (head_PLOC) 2182 free_pipelocs(aTHX_ &head_PLOC); 2183 2184 /* the . directory from @INC comes last */ 2185 2186 Newx(p,1,PLOC); 2187 p->next = head_PLOC; 2188 head_PLOC = p; 2189 strcpy(p->dir,"./"); 2190 2191 /* get the directory from $^X */ 2192 2193 #ifdef PERL_IMPLICIT_CONTEXT 2194 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */ 2195 #else 2196 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */ 2197 #endif 2198 strcpy(temp, PL_origargv[0]); 2199 x = strrchr(temp,']'); 2200 if (x) x[1] = '\0'; 2201 2202 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) { 2203 Newx(p,1,PLOC); 2204 p->next = head_PLOC; 2205 head_PLOC = p; 2206 strncpy(p->dir,unixdir,sizeof(p->dir)-1); 2207 p->dir[NAM$C_MAXRSS] = '\0'; 2208 } 2209 } 2210 2211 /* reverse order of @INC entries, skip "." since entered above */ 2212 2213 #ifdef PERL_IMPLICIT_CONTEXT 2214 if (aTHX) 2215 #endif 2216 if (PL_incgv) av = GvAVn(PL_incgv); 2217 2218 for (i = 0; av && i <= AvFILL(av); i++) { 2219 dirsv = *av_fetch(av,i,TRUE); 2220 2221 if (SvROK(dirsv)) continue; 2222 dir = SvPVx(dirsv,n_a); 2223 if (strcmp(dir,".") == 0) continue; 2224 if ((unixdir = tounixpath(dir, Nullch)) == Nullch) 2225 continue; 2226 2227 Newx(p,1,PLOC); 2228 p->next = head_PLOC; 2229 head_PLOC = p; 2230 strncpy(p->dir,unixdir,sizeof(p->dir)-1); 2231 p->dir[NAM$C_MAXRSS] = '\0'; 2232 } 2233 2234 /* most likely spot (ARCHLIB) put first in the list */ 2235 2236 #ifdef ARCHLIB_EXP 2237 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) { 2238 Newx(p,1,PLOC); 2239 p->next = head_PLOC; 2240 head_PLOC = p; 2241 strncpy(p->dir,unixdir,sizeof(p->dir)-1); 2242 p->dir[NAM$C_MAXRSS] = '\0'; 2243 } 2244 #endif 2245 } 2246 2247 2248 static char * 2249 find_vmspipe(pTHX) 2250 { 2251 static int vmspipe_file_status = 0; 2252 static char vmspipe_file[NAM$C_MAXRSS+1]; 2253 2254 /* already found? Check and use ... need read+execute permission */ 2255 2256 if (vmspipe_file_status == 1) { 2257 if (cando_by_name(S_IRUSR, 0, vmspipe_file) 2258 && cando_by_name(S_IXUSR, 0, vmspipe_file)) { 2259 return vmspipe_file; 2260 } 2261 vmspipe_file_status = 0; 2262 } 2263 2264 /* scan through stored @INC, $^X */ 2265 2266 if (vmspipe_file_status == 0) { 2267 char file[NAM$C_MAXRSS+1]; 2268 pPLOC p = head_PLOC; 2269 2270 while (p) { 2271 strcpy(file, p->dir); 2272 strncat(file, "vmspipe.com",NAM$C_MAXRSS); 2273 file[NAM$C_MAXRSS] = '\0'; 2274 p = p->next; 2275 2276 if (!do_tovmsspec(file,vmspipe_file,0)) continue; 2277 2278 if (cando_by_name(S_IRUSR, 0, vmspipe_file) 2279 && cando_by_name(S_IXUSR, 0, vmspipe_file)) { 2280 vmspipe_file_status = 1; 2281 return vmspipe_file; 2282 } 2283 } 2284 vmspipe_file_status = -1; /* failed, use tempfiles */ 2285 } 2286 2287 return 0; 2288 } 2289 2290 static FILE * 2291 vmspipe_tempfile(pTHX) 2292 { 2293 char file[NAM$C_MAXRSS+1]; 2294 FILE *fp; 2295 static int index = 0; 2296 stat_t s0, s1; 2297 2298 /* create a tempfile */ 2299 2300 /* we can't go from W, shr=get to R, shr=get without 2301 an intermediate vulnerable state, so don't bother trying... 2302 2303 and lib$spawn doesn't shr=put, so have to close the write 2304 2305 So... match up the creation date/time and the FID to 2306 make sure we're dealing with the same file 2307 2308 */ 2309 2310 index++; 2311 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index); 2312 fp = fopen(file,"w"); 2313 if (!fp) { 2314 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index); 2315 fp = fopen(file,"w"); 2316 if (!fp) { 2317 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index); 2318 fp = fopen(file,"w"); 2319 } 2320 } 2321 if (!fp) return 0; /* we're hosed */ 2322 2323 fprintf(fp,"$! 'f$verify(0)'\n"); 2324 fprintf(fp,"$! --- protect against nonstandard definitions ---\n"); 2325 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n"); 2326 fprintf(fp,"$ perl_define = \"define/nolog\"\n"); 2327 fprintf(fp,"$ perl_on = \"set noon\"\n"); 2328 fprintf(fp,"$ perl_exit = \"exit\"\n"); 2329 fprintf(fp,"$ perl_del = \"delete\"\n"); 2330 fprintf(fp,"$ pif = \"if\"\n"); 2331 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n"); 2332 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n"); 2333 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n"); 2334 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n"); 2335 fprintf(fp,"$! --- build command line to get max possible length\n"); 2336 fprintf(fp,"$c=perl_popen_cmd0\n"); 2337 fprintf(fp,"$c=c+perl_popen_cmd1\n"); 2338 fprintf(fp,"$c=c+perl_popen_cmd2\n"); 2339 fprintf(fp,"$x=perl_popen_cmd3\n"); 2340 fprintf(fp,"$c=c+x\n"); 2341 fprintf(fp,"$ perl_on\n"); 2342 fprintf(fp,"$ 'c'\n"); 2343 fprintf(fp,"$ perl_status = $STATUS\n"); 2344 fprintf(fp,"$ perl_del 'perl_cfile'\n"); 2345 fprintf(fp,"$ perl_exit 'perl_status'\n"); 2346 fsync(fileno(fp)); 2347 2348 fgetname(fp, file, 1); 2349 fstat(fileno(fp), &s0); 2350 fclose(fp); 2351 2352 fp = fopen(file,"r","shr=get"); 2353 if (!fp) return 0; 2354 fstat(fileno(fp), &s1); 2355 2356 if (s0.st_ino[0] != s1.st_ino[0] || 2357 s0.st_ino[1] != s1.st_ino[1] || 2358 s0.st_ino[2] != s1.st_ino[2] || 2359 s0.st_ctime != s1.st_ctime ) { 2360 fclose(fp); 2361 return 0; 2362 } 2363 2364 return fp; 2365 } 2366 2367 2368 2369 static PerlIO * 2370 safe_popen(pTHX_ char *cmd, char *in_mode, int *psts) 2371 { 2372 static int handler_set_up = FALSE; 2373 unsigned long int sts, flags = CLI$M_NOWAIT; 2374 /* The use of a GLOBAL table (as was done previously) rendered 2375 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL 2376 * environment. Hence we've switched to LOCAL symbol table. 2377 */ 2378 unsigned int table = LIB$K_CLI_LOCAL_SYM; 2379 int j, wait = 0; 2380 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe; 2381 char in[512], out[512], err[512], mbx[512]; 2382 FILE *tpipe = 0; 2383 char tfilebuf[NAM$C_MAXRSS+1]; 2384 pInfo info; 2385 char cmd_sym_name[20]; 2386 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T, 2387 DSC$K_CLASS_S, symbol}; 2388 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T, 2389 DSC$K_CLASS_S, 0}; 2390 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T, 2391 DSC$K_CLASS_S, cmd_sym_name}; 2392 struct dsc$descriptor_s *vmscmd; 2393 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN"); 2394 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT"); 2395 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR"); 2396 2397 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */ 2398 2399 /* once-per-program initialization... 2400 note that the SETAST calls and the dual test of pipe_ef 2401 makes sure that only the FIRST thread through here does 2402 the initialization...all other threads wait until it's 2403 done. 2404 2405 Yeah, uglier than a pthread call, it's got all the stuff inline 2406 rather than in a separate routine. 2407 */ 2408 2409 if (!pipe_ef) { 2410 _ckvmssts(sys$setast(0)); 2411 if (!pipe_ef) { 2412 unsigned long int pidcode = JPI$_PID; 2413 $DESCRIPTOR(d_delay, RETRY_DELAY); 2414 _ckvmssts(lib$get_ef(&pipe_ef)); 2415 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0)); 2416 _ckvmssts(sys$bintim(&d_delay, delaytime)); 2417 } 2418 if (!handler_set_up) { 2419 _ckvmssts(sys$dclexh(&pipe_exitblock)); 2420 handler_set_up = TRUE; 2421 } 2422 _ckvmssts(sys$setast(1)); 2423 } 2424 2425 /* see if we can find a VMSPIPE.COM */ 2426 2427 tfilebuf[0] = '@'; 2428 vmspipe = find_vmspipe(aTHX); 2429 if (vmspipe) { 2430 strcpy(tfilebuf+1,vmspipe); 2431 } else { /* uh, oh...we're in tempfile hell */ 2432 tpipe = vmspipe_tempfile(aTHX); 2433 if (!tpipe) { /* a fish popular in Boston */ 2434 if (ckWARN(WARN_PIPE)) { 2435 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping"); 2436 } 2437 return Nullfp; 2438 } 2439 fgetname(tpipe,tfilebuf+1,1); 2440 } 2441 vmspipedsc.dsc$a_pointer = tfilebuf; 2442 vmspipedsc.dsc$w_length = strlen(tfilebuf); 2443 2444 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd); 2445 if (!(sts & 1)) { 2446 switch (sts) { 2447 case RMS$_FNF: case RMS$_DNF: 2448 set_errno(ENOENT); break; 2449 case RMS$_DIR: 2450 set_errno(ENOTDIR); break; 2451 case RMS$_DEV: 2452 set_errno(ENODEV); break; 2453 case RMS$_PRV: 2454 set_errno(EACCES); break; 2455 case RMS$_SYN: 2456 set_errno(EINVAL); break; 2457 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF: 2458 set_errno(E2BIG); break; 2459 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */ 2460 _ckvmssts(sts); /* fall through */ 2461 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */ 2462 set_errno(EVMSERR); 2463 } 2464 set_vaxc_errno(sts); 2465 if (*mode != 'n' && ckWARN(WARN_PIPE)) { 2466 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno)); 2467 } 2468 *psts = sts; 2469 return Nullfp; 2470 } 2471 Newx(info,1,Info); 2472 2473 strcpy(mode,in_mode); 2474 info->mode = *mode; 2475 info->done = FALSE; 2476 info->completion = 0; 2477 info->closing = FALSE; 2478 info->in = 0; 2479 info->out = 0; 2480 info->err = 0; 2481 info->fp = Nullfp; 2482 info->useFILE = 0; 2483 info->waiting = 0; 2484 info->in_done = TRUE; 2485 info->out_done = TRUE; 2486 info->err_done = TRUE; 2487 in[0] = out[0] = err[0] = '\0'; 2488 2489 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */ 2490 info->useFILE = 1; 2491 strcpy(p,p+1); 2492 } 2493 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */ 2494 wait = 1; 2495 strcpy(p,p+1); 2496 } 2497 2498 if (*mode == 'r') { /* piping from subroutine */ 2499 2500 info->out = pipe_infromchild_setup(aTHX_ mbx,out); 2501 if (info->out) { 2502 info->out->pipe_done = &info->out_done; 2503 info->out_done = FALSE; 2504 info->out->info = info; 2505 } 2506 if (!info->useFILE) { 2507 info->fp = PerlIO_open(mbx, mode); 2508 } else { 2509 info->fp = (PerlIO *) freopen(mbx, mode, stdin); 2510 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx); 2511 } 2512 2513 if (!info->fp && info->out) { 2514 sys$cancel(info->out->chan_out); 2515 2516 while (!info->out_done) { 2517 int done; 2518 _ckvmssts(sys$setast(0)); 2519 done = info->out_done; 2520 if (!done) _ckvmssts(sys$clref(pipe_ef)); 2521 _ckvmssts(sys$setast(1)); 2522 if (!done) _ckvmssts(sys$waitfr(pipe_ef)); 2523 } 2524 2525 if (info->out->buf) Safefree(info->out->buf); 2526 Safefree(info->out); 2527 Safefree(info); 2528 *psts = RMS$_FNF; 2529 return Nullfp; 2530 } 2531 2532 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err); 2533 if (info->err) { 2534 info->err->pipe_done = &info->err_done; 2535 info->err_done = FALSE; 2536 info->err->info = info; 2537 } 2538 2539 } else if (*mode == 'w') { /* piping to subroutine */ 2540 2541 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out); 2542 if (info->out) { 2543 info->out->pipe_done = &info->out_done; 2544 info->out_done = FALSE; 2545 info->out->info = info; 2546 } 2547 2548 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err); 2549 if (info->err) { 2550 info->err->pipe_done = &info->err_done; 2551 info->err_done = FALSE; 2552 info->err->info = info; 2553 } 2554 2555 info->in = pipe_tochild_setup(aTHX_ in,mbx); 2556 if (!info->useFILE) { 2557 info->fp = PerlIO_open(mbx, mode); 2558 } else { 2559 info->fp = (PerlIO *) freopen(mbx, mode, stdout); 2560 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx); 2561 } 2562 2563 if (info->in) { 2564 info->in->pipe_done = &info->in_done; 2565 info->in_done = FALSE; 2566 info->in->info = info; 2567 } 2568 2569 /* error cleanup */ 2570 if (!info->fp && info->in) { 2571 info->done = TRUE; 2572 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0, 2573 0, 0, 0, 0, 0, 0, 0, 0)); 2574 2575 while (!info->in_done) { 2576 int done; 2577 _ckvmssts(sys$setast(0)); 2578 done = info->in_done; 2579 if (!done) _ckvmssts(sys$clref(pipe_ef)); 2580 _ckvmssts(sys$setast(1)); 2581 if (!done) _ckvmssts(sys$waitfr(pipe_ef)); 2582 } 2583 2584 if (info->in->buf) Safefree(info->in->buf); 2585 Safefree(info->in); 2586 Safefree(info); 2587 *psts = RMS$_FNF; 2588 return Nullfp; 2589 } 2590 2591 2592 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */ 2593 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out); 2594 if (info->out) { 2595 info->out->pipe_done = &info->out_done; 2596 info->out_done = FALSE; 2597 info->out->info = info; 2598 } 2599 2600 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err); 2601 if (info->err) { 2602 info->err->pipe_done = &info->err_done; 2603 info->err_done = FALSE; 2604 info->err->info = info; 2605 } 2606 } 2607 2608 symbol[MAX_DCL_SYMBOL] = '\0'; 2609 2610 strncpy(symbol, in, MAX_DCL_SYMBOL); 2611 d_symbol.dsc$w_length = strlen(symbol); 2612 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table)); 2613 2614 strncpy(symbol, err, MAX_DCL_SYMBOL); 2615 d_symbol.dsc$w_length = strlen(symbol); 2616 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table)); 2617 2618 strncpy(symbol, out, MAX_DCL_SYMBOL); 2619 d_symbol.dsc$w_length = strlen(symbol); 2620 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table)); 2621 2622 p = vmscmd->dsc$a_pointer; 2623 while (*p && *p != '\n') p++; 2624 *p = '\0'; /* truncate on \n */ 2625 p = vmscmd->dsc$a_pointer; 2626 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */ 2627 if (*p == '$') p++; /* remove leading $ */ 2628 while (*p == ' ' || *p == '\t') p++; 2629 2630 for (j = 0; j < 4; j++) { 2631 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j); 2632 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name); 2633 2634 strncpy(symbol, p, MAX_DCL_SYMBOL); 2635 d_symbol.dsc$w_length = strlen(symbol); 2636 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table)); 2637 2638 if (strlen(p) > MAX_DCL_SYMBOL) { 2639 p += MAX_DCL_SYMBOL; 2640 } else { 2641 p += strlen(p); 2642 } 2643 } 2644 _ckvmssts(sys$setast(0)); 2645 info->next=open_pipes; /* prepend to list */ 2646 open_pipes=info; 2647 _ckvmssts(sys$setast(1)); 2648 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT 2649 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still 2650 * have SYS$COMMAND if we need it. 2651 */ 2652 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags, 2653 0, &info->pid, &info->completion, 2654 0, popen_completion_ast,info,0,0,0)); 2655 2656 /* if we were using a tempfile, close it now */ 2657 2658 if (tpipe) fclose(tpipe); 2659 2660 /* once the subprocess is spawned, it has copied the symbols and 2661 we can get rid of ours */ 2662 2663 for (j = 0; j < 4; j++) { 2664 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j); 2665 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name); 2666 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table)); 2667 } 2668 _ckvmssts(lib$delete_symbol(&d_sym_in, &table)); 2669 _ckvmssts(lib$delete_symbol(&d_sym_err, &table)); 2670 _ckvmssts(lib$delete_symbol(&d_sym_out, &table)); 2671 vms_execfree(vmscmd); 2672 2673 #ifdef PERL_IMPLICIT_CONTEXT 2674 if (aTHX) 2675 #endif 2676 PL_forkprocess = info->pid; 2677 2678 if (wait) { 2679 int done = 0; 2680 while (!done) { 2681 _ckvmssts(sys$setast(0)); 2682 done = info->done; 2683 if (!done) _ckvmssts(sys$clref(pipe_ef)); 2684 _ckvmssts(sys$setast(1)); 2685 if (!done) _ckvmssts(sys$waitfr(pipe_ef)); 2686 } 2687 *psts = info->completion; 2688 my_pclose(info->fp); 2689 } else { 2690 *psts = SS$_NORMAL; 2691 } 2692 return info->fp; 2693 } /* end of safe_popen */ 2694 2695 2696 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/ 2697 PerlIO * 2698 Perl_my_popen(pTHX_ char *cmd, char *mode) 2699 { 2700 int sts; 2701 TAINT_ENV(); 2702 TAINT_PROPER("popen"); 2703 PERL_FLUSHALL_FOR_CHILD; 2704 return safe_popen(aTHX_ cmd,mode,&sts); 2705 } 2706 2707 /*}}}*/ 2708 2709 /*{{{ I32 my_pclose(PerlIO *fp)*/ 2710 I32 Perl_my_pclose(pTHX_ PerlIO *fp) 2711 { 2712 pInfo info, last = NULL; 2713 unsigned long int retsts; 2714 int done, iss; 2715 2716 for (info = open_pipes; info != NULL; last = info, info = info->next) 2717 if (info->fp == fp) break; 2718 2719 if (info == NULL) { /* no such pipe open */ 2720 set_errno(ECHILD); /* quoth POSIX */ 2721 set_vaxc_errno(SS$_NONEXPR); 2722 return -1; 2723 } 2724 2725 /* If we were writing to a subprocess, insure that someone reading from 2726 * the mailbox gets an EOF. It looks like a simple fclose() doesn't 2727 * produce an EOF record in the mailbox. 2728 * 2729 * well, at least sometimes it *does*, so we have to watch out for 2730 * the first EOF closing the pipe (and DASSGN'ing the channel)... 2731 */ 2732 if (info->fp) { 2733 if (!info->useFILE) 2734 PerlIO_flush(info->fp); /* first, flush data */ 2735 else 2736 fflush((FILE *)info->fp); 2737 } 2738 2739 _ckvmssts(sys$setast(0)); 2740 info->closing = TRUE; 2741 done = info->done && info->in_done && info->out_done && info->err_done; 2742 /* hanging on write to Perl's input? cancel it */ 2743 if (info->mode == 'r' && info->out && !info->out_done) { 2744 if (info->out->chan_out) { 2745 _ckvmssts(sys$cancel(info->out->chan_out)); 2746 if (!info->out->chan_in) { /* EOF generation, need AST */ 2747 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0)); 2748 } 2749 } 2750 } 2751 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */ 2752 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0, 2753 0, 0, 0, 0, 0, 0)); 2754 _ckvmssts(sys$setast(1)); 2755 if (info->fp) { 2756 if (!info->useFILE) 2757 PerlIO_close(info->fp); 2758 else 2759 fclose((FILE *)info->fp); 2760 } 2761 /* 2762 we have to wait until subprocess completes, but ALSO wait until all 2763 the i/o completes...otherwise we'll be freeing the "info" structure 2764 that the i/o ASTs could still be using... 2765 */ 2766 2767 while (!done) { 2768 _ckvmssts(sys$setast(0)); 2769 done = info->done && info->in_done && info->out_done && info->err_done; 2770 if (!done) _ckvmssts(sys$clref(pipe_ef)); 2771 _ckvmssts(sys$setast(1)); 2772 if (!done) _ckvmssts(sys$waitfr(pipe_ef)); 2773 } 2774 retsts = info->completion; 2775 2776 /* remove from list of open pipes */ 2777 _ckvmssts(sys$setast(0)); 2778 if (last) last->next = info->next; 2779 else open_pipes = info->next; 2780 _ckvmssts(sys$setast(1)); 2781 2782 /* free buffers and structures */ 2783 2784 if (info->in) { 2785 if (info->in->buf) Safefree(info->in->buf); 2786 Safefree(info->in); 2787 } 2788 if (info->out) { 2789 if (info->out->buf) Safefree(info->out->buf); 2790 Safefree(info->out); 2791 } 2792 if (info->err) { 2793 if (info->err->buf) Safefree(info->err->buf); 2794 Safefree(info->err); 2795 } 2796 Safefree(info); 2797 2798 return retsts; 2799 2800 } /* end of my_pclose() */ 2801 2802 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000 2803 /* Roll our own prototype because we want this regardless of whether 2804 * _VMS_WAIT is defined. 2805 */ 2806 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options ); 2807 #endif 2808 /* sort-of waitpid; special handling of pipe clean-up for subprocesses 2809 created with popen(); otherwise partially emulate waitpid() unless 2810 we have a suitable one from the CRTL that came with VMS 7.2 and later. 2811 Also check processes not considered by the CRTL waitpid(). 2812 */ 2813 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/ 2814 Pid_t 2815 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags) 2816 { 2817 pInfo info; 2818 int done; 2819 int sts; 2820 int j; 2821 2822 if (statusp) *statusp = 0; 2823 2824 for (info = open_pipes; info != NULL; info = info->next) 2825 if (info->pid == pid) break; 2826 2827 if (info != NULL) { /* we know about this child */ 2828 while (!info->done) { 2829 _ckvmssts(sys$setast(0)); 2830 done = info->done; 2831 if (!done) _ckvmssts(sys$clref(pipe_ef)); 2832 _ckvmssts(sys$setast(1)); 2833 if (!done) _ckvmssts(sys$waitfr(pipe_ef)); 2834 } 2835 2836 if (statusp) *statusp = info->completion; 2837 return pid; 2838 } 2839 2840 /* child that already terminated? */ 2841 2842 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) { 2843 if (closed_list[j].pid == pid) { 2844 if (statusp) *statusp = closed_list[j].completion; 2845 return pid; 2846 } 2847 } 2848 2849 /* fall through if this child is not one of our own pipe children */ 2850 2851 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000 2852 2853 /* waitpid() became available in the CRTL as of VMS 7.0, but only 2854 * in 7.2 did we get a version that fills in the VMS completion 2855 * status as Perl has always tried to do. 2856 */ 2857 2858 sts = __vms_waitpid( pid, statusp, flags ); 2859 2860 if ( sts == 0 || !(sts == -1 && errno == ECHILD) ) 2861 return sts; 2862 2863 /* If the real waitpid tells us the child does not exist, we 2864 * fall through here to implement waiting for a child that 2865 * was created by some means other than exec() (say, spawned 2866 * from DCL) or to wait for a process that is not a subprocess 2867 * of the current process. 2868 */ 2869 2870 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */ 2871 2872 { 2873 $DESCRIPTOR(intdsc,"0 00:00:01"); 2874 unsigned long int ownercode = JPI$_OWNER, ownerpid; 2875 unsigned long int pidcode = JPI$_PID, mypid; 2876 unsigned long int interval[2]; 2877 unsigned int jpi_iosb[2]; 2878 struct itmlst_3 jpilist[2] = { 2879 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0}, 2880 { 0, 0, 0, 0} 2881 }; 2882 2883 if (pid <= 0) { 2884 /* Sorry folks, we don't presently implement rooting around for 2885 the first child we can find, and we definitely don't want to 2886 pass a pid of -1 to $getjpi, where it is a wildcard operation. 2887 */ 2888 set_errno(ENOTSUP); 2889 return -1; 2890 } 2891 2892 /* Get the owner of the child so I can warn if it's not mine. If the 2893 * process doesn't exist or I don't have the privs to look at it, 2894 * I can go home early. 2895 */ 2896 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL); 2897 if (sts & 1) sts = jpi_iosb[0]; 2898 if (!(sts & 1)) { 2899 switch (sts) { 2900 case SS$_NONEXPR: 2901 set_errno(ECHILD); 2902 break; 2903 case SS$_NOPRIV: 2904 set_errno(EACCES); 2905 break; 2906 default: 2907 _ckvmssts(sts); 2908 } 2909 set_vaxc_errno(sts); 2910 return -1; 2911 } 2912 2913 if (ckWARN(WARN_EXEC)) { 2914 /* remind folks they are asking for non-standard waitpid behavior */ 2915 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0)); 2916 if (ownerpid != mypid) 2917 Perl_warner(aTHX_ packWARN(WARN_EXEC), 2918 "waitpid: process %x is not a child of process %x", 2919 pid,mypid); 2920 } 2921 2922 /* simply check on it once a second until it's not there anymore. */ 2923 2924 _ckvmssts(sys$bintim(&intdsc,interval)); 2925 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) { 2926 _ckvmssts(sys$schdwk(0,0,interval,0)); 2927 _ckvmssts(sys$hiber()); 2928 } 2929 if (sts == SS$_NONEXPR) sts = SS$_NORMAL; 2930 2931 _ckvmssts(sts); 2932 return pid; 2933 } 2934 } /* end of waitpid() */ 2935 /*}}}*/ 2936 /*}}}*/ 2937 /*}}}*/ 2938 2939 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */ 2940 char * 2941 my_gconvert(double val, int ndig, int trail, char *buf) 2942 { 2943 static char __gcvtbuf[DBL_DIG+1]; 2944 char *loc; 2945 2946 loc = buf ? buf : __gcvtbuf; 2947 2948 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */ 2949 if (val < 1) { 2950 sprintf(loc,"%.*g",ndig,val); 2951 return loc; 2952 } 2953 #endif 2954 2955 if (val) { 2956 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG; 2957 return gcvt(val,ndig,loc); 2958 } 2959 else { 2960 loc[0] = '0'; loc[1] = '\0'; 2961 return loc; 2962 } 2963 2964 } 2965 /*}}}*/ 2966 2967 2968 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/ 2969 /* Shortcut for common case of simple calls to $PARSE and $SEARCH 2970 * to expand file specification. Allows for a single default file 2971 * specification and a simple mask of options. If outbuf is non-NULL, 2972 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which 2973 * the resultant file specification is placed. If outbuf is NULL, the 2974 * resultant file specification is placed into a static buffer. 2975 * The third argument, if non-NULL, is taken to be a default file 2976 * specification string. The fourth argument is unused at present. 2977 * rmesexpand() returns the address of the resultant string if 2978 * successful, and NULL on error. 2979 */ 2980 static char *mp_do_tounixspec(pTHX_ char *, char *, int); 2981 2982 static char * 2983 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts) 2984 { 2985 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1]; 2986 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1]; 2987 char esa[NAM$C_MAXRSS], *cp, *out = NULL; 2988 struct FAB myfab = cc$rms_fab; 2989 struct NAM mynam = cc$rms_nam; 2990 STRLEN speclen; 2991 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0; 2992 2993 if (!filespec || !*filespec) { 2994 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL); 2995 return NULL; 2996 } 2997 if (!outbuf) { 2998 if (ts) out = Newx(outbuf,NAM$C_MAXRSS+1,char); 2999 else outbuf = __rmsexpand_retbuf; 3000 } 3001 if ((isunix = (strchr(filespec,'/') != NULL))) { 3002 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL; 3003 filespec = vmsfspec; 3004 } 3005 3006 myfab.fab$l_fna = filespec; 3007 myfab.fab$b_fns = strlen(filespec); 3008 myfab.fab$l_nam = &mynam; 3009 3010 if (defspec && *defspec) { 3011 if (strchr(defspec,'/') != NULL) { 3012 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL; 3013 defspec = tmpfspec; 3014 } 3015 myfab.fab$l_dna = defspec; 3016 myfab.fab$b_dns = strlen(defspec); 3017 } 3018 3019 mynam.nam$l_esa = esa; 3020 mynam.nam$b_ess = sizeof esa; 3021 mynam.nam$l_rsa = outbuf; 3022 mynam.nam$b_rss = NAM$C_MAXRSS; 3023 3024 retsts = sys$parse(&myfab,0,0); 3025 if (!(retsts & 1)) { 3026 mynam.nam$b_nop |= NAM$M_SYNCHK; 3027 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) { 3028 retsts = sys$parse(&myfab,0,0); 3029 if (retsts & 1) goto expanded; 3030 } 3031 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0; 3032 (void) sys$parse(&myfab,0,0); /* Free search context */ 3033 if (out) Safefree(out); 3034 set_vaxc_errno(retsts); 3035 if (retsts == RMS$_PRV) set_errno(EACCES); 3036 else if (retsts == RMS$_DEV) set_errno(ENODEV); 3037 else if (retsts == RMS$_DIR) set_errno(ENOTDIR); 3038 else set_errno(EVMSERR); 3039 return NULL; 3040 } 3041 retsts = sys$search(&myfab,0,0); 3042 if (!(retsts & 1) && retsts != RMS$_FNF) { 3043 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL; 3044 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */ 3045 if (out) Safefree(out); 3046 set_vaxc_errno(retsts); 3047 if (retsts == RMS$_PRV) set_errno(EACCES); 3048 else set_errno(EVMSERR); 3049 return NULL; 3050 } 3051 3052 /* If the input filespec contained any lowercase characters, 3053 * downcase the result for compatibility with Unix-minded code. */ 3054 expanded: 3055 for (out = myfab.fab$l_fna; *out; out++) 3056 if (islower(*out)) { haslower = 1; break; } 3057 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; } 3058 else { out = esa; speclen = mynam.nam$b_esl; } 3059 /* Trim off null fields added by $PARSE 3060 * If type > 1 char, must have been specified in original or default spec 3061 * (not true for version; $SEARCH may have added version of existing file). 3062 */ 3063 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER); 3064 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) && 3065 (mynam.nam$l_ver - mynam.nam$l_type == 1); 3066 if (trimver || trimtype) { 3067 if (defspec && *defspec) { 3068 char defesa[NAM$C_MAXRSS]; 3069 struct FAB deffab = cc$rms_fab; 3070 struct NAM defnam = cc$rms_nam; 3071 3072 deffab.fab$l_nam = &defnam; 3073 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns; 3074 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa; 3075 defnam.nam$b_nop = NAM$M_SYNCHK; 3076 if (sys$parse(&deffab,0,0) & 1) { 3077 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER); 3078 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE); 3079 } 3080 } 3081 if (trimver) speclen = mynam.nam$l_ver - out; 3082 if (trimtype) { 3083 /* If we didn't already trim version, copy down */ 3084 if (speclen > mynam.nam$l_ver - out) 3085 memcpy(mynam.nam$l_type, mynam.nam$l_ver, 3086 speclen - (mynam.nam$l_ver - out)); 3087 speclen -= mynam.nam$l_ver - mynam.nam$l_type; 3088 } 3089 } 3090 /* If we just had a directory spec on input, $PARSE "helpfully" 3091 * adds an empty name and type for us */ 3092 if (mynam.nam$l_name == mynam.nam$l_type && 3093 mynam.nam$l_ver == mynam.nam$l_type + 1 && 3094 !(mynam.nam$l_fnb & NAM$M_EXP_NAME)) 3095 speclen = mynam.nam$l_name - out; 3096 out[speclen] = '\0'; 3097 if (haslower) __mystrtolower(out); 3098 3099 /* Have we been working with an expanded, but not resultant, spec? */ 3100 /* Also, convert back to Unix syntax if necessary. */ 3101 if (!mynam.nam$b_rsl) { 3102 if (isunix) { 3103 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL; 3104 } 3105 else strcpy(outbuf,esa); 3106 } 3107 else if (isunix) { 3108 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL; 3109 strcpy(outbuf,tmpfspec); 3110 } 3111 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL; 3112 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0; 3113 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */ 3114 return outbuf; 3115 } 3116 /*}}}*/ 3117 /* External entry points */ 3118 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt) 3119 { return do_rmsexpand(spec,buf,0,def,opt); } 3120 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt) 3121 { return do_rmsexpand(spec,buf,1,def,opt); } 3122 3123 3124 /* 3125 ** The following routines are provided to make life easier when 3126 ** converting among VMS-style and Unix-style directory specifications. 3127 ** All will take input specifications in either VMS or Unix syntax. On 3128 ** failure, all return NULL. If successful, the routines listed below 3129 ** return a pointer to a buffer containing the appropriately 3130 ** reformatted spec (and, therefore, subsequent calls to that routine 3131 ** will clobber the result), while the routines of the same names with 3132 ** a _ts suffix appended will return a pointer to a mallocd string 3133 ** containing the appropriately reformatted spec. 3134 ** In all cases, only explicit syntax is altered; no check is made that 3135 ** the resulting string is valid or that the directory in question 3136 ** actually exists. 3137 ** 3138 ** fileify_dirspec() - convert a directory spec into the name of the 3139 ** directory file (i.e. what you can stat() to see if it's a dir). 3140 ** The style (VMS or Unix) of the result is the same as the style 3141 ** of the parameter passed in. 3142 ** pathify_dirspec() - convert a directory spec into a path (i.e. 3143 ** what you prepend to a filename to indicate what directory it's in). 3144 ** The style (VMS or Unix) of the result is the same as the style 3145 ** of the parameter passed in. 3146 ** tounixpath() - convert a directory spec into a Unix-style path. 3147 ** tovmspath() - convert a directory spec into a VMS-style path. 3148 ** tounixspec() - convert any file spec into a Unix-style file spec. 3149 ** tovmsspec() - convert any file spec into a VMS-style spec. 3150 ** 3151 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu> 3152 ** Permission is given to distribute this code as part of the Perl 3153 ** standard distribution under the terms of the GNU General Public 3154 ** License or the Perl Artistic License. Copies of each may be 3155 ** found in the Perl standard distribution. 3156 */ 3157 3158 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/ 3159 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts) 3160 { 3161 static char __fileify_retbuf[NAM$C_MAXRSS+1]; 3162 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0; 3163 char *retspec, *cp1, *cp2, *lastdir; 3164 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1]; 3165 unsigned short int trnlnm_iter_count; 3166 3167 if (!dir || !*dir) { 3168 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL; 3169 } 3170 dirlen = strlen(dir); 3171 while (dirlen && dir[dirlen-1] == '/') --dirlen; 3172 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */ 3173 strcpy(trndir,"/sys$disk/000000"); 3174 dir = trndir; 3175 dirlen = 16; 3176 } 3177 if (dirlen > NAM$C_MAXRSS) { 3178 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL; 3179 } 3180 if (!strpbrk(dir+1,"/]>:")) { 3181 strcpy(trndir,*dir == '/' ? dir + 1: dir); 3182 trnlnm_iter_count = 0; 3183 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) { 3184 trnlnm_iter_count++; 3185 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break; 3186 } 3187 dir = trndir; 3188 dirlen = strlen(dir); 3189 } 3190 else { 3191 strncpy(trndir,dir,dirlen); 3192 trndir[dirlen] = '\0'; 3193 dir = trndir; 3194 } 3195 /* If we were handed a rooted logical name or spec, treat it like a 3196 * simple directory, so that 3197 * $ Define myroot dev:[dir.] 3198 * ... do_fileify_dirspec("myroot",buf,1) ... 3199 * does something useful. 3200 */ 3201 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) { 3202 dir[--dirlen] = '\0'; 3203 dir[dirlen-1] = ']'; 3204 } 3205 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".>")) { 3206 dir[--dirlen] = '\0'; 3207 dir[dirlen-1] = '>'; 3208 } 3209 3210 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) { 3211 /* If we've got an explicit filename, we can just shuffle the string. */ 3212 if (*(cp1+1)) hasfilename = 1; 3213 /* Similarly, we can just back up a level if we've got multiple levels 3214 of explicit directories in a VMS spec which ends with directories. */ 3215 else { 3216 for (cp2 = cp1; cp2 > dir; cp2--) { 3217 if (*cp2 == '.') { 3218 *cp2 = *cp1; *cp1 = '\0'; 3219 hasfilename = 1; 3220 break; 3221 } 3222 if (*cp2 == '[' || *cp2 == '<') break; 3223 } 3224 } 3225 } 3226 3227 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */ 3228 if (dir[0] == '.') { 3229 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0')) 3230 return do_fileify_dirspec("[]",buf,ts); 3231 else if (dir[1] == '.' && 3232 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0'))) 3233 return do_fileify_dirspec("[-]",buf,ts); 3234 } 3235 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */ 3236 dirlen -= 1; /* to last element */ 3237 lastdir = strrchr(dir,'/'); 3238 } 3239 else if ((cp1 = strstr(dir,"/.")) != NULL) { 3240 /* If we have "/." or "/..", VMSify it and let the VMS code 3241 * below expand it, rather than repeating the code to handle 3242 * relative components of a filespec here */ 3243 do { 3244 if (*(cp1+2) == '.') cp1++; 3245 if (*(cp1+2) == '/' || *(cp1+2) == '\0') { 3246 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL; 3247 if (strchr(vmsdir,'/') != NULL) { 3248 /* If do_tovmsspec() returned it, it must have VMS syntax 3249 * delimiters in it, so it's a mixed VMS/Unix spec. We take 3250 * the time to check this here only so we avoid a recursion 3251 * loop; otherwise, gigo. 3252 */ 3253 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL; 3254 } 3255 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL; 3256 return do_tounixspec(trndir,buf,ts); 3257 } 3258 cp1++; 3259 } while ((cp1 = strstr(cp1,"/.")) != NULL); 3260 lastdir = strrchr(dir,'/'); 3261 } 3262 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) { 3263 /* Ditto for specs that end in an MFD -- let the VMS code 3264 * figure out whether it's a real device or a rooted logical. */ 3265 dir[dirlen] = '/'; dir[dirlen+1] = '\0'; 3266 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL; 3267 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL; 3268 return do_tounixspec(trndir,buf,ts); 3269 } 3270 else { 3271 if ( !(lastdir = cp1 = strrchr(dir,'/')) && 3272 !(lastdir = cp1 = strrchr(dir,']')) && 3273 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir; 3274 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */ 3275 int ver; char *cp3; 3276 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */ 3277 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */ 3278 !*(cp2+3) || toupper(*(cp2+3)) != 'R' || 3279 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') || 3280 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 && 3281 (ver || *cp3)))))) { 3282 set_errno(ENOTDIR); 3283 set_vaxc_errno(RMS$_DIR); 3284 return NULL; 3285 } 3286 dirlen = cp2 - dir; 3287 } 3288 } 3289 /* If we lead off with a device or rooted logical, add the MFD 3290 if we're specifying a top-level directory. */ 3291 if (lastdir && *dir == '/') { 3292 addmfd = 1; 3293 for (cp1 = lastdir - 1; cp1 > dir; cp1--) { 3294 if (*cp1 == '/') { 3295 addmfd = 0; 3296 break; 3297 } 3298 } 3299 } 3300 retlen = dirlen + (addmfd ? 13 : 6); 3301 if (buf) retspec = buf; 3302 else if (ts) Newx(retspec,retlen+1,char); 3303 else retspec = __fileify_retbuf; 3304 if (addmfd) { 3305 dirlen = lastdir - dir; 3306 memcpy(retspec,dir,dirlen); 3307 strcpy(&retspec[dirlen],"/000000"); 3308 strcpy(&retspec[dirlen+7],lastdir); 3309 } 3310 else { 3311 memcpy(retspec,dir,dirlen); 3312 retspec[dirlen] = '\0'; 3313 } 3314 /* We've picked up everything up to the directory file name. 3315 Now just add the type and version, and we're set. */ 3316 strcat(retspec,".dir;1"); 3317 return retspec; 3318 } 3319 else { /* VMS-style directory spec */ 3320 char esa[NAM$C_MAXRSS+1], term, *cp; 3321 unsigned long int sts, cmplen, haslower = 0; 3322 struct FAB dirfab = cc$rms_fab; 3323 struct NAM savnam, dirnam = cc$rms_nam; 3324 3325 dirfab.fab$b_fns = strlen(dir); 3326 dirfab.fab$l_fna = dir; 3327 dirfab.fab$l_nam = &dirnam; 3328 dirfab.fab$l_dna = ".DIR;1"; 3329 dirfab.fab$b_dns = 6; 3330 dirnam.nam$b_ess = NAM$C_MAXRSS; 3331 dirnam.nam$l_esa = esa; 3332 3333 for (cp = dir; *cp; cp++) 3334 if (islower(*cp)) { haslower = 1; break; } 3335 if (!((sts = sys$parse(&dirfab))&1)) { 3336 if (dirfab.fab$l_sts == RMS$_DIR) { 3337 dirnam.nam$b_nop |= NAM$M_SYNCHK; 3338 sts = sys$parse(&dirfab) & 1; 3339 } 3340 if (!sts) { 3341 set_errno(EVMSERR); 3342 set_vaxc_errno(dirfab.fab$l_sts); 3343 return NULL; 3344 } 3345 } 3346 else { 3347 savnam = dirnam; 3348 if (sys$search(&dirfab)&1) { /* Does the file really exist? */ 3349 /* Yes; fake the fnb bits so we'll check type below */ 3350 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER; 3351 } 3352 else { /* No; just work with potential name */ 3353 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam; 3354 else { 3355 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts); 3356 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; 3357 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); 3358 return NULL; 3359 } 3360 } 3361 } 3362 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) { 3363 cp1 = strchr(esa,']'); 3364 if (!cp1) cp1 = strchr(esa,'>'); 3365 if (cp1) { /* Should always be true */ 3366 dirnam.nam$b_esl -= cp1 - esa - 1; 3367 memcpy(esa,cp1 + 1,dirnam.nam$b_esl); 3368 } 3369 } 3370 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */ 3371 /* Yep; check version while we're at it, if it's there. */ 3372 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4; 3373 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) { 3374 /* Something other than .DIR[;1]. Bzzt. */ 3375 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; 3376 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); 3377 set_errno(ENOTDIR); 3378 set_vaxc_errno(RMS$_DIR); 3379 return NULL; 3380 } 3381 } 3382 esa[dirnam.nam$b_esl] = '\0'; 3383 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) { 3384 /* They provided at least the name; we added the type, if necessary, */ 3385 if (buf) retspec = buf; /* in sys$parse() */ 3386 else if (ts) Newx(retspec,dirnam.nam$b_esl+1,char); 3387 else retspec = __fileify_retbuf; 3388 strcpy(retspec,esa); 3389 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; 3390 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); 3391 return retspec; 3392 } 3393 if ((cp1 = strstr(esa,".][000000]")) != NULL) { 3394 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2; 3395 *cp1 = '\0'; 3396 dirnam.nam$b_esl -= 9; 3397 } 3398 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>'); 3399 if (cp1 == NULL) { /* should never happen */ 3400 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; 3401 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); 3402 return NULL; 3403 } 3404 term = *cp1; 3405 *cp1 = '\0'; 3406 retlen = strlen(esa); 3407 if ((cp1 = strrchr(esa,'.')) != NULL) { 3408 /* There's more than one directory in the path. Just roll back. */ 3409 *cp1 = term; 3410 if (buf) retspec = buf; 3411 else if (ts) Newx(retspec,retlen+7,char); 3412 else retspec = __fileify_retbuf; 3413 strcpy(retspec,esa); 3414 } 3415 else { 3416 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) { 3417 /* Go back and expand rooted logical name */ 3418 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL; 3419 if (!(sys$parse(&dirfab) & 1)) { 3420 dirnam.nam$l_rlf = NULL; 3421 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); 3422 set_errno(EVMSERR); 3423 set_vaxc_errno(dirfab.fab$l_sts); 3424 return NULL; 3425 } 3426 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */ 3427 if (buf) retspec = buf; 3428 else if (ts) Newx(retspec,retlen+16,char); 3429 else retspec = __fileify_retbuf; 3430 cp1 = strstr(esa,"]["); 3431 if (!cp1) cp1 = strstr(esa,"]<"); 3432 dirlen = cp1 - esa; 3433 memcpy(retspec,esa,dirlen); 3434 if (!strncmp(cp1+2,"000000]",7)) { 3435 retspec[dirlen-1] = '\0'; 3436 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ; 3437 if (*cp1 == '.') *cp1 = ']'; 3438 else { 3439 memmove(cp1+8,cp1+1,retspec+dirlen-cp1); 3440 memcpy(cp1+1,"000000]",7); 3441 } 3442 } 3443 else { 3444 memcpy(retspec+dirlen,cp1+2,retlen-dirlen); 3445 retspec[retlen] = '\0'; 3446 /* Convert last '.' to ']' */ 3447 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ; 3448 if (*cp1 == '.') *cp1 = ']'; 3449 else { 3450 memmove(cp1+8,cp1+1,retspec+dirlen-cp1); 3451 memcpy(cp1+1,"000000]",7); 3452 } 3453 } 3454 } 3455 else { /* This is a top-level dir. Add the MFD to the path. */ 3456 if (buf) retspec = buf; 3457 else if (ts) Newx(retspec,retlen+16,char); 3458 else retspec = __fileify_retbuf; 3459 cp1 = esa; 3460 cp2 = retspec; 3461 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++); 3462 strcpy(cp2,":[000000]"); 3463 cp1 += 2; 3464 strcpy(cp2+9,cp1); 3465 } 3466 } 3467 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; 3468 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); 3469 /* We've set up the string up through the filename. Add the 3470 type and version, and we're done. */ 3471 strcat(retspec,".DIR;1"); 3472 3473 /* $PARSE may have upcased filespec, so convert output to lower 3474 * case if input contained any lowercase characters. */ 3475 if (haslower) __mystrtolower(retspec); 3476 return retspec; 3477 } 3478 } /* end of do_fileify_dirspec() */ 3479 /*}}}*/ 3480 /* External entry points */ 3481 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf) 3482 { return do_fileify_dirspec(dir,buf,0); } 3483 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf) 3484 { return do_fileify_dirspec(dir,buf,1); } 3485 3486 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/ 3487 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts) 3488 { 3489 static char __pathify_retbuf[NAM$C_MAXRSS+1]; 3490 unsigned long int retlen; 3491 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1]; 3492 unsigned short int trnlnm_iter_count; 3493 STRLEN trnlen; 3494 3495 if (!dir || !*dir) { 3496 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL; 3497 } 3498 3499 if (*dir) strcpy(trndir,dir); 3500 else getcwd(trndir,sizeof trndir - 1); 3501 3502 trnlnm_iter_count = 0; 3503 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords 3504 && my_trnlnm(trndir,trndir,0)) { 3505 trnlnm_iter_count++; 3506 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break; 3507 trnlen = strlen(trndir); 3508 3509 /* Trap simple rooted lnms, and return lnm:[000000] */ 3510 if (!strcmp(trndir+trnlen-2,".]")) { 3511 if (buf) retpath = buf; 3512 else if (ts) Newx(retpath,strlen(dir)+10,char); 3513 else retpath = __pathify_retbuf; 3514 strcpy(retpath,dir); 3515 strcat(retpath,":[000000]"); 3516 return retpath; 3517 } 3518 } 3519 dir = trndir; 3520 3521 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */ 3522 if (*dir == '.' && (*(dir+1) == '\0' || 3523 (*(dir+1) == '.' && *(dir+2) == '\0'))) 3524 retlen = 2 + (*(dir+1) != '\0'); 3525 else { 3526 if ( !(cp1 = strrchr(dir,'/')) && 3527 !(cp1 = strrchr(dir,']')) && 3528 !(cp1 = strrchr(dir,'>')) ) cp1 = dir; 3529 if ((cp2 = strchr(cp1,'.')) != NULL && 3530 (*(cp2-1) != '/' || /* Trailing '.', '..', */ 3531 !(*(cp2+1) == '\0' || /* or '...' are dirs. */ 3532 (*(cp2+1) == '.' && *(cp2+2) == '\0') || 3533 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) { 3534 int ver; char *cp3; 3535 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */ 3536 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */ 3537 !*(cp2+3) || toupper(*(cp2+3)) != 'R' || 3538 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') || 3539 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 && 3540 (ver || *cp3)))))) { 3541 set_errno(ENOTDIR); 3542 set_vaxc_errno(RMS$_DIR); 3543 return NULL; 3544 } 3545 retlen = cp2 - dir + 1; 3546 } 3547 else { /* No file type present. Treat the filename as a directory. */ 3548 retlen = strlen(dir) + 1; 3549 } 3550 } 3551 if (buf) retpath = buf; 3552 else if (ts) Newx(retpath,retlen+1,char); 3553 else retpath = __pathify_retbuf; 3554 strncpy(retpath,dir,retlen-1); 3555 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */ 3556 retpath[retlen-1] = '/'; /* with '/', add it. */ 3557 retpath[retlen] = '\0'; 3558 } 3559 else retpath[retlen-1] = '\0'; 3560 } 3561 else { /* VMS-style directory spec */ 3562 char esa[NAM$C_MAXRSS+1], *cp; 3563 unsigned long int sts, cmplen, haslower; 3564 struct FAB dirfab = cc$rms_fab; 3565 struct NAM savnam, dirnam = cc$rms_nam; 3566 3567 /* If we've got an explicit filename, we can just shuffle the string. */ 3568 if ( ( (cp1 = strrchr(dir,']')) != NULL || 3569 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) { 3570 if ((cp2 = strchr(cp1,'.')) != NULL) { 3571 int ver; char *cp3; 3572 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */ 3573 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */ 3574 !*(cp2+3) || toupper(*(cp2+3)) != 'R' || 3575 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') || 3576 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 && 3577 (ver || *cp3)))))) { 3578 set_errno(ENOTDIR); 3579 set_vaxc_errno(RMS$_DIR); 3580 return NULL; 3581 } 3582 } 3583 else { /* No file type, so just draw name into directory part */ 3584 for (cp2 = cp1; *cp2; cp2++) ; 3585 } 3586 *cp2 = *cp1; 3587 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */ 3588 *cp1 = '.'; 3589 /* We've now got a VMS 'path'; fall through */ 3590 } 3591 dirfab.fab$b_fns = strlen(dir); 3592 dirfab.fab$l_fna = dir; 3593 if (dir[dirfab.fab$b_fns-1] == ']' || 3594 dir[dirfab.fab$b_fns-1] == '>' || 3595 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */ 3596 if (buf) retpath = buf; 3597 else if (ts) Newx(retpath,strlen(dir)+1,char); 3598 else retpath = __pathify_retbuf; 3599 strcpy(retpath,dir); 3600 return retpath; 3601 } 3602 dirfab.fab$l_dna = ".DIR;1"; 3603 dirfab.fab$b_dns = 6; 3604 dirfab.fab$l_nam = &dirnam; 3605 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1; 3606 dirnam.nam$l_esa = esa; 3607 3608 for (cp = dir; *cp; cp++) 3609 if (islower(*cp)) { haslower = 1; break; } 3610 3611 if (!(sts = (sys$parse(&dirfab)&1))) { 3612 if (dirfab.fab$l_sts == RMS$_DIR) { 3613 dirnam.nam$b_nop |= NAM$M_SYNCHK; 3614 sts = sys$parse(&dirfab) & 1; 3615 } 3616 if (!sts) { 3617 set_errno(EVMSERR); 3618 set_vaxc_errno(dirfab.fab$l_sts); 3619 return NULL; 3620 } 3621 } 3622 else { 3623 savnam = dirnam; 3624 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */ 3625 if (dirfab.fab$l_sts != RMS$_FNF) { 3626 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; 3627 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); 3628 set_errno(EVMSERR); 3629 set_vaxc_errno(dirfab.fab$l_sts); 3630 return NULL; 3631 } 3632 dirnam = savnam; /* No; just work with potential name */ 3633 } 3634 } 3635 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */ 3636 /* Yep; check version while we're at it, if it's there. */ 3637 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4; 3638 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) { 3639 /* Something other than .DIR[;1]. Bzzt. */ 3640 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; 3641 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); 3642 set_errno(ENOTDIR); 3643 set_vaxc_errno(RMS$_DIR); 3644 return NULL; 3645 } 3646 } 3647 /* OK, the type was fine. Now pull any file name into the 3648 directory path. */ 3649 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']'; 3650 else { 3651 cp1 = strrchr(esa,'>'); 3652 *dirnam.nam$l_type = '>'; 3653 } 3654 *cp1 = '.'; 3655 *(dirnam.nam$l_type + 1) = '\0'; 3656 retlen = dirnam.nam$l_type - esa + 2; 3657 if (buf) retpath = buf; 3658 else if (ts) Newx(retpath,retlen,char); 3659 else retpath = __pathify_retbuf; 3660 strcpy(retpath,esa); 3661 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; 3662 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); 3663 /* $PARSE may have upcased filespec, so convert output to lower 3664 * case if input contained any lowercase characters. */ 3665 if (haslower) __mystrtolower(retpath); 3666 } 3667 3668 return retpath; 3669 } /* end of do_pathify_dirspec() */ 3670 /*}}}*/ 3671 /* External entry points */ 3672 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf) 3673 { return do_pathify_dirspec(dir,buf,0); } 3674 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf) 3675 { return do_pathify_dirspec(dir,buf,1); } 3676 3677 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/ 3678 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts) 3679 { 3680 static char __tounixspec_retbuf[NAM$C_MAXRSS+1]; 3681 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1]; 3682 int devlen, dirlen, retlen = NAM$C_MAXRSS+1; 3683 int expand = 1; /* guarantee room for leading and trailing slashes */ 3684 unsigned short int trnlnm_iter_count; 3685 3686 if (spec == NULL) return NULL; 3687 if (strlen(spec) > NAM$C_MAXRSS) return NULL; 3688 if (buf) rslt = buf; 3689 else if (ts) { 3690 retlen = strlen(spec); 3691 cp1 = strchr(spec,'['); 3692 if (!cp1) cp1 = strchr(spec,'<'); 3693 if (cp1) { 3694 for (cp1++; *cp1; cp1++) { 3695 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */ 3696 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.') 3697 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */ 3698 } 3699 } 3700 Newx(rslt,retlen+2+2*expand,char); 3701 } 3702 else rslt = __tounixspec_retbuf; 3703 if (strchr(spec,'/') != NULL) { 3704 strcpy(rslt,spec); 3705 return rslt; 3706 } 3707 3708 cp1 = rslt; 3709 cp2 = spec; 3710 dirend = strrchr(spec,']'); 3711 if (dirend == NULL) dirend = strrchr(spec,'>'); 3712 if (dirend == NULL) dirend = strchr(spec,':'); 3713 if (dirend == NULL) { 3714 strcpy(rslt,spec); 3715 return rslt; 3716 } 3717 if (*cp2 != '[' && *cp2 != '<') { 3718 *(cp1++) = '/'; 3719 } 3720 else { /* the VMS spec begins with directories */ 3721 cp2++; 3722 if (*cp2 == ']' || *cp2 == '>') { 3723 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0'; 3724 return rslt; 3725 } 3726 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */ 3727 if (getcwd(tmp,sizeof tmp,1) == NULL) { 3728 if (ts) Safefree(rslt); 3729 return NULL; 3730 } 3731 trnlnm_iter_count = 0; 3732 do { 3733 cp3 = tmp; 3734 while (*cp3 != ':' && *cp3) cp3++; 3735 *(cp3++) = '\0'; 3736 if (strchr(cp3,']') != NULL) break; 3737 trnlnm_iter_count++; 3738 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break; 3739 } while (vmstrnenv(tmp,tmp,0,fildev,0)); 3740 if (ts && !buf && 3741 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) { 3742 retlen = devlen + dirlen; 3743 Renew(rslt,retlen+1+2*expand,char); 3744 cp1 = rslt; 3745 } 3746 cp3 = tmp; 3747 *(cp1++) = '/'; 3748 while (*cp3) { 3749 *(cp1++) = *(cp3++); 3750 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */ 3751 } 3752 *(cp1++) = '/'; 3753 } 3754 else if ( *cp2 == '.') { 3755 if (*(cp2+1) == '.' && *(cp2+2) == '.') { 3756 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/'; 3757 cp2 += 3; 3758 } 3759 else cp2++; 3760 } 3761 } 3762 for (; cp2 <= dirend; cp2++) { 3763 if (*cp2 == ':') { 3764 *(cp1++) = '/'; 3765 if (*(cp2+1) == '[') cp2++; 3766 } 3767 else if (*cp2 == ']' || *cp2 == '>') { 3768 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */ 3769 } 3770 else if (*cp2 == '.') { 3771 *(cp1++) = '/'; 3772 if (*(cp2+1) == ']' || *(cp2+1) == '>') { 3773 while (*(cp2+1) == ']' || *(cp2+1) == '>' || 3774 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++; 3775 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' || 3776 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7; 3777 } 3778 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') { 3779 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/'; 3780 cp2 += 2; 3781 } 3782 } 3783 else if (*cp2 == '-') { 3784 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') { 3785 while (*cp2 == '-') { 3786 cp2++; 3787 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/'; 3788 } 3789 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */ 3790 if (ts) Safefree(rslt); /* filespecs like */ 3791 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */ 3792 return NULL; 3793 } 3794 } 3795 else *(cp1++) = *cp2; 3796 } 3797 else *(cp1++) = *cp2; 3798 } 3799 while (*cp2) *(cp1++) = *(cp2++); 3800 *cp1 = '\0'; 3801 3802 return rslt; 3803 3804 } /* end of do_tounixspec() */ 3805 /*}}}*/ 3806 /* External entry points */ 3807 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); } 3808 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); } 3809 3810 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/ 3811 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) { 3812 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1]; 3813 char *rslt, *dirend; 3814 register char *cp1, *cp2; 3815 unsigned long int infront = 0, hasdir = 1; 3816 3817 if (path == NULL) return NULL; 3818 if (buf) rslt = buf; 3819 else if (ts) Newx(rslt,NAM$C_MAXRSS+1,char); 3820 else rslt = __tovmsspec_retbuf; 3821 if (strpbrk(path,"]:>") || 3822 (dirend = strrchr(path,'/')) == NULL) { 3823 if (path[0] == '.') { 3824 if (path[1] == '\0') strcpy(rslt,"[]"); 3825 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]"); 3826 else strcpy(rslt,path); /* probably garbage */ 3827 } 3828 else strcpy(rslt,path); 3829 return rslt; 3830 } 3831 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */ 3832 if (!*(dirend+2)) dirend +=2; 3833 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3; 3834 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4; 3835 } 3836 cp1 = rslt; 3837 cp2 = path; 3838 if (*cp2 == '/') { 3839 char trndev[NAM$C_MAXRSS+1]; 3840 int islnm, rooted; 3841 STRLEN trnend; 3842 3843 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */ 3844 if (!*(cp2+1)) { 3845 strcpy(rslt,"sys$disk:[000000]"); 3846 return rslt; 3847 } 3848 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2; 3849 *cp1 = '\0'; 3850 islnm = my_trnlnm(rslt,trndev,0); 3851 trnend = islnm ? strlen(trndev) - 1 : 0; 3852 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0; 3853 rooted = islnm ? (trndev[trnend-1] == '.') : 0; 3854 /* If the first element of the path is a logical name, determine 3855 * whether it has to be translated so we can add more directories. */ 3856 if (!islnm || rooted) { 3857 *(cp1++) = ':'; 3858 *(cp1++) = '['; 3859 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0'; 3860 else cp2++; 3861 } 3862 else { 3863 if (cp2 != dirend) { 3864 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char); 3865 strcpy(rslt,trndev); 3866 cp1 = rslt + trnend; 3867 if (*cp2 != 0) { 3868 *(cp1++) = '.'; 3869 cp2++; 3870 } 3871 } 3872 else { 3873 *(cp1++) = ':'; 3874 hasdir = 0; 3875 } 3876 } 3877 } 3878 else { 3879 *(cp1++) = '['; 3880 if (*cp2 == '.') { 3881 if (*(cp2+1) == '/' || *(cp2+1) == '\0') { 3882 cp2 += 2; /* skip over "./" - it's redundant */ 3883 *(cp1++) = '.'; /* but it does indicate a relative dirspec */ 3884 } 3885 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) { 3886 *(cp1++) = '-'; /* "../" --> "-" */ 3887 cp2 += 3; 3888 } 3889 else if (*(cp2+1) == '.' && *(cp2+2) == '.' && 3890 (*(cp2+3) == '/' || *(cp2+3) == '\0')) { 3891 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */ 3892 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */ 3893 cp2 += 4; 3894 } 3895 if (cp2 > dirend) cp2 = dirend; 3896 } 3897 else *(cp1++) = '.'; 3898 } 3899 for (; cp2 < dirend; cp2++) { 3900 if (*cp2 == '/') { 3901 if (*(cp2-1) == '/') continue; 3902 if (*(cp1-1) != '.') *(cp1++) = '.'; 3903 infront = 0; 3904 } 3905 else if (!infront && *cp2 == '.') { 3906 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; } 3907 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */ 3908 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) { 3909 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */ 3910 else if (*(cp1-2) == '[') *(cp1-1) = '-'; 3911 else { /* back up over previous directory name */ 3912 cp1--; 3913 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--; 3914 if (*(cp1-1) == '[') { 3915 memcpy(cp1,"000000.",7); 3916 cp1 += 7; 3917 } 3918 } 3919 cp2 += 2; 3920 if (cp2 == dirend) break; 3921 } 3922 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' && 3923 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) { 3924 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */ 3925 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */ 3926 if (!*(cp2+3)) { 3927 *(cp1++) = '.'; /* Simulate trailing '/' */ 3928 cp2 += 2; /* for loop will incr this to == dirend */ 3929 } 3930 else cp2 += 3; /* Trailing '/' was there, so skip it, too */ 3931 } 3932 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */ 3933 } 3934 else { 3935 if (!infront && *(cp1-1) == '-') *(cp1++) = '.'; 3936 if (*cp2 == '.') *(cp1++) = '_'; 3937 else *(cp1++) = *cp2; 3938 infront = 1; 3939 } 3940 } 3941 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */ 3942 if (hasdir) *(cp1++) = ']'; 3943 if (*cp2) cp2++; /* check in case we ended with trailing '..' */ 3944 while (*cp2) *(cp1++) = *(cp2++); 3945 *cp1 = '\0'; 3946 3947 return rslt; 3948 3949 } /* end of do_tovmsspec() */ 3950 /*}}}*/ 3951 /* External entry points */ 3952 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); } 3953 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); } 3954 3955 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/ 3956 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) { 3957 static char __tovmspath_retbuf[NAM$C_MAXRSS+1]; 3958 int vmslen; 3959 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp; 3960 3961 if (path == NULL) return NULL; 3962 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL; 3963 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL; 3964 if (buf) return buf; 3965 else if (ts) { 3966 vmslen = strlen(vmsified); 3967 Newx(cp,vmslen+1,char); 3968 memcpy(cp,vmsified,vmslen); 3969 cp[vmslen] = '\0'; 3970 return cp; 3971 } 3972 else { 3973 strcpy(__tovmspath_retbuf,vmsified); 3974 return __tovmspath_retbuf; 3975 } 3976 3977 } /* end of do_tovmspath() */ 3978 /*}}}*/ 3979 /* External entry points */ 3980 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); } 3981 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); } 3982 3983 3984 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/ 3985 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) { 3986 static char __tounixpath_retbuf[NAM$C_MAXRSS+1]; 3987 int unixlen; 3988 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp; 3989 3990 if (path == NULL) return NULL; 3991 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL; 3992 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL; 3993 if (buf) return buf; 3994 else if (ts) { 3995 unixlen = strlen(unixified); 3996 Newx(cp,unixlen+1,char); 3997 memcpy(cp,unixified,unixlen); 3998 cp[unixlen] = '\0'; 3999 return cp; 4000 } 4001 else { 4002 strcpy(__tounixpath_retbuf,unixified); 4003 return __tounixpath_retbuf; 4004 } 4005 4006 } /* end of do_tounixpath() */ 4007 /*}}}*/ 4008 /* External entry points */ 4009 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); } 4010 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); } 4011 4012 /* 4013 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com) 4014 * 4015 ***************************************************************************** 4016 * * 4017 * Copyright (C) 1989-1994 by * 4018 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 * 4019 * * 4020 * Permission is hereby granted for the reproduction of this software, * 4021 * on condition that this copyright notice is included in the reproduction, * 4022 * and that such reproduction is not for purposes of profit or material * 4023 * gain. * 4024 * * 4025 * 27-Aug-1994 Modified for inclusion in perl5 * 4026 * by Charles Bailey bailey@newman.upenn.edu * 4027 ***************************************************************************** 4028 */ 4029 4030 /* 4031 * getredirection() is intended to aid in porting C programs 4032 * to VMS (Vax-11 C). The native VMS environment does not support 4033 * '>' and '<' I/O redirection, or command line wild card expansion, 4034 * or a command line pipe mechanism using the '|' AND background 4035 * command execution '&'. All of these capabilities are provided to any 4036 * C program which calls this procedure as the first thing in the 4037 * main program. 4038 * The piping mechanism will probably work with almost any 'filter' type 4039 * of program. With suitable modification, it may useful for other 4040 * portability problems as well. 4041 * 4042 * Author: Mark Pizzolato mark@infocomm.com 4043 */ 4044 struct list_item 4045 { 4046 struct list_item *next; 4047 char *value; 4048 }; 4049 4050 static void add_item(struct list_item **head, 4051 struct list_item **tail, 4052 char *value, 4053 int *count); 4054 4055 static void mp_expand_wild_cards(pTHX_ char *item, 4056 struct list_item **head, 4057 struct list_item **tail, 4058 int *count); 4059 4060 static int background_process(pTHX_ int argc, char **argv); 4061 4062 static void pipe_and_fork(pTHX_ char **cmargv); 4063 4064 /*{{{ void getredirection(int *ac, char ***av)*/ 4065 static void 4066 mp_getredirection(pTHX_ int *ac, char ***av) 4067 /* 4068 * Process vms redirection arg's. Exit if any error is seen. 4069 * If getredirection() processes an argument, it is erased 4070 * from the vector. getredirection() returns a new argc and argv value. 4071 * In the event that a background command is requested (by a trailing "&"), 4072 * this routine creates a background subprocess, and simply exits the program. 4073 * 4074 * Warning: do not try to simplify the code for vms. The code 4075 * presupposes that getredirection() is called before any data is 4076 * read from stdin or written to stdout. 4077 * 4078 * Normal usage is as follows: 4079 * 4080 * main(argc, argv) 4081 * int argc; 4082 * char *argv[]; 4083 * { 4084 * getredirection(&argc, &argv); 4085 * } 4086 */ 4087 { 4088 int argc = *ac; /* Argument Count */ 4089 char **argv = *av; /* Argument Vector */ 4090 char *ap; /* Argument pointer */ 4091 int j; /* argv[] index */ 4092 int item_count = 0; /* Count of Items in List */ 4093 struct list_item *list_head = 0; /* First Item in List */ 4094 struct list_item *list_tail; /* Last Item in List */ 4095 char *in = NULL; /* Input File Name */ 4096 char *out = NULL; /* Output File Name */ 4097 char *outmode = "w"; /* Mode to Open Output File */ 4098 char *err = NULL; /* Error File Name */ 4099 char *errmode = "w"; /* Mode to Open Error File */ 4100 int cmargc = 0; /* Piped Command Arg Count */ 4101 char **cmargv = NULL;/* Piped Command Arg Vector */ 4102 4103 /* 4104 * First handle the case where the last thing on the line ends with 4105 * a '&'. This indicates the desire for the command to be run in a 4106 * subprocess, so we satisfy that desire. 4107 */ 4108 ap = argv[argc-1]; 4109 if (0 == strcmp("&", ap)) 4110 exit(background_process(aTHX_ --argc, argv)); 4111 if (*ap && '&' == ap[strlen(ap)-1]) 4112 { 4113 ap[strlen(ap)-1] = '\0'; 4114 exit(background_process(aTHX_ argc, argv)); 4115 } 4116 /* 4117 * Now we handle the general redirection cases that involve '>', '>>', 4118 * '<', and pipes '|'. 4119 */ 4120 for (j = 0; j < argc; ++j) 4121 { 4122 if (0 == strcmp("<", argv[j])) 4123 { 4124 if (j+1 >= argc) 4125 { 4126 fprintf(stderr,"No input file after < on command line"); 4127 exit(LIB$_WRONUMARG); 4128 } 4129 in = argv[++j]; 4130 continue; 4131 } 4132 if ('<' == *(ap = argv[j])) 4133 { 4134 in = 1 + ap; 4135 continue; 4136 } 4137 if (0 == strcmp(">", ap)) 4138 { 4139 if (j+1 >= argc) 4140 { 4141 fprintf(stderr,"No output file after > on command line"); 4142 exit(LIB$_WRONUMARG); 4143 } 4144 out = argv[++j]; 4145 continue; 4146 } 4147 if ('>' == *ap) 4148 { 4149 if ('>' == ap[1]) 4150 { 4151 outmode = "a"; 4152 if ('\0' == ap[2]) 4153 out = argv[++j]; 4154 else 4155 out = 2 + ap; 4156 } 4157 else 4158 out = 1 + ap; 4159 if (j >= argc) 4160 { 4161 fprintf(stderr,"No output file after > or >> on command line"); 4162 exit(LIB$_WRONUMARG); 4163 } 4164 continue; 4165 } 4166 if (('2' == *ap) && ('>' == ap[1])) 4167 { 4168 if ('>' == ap[2]) 4169 { 4170 errmode = "a"; 4171 if ('\0' == ap[3]) 4172 err = argv[++j]; 4173 else 4174 err = 3 + ap; 4175 } 4176 else 4177 if ('\0' == ap[2]) 4178 err = argv[++j]; 4179 else 4180 err = 2 + ap; 4181 if (j >= argc) 4182 { 4183 fprintf(stderr,"No output file after 2> or 2>> on command line"); 4184 exit(LIB$_WRONUMARG); 4185 } 4186 continue; 4187 } 4188 if (0 == strcmp("|", argv[j])) 4189 { 4190 if (j+1 >= argc) 4191 { 4192 fprintf(stderr,"No command into which to pipe on command line"); 4193 exit(LIB$_WRONUMARG); 4194 } 4195 cmargc = argc-(j+1); 4196 cmargv = &argv[j+1]; 4197 argc = j; 4198 continue; 4199 } 4200 if ('|' == *(ap = argv[j])) 4201 { 4202 ++argv[j]; 4203 cmargc = argc-j; 4204 cmargv = &argv[j]; 4205 argc = j; 4206 continue; 4207 } 4208 expand_wild_cards(ap, &list_head, &list_tail, &item_count); 4209 } 4210 /* 4211 * Allocate and fill in the new argument vector, Some Unix's terminate 4212 * the list with an extra null pointer. 4213 */ 4214 Newx(argv, item_count+1, char *); 4215 *av = argv; 4216 for (j = 0; j < item_count; ++j, list_head = list_head->next) 4217 argv[j] = list_head->value; 4218 *ac = item_count; 4219 if (cmargv != NULL) 4220 { 4221 if (out != NULL) 4222 { 4223 fprintf(stderr,"'|' and '>' may not both be specified on command line"); 4224 exit(LIB$_INVARGORD); 4225 } 4226 pipe_and_fork(aTHX_ cmargv); 4227 } 4228 4229 /* Check for input from a pipe (mailbox) */ 4230 4231 if (in == NULL && 1 == isapipe(0)) 4232 { 4233 char mbxname[L_tmpnam]; 4234 long int bufsize; 4235 long int dvi_item = DVI$_DEVBUFSIZ; 4236 $DESCRIPTOR(mbxnam, ""); 4237 $DESCRIPTOR(mbxdevnam, ""); 4238 4239 /* Input from a pipe, reopen it in binary mode to disable */ 4240 /* carriage control processing. */ 4241 4242 fgetname(stdin, mbxname); 4243 mbxnam.dsc$a_pointer = mbxname; 4244 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer); 4245 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0); 4246 mbxdevnam.dsc$a_pointer = mbxname; 4247 mbxdevnam.dsc$w_length = sizeof(mbxname); 4248 dvi_item = DVI$_DEVNAM; 4249 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length); 4250 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0'; 4251 set_errno(0); 4252 set_vaxc_errno(1); 4253 freopen(mbxname, "rb", stdin); 4254 if (errno != 0) 4255 { 4256 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname); 4257 exit(vaxc$errno); 4258 } 4259 } 4260 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2"))) 4261 { 4262 fprintf(stderr,"Can't open input file %s as stdin",in); 4263 exit(vaxc$errno); 4264 } 4265 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2"))) 4266 { 4267 fprintf(stderr,"Can't open output file %s as stdout",out); 4268 exit(vaxc$errno); 4269 } 4270 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out); 4271 4272 if (err != NULL) { 4273 if (strcmp(err,"&1") == 0) { 4274 dup2(fileno(stdout), fileno(stderr)); 4275 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT"); 4276 } else { 4277 FILE *tmperr; 4278 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2"))) 4279 { 4280 fprintf(stderr,"Can't open error file %s as stderr",err); 4281 exit(vaxc$errno); 4282 } 4283 fclose(tmperr); 4284 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2")) 4285 { 4286 exit(vaxc$errno); 4287 } 4288 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err); 4289 } 4290 } 4291 #ifdef ARGPROC_DEBUG 4292 PerlIO_printf(Perl_debug_log, "Arglist:\n"); 4293 for (j = 0; j < *ac; ++j) 4294 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]); 4295 #endif 4296 /* Clear errors we may have hit expanding wildcards, so they don't 4297 show up in Perl's $! later */ 4298 set_errno(0); set_vaxc_errno(1); 4299 } /* end of getredirection() */ 4300 /*}}}*/ 4301 4302 static void add_item(struct list_item **head, 4303 struct list_item **tail, 4304 char *value, 4305 int *count) 4306 { 4307 if (*head == 0) 4308 { 4309 Newx(*head,1,struct list_item); 4310 *tail = *head; 4311 } 4312 else { 4313 Newx((*tail)->next,1,struct list_item); 4314 *tail = (*tail)->next; 4315 } 4316 (*tail)->value = value; 4317 ++(*count); 4318 } 4319 4320 static void mp_expand_wild_cards(pTHX_ char *item, 4321 struct list_item **head, 4322 struct list_item **tail, 4323 int *count) 4324 { 4325 int expcount = 0; 4326 unsigned long int context = 0; 4327 int isunix = 0; 4328 int item_len = 0; 4329 char *had_version; 4330 char *had_device; 4331 int had_directory; 4332 char *devdir,*cp; 4333 char vmsspec[NAM$C_MAXRSS+1]; 4334 $DESCRIPTOR(filespec, ""); 4335 $DESCRIPTOR(defaultspec, "SYS$DISK:[]"); 4336 $DESCRIPTOR(resultspec, ""); 4337 unsigned long int zero = 0, sts; 4338 4339 for (cp = item; *cp; cp++) { 4340 if (*cp == '*' || *cp == '%' || isspace(*cp)) break; 4341 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break; 4342 } 4343 if (!*cp || isspace(*cp)) 4344 { 4345 add_item(head, tail, item, count); 4346 return; 4347 } 4348 else 4349 { 4350 /* "double quoted" wild card expressions pass as is */ 4351 /* From DCL that means using e.g.: */ 4352 /* perl program """perl.*""" */ 4353 item_len = strlen(item); 4354 if ( '"' == *item && '"' == item[item_len-1] ) 4355 { 4356 item++; 4357 item[item_len-2] = '\0'; 4358 add_item(head, tail, item, count); 4359 return; 4360 } 4361 } 4362 resultspec.dsc$b_dtype = DSC$K_DTYPE_T; 4363 resultspec.dsc$b_class = DSC$K_CLASS_D; 4364 resultspec.dsc$a_pointer = NULL; 4365 if ((isunix = (int) strchr(item,'/')) != (int) NULL) 4366 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0); 4367 if (!isunix || !filespec.dsc$a_pointer) 4368 filespec.dsc$a_pointer = item; 4369 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer); 4370 /* 4371 * Only return version specs, if the caller specified a version 4372 */ 4373 had_version = strchr(item, ';'); 4374 /* 4375 * Only return device and directory specs, if the caller specifed either. 4376 */ 4377 had_device = strchr(item, ':'); 4378 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<')); 4379 4380 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context, 4381 &defaultspec, 0, 0, &zero)))) 4382 { 4383 char *string; 4384 char *c; 4385 4386 Newx(string,resultspec.dsc$w_length+1,char); 4387 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length); 4388 string[resultspec.dsc$w_length] = '\0'; 4389 if (NULL == had_version) 4390 *((char *)strrchr(string, ';')) = '\0'; 4391 if ((!had_directory) && (had_device == NULL)) 4392 { 4393 if (NULL == (devdir = strrchr(string, ']'))) 4394 devdir = strrchr(string, '>'); 4395 strcpy(string, devdir + 1); 4396 } 4397 /* 4398 * Be consistent with what the C RTL has already done to the rest of 4399 * the argv items and lowercase all of these names. 4400 */ 4401 for (c = string; *c; ++c) 4402 if (isupper(*c)) 4403 *c = tolower(*c); 4404 if (isunix) trim_unixpath(string,item,1); 4405 add_item(head, tail, string, count); 4406 ++expcount; 4407 } 4408 if (sts != RMS$_NMF) 4409 { 4410 set_vaxc_errno(sts); 4411 switch (sts) 4412 { 4413 case RMS$_FNF: case RMS$_DNF: 4414 set_errno(ENOENT); break; 4415 case RMS$_DIR: 4416 set_errno(ENOTDIR); break; 4417 case RMS$_DEV: 4418 set_errno(ENODEV); break; 4419 case RMS$_FNM: case RMS$_SYN: 4420 set_errno(EINVAL); break; 4421 case RMS$_PRV: 4422 set_errno(EACCES); break; 4423 default: 4424 _ckvmssts_noperl(sts); 4425 } 4426 } 4427 if (expcount == 0) 4428 add_item(head, tail, item, count); 4429 _ckvmssts_noperl(lib$sfree1_dd(&resultspec)); 4430 _ckvmssts_noperl(lib$find_file_end(&context)); 4431 } 4432 4433 static int child_st[2];/* Event Flag set when child process completes */ 4434 4435 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */ 4436 4437 static unsigned long int exit_handler(int *status) 4438 { 4439 short iosb[4]; 4440 4441 if (0 == child_st[0]) 4442 { 4443 #ifdef ARGPROC_DEBUG 4444 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n"); 4445 #endif 4446 fflush(stdout); /* Have to flush pipe for binary data to */ 4447 /* terminate properly -- <tp@mccall.com> */ 4448 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0); 4449 sys$dassgn(child_chan); 4450 fclose(stdout); 4451 sys$synch(0, child_st); 4452 } 4453 return(1); 4454 } 4455 4456 static void sig_child(int chan) 4457 { 4458 #ifdef ARGPROC_DEBUG 4459 PerlIO_printf(Perl_debug_log, "Child Completion AST\n"); 4460 #endif 4461 if (child_st[0] == 0) 4462 child_st[0] = 1; 4463 } 4464 4465 static struct exit_control_block exit_block = 4466 { 4467 0, 4468 exit_handler, 4469 1, 4470 &exit_block.exit_status, 4471 0 4472 }; 4473 4474 static void 4475 pipe_and_fork(pTHX_ char **cmargv) 4476 { 4477 PerlIO *fp; 4478 struct dsc$descriptor_s *vmscmd; 4479 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q; 4480 int sts, j, l, ismcr, quote, tquote = 0; 4481 4482 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd); 4483 vms_execfree(vmscmd); 4484 4485 j = l = 0; 4486 p = subcmd; 4487 q = cmargv[0]; 4488 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C' 4489 && toupper(*(q+2)) == 'R' && !*(q+3); 4490 4491 while (q && l < MAX_DCL_LINE_LENGTH) { 4492 if (!*q) { 4493 if (j > 0 && quote) { 4494 *p++ = '"'; 4495 l++; 4496 } 4497 q = cmargv[++j]; 4498 if (q) { 4499 if (ismcr && j > 1) quote = 1; 4500 tquote = (strchr(q,' ')) != NULL || *q == '\0'; 4501 *p++ = ' '; 4502 l++; 4503 if (quote || tquote) { 4504 *p++ = '"'; 4505 l++; 4506 } 4507 } 4508 } else { 4509 if ((quote||tquote) && *q == '"') { 4510 *p++ = '"'; 4511 l++; 4512 } 4513 *p++ = *q++; 4514 l++; 4515 } 4516 } 4517 *p = '\0'; 4518 4519 fp = safe_popen(aTHX_ subcmd,"wbF",&sts); 4520 if (fp == Nullfp) { 4521 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts); 4522 } 4523 } 4524 4525 static int background_process(pTHX_ int argc, char **argv) 4526 { 4527 char command[2048] = "$"; 4528 $DESCRIPTOR(value, ""); 4529 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND"); 4530 static $DESCRIPTOR(null, "NLA0:"); 4531 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID"); 4532 char pidstring[80]; 4533 $DESCRIPTOR(pidstr, ""); 4534 int pid; 4535 unsigned long int flags = 17, one = 1, retsts; 4536 4537 strcat(command, argv[0]); 4538 while (--argc) 4539 { 4540 strcat(command, " \""); 4541 strcat(command, *(++argv)); 4542 strcat(command, "\""); 4543 } 4544 value.dsc$a_pointer = command; 4545 value.dsc$w_length = strlen(value.dsc$a_pointer); 4546 _ckvmssts_noperl(lib$set_symbol(&cmd, &value)); 4547 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid); 4548 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */ 4549 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid)); 4550 } 4551 else { 4552 _ckvmssts_noperl(retsts); 4553 } 4554 #ifdef ARGPROC_DEBUG 4555 PerlIO_printf(Perl_debug_log, "%s\n", command); 4556 #endif 4557 sprintf(pidstring, "%08X", pid); 4558 PerlIO_printf(Perl_debug_log, "%s\n", pidstring); 4559 pidstr.dsc$a_pointer = pidstring; 4560 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer); 4561 lib$set_symbol(&pidsymbol, &pidstr); 4562 return(SS$_NORMAL); 4563 } 4564 /*}}}*/ 4565 /***** End of code taken from Mark Pizzolato's argproc.c package *****/ 4566 4567 4568 /* OS-specific initialization at image activation (not thread startup) */ 4569 /* Older VAXC header files lack these constants */ 4570 #ifndef JPI$_RIGHTS_SIZE 4571 # define JPI$_RIGHTS_SIZE 817 4572 #endif 4573 #ifndef KGB$M_SUBSYSTEM 4574 # define KGB$M_SUBSYSTEM 0x8 4575 #endif 4576 4577 /*{{{void vms_image_init(int *, char ***)*/ 4578 void 4579 vms_image_init(int *argcp, char ***argvp) 4580 { 4581 char eqv[LNM$C_NAMLENGTH+1] = ""; 4582 unsigned int len, tabct = 8, tabidx = 0; 4583 unsigned long int *mask, iosb[2], i, rlst[128], rsz; 4584 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)]; 4585 unsigned short int dummy, rlen; 4586 struct dsc$descriptor_s **tabvec; 4587 #if defined(PERL_IMPLICIT_CONTEXT) 4588 pTHX = NULL; 4589 #endif 4590 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy}, 4591 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen}, 4592 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy}, 4593 { 0, 0, 0, 0} }; 4594 4595 #ifdef KILL_BY_SIGPRC 4596 (void) Perl_csighandler_init(); 4597 #endif 4598 4599 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL)); 4600 _ckvmssts_noperl(iosb[0]); 4601 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) { 4602 if (iprv[i]) { /* Running image installed with privs? */ 4603 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */ 4604 will_taint = TRUE; 4605 break; 4606 } 4607 } 4608 /* Rights identifiers might trigger tainting as well. */ 4609 if (!will_taint && (rlen || rsz)) { 4610 while (rlen < rsz) { 4611 /* We didn't get all the identifiers on the first pass. Allocate a 4612 * buffer much larger than $GETJPI wants (rsz is size in bytes that 4613 * were needed to hold all identifiers at time of last call; we'll 4614 * allocate that many unsigned long ints), and go back and get 'em. 4615 * If it gave us less than it wanted to despite ample buffer space, 4616 * something's broken. Is your system missing a system identifier? 4617 */ 4618 if (rsz <= jpilist[1].buflen) { 4619 /* Perl_croak accvios when used this early in startup. */ 4620 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s", 4621 rsz, (unsigned long) jpilist[1].buflen, 4622 "Check your rights database for corruption.\n"); 4623 exit(SS$_ABORT); 4624 } 4625 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr); 4626 jpilist[1].bufadr = Newx(mask,rsz,unsigned long int); 4627 jpilist[1].buflen = rsz * sizeof(unsigned long int); 4628 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL)); 4629 _ckvmssts_noperl(iosb[0]); 4630 } 4631 mask = jpilist[1].bufadr; 4632 /* Check attribute flags for each identifier (2nd longword); protected 4633 * subsystem identifiers trigger tainting. 4634 */ 4635 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) { 4636 if (mask[i] & KGB$M_SUBSYSTEM) { 4637 will_taint = TRUE; 4638 break; 4639 } 4640 } 4641 if (mask != rlst) Safefree(mask); 4642 } 4643 /* We need to use this hack to tell Perl it should run with tainting, 4644 * since its tainting flag may be part of the PL_curinterp struct, which 4645 * hasn't been allocated when vms_image_init() is called. 4646 */ 4647 if (will_taint) { 4648 char **newargv, **oldargv; 4649 oldargv = *argvp; 4650 Newx(newargv,(*argcp)+2,char *); 4651 newargv[0] = oldargv[0]; 4652 Newx(newargv[1],3,char); 4653 strcpy(newargv[1], "-T"); 4654 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **); 4655 (*argcp)++; 4656 newargv[*argcp] = NULL; 4657 /* We orphan the old argv, since we don't know where it's come from, 4658 * so we don't know how to free it. 4659 */ 4660 *argvp = newargv; 4661 } 4662 else { /* Did user explicitly request tainting? */ 4663 int i; 4664 char *cp, **av = *argvp; 4665 for (i = 1; i < *argcp; i++) { 4666 if (*av[i] != '-') break; 4667 for (cp = av[i]+1; *cp; cp++) { 4668 if (*cp == 'T') { will_taint = 1; break; } 4669 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' || 4670 strchr("DFIiMmx",*cp)) break; 4671 } 4672 if (will_taint) break; 4673 } 4674 } 4675 4676 for (tabidx = 0; 4677 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx); 4678 tabidx++) { 4679 if (!tabidx) Newx(tabvec,tabct,struct dsc$descriptor_s *); 4680 else if (tabidx >= tabct) { 4681 tabct += 8; 4682 Renew(tabvec,tabct,struct dsc$descriptor_s *); 4683 } 4684 Newx(tabvec[tabidx],1,struct dsc$descriptor_s); 4685 tabvec[tabidx]->dsc$w_length = 0; 4686 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T; 4687 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D; 4688 tabvec[tabidx]->dsc$a_pointer = NULL; 4689 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx])); 4690 } 4691 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; } 4692 4693 getredirection(argcp,argvp); 4694 #if ( defined(USE_5005THREADS) || defined(USE_ITHREADS) ) && ( defined(__DECC) || defined(__DECCXX) ) 4695 { 4696 # include <reentrancy.h> 4697 (void) decc$set_reentrancy(C$C_MULTITHREAD); 4698 } 4699 #endif 4700 return; 4701 } 4702 /*}}}*/ 4703 4704 4705 /* trim_unixpath() 4706 * Trim Unix-style prefix off filespec, so it looks like what a shell 4707 * glob expansion would return (i.e. from specified prefix on, not 4708 * full path). Note that returned filespec is Unix-style, regardless 4709 * of whether input filespec was VMS-style or Unix-style. 4710 * 4711 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to 4712 * determine prefix (both may be in VMS or Unix syntax). opts is a bit 4713 * vector of options; at present, only bit 0 is used, and if set tells 4714 * trim unixpath to try the current default directory as a prefix when 4715 * presented with a possibly ambiguous ... wildcard. 4716 * 4717 * Returns !=0 on success, with trimmed filespec replacing contents of 4718 * fspec, and 0 on failure, with contents of fpsec unchanged. 4719 */ 4720 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/ 4721 int 4722 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts) 4723 { 4724 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1], 4725 *template, *base, *end, *cp1, *cp2; 4726 register int tmplen, reslen = 0, dirs = 0; 4727 4728 if (!wildspec || !fspec) return 0; 4729 if (strpbrk(wildspec,"]>:") != NULL) { 4730 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0; 4731 else template = unixwild; 4732 } 4733 else template = wildspec; 4734 if (strpbrk(fspec,"]>:") != NULL) { 4735 if (do_tounixspec(fspec,unixified,0) == NULL) return 0; 4736 else base = unixified; 4737 /* reslen != 0 ==> we had to unixify resultant filespec, so we must 4738 * check to see that final result fits into (isn't longer than) fspec */ 4739 reslen = strlen(fspec); 4740 } 4741 else base = fspec; 4742 4743 /* No prefix or absolute path on wildcard, so nothing to remove */ 4744 if (!*template || *template == '/') { 4745 if (base == fspec) return 1; 4746 tmplen = strlen(unixified); 4747 if (tmplen > reslen) return 0; /* not enough space */ 4748 /* Copy unixified resultant, including trailing NUL */ 4749 memmove(fspec,unixified,tmplen+1); 4750 return 1; 4751 } 4752 4753 for (end = base; *end; end++) ; /* Find end of resultant filespec */ 4754 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */ 4755 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++; 4756 for (cp1 = end ;cp1 >= base; cp1--) 4757 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */ 4758 { cp1++; break; } 4759 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1); 4760 return 1; 4761 } 4762 else { 4763 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1]; 4764 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1; 4765 int ells = 1, totells, segdirs, match; 4766 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl}, 4767 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; 4768 4769 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;} 4770 totells = ells; 4771 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++; 4772 if (ellipsis == template && opts & 1) { 4773 /* Template begins with an ellipsis. Since we can't tell how many 4774 * directory names at the front of the resultant to keep for an 4775 * arbitrary starting point, we arbitrarily choose the current 4776 * default directory as a starting point. If it's there as a prefix, 4777 * clip it off. If not, fall through and act as if the leading 4778 * ellipsis weren't there (i.e. return shortest possible path that 4779 * could match template). 4780 */ 4781 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0; 4782 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++) 4783 if (_tolower(*cp1) != _tolower(*cp2)) break; 4784 segdirs = dirs - totells; /* Min # of dirs we must have left */ 4785 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--; 4786 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) { 4787 memcpy(fspec,cp2+1,end - cp2); 4788 return 1; 4789 } 4790 } 4791 /* First off, back up over constant elements at end of path */ 4792 if (dirs) { 4793 for (front = end ; front >= base; front--) 4794 if (*front == '/' && !dirs--) { front++; break; } 4795 } 4796 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres; 4797 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */ 4798 if (cp1 != '\0') return 0; /* Path too long. */ 4799 lcend = cp2; 4800 *cp2 = '\0'; /* Pick up with memcpy later */ 4801 lcfront = lcres + (front - base); 4802 /* Now skip over each ellipsis and try to match the path in front of it. */ 4803 while (ells--) { 4804 for (cp1 = ellipsis - 2; cp1 >= template; cp1--) 4805 if (*(cp1) == '.' && *(cp1+1) == '.' && 4806 *(cp1+2) == '.' && *(cp1+3) == '/' ) break; 4807 if (cp1 < template) break; /* template started with an ellipsis */ 4808 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */ 4809 ellipsis = cp1; continue; 4810 } 4811 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1; 4812 nextell = cp1; 4813 for (segdirs = 0, cp2 = tpl; 4814 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl; 4815 cp1++, cp2++) { 4816 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */ 4817 else *cp2 = _tolower(*cp1); /* else lowercase for match */ 4818 if (*cp2 == '/') segdirs++; 4819 } 4820 if (cp1 != ellipsis - 1) return 0; /* Path too long */ 4821 /* Back up at least as many dirs as in template before matching */ 4822 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--) 4823 if (*cp1 == '/' && !segdirs--) { cp1++; break; } 4824 for (match = 0; cp1 > lcres;) { 4825 resdsc.dsc$a_pointer = cp1; 4826 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) { 4827 match++; 4828 if (match == 1) lcfront = cp1; 4829 } 4830 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; } 4831 } 4832 if (!match) return 0; /* Can't find prefix ??? */ 4833 if (match > 1 && opts & 1) { 4834 /* This ... wildcard could cover more than one set of dirs (i.e. 4835 * a set of similar dir names is repeated). If the template 4836 * contains more than 1 ..., upstream elements could resolve the 4837 * ambiguity, but it's not worth a full backtracking setup here. 4838 * As a quick heuristic, clip off the current default directory 4839 * if it's present to find the trimmed spec, else use the 4840 * shortest string that this ... could cover. 4841 */ 4842 char def[NAM$C_MAXRSS+1], *st; 4843 4844 if (getcwd(def, sizeof def,0) == NULL) return 0; 4845 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++) 4846 if (_tolower(*cp1) != _tolower(*cp2)) break; 4847 segdirs = dirs - totells; /* Min # of dirs we must have left */ 4848 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--; 4849 if (*cp1 == '\0' && *cp2 == '/') { 4850 memcpy(fspec,cp2+1,end - cp2); 4851 return 1; 4852 } 4853 /* Nope -- stick with lcfront from above and keep going. */ 4854 } 4855 } 4856 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1); 4857 return 1; 4858 ellipsis = nextell; 4859 } 4860 4861 } /* end of trim_unixpath() */ 4862 /*}}}*/ 4863 4864 4865 /* 4866 * VMS readdir() routines. 4867 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990. 4868 * 4869 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu 4870 * Minor modifications to original routines. 4871 */ 4872 4873 /* readdir may have been redefined by reentr.h, so make sure we get 4874 * the local version for what we do here. 4875 */ 4876 #ifdef readdir 4877 # undef readdir 4878 #endif 4879 #if !defined(PERL_IMPLICIT_CONTEXT) 4880 # define readdir Perl_readdir 4881 #else 4882 # define readdir(a) Perl_readdir(aTHX_ a) 4883 #endif 4884 4885 /* Number of elements in vms_versions array */ 4886 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0]) 4887 4888 /* 4889 * Open a directory, return a handle for later use. 4890 */ 4891 /*{{{ DIR *opendir(char*name) */ 4892 DIR * 4893 Perl_opendir(pTHX_ char *name) 4894 { 4895 DIR *dd; 4896 char dir[NAM$C_MAXRSS+1]; 4897 Stat_t sb; 4898 4899 if (do_tovmspath(name,dir,0) == NULL) { 4900 return NULL; 4901 } 4902 /* Check access before stat; otherwise stat does not 4903 * accurately report whether it's a directory. 4904 */ 4905 if (!cando_by_name(S_IRUSR,0,dir)) { 4906 /* cando_by_name has already set errno */ 4907 return NULL; 4908 } 4909 if (flex_stat(dir,&sb) == -1) return NULL; 4910 if (!S_ISDIR(sb.st_mode)) { 4911 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR); 4912 return NULL; 4913 } 4914 /* Get memory for the handle, and the pattern. */ 4915 Newx(dd,1,DIR); 4916 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char); 4917 4918 /* Fill in the fields; mainly playing with the descriptor. */ 4919 (void)sprintf(dd->pattern, "%s*.*",dir); 4920 dd->context = 0; 4921 dd->count = 0; 4922 dd->vms_wantversions = 0; 4923 dd->pat.dsc$a_pointer = dd->pattern; 4924 dd->pat.dsc$w_length = strlen(dd->pattern); 4925 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T; 4926 dd->pat.dsc$b_class = DSC$K_CLASS_S; 4927 #if defined(USE_5005THREADS) || defined(USE_ITHREADS) 4928 Newx(dd->mutex,1,perl_mutex); 4929 MUTEX_INIT( (perl_mutex *) dd->mutex ); 4930 #else 4931 dd->mutex = NULL; 4932 #endif 4933 4934 return dd; 4935 } /* end of opendir() */ 4936 /*}}}*/ 4937 4938 /* 4939 * Set the flag to indicate we want versions or not. 4940 */ 4941 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/ 4942 void 4943 vmsreaddirversions(DIR *dd, int flag) 4944 { 4945 dd->vms_wantversions = flag; 4946 } 4947 /*}}}*/ 4948 4949 /* 4950 * Free up an opened directory. 4951 */ 4952 /*{{{ void closedir(DIR *dd)*/ 4953 void 4954 closedir(DIR *dd) 4955 { 4956 (void)lib$find_file_end(&dd->context); 4957 Safefree(dd->pattern); 4958 #if defined(USE_5005THREADS) || defined(USE_ITHREADS) 4959 MUTEX_DESTROY( (perl_mutex *) dd->mutex ); 4960 Safefree(dd->mutex); 4961 #endif 4962 Safefree((char *)dd); 4963 } 4964 /*}}}*/ 4965 4966 /* 4967 * Collect all the version numbers for the current file. 4968 */ 4969 static void 4970 collectversions(pTHX_ DIR *dd) 4971 { 4972 struct dsc$descriptor_s pat; 4973 struct dsc$descriptor_s res; 4974 struct dirent *e; 4975 char *p, *text, buff[sizeof dd->entry.d_name]; 4976 int i; 4977 unsigned long context, tmpsts; 4978 4979 /* Convenient shorthand. */ 4980 e = &dd->entry; 4981 4982 /* Add the version wildcard, ignoring the "*.*" put on before */ 4983 i = strlen(dd->pattern); 4984 Newx(text,i + e->d_namlen + 3,char); 4985 (void)strcpy(text, dd->pattern); 4986 (void)sprintf(&text[i - 3], "%s;*", e->d_name); 4987 4988 /* Set up the pattern descriptor. */ 4989 pat.dsc$a_pointer = text; 4990 pat.dsc$w_length = i + e->d_namlen - 1; 4991 pat.dsc$b_dtype = DSC$K_DTYPE_T; 4992 pat.dsc$b_class = DSC$K_CLASS_S; 4993 4994 /* Set up result descriptor. */ 4995 res.dsc$a_pointer = buff; 4996 res.dsc$w_length = sizeof buff - 2; 4997 res.dsc$b_dtype = DSC$K_DTYPE_T; 4998 res.dsc$b_class = DSC$K_CLASS_S; 4999 5000 /* Read files, collecting versions. */ 5001 for (context = 0, e->vms_verscount = 0; 5002 e->vms_verscount < VERSIZE(e); 5003 e->vms_verscount++) { 5004 tmpsts = lib$find_file(&pat, &res, &context); 5005 if (tmpsts == RMS$_NMF || context == 0) break; 5006 _ckvmssts(tmpsts); 5007 buff[sizeof buff - 1] = '\0'; 5008 if ((p = strchr(buff, ';'))) 5009 e->vms_versions[e->vms_verscount] = atoi(p + 1); 5010 else 5011 e->vms_versions[e->vms_verscount] = -1; 5012 } 5013 5014 _ckvmssts(lib$find_file_end(&context)); 5015 Safefree(text); 5016 5017 } /* end of collectversions() */ 5018 5019 /* 5020 * Read the next entry from the directory. 5021 */ 5022 /*{{{ struct dirent *readdir(DIR *dd)*/ 5023 struct dirent * 5024 Perl_readdir(pTHX_ DIR *dd) 5025 { 5026 struct dsc$descriptor_s res; 5027 char *p, buff[sizeof dd->entry.d_name]; 5028 unsigned long int tmpsts; 5029 5030 /* Set up result descriptor, and get next file. */ 5031 res.dsc$a_pointer = buff; 5032 res.dsc$w_length = sizeof buff - 2; 5033 res.dsc$b_dtype = DSC$K_DTYPE_T; 5034 res.dsc$b_class = DSC$K_CLASS_S; 5035 tmpsts = lib$find_file(&dd->pat, &res, &dd->context); 5036 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */ 5037 if (!(tmpsts & 1)) { 5038 set_vaxc_errno(tmpsts); 5039 switch (tmpsts) { 5040 case RMS$_PRV: 5041 set_errno(EACCES); break; 5042 case RMS$_DEV: 5043 set_errno(ENODEV); break; 5044 case RMS$_DIR: 5045 set_errno(ENOTDIR); break; 5046 case RMS$_FNF: case RMS$_DNF: 5047 set_errno(ENOENT); break; 5048 default: 5049 set_errno(EVMSERR); 5050 } 5051 return NULL; 5052 } 5053 dd->count++; 5054 /* Force the buffer to end with a NUL, and downcase name to match C convention. */ 5055 buff[sizeof buff - 1] = '\0'; 5056 for (p = buff; *p; p++) *p = _tolower(*p); 5057 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */ 5058 *p = '\0'; 5059 5060 /* Skip any directory component and just copy the name. */ 5061 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1); 5062 else (void)strcpy(dd->entry.d_name, buff); 5063 5064 /* Clobber the version. */ 5065 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0'; 5066 5067 dd->entry.d_namlen = strlen(dd->entry.d_name); 5068 dd->entry.vms_verscount = 0; 5069 if (dd->vms_wantversions) collectversions(aTHX_ dd); 5070 return &dd->entry; 5071 5072 } /* end of readdir() */ 5073 /*}}}*/ 5074 5075 /* 5076 * Read the next entry from the directory -- thread-safe version. 5077 */ 5078 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/ 5079 int 5080 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result) 5081 { 5082 int retval; 5083 5084 MUTEX_LOCK( (perl_mutex *) dd->mutex ); 5085 5086 entry = readdir(dd); 5087 *result = entry; 5088 retval = ( *result == NULL ? errno : 0 ); 5089 5090 MUTEX_UNLOCK( (perl_mutex *) dd->mutex ); 5091 5092 return retval; 5093 5094 } /* end of readdir_r() */ 5095 /*}}}*/ 5096 5097 /* 5098 * Return something that can be used in a seekdir later. 5099 */ 5100 /*{{{ long telldir(DIR *dd)*/ 5101 long 5102 telldir(DIR *dd) 5103 { 5104 return dd->count; 5105 } 5106 /*}}}*/ 5107 5108 /* 5109 * Return to a spot where we used to be. Brute force. 5110 */ 5111 /*{{{ void seekdir(DIR *dd,long count)*/ 5112 void 5113 Perl_seekdir(pTHX_ DIR *dd, long count) 5114 { 5115 int vms_wantversions; 5116 5117 /* If we haven't done anything yet... */ 5118 if (dd->count == 0) 5119 return; 5120 5121 /* Remember some state, and clear it. */ 5122 vms_wantversions = dd->vms_wantversions; 5123 dd->vms_wantversions = 0; 5124 _ckvmssts(lib$find_file_end(&dd->context)); 5125 dd->context = 0; 5126 5127 /* The increment is in readdir(). */ 5128 for (dd->count = 0; dd->count < count; ) 5129 (void)readdir(dd); 5130 5131 dd->vms_wantversions = vms_wantversions; 5132 5133 } /* end of seekdir() */ 5134 /*}}}*/ 5135 5136 /* VMS subprocess management 5137 * 5138 * my_vfork() - just a vfork(), after setting a flag to record that 5139 * the current script is trying a Unix-style fork/exec. 5140 * 5141 * vms_do_aexec() and vms_do_exec() are called in response to the 5142 * perl 'exec' function. If this follows a vfork call, then they 5143 * call out the regular perl routines in doio.c which do an 5144 * execvp (for those who really want to try this under VMS). 5145 * Otherwise, they do exactly what the perl docs say exec should 5146 * do - terminate the current script and invoke a new command 5147 * (See below for notes on command syntax.) 5148 * 5149 * do_aspawn() and do_spawn() implement the VMS side of the perl 5150 * 'system' function. 5151 * 5152 * Note on command arguments to perl 'exec' and 'system': When handled 5153 * in 'VMSish fashion' (i.e. not after a call to vfork) The args 5154 * are concatenated to form a DCL command string. If the first arg 5155 * begins with '$' (i.e. the perl script had "\$ Type" or some such), 5156 * the command string is handed off to DCL directly. Otherwise, 5157 * the first token of the command is taken as the filespec of an image 5158 * to run. The filespec is expanded using a default type of '.EXE' and 5159 * the process defaults for device, directory, etc., and if found, the resultant 5160 * filespec is invoked using the DCL verb 'MCR', and passed the rest of 5161 * the command string as parameters. This is perhaps a bit complicated, 5162 * but I hope it will form a happy medium between what VMS folks expect 5163 * from lib$spawn and what Unix folks expect from exec. 5164 */ 5165 5166 static int vfork_called; 5167 5168 /*{{{int my_vfork()*/ 5169 int 5170 my_vfork() 5171 { 5172 vfork_called++; 5173 return vfork(); 5174 } 5175 /*}}}*/ 5176 5177 5178 static void 5179 vms_execfree(struct dsc$descriptor_s *vmscmd) 5180 { 5181 if (vmscmd) { 5182 if (vmscmd->dsc$a_pointer) { 5183 Safefree(vmscmd->dsc$a_pointer); 5184 } 5185 Safefree(vmscmd); 5186 } 5187 } 5188 5189 static char * 5190 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp) 5191 { 5192 char *junk, *tmps = Nullch; 5193 register size_t cmdlen = 0; 5194 size_t rlen; 5195 register SV **idx; 5196 STRLEN n_a; 5197 5198 idx = mark; 5199 if (really) { 5200 tmps = SvPV(really,rlen); 5201 if (*tmps) { 5202 cmdlen += rlen + 1; 5203 idx++; 5204 } 5205 } 5206 5207 for (idx++; idx <= sp; idx++) { 5208 if (*idx) { 5209 junk = SvPVx(*idx,rlen); 5210 cmdlen += rlen ? rlen + 1 : 0; 5211 } 5212 } 5213 Newx(PL_Cmd,cmdlen+1,char); 5214 5215 if (tmps && *tmps) { 5216 strcpy(PL_Cmd,tmps); 5217 mark++; 5218 } 5219 else *PL_Cmd = '\0'; 5220 while (++mark <= sp) { 5221 if (*mark) { 5222 char *s = SvPVx(*mark,n_a); 5223 if (!*s) continue; 5224 if (*PL_Cmd) strcat(PL_Cmd," "); 5225 strcat(PL_Cmd,s); 5226 } 5227 } 5228 return PL_Cmd; 5229 5230 } /* end of setup_argstr() */ 5231 5232 5233 static unsigned long int 5234 setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote, 5235 struct dsc$descriptor_s **pvmscmd) 5236 { 5237 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1]; 5238 $DESCRIPTOR(defdsc,".EXE"); 5239 $DESCRIPTOR(defdsc2,"."); 5240 $DESCRIPTOR(resdsc,resspec); 5241 struct dsc$descriptor_s *vmscmd; 5242 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; 5243 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL; 5244 register char *s, *rest, *cp, *wordbreak; 5245 register int isdcl; 5246 5247 Newx(vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s); 5248 vmscmd->dsc$a_pointer = NULL; 5249 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T; 5250 vmscmd->dsc$b_class = DSC$K_CLASS_S; 5251 vmscmd->dsc$w_length = 0; 5252 if (pvmscmd) *pvmscmd = vmscmd; 5253 5254 if (suggest_quote) *suggest_quote = 0; 5255 5256 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) 5257 return CLI$_BUFOVF; /* continuation lines currently unsupported */ 5258 s = cmd; 5259 while (*s && isspace(*s)) s++; 5260 5261 if (*s == '@' || *s == '$') { 5262 vmsspec[0] = *s; rest = s + 1; 5263 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest; 5264 } 5265 else { cp = vmsspec; rest = s; } 5266 if (*rest == '.' || *rest == '/') { 5267 char *cp2; 5268 for (cp2 = resspec; 5269 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec; 5270 rest++, cp2++) *cp2 = *rest; 5271 *cp2 = '\0'; 5272 if (do_tovmsspec(resspec,cp,0)) { 5273 s = vmsspec; 5274 if (*rest) { 5275 for (cp2 = vmsspec + strlen(vmsspec); 5276 *rest && cp2 - vmsspec < sizeof vmsspec; 5277 rest++, cp2++) *cp2 = *rest; 5278 *cp2 = '\0'; 5279 } 5280 } 5281 } 5282 /* Intuit whether verb (first word of cmd) is a DCL command: 5283 * - if first nonspace char is '@', it's a DCL indirection 5284 * otherwise 5285 * - if verb contains a filespec separator, it's not a DCL command 5286 * - if it doesn't, caller tells us whether to default to a DCL 5287 * command, or to a local image unless told it's DCL (by leading '$') 5288 */ 5289 if (*s == '@') { 5290 isdcl = 1; 5291 if (suggest_quote) *suggest_quote = 1; 5292 } else { 5293 register char *filespec = strpbrk(s,":<[.;"); 5294 rest = wordbreak = strpbrk(s," \"\t/"); 5295 if (!wordbreak) wordbreak = s + strlen(s); 5296 if (*s == '$') check_img = 0; 5297 if (filespec && (filespec < wordbreak)) isdcl = 0; 5298 else isdcl = !check_img; 5299 } 5300 5301 if (!isdcl) { 5302 imgdsc.dsc$a_pointer = s; 5303 imgdsc.dsc$w_length = wordbreak - s; 5304 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags); 5305 if (!(retsts&1)) { 5306 _ckvmssts(lib$find_file_end(&cxt)); 5307 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags); 5308 if (!(retsts & 1) && *s == '$') { 5309 _ckvmssts(lib$find_file_end(&cxt)); 5310 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--; 5311 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags); 5312 if (!(retsts&1)) { 5313 _ckvmssts(lib$find_file_end(&cxt)); 5314 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags); 5315 } 5316 } 5317 } 5318 _ckvmssts(lib$find_file_end(&cxt)); 5319 5320 if (retsts & 1) { 5321 FILE *fp; 5322 s = resspec; 5323 while (*s && !isspace(*s)) s++; 5324 *s = '\0'; 5325 5326 /* check that it's really not DCL with no file extension */ 5327 fp = fopen(resspec,"r","ctx=bin","shr=get"); 5328 if (fp) { 5329 char b[4] = {0,0,0,0}; 5330 read(fileno(fp),b,4); 5331 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]); 5332 fclose(fp); 5333 } 5334 if (check_img && isdcl) return RMS$_FNF; 5335 5336 if (cando_by_name(S_IXUSR,0,resspec)) { 5337 Newx(vmscmd->dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char); 5338 if (!isdcl) { 5339 strcpy(vmscmd->dsc$a_pointer,"$ MCR "); 5340 if (suggest_quote) *suggest_quote = 1; 5341 } else { 5342 strcpy(vmscmd->dsc$a_pointer,"@"); 5343 if (suggest_quote) *suggest_quote = 1; 5344 } 5345 strcat(vmscmd->dsc$a_pointer,resspec); 5346 if (rest) strcat(vmscmd->dsc$a_pointer,rest); 5347 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer); 5348 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts); 5349 } 5350 else retsts = RMS$_PRV; 5351 } 5352 } 5353 /* It's either a DCL command or we couldn't find a suitable image */ 5354 vmscmd->dsc$w_length = strlen(cmd); 5355 /* if (cmd == PL_Cmd) { 5356 vmscmd->dsc$a_pointer = PL_Cmd; 5357 if (suggest_quote) *suggest_quote = 1; 5358 } 5359 else */ 5360 vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length); 5361 5362 /* check if it's a symbol (for quoting purposes) */ 5363 if (suggest_quote && !*suggest_quote) { 5364 int iss; 5365 char equiv[LNM$C_NAMLENGTH]; 5366 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; 5367 eqvdsc.dsc$a_pointer = equiv; 5368 5369 iss = lib$get_symbol(vmscmd,&eqvdsc); 5370 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1; 5371 } 5372 if (!(retsts & 1)) { 5373 /* just hand off status values likely to be due to user error */ 5374 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV || 5375 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN || 5376 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts; 5377 else { _ckvmssts(retsts); } 5378 } 5379 5380 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts); 5381 5382 } /* end of setup_cmddsc() */ 5383 5384 5385 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */ 5386 bool 5387 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp) 5388 { 5389 if (sp > mark) { 5390 if (vfork_called) { /* this follows a vfork - act Unixish */ 5391 vfork_called--; 5392 if (vfork_called < 0) { 5393 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks"); 5394 vfork_called = 0; 5395 } 5396 else return do_aexec(really,mark,sp); 5397 } 5398 /* no vfork - act VMSish */ 5399 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp)); 5400 5401 } 5402 5403 return FALSE; 5404 } /* end of vms_do_aexec() */ 5405 /*}}}*/ 5406 5407 /* {{{bool vms_do_exec(char *cmd) */ 5408 bool 5409 Perl_vms_do_exec(pTHX_ char *cmd) 5410 { 5411 struct dsc$descriptor_s *vmscmd; 5412 5413 if (vfork_called) { /* this follows a vfork - act Unixish */ 5414 vfork_called--; 5415 if (vfork_called < 0) { 5416 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks"); 5417 vfork_called = 0; 5418 } 5419 else return do_exec(cmd); 5420 } 5421 5422 { /* no vfork - act VMSish */ 5423 unsigned long int retsts; 5424 5425 TAINT_ENV(); 5426 TAINT_PROPER("exec"); 5427 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1) 5428 retsts = lib$do_command(vmscmd); 5429 5430 switch (retsts) { 5431 case RMS$_FNF: case RMS$_DNF: 5432 set_errno(ENOENT); break; 5433 case RMS$_DIR: 5434 set_errno(ENOTDIR); break; 5435 case RMS$_DEV: 5436 set_errno(ENODEV); break; 5437 case RMS$_PRV: 5438 set_errno(EACCES); break; 5439 case RMS$_SYN: 5440 set_errno(EINVAL); break; 5441 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF: 5442 set_errno(E2BIG); break; 5443 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */ 5444 _ckvmssts(retsts); /* fall through */ 5445 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */ 5446 set_errno(EVMSERR); 5447 } 5448 set_vaxc_errno(retsts); 5449 if (ckWARN(WARN_EXEC)) { 5450 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s", 5451 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno)); 5452 } 5453 vms_execfree(vmscmd); 5454 } 5455 5456 return FALSE; 5457 5458 } /* end of vms_do_exec() */ 5459 /*}}}*/ 5460 5461 unsigned long int Perl_do_spawn(pTHX_ char *); 5462 5463 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */ 5464 unsigned long int 5465 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp) 5466 { 5467 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp)); 5468 5469 return SS$_ABORT; 5470 } /* end of do_aspawn() */ 5471 /*}}}*/ 5472 5473 /* {{{unsigned long int do_spawn(char *cmd) */ 5474 unsigned long int 5475 Perl_do_spawn(pTHX_ char *cmd) 5476 { 5477 unsigned long int sts, substs; 5478 5479 TAINT_ENV(); 5480 TAINT_PROPER("spawn"); 5481 if (!cmd || !*cmd) { 5482 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0); 5483 if (!(sts & 1)) { 5484 switch (sts) { 5485 case RMS$_FNF: case RMS$_DNF: 5486 set_errno(ENOENT); break; 5487 case RMS$_DIR: 5488 set_errno(ENOTDIR); break; 5489 case RMS$_DEV: 5490 set_errno(ENODEV); break; 5491 case RMS$_PRV: 5492 set_errno(EACCES); break; 5493 case RMS$_SYN: 5494 set_errno(EINVAL); break; 5495 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF: 5496 set_errno(E2BIG); break; 5497 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */ 5498 _ckvmssts(sts); /* fall through */ 5499 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */ 5500 set_errno(EVMSERR); 5501 } 5502 set_vaxc_errno(sts); 5503 if (ckWARN(WARN_EXEC)) { 5504 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s", 5505 Strerror(errno)); 5506 } 5507 } 5508 sts = substs; 5509 } 5510 else { 5511 (void) safe_popen(aTHX_ cmd, "nW", (int *)&sts); 5512 } 5513 return sts; 5514 } /* end of do_spawn() */ 5515 /*}}}*/ 5516 5517 5518 static unsigned int *sockflags, sockflagsize; 5519 5520 /* 5521 * Shim fdopen to identify sockets for my_fwrite later, since the stdio 5522 * routines found in some versions of the CRTL can't deal with sockets. 5523 * We don't shim the other file open routines since a socket isn't 5524 * likely to be opened by a name. 5525 */ 5526 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/ 5527 FILE *my_fdopen(int fd, const char *mode) 5528 { 5529 FILE *fp = fdopen(fd, (char *) mode); 5530 5531 if (fp) { 5532 unsigned int fdoff = fd / sizeof(unsigned int); 5533 struct stat sbuf; /* native stat; we don't need flex_stat */ 5534 if (!sockflagsize || fdoff > sockflagsize) { 5535 if (sockflags) Renew( sockflags,fdoff+2,unsigned int); 5536 else Newx (sockflags,fdoff+2,unsigned int); 5537 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize); 5538 sockflagsize = fdoff + 2; 5539 } 5540 if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode)) 5541 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int)); 5542 } 5543 return fp; 5544 5545 } 5546 /*}}}*/ 5547 5548 5549 /* 5550 * Clear the corresponding bit when the (possibly) socket stream is closed. 5551 * There still a small hole: we miss an implicit close which might occur 5552 * via freopen(). >> Todo 5553 */ 5554 /*{{{ int my_fclose(FILE *fp)*/ 5555 int my_fclose(FILE *fp) { 5556 if (fp) { 5557 unsigned int fd = fileno(fp); 5558 unsigned int fdoff = fd / sizeof(unsigned int); 5559 5560 if (sockflagsize && fdoff <= sockflagsize) 5561 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int)); 5562 } 5563 return fclose(fp); 5564 } 5565 /*}}}*/ 5566 5567 5568 /* 5569 * A simple fwrite replacement which outputs itmsz*nitm chars without 5570 * introducing record boundaries every itmsz chars. 5571 * We are using fputs, which depends on a terminating null. We may 5572 * well be writing binary data, so we need to accommodate not only 5573 * data with nulls sprinkled in the middle but also data with no null 5574 * byte at the end. 5575 */ 5576 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/ 5577 int 5578 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest) 5579 { 5580 register char *cp, *end, *cpd, *data; 5581 register unsigned int fd = fileno(dest); 5582 register unsigned int fdoff = fd / sizeof(unsigned int); 5583 int retval; 5584 int bufsize = itmsz * nitm + 1; 5585 5586 if (fdoff < sockflagsize && 5587 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) { 5588 if (write(fd, src, itmsz * nitm) == EOF) return EOF; 5589 return nitm; 5590 } 5591 5592 _ckvmssts_noperl(lib$get_vm(&bufsize, &data)); 5593 memcpy( data, src, itmsz*nitm ); 5594 data[itmsz*nitm] = '\0'; 5595 5596 end = data + itmsz * nitm; 5597 retval = (int) nitm; /* on success return # items written */ 5598 5599 cpd = data; 5600 while (cpd <= end) { 5601 for (cp = cpd; cp <= end; cp++) if (!*cp) break; 5602 if (fputs(cpd,dest) == EOF) { retval = EOF; break; } 5603 if (cp < end) 5604 if (fputc('\0',dest) == EOF) { retval = EOF; break; } 5605 cpd = cp + 1; 5606 } 5607 5608 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data)); 5609 return retval; 5610 5611 } /* end of my_fwrite() */ 5612 /*}}}*/ 5613 5614 /*{{{ int my_flush(FILE *fp)*/ 5615 int 5616 Perl_my_flush(pTHX_ FILE *fp) 5617 { 5618 int res; 5619 if ((res = fflush(fp)) == 0 && fp) { 5620 #ifdef VMS_DO_SOCKETS 5621 Stat_t s; 5622 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode)) 5623 #endif 5624 res = fsync(fileno(fp)); 5625 } 5626 /* 5627 * If the flush succeeded but set end-of-file, we need to clear 5628 * the error because our caller may check ferror(). BTW, this 5629 * probably means we just flushed an empty file. 5630 */ 5631 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp); 5632 5633 return res; 5634 } 5635 /*}}}*/ 5636 5637 /* 5638 * Here are replacements for the following Unix routines in the VMS environment: 5639 * getpwuid Get information for a particular UIC or UID 5640 * getpwnam Get information for a named user 5641 * getpwent Get information for each user in the rights database 5642 * setpwent Reset search to the start of the rights database 5643 * endpwent Finish searching for users in the rights database 5644 * 5645 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure 5646 * (defined in pwd.h), which contains the following fields:- 5647 * struct passwd { 5648 * char *pw_name; Username (in lower case) 5649 * char *pw_passwd; Hashed password 5650 * unsigned int pw_uid; UIC 5651 * unsigned int pw_gid; UIC group number 5652 * char *pw_unixdir; Default device/directory (VMS-style) 5653 * char *pw_gecos; Owner name 5654 * char *pw_dir; Default device/directory (Unix-style) 5655 * char *pw_shell; Default CLI name (eg. DCL) 5656 * }; 5657 * If the specified user does not exist, getpwuid and getpwnam return NULL. 5658 * 5659 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid). 5660 * not the UIC member number (eg. what's returned by getuid()), 5661 * getpwuid() can accept either as input (if uid is specified, the caller's 5662 * UIC group is used), though it won't recognise gid=0. 5663 * 5664 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return 5665 * information about other users in your group or in other groups, respectively. 5666 * If the required privilege is not available, then these routines fill only 5667 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty 5668 * string). 5669 * 5670 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995. 5671 */ 5672 5673 /* sizes of various UAF record fields */ 5674 #define UAI$S_USERNAME 12 5675 #define UAI$S_IDENT 31 5676 #define UAI$S_OWNER 31 5677 #define UAI$S_DEFDEV 31 5678 #define UAI$S_DEFDIR 63 5679 #define UAI$S_DEFCLI 31 5680 #define UAI$S_PWD 8 5681 5682 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \ 5683 (uic).uic$v_member != UIC$K_WILD_MEMBER && \ 5684 (uic).uic$v_group != UIC$K_WILD_GROUP) 5685 5686 static char __empty[]= ""; 5687 static struct passwd __passwd_empty= 5688 {(char *) __empty, (char *) __empty, 0, 0, 5689 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty}; 5690 static int contxt= 0; 5691 static struct passwd __pwdcache; 5692 static char __pw_namecache[UAI$S_IDENT+1]; 5693 5694 /* 5695 * This routine does most of the work extracting the user information. 5696 */ 5697 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd) 5698 { 5699 static struct { 5700 unsigned char length; 5701 char pw_gecos[UAI$S_OWNER+1]; 5702 } owner; 5703 static union uicdef uic; 5704 static struct { 5705 unsigned char length; 5706 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1]; 5707 } defdev; 5708 static struct { 5709 unsigned char length; 5710 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1]; 5711 } defdir; 5712 static struct { 5713 unsigned char length; 5714 char pw_shell[UAI$S_DEFCLI+1]; 5715 } defcli; 5716 static char pw_passwd[UAI$S_PWD+1]; 5717 5718 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd; 5719 struct dsc$descriptor_s name_desc; 5720 unsigned long int sts; 5721 5722 static struct itmlst_3 itmlst[]= { 5723 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner}, 5724 {sizeof(uic), UAI$_UIC, &uic, &luic}, 5725 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev}, 5726 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir}, 5727 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli}, 5728 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd}, 5729 {0, 0, NULL, NULL}}; 5730 5731 name_desc.dsc$w_length= strlen(name); 5732 name_desc.dsc$b_dtype= DSC$K_DTYPE_T; 5733 name_desc.dsc$b_class= DSC$K_CLASS_S; 5734 name_desc.dsc$a_pointer= (char *) name; 5735 5736 /* Note that sys$getuai returns many fields as counted strings. */ 5737 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0); 5738 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) { 5739 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES); 5740 } 5741 else { _ckvmssts(sts); } 5742 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */ 5743 5744 if ((int) owner.length < lowner) lowner= (int) owner.length; 5745 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length; 5746 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length; 5747 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length; 5748 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir); 5749 owner.pw_gecos[lowner]= '\0'; 5750 defdev.pw_dir[ldefdev+ldefdir]= '\0'; 5751 defcli.pw_shell[ldefcli]= '\0'; 5752 if (valid_uic(uic)) { 5753 pwd->pw_uid= uic.uic$l_uic; 5754 pwd->pw_gid= uic.uic$v_group; 5755 } 5756 else 5757 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\""); 5758 pwd->pw_passwd= pw_passwd; 5759 pwd->pw_gecos= owner.pw_gecos; 5760 pwd->pw_dir= defdev.pw_dir; 5761 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1); 5762 pwd->pw_shell= defcli.pw_shell; 5763 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) { 5764 int ldir; 5765 ldir= strlen(pwd->pw_unixdir) - 1; 5766 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0'; 5767 } 5768 else 5769 strcpy(pwd->pw_unixdir, pwd->pw_dir); 5770 __mystrtolower(pwd->pw_unixdir); 5771 return 1; 5772 } 5773 5774 /* 5775 * Get information for a named user. 5776 */ 5777 /*{{{struct passwd *getpwnam(char *name)*/ 5778 struct passwd *Perl_my_getpwnam(pTHX_ char *name) 5779 { 5780 struct dsc$descriptor_s name_desc; 5781 union uicdef uic; 5782 unsigned long int status, sts; 5783 5784 __pwdcache = __passwd_empty; 5785 if (!fillpasswd(aTHX_ name, &__pwdcache)) { 5786 /* We still may be able to determine pw_uid and pw_gid */ 5787 name_desc.dsc$w_length= strlen(name); 5788 name_desc.dsc$b_dtype= DSC$K_DTYPE_T; 5789 name_desc.dsc$b_class= DSC$K_CLASS_S; 5790 name_desc.dsc$a_pointer= (char *) name; 5791 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) { 5792 __pwdcache.pw_uid= uic.uic$l_uic; 5793 __pwdcache.pw_gid= uic.uic$v_group; 5794 } 5795 else { 5796 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) { 5797 set_vaxc_errno(sts); 5798 set_errno(sts == RMS$_PRV ? EACCES : EINVAL); 5799 return NULL; 5800 } 5801 else { _ckvmssts(sts); } 5802 } 5803 } 5804 strncpy(__pw_namecache, name, sizeof(__pw_namecache)); 5805 __pw_namecache[sizeof __pw_namecache - 1] = '\0'; 5806 __pwdcache.pw_name= __pw_namecache; 5807 return &__pwdcache; 5808 } /* end of my_getpwnam() */ 5809 /*}}}*/ 5810 5811 /* 5812 * Get information for a particular UIC or UID. 5813 * Called by my_getpwent with uid=-1 to list all users. 5814 */ 5815 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/ 5816 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid) 5817 { 5818 const $DESCRIPTOR(name_desc,__pw_namecache); 5819 unsigned short lname; 5820 union uicdef uic; 5821 unsigned long int status; 5822 5823 if (uid == (unsigned int) -1) { 5824 do { 5825 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt); 5826 if (status == SS$_NOSUCHID || status == RMS$_PRV) { 5827 set_vaxc_errno(status); 5828 set_errno(status == RMS$_PRV ? EACCES : EINVAL); 5829 my_endpwent(); 5830 return NULL; 5831 } 5832 else { _ckvmssts(status); } 5833 } while (!valid_uic (uic)); 5834 } 5835 else { 5836 uic.uic$l_uic= uid; 5837 if (!uic.uic$v_group) 5838 uic.uic$v_group= PerlProc_getgid(); 5839 if (valid_uic(uic)) 5840 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0); 5841 else status = SS$_IVIDENT; 5842 if (status == SS$_IVIDENT || status == SS$_NOSUCHID || 5843 status == RMS$_PRV) { 5844 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL); 5845 return NULL; 5846 } 5847 else { _ckvmssts(status); } 5848 } 5849 __pw_namecache[lname]= '\0'; 5850 __mystrtolower(__pw_namecache); 5851 5852 __pwdcache = __passwd_empty; 5853 __pwdcache.pw_name = __pw_namecache; 5854 5855 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege). 5856 The identifier's value is usually the UIC, but it doesn't have to be, 5857 so if we can, we let fillpasswd update this. */ 5858 __pwdcache.pw_uid = uic.uic$l_uic; 5859 __pwdcache.pw_gid = uic.uic$v_group; 5860 5861 fillpasswd(aTHX_ __pw_namecache, &__pwdcache); 5862 return &__pwdcache; 5863 5864 } /* end of my_getpwuid() */ 5865 /*}}}*/ 5866 5867 /* 5868 * Get information for next user. 5869 */ 5870 /*{{{struct passwd *my_getpwent()*/ 5871 struct passwd *Perl_my_getpwent(pTHX) 5872 { 5873 return (my_getpwuid((unsigned int) -1)); 5874 } 5875 /*}}}*/ 5876 5877 /* 5878 * Finish searching rights database for users. 5879 */ 5880 /*{{{void my_endpwent()*/ 5881 void Perl_my_endpwent(pTHX) 5882 { 5883 if (contxt) { 5884 _ckvmssts(sys$finish_rdb(&contxt)); 5885 contxt= 0; 5886 } 5887 } 5888 /*}}}*/ 5889 5890 #ifdef HOMEGROWN_POSIX_SIGNALS 5891 /* Signal handling routines, pulled into the core from POSIX.xs. 5892 * 5893 * We need these for threads, so they've been rolled into the core, 5894 * rather than left in POSIX.xs. 5895 * 5896 * (DRS, Oct 23, 1997) 5897 */ 5898 5899 /* sigset_t is atomic under VMS, so these routines are easy */ 5900 /*{{{int my_sigemptyset(sigset_t *) */ 5901 int my_sigemptyset(sigset_t *set) { 5902 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; } 5903 *set = 0; return 0; 5904 } 5905 /*}}}*/ 5906 5907 5908 /*{{{int my_sigfillset(sigset_t *)*/ 5909 int my_sigfillset(sigset_t *set) { 5910 int i; 5911 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; } 5912 for (i = 0; i < NSIG; i++) *set |= (1 << i); 5913 return 0; 5914 } 5915 /*}}}*/ 5916 5917 5918 /*{{{int my_sigaddset(sigset_t *set, int sig)*/ 5919 int my_sigaddset(sigset_t *set, int sig) { 5920 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; } 5921 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; } 5922 *set |= (1 << (sig - 1)); 5923 return 0; 5924 } 5925 /*}}}*/ 5926 5927 5928 /*{{{int my_sigdelset(sigset_t *set, int sig)*/ 5929 int my_sigdelset(sigset_t *set, int sig) { 5930 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; } 5931 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; } 5932 *set &= ~(1 << (sig - 1)); 5933 return 0; 5934 } 5935 /*}}}*/ 5936 5937 5938 /*{{{int my_sigismember(sigset_t *set, int sig)*/ 5939 int my_sigismember(sigset_t *set, int sig) { 5940 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; } 5941 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; } 5942 return *set & (1 << (sig - 1)); 5943 } 5944 /*}}}*/ 5945 5946 5947 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/ 5948 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) { 5949 sigset_t tempmask; 5950 5951 /* If set and oset are both null, then things are badly wrong. Bail out. */ 5952 if ((oset == NULL) && (set == NULL)) { 5953 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO); 5954 return -1; 5955 } 5956 5957 /* If set's null, then we're just handling a fetch. */ 5958 if (set == NULL) { 5959 tempmask = sigblock(0); 5960 } 5961 else { 5962 switch (how) { 5963 case SIG_SETMASK: 5964 tempmask = sigsetmask(*set); 5965 break; 5966 case SIG_BLOCK: 5967 tempmask = sigblock(*set); 5968 break; 5969 case SIG_UNBLOCK: 5970 tempmask = sigblock(0); 5971 sigsetmask(*oset & ~tempmask); 5972 break; 5973 default: 5974 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); 5975 return -1; 5976 } 5977 } 5978 5979 /* Did they pass us an oset? If so, stick our holding mask into it */ 5980 if (oset) 5981 *oset = tempmask; 5982 5983 return 0; 5984 } 5985 /*}}}*/ 5986 #endif /* HOMEGROWN_POSIX_SIGNALS */ 5987 5988 5989 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(), 5990 * my_utime(), and flex_stat(), all of which operate on UTC unless 5991 * VMSISH_TIMES is true. 5992 */ 5993 /* method used to handle UTC conversions: 5994 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction 5995 */ 5996 static int gmtime_emulation_type; 5997 /* number of secs to add to UTC POSIX-style time to get local time */ 5998 static long int utc_offset_secs; 5999 6000 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc. 6001 * in vmsish.h. #undef them here so we can call the CRTL routines 6002 * directly. 6003 */ 6004 #undef gmtime 6005 #undef localtime 6006 #undef time 6007 6008 6009 /* 6010 * DEC C previous to 6.0 corrupts the behavior of the /prefix 6011 * qualifier with the extern prefix pragma. This provisional 6012 * hack circumvents this prefix pragma problem in previous 6013 * precompilers. 6014 */ 6015 #if defined(__VMS_VER) && __VMS_VER >= 70000000 6016 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000) 6017 # pragma __extern_prefix save 6018 # pragma __extern_prefix "" /* set to empty to prevent prefixing */ 6019 # define gmtime decc$__utctz_gmtime 6020 # define localtime decc$__utctz_localtime 6021 # define time decc$__utc_time 6022 # pragma __extern_prefix restore 6023 6024 struct tm *gmtime(), *localtime(); 6025 6026 # endif 6027 #endif 6028 6029 6030 static time_t toutc_dst(time_t loc) { 6031 struct tm *rsltmp; 6032 6033 if ((rsltmp = localtime(&loc)) == NULL) return -1; 6034 loc -= utc_offset_secs; 6035 if (rsltmp->tm_isdst) loc -= 3600; 6036 return loc; 6037 } 6038 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \ 6039 ((gmtime_emulation_type || my_time(NULL)), \ 6040 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \ 6041 ((secs) - utc_offset_secs)))) 6042 6043 static time_t toloc_dst(time_t utc) { 6044 struct tm *rsltmp; 6045 6046 utc += utc_offset_secs; 6047 if ((rsltmp = localtime(&utc)) == NULL) return -1; 6048 if (rsltmp->tm_isdst) utc += 3600; 6049 return utc; 6050 } 6051 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \ 6052 ((gmtime_emulation_type || my_time(NULL)), \ 6053 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \ 6054 ((secs) + utc_offset_secs)))) 6055 6056 #ifndef RTL_USES_UTC 6057 /* 6058 6059 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical 6060 DST starts on 1st sun of april at 02:00 std time 6061 ends on last sun of october at 02:00 dst time 6062 see the UCX management command reference, SET CONFIG TIMEZONE 6063 for formatting info. 6064 6065 No, it's not as general as it should be, but then again, NOTHING 6066 will handle UK times in a sensible way. 6067 */ 6068 6069 6070 /* 6071 parse the DST start/end info: 6072 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss] 6073 */ 6074 6075 static char * 6076 tz_parse_startend(char *s, struct tm *w, int *past) 6077 { 6078 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31}; 6079 int ly, dozjd, d, m, n, hour, min, sec, j, k; 6080 time_t g; 6081 6082 if (!s) return 0; 6083 if (!w) return 0; 6084 if (!past) return 0; 6085 6086 ly = 0; 6087 if (w->tm_year % 4 == 0) ly = 1; 6088 if (w->tm_year % 100 == 0) ly = 0; 6089 if (w->tm_year+1900 % 400 == 0) ly = 1; 6090 if (ly) dinm[1]++; 6091 6092 dozjd = isdigit(*s); 6093 if (*s == 'J' || *s == 'j' || dozjd) { 6094 if (!dozjd && !isdigit(*++s)) return 0; 6095 d = *s++ - '0'; 6096 if (isdigit(*s)) { 6097 d = d*10 + *s++ - '0'; 6098 if (isdigit(*s)) { 6099 d = d*10 + *s++ - '0'; 6100 } 6101 } 6102 if (d == 0) return 0; 6103 if (d > 366) return 0; 6104 d--; 6105 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */ 6106 g = d * 86400; 6107 dozjd = 1; 6108 } else if (*s == 'M' || *s == 'm') { 6109 if (!isdigit(*++s)) return 0; 6110 m = *s++ - '0'; 6111 if (isdigit(*s)) m = 10*m + *s++ - '0'; 6112 if (*s != '.') return 0; 6113 if (!isdigit(*++s)) return 0; 6114 n = *s++ - '0'; 6115 if (n < 1 || n > 5) return 0; 6116 if (*s != '.') return 0; 6117 if (!isdigit(*++s)) return 0; 6118 d = *s++ - '0'; 6119 if (d > 6) return 0; 6120 } 6121 6122 if (*s == '/') { 6123 if (!isdigit(*++s)) return 0; 6124 hour = *s++ - '0'; 6125 if (isdigit(*s)) hour = 10*hour + *s++ - '0'; 6126 if (*s == ':') { 6127 if (!isdigit(*++s)) return 0; 6128 min = *s++ - '0'; 6129 if (isdigit(*s)) min = 10*min + *s++ - '0'; 6130 if (*s == ':') { 6131 if (!isdigit(*++s)) return 0; 6132 sec = *s++ - '0'; 6133 if (isdigit(*s)) sec = 10*sec + *s++ - '0'; 6134 } 6135 } 6136 } else { 6137 hour = 2; 6138 min = 0; 6139 sec = 0; 6140 } 6141 6142 if (dozjd) { 6143 if (w->tm_yday < d) goto before; 6144 if (w->tm_yday > d) goto after; 6145 } else { 6146 if (w->tm_mon+1 < m) goto before; 6147 if (w->tm_mon+1 > m) goto after; 6148 6149 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */ 6150 k = d - j; /* mday of first d */ 6151 if (k <= 0) k += 7; 6152 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */ 6153 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7; 6154 if (w->tm_mday < k) goto before; 6155 if (w->tm_mday > k) goto after; 6156 } 6157 6158 if (w->tm_hour < hour) goto before; 6159 if (w->tm_hour > hour) goto after; 6160 if (w->tm_min < min) goto before; 6161 if (w->tm_min > min) goto after; 6162 if (w->tm_sec < sec) goto before; 6163 goto after; 6164 6165 before: 6166 *past = 0; 6167 return s; 6168 after: 6169 *past = 1; 6170 return s; 6171 } 6172 6173 6174 6175 6176 /* parse the offset: (+|-)hh[:mm[:ss]] */ 6177 6178 static char * 6179 tz_parse_offset(char *s, int *offset) 6180 { 6181 int hour = 0, min = 0, sec = 0; 6182 int neg = 0; 6183 if (!s) return 0; 6184 if (!offset) return 0; 6185 6186 if (*s == '-') {neg++; s++;} 6187 if (*s == '+') s++; 6188 if (!isdigit(*s)) return 0; 6189 hour = *s++ - '0'; 6190 if (isdigit(*s)) hour = hour*10+(*s++ - '0'); 6191 if (hour > 24) return 0; 6192 if (*s == ':') { 6193 if (!isdigit(*++s)) return 0; 6194 min = *s++ - '0'; 6195 if (isdigit(*s)) min = min*10 + (*s++ - '0'); 6196 if (min > 59) return 0; 6197 if (*s == ':') { 6198 if (!isdigit(*++s)) return 0; 6199 sec = *s++ - '0'; 6200 if (isdigit(*s)) sec = sec*10 + (*s++ - '0'); 6201 if (sec > 59) return 0; 6202 } 6203 } 6204 6205 *offset = (hour*60+min)*60 + sec; 6206 if (neg) *offset = -*offset; 6207 return s; 6208 } 6209 6210 /* 6211 input time is w, whatever type of time the CRTL localtime() uses. 6212 sets dst, the zone, and the gmtoff (seconds) 6213 6214 caches the value of TZ and UCX$TZ env variables; note that 6215 my_setenv looks for these and sets a flag if they're changed 6216 for efficiency. 6217 6218 We have to watch out for the "australian" case (dst starts in 6219 october, ends in april)...flagged by "reverse" and checked by 6220 scanning through the months of the previous year. 6221 6222 */ 6223 6224 static int 6225 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff) 6226 { 6227 time_t when; 6228 struct tm *w2; 6229 char *s,*s2; 6230 char *dstzone, *tz, *s_start, *s_end; 6231 int std_off, dst_off, isdst; 6232 int y, dststart, dstend; 6233 static char envtz[1025]; /* longer than any logical, symbol, ... */ 6234 static char ucxtz[1025]; 6235 static char reversed = 0; 6236 6237 if (!w) return 0; 6238 6239 if (tz_updated) { 6240 tz_updated = 0; 6241 reversed = -1; /* flag need to check */ 6242 envtz[0] = ucxtz[0] = '\0'; 6243 tz = my_getenv("TZ",0); 6244 if (tz) strcpy(envtz, tz); 6245 tz = my_getenv("UCX$TZ",0); 6246 if (tz) strcpy(ucxtz, tz); 6247 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */ 6248 } 6249 tz = envtz; 6250 if (!*tz) tz = ucxtz; 6251 6252 s = tz; 6253 while (isalpha(*s)) s++; 6254 s = tz_parse_offset(s, &std_off); 6255 if (!s) return 0; 6256 if (!*s) { /* no DST, hurray we're done! */ 6257 isdst = 0; 6258 goto done; 6259 } 6260 6261 dstzone = s; 6262 while (isalpha(*s)) s++; 6263 s2 = tz_parse_offset(s, &dst_off); 6264 if (s2) { 6265 s = s2; 6266 } else { 6267 dst_off = std_off - 3600; 6268 } 6269 6270 if (!*s) { /* default dst start/end?? */ 6271 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */ 6272 s = strchr(ucxtz,','); 6273 } 6274 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */ 6275 } 6276 if (*s != ',') return 0; 6277 6278 when = *w; 6279 when = _toutc(when); /* convert to utc */ 6280 when = when - std_off; /* convert to pseudolocal time*/ 6281 6282 w2 = localtime(&when); 6283 y = w2->tm_year; 6284 s_start = s+1; 6285 s = tz_parse_startend(s_start,w2,&dststart); 6286 if (!s) return 0; 6287 if (*s != ',') return 0; 6288 6289 when = *w; 6290 when = _toutc(when); /* convert to utc */ 6291 when = when - dst_off; /* convert to pseudolocal time*/ 6292 w2 = localtime(&when); 6293 if (w2->tm_year != y) { /* spans a year, just check one time */ 6294 when += dst_off - std_off; 6295 w2 = localtime(&when); 6296 } 6297 s_end = s+1; 6298 s = tz_parse_startend(s_end,w2,&dstend); 6299 if (!s) return 0; 6300 6301 if (reversed == -1) { /* need to check if start later than end */ 6302 int j, ds, de; 6303 6304 when = *w; 6305 if (when < 2*365*86400) { 6306 when += 2*365*86400; 6307 } else { 6308 when -= 365*86400; 6309 } 6310 w2 =localtime(&when); 6311 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */ 6312 6313 for (j = 0; j < 12; j++) { 6314 w2 =localtime(&when); 6315 (void) tz_parse_startend(s_start,w2,&ds); 6316 (void) tz_parse_startend(s_end,w2,&de); 6317 if (ds != de) break; 6318 when += 30*86400; 6319 } 6320 reversed = 0; 6321 if (de && !ds) reversed = 1; 6322 } 6323 6324 isdst = dststart && !dstend; 6325 if (reversed) isdst = dststart || !dstend; 6326 6327 done: 6328 if (dst) *dst = isdst; 6329 if (gmtoff) *gmtoff = isdst ? dst_off : std_off; 6330 if (isdst) tz = dstzone; 6331 if (zone) { 6332 while(isalpha(*tz)) *zone++ = *tz++; 6333 *zone = '\0'; 6334 } 6335 return 1; 6336 } 6337 6338 #endif /* !RTL_USES_UTC */ 6339 6340 /* my_time(), my_localtime(), my_gmtime() 6341 * By default traffic in UTC time values, using CRTL gmtime() or 6342 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone. 6343 * Note: We need to use these functions even when the CRTL has working 6344 * UTC support, since they also handle C<use vmsish qw(times);> 6345 * 6346 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu> 6347 * Modified by Charles Bailey <bailey@newman.upenn.edu> 6348 */ 6349 6350 /*{{{time_t my_time(time_t *timep)*/ 6351 time_t Perl_my_time(pTHX_ time_t *timep) 6352 { 6353 time_t when; 6354 struct tm *tm_p; 6355 6356 if (gmtime_emulation_type == 0) { 6357 int dstnow; 6358 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */ 6359 /* results of calls to gmtime() and localtime() */ 6360 /* for same &base */ 6361 6362 gmtime_emulation_type++; 6363 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */ 6364 char off[LNM$C_NAMLENGTH+1];; 6365 6366 gmtime_emulation_type++; 6367 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) { 6368 gmtime_emulation_type++; 6369 utc_offset_secs = 0; 6370 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC"); 6371 } 6372 else { utc_offset_secs = atol(off); } 6373 } 6374 else { /* We've got a working gmtime() */ 6375 struct tm gmt, local; 6376 6377 gmt = *tm_p; 6378 tm_p = localtime(&base); 6379 local = *tm_p; 6380 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400; 6381 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600; 6382 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60; 6383 utc_offset_secs += (local.tm_sec - gmt.tm_sec); 6384 } 6385 } 6386 6387 when = time(NULL); 6388 # ifdef VMSISH_TIME 6389 # ifdef RTL_USES_UTC 6390 if (VMSISH_TIME) when = _toloc(when); 6391 # else 6392 if (!VMSISH_TIME) when = _toutc(when); 6393 # endif 6394 # endif 6395 if (timep != NULL) *timep = when; 6396 return when; 6397 6398 } /* end of my_time() */ 6399 /*}}}*/ 6400 6401 6402 /*{{{struct tm *my_gmtime(const time_t *timep)*/ 6403 struct tm * 6404 Perl_my_gmtime(pTHX_ const time_t *timep) 6405 { 6406 char *p; 6407 time_t when; 6408 struct tm *rsltmp; 6409 6410 if (timep == NULL) { 6411 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); 6412 return NULL; 6413 } 6414 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */ 6415 6416 when = *timep; 6417 # ifdef VMSISH_TIME 6418 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */ 6419 # endif 6420 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */ 6421 return gmtime(&when); 6422 # else 6423 /* CRTL localtime() wants local time as input, so does no tz correction */ 6424 rsltmp = localtime(&when); 6425 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */ 6426 return rsltmp; 6427 #endif 6428 } /* end of my_gmtime() */ 6429 /*}}}*/ 6430 6431 6432 /*{{{struct tm *my_localtime(const time_t *timep)*/ 6433 struct tm * 6434 Perl_my_localtime(pTHX_ const time_t *timep) 6435 { 6436 time_t when, whenutc; 6437 struct tm *rsltmp; 6438 int dst, offset; 6439 6440 if (timep == NULL) { 6441 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); 6442 return NULL; 6443 } 6444 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */ 6445 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */ 6446 6447 when = *timep; 6448 # ifdef RTL_USES_UTC 6449 # ifdef VMSISH_TIME 6450 if (VMSISH_TIME) when = _toutc(when); 6451 # endif 6452 /* CRTL localtime() wants UTC as input, does tz correction itself */ 6453 return localtime(&when); 6454 6455 # else /* !RTL_USES_UTC */ 6456 whenutc = when; 6457 # ifdef VMSISH_TIME 6458 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */ 6459 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */ 6460 # endif 6461 dst = -1; 6462 #ifndef RTL_USES_UTC 6463 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/ 6464 when = whenutc - offset; /* pseudolocal time*/ 6465 } 6466 # endif 6467 /* CRTL localtime() wants local time as input, so does no tz correction */ 6468 rsltmp = localtime(&when); 6469 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst; 6470 return rsltmp; 6471 # endif 6472 6473 } /* end of my_localtime() */ 6474 /*}}}*/ 6475 6476 /* Reset definitions for later calls */ 6477 #define gmtime(t) my_gmtime(t) 6478 #define localtime(t) my_localtime(t) 6479 #define time(t) my_time(t) 6480 6481 6482 /* my_utime - update modification time of a file 6483 * calling sequence is identical to POSIX utime(), but under 6484 * VMS only the modification time is changed; ODS-2 does not 6485 * maintain access times. Restrictions differ from the POSIX 6486 * definition in that the time can be changed as long as the 6487 * caller has permission to execute the necessary IO$_MODIFY $QIO; 6488 * no separate checks are made to insure that the caller is the 6489 * owner of the file or has special privs enabled. 6490 * Code here is based on Joe Meadows' FILE utility. 6491 */ 6492 6493 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00) 6494 * to VMS epoch (01-JAN-1858 00:00:00.00) 6495 * in 100 ns intervals. 6496 */ 6497 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 }; 6498 6499 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/ 6500 int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes) 6501 { 6502 register int i; 6503 long int bintime[2], len = 2, lowbit, unixtime, 6504 secscale = 10000000; /* seconds --> 100 ns intervals */ 6505 unsigned long int chan, iosb[2], retsts; 6506 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS]; 6507 struct FAB myfab = cc$rms_fab; 6508 struct NAM mynam = cc$rms_nam; 6509 #if defined (__DECC) && defined (__VAX) 6510 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr, 6511 * at least through VMS V6.1, which causes a type-conversion warning. 6512 */ 6513 # pragma message save 6514 # pragma message disable cvtdiftypes 6515 #endif 6516 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}}; 6517 struct fibdef myfib; 6518 #if defined (__DECC) && defined (__VAX) 6519 /* This should be right after the declaration of myatr, but due 6520 * to a bug in VAX DEC C, this takes effect a statement early. 6521 */ 6522 # pragma message restore 6523 #endif 6524 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib}, 6525 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0}, 6526 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0}; 6527 6528 if (file == NULL || *file == '\0') { 6529 set_errno(ENOENT); 6530 set_vaxc_errno(LIB$_INVARG); 6531 return -1; 6532 } 6533 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1; 6534 6535 if (utimes != NULL) { 6536 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00) 6537 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00). 6538 * Since time_t is unsigned long int, and lib$emul takes a signed long int 6539 * as input, we force the sign bit to be clear by shifting unixtime right 6540 * one bit, then multiplying by an extra factor of 2 in lib$emul(). 6541 */ 6542 lowbit = (utimes->modtime & 1) ? secscale : 0; 6543 unixtime = (long int) utimes->modtime; 6544 # ifdef VMSISH_TIME 6545 /* If input was UTC; convert to local for sys svc */ 6546 if (!VMSISH_TIME) unixtime = _toloc(unixtime); 6547 # endif 6548 unixtime >>= 1; secscale <<= 1; 6549 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime); 6550 if (!(retsts & 1)) { 6551 set_errno(EVMSERR); 6552 set_vaxc_errno(retsts); 6553 return -1; 6554 } 6555 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len); 6556 if (!(retsts & 1)) { 6557 set_errno(EVMSERR); 6558 set_vaxc_errno(retsts); 6559 return -1; 6560 } 6561 } 6562 else { 6563 /* Just get the current time in VMS format directly */ 6564 retsts = sys$gettim(bintime); 6565 if (!(retsts & 1)) { 6566 set_errno(EVMSERR); 6567 set_vaxc_errno(retsts); 6568 return -1; 6569 } 6570 } 6571 6572 myfab.fab$l_fna = vmsspec; 6573 myfab.fab$b_fns = (unsigned char) strlen(vmsspec); 6574 myfab.fab$l_nam = &mynam; 6575 mynam.nam$l_esa = esa; 6576 mynam.nam$b_ess = (unsigned char) sizeof esa; 6577 mynam.nam$l_rsa = rsa; 6578 mynam.nam$b_rss = (unsigned char) sizeof rsa; 6579 6580 /* Look for the file to be affected, letting RMS parse the file 6581 * specification for us as well. I have set errno using only 6582 * values documented in the utime() man page for VMS POSIX. 6583 */ 6584 retsts = sys$parse(&myfab,0,0); 6585 if (!(retsts & 1)) { 6586 set_vaxc_errno(retsts); 6587 if (retsts == RMS$_PRV) set_errno(EACCES); 6588 else if (retsts == RMS$_DIR) set_errno(ENOTDIR); 6589 else set_errno(EVMSERR); 6590 return -1; 6591 } 6592 retsts = sys$search(&myfab,0,0); 6593 if (!(retsts & 1)) { 6594 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL; 6595 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); 6596 set_vaxc_errno(retsts); 6597 if (retsts == RMS$_PRV) set_errno(EACCES); 6598 else if (retsts == RMS$_FNF) set_errno(ENOENT); 6599 else set_errno(EVMSERR); 6600 return -1; 6601 } 6602 6603 devdsc.dsc$w_length = mynam.nam$b_dev; 6604 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev; 6605 6606 retsts = sys$assign(&devdsc,&chan,0,0); 6607 if (!(retsts & 1)) { 6608 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL; 6609 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); 6610 set_vaxc_errno(retsts); 6611 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR); 6612 else if (retsts == SS$_NOPRIV) set_errno(EACCES); 6613 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR); 6614 else set_errno(EVMSERR); 6615 return -1; 6616 } 6617 6618 fnmdsc.dsc$a_pointer = mynam.nam$l_name; 6619 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver; 6620 6621 memset((void *) &myfib, 0, sizeof myfib); 6622 #if defined(__DECC) || defined(__DECCXX) 6623 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i]; 6624 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i]; 6625 /* This prevents the revision time of the file being reset to the current 6626 * time as a result of our IO$_MODIFY $QIO. */ 6627 myfib.fib$l_acctl = FIB$M_NORECORD; 6628 #else 6629 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i]; 6630 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i]; 6631 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD; 6632 #endif 6633 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0); 6634 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL; 6635 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); 6636 _ckvmssts(sys$dassgn(chan)); 6637 if (retsts & 1) retsts = iosb[0]; 6638 if (!(retsts & 1)) { 6639 set_vaxc_errno(retsts); 6640 if (retsts == SS$_NOPRIV) set_errno(EACCES); 6641 else set_errno(EVMSERR); 6642 return -1; 6643 } 6644 6645 return 0; 6646 } /* end of my_utime() */ 6647 /*}}}*/ 6648 6649 /* 6650 * flex_stat, flex_fstat 6651 * basic stat, but gets it right when asked to stat 6652 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3) 6653 */ 6654 6655 /* encode_dev packs a VMS device name string into an integer to allow 6656 * simple comparisons. This can be used, for example, to check whether two 6657 * files are located on the same device, by comparing their encoded device 6658 * names. Even a string comparison would not do, because stat() reuses the 6659 * device name buffer for each call; so without encode_dev, it would be 6660 * necessary to save the buffer and use strcmp (this would mean a number of 6661 * changes to the standard Perl code, to say nothing of what a Perl script 6662 * would have to do. 6663 * 6664 * The device lock id, if it exists, should be unique (unless perhaps compared 6665 * with lock ids transferred from other nodes). We have a lock id if the disk is 6666 * mounted cluster-wide, which is when we tend to get long (host-qualified) 6667 * device names. Thus we use the lock id in preference, and only if that isn't 6668 * available, do we try to pack the device name into an integer (flagged by 6669 * the sign bit (LOCKID_MASK) being set). 6670 * 6671 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device 6672 * name and its encoded form, but it seems very unlikely that we will find 6673 * two files on different disks that share the same encoded device names, 6674 * and even more remote that they will share the same file id (if the test 6675 * is to check for the same file). 6676 * 6677 * A better method might be to use sys$device_scan on the first call, and to 6678 * search for the device, returning an index into the cached array. 6679 * The number returned would be more intelligable. 6680 * This is probably not worth it, and anyway would take quite a bit longer 6681 * on the first call. 6682 */ 6683 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */ 6684 static mydev_t encode_dev (pTHX_ const char *dev) 6685 { 6686 int i; 6687 unsigned long int f; 6688 mydev_t enc; 6689 char c; 6690 const char *q; 6691 6692 if (!dev || !dev[0]) return 0; 6693 6694 #if LOCKID_MASK 6695 { 6696 struct dsc$descriptor_s dev_desc; 6697 unsigned long int status, lockid, item = DVI$_LOCKID; 6698 6699 /* For cluster-mounted disks, the disk lock identifier is unique, so we 6700 can try that first. */ 6701 dev_desc.dsc$w_length = strlen (dev); 6702 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T; 6703 dev_desc.dsc$b_class = DSC$K_CLASS_S; 6704 dev_desc.dsc$a_pointer = (char *) dev; 6705 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0)); 6706 if (lockid) return (lockid & ~LOCKID_MASK); 6707 } 6708 #endif 6709 6710 /* Otherwise we try to encode the device name */ 6711 enc = 0; 6712 f = 1; 6713 i = 0; 6714 for (q = dev + strlen(dev); q--; q >= dev) { 6715 if (isdigit (*q)) 6716 c= (*q) - '0'; 6717 else if (isalpha (toupper (*q))) 6718 c= toupper (*q) - 'A' + (char)10; 6719 else 6720 continue; /* Skip '$'s */ 6721 i++; 6722 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */ 6723 if (i>1) f *= 36; 6724 enc += f * (unsigned long int) c; 6725 } 6726 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */ 6727 6728 } /* end of encode_dev() */ 6729 6730 static char namecache[NAM$C_MAXRSS+1]; 6731 6732 static int 6733 is_null_device(name) 6734 const char *name; 6735 { 6736 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:". 6737 The underscore prefix, controller letter, and unit number are 6738 independently optional; for our purposes, the colon punctuation 6739 is not. The colon can be trailed by optional directory and/or 6740 filename, but two consecutive colons indicates a nodename rather 6741 than a device. [pr] */ 6742 if (*name == '_') ++name; 6743 if (tolower(*name++) != 'n') return 0; 6744 if (tolower(*name++) != 'l') return 0; 6745 if (tolower(*name) == 'a') ++name; 6746 if (*name == '0') ++name; 6747 return (*name++ == ':') && (*name != ':'); 6748 } 6749 6750 /* Do the permissions allow some operation? Assumes PL_statcache already set. */ 6751 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a 6752 * subset of the applicable information. 6753 */ 6754 bool 6755 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp) 6756 { 6757 char fname_phdev[NAM$C_MAXRSS+1]; 6758 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache); 6759 else { 6760 char fname[NAM$C_MAXRSS+1]; 6761 unsigned long int retsts; 6762 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}, 6763 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; 6764 6765 /* If the struct mystat is stale, we're OOL; stat() overwrites the 6766 device name on successive calls */ 6767 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam; 6768 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam); 6769 namdsc.dsc$a_pointer = fname; 6770 namdsc.dsc$w_length = sizeof fname - 1; 6771 6772 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino), 6773 &namdsc,&namdsc.dsc$w_length,0,0); 6774 if (retsts & 1) { 6775 fname[namdsc.dsc$w_length] = '\0'; 6776 /* 6777 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name, 6778 * but if someone has redefined that logical, Perl gets very lost. Since 6779 * we have the physical device name from the stat buffer, just paste it on. 6780 */ 6781 strcpy( fname_phdev, statbufp->st_devnam ); 6782 strcat( fname_phdev, strrchr(fname, ':') ); 6783 6784 return cando_by_name(bit,effective,fname_phdev); 6785 } 6786 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) { 6787 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n"); 6788 return FALSE; 6789 } 6790 _ckvmssts(retsts); 6791 return FALSE; /* Should never get to here */ 6792 } 6793 } /* end of cando() */ 6794 /*}}}*/ 6795 6796 6797 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/ 6798 I32 6799 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname) 6800 { 6801 static char usrname[L_cuserid]; 6802 static struct dsc$descriptor_s usrdsc = 6803 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname}; 6804 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1]; 6805 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2]; 6806 unsigned short int retlen, trnlnm_iter_count; 6807 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; 6808 union prvdef curprv; 6809 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen}, 6810 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}}; 6811 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen}, 6812 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length}, 6813 {0,0,0,0}}; 6814 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen}, 6815 {0,0,0,0}}; 6816 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; 6817 6818 if (!fname || !*fname) return FALSE; 6819 /* Make sure we expand logical names, since sys$check_access doesn't */ 6820 if (!strpbrk(fname,"/]>:")) { 6821 strcpy(fileified,fname); 6822 trnlnm_iter_count = 0; 6823 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) { 6824 trnlnm_iter_count++; 6825 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break; 6826 } 6827 fname = fileified; 6828 } 6829 if (!do_tovmsspec(fname,vmsname,1)) return FALSE; 6830 retlen = namdsc.dsc$w_length = strlen(vmsname); 6831 namdsc.dsc$a_pointer = vmsname; 6832 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' || 6833 vmsname[retlen-1] == ':') { 6834 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE; 6835 namdsc.dsc$w_length = strlen(fileified); 6836 namdsc.dsc$a_pointer = fileified; 6837 } 6838 6839 switch (bit) { 6840 case S_IXUSR: case S_IXGRP: case S_IXOTH: 6841 access = ARM$M_EXECUTE; break; 6842 case S_IRUSR: case S_IRGRP: case S_IROTH: 6843 access = ARM$M_READ; break; 6844 case S_IWUSR: case S_IWGRP: case S_IWOTH: 6845 access = ARM$M_WRITE; break; 6846 case S_IDUSR: case S_IDGRP: case S_IDOTH: 6847 access = ARM$M_DELETE; break; 6848 default: 6849 return FALSE; 6850 } 6851 6852 /* Before we call $check_access, create a user profile with the current 6853 * process privs since otherwise it just uses the default privs from the 6854 * UAF and might give false positives or negatives. This only works on 6855 * VMS versions v6.0 and later since that's when sys$create_user_profile 6856 * became available. 6857 */ 6858 6859 /* get current process privs and username */ 6860 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0)); 6861 _ckvmssts(iosb[0]); 6862 6863 #if defined(__VMS_VER) && __VMS_VER >= 60000000 6864 6865 /* find out the space required for the profile */ 6866 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0, 6867 &usrprodsc.dsc$w_length,0)); 6868 6869 /* allocate space for the profile and get it filled in */ 6870 Newx(usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char); 6871 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer, 6872 &usrprodsc.dsc$w_length,0)); 6873 6874 /* use the profile to check access to the file; free profile & analyze results */ 6875 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc); 6876 Safefree(usrprodsc.dsc$a_pointer); 6877 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */ 6878 6879 #else 6880 6881 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst); 6882 6883 #endif 6884 6885 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT || 6886 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN || 6887 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) { 6888 set_vaxc_errno(retsts); 6889 if (retsts == SS$_NOPRIV) set_errno(EACCES); 6890 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL); 6891 else set_errno(ENOENT); 6892 return FALSE; 6893 } 6894 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) { 6895 return TRUE; 6896 } 6897 _ckvmssts(retsts); 6898 6899 return FALSE; /* Should never get here */ 6900 6901 } /* end of cando_by_name() */ 6902 /*}}}*/ 6903 6904 6905 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/ 6906 int 6907 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp) 6908 { 6909 if (!fstat(fd,(stat_t *) statbufp)) { 6910 if (statbufp == (Stat_t *) &PL_statcache) { 6911 char *cptr; 6912 6913 /* Save name for cando by name in VMS format */ 6914 cptr = getname(fd, namecache, 1); 6915 6916 /* This should not happen, but just in case */ 6917 if (cptr == NULL) 6918 namecache[0] = '\0'; 6919 } 6920 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam); 6921 # ifdef RTL_USES_UTC 6922 # ifdef VMSISH_TIME 6923 if (VMSISH_TIME) { 6924 statbufp->st_mtime = _toloc(statbufp->st_mtime); 6925 statbufp->st_atime = _toloc(statbufp->st_atime); 6926 statbufp->st_ctime = _toloc(statbufp->st_ctime); 6927 } 6928 # endif 6929 # else 6930 # ifdef VMSISH_TIME 6931 if (!VMSISH_TIME) { /* Return UTC instead of local time */ 6932 # else 6933 if (1) { 6934 # endif 6935 statbufp->st_mtime = _toutc(statbufp->st_mtime); 6936 statbufp->st_atime = _toutc(statbufp->st_atime); 6937 statbufp->st_ctime = _toutc(statbufp->st_ctime); 6938 } 6939 #endif 6940 return 0; 6941 } 6942 return -1; 6943 6944 } /* end of flex_fstat() */ 6945 /*}}}*/ 6946 6947 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/ 6948 int 6949 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp) 6950 { 6951 char fileified[NAM$C_MAXRSS+1]; 6952 char temp_fspec[NAM$C_MAXRSS+300]; 6953 int retval = -1; 6954 int saved_errno, saved_vaxc_errno; 6955 6956 if (!fspec) return retval; 6957 saved_errno = errno; saved_vaxc_errno = vaxc$errno; 6958 strcpy(temp_fspec, fspec); 6959 if (statbufp == (Stat_t *) &PL_statcache) 6960 do_tovmsspec(temp_fspec,namecache,0); 6961 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */ 6962 memset(statbufp,0,sizeof *statbufp); 6963 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:"); 6964 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC; 6965 statbufp->st_uid = 0x00010001; 6966 statbufp->st_gid = 0x0001; 6967 time((time_t *)&statbufp->st_mtime); 6968 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime; 6969 return 0; 6970 } 6971 6972 /* Try for a directory name first. If fspec contains a filename without 6973 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir 6974 * and sea:[wine.dark]water. exist, we prefer the directory here. 6975 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir, 6976 * not sea:[wine.dark]., if the latter exists. If the intended target is 6977 * the file with null type, specify this by calling flex_stat() with 6978 * a '.' at the end of fspec. 6979 */ 6980 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) { 6981 retval = stat(fileified,(stat_t *) statbufp); 6982 if (!retval && statbufp == (Stat_t *) &PL_statcache) 6983 strcpy(namecache,fileified); 6984 } 6985 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp); 6986 if (!retval) { 6987 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam); 6988 # ifdef RTL_USES_UTC 6989 # ifdef VMSISH_TIME 6990 if (VMSISH_TIME) { 6991 statbufp->st_mtime = _toloc(statbufp->st_mtime); 6992 statbufp->st_atime = _toloc(statbufp->st_atime); 6993 statbufp->st_ctime = _toloc(statbufp->st_ctime); 6994 } 6995 # endif 6996 # else 6997 # ifdef VMSISH_TIME 6998 if (!VMSISH_TIME) { /* Return UTC instead of local time */ 6999 # else 7000 if (1) { 7001 # endif 7002 statbufp->st_mtime = _toutc(statbufp->st_mtime); 7003 statbufp->st_atime = _toutc(statbufp->st_atime); 7004 statbufp->st_ctime = _toutc(statbufp->st_ctime); 7005 } 7006 # endif 7007 } 7008 /* If we were successful, leave errno where we found it */ 7009 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; } 7010 return retval; 7011 7012 } /* end of flex_stat() */ 7013 /*}}}*/ 7014 7015 7016 /*{{{char *my_getlogin()*/ 7017 /* VMS cuserid == Unix getlogin, except calling sequence */ 7018 char * 7019 my_getlogin() 7020 { 7021 static char user[L_cuserid]; 7022 return cuserid(user); 7023 } 7024 /*}}}*/ 7025 7026 7027 /* rmscopy - copy a file using VMS RMS routines 7028 * 7029 * Copies contents and attributes of spec_in to spec_out, except owner 7030 * and protection information. Name and type of spec_in are used as 7031 * defaults for spec_out. The third parameter specifies whether rmscopy() 7032 * should try to propagate timestamps from the input file to the output file. 7033 * If it is less than 0, no timestamps are preserved. If it is 0, then 7034 * rmscopy() will behave similarly to the DCL COPY command: timestamps are 7035 * propagated to the output file at creation iff the output file specification 7036 * did not contain an explicit name or type, and the revision date is always 7037 * updated at the end of the copy operation. If it is greater than 0, then 7038 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps 7039 * other than the revision date should be propagated, and bit 1 indicates 7040 * that the revision date should be propagated. 7041 * 7042 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure. 7043 * 7044 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>. 7045 * Incorporates, with permission, some code from EZCOPY by Tim Adye 7046 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code 7047 * as part of the Perl standard distribution under the terms of the 7048 * GNU General Public License or the Perl Artistic License. Copies 7049 * of each may be found in the Perl standard distribution. 7050 */ 7051 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/ 7052 int 7053 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates) 7054 { 7055 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS], 7056 rsa[NAM$C_MAXRSS], ubf[32256]; 7057 unsigned long int i, sts, sts2; 7058 struct FAB fab_in, fab_out; 7059 struct RAB rab_in, rab_out; 7060 struct NAM nam; 7061 struct XABDAT xabdat; 7062 struct XABFHC xabfhc; 7063 struct XABRDT xabrdt; 7064 struct XABSUM xabsum; 7065 7066 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) || 7067 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) { 7068 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); 7069 return 0; 7070 } 7071 7072 fab_in = cc$rms_fab; 7073 fab_in.fab$l_fna = vmsin; 7074 fab_in.fab$b_fns = strlen(vmsin); 7075 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI; 7076 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET; 7077 fab_in.fab$l_fop = FAB$M_SQO; 7078 fab_in.fab$l_nam = &nam; 7079 fab_in.fab$l_xab = (void *) &xabdat; 7080 7081 nam = cc$rms_nam; 7082 nam.nam$l_rsa = rsa; 7083 nam.nam$b_rss = sizeof(rsa); 7084 nam.nam$l_esa = esa; 7085 nam.nam$b_ess = sizeof (esa); 7086 nam.nam$b_esl = nam.nam$b_rsl = 0; 7087 7088 xabdat = cc$rms_xabdat; /* To get creation date */ 7089 xabdat.xab$l_nxt = (void *) &xabfhc; 7090 7091 xabfhc = cc$rms_xabfhc; /* To get record length */ 7092 xabfhc.xab$l_nxt = (void *) &xabsum; 7093 7094 xabsum = cc$rms_xabsum; /* To get key and area information */ 7095 7096 if (!((sts = sys$open(&fab_in)) & 1)) { 7097 set_vaxc_errno(sts); 7098 switch (sts) { 7099 case RMS$_FNF: case RMS$_DNF: 7100 set_errno(ENOENT); break; 7101 case RMS$_DIR: 7102 set_errno(ENOTDIR); break; 7103 case RMS$_DEV: 7104 set_errno(ENODEV); break; 7105 case RMS$_SYN: 7106 set_errno(EINVAL); break; 7107 case RMS$_PRV: 7108 set_errno(EACCES); break; 7109 default: 7110 set_errno(EVMSERR); 7111 } 7112 return 0; 7113 } 7114 7115 fab_out = fab_in; 7116 fab_out.fab$w_ifi = 0; 7117 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT; 7118 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI; 7119 fab_out.fab$l_fop = FAB$M_SQO; 7120 fab_out.fab$l_fna = vmsout; 7121 fab_out.fab$b_fns = strlen(vmsout); 7122 fab_out.fab$l_dna = nam.nam$l_name; 7123 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0; 7124 7125 if (preserve_dates == 0) { /* Act like DCL COPY */ 7126 nam.nam$b_nop = NAM$M_SYNCHK; 7127 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */ 7128 if (!((sts = sys$parse(&fab_out)) & 1)) { 7129 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR); 7130 set_vaxc_errno(sts); 7131 return 0; 7132 } 7133 fab_out.fab$l_xab = (void *) &xabdat; 7134 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1; 7135 } 7136 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */ 7137 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */ 7138 preserve_dates =0; /* bitmask from this point forward */ 7139 7140 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc; 7141 if (!((sts = sys$create(&fab_out)) & 1)) { 7142 set_vaxc_errno(sts); 7143 switch (sts) { 7144 case RMS$_DNF: 7145 set_errno(ENOENT); break; 7146 case RMS$_DIR: 7147 set_errno(ENOTDIR); break; 7148 case RMS$_DEV: 7149 set_errno(ENODEV); break; 7150 case RMS$_SYN: 7151 set_errno(EINVAL); break; 7152 case RMS$_PRV: 7153 set_errno(EACCES); break; 7154 default: 7155 set_errno(EVMSERR); 7156 } 7157 return 0; 7158 } 7159 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */ 7160 if (preserve_dates & 2) { 7161 /* sys$close() will process xabrdt, not xabdat */ 7162 xabrdt = cc$rms_xabrdt; 7163 #ifndef __GNUC__ 7164 xabrdt.xab$q_rdt = xabdat.xab$q_rdt; 7165 #else 7166 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt 7167 * is unsigned long[2], while DECC & VAXC use a struct */ 7168 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt); 7169 #endif 7170 fab_out.fab$l_xab = (void *) &xabrdt; 7171 } 7172 7173 rab_in = cc$rms_rab; 7174 rab_in.rab$l_fab = &fab_in; 7175 rab_in.rab$l_rop = RAB$M_BIO; 7176 rab_in.rab$l_ubf = ubf; 7177 rab_in.rab$w_usz = sizeof ubf; 7178 if (!((sts = sys$connect(&rab_in)) & 1)) { 7179 sys$close(&fab_in); sys$close(&fab_out); 7180 set_errno(EVMSERR); set_vaxc_errno(sts); 7181 return 0; 7182 } 7183 7184 rab_out = cc$rms_rab; 7185 rab_out.rab$l_fab = &fab_out; 7186 rab_out.rab$l_rbf = ubf; 7187 if (!((sts = sys$connect(&rab_out)) & 1)) { 7188 sys$close(&fab_in); sys$close(&fab_out); 7189 set_errno(EVMSERR); set_vaxc_errno(sts); 7190 return 0; 7191 } 7192 7193 while ((sts = sys$read(&rab_in))) { /* always true */ 7194 if (sts == RMS$_EOF) break; 7195 rab_out.rab$w_rsz = rab_in.rab$w_rsz; 7196 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) { 7197 sys$close(&fab_in); sys$close(&fab_out); 7198 set_errno(EVMSERR); set_vaxc_errno(sts); 7199 return 0; 7200 } 7201 } 7202 7203 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */ 7204 sys$close(&fab_in); sys$close(&fab_out); 7205 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts; 7206 if (!(sts & 1)) { 7207 set_errno(EVMSERR); set_vaxc_errno(sts); 7208 return 0; 7209 } 7210 7211 return 1; 7212 7213 } /* end of rmscopy() */ 7214 /*}}}*/ 7215 7216 7217 /*** The following glue provides 'hooks' to make some of the routines 7218 * from this file available from Perl. These routines are sufficiently 7219 * basic, and are required sufficiently early in the build process, 7220 * that's it's nice to have them available to miniperl as well as the 7221 * full Perl, so they're set up here instead of in an extension. The 7222 * Perl code which handles importation of these names into a given 7223 * package lives in [.VMS]Filespec.pm in @INC. 7224 */ 7225 7226 void 7227 rmsexpand_fromperl(pTHX_ CV *cv) 7228 { 7229 dXSARGS; 7230 char *fspec, *defspec = NULL, *rslt; 7231 STRLEN n_a; 7232 7233 if (!items || items > 2) 7234 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])"); 7235 fspec = SvPV(ST(0),n_a); 7236 if (!fspec || !*fspec) XSRETURN_UNDEF; 7237 if (items == 2) defspec = SvPV(ST(1),n_a); 7238 7239 rslt = do_rmsexpand(fspec,NULL,1,defspec,0); 7240 ST(0) = sv_newmortal(); 7241 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt)); 7242 XSRETURN(1); 7243 } 7244 7245 void 7246 vmsify_fromperl(pTHX_ CV *cv) 7247 { 7248 dXSARGS; 7249 char *vmsified; 7250 STRLEN n_a; 7251 7252 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)"); 7253 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1); 7254 ST(0) = sv_newmortal(); 7255 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified)); 7256 XSRETURN(1); 7257 } 7258 7259 void 7260 unixify_fromperl(pTHX_ CV *cv) 7261 { 7262 dXSARGS; 7263 char *unixified; 7264 STRLEN n_a; 7265 7266 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)"); 7267 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1); 7268 ST(0) = sv_newmortal(); 7269 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified)); 7270 XSRETURN(1); 7271 } 7272 7273 void 7274 fileify_fromperl(pTHX_ CV *cv) 7275 { 7276 dXSARGS; 7277 char *fileified; 7278 STRLEN n_a; 7279 7280 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)"); 7281 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1); 7282 ST(0) = sv_newmortal(); 7283 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified)); 7284 XSRETURN(1); 7285 } 7286 7287 void 7288 pathify_fromperl(pTHX_ CV *cv) 7289 { 7290 dXSARGS; 7291 char *pathified; 7292 STRLEN n_a; 7293 7294 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)"); 7295 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1); 7296 ST(0) = sv_newmortal(); 7297 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified)); 7298 XSRETURN(1); 7299 } 7300 7301 void 7302 vmspath_fromperl(pTHX_ CV *cv) 7303 { 7304 dXSARGS; 7305 char *vmspath; 7306 STRLEN n_a; 7307 7308 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)"); 7309 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1); 7310 ST(0) = sv_newmortal(); 7311 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath)); 7312 XSRETURN(1); 7313 } 7314 7315 void 7316 unixpath_fromperl(pTHX_ CV *cv) 7317 { 7318 dXSARGS; 7319 char *unixpath; 7320 STRLEN n_a; 7321 7322 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)"); 7323 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1); 7324 ST(0) = sv_newmortal(); 7325 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath)); 7326 XSRETURN(1); 7327 } 7328 7329 void 7330 candelete_fromperl(pTHX_ CV *cv) 7331 { 7332 dXSARGS; 7333 char fspec[NAM$C_MAXRSS+1], *fsp; 7334 SV *mysv; 7335 IO *io; 7336 STRLEN n_a; 7337 7338 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)"); 7339 7340 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0); 7341 if (SvTYPE(mysv) == SVt_PVGV) { 7342 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) { 7343 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); 7344 ST(0) = &PL_sv_no; 7345 XSRETURN(1); 7346 } 7347 fsp = fspec; 7348 } 7349 else { 7350 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) { 7351 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); 7352 ST(0) = &PL_sv_no; 7353 XSRETURN(1); 7354 } 7355 } 7356 7357 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp)); 7358 XSRETURN(1); 7359 } 7360 7361 void 7362 rmscopy_fromperl(pTHX_ CV *cv) 7363 { 7364 dXSARGS; 7365 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp; 7366 int date_flag; 7367 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}, 7368 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; 7369 unsigned long int sts; 7370 SV *mysv; 7371 IO *io; 7372 STRLEN n_a; 7373 7374 if (items < 2 || items > 3) 7375 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])"); 7376 7377 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0); 7378 if (SvTYPE(mysv) == SVt_PVGV) { 7379 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) { 7380 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); 7381 ST(0) = &PL_sv_no; 7382 XSRETURN(1); 7383 } 7384 inp = inspec; 7385 } 7386 else { 7387 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) { 7388 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); 7389 ST(0) = &PL_sv_no; 7390 XSRETURN(1); 7391 } 7392 } 7393 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1); 7394 if (SvTYPE(mysv) == SVt_PVGV) { 7395 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) { 7396 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); 7397 ST(0) = &PL_sv_no; 7398 XSRETURN(1); 7399 } 7400 outp = outspec; 7401 } 7402 else { 7403 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) { 7404 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); 7405 ST(0) = &PL_sv_no; 7406 XSRETURN(1); 7407 } 7408 } 7409 date_flag = (items == 3) ? SvIV(ST(2)) : 0; 7410 7411 ST(0) = boolSV(rmscopy(inp,outp,date_flag)); 7412 XSRETURN(1); 7413 } 7414 7415 7416 void 7417 mod2fname(pTHX_ CV *cv) 7418 { 7419 dXSARGS; 7420 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1], 7421 workbuff[NAM$C_MAXRSS*1 + 1]; 7422 int total_namelen = 3, counter, num_entries; 7423 /* ODS-5 ups this, but we want to be consistent, so... */ 7424 int max_name_len = 39; 7425 AV *in_array = (AV *)SvRV(ST(0)); 7426 7427 num_entries = av_len(in_array); 7428 7429 /* All the names start with PL_. */ 7430 strcpy(ultimate_name, "PL_"); 7431 7432 /* Clean up our working buffer */ 7433 Zero(work_name, sizeof(work_name), char); 7434 7435 /* Run through the entries and build up a working name */ 7436 for(counter = 0; counter <= num_entries; counter++) { 7437 /* If it's not the first name then tack on a __ */ 7438 if (counter) { 7439 strcat(work_name, "__"); 7440 } 7441 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE), 7442 PL_na)); 7443 } 7444 7445 /* Check to see if we actually have to bother...*/ 7446 if (strlen(work_name) + 3 <= max_name_len) { 7447 strcat(ultimate_name, work_name); 7448 } else { 7449 /* It's too darned big, so we need to go strip. We use the same */ 7450 /* algorithm as xsubpp does. First, strip out doubled __ */ 7451 char *source, *dest, last; 7452 dest = workbuff; 7453 last = 0; 7454 for (source = work_name; *source; source++) { 7455 if (last == *source && last == '_') { 7456 continue; 7457 } 7458 *dest++ = *source; 7459 last = *source; 7460 } 7461 /* Go put it back */ 7462 strcpy(work_name, workbuff); 7463 /* Is it still too big? */ 7464 if (strlen(work_name) + 3 > max_name_len) { 7465 /* Strip duplicate letters */ 7466 last = 0; 7467 dest = workbuff; 7468 for (source = work_name; *source; source++) { 7469 if (last == toupper(*source)) { 7470 continue; 7471 } 7472 *dest++ = *source; 7473 last = toupper(*source); 7474 } 7475 strcpy(work_name, workbuff); 7476 } 7477 7478 /* Is it *still* too big? */ 7479 if (strlen(work_name) + 3 > max_name_len) { 7480 /* Too bad, we truncate */ 7481 work_name[max_name_len - 2] = 0; 7482 } 7483 strcat(ultimate_name, work_name); 7484 } 7485 7486 /* Okay, return it */ 7487 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0)); 7488 XSRETURN(1); 7489 } 7490 7491 void 7492 hushexit_fromperl(pTHX_ CV *cv) 7493 { 7494 dXSARGS; 7495 7496 if (items > 0) { 7497 VMSISH_HUSHED = SvTRUE(ST(0)); 7498 } 7499 ST(0) = boolSV(VMSISH_HUSHED); 7500 XSRETURN(1); 7501 } 7502 7503 void 7504 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, 7505 struct interp_intern *dst) 7506 { 7507 memcpy(dst,src,sizeof(struct interp_intern)); 7508 } 7509 7510 void 7511 Perl_sys_intern_clear(pTHX) 7512 { 7513 } 7514 7515 void 7516 Perl_sys_intern_init(pTHX) 7517 { 7518 unsigned int ix = RAND_MAX; 7519 double x; 7520 7521 VMSISH_HUSHED = 0; 7522 7523 x = (float)ix; 7524 MY_INV_RAND_MAX = 1./x; 7525 } 7526 7527 void 7528 init_os_extras() 7529 { 7530 dTHX; 7531 char* file = __FILE__; 7532 char temp_buff[512]; 7533 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) { 7534 no_translate_barewords = TRUE; 7535 } else { 7536 no_translate_barewords = FALSE; 7537 } 7538 7539 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$"); 7540 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$"); 7541 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$"); 7542 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$"); 7543 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$"); 7544 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$"); 7545 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$"); 7546 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$"); 7547 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$"); 7548 newXS("File::Copy::rmscopy",rmscopy_fromperl,file); 7549 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$"); 7550 7551 store_pipelocs(aTHX); /* will redo any earlier attempts */ 7552 7553 return; 7554 } 7555 7556 /* End of vms.c */ 7557