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