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