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