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