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