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