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