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