source: vendor/perl/5.8.8/vms/vms.c

Last change on this file was 3181, checked in by bird, 18 years ago

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