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