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