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