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