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