This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[dummy merge]
[perl5.git] / vms / vms.c
CommitLineData
748a9306 1/* vms.c
a0d0e21e 2 *
748a9306
LW
3 * VMS-specific routines for perl5
4 *
ff0cee69
PP
5 * Last revised: 15-Feb-1997 by Charles Bailey bailey@genetics.upenn.edu
6 * Version: 5.3.27
a0d0e21e
LW
7 */
8
9#include <acedef.h>
10#include <acldef.h>
11#include <armdef.h>
748a9306 12#include <atrdef.h>
a0d0e21e 13#include <chpdef.h>
a3e9d8c9 14#include <climsgdef.h>
a0d0e21e
LW
15#include <descrip.h>
16#include <dvidef.h>
748a9306 17#include <fibdef.h>
a0d0e21e
LW
18#include <float.h>
19#include <fscndef.h>
20#include <iodef.h>
21#include <jpidef.h>
22#include <libdef.h>
23#include <lib$routines.h>
24#include <lnmdef.h>
748a9306 25#include <prvdef.h>
a0d0e21e
LW
26#include <psldef.h>
27#include <rms.h>
28#include <shrdef.h>
29#include <ssdef.h>
30#include <starlet.h>
f86702cc
PP
31#include <strdef.h>
32#include <str$routines.h>
a0d0e21e 33#include <syidef.h>
748a9306
LW
34#include <uaidef.h>
35#include <uicdef.h>
a0d0e21e 36
740ce14c
PP
37/* Older versions of ssdef.h don't have these */
38#ifndef SS$_INVFILFOROP
39# define SS$_INVFILFOROP 3930
40#endif
41#ifndef SS$_NOSUCHOBJECT
b7ae7a0d
PP
42# define SS$_NOSUCHOBJECT 2696
43#endif
44
aa689395
PP
45/* Don't replace system definitions of vfork, getenv, and stat,
46 * code below needs to get to the underlying CRTL routines. */
47#define DONT_MASK_RTL_CALLS
a0d0e21e
LW
48#include "EXTERN.h"
49#include "perl.h"
748a9306 50#include "XSUB.h"
a0d0e21e 51
c07a80fd
PP
52/* gcc's header files don't #define direct access macros
53 * corresponding to VAXC's variant structs */
54#ifdef __GNUC__
482b294c
PP
55# define uic$v_format uic$r_uic_form.uic$v_format
56# define uic$v_group uic$r_uic_form.uic$v_group
57# define uic$v_member uic$r_uic_form.uic$v_member
c07a80fd
PP
58# define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
59# define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
60# define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
61# define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
62#endif
63
64
a0d0e21e
LW
65struct itmlst_3 {
66 unsigned short int buflen;
67 unsigned short int itmcode;
68 void *bufadr;
748a9306 69 unsigned short int *retlen;
a0d0e21e
LW
70};
71
01b8edb6
PP
72static char *__mystrtolower(char *str)
73{
74 if (str) for (; *str; ++str) *str= tolower(*str);
75 return str;
76}
77
c07a80fd
PP
78int
79my_trnlnm(char *lnm, char *eqv, unsigned long int idx)
748a9306
LW
80{
81 static char __my_trnlnm_eqv[LNM$C_NAMLENGTH+1];
82 unsigned short int eqvlen;
83 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
84 $DESCRIPTOR(tabdsc,"LNM$FILE_DEV");
85 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
c07a80fd
PP
86 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
87 {LNM$C_NAMLENGTH, LNM$_STRING, 0, &eqvlen},
748a9306
LW
88 {0, 0, 0, 0}};
89
b7ae7a0d
PP
90 if (!lnm || idx > LNM$_MAX_INDEX) {
91 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
92 }
748a9306 93 if (!eqv) eqv = __my_trnlnm_eqv;
c07a80fd 94 lnmlst[1].bufadr = (void *)eqv;
748a9306
LW
95 lnmdsc.dsc$a_pointer = lnm;
96 lnmdsc.dsc$w_length = strlen(lnm);
97 retsts = sys$trnlnm(&attr,&tabdsc,&lnmdsc,0,lnmlst);
c07a80fd
PP
98 if (retsts == SS$_NOLOGNAM || retsts == SS$_IVLOGNAM) {
99 set_vaxc_errno(retsts); set_errno(EINVAL); return 0;
100 }
748a9306
LW
101 else if (retsts & 1) {
102 eqv[eqvlen] = '\0';
740ce14c 103 return eqvlen;
748a9306
LW
104 }
105 _ckvmssts(retsts); /* Must be an error */
c07a80fd
PP
106 return 0; /* Not reached, assuming _ckvmssts() bails out */
107
108} /* end of my_trnlnm */
a0d0e21e
LW
109
110/* my_getenv
111 * Translate a logical name. Substitute for CRTL getenv() to avoid
112 * memory leak, and to keep my_getenv() and my_setenv() in the same
113 * domain (mostly - my_getenv() need not return a translation from
114 * the process logical name table)
115 *
116 * Note: Uses static buffer -- not thread-safe!
117 */
118/*{{{ char *my_getenv(char *lnm)*/
119char *
120my_getenv(char *lnm)
121{
122 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
55497cff 123 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
c07a80fd 124 unsigned long int idx = 0;
edc7bc49 125 int trnsuccess;
a0d0e21e
LW
126
127 for (cp1 = lnm, cp2= uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
128 *cp2 = '\0';
748a9306
LW
129 if (cp1 - lnm == 7 && !strncmp(uplnm,"DEFAULT",7)) {
130 getcwd(__my_getenv_eqv,sizeof __my_getenv_eqv);
131 return __my_getenv_eqv;
132 }
a0d0e21e 133 else {
c07a80fd
PP
134 if ((cp2 = strchr(uplnm,';')) != NULL) {
135 *cp2 = '\0';
136 idx = strtoul(cp2+1,NULL,0);
137 }
edc7bc49
CB
138 trnsuccess = my_trnlnm(uplnm,__my_getenv_eqv,idx);
139 /* If we had a translation index, we're only interested in lnms */
140 if (!trnsuccess && cp2 != NULL) return Nullch;
141 if (trnsuccess) return __my_getenv_eqv;
c07a80fd
PP
142 else {
143 unsigned long int retsts;
144 struct dsc$descriptor_s symdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
145 valdsc = {sizeof __my_getenv_eqv,DSC$K_DTYPE_T,
146 DSC$K_CLASS_S, __my_getenv_eqv};
147 symdsc.dsc$w_length = cp1 - lnm;
148 symdsc.dsc$a_pointer = uplnm;
149 retsts = lib$get_symbol(&symdsc,&valdsc,&(valdsc.dsc$w_length),0);
150 if (retsts == LIB$_INVSYMNAM) return Nullch;
151 if (retsts != LIB$_NOSUCHSYM) {
152 /* We want to return only logical names or CRTL Unix emulations */
153 if (retsts & 1) return Nullch;
154 _ckvmssts(retsts);
155 }
156 /* Try for CRTL emulation of a Unix/POSIX name */
740ce14c 157 else return getenv(uplnm);
a0d0e21e
LW
158 }
159 }
748a9306 160 return Nullch;
a0d0e21e
LW
161
162} /* end of my_getenv() */
163/*}}}*/
164
1e422769
PP
165static FILE *safe_popen(char *, char *);
166
740ce14c
PP
167/*{{{ void prime_env_iter() */
168void
169prime_env_iter(void)
170/* Fill the %ENV associative array with all logical names we can
171 * find, in preparation for iterating over it.
172 */
173{
174 static int primed = 0; /* XXX Not thread-safe!!! */
175 HV *envhv = GvHVn(envgv);
176 FILE *sholog;
177 char eqv[LNM$C_NAMLENGTH+1],*start,*end;
178 STRLEN eqvlen;
179 SV *oldrs, *linesv, *eqvsv;
180
181 if (primed) return;
182 /* Perform a dummy fetch as an lval to insure that the hash table is
183 * set up. Otherwise, the hv_store() will turn into a nullop */
184 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
185 /* Also, set up the four "special" keys that the CRTL defines,
186 * whether or not underlying logical names exist. */
187 (void) hv_fetch(envhv,"HOME",4,TRUE);
188 (void) hv_fetch(envhv,"TERM",4,TRUE);
189 (void) hv_fetch(envhv,"PATH",4,TRUE);
190 (void) hv_fetch(envhv,"USER",4,TRUE);
191
192 /* Now, go get the logical names */
1e422769 193 if ((sholog = safe_popen("$ Show Logical *","r")) == Nullfp)
740ce14c 194 _ckvmssts(vaxc$errno);
1e422769 195 /* We use Perl's sv_gets to read from the pipe, since safe_popen is
740ce14c
PP
196 * tied to Perl's I/O layer, so it may not return a simple FILE * */
197 oldrs = rs;
198 rs = newSVpv("\n",1);
199 linesv = newSVpv("",0);
200 while (1) {
201 if ((start = sv_gets(linesv,sholog,0)) == Nullch) {
202 my_pclose(sholog);
203 SvREFCNT_dec(linesv); SvREFCNT_dec(rs); rs = oldrs;
204 primed = 1;
205 return;
206 }
207 while (*start != '"' && *start != '=' && *start) start++;
208 if (*start != '"') continue;
209 for (end = ++start; *end && *end != '"'; end++) ;
210 if (*end) *end = '\0';
211 else end = Nullch;
edc7bc49
CB
212 if ((eqvlen = my_trnlnm(start,eqv,0)) == 0) {
213 if (vaxc$errno == SS$_NOLOGNAM || vaxc$errno == SS$_IVLOGNAM) {
214 if (dowarn)
215 warn("Ill-formed logical name |%s| in prime_env_iter",start);
216 continue;
217 }
218 else _ckvmssts(vaxc$errno);
219 }
740ce14c
PP
220 else {
221 eqvsv = newSVpv(eqv,eqvlen);
222 hv_store(envhv,start,(end ? end - start : strlen(start)),eqvsv,0);
223 }
224 }
225} /* end of prime_env_iter */
226/*}}}*/
227
228
a0d0e21e
LW
229/*{{{ void my_setenv(char *lnm, char *eqv)*/
230void
231my_setenv(char *lnm,char *eqv)
232/* Define a supervisor-mode logical name in the process table.
233 * In the future we'll add tables, attribs, and acmodes,
234 * probably through a different call.
235 */
236{
237 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
238 unsigned long int retsts, usermode = PSL$C_USER;
239 $DESCRIPTOR(tabdsc,"LNM$PROCESS");
240 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
241 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
242
243 for(cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
244 lnmdsc.dsc$w_length = cp1 - lnm;
245
246 if (!eqv || !*eqv) { /* we're deleting a logical name */
247 retsts = sys$dellnm(&tabdsc,&lnmdsc,&usermode); /* try user mode first */
748a9306
LW
248 if (retsts == SS$_IVLOGNAM) return;
249 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
a0d0e21e
LW
250 if (!(retsts & 1)) {
251 retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */
748a9306 252 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
a0d0e21e
LW
253 }
254 }
255 else {
256 eqvdsc.dsc$w_length = strlen(eqv);
257 eqvdsc.dsc$a_pointer = eqv;
258
748a9306 259 _ckvmssts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0));
a0d0e21e
LW
260 }
261
262} /* end of my_setenv() */
263/*}}}*/
264
c07a80fd
PP
265
266/*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
267/* my_crypt - VMS password hashing
268 * my_crypt() provides an interface compatible with the Unix crypt()
269 * C library function, and uses sys$hash_password() to perform VMS
270 * password hashing. The quadword hashed password value is returned
271 * as a NUL-terminated 8 character string. my_crypt() does not change
272 * the case of its string arguments; in order to match the behavior
273 * of LOGINOUT et al., alphabetic characters in both arguments must
274 * be upcased by the caller.
275 */
276char *
277my_crypt(const char *textpasswd, const char *usrname)
278{
279# ifndef UAI$C_PREFERRED_ALGORITHM
280# define UAI$C_PREFERRED_ALGORITHM 127
281# endif
282 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
283 unsigned short int salt = 0;
284 unsigned long int sts;
285 struct const_dsc {
286 unsigned short int dsc$w_length;
287 unsigned char dsc$b_type;
288 unsigned char dsc$b_class;
289 const char * dsc$a_pointer;
290 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
291 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
292 struct itmlst_3 uailst[3] = {
293 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
294 { sizeof salt, UAI$_SALT, &salt, 0},
295 { 0, 0, NULL, NULL}};
296 static char hash[9];
297
298 usrdsc.dsc$w_length = strlen(usrname);
299 usrdsc.dsc$a_pointer = usrname;
300 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
301 switch (sts) {
302 case SS$_NOGRPPRV:
303 case SS$_NOSYSPRV:
304 set_errno(EACCES);
305 break;
306 case RMS$_RNF:
307 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
308 break;
309 default:
310 set_errno(EVMSERR);
311 }
312 set_vaxc_errno(sts);
313 if (sts != RMS$_RNF) return NULL;
314 }
315
316 txtdsc.dsc$w_length = strlen(textpasswd);
317 txtdsc.dsc$a_pointer = textpasswd;
318 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
319 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
320 }
321
322 return (char *) hash;
323
324} /* end of my_crypt() */
325/*}}}*/
326
327
bbce6d69 328static char *do_rmsexpand(char *, char *, int, char *, unsigned);
a0d0e21e
LW
329static char *do_fileify_dirspec(char *, char *, int);
330static char *do_tovmsspec(char *, char *, int);
331
332/*{{{int do_rmdir(char *name)*/
333int
334do_rmdir(char *name)
335{
336 char dirfile[NAM$C_MAXRSS+1];
337 int retval;
aa689395 338 struct mystat st;
a0d0e21e
LW
339
340 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
341 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
342 else retval = kill_file(dirfile);
343 return retval;
344
345} /* end of do_rmdir */
346/*}}}*/
347
348/* kill_file
349 * Delete any file to which user has control access, regardless of whether
350 * delete access is explicitly allowed.
351 * Limitations: User must have write access to parent directory.
352 * Does not block signals or ASTs; if interrupted in midstream
353 * may leave file with an altered ACL.
354 * HANDLE WITH CARE!
355 */
356/*{{{int kill_file(char *name)*/
357int
358kill_file(char *name)
359{
bbce6d69 360 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
a0d0e21e 361 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
748a9306 362 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
a0d0e21e
LW
363 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
364 struct myacedef {
748a9306
LW
365 unsigned char myace$b_length;
366 unsigned char myace$b_type;
367 unsigned short int myace$w_flags;
368 unsigned long int myace$l_access;
369 unsigned long int myace$l_ident;
a0d0e21e
LW
370 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
371 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
372 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
373 struct itmlst_3
748a9306
LW
374 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
375 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
376 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
377 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
378 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
379 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
a0d0e21e 380
bbce6d69
PP
381 /* Expand the input spec using RMS, since the CRTL remove() and
382 * system services won't do this by themselves, so we may miss
383 * a file "hiding" behind a logical name or search list. */
384 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
385 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
386 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
740ce14c
PP
387 /* If not, can changing protections help? */
388 if (vaxc$errno != RMS$_PRV) return -1;
a0d0e21e
LW
389
390 /* No, so we get our own UIC to use as a rights identifier,
391 * and the insert an ACE at the head of the ACL which allows us
392 * to delete the file.
393 */
748a9306 394 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
bbce6d69
PP
395 fildsc.dsc$w_length = strlen(rspec);
396 fildsc.dsc$a_pointer = rspec;
a0d0e21e 397 cxt = 0;
748a9306 398 newace.myace$l_ident = oldace.myace$l_ident;
a0d0e21e 399 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
740ce14c
PP
400 switch (aclsts) {
401 case RMS$_FNF:
402 case RMS$_DNF:
403 case RMS$_DIR:
404 case SS$_NOSUCHOBJECT:
405 set_errno(ENOENT); break;
406 case RMS$_DEV:
407 set_errno(ENODEV); break;
408 case RMS$_SYN:
409 case SS$_INVFILFOROP:
410 set_errno(EINVAL); break;
411 case RMS$_PRV:
412 set_errno(EACCES); break;
413 default:
414 _ckvmssts(aclsts);
415 }
748a9306 416 set_vaxc_errno(aclsts);
a0d0e21e
LW
417 return -1;
418 }
419 /* Grab any existing ACEs with this identifier in case we fail */
420 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
e518068a
PP
421 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
422 || fndsts == SS$_NOMOREACE ) {
a0d0e21e
LW
423 /* Add the new ACE . . . */
424 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
425 goto yourroom;
748a9306 426 if ((rmsts = remove(name))) {
a0d0e21e
LW
427 /* We blew it - dir with files in it, no write priv for
428 * parent directory, etc. Put things back the way they were. */
429 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
430 goto yourroom;
431 if (fndsts & 1) {
432 addlst[0].bufadr = &oldace;
433 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
434 goto yourroom;
435 }
436 }
437 }
438
439 yourroom:
b7ae7a0d
PP
440 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
441 /* We just deleted it, so of course it's not there. Some versions of
442 * VMS seem to return success on the unlock operation anyhow (after all
443 * the unlock is successful), but others don't.
444 */
760ac839 445 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
b7ae7a0d 446 if (aclsts & 1) aclsts = fndsts;
a0d0e21e 447 if (!(aclsts & 1)) {
748a9306
LW
448 set_errno(EVMSERR);
449 set_vaxc_errno(aclsts);
a0d0e21e
LW
450 return -1;
451 }
452
453 return rmsts;
454
455} /* end of kill_file() */
456/*}}}*/
457
458static void
459create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
460{
461 static unsigned long int mbxbufsiz;
462 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
463
464 if (!mbxbufsiz) {
465 /*
466 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
467 * preprocessor consant BUFSIZ from stdio.h as the size of the
468 * 'pipe' mailbox.
469 */
748a9306 470 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
a0d0e21e
LW
471 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
472 }
748a9306 473 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
a0d0e21e 474
748a9306 475 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
a0d0e21e
LW
476 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
477
478} /* end of create_mbx() */
479
480/*{{{ my_popen and my_pclose*/
481struct pipe_details
482{
483 struct pipe_details *next;
740ce14c 484 PerlIO *fp; /* stdio file pointer to pipe mailbox */
748a9306
LW
485 int pid; /* PID of subprocess */
486 int mode; /* == 'r' if pipe open for reading */
487 int done; /* subprocess has completed */
488 unsigned long int completion; /* termination status of subprocess */
a0d0e21e
LW
489};
490
748a9306
LW
491struct exit_control_block
492{
493 struct exit_control_block *flink;
494 unsigned long int (*exit_routine)();
495 unsigned long int arg_count;
496 unsigned long int *status_address;
497 unsigned long int exit_status;
498};
499
a0d0e21e
LW
500static struct pipe_details *open_pipes = NULL;
501static $DESCRIPTOR(nl_desc, "NL:");
502static int waitpid_asleep = 0;
503
748a9306
LW
504static unsigned long int
505pipe_exit_routine()
506{
1e422769
PP
507 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
508 int sts;
748a9306
LW
509
510 while (open_pipes != NULL) {
511 if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/
512 _ckvmssts(sys$forcex(&open_pipes->pid,0,&abort));
513 sleep(1);
514 }
515 if (!open_pipes->done) /* We tried to be nice . . . */
516 _ckvmssts(sys$delprc(&open_pipes->pid,0));
1e422769
PP
517 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
518 else if (!(sts & 1)) retsts = sts;
748a9306
LW
519 }
520 return retsts;
521}
522
523static struct exit_control_block pipe_exitblock =
524 {(struct exit_control_block *) 0,
525 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
526
527
a0d0e21e 528static void
748a9306 529popen_completion_ast(struct pipe_details *thispipe)
a0d0e21e 530{
748a9306 531 thispipe->done = TRUE;
a0d0e21e
LW
532 if (waitpid_asleep) {
533 waitpid_asleep = 0;
534 sys$wake(0,0);
535 }
536}
537
1e422769
PP
538static FILE *
539safe_popen(char *cmd, char *mode)
a0d0e21e 540{
748a9306 541 static int handler_set_up = FALSE;
a0d0e21e
LW
542 char mbxname[64];
543 unsigned short int chan;
544 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
545 struct pipe_details *info;
546 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
547 DSC$K_CLASS_S, mbxname},
548 cmddsc = {0, DSC$K_DTYPE_T,
549 DSC$K_CLASS_S, 0};
550
551
a3e9d8c9
PP
552 cmddsc.dsc$w_length=strlen(cmd);
553 cmddsc.dsc$a_pointer=cmd;
554 if (cmddsc.dsc$w_length > 255) {
555 set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
556 return Nullfp;
557 }
558
a0d0e21e
LW
559 New(7001,info,1,struct pipe_details);
560
a0d0e21e
LW
561 /* create mailbox */
562 create_mbx(&chan,&namdsc);
563
564 /* open a FILE* onto it */
740ce14c 565 info->fp = PerlIO_open(mbxname, mode);
a0d0e21e
LW
566
567 /* give up other channel onto it */
748a9306 568 _ckvmssts(sys$dassgn(chan));
a0d0e21e
LW
569
570 if (!info->fp)
571 return Nullfp;
572
748a9306
LW
573 info->mode = *mode;
574 info->done = FALSE;
575 info->completion=0;
576
577 if (*mode == 'r') {
578 _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
a0d0e21e 579 0 /* name */, &info->pid, &info->completion,
748a9306 580 0, popen_completion_ast,info,0,0,0));
a0d0e21e
LW
581 }
582 else {
748a9306
LW
583 _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
584 0 /* name */, &info->pid, &info->completion,
585 0, popen_completion_ast,info,0,0,0));
a0d0e21e
LW
586 }
587
748a9306
LW
588 if (!handler_set_up) {
589 _ckvmssts(sys$dclexh(&pipe_exitblock));
590 handler_set_up = TRUE;
591 }
a0d0e21e
LW
592 info->next=open_pipes; /* prepend to list */
593 open_pipes=info;
594
e518068a 595 forkprocess = info->pid;
a0d0e21e 596 return info->fp;
1e422769
PP
597} /* end of safe_popen */
598
599
600/*{{{ FILE *my_popen(char *cmd, char *mode)*/
601FILE *
602my_popen(char *cmd, char *mode)
603{
604 TAINT_ENV();
605 TAINT_PROPER("popen");
606 return safe_popen(cmd,mode);
a0d0e21e 607}
1e422769 608
a0d0e21e
LW
609/*}}}*/
610
611/*{{{ I32 my_pclose(FILE *fp)*/
612I32 my_pclose(FILE *fp)
613{
614 struct pipe_details *info, *last = NULL;
748a9306 615 unsigned long int retsts;
a0d0e21e
LW
616
617 for (info = open_pipes; info != NULL; last = info, info = info->next)
618 if (info->fp == fp) break;
619
1e422769
PP
620 if (info == NULL) { /* no such pipe open */
621 set_errno(ECHILD); /* quoth POSIX */
622 set_vaxc_errno(SS$_NONEXPR);
623 return -1;
624 }
748a9306 625
bbce6d69
PP
626 /* If we were writing to a subprocess, insure that someone reading from
627 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
628 * produce an EOF record in the mailbox. */
629 if (info->mode != 'r') {
630 char devnam[NAM$C_MAXRSS+1], *cp;
631 unsigned long int chan, iosb[2], retsts, retsts2;
632 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
633
634 if (fgetname(info->fp,devnam)) {
635 /* It oughta be a mailbox, so fgetname should give just the device
636 * name, but just in case . . . */
637 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
638 devdsc.dsc$w_length = strlen(devnam);
639 _ckvmssts(sys$assign(&devdsc,&chan,0,0));
640 retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
641 if (retsts & 1) retsts = iosb[0];
642 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
643 if (retsts & 1) retsts = retsts2;
644 _ckvmssts(retsts);
645 }
646 else _ckvmssts(vaxc$errno); /* Should never happen */
647 }
740ce14c 648 PerlIO_close(info->fp);
c07a80fd 649
748a9306
LW
650 if (info->done) retsts = info->completion;
651 else waitpid(info->pid,(int *) &retsts,0);
a0d0e21e 652
a0d0e21e
LW
653 /* remove from list of open pipes */
654 if (last) last->next = info->next;
655 else open_pipes = info->next;
a0d0e21e
LW
656 Safefree(info);
657
658 return retsts;
748a9306 659
a0d0e21e
LW
660} /* end of my_pclose() */
661
a0d0e21e 662/* sort-of waitpid; use only with popen() */
4fdae800
PP
663/*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
664Pid_t
665my_waitpid(Pid_t pid, int *statusp, int flags)
a0d0e21e
LW
666{
667 struct pipe_details *info;
a0d0e21e
LW
668
669 for (info = open_pipes; info != NULL; info = info->next)
670 if (info->pid == pid) break;
671
672 if (info != NULL) { /* we know about this child */
748a9306 673 while (!info->done) {
a0d0e21e
LW
674 waitpid_asleep = 1;
675 sys$hiber();
676 }
677
678 *statusp = info->completion;
679 return pid;
680 }
681 else { /* we haven't heard of this child */
682 $DESCRIPTOR(intdsc,"0 00:00:01");
683 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
748a9306 684 unsigned long int interval[2],sts;
a0d0e21e 685
748a9306
LW
686 if (dowarn) {
687 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
688 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
689 if (ownerpid != mypid)
690 warn("pid %d not a child",pid);
691 }
a0d0e21e 692
748a9306 693 _ckvmssts(sys$bintim(&intdsc,interval));
a0d0e21e 694 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
748a9306
LW
695 _ckvmssts(sys$schdwk(0,0,interval,0));
696 _ckvmssts(sys$hiber());
a0d0e21e 697 }
748a9306 698 _ckvmssts(sts);
a0d0e21e
LW
699
700 /* There's no easy way to find the termination status a child we're
701 * not aware of beforehand. If we're really interested in the future,
702 * we can go looking for a termination mailbox, or chase after the
703 * accounting record for the process.
704 */
705 *statusp = 0;
706 return pid;
707 }
708
709} /* end of waitpid() */
a0d0e21e
LW
710/*}}}*/
711/*}}}*/
712/*}}}*/
713
714/*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
715char *
716my_gconvert(double val, int ndig, int trail, char *buf)
717{
718 static char __gcvtbuf[DBL_DIG+1];
719 char *loc;
720
721 loc = buf ? buf : __gcvtbuf;
71be2cbc
PP
722
723#ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
724 if (val < 1) {
725 sprintf(loc,"%.*g",ndig,val);
726 return loc;
727 }
728#endif
729
a0d0e21e
LW
730 if (val) {
731 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
732 return gcvt(val,ndig,loc);
733 }
734 else {
735 loc[0] = '0'; loc[1] = '\0';
736 return loc;
737 }
738
739}
740/*}}}*/
741
bbce6d69
PP
742
743/*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
744/* Shortcut for common case of simple calls to $PARSE and $SEARCH
745 * to expand file specification. Allows for a single default file
746 * specification and a simple mask of options. If outbuf is non-NULL,
747 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
748 * the resultant file specification is placed. If outbuf is NULL, the
749 * resultant file specification is placed into a static buffer.
750 * The third argument, if non-NULL, is taken to be a default file
751 * specification string. The fourth argument is unused at present.
752 * rmesexpand() returns the address of the resultant string if
753 * successful, and NULL on error.
754 */
755static char *
756do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
757{
758 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
759 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
760 struct FAB myfab = cc$rms_fab;
761 struct NAM mynam = cc$rms_nam;
762 STRLEN speclen;
763 unsigned long int retsts, haslower = 0;
764
765 if (!filespec || !*filespec) {
766 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
767 return NULL;
768 }
769 if (!outbuf) {
770 if (ts) out = New(7019,outbuf,NAM$C_MAXRSS+1,char);
771 else outbuf = __rmsexpand_retbuf;
772 }
773
774 myfab.fab$l_fna = filespec;
775 myfab.fab$b_fns = strlen(filespec);
776 myfab.fab$l_nam = &mynam;
777
778 if (defspec && *defspec) {
779 myfab.fab$l_dna = defspec;
780 myfab.fab$b_dns = strlen(defspec);
781 }
782
783 mynam.nam$l_esa = esa;
784 mynam.nam$b_ess = sizeof esa;
785 mynam.nam$l_rsa = outbuf;
786 mynam.nam$b_rss = NAM$C_MAXRSS;
787
788 retsts = sys$parse(&myfab,0,0);
789 if (!(retsts & 1)) {
790 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
791 retsts == RMS$_DEV || retsts == RMS$_DEV) {
792 mynam.nam$b_nop |= NAM$M_SYNCHK;
793 retsts = sys$parse(&myfab,0,0);
794 if (retsts & 1) goto expanded;
795 }
796 if (out) Safefree(out);
797 set_vaxc_errno(retsts);
798 if (retsts == RMS$_PRV) set_errno(EACCES);
799 else if (retsts == RMS$_DEV) set_errno(ENODEV);
800 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
801 else set_errno(EVMSERR);
802 return NULL;
803 }
804 retsts = sys$search(&myfab,0,0);
805 if (!(retsts & 1) && retsts != RMS$_FNF) {
806 if (out) Safefree(out);
807 set_vaxc_errno(retsts);
808 if (retsts == RMS$_PRV) set_errno(EACCES);
809 else set_errno(EVMSERR);
810 return NULL;
811 }
812
813 /* If the input filespec contained any lowercase characters,
814 * downcase the result for compatibility with Unix-minded code. */
815 expanded:
816 for (out = myfab.fab$l_fna; *out; out++)
817 if (islower(*out)) { haslower = 1; break; }
818 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
819 else { out = esa; speclen = mynam.nam$b_esl; }
820 if (!(mynam.nam$l_fnb & NAM$M_EXP_VER) &&
821 (!defspec || !*defspec || !strchr(myfab.fab$l_dna,';')))
822 speclen = mynam.nam$l_ver - out;
823 /* If we just had a directory spec on input, $PARSE "helpfully"
824 * adds an empty name and type for us */
825 if (mynam.nam$l_name == mynam.nam$l_type &&
826 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
827 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
828 speclen = mynam.nam$l_name - out;
829 out[speclen] = '\0';
830 if (haslower) __mystrtolower(out);
831
832 /* Have we been working with an expanded, but not resultant, spec? */
833 if (!mynam.nam$b_rsl) strcpy(outbuf,esa);
834 return outbuf;
835}
836/*}}}*/
837/* External entry points */
838char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
839{ return do_rmsexpand(spec,buf,0,def,opt); }
840char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
841{ return do_rmsexpand(spec,buf,1,def,opt); }
842
843
a0d0e21e
LW
844/*
845** The following routines are provided to make life easier when
846** converting among VMS-style and Unix-style directory specifications.
847** All will take input specifications in either VMS or Unix syntax. On
848** failure, all return NULL. If successful, the routines listed below
748a9306 849** return a pointer to a buffer containing the appropriately
a0d0e21e
LW
850** reformatted spec (and, therefore, subsequent calls to that routine
851** will clobber the result), while the routines of the same names with
852** a _ts suffix appended will return a pointer to a mallocd string
853** containing the appropriately reformatted spec.
854** In all cases, only explicit syntax is altered; no check is made that
855** the resulting string is valid or that the directory in question
856** actually exists.
857**
858** fileify_dirspec() - convert a directory spec into the name of the
859** directory file (i.e. what you can stat() to see if it's a dir).
860** The style (VMS or Unix) of the result is the same as the style
861** of the parameter passed in.
862** pathify_dirspec() - convert a directory spec into a path (i.e.
863** what you prepend to a filename to indicate what directory it's in).
864** The style (VMS or Unix) of the result is the same as the style
865** of the parameter passed in.
866** tounixpath() - convert a directory spec into a Unix-style path.
867** tovmspath() - convert a directory spec into a VMS-style path.
868** tounixspec() - convert any file spec into a Unix-style file spec.
869** tovmsspec() - convert any file spec into a VMS-style spec.
e518068a 870**
a3e9d8c9 871** Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>
01b8edb6
PP
872** Permission is given to distribute this code as part of the Perl
873** standard distribution under the terms of the GNU General Public
874** License or the Perl Artistic License. Copies of each may be
875** found in the Perl standard distribution.
a0d0e21e
LW
876 */
877
748a9306
LW
878static char *do_tounixspec(char *, char *, int);
879
a0d0e21e
LW
880/*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
881static char *do_fileify_dirspec(char *dir,char *buf,int ts)
882{
883 static char __fileify_retbuf[NAM$C_MAXRSS+1];
b7ae7a0d 884 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
a0d0e21e 885 char *retspec, *cp1, *cp2, *lastdir;
748a9306 886 char trndir[NAM$C_MAXRSS+1], vmsdir[NAM$C_MAXRSS+1];
a0d0e21e 887
c07a80fd
PP
888 if (!dir || !*dir) {
889 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
890 }
a0d0e21e 891 dirlen = strlen(dir);
01b8edb6 892 if (dir[dirlen-1] == '/') --dirlen;
c07a80fd
PP
893 if (!dirlen) {
894 set_errno(ENOTDIR);
895 set_vaxc_errno(RMS$_DIR);
896 return NULL;
897 }
e518068a
PP
898 if (!strpbrk(dir+1,"/]>:")) {
899 strcpy(trndir,*dir == '/' ? dir + 1: dir);
c07a80fd 900 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
e518068a
PP
901 dir = trndir;
902 dirlen = strlen(dir);
903 }
01b8edb6
PP
904 else {
905 strncpy(trndir,dir,dirlen);
906 trndir[dirlen] = '\0';
907 dir = trndir;
908 }
c07a80fd
PP
909 /* If we were handed a rooted logical name or spec, treat it like a
910 * simple directory, so that
911 * $ Define myroot dev:[dir.]
912 * ... do_fileify_dirspec("myroot",buf,1) ...
913 * does something useful.
914 */
915 if (!strcmp(dir+dirlen-2,".]")) {
916 dir[--dirlen] = '\0';
917 dir[dirlen-1] = ']';
918 }
e518068a 919
b7ae7a0d
PP
920 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
921 /* If we've got an explicit filename, we can just shuffle the string. */
922 if (*(cp1+1)) hasfilename = 1;
923 /* Similarly, we can just back up a level if we've got multiple levels
924 of explicit directories in a VMS spec which ends with directories. */
925 else {
926 for (cp2 = cp1; cp2 > dir; cp2--) {
927 if (*cp2 == '.') {
928 *cp2 = *cp1; *cp1 = '\0';
929 hasfilename = 1;
930 break;
931 }
932 if (*cp2 == '[' || *cp2 == '<') break;
933 }
934 }
935 }
936
937 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
748a9306
LW
938 if (dir[0] == '.') {
939 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
940 return do_fileify_dirspec("[]",buf,ts);
941 else if (dir[1] == '.' &&
942 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
943 return do_fileify_dirspec("[-]",buf,ts);
944 }
a0d0e21e
LW
945 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
946 dirlen -= 1; /* to last element */
947 lastdir = strrchr(dir,'/');
948 }
01b8edb6
PP
949 else if ((cp1 = strstr(dir,"/.")) != NULL) {
950 /* If we have "/." or "/..", VMSify it and let the VMS code
951 * below expand it, rather than repeating the code to handle
952 * relative components of a filespec here */
4633a7c4
LW
953 do {
954 if (*(cp1+2) == '.') cp1++;
955 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
01b8edb6
PP
956 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
957 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
958 return do_tounixspec(trndir,buf,ts);
4633a7c4
LW
959 }
960 cp1++;
961 } while ((cp1 = strstr(cp1,"/.")) != NULL);
748a9306 962 }
a0d0e21e 963 else {
b7ae7a0d
PP
964 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
965 !(lastdir = cp1 = strrchr(dir,']')) &&
966 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
a0d0e21e 967 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
b7ae7a0d
PP
968 int ver; char *cp3;
969 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
970 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
971 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
972 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
973 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
974 (ver || *cp3)))))) {
975 set_errno(ENOTDIR);
748a9306 976 set_vaxc_errno(RMS$_DIR);
a0d0e21e
LW
977 return NULL;
978 }
b7ae7a0d 979 dirlen = cp2 - dir;
a0d0e21e 980 }
748a9306
LW
981 }
982 /* If we lead off with a device or rooted logical, add the MFD
983 if we're specifying a top-level directory. */
984 if (lastdir && *dir == '/') {
985 addmfd = 1;
986 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
987 if (*cp1 == '/') {
988 addmfd = 0;
989 break;
a0d0e21e
LW
990 }
991 }
748a9306 992 }
4633a7c4 993 retlen = dirlen + (addmfd ? 13 : 6);
748a9306 994 if (buf) retspec = buf;
e518068a 995 else if (ts) New(7009,retspec,retlen+1,char);
748a9306
LW
996 else retspec = __fileify_retbuf;
997 if (addmfd) {
998 dirlen = lastdir - dir;
999 memcpy(retspec,dir,dirlen);
1000 strcpy(&retspec[dirlen],"/000000");
1001 strcpy(&retspec[dirlen+7],lastdir);
1002 }
1003 else {
1004 memcpy(retspec,dir,dirlen);
1005 retspec[dirlen] = '\0';
a0d0e21e
LW
1006 }
1007 /* We've picked up everything up to the directory file name.
1008 Now just add the type and version, and we're set. */
1009 strcat(retspec,".dir;1");
1010 return retspec;
1011 }
1012 else { /* VMS-style directory spec */
01b8edb6
PP
1013 char esa[NAM$C_MAXRSS+1], term, *cp;
1014 unsigned long int sts, cmplen, haslower = 0;
a0d0e21e
LW
1015 struct FAB dirfab = cc$rms_fab;
1016 struct NAM savnam, dirnam = cc$rms_nam;
1017
1018 dirfab.fab$b_fns = strlen(dir);
1019 dirfab.fab$l_fna = dir;
1020 dirfab.fab$l_nam = &dirnam;
748a9306
LW
1021 dirfab.fab$l_dna = ".DIR;1";
1022 dirfab.fab$b_dns = 6;
a0d0e21e
LW
1023 dirnam.nam$b_ess = NAM$C_MAXRSS;
1024 dirnam.nam$l_esa = esa;
01b8edb6
PP
1025
1026 for (cp = dir; *cp; cp++)
1027 if (islower(*cp)) { haslower = 1; break; }
e518068a
PP
1028 if (!((sts = sys$parse(&dirfab))&1)) {
1029 if (dirfab.fab$l_sts == RMS$_DIR) {
1030 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1031 sts = sys$parse(&dirfab) & 1;
1032 }
1033 if (!sts) {
748a9306
LW
1034 set_errno(EVMSERR);
1035 set_vaxc_errno(dirfab.fab$l_sts);
a0d0e21e
LW
1036 return NULL;
1037 }
e518068a
PP
1038 }
1039 else {
1040 savnam = dirnam;
1041 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1042 /* Yes; fake the fnb bits so we'll check type below */
1043 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1044 }
1045 else {
1046 if (dirfab.fab$l_sts != RMS$_FNF) {
1047 set_errno(EVMSERR);
1048 set_vaxc_errno(dirfab.fab$l_sts);
1049 return NULL;
1050 }
1051 dirnam = savnam; /* No; just work with potential name */
1052 }
a0d0e21e 1053 }
748a9306
LW
1054 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1055 cp1 = strchr(esa,']');
1056 if (!cp1) cp1 = strchr(esa,'>');
1057 if (cp1) { /* Should always be true */
1058 dirnam.nam$b_esl -= cp1 - esa - 1;
1059 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1060 }
1061 }
a0d0e21e
LW
1062 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1063 /* Yep; check version while we're at it, if it's there. */
1064 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1065 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1066 /* Something other than .DIR[;1]. Bzzt. */
748a9306
LW
1067 set_errno(ENOTDIR);
1068 set_vaxc_errno(RMS$_DIR);
a0d0e21e
LW
1069 return NULL;
1070 }
748a9306
LW
1071 }
1072 esa[dirnam.nam$b_esl] = '\0';
1073 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1074 /* They provided at least the name; we added the type, if necessary, */
1075 if (buf) retspec = buf; /* in sys$parse() */
e518068a 1076 else if (ts) New(7011,retspec,dirnam.nam$b_esl+1,char);
748a9306
LW
1077 else retspec = __fileify_retbuf;
1078 strcpy(retspec,esa);
1079 return retspec;
1080 }
c07a80fd
PP
1081 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1082 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1083 *cp1 = '\0';
1084 dirnam.nam$b_esl -= 9;
1085 }
748a9306
LW
1086 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1087 if (cp1 == NULL) return NULL; /* should never happen */
1088 term = *cp1;
1089 *cp1 = '\0';
1090 retlen = strlen(esa);
1091 if ((cp1 = strrchr(esa,'.')) != NULL) {
1092 /* There's more than one directory in the path. Just roll back. */
1093 *cp1 = term;
1094 if (buf) retspec = buf;
e518068a 1095 else if (ts) New(7011,retspec,retlen+7,char);
748a9306
LW
1096 else retspec = __fileify_retbuf;
1097 strcpy(retspec,esa);
a0d0e21e
LW
1098 }
1099 else {
748a9306
LW
1100 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1101 /* Go back and expand rooted logical name */
1102 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1103 if (!(sys$parse(&dirfab) & 1)) {
1104 set_errno(EVMSERR);
1105 set_vaxc_errno(dirfab.fab$l_sts);
1106 return NULL;
1107 }
1108 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
a0d0e21e 1109 if (buf) retspec = buf;
e518068a 1110 else if (ts) New(7012,retspec,retlen+16,char);
a0d0e21e 1111 else retspec = __fileify_retbuf;
748a9306
LW
1112 cp1 = strstr(esa,"][");
1113 dirlen = cp1 - esa;
1114 memcpy(retspec,esa,dirlen);
1115 if (!strncmp(cp1+2,"000000]",7)) {
1116 retspec[dirlen-1] = '\0';
4633a7c4
LW
1117 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1118 if (*cp1 == '.') *cp1 = ']';
1119 else {
1120 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1121 memcpy(cp1+1,"000000]",7);
1122 }
748a9306
LW
1123 }
1124 else {
1125 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1126 retspec[retlen] = '\0';
1127 /* Convert last '.' to ']' */
4633a7c4
LW
1128 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1129 if (*cp1 == '.') *cp1 = ']';
1130 else {
1131 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1132 memcpy(cp1+1,"000000]",7);
1133 }
748a9306 1134 }
a0d0e21e 1135 }
748a9306 1136 else { /* This is a top-level dir. Add the MFD to the path. */
a0d0e21e 1137 if (buf) retspec = buf;
e518068a 1138 else if (ts) New(7012,retspec,retlen+16,char);
a0d0e21e
LW
1139 else retspec = __fileify_retbuf;
1140 cp1 = esa;
1141 cp2 = retspec;
1142 while (*cp1 != ':') *(cp2++) = *(cp1++);
1143 strcpy(cp2,":[000000]");
1144 cp1 += 2;
1145 strcpy(cp2+9,cp1);
1146 }
748a9306
LW
1147 }
1148 /* We've set up the string up through the filename. Add the
a0d0e21e
LW
1149 type and version, and we're done. */
1150 strcat(retspec,".DIR;1");
01b8edb6
PP
1151
1152 /* $PARSE may have upcased filespec, so convert output to lower
1153 * case if input contained any lowercase characters. */
1154 if (haslower) __mystrtolower(retspec);
a0d0e21e
LW
1155 return retspec;
1156 }
1157} /* end of do_fileify_dirspec() */
1158/*}}}*/
1159/* External entry points */
1160char *fileify_dirspec(char *dir, char *buf)
1161{ return do_fileify_dirspec(dir,buf,0); }
1162char *fileify_dirspec_ts(char *dir, char *buf)
1163{ return do_fileify_dirspec(dir,buf,1); }
1164
1165/*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1166static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1167{
1168 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1169 unsigned long int retlen;
748a9306 1170 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
a0d0e21e 1171
c07a80fd
PP
1172 if (!dir || !*dir) {
1173 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1174 }
1175
1176 if (*dir) strcpy(trndir,dir);
1177 else getcwd(trndir,sizeof trndir - 1);
1178
1179 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
1180 STRLEN trnlen = strlen(trndir);
a0d0e21e 1181
c07a80fd
PP
1182 /* Trap simple rooted lnms, and return lnm:[000000] */
1183 if (!strcmp(trndir+trnlen-2,".]")) {
1184 if (buf) retpath = buf;
1185 else if (ts) New(7018,retpath,strlen(dir)+10,char);
1186 else retpath = __pathify_retbuf;
1187 strcpy(retpath,dir);
1188 strcat(retpath,":[000000]");
1189 return retpath;
1190 }
1191 }
748a9306
LW
1192 dir = trndir;
1193
b7ae7a0d 1194 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
748a9306
LW
1195 if (*dir == '.' && (*(dir+1) == '\0' ||
1196 (*(dir+1) == '.' && *(dir+2) == '\0')))
1197 retlen = 2 + (*(dir+1) != '\0');
1198 else {
b7ae7a0d
PP
1199 if ( !(cp1 = strrchr(dir,'/')) &&
1200 !(cp1 = strrchr(dir,']')) &&
1201 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
f86702cc
PP
1202 if ((cp2 = strchr(cp1,'.')) != NULL &&
1203 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1204 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1205 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1206 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
b7ae7a0d
PP
1207 int ver; char *cp3;
1208 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1209 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1210 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1211 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1212 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1213 (ver || *cp3)))))) {
748a9306
LW
1214 set_errno(ENOTDIR);
1215 set_vaxc_errno(RMS$_DIR);
1216 return NULL;
1217 }
b7ae7a0d 1218 retlen = cp2 - dir + 1;
a0d0e21e 1219 }
748a9306
LW
1220 else { /* No file type present. Treat the filename as a directory. */
1221 retlen = strlen(dir) + 1;
a0d0e21e
LW
1222 }
1223 }
a0d0e21e 1224 if (buf) retpath = buf;
e518068a 1225 else if (ts) New(7013,retpath,retlen+1,char);
a0d0e21e
LW
1226 else retpath = __pathify_retbuf;
1227 strncpy(retpath,dir,retlen-1);
1228 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1229 retpath[retlen-1] = '/'; /* with '/', add it. */
1230 retpath[retlen] = '\0';
1231 }
1232 else retpath[retlen-1] = '\0';
1233 }
1234 else { /* VMS-style directory spec */
01b8edb6
PP
1235 char esa[NAM$C_MAXRSS+1], *cp;
1236 unsigned long int sts, cmplen, haslower;
a0d0e21e
LW
1237 struct FAB dirfab = cc$rms_fab;
1238 struct NAM savnam, dirnam = cc$rms_nam;
1239
b7ae7a0d
PP
1240 /* If we've got an explicit filename, we can just shuffle the string. */
1241 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1242 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1243 if ((cp2 = strchr(cp1,'.')) != NULL) {
1244 int ver; char *cp3;
1245 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1246 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1247 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1248 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1249 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1250 (ver || *cp3)))))) {
1251 set_errno(ENOTDIR);
1252 set_vaxc_errno(RMS$_DIR);
1253 return NULL;
1254 }
1255 }
1256 else { /* No file type, so just draw name into directory part */
1257 for (cp2 = cp1; *cp2; cp2++) ;
1258 }
1259 *cp2 = *cp1;
1260 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1261 *cp1 = '.';
1262 /* We've now got a VMS 'path'; fall through */
1263 }
a0d0e21e
LW
1264 dirfab.fab$b_fns = strlen(dir);
1265 dirfab.fab$l_fna = dir;
748a9306
LW
1266 if (dir[dirfab.fab$b_fns-1] == ']' ||
1267 dir[dirfab.fab$b_fns-1] == '>' ||
1268 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1269 if (buf) retpath = buf;
e518068a 1270 else if (ts) New(7014,retpath,strlen(dir)+1,char);
748a9306
LW
1271 else retpath = __pathify_retbuf;
1272 strcpy(retpath,dir);
1273 return retpath;
1274 }
1275 dirfab.fab$l_dna = ".DIR;1";
1276 dirfab.fab$b_dns = 6;
a0d0e21e 1277 dirfab.fab$l_nam = &dirnam;
e518068a 1278 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
a0d0e21e 1279 dirnam.nam$l_esa = esa;
01b8edb6
PP
1280
1281 for (cp = dir; *cp; cp++)
1282 if (islower(*cp)) { haslower = 1; break; }
1283
1284 if (!(sts = (sys$parse(&dirfab)&1))) {
e518068a
PP
1285 if (dirfab.fab$l_sts == RMS$_DIR) {
1286 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1287 sts = sys$parse(&dirfab) & 1;
1288 }
1289 if (!sts) {
748a9306
LW
1290 set_errno(EVMSERR);
1291 set_vaxc_errno(dirfab.fab$l_sts);
a0d0e21e
LW
1292 return NULL;
1293 }
a0d0e21e 1294 }
e518068a
PP
1295 else {
1296 savnam = dirnam;
1297 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1298 if (dirfab.fab$l_sts != RMS$_FNF) {
1299 set_errno(EVMSERR);
1300 set_vaxc_errno(dirfab.fab$l_sts);
1301 return NULL;
1302 }
1303 dirnam = savnam; /* No; just work with potential name */
1304 }
1305 }
a0d0e21e
LW
1306 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1307 /* Yep; check version while we're at it, if it's there. */
1308 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1309 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1310 /* Something other than .DIR[;1]. Bzzt. */
748a9306
LW
1311 set_errno(ENOTDIR);
1312 set_vaxc_errno(RMS$_DIR);
a0d0e21e
LW
1313 return NULL;
1314 }
a0d0e21e 1315 }
748a9306
LW
1316 /* OK, the type was fine. Now pull any file name into the
1317 directory path. */
1318 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
a0d0e21e 1319 else {
748a9306
LW
1320 cp1 = strrchr(esa,'>');
1321 *dirnam.nam$l_type = '>';
a0d0e21e 1322 }
748a9306
LW
1323 *cp1 = '.';
1324 *(dirnam.nam$l_type + 1) = '\0';
1325 retlen = dirnam.nam$l_type - esa + 2;
a0d0e21e
LW
1326 if (buf) retpath = buf;
1327 else if (ts) New(7014,retpath,retlen,char);
1328 else retpath = __pathify_retbuf;
1329 strcpy(retpath,esa);
01b8edb6
PP
1330 /* $PARSE may have upcased filespec, so convert output to lower
1331 * case if input contained any lowercase characters. */
1332 if (haslower) __mystrtolower(retpath);
a0d0e21e
LW
1333 }
1334
1335 return retpath;
1336} /* end of do_pathify_dirspec() */
1337/*}}}*/
1338/* External entry points */
1339char *pathify_dirspec(char *dir, char *buf)
1340{ return do_pathify_dirspec(dir,buf,0); }
1341char *pathify_dirspec_ts(char *dir, char *buf)
1342{ return do_pathify_dirspec(dir,buf,1); }
1343
1344/*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1345static char *do_tounixspec(char *spec, char *buf, int ts)
1346{
1347 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1348 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
f86702cc 1349 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
a0d0e21e 1350
748a9306 1351 if (spec == NULL) return NULL;
e518068a 1352 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
a0d0e21e 1353 if (buf) rslt = buf;
e518068a
PP
1354 else if (ts) {
1355 retlen = strlen(spec);
1356 cp1 = strchr(spec,'[');
1357 if (!cp1) cp1 = strchr(spec,'<');
1358 if (cp1) {
f86702cc
PP
1359 for (cp1++; *cp1; cp1++) {
1360 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
1361 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
1362 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
1363 }
e518068a 1364 }
f86702cc 1365 New(7015,rslt,retlen+2+2*expand,char);
e518068a 1366 }
a0d0e21e
LW
1367 else rslt = __tounixspec_retbuf;
1368 if (strchr(spec,'/') != NULL) {
1369 strcpy(rslt,spec);
1370 return rslt;
1371 }
1372
1373 cp1 = rslt;
1374 cp2 = spec;
1375 dirend = strrchr(spec,']');
1376 if (dirend == NULL) dirend = strrchr(spec,'>');
1377 if (dirend == NULL) dirend = strchr(spec,':');
1378 if (dirend == NULL) {
1379 strcpy(rslt,spec);
1380 return rslt;
1381 }
a5f75d66 1382 if (*cp2 != '[' && *cp2 != '<') {
a0d0e21e
LW
1383 *(cp1++) = '/';
1384 }
1385 else { /* the VMS spec begins with directories */
1386 cp2++;
a5f75d66 1387 if (*cp2 == ']' || *cp2 == '>') {
f86702cc 1388 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
a5f75d66
AD
1389 return rslt;
1390 }
f86702cc 1391 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
a0d0e21e
LW
1392 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1393 if (ts) Safefree(rslt);
1394 return NULL;
1395 }
1396 do {
1397 cp3 = tmp;
1398 while (*cp3 != ':' && *cp3) cp3++;
1399 *(cp3++) = '\0';
1400 if (strchr(cp3,']') != NULL) break;
e518068a 1401 } while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3));
f86702cc 1402 if (ts && !buf &&
e518068a 1403 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
e518068a 1404 retlen = devlen + dirlen;
f86702cc
PP
1405 Renew(rslt,retlen+1+2*expand,char);
1406 cp1 = rslt;
1407 }
1408 cp3 = tmp;
1409 *(cp1++) = '/';
1410 while (*cp3) {
1411 *(cp1++) = *(cp3++);
1412 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
a0d0e21e 1413 }
f86702cc
PP
1414 *(cp1++) = '/';
1415 }
1416 else if ( *cp2 == '.') {
1417 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
1418 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1419 cp2 += 3;
1420 }
1421 else cp2++;
a0d0e21e 1422 }
a0d0e21e
LW
1423 }
1424 for (; cp2 <= dirend; cp2++) {
1425 if (*cp2 == ':') {
1426 *(cp1++) = '/';
1427 if (*(cp2+1) == '[') cp2++;
1428 }
f86702cc
PP
1429 else if (*cp2 == ']' || *cp2 == '>') {
1430 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
1431 }
a0d0e21e
LW
1432 else if (*cp2 == '.') {
1433 *(cp1++) = '/';
e518068a
PP
1434 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1435 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1436 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1437 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1438 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1439 }
f86702cc
PP
1440 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
1441 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
1442 cp2 += 2;
1443 }
a0d0e21e
LW
1444 }
1445 else if (*cp2 == '-') {
1446 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1447 while (*cp2 == '-') {
1448 cp2++;
1449 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1450 }
1451 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1452 if (ts) Safefree(rslt); /* filespecs like */
01b8edb6 1453 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
a0d0e21e
LW
1454 return NULL;
1455 }
a0d0e21e
LW
1456 }
1457 else *(cp1++) = *cp2;
1458 }
1459 else *(cp1++) = *cp2;
1460 }
1461 while (*cp2) *(cp1++) = *(cp2++);
1462 *cp1 = '\0';
1463
1464 return rslt;
1465
1466} /* end of do_tounixspec() */
1467/*}}}*/
1468/* External entry points */
1469char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1470char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1471
1472/*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1473static char *do_tovmsspec(char *path, char *buf, int ts) {
1474 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
e518068a
PP
1475 char *rslt, *dirend;
1476 register char *cp1, *cp2;
1477 unsigned long int infront = 0, hasdir = 1;
a0d0e21e 1478
748a9306 1479 if (path == NULL) return NULL;
a0d0e21e 1480 if (buf) rslt = buf;
e518068a 1481 else if (ts) New(7016,rslt,strlen(path)+9,char);
a0d0e21e 1482 else rslt = __tovmsspec_retbuf;
748a9306 1483 if (strpbrk(path,"]:>") ||
a0d0e21e 1484 (dirend = strrchr(path,'/')) == NULL) {
748a9306
LW
1485 if (path[0] == '.') {
1486 if (path[1] == '\0') strcpy(rslt,"[]");
1487 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1488 else strcpy(rslt,path); /* probably garbage */
1489 }
1490 else strcpy(rslt,path);
a0d0e21e
LW
1491 return rslt;
1492 }
f86702cc 1493 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
748a9306
LW
1494 if (!*(dirend+2)) dirend +=2;
1495 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
f86702cc 1496 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
748a9306 1497 }
a0d0e21e
LW
1498 cp1 = rslt;
1499 cp2 = path;
1500 if (*cp2 == '/') {
e518068a
PP
1501 char trndev[NAM$C_MAXRSS+1];
1502 int islnm, rooted;
1503 STRLEN trnend;
1504
b7ae7a0d 1505 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
a0d0e21e 1506 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
e518068a 1507 *cp1 = '\0';
c07a80fd 1508 islnm = my_trnlnm(rslt,trndev,0);
e518068a
PP
1509 trnend = islnm ? strlen(trndev) - 1 : 0;
1510 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
1511 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
1512 /* If the first element of the path is a logical name, determine
1513 * whether it has to be translated so we can add more directories. */
1514 if (!islnm || rooted) {
1515 *(cp1++) = ':';
1516 *(cp1++) = '[';
1517 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
1518 else cp2++;
1519 }
1520 else {
1521 if (cp2 != dirend) {
1522 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
1523 strcpy(rslt,trndev);
1524 cp1 = rslt + trnend;
1525 *(cp1++) = '.';
1526 cp2++;
1527 }
1528 else {
1529 *(cp1++) = ':';
1530 hasdir = 0;
1531 }
1532 }
748a9306 1533 }
a0d0e21e
LW
1534 else {
1535 *(cp1++) = '[';
748a9306
LW
1536 if (*cp2 == '.') {
1537 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
1538 cp2 += 2; /* skip over "./" - it's redundant */
1539 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
1540 }
1541 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1542 *(cp1++) = '-'; /* "../" --> "-" */
1543 cp2 += 3;
1544 }
f86702cc
PP
1545 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
1546 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
1547 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
1548 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
1549 cp2 += 4;
1550 }
748a9306
LW
1551 if (cp2 > dirend) cp2 = dirend;
1552 }
1553 else *(cp1++) = '.';
1554 }
1555 for (; cp2 < dirend; cp2++) {
1556 if (*cp2 == '/') {
01b8edb6 1557 if (*(cp2-1) == '/') continue;
748a9306
LW
1558 if (*(cp1-1) != '.') *(cp1++) = '.';
1559 infront = 0;
1560 }
1561 else if (!infront && *cp2 == '.') {
01b8edb6
PP
1562 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
1563 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
748a9306
LW
1564 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1565 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
1566 else if (*(cp1-2) == '[') *(cp1-1) = '-';
1567 else { /* back up over previous directory name */
1568 cp1--;
1569 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
4633a7c4
LW
1570 if (*(cp1-1) == '[') {
1571 memcpy(cp1,"000000.",7);
1572 cp1 += 7;
1573 }
748a9306
LW
1574 }
1575 cp2 += 2;
01b8edb6 1576 if (cp2 == dirend) break;
748a9306 1577 }
f86702cc
PP
1578 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
1579 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
1580 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
1581 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
1582 if (!*(cp2+3)) {
1583 *(cp1++) = '.'; /* Simulate trailing '/' */
1584 cp2 += 2; /* for loop will incr this to == dirend */
1585 }
1586 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
1587 }
748a9306
LW
1588 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
1589 }
1590 else {
e518068a 1591 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
01b8edb6 1592 if (*cp2 == '.') *(cp1++) = '_';
748a9306
LW
1593 else *(cp1++) = *cp2;
1594 infront = 1;
1595 }
a0d0e21e 1596 }
748a9306 1597 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
e518068a 1598 if (hasdir) *(cp1++) = ']';
748a9306 1599 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
a0d0e21e
LW
1600 while (*cp2) *(cp1++) = *(cp2++);
1601 *cp1 = '\0';
1602
1603 return rslt;
1604
1605} /* end of do_tovmsspec() */
1606/*}}}*/
1607/* External entry points */
1608char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
1609char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
1610
1611/*{{{ char *tovmspath[_ts](char *path, char *buf)*/
1612static char *do_tovmspath(char *path, char *buf, int ts) {
1613 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
1614 int vmslen;
1615 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
1616
748a9306 1617 if (path == NULL) return NULL;
a0d0e21e
LW
1618 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1619 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
1620 if (buf) return buf;
1621 else if (ts) {
1622 vmslen = strlen(vmsified);
e518068a 1623 New(7017,cp,vmslen+1,char);
a0d0e21e
LW
1624 memcpy(cp,vmsified,vmslen);
1625 cp[vmslen] = '\0';
1626 return cp;
1627 }
1628 else {
1629 strcpy(__tovmspath_retbuf,vmsified);
1630 return __tovmspath_retbuf;
1631 }
1632
1633} /* end of do_tovmspath() */
1634/*}}}*/
1635/* External entry points */
1636char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
1637char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
1638
1639
1640/*{{{ char *tounixpath[_ts](char *path, char *buf)*/
1641static char *do_tounixpath(char *path, char *buf, int ts) {
1642 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
1643 int unixlen;
1644 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
1645
748a9306 1646 if (path == NULL) return NULL;
a0d0e21e
LW
1647 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1648 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
1649 if (buf) return buf;
1650 else if (ts) {
1651 unixlen = strlen(unixified);
e518068a 1652 New(7017,cp,unixlen+1,char);
a0d0e21e
LW
1653 memcpy(cp,unixified,unixlen);
1654 cp[unixlen] = '\0';
1655 return cp;
1656 }
1657 else {
1658 strcpy(__tounixpath_retbuf,unixified);
1659 return __tounixpath_retbuf;
1660 }
1661
1662} /* end of do_tounixpath() */
1663/*}}}*/
1664/* External entry points */
1665char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
1666char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
1667
1668/*
1669 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
1670 *
1671 *****************************************************************************
1672 * *
1673 * Copyright (C) 1989-1994 by *
1674 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
1675 * *
1676 * Permission is hereby granted for the reproduction of this software, *
1677 * on condition that this copyright notice is included in the reproduction, *
1678 * and that such reproduction is not for purposes of profit or material *
1679 * gain. *
1680 * *
1681 * 27-Aug-1994 Modified for inclusion in perl5 *
1682 * by Charles Bailey bailey@genetics.upenn.edu *
1683 *****************************************************************************
1684 */
1685
1686/*
1687 * getredirection() is intended to aid in porting C programs
1688 * to VMS (Vax-11 C). The native VMS environment does not support
1689 * '>' and '<' I/O redirection, or command line wild card expansion,
1690 * or a command line pipe mechanism using the '|' AND background
1691 * command execution '&'. All of these capabilities are provided to any
1692 * C program which calls this procedure as the first thing in the
1693 * main program.
1694 * The piping mechanism will probably work with almost any 'filter' type
1695 * of program. With suitable modification, it may useful for other
1696 * portability problems as well.
1697 *
1698 * Author: Mark Pizzolato mark@infocomm.com
1699 */
1700struct list_item
1701 {
1702 struct list_item *next;
1703 char *value;
1704 };
1705
1706static void add_item(struct list_item **head,
1707 struct list_item **tail,
1708 char *value,
1709 int *count);
1710
1711static void expand_wild_cards(char *item,
1712 struct list_item **head,
1713 struct list_item **tail,
1714 int *count);
1715
1716static int background_process(int argc, char **argv);
1717
1718static void pipe_and_fork(char **cmargv);
1719
1720/*{{{ void getredirection(int *ac, char ***av)*/
1721void
1722getredirection(int *ac, char ***av)
1723/*
1724 * Process vms redirection arg's. Exit if any error is seen.
1725 * If getredirection() processes an argument, it is erased
1726 * from the vector. getredirection() returns a new argc and argv value.
1727 * In the event that a background command is requested (by a trailing "&"),
1728 * this routine creates a background subprocess, and simply exits the program.
1729 *
1730 * Warning: do not try to simplify the code for vms. The code
1731 * presupposes that getredirection() is called before any data is
1732 * read from stdin or written to stdout.
1733 *
1734 * Normal usage is as follows:
1735 *
1736 * main(argc, argv)
1737 * int argc;
1738 * char *argv[];
1739 * {
1740 * getredirection(&argc, &argv);
1741 * }
1742 */
1743{
1744 int argc = *ac; /* Argument Count */
1745 char **argv = *av; /* Argument Vector */
1746 char *ap; /* Argument pointer */
1747 int j; /* argv[] index */
1748 int item_count = 0; /* Count of Items in List */
1749 struct list_item *list_head = 0; /* First Item in List */
1750 struct list_item *list_tail; /* Last Item in List */
1751 char *in = NULL; /* Input File Name */
1752 char *out = NULL; /* Output File Name */
1753 char *outmode = "w"; /* Mode to Open Output File */
1754 char *err = NULL; /* Error File Name */
1755 char *errmode = "w"; /* Mode to Open Error File */
1756 int cmargc = 0; /* Piped Command Arg Count */
1757 char **cmargv = NULL;/* Piped Command Arg Vector */
a0d0e21e
LW
1758
1759 /*
1760 * First handle the case where the last thing on the line ends with
1761 * a '&'. This indicates the desire for the command to be run in a
1762 * subprocess, so we satisfy that desire.
1763 */
1764 ap = argv[argc-1];
1765 if (0 == strcmp("&", ap))
1766 exit(background_process(--argc, argv));
e518068a 1767 if (*ap && '&' == ap[strlen(ap)-1])
a0d0e21e
LW
1768 {
1769 ap[strlen(ap)-1] = '\0';
1770 exit(background_process(argc, argv));
1771 }
1772 /*
1773 * Now we handle the general redirection cases that involve '>', '>>',
1774 * '<', and pipes '|'.
1775 */
1776 for (j = 0; j < argc; ++j)
1777 {
1778 if (0 == strcmp("<", argv[j]))
1779 {
1780 if (j+1 >= argc)
1781 {
740ce14c 1782 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
748a9306 1783 exit(LIB$_WRONUMARG);
a0d0e21e
LW
1784 }
1785 in = argv[++j];
1786 continue;
1787 }
1788 if ('<' == *(ap = argv[j]))
1789 {
1790 in = 1 + ap;
1791 continue;
1792 }
1793 if (0 == strcmp(">", ap))
1794 {
1795 if (j+1 >= argc)
1796 {
740ce14c 1797 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
748a9306 1798 exit(LIB$_WRONUMARG);
a0d0e21e
LW
1799 }
1800 out = argv[++j];
1801 continue;
1802 }
1803 if ('>' == *ap)
1804 {
1805 if ('>' == ap[1])
1806 {
1807 outmode = "a";
1808 if ('\0' == ap[2])
1809 out = argv[++j];
1810 else
1811 out = 2 + ap;
1812 }
1813 else
1814 out = 1 + ap;
1815 if (j >= argc)
1816 {
740ce14c 1817 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
748a9306 1818 exit(LIB$_WRONUMARG);
a0d0e21e
LW
1819 }
1820 continue;
1821 }
1822 if (('2' == *ap) && ('>' == ap[1]))
1823 {
1824 if ('>' == ap[2])
1825 {
1826 errmode = "a";
1827 if ('\0' == ap[3])
1828 err = argv[++j];
1829 else
1830 err = 3 + ap;
1831 }
1832 else
1833 if ('\0' == ap[2])
1834 err = argv[++j];
1835 else
748a9306 1836 err = 2 + ap;
a0d0e21e
LW
1837 if (j >= argc)
1838 {
740ce14c 1839 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
748a9306 1840 exit(LIB$_WRONUMARG);
a0d0e21e
LW
1841 }
1842 continue;
1843 }
1844 if (0 == strcmp("|", argv[j]))
1845 {
1846 if (j+1 >= argc)
1847 {
740ce14c 1848 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
748a9306 1849 exit(LIB$_WRONUMARG);
a0d0e21e
LW
1850 }
1851 cmargc = argc-(j+1);
1852 cmargv = &argv[j+1];
1853 argc = j;
1854 continue;
1855 }
1856 if ('|' == *(ap = argv[j]))
1857 {
1858 ++argv[j];
1859 cmargc = argc-j;
1860 cmargv = &argv[j];
1861 argc = j;
1862 continue;
1863 }
1864 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
1865 }
1866 /*
1867 * Allocate and fill in the new argument vector, Some Unix's terminate
1868 * the list with an extra null pointer.
1869 */
1870 New(7002, argv, item_count+1, char *);
1871 *av = argv;
1872 for (j = 0; j < item_count; ++j, list_head = list_head->next)
1873 argv[j] = list_head->value;
1874 *ac = item_count;
1875 if (cmargv != NULL)
1876 {
1877 if (out != NULL)
1878 {
740ce14c 1879 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
748a9306 1880 exit(LIB$_INVARGORD);
a0d0e21e
LW
1881 }
1882 pipe_and_fork(cmargv);
1883 }
1884
1885 /* Check for input from a pipe (mailbox) */
1886
a5f75d66 1887 if (in == NULL && 1 == isapipe(0))
a0d0e21e
LW
1888 {
1889 char mbxname[L_tmpnam];
1890 long int bufsize;
1891 long int dvi_item = DVI$_DEVBUFSIZ;
1892 $DESCRIPTOR(mbxnam, "");
1893 $DESCRIPTOR(mbxdevnam, "");
1894
1895 /* Input from a pipe, reopen it in binary mode to disable */
1896 /* carriage control processing. */
1897
740ce14c 1898 PerlIO_getname(stdin, mbxname);
a0d0e21e
LW
1899 mbxnam.dsc$a_pointer = mbxname;
1900 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
1901 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
1902 mbxdevnam.dsc$a_pointer = mbxname;
1903 mbxdevnam.dsc$w_length = sizeof(mbxname);
1904 dvi_item = DVI$_DEVNAM;
1905 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
1906 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
748a9306
LW
1907 set_errno(0);
1908 set_vaxc_errno(1);
a0d0e21e
LW
1909 freopen(mbxname, "rb", stdin);
1910 if (errno != 0)
1911 {
740ce14c 1912 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
748a9306 1913 exit(vaxc$errno);
a0d0e21e
LW
1914 }
1915 }
1916 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
1917 {
740ce14c 1918 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
748a9306 1919 exit(vaxc$errno);
a0d0e21e
LW
1920 }
1921 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
1922 {
740ce14c 1923 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
748a9306 1924 exit(vaxc$errno);
a0d0e21e 1925 }
748a9306
LW
1926 if (err != NULL) {
1927 FILE *tmperr;
1928 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
1929 {
740ce14c 1930 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
748a9306
LW
1931 exit(vaxc$errno);
1932 }
1933 fclose(tmperr);
b7ae7a0d 1934 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
748a9306
LW
1935 {
1936 exit(vaxc$errno);
1937 }
a0d0e21e
LW
1938 }
1939#ifdef ARGPROC_DEBUG
740ce14c 1940 PerlIO_printf(Perl_debug_log, "Arglist:\n");
a0d0e21e 1941 for (j = 0; j < *ac; ++j)
740ce14c 1942 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
a0d0e21e 1943#endif
b7ae7a0d
PP
1944 /* Clear errors we may have hit expanding wildcards, so they don't
1945 show up in Perl's $! later */
1946 set_errno(0); set_vaxc_errno(1);
a0d0e21e
LW
1947} /* end of getredirection() */
1948/*}}}*/
1949
1950static void add_item(struct list_item **head,
1951 struct list_item **tail,
1952 char *value,
1953 int *count)
1954{
1955 if (*head == 0)
1956 {
1957 New(7003,*head,1,struct list_item);
1958 *tail = *head;
1959 }
1960 else {
1961 New(7004,(*tail)->next,1,struct list_item);
1962 *tail = (*tail)->next;
1963 }
1964 (*tail)->value = value;
1965 ++(*count);
1966}
1967
1968static void expand_wild_cards(char *item,
1969 struct list_item **head,
1970 struct list_item **tail,
1971 int *count)
1972{
1973int expcount = 0;
748a9306 1974unsigned long int context = 0;
a0d0e21e 1975int isunix = 0;
a0d0e21e
LW
1976char *had_version;
1977char *had_device;
1978int had_directory;
1979char *devdir;
1980char vmsspec[NAM$C_MAXRSS+1];
1981$DESCRIPTOR(filespec, "");
748a9306 1982$DESCRIPTOR(defaultspec, "SYS$DISK:[]");
a0d0e21e 1983$DESCRIPTOR(resultspec, "");
c07a80fd 1984unsigned long int zero = 0, sts;
a0d0e21e 1985
b7ae7a0d 1986 if (strcspn(item, "*%") == strlen(item) || strchr(item,' ') != NULL)
a0d0e21e
LW
1987 {
1988 add_item(head, tail, item, count);
1989 return;
1990 }
1991 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
1992 resultspec.dsc$b_class = DSC$K_CLASS_D;
1993 resultspec.dsc$a_pointer = NULL;
748a9306 1994 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
a0d0e21e
LW
1995 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
1996 if (!isunix || !filespec.dsc$a_pointer)
1997 filespec.dsc$a_pointer = item;
1998 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
1999 /*
2000 * Only return version specs, if the caller specified a version
2001 */
2002 had_version = strchr(item, ';');
2003 /*
2004 * Only return device and directory specs, if the caller specifed either.
2005 */
2006 had_device = strchr(item, ':');
2007 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2008
c07a80fd
PP
2009 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2010 &defaultspec, 0, 0, &zero))))
a0d0e21e
LW
2011 {
2012 char *string;
2013 char *c;
2014
2015 New(7005,string,resultspec.dsc$w_length+1,char);
2016 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2017 string[resultspec.dsc$w_length] = '\0';
2018 if (NULL == had_version)
2019 *((char *)strrchr(string, ';')) = '\0';
2020 if ((!had_directory) && (had_device == NULL))
2021 {
2022 if (NULL == (devdir = strrchr(string, ']')))
2023 devdir = strrchr(string, '>');
2024 strcpy(string, devdir + 1);
2025 }
2026 /*
2027 * Be consistent with what the C RTL has already done to the rest of
2028 * the argv items and lowercase all of these names.
2029 */
2030 for (c = string; *c; ++c)
2031 if (isupper(*c))
2032 *c = tolower(*c);
f86702cc 2033 if (isunix) trim_unixpath(string,item,1);
a0d0e21e
LW
2034 add_item(head, tail, string, count);
2035 ++expcount;
2036 }
c07a80fd
PP
2037 if (sts != RMS$_NMF)
2038 {
2039 set_vaxc_errno(sts);
2040 switch (sts)
2041 {
2042 case RMS$_FNF:
b7ae7a0d 2043 case RMS$_DNF:
c07a80fd
PP
2044 case RMS$_DIR:
2045 set_errno(ENOENT); break;
2046 case RMS$_DEV:
2047 set_errno(ENODEV); break;
71be2cbc 2048 case RMS$_FNM:
c07a80fd
PP
2049 case RMS$_SYN:
2050 set_errno(EINVAL); break;
2051 case RMS$_PRV:
2052 set_errno(EACCES); break;
2053 default:
b7ae7a0d 2054 _ckvmssts_noperl(sts);
c07a80fd
PP
2055 }
2056 }
a0d0e21e
LW
2057 if (expcount == 0)
2058 add_item(head, tail, item, count);
b7ae7a0d
PP
2059 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2060 _ckvmssts_noperl(lib$find_file_end(&context));
a0d0e21e
LW
2061}
2062
2063static int child_st[2];/* Event Flag set when child process completes */
2064
748a9306 2065static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
a0d0e21e 2066
748a9306 2067static unsigned long int exit_handler(int *status)
a0d0e21e
LW
2068{
2069short iosb[4];
2070
2071 if (0 == child_st[0])
2072 {
2073#ifdef ARGPROC_DEBUG
740ce14c 2074 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
a0d0e21e
LW
2075#endif
2076 fflush(stdout); /* Have to flush pipe for binary data to */
2077 /* terminate properly -- <tp@mccall.com> */
2078 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2079 sys$dassgn(child_chan);
2080 fclose(stdout);
2081 sys$synch(0, child_st);
2082 }
2083 return(1);
2084}
2085
2086static void sig_child(int chan)
2087{
2088#ifdef ARGPROC_DEBUG
740ce14c 2089 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
a0d0e21e
LW
2090#endif
2091 if (child_st[0] == 0)
2092 child_st[0] = 1;
2093}
2094
748a9306 2095static struct exit_control_block exit_block =
a0d0e21e
LW
2096 {
2097 0,
2098 exit_handler,
2099 1,
2100 &exit_block.exit_status,
2101 0
2102 };
2103
2104static void pipe_and_fork(char **cmargv)
2105{
2106 char subcmd[2048];
2107 $DESCRIPTOR(cmddsc, "");
2108 static char mbxname[64];
2109 $DESCRIPTOR(mbxdsc, mbxname);
a0d0e21e 2110 int pid, j;
a0d0e21e
LW
2111 unsigned long int zero = 0, one = 1;
2112
2113 strcpy(subcmd, cmargv[0]);
2114 for (j = 1; NULL != cmargv[j]; ++j)
2115 {
2116 strcat(subcmd, " \"");
2117 strcat(subcmd, cmargv[j]);
2118 strcat(subcmd, "\"");
2119 }
2120 cmddsc.dsc$a_pointer = subcmd;
2121 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2122
2123 create_mbx(&child_chan,&mbxdsc);
2124#ifdef ARGPROC_DEBUG
740ce14c
PP
2125 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2126 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
a0d0e21e 2127#endif
b7ae7a0d
PP
2128 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2129 0, &pid, child_st, &zero, sig_child,
2130 &child_chan));
a0d0e21e 2131#ifdef ARGPROC_DEBUG
740ce14c 2132 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
a0d0e21e
LW
2133#endif
2134 sys$dclexh(&exit_block);
2135 if (NULL == freopen(mbxname, "wb", stdout))
2136 {
740ce14c 2137 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
a0d0e21e
LW
2138 }
2139}
2140
2141static int background_process(int argc, char **argv)
2142{
2143char command[2048] = "$";
2144$DESCRIPTOR(value, "");
2145static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2146static $DESCRIPTOR(null, "NLA0:");
2147static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2148char pidstring[80];
2149$DESCRIPTOR(pidstr, "");
2150int pid;
748a9306 2151unsigned long int flags = 17, one = 1, retsts;
a0d0e21e
LW
2152
2153 strcat(command, argv[0]);
2154 while (--argc)
2155 {
2156 strcat(command, " \"");
2157 strcat(command, *(++argv));
2158 strcat(command, "\"");
2159 }
2160 value.dsc$a_pointer = command;
2161 value.dsc$w_length = strlen(value.dsc$a_pointer);
b7ae7a0d 2162 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
748a9306
LW
2163 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2164 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
b7ae7a0d 2165 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
748a9306
LW
2166 }
2167 else {
b7ae7a0d 2168 _ckvmssts_noperl(retsts);
748a9306 2169 }
a0d0e21e 2170#ifdef ARGPROC_DEBUG
740ce14c 2171 PerlIO_printf(Perl_debug_log, "%s\n", command);
a0d0e21e
LW
2172#endif
2173 sprintf(pidstring, "%08X", pid);
740ce14c 2174 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
a0d0e21e
LW
2175 pidstr.dsc$a_pointer = pidstring;
2176 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2177 lib$set_symbol(&pidsymbol, &pidstr);
2178 return(SS$_NORMAL);
2179}
2180/*}}}*/
2181/***** End of code taken from Mark Pizzolato's argproc.c package *****/
2182
a0d0e21e
LW
2183/* trim_unixpath()
2184 * Trim Unix-style prefix off filespec, so it looks like what a shell
2185 * glob expansion would return (i.e. from specified prefix on, not
2186 * full path). Note that returned filespec is Unix-style, regardless
2187 * of whether input filespec was VMS-style or Unix-style.
2188 *
a3e9d8c9 2189 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
f86702cc
PP
2190 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2191 * vector of options; at present, only bit 0 is used, and if set tells
2192 * trim unixpath to try the current default directory as a prefix when
2193 * presented with a possibly ambiguous ... wildcard.
a3e9d8c9
PP
2194 *
2195 * Returns !=0 on success, with trimmed filespec replacing contents of
2196 * fspec, and 0 on failure, with contents of fpsec unchanged.
a0d0e21e 2197 */
f86702cc 2198/*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
a0d0e21e 2199int
f86702cc 2200trim_unixpath(char *fspec, char *wildspec, int opts)
a0d0e21e 2201{
a3e9d8c9 2202 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
f86702cc
PP
2203 *template, *base, *end, *cp1, *cp2;
2204 register int tmplen, reslen = 0, dirs = 0;
a0d0e21e 2205
a3e9d8c9
PP
2206 if (!wildspec || !fspec) return 0;
2207 if (strpbrk(wildspec,"]>:") != NULL) {
2208 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
f86702cc 2209 else template = unixwild;
a3e9d8c9
PP
2210 }
2211 else template = wildspec;
a0d0e21e
LW
2212 if (strpbrk(fspec,"]>:") != NULL) {
2213 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2214 else base = unixified;
a3e9d8c9
PP
2215 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2216 * check to see that final result fits into (isn't longer than) fspec */
2217 reslen = strlen(fspec);
a0d0e21e
LW
2218 }
2219 else base = fspec;
a3e9d8c9
PP
2220
2221 /* No prefix or absolute path on wildcard, so nothing to remove */
2222 if (!*template || *template == '/') {
2223 if (base == fspec) return 1;
2224 tmplen = strlen(unixified);
2225 if (tmplen > reslen) return 0; /* not enough space */
2226 /* Copy unixified resultant, including trailing NUL */
2227 memmove(fspec,unixified,tmplen+1);
2228 return 1;
2229 }
a0d0e21e 2230
f86702cc
PP
2231 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2232 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
2233 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
2234 for (cp1 = end ;cp1 >= base; cp1--)
2235 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
2236 { cp1++; break; }
2237 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
a3e9d8c9
PP
2238 return 1;
2239 }
f86702cc
PP
2240 else {
2241 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
2242 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
2243 int ells = 1, totells, segdirs, match;
2244 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
2245 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2246
2247 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
2248 totells = ells;
2249 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
2250 if (ellipsis == template && opts & 1) {
2251 /* Template begins with an ellipsis. Since we can't tell how many
2252 * directory names at the front of the resultant to keep for an
2253 * arbitrary starting point, we arbitrarily choose the current
2254 * default directory as a starting point. If it's there as a prefix,
2255 * clip it off. If not, fall through and act as if the leading
2256 * ellipsis weren't there (i.e. return shortest possible path that
2257 * could match template).
2258 */
2259 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
2260 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2261 if (_tolower(*cp1) != _tolower(*cp2)) break;
2262 segdirs = dirs - totells; /* Min # of dirs we must have left */
2263 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
2264 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
2265 memcpy(fspec,cp2+1,end - cp2);
2266 return 1;
a3e9d8c9 2267 }
a3e9d8c9 2268 }
f86702cc
PP
2269 /* First off, back up over constant elements at end of path */
2270 if (dirs) {
2271 for (front = end ; front >= base; front--)
2272 if (*front == '/' && !dirs--) { front++; break; }
a3e9d8c9 2273 }
f86702cc
PP
2274 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcend + sizeof lcend;
2275 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
2276 if (cp1 != '\0') return 0; /* Path too long. */
2277 lcend = cp2;
2278 *cp2 = '\0'; /* Pick up with memcpy later */
2279 lcfront = lcres + (front - base);
2280 /* Now skip over each ellipsis and try to match the path in front of it. */
2281 while (ells--) {
2282 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
2283 if (*(cp1) == '.' && *(cp1+1) == '.' &&
2284 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
2285 if (cp1 < template) break; /* template started with an ellipsis */
2286 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
2287 ellipsis = cp1; continue;
2288 }
2289 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
2290 nextell = cp1;
2291 for (segdirs = 0, cp2 = tpl;
2292 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
2293 cp1++, cp2++) {
2294 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
2295 else *cp2 = _tolower(*cp1); /* else lowercase for match */
2296 if (*cp2 == '/') segdirs++;
2297 }
2298 if (cp1 != ellipsis - 1) return 0; /* Path too long */
2299 /* Back up at least as many dirs as in template before matching */
2300 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
2301 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
2302 for (match = 0; cp1 > lcres;) {
2303 resdsc.dsc$a_pointer = cp1;
2304 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
2305 match++;
2306 if (match == 1) lcfront = cp1;
2307 }
2308 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
2309 }
2310 if (!match) return 0; /* Can't find prefix ??? */
2311 if (match > 1 && opts & 1) {
2312 /* This ... wildcard could cover more than one set of dirs (i.e.
2313 * a set of similar dir names is repeated). If the template
2314 * contains more than 1 ..., upstream elements could resolve the
2315 * ambiguity, but it's not worth a full backtracking setup here.
2316 * As a quick heuristic, clip off the current default directory
2317 * if it's present to find the trimmed spec, else use the
2318 * shortest string that this ... could cover.
2319 */
2320 char def[NAM$C_MAXRSS+1], *st;
2321
2322 if (getcwd(def, sizeof def,0) == NULL) return 0;
2323 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2324 if (_tolower(*cp1) != _tolower(*cp2)) break;
2325 segdirs = dirs - totells; /* Min # of dirs we must have left */
2326 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
2327 if (*cp1 == '\0' && *cp2 == '/') {
2328 memcpy(fspec,cp2+1,end - cp2);
2329 return 1;
2330 }
2331 /* Nope -- stick with lcfront from above and keep going. */
2332 }
2333 }
2334 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
a3e9d8c9 2335 return 1;
f86702cc 2336 ellipsis = nextell;
a0d0e21e 2337 }
a0d0e21e
LW
2338
2339} /* end of trim_unixpath() */
2340/*}}}*/
2341
a0d0e21e
LW
2342
2343/*
2344 * VMS readdir() routines.
2345 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
a0d0e21e
LW
2346 *
2347 * 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu
2348 * Minor modifications to original routines.
2349 */
2350
2351 /* Number of elements in vms_versions array */
2352#define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
2353
2354/*
2355 * Open a directory, return a handle for later use.
2356 */
2357/*{{{ DIR *opendir(char*name) */
2358DIR *
2359opendir(char *name)
2360{
2361 DIR *dd;
2362 char dir[NAM$C_MAXRSS+1];
2363
2364 /* Get memory for the handle, and the pattern. */
2365 New(7006,dd,1,DIR);
2366 if (do_tovmspath(name,dir,0) == NULL) {
2367 Safefree((char *)dd);
2368 return(NULL);
2369 }
2370 New(7007,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
2371
2372 /* Fill in the fields; mainly playing with the descriptor. */
2373 (void)sprintf(dd->pattern, "%s*.*",dir);
2374 dd->context = 0;
2375 dd->count = 0;
2376 dd->vms_wantversions = 0;
2377 dd->pat.dsc$a_pointer = dd->pattern;
2378 dd->pat.dsc$w_length = strlen(dd->pattern);
2379 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
2380 dd->pat.dsc$b_class = DSC$K_CLASS_S;
2381
2382 return dd;
2383} /* end of opendir() */
2384/*}}}*/
2385
2386/*
2387 * Set the flag to indicate we want versions or not.
2388 */
2389/*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
2390void
2391vmsreaddirversions(DIR *dd, int flag)
2392{
2393 dd->vms_wantversions = flag;
2394}
2395/*}}}*/
2396
2397/*
2398 * Free up an opened directory.
2399 */
2400/*{{{ void closedir(DIR *dd)*/
2401void
2402closedir(DIR *dd)
2403{
2404 (void)lib$find_file_end(&dd->context);
2405 Safefree(dd->pattern);
2406 Safefree((char *)dd);
2407}
2408/*}}}*/
2409
2410/*
2411 * Collect all the version numbers for the current file.
2412 */
2413static void
2414collectversions(dd)
2415 DIR *dd;
2416{
2417 struct dsc$descriptor_s pat;
2418 struct dsc$descriptor_s res;
2419 struct dirent *e;
2420 char *p, *text, buff[sizeof dd->entry.d_name];
2421 int i;
2422 unsigned long context, tmpsts;
2423
2424 /* Convenient shorthand. */
2425 e = &dd->entry;
2426
2427 /* Add the version wildcard, ignoring the "*.*" put on before */
2428 i = strlen(dd->pattern);
2429 New(7008,text,i + e->d_namlen + 3,char);
2430 (void)strcpy(text, dd->pattern);
2431 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
2432
2433 /* Set up the pattern descriptor. */
2434 pat.dsc$a_pointer = text;
2435 pat.dsc$w_length = i + e->d_namlen - 1;
2436 pat.dsc$b_dtype = DSC$K_DTYPE_T;
2437 pat.dsc$b_class = DSC$K_CLASS_S;
2438
2439 /* Set up result descriptor. */
2440 res.dsc$a_pointer = buff;
2441 res.dsc$w_length = sizeof buff - 2;
2442 res.dsc$b_dtype = DSC$K_DTYPE_T;
2443 res.dsc$b_class = DSC$K_CLASS_S;
2444
2445 /* Read files, collecting versions. */
2446 for (context = 0, e->vms_verscount = 0;
2447 e->vms_verscount < VERSIZE(e);
2448 e->vms_verscount++) {
2449 tmpsts = lib$find_file(&pat, &res, &context);
2450 if (tmpsts == RMS$_NMF || context == 0) break;
748a9306 2451 _ckvmssts(tmpsts);
a0d0e21e 2452 buff[sizeof buff - 1] = '\0';
748a9306 2453 if ((p = strchr(buff, ';')))
a0d0e21e
LW
2454 e->vms_versions[e->vms_verscount] = atoi(p + 1);
2455 else
2456 e->vms_versions[e->vms_verscount] = -1;
2457 }
2458
748a9306 2459 _ckvmssts(lib$find_file_end(&context));
a0d0e21e
LW
2460 Safefree(text);
2461
2462} /* end of collectversions() */
2463
2464/*
2465 * Read the next entry from the directory.
2466 */
2467/*{{{ struct dirent *readdir(DIR *dd)*/
2468struct dirent *
2469readdir(DIR *dd)
2470{
2471 struct dsc$descriptor_s res;
2472 char *p, buff[sizeof dd->entry.d_name];
a0d0e21e
LW
2473 unsigned long int tmpsts;
2474
2475 /* Set up result descriptor, and get next file. */
2476 res.dsc$a_pointer = buff;
2477 res.dsc$w_length = sizeof buff - 2;
2478 res.dsc$b_dtype = DSC$K_DTYPE_T;
2479 res.dsc$b_class = DSC$K_CLASS_S;
a0d0e21e 2480 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4633a7c4
LW
2481 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
2482 if (!(tmpsts & 1)) {
2483 set_vaxc_errno(tmpsts);
2484 switch (tmpsts) {
2485 case RMS$_PRV:
c07a80fd 2486 set_errno(EACCES); break;
4633a7c4 2487 case RMS$_DEV:
c07a80fd 2488 set_errno(ENODEV); break;
4633a7c4 2489 case RMS$_DIR:
4633a7c4 2490 case RMS$_FNF:
c07a80fd 2491 set_errno(ENOENT); break;
4633a7c4
LW
2492 default:
2493 set_errno(EVMSERR);
2494 }
2495 return NULL;
2496 }
2497 dd->count++;
a0d0e21e
LW
2498 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
2499 buff[sizeof buff - 1] = '\0';
2500 for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
2501 *p = '\0';
2502
2503 /* Skip any directory component and just copy the name. */
748a9306 2504 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
a0d0e21e
LW
2505 else (void)strcpy(dd->entry.d_name, buff);
2506
2507 /* Clobber the version. */
748a9306 2508 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
a0d0e21e
LW
2509
2510 dd->entry.d_namlen = strlen(dd->entry.d_name);
2511 dd->entry.vms_verscount = 0;
2512 if (dd->vms_wantversions) collectversions(dd);
2513 return &dd->entry;
2514
2515} /* end of readdir() */
2516/*}}}*/
2517
2518/*
2519 * Return something that can be used in a seekdir later.
2520 */
2521/*{{{ long telldir(DIR *dd)*/
2522long
2523telldir(DIR *dd)
2524{
2525 return dd->count;
2526}
2527/*}}}*/
2528
2529/*
2530 * Return to a spot where we used to be. Brute force.
2531 */
2532/*{{{ void seekdir(DIR *dd,long count)*/
2533void
2534seekdir(DIR *dd, long count)
2535{
2536 int vms_wantversions;
a0d0e21e
LW
2537
2538 /* If we haven't done anything yet... */
2539 if (dd->count == 0)
2540 return;
2541
2542 /* Remember some state, and clear it. */
2543 vms_wantversions = dd->vms_wantversions;
2544 dd->vms_wantversions = 0;
748a9306 2545 _ckvmssts(lib$find_file_end(&dd->context));
a0d0e21e
LW
2546 dd->context = 0;
2547
2548 /* The increment is in readdir(). */
2549 for (dd->count = 0; dd->count < count; )
2550 (void)readdir(dd);
2551
2552 dd->vms_wantversions = vms_wantversions;
2553
2554} /* end of seekdir() */
2555/*}}}*/
2556
2557/* VMS subprocess management
2558 *
2559 * my_vfork() - just a vfork(), after setting a flag to record that
2560 * the current script is trying a Unix-style fork/exec.
2561 *
2562 * vms_do_aexec() and vms_do_exec() are called in response to the
2563 * perl 'exec' function. If this follows a vfork call, then they
2564 * call out the the regular perl routines in doio.c which do an
2565 * execvp (for those who really want to try this under VMS).
2566 * Otherwise, they do exactly what the perl docs say exec should
2567 * do - terminate the current script and invoke a new command
2568 * (See below for notes on command syntax.)
2569 *
2570 * do_aspawn() and do_spawn() implement the VMS side of the perl
2571 * 'system' function.
2572 *
2573 * Note on command arguments to perl 'exec' and 'system': When handled
2574 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2575 * are concatenated to form a DCL command string. If the first arg
2576 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2577 * the the command string is hrnded off to DCL directly. Otherwise,
2578 * the first token of the command is taken as the filespec of an image
2579 * to run. The filespec is expanded using a default type of '.EXE' and
2580 * the process defaults for device, directory, etc., and the resultant
2581 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2582 * the command string as parameters. This is perhaps a bit compicated,
2583 * but I hope it will form a happy medium between what VMS folks expect
2584 * from lib$spawn and what Unix folks expect from exec.
2585 */
2586
2587static int vfork_called;
2588
2589/*{{{int my_vfork()*/
2590int
2591my_vfork()
2592{
748a9306 2593 vfork_called++;
a0d0e21e
LW
2594 return vfork();
2595}
2596/*}}}*/
2597
4633a7c4
LW
2598
2599static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
2600
a0d0e21e 2601static void
4633a7c4
LW
2602vms_execfree() {
2603 if (Cmd) {
e518068a 2604 Safefree(Cmd);
4633a7c4
LW
2605 Cmd = Nullch;
2606 }
2607 if (VMScmd.dsc$a_pointer) {
2608 Safefree(VMScmd.dsc$a_pointer);
2609 VMScmd.dsc$w_length = 0;
2610 VMScmd.dsc$a_pointer = Nullch;
2611 }
2612}
2613
2614static char *
2615setup_argstr(SV *really, SV **mark, SV **sp)
a0d0e21e 2616{
4633a7c4 2617 char *junk, *tmps = Nullch;
a0d0e21e
LW
2618 register size_t cmdlen = 0;
2619 size_t rlen;
2620 register SV **idx;
2621
2622 idx = mark;
4633a7c4
LW
2623 if (really) {
2624 tmps = SvPV(really,rlen);
2625 if (*tmps) {
2626 cmdlen += rlen + 1;
2627 idx++;
2628 }
a0d0e21e
LW
2629 }
2630
2631 for (idx++; idx <= sp; idx++) {
2632 if (*idx) {
2633 junk = SvPVx(*idx,rlen);
2634 cmdlen += rlen ? rlen + 1 : 0;
2635 }
2636 }
e518068a 2637 New(401,Cmd,cmdlen+1,char);
a0d0e21e 2638
4633a7c4
LW
2639 if (tmps && *tmps) {
2640 strcpy(Cmd,tmps);
a0d0e21e
LW
2641 mark++;
2642 }
4633a7c4 2643 else *Cmd = '\0';
a0d0e21e
LW
2644 while (++mark <= sp) {
2645 if (*mark) {
4633a7c4
LW
2646 strcat(Cmd," ");
2647 strcat(Cmd,SvPVx(*mark,na));
a0d0e21e
LW
2648 }
2649 }
4633a7c4 2650 return Cmd;
a0d0e21e
LW
2651
2652} /* end of setup_argstr() */
2653
4633a7c4 2654
a0d0e21e 2655static unsigned long int
4633a7c4 2656setup_cmddsc(char *cmd, int check_img)
a0d0e21e
LW
2657{
2658 char resspec[NAM$C_MAXRSS+1];
2659 $DESCRIPTOR(defdsc,".EXE");
2660 $DESCRIPTOR(resdsc,resspec);
2661 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2662 unsigned long int cxt = 0, flags = 1, retsts;
2663 register char *s, *rest, *cp;
2664 register int isdcl = 0;
2665
2666 s = cmd;
2667 while (*s && isspace(*s)) s++;
2668 if (check_img) {
2669 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2670 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
2671 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2672 if (*cp == ':' || *cp == '[' || *cp == '<') {
2673 isdcl = 0;
2674 break;
2675 }
2676 }
2677 }
2678 }
2679 else isdcl = 1;
2680 if (isdcl) { /* It's a DCL command, just do it. */
4633a7c4 2681 VMScmd.dsc$w_length = strlen(cmd);
e518068a
PP
2682 if (cmd == Cmd) {
2683 VMScmd.dsc$a_pointer = Cmd;
2684 Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
2685 }
2686 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
a0d0e21e
LW
2687 }
2688 else { /* assume first token is an image spec */
2689 cmd = s;
2690 while (*s && !isspace(*s)) s++;
2691 rest = *s ? s : 0;
2692 imgdsc.dsc$a_pointer = cmd;
2693 imgdsc.dsc$w_length = s - cmd;
2694 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4633a7c4
LW
2695 if (!(retsts & 1)) {
2696 /* just hand off status values likely to be due to user error */
2697 if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
2698 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2699 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2700 else { _ckvmssts(retsts); }
2701 }
a0d0e21e 2702 else {
748a9306 2703 _ckvmssts(lib$find_file_end(&cxt));
a0d0e21e
LW
2704 s = resspec;
2705 while (*s && !isspace(*s)) s++;
2706 *s = '\0';
e518068a 2707 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
4633a7c4
LW
2708 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
2709 strcat(VMScmd.dsc$a_pointer,resspec);
2710 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
2711 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
a0d0e21e
LW
2712 }
2713 }
2714
a3e9d8c9
PP
2715 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : SS$_NORMAL);
2716
a0d0e21e
LW
2717} /* end of setup_cmddsc() */
2718
a3e9d8c9 2719
a0d0e21e
LW
2720/* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2721bool
2722vms_do_aexec(SV *really,SV **mark,SV **sp)
2723{
a0d0e21e
LW
2724 if (sp > mark) {
2725 if (vfork_called) { /* this follows a vfork - act Unixish */
748a9306
LW
2726 vfork_called--;
2727 if (vfork_called < 0) {
2728 warn("Internal inconsistency in tracking vforks");
2729 vfork_called = 0;
2730 }
2731 else return do_aexec(really,mark,sp);
a0d0e21e 2732 }
4633a7c4
LW
2733 /* no vfork - act VMSish */
2734 return vms_do_exec(setup_argstr(really,mark,sp));
748a9306 2735
a0d0e21e
LW
2736 }
2737
2738 return FALSE;
2739} /* end of vms_do_aexec() */
2740/*}}}*/
2741
2742/* {{{bool vms_do_exec(char *cmd) */
2743bool
2744vms_do_exec(char *cmd)
2745{
2746
2747 if (vfork_called) { /* this follows a vfork - act Unixish */
748a9306
LW
2748 vfork_called--;
2749 if (vfork_called < 0) {
2750 warn("Internal inconsistency in tracking vforks");
2751 vfork_called = 0;
2752 }
2753 else return do_exec(cmd);
a0d0e21e 2754 }
748a9306
LW
2755
2756 { /* no vfork - act VMSish */
748a9306 2757 unsigned long int retsts;
a0d0e21e 2758
1e422769
PP
2759 TAINT_ENV();
2760 TAINT_PROPER("exec");
4633a7c4
LW
2761 if ((retsts = setup_cmddsc(cmd,1)) & 1)
2762 retsts = lib$do_command(&VMScmd);
a0d0e21e 2763
748a9306
LW
2764 set_errno(EVMSERR);
2765 set_vaxc_errno(retsts);
a0d0e21e 2766 if (dowarn)
4633a7c4
LW
2767 warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
2768 vms_execfree();
a0d0e21e
LW
2769 }
2770
2771 return FALSE;
2772
2773} /* end of vms_do_exec() */
2774/*}}}*/
2775
2776unsigned long int do_spawn(char *);
2777
2778/* {{{ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) */
2779unsigned long int
2780do_aspawn(SV *really,SV **mark,SV **sp)
2781{
4633a7c4 2782 if (sp > mark) return do_spawn(setup_argstr(really,mark,sp));
a0d0e21e
LW
2783
2784 return SS$_ABORT;
2785} /* end of do_aspawn() */
2786/*}}}*/
2787
2788/* {{{unsigned long int do_spawn(char *cmd) */
2789unsigned long int
2790do_spawn(char *cmd)
2791{
4633a7c4 2792 unsigned long int substs, hadcmd = 1;
a0d0e21e 2793
1e422769
PP
2794 TAINT_ENV();
2795 TAINT_PROPER("spawn");
748a9306 2796 if (!cmd || !*cmd) {
4633a7c4
LW
2797 hadcmd = 0;
2798 _ckvmssts(lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0));
748a9306 2799 }
4633a7c4
LW
2800 else if ((substs = setup_cmddsc(cmd,0)) & 1) {
2801 _ckvmssts(lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0));
748a9306 2802 }
a0d0e21e
LW
2803
2804 if (!(substs&1)) {
748a9306
LW
2805 set_errno(EVMSERR);
2806 set_vaxc_errno(substs);
a0d0e21e 2807 if (dowarn)
a3e9d8c9 2808 warn("Can't spawn \"%s\": %s",
4633a7c4 2809 hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
a0d0e21e 2810 }
4633a7c4 2811 vms_execfree();
a0d0e21e
LW
2812 return substs;
2813
2814} /* end of do_spawn() */
2815/*}}}*/
2816
2817/*
2818 * A simple fwrite replacement which outputs itmsz*nitm chars without
2819 * introducing record boundaries every itmsz chars.
2820 */
2821/*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
2822int
2823my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
2824{
2825 register char *cp, *end;
2826
2827 end = (char *)src + itmsz * nitm;
2828
2829 while ((char *)src <= end) {
2830 for (cp = src; cp <= end; cp++) if (!*cp) break;
2831 if (fputs(src,dest) == EOF) return EOF;
2832 if (cp < end)
2833 if (fputc('\0',dest) == EOF) return EOF;
2834 src = cp + 1;
2835 }
2836
2837 return 1;
2838
2839} /* end of my_fwrite() */
2840/*}}}*/
2841
748a9306
LW
2842/*
2843 * Here are replacements for the following Unix routines in the VMS environment:
2844 * getpwuid Get information for a particular UIC or UID
2845 * getpwnam Get information for a named user
2846 * getpwent Get information for each user in the rights database
2847 * setpwent Reset search to the start of the rights database
2848 * endpwent Finish searching for users in the rights database
2849 *
2850 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
2851 * (defined in pwd.h), which contains the following fields:-
2852 * struct passwd {
2853 * char *pw_name; Username (in lower case)
2854 * char *pw_passwd; Hashed password
2855 * unsigned int pw_uid; UIC
2856 * unsigned int pw_gid; UIC group number
2857 * char *pw_unixdir; Default device/directory (VMS-style)
2858 * char *pw_gecos; Owner name
2859 * char *pw_dir; Default device/directory (Unix-style)
2860 * char *pw_shell; Default CLI name (eg. DCL)
2861 * };
2862 * If the specified user does not exist, getpwuid and getpwnam return NULL.
2863 *
2864 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
2865 * not the UIC member number (eg. what's returned by getuid()),
2866 * getpwuid() can accept either as input (if uid is specified, the caller's
2867 * UIC group is used), though it won't recognise gid=0.
2868 *
2869 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
2870 * information about other users in your group or in other groups, respectively.
2871 * If the required privilege is not available, then these routines fill only
2872 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
2873 * string).
2874 *
2875 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
2876 */
2877
2878/* sizes of various UAF record fields */
2879#define UAI$S_USERNAME 12
2880#define UAI$S_IDENT 31
2881#define UAI$S_OWNER 31
2882#define UAI$S_DEFDEV 31
2883#define UAI$S_DEFDIR 63
2884#define UAI$S_DEFCLI 31
2885#define UAI$S_PWD 8
2886
2887#define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
2888 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
2889 (uic).uic$v_group != UIC$K_WILD_GROUP)
2890
4633a7c4
LW
2891static char __empty[]= "";
2892static struct passwd __passwd_empty=
748a9306
LW
2893 {(char *) __empty, (char *) __empty, 0, 0,
2894 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
2895static int contxt= 0;
2896static struct passwd __pwdcache;
2897static char __pw_namecache[UAI$S_IDENT+1];
2898
748a9306
LW
2899/*
2900 * This routine does most of the work extracting the user information.
2901 */
2902static int fillpasswd (const char *name, struct passwd *pwd)
a0d0e21e 2903{
748a9306
LW
2904 static struct {
2905 unsigned char length;
2906 char pw_gecos[UAI$S_OWNER+1];
2907 } owner;
2908 static union uicdef uic;
2909 static struct {
2910 unsigned char length;
2911 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
2912 } defdev;
2913 static struct {
2914 unsigned char length;
2915 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
2916 } defdir;
2917 static struct {
2918 unsigned char length;
2919 char pw_shell[UAI$S_DEFCLI+1];
2920 } defcli;
2921 static char pw_passwd[UAI$S_PWD+1];
2922
2923 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
2924 struct dsc$descriptor_s name_desc;
c07a80fd 2925 unsigned long int sts;
748a9306 2926
4633a7c4 2927 static struct itmlst_3 itmlst[]= {
748a9306
LW
2928 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
2929 {sizeof(uic), UAI$_UIC, &uic, &luic},
2930 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
2931 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
2932 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
2933 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
2934 {0, 0, NULL, NULL}};
2935
2936 name_desc.dsc$w_length= strlen(name);
2937 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2938 name_desc.dsc$b_class= DSC$K_CLASS_S;
2939 name_desc.dsc$a_pointer= (char *) name;
2940
2941/* Note that sys$getuai returns many fields as counted strings. */
c07a80fd
PP
2942 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
2943 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
2944 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
2945 }
2946 else { _ckvmssts(sts); }
2947 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
748a9306
LW
2948
2949 if ((int) owner.length < lowner) lowner= (int) owner.length;
2950 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
2951 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
2952 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
2953 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
2954 owner.pw_gecos[lowner]= '\0';
2955 defdev.pw_dir[ldefdev+ldefdir]= '\0';
2956 defcli.pw_shell[ldefcli]= '\0';
2957 if (valid_uic(uic)) {
2958 pwd->pw_uid= uic.uic$l_uic;
2959 pwd->pw_gid= uic.uic$v_group;
2960 }
2961 else
2962 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
2963 pwd->pw_passwd= pw_passwd;
2964 pwd->pw_gecos= owner.pw_gecos;
2965 pwd->pw_dir= defdev.pw_dir;
2966 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
2967 pwd->pw_shell= defcli.pw_shell;
2968 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
2969 int ldir;
2970 ldir= strlen(pwd->pw_unixdir) - 1;
2971 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
2972 }
2973 else
2974 strcpy(pwd->pw_unixdir, pwd->pw_dir);
01b8edb6 2975 __mystrtolower(pwd->pw_unixdir);
c07a80fd 2976 return 1;
a0d0e21e 2977}
748a9306
LW
2978
2979/*
2980 * Get information for a named user.
2981*/
2982/*{{{struct passwd *getpwnam(char *name)*/
2983struct passwd *my_getpwnam(char *name)
2984{
2985 struct dsc$descriptor_s name_desc;
2986 union uicdef uic;
aa689395 2987 unsigned long int status, sts;
748a9306
LW
2988
2989 __pwdcache = __passwd_empty;
c07a80fd 2990 if (!fillpasswd(name, &__pwdcache)) {
748a9306
LW
2991 /* We still may be able to determine pw_uid and pw_gid */
2992 name_desc.dsc$w_length= strlen(name);
2993 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2994 name_desc.dsc$b_class= DSC$K_CLASS_S;
2995 name_desc.dsc$a_pointer= (char *) name;
aa689395 2996 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
748a9306
LW
2997 __pwdcache.pw_uid= uic.uic$l_uic;
2998 __pwdcache.pw_gid= uic.uic$v_group;
2999 }
c07a80fd 3000 else {
aa689395
PP
3001 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3002 set_vaxc_errno(sts);
3003 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
c07a80fd
PP
3004 return NULL;
3005 }
aa689395 3006 else { _ckvmssts(sts); }
c07a80fd 3007 }
748a9306 3008 }
748a9306
LW
3009 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3010 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3011 __pwdcache.pw_name= __pw_namecache;
3012 return &__pwdcache;
3013} /* end of my_getpwnam() */
a0d0e21e
LW
3014/*}}}*/
3015
748a9306
LW
3016/*
3017 * Get information for a particular UIC or UID.
3018 * Called by my_getpwent with uid=-1 to list all users.
3019*/
3020/*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3021struct passwd *my_getpwuid(Uid_t uid)
a0d0e21e 3022{
748a9306
LW
3023 const $DESCRIPTOR(name_desc,__pw_namecache);
3024 unsigned short lname;
3025 union uicdef uic;
3026 unsigned long int status;
3027
3028 if (uid == (unsigned int) -1) {
3029 do {
3030 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3031 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
c07a80fd
PP
3032 set_vaxc_errno(status);
3033 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
748a9306
LW
3034 my_endpwent();
3035 return NULL;
3036 }
3037 else { _ckvmssts(status); }
3038 } while (!valid_uic (uic));
3039 }
3040 else {
3041 uic.uic$l_uic= uid;
c07a80fd
PP
3042 if (!uic.uic$v_group)
3043 uic.uic$v_group= getgid();
748a9306
LW
3044 if (valid_uic(uic))
3045 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3046 else status = SS$_IVIDENT;
c07a80fd
PP
3047 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3048 status == RMS$_PRV) {
3049 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3050 return NULL;
3051 }
3052 else { _ckvmssts(status); }
748a9306
LW
3053 }
3054 __pw_namecache[lname]= '\0';
01b8edb6 3055 __mystrtolower(__pw_namecache);
748a9306
LW
3056
3057 __pwdcache = __passwd_empty;
3058 __pwdcache.pw_name = __pw_namecache;
3059
3060/* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3061 The identifier's value is usually the UIC, but it doesn't have to be,
3062 so if we can, we let fillpasswd update this. */
3063 __pwdcache.pw_uid = uic.uic$l_uic;
3064 __pwdcache.pw_gid = uic.uic$v_group;
3065
c07a80fd 3066 fillpasswd(__pw_namecache, &__pwdcache);
748a9306 3067 return &__pwdcache;
a0d0e21e 3068
748a9306
LW
3069} /* end of my_getpwuid() */
3070/*}}}*/
3071
3072/*
3073 * Get information for next user.
3074*/
3075/*{{{struct passwd *my_getpwent()*/
3076struct passwd *my_getpwent()
3077{
3078 return (my_getpwuid((unsigned int) -1));
3079}
3080/*}}}*/
a0d0e21e 3081
748a9306
LW
3082/*
3083 * Finish searching rights database for users.
3084*/
3085/*{{{void my_endpwent()*/
3086void my_endpwent()
3087{
3088 if (contxt) {
3089 _ckvmssts(sys$finish_rdb(&contxt));
3090 contxt= 0;
3091 }
a0d0e21e
LW
3092}
3093/*}}}*/
748a9306 3094
e518068a 3095
ff0cee69
PP
3096/* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
3097 * my_utime(), and flex_stat(), all of which operate on UTC unless
3098 * VMSISH_TIMES is true.
3099 */
3100/* method used to handle UTC conversions:
3101 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
e518068a 3102 */
ff0cee69
PP
3103static int gmtime_emulation_type;
3104/* number of secs to add to UTC POSIX-style time to get local time */
3105static long int utc_offset_secs;
e518068a 3106
ff0cee69
PP
3107/* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
3108 * in vmsish.h. #undef them here so we can call the CRTL routines
3109 * directly.
e518068a
PP
3110 */
3111#undef gmtime
ff0cee69
PP
3112#undef localtime
3113#undef time
3114
3115/* my_time(), my_localtime(), my_gmtime()
3116 * By default traffic in UTC time values, suing CRTL gmtime() or
3117 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
3118 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
3119 * Modified by Charles Bailey <bailey@genetics.upenn.edu>
3120 */
3121
3122/*{{{time_t my_time(time_t *timep)*/
3123time_t my_time(time_t *timep)
e518068a 3124{
e518068a
PP
3125 time_t when;
3126
3127 if (gmtime_emulation_type == 0) {
ff0cee69
PP
3128 struct tm *tm_p;
3129 time_t base = 15 * 86400; /* 15jan71; to avoid month ends */
3130
e518068a 3131 gmtime_emulation_type++;
ff0cee69
PP
3132 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
3133 char *off;
3134
e518068a 3135 gmtime_emulation_type++;
ff0cee69 3136 if ((off = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL) {
e518068a 3137 gmtime_emulation_type++;
ff0cee69
PP
3138 warn("no UTC offset information; assuming local time is UTC");
3139 }
3140 else { utc_offset_secs = atol(off); }
e518068a 3141 }
ff0cee69
PP
3142 else { /* We've got a working gmtime() */
3143 struct tm gmt, local;
e518068a 3144
ff0cee69
PP
3145 gmt = *tm_p;
3146 tm_p = localtime(&base);
3147 local = *tm_p;
3148 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
3149 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
3150 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
3151 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
3152 }
e518068a 3153 }
ff0cee69
PP
3154
3155 when = time(NULL);
3156 if (
3157# ifdef VMSISH_TIME
3158 !VMSISH_TIME &&
3159# endif
3160 when != -1) when -= utc_offset_secs;
3161 if (timep != NULL) *timep = when;
3162 return when;
3163
3164} /* end of my_time() */
3165/*}}}*/
3166
3167
3168/*{{{struct tm *my_gmtime(const time_t *timep)*/
3169struct tm *
3170my_gmtime(const time_t *timep)
3171{
3172 char *p;
3173 time_t when;
3174
68dc0745
PP
3175 if (timep == NULL) {
3176 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3177 return NULL;
3178 }
3179 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
ff0cee69
PP
3180 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
3181
3182 when = *timep;
3183# ifdef VMSISH_TIME
3184 if (VMSISH_TIME) when -= utc_offset_secs; /* Input was local time */
3185# endif
3186 /* CRTL localtime() wants local time as input, so does no tz correction */
3187 return localtime(&when);
3188
e518068a 3189} /* end of my_gmtime() */
e518068a
PP
3190/*}}}*/
3191
3192
ff0cee69
PP
3193/*{{{struct tm *my_localtime(const time_t *timep)*/
3194struct tm *
3195my_localtime(const time_t *timep)
3196{
3197 time_t when;
3198
68dc0745
PP
3199 if (timep == NULL) {
3200 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3201 return NULL;
3202 }
3203 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
ff0cee69
PP
3204 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
3205
3206 when = *timep;
3207# ifdef VMSISH_TIME
3208 if (!VMSISH_TIME) when += utc_offset_secs; /* Input was UTC */
3209# endif
3210 /* CRTL localtime() wants local time as input, so does no tz correction */
3211 return localtime(&when);
3212
3213} /* end of my_localtime() */
3214/*}}}*/
3215
3216/* Reset definitions for later calls */
3217#define gmtime(t) my_gmtime(t)
3218#define localtime(t) my_localtime(t)
3219#define time(t) my_time(t)
3220
3221
3222/* my_utime - update modification time of a file
3223 * calling sequence is identical to POSIX utime(), but under
3224 * VMS only the modification time is changed; ODS-2 does not
3225 * maintain access times. Restrictions differ from the POSIX
3226 * definition in that the time can be changed as long as the
3227 * caller has permission to execute the necessary IO$_MODIFY $QIO;
3228 * no separate checks are made to insure that the caller is the
3229 * owner of the file or has special privs enabled.
3230 * Code here is based on Joe Meadows' FILE utility.
3231 */
3232
3233/* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
3234 * to VMS epoch (01-JAN-1858 00:00:00.00)
3235 * in 100 ns intervals.
3236 */
3237static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
3238
3239/*{{{int my_utime(char *path, struct utimbuf *utimes)*/
3240int my_utime(char *file, struct utimbuf *utimes)
3241{
3242 register int i;
3243 long int bintime[2], len = 2, lowbit, unixtime,
3244 secscale = 10000000; /* seconds --> 100 ns intervals */
3245 unsigned long int chan, iosb[2], retsts;
3246 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
3247 struct FAB myfab = cc$rms_fab;
3248 struct NAM mynam = cc$rms_nam;
3249#if defined (__DECC) && defined (__VAX)
3250 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
3251 * at least through VMS V6.1, which causes a type-conversion warning.
3252 */
3253# pragma message save
3254# pragma message disable cvtdiftypes
3255#endif
3256 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
3257 struct fibdef myfib;
3258#if defined (__DECC) && defined (__VAX)
3259 /* This should be right after the declaration of myatr, but due
3260 * to a bug in VAX DEC C, this takes effect a statement early.
3261 */
3262# pragma message restore
3263#endif
3264 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
3265 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
3266 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
3267
3268 if (file == NULL || *file == '\0') {
3269 set_errno(ENOENT);
3270 set_vaxc_errno(LIB$_INVARG);
3271 return -1;
3272 }
3273 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
3274
3275 if (utimes != NULL) {
3276 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
3277 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
3278 * Since time_t is unsigned long int, and lib$emul takes a signed long int
3279 * as input, we force the sign bit to be clear by shifting unixtime right
3280 * one bit, then multiplying by an extra factor of 2 in lib$emul().
3281 */
3282 lowbit = (utimes->modtime & 1) ? secscale : 0;
3283 unixtime = (long int) utimes->modtime;
3284# ifdef VMSISH_TIME
3285 if (!VMSISH_TIME) { /* Input was UTC; convert to local for sys svc */
3286 if (!gmtime_emulation_type) (void) time(NULL); /* Initialize UTC */
3287 unixtime += utc_offset_secs;
3288 }
3289# endif
3290 unixtime >> 1; secscale << 1;
3291 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
3292 if (!(retsts & 1)) {
3293 set_errno(EVMSERR);
3294 set_vaxc_errno(retsts);
3295 return -1;
3296 }
3297 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
3298 if (!(retsts & 1)) {
3299 set_errno(EVMSERR);
3300 set_vaxc_errno(retsts);
3301 return -1;
3302 }
3303 }
3304 else {
3305 /* Just get the current time in VMS format directly */
3306 retsts = sys$gettim(bintime);
3307 if (!(retsts & 1)) {
3308 set_errno(EVMSERR);
3309 set_vaxc_errno(retsts);
3310 return -1;
3311 }
3312 }
3313
3314 myfab.fab$l_fna = vmsspec;
3315 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
3316 myfab.fab$l_nam = &mynam;
3317 mynam.nam$l_esa = esa;
3318 mynam.nam$b_ess = (unsigned char) sizeof esa;
3319 mynam.nam$l_rsa = rsa;
3320 mynam.nam$b_rss = (unsigned char) sizeof rsa;
3321
3322 /* Look for the file to be affected, letting RMS parse the file
3323 * specification for us as well. I have set errno using only
3324 * values documented in the utime() man page for VMS POSIX.
3325 */
3326 retsts = sys$parse(&myfab,0,0);
3327 if (!(retsts & 1)) {
3328 set_vaxc_errno(retsts);
3329 if (retsts == RMS$_PRV) set_errno(EACCES);
3330 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3331 else set_errno(EVMSERR);
3332 return -1;
3333 }
3334 retsts = sys$search(&myfab,0,0);
3335 if (!(retsts & 1)) {
3336 set_vaxc_errno(retsts);
3337 if (retsts == RMS$_PRV) set_errno(EACCES);
3338 else if (retsts == RMS$_FNF) set_errno(ENOENT);
3339 else set_errno(EVMSERR);
3340 return -1;
3341 }
3342
3343 devdsc.dsc$w_length = mynam.nam$b_dev;
3344 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
3345
3346 retsts = sys$assign(&devdsc,&chan,0,0);
3347 if (!(retsts & 1)) {
3348 set_vaxc_errno(retsts);
3349 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
3350 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
3351 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
3352 else set_errno(EVMSERR);
3353 return -1;
3354 }
3355
3356 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
3357 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
3358
3359 memset((void *) &myfib, 0, sizeof myfib);
3360#ifdef __DECC
3361 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
3362 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
3363 /* This prevents the revision time of the file being reset to the current
3364 * time as a result of our IO$_MODIFY $QIO. */
3365 myfib.fib$l_acctl = FIB$M_NORECORD;
3366#else
3367 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
3368 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
3369 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
3370#endif
3371 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
3372 _ckvmssts(sys$dassgn(chan));
3373 if (retsts & 1) retsts = iosb[0];
3374 if (!(retsts & 1)) {
3375 set_vaxc_errno(retsts);
3376 if (retsts == SS$_NOPRIV) set_errno(EACCES);
3377 else set_errno(EVMSERR);
3378 return -1;
3379 }
3380
3381 return 0;
3382} /* end of my_utime() */
3383/*}}}*/
3384
748a9306
LW
3385/*
3386 * flex_stat, flex_fstat
3387 * basic stat, but gets it right when asked to stat
3388 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
3389 */
3390
3391/* encode_dev packs a VMS device name string into an integer to allow
3392 * simple comparisons. This can be used, for example, to check whether two
3393 * files are located on the same device, by comparing their encoded device
3394 * names. Even a string comparison would not do, because stat() reuses the
3395 * device name buffer for each call; so without encode_dev, it would be
3396 * necessary to save the buffer and use strcmp (this would mean a number of
3397 * changes to the standard Perl code, to say nothing of what a Perl script
3398 * would have to do.
3399 *
3400 * The device lock id, if it exists, should be unique (unless perhaps compared
3401 * with lock ids transferred from other nodes). We have a lock id if the disk is
3402 * mounted cluster-wide, which is when we tend to get long (host-qualified)
3403 * device names. Thus we use the lock id in preference, and only if that isn't
3404 * available, do we try to pack the device name into an integer (flagged by
3405 * the sign bit (LOCKID_MASK) being set).
3406 *
e518068a 3407 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
748a9306
LW
3408 * name and its encoded form, but it seems very unlikely that we will find
3409 * two files on different disks that share the same encoded device names,
3410 * and even more remote that they will share the same file id (if the test
3411 * is to check for the same file).
3412 *
3413 * A better method might be to use sys$device_scan on the first call, and to
3414 * search for the device, returning an index into the cached array.
3415 * The number returned would be more intelligable.
3416 * This is probably not worth it, and anyway would take quite a bit longer
3417 * on the first call.
3418 */
3419#define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
aa689395 3420static mydev_t encode_dev (const char *dev)
748a9306
LW
3421{
3422 int i;
3423 unsigned long int f;
aa689395 3424 mydev_t enc;
748a9306
LW
3425 char c;
3426 const char *q;
3427
3428 if (!dev || !dev[0]) return 0;
3429
3430#if LOCKID_MASK
3431 {
3432 struct dsc$descriptor_s dev_desc;
3433 unsigned long int status, lockid, item = DVI$_LOCKID;
3434
3435 /* For cluster-mounted disks, the disk lock identifier is unique, so we
3436 can try that first. */
3437 dev_desc.dsc$w_length = strlen (dev);
3438 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
3439 dev_desc.dsc$b_class = DSC$K_CLASS_S;
3440 dev_desc.dsc$a_pointer = (char *) dev;
3441 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
3442 if (lockid) return (lockid & ~LOCKID_MASK);
3443 }
a0d0e21e 3444#endif
748a9306
LW
3445
3446 /* Otherwise we try to encode the device name */
3447 enc = 0;
3448 f = 1;
3449 i = 0;
3450 for (q = dev + strlen(dev); q--; q >= dev) {
3451 if (isdigit (*q))
3452 c= (*q) - '0';
3453 else if (isalpha (toupper (*q)))
3454 c= toupper (*q) - 'A' + (char)10;
3455 else
3456 continue; /* Skip '$'s */
3457 i++;
3458 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
3459 if (i>1) f *= 36;
3460 enc += f * (unsigned long int) c;
3461 }
3462 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
3463
3464} /* end of encode_dev() */
3465
3466static char namecache[NAM$C_MAXRSS+1];
3467
3468static int
3469is_null_device(name)
3470 const char *name;
3471{
3472 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
3473 The underscore prefix, controller letter, and unit number are
3474 independently optional; for our purposes, the colon punctuation
3475 is not. The colon can be trailed by optional directory and/or
3476 filename, but two consecutive colons indicates a nodename rather
3477 than a device. [pr] */
3478 if (*name == '_') ++name;
3479 if (tolower(*name++) != 'n') return 0;
3480 if (tolower(*name++) != 'l') return 0;
3481 if (tolower(*name) == 'a') ++name;
3482 if (*name == '0') ++name;
3483 return (*name++ == ':') && (*name != ':');
3484}
3485
3486/* Do the permissions allow some operation? Assumes statcache already set. */
3487/* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
aa689395
PP
3488 * subset of the applicable information. (We have to stick with struct
3489 * stat instead of struct mystat in the prototype since we have to match
3490 * the one in proto.h.)
748a9306
LW
3491 */
3492/*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
3493I32
3494cando(I32 bit, I32 effective, struct stat *statbufp)
3495{
aa689395 3496 if (statbufp == &statcache) return cando_by_name(bit,effective,namecache);
748a9306
LW
3497 else {
3498 char fname[NAM$C_MAXRSS+1];
3499 unsigned long int retsts;
3500 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3501 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3502
3503 /* If the struct mystat is stale, we're OOL; stat() overwrites the
3504 device name on successive calls */
aa689395
PP
3505 devdsc.dsc$a_pointer = ((struct mystat *)statbufp)->st_devnam;
3506 devdsc.dsc$w_length = strlen(((struct mystat *)statbufp)->st_devnam);
748a9306
LW
3507 namdsc.dsc$a_pointer = fname;
3508 namdsc.dsc$w_length = sizeof fname - 1;
3509
aa689395
PP
3510 retsts = lib$fid_to_name(&devdsc,&(((struct mystat *)statbufp)->st_ino),
3511 &namdsc,&namdsc.dsc$w_length,0,0);
748a9306
LW
3512 if (retsts & 1) {
3513 fname[namdsc.dsc$w_length] = '\0';
3514 return cando_by_name(bit,effective,fname);
3515 }
3516 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
3517 warn("Can't get filespec - stale stat buffer?\n");
3518 return FALSE;
3519 }
3520 _ckvmssts(retsts);
3521 return FALSE; /* Should never get to here */
3522 }
e518068a 3523} /* end of cando() */
748a9306
LW
3524/*}}}*/
3525
c07a80fd 3526
748a9306
LW
3527/*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
3528I32
3529cando_by_name(I32 bit, I32 effective, char *fname)
3530{
3531 static char usrname[L_cuserid];
3532 static struct dsc$descriptor_s usrdsc =
3533 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
a5f75d66 3534 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
748a9306
LW
3535 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
3536 unsigned short int retlen;
3537 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3538 union prvdef curprv;
3539 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
3540 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
3541 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
3542 {0,0,0,0}};
3543
3544 if (!fname || !*fname) return FALSE;
01b8edb6
PP
3545 /* Make sure we expand logical names, since sys$check_access doesn't */
3546 if (!strpbrk(fname,"/]>:")) {
3547 strcpy(fileified,fname);
3548 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
3549 fname = fileified;
3550 }
a5f75d66
AD
3551 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
3552 retlen = namdsc.dsc$w_length = strlen(vmsname);
3553 namdsc.dsc$a_pointer = vmsname;
3554 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
3555 vmsname[retlen-1] == ':') {
3556 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
3557 namdsc.dsc$w_length = strlen(fileified);
3558 namdsc.dsc$a_pointer = fileified;
3559 }
3560
748a9306
LW
3561 if (!usrdsc.dsc$w_length) {
3562 cuserid(usrname);
3563 usrdsc.dsc$w_length = strlen(usrname);
3564 }
a5f75d66 3565
748a9306
LW
3566 switch (bit) {
3567 case S_IXUSR:
3568 case S_IXGRP:
3569 case S_IXOTH:
3570 access = ARM$M_EXECUTE;
3571 break;
3572 case S_IRUSR:
3573 case S_IRGRP:
3574 case S_IROTH:
3575 access = ARM$M_READ;
3576 break;
3577 case S_IWUSR:
3578 case S_IWGRP:
3579 case S_IWOTH:
3580 access = ARM$M_WRITE;
3581 break;
3582 case S_IDUSR:
3583 case S_IDGRP:
3584 case S_IDOTH:
3585 access = ARM$M_DELETE;
3586 break;
3587 default:
3588 return FALSE;
3589 }
3590
3591 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
bbce6d69
PP
3592 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
3593 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF ||
3594 retsts == RMS$_DIR || retsts == RMS$_DEV) {
3595 set_vaxc_errno(retsts);
3596 if (retsts == SS$_NOPRIV) set_errno(EACCES);
3597 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
3598 else set_errno(ENOENT);
a3e9d8c9
PP
3599 return FALSE;
3600 }
748a9306
LW
3601 if (retsts == SS$_NORMAL) {
3602 if (!privused) return TRUE;
3603 /* We can get access, but only by using privs. Do we have the
3604 necessary privs currently enabled? */
3605 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
3606 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
c07a80fd
PP
3607 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
3608 !curprv.prv$v_bypass) return FALSE;
3609 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
3610 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
748a9306
LW
3611 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
3612 return TRUE;
3613 }
3614 _ckvmssts(retsts);
3615
3616 return FALSE; /* Should never get here */
3617
3618} /* end of cando_by_name() */
3619/*}}}*/
3620
3621
aa689395 3622/*{{{ int flex_fstat(int fd, struct mystat *statbuf)*/
748a9306 3623int
b7ae7a0d 3624flex_fstat(int fd, struct mystat *statbufp)
748a9306 3625{
b7ae7a0d 3626 if (!fstat(fd,(stat_t *) statbufp)) {
aa689395 3627 if (statbufp == (struct mystat *) &statcache) *namecache == '\0';
b7ae7a0d 3628 statbufp->st_dev = encode_dev(statbufp->st_devnam);
ff0cee69
PP
3629# ifdef VMSISH_TIME
3630 if (!VMSISH_TIME) { /* Return UTC instead of local time */
3631# else
3632 if (1) {
3633# endif
3634 if (!gmtime_emulation_type) (void)time(NULL);
3635 statbufp->st_mtime -= utc_offset_secs;
3636 statbufp->st_atime -= utc_offset_secs;
3637 statbufp->st_ctime -= utc_offset_secs;
3638 }
b7ae7a0d
PP
3639 return 0;
3640 }
3641 return -1;
748a9306
LW
3642
3643} /* end of flex_fstat() */
3644/*}}}*/
3645
aa689395 3646/*{{{ int flex_stat(char *fspec, struct mystat *statbufp)*/
748a9306 3647int
e518068a 3648flex_stat(char *fspec, struct mystat *statbufp)
748a9306
LW
3649{
3650 char fileified[NAM$C_MAXRSS+1];
bbce6d69 3651 int retval = -1;
748a9306 3652
aa689395
PP
3653 if (statbufp == (struct mystat *) &statcache)
3654 do_tovmsspec(fspec,namecache,0);
748a9306
LW
3655 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
3656 memset(statbufp,0,sizeof *statbufp);
3657 statbufp->st_dev = encode_dev("_NLA0:");
3658 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
3659 statbufp->st_uid = 0x00010001;
3660 statbufp->st_gid = 0x0001;
3661 time((time_t *)&statbufp->st_mtime);
3662 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
3663 return 0;
3664 }
3665
bbce6d69
PP
3666 /* Try for a directory name first. If fspec contains a filename without
3667 * a type (e.g. sea:[dark.dark]water), and both sea:[wine.dark]water.dir
3668 * and sea:[wine.dark]water. exist, we prefer the directory here.
3669 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
3670 * not sea:[wine.dark]., if the latter exists. If the intended target is
3671 * the file with null type, specify this by calling flex_stat() with
3672 * a '.' at the end of fspec.
3673 */
3674 if (do_fileify_dirspec(fspec,fileified,0) != NULL) {
3675 retval = stat(fileified,(stat_t *) statbufp);
aa689395
PP
3676 if (!retval && statbufp == (struct mystat *) &statcache)
3677 strcpy(namecache,fileified);
748a9306 3678 }
bbce6d69 3679 if (retval) retval = stat(fspec,(stat_t *) statbufp);
ff0cee69
PP
3680 if (!retval) {
3681 statbufp->st_dev = encode_dev(statbufp->st_devnam);
3682# ifdef VMSISH_TIME
3683 if (!VMSISH_TIME) { /* Return UTC instead of local time */
3684# else
3685 if (1) {
3686# endif
3687 if (!gmtime_emulation_type) (void)time(NULL);
3688 statbufp->st_mtime -= utc_offset_secs;
3689 statbufp->st_atime -= utc_offset_secs;
3690 statbufp->st_ctime -= utc_offset_secs;
3691 }
3692 }
748a9306
LW
3693 return retval;
3694
3695} /* end of flex_stat() */
3696/*}}}*/
3697
b7ae7a0d
PP
3698/* Insures that no carriage-control translation will be done on a file. */
3699/*{{{FILE *my_binmode(FILE *fp, char iotype)*/
3700FILE *
3701my_binmode(FILE *fp, char iotype)
3702{
3703 char filespec[NAM$C_MAXRSS], *acmode;
3704 fpos_t pos;
3705
3706 if (!fgetname(fp,filespec)) return NULL;
71be2cbc 3707 if (iotype != '-' && fgetpos(fp,&pos) == -1) return NULL;
b7ae7a0d
PP
3708 switch (iotype) {
3709 case '<': case 'r': acmode = "rb"; break;
71be2cbc
PP
3710 case '>': case 'w':
3711 /* use 'a' instead of 'w' to avoid creating new file;
3712 fsetpos below will take care of restoring file position */
b7ae7a0d 3713 case 'a': acmode = "ab"; break;
71be2cbc
PP
3714 case '+': case '|': case 's': acmode = "rb+"; break;
3715 case '-': acmode = fileno(fp) ? "ab" : "rb"; break;
3716 default:
3717 warn("Unrecognized iotype %c in my_binmode",iotype);
3718 acmode = "rb+";
b7ae7a0d
PP
3719 }
3720 if (freopen(filespec,acmode,fp) == NULL) return NULL;
71be2cbc
PP
3721 if (iotype != '-' && fsetpos(fp,&pos) == -1) return NULL;
3722 return fp;
b7ae7a0d
PP
3723} /* end of my_binmode() */
3724/*}}}*/
3725
3726
c07a80fd
PP
3727/*{{{char *my_getlogin()*/
3728/* VMS cuserid == Unix getlogin, except calling sequence */
3729char *
3730my_getlogin()
3731{
3732 static char user[L_cuserid];
3733 return cuserid(user);
3734}
3735/*}}}*/
3736
3737
a5f75d66
AD
3738/* rmscopy - copy a file using VMS RMS routines
3739 *
3740 * Copies contents and attributes of spec_in to spec_out, except owner
3741 * and protection information. Name and type of spec_in are used as
a3e9d8c9
PP
3742 * defaults for spec_out. The third parameter specifies whether rmscopy()
3743 * should try to propagate timestamps from the input file to the output file.
3744 * If it is less than 0, no timestamps are preserved. If it is 0, then
3745 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
3746 * propagated to the output file at creation iff the output file specification
3747 * did not contain an explicit name or type, and the revision date is always
3748 * updated at the end of the copy operation. If it is greater than 0, then
3749 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
3750 * other than the revision date should be propagated, and bit 1 indicates
3751 * that the revision date should be propagated.
3752 *
3753 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
a5f75d66
AD
3754 *
3755 * Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>.
3756 * Incorporates, with permission, some code from EZCOPY by Tim Adye
01b8edb6
PP
3757 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
3758 * as part of the Perl standard distribution under the terms of the
3759 * GNU General Public License or the Perl Artistic License. Copies
3760 * of each may be found in the Perl standard distribution.
a5f75d66 3761 */
a3e9d8c9 3762/*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
a5f75d66 3763int
a3e9d8c9 3764rmscopy(char *spec_in, char *spec_out, int preserve_dates)
a5f75d66
AD
3765{
3766 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
3767 rsa[NAM$C_MAXRSS], ubf[32256];
3768 unsigned long int i, sts, sts2;
3769 struct FAB fab_in, fab_out;
3770 struct RAB rab_in, rab_out;
3771 struct NAM nam;
3772 struct XABDAT xabdat;
3773 struct XABFHC xabfhc;
3774 struct XABRDT xabrdt;
3775 struct XABSUM xabsum;
3776
3777 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
3778 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
3779 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3780 return 0;
3781 }
3782
3783 fab_in = cc$rms_fab;
3784 fab_in.fab$l_fna = vmsin;
3785 fab_in.fab$b_fns = strlen(vmsin);
3786 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
3787 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
3788 fab_in.fab$l_fop = FAB$M_SQO;
3789 fab_in.fab$l_nam = &nam;
a3e9d8c9 3790 fab_in.fab$l_xab = (void *) &xabdat;
a5f75d66
AD
3791
3792 nam = cc$rms_nam;
3793 nam.nam$l_rsa = rsa;
3794 nam.nam$b_rss = sizeof(rsa);
3795 nam.nam$l_esa = esa;
3796 nam.nam$b_ess = sizeof (esa);
3797 nam.nam$b_esl = nam.nam$b_rsl = 0;
3798
3799 xabdat = cc$rms_xabdat; /* To get creation date */
a3e9d8c9 3800 xabdat.xab$l_nxt = (void *) &xabfhc;
a5f75d66
AD
3801
3802 xabfhc = cc$rms_xabfhc; /* To get record length */
a3e9d8c9 3803 xabfhc.xab$l_nxt = (void *) &xabsum;
a5f75d66
AD
3804
3805 xabsum = cc$rms_xabsum; /* To get key and area information */
3806
3807 if (!((sts = sys$open(&fab_in)) & 1)) {
3808 set_vaxc_errno(sts);
3809 switch (sts) {
3810 case RMS$_FNF:
3811 case RMS$_DIR:
3812 set_errno(ENOENT); break;
3813 case RMS$_DEV:
3814 set_errno(ENODEV); break;
3815 case RMS$_SYN:
3816 set_errno(EINVAL); break;
3817 case RMS$_PRV:
3818 set_errno(EACCES); break;
3819 default:
3820 set_errno(EVMSERR);
3821 }
3822 return 0;
3823 }
3824
3825 fab_out = fab_in;
3826 fab_out.fab$w_ifi = 0;
3827 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
3828 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
3829 fab_out.fab$l_fop = FAB$M_SQO;
3830 fab_out.fab$l_fna = vmsout;
3831 fab_out.fab$b_fns = strlen(vmsout);
3832 fab_out.fab$l_dna = nam.nam$l_name;
3833 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
a3e9d8c9
PP
3834
3835 if (preserve_dates == 0) { /* Act like DCL COPY */
3836 nam.nam$b_nop = NAM$M_SYNCHK;
3837 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
3838 if (!((sts = sys$parse(&fab_out)) & 1)) {
3839 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
3840 set_vaxc_errno(sts);
3841 return 0;
3842 }
3843 fab_out.fab$l_xab = (void *) &xabdat;
3844 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
3845 }
3846 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
3847 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
3848 preserve_dates =0; /* bitmask from this point forward */
3849
3850 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
a5f75d66
AD
3851 if (!((sts = sys$create(&fab_out)) & 1)) {
3852 set_vaxc_errno(sts);
3853 switch (sts) {
3854 case RMS$_DIR:
3855 set_errno(ENOENT); break;
3856 case RMS$_DEV:
3857 set_errno(ENODEV); break;
3858 case RMS$_SYN:
3859 set_errno(EINVAL); break;
3860 case RMS$_PRV:
3861 set_errno(EACCES); break;
3862 default:
3863 set_errno(EVMSERR);
3864 }
3865 return 0;
3866 }
3867 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
a3e9d8c9
PP
3868 if (preserve_dates & 2) {
3869 /* sys$close() will process xabrdt, not xabdat */
3870 xabrdt = cc$rms_xabrdt;
b7ae7a0d 3871#ifndef __GNUC__
a3e9d8c9 3872 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
b7ae7a0d
PP
3873#else
3874 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
3875 * is unsigned long[2], while DECC & VAXC use a struct */
3876 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
3877#endif
a3e9d8c9
PP
3878 fab_out.fab$l_xab = (void *) &xabrdt;
3879 }
a5f75d66
AD
3880
3881 rab_in = cc$rms_rab;
3882 rab_in.rab$l_fab = &fab_in;
3883 rab_in.rab$l_rop = RAB$M_BIO;
3884 rab_in.rab$l_ubf = ubf;
3885 rab_in.rab$w_usz = sizeof ubf;
3886 if (!((sts = sys$connect(&rab_in)) & 1)) {
3887 sys$close(&fab_in); sys$close(&fab_out);
3888 set_errno(EVMSERR); set_vaxc_errno(sts);
3889 return 0;
3890 }
3891
3892 rab_out = cc$rms_rab;
3893 rab_out.rab$l_fab = &fab_out;
3894 rab_out.rab$l_rbf = ubf;
3895 if (!((sts = sys$connect(&rab_out)) & 1)) {
3896 sys$close(&fab_in); sys$close(&fab_out);
3897 set_errno(EVMSERR); set_vaxc_errno(sts);
3898 return 0;
3899 }
3900
3901 while ((sts = sys$read(&rab_in))) { /* always true */
3902 if (sts == RMS$_EOF) break;
3903 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
3904 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
3905 sys$close(&fab_in); sys$close(&fab_out);
3906 set_errno(EVMSERR); set_vaxc_errno(sts);
3907 return 0;
3908 }
3909 }
3910
3911 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
3912 sys$close(&fab_in); sys$close(&fab_out);
3913 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
3914 if (!(sts & 1)) {
3915 set_errno(EVMSERR); set_vaxc_errno(sts);
3916 return 0;
3917 }
3918
3919 return 1;
3920
3921} /* end of rmscopy() */
3922/*}}}*/
3923
3924
748a9306
LW
3925/*** The following glue provides 'hooks' to make some of the routines
3926 * from this file available from Perl. These routines are sufficiently
3927 * basic, and are required sufficiently early in the build process,
3928 * that's it's nice to have them available to miniperl as well as the
3929 * full Perl, so they're set up here instead of in an extension. The
3930 * Perl code which handles importation of these names into a given
3931 * package lives in [.VMS]Filespec.pm in @INC.
3932 */
3933
3934void
01b8edb6
PP
3935rmsexpand_fromperl(CV *cv)
3936{
3937 dXSARGS;
bbce6d69 3938 char *fspec, *defspec = NULL, *rslt;
01b8edb6 3939
bbce6d69
PP
3940 if (!items || items > 2)
3941 croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
3942 fspec = SvPV(ST(0),na);
3943 if (!fspec || !*fspec) XSRETURN_UNDEF;
3944 if (items == 2) defspec = SvPV(ST(1),na);
b7ae7a0d 3945
bbce6d69
PP
3946 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
3947 ST(0) = sv_newmortal();
3948 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
740ce14c 3949 XSRETURN(1);
01b8edb6
PP
3950}
3951
3952void
748a9306
LW
3953vmsify_fromperl(CV *cv)
3954{
3955 dXSARGS;
3956 char *vmsified;
3957
3958 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
3959 vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
3960 ST(0) = sv_newmortal();
3961 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
3962 XSRETURN(1);
3963}
3964
3965void
3966unixify_fromperl(CV *cv)
3967{
3968 dXSARGS;
3969 char *unixified;
3970
3971 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
3972 unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
3973 ST(0) = sv_newmortal();
3974 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
3975 XSRETURN(1);
3976}
3977
3978void
3979fileify_fromperl(CV *cv)
3980{
3981 dXSARGS;
3982 char *fileified;
3983
3984 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");