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