projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
perl 5.002beta2 patch: toke.c
[p5sagit/p5-mst-13.2.git] / vms / vms.c
CommitLineData
748a9306 1/* vms.c
a0d0e21e 2 *
748a9306 3 * VMS-specific routines for perl5
4 *
e518068a 5 * Last revised: 22-Nov-1995 by Charles Bailey bailey@genetics.upenn.edu
6 * Version: 5.2.0
a0d0e21e 7 */
8
9#include <acedef.h>
10#include <acldef.h>
11#include <armdef.h>
748a9306 12#include <atrdef.h>
a0d0e21e 13#include <chpdef.h>
14#include <descrip.h>
15#include <dvidef.h>
748a9306 16#include <fibdef.h>
a0d0e21e 17#include <float.h>
18#include <fscndef.h>
19#include <iodef.h>
20#include <jpidef.h>
21#include <libdef.h>
22#include <lib$routines.h>
23#include <lnmdef.h>
748a9306 24#include <prvdef.h>
a0d0e21e 25#include <psldef.h>
26#include <rms.h>
27#include <shrdef.h>
28#include <ssdef.h>
29#include <starlet.h>
30#include <stsdef.h>
31#include <syidef.h>
748a9306 32#include <uaidef.h>
33#include <uicdef.h>
a0d0e21e 34
35#include "EXTERN.h"
36#include "perl.h"
748a9306 37#include "XSUB.h"
a0d0e21e 38
39struct itmlst_3 {
40 unsigned short int buflen;
41 unsigned short int itmcode;
42 void *bufadr;
748a9306 43 unsigned short int *retlen;
a0d0e21e 44};
45
748a9306 46static char *
47my_trnlnm(char *lnm, char *eqv)
48{
49 static char __my_trnlnm_eqv[LNM$C_NAMLENGTH+1];
50 unsigned short int eqvlen;
51 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
52 $DESCRIPTOR(tabdsc,"LNM$FILE_DEV");
53 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
54 struct itmlst_3 lnmlst[2] = {{LNM$C_NAMLENGTH, LNM$_STRING,0, &eqvlen},
55 {0, 0, 0, 0}};
56
57 if (!eqv) eqv = __my_trnlnm_eqv;
58 lnmlst[0].bufadr = (void *)eqv;
59 lnmdsc.dsc$a_pointer = lnm;
60 lnmdsc.dsc$w_length = strlen(lnm);
61 retsts = sys$trnlnm(&attr,&tabdsc,&lnmdsc,0,lnmlst);
62 if (retsts == SS$_NOLOGNAM || retsts == SS$_IVLOGNAM) return Nullch;
63 else if (retsts & 1) {
64 eqv[eqvlen] = '\0';
65 return eqv;
66 }
67 _ckvmssts(retsts); /* Must be an error */
68 return Nullch; /* Not reached, assuming _ckvmssts() bails out */
69}
a0d0e21e 70
71/* my_getenv
72 * Translate a logical name. Substitute for CRTL getenv() to avoid
73 * memory leak, and to keep my_getenv() and my_setenv() in the same
74 * domain (mostly - my_getenv() need not return a translation from
75 * the process logical name table)
76 *
77 * Note: Uses static buffer -- not thread-safe!
78 */
79/*{{{ char *my_getenv(char *lnm)*/
80char *
81my_getenv(char *lnm)
82{
83 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
84 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
a0d0e21e 85
86 for (cp1 = lnm, cp2= uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
87 *cp2 = '\0';
748a9306 88 if (cp1 - lnm == 7 && !strncmp(uplnm,"DEFAULT",7)) {
89 getcwd(__my_getenv_eqv,sizeof __my_getenv_eqv);
90 return __my_getenv_eqv;
91 }
92 else if (my_trnlnm(uplnm,__my_getenv_eqv) != NULL) {
a0d0e21e 93 return __my_getenv_eqv;
94 }
95 else {
748a9306 96 unsigned long int retsts;
97 struct dsc$descriptor_s symdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
98 valdsc = {sizeof __my_getenv_eqv,DSC$K_DTYPE_T,
99 DSC$K_CLASS_S, __my_getenv_eqv};
100 symdsc.dsc$w_length = cp1 - lnm;
101 symdsc.dsc$a_pointer = uplnm;
102 retsts = lib$get_symbol(&symdsc,&valdsc,&(valdsc.dsc$w_length),0);
103 if (retsts == LIB$_INVSYMNAM) return Nullch;
104 if (retsts != LIB$_NOSUCHSYM) {
105 /* We want to return only logical names or CRTL Unix emulations */
106 if (retsts & 1) return Nullch;
107 _ckvmssts(retsts);
a0d0e21e 108 }
748a9306 109 else return getenv(lnm); /* Try for CRTL emulation of a Unix/POSIX name */
a0d0e21e 110 }
748a9306 111 return Nullch;
a0d0e21e 112
113} /* end of my_getenv() */
114/*}}}*/
115
116/*{{{ void my_setenv(char *lnm, char *eqv)*/
117void
118my_setenv(char *lnm,char *eqv)
119/* Define a supervisor-mode logical name in the process table.
120 * In the future we'll add tables, attribs, and acmodes,
121 * probably through a different call.
122 */
123{
124 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
125 unsigned long int retsts, usermode = PSL$C_USER;
126 $DESCRIPTOR(tabdsc,"LNM$PROCESS");
127 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
128 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
129
130 for(cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
131 lnmdsc.dsc$w_length = cp1 - lnm;
132
133 if (!eqv || !*eqv) { /* we're deleting a logical name */
134 retsts = sys$dellnm(&tabdsc,&lnmdsc,&usermode); /* try user mode first */
748a9306 135 if (retsts == SS$_IVLOGNAM) return;
136 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
a0d0e21e 137 if (!(retsts & 1)) {
138 retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */
748a9306 139 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
a0d0e21e 140 }
141 }
142 else {
143 eqvdsc.dsc$w_length = strlen(eqv);
144 eqvdsc.dsc$a_pointer = eqv;
145
748a9306 146 _ckvmssts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0));
a0d0e21e 147 }
148
149} /* end of my_setenv() */
150/*}}}*/
151
152static char *do_fileify_dirspec(char *, char *, int);
153static char *do_tovmsspec(char *, char *, int);
154
155/*{{{int do_rmdir(char *name)*/
156int
157do_rmdir(char *name)
158{
159 char dirfile[NAM$C_MAXRSS+1];
160 int retval;
748a9306 161 struct stat st;
a0d0e21e 162
163 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
164 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
165 else retval = kill_file(dirfile);
166 return retval;
167
168} /* end of do_rmdir */
169/*}}}*/
170
171/* kill_file
172 * Delete any file to which user has control access, regardless of whether
173 * delete access is explicitly allowed.
174 * Limitations: User must have write access to parent directory.
175 * Does not block signals or ASTs; if interrupted in midstream
176 * may leave file with an altered ACL.
177 * HANDLE WITH CARE!
178 */
179/*{{{int kill_file(char *name)*/
180int
181kill_file(char *name)
182{
183 char vmsname[NAM$C_MAXRSS+1];
184 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
748a9306 185 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
a0d0e21e 186 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
187 struct myacedef {
748a9306 188 unsigned char myace$b_length;
189 unsigned char myace$b_type;
190 unsigned short int myace$w_flags;
191 unsigned long int myace$l_access;
192 unsigned long int myace$l_ident;
a0d0e21e 193 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
194 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
195 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
196 struct itmlst_3
748a9306 197 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
198 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
199 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
200 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
201 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
202 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
a0d0e21e 203
204 if (!remove(name)) return 0; /* Can we just get rid of it? */
205
206 /* No, so we get our own UIC to use as a rights identifier,
207 * and the insert an ACE at the head of the ACL which allows us
208 * to delete the file.
209 */
748a9306 210 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
a0d0e21e 211 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
212 fildsc.dsc$w_length = strlen(vmsname);
213 fildsc.dsc$a_pointer = vmsname;
214 cxt = 0;
748a9306 215 newace.myace$l_ident = oldace.myace$l_ident;
a0d0e21e 216 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
748a9306 217 set_errno(EVMSERR);
218 set_vaxc_errno(aclsts);
a0d0e21e 219 return -1;
220 }
221 /* Grab any existing ACEs with this identifier in case we fail */
222 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
e518068a 223 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
224 || fndsts == SS$_NOMOREACE ) {
a0d0e21e 225 /* Add the new ACE . . . */
226 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
227 goto yourroom;
748a9306 228 if ((rmsts = remove(name))) {
a0d0e21e 229 /* We blew it - dir with files in it, no write priv for
230 * parent directory, etc. Put things back the way they were. */
231 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
232 goto yourroom;
233 if (fndsts & 1) {
234 addlst[0].bufadr = &oldace;
235 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
236 goto yourroom;
237 }
238 }
239 }
240
241 yourroom:
242 if (rmsts) {
243 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
244 if (aclsts & 1) aclsts = fndsts;
245 }
246 if (!(aclsts & 1)) {
748a9306 247 set_errno(EVMSERR);
248 set_vaxc_errno(aclsts);
a0d0e21e 249 return -1;
250 }
251
252 return rmsts;
253
254} /* end of kill_file() */
255/*}}}*/
256
748a9306 257/* my_utime - update modification time of a file
258 * calling sequence is identical to POSIX utime(), but under
259 * VMS only the modification time is changed; ODS-2 does not
260 * maintain access times. Restrictions differ from the POSIX
261 * definition in that the time can be changed as long as the
262 * caller has permission to execute the necessary IO$_MODIFY $QIO;
263 * no separate checks are made to insure that the caller is the
264 * owner of the file or has special privs enabled.
265 * Code here is based on Joe Meadows' FILE utility.
266 */
267
268/* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
269 * to VMS epoch (01-JAN-1858 00:00:00.00)
270 * in 100 ns intervals.
271 */
272static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
273
274/*{{{int my_utime(char *path, struct utimbuf *utimes)*/
275int my_utime(char *file, struct utimbuf *utimes)
276{
277 register int i;
278 long int bintime[2], len = 2, lowbit, unixtime,
279 secscale = 10000000; /* seconds --> 100 ns intervals */
280 unsigned long int chan, iosb[2], retsts;
281 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
282 struct FAB myfab = cc$rms_fab;
283 struct NAM mynam = cc$rms_nam;
4633a7c4 284#if defined (__DECC) && defined (__VAX)
285 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
286 * at least through VMS V6.1, which causes a type-conversion warning.
287 */
288# pragma message save
289# pragma message disable cvtdiftypes
290#endif
748a9306 291 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
292 struct fibdef myfib;
4633a7c4 293#if defined (__DECC) && defined (__VAX)
294 /* This should be right after the declaration of myatr, but due
295 * to a bug in VAX DEC C, this takes effect a statement early.
296 */
297# pragma message restore
298#endif
748a9306 299 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
300 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
301 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
302
303 if (file == NULL || *file == '\0') {
304 set_errno(ENOENT);
305 set_vaxc_errno(LIB$_INVARG);
306 return -1;
307 }
e518068a 308 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
748a9306 309
310 if (utimes != NULL) {
311 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
312 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
313 * Since time_t is unsigned long int, and lib$emul takes a signed long int
314 * as input, we force the sign bit to be clear by shifting unixtime right
315 * one bit, then multiplying by an extra factor of 2 in lib$emul().
316 */
317 lowbit = (utimes->modtime & 1) ? secscale : 0;
318 unixtime = (long int) utimes->modtime;
319 unixtime >> 1; secscale << 1;
320 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
321 if (!(retsts & 1)) {
322 set_errno(EVMSERR);
323 set_vaxc_errno(retsts);
324 return -1;
325 }
326 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
327 if (!(retsts & 1)) {
328 set_errno(EVMSERR);
329 set_vaxc_errno(retsts);
330 return -1;
331 }
332 }
333 else {
334 /* Just get the current time in VMS format directly */
335 retsts = sys$gettim(bintime);
336 if (!(retsts & 1)) {
337 set_errno(EVMSERR);
338 set_vaxc_errno(retsts);
339 return -1;
340 }
341 }
342
343 myfab.fab$l_fna = vmsspec;
344 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
345 myfab.fab$l_nam = &mynam;
346 mynam.nam$l_esa = esa;
347 mynam.nam$b_ess = (unsigned char) sizeof esa;
348 mynam.nam$l_rsa = rsa;
349 mynam.nam$b_rss = (unsigned char) sizeof rsa;
350
351 /* Look for the file to be affected, letting RMS parse the file
352 * specification for us as well. I have set errno using only
353 * values documented in the utime() man page for VMS POSIX.
354 */
355 retsts = sys$parse(&myfab,0,0);
356 if (!(retsts & 1)) {
357 set_vaxc_errno(retsts);
358 if (retsts == RMS$_PRV) set_errno(EACCES);
359 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
360 else set_errno(EVMSERR);
361 return -1;
362 }
363 retsts = sys$search(&myfab,0,0);
364 if (!(retsts & 1)) {
365 set_vaxc_errno(retsts);
366 if (retsts == RMS$_PRV) set_errno(EACCES);
367 else if (retsts == RMS$_FNF) set_errno(ENOENT);
368 else set_errno(EVMSERR);
369 return -1;
370 }
371
372 devdsc.dsc$w_length = mynam.nam$b_dev;
373 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
374
375 retsts = sys$assign(&devdsc,&chan,0,0);
376 if (!(retsts & 1)) {
377 set_vaxc_errno(retsts);
378 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
379 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
380 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
381 else set_errno(EVMSERR);
382 return -1;
383 }
384
385 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
386 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
387
388 memset((void *) &myfib, 0, sizeof myfib);
389#ifdef __DECC
390 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
391 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
392 /* This prevents the revision time of the file being reset to the current
393 * time as a reqult of our IO$_MODIFY $QIO. */
394 myfib.fib$l_acctl = FIB$M_NORECORD;
395#else
396 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
397 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
398 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
399#endif
400 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
401 if (retsts & 1) retsts = iosb[0];
402 if (!(retsts & 1)) {
403 set_vaxc_errno(retsts);
404 if (retsts == SS$_NOPRIV) set_errno(EACCES);
405 else set_errno(EVMSERR);
406 return -1;
407 }
408
409 return 0;
410} /* end of my_utime() */
411/*}}}*/
412
a0d0e21e 413static void
414create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
415{
416 static unsigned long int mbxbufsiz;
417 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
418
419 if (!mbxbufsiz) {
420 /*
421 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
422 * preprocessor consant BUFSIZ from stdio.h as the size of the
423 * 'pipe' mailbox.
424 */
748a9306 425 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
a0d0e21e 426 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
427 }
748a9306 428 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
a0d0e21e 429
748a9306 430 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
a0d0e21e 431 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
432
433} /* end of create_mbx() */
434
435/*{{{ my_popen and my_pclose*/
436struct pipe_details
437{
438 struct pipe_details *next;
748a9306 439 FILE *fp; /* stdio file pointer to pipe mailbox */
440 int pid; /* PID of subprocess */
441 int mode; /* == 'r' if pipe open for reading */
442 int done; /* subprocess has completed */
443 unsigned long int completion; /* termination status of subprocess */
a0d0e21e 444};
445
748a9306 446struct exit_control_block
447{
448 struct exit_control_block *flink;
449 unsigned long int (*exit_routine)();
450 unsigned long int arg_count;
451 unsigned long int *status_address;
452 unsigned long int exit_status;
453};
454
a0d0e21e 455static struct pipe_details *open_pipes = NULL;
456static $DESCRIPTOR(nl_desc, "NL:");
457static int waitpid_asleep = 0;
458
748a9306 459static unsigned long int
460pipe_exit_routine()
461{
462 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT, sts;
463
464 while (open_pipes != NULL) {
465 if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/
466 _ckvmssts(sys$forcex(&open_pipes->pid,0,&abort));
467 sleep(1);
468 }
469 if (!open_pipes->done) /* We tried to be nice . . . */
470 _ckvmssts(sys$delprc(&open_pipes->pid,0));
471 if (!((sts = my_pclose(open_pipes->fp))&1)) retsts = sts;
472 }
473 return retsts;
474}
475
476static struct exit_control_block pipe_exitblock =
477 {(struct exit_control_block *) 0,
478 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
479
480
a0d0e21e 481static void
748a9306 482popen_completion_ast(struct pipe_details *thispipe)
a0d0e21e 483{
748a9306 484 thispipe->done = TRUE;
a0d0e21e 485 if (waitpid_asleep) {
486 waitpid_asleep = 0;
487 sys$wake(0,0);
488 }
489}
490
491/*{{{ FILE *my_popen(char *cmd, char *mode)*/
492FILE *
493my_popen(char *cmd, char *mode)
494{
748a9306 495 static int handler_set_up = FALSE;
a0d0e21e 496 char mbxname[64];
497 unsigned short int chan;
498 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
499 struct pipe_details *info;
500 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
501 DSC$K_CLASS_S, mbxname},
502 cmddsc = {0, DSC$K_DTYPE_T,
503 DSC$K_CLASS_S, 0};
504
505
506 New(7001,info,1,struct pipe_details);
507
a0d0e21e 508 /* create mailbox */
509 create_mbx(&chan,&namdsc);
510
511 /* open a FILE* onto it */
512 info->fp=fopen(mbxname, mode);
513
514 /* give up other channel onto it */
748a9306 515 _ckvmssts(sys$dassgn(chan));
a0d0e21e 516
517 if (!info->fp)
518 return Nullfp;
519
520 cmddsc.dsc$w_length=strlen(cmd);
521 cmddsc.dsc$a_pointer=cmd;
522
748a9306 523 info->mode = *mode;
524 info->done = FALSE;
525 info->completion=0;
526
527 if (*mode == 'r') {
528 _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
a0d0e21e 529 0 /* name */, &info->pid, &info->completion,
748a9306 530 0, popen_completion_ast,info,0,0,0));
a0d0e21e 531 }
532 else {
748a9306 533 _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
534 0 /* name */, &info->pid, &info->completion,
535 0, popen_completion_ast,info,0,0,0));
a0d0e21e 536 }
537
748a9306 538 if (!handler_set_up) {
539 _ckvmssts(sys$dclexh(&pipe_exitblock));
540 handler_set_up = TRUE;
541 }
a0d0e21e 542 info->next=open_pipes; /* prepend to list */
543 open_pipes=info;
544
e518068a 545 forkprocess = info->pid;
a0d0e21e 546 return info->fp;
547}
548/*}}}*/
549
550/*{{{ I32 my_pclose(FILE *fp)*/
551I32 my_pclose(FILE *fp)
552{
553 struct pipe_details *info, *last = NULL;
748a9306 554 unsigned long int retsts;
a0d0e21e 555
556 for (info = open_pipes; info != NULL; last = info, info = info->next)
557 if (info->fp == fp) break;
558
559 if (info == NULL)
560 /* get here => no such pipe open */
748a9306 561 croak("No such pipe open");
562
563 if (info->done) retsts = info->completion;
564 else waitpid(info->pid,(int *) &retsts,0);
a0d0e21e 565
a0d0e21e 566 fclose(info->fp);
748a9306 567
a0d0e21e 568 /* remove from list of open pipes */
569 if (last) last->next = info->next;
570 else open_pipes = info->next;
a0d0e21e 571 Safefree(info);
572
573 return retsts;
748a9306 574
a0d0e21e 575} /* end of my_pclose() */
576
a0d0e21e 577/* sort-of waitpid; use only with popen() */
578/*{{{unsigned long int waitpid(unsigned long int pid, int *statusp, int flags)*/
579unsigned long int
580waitpid(unsigned long int pid, int *statusp, int flags)
581{
582 struct pipe_details *info;
a0d0e21e 583
584 for (info = open_pipes; info != NULL; info = info->next)
585 if (info->pid == pid) break;
586
587 if (info != NULL) { /* we know about this child */
748a9306 588 while (!info->done) {
a0d0e21e 589 waitpid_asleep = 1;
590 sys$hiber();
591 }
592
593 *statusp = info->completion;
594 return pid;
595 }
596 else { /* we haven't heard of this child */
597 $DESCRIPTOR(intdsc,"0 00:00:01");
598 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
748a9306 599 unsigned long int interval[2],sts;
a0d0e21e 600
748a9306 601 if (dowarn) {
602 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
603 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
604 if (ownerpid != mypid)
605 warn("pid %d not a child",pid);
606 }
a0d0e21e 607
748a9306 608 _ckvmssts(sys$bintim(&intdsc,interval));
a0d0e21e 609 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
748a9306 610 _ckvmssts(sys$schdwk(0,0,interval,0));
611 _ckvmssts(sys$hiber());
a0d0e21e 612 }
748a9306 613 _ckvmssts(sts);
a0d0e21e 614
615 /* There's no easy way to find the termination status a child we're
616 * not aware of beforehand. If we're really interested in the future,
617 * we can go looking for a termination mailbox, or chase after the
618 * accounting record for the process.
619 */
620 *statusp = 0;
621 return pid;
622 }
623
624} /* end of waitpid() */
a0d0e21e 625/*}}}*/
626/*}}}*/
627/*}}}*/
628
629/*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
630char *
631my_gconvert(double val, int ndig, int trail, char *buf)
632{
633 static char __gcvtbuf[DBL_DIG+1];
634 char *loc;
635
636 loc = buf ? buf : __gcvtbuf;
637 if (val) {
638 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
639 return gcvt(val,ndig,loc);
640 }
641 else {
642 loc[0] = '0'; loc[1] = '\0';
643 return loc;
644 }
645
646}
647/*}}}*/
648
649/*
650** The following routines are provided to make life easier when
651** converting among VMS-style and Unix-style directory specifications.
652** All will take input specifications in either VMS or Unix syntax. On
653** failure, all return NULL. If successful, the routines listed below
748a9306 654** return a pointer to a buffer containing the appropriately
a0d0e21e 655** reformatted spec (and, therefore, subsequent calls to that routine
656** will clobber the result), while the routines of the same names with
657** a _ts suffix appended will return a pointer to a mallocd string
658** containing the appropriately reformatted spec.
659** In all cases, only explicit syntax is altered; no check is made that
660** the resulting string is valid or that the directory in question
661** actually exists.
662**
663** fileify_dirspec() - convert a directory spec into the name of the
664** directory file (i.e. what you can stat() to see if it's a dir).
665** The style (VMS or Unix) of the result is the same as the style
666** of the parameter passed in.
667** pathify_dirspec() - convert a directory spec into a path (i.e.
668** what you prepend to a filename to indicate what directory it's in).
669** The style (VMS or Unix) of the result is the same as the style
670** of the parameter passed in.
671** tounixpath() - convert a directory spec into a Unix-style path.
672** tovmspath() - convert a directory spec into a VMS-style path.
673** tounixspec() - convert any file spec into a Unix-style file spec.
674** tovmsspec() - convert any file spec into a VMS-style spec.
e518068a 675**
676** Copyright 1995 by Charles Bailey <bailey@genetics.upenn.edu>
677** Permission is given for non-commercial use of this code according
678** to the terms of the GNU General Public License or the Perl
679** Artistic License. Copies of each may be found in the Perl
680** standard distribution. This software is supplied without any
681** warranty whatsoever.
a0d0e21e 682 */
683
748a9306 684static char *do_tounixspec(char *, char *, int);
685
a0d0e21e 686/*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
687static char *do_fileify_dirspec(char *dir,char *buf,int ts)
688{
689 static char __fileify_retbuf[NAM$C_MAXRSS+1];
690 unsigned long int dirlen, retlen, addmfd = 0;
691 char *retspec, *cp1, *cp2, *lastdir;
748a9306 692 char trndir[NAM$C_MAXRSS+1], vmsdir[NAM$C_MAXRSS+1];
a0d0e21e 693
694 if (dir == NULL) return NULL;
a0d0e21e 695 dirlen = strlen(dir);
e518068a 696 if (dir[dirlen-1] == '/') dir[--dirlen] = '\0';
697 if (!strpbrk(dir+1,"/]>:")) {
698 strcpy(trndir,*dir == '/' ? dir + 1: dir);
699 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir) != NULL) ;
700 dir = trndir;
701 dirlen = strlen(dir);
702 }
703
a0d0e21e 704 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
748a9306 705 if (dir[0] == '.') {
706 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
707 return do_fileify_dirspec("[]",buf,ts);
708 else if (dir[1] == '.' &&
709 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
710 return do_fileify_dirspec("[-]",buf,ts);
711 }
a0d0e21e 712 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
713 dirlen -= 1; /* to last element */
714 lastdir = strrchr(dir,'/');
715 }
4633a7c4 716 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
717 do {
718 if (*(cp1+2) == '.') cp1++;
719 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
720 addmfd = 1;
721 break;
722 }
723 cp1++;
724 } while ((cp1 = strstr(cp1,"/.")) != NULL);
725 /* If we have a relative path, VMSify it and let the VMS code
726 * below expand it, rather than repeating the code here */
727 if (addmfd) {
728 if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL;
729 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
730 return do_tounixspec(trndir,buf,ts);
731 }
748a9306 732 }
a0d0e21e 733 else {
734 if (!(lastdir = cp1 = strrchr(dir,'/'))) cp1 = dir;
735 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
736 if (toupper(*(cp2+1)) == 'D' && /* Yep. Is it .dir? */
737 toupper(*(cp2+2)) == 'I' &&
738 toupper(*(cp2+3)) == 'R') {
739 if ((cp1 = strchr(cp2,';')) || (cp1 = strchr(cp2+1,'.'))) {
740 if (*(cp1+1) != '1' || *(cp1+2) != '\0') { /* Version is not ;1 */
748a9306 741 set_errno(ENOTDIR); /* Bzzt. */
742 set_vaxc_errno(RMS$_DIR);
a0d0e21e 743 return NULL;
744 }
745 }
746 dirlen = cp2 - dir;
747 }
748 else { /* There's a type, and it's not .dir. Bzzt. */
748a9306 749 set_errno(ENOTDIR);
750 set_vaxc_errno(RMS$_DIR);
a0d0e21e 751 return NULL;
752 }
753 }
748a9306 754 }
755 /* If we lead off with a device or rooted logical, add the MFD
756 if we're specifying a top-level directory. */
757 if (lastdir && *dir == '/') {
758 addmfd = 1;
759 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
760 if (*cp1 == '/') {
761 addmfd = 0;
762 break;
a0d0e21e 763 }
764 }
748a9306 765 }
4633a7c4 766 retlen = dirlen + (addmfd ? 13 : 6);
748a9306 767 if (buf) retspec = buf;
e518068a 768 else if (ts) New(7009,retspec,retlen+1,char);
748a9306 769 else retspec = __fileify_retbuf;
770 if (addmfd) {
771 dirlen = lastdir - dir;
772 memcpy(retspec,dir,dirlen);
773 strcpy(&retspec[dirlen],"/000000");
774 strcpy(&retspec[dirlen+7],lastdir);
775 }
776 else {
777 memcpy(retspec,dir,dirlen);
778 retspec[dirlen] = '\0';
a0d0e21e 779 }
780 /* We've picked up everything up to the directory file name.
781 Now just add the type and version, and we're set. */
782 strcat(retspec,".dir;1");
783 return retspec;
784 }
785 else { /* VMS-style directory spec */
786 char esa[NAM$C_MAXRSS+1], term;
e518068a 787 unsigned long int sts, cmplen, hasdev, hasdir, hastype, hasver;
a0d0e21e 788 struct FAB dirfab = cc$rms_fab;
789 struct NAM savnam, dirnam = cc$rms_nam;
790
791 dirfab.fab$b_fns = strlen(dir);
792 dirfab.fab$l_fna = dir;
793 dirfab.fab$l_nam = &dirnam;
748a9306 794 dirfab.fab$l_dna = ".DIR;1";
795 dirfab.fab$b_dns = 6;
a0d0e21e 796 dirnam.nam$b_ess = NAM$C_MAXRSS;
797 dirnam.nam$l_esa = esa;
e518068a 798 if (!((sts = sys$parse(&dirfab))&1)) {
799 if (dirfab.fab$l_sts == RMS$_DIR) {
800 dirnam.nam$b_nop |= NAM$M_SYNCHK;
801 sts = sys$parse(&dirfab) & 1;
802 }
803 if (!sts) {
748a9306 804 set_errno(EVMSERR);
805 set_vaxc_errno(dirfab.fab$l_sts);
a0d0e21e 806 return NULL;
807 }
e518068a 808 }
809 else {
810 savnam = dirnam;
811 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
812 /* Yes; fake the fnb bits so we'll check type below */
813 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
814 }
815 else {
816 if (dirfab.fab$l_sts != RMS$_FNF) {
817 set_errno(EVMSERR);
818 set_vaxc_errno(dirfab.fab$l_sts);
819 return NULL;
820 }
821 dirnam = savnam; /* No; just work with potential name */
822 }
a0d0e21e 823 }
748a9306 824 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
825 cp1 = strchr(esa,']');
826 if (!cp1) cp1 = strchr(esa,'>');
827 if (cp1) { /* Should always be true */
828 dirnam.nam$b_esl -= cp1 - esa - 1;
829 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
830 }
831 }
a0d0e21e 832 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
833 /* Yep; check version while we're at it, if it's there. */
834 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
835 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
836 /* Something other than .DIR[;1]. Bzzt. */
748a9306 837 set_errno(ENOTDIR);
838 set_vaxc_errno(RMS$_DIR);
a0d0e21e 839 return NULL;
840 }
748a9306 841 }
842 esa[dirnam.nam$b_esl] = '\0';
843 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
844 /* They provided at least the name; we added the type, if necessary, */
845 if (buf) retspec = buf; /* in sys$parse() */
e518068a 846 else if (ts) New(7011,retspec,dirnam.nam$b_esl+1,char);
748a9306 847 else retspec = __fileify_retbuf;
848 strcpy(retspec,esa);
849 return retspec;
850 }
851 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
852 if (cp1 == NULL) return NULL; /* should never happen */
853 term = *cp1;
854 *cp1 = '\0';
855 retlen = strlen(esa);
856 if ((cp1 = strrchr(esa,'.')) != NULL) {
857 /* There's more than one directory in the path. Just roll back. */
858 *cp1 = term;
859 if (buf) retspec = buf;
e518068a 860 else if (ts) New(7011,retspec,retlen+7,char);
748a9306 861 else retspec = __fileify_retbuf;
862 strcpy(retspec,esa);
a0d0e21e 863 }
864 else {
748a9306 865 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
866 /* Go back and expand rooted logical name */
867 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
868 if (!(sys$parse(&dirfab) & 1)) {
869 set_errno(EVMSERR);
870 set_vaxc_errno(dirfab.fab$l_sts);
871 return NULL;
872 }
873 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
a0d0e21e 874 if (buf) retspec = buf;
e518068a 875 else if (ts) New(7012,retspec,retlen+16,char);
a0d0e21e 876 else retspec = __fileify_retbuf;
748a9306 877 cp1 = strstr(esa,"][");
878 dirlen = cp1 - esa;
879 memcpy(retspec,esa,dirlen);
880 if (!strncmp(cp1+2,"000000]",7)) {
881 retspec[dirlen-1] = '\0';
4633a7c4 882 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
883 if (*cp1 == '.') *cp1 = ']';
884 else {
885 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
886 memcpy(cp1+1,"000000]",7);
887 }
748a9306 888 }
889 else {
890 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
891 retspec[retlen] = '\0';
892 /* Convert last '.' to ']' */
4633a7c4 893 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
894 if (*cp1 == '.') *cp1 = ']';
895 else {
896 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
897 memcpy(cp1+1,"000000]",7);
898 }
748a9306 899 }
a0d0e21e 900 }
748a9306 901 else { /* This is a top-level dir. Add the MFD to the path. */
a0d0e21e 902 if (buf) retspec = buf;
e518068a 903 else if (ts) New(7012,retspec,retlen+16,char);
a0d0e21e 904 else retspec = __fileify_retbuf;
905 cp1 = esa;
906 cp2 = retspec;
907 while (*cp1 != ':') *(cp2++) = *(cp1++);
908 strcpy(cp2,":[000000]");
909 cp1 += 2;
910 strcpy(cp2+9,cp1);
911 }
748a9306 912 }
913 /* We've set up the string up through the filename. Add the
a0d0e21e 914 type and version, and we're done. */
915 strcat(retspec,".DIR;1");
916 return retspec;
917 }
918} /* end of do_fileify_dirspec() */
919/*}}}*/
920/* External entry points */
921char *fileify_dirspec(char *dir, char *buf)
922{ return do_fileify_dirspec(dir,buf,0); }
923char *fileify_dirspec_ts(char *dir, char *buf)
924{ return do_fileify_dirspec(dir,buf,1); }
925
926/*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
927static char *do_pathify_dirspec(char *dir,char *buf, int ts)
928{
929 static char __pathify_retbuf[NAM$C_MAXRSS+1];
930 unsigned long int retlen;
748a9306 931 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
a0d0e21e 932
933 if (dir == NULL) return NULL;
934
748a9306 935 strcpy(trndir,dir);
936 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir) != NULL) ;
937 dir = trndir;
938
a0d0e21e 939 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
748a9306 940 if (*dir == '.' && (*(dir+1) == '\0' ||
941 (*(dir+1) == '.' && *(dir+2) == '\0')))
942 retlen = 2 + (*(dir+1) != '\0');
943 else {
944 if (!(cp1 = strrchr(dir,'/'))) cp1 = dir;
945 if ((cp2 = strchr(cp1,'.')) && *(cp2+1) != '.') {
946 if (toupper(*(cp2+1)) == 'D' && /* They specified .dir. */
947 toupper(*(cp2+2)) == 'I' && /* Trim it off. */
948 toupper(*(cp2+3)) == 'R') {
949 retlen = cp2 - dir + 1;
950 }
951 else { /* Some other file type. Bzzt. */
952 set_errno(ENOTDIR);
953 set_vaxc_errno(RMS$_DIR);
954 return NULL;
955 }
a0d0e21e 956 }
748a9306 957 else { /* No file type present. Treat the filename as a directory. */
958 retlen = strlen(dir) + 1;
a0d0e21e 959 }
960 }
a0d0e21e 961 if (buf) retpath = buf;
e518068a 962 else if (ts) New(7013,retpath,retlen+1,char);
a0d0e21e 963 else retpath = __pathify_retbuf;
964 strncpy(retpath,dir,retlen-1);
965 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
966 retpath[retlen-1] = '/'; /* with '/', add it. */
967 retpath[retlen] = '\0';
968 }
969 else retpath[retlen-1] = '\0';
970 }
971 else { /* VMS-style directory spec */
972 char esa[NAM$C_MAXRSS+1];
e518068a 973 unsigned long int sts, cmplen;
a0d0e21e 974 struct FAB dirfab = cc$rms_fab;
975 struct NAM savnam, dirnam = cc$rms_nam;
976
977 dirfab.fab$b_fns = strlen(dir);
978 dirfab.fab$l_fna = dir;
748a9306 979 if (dir[dirfab.fab$b_fns-1] == ']' ||
980 dir[dirfab.fab$b_fns-1] == '>' ||
981 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
982 if (buf) retpath = buf;
e518068a 983 else if (ts) New(7014,retpath,strlen(dir)+1,char);
748a9306 984 else retpath = __pathify_retbuf;
985 strcpy(retpath,dir);
986 return retpath;
987 }
988 dirfab.fab$l_dna = ".DIR;1";
989 dirfab.fab$b_dns = 6;
a0d0e21e 990 dirfab.fab$l_nam = &dirnam;
e518068a 991 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
a0d0e21e 992 dirnam.nam$l_esa = esa;
e518068a 993 if (!((sts = sys$parse(&dirfab))&1)) {
994 if (dirfab.fab$l_sts == RMS$_DIR) {
995 dirnam.nam$b_nop |= NAM$M_SYNCHK;
996 sts = sys$parse(&dirfab) & 1;
997 }
998 if (!sts) {
748a9306 999 set_errno(EVMSERR);
1000 set_vaxc_errno(dirfab.fab$l_sts);
a0d0e21e 1001 return NULL;
1002 }
a0d0e21e 1003 }
e518068a 1004 else {
1005 savnam = dirnam;
1006 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1007 if (dirfab.fab$l_sts != RMS$_FNF) {
1008 set_errno(EVMSERR);
1009 set_vaxc_errno(dirfab.fab$l_sts);
1010 return NULL;
1011 }
1012 dirnam = savnam; /* No; just work with potential name */
1013 }
1014 }
a0d0e21e 1015 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1016 /* Yep; check version while we're at it, if it's there. */
1017 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1018 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1019 /* Something other than .DIR[;1]. Bzzt. */
748a9306 1020 set_errno(ENOTDIR);
1021 set_vaxc_errno(RMS$_DIR);
a0d0e21e 1022 return NULL;
1023 }
a0d0e21e 1024 }
748a9306 1025 /* OK, the type was fine. Now pull any file name into the
1026 directory path. */
1027 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
a0d0e21e 1028 else {
748a9306 1029 cp1 = strrchr(esa,'>');
1030 *dirnam.nam$l_type = '>';
a0d0e21e 1031 }
748a9306 1032 *cp1 = '.';
1033 *(dirnam.nam$l_type + 1) = '\0';
1034 retlen = dirnam.nam$l_type - esa + 2;
a0d0e21e 1035 if (buf) retpath = buf;
1036 else if (ts) New(7014,retpath,retlen,char);
1037 else retpath = __pathify_retbuf;
1038 strcpy(retpath,esa);
1039 }
1040
1041 return retpath;
1042} /* end of do_pathify_dirspec() */
1043/*}}}*/
1044/* External entry points */
1045char *pathify_dirspec(char *dir, char *buf)
1046{ return do_pathify_dirspec(dir,buf,0); }
1047char *pathify_dirspec_ts(char *dir, char *buf)
1048{ return do_pathify_dirspec(dir,buf,1); }
1049
1050/*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1051static char *do_tounixspec(char *spec, char *buf, int ts)
1052{
1053 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1054 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
e518068a 1055 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, dashes = 0;
a0d0e21e 1056
748a9306 1057 if (spec == NULL) return NULL;
e518068a 1058 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
a0d0e21e 1059 if (buf) rslt = buf;
e518068a 1060 else if (ts) {
1061 retlen = strlen(spec);
1062 cp1 = strchr(spec,'[');
1063 if (!cp1) cp1 = strchr(spec,'<');
1064 if (cp1) {
1065 for (cp1++; *cp1 == '-'; cp1++) dashes++; /* VMS '-' ==> Unix '../' */
1066 }
1067 New(7015,rslt,retlen+1+2*dashes,char);
1068 }
a0d0e21e 1069 else rslt = __tounixspec_retbuf;
1070 if (strchr(spec,'/') != NULL) {
1071 strcpy(rslt,spec);
1072 return rslt;
1073 }
1074
1075 cp1 = rslt;
1076 cp2 = spec;
1077 dirend = strrchr(spec,']');
1078 if (dirend == NULL) dirend = strrchr(spec,'>');
1079 if (dirend == NULL) dirend = strchr(spec,':');
1080 if (dirend == NULL) {
1081 strcpy(rslt,spec);
1082 return rslt;
1083 }
1084 if (*cp2 != '[') {
1085 *(cp1++) = '/';
1086 }
1087 else { /* the VMS spec begins with directories */
1088 cp2++;
1089 if (*cp2 == '-') {
1090 while (*cp2 == '-') {
1091 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1092 cp2++;
1093 }
1094 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1095 if (ts) Safefree(rslt); /* filespecs like */
748a9306 1096 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [--foo.bar] */
a0d0e21e 1097 return NULL;
1098 }
1099 cp2++;
1100 }
1101 else if ( *(cp2) != '.') { /* add the implied device into the Unix spec */
1102 *(cp1++) = '/';
1103 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1104 if (ts) Safefree(rslt);
1105 return NULL;
1106 }
1107 do {
1108 cp3 = tmp;
1109 while (*cp3 != ':' && *cp3) cp3++;
1110 *(cp3++) = '\0';
1111 if (strchr(cp3,']') != NULL) break;
e518068a 1112 } while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3));
a0d0e21e 1113 cp3 = tmp;
1114 while (*cp3) *(cp1++) = *(cp3++);
1115 *(cp1++) = '/';
e518068a 1116 if (ts &&
1117 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1118 int offset = cp1 - rslt;
1119
1120 retlen = devlen + dirlen;
1121 Renew(rslt,retlen+1+2*dashes,char);
1122 cp1 = rslt + offset;
a0d0e21e 1123 }
1124 }
1125 else cp2++;
1126 }
1127 for (; cp2 <= dirend; cp2++) {
1128 if (*cp2 == ':') {
1129 *(cp1++) = '/';
1130 if (*(cp2+1) == '[') cp2++;
1131 }
1132 else if (*cp2 == ']' || *cp2 == '>') *(cp1++) = '/';
1133 else if (*cp2 == '.') {
1134 *(cp1++) = '/';
e518068a 1135 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1136 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1137 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1138 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1139 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1140 }
a0d0e21e 1141 }
1142 else if (*cp2 == '-') {
1143 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1144 while (*cp2 == '-') {
1145 cp2++;
1146 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1147 }
1148 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1149 if (ts) Safefree(rslt); /* filespecs like */
748a9306 1150 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [--foo.bar] */
a0d0e21e 1151 return NULL;
1152 }
1153 cp2++;
1154 }
1155 else *(cp1++) = *cp2;
1156 }
1157 else *(cp1++) = *cp2;
1158 }
1159 while (*cp2) *(cp1++) = *(cp2++);
1160 *cp1 = '\0';
1161
1162 return rslt;
1163
1164} /* end of do_tounixspec() */
1165/*}}}*/
1166/* External entry points */
1167char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1168char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1169
1170/*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1171static char *do_tovmsspec(char *path, char *buf, int ts) {
1172 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
e518068a 1173 char *rslt, *dirend;
1174 register char *cp1, *cp2;
1175 unsigned long int infront = 0, hasdir = 1;
a0d0e21e 1176
748a9306 1177 if (path == NULL) return NULL;
a0d0e21e 1178 if (buf) rslt = buf;
e518068a 1179 else if (ts) New(7016,rslt,strlen(path)+9,char);
a0d0e21e 1180 else rslt = __tovmsspec_retbuf;
748a9306 1181 if (strpbrk(path,"]:>") ||
a0d0e21e 1182 (dirend = strrchr(path,'/')) == NULL) {
748a9306 1183 if (path[0] == '.') {
1184 if (path[1] == '\0') strcpy(rslt,"[]");
1185 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1186 else strcpy(rslt,path); /* probably garbage */
1187 }
1188 else strcpy(rslt,path);
a0d0e21e 1189 return rslt;
1190 }
748a9306 1191 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.."? */
1192 if (!*(dirend+2)) dirend +=2;
1193 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
1194 }
a0d0e21e 1195 cp1 = rslt;
1196 cp2 = path;
1197 if (*cp2 == '/') {
e518068a 1198 char trndev[NAM$C_MAXRSS+1];
1199 int islnm, rooted;
1200 STRLEN trnend;
1201
a0d0e21e 1202 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
e518068a 1203 *cp1 = '\0';
1204 islnm = (my_trnlnm(rslt,trndev) != Nullch);
1205 trnend = islnm ? strlen(trndev) - 1 : 0;
1206 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
1207 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
1208 /* If the first element of the path is a logical name, determine
1209 * whether it has to be translated so we can add more directories. */
1210 if (!islnm || rooted) {
1211 *(cp1++) = ':';
1212 *(cp1++) = '[';
1213 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
1214 else cp2++;
1215 }
1216 else {
1217 if (cp2 != dirend) {
1218 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
1219 strcpy(rslt,trndev);
1220 cp1 = rslt + trnend;
1221 *(cp1++) = '.';
1222 cp2++;
1223 }
1224 else {
1225 *(cp1++) = ':';
1226 hasdir = 0;
1227 }
1228 }
748a9306 1229 }
a0d0e21e 1230 else {
1231 *(cp1++) = '[';
748a9306 1232 if (*cp2 == '.') {
1233 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
1234 cp2 += 2; /* skip over "./" - it's redundant */
1235 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
1236 }
1237 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1238 *(cp1++) = '-'; /* "../" --> "-" */
1239 cp2 += 3;
1240 }
1241 if (cp2 > dirend) cp2 = dirend;
1242 }
1243 else *(cp1++) = '.';
1244 }
1245 for (; cp2 < dirend; cp2++) {
1246 if (*cp2 == '/') {
1247 if (*(cp1-1) != '.') *(cp1++) = '.';
1248 infront = 0;
1249 }
1250 else if (!infront && *cp2 == '.') {
4633a7c4 1251 if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
1252 else if (*(cp2+1) == '\0') { cp2++; break; }
748a9306 1253 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1254 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
1255 else if (*(cp1-2) == '[') *(cp1-1) = '-';
1256 else { /* back up over previous directory name */
1257 cp1--;
1258 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
4633a7c4 1259 if (*(cp1-1) == '[') {
1260 memcpy(cp1,"000000.",7);
1261 cp1 += 7;
1262 }
748a9306 1263 }
1264 cp2 += 2;
1265 if (cp2 == dirend) {
1266 if (*(cp1-1) == '.') cp1--;
1267 break;
1268 }
1269 }
1270 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
1271 }
1272 else {
e518068a 1273 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
748a9306 1274 if (*cp2 == '/') *(cp1++) = '.';
1275 else if (*cp2 == '.') *(cp1++) = '_';
1276 else *(cp1++) = *cp2;
1277 infront = 1;
1278 }
a0d0e21e 1279 }
748a9306 1280 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
e518068a 1281 if (hasdir) *(cp1++) = ']';
748a9306 1282 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
a0d0e21e 1283 while (*cp2) *(cp1++) = *(cp2++);
1284 *cp1 = '\0';
1285
1286 return rslt;
1287
1288} /* end of do_tovmsspec() */
1289/*}}}*/
1290/* External entry points */
1291char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
1292char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
1293
1294/*{{{ char *tovmspath[_ts](char *path, char *buf)*/
1295static char *do_tovmspath(char *path, char *buf, int ts) {
1296 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
1297 int vmslen;
1298 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
1299
748a9306 1300 if (path == NULL) return NULL;
a0d0e21e 1301 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1302 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
1303 if (buf) return buf;
1304 else if (ts) {
1305 vmslen = strlen(vmsified);
e518068a 1306 New(7017,cp,vmslen+1,char);
a0d0e21e 1307 memcpy(cp,vmsified,vmslen);
1308 cp[vmslen] = '\0';
1309 return cp;
1310 }
1311 else {
1312 strcpy(__tovmspath_retbuf,vmsified);
1313 return __tovmspath_retbuf;
1314 }
1315
1316} /* end of do_tovmspath() */
1317/*}}}*/
1318/* External entry points */
1319char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
1320char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
1321
1322
1323/*{{{ char *tounixpath[_ts](char *path, char *buf)*/
1324static char *do_tounixpath(char *path, char *buf, int ts) {
1325 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
1326 int unixlen;
1327 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
1328
748a9306 1329 if (path == NULL) return NULL;
a0d0e21e 1330 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1331 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
1332 if (buf) return buf;
1333 else if (ts) {
1334 unixlen = strlen(unixified);
e518068a 1335 New(7017,cp,unixlen+1,char);
a0d0e21e 1336 memcpy(cp,unixified,unixlen);
1337 cp[unixlen] = '\0';
1338 return cp;
1339 }
1340 else {
1341 strcpy(__tounixpath_retbuf,unixified);
1342 return __tounixpath_retbuf;
1343 }
1344
1345} /* end of do_tounixpath() */
1346/*}}}*/
1347/* External entry points */
1348char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
1349char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
1350
1351/*
1352 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
1353 *
1354 *****************************************************************************
1355 * *
1356 * Copyright (C) 1989-1994 by *
1357 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
1358 * *
1359 * Permission is hereby granted for the reproduction of this software, *
1360 * on condition that this copyright notice is included in the reproduction, *
1361 * and that such reproduction is not for purposes of profit or material *
1362 * gain. *
1363 * *
1364 * 27-Aug-1994 Modified for inclusion in perl5 *
1365 * by Charles Bailey bailey@genetics.upenn.edu *
1366 *****************************************************************************
1367 */
1368
1369/*
1370 * getredirection() is intended to aid in porting C programs
1371 * to VMS (Vax-11 C). The native VMS environment does not support
1372 * '>' and '<' I/O redirection, or command line wild card expansion,
1373 * or a command line pipe mechanism using the '|' AND background
1374 * command execution '&'. All of these capabilities are provided to any
1375 * C program which calls this procedure as the first thing in the
1376 * main program.
1377 * The piping mechanism will probably work with almost any 'filter' type
1378 * of program. With suitable modification, it may useful for other
1379 * portability problems as well.
1380 *
1381 * Author: Mark Pizzolato mark@infocomm.com
1382 */
1383struct list_item
1384 {
1385 struct list_item *next;
1386 char *value;
1387 };
1388
1389static void add_item(struct list_item **head,
1390 struct list_item **tail,
1391 char *value,
1392 int *count);
1393
1394static void expand_wild_cards(char *item,
1395 struct list_item **head,
1396 struct list_item **tail,
1397 int *count);
1398
1399static int background_process(int argc, char **argv);
1400
1401static void pipe_and_fork(char **cmargv);
1402
1403/*{{{ void getredirection(int *ac, char ***av)*/
1404void
1405getredirection(int *ac, char ***av)
1406/*
1407 * Process vms redirection arg's. Exit if any error is seen.
1408 * If getredirection() processes an argument, it is erased
1409 * from the vector. getredirection() returns a new argc and argv value.
1410 * In the event that a background command is requested (by a trailing "&"),
1411 * this routine creates a background subprocess, and simply exits the program.
1412 *
1413 * Warning: do not try to simplify the code for vms. The code
1414 * presupposes that getredirection() is called before any data is
1415 * read from stdin or written to stdout.
1416 *
1417 * Normal usage is as follows:
1418 *
1419 * main(argc, argv)
1420 * int argc;
1421 * char *argv[];
1422 * {
1423 * getredirection(&argc, &argv);
1424 * }
1425 */
1426{
1427 int argc = *ac; /* Argument Count */
1428 char **argv = *av; /* Argument Vector */
1429 char *ap; /* Argument pointer */
1430 int j; /* argv[] index */
1431 int item_count = 0; /* Count of Items in List */
1432 struct list_item *list_head = 0; /* First Item in List */
1433 struct list_item *list_tail; /* Last Item in List */
1434 char *in = NULL; /* Input File Name */
1435 char *out = NULL; /* Output File Name */
1436 char *outmode = "w"; /* Mode to Open Output File */
1437 char *err = NULL; /* Error File Name */
1438 char *errmode = "w"; /* Mode to Open Error File */
1439 int cmargc = 0; /* Piped Command Arg Count */
1440 char **cmargv = NULL;/* Piped Command Arg Vector */
a0d0e21e 1441
1442 /*
1443 * First handle the case where the last thing on the line ends with
1444 * a '&'. This indicates the desire for the command to be run in a
1445 * subprocess, so we satisfy that desire.
1446 */
1447 ap = argv[argc-1];
1448 if (0 == strcmp("&", ap))
1449 exit(background_process(--argc, argv));
e518068a 1450 if (*ap && '&' == ap[strlen(ap)-1])
a0d0e21e 1451 {
1452 ap[strlen(ap)-1] = '\0';
1453 exit(background_process(argc, argv));
1454 }
1455 /*
1456 * Now we handle the general redirection cases that involve '>', '>>',
1457 * '<', and pipes '|'.
1458 */
1459 for (j = 0; j < argc; ++j)
1460 {
1461 if (0 == strcmp("<", argv[j]))
1462 {
1463 if (j+1 >= argc)
1464 {
748a9306 1465 fprintf(stderr,"No input file after < on command line");
1466 exit(LIB$_WRONUMARG);
a0d0e21e 1467 }
1468 in = argv[++j];
1469 continue;
1470 }
1471 if ('<' == *(ap = argv[j]))
1472 {
1473 in = 1 + ap;
1474 continue;
1475 }
1476 if (0 == strcmp(">", ap))
1477 {
1478 if (j+1 >= argc)
1479 {
748a9306 1480 fprintf(stderr,"No output file after > on command line");
1481 exit(LIB$_WRONUMARG);
a0d0e21e 1482 }
1483 out = argv[++j];
1484 continue;
1485 }
1486 if ('>' == *ap)
1487 {
1488 if ('>' == ap[1])
1489 {
1490 outmode = "a";
1491 if ('\0' == ap[2])
1492 out = argv[++j];
1493 else
1494 out = 2 + ap;
1495 }
1496 else
1497 out = 1 + ap;
1498 if (j >= argc)
1499 {
748a9306 1500 fprintf(stderr,"No output file after > or >> on command line");
1501 exit(LIB$_WRONUMARG);
a0d0e21e 1502 }
1503 continue;
1504 }
1505 if (('2' == *ap) && ('>' == ap[1]))
1506 {
1507 if ('>' == ap[2])
1508 {
1509 errmode = "a";
1510 if ('\0' == ap[3])
1511 err = argv[++j];
1512 else
1513 err = 3 + ap;
1514 }
1515 else
1516 if ('\0' == ap[2])
1517 err = argv[++j];
1518 else
748a9306 1519 err = 2 + ap;
a0d0e21e 1520 if (j >= argc)
1521 {
748a9306 1522 fprintf(stderr,"No output file after 2> or 2>> on command line");
1523 exit(LIB$_WRONUMARG);
a0d0e21e 1524 }
1525 continue;
1526 }
1527 if (0 == strcmp("|", argv[j]))
1528 {
1529 if (j+1 >= argc)
1530 {
748a9306 1531 fprintf(stderr,"No command into which to pipe on command line");
1532 exit(LIB$_WRONUMARG);
a0d0e21e 1533 }
1534 cmargc = argc-(j+1);
1535 cmargv = &argv[j+1];
1536 argc = j;
1537 continue;
1538 }
1539 if ('|' == *(ap = argv[j]))
1540 {
1541 ++argv[j];
1542 cmargc = argc-j;
1543 cmargv = &argv[j];
1544 argc = j;
1545 continue;
1546 }
1547 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
1548 }
1549 /*
1550 * Allocate and fill in the new argument vector, Some Unix's terminate
1551 * the list with an extra null pointer.
1552 */
1553 New(7002, argv, item_count+1, char *);
1554 *av = argv;
1555 for (j = 0; j < item_count; ++j, list_head = list_head->next)
1556 argv[j] = list_head->value;
1557 *ac = item_count;
1558 if (cmargv != NULL)
1559 {
1560 if (out != NULL)
1561 {
748a9306 1562 fprintf(stderr,"'|' and '>' may not both be specified on command line");
1563 exit(LIB$_INVARGORD);
a0d0e21e 1564 }
1565 pipe_and_fork(cmargv);
1566 }
1567
1568 /* Check for input from a pipe (mailbox) */
1569
1570 if (1 == isapipe(0))
1571 {
1572 char mbxname[L_tmpnam];
1573 long int bufsize;
1574 long int dvi_item = DVI$_DEVBUFSIZ;
1575 $DESCRIPTOR(mbxnam, "");
1576 $DESCRIPTOR(mbxdevnam, "");
1577
1578 /* Input from a pipe, reopen it in binary mode to disable */
1579 /* carriage control processing. */
1580
1581 if (in != NULL)
1582 {
748a9306 1583 fprintf(stderr,"'|' and '<' may not both be specified on command line");
1584 exit(LIB$_INVARGORD);
a0d0e21e 1585 }
748a9306 1586 fgetname(stdin, mbxname,1);
a0d0e21e 1587 mbxnam.dsc$a_pointer = mbxname;
1588 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
1589 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
1590 mbxdevnam.dsc$a_pointer = mbxname;
1591 mbxdevnam.dsc$w_length = sizeof(mbxname);
1592 dvi_item = DVI$_DEVNAM;
1593 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
1594 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
748a9306 1595 set_errno(0);
1596 set_vaxc_errno(1);
a0d0e21e 1597 freopen(mbxname, "rb", stdin);
1598 if (errno != 0)
1599 {
748a9306 1600 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
1601 exit(vaxc$errno);
a0d0e21e 1602 }
1603 }
1604 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
1605 {
748a9306 1606 fprintf(stderr,"Can't open input file %s as stdin",in);
1607 exit(vaxc$errno);
a0d0e21e 1608 }
1609 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
1610 {
748a9306 1611 fprintf(stderr,"Can't open output file %s as stdout",out);
1612 exit(vaxc$errno);
a0d0e21e 1613 }
748a9306 1614 if (err != NULL) {
1615 FILE *tmperr;
1616 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
1617 {
1618 fprintf(stderr,"Can't open error file %s as stderr",err);
1619 exit(vaxc$errno);
1620 }
1621 fclose(tmperr);
1622 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
1623 {
1624 exit(vaxc$errno);
1625 }
a0d0e21e 1626 }
1627#ifdef ARGPROC_DEBUG
1628 fprintf(stderr, "Arglist:\n");
1629 for (j = 0; j < *ac; ++j)
1630 fprintf(stderr, "argv[%d] = '%s'\n", j, argv[j]);
1631#endif
1632} /* end of getredirection() */
1633/*}}}*/
1634
1635static void add_item(struct list_item **head,
1636 struct list_item **tail,
1637 char *value,
1638 int *count)
1639{
1640 if (*head == 0)
1641 {
1642 New(7003,*head,1,struct list_item);
1643 *tail = *head;
1644 }
1645 else {
1646 New(7004,(*tail)->next,1,struct list_item);
1647 *tail = (*tail)->next;
1648 }
1649 (*tail)->value = value;
1650 ++(*count);
1651}
1652
1653static void expand_wild_cards(char *item,
1654 struct list_item **head,
1655 struct list_item **tail,
1656 int *count)
1657{
1658int expcount = 0;
748a9306 1659unsigned long int context = 0;
a0d0e21e 1660int isunix = 0;
a0d0e21e 1661int status_value;
1662char *had_version;
1663char *had_device;
1664int had_directory;
1665char *devdir;
1666char vmsspec[NAM$C_MAXRSS+1];
1667$DESCRIPTOR(filespec, "");
748a9306 1668$DESCRIPTOR(defaultspec, "SYS$DISK:[]");
a0d0e21e 1669$DESCRIPTOR(resultspec, "");
1670unsigned long int zero = 0;
1671
1672 if (strcspn(item, "*%") == strlen(item))
1673 {
1674 add_item(head, tail, item, count);
1675 return;
1676 }
1677 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
1678 resultspec.dsc$b_class = DSC$K_CLASS_D;
1679 resultspec.dsc$a_pointer = NULL;
748a9306 1680 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
a0d0e21e 1681 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
1682 if (!isunix || !filespec.dsc$a_pointer)
1683 filespec.dsc$a_pointer = item;
1684 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
1685 /*
1686 * Only return version specs, if the caller specified a version
1687 */
1688 had_version = strchr(item, ';');
1689 /*
1690 * Only return device and directory specs, if the caller specifed either.
1691 */
1692 had_device = strchr(item, ':');
1693 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
1694
1695 while (1 == (1&lib$find_file(&filespec, &resultspec, &context,
1696 &defaultspec, 0, &status_value, &zero)))
1697 {
1698 char *string;
1699 char *c;
1700
1701 New(7005,string,resultspec.dsc$w_length+1,char);
1702 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
1703 string[resultspec.dsc$w_length] = '\0';
1704 if (NULL == had_version)
1705 *((char *)strrchr(string, ';')) = '\0';
1706 if ((!had_directory) && (had_device == NULL))
1707 {
1708 if (NULL == (devdir = strrchr(string, ']')))
1709 devdir = strrchr(string, '>');
1710 strcpy(string, devdir + 1);
1711 }
1712 /*
1713 * Be consistent with what the C RTL has already done to the rest of
1714 * the argv items and lowercase all of these names.
1715 */
1716 for (c = string; *c; ++c)
1717 if (isupper(*c))
1718 *c = tolower(*c);
1719 if (isunix) trim_unixpath(item,string);
1720 add_item(head, tail, string, count);
1721 ++expcount;
1722 }
1723 if (expcount == 0)
1724 add_item(head, tail, item, count);
1725 lib$sfree1_dd(&resultspec);
1726 lib$find_file_end(&context);
1727}
1728
1729static int child_st[2];/* Event Flag set when child process completes */
1730
748a9306 1731static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
a0d0e21e 1732
748a9306 1733static unsigned long int exit_handler(int *status)
a0d0e21e 1734{
1735short iosb[4];
1736
1737 if (0 == child_st[0])
1738 {
1739#ifdef ARGPROC_DEBUG
1740 fprintf(stderr, "Waiting for Child Process to Finish . . .\n");
1741#endif
1742 fflush(stdout); /* Have to flush pipe for binary data to */
1743 /* terminate properly -- <tp@mccall.com> */
1744 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
1745 sys$dassgn(child_chan);
1746 fclose(stdout);
1747 sys$synch(0, child_st);
1748 }
1749 return(1);
1750}
1751
1752static void sig_child(int chan)
1753{
1754#ifdef ARGPROC_DEBUG
1755 fprintf(stderr, "Child Completion AST\n");
1756#endif
1757 if (child_st[0] == 0)
1758 child_st[0] = 1;
1759}
1760
748a9306 1761static struct exit_control_block exit_block =
a0d0e21e 1762 {
1763 0,
1764 exit_handler,
1765 1,
1766 &exit_block.exit_status,
1767 0
1768 };
1769
1770static void pipe_and_fork(char **cmargv)
1771{
1772 char subcmd[2048];
1773 $DESCRIPTOR(cmddsc, "");
1774 static char mbxname[64];
1775 $DESCRIPTOR(mbxdsc, mbxname);
a0d0e21e 1776 int pid, j;
a0d0e21e 1777 unsigned long int zero = 0, one = 1;
1778
1779 strcpy(subcmd, cmargv[0]);
1780 for (j = 1; NULL != cmargv[j]; ++j)
1781 {
1782 strcat(subcmd, " \"");
1783 strcat(subcmd, cmargv[j]);
1784 strcat(subcmd, "\"");
1785 }
1786 cmddsc.dsc$a_pointer = subcmd;
1787 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
1788
1789 create_mbx(&child_chan,&mbxdsc);
1790#ifdef ARGPROC_DEBUG
1791 fprintf(stderr, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
1792 fprintf(stderr, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
1793#endif
748a9306 1794 _ckvmssts(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
a0d0e21e 1795 0, &pid, child_st, &zero, sig_child,
748a9306 1796 &child_chan));
a0d0e21e 1797#ifdef ARGPROC_DEBUG
1798 fprintf(stderr, "Subprocess's Pid = %08X\n", pid);
1799#endif
1800 sys$dclexh(&exit_block);
1801 if (NULL == freopen(mbxname, "wb", stdout))
1802 {
748a9306 1803 fprintf(stderr,"Can't open output pipe (name %s)",mbxname);
a0d0e21e 1804 }
1805}
1806
1807static int background_process(int argc, char **argv)
1808{
1809char command[2048] = "$";
1810$DESCRIPTOR(value, "");
1811static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
1812static $DESCRIPTOR(null, "NLA0:");
1813static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
1814char pidstring[80];
1815$DESCRIPTOR(pidstr, "");
1816int pid;
748a9306 1817unsigned long int flags = 17, one = 1, retsts;
a0d0e21e 1818
1819 strcat(command, argv[0]);
1820 while (--argc)
1821 {
1822 strcat(command, " \"");
1823 strcat(command, *(++argv));
1824 strcat(command, "\"");
1825 }
1826 value.dsc$a_pointer = command;
1827 value.dsc$w_length = strlen(value.dsc$a_pointer);
748a9306 1828 _ckvmssts(lib$set_symbol(&cmd, &value));
1829 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
1830 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
1831 _ckvmssts(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
1832 }
1833 else {
1834 _ckvmssts(retsts);
1835 }
a0d0e21e 1836#ifdef ARGPROC_DEBUG
1837 fprintf(stderr, "%s\n", command);
1838#endif
1839 sprintf(pidstring, "%08X", pid);
1840 fprintf(stderr, "%s\n", pidstring);
1841 pidstr.dsc$a_pointer = pidstring;
1842 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
1843 lib$set_symbol(&pidsymbol, &pidstr);
1844 return(SS$_NORMAL);
1845}
1846/*}}}*/
1847/***** End of code taken from Mark Pizzolato's argproc.c package *****/
1848
a0d0e21e 1849/* trim_unixpath()
1850 * Trim Unix-style prefix off filespec, so it looks like what a shell
1851 * glob expansion would return (i.e. from specified prefix on, not
1852 * full path). Note that returned filespec is Unix-style, regardless
1853 * of whether input filespec was VMS-style or Unix-style.
1854 *
1855 * Returns !=0 on success, 0 on failure.
1856 */
1857/*{{{int trim_unixpath(char *template, char *fspec)*/
1858int
1859trim_unixpath(char *template, char *fspec)
1860{
1861 char unixified[NAM$C_MAXRSS+1], *base, *cp1, *cp2;
1862 register int tmplen;
1863
1864 if (strpbrk(fspec,"]>:") != NULL) {
1865 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
1866 else base = unixified;
1867 }
1868 else base = fspec;
1869 for (cp2 = base; *cp2; cp2++) ; /* Find end of filespec */
1870
1871 /* Find prefix to template consisting of path elements without wildcards */
1872 if ((cp1 = strpbrk(template,"*%?")) == NULL)
1873 for (cp1 = template; *cp1; cp1++) ;
1874 else while (cp1 >= template && *cp1 != '/') cp1--;
1875 if (cp1 == template) return 1; /* Wildcard was up front - no prefix to clip */
1876 tmplen = cp1 - template;
1877
1878 /* Try to find template prefix on filespec */
1879 if (!memcmp(base,template,tmplen)) return 1; /* Nothing before prefix - we're done */
1880 for (; cp2 - base > tmplen; base++) {
1881 if (*base != '/') continue;
1882 if (!memcmp(base + 1,template,tmplen)) break;
1883 }
1884 if (cp2 - base == tmplen) return 0; /* Not there - not good */
1885 base++; /* Move past leading '/' */
1886 /* Copy down remaining portion of filespec, including trailing NUL */
1887 memmove(fspec,base,cp2 - base + 1);
1888 return 1;
1889
1890} /* end of trim_unixpath() */
1891/*}}}*/
1892
a0d0e21e 1893
1894/*
1895 * VMS readdir() routines.
1896 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
1897 * This code has no copyright.
1898 *
1899 * 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu
1900 * Minor modifications to original routines.
1901 */
1902
1903 /* Number of elements in vms_versions array */
1904#define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
1905
1906/*
1907 * Open a directory, return a handle for later use.
1908 */
1909/*{{{ DIR *opendir(char*name) */
1910DIR *
1911opendir(char *name)
1912{
1913 DIR *dd;
1914 char dir[NAM$C_MAXRSS+1];
1915
1916 /* Get memory for the handle, and the pattern. */
1917 New(7006,dd,1,DIR);
1918 if (do_tovmspath(name,dir,0) == NULL) {
1919 Safefree((char *)dd);
1920 return(NULL);
1921 }
1922 New(7007,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
1923
1924 /* Fill in the fields; mainly playing with the descriptor. */
1925 (void)sprintf(dd->pattern, "%s*.*",dir);
1926 dd->context = 0;
1927 dd->count = 0;
1928 dd->vms_wantversions = 0;
1929 dd->pat.dsc$a_pointer = dd->pattern;
1930 dd->pat.dsc$w_length = strlen(dd->pattern);
1931 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
1932 dd->pat.dsc$b_class = DSC$K_CLASS_S;
1933
1934 return dd;
1935} /* end of opendir() */
1936/*}}}*/
1937
1938/*
1939 * Set the flag to indicate we want versions or not.
1940 */
1941/*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
1942void
1943vmsreaddirversions(DIR *dd, int flag)
1944{
1945 dd->vms_wantversions = flag;
1946}
1947/*}}}*/
1948
1949/*
1950 * Free up an opened directory.
1951 */
1952/*{{{ void closedir(DIR *dd)*/
1953void
1954closedir(DIR *dd)
1955{
1956 (void)lib$find_file_end(&dd->context);
1957 Safefree(dd->pattern);
1958 Safefree((char *)dd);
1959}
1960/*}}}*/
1961
1962/*
1963 * Collect all the version numbers for the current file.
1964 */
1965static void
1966collectversions(dd)
1967 DIR *dd;
1968{
1969 struct dsc$descriptor_s pat;
1970 struct dsc$descriptor_s res;
1971 struct dirent *e;
1972 char *p, *text, buff[sizeof dd->entry.d_name];
1973 int i;
1974 unsigned long context, tmpsts;
1975
1976 /* Convenient shorthand. */
1977 e = &dd->entry;
1978
1979 /* Add the version wildcard, ignoring the "*.*" put on before */
1980 i = strlen(dd->pattern);
1981 New(7008,text,i + e->d_namlen + 3,char);
1982 (void)strcpy(text, dd->pattern);
1983 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
1984
1985 /* Set up the pattern descriptor. */
1986 pat.dsc$a_pointer = text;
1987 pat.dsc$w_length = i + e->d_namlen - 1;
1988 pat.dsc$b_dtype = DSC$K_DTYPE_T;
1989 pat.dsc$b_class = DSC$K_CLASS_S;
1990
1991 /* Set up result descriptor. */
1992 res.dsc$a_pointer = buff;
1993 res.dsc$w_length = sizeof buff - 2;
1994 res.dsc$b_dtype = DSC$K_DTYPE_T;
1995 res.dsc$b_class = DSC$K_CLASS_S;
1996
1997 /* Read files, collecting versions. */
1998 for (context = 0, e->vms_verscount = 0;
1999 e->vms_verscount < VERSIZE(e);
2000 e->vms_verscount++) {
2001 tmpsts = lib$find_file(&pat, &res, &context);
2002 if (tmpsts == RMS$_NMF || context == 0) break;
748a9306 2003 _ckvmssts(tmpsts);
a0d0e21e 2004 buff[sizeof buff - 1] = '\0';
748a9306 2005 if ((p = strchr(buff, ';')))
a0d0e21e 2006 e->vms_versions[e->vms_verscount] = atoi(p + 1);
2007 else
2008 e->vms_versions[e->vms_verscount] = -1;
2009 }
2010
748a9306 2011 _ckvmssts(lib$find_file_end(&context));
a0d0e21e 2012 Safefree(text);
2013
2014} /* end of collectversions() */
2015
2016/*
2017 * Read the next entry from the directory.
2018 */
2019/*{{{ struct dirent *readdir(DIR *dd)*/
2020struct dirent *
2021readdir(DIR *dd)
2022{
2023 struct dsc$descriptor_s res;
2024 char *p, buff[sizeof dd->entry.d_name];
a0d0e21e 2025 unsigned long int tmpsts;
2026
2027 /* Set up result descriptor, and get next file. */
2028 res.dsc$a_pointer = buff;
2029 res.dsc$w_length = sizeof buff - 2;
2030 res.dsc$b_dtype = DSC$K_DTYPE_T;
2031 res.dsc$b_class = DSC$K_CLASS_S;
a0d0e21e 2032 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4633a7c4 2033 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
2034 if (!(tmpsts & 1)) {
2035 set_vaxc_errno(tmpsts);
2036 switch (tmpsts) {
2037 case RMS$_PRV:
2038 set_errno(EACCES);
2039 break;
2040 case RMS$_DEV:
2041 set_errno(ENODEV);
2042 break;
2043 case RMS$_DIR:
2044 set_errno(ENOTDIR);
2045 break;
2046 case RMS$_FNF:
2047 set_errno(ENOENT);
2048 break;
2049 default:
2050 set_errno(EVMSERR);
2051 }
2052 return NULL;
2053 }
2054 dd->count++;
a0d0e21e 2055 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
2056 buff[sizeof buff - 1] = '\0';
2057 for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
2058 *p = '\0';
2059
2060 /* Skip any directory component and just copy the name. */
748a9306 2061 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
a0d0e21e 2062 else (void)strcpy(dd->entry.d_name, buff);
2063
2064 /* Clobber the version. */
748a9306 2065 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
a0d0e21e 2066
2067 dd->entry.d_namlen = strlen(dd->entry.d_name);
2068 dd->entry.vms_verscount = 0;
2069 if (dd->vms_wantversions) collectversions(dd);
2070 return &dd->entry;
2071
2072} /* end of readdir() */
2073/*}}}*/
2074
2075/*
2076 * Return something that can be used in a seekdir later.
2077 */
2078/*{{{ long telldir(DIR *dd)*/
2079long
2080telldir(DIR *dd)
2081{
2082 return dd->count;
2083}
2084/*}}}*/
2085
2086/*
2087 * Return to a spot where we used to be. Brute force.
2088 */
2089/*{{{ void seekdir(DIR *dd,long count)*/
2090void
2091seekdir(DIR *dd, long count)
2092{
2093 int vms_wantversions;
a0d0e21e 2094
2095 /* If we haven't done anything yet... */
2096 if (dd->count == 0)
2097 return;
2098
2099 /* Remember some state, and clear it. */
2100 vms_wantversions = dd->vms_wantversions;
2101 dd->vms_wantversions = 0;
748a9306 2102 _ckvmssts(lib$find_file_end(&dd->context));
a0d0e21e 2103 dd->context = 0;
2104
2105 /* The increment is in readdir(). */
2106 for (dd->count = 0; dd->count < count; )
2107 (void)readdir(dd);
2108
2109 dd->vms_wantversions = vms_wantversions;
2110
2111} /* end of seekdir() */
2112/*}}}*/
2113
2114/* VMS subprocess management
2115 *
2116 * my_vfork() - just a vfork(), after setting a flag to record that
2117 * the current script is trying a Unix-style fork/exec.
2118 *
2119 * vms_do_aexec() and vms_do_exec() are called in response to the
2120 * perl 'exec' function. If this follows a vfork call, then they
2121 * call out the the regular perl routines in doio.c which do an
2122 * execvp (for those who really want to try this under VMS).
2123 * Otherwise, they do exactly what the perl docs say exec should
2124 * do - terminate the current script and invoke a new command
2125 * (See below for notes on command syntax.)
2126 *
2127 * do_aspawn() and do_spawn() implement the VMS side of the perl
2128 * 'system' function.
2129 *
2130 * Note on command arguments to perl 'exec' and 'system': When handled
2131 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2132 * are concatenated to form a DCL command string. If the first arg
2133 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2134 * the the command string is hrnded off to DCL directly. Otherwise,
2135 * the first token of the command is taken as the filespec of an image
2136 * to run. The filespec is expanded using a default type of '.EXE' and
2137 * the process defaults for device, directory, etc., and the resultant
2138 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2139 * the command string as parameters. This is perhaps a bit compicated,
2140 * but I hope it will form a happy medium between what VMS folks expect
2141 * from lib$spawn and what Unix folks expect from exec.
2142 */
2143
2144static int vfork_called;
2145
2146/*{{{int my_vfork()*/
2147int
2148my_vfork()
2149{
748a9306 2150 vfork_called++;
a0d0e21e 2151 return vfork();
2152}
2153/*}}}*/
2154
4633a7c4 2155
2156static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
2157
a0d0e21e 2158static void
4633a7c4 2159vms_execfree() {
2160 if (Cmd) {
e518068a 2161 Safefree(Cmd);
4633a7c4 2162 Cmd = Nullch;
2163 }
2164 if (VMScmd.dsc$a_pointer) {
2165 Safefree(VMScmd.dsc$a_pointer);
2166 VMScmd.dsc$w_length = 0;
2167 VMScmd.dsc$a_pointer = Nullch;
2168 }
2169}
2170
2171static char *
2172setup_argstr(SV *really, SV **mark, SV **sp)
a0d0e21e 2173{
4633a7c4 2174 char *junk, *tmps = Nullch;
a0d0e21e 2175 register size_t cmdlen = 0;
2176 size_t rlen;
2177 register SV **idx;
2178
2179 idx = mark;
4633a7c4 2180 if (really) {
2181 tmps = SvPV(really,rlen);
2182 if (*tmps) {
2183 cmdlen += rlen + 1;
2184 idx++;
2185 }
a0d0e21e 2186 }
2187
2188 for (idx++; idx <= sp; idx++) {
2189 if (*idx) {
2190 junk = SvPVx(*idx,rlen);
2191 cmdlen += rlen ? rlen + 1 : 0;
2192 }
2193 }
e518068a 2194 New(401,Cmd,cmdlen+1,char);
a0d0e21e 2195
4633a7c4 2196 if (tmps && *tmps) {
2197 strcpy(Cmd,tmps);
a0d0e21e 2198 mark++;
2199 }
4633a7c4 2200 else *Cmd = '\0';
a0d0e21e 2201 while (++mark <= sp) {
2202 if (*mark) {
4633a7c4 2203 strcat(Cmd," ");
2204 strcat(Cmd,SvPVx(*mark,na));
a0d0e21e 2205 }
2206 }
4633a7c4 2207 return Cmd;
a0d0e21e 2208
2209} /* end of setup_argstr() */
2210
4633a7c4 2211
a0d0e21e 2212static unsigned long int
4633a7c4 2213setup_cmddsc(char *cmd, int check_img)
a0d0e21e 2214{
2215 char resspec[NAM$C_MAXRSS+1];
2216 $DESCRIPTOR(defdsc,".EXE");
2217 $DESCRIPTOR(resdsc,resspec);
2218 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2219 unsigned long int cxt = 0, flags = 1, retsts;
2220 register char *s, *rest, *cp;
2221 register int isdcl = 0;
2222
2223 s = cmd;
2224 while (*s && isspace(*s)) s++;
2225 if (check_img) {
2226 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2227 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
2228 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2229 if (*cp == ':' || *cp == '[' || *cp == '<') {
2230 isdcl = 0;
2231 break;
2232 }
2233 }
2234 }
2235 }
2236 else isdcl = 1;
2237 if (isdcl) { /* It's a DCL command, just do it. */
4633a7c4 2238 VMScmd.dsc$w_length = strlen(cmd);
e518068a 2239 if (cmd == Cmd) {
2240 VMScmd.dsc$a_pointer = Cmd;
2241 Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
2242 }
2243 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
a0d0e21e 2244 }
2245 else { /* assume first token is an image spec */
2246 cmd = s;
2247 while (*s && !isspace(*s)) s++;
2248 rest = *s ? s : 0;
2249 imgdsc.dsc$a_pointer = cmd;
2250 imgdsc.dsc$w_length = s - cmd;
2251 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4633a7c4 2252 if (!(retsts & 1)) {
2253 /* just hand off status values likely to be due to user error */
2254 if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
2255 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2256 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2257 else { _ckvmssts(retsts); }
2258 }
a0d0e21e 2259 else {
748a9306 2260 _ckvmssts(lib$find_file_end(&cxt));
a0d0e21e 2261 s = resspec;
2262 while (*s && !isspace(*s)) s++;
2263 *s = '\0';
e518068a 2264 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
4633a7c4 2265 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
2266 strcat(VMScmd.dsc$a_pointer,resspec);
2267 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
2268 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
a0d0e21e 2269 }
2270 }
2271
2272 return SS$_NORMAL;
2273} /* end of setup_cmddsc() */
2274
2275/* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2276bool
2277vms_do_aexec(SV *really,SV **mark,SV **sp)
2278{
a0d0e21e 2279 if (sp > mark) {
2280 if (vfork_called) { /* this follows a vfork - act Unixish */
748a9306 2281 vfork_called--;
2282 if (vfork_called < 0) {
2283 warn("Internal inconsistency in tracking vforks");
2284 vfork_called = 0;
2285 }
2286 else return do_aexec(really,mark,sp);
a0d0e21e 2287 }
4633a7c4 2288 /* no vfork - act VMSish */
2289 return vms_do_exec(setup_argstr(really,mark,sp));
748a9306 2290
a0d0e21e 2291 }
2292
2293 return FALSE;
2294} /* end of vms_do_aexec() */
2295/*}}}*/
2296
2297/* {{{bool vms_do_exec(char *cmd) */
2298bool
2299vms_do_exec(char *cmd)
2300{
2301
2302 if (vfork_called) { /* this follows a vfork - act Unixish */
748a9306 2303 vfork_called--;
2304 if (vfork_called < 0) {
2305 warn("Internal inconsistency in tracking vforks");
2306 vfork_called = 0;
2307 }
2308 else return do_exec(cmd);
a0d0e21e 2309 }
748a9306 2310
2311 { /* no vfork - act VMSish */
748a9306 2312 unsigned long int retsts;
a0d0e21e 2313
4633a7c4 2314 if ((retsts = setup_cmddsc(cmd,1)) & 1)
2315 retsts = lib$do_command(&VMScmd);
a0d0e21e 2316
748a9306 2317 set_errno(EVMSERR);
2318 set_vaxc_errno(retsts);
a0d0e21e 2319 if (dowarn)
4633a7c4 2320 warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
2321 vms_execfree();
a0d0e21e 2322 }
2323
2324 return FALSE;
2325
2326} /* end of vms_do_exec() */
2327/*}}}*/
2328
2329unsigned long int do_spawn(char *);
2330
2331/* {{{ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) */
2332unsigned long int
2333do_aspawn(SV *really,SV **mark,SV **sp)
2334{
4633a7c4 2335 if (sp > mark) return do_spawn(setup_argstr(really,mark,sp));
a0d0e21e 2336
2337 return SS$_ABORT;
2338} /* end of do_aspawn() */
2339/*}}}*/
2340
2341/* {{{unsigned long int do_spawn(char *cmd) */
2342unsigned long int
2343do_spawn(char *cmd)
2344{
4633a7c4 2345 unsigned long int substs, hadcmd = 1;
a0d0e21e 2346
748a9306 2347 if (!cmd || !*cmd) {
4633a7c4 2348 hadcmd = 0;
2349 _ckvmssts(lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0));
748a9306 2350 }
4633a7c4 2351 else if ((substs = setup_cmddsc(cmd,0)) & 1) {
2352 _ckvmssts(lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0));
748a9306 2353 }
a0d0e21e 2354
2355 if (!(substs&1)) {
748a9306 2356 set_errno(EVMSERR);
2357 set_vaxc_errno(substs);
a0d0e21e 2358 if (dowarn)
748a9306 2359 warn("Can't exec \"%s\": %s",
4633a7c4 2360 hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
a0d0e21e 2361 }
4633a7c4 2362 vms_execfree();
a0d0e21e 2363 return substs;
2364
2365} /* end of do_spawn() */
2366/*}}}*/
2367
2368/*
2369 * A simple fwrite replacement which outputs itmsz*nitm chars without
2370 * introducing record boundaries every itmsz chars.
2371 */
2372/*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
2373int
2374my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
2375{
2376 register char *cp, *end;
2377
2378 end = (char *)src + itmsz * nitm;
2379
2380 while ((char *)src <= end) {
2381 for (cp = src; cp <= end; cp++) if (!*cp) break;
2382 if (fputs(src,dest) == EOF) return EOF;
2383 if (cp < end)
2384 if (fputc('\0',dest) == EOF) return EOF;
2385 src = cp + 1;
2386 }
2387
2388 return 1;
2389
2390} /* end of my_fwrite() */
2391/*}}}*/
2392
748a9306 2393/*
2394 * Here are replacements for the following Unix routines in the VMS environment:
2395 * getpwuid Get information for a particular UIC or UID
2396 * getpwnam Get information for a named user
2397 * getpwent Get information for each user in the rights database
2398 * setpwent Reset search to the start of the rights database
2399 * endpwent Finish searching for users in the rights database
2400 *
2401 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
2402 * (defined in pwd.h), which contains the following fields:-
2403 * struct passwd {
2404 * char *pw_name; Username (in lower case)
2405 * char *pw_passwd; Hashed password
2406 * unsigned int pw_uid; UIC
2407 * unsigned int pw_gid; UIC group number
2408 * char *pw_unixdir; Default device/directory (VMS-style)
2409 * char *pw_gecos; Owner name
2410 * char *pw_dir; Default device/directory (Unix-style)
2411 * char *pw_shell; Default CLI name (eg. DCL)
2412 * };
2413 * If the specified user does not exist, getpwuid and getpwnam return NULL.
2414 *
2415 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
2416 * not the UIC member number (eg. what's returned by getuid()),
2417 * getpwuid() can accept either as input (if uid is specified, the caller's
2418 * UIC group is used), though it won't recognise gid=0.
2419 *
2420 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
2421 * information about other users in your group or in other groups, respectively.
2422 * If the required privilege is not available, then these routines fill only
2423 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
2424 * string).
2425 *
2426 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
2427 */
2428
2429/* sizes of various UAF record fields */
2430#define UAI$S_USERNAME 12
2431#define UAI$S_IDENT 31
2432#define UAI$S_OWNER 31
2433#define UAI$S_DEFDEV 31
2434#define UAI$S_DEFDIR 63
2435#define UAI$S_DEFCLI 31
2436#define UAI$S_PWD 8
2437
2438#define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
2439 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
2440 (uic).uic$v_group != UIC$K_WILD_GROUP)
2441
4633a7c4 2442static char __empty[]= "";
2443static struct passwd __passwd_empty=
748a9306 2444 {(char *) __empty, (char *) __empty, 0, 0,
2445 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
2446static int contxt= 0;
2447static struct passwd __pwdcache;
2448static char __pw_namecache[UAI$S_IDENT+1];
2449
2450static char *_mystrtolower(char *str)
2451{
2452 if (str) for (; *str; ++str) *str= tolower(*str);
2453 return str;
2454}
2455
2456/*
2457 * This routine does most of the work extracting the user information.
2458 */
2459static int fillpasswd (const char *name, struct passwd *pwd)
a0d0e21e 2460{
748a9306 2461 static struct {
2462 unsigned char length;
2463 char pw_gecos[UAI$S_OWNER+1];
2464 } owner;
2465 static union uicdef uic;
2466 static struct {
2467 unsigned char length;
2468 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
2469 } defdev;
2470 static struct {
2471 unsigned char length;
2472 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
2473 } defdir;
2474 static struct {
2475 unsigned char length;
2476 char pw_shell[UAI$S_DEFCLI+1];
2477 } defcli;
2478 static char pw_passwd[UAI$S_PWD+1];
2479
2480 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
2481 struct dsc$descriptor_s name_desc;
2482 int status;
2483
4633a7c4 2484 static struct itmlst_3 itmlst[]= {
748a9306 2485 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
2486 {sizeof(uic), UAI$_UIC, &uic, &luic},
2487 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
2488 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
2489 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
2490 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
2491 {0, 0, NULL, NULL}};
2492
2493 name_desc.dsc$w_length= strlen(name);
2494 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2495 name_desc.dsc$b_class= DSC$K_CLASS_S;
2496 name_desc.dsc$a_pointer= (char *) name;
2497
2498/* Note that sys$getuai returns many fields as counted strings. */
2499 status= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
2500 if (!(status&1)) return status;
2501
2502 if ((int) owner.length < lowner) lowner= (int) owner.length;
2503 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
2504 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
2505 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
2506 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
2507 owner.pw_gecos[lowner]= '\0';
2508 defdev.pw_dir[ldefdev+ldefdir]= '\0';
2509 defcli.pw_shell[ldefcli]= '\0';
2510 if (valid_uic(uic)) {
2511 pwd->pw_uid= uic.uic$l_uic;
2512 pwd->pw_gid= uic.uic$v_group;
2513 }
2514 else
2515 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
2516 pwd->pw_passwd= pw_passwd;
2517 pwd->pw_gecos= owner.pw_gecos;
2518 pwd->pw_dir= defdev.pw_dir;
2519 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
2520 pwd->pw_shell= defcli.pw_shell;
2521 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
2522 int ldir;
2523 ldir= strlen(pwd->pw_unixdir) - 1;
2524 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
2525 }
2526 else
2527 strcpy(pwd->pw_unixdir, pwd->pw_dir);
2528 _mystrtolower(pwd->pw_unixdir);
2529 return status;
a0d0e21e 2530}
748a9306 2531
2532/*
2533 * Get information for a named user.
2534*/
2535/*{{{struct passwd *getpwnam(char *name)*/
2536struct passwd *my_getpwnam(char *name)
2537{
2538 struct dsc$descriptor_s name_desc;
2539 union uicdef uic;
2540 unsigned long int status, stat;
2541
2542 __pwdcache = __passwd_empty;
2543 if ((status = fillpasswd(name, &__pwdcache)) == SS$_NOSYSPRV
2544 || status == SS$_NOGRPPRV || status == RMS$_RNF) {
2545 /* We still may be able to determine pw_uid and pw_gid */
2546 name_desc.dsc$w_length= strlen(name);
2547 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2548 name_desc.dsc$b_class= DSC$K_CLASS_S;
2549 name_desc.dsc$a_pointer= (char *) name;
2550 if ((stat = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
2551 __pwdcache.pw_uid= uic.uic$l_uic;
2552 __pwdcache.pw_gid= uic.uic$v_group;
2553 }
2554 else if (stat == SS$_NOSUCHID || stat == RMS$_PRV) return NULL;
2555 else { _ckvmssts(stat); }
2556 }
2557 else { _ckvmssts(status); }
2558 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
2559 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
2560 __pwdcache.pw_name= __pw_namecache;
2561 return &__pwdcache;
2562} /* end of my_getpwnam() */
a0d0e21e 2563/*}}}*/
2564
748a9306 2565/*
2566 * Get information for a particular UIC or UID.
2567 * Called by my_getpwent with uid=-1 to list all users.
2568*/
2569/*{{{struct passwd *my_getpwuid(Uid_t uid)*/
2570struct passwd *my_getpwuid(Uid_t uid)
a0d0e21e 2571{
748a9306 2572 const $DESCRIPTOR(name_desc,__pw_namecache);
2573 unsigned short lname;
2574 union uicdef uic;
2575 unsigned long int status;
2576
2577 if (uid == (unsigned int) -1) {
2578 do {
2579 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
2580 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
2581 my_endpwent();
2582 return NULL;
2583 }
2584 else { _ckvmssts(status); }
2585 } while (!valid_uic (uic));
2586 }
2587 else {
2588 uic.uic$l_uic= uid;
2589 if (!uic.uic$v_group) uic.uic$v_group= getgid();
2590 if (valid_uic(uic))
2591 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
2592 else status = SS$_IVIDENT;
2593 _ckvmssts(status);
2594 }
2595 __pw_namecache[lname]= '\0';
2596 _mystrtolower(__pw_namecache);
2597
2598 __pwdcache = __passwd_empty;
2599 __pwdcache.pw_name = __pw_namecache;
2600
2601/* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
2602 The identifier's value is usually the UIC, but it doesn't have to be,
2603 so if we can, we let fillpasswd update this. */
2604 __pwdcache.pw_uid = uic.uic$l_uic;
2605 __pwdcache.pw_gid = uic.uic$v_group;
2606
2607 status = fillpasswd(__pw_namecache, &__pwdcache);
2608 if (status != SS$_NOSYSPRV && status != SS$_NOGRPPRV &&
2609 status != RMS$_RNF) { _ckvmssts(status); }
2610 return &__pwdcache;
a0d0e21e 2611
748a9306 2612} /* end of my_getpwuid() */
2613/*}}}*/
2614
2615/*
2616 * Get information for next user.
2617*/
2618/*{{{struct passwd *my_getpwent()*/
2619struct passwd *my_getpwent()
2620{
2621 return (my_getpwuid((unsigned int) -1));
2622}
2623/*}}}*/
a0d0e21e 2624
748a9306 2625/*
2626 * Finish searching rights database for users.
2627*/
2628/*{{{void my_endpwent()*/
2629void my_endpwent()
2630{
2631 if (contxt) {
2632 _ckvmssts(sys$finish_rdb(&contxt));
2633 contxt= 0;
2634 }
a0d0e21e 2635}
2636/*}}}*/
748a9306 2637
e518068a 2638
2639/* my_gmtime
2640 * If the CRTL has a real gmtime(), use it, else look for the logical
2641 * name SYS$TIMEZONE_DIFFERENTIAL used by the native UTC routines on
2642 * VMS >= 6.0. Can be manually defined under earlier versions of VMS
2643 * to translate to the number of seconds which must be added to UTC
2644 * to get to the local time of the system.
2645 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
2646 */
2647
2648/*{{{struct tm *my_gmtime(const time_t *time)*/
2649/* We #defined 'gmtime' as 'my_gmtime' in vmsish.h. #undef it here
2650 * so we can call the CRTL's routine to see if it works.
2651 */
2652#undef gmtime
2653struct tm *
2654my_gmtime(const time_t *time)
2655{
2656 static int gmtime_emulation_type;
2657 static time_t utc_offset_secs;
2658 char *p;
2659 time_t when;
2660
2661 if (gmtime_emulation_type == 0) {
2662 gmtime_emulation_type++;
2663 when = 300000000;
2664 if (gmtime(&when) == NULL) { /* CRTL gmtime() is just a stub */
2665 gmtime_emulation_type++;
2666 if ((p = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL)
2667 gmtime_emulation_type++;
2668 else
2669 utc_offset_secs = (time_t) atol(p);
2670 }
2671 }
2672
2673 switch (gmtime_emulation_type) {
2674 case 1:
2675 return gmtime(time);
2676 case 2:
2677 when = *time - utc_offset_secs;
2678 return localtime(&when);
2679 default:
2680 warn("gmtime not supported on this system");
2681 return NULL;
2682 }
2683} /* end of my_gmtime() */
2684/* Reset definition for later calls */
2685#define gmtime(t) my_gmtime(t)
2686/*}}}*/
2687
2688
748a9306 2689/*
2690 * flex_stat, flex_fstat
2691 * basic stat, but gets it right when asked to stat
2692 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
2693 */
2694
2695/* encode_dev packs a VMS device name string into an integer to allow
2696 * simple comparisons. This can be used, for example, to check whether two
2697 * files are located on the same device, by comparing their encoded device
2698 * names. Even a string comparison would not do, because stat() reuses the
2699 * device name buffer for each call; so without encode_dev, it would be
2700 * necessary to save the buffer and use strcmp (this would mean a number of
2701 * changes to the standard Perl code, to say nothing of what a Perl script
2702 * would have to do.
2703 *
2704 * The device lock id, if it exists, should be unique (unless perhaps compared
2705 * with lock ids transferred from other nodes). We have a lock id if the disk is
2706 * mounted cluster-wide, which is when we tend to get long (host-qualified)
2707 * device names. Thus we use the lock id in preference, and only if that isn't
2708 * available, do we try to pack the device name into an integer (flagged by
2709 * the sign bit (LOCKID_MASK) being set).
2710 *
e518068a 2711 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
748a9306 2712 * name and its encoded form, but it seems very unlikely that we will find
2713 * two files on different disks that share the same encoded device names,
2714 * and even more remote that they will share the same file id (if the test
2715 * is to check for the same file).
2716 *
2717 * A better method might be to use sys$device_scan on the first call, and to
2718 * search for the device, returning an index into the cached array.
2719 * The number returned would be more intelligable.
2720 * This is probably not worth it, and anyway would take quite a bit longer
2721 * on the first call.
2722 */
2723#define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
2724static dev_t encode_dev (const char *dev)
2725{
2726 int i;
2727 unsigned long int f;
2728 dev_t enc;
2729 char c;
2730 const char *q;
2731
2732 if (!dev || !dev[0]) return 0;
2733
2734#if LOCKID_MASK
2735 {
2736 struct dsc$descriptor_s dev_desc;
2737 unsigned long int status, lockid, item = DVI$_LOCKID;
2738
2739 /* For cluster-mounted disks, the disk lock identifier is unique, so we
2740 can try that first. */
2741 dev_desc.dsc$w_length = strlen (dev);
2742 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
2743 dev_desc.dsc$b_class = DSC$K_CLASS_S;
2744 dev_desc.dsc$a_pointer = (char *) dev;
2745 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
2746 if (lockid) return (lockid & ~LOCKID_MASK);
2747 }
a0d0e21e 2748#endif
748a9306 2749
2750 /* Otherwise we try to encode the device name */
2751 enc = 0;
2752 f = 1;
2753 i = 0;
2754 for (q = dev + strlen(dev); q--; q >= dev) {
2755 if (isdigit (*q))
2756 c= (*q) - '0';
2757 else if (isalpha (toupper (*q)))
2758 c= toupper (*q) - 'A' + (char)10;
2759 else
2760 continue; /* Skip '$'s */
2761 i++;
2762 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
2763 if (i>1) f *= 36;
2764 enc += f * (unsigned long int) c;
2765 }
2766 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
2767
2768} /* end of encode_dev() */
2769
2770static char namecache[NAM$C_MAXRSS+1];
2771
2772static int
2773is_null_device(name)
2774 const char *name;
2775{
2776 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
2777 The underscore prefix, controller letter, and unit number are
2778 independently optional; for our purposes, the colon punctuation
2779 is not. The colon can be trailed by optional directory and/or
2780 filename, but two consecutive colons indicates a nodename rather
2781 than a device. [pr] */
2782 if (*name == '_') ++name;
2783 if (tolower(*name++) != 'n') return 0;
2784 if (tolower(*name++) != 'l') return 0;
2785 if (tolower(*name) == 'a') ++name;
2786 if (*name == '0') ++name;
2787 return (*name++ == ':') && (*name != ':');
2788}
2789
2790/* Do the permissions allow some operation? Assumes statcache already set. */
2791/* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
2792 * subset of the applicable information.
2793 */
2794/*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
2795I32
2796cando(I32 bit, I32 effective, struct stat *statbufp)
2797{
2798 if (statbufp == &statcache)
2799 return cando_by_name(bit,effective,namecache);
2800 else {
2801 char fname[NAM$C_MAXRSS+1];
2802 unsigned long int retsts;
2803 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
2804 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2805
2806 /* If the struct mystat is stale, we're OOL; stat() overwrites the
2807 device name on successive calls */
2808 devdsc.dsc$a_pointer = statbufp->st_devnam;
2809 devdsc.dsc$w_length = strlen(statbufp->st_devnam);
2810 namdsc.dsc$a_pointer = fname;
2811 namdsc.dsc$w_length = sizeof fname - 1;
2812
2813 retsts = lib$fid_to_name(&devdsc,statbufp->st_inode_u.fid,&namdsc,
2814 &namdsc.dsc$w_length,0,0);
2815 if (retsts & 1) {
2816 fname[namdsc.dsc$w_length] = '\0';
2817 return cando_by_name(bit,effective,fname);
2818 }
2819 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
2820 warn("Can't get filespec - stale stat buffer?\n");
2821 return FALSE;
2822 }
2823 _ckvmssts(retsts);
2824 return FALSE; /* Should never get to here */
2825 }
e518068a 2826} /* end of cando() */
748a9306 2827/*}}}*/
2828
2829/*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
2830I32
2831cando_by_name(I32 bit, I32 effective, char *fname)
2832{
2833 static char usrname[L_cuserid];
2834 static struct dsc$descriptor_s usrdsc =
2835 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
2836
2837 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
2838 unsigned short int retlen;
2839 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2840 union prvdef curprv;
2841 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
2842 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
2843 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
2844 {0,0,0,0}};
2845
2846 if (!fname || !*fname) return FALSE;
2847 if (!usrdsc.dsc$w_length) {
2848 cuserid(usrname);
2849 usrdsc.dsc$w_length = strlen(usrname);
2850 }
2851 namdsc.dsc$w_length = strlen(fname);
2852 namdsc.dsc$a_pointer = fname;
2853 switch (bit) {
2854 case S_IXUSR:
2855 case S_IXGRP:
2856 case S_IXOTH:
2857 access = ARM$M_EXECUTE;
2858 break;
2859 case S_IRUSR:
2860 case S_IRGRP:
2861 case S_IROTH:
2862 access = ARM$M_READ;
2863 break;
2864 case S_IWUSR:
2865 case S_IWGRP:
2866 case S_IWOTH:
2867 access = ARM$M_WRITE;
2868 break;
2869 case S_IDUSR:
2870 case S_IDGRP:
2871 case S_IDOTH:
2872 access = ARM$M_DELETE;
2873 break;
2874 default:
2875 return FALSE;
2876 }
2877
2878 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
e518068a 2879 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJ || retsts == RMS$_FNF ||
748a9306 2880 retsts == RMS$_DIR || retsts == RMS$_DEV) return FALSE;
2881 if (retsts == SS$_NORMAL) {
2882 if (!privused) return TRUE;
2883 /* We can get access, but only by using privs. Do we have the
2884 necessary privs currently enabled? */
2885 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
2886 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
2887 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv
2888 && !curprv.prv$v_bypass) return FALSE;
2889 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv
2890 && !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
2891 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
2892 return TRUE;
2893 }
2894 _ckvmssts(retsts);
2895
2896 return FALSE; /* Should never get here */
2897
2898} /* end of cando_by_name() */
2899/*}}}*/
2900
2901
2902/*{{{ int flex_fstat(int fd, struct stat *statbuf)*/
2903int
2904flex_fstat(int fd, struct stat *statbuf)
2905{
2906 char fspec[NAM$C_MAXRSS+1];
2907
2908 if (!getname(fd,fspec,1)) return -1;
2909 return flex_stat(fspec,statbuf);
2910
2911} /* end of flex_fstat() */
2912/*}}}*/
2913
2914/*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/
e518068a 2915/* We defined 'stat' as 'mystat' in vmsish.h so that declarations of
2916 * 'struct stat' elsewhere in Perl would use our struct. We go back
2917 * to the system version here, since we're actually calling their
2918 * stat().
2919 */
2920#undef stat
748a9306 2921int
e518068a 2922flex_stat(char *fspec, struct mystat *statbufp)
748a9306 2923{
2924 char fileified[NAM$C_MAXRSS+1];
2925 int retval,myretval;
e518068a 2926 struct mystat tmpbuf;
748a9306 2927
2928
2929 if (statbufp == &statcache) do_tovmsspec(fspec,namecache,0);
2930 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
2931 memset(statbufp,0,sizeof *statbufp);
2932 statbufp->st_dev = encode_dev("_NLA0:");
2933 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
2934 statbufp->st_uid = 0x00010001;
2935 statbufp->st_gid = 0x0001;
2936 time((time_t *)&statbufp->st_mtime);
2937 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
2938 return 0;
2939 }
2940
748a9306 2941 if (do_fileify_dirspec(fspec,fileified,0) == NULL) myretval = -1;
2942 else {
2943 myretval = stat(fileified,(stat_t *) &tmpbuf);
2944 }
2945 retval = stat(fspec,(stat_t *) statbufp);
2946 if (!myretval) {
2947 if (retval == -1) {
2948 *statbufp = tmpbuf;
2949 retval = 0;
2950 }
2951 else if (!retval) { /* Dir with same name. Substitute it. */
2952 statbufp->st_mode &= ~S_IFDIR;
2953 statbufp->st_mode |= tmpbuf.st_mode & S_IFDIR;
2954 strcpy(namecache,fileified);
2955 }
2956 }
2957 if (!retval) statbufp->st_dev = encode_dev(statbufp->st_devnam);
2958 return retval;
2959
2960} /* end of flex_stat() */
e518068a 2961/* Reset definition for later calls */
2962#define stat mystat
748a9306 2963/*}}}*/
2964
2965/*** The following glue provides 'hooks' to make some of the routines
2966 * from this file available from Perl. These routines are sufficiently
2967 * basic, and are required sufficiently early in the build process,
2968 * that's it's nice to have them available to miniperl as well as the
2969 * full Perl, so they're set up here instead of in an extension. The
2970 * Perl code which handles importation of these names into a given
2971 * package lives in [.VMS]Filespec.pm in @INC.
2972 */
2973
2974void
2975vmsify_fromperl(CV *cv)
2976{
2977 dXSARGS;
2978 char *vmsified;
2979
2980 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
2981 vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
2982 ST(0) = sv_newmortal();
2983 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
2984 XSRETURN(1);
2985}
2986
2987void
2988unixify_fromperl(CV *cv)
2989{
2990 dXSARGS;
2991 char *unixified;
2992
2993 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
2994 unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
2995 ST(0) = sv_newmortal();
2996 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
2997 XSRETURN(1);
2998}
2999
3000void
3001fileify_fromperl(CV *cv)
3002{
3003 dXSARGS;
3004 char *fileified;
3005
3006 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
3007 fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
3008 ST(0) = sv_newmortal();
3009 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
3010 XSRETURN(1);
3011}
3012
3013void
3014pathify_fromperl(CV *cv)
3015{
3016 dXSARGS;
3017 char *pathified;
3018
3019 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
3020 pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
3021 ST(0) = sv_newmortal();
3022 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
3023 XSRETURN(1);
3024}
3025
3026void
3027vmspath_fromperl(CV *cv)
3028{
3029 dXSARGS;
3030 char *vmspath;
3031
3032 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
3033 vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
3034 ST(0) = sv_newmortal();
3035 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
3036 XSRETURN(1);
3037}
3038
3039void
3040unixpath_fromperl(CV *cv)
3041{
3042 dXSARGS;
3043 char *unixpath;
3044
3045 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
3046 unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
3047 ST(0) = sv_newmortal();
3048 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
3049 XSRETURN(1);
3050}
3051
3052void
3053candelete_fromperl(CV *cv)
3054{
3055 dXSARGS;
3056 char vmsspec[NAM$C_MAXRSS+1];
3057
3058 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
3059 if (do_tovmsspec(SvPV(ST(0),na),buf,0) && cando_by_name(S_IDUSR,0,buf))
3060 ST(0) = &sv_yes;
3061 else ST(0) = &sv_no;
3062 XSRETURN(1);
3063}
3064
3065void
3066init_os_extras()
3067{
3068 char* file = __FILE__;
3069
3070 newXS("VMS::Filespec::vmsify",vmsify_fromperl,file);
3071 newXS("VMS::Filespec::unixify",unixify_fromperl,file);
3072 newXS("VMS::Filespec::pathify",pathify_fromperl,file);
3073 newXS("VMS::Filespec::fileify",fileify_fromperl,file);
3074 newXS("VMS::Filespec::vmspath",vmspath_fromperl,file);
3075 newXS("VMS::Filespec::unixpath",unixpath_fromperl,file);
3076 newXS("VMS::Filespec::candelete",candelete_fromperl,file);
3077 return;
3078}
3079
3080/* End of vms.c */
Unnamed repository; edit this file to name it for gitweb.