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