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