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