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