projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
perl 5.002_01: vms/descrip.mms
[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 }
a5f75d66 1193 New(7015,rslt,retlen+2+2*dashes,char);
e518068a 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 }
a5f75d66 1210 if (*cp2 != '[' && *cp2 != '<') {
a0d0e21e 1211 *(cp1++) = '/';
1212 }
1213 else { /* the VMS spec begins with directories */
1214 cp2++;
a5f75d66 1215 if (*cp2 == ']' || *cp2 == '>') {
1216 strcpy(rslt,"./");
1217 return rslt;
1218 }
1219 else if (*cp2 == '-') {
a0d0e21e 1220 while (*cp2 == '-') {
1221 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1222 cp2++;
1223 }
1224 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1225 if (ts) Safefree(rslt); /* filespecs like */
748a9306 1226 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [--foo.bar] */
a0d0e21e 1227 return NULL;
1228 }
1229 cp2++;
1230 }
1231 else if ( *(cp2) != '.') { /* add the implied device into the Unix spec */
1232 *(cp1++) = '/';
1233 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1234 if (ts) Safefree(rslt);
1235 return NULL;
1236 }
1237 do {
1238 cp3 = tmp;
1239 while (*cp3 != ':' && *cp3) cp3++;
1240 *(cp3++) = '\0';
1241 if (strchr(cp3,']') != NULL) break;
e518068a 1242 } while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3));
a0d0e21e 1243 cp3 = tmp;
1244 while (*cp3) *(cp1++) = *(cp3++);
1245 *(cp1++) = '/';
e518068a 1246 if (ts &&
1247 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1248 int offset = cp1 - rslt;
1249
1250 retlen = devlen + dirlen;
1251 Renew(rslt,retlen+1+2*dashes,char);
1252 cp1 = rslt + offset;
a0d0e21e 1253 }
1254 }
1255 else cp2++;
1256 }
1257 for (; cp2 <= dirend; cp2++) {
1258 if (*cp2 == ':') {
1259 *(cp1++) = '/';
1260 if (*(cp2+1) == '[') cp2++;
1261 }
1262 else if (*cp2 == ']' || *cp2 == '>') *(cp1++) = '/';
1263 else if (*cp2 == '.') {
1264 *(cp1++) = '/';
e518068a 1265 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1266 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1267 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1268 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1269 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1270 }
a0d0e21e 1271 }
1272 else if (*cp2 == '-') {
1273 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1274 while (*cp2 == '-') {
1275 cp2++;
1276 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1277 }
1278 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1279 if (ts) Safefree(rslt); /* filespecs like */
748a9306 1280 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [--foo.bar] */
a0d0e21e 1281 return NULL;
1282 }
1283 cp2++;
1284 }
1285 else *(cp1++) = *cp2;
1286 }
1287 else *(cp1++) = *cp2;
1288 }
1289 while (*cp2) *(cp1++) = *(cp2++);
1290 *cp1 = '\0';
1291
1292 return rslt;
1293
1294} /* end of do_tounixspec() */
1295/*}}}*/
1296/* External entry points */
1297char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1298char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1299
1300/*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1301static char *do_tovmsspec(char *path, char *buf, int ts) {
1302 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
e518068a 1303 char *rslt, *dirend;
1304 register char *cp1, *cp2;
1305 unsigned long int infront = 0, hasdir = 1;
a0d0e21e 1306
748a9306 1307 if (path == NULL) return NULL;
a0d0e21e 1308 if (buf) rslt = buf;
e518068a 1309 else if (ts) New(7016,rslt,strlen(path)+9,char);
a0d0e21e 1310 else rslt = __tovmsspec_retbuf;
748a9306 1311 if (strpbrk(path,"]:>") ||
a0d0e21e 1312 (dirend = strrchr(path,'/')) == NULL) {
748a9306 1313 if (path[0] == '.') {
1314 if (path[1] == '\0') strcpy(rslt,"[]");
1315 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1316 else strcpy(rslt,path); /* probably garbage */
1317 }
1318 else strcpy(rslt,path);
a0d0e21e 1319 return rslt;
1320 }
748a9306 1321 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.."? */
1322 if (!*(dirend+2)) dirend +=2;
1323 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
1324 }
a0d0e21e 1325 cp1 = rslt;
1326 cp2 = path;
1327 if (*cp2 == '/') {
e518068a 1328 char trndev[NAM$C_MAXRSS+1];
1329 int islnm, rooted;
1330 STRLEN trnend;
1331
a0d0e21e 1332 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
e518068a 1333 *cp1 = '\0';
c07a80fd 1334 islnm = my_trnlnm(rslt,trndev,0);
e518068a 1335 trnend = islnm ? strlen(trndev) - 1 : 0;
1336 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
1337 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
1338 /* If the first element of the path is a logical name, determine
1339 * whether it has to be translated so we can add more directories. */
1340 if (!islnm || rooted) {
1341 *(cp1++) = ':';
1342 *(cp1++) = '[';
1343 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
1344 else cp2++;
1345 }
1346 else {
1347 if (cp2 != dirend) {
1348 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
1349 strcpy(rslt,trndev);
1350 cp1 = rslt + trnend;
1351 *(cp1++) = '.';
1352 cp2++;
1353 }
1354 else {
1355 *(cp1++) = ':';
1356 hasdir = 0;
1357 }
1358 }
748a9306 1359 }
a0d0e21e 1360 else {
1361 *(cp1++) = '[';
748a9306 1362 if (*cp2 == '.') {
1363 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
1364 cp2 += 2; /* skip over "./" - it's redundant */
1365 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
1366 }
1367 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1368 *(cp1++) = '-'; /* "../" --> "-" */
1369 cp2 += 3;
1370 }
1371 if (cp2 > dirend) cp2 = dirend;
1372 }
1373 else *(cp1++) = '.';
1374 }
1375 for (; cp2 < dirend; cp2++) {
1376 if (*cp2 == '/') {
1377 if (*(cp1-1) != '.') *(cp1++) = '.';
1378 infront = 0;
1379 }
1380 else if (!infront && *cp2 == '.') {
4633a7c4 1381 if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
1382 else if (*(cp2+1) == '\0') { cp2++; break; }
748a9306 1383 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1384 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
1385 else if (*(cp1-2) == '[') *(cp1-1) = '-';
1386 else { /* back up over previous directory name */
1387 cp1--;
1388 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
4633a7c4 1389 if (*(cp1-1) == '[') {
1390 memcpy(cp1,"000000.",7);
1391 cp1 += 7;
1392 }
748a9306 1393 }
1394 cp2 += 2;
1395 if (cp2 == dirend) {
1396 if (*(cp1-1) == '.') cp1--;
1397 break;
1398 }
1399 }
1400 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
1401 }
1402 else {
e518068a 1403 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
748a9306 1404 if (*cp2 == '/') *(cp1++) = '.';
1405 else if (*cp2 == '.') *(cp1++) = '_';
1406 else *(cp1++) = *cp2;
1407 infront = 1;
1408 }
a0d0e21e 1409 }
748a9306 1410 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
e518068a 1411 if (hasdir) *(cp1++) = ']';
748a9306 1412 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
a0d0e21e 1413 while (*cp2) *(cp1++) = *(cp2++);
1414 *cp1 = '\0';
1415
1416 return rslt;
1417
1418} /* end of do_tovmsspec() */
1419/*}}}*/
1420/* External entry points */
1421char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
1422char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
1423
1424/*{{{ char *tovmspath[_ts](char *path, char *buf)*/
1425static char *do_tovmspath(char *path, char *buf, int ts) {
1426 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
1427 int vmslen;
1428 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
1429
748a9306 1430 if (path == NULL) return NULL;
a0d0e21e 1431 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1432 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
1433 if (buf) return buf;
1434 else if (ts) {
1435 vmslen = strlen(vmsified);
e518068a 1436 New(7017,cp,vmslen+1,char);
a0d0e21e 1437 memcpy(cp,vmsified,vmslen);
1438 cp[vmslen] = '\0';
1439 return cp;
1440 }
1441 else {
1442 strcpy(__tovmspath_retbuf,vmsified);
1443 return __tovmspath_retbuf;
1444 }
1445
1446} /* end of do_tovmspath() */
1447/*}}}*/
1448/* External entry points */
1449char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
1450char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
1451
1452
1453/*{{{ char *tounixpath[_ts](char *path, char *buf)*/
1454static char *do_tounixpath(char *path, char *buf, int ts) {
1455 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
1456 int unixlen;
1457 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
1458
748a9306 1459 if (path == NULL) return NULL;
a0d0e21e 1460 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1461 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
1462 if (buf) return buf;
1463 else if (ts) {
1464 unixlen = strlen(unixified);
e518068a 1465 New(7017,cp,unixlen+1,char);
a0d0e21e 1466 memcpy(cp,unixified,unixlen);
1467 cp[unixlen] = '\0';
1468 return cp;
1469 }
1470 else {
1471 strcpy(__tounixpath_retbuf,unixified);
1472 return __tounixpath_retbuf;
1473 }
1474
1475} /* end of do_tounixpath() */
1476/*}}}*/
1477/* External entry points */
1478char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
1479char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
1480
1481/*
1482 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
1483 *
1484 *****************************************************************************
1485 * *
1486 * Copyright (C) 1989-1994 by *
1487 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
1488 * *
1489 * Permission is hereby granted for the reproduction of this software, *
1490 * on condition that this copyright notice is included in the reproduction, *
1491 * and that such reproduction is not for purposes of profit or material *
1492 * gain. *
1493 * *
1494 * 27-Aug-1994 Modified for inclusion in perl5 *
1495 * by Charles Bailey bailey@genetics.upenn.edu *
1496 *****************************************************************************
1497 */
1498
1499/*
1500 * getredirection() is intended to aid in porting C programs
1501 * to VMS (Vax-11 C). The native VMS environment does not support
1502 * '>' and '<' I/O redirection, or command line wild card expansion,
1503 * or a command line pipe mechanism using the '|' AND background
1504 * command execution '&'. All of these capabilities are provided to any
1505 * C program which calls this procedure as the first thing in the
1506 * main program.
1507 * The piping mechanism will probably work with almost any 'filter' type
1508 * of program. With suitable modification, it may useful for other
1509 * portability problems as well.
1510 *
1511 * Author: Mark Pizzolato mark@infocomm.com
1512 */
1513struct list_item
1514 {
1515 struct list_item *next;
1516 char *value;
1517 };
1518
1519static void add_item(struct list_item **head,
1520 struct list_item **tail,
1521 char *value,
1522 int *count);
1523
1524static void expand_wild_cards(char *item,
1525 struct list_item **head,
1526 struct list_item **tail,
1527 int *count);
1528
1529static int background_process(int argc, char **argv);
1530
1531static void pipe_and_fork(char **cmargv);
1532
1533/*{{{ void getredirection(int *ac, char ***av)*/
1534void
1535getredirection(int *ac, char ***av)
1536/*
1537 * Process vms redirection arg's. Exit if any error is seen.
1538 * If getredirection() processes an argument, it is erased
1539 * from the vector. getredirection() returns a new argc and argv value.
1540 * In the event that a background command is requested (by a trailing "&"),
1541 * this routine creates a background subprocess, and simply exits the program.
1542 *
1543 * Warning: do not try to simplify the code for vms. The code
1544 * presupposes that getredirection() is called before any data is
1545 * read from stdin or written to stdout.
1546 *
1547 * Normal usage is as follows:
1548 *
1549 * main(argc, argv)
1550 * int argc;
1551 * char *argv[];
1552 * {
1553 * getredirection(&argc, &argv);
1554 * }
1555 */
1556{
1557 int argc = *ac; /* Argument Count */
1558 char **argv = *av; /* Argument Vector */
1559 char *ap; /* Argument pointer */
1560 int j; /* argv[] index */
1561 int item_count = 0; /* Count of Items in List */
1562 struct list_item *list_head = 0; /* First Item in List */
1563 struct list_item *list_tail; /* Last Item in List */
1564 char *in = NULL; /* Input File Name */
1565 char *out = NULL; /* Output File Name */
1566 char *outmode = "w"; /* Mode to Open Output File */
1567 char *err = NULL; /* Error File Name */
1568 char *errmode = "w"; /* Mode to Open Error File */
1569 int cmargc = 0; /* Piped Command Arg Count */
1570 char **cmargv = NULL;/* Piped Command Arg Vector */
a0d0e21e 1571
1572 /*
1573 * First handle the case where the last thing on the line ends with
1574 * a '&'. This indicates the desire for the command to be run in a
1575 * subprocess, so we satisfy that desire.
1576 */
1577 ap = argv[argc-1];
1578 if (0 == strcmp("&", ap))
1579 exit(background_process(--argc, argv));
e518068a 1580 if (*ap && '&' == ap[strlen(ap)-1])
a0d0e21e 1581 {
1582 ap[strlen(ap)-1] = '\0';
1583 exit(background_process(argc, argv));
1584 }
1585 /*
1586 * Now we handle the general redirection cases that involve '>', '>>',
1587 * '<', and pipes '|'.
1588 */
1589 for (j = 0; j < argc; ++j)
1590 {
1591 if (0 == strcmp("<", argv[j]))
1592 {
1593 if (j+1 >= argc)
1594 {
748a9306 1595 fprintf(stderr,"No input file after < on command line");
1596 exit(LIB$_WRONUMARG);
a0d0e21e 1597 }
1598 in = argv[++j];
1599 continue;
1600 }
1601 if ('<' == *(ap = argv[j]))
1602 {
1603 in = 1 + ap;
1604 continue;
1605 }
1606 if (0 == strcmp(">", ap))
1607 {
1608 if (j+1 >= argc)
1609 {
748a9306 1610 fprintf(stderr,"No output file after > on command line");
1611 exit(LIB$_WRONUMARG);
a0d0e21e 1612 }
1613 out = argv[++j];
1614 continue;
1615 }
1616 if ('>' == *ap)
1617 {
1618 if ('>' == ap[1])
1619 {
1620 outmode = "a";
1621 if ('\0' == ap[2])
1622 out = argv[++j];
1623 else
1624 out = 2 + ap;
1625 }
1626 else
1627 out = 1 + ap;
1628 if (j >= argc)
1629 {
748a9306 1630 fprintf(stderr,"No output file after > or >> on command line");
1631 exit(LIB$_WRONUMARG);
a0d0e21e 1632 }
1633 continue;
1634 }
1635 if (('2' == *ap) && ('>' == ap[1]))
1636 {
1637 if ('>' == ap[2])
1638 {
1639 errmode = "a";
1640 if ('\0' == ap[3])
1641 err = argv[++j];
1642 else
1643 err = 3 + ap;
1644 }
1645 else
1646 if ('\0' == ap[2])
1647 err = argv[++j];
1648 else
748a9306 1649 err = 2 + ap;
a0d0e21e 1650 if (j >= argc)
1651 {
748a9306 1652 fprintf(stderr,"No output file after 2> or 2>> on command line");
1653 exit(LIB$_WRONUMARG);
a0d0e21e 1654 }
1655 continue;
1656 }
1657 if (0 == strcmp("|", argv[j]))
1658 {
1659 if (j+1 >= argc)
1660 {
748a9306 1661 fprintf(stderr,"No command into which to pipe on command line");
1662 exit(LIB$_WRONUMARG);
a0d0e21e 1663 }
1664 cmargc = argc-(j+1);
1665 cmargv = &argv[j+1];
1666 argc = j;
1667 continue;
1668 }
1669 if ('|' == *(ap = argv[j]))
1670 {
1671 ++argv[j];
1672 cmargc = argc-j;
1673 cmargv = &argv[j];
1674 argc = j;
1675 continue;
1676 }
1677 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
1678 }
1679 /*
1680 * Allocate and fill in the new argument vector, Some Unix's terminate
1681 * the list with an extra null pointer.
1682 */
1683 New(7002, argv, item_count+1, char *);
1684 *av = argv;
1685 for (j = 0; j < item_count; ++j, list_head = list_head->next)
1686 argv[j] = list_head->value;
1687 *ac = item_count;
1688 if (cmargv != NULL)
1689 {
1690 if (out != NULL)
1691 {
748a9306 1692 fprintf(stderr,"'|' and '>' may not both be specified on command line");
1693 exit(LIB$_INVARGORD);
a0d0e21e 1694 }
1695 pipe_and_fork(cmargv);
1696 }
1697
1698 /* Check for input from a pipe (mailbox) */
1699
a5f75d66 1700 if (in == NULL && 1 == isapipe(0))
a0d0e21e 1701 {
1702 char mbxname[L_tmpnam];
1703 long int bufsize;
1704 long int dvi_item = DVI$_DEVBUFSIZ;
1705 $DESCRIPTOR(mbxnam, "");
1706 $DESCRIPTOR(mbxdevnam, "");
1707
1708 /* Input from a pipe, reopen it in binary mode to disable */
1709 /* carriage control processing. */
1710
748a9306 1711 fgetname(stdin, mbxname,1);
a0d0e21e 1712 mbxnam.dsc$a_pointer = mbxname;
1713 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
1714 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
1715 mbxdevnam.dsc$a_pointer = mbxname;
1716 mbxdevnam.dsc$w_length = sizeof(mbxname);
1717 dvi_item = DVI$_DEVNAM;
1718 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
1719 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
748a9306 1720 set_errno(0);
1721 set_vaxc_errno(1);
a0d0e21e 1722 freopen(mbxname, "rb", stdin);
1723 if (errno != 0)
1724 {
748a9306 1725 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
1726 exit(vaxc$errno);
a0d0e21e 1727 }
1728 }
1729 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
1730 {
748a9306 1731 fprintf(stderr,"Can't open input file %s as stdin",in);
1732 exit(vaxc$errno);
a0d0e21e 1733 }
1734 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
1735 {
748a9306 1736 fprintf(stderr,"Can't open output file %s as stdout",out);
1737 exit(vaxc$errno);
a0d0e21e 1738 }
748a9306 1739 if (err != NULL) {
1740 FILE *tmperr;
1741 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
1742 {
1743 fprintf(stderr,"Can't open error file %s as stderr",err);
1744 exit(vaxc$errno);
1745 }
1746 fclose(tmperr);
1747 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
1748 {
1749 exit(vaxc$errno);
1750 }
a0d0e21e 1751 }
1752#ifdef ARGPROC_DEBUG
1753 fprintf(stderr, "Arglist:\n");
1754 for (j = 0; j < *ac; ++j)
1755 fprintf(stderr, "argv[%d] = '%s'\n", j, argv[j]);
1756#endif
1757} /* end of getredirection() */
1758/*}}}*/
1759
1760static void add_item(struct list_item **head,
1761 struct list_item **tail,
1762 char *value,
1763 int *count)
1764{
1765 if (*head == 0)
1766 {
1767 New(7003,*head,1,struct list_item);
1768 *tail = *head;
1769 }
1770 else {
1771 New(7004,(*tail)->next,1,struct list_item);
1772 *tail = (*tail)->next;
1773 }
1774 (*tail)->value = value;
1775 ++(*count);
1776}
1777
1778static void expand_wild_cards(char *item,
1779 struct list_item **head,
1780 struct list_item **tail,
1781 int *count)
1782{
1783int expcount = 0;
748a9306 1784unsigned long int context = 0;
a0d0e21e 1785int isunix = 0;
a0d0e21e 1786char *had_version;
1787char *had_device;
1788int had_directory;
1789char *devdir;
1790char vmsspec[NAM$C_MAXRSS+1];
1791$DESCRIPTOR(filespec, "");
748a9306 1792$DESCRIPTOR(defaultspec, "SYS$DISK:[]");
a0d0e21e 1793$DESCRIPTOR(resultspec, "");
c07a80fd 1794unsigned long int zero = 0, sts;
a0d0e21e 1795
1796 if (strcspn(item, "*%") == strlen(item))
1797 {
1798 add_item(head, tail, item, count);
1799 return;
1800 }
1801 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
1802 resultspec.dsc$b_class = DSC$K_CLASS_D;
1803 resultspec.dsc$a_pointer = NULL;
748a9306 1804 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
a0d0e21e 1805 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
1806 if (!isunix || !filespec.dsc$a_pointer)
1807 filespec.dsc$a_pointer = item;
1808 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
1809 /*
1810 * Only return version specs, if the caller specified a version
1811 */
1812 had_version = strchr(item, ';');
1813 /*
1814 * Only return device and directory specs, if the caller specifed either.
1815 */
1816 had_device = strchr(item, ':');
1817 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
1818
c07a80fd 1819 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
1820 &defaultspec, 0, 0, &zero))))
a0d0e21e 1821 {
1822 char *string;
1823 char *c;
1824
1825 New(7005,string,resultspec.dsc$w_length+1,char);
1826 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
1827 string[resultspec.dsc$w_length] = '\0';
1828 if (NULL == had_version)
1829 *((char *)strrchr(string, ';')) = '\0';
1830 if ((!had_directory) && (had_device == NULL))
1831 {
1832 if (NULL == (devdir = strrchr(string, ']')))
1833 devdir = strrchr(string, '>');
1834 strcpy(string, devdir + 1);
1835 }
1836 /*
1837 * Be consistent with what the C RTL has already done to the rest of
1838 * the argv items and lowercase all of these names.
1839 */
1840 for (c = string; *c; ++c)
1841 if (isupper(*c))
1842 *c = tolower(*c);
1843 if (isunix) trim_unixpath(item,string);
1844 add_item(head, tail, string, count);
1845 ++expcount;
1846 }
c07a80fd 1847 if (sts != RMS$_NMF)
1848 {
1849 set_vaxc_errno(sts);
1850 switch (sts)
1851 {
1852 case RMS$_FNF:
1853 case RMS$_DIR:
1854 set_errno(ENOENT); break;
1855 case RMS$_DEV:
1856 set_errno(ENODEV); break;
1857 case RMS$_SYN:
1858 set_errno(EINVAL); break;
1859 case RMS$_PRV:
1860 set_errno(EACCES); break;
1861 default:
1862 _ckvmssts(sts);
1863 }
1864 }
a0d0e21e 1865 if (expcount == 0)
1866 add_item(head, tail, item, count);
c07a80fd 1867 _ckvmssts(lib$sfree1_dd(&resultspec));
1868 _ckvmssts(lib$find_file_end(&context));
a0d0e21e 1869}
1870
1871static int child_st[2];/* Event Flag set when child process completes */
1872
748a9306 1873static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
a0d0e21e 1874
748a9306 1875static unsigned long int exit_handler(int *status)
a0d0e21e 1876{
1877short iosb[4];
1878
1879 if (0 == child_st[0])
1880 {
1881#ifdef ARGPROC_DEBUG
1882 fprintf(stderr, "Waiting for Child Process to Finish . . .\n");
1883#endif
1884 fflush(stdout); /* Have to flush pipe for binary data to */
1885 /* terminate properly -- <tp@mccall.com> */
1886 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
1887 sys$dassgn(child_chan);
1888 fclose(stdout);
1889 sys$synch(0, child_st);
1890 }
1891 return(1);
1892}
1893
1894static void sig_child(int chan)
1895{
1896#ifdef ARGPROC_DEBUG
1897 fprintf(stderr, "Child Completion AST\n");
1898#endif
1899 if (child_st[0] == 0)
1900 child_st[0] = 1;
1901}
1902
748a9306 1903static struct exit_control_block exit_block =
a0d0e21e 1904 {
1905 0,
1906 exit_handler,
1907 1,
1908 &exit_block.exit_status,
1909 0
1910 };
1911
1912static void pipe_and_fork(char **cmargv)
1913{
1914 char subcmd[2048];
1915 $DESCRIPTOR(cmddsc, "");
1916 static char mbxname[64];
1917 $DESCRIPTOR(mbxdsc, mbxname);
a0d0e21e 1918 int pid, j;
a0d0e21e 1919 unsigned long int zero = 0, one = 1;
1920
1921 strcpy(subcmd, cmargv[0]);
1922 for (j = 1; NULL != cmargv[j]; ++j)
1923 {
1924 strcat(subcmd, " \"");
1925 strcat(subcmd, cmargv[j]);
1926 strcat(subcmd, "\"");
1927 }
1928 cmddsc.dsc$a_pointer = subcmd;
1929 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
1930
1931 create_mbx(&child_chan,&mbxdsc);
1932#ifdef ARGPROC_DEBUG
1933 fprintf(stderr, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
1934 fprintf(stderr, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
1935#endif
748a9306 1936 _ckvmssts(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
a0d0e21e 1937 0, &pid, child_st, &zero, sig_child,
748a9306 1938 &child_chan));
a0d0e21e 1939#ifdef ARGPROC_DEBUG
1940 fprintf(stderr, "Subprocess's Pid = %08X\n", pid);
1941#endif
1942 sys$dclexh(&exit_block);
1943 if (NULL == freopen(mbxname, "wb", stdout))
1944 {
748a9306 1945 fprintf(stderr,"Can't open output pipe (name %s)",mbxname);
a0d0e21e 1946 }
1947}
1948
1949static int background_process(int argc, char **argv)
1950{
1951char command[2048] = "$";
1952$DESCRIPTOR(value, "");
1953static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
1954static $DESCRIPTOR(null, "NLA0:");
1955static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
1956char pidstring[80];
1957$DESCRIPTOR(pidstr, "");
1958int pid;
748a9306 1959unsigned long int flags = 17, one = 1, retsts;
a0d0e21e 1960
1961 strcat(command, argv[0]);
1962 while (--argc)
1963 {
1964 strcat(command, " \"");
1965 strcat(command, *(++argv));
1966 strcat(command, "\"");
1967 }
1968 value.dsc$a_pointer = command;
1969 value.dsc$w_length = strlen(value.dsc$a_pointer);
748a9306 1970 _ckvmssts(lib$set_symbol(&cmd, &value));
1971 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
1972 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
1973 _ckvmssts(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
1974 }
1975 else {
1976 _ckvmssts(retsts);
1977 }
a0d0e21e 1978#ifdef ARGPROC_DEBUG
1979 fprintf(stderr, "%s\n", command);
1980#endif
1981 sprintf(pidstring, "%08X", pid);
1982 fprintf(stderr, "%s\n", pidstring);
1983 pidstr.dsc$a_pointer = pidstring;
1984 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
1985 lib$set_symbol(&pidsymbol, &pidstr);
1986 return(SS$_NORMAL);
1987}
1988/*}}}*/
1989/***** End of code taken from Mark Pizzolato's argproc.c package *****/
1990
a0d0e21e 1991/* trim_unixpath()
1992 * Trim Unix-style prefix off filespec, so it looks like what a shell
1993 * glob expansion would return (i.e. from specified prefix on, not
1994 * full path). Note that returned filespec is Unix-style, regardless
1995 * of whether input filespec was VMS-style or Unix-style.
1996 *
1997 * Returns !=0 on success, 0 on failure.
1998 */
1999/*{{{int trim_unixpath(char *template, char *fspec)*/
2000int
2001trim_unixpath(char *template, char *fspec)
2002{
2003 char unixified[NAM$C_MAXRSS+1], *base, *cp1, *cp2;
2004 register int tmplen;
2005
2006 if (strpbrk(fspec,"]>:") != NULL) {
2007 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2008 else base = unixified;
2009 }
2010 else base = fspec;
2011 for (cp2 = base; *cp2; cp2++) ; /* Find end of filespec */
2012
2013 /* Find prefix to template consisting of path elements without wildcards */
2014 if ((cp1 = strpbrk(template,"*%?")) == NULL)
2015 for (cp1 = template; *cp1; cp1++) ;
2016 else while (cp1 >= template && *cp1 != '/') cp1--;
2017 if (cp1 == template) return 1; /* Wildcard was up front - no prefix to clip */
2018 tmplen = cp1 - template;
2019
2020 /* Try to find template prefix on filespec */
2021 if (!memcmp(base,template,tmplen)) return 1; /* Nothing before prefix - we're done */
2022 for (; cp2 - base > tmplen; base++) {
2023 if (*base != '/') continue;
2024 if (!memcmp(base + 1,template,tmplen)) break;
2025 }
2026 if (cp2 - base == tmplen) return 0; /* Not there - not good */
2027 base++; /* Move past leading '/' */
2028 /* Copy down remaining portion of filespec, including trailing NUL */
2029 memmove(fspec,base,cp2 - base + 1);
2030 return 1;
2031
2032} /* end of trim_unixpath() */
2033/*}}}*/
2034
a0d0e21e 2035
2036/*
2037 * VMS readdir() routines.
2038 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
2039 * This code has no copyright.
2040 *
2041 * 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu
2042 * Minor modifications to original routines.
2043 */
2044
2045 /* Number of elements in vms_versions array */
2046#define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
2047
2048/*
2049 * Open a directory, return a handle for later use.
2050 */
2051/*{{{ DIR *opendir(char*name) */
2052DIR *
2053opendir(char *name)
2054{
2055 DIR *dd;
2056 char dir[NAM$C_MAXRSS+1];
2057
2058 /* Get memory for the handle, and the pattern. */
2059 New(7006,dd,1,DIR);
2060 if (do_tovmspath(name,dir,0) == NULL) {
2061 Safefree((char *)dd);
2062 return(NULL);
2063 }
2064 New(7007,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
2065
2066 /* Fill in the fields; mainly playing with the descriptor. */
2067 (void)sprintf(dd->pattern, "%s*.*",dir);
2068 dd->context = 0;
2069 dd->count = 0;
2070 dd->vms_wantversions = 0;
2071 dd->pat.dsc$a_pointer = dd->pattern;
2072 dd->pat.dsc$w_length = strlen(dd->pattern);
2073 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
2074 dd->pat.dsc$b_class = DSC$K_CLASS_S;
2075
2076 return dd;
2077} /* end of opendir() */
2078/*}}}*/
2079
2080/*
2081 * Set the flag to indicate we want versions or not.
2082 */
2083/*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
2084void
2085vmsreaddirversions(DIR *dd, int flag)
2086{
2087 dd->vms_wantversions = flag;
2088}
2089/*}}}*/
2090
2091/*
2092 * Free up an opened directory.
2093 */
2094/*{{{ void closedir(DIR *dd)*/
2095void
2096closedir(DIR *dd)
2097{
2098 (void)lib$find_file_end(&dd->context);
2099 Safefree(dd->pattern);
2100 Safefree((char *)dd);
2101}
2102/*}}}*/
2103
2104/*
2105 * Collect all the version numbers for the current file.
2106 */
2107static void
2108collectversions(dd)
2109 DIR *dd;
2110{
2111 struct dsc$descriptor_s pat;
2112 struct dsc$descriptor_s res;
2113 struct dirent *e;
2114 char *p, *text, buff[sizeof dd->entry.d_name];
2115 int i;
2116 unsigned long context, tmpsts;
2117
2118 /* Convenient shorthand. */
2119 e = &dd->entry;
2120
2121 /* Add the version wildcard, ignoring the "*.*" put on before */
2122 i = strlen(dd->pattern);
2123 New(7008,text,i + e->d_namlen + 3,char);
2124 (void)strcpy(text, dd->pattern);
2125 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
2126
2127 /* Set up the pattern descriptor. */
2128 pat.dsc$a_pointer = text;
2129 pat.dsc$w_length = i + e->d_namlen - 1;
2130 pat.dsc$b_dtype = DSC$K_DTYPE_T;
2131 pat.dsc$b_class = DSC$K_CLASS_S;
2132
2133 /* Set up result descriptor. */
2134 res.dsc$a_pointer = buff;
2135 res.dsc$w_length = sizeof buff - 2;
2136 res.dsc$b_dtype = DSC$K_DTYPE_T;
2137 res.dsc$b_class = DSC$K_CLASS_S;
2138
2139 /* Read files, collecting versions. */
2140 for (context = 0, e->vms_verscount = 0;
2141 e->vms_verscount < VERSIZE(e);
2142 e->vms_verscount++) {
2143 tmpsts = lib$find_file(&pat, &res, &context);
2144 if (tmpsts == RMS$_NMF || context == 0) break;
748a9306 2145 _ckvmssts(tmpsts);
a0d0e21e 2146 buff[sizeof buff - 1] = '\0';
748a9306 2147 if ((p = strchr(buff, ';')))
a0d0e21e 2148 e->vms_versions[e->vms_verscount] = atoi(p + 1);
2149 else
2150 e->vms_versions[e->vms_verscount] = -1;
2151 }
2152
748a9306 2153 _ckvmssts(lib$find_file_end(&context));
a0d0e21e 2154 Safefree(text);
2155
2156} /* end of collectversions() */
2157
2158/*
2159 * Read the next entry from the directory.
2160 */
2161/*{{{ struct dirent *readdir(DIR *dd)*/
2162struct dirent *
2163readdir(DIR *dd)
2164{
2165 struct dsc$descriptor_s res;
2166 char *p, buff[sizeof dd->entry.d_name];
a0d0e21e 2167 unsigned long int tmpsts;
2168
2169 /* Set up result descriptor, and get next file. */
2170 res.dsc$a_pointer = buff;
2171 res.dsc$w_length = sizeof buff - 2;
2172 res.dsc$b_dtype = DSC$K_DTYPE_T;
2173 res.dsc$b_class = DSC$K_CLASS_S;
a0d0e21e 2174 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4633a7c4 2175 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
2176 if (!(tmpsts & 1)) {
2177 set_vaxc_errno(tmpsts);
2178 switch (tmpsts) {
2179 case RMS$_PRV:
c07a80fd 2180 set_errno(EACCES); break;
4633a7c4 2181 case RMS$_DEV:
c07a80fd 2182 set_errno(ENODEV); break;
4633a7c4 2183 case RMS$_DIR:
4633a7c4 2184 case RMS$_FNF:
c07a80fd 2185 set_errno(ENOENT); break;
4633a7c4 2186 default:
2187 set_errno(EVMSERR);
2188 }
2189 return NULL;
2190 }
2191 dd->count++;
a0d0e21e 2192 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
2193 buff[sizeof buff - 1] = '\0';
2194 for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
2195 *p = '\0';
2196
2197 /* Skip any directory component and just copy the name. */
748a9306 2198 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
a0d0e21e 2199 else (void)strcpy(dd->entry.d_name, buff);
2200
2201 /* Clobber the version. */
748a9306 2202 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
a0d0e21e 2203
2204 dd->entry.d_namlen = strlen(dd->entry.d_name);
2205 dd->entry.vms_verscount = 0;
2206 if (dd->vms_wantversions) collectversions(dd);
2207 return &dd->entry;
2208
2209} /* end of readdir() */
2210/*}}}*/
2211
2212/*
2213 * Return something that can be used in a seekdir later.
2214 */
2215/*{{{ long telldir(DIR *dd)*/
2216long
2217telldir(DIR *dd)
2218{
2219 return dd->count;
2220}
2221/*}}}*/
2222
2223/*
2224 * Return to a spot where we used to be. Brute force.
2225 */
2226/*{{{ void seekdir(DIR *dd,long count)*/
2227void
2228seekdir(DIR *dd, long count)
2229{
2230 int vms_wantversions;
a0d0e21e 2231
2232 /* If we haven't done anything yet... */
2233 if (dd->count == 0)
2234 return;
2235
2236 /* Remember some state, and clear it. */
2237 vms_wantversions = dd->vms_wantversions;
2238 dd->vms_wantversions = 0;
748a9306 2239 _ckvmssts(lib$find_file_end(&dd->context));
a0d0e21e 2240 dd->context = 0;
2241
2242 /* The increment is in readdir(). */
2243 for (dd->count = 0; dd->count < count; )
2244 (void)readdir(dd);
2245
2246 dd->vms_wantversions = vms_wantversions;
2247
2248} /* end of seekdir() */
2249/*}}}*/
2250
2251/* VMS subprocess management
2252 *
2253 * my_vfork() - just a vfork(), after setting a flag to record that
2254 * the current script is trying a Unix-style fork/exec.
2255 *
2256 * vms_do_aexec() and vms_do_exec() are called in response to the
2257 * perl 'exec' function. If this follows a vfork call, then they
2258 * call out the the regular perl routines in doio.c which do an
2259 * execvp (for those who really want to try this under VMS).
2260 * Otherwise, they do exactly what the perl docs say exec should
2261 * do - terminate the current script and invoke a new command
2262 * (See below for notes on command syntax.)
2263 *
2264 * do_aspawn() and do_spawn() implement the VMS side of the perl
2265 * 'system' function.
2266 *
2267 * Note on command arguments to perl 'exec' and 'system': When handled
2268 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2269 * are concatenated to form a DCL command string. If the first arg
2270 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2271 * the the command string is hrnded off to DCL directly. Otherwise,
2272 * the first token of the command is taken as the filespec of an image
2273 * to run. The filespec is expanded using a default type of '.EXE' and
2274 * the process defaults for device, directory, etc., and the resultant
2275 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2276 * the command string as parameters. This is perhaps a bit compicated,
2277 * but I hope it will form a happy medium between what VMS folks expect
2278 * from lib$spawn and what Unix folks expect from exec.
2279 */
2280
2281static int vfork_called;
2282
2283/*{{{int my_vfork()*/
2284int
2285my_vfork()
2286{
748a9306 2287 vfork_called++;
a0d0e21e 2288 return vfork();
2289}
2290/*}}}*/
2291
4633a7c4 2292
2293static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
2294
a0d0e21e 2295static void
4633a7c4 2296vms_execfree() {
2297 if (Cmd) {
e518068a 2298 Safefree(Cmd);
4633a7c4 2299 Cmd = Nullch;
2300 }
2301 if (VMScmd.dsc$a_pointer) {
2302 Safefree(VMScmd.dsc$a_pointer);
2303 VMScmd.dsc$w_length = 0;
2304 VMScmd.dsc$a_pointer = Nullch;
2305 }
2306}
2307
2308static char *
2309setup_argstr(SV *really, SV **mark, SV **sp)
a0d0e21e 2310{
4633a7c4 2311 char *junk, *tmps = Nullch;
a0d0e21e 2312 register size_t cmdlen = 0;
2313 size_t rlen;
2314 register SV **idx;
2315
2316 idx = mark;
4633a7c4 2317 if (really) {
2318 tmps = SvPV(really,rlen);
2319 if (*tmps) {
2320 cmdlen += rlen + 1;
2321 idx++;
2322 }
a0d0e21e 2323 }
2324
2325 for (idx++; idx <= sp; idx++) {
2326 if (*idx) {
2327 junk = SvPVx(*idx,rlen);
2328 cmdlen += rlen ? rlen + 1 : 0;
2329 }
2330 }
e518068a 2331 New(401,Cmd,cmdlen+1,char);
a0d0e21e 2332
4633a7c4 2333 if (tmps && *tmps) {
2334 strcpy(Cmd,tmps);
a0d0e21e 2335 mark++;
2336 }
4633a7c4 2337 else *Cmd = '\0';
a0d0e21e 2338 while (++mark <= sp) {
2339 if (*mark) {
4633a7c4 2340 strcat(Cmd," ");
2341 strcat(Cmd,SvPVx(*mark,na));
a0d0e21e 2342 }
2343 }
4633a7c4 2344 return Cmd;
a0d0e21e 2345
2346} /* end of setup_argstr() */
2347
4633a7c4 2348
a0d0e21e 2349static unsigned long int
4633a7c4 2350setup_cmddsc(char *cmd, int check_img)
a0d0e21e 2351{
2352 char resspec[NAM$C_MAXRSS+1];
2353 $DESCRIPTOR(defdsc,".EXE");
2354 $DESCRIPTOR(resdsc,resspec);
2355 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2356 unsigned long int cxt = 0, flags = 1, retsts;
2357 register char *s, *rest, *cp;
2358 register int isdcl = 0;
2359
2360 s = cmd;
2361 while (*s && isspace(*s)) s++;
2362 if (check_img) {
2363 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2364 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
2365 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2366 if (*cp == ':' || *cp == '[' || *cp == '<') {
2367 isdcl = 0;
2368 break;
2369 }
2370 }
2371 }
2372 }
2373 else isdcl = 1;
2374 if (isdcl) { /* It's a DCL command, just do it. */
4633a7c4 2375 VMScmd.dsc$w_length = strlen(cmd);
e518068a 2376 if (cmd == Cmd) {
2377 VMScmd.dsc$a_pointer = Cmd;
2378 Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
2379 }
2380 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
a0d0e21e 2381 }
2382 else { /* assume first token is an image spec */
2383 cmd = s;
2384 while (*s && !isspace(*s)) s++;
2385 rest = *s ? s : 0;
2386 imgdsc.dsc$a_pointer = cmd;
2387 imgdsc.dsc$w_length = s - cmd;
2388 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4633a7c4 2389 if (!(retsts & 1)) {
2390 /* just hand off status values likely to be due to user error */
2391 if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
2392 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2393 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2394 else { _ckvmssts(retsts); }
2395 }
a0d0e21e 2396 else {
748a9306 2397 _ckvmssts(lib$find_file_end(&cxt));
a0d0e21e 2398 s = resspec;
2399 while (*s && !isspace(*s)) s++;
2400 *s = '\0';
e518068a 2401 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
4633a7c4 2402 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
2403 strcat(VMScmd.dsc$a_pointer,resspec);
2404 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
2405 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
a0d0e21e 2406 }
2407 }
2408
2409 return SS$_NORMAL;
2410} /* end of setup_cmddsc() */
2411
2412/* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2413bool
2414vms_do_aexec(SV *really,SV **mark,SV **sp)
2415{
a0d0e21e 2416 if (sp > mark) {
2417 if (vfork_called) { /* this follows a vfork - act Unixish */
748a9306 2418 vfork_called--;
2419 if (vfork_called < 0) {
2420 warn("Internal inconsistency in tracking vforks");
2421 vfork_called = 0;
2422 }
2423 else return do_aexec(really,mark,sp);
a0d0e21e 2424 }
4633a7c4 2425 /* no vfork - act VMSish */
2426 return vms_do_exec(setup_argstr(really,mark,sp));
748a9306 2427
a0d0e21e 2428 }
2429
2430 return FALSE;
2431} /* end of vms_do_aexec() */
2432/*}}}*/
2433
2434/* {{{bool vms_do_exec(char *cmd) */
2435bool
2436vms_do_exec(char *cmd)
2437{
2438
2439 if (vfork_called) { /* this follows a vfork - act Unixish */
748a9306 2440 vfork_called--;
2441 if (vfork_called < 0) {
2442 warn("Internal inconsistency in tracking vforks");
2443 vfork_called = 0;
2444 }
2445 else return do_exec(cmd);
a0d0e21e 2446 }
748a9306 2447
2448 { /* no vfork - act VMSish */
748a9306 2449 unsigned long int retsts;
a0d0e21e 2450
4633a7c4 2451 if ((retsts = setup_cmddsc(cmd,1)) & 1)
2452 retsts = lib$do_command(&VMScmd);
a0d0e21e 2453
748a9306 2454 set_errno(EVMSERR);
2455 set_vaxc_errno(retsts);
a0d0e21e 2456 if (dowarn)
4633a7c4 2457 warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
2458 vms_execfree();
a0d0e21e 2459 }
2460
2461 return FALSE;
2462
2463} /* end of vms_do_exec() */
2464/*}}}*/
2465
2466unsigned long int do_spawn(char *);
2467
2468/* {{{ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) */
2469unsigned long int
2470do_aspawn(SV *really,SV **mark,SV **sp)
2471{
4633a7c4 2472 if (sp > mark) return do_spawn(setup_argstr(really,mark,sp));
a0d0e21e 2473
2474 return SS$_ABORT;
2475} /* end of do_aspawn() */
2476/*}}}*/
2477
2478/* {{{unsigned long int do_spawn(char *cmd) */
2479unsigned long int
2480do_spawn(char *cmd)
2481{
4633a7c4 2482 unsigned long int substs, hadcmd = 1;
a0d0e21e 2483
748a9306 2484 if (!cmd || !*cmd) {
4633a7c4 2485 hadcmd = 0;
2486 _ckvmssts(lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0));
748a9306 2487 }
4633a7c4 2488 else if ((substs = setup_cmddsc(cmd,0)) & 1) {
2489 _ckvmssts(lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0));
748a9306 2490 }
a0d0e21e 2491
2492 if (!(substs&1)) {
748a9306 2493 set_errno(EVMSERR);
2494 set_vaxc_errno(substs);
a0d0e21e 2495 if (dowarn)
748a9306 2496 warn("Can't exec \"%s\": %s",
4633a7c4 2497 hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
a0d0e21e 2498 }
4633a7c4 2499 vms_execfree();
a0d0e21e 2500 return substs;
2501
2502} /* end of do_spawn() */
2503/*}}}*/
2504
2505/*
2506 * A simple fwrite replacement which outputs itmsz*nitm chars without
2507 * introducing record boundaries every itmsz chars.
2508 */
2509/*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
2510int
2511my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
2512{
2513 register char *cp, *end;
2514
2515 end = (char *)src + itmsz * nitm;
2516
2517 while ((char *)src <= end) {
2518 for (cp = src; cp <= end; cp++) if (!*cp) break;
2519 if (fputs(src,dest) == EOF) return EOF;
2520 if (cp < end)
2521 if (fputc('\0',dest) == EOF) return EOF;
2522 src = cp + 1;
2523 }
2524
2525 return 1;
2526
2527} /* end of my_fwrite() */
2528/*}}}*/
2529
748a9306 2530/*
2531 * Here are replacements for the following Unix routines in the VMS environment:
2532 * getpwuid Get information for a particular UIC or UID
2533 * getpwnam Get information for a named user
2534 * getpwent Get information for each user in the rights database
2535 * setpwent Reset search to the start of the rights database
2536 * endpwent Finish searching for users in the rights database
2537 *
2538 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
2539 * (defined in pwd.h), which contains the following fields:-
2540 * struct passwd {
2541 * char *pw_name; Username (in lower case)
2542 * char *pw_passwd; Hashed password
2543 * unsigned int pw_uid; UIC
2544 * unsigned int pw_gid; UIC group number
2545 * char *pw_unixdir; Default device/directory (VMS-style)
2546 * char *pw_gecos; Owner name
2547 * char *pw_dir; Default device/directory (Unix-style)
2548 * char *pw_shell; Default CLI name (eg. DCL)
2549 * };
2550 * If the specified user does not exist, getpwuid and getpwnam return NULL.
2551 *
2552 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
2553 * not the UIC member number (eg. what's returned by getuid()),
2554 * getpwuid() can accept either as input (if uid is specified, the caller's
2555 * UIC group is used), though it won't recognise gid=0.
2556 *
2557 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
2558 * information about other users in your group or in other groups, respectively.
2559 * If the required privilege is not available, then these routines fill only
2560 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
2561 * string).
2562 *
2563 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
2564 */
2565
2566/* sizes of various UAF record fields */
2567#define UAI$S_USERNAME 12
2568#define UAI$S_IDENT 31
2569#define UAI$S_OWNER 31
2570#define UAI$S_DEFDEV 31
2571#define UAI$S_DEFDIR 63
2572#define UAI$S_DEFCLI 31
2573#define UAI$S_PWD 8
2574
2575#define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
2576 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
2577 (uic).uic$v_group != UIC$K_WILD_GROUP)
2578
4633a7c4 2579static char __empty[]= "";
2580static struct passwd __passwd_empty=
748a9306 2581 {(char *) __empty, (char *) __empty, 0, 0,
2582 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
2583static int contxt= 0;
2584static struct passwd __pwdcache;
2585static char __pw_namecache[UAI$S_IDENT+1];
2586
2587static char *_mystrtolower(char *str)
2588{
2589 if (str) for (; *str; ++str) *str= tolower(*str);
2590 return str;
2591}
2592
2593/*
2594 * This routine does most of the work extracting the user information.
2595 */
2596static int fillpasswd (const char *name, struct passwd *pwd)
a0d0e21e 2597{
748a9306 2598 static struct {
2599 unsigned char length;
2600 char pw_gecos[UAI$S_OWNER+1];
2601 } owner;
2602 static union uicdef uic;
2603 static struct {
2604 unsigned char length;
2605 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
2606 } defdev;
2607 static struct {
2608 unsigned char length;
2609 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
2610 } defdir;
2611 static struct {
2612 unsigned char length;
2613 char pw_shell[UAI$S_DEFCLI+1];
2614 } defcli;
2615 static char pw_passwd[UAI$S_PWD+1];
2616
2617 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
2618 struct dsc$descriptor_s name_desc;
c07a80fd 2619 unsigned long int sts;
748a9306 2620
4633a7c4 2621 static struct itmlst_3 itmlst[]= {
748a9306 2622 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
2623 {sizeof(uic), UAI$_UIC, &uic, &luic},
2624 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
2625 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
2626 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
2627 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
2628 {0, 0, NULL, NULL}};
2629
2630 name_desc.dsc$w_length= strlen(name);
2631 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2632 name_desc.dsc$b_class= DSC$K_CLASS_S;
2633 name_desc.dsc$a_pointer= (char *) name;
2634
2635/* Note that sys$getuai returns many fields as counted strings. */
c07a80fd 2636 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
2637 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
2638 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
2639 }
2640 else { _ckvmssts(sts); }
2641 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
748a9306 2642
2643 if ((int) owner.length < lowner) lowner= (int) owner.length;
2644 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
2645 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
2646 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
2647 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
2648 owner.pw_gecos[lowner]= '\0';
2649 defdev.pw_dir[ldefdev+ldefdir]= '\0';
2650 defcli.pw_shell[ldefcli]= '\0';
2651 if (valid_uic(uic)) {
2652 pwd->pw_uid= uic.uic$l_uic;
2653 pwd->pw_gid= uic.uic$v_group;
2654 }
2655 else
2656 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
2657 pwd->pw_passwd= pw_passwd;
2658 pwd->pw_gecos= owner.pw_gecos;
2659 pwd->pw_dir= defdev.pw_dir;
2660 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
2661 pwd->pw_shell= defcli.pw_shell;
2662 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
2663 int ldir;
2664 ldir= strlen(pwd->pw_unixdir) - 1;
2665 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
2666 }
2667 else
2668 strcpy(pwd->pw_unixdir, pwd->pw_dir);
2669 _mystrtolower(pwd->pw_unixdir);
c07a80fd 2670 return 1;
a0d0e21e 2671}
748a9306 2672
2673/*
2674 * Get information for a named user.
2675*/
2676/*{{{struct passwd *getpwnam(char *name)*/
2677struct passwd *my_getpwnam(char *name)
2678{
2679 struct dsc$descriptor_s name_desc;
2680 union uicdef uic;
2681 unsigned long int status, stat;
2682
2683 __pwdcache = __passwd_empty;
c07a80fd 2684 if (!fillpasswd(name, &__pwdcache)) {
748a9306 2685 /* We still may be able to determine pw_uid and pw_gid */
2686 name_desc.dsc$w_length= strlen(name);
2687 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2688 name_desc.dsc$b_class= DSC$K_CLASS_S;
2689 name_desc.dsc$a_pointer= (char *) name;
2690 if ((stat = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
2691 __pwdcache.pw_uid= uic.uic$l_uic;
2692 __pwdcache.pw_gid= uic.uic$v_group;
2693 }
c07a80fd 2694 else {
2695 if (stat == SS$_NOSUCHID || stat == SS$_IVIDENT || stat == RMS$_PRV) {
2696 set_vaxc_errno(stat);
2697 set_errno(stat == RMS$_PRV ? EACCES : EINVAL);
2698 return NULL;
2699 }
2700 else { _ckvmssts(stat); }
2701 }
748a9306 2702 }
748a9306 2703 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
2704 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
2705 __pwdcache.pw_name= __pw_namecache;
2706 return &__pwdcache;
2707} /* end of my_getpwnam() */
a0d0e21e 2708/*}}}*/
2709
748a9306 2710/*
2711 * Get information for a particular UIC or UID.
2712 * Called by my_getpwent with uid=-1 to list all users.
2713*/
2714/*{{{struct passwd *my_getpwuid(Uid_t uid)*/
2715struct passwd *my_getpwuid(Uid_t uid)
a0d0e21e 2716{
748a9306 2717 const $DESCRIPTOR(name_desc,__pw_namecache);
2718 unsigned short lname;
2719 union uicdef uic;
2720 unsigned long int status;
2721
2722 if (uid == (unsigned int) -1) {
2723 do {
2724 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
2725 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
c07a80fd 2726 set_vaxc_errno(status);
2727 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
748a9306 2728 my_endpwent();
2729 return NULL;
2730 }
2731 else { _ckvmssts(status); }
2732 } while (!valid_uic (uic));
2733 }
2734 else {
2735 uic.uic$l_uic= uid;
c07a80fd 2736 if (!uic.uic$v_group)
2737 uic.uic$v_group= getgid();
748a9306 2738 if (valid_uic(uic))
2739 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
2740 else status = SS$_IVIDENT;
c07a80fd 2741 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
2742 status == RMS$_PRV) {
2743 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
2744 return NULL;
2745 }
2746 else { _ckvmssts(status); }
748a9306 2747 }
2748 __pw_namecache[lname]= '\0';
2749 _mystrtolower(__pw_namecache);
2750
2751 __pwdcache = __passwd_empty;
2752 __pwdcache.pw_name = __pw_namecache;
2753
2754/* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
2755 The identifier's value is usually the UIC, but it doesn't have to be,
2756 so if we can, we let fillpasswd update this. */
2757 __pwdcache.pw_uid = uic.uic$l_uic;
2758 __pwdcache.pw_gid = uic.uic$v_group;
2759
c07a80fd 2760 fillpasswd(__pw_namecache, &__pwdcache);
748a9306 2761 return &__pwdcache;
a0d0e21e 2762
748a9306 2763} /* end of my_getpwuid() */
2764/*}}}*/
2765
2766/*
2767 * Get information for next user.
2768*/
2769/*{{{struct passwd *my_getpwent()*/
2770struct passwd *my_getpwent()
2771{
2772 return (my_getpwuid((unsigned int) -1));
2773}
2774/*}}}*/
a0d0e21e 2775
748a9306 2776/*
2777 * Finish searching rights database for users.
2778*/
2779/*{{{void my_endpwent()*/
2780void my_endpwent()
2781{
2782 if (contxt) {
2783 _ckvmssts(sys$finish_rdb(&contxt));
2784 contxt= 0;
2785 }
a0d0e21e 2786}
2787/*}}}*/
748a9306 2788
e518068a 2789
2790/* my_gmtime
2791 * If the CRTL has a real gmtime(), use it, else look for the logical
2792 * name SYS$TIMEZONE_DIFFERENTIAL used by the native UTC routines on
2793 * VMS >= 6.0. Can be manually defined under earlier versions of VMS
2794 * to translate to the number of seconds which must be added to UTC
2795 * to get to the local time of the system.
2796 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
2797 */
2798
2799/*{{{struct tm *my_gmtime(const time_t *time)*/
2800/* We #defined 'gmtime' as 'my_gmtime' in vmsish.h. #undef it here
2801 * so we can call the CRTL's routine to see if it works.
2802 */
2803#undef gmtime
2804struct tm *
2805my_gmtime(const time_t *time)
2806{
2807 static int gmtime_emulation_type;
2808 static time_t utc_offset_secs;
2809 char *p;
2810 time_t when;
2811
2812 if (gmtime_emulation_type == 0) {
2813 gmtime_emulation_type++;
2814 when = 300000000;
2815 if (gmtime(&when) == NULL) { /* CRTL gmtime() is just a stub */
2816 gmtime_emulation_type++;
2817 if ((p = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL)
2818 gmtime_emulation_type++;
2819 else
2820 utc_offset_secs = (time_t) atol(p);
2821 }
2822 }
2823
2824 switch (gmtime_emulation_type) {
2825 case 1:
2826 return gmtime(time);
2827 case 2:
2828 when = *time - utc_offset_secs;
2829 return localtime(&when);
2830 default:
2831 warn("gmtime not supported on this system");
2832 return NULL;
2833 }
2834} /* end of my_gmtime() */
2835/* Reset definition for later calls */
2836#define gmtime(t) my_gmtime(t)
2837/*}}}*/
2838
2839
748a9306 2840/*
2841 * flex_stat, flex_fstat
2842 * basic stat, but gets it right when asked to stat
2843 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
2844 */
2845
2846/* encode_dev packs a VMS device name string into an integer to allow
2847 * simple comparisons. This can be used, for example, to check whether two
2848 * files are located on the same device, by comparing their encoded device
2849 * names. Even a string comparison would not do, because stat() reuses the
2850 * device name buffer for each call; so without encode_dev, it would be
2851 * necessary to save the buffer and use strcmp (this would mean a number of
2852 * changes to the standard Perl code, to say nothing of what a Perl script
2853 * would have to do.
2854 *
2855 * The device lock id, if it exists, should be unique (unless perhaps compared
2856 * with lock ids transferred from other nodes). We have a lock id if the disk is
2857 * mounted cluster-wide, which is when we tend to get long (host-qualified)
2858 * device names. Thus we use the lock id in preference, and only if that isn't
2859 * available, do we try to pack the device name into an integer (flagged by
2860 * the sign bit (LOCKID_MASK) being set).
2861 *
e518068a 2862 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
748a9306 2863 * name and its encoded form, but it seems very unlikely that we will find
2864 * two files on different disks that share the same encoded device names,
2865 * and even more remote that they will share the same file id (if the test
2866 * is to check for the same file).
2867 *
2868 * A better method might be to use sys$device_scan on the first call, and to
2869 * search for the device, returning an index into the cached array.
2870 * The number returned would be more intelligable.
2871 * This is probably not worth it, and anyway would take quite a bit longer
2872 * on the first call.
2873 */
2874#define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
2875static dev_t encode_dev (const char *dev)
2876{
2877 int i;
2878 unsigned long int f;
2879 dev_t enc;
2880 char c;
2881 const char *q;
2882
2883 if (!dev || !dev[0]) return 0;
2884
2885#if LOCKID_MASK
2886 {
2887 struct dsc$descriptor_s dev_desc;
2888 unsigned long int status, lockid, item = DVI$_LOCKID;
2889
2890 /* For cluster-mounted disks, the disk lock identifier is unique, so we
2891 can try that first. */
2892 dev_desc.dsc$w_length = strlen (dev);
2893 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
2894 dev_desc.dsc$b_class = DSC$K_CLASS_S;
2895 dev_desc.dsc$a_pointer = (char *) dev;
2896 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
2897 if (lockid) return (lockid & ~LOCKID_MASK);
2898 }
a0d0e21e 2899#endif
748a9306 2900
2901 /* Otherwise we try to encode the device name */
2902 enc = 0;
2903 f = 1;
2904 i = 0;
2905 for (q = dev + strlen(dev); q--; q >= dev) {
2906 if (isdigit (*q))
2907 c= (*q) - '0';
2908 else if (isalpha (toupper (*q)))
2909 c= toupper (*q) - 'A' + (char)10;
2910 else
2911 continue; /* Skip '$'s */
2912 i++;
2913 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
2914 if (i>1) f *= 36;
2915 enc += f * (unsigned long int) c;
2916 }
2917 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
2918
2919} /* end of encode_dev() */
2920
2921static char namecache[NAM$C_MAXRSS+1];
2922
2923static int
2924is_null_device(name)
2925 const char *name;
2926{
2927 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
2928 The underscore prefix, controller letter, and unit number are
2929 independently optional; for our purposes, the colon punctuation
2930 is not. The colon can be trailed by optional directory and/or
2931 filename, but two consecutive colons indicates a nodename rather
2932 than a device. [pr] */
2933 if (*name == '_') ++name;
2934 if (tolower(*name++) != 'n') return 0;
2935 if (tolower(*name++) != 'l') return 0;
2936 if (tolower(*name) == 'a') ++name;
2937 if (*name == '0') ++name;
2938 return (*name++ == ':') && (*name != ':');
2939}
2940
2941/* Do the permissions allow some operation? Assumes statcache already set. */
2942/* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
2943 * subset of the applicable information.
2944 */
2945/*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
2946I32
2947cando(I32 bit, I32 effective, struct stat *statbufp)
2948{
2949 if (statbufp == &statcache)
2950 return cando_by_name(bit,effective,namecache);
2951 else {
2952 char fname[NAM$C_MAXRSS+1];
2953 unsigned long int retsts;
2954 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
2955 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2956
2957 /* If the struct mystat is stale, we're OOL; stat() overwrites the
2958 device name on successive calls */
2959 devdsc.dsc$a_pointer = statbufp->st_devnam;
2960 devdsc.dsc$w_length = strlen(statbufp->st_devnam);
2961 namdsc.dsc$a_pointer = fname;
2962 namdsc.dsc$w_length = sizeof fname - 1;
2963
c07a80fd 2964 retsts = lib$fid_to_name(&devdsc,&(statbufp->st_ino),&namdsc,
748a9306 2965 &namdsc.dsc$w_length,0,0);
2966 if (retsts & 1) {
2967 fname[namdsc.dsc$w_length] = '\0';
2968 return cando_by_name(bit,effective,fname);
2969 }
2970 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
2971 warn("Can't get filespec - stale stat buffer?\n");
2972 return FALSE;
2973 }
2974 _ckvmssts(retsts);
2975 return FALSE; /* Should never get to here */
2976 }
e518068a 2977} /* end of cando() */
748a9306 2978/*}}}*/
2979
c07a80fd 2980
748a9306 2981/*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
2982I32
2983cando_by_name(I32 bit, I32 effective, char *fname)
2984{
2985 static char usrname[L_cuserid];
2986 static struct dsc$descriptor_s usrdsc =
2987 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
a5f75d66 2988 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
748a9306 2989 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
2990 unsigned short int retlen;
2991 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2992 union prvdef curprv;
2993 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
2994 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
2995 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
2996 {0,0,0,0}};
2997
2998 if (!fname || !*fname) return FALSE;
a5f75d66 2999 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
3000 retlen = namdsc.dsc$w_length = strlen(vmsname);
3001 namdsc.dsc$a_pointer = vmsname;
3002 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
3003 vmsname[retlen-1] == ':') {
3004 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
3005 namdsc.dsc$w_length = strlen(fileified);
3006 namdsc.dsc$a_pointer = fileified;
3007 }
3008
748a9306 3009 if (!usrdsc.dsc$w_length) {
3010 cuserid(usrname);
3011 usrdsc.dsc$w_length = strlen(usrname);
3012 }
a5f75d66 3013
748a9306 3014 switch (bit) {
3015 case S_IXUSR:
3016 case S_IXGRP:
3017 case S_IXOTH:
3018 access = ARM$M_EXECUTE;
3019 break;
3020 case S_IRUSR:
3021 case S_IRGRP:
3022 case S_IROTH:
3023 access = ARM$M_READ;
3024 break;
3025 case S_IWUSR:
3026 case S_IWGRP:
3027 case S_IWOTH:
3028 access = ARM$M_WRITE;
3029 break;
3030 case S_IDUSR:
3031 case S_IDGRP:
3032 case S_IDOTH:
3033 access = ARM$M_DELETE;
3034 break;
3035 default:
3036 return FALSE;
3037 }
3038
3039 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
e518068a 3040 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJ || retsts == RMS$_FNF ||
748a9306 3041 retsts == RMS$_DIR || retsts == RMS$_DEV) return FALSE;
3042 if (retsts == SS$_NORMAL) {
3043 if (!privused) return TRUE;
3044 /* We can get access, but only by using privs. Do we have the
3045 necessary privs currently enabled? */
3046 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
3047 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
c07a80fd 3048 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
3049 !curprv.prv$v_bypass) return FALSE;
3050 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
3051 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
748a9306 3052 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
3053 return TRUE;
3054 }
3055 _ckvmssts(retsts);
3056
3057 return FALSE; /* Should never get here */
3058
3059} /* end of cando_by_name() */
3060/*}}}*/
3061
3062
3063/*{{{ int flex_fstat(int fd, struct stat *statbuf)*/
3064int
3065flex_fstat(int fd, struct stat *statbuf)
3066{
3067 char fspec[NAM$C_MAXRSS+1];
3068
3069 if (!getname(fd,fspec,1)) return -1;
3070 return flex_stat(fspec,statbuf);
3071
3072} /* end of flex_fstat() */
3073/*}}}*/
3074
3075/*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/
e518068a 3076/* We defined 'stat' as 'mystat' in vmsish.h so that declarations of
3077 * 'struct stat' elsewhere in Perl would use our struct. We go back
3078 * to the system version here, since we're actually calling their
3079 * stat().
3080 */
3081#undef stat
748a9306 3082int
e518068a 3083flex_stat(char *fspec, struct mystat *statbufp)
748a9306 3084{
3085 char fileified[NAM$C_MAXRSS+1];
3086 int retval,myretval;
e518068a 3087 struct mystat tmpbuf;
748a9306 3088
3089
3090 if (statbufp == &statcache) do_tovmsspec(fspec,namecache,0);
3091 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
3092 memset(statbufp,0,sizeof *statbufp);
3093 statbufp->st_dev = encode_dev("_NLA0:");
3094 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
3095 statbufp->st_uid = 0x00010001;
3096 statbufp->st_gid = 0x0001;
3097 time((time_t *)&statbufp->st_mtime);
3098 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
3099 return 0;
3100 }
3101
748a9306 3102 if (do_fileify_dirspec(fspec,fileified,0) == NULL) myretval = -1;
3103 else {
3104 myretval = stat(fileified,(stat_t *) &tmpbuf);
3105 }
3106 retval = stat(fspec,(stat_t *) statbufp);
3107 if (!myretval) {
3108 if (retval == -1) {
3109 *statbufp = tmpbuf;
3110 retval = 0;
3111 }
3112 else if (!retval) { /* Dir with same name. Substitute it. */
3113 statbufp->st_mode &= ~S_IFDIR;
3114 statbufp->st_mode |= tmpbuf.st_mode & S_IFDIR;
3115 strcpy(namecache,fileified);
3116 }
3117 }
3118 if (!retval) statbufp->st_dev = encode_dev(statbufp->st_devnam);
3119 return retval;
3120
3121} /* end of flex_stat() */
e518068a 3122/* Reset definition for later calls */
3123#define stat mystat
748a9306 3124/*}}}*/
3125
c07a80fd 3126/*{{{char *my_getlogin()*/
3127/* VMS cuserid == Unix getlogin, except calling sequence */
3128char *
3129my_getlogin()
3130{
3131 static char user[L_cuserid];
3132 return cuserid(user);
3133}
3134/*}}}*/
3135
3136
a5f75d66 3137/* rmscopy - copy a file using VMS RMS routines
3138 *
3139 * Copies contents and attributes of spec_in to spec_out, except owner
3140 * and protection information. Name and type of spec_in are used as
3141 * defaults for spec_out. Returns 1 on success; returns 0 and sets
3142 * errno and vaxc$errno on failure.
3143 *
3144 * Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>.
3145 * Incorporates, with permission, some code from EZCOPY by Tim Adye
3146 * <T.J.Adye@rl.ac.uk>. Permission is given to use and distribute this
3147 * code under the same terms as Perl itself. (See the GNU General Public
3148 * License or the Perl Artistic License supplied as part of the Perl
3149 * distribution.)
3150 */
3151/*{{{int rmscopy(char *src, char *dst)*/
3152int
3153rmscopy(char *spec_in, char *spec_out)
3154{
3155 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
3156 rsa[NAM$C_MAXRSS], ubf[32256];
3157 unsigned long int i, sts, sts2;
3158 struct FAB fab_in, fab_out;
3159 struct RAB rab_in, rab_out;
3160 struct NAM nam;
3161 struct XABDAT xabdat;
3162 struct XABFHC xabfhc;
3163 struct XABRDT xabrdt;
3164 struct XABSUM xabsum;
3165
3166 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
3167 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
3168 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3169 return 0;
3170 }
3171
3172 fab_in = cc$rms_fab;
3173 fab_in.fab$l_fna = vmsin;
3174 fab_in.fab$b_fns = strlen(vmsin);
3175 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
3176 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
3177 fab_in.fab$l_fop = FAB$M_SQO;
3178 fab_in.fab$l_nam = &nam;
3179 fab_in.fab$l_xab = (void*) &xabdat;
3180
3181 nam = cc$rms_nam;
3182 nam.nam$l_rsa = rsa;
3183 nam.nam$b_rss = sizeof(rsa);
3184 nam.nam$l_esa = esa;
3185 nam.nam$b_ess = sizeof (esa);
3186 nam.nam$b_esl = nam.nam$b_rsl = 0;
3187
3188 xabdat = cc$rms_xabdat; /* To get creation date */
3189 xabdat.xab$l_nxt = (void*) &xabfhc;
3190
3191 xabfhc = cc$rms_xabfhc; /* To get record length */
3192 xabfhc.xab$l_nxt = (void*) &xabsum;
3193
3194 xabsum = cc$rms_xabsum; /* To get key and area information */
3195
3196 if (!((sts = sys$open(&fab_in)) & 1)) {
3197 set_vaxc_errno(sts);
3198 switch (sts) {
3199 case RMS$_FNF:
3200 case RMS$_DIR:
3201 set_errno(ENOENT); break;
3202 case RMS$_DEV:
3203 set_errno(ENODEV); break;
3204 case RMS$_SYN:
3205 set_errno(EINVAL); break;
3206 case RMS$_PRV:
3207 set_errno(EACCES); break;
3208 default:
3209 set_errno(EVMSERR);
3210 }
3211 return 0;
3212 }
3213
3214 fab_out = fab_in;
3215 fab_out.fab$w_ifi = 0;
3216 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
3217 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
3218 fab_out.fab$l_fop = FAB$M_SQO;
3219 fab_out.fab$l_fna = vmsout;
3220 fab_out.fab$b_fns = strlen(vmsout);
3221 fab_out.fab$l_dna = nam.nam$l_name;
3222 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
3223 if (!((sts = sys$create(&fab_out)) & 1)) {
3224 set_vaxc_errno(sts);
3225 switch (sts) {
3226 case RMS$_DIR:
3227 set_errno(ENOENT); break;
3228 case RMS$_DEV:
3229 set_errno(ENODEV); break;
3230 case RMS$_SYN:
3231 set_errno(EINVAL); break;
3232 case RMS$_PRV:
3233 set_errno(EACCES); break;
3234 default:
3235 set_errno(EVMSERR);
3236 }
3237 return 0;
3238 }
3239 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
3240 /* sys$close() will process xabrdt, not xabdat */
3241 xabrdt = cc$rms_xabrdt;
3242 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
3243 fab_out.fab$l_xab = &xabrdt;
3244
3245 rab_in = cc$rms_rab;
3246 rab_in.rab$l_fab = &fab_in;
3247 rab_in.rab$l_rop = RAB$M_BIO;
3248 rab_in.rab$l_ubf = ubf;
3249 rab_in.rab$w_usz = sizeof ubf;
3250 if (!((sts = sys$connect(&rab_in)) & 1)) {
3251 sys$close(&fab_in); sys$close(&fab_out);
3252 set_errno(EVMSERR); set_vaxc_errno(sts);
3253 return 0;
3254 }
3255
3256 rab_out = cc$rms_rab;
3257 rab_out.rab$l_fab = &fab_out;
3258 rab_out.rab$l_rbf = ubf;
3259 if (!((sts = sys$connect(&rab_out)) & 1)) {
3260 sys$close(&fab_in); sys$close(&fab_out);
3261 set_errno(EVMSERR); set_vaxc_errno(sts);
3262 return 0;
3263 }
3264
3265 while ((sts = sys$read(&rab_in))) { /* always true */
3266 if (sts == RMS$_EOF) break;
3267 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
3268 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
3269 sys$close(&fab_in); sys$close(&fab_out);
3270 set_errno(EVMSERR); set_vaxc_errno(sts);
3271 return 0;
3272 }
3273 }
3274
3275 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
3276 sys$close(&fab_in); sys$close(&fab_out);
3277 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
3278 if (!(sts & 1)) {
3279 set_errno(EVMSERR); set_vaxc_errno(sts);
3280 return 0;
3281 }
3282
3283 return 1;
3284
3285} /* end of rmscopy() */
3286/*}}}*/
3287
3288
748a9306 3289/*** The following glue provides 'hooks' to make some of the routines
3290 * from this file available from Perl. These routines are sufficiently
3291 * basic, and are required sufficiently early in the build process,
3292 * that's it's nice to have them available to miniperl as well as the
3293 * full Perl, so they're set up here instead of in an extension. The
3294 * Perl code which handles importation of these names into a given
3295 * package lives in [.VMS]Filespec.pm in @INC.
3296 */
3297
3298void
3299vmsify_fromperl(CV *cv)
3300{
3301 dXSARGS;
3302 char *vmsified;
3303
3304 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
3305 vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
3306 ST(0) = sv_newmortal();
3307 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
3308 XSRETURN(1);
3309}
3310
3311void
3312unixify_fromperl(CV *cv)
3313{
3314 dXSARGS;
3315 char *unixified;
3316
3317 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
3318 unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
3319 ST(0) = sv_newmortal();
3320 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
3321 XSRETURN(1);
3322}
3323
3324void
3325fileify_fromperl(CV *cv)
3326{
3327 dXSARGS;
3328 char *fileified;
3329
3330 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
3331 fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
3332 ST(0) = sv_newmortal();
3333 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
3334 XSRETURN(1);
3335}
3336
3337void
3338pathify_fromperl(CV *cv)
3339{
3340 dXSARGS;
3341 char *pathified;
3342
3343 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
3344 pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
3345 ST(0) = sv_newmortal();
3346 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
3347 XSRETURN(1);
3348}
3349
3350void
3351vmspath_fromperl(CV *cv)
3352{
3353 dXSARGS;
3354 char *vmspath;
3355
3356 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
3357 vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
3358 ST(0) = sv_newmortal();
3359 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
3360 XSRETURN(1);
3361}
3362
3363void
3364unixpath_fromperl(CV *cv)
3365{
3366 dXSARGS;
3367 char *unixpath;
3368
3369 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
3370 unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
3371 ST(0) = sv_newmortal();
3372 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
3373 XSRETURN(1);
3374}
3375
3376void
3377candelete_fromperl(CV *cv)
3378{
3379 dXSARGS;
a5f75d66 3380 char fspec[NAM$C_MAXRSS+1], *fsp;
3381 SV *mysv;
3382 IO *io;
748a9306 3383
3384 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
a5f75d66 3385
3386 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
3387 if (SvTYPE(mysv) == SVt_PVGV) {
3388 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec)) {
3389 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3390 ST(0) = &sv_no;
3391 XSRETURN(1);
3392 }
3393 fsp = fspec;
3394 }
3395 else {
3396 if (mysv != ST(0) || !(fsp = SvPV(mysv,na)) || !*fsp) {
3397 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3398 ST(0) = &sv_no;
3399 XSRETURN(1);
3400 }
3401 }
3402
3403 ST(0) = cando_by_name(S_IDUSR,0,fsp) ? &sv_yes : &sv_no;
3404 XSRETURN(1);
3405}
3406
3407void
3408rmscopy_fromperl(CV *cv)
3409{
3410 dXSARGS;
3411 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
3412 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3413 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3414 unsigned long int sts;
3415 SV *mysv;
3416 IO *io;
3417
3418 if (items != 2) croak("Usage: File::Copy::rmscopy(from,to)");
3419
3420 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
3421 if (SvTYPE(mysv) == SVt_PVGV) {
3422 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec)) {
3423 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3424 ST(0) = &sv_no;
3425 XSRETURN(1);
3426 }
3427 inp = inspec;
3428 }
3429 else {
3430 if (mysv != ST(0) || !(inp = SvPV(mysv,na)) || !*inp) {
3431 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3432 ST(0) = &sv_no;
3433 XSRETURN(1);
3434 }
3435 }
3436 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
3437 if (SvTYPE(mysv) == SVt_PVGV) {
3438 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec)) {
3439 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3440 ST(0) = &sv_no;
3441 XSRETURN(1);
3442 }
3443 outp = outspec;
3444 }
3445 else {
3446 if (mysv != ST(1) || !(outp = SvPV(mysv,na)) || !*outp) {
3447 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3448 ST(0) = &sv_no;
3449 XSRETURN(1);
3450 }
3451 }
3452
3453 ST(0) = rmscopy(inp,outp) ? &sv_yes : &sv_no;
748a9306 3454 XSRETURN(1);
3455}
3456
3457void
3458init_os_extras()
3459{
3460 char* file = __FILE__;
3461
a5f75d66 3462 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
3463 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
3464 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
3465 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
3466 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
3467 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
3468 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
3469 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
748a9306 3470 return;
3471}
3472
3473/* End of vms.c */
Unnamed repository; edit this file to name it for gitweb.