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