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