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