1 | /* vms.c |
---|
2 | * |
---|
3 | * VMS-specific routines for perl5 |
---|
4 | * Version: 5.7.0 |
---|
5 | * |
---|
6 | * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name, |
---|
7 | * and Perl_cando by Craig Berry |
---|
8 | * 29-Aug-2000 Charles Lane's piping improvements rolled in |
---|
9 | * 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu |
---|
10 | */ |
---|
11 | |
---|
12 | #include <acedef.h> |
---|
13 | #include <acldef.h> |
---|
14 | #include <armdef.h> |
---|
15 | #include <atrdef.h> |
---|
16 | #include <chpdef.h> |
---|
17 | #include <clidef.h> |
---|
18 | #include <climsgdef.h> |
---|
19 | #include <descrip.h> |
---|
20 | #include <devdef.h> |
---|
21 | #include <dvidef.h> |
---|
22 | #include <fibdef.h> |
---|
23 | #include <float.h> |
---|
24 | #include <fscndef.h> |
---|
25 | #include <iodef.h> |
---|
26 | #include <jpidef.h> |
---|
27 | #include <kgbdef.h> |
---|
28 | #include <libclidef.h> |
---|
29 | #include <libdef.h> |
---|
30 | #include <lib$routines.h> |
---|
31 | #include <lnmdef.h> |
---|
32 | #include <prvdef.h> |
---|
33 | #include <psldef.h> |
---|
34 | #include <rms.h> |
---|
35 | #include <shrdef.h> |
---|
36 | #include <ssdef.h> |
---|
37 | #include <starlet.h> |
---|
38 | #include <strdef.h> |
---|
39 | #include <str$routines.h> |
---|
40 | #include <syidef.h> |
---|
41 | #include <uaidef.h> |
---|
42 | #include <uicdef.h> |
---|
43 | |
---|
44 | /* Older versions of ssdef.h don't have these */ |
---|
45 | #ifndef SS$_INVFILFOROP |
---|
46 | # define SS$_INVFILFOROP 3930 |
---|
47 | #endif |
---|
48 | #ifndef SS$_NOSUCHOBJECT |
---|
49 | # define SS$_NOSUCHOBJECT 2696 |
---|
50 | #endif |
---|
51 | |
---|
52 | /* Don't replace system definitions of vfork, getenv, and stat, |
---|
53 | * code below needs to get to the underlying CRTL routines. */ |
---|
54 | #define DONT_MASK_RTL_CALLS |
---|
55 | #include "EXTERN.h" |
---|
56 | #include "perl.h" |
---|
57 | #include "XSUB.h" |
---|
58 | /* Anticipating future expansion in lexical warnings . . . */ |
---|
59 | #ifndef WARN_INTERNAL |
---|
60 | # define WARN_INTERNAL WARN_MISC |
---|
61 | #endif |
---|
62 | |
---|
63 | #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000 |
---|
64 | # define RTL_USES_UTC 1 |
---|
65 | #endif |
---|
66 | |
---|
67 | |
---|
68 | /* gcc's header files don't #define direct access macros |
---|
69 | * corresponding to VAXC's variant structs */ |
---|
70 | #ifdef __GNUC__ |
---|
71 | # define uic$v_format uic$r_uic_form.uic$v_format |
---|
72 | # define uic$v_group uic$r_uic_form.uic$v_group |
---|
73 | # define uic$v_member uic$r_uic_form.uic$v_member |
---|
74 | # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass |
---|
75 | # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv |
---|
76 | # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall |
---|
77 | # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv |
---|
78 | #endif |
---|
79 | |
---|
80 | #if defined(NEED_AN_H_ERRNO) |
---|
81 | dEXT int h_errno; |
---|
82 | #endif |
---|
83 | |
---|
84 | struct itmlst_3 { |
---|
85 | unsigned short int buflen; |
---|
86 | unsigned short int itmcode; |
---|
87 | void *bufadr; |
---|
88 | unsigned short int *retlen; |
---|
89 | }; |
---|
90 | |
---|
91 | #define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c) |
---|
92 | #define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c) |
---|
93 | #define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c) |
---|
94 | #define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c) |
---|
95 | #define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e) |
---|
96 | #define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c) |
---|
97 | #define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c) |
---|
98 | #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d) |
---|
99 | #define getredirection(a,b) mp_getredirection(aTHX_ a,b) |
---|
100 | |
---|
101 | /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */ |
---|
102 | #define PERL_LNM_MAX_ALLOWED_INDEX 127 |
---|
103 | |
---|
104 | static char *__mystrtolower(char *str) |
---|
105 | { |
---|
106 | if (str) for (; *str; ++str) *str= tolower(*str); |
---|
107 | return str; |
---|
108 | } |
---|
109 | |
---|
110 | static struct dsc$descriptor_s fildevdsc = |
---|
111 | { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" }; |
---|
112 | static struct dsc$descriptor_s crtlenvdsc = |
---|
113 | { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" }; |
---|
114 | static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL }; |
---|
115 | static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL }; |
---|
116 | static struct dsc$descriptor_s **env_tables = defenv; |
---|
117 | static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */ |
---|
118 | |
---|
119 | /* True if we shouldn't treat barewords as logicals during directory */ |
---|
120 | /* munching */ |
---|
121 | static int no_translate_barewords; |
---|
122 | |
---|
123 | /* Temp for subprocess commands */ |
---|
124 | static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch}; |
---|
125 | |
---|
126 | #ifndef RTL_USES_UTC |
---|
127 | static int tz_updated = 1; |
---|
128 | #endif |
---|
129 | |
---|
130 | /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */ |
---|
131 | int |
---|
132 | Perl_vmstrnenv(pTHX_ const char *lnm, char *eqv, unsigned long int idx, |
---|
133 | struct dsc$descriptor_s **tabvec, unsigned long int flags) |
---|
134 | { |
---|
135 | char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2; |
---|
136 | unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure; |
---|
137 | unsigned long int retsts, attr = LNM$M_CASE_BLIND; |
---|
138 | unsigned char acmode; |
---|
139 | struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0}, |
---|
140 | tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0}; |
---|
141 | struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0}, |
---|
142 | {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen}, |
---|
143 | {0, 0, 0, 0}}; |
---|
144 | $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM"); |
---|
145 | #if defined(USE_THREADS) |
---|
146 | /* We jump through these hoops because we can be called at */ |
---|
147 | /* platform-specific initialization time, which is before anything is */ |
---|
148 | /* set up--we can't even do a plain dTHX since that relies on the */ |
---|
149 | /* interpreter structure to be initialized */ |
---|
150 | struct perl_thread *thr; |
---|
151 | if (PL_curinterp) { |
---|
152 | thr = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv); |
---|
153 | } else { |
---|
154 | thr = NULL; |
---|
155 | } |
---|
156 | #endif |
---|
157 | |
---|
158 | if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) { |
---|
159 | set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0; |
---|
160 | } |
---|
161 | for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) { |
---|
162 | *cp2 = _toupper(*cp1); |
---|
163 | if (cp1 - lnm > LNM$C_NAMLENGTH) { |
---|
164 | set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM); |
---|
165 | return 0; |
---|
166 | } |
---|
167 | } |
---|
168 | lnmdsc.dsc$w_length = cp1 - lnm; |
---|
169 | lnmdsc.dsc$a_pointer = uplnm; |
---|
170 | uplnm[lnmdsc.dsc$w_length] = '\0'; |
---|
171 | secure = flags & PERL__TRNENV_SECURE; |
---|
172 | acmode = secure ? PSL$C_EXEC : PSL$C_USER; |
---|
173 | if (!tabvec || !*tabvec) tabvec = env_tables; |
---|
174 | |
---|
175 | for (curtab = 0; tabvec[curtab]; curtab++) { |
---|
176 | if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) { |
---|
177 | if (!ivenv && !secure) { |
---|
178 | char *eq, *end; |
---|
179 | int i; |
---|
180 | if (!environ) { |
---|
181 | ivenv = 1; |
---|
182 | Perl_warn(aTHX_ "Can't read CRTL environ\n"); |
---|
183 | continue; |
---|
184 | } |
---|
185 | retsts = SS$_NOLOGNAM; |
---|
186 | for (i = 0; environ[i]; i++) { |
---|
187 | if ((eq = strchr(environ[i],'=')) && |
---|
188 | !strncmp(environ[i],uplnm,eq - environ[i])) { |
---|
189 | eq++; |
---|
190 | for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen]; |
---|
191 | if (!eqvlen) continue; |
---|
192 | retsts = SS$_NORMAL; |
---|
193 | break; |
---|
194 | } |
---|
195 | } |
---|
196 | if (retsts != SS$_NOLOGNAM) break; |
---|
197 | } |
---|
198 | } |
---|
199 | else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) && |
---|
200 | !str$case_blind_compare(&tmpdsc,&clisym)) { |
---|
201 | if (!ivsym && !secure) { |
---|
202 | unsigned short int deflen = LNM$C_NAMLENGTH; |
---|
203 | struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0}; |
---|
204 | /* dynamic dsc to accomodate possible long value */ |
---|
205 | _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc)); |
---|
206 | retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0); |
---|
207 | if (retsts & 1) { |
---|
208 | if (eqvlen > 1024) { |
---|
209 | set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU); |
---|
210 | eqvlen = 1024; |
---|
211 | /* Special hack--we might be called before the interpreter's */ |
---|
212 | /* fully initialized, in which case either thr or PL_curcop */ |
---|
213 | /* might be bogus. We have to check, since ckWARN needs them */ |
---|
214 | /* both to be valid if running threaded */ |
---|
215 | #if defined(USE_THREADS) |
---|
216 | if (thr && PL_curcop) { |
---|
217 | #endif |
---|
218 | if (ckWARN(WARN_MISC)) { |
---|
219 | Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm); |
---|
220 | } |
---|
221 | #if defined(USE_THREADS) |
---|
222 | } else { |
---|
223 | Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm); |
---|
224 | } |
---|
225 | #endif |
---|
226 | |
---|
227 | } |
---|
228 | strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen); |
---|
229 | } |
---|
230 | _ckvmssts(lib$sfree1_dd(&eqvdsc)); |
---|
231 | if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; } |
---|
232 | if (retsts == LIB$_NOSUCHSYM) continue; |
---|
233 | break; |
---|
234 | } |
---|
235 | } |
---|
236 | else if (!ivlnm) { |
---|
237 | retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst); |
---|
238 | if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; } |
---|
239 | if (retsts == SS$_NOLOGNAM) continue; |
---|
240 | /* PPFs have a prefix */ |
---|
241 | if ( |
---|
242 | #if INTSIZE == 4 |
---|
243 | *((int *)uplnm) == *((int *)"SYS$") && |
---|
244 | #endif |
---|
245 | eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 && |
---|
246 | ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) || |
---|
247 | (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) || |
---|
248 | (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) || |
---|
249 | (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) { |
---|
250 | memcpy(eqv,eqv+4,eqvlen-4); |
---|
251 | eqvlen -= 4; |
---|
252 | } |
---|
253 | break; |
---|
254 | } |
---|
255 | } |
---|
256 | if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; } |
---|
257 | else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM || |
---|
258 | retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB || |
---|
259 | retsts == SS$_NOLOGNAM) { |
---|
260 | set_errno(EINVAL); set_vaxc_errno(retsts); |
---|
261 | } |
---|
262 | else _ckvmssts(retsts); |
---|
263 | return 0; |
---|
264 | } /* end of vmstrnenv */ |
---|
265 | /*}}}*/ |
---|
266 | |
---|
267 | /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/ |
---|
268 | /* Define as a function so we can access statics. */ |
---|
269 | int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx) |
---|
270 | { |
---|
271 | return vmstrnenv(lnm,eqv,idx,fildev, |
---|
272 | #ifdef SECURE_INTERNAL_GETENV |
---|
273 | (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0 |
---|
274 | #else |
---|
275 | 0 |
---|
276 | #endif |
---|
277 | ); |
---|
278 | } |
---|
279 | /*}}}*/ |
---|
280 | |
---|
281 | /* my_getenv |
---|
282 | * Note: Uses Perl temp to store result so char * can be returned to |
---|
283 | * caller; this pointer will be invalidated at next Perl statement |
---|
284 | * transition. |
---|
285 | * We define this as a function rather than a macro in terms of my_getenv_len() |
---|
286 | * so that it'll work when PL_curinterp is undefined (and we therefore can't |
---|
287 | * allocate SVs). |
---|
288 | */ |
---|
289 | /*{{{ char *my_getenv(const char *lnm, bool sys)*/ |
---|
290 | char * |
---|
291 | Perl_my_getenv(pTHX_ const char *lnm, bool sys) |
---|
292 | { |
---|
293 | static char __my_getenv_eqv[LNM$C_NAMLENGTH+1]; |
---|
294 | char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv; |
---|
295 | unsigned long int idx = 0; |
---|
296 | int trnsuccess, success, secure, saverr, savvmserr; |
---|
297 | SV *tmpsv; |
---|
298 | |
---|
299 | if (PL_curinterp) { /* Perl interpreter running -- may be threaded */ |
---|
300 | /* Set up a temporary buffer for the return value; Perl will |
---|
301 | * clean it up at the next statement transition */ |
---|
302 | tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1)); |
---|
303 | if (!tmpsv) return NULL; |
---|
304 | eqv = SvPVX(tmpsv); |
---|
305 | } |
---|
306 | else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */ |
---|
307 | for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1); |
---|
308 | if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) { |
---|
309 | getcwd(eqv,LNM$C_NAMLENGTH); |
---|
310 | return eqv; |
---|
311 | } |
---|
312 | else { |
---|
313 | if ((cp2 = strchr(lnm,';')) != NULL) { |
---|
314 | strcpy(uplnm,lnm); |
---|
315 | uplnm[cp2-lnm] = '\0'; |
---|
316 | idx = strtoul(cp2+1,NULL,0); |
---|
317 | lnm = uplnm; |
---|
318 | } |
---|
319 | /* Impose security constraints only if tainting */ |
---|
320 | if (sys) { |
---|
321 | /* Impose security constraints only if tainting */ |
---|
322 | secure = PL_curinterp ? PL_tainting : will_taint; |
---|
323 | saverr = errno; savvmserr = vaxc$errno; |
---|
324 | } |
---|
325 | else secure = 0; |
---|
326 | success = vmstrnenv(lnm,eqv,idx, |
---|
327 | secure ? fildev : NULL, |
---|
328 | #ifdef SECURE_INTERNAL_GETENV |
---|
329 | secure ? PERL__TRNENV_SECURE : 0 |
---|
330 | #else |
---|
331 | 0 |
---|
332 | #endif |
---|
333 | ); |
---|
334 | /* Discard NOLOGNAM on internal calls since we're often looking |
---|
335 | * for an optional name, and this "error" often shows up as the |
---|
336 | * (bogus) exit status for a die() call later on. */ |
---|
337 | if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr); |
---|
338 | return success ? eqv : Nullch; |
---|
339 | } |
---|
340 | |
---|
341 | } /* end of my_getenv() */ |
---|
342 | /*}}}*/ |
---|
343 | |
---|
344 | |
---|
345 | /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/ |
---|
346 | char * |
---|
347 | my_getenv_len(const char *lnm, unsigned long *len, bool sys) |
---|
348 | { |
---|
349 | dTHX; |
---|
350 | char *buf, *cp1, *cp2; |
---|
351 | unsigned long idx = 0; |
---|
352 | static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1]; |
---|
353 | int secure, saverr, savvmserr; |
---|
354 | SV *tmpsv; |
---|
355 | |
---|
356 | if (PL_curinterp) { /* Perl interpreter running -- may be threaded */ |
---|
357 | /* Set up a temporary buffer for the return value; Perl will |
---|
358 | * clean it up at the next statement transition */ |
---|
359 | tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1)); |
---|
360 | if (!tmpsv) return NULL; |
---|
361 | buf = SvPVX(tmpsv); |
---|
362 | } |
---|
363 | else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */ |
---|
364 | for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1); |
---|
365 | if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) { |
---|
366 | getcwd(buf,LNM$C_NAMLENGTH); |
---|
367 | *len = strlen(buf); |
---|
368 | return buf; |
---|
369 | } |
---|
370 | else { |
---|
371 | if ((cp2 = strchr(lnm,';')) != NULL) { |
---|
372 | strcpy(buf,lnm); |
---|
373 | buf[cp2-lnm] = '\0'; |
---|
374 | idx = strtoul(cp2+1,NULL,0); |
---|
375 | lnm = buf; |
---|
376 | } |
---|
377 | if (sys) { |
---|
378 | /* Impose security constraints only if tainting */ |
---|
379 | secure = PL_curinterp ? PL_tainting : will_taint; |
---|
380 | saverr = errno; savvmserr = vaxc$errno; |
---|
381 | } |
---|
382 | else secure = 0; |
---|
383 | *len = vmstrnenv(lnm,buf,idx, |
---|
384 | secure ? fildev : NULL, |
---|
385 | #ifdef SECURE_INTERNAL_GETENV |
---|
386 | secure ? PERL__TRNENV_SECURE : 0 |
---|
387 | #else |
---|
388 | 0 |
---|
389 | #endif |
---|
390 | ); |
---|
391 | /* Discard NOLOGNAM on internal calls since we're often looking |
---|
392 | * for an optional name, and this "error" often shows up as the |
---|
393 | * (bogus) exit status for a die() call later on. */ |
---|
394 | if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr); |
---|
395 | return *len ? buf : Nullch; |
---|
396 | } |
---|
397 | |
---|
398 | } /* end of my_getenv_len() */ |
---|
399 | /*}}}*/ |
---|
400 | |
---|
401 | static void create_mbx(unsigned short int *, struct dsc$descriptor_s *); |
---|
402 | |
---|
403 | static void riseandshine(unsigned long int dummy) { sys$wake(0,0); } |
---|
404 | |
---|
405 | /*{{{ void prime_env_iter() */ |
---|
406 | void |
---|
407 | prime_env_iter(void) |
---|
408 | /* Fill the %ENV associative array with all logical names we can |
---|
409 | * find, in preparation for iterating over it. |
---|
410 | */ |
---|
411 | { |
---|
412 | dTHX; |
---|
413 | static int primed = 0; |
---|
414 | HV *seenhv = NULL, *envhv; |
---|
415 | char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch; |
---|
416 | unsigned short int chan; |
---|
417 | #ifndef CLI$M_TRUSTED |
---|
418 | # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */ |
---|
419 | #endif |
---|
420 | unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED; |
---|
421 | unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0; |
---|
422 | long int i; |
---|
423 | bool have_sym = FALSE, have_lnm = FALSE; |
---|
424 | struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0}; |
---|
425 | $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:"); |
---|
426 | $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES"); |
---|
427 | $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM"); |
---|
428 | $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam); |
---|
429 | #if defined(USE_THREADS) || defined(USE_ITHREADS) |
---|
430 | static perl_mutex primenv_mutex; |
---|
431 | MUTEX_INIT(&primenv_mutex); |
---|
432 | #endif |
---|
433 | |
---|
434 | if (primed || !PL_envgv) return; |
---|
435 | MUTEX_LOCK(&primenv_mutex); |
---|
436 | if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; } |
---|
437 | envhv = GvHVn(PL_envgv); |
---|
438 | /* Perform a dummy fetch as an lval to insure that the hash table is |
---|
439 | * set up. Otherwise, the hv_store() will turn into a nullop. */ |
---|
440 | (void) hv_fetch(envhv,"DEFAULT",7,TRUE); |
---|
441 | |
---|
442 | for (i = 0; env_tables[i]; i++) { |
---|
443 | if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) && |
---|
444 | !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1; |
---|
445 | if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1; |
---|
446 | } |
---|
447 | if (have_sym || have_lnm) { |
---|
448 | long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM; |
---|
449 | _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0)); |
---|
450 | _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0)); |
---|
451 | _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length)); |
---|
452 | } |
---|
453 | |
---|
454 | for (i--; i >= 0; i--) { |
---|
455 | if (!str$case_blind_compare(env_tables[i],&crtlenv)) { |
---|
456 | char *start; |
---|
457 | int j; |
---|
458 | for (j = 0; environ[j]; j++) { |
---|
459 | if (!(start = strchr(environ[j],'='))) { |
---|
460 | if (ckWARN(WARN_INTERNAL)) |
---|
461 | Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]); |
---|
462 | } |
---|
463 | else { |
---|
464 | start++; |
---|
465 | (void) hv_store(envhv,environ[j],start - environ[j] - 1, |
---|
466 | newSVpv(start,0),0); |
---|
467 | } |
---|
468 | } |
---|
469 | continue; |
---|
470 | } |
---|
471 | else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) && |
---|
472 | !str$case_blind_compare(&tmpdsc,&clisym)) { |
---|
473 | strcpy(cmd,"Show Symbol/Global *"); |
---|
474 | cmddsc.dsc$w_length = 20; |
---|
475 | if (env_tables[i]->dsc$w_length == 12 && |
---|
476 | (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) && |
---|
477 | !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *"); |
---|
478 | flags = defflags | CLI$M_NOLOGNAM; |
---|
479 | } |
---|
480 | else { |
---|
481 | strcpy(cmd,"Show Logical *"); |
---|
482 | if (str$case_blind_compare(env_tables[i],&fildevdsc)) { |
---|
483 | strcat(cmd," /Table="); |
---|
484 | strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length); |
---|
485 | cmddsc.dsc$w_length = strlen(cmd); |
---|
486 | } |
---|
487 | else cmddsc.dsc$w_length = 14; /* N.B. We test this below */ |
---|
488 | flags = defflags | CLI$M_NOCLISYM; |
---|
489 | } |
---|
490 | |
---|
491 | /* Create a new subprocess to execute each command, to exclude the |
---|
492 | * remote possibility that someone could subvert a mbx or file used |
---|
493 | * to write multiple commands to a single subprocess. |
---|
494 | */ |
---|
495 | do { |
---|
496 | retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs, |
---|
497 | 0,&riseandshine,0,0,&clidsc,&clitabdsc); |
---|
498 | flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */ |
---|
499 | defflags &= ~CLI$M_TRUSTED; |
---|
500 | } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED)); |
---|
501 | _ckvmssts(retsts); |
---|
502 | if (!buf) New(1322,buf,mbxbufsiz + 1,char); |
---|
503 | if (seenhv) SvREFCNT_dec(seenhv); |
---|
504 | seenhv = newHV(); |
---|
505 | while (1) { |
---|
506 | char *cp1, *cp2, *key; |
---|
507 | unsigned long int sts, iosb[2], retlen, keylen; |
---|
508 | register U32 hash; |
---|
509 | |
---|
510 | sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0); |
---|
511 | if (sts & 1) sts = iosb[0] & 0xffff; |
---|
512 | if (sts == SS$_ENDOFFILE) { |
---|
513 | int wakect = 0; |
---|
514 | while (substs == 0) { sys$hiber(); wakect++;} |
---|
515 | if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */ |
---|
516 | _ckvmssts(substs); |
---|
517 | break; |
---|
518 | } |
---|
519 | _ckvmssts(sts); |
---|
520 | retlen = iosb[0] >> 16; |
---|
521 | if (!retlen) continue; /* blank line */ |
---|
522 | buf[retlen] = '\0'; |
---|
523 | if (iosb[1] != subpid) { |
---|
524 | if (iosb[1]) { |
---|
525 | Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf); |
---|
526 | } |
---|
527 | continue; |
---|
528 | } |
---|
529 | if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL)) |
---|
530 | Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf); |
---|
531 | |
---|
532 | for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ; |
---|
533 | if (*cp1 == '(' || /* Logical name table name */ |
---|
534 | *cp1 == '=' /* Next eqv of searchlist */) continue; |
---|
535 | if (*cp1 == '"') cp1++; |
---|
536 | for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ; |
---|
537 | key = cp1; keylen = cp2 - cp1; |
---|
538 | if (keylen && hv_exists(seenhv,key,keylen)) continue; |
---|
539 | while (*cp2 && *cp2 != '=') cp2++; |
---|
540 | while (*cp2 && *cp2 == '=') cp2++; |
---|
541 | while (*cp2 && *cp2 == ' ') cp2++; |
---|
542 | if (*cp2 == '"') { /* String translation; may embed "" */ |
---|
543 | for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ; |
---|
544 | cp2++; cp1--; /* Skip "" surrounding translation */ |
---|
545 | } |
---|
546 | else { /* Numeric translation */ |
---|
547 | for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ; |
---|
548 | cp1--; /* stop on last non-space char */ |
---|
549 | } |
---|
550 | if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) { |
---|
551 | Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf); |
---|
552 | continue; |
---|
553 | } |
---|
554 | PERL_HASH(hash,key,keylen); |
---|
555 | hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash); |
---|
556 | hv_store(seenhv,key,keylen,&PL_sv_yes,hash); |
---|
557 | } |
---|
558 | if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */ |
---|
559 | /* get the PPFs for this process, not the subprocess */ |
---|
560 | char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL}; |
---|
561 | char eqv[LNM$C_NAMLENGTH+1]; |
---|
562 | int trnlen, i; |
---|
563 | for (i = 0; ppfs[i]; i++) { |
---|
564 | trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0); |
---|
565 | hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0); |
---|
566 | } |
---|
567 | } |
---|
568 | } |
---|
569 | primed = 1; |
---|
570 | if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan)); |
---|
571 | if (buf) Safefree(buf); |
---|
572 | if (seenhv) SvREFCNT_dec(seenhv); |
---|
573 | MUTEX_UNLOCK(&primenv_mutex); |
---|
574 | return; |
---|
575 | |
---|
576 | } /* end of prime_env_iter */ |
---|
577 | /*}}}*/ |
---|
578 | |
---|
579 | |
---|
580 | /*{{{ int vmssetenv(char *lnm, char *eqv)*/ |
---|
581 | /* Define or delete an element in the same "environment" as |
---|
582 | * vmstrnenv(). If an element is to be deleted, it's removed from |
---|
583 | * the first place it's found. If it's to be set, it's set in the |
---|
584 | * place designated by the first element of the table vector. |
---|
585 | * Like setenv() returns 0 for success, non-zero on error. |
---|
586 | */ |
---|
587 | int |
---|
588 | vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) |
---|
589 | { |
---|
590 | char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2; |
---|
591 | unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0; |
---|
592 | unsigned long int retsts, usermode = PSL$C_USER; |
---|
593 | struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm}, |
---|
594 | eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0}, |
---|
595 | tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0}; |
---|
596 | $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM"); |
---|
597 | $DESCRIPTOR(local,"_LOCAL"); |
---|
598 | dTHX; |
---|
599 | |
---|
600 | for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) { |
---|
601 | *cp2 = _toupper(*cp1); |
---|
602 | if (cp1 - lnm > LNM$C_NAMLENGTH) { |
---|
603 | set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM); |
---|
604 | return SS$_IVLOGNAM; |
---|
605 | } |
---|
606 | } |
---|
607 | lnmdsc.dsc$w_length = cp1 - lnm; |
---|
608 | if (!tabvec || !*tabvec) tabvec = env_tables; |
---|
609 | |
---|
610 | if (!eqv) { /* we're deleting n element */ |
---|
611 | for (curtab = 0; tabvec[curtab]; curtab++) { |
---|
612 | if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) { |
---|
613 | int i; |
---|
614 | for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */ |
---|
615 | if ((cp1 = strchr(environ[i],'=')) && |
---|
616 | !strncmp(environ[i],lnm,cp1 - environ[i])) { |
---|
617 | #ifdef HAS_SETENV |
---|
618 | return setenv(lnm,"",1) ? vaxc$errno : 0; |
---|
619 | } |
---|
620 | } |
---|
621 | ivenv = 1; retsts = SS$_NOLOGNAM; |
---|
622 | #else |
---|
623 | if (ckWARN(WARN_INTERNAL)) |
---|
624 | Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm); |
---|
625 | ivenv = 1; retsts = SS$_NOSUCHPGM; |
---|
626 | break; |
---|
627 | } |
---|
628 | } |
---|
629 | #endif |
---|
630 | } |
---|
631 | else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) && |
---|
632 | !str$case_blind_compare(&tmpdsc,&clisym)) { |
---|
633 | unsigned int symtype; |
---|
634 | if (tabvec[curtab]->dsc$w_length == 12 && |
---|
635 | (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) && |
---|
636 | !str$case_blind_compare(&tmpdsc,&local)) |
---|
637 | symtype = LIB$K_CLI_LOCAL_SYM; |
---|
638 | else symtype = LIB$K_CLI_GLOBAL_SYM; |
---|
639 | retsts = lib$delete_symbol(&lnmdsc,&symtype); |
---|
640 | if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; } |
---|
641 | if (retsts == LIB$_NOSUCHSYM) continue; |
---|
642 | break; |
---|
643 | } |
---|
644 | else if (!ivlnm) { |
---|
645 | retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */ |
---|
646 | if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; } |
---|
647 | if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break; |
---|
648 | retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */ |
---|
649 | if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break; |
---|
650 | } |
---|
651 | } |
---|
652 | } |
---|
653 | else { /* we're defining a value */ |
---|
654 | if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) { |
---|
655 | #ifdef HAS_SETENV |
---|
656 | return setenv(lnm,eqv,1) ? vaxc$errno : 0; |
---|
657 | #else |
---|
658 | if (ckWARN(WARN_INTERNAL)) |
---|
659 | Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv); |
---|
660 | retsts = SS$_NOSUCHPGM; |
---|
661 | #endif |
---|
662 | } |
---|
663 | else { |
---|
664 | eqvdsc.dsc$a_pointer = eqv; |
---|
665 | eqvdsc.dsc$w_length = strlen(eqv); |
---|
666 | if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) && |
---|
667 | !str$case_blind_compare(&tmpdsc,&clisym)) { |
---|
668 | unsigned int symtype; |
---|
669 | if (tabvec[0]->dsc$w_length == 12 && |
---|
670 | (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) && |
---|
671 | !str$case_blind_compare(&tmpdsc,&local)) |
---|
672 | symtype = LIB$K_CLI_LOCAL_SYM; |
---|
673 | else symtype = LIB$K_CLI_GLOBAL_SYM; |
---|
674 | retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype); |
---|
675 | } |
---|
676 | else { |
---|
677 | if (!*eqv) eqvdsc.dsc$w_length = 1; |
---|
678 | if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) { |
---|
679 | eqvdsc.dsc$w_length = LNM$C_NAMLENGTH; |
---|
680 | if (ckWARN(WARN_MISC)) { |
---|
681 | Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH); |
---|
682 | } |
---|
683 | } |
---|
684 | retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0); |
---|
685 | } |
---|
686 | } |
---|
687 | } |
---|
688 | if (!(retsts & 1)) { |
---|
689 | switch (retsts) { |
---|
690 | case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM: |
---|
691 | case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB: |
---|
692 | set_errno(EVMSERR); break; |
---|
693 | case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM: |
---|
694 | case LIB$_NOSUCHSYM: case SS$_NOLOGNAM: |
---|
695 | set_errno(EINVAL); break; |
---|
696 | case SS$_NOPRIV: |
---|
697 | set_errno(EACCES); |
---|
698 | default: |
---|
699 | _ckvmssts(retsts); |
---|
700 | set_errno(EVMSERR); |
---|
701 | } |
---|
702 | set_vaxc_errno(retsts); |
---|
703 | return (int) retsts || 44; /* retsts should never be 0, but just in case */ |
---|
704 | } |
---|
705 | else { |
---|
706 | /* We reset error values on success because Perl does an hv_fetch() |
---|
707 | * before each hv_store(), and if the thing we're setting didn't |
---|
708 | * previously exist, we've got a leftover error message. (Of course, |
---|
709 | * this fails in the face of |
---|
710 | * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo'; |
---|
711 | * in that the error reported in $! isn't spurious, |
---|
712 | * but it's right more often than not.) |
---|
713 | */ |
---|
714 | set_errno(0); set_vaxc_errno(retsts); |
---|
715 | return 0; |
---|
716 | } |
---|
717 | |
---|
718 | } /* end of vmssetenv() */ |
---|
719 | /*}}}*/ |
---|
720 | |
---|
721 | /*{{{ void my_setenv(char *lnm, char *eqv)*/ |
---|
722 | /* This has to be a function since there's a prototype for it in proto.h */ |
---|
723 | void |
---|
724 | Perl_my_setenv(pTHX_ char *lnm,char *eqv) |
---|
725 | { |
---|
726 | if (lnm && *lnm) { |
---|
727 | int len = strlen(lnm); |
---|
728 | if (len == 7) { |
---|
729 | char uplnm[8]; |
---|
730 | int i; |
---|
731 | for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]); |
---|
732 | if (!strcmp(uplnm,"DEFAULT")) { |
---|
733 | if (eqv && *eqv) chdir(eqv); |
---|
734 | return; |
---|
735 | } |
---|
736 | } |
---|
737 | #ifndef RTL_USES_UTC |
---|
738 | if (len == 6 || len == 2) { |
---|
739 | char uplnm[7]; |
---|
740 | int i; |
---|
741 | for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]); |
---|
742 | uplnm[len] = '\0'; |
---|
743 | if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1; |
---|
744 | if (!strcmp(uplnm,"TZ")) tz_updated = 1; |
---|
745 | } |
---|
746 | #endif |
---|
747 | } |
---|
748 | (void) vmssetenv(lnm,eqv,NULL); |
---|
749 | } |
---|
750 | /*}}}*/ |
---|
751 | |
---|
752 | /*{{{static void vmssetuserlnm(char *name, char *eqv); |
---|
753 | /* vmssetuserlnm |
---|
754 | * sets a user-mode logical in the process logical name table |
---|
755 | * used for redirection of sys$error |
---|
756 | */ |
---|
757 | void |
---|
758 | Perl_vmssetuserlnm(char *name, char *eqv) |
---|
759 | { |
---|
760 | $DESCRIPTOR(d_tab, "LNM$PROCESS"); |
---|
761 | struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0}; |
---|
762 | unsigned long int iss, attr = LNM$M_CONFINE; |
---|
763 | unsigned char acmode = PSL$C_USER; |
---|
764 | struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0}, |
---|
765 | {0, 0, 0, 0}}; |
---|
766 | d_name.dsc$a_pointer = name; |
---|
767 | d_name.dsc$w_length = strlen(name); |
---|
768 | |
---|
769 | lnmlst[0].buflen = strlen(eqv); |
---|
770 | lnmlst[0].bufadr = eqv; |
---|
771 | |
---|
772 | iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst); |
---|
773 | if (!(iss&1)) lib$signal(iss); |
---|
774 | } |
---|
775 | /*}}}*/ |
---|
776 | |
---|
777 | |
---|
778 | /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/ |
---|
779 | /* my_crypt - VMS password hashing |
---|
780 | * my_crypt() provides an interface compatible with the Unix crypt() |
---|
781 | * C library function, and uses sys$hash_password() to perform VMS |
---|
782 | * password hashing. The quadword hashed password value is returned |
---|
783 | * as a NUL-terminated 8 character string. my_crypt() does not change |
---|
784 | * the case of its string arguments; in order to match the behavior |
---|
785 | * of LOGINOUT et al., alphabetic characters in both arguments must |
---|
786 | * be upcased by the caller. |
---|
787 | */ |
---|
788 | char * |
---|
789 | my_crypt(const char *textpasswd, const char *usrname) |
---|
790 | { |
---|
791 | # ifndef UAI$C_PREFERRED_ALGORITHM |
---|
792 | # define UAI$C_PREFERRED_ALGORITHM 127 |
---|
793 | # endif |
---|
794 | unsigned char alg = UAI$C_PREFERRED_ALGORITHM; |
---|
795 | unsigned short int salt = 0; |
---|
796 | unsigned long int sts; |
---|
797 | struct const_dsc { |
---|
798 | unsigned short int dsc$w_length; |
---|
799 | unsigned char dsc$b_type; |
---|
800 | unsigned char dsc$b_class; |
---|
801 | const char * dsc$a_pointer; |
---|
802 | } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}, |
---|
803 | txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; |
---|
804 | struct itmlst_3 uailst[3] = { |
---|
805 | { sizeof alg, UAI$_ENCRYPT, &alg, 0}, |
---|
806 | { sizeof salt, UAI$_SALT, &salt, 0}, |
---|
807 | { 0, 0, NULL, NULL}}; |
---|
808 | static char hash[9]; |
---|
809 | |
---|
810 | usrdsc.dsc$w_length = strlen(usrname); |
---|
811 | usrdsc.dsc$a_pointer = usrname; |
---|
812 | if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) { |
---|
813 | switch (sts) { |
---|
814 | case SS$_NOGRPPRV: case SS$_NOSYSPRV: |
---|
815 | set_errno(EACCES); |
---|
816 | break; |
---|
817 | case RMS$_RNF: |
---|
818 | set_errno(ESRCH); /* There isn't a Unix no-such-user error */ |
---|
819 | break; |
---|
820 | default: |
---|
821 | set_errno(EVMSERR); |
---|
822 | } |
---|
823 | set_vaxc_errno(sts); |
---|
824 | if (sts != RMS$_RNF) return NULL; |
---|
825 | } |
---|
826 | |
---|
827 | txtdsc.dsc$w_length = strlen(textpasswd); |
---|
828 | txtdsc.dsc$a_pointer = textpasswd; |
---|
829 | if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) { |
---|
830 | set_errno(EVMSERR); set_vaxc_errno(sts); return NULL; |
---|
831 | } |
---|
832 | |
---|
833 | return (char *) hash; |
---|
834 | |
---|
835 | } /* end of my_crypt() */ |
---|
836 | /*}}}*/ |
---|
837 | |
---|
838 | |
---|
839 | static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned); |
---|
840 | static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int); |
---|
841 | static char *mp_do_tovmsspec(pTHX_ char *, char *, int); |
---|
842 | |
---|
843 | /*{{{int do_rmdir(char *name)*/ |
---|
844 | int |
---|
845 | Perl_do_rmdir(pTHX_ char *name) |
---|
846 | { |
---|
847 | char dirfile[NAM$C_MAXRSS+1]; |
---|
848 | int retval; |
---|
849 | Stat_t st; |
---|
850 | |
---|
851 | if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1; |
---|
852 | if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1; |
---|
853 | else retval = kill_file(dirfile); |
---|
854 | return retval; |
---|
855 | |
---|
856 | } /* end of do_rmdir */ |
---|
857 | /*}}}*/ |
---|
858 | |
---|
859 | /* kill_file |
---|
860 | * Delete any file to which user has control access, regardless of whether |
---|
861 | * delete access is explicitly allowed. |
---|
862 | * Limitations: User must have write access to parent directory. |
---|
863 | * Does not block signals or ASTs; if interrupted in midstream |
---|
864 | * may leave file with an altered ACL. |
---|
865 | * HANDLE WITH CARE! |
---|
866 | */ |
---|
867 | /*{{{int kill_file(char *name)*/ |
---|
868 | int |
---|
869 | kill_file(char *name) |
---|
870 | { |
---|
871 | char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1]; |
---|
872 | unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE; |
---|
873 | unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1; |
---|
874 | dTHX; |
---|
875 | struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; |
---|
876 | struct myacedef { |
---|
877 | unsigned char myace$b_length; |
---|
878 | unsigned char myace$b_type; |
---|
879 | unsigned short int myace$w_flags; |
---|
880 | unsigned long int myace$l_access; |
---|
881 | unsigned long int myace$l_ident; |
---|
882 | } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0, |
---|
883 | ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0}, |
---|
884 | oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0}; |
---|
885 | struct itmlst_3 |
---|
886 | findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0}, |
---|
887 | {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}}, |
---|
888 | addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}}, |
---|
889 | dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}}, |
---|
890 | lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}}, |
---|
891 | ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}}; |
---|
892 | |
---|
893 | /* Expand the input spec using RMS, since the CRTL remove() and |
---|
894 | * system services won't do this by themselves, so we may miss |
---|
895 | * a file "hiding" behind a logical name or search list. */ |
---|
896 | if (do_tovmsspec(name,vmsname,0) == NULL) return -1; |
---|
897 | if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1; |
---|
898 | if (!remove(rspec)) return 0; /* Can we just get rid of it? */ |
---|
899 | /* If not, can changing protections help? */ |
---|
900 | if (vaxc$errno != RMS$_PRV) return -1; |
---|
901 | |
---|
902 | /* No, so we get our own UIC to use as a rights identifier, |
---|
903 | * and the insert an ACE at the head of the ACL which allows us |
---|
904 | * to delete the file. |
---|
905 | */ |
---|
906 | _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0)); |
---|
907 | fildsc.dsc$w_length = strlen(rspec); |
---|
908 | fildsc.dsc$a_pointer = rspec; |
---|
909 | cxt = 0; |
---|
910 | newace.myace$l_ident = oldace.myace$l_ident; |
---|
911 | if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) { |
---|
912 | switch (aclsts) { |
---|
913 | case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT: |
---|
914 | set_errno(ENOENT); break; |
---|
915 | case RMS$_DIR: |
---|
916 | set_errno(ENOTDIR); break; |
---|
917 | case RMS$_DEV: |
---|
918 | set_errno(ENODEV); break; |
---|
919 | case RMS$_SYN: case SS$_INVFILFOROP: |
---|
920 | set_errno(EINVAL); break; |
---|
921 | case RMS$_PRV: |
---|
922 | set_errno(EACCES); break; |
---|
923 | default: |
---|
924 | _ckvmssts(aclsts); |
---|
925 | } |
---|
926 | set_vaxc_errno(aclsts); |
---|
927 | return -1; |
---|
928 | } |
---|
929 | /* Grab any existing ACEs with this identifier in case we fail */ |
---|
930 | aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt); |
---|
931 | if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY |
---|
932 | || fndsts == SS$_NOMOREACE ) { |
---|
933 | /* Add the new ACE . . . */ |
---|
934 | if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1)) |
---|
935 | goto yourroom; |
---|
936 | if ((rmsts = remove(name))) { |
---|
937 | /* We blew it - dir with files in it, no write priv for |
---|
938 | * parent directory, etc. Put things back the way they were. */ |
---|
939 | if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1)) |
---|
940 | goto yourroom; |
---|
941 | if (fndsts & 1) { |
---|
942 | addlst[0].bufadr = &oldace; |
---|
943 | if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1)) |
---|
944 | goto yourroom; |
---|
945 | } |
---|
946 | } |
---|
947 | } |
---|
948 | |
---|
949 | yourroom: |
---|
950 | fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0); |
---|
951 | /* We just deleted it, so of course it's not there. Some versions of |
---|
952 | * VMS seem to return success on the unlock operation anyhow (after all |
---|
953 | * the unlock is successful), but others don't. |
---|
954 | */ |
---|
955 | if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL; |
---|
956 | if (aclsts & 1) aclsts = fndsts; |
---|
957 | if (!(aclsts & 1)) { |
---|
958 | set_errno(EVMSERR); |
---|
959 | set_vaxc_errno(aclsts); |
---|
960 | return -1; |
---|
961 | } |
---|
962 | |
---|
963 | return rmsts; |
---|
964 | |
---|
965 | } /* end of kill_file() */ |
---|
966 | /*}}}*/ |
---|
967 | |
---|
968 | |
---|
969 | /*{{{int my_mkdir(char *,Mode_t)*/ |
---|
970 | int |
---|
971 | my_mkdir(char *dir, Mode_t mode) |
---|
972 | { |
---|
973 | STRLEN dirlen = strlen(dir); |
---|
974 | dTHX; |
---|
975 | |
---|
976 | /* zero length string sometimes gives ACCVIO */ |
---|
977 | if (dirlen == 0) return -1; |
---|
978 | |
---|
979 | /* CRTL mkdir() doesn't tolerate trailing /, since that implies |
---|
980 | * null file name/type. However, it's commonplace under Unix, |
---|
981 | * so we'll allow it for a gain in portability. |
---|
982 | */ |
---|
983 | if (dir[dirlen-1] == '/') { |
---|
984 | char *newdir = savepvn(dir,dirlen-1); |
---|
985 | int ret = mkdir(newdir,mode); |
---|
986 | Safefree(newdir); |
---|
987 | return ret; |
---|
988 | } |
---|
989 | else return mkdir(dir,mode); |
---|
990 | } /* end of my_mkdir */ |
---|
991 | /*}}}*/ |
---|
992 | |
---|
993 | /*{{{int my_chdir(char *)*/ |
---|
994 | int |
---|
995 | my_chdir(char *dir) |
---|
996 | { |
---|
997 | STRLEN dirlen = strlen(dir); |
---|
998 | dTHX; |
---|
999 | |
---|
1000 | /* zero length string sometimes gives ACCVIO */ |
---|
1001 | if (dirlen == 0) return -1; |
---|
1002 | |
---|
1003 | /* some versions of CRTL chdir() doesn't tolerate trailing /, since |
---|
1004 | * that implies |
---|
1005 | * null file name/type. However, it's commonplace under Unix, |
---|
1006 | * so we'll allow it for a gain in portability. |
---|
1007 | */ |
---|
1008 | if (dir[dirlen-1] == '/') { |
---|
1009 | char *newdir = savepvn(dir,dirlen-1); |
---|
1010 | int ret = chdir(newdir); |
---|
1011 | Safefree(newdir); |
---|
1012 | return ret; |
---|
1013 | } |
---|
1014 | else return chdir(dir); |
---|
1015 | } /* end of my_chdir */ |
---|
1016 | /*}}}*/ |
---|
1017 | |
---|
1018 | |
---|
1019 | /*{{{FILE *my_tmpfile()*/ |
---|
1020 | FILE * |
---|
1021 | my_tmpfile(void) |
---|
1022 | { |
---|
1023 | FILE *fp; |
---|
1024 | char *cp; |
---|
1025 | dTHX; |
---|
1026 | |
---|
1027 | if ((fp = tmpfile())) return fp; |
---|
1028 | |
---|
1029 | New(1323,cp,L_tmpnam+24,char); |
---|
1030 | strcpy(cp,"Sys$Scratch:"); |
---|
1031 | tmpnam(cp+strlen(cp)); |
---|
1032 | strcat(cp,".Perltmp"); |
---|
1033 | fp = fopen(cp,"w+","fop=dlt"); |
---|
1034 | Safefree(cp); |
---|
1035 | return fp; |
---|
1036 | } |
---|
1037 | /*}}}*/ |
---|
1038 | |
---|
1039 | /* default piping mailbox size */ |
---|
1040 | #define PERL_BUFSIZ 512 |
---|
1041 | |
---|
1042 | |
---|
1043 | static void |
---|
1044 | create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc) |
---|
1045 | { |
---|
1046 | unsigned long int mbxbufsiz; |
---|
1047 | static unsigned long int syssize = 0; |
---|
1048 | unsigned long int dviitm = DVI$_DEVNAM; |
---|
1049 | dTHX; |
---|
1050 | char csize[LNM$C_NAMLENGTH+1]; |
---|
1051 | |
---|
1052 | if (!syssize) { |
---|
1053 | unsigned long syiitm = SYI$_MAXBUF; |
---|
1054 | /* |
---|
1055 | * Get the SYSGEN parameter MAXBUF |
---|
1056 | * |
---|
1057 | * If the logical 'PERL_MBX_SIZE' is defined |
---|
1058 | * use the value of the logical instead of PERL_BUFSIZ, but |
---|
1059 | * keep the size between 128 and MAXBUF. |
---|
1060 | * |
---|
1061 | */ |
---|
1062 | _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0)); |
---|
1063 | } |
---|
1064 | |
---|
1065 | if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) { |
---|
1066 | mbxbufsiz = atoi(csize); |
---|
1067 | } else { |
---|
1068 | mbxbufsiz = PERL_BUFSIZ; |
---|
1069 | } |
---|
1070 | if (mbxbufsiz < 128) mbxbufsiz = 128; |
---|
1071 | if (mbxbufsiz > syssize) mbxbufsiz = syssize; |
---|
1072 | |
---|
1073 | _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0)); |
---|
1074 | |
---|
1075 | _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length)); |
---|
1076 | namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0'; |
---|
1077 | |
---|
1078 | } /* end of create_mbx() */ |
---|
1079 | |
---|
1080 | |
---|
1081 | /*{{{ my_popen and my_pclose*/ |
---|
1082 | |
---|
1083 | typedef struct _iosb IOSB; |
---|
1084 | typedef struct _iosb* pIOSB; |
---|
1085 | typedef struct _pipe Pipe; |
---|
1086 | typedef struct _pipe* pPipe; |
---|
1087 | typedef struct pipe_details Info; |
---|
1088 | typedef struct pipe_details* pInfo; |
---|
1089 | typedef struct _srqp RQE; |
---|
1090 | typedef struct _srqp* pRQE; |
---|
1091 | typedef struct _tochildbuf CBuf; |
---|
1092 | typedef struct _tochildbuf* pCBuf; |
---|
1093 | |
---|
1094 | struct _iosb { |
---|
1095 | unsigned short status; |
---|
1096 | unsigned short count; |
---|
1097 | unsigned long dvispec; |
---|
1098 | }; |
---|
1099 | |
---|
1100 | #pragma member_alignment save |
---|
1101 | #pragma nomember_alignment quadword |
---|
1102 | struct _srqp { /* VMS self-relative queue entry */ |
---|
1103 | unsigned long qptr[2]; |
---|
1104 | }; |
---|
1105 | #pragma member_alignment restore |
---|
1106 | static RQE RQE_ZERO = {0,0}; |
---|
1107 | |
---|
1108 | struct _tochildbuf { |
---|
1109 | RQE q; |
---|
1110 | int eof; |
---|
1111 | unsigned short size; |
---|
1112 | char *buf; |
---|
1113 | }; |
---|
1114 | |
---|
1115 | struct _pipe { |
---|
1116 | RQE free; |
---|
1117 | RQE wait; |
---|
1118 | int fd_out; |
---|
1119 | unsigned short chan_in; |
---|
1120 | unsigned short chan_out; |
---|
1121 | char *buf; |
---|
1122 | unsigned int bufsize; |
---|
1123 | IOSB iosb; |
---|
1124 | IOSB iosb2; |
---|
1125 | int *pipe_done; |
---|
1126 | int retry; |
---|
1127 | int type; |
---|
1128 | int shut_on_empty; |
---|
1129 | int need_wake; |
---|
1130 | pPipe *home; |
---|
1131 | pInfo info; |
---|
1132 | pCBuf curr; |
---|
1133 | pCBuf curr2; |
---|
1134 | }; |
---|
1135 | |
---|
1136 | |
---|
1137 | struct pipe_details |
---|
1138 | { |
---|
1139 | pInfo next; |
---|
1140 | PerlIO *fp; /* stdio file pointer to pipe mailbox */ |
---|
1141 | int pid; /* PID of subprocess */ |
---|
1142 | int mode; /* == 'r' if pipe open for reading */ |
---|
1143 | int done; /* subprocess has completed */ |
---|
1144 | int closing; /* my_pclose is closing this pipe */ |
---|
1145 | unsigned long completion; /* termination status of subprocess */ |
---|
1146 | pPipe in; /* pipe in to sub */ |
---|
1147 | pPipe out; /* pipe out of sub */ |
---|
1148 | pPipe err; /* pipe of sub's sys$error */ |
---|
1149 | int in_done; /* true when in pipe finished */ |
---|
1150 | int out_done; |
---|
1151 | int err_done; |
---|
1152 | }; |
---|
1153 | |
---|
1154 | struct exit_control_block |
---|
1155 | { |
---|
1156 | struct exit_control_block *flink; |
---|
1157 | unsigned long int (*exit_routine)(); |
---|
1158 | unsigned long int arg_count; |
---|
1159 | unsigned long int *status_address; |
---|
1160 | unsigned long int exit_status; |
---|
1161 | }; |
---|
1162 | |
---|
1163 | #define RETRY_DELAY "0 ::0.20" |
---|
1164 | #define MAX_RETRY 50 |
---|
1165 | |
---|
1166 | static int pipe_ef = 0; /* first call to safe_popen inits these*/ |
---|
1167 | static unsigned long mypid; |
---|
1168 | static unsigned long delaytime[2]; |
---|
1169 | |
---|
1170 | static pInfo open_pipes = NULL; |
---|
1171 | static $DESCRIPTOR(nl_desc, "NL:"); |
---|
1172 | |
---|
1173 | |
---|
1174 | static unsigned long int |
---|
1175 | pipe_exit_routine() |
---|
1176 | { |
---|
1177 | pInfo info; |
---|
1178 | unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT; |
---|
1179 | int sts, did_stuff, need_eof; |
---|
1180 | dTHX; |
---|
1181 | |
---|
1182 | /* |
---|
1183 | first we try sending an EOF...ignore if doesn't work, make sure we |
---|
1184 | don't hang |
---|
1185 | */ |
---|
1186 | did_stuff = 0; |
---|
1187 | info = open_pipes; |
---|
1188 | |
---|
1189 | while (info) { |
---|
1190 | int need_eof; |
---|
1191 | _ckvmssts(sys$setast(0)); |
---|
1192 | if (info->in && !info->in->shut_on_empty) { |
---|
1193 | _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0, |
---|
1194 | 0, 0, 0, 0, 0, 0)); |
---|
1195 | did_stuff = 1; |
---|
1196 | } |
---|
1197 | _ckvmssts(sys$setast(1)); |
---|
1198 | info = info->next; |
---|
1199 | } |
---|
1200 | if (did_stuff) sleep(1); /* wait for EOF to have an effect */ |
---|
1201 | |
---|
1202 | did_stuff = 0; |
---|
1203 | info = open_pipes; |
---|
1204 | while (info) { |
---|
1205 | _ckvmssts(sys$setast(0)); |
---|
1206 | if (!info->done) { /* Tap them gently on the shoulder . . .*/ |
---|
1207 | sts = sys$forcex(&info->pid,0,&abort); |
---|
1208 | if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts); |
---|
1209 | did_stuff = 1; |
---|
1210 | } |
---|
1211 | _ckvmssts(sys$setast(1)); |
---|
1212 | info = info->next; |
---|
1213 | } |
---|
1214 | if (did_stuff) sleep(1); /* wait for them to respond */ |
---|
1215 | |
---|
1216 | info = open_pipes; |
---|
1217 | while (info) { |
---|
1218 | _ckvmssts(sys$setast(0)); |
---|
1219 | if (!info->done) { /* We tried to be nice . . . */ |
---|
1220 | sts = sys$delprc(&info->pid,0); |
---|
1221 | if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts); |
---|
1222 | } |
---|
1223 | _ckvmssts(sys$setast(1)); |
---|
1224 | info = info->next; |
---|
1225 | } |
---|
1226 | |
---|
1227 | while(open_pipes) { |
---|
1228 | if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno; |
---|
1229 | else if (!(sts & 1)) retsts = sts; |
---|
1230 | } |
---|
1231 | return retsts; |
---|
1232 | } |
---|
1233 | |
---|
1234 | static struct exit_control_block pipe_exitblock = |
---|
1235 | {(struct exit_control_block *) 0, |
---|
1236 | pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0}; |
---|
1237 | |
---|
1238 | static void pipe_mbxtofd_ast(pPipe p); |
---|
1239 | static void pipe_tochild1_ast(pPipe p); |
---|
1240 | static void pipe_tochild2_ast(pPipe p); |
---|
1241 | |
---|
1242 | static void |
---|
1243 | popen_completion_ast(pInfo info) |
---|
1244 | { |
---|
1245 | dTHX; |
---|
1246 | pInfo i = open_pipes; |
---|
1247 | int iss; |
---|
1248 | |
---|
1249 | while (i) { |
---|
1250 | if (i == info) break; |
---|
1251 | i = i->next; |
---|
1252 | } |
---|
1253 | if (!i) return; /* unlinked, probably freed too */ |
---|
1254 | |
---|
1255 | info->completion &= 0x0FFFFFFF; /* strip off "control" field */ |
---|
1256 | info->done = TRUE; |
---|
1257 | |
---|
1258 | /* |
---|
1259 | Writing to subprocess ... |
---|
1260 | if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe |
---|
1261 | |
---|
1262 | chan_out may be waiting for "done" flag, or hung waiting |
---|
1263 | for i/o completion to child...cancel the i/o. This will |
---|
1264 | put it into "snarf mode" (done but no EOF yet) that discards |
---|
1265 | input. |
---|
1266 | |
---|
1267 | Output from subprocess (stdout, stderr) needs to be flushed and |
---|
1268 | shut down. We try sending an EOF, but if the mbx is full the pipe |
---|
1269 | routine should still catch the "shut_on_empty" flag, telling it to |
---|
1270 | use immediate-style reads so that "mbx empty" -> EOF. |
---|
1271 | |
---|
1272 | |
---|
1273 | */ |
---|
1274 | if (info->in && !info->in_done) { /* only for mode=w */ |
---|
1275 | if (info->in->shut_on_empty && info->in->need_wake) { |
---|
1276 | info->in->need_wake = FALSE; |
---|
1277 | _ckvmssts(sys$dclast(pipe_tochild2_ast,info->in,0)); |
---|
1278 | } else { |
---|
1279 | _ckvmssts(sys$cancel(info->in->chan_out)); |
---|
1280 | } |
---|
1281 | } |
---|
1282 | |
---|
1283 | if (info->out && !info->out_done) { /* were we also piping output? */ |
---|
1284 | info->out->shut_on_empty = TRUE; |
---|
1285 | iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0); |
---|
1286 | if (iss == SS$_MBFULL) iss = SS$_NORMAL; |
---|
1287 | _ckvmssts(iss); |
---|
1288 | } |
---|
1289 | |
---|
1290 | if (info->err && !info->err_done) { /* we were piping stderr */ |
---|
1291 | info->err->shut_on_empty = TRUE; |
---|
1292 | iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0); |
---|
1293 | if (iss == SS$_MBFULL) iss = SS$_NORMAL; |
---|
1294 | _ckvmssts(iss); |
---|
1295 | } |
---|
1296 | _ckvmssts(sys$setef(pipe_ef)); |
---|
1297 | |
---|
1298 | } |
---|
1299 | |
---|
1300 | static unsigned long int setup_cmddsc(char *cmd, int check_img); |
---|
1301 | static void vms_execfree(pTHX); |
---|
1302 | |
---|
1303 | /* |
---|
1304 | we actually differ from vmstrnenv since we use this to |
---|
1305 | get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really* |
---|
1306 | are pointing to the same thing |
---|
1307 | */ |
---|
1308 | |
---|
1309 | static unsigned short |
---|
1310 | popen_translate(char *logical, char *result) |
---|
1311 | { |
---|
1312 | int iss; |
---|
1313 | $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE"); |
---|
1314 | $DESCRIPTOR(d_log,""); |
---|
1315 | struct _il3 { |
---|
1316 | unsigned short length; |
---|
1317 | unsigned short code; |
---|
1318 | char * buffer_addr; |
---|
1319 | unsigned short *retlenaddr; |
---|
1320 | } itmlst[2]; |
---|
1321 | unsigned short l, ifi; |
---|
1322 | |
---|
1323 | d_log.dsc$a_pointer = logical; |
---|
1324 | d_log.dsc$w_length = strlen(logical); |
---|
1325 | |
---|
1326 | itmlst[0].code = LNM$_STRING; |
---|
1327 | itmlst[0].length = 255; |
---|
1328 | itmlst[0].buffer_addr = result; |
---|
1329 | itmlst[0].retlenaddr = &l; |
---|
1330 | |
---|
1331 | itmlst[1].code = 0; |
---|
1332 | itmlst[1].length = 0; |
---|
1333 | itmlst[1].buffer_addr = 0; |
---|
1334 | itmlst[1].retlenaddr = 0; |
---|
1335 | |
---|
1336 | iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst); |
---|
1337 | if (iss == SS$_NOLOGNAM) { |
---|
1338 | iss = SS$_NORMAL; |
---|
1339 | l = 0; |
---|
1340 | } |
---|
1341 | if (!(iss&1)) lib$signal(iss); |
---|
1342 | result[l] = '\0'; |
---|
1343 | /* |
---|
1344 | logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI) |
---|
1345 | strip it off and return the ifi, if any |
---|
1346 | */ |
---|
1347 | ifi = 0; |
---|
1348 | if (result[0] == 0x1b && result[1] == 0x00) { |
---|
1349 | memcpy(&ifi,result+2,2); |
---|
1350 | strcpy(result,result+4); |
---|
1351 | } |
---|
1352 | return ifi; /* this is the RMS internal file id */ |
---|
1353 | } |
---|
1354 | |
---|
1355 | #define MAX_DCL_SYMBOL 255 |
---|
1356 | static void pipe_infromchild_ast(pPipe p); |
---|
1357 | |
---|
1358 | /* |
---|
1359 | I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate |
---|
1360 | inside an AST routine without worrying about reentrancy and which Perl |
---|
1361 | memory allocator is being used. |
---|
1362 | |
---|
1363 | We read data and queue up the buffers, then spit them out one at a |
---|
1364 | time to the output mailbox when the output mailbox is ready for one. |
---|
1365 | |
---|
1366 | */ |
---|
1367 | #define INITIAL_TOCHILDQUEUE 2 |
---|
1368 | |
---|
1369 | static pPipe |
---|
1370 | pipe_tochild_setup(char *rmbx, char *wmbx) |
---|
1371 | { |
---|
1372 | dTHX; |
---|
1373 | pPipe p; |
---|
1374 | pCBuf b; |
---|
1375 | char mbx1[64], mbx2[64]; |
---|
1376 | struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T, |
---|
1377 | DSC$K_CLASS_S, mbx1}, |
---|
1378 | d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T, |
---|
1379 | DSC$K_CLASS_S, mbx2}; |
---|
1380 | unsigned int dviitm = DVI$_DEVBUFSIZ; |
---|
1381 | int j, n; |
---|
1382 | |
---|
1383 | New(1368, p, 1, Pipe); |
---|
1384 | |
---|
1385 | create_mbx(&p->chan_in , &d_mbx1); |
---|
1386 | create_mbx(&p->chan_out, &d_mbx2); |
---|
1387 | _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize)); |
---|
1388 | |
---|
1389 | p->buf = 0; |
---|
1390 | p->shut_on_empty = FALSE; |
---|
1391 | p->need_wake = FALSE; |
---|
1392 | p->type = 0; |
---|
1393 | p->retry = 0; |
---|
1394 | p->iosb.status = SS$_NORMAL; |
---|
1395 | p->iosb2.status = SS$_NORMAL; |
---|
1396 | p->free = RQE_ZERO; |
---|
1397 | p->wait = RQE_ZERO; |
---|
1398 | p->curr = 0; |
---|
1399 | p->curr2 = 0; |
---|
1400 | p->info = 0; |
---|
1401 | |
---|
1402 | n = sizeof(CBuf) + p->bufsize; |
---|
1403 | |
---|
1404 | for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) { |
---|
1405 | _ckvmssts(lib$get_vm(&n, &b)); |
---|
1406 | b->buf = (char *) b + sizeof(CBuf); |
---|
1407 | _ckvmssts(lib$insqhi(b, &p->free)); |
---|
1408 | } |
---|
1409 | |
---|
1410 | pipe_tochild2_ast(p); |
---|
1411 | pipe_tochild1_ast(p); |
---|
1412 | strcpy(wmbx, mbx1); |
---|
1413 | strcpy(rmbx, mbx2); |
---|
1414 | return p; |
---|
1415 | } |
---|
1416 | |
---|
1417 | /* reads the MBX Perl is writing, and queues */ |
---|
1418 | |
---|
1419 | static void |
---|
1420 | pipe_tochild1_ast(pPipe p) |
---|
1421 | { |
---|
1422 | dTHX; |
---|
1423 | pCBuf b = p->curr; |
---|
1424 | int iss = p->iosb.status; |
---|
1425 | int eof = (iss == SS$_ENDOFFILE); |
---|
1426 | |
---|
1427 | if (p->retry) { |
---|
1428 | if (eof) { |
---|
1429 | p->shut_on_empty = TRUE; |
---|
1430 | b->eof = TRUE; |
---|
1431 | _ckvmssts(sys$dassgn(p->chan_in)); |
---|
1432 | } else { |
---|
1433 | _ckvmssts(iss); |
---|
1434 | } |
---|
1435 | |
---|
1436 | b->eof = eof; |
---|
1437 | b->size = p->iosb.count; |
---|
1438 | _ckvmssts(lib$insqhi(b, &p->wait)); |
---|
1439 | if (p->need_wake) { |
---|
1440 | p->need_wake = FALSE; |
---|
1441 | _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0)); |
---|
1442 | } |
---|
1443 | } else { |
---|
1444 | p->retry = 1; /* initial call */ |
---|
1445 | } |
---|
1446 | |
---|
1447 | if (eof) { /* flush the free queue, return when done */ |
---|
1448 | int n = sizeof(CBuf) + p->bufsize; |
---|
1449 | while (1) { |
---|
1450 | iss = lib$remqti(&p->free, &b); |
---|
1451 | if (iss == LIB$_QUEWASEMP) return; |
---|
1452 | _ckvmssts(iss); |
---|
1453 | _ckvmssts(lib$free_vm(&n, &b)); |
---|
1454 | } |
---|
1455 | } |
---|
1456 | |
---|
1457 | iss = lib$remqti(&p->free, &b); |
---|
1458 | if (iss == LIB$_QUEWASEMP) { |
---|
1459 | int n = sizeof(CBuf) + p->bufsize; |
---|
1460 | _ckvmssts(lib$get_vm(&n, &b)); |
---|
1461 | b->buf = (char *) b + sizeof(CBuf); |
---|
1462 | } else { |
---|
1463 | _ckvmssts(iss); |
---|
1464 | } |
---|
1465 | |
---|
1466 | p->curr = b; |
---|
1467 | iss = sys$qio(0,p->chan_in, |
---|
1468 | IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0), |
---|
1469 | &p->iosb, |
---|
1470 | pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0); |
---|
1471 | if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL; |
---|
1472 | _ckvmssts(iss); |
---|
1473 | } |
---|
1474 | |
---|
1475 | |
---|
1476 | /* writes queued buffers to output, waits for each to complete before |
---|
1477 | doing the next */ |
---|
1478 | |
---|
1479 | static void |
---|
1480 | pipe_tochild2_ast(pPipe p) |
---|
1481 | { |
---|
1482 | dTHX; |
---|
1483 | pCBuf b = p->curr2; |
---|
1484 | int iss = p->iosb2.status; |
---|
1485 | int n = sizeof(CBuf) + p->bufsize; |
---|
1486 | int done = (p->info && p->info->done) || |
---|
1487 | iss == SS$_CANCEL || iss == SS$_ABORT; |
---|
1488 | |
---|
1489 | do { |
---|
1490 | if (p->type) { /* type=1 has old buffer, dispose */ |
---|
1491 | if (p->shut_on_empty) { |
---|
1492 | _ckvmssts(lib$free_vm(&n, &b)); |
---|
1493 | } else { |
---|
1494 | _ckvmssts(lib$insqhi(b, &p->free)); |
---|
1495 | } |
---|
1496 | p->type = 0; |
---|
1497 | } |
---|
1498 | |
---|
1499 | iss = lib$remqti(&p->wait, &b); |
---|
1500 | if (iss == LIB$_QUEWASEMP) { |
---|
1501 | if (p->shut_on_empty) { |
---|
1502 | if (done) { |
---|
1503 | _ckvmssts(sys$dassgn(p->chan_out)); |
---|
1504 | *p->pipe_done = TRUE; |
---|
1505 | _ckvmssts(sys$setef(pipe_ef)); |
---|
1506 | } else { |
---|
1507 | _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, |
---|
1508 | &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0)); |
---|
1509 | } |
---|
1510 | return; |
---|
1511 | } |
---|
1512 | p->need_wake = TRUE; |
---|
1513 | return; |
---|
1514 | } |
---|
1515 | _ckvmssts(iss); |
---|
1516 | p->type = 1; |
---|
1517 | } while (done); |
---|
1518 | |
---|
1519 | |
---|
1520 | p->curr2 = b; |
---|
1521 | if (b->eof) { |
---|
1522 | _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, |
---|
1523 | &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0)); |
---|
1524 | } else { |
---|
1525 | _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK, |
---|
1526 | &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0)); |
---|
1527 | } |
---|
1528 | |
---|
1529 | return; |
---|
1530 | |
---|
1531 | } |
---|
1532 | |
---|
1533 | |
---|
1534 | static pPipe |
---|
1535 | pipe_infromchild_setup(char *rmbx, char *wmbx) |
---|
1536 | { |
---|
1537 | dTHX; |
---|
1538 | pPipe p; |
---|
1539 | char mbx1[64], mbx2[64]; |
---|
1540 | struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T, |
---|
1541 | DSC$K_CLASS_S, mbx1}, |
---|
1542 | d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T, |
---|
1543 | DSC$K_CLASS_S, mbx2}; |
---|
1544 | unsigned int dviitm = DVI$_DEVBUFSIZ; |
---|
1545 | |
---|
1546 | New(1367, p, 1, Pipe); |
---|
1547 | create_mbx(&p->chan_in , &d_mbx1); |
---|
1548 | create_mbx(&p->chan_out, &d_mbx2); |
---|
1549 | |
---|
1550 | _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize)); |
---|
1551 | New(1367, p->buf, p->bufsize, char); |
---|
1552 | p->shut_on_empty = FALSE; |
---|
1553 | p->info = 0; |
---|
1554 | p->type = 0; |
---|
1555 | p->iosb.status = SS$_NORMAL; |
---|
1556 | pipe_infromchild_ast(p); |
---|
1557 | |
---|
1558 | strcpy(wmbx, mbx1); |
---|
1559 | strcpy(rmbx, mbx2); |
---|
1560 | return p; |
---|
1561 | } |
---|
1562 | |
---|
1563 | static void |
---|
1564 | pipe_infromchild_ast(pPipe p) |
---|
1565 | { |
---|
1566 | dTHX; |
---|
1567 | int iss = p->iosb.status; |
---|
1568 | int eof = (iss == SS$_ENDOFFILE); |
---|
1569 | int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0)); |
---|
1570 | int kideof = (eof && (p->iosb.dvispec == p->info->pid)); |
---|
1571 | |
---|
1572 | if (p->info && p->info->closing && p->chan_out) { /* output shutdown */ |
---|
1573 | _ckvmssts(sys$dassgn(p->chan_out)); |
---|
1574 | p->chan_out = 0; |
---|
1575 | } |
---|
1576 | |
---|
1577 | /* read completed: |
---|
1578 | input shutdown if EOF from self (done or shut_on_empty) |
---|
1579 | output shutdown if closing flag set (my_pclose) |
---|
1580 | send data/eof from child or eof from self |
---|
1581 | otherwise, re-read (snarf of data from child) |
---|
1582 | */ |
---|
1583 | |
---|
1584 | if (p->type == 1) { |
---|
1585 | p->type = 0; |
---|
1586 | if (myeof && p->chan_in) { /* input shutdown */ |
---|
1587 | _ckvmssts(sys$dassgn(p->chan_in)); |
---|
1588 | p->chan_in = 0; |
---|
1589 | } |
---|
1590 | |
---|
1591 | if (p->chan_out) { |
---|
1592 | if (myeof || kideof) { /* pass EOF to parent */ |
---|
1593 | _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb, |
---|
1594 | pipe_infromchild_ast, p, |
---|
1595 | 0, 0, 0, 0, 0, 0)); |
---|
1596 | return; |
---|
1597 | } else if (eof) { /* eat EOF --- fall through to read*/ |
---|
1598 | |
---|
1599 | } else { /* transmit data */ |
---|
1600 | _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb, |
---|
1601 | pipe_infromchild_ast,p, |
---|
1602 | p->buf, p->iosb.count, 0, 0, 0, 0)); |
---|
1603 | return; |
---|
1604 | } |
---|
1605 | } |
---|
1606 | } |
---|
1607 | |
---|
1608 | /* everything shut? flag as done */ |
---|
1609 | |
---|
1610 | if (!p->chan_in && !p->chan_out) { |
---|
1611 | *p->pipe_done = TRUE; |
---|
1612 | _ckvmssts(sys$setef(pipe_ef)); |
---|
1613 | return; |
---|
1614 | } |
---|
1615 | |
---|
1616 | /* write completed (or read, if snarfing from child) |
---|
1617 | if still have input active, |
---|
1618 | queue read...immediate mode if shut_on_empty so we get EOF if empty |
---|
1619 | otherwise, |
---|
1620 | check if Perl reading, generate EOFs as needed |
---|
1621 | */ |
---|
1622 | |
---|
1623 | if (p->type == 0) { |
---|
1624 | p->type = 1; |
---|
1625 | if (p->chan_in) { |
---|
1626 | iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb, |
---|
1627 | pipe_infromchild_ast,p, |
---|
1628 | p->buf, p->bufsize, 0, 0, 0, 0); |
---|
1629 | if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL; |
---|
1630 | _ckvmssts(iss); |
---|
1631 | } else { /* send EOFs for extra reads */ |
---|
1632 | p->iosb.status = SS$_ENDOFFILE; |
---|
1633 | p->iosb.dvispec = 0; |
---|
1634 | _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN, |
---|
1635 | 0, 0, 0, |
---|
1636 | pipe_infromchild_ast, p, 0, 0, 0, 0)); |
---|
1637 | } |
---|
1638 | } |
---|
1639 | } |
---|
1640 | |
---|
1641 | static pPipe |
---|
1642 | pipe_mbxtofd_setup(int fd, char *out) |
---|
1643 | { |
---|
1644 | dTHX; |
---|
1645 | pPipe p; |
---|
1646 | char mbx[64]; |
---|
1647 | unsigned long dviitm = DVI$_DEVBUFSIZ; |
---|
1648 | struct stat s; |
---|
1649 | struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T, |
---|
1650 | DSC$K_CLASS_S, mbx}; |
---|
1651 | |
---|
1652 | /* things like terminals and mbx's don't need this filter */ |
---|
1653 | if (fd && fstat(fd,&s) == 0) { |
---|
1654 | unsigned long dviitm = DVI$_DEVCHAR, devchar; |
---|
1655 | struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T, |
---|
1656 | DSC$K_CLASS_S, s.st_dev}; |
---|
1657 | |
---|
1658 | _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0)); |
---|
1659 | if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/ |
---|
1660 | strcpy(out, s.st_dev); |
---|
1661 | return 0; |
---|
1662 | } |
---|
1663 | } |
---|
1664 | |
---|
1665 | New(1366, p, 1, Pipe); |
---|
1666 | p->fd_out = dup(fd); |
---|
1667 | create_mbx(&p->chan_in, &d_mbx); |
---|
1668 | _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize)); |
---|
1669 | New(1366, p->buf, p->bufsize+1, char); |
---|
1670 | p->shut_on_empty = FALSE; |
---|
1671 | p->retry = 0; |
---|
1672 | p->info = 0; |
---|
1673 | strcpy(out, mbx); |
---|
1674 | |
---|
1675 | _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb, |
---|
1676 | pipe_mbxtofd_ast, p, |
---|
1677 | p->buf, p->bufsize, 0, 0, 0, 0)); |
---|
1678 | |
---|
1679 | return p; |
---|
1680 | } |
---|
1681 | |
---|
1682 | static void |
---|
1683 | pipe_mbxtofd_ast(pPipe p) |
---|
1684 | { |
---|
1685 | dTHX; |
---|
1686 | int iss = p->iosb.status; |
---|
1687 | int done = p->info->done; |
---|
1688 | int iss2; |
---|
1689 | int eof = (iss == SS$_ENDOFFILE); |
---|
1690 | int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0)); |
---|
1691 | int err = !(iss&1) && !eof; |
---|
1692 | |
---|
1693 | |
---|
1694 | if (done && myeof) { /* end piping */ |
---|
1695 | close(p->fd_out); |
---|
1696 | sys$dassgn(p->chan_in); |
---|
1697 | *p->pipe_done = TRUE; |
---|
1698 | _ckvmssts(sys$setef(pipe_ef)); |
---|
1699 | return; |
---|
1700 | } |
---|
1701 | |
---|
1702 | if (!err && !eof) { /* good data to send to file */ |
---|
1703 | p->buf[p->iosb.count] = '\n'; |
---|
1704 | iss2 = write(p->fd_out, p->buf, p->iosb.count+1); |
---|
1705 | if (iss2 < 0) { |
---|
1706 | p->retry++; |
---|
1707 | if (p->retry < MAX_RETRY) { |
---|
1708 | _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p)); |
---|
1709 | return; |
---|
1710 | } |
---|
1711 | } |
---|
1712 | p->retry = 0; |
---|
1713 | } else if (err) { |
---|
1714 | _ckvmssts(iss); |
---|
1715 | } |
---|
1716 | |
---|
1717 | |
---|
1718 | iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb, |
---|
1719 | pipe_mbxtofd_ast, p, |
---|
1720 | p->buf, p->bufsize, 0, 0, 0, 0); |
---|
1721 | if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL; |
---|
1722 | _ckvmssts(iss); |
---|
1723 | } |
---|
1724 | |
---|
1725 | |
---|
1726 | typedef struct _pipeloc PLOC; |
---|
1727 | typedef struct _pipeloc* pPLOC; |
---|
1728 | |
---|
1729 | struct _pipeloc { |
---|
1730 | pPLOC next; |
---|
1731 | char dir[NAM$C_MAXRSS+1]; |
---|
1732 | }; |
---|
1733 | static pPLOC head_PLOC = 0; |
---|
1734 | |
---|
1735 | void |
---|
1736 | free_pipelocs(void *head) |
---|
1737 | { |
---|
1738 | pPLOC p, pnext; |
---|
1739 | |
---|
1740 | p = (pPLOC) head; |
---|
1741 | while (p) { |
---|
1742 | pnext = p->next; |
---|
1743 | Safefree(p); |
---|
1744 | p = pnext; |
---|
1745 | } |
---|
1746 | } |
---|
1747 | |
---|
1748 | static void |
---|
1749 | store_pipelocs() |
---|
1750 | { |
---|
1751 | int i; |
---|
1752 | pPLOC p; |
---|
1753 | AV *av = GvAVn(PL_incgv); |
---|
1754 | SV *dirsv; |
---|
1755 | GV *gv; |
---|
1756 | char *dir, *x; |
---|
1757 | char *unixdir; |
---|
1758 | char temp[NAM$C_MAXRSS+1]; |
---|
1759 | STRLEN n_a; |
---|
1760 | |
---|
1761 | /* the . directory from @INC comes last */ |
---|
1762 | |
---|
1763 | New(1370,p,1,PLOC); |
---|
1764 | p->next = head_PLOC; |
---|
1765 | head_PLOC = p; |
---|
1766 | strcpy(p->dir,"./"); |
---|
1767 | |
---|
1768 | /* get the directory from $^X */ |
---|
1769 | |
---|
1770 | if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */ |
---|
1771 | strcpy(temp, PL_origargv[0]); |
---|
1772 | x = strrchr(temp,']'); |
---|
1773 | if (x) x[1] = '\0'; |
---|
1774 | |
---|
1775 | if ((unixdir = tounixpath(temp, Nullch)) != Nullch) { |
---|
1776 | New(1370,p,1,PLOC); |
---|
1777 | p->next = head_PLOC; |
---|
1778 | head_PLOC = p; |
---|
1779 | strncpy(p->dir,unixdir,sizeof(p->dir)-1); |
---|
1780 | p->dir[NAM$C_MAXRSS] = '\0'; |
---|
1781 | } |
---|
1782 | } |
---|
1783 | |
---|
1784 | /* reverse order of @INC entries, skip "." since entered above */ |
---|
1785 | |
---|
1786 | for (i = 0; i <= AvFILL(av); i++) { |
---|
1787 | dirsv = *av_fetch(av,i,TRUE); |
---|
1788 | |
---|
1789 | if (SvROK(dirsv)) continue; |
---|
1790 | dir = SvPVx(dirsv,n_a); |
---|
1791 | if (strcmp(dir,".") == 0) continue; |
---|
1792 | if ((unixdir = tounixpath(dir, Nullch)) == Nullch) |
---|
1793 | continue; |
---|
1794 | |
---|
1795 | New(1370,p,1,PLOC); |
---|
1796 | p->next = head_PLOC; |
---|
1797 | head_PLOC = p; |
---|
1798 | strncpy(p->dir,unixdir,sizeof(p->dir)-1); |
---|
1799 | p->dir[NAM$C_MAXRSS] = '\0'; |
---|
1800 | } |
---|
1801 | |
---|
1802 | /* most likely spot (ARCHLIB) put first in the list */ |
---|
1803 | |
---|
1804 | #ifdef ARCHLIB_EXP |
---|
1805 | if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) { |
---|
1806 | New(1370,p,1,PLOC); |
---|
1807 | p->next = head_PLOC; |
---|
1808 | head_PLOC = p; |
---|
1809 | strncpy(p->dir,unixdir,sizeof(p->dir)-1); |
---|
1810 | p->dir[NAM$C_MAXRSS] = '\0'; |
---|
1811 | } |
---|
1812 | #endif |
---|
1813 | Perl_call_atexit(&free_pipelocs, head_PLOC); |
---|
1814 | } |
---|
1815 | |
---|
1816 | |
---|
1817 | static char * |
---|
1818 | find_vmspipe(void) |
---|
1819 | { |
---|
1820 | static int vmspipe_file_status = 0; |
---|
1821 | static char vmspipe_file[NAM$C_MAXRSS+1]; |
---|
1822 | |
---|
1823 | /* already found? Check and use ... need read+execute permission */ |
---|
1824 | |
---|
1825 | if (vmspipe_file_status == 1) { |
---|
1826 | if (cando_by_name(S_IRUSR, 0, vmspipe_file) |
---|
1827 | && cando_by_name(S_IXUSR, 0, vmspipe_file)) { |
---|
1828 | return vmspipe_file; |
---|
1829 | } |
---|
1830 | vmspipe_file_status = 0; |
---|
1831 | } |
---|
1832 | |
---|
1833 | /* scan through stored @INC, $^X */ |
---|
1834 | |
---|
1835 | if (vmspipe_file_status == 0) { |
---|
1836 | char file[NAM$C_MAXRSS+1]; |
---|
1837 | pPLOC p = head_PLOC; |
---|
1838 | |
---|
1839 | while (p) { |
---|
1840 | strcpy(file, p->dir); |
---|
1841 | strncat(file, "vmspipe.com",NAM$C_MAXRSS); |
---|
1842 | file[NAM$C_MAXRSS] = '\0'; |
---|
1843 | p = p->next; |
---|
1844 | |
---|
1845 | if (!do_tovmsspec(file,vmspipe_file,0)) continue; |
---|
1846 | |
---|
1847 | if (cando_by_name(S_IRUSR, 0, vmspipe_file) |
---|
1848 | && cando_by_name(S_IXUSR, 0, vmspipe_file)) { |
---|
1849 | vmspipe_file_status = 1; |
---|
1850 | return vmspipe_file; |
---|
1851 | } |
---|
1852 | } |
---|
1853 | vmspipe_file_status = -1; /* failed, use tempfiles */ |
---|
1854 | } |
---|
1855 | |
---|
1856 | return 0; |
---|
1857 | } |
---|
1858 | |
---|
1859 | static FILE * |
---|
1860 | vmspipe_tempfile(void) |
---|
1861 | { |
---|
1862 | char file[NAM$C_MAXRSS+1]; |
---|
1863 | FILE *fp; |
---|
1864 | static int index = 0; |
---|
1865 | stat_t s0, s1; |
---|
1866 | |
---|
1867 | /* create a tempfile */ |
---|
1868 | |
---|
1869 | /* we can't go from W, shr=get to R, shr=get without |
---|
1870 | an intermediate vulnerable state, so don't bother trying... |
---|
1871 | |
---|
1872 | and lib$spawn doesn't shr=put, so have to close the write |
---|
1873 | |
---|
1874 | So... match up the creation date/time and the FID to |
---|
1875 | make sure we're dealing with the same file |
---|
1876 | |
---|
1877 | */ |
---|
1878 | |
---|
1879 | index++; |
---|
1880 | sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index); |
---|
1881 | fp = fopen(file,"w"); |
---|
1882 | if (!fp) { |
---|
1883 | sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index); |
---|
1884 | fp = fopen(file,"w"); |
---|
1885 | if (!fp) { |
---|
1886 | sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index); |
---|
1887 | fp = fopen(file,"w"); |
---|
1888 | } |
---|
1889 | } |
---|
1890 | if (!fp) return 0; /* we're hosed */ |
---|
1891 | |
---|
1892 | fprintf(fp,"$! 'f$verify(0)\n"); |
---|
1893 | fprintf(fp,"$! --- protect against nonstandard definitions ---\n"); |
---|
1894 | fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n"); |
---|
1895 | fprintf(fp,"$ perl_define = \"define/nolog\"\n"); |
---|
1896 | fprintf(fp,"$ perl_on = \"set noon\"\n"); |
---|
1897 | fprintf(fp,"$ perl_exit = \"exit\"\n"); |
---|
1898 | fprintf(fp,"$ perl_del = \"delete\"\n"); |
---|
1899 | fprintf(fp,"$ pif = \"if\"\n"); |
---|
1900 | fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n"); |
---|
1901 | fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n"); |
---|
1902 | fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n"); |
---|
1903 | fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n"); |
---|
1904 | fprintf(fp,"$ cmd = perl_popen_cmd\n"); |
---|
1905 | fprintf(fp,"$! --- get rid of global symbols\n"); |
---|
1906 | fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n"); |
---|
1907 | fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n"); |
---|
1908 | fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n"); |
---|
1909 | fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd\n"); |
---|
1910 | fprintf(fp,"$ perl_on\n"); |
---|
1911 | fprintf(fp,"$ 'cmd\n"); |
---|
1912 | fprintf(fp,"$ perl_status = $STATUS\n"); |
---|
1913 | fprintf(fp,"$ perl_del 'perl_cfile'\n"); |
---|
1914 | fprintf(fp,"$ perl_exit 'perl_status'\n"); |
---|
1915 | fsync(fileno(fp)); |
---|
1916 | |
---|
1917 | fgetname(fp, file, 1); |
---|
1918 | fstat(fileno(fp), &s0); |
---|
1919 | fclose(fp); |
---|
1920 | |
---|
1921 | fp = fopen(file,"r","shr=get"); |
---|
1922 | if (!fp) return 0; |
---|
1923 | fstat(fileno(fp), &s1); |
---|
1924 | |
---|
1925 | if (s0.st_ino[0] != s1.st_ino[0] || |
---|
1926 | s0.st_ino[1] != s1.st_ino[1] || |
---|
1927 | s0.st_ino[2] != s1.st_ino[2] || |
---|
1928 | s0.st_ctime != s1.st_ctime ) { |
---|
1929 | fclose(fp); |
---|
1930 | return 0; |
---|
1931 | } |
---|
1932 | |
---|
1933 | return fp; |
---|
1934 | } |
---|
1935 | |
---|
1936 | |
---|
1937 | |
---|
1938 | static PerlIO * |
---|
1939 | safe_popen(char *cmd, char *mode) |
---|
1940 | { |
---|
1941 | dTHX; |
---|
1942 | static int handler_set_up = FALSE; |
---|
1943 | unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */ |
---|
1944 | unsigned int table = LIB$K_CLI_GLOBAL_SYM; |
---|
1945 | char *p, symbol[MAX_DCL_SYMBOL+1], *vmspipe; |
---|
1946 | char in[512], out[512], err[512], mbx[512]; |
---|
1947 | FILE *tpipe = 0; |
---|
1948 | char tfilebuf[NAM$C_MAXRSS+1]; |
---|
1949 | pInfo info; |
---|
1950 | struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T, |
---|
1951 | DSC$K_CLASS_S, symbol}; |
---|
1952 | struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T, |
---|
1953 | DSC$K_CLASS_S, 0}; |
---|
1954 | |
---|
1955 | $DESCRIPTOR(d_sym_cmd,"PERL_POPEN_CMD"); |
---|
1956 | $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN"); |
---|
1957 | $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT"); |
---|
1958 | $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR"); |
---|
1959 | |
---|
1960 | /* once-per-program initialization... |
---|
1961 | note that the SETAST calls and the dual test of pipe_ef |
---|
1962 | makes sure that only the FIRST thread through here does |
---|
1963 | the initialization...all other threads wait until it's |
---|
1964 | done. |
---|
1965 | |
---|
1966 | Yeah, uglier than a pthread call, it's got all the stuff inline |
---|
1967 | rather than in a separate routine. |
---|
1968 | */ |
---|
1969 | |
---|
1970 | if (!pipe_ef) { |
---|
1971 | _ckvmssts(sys$setast(0)); |
---|
1972 | if (!pipe_ef) { |
---|
1973 | unsigned long int pidcode = JPI$_PID; |
---|
1974 | $DESCRIPTOR(d_delay, RETRY_DELAY); |
---|
1975 | _ckvmssts(lib$get_ef(&pipe_ef)); |
---|
1976 | _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0)); |
---|
1977 | _ckvmssts(sys$bintim(&d_delay, delaytime)); |
---|
1978 | } |
---|
1979 | if (!handler_set_up) { |
---|
1980 | _ckvmssts(sys$dclexh(&pipe_exitblock)); |
---|
1981 | handler_set_up = TRUE; |
---|
1982 | } |
---|
1983 | _ckvmssts(sys$setast(1)); |
---|
1984 | } |
---|
1985 | |
---|
1986 | /* see if we can find a VMSPIPE.COM */ |
---|
1987 | |
---|
1988 | tfilebuf[0] = '@'; |
---|
1989 | vmspipe = find_vmspipe(); |
---|
1990 | if (vmspipe) { |
---|
1991 | strcpy(tfilebuf+1,vmspipe); |
---|
1992 | } else { /* uh, oh...we're in tempfile hell */ |
---|
1993 | tpipe = vmspipe_tempfile(); |
---|
1994 | if (!tpipe) { /* a fish popular in Boston */ |
---|
1995 | if (ckWARN(WARN_PIPE)) { |
---|
1996 | Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping"); |
---|
1997 | } |
---|
1998 | return Nullfp; |
---|
1999 | } |
---|
2000 | fgetname(tpipe,tfilebuf+1,1); |
---|
2001 | } |
---|
2002 | vmspipedsc.dsc$a_pointer = tfilebuf; |
---|
2003 | vmspipedsc.dsc$w_length = strlen(tfilebuf); |
---|
2004 | |
---|
2005 | if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; } |
---|
2006 | New(1301,info,1,Info); |
---|
2007 | |
---|
2008 | info->mode = *mode; |
---|
2009 | info->done = FALSE; |
---|
2010 | info->completion = 0; |
---|
2011 | info->closing = FALSE; |
---|
2012 | info->in = 0; |
---|
2013 | info->out = 0; |
---|
2014 | info->err = 0; |
---|
2015 | info->in_done = TRUE; |
---|
2016 | info->out_done = TRUE; |
---|
2017 | info->err_done = TRUE; |
---|
2018 | in[0] = out[0] = err[0] = '\0'; |
---|
2019 | |
---|
2020 | if (*mode == 'r') { /* piping from subroutine */ |
---|
2021 | |
---|
2022 | info->out = pipe_infromchild_setup(mbx,out); |
---|
2023 | if (info->out) { |
---|
2024 | info->out->pipe_done = &info->out_done; |
---|
2025 | info->out_done = FALSE; |
---|
2026 | info->out->info = info; |
---|
2027 | } |
---|
2028 | info->fp = PerlIO_open(mbx, mode); |
---|
2029 | if (!info->fp && info->out) { |
---|
2030 | sys$cancel(info->out->chan_out); |
---|
2031 | |
---|
2032 | while (!info->out_done) { |
---|
2033 | int done; |
---|
2034 | _ckvmssts(sys$setast(0)); |
---|
2035 | done = info->out_done; |
---|
2036 | if (!done) _ckvmssts(sys$clref(pipe_ef)); |
---|
2037 | _ckvmssts(sys$setast(1)); |
---|
2038 | if (!done) _ckvmssts(sys$waitfr(pipe_ef)); |
---|
2039 | } |
---|
2040 | |
---|
2041 | if (info->out->buf) Safefree(info->out->buf); |
---|
2042 | Safefree(info->out); |
---|
2043 | Safefree(info); |
---|
2044 | return Nullfp; |
---|
2045 | } |
---|
2046 | |
---|
2047 | info->err = pipe_mbxtofd_setup(fileno(stderr), err); |
---|
2048 | if (info->err) { |
---|
2049 | info->err->pipe_done = &info->err_done; |
---|
2050 | info->err_done = FALSE; |
---|
2051 | info->err->info = info; |
---|
2052 | } |
---|
2053 | |
---|
2054 | } else { /* piping to subroutine , mode=w*/ |
---|
2055 | |
---|
2056 | info->in = pipe_tochild_setup(in,mbx); |
---|
2057 | info->fp = PerlIO_open(mbx, mode); |
---|
2058 | if (info->in) { |
---|
2059 | info->in->pipe_done = &info->in_done; |
---|
2060 | info->in_done = FALSE; |
---|
2061 | info->in->info = info; |
---|
2062 | } |
---|
2063 | |
---|
2064 | /* error cleanup */ |
---|
2065 | if (!info->fp && info->in) { |
---|
2066 | info->done = TRUE; |
---|
2067 | _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0, |
---|
2068 | 0, 0, 0, 0, 0, 0, 0, 0)); |
---|
2069 | |
---|
2070 | while (!info->in_done) { |
---|
2071 | int done; |
---|
2072 | _ckvmssts(sys$setast(0)); |
---|
2073 | done = info->in_done; |
---|
2074 | if (!done) _ckvmssts(sys$clref(pipe_ef)); |
---|
2075 | _ckvmssts(sys$setast(1)); |
---|
2076 | if (!done) _ckvmssts(sys$waitfr(pipe_ef)); |
---|
2077 | } |
---|
2078 | |
---|
2079 | if (info->in->buf) Safefree(info->in->buf); |
---|
2080 | Safefree(info->in); |
---|
2081 | Safefree(info); |
---|
2082 | return Nullfp; |
---|
2083 | } |
---|
2084 | |
---|
2085 | |
---|
2086 | info->out = pipe_mbxtofd_setup(fileno(stdout), out); |
---|
2087 | if (info->out) { |
---|
2088 | info->out->pipe_done = &info->out_done; |
---|
2089 | info->out_done = FALSE; |
---|
2090 | info->out->info = info; |
---|
2091 | } |
---|
2092 | |
---|
2093 | info->err = pipe_mbxtofd_setup(fileno(stderr), err); |
---|
2094 | if (info->err) { |
---|
2095 | info->err->pipe_done = &info->err_done; |
---|
2096 | info->err_done = FALSE; |
---|
2097 | info->err->info = info; |
---|
2098 | } |
---|
2099 | } |
---|
2100 | |
---|
2101 | symbol[MAX_DCL_SYMBOL] = '\0'; |
---|
2102 | |
---|
2103 | strncpy(symbol, in, MAX_DCL_SYMBOL); |
---|
2104 | d_symbol.dsc$w_length = strlen(symbol); |
---|
2105 | _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table)); |
---|
2106 | |
---|
2107 | strncpy(symbol, err, MAX_DCL_SYMBOL); |
---|
2108 | d_symbol.dsc$w_length = strlen(symbol); |
---|
2109 | _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table)); |
---|
2110 | |
---|
2111 | strncpy(symbol, out, MAX_DCL_SYMBOL); |
---|
2112 | d_symbol.dsc$w_length = strlen(symbol); |
---|
2113 | _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table)); |
---|
2114 | |
---|
2115 | p = VMScmd.dsc$a_pointer; |
---|
2116 | while (*p && *p != '\n') p++; |
---|
2117 | *p = '\0'; /* truncate on \n */ |
---|
2118 | p = VMScmd.dsc$a_pointer; |
---|
2119 | while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */ |
---|
2120 | if (*p == '$') p++; /* remove leading $ */ |
---|
2121 | while (*p == ' ' || *p == '\t') p++; |
---|
2122 | strncpy(symbol, p, MAX_DCL_SYMBOL); |
---|
2123 | d_symbol.dsc$w_length = strlen(symbol); |
---|
2124 | _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table)); |
---|
2125 | |
---|
2126 | _ckvmssts(sys$setast(0)); |
---|
2127 | info->next=open_pipes; /* prepend to list */ |
---|
2128 | open_pipes=info; |
---|
2129 | _ckvmssts(sys$setast(1)); |
---|
2130 | _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags, |
---|
2131 | 0, &info->pid, &info->completion, |
---|
2132 | 0, popen_completion_ast,info,0,0,0)); |
---|
2133 | |
---|
2134 | /* if we were using a tempfile, close it now */ |
---|
2135 | |
---|
2136 | if (tpipe) fclose(tpipe); |
---|
2137 | |
---|
2138 | /* once the subprocess is spawned, its copied the symbols and |
---|
2139 | we can get rid of ours */ |
---|
2140 | |
---|
2141 | _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table)); |
---|
2142 | _ckvmssts(lib$delete_symbol(&d_sym_in, &table)); |
---|
2143 | _ckvmssts(lib$delete_symbol(&d_sym_err, &table)); |
---|
2144 | _ckvmssts(lib$delete_symbol(&d_sym_out, &table)); |
---|
2145 | vms_execfree(aTHX); |
---|
2146 | |
---|
2147 | PL_forkprocess = info->pid; |
---|
2148 | return info->fp; |
---|
2149 | } /* end of safe_popen */ |
---|
2150 | |
---|
2151 | |
---|
2152 | /*{{{ FILE *my_popen(char *cmd, char *mode)*/ |
---|
2153 | FILE * |
---|
2154 | Perl_my_popen(pTHX_ char *cmd, char *mode) |
---|
2155 | { |
---|
2156 | TAINT_ENV(); |
---|
2157 | TAINT_PROPER("popen"); |
---|
2158 | PERL_FLUSHALL_FOR_CHILD; |
---|
2159 | return safe_popen(cmd,mode); |
---|
2160 | } |
---|
2161 | |
---|
2162 | /*}}}*/ |
---|
2163 | |
---|
2164 | /*{{{ I32 my_pclose(FILE *fp)*/ |
---|
2165 | I32 Perl_my_pclose(pTHX_ FILE *fp) |
---|
2166 | { |
---|
2167 | dTHX; |
---|
2168 | pInfo info, last = NULL; |
---|
2169 | unsigned long int retsts; |
---|
2170 | int done, iss; |
---|
2171 | |
---|
2172 | for (info = open_pipes; info != NULL; last = info, info = info->next) |
---|
2173 | if (info->fp == fp) break; |
---|
2174 | |
---|
2175 | if (info == NULL) { /* no such pipe open */ |
---|
2176 | set_errno(ECHILD); /* quoth POSIX */ |
---|
2177 | set_vaxc_errno(SS$_NONEXPR); |
---|
2178 | return -1; |
---|
2179 | } |
---|
2180 | |
---|
2181 | /* If we were writing to a subprocess, insure that someone reading from |
---|
2182 | * the mailbox gets an EOF. It looks like a simple fclose() doesn't |
---|
2183 | * produce an EOF record in the mailbox. |
---|
2184 | * |
---|
2185 | * well, at least sometimes it *does*, so we have to watch out for |
---|
2186 | * the first EOF closing the pipe (and DASSGN'ing the channel)... |
---|
2187 | */ |
---|
2188 | |
---|
2189 | fsync(fileno(info->fp)); /* first, flush data */ |
---|
2190 | |
---|
2191 | _ckvmssts(sys$setast(0)); |
---|
2192 | info->closing = TRUE; |
---|
2193 | done = info->done && info->in_done && info->out_done && info->err_done; |
---|
2194 | /* hanging on write to Perl's input? cancel it */ |
---|
2195 | if (info->mode == 'r' && info->out && !info->out_done) { |
---|
2196 | if (info->out->chan_out) { |
---|
2197 | _ckvmssts(sys$cancel(info->out->chan_out)); |
---|
2198 | if (!info->out->chan_in) { /* EOF generation, need AST */ |
---|
2199 | _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0)); |
---|
2200 | } |
---|
2201 | } |
---|
2202 | } |
---|
2203 | if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */ |
---|
2204 | _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0, |
---|
2205 | 0, 0, 0, 0, 0, 0)); |
---|
2206 | _ckvmssts(sys$setast(1)); |
---|
2207 | PerlIO_close(info->fp); |
---|
2208 | |
---|
2209 | /* |
---|
2210 | we have to wait until subprocess completes, but ALSO wait until all |
---|
2211 | the i/o completes...otherwise we'll be freeing the "info" structure |
---|
2212 | that the i/o ASTs could still be using... |
---|
2213 | */ |
---|
2214 | |
---|
2215 | while (!done) { |
---|
2216 | _ckvmssts(sys$setast(0)); |
---|
2217 | done = info->done && info->in_done && info->out_done && info->err_done; |
---|
2218 | if (!done) _ckvmssts(sys$clref(pipe_ef)); |
---|
2219 | _ckvmssts(sys$setast(1)); |
---|
2220 | if (!done) _ckvmssts(sys$waitfr(pipe_ef)); |
---|
2221 | } |
---|
2222 | retsts = info->completion; |
---|
2223 | |
---|
2224 | /* remove from list of open pipes */ |
---|
2225 | _ckvmssts(sys$setast(0)); |
---|
2226 | if (last) last->next = info->next; |
---|
2227 | else open_pipes = info->next; |
---|
2228 | _ckvmssts(sys$setast(1)); |
---|
2229 | |
---|
2230 | /* free buffers and structures */ |
---|
2231 | |
---|
2232 | if (info->in) { |
---|
2233 | if (info->in->buf) Safefree(info->in->buf); |
---|
2234 | Safefree(info->in); |
---|
2235 | } |
---|
2236 | if (info->out) { |
---|
2237 | if (info->out->buf) Safefree(info->out->buf); |
---|
2238 | Safefree(info->out); |
---|
2239 | } |
---|
2240 | if (info->err) { |
---|
2241 | if (info->err->buf) Safefree(info->err->buf); |
---|
2242 | Safefree(info->err); |
---|
2243 | } |
---|
2244 | Safefree(info); |
---|
2245 | |
---|
2246 | return retsts; |
---|
2247 | |
---|
2248 | } /* end of my_pclose() */ |
---|
2249 | |
---|
2250 | /* sort-of waitpid; use only with popen() */ |
---|
2251 | /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/ |
---|
2252 | Pid_t |
---|
2253 | my_waitpid(Pid_t pid, int *statusp, int flags) |
---|
2254 | { |
---|
2255 | pInfo info; |
---|
2256 | int done; |
---|
2257 | dTHX; |
---|
2258 | |
---|
2259 | for (info = open_pipes; info != NULL; info = info->next) |
---|
2260 | if (info->pid == pid) break; |
---|
2261 | |
---|
2262 | if (info != NULL) { /* we know about this child */ |
---|
2263 | while (!info->done) { |
---|
2264 | _ckvmssts(sys$setast(0)); |
---|
2265 | done = info->done; |
---|
2266 | if (!done) _ckvmssts(sys$clref(pipe_ef)); |
---|
2267 | _ckvmssts(sys$setast(1)); |
---|
2268 | if (!done) _ckvmssts(sys$waitfr(pipe_ef)); |
---|
2269 | } |
---|
2270 | |
---|
2271 | *statusp = info->completion; |
---|
2272 | return pid; |
---|
2273 | } |
---|
2274 | else { /* we haven't heard of this child */ |
---|
2275 | $DESCRIPTOR(intdsc,"0 00:00:01"); |
---|
2276 | unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid; |
---|
2277 | unsigned long int interval[2],sts; |
---|
2278 | |
---|
2279 | if (ckWARN(WARN_EXEC)) { |
---|
2280 | _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)); |
---|
2281 | _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0)); |
---|
2282 | if (ownerpid != mypid) |
---|
2283 | Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid); |
---|
2284 | } |
---|
2285 | |
---|
2286 | _ckvmssts(sys$bintim(&intdsc,interval)); |
---|
2287 | while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) { |
---|
2288 | _ckvmssts(sys$schdwk(0,0,interval,0)); |
---|
2289 | _ckvmssts(sys$hiber()); |
---|
2290 | } |
---|
2291 | if (sts == SS$_NONEXPR) sts = SS$_NORMAL; |
---|
2292 | _ckvmssts(sts); |
---|
2293 | |
---|
2294 | /* There's no easy way to find the termination status a child we're |
---|
2295 | * not aware of beforehand. If we're really interested in the future, |
---|
2296 | * we can go looking for a termination mailbox, or chase after the |
---|
2297 | * accounting record for the process. |
---|
2298 | */ |
---|
2299 | *statusp = 0; |
---|
2300 | return pid; |
---|
2301 | } |
---|
2302 | |
---|
2303 | } /* end of waitpid() */ |
---|
2304 | /*}}}*/ |
---|
2305 | /*}}}*/ |
---|
2306 | /*}}}*/ |
---|
2307 | |
---|
2308 | /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */ |
---|
2309 | char * |
---|
2310 | my_gconvert(double val, int ndig, int trail, char *buf) |
---|
2311 | { |
---|
2312 | static char __gcvtbuf[DBL_DIG+1]; |
---|
2313 | char *loc; |
---|
2314 | |
---|
2315 | loc = buf ? buf : __gcvtbuf; |
---|
2316 | |
---|
2317 | #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */ |
---|
2318 | if (val < 1) { |
---|
2319 | sprintf(loc,"%.*g",ndig,val); |
---|
2320 | return loc; |
---|
2321 | } |
---|
2322 | #endif |
---|
2323 | |
---|
2324 | if (val) { |
---|
2325 | if (!buf && ndig > DBL_DIG) ndig = DBL_DIG; |
---|
2326 | return gcvt(val,ndig,loc); |
---|
2327 | } |
---|
2328 | else { |
---|
2329 | loc[0] = '0'; loc[1] = '\0'; |
---|
2330 | return loc; |
---|
2331 | } |
---|
2332 | |
---|
2333 | } |
---|
2334 | /*}}}*/ |
---|
2335 | |
---|
2336 | |
---|
2337 | /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/ |
---|
2338 | /* Shortcut for common case of simple calls to $PARSE and $SEARCH |
---|
2339 | * to expand file specification. Allows for a single default file |
---|
2340 | * specification and a simple mask of options. If outbuf is non-NULL, |
---|
2341 | * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which |
---|
2342 | * the resultant file specification is placed. If outbuf is NULL, the |
---|
2343 | * resultant file specification is placed into a static buffer. |
---|
2344 | * The third argument, if non-NULL, is taken to be a default file |
---|
2345 | * specification string. The fourth argument is unused at present. |
---|
2346 | * rmesexpand() returns the address of the resultant string if |
---|
2347 | * successful, and NULL on error. |
---|
2348 | */ |
---|
2349 | static char *mp_do_tounixspec(pTHX_ char *, char *, int); |
---|
2350 | |
---|
2351 | static char * |
---|
2352 | mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts) |
---|
2353 | { |
---|
2354 | static char __rmsexpand_retbuf[NAM$C_MAXRSS+1]; |
---|
2355 | char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1]; |
---|
2356 | char esa[NAM$C_MAXRSS], *cp, *out = NULL; |
---|
2357 | struct FAB myfab = cc$rms_fab; |
---|
2358 | struct NAM mynam = cc$rms_nam; |
---|
2359 | STRLEN speclen; |
---|
2360 | unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0; |
---|
2361 | |
---|
2362 | if (!filespec || !*filespec) { |
---|
2363 | set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL); |
---|
2364 | return NULL; |
---|
2365 | } |
---|
2366 | if (!outbuf) { |
---|
2367 | if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char); |
---|
2368 | else outbuf = __rmsexpand_retbuf; |
---|
2369 | } |
---|
2370 | if ((isunix = (strchr(filespec,'/') != NULL))) { |
---|
2371 | if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL; |
---|
2372 | filespec = vmsfspec; |
---|
2373 | } |
---|
2374 | |
---|
2375 | myfab.fab$l_fna = filespec; |
---|
2376 | myfab.fab$b_fns = strlen(filespec); |
---|
2377 | myfab.fab$l_nam = &mynam; |
---|
2378 | |
---|
2379 | if (defspec && *defspec) { |
---|
2380 | if (strchr(defspec,'/') != NULL) { |
---|
2381 | if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL; |
---|
2382 | defspec = tmpfspec; |
---|
2383 | } |
---|
2384 | myfab.fab$l_dna = defspec; |
---|
2385 | myfab.fab$b_dns = strlen(defspec); |
---|
2386 | } |
---|
2387 | |
---|
2388 | mynam.nam$l_esa = esa; |
---|
2389 | mynam.nam$b_ess = sizeof esa; |
---|
2390 | mynam.nam$l_rsa = outbuf; |
---|
2391 | mynam.nam$b_rss = NAM$C_MAXRSS; |
---|
2392 | |
---|
2393 | retsts = sys$parse(&myfab,0,0); |
---|
2394 | if (!(retsts & 1)) { |
---|
2395 | mynam.nam$b_nop |= NAM$M_SYNCHK; |
---|
2396 | if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) { |
---|
2397 | retsts = sys$parse(&myfab,0,0); |
---|
2398 | if (retsts & 1) goto expanded; |
---|
2399 | } |
---|
2400 | mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0; |
---|
2401 | (void) sys$parse(&myfab,0,0); /* Free search context */ |
---|
2402 | if (out) Safefree(out); |
---|
2403 | set_vaxc_errno(retsts); |
---|
2404 | if (retsts == RMS$_PRV) set_errno(EACCES); |
---|
2405 | else if (retsts == RMS$_DEV) set_errno(ENODEV); |
---|
2406 | else if (retsts == RMS$_DIR) set_errno(ENOTDIR); |
---|
2407 | else set_errno(EVMSERR); |
---|
2408 | return NULL; |
---|
2409 | } |
---|
2410 | retsts = sys$search(&myfab,0,0); |
---|
2411 | if (!(retsts & 1) && retsts != RMS$_FNF) { |
---|
2412 | mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL; |
---|
2413 | myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */ |
---|
2414 | if (out) Safefree(out); |
---|
2415 | set_vaxc_errno(retsts); |
---|
2416 | if (retsts == RMS$_PRV) set_errno(EACCES); |
---|
2417 | else set_errno(EVMSERR); |
---|
2418 | return NULL; |
---|
2419 | } |
---|
2420 | |
---|
2421 | /* If the input filespec contained any lowercase characters, |
---|
2422 | * downcase the result for compatibility with Unix-minded code. */ |
---|
2423 | expanded: |
---|
2424 | for (out = myfab.fab$l_fna; *out; out++) |
---|
2425 | if (islower(*out)) { haslower = 1; break; } |
---|
2426 | if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; } |
---|
2427 | else { out = esa; speclen = mynam.nam$b_esl; } |
---|
2428 | /* Trim off null fields added by $PARSE |
---|
2429 | * If type > 1 char, must have been specified in original or default spec |
---|
2430 | * (not true for version; $SEARCH may have added version of existing file). |
---|
2431 | */ |
---|
2432 | trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER); |
---|
2433 | trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) && |
---|
2434 | (mynam.nam$l_ver - mynam.nam$l_type == 1); |
---|
2435 | if (trimver || trimtype) { |
---|
2436 | if (defspec && *defspec) { |
---|
2437 | char defesa[NAM$C_MAXRSS]; |
---|
2438 | struct FAB deffab = cc$rms_fab; |
---|
2439 | struct NAM defnam = cc$rms_nam; |
---|
2440 | |
---|
2441 | deffab.fab$l_nam = &defnam; |
---|
2442 | deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns; |
---|
2443 | defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa; |
---|
2444 | defnam.nam$b_nop = NAM$M_SYNCHK; |
---|
2445 | if (sys$parse(&deffab,0,0) & 1) { |
---|
2446 | if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER); |
---|
2447 | if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE); |
---|
2448 | } |
---|
2449 | } |
---|
2450 | if (trimver) speclen = mynam.nam$l_ver - out; |
---|
2451 | if (trimtype) { |
---|
2452 | /* If we didn't already trim version, copy down */ |
---|
2453 | if (speclen > mynam.nam$l_ver - out) |
---|
2454 | memcpy(mynam.nam$l_type, mynam.nam$l_ver, |
---|
2455 | speclen - (mynam.nam$l_ver - out)); |
---|
2456 | speclen -= mynam.nam$l_ver - mynam.nam$l_type; |
---|
2457 | } |
---|
2458 | } |
---|
2459 | /* If we just had a directory spec on input, $PARSE "helpfully" |
---|
2460 | * adds an empty name and type for us */ |
---|
2461 | if (mynam.nam$l_name == mynam.nam$l_type && |
---|
2462 | mynam.nam$l_ver == mynam.nam$l_type + 1 && |
---|
2463 | !(mynam.nam$l_fnb & NAM$M_EXP_NAME)) |
---|
2464 | speclen = mynam.nam$l_name - out; |
---|
2465 | out[speclen] = '\0'; |
---|
2466 | if (haslower) __mystrtolower(out); |
---|
2467 | |
---|
2468 | /* Have we been working with an expanded, but not resultant, spec? */ |
---|
2469 | /* Also, convert back to Unix syntax if necessary. */ |
---|
2470 | if (!mynam.nam$b_rsl) { |
---|
2471 | if (isunix) { |
---|
2472 | if (do_tounixspec(esa,outbuf,0) == NULL) return NULL; |
---|
2473 | } |
---|
2474 | else strcpy(outbuf,esa); |
---|
2475 | } |
---|
2476 | else if (isunix) { |
---|
2477 | if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL; |
---|
2478 | strcpy(outbuf,tmpfspec); |
---|
2479 | } |
---|
2480 | mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL; |
---|
2481 | mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0; |
---|
2482 | myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */ |
---|
2483 | return outbuf; |
---|
2484 | } |
---|
2485 | /*}}}*/ |
---|
2486 | /* External entry points */ |
---|
2487 | char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt) |
---|
2488 | { return do_rmsexpand(spec,buf,0,def,opt); } |
---|
2489 | char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt) |
---|
2490 | { return do_rmsexpand(spec,buf,1,def,opt); } |
---|
2491 | |
---|
2492 | |
---|
2493 | /* |
---|
2494 | ** The following routines are provided to make life easier when |
---|
2495 | ** converting among VMS-style and Unix-style directory specifications. |
---|
2496 | ** All will take input specifications in either VMS or Unix syntax. On |
---|
2497 | ** failure, all return NULL. If successful, the routines listed below |
---|
2498 | ** return a pointer to a buffer containing the appropriately |
---|
2499 | ** reformatted spec (and, therefore, subsequent calls to that routine |
---|
2500 | ** will clobber the result), while the routines of the same names with |
---|
2501 | ** a _ts suffix appended will return a pointer to a mallocd string |
---|
2502 | ** containing the appropriately reformatted spec. |
---|
2503 | ** In all cases, only explicit syntax is altered; no check is made that |
---|
2504 | ** the resulting string is valid or that the directory in question |
---|
2505 | ** actually exists. |
---|
2506 | ** |
---|
2507 | ** fileify_dirspec() - convert a directory spec into the name of the |
---|
2508 | ** directory file (i.e. what you can stat() to see if it's a dir). |
---|
2509 | ** The style (VMS or Unix) of the result is the same as the style |
---|
2510 | ** of the parameter passed in. |
---|
2511 | ** pathify_dirspec() - convert a directory spec into a path (i.e. |
---|
2512 | ** what you prepend to a filename to indicate what directory it's in). |
---|
2513 | ** The style (VMS or Unix) of the result is the same as the style |
---|
2514 | ** of the parameter passed in. |
---|
2515 | ** tounixpath() - convert a directory spec into a Unix-style path. |
---|
2516 | ** tovmspath() - convert a directory spec into a VMS-style path. |
---|
2517 | ** tounixspec() - convert any file spec into a Unix-style file spec. |
---|
2518 | ** tovmsspec() - convert any file spec into a VMS-style spec. |
---|
2519 | ** |
---|
2520 | ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu> |
---|
2521 | ** Permission is given to distribute this code as part of the Perl |
---|
2522 | ** standard distribution under the terms of the GNU General Public |
---|
2523 | ** License or the Perl Artistic License. Copies of each may be |
---|
2524 | ** found in the Perl standard distribution. |
---|
2525 | */ |
---|
2526 | |
---|
2527 | /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/ |
---|
2528 | static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts) |
---|
2529 | { |
---|
2530 | static char __fileify_retbuf[NAM$C_MAXRSS+1]; |
---|
2531 | unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0; |
---|
2532 | char *retspec, *cp1, *cp2, *lastdir; |
---|
2533 | char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1]; |
---|
2534 | |
---|
2535 | if (!dir || !*dir) { |
---|
2536 | set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL; |
---|
2537 | } |
---|
2538 | dirlen = strlen(dir); |
---|
2539 | while (dirlen && dir[dirlen-1] == '/') --dirlen; |
---|
2540 | if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */ |
---|
2541 | strcpy(trndir,"/sys$disk/000000"); |
---|
2542 | dir = trndir; |
---|
2543 | dirlen = 16; |
---|
2544 | } |
---|
2545 | if (dirlen > NAM$C_MAXRSS) { |
---|
2546 | set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL; |
---|
2547 | } |
---|
2548 | if (!strpbrk(dir+1,"/]>:")) { |
---|
2549 | strcpy(trndir,*dir == '/' ? dir + 1: dir); |
---|
2550 | while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ; |
---|
2551 | dir = trndir; |
---|
2552 | dirlen = strlen(dir); |
---|
2553 | } |
---|
2554 | else { |
---|
2555 | strncpy(trndir,dir,dirlen); |
---|
2556 | trndir[dirlen] = '\0'; |
---|
2557 | dir = trndir; |
---|
2558 | } |
---|
2559 | /* If we were handed a rooted logical name or spec, treat it like a |
---|
2560 | * simple directory, so that |
---|
2561 | * $ Define myroot dev:[dir.] |
---|
2562 | * ... do_fileify_dirspec("myroot",buf,1) ... |
---|
2563 | * does something useful. |
---|
2564 | */ |
---|
2565 | if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) { |
---|
2566 | dir[--dirlen] = '\0'; |
---|
2567 | dir[dirlen-1] = ']'; |
---|
2568 | } |
---|
2569 | |
---|
2570 | if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) { |
---|
2571 | /* If we've got an explicit filename, we can just shuffle the string. */ |
---|
2572 | if (*(cp1+1)) hasfilename = 1; |
---|
2573 | /* Similarly, we can just back up a level if we've got multiple levels |
---|
2574 | of explicit directories in a VMS spec which ends with directories. */ |
---|
2575 | else { |
---|
2576 | for (cp2 = cp1; cp2 > dir; cp2--) { |
---|
2577 | if (*cp2 == '.') { |
---|
2578 | *cp2 = *cp1; *cp1 = '\0'; |
---|
2579 | hasfilename = 1; |
---|
2580 | break; |
---|
2581 | } |
---|
2582 | if (*cp2 == '[' || *cp2 == '<') break; |
---|
2583 | } |
---|
2584 | } |
---|
2585 | } |
---|
2586 | |
---|
2587 | if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */ |
---|
2588 | if (dir[0] == '.') { |
---|
2589 | if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0')) |
---|
2590 | return do_fileify_dirspec("[]",buf,ts); |
---|
2591 | else if (dir[1] == '.' && |
---|
2592 | (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0'))) |
---|
2593 | return do_fileify_dirspec("[-]",buf,ts); |
---|
2594 | } |
---|
2595 | if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */ |
---|
2596 | dirlen -= 1; /* to last element */ |
---|
2597 | lastdir = strrchr(dir,'/'); |
---|
2598 | } |
---|
2599 | else if ((cp1 = strstr(dir,"/.")) != NULL) { |
---|
2600 | /* If we have "/." or "/..", VMSify it and let the VMS code |
---|
2601 | * below expand it, rather than repeating the code to handle |
---|
2602 | * relative components of a filespec here */ |
---|
2603 | do { |
---|
2604 | if (*(cp1+2) == '.') cp1++; |
---|
2605 | if (*(cp1+2) == '/' || *(cp1+2) == '\0') { |
---|
2606 | if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL; |
---|
2607 | if (strchr(vmsdir,'/') != NULL) { |
---|
2608 | /* If do_tovmsspec() returned it, it must have VMS syntax |
---|
2609 | * delimiters in it, so it's a mixed VMS/Unix spec. We take |
---|
2610 | * the time to check this here only so we avoid a recursion |
---|
2611 | * loop; otherwise, gigo. |
---|
2612 | */ |
---|
2613 | set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL; |
---|
2614 | } |
---|
2615 | if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL; |
---|
2616 | return do_tounixspec(trndir,buf,ts); |
---|
2617 | } |
---|
2618 | cp1++; |
---|
2619 | } while ((cp1 = strstr(cp1,"/.")) != NULL); |
---|
2620 | lastdir = strrchr(dir,'/'); |
---|
2621 | } |
---|
2622 | else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) { |
---|
2623 | /* Ditto for specs that end in an MFD -- let the VMS code |
---|
2624 | * figure out whether it's a real device or a rooted logical. */ |
---|
2625 | dir[dirlen] = '/'; dir[dirlen+1] = '\0'; |
---|
2626 | if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL; |
---|
2627 | if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL; |
---|
2628 | return do_tounixspec(trndir,buf,ts); |
---|
2629 | } |
---|
2630 | else { |
---|
2631 | if ( !(lastdir = cp1 = strrchr(dir,'/')) && |
---|
2632 | !(lastdir = cp1 = strrchr(dir,']')) && |
---|
2633 | !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir; |
---|
2634 | if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */ |
---|
2635 | int ver; char *cp3; |
---|
2636 | if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */ |
---|
2637 | !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */ |
---|
2638 | !*(cp2+3) || toupper(*(cp2+3)) != 'R' || |
---|
2639 | (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') || |
---|
2640 | (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 && |
---|
2641 | (ver || *cp3)))))) { |
---|
2642 | set_errno(ENOTDIR); |
---|
2643 | set_vaxc_errno(RMS$_DIR); |
---|
2644 | return NULL; |
---|
2645 | } |
---|
2646 | dirlen = cp2 - dir; |
---|
2647 | } |
---|
2648 | } |
---|
2649 | /* If we lead off with a device or rooted logical, add the MFD |
---|
2650 | if we're specifying a top-level directory. */ |
---|
2651 | if (lastdir && *dir == '/') { |
---|
2652 | addmfd = 1; |
---|
2653 | for (cp1 = lastdir - 1; cp1 > dir; cp1--) { |
---|
2654 | if (*cp1 == '/') { |
---|
2655 | addmfd = 0; |
---|
2656 | break; |
---|
2657 | } |
---|
2658 | } |
---|
2659 | } |
---|
2660 | retlen = dirlen + (addmfd ? 13 : 6); |
---|
2661 | if (buf) retspec = buf; |
---|
2662 | else if (ts) New(1309,retspec,retlen+1,char); |
---|
2663 | else retspec = __fileify_retbuf; |
---|
2664 | if (addmfd) { |
---|
2665 | dirlen = lastdir - dir; |
---|
2666 | memcpy(retspec,dir,dirlen); |
---|
2667 | strcpy(&retspec[dirlen],"/000000"); |
---|
2668 | strcpy(&retspec[dirlen+7],lastdir); |
---|
2669 | } |
---|
2670 | else { |
---|
2671 | memcpy(retspec,dir,dirlen); |
---|
2672 | retspec[dirlen] = '\0'; |
---|
2673 | } |
---|
2674 | /* We've picked up everything up to the directory file name. |
---|
2675 | Now just add the type and version, and we're set. */ |
---|
2676 | strcat(retspec,".dir;1"); |
---|
2677 | return retspec; |
---|
2678 | } |
---|
2679 | else { /* VMS-style directory spec */ |
---|
2680 | char esa[NAM$C_MAXRSS+1], term, *cp; |
---|
2681 | unsigned long int sts, cmplen, haslower = 0; |
---|
2682 | struct FAB dirfab = cc$rms_fab; |
---|
2683 | struct NAM savnam, dirnam = cc$rms_nam; |
---|
2684 | |
---|
2685 | dirfab.fab$b_fns = strlen(dir); |
---|
2686 | dirfab.fab$l_fna = dir; |
---|
2687 | dirfab.fab$l_nam = &dirnam; |
---|
2688 | dirfab.fab$l_dna = ".DIR;1"; |
---|
2689 | dirfab.fab$b_dns = 6; |
---|
2690 | dirnam.nam$b_ess = NAM$C_MAXRSS; |
---|
2691 | dirnam.nam$l_esa = esa; |
---|
2692 | |
---|
2693 | for (cp = dir; *cp; cp++) |
---|
2694 | if (islower(*cp)) { haslower = 1; break; } |
---|
2695 | if (!((sts = sys$parse(&dirfab))&1)) { |
---|
2696 | if (dirfab.fab$l_sts == RMS$_DIR) { |
---|
2697 | dirnam.nam$b_nop |= NAM$M_SYNCHK; |
---|
2698 | sts = sys$parse(&dirfab) & 1; |
---|
2699 | } |
---|
2700 | if (!sts) { |
---|
2701 | set_errno(EVMSERR); |
---|
2702 | set_vaxc_errno(dirfab.fab$l_sts); |
---|
2703 | return NULL; |
---|
2704 | } |
---|
2705 | } |
---|
2706 | else { |
---|
2707 | savnam = dirnam; |
---|
2708 | if (sys$search(&dirfab)&1) { /* Does the file really exist? */ |
---|
2709 | /* Yes; fake the fnb bits so we'll check type below */ |
---|
2710 | dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER; |
---|
2711 | } |
---|
2712 | else { /* No; just work with potential name */ |
---|
2713 | if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam; |
---|
2714 | else { |
---|
2715 | set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts); |
---|
2716 | dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; |
---|
2717 | dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); |
---|
2718 | return NULL; |
---|
2719 | } |
---|
2720 | } |
---|
2721 | } |
---|
2722 | if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) { |
---|
2723 | cp1 = strchr(esa,']'); |
---|
2724 | if (!cp1) cp1 = strchr(esa,'>'); |
---|
2725 | if (cp1) { /* Should always be true */ |
---|
2726 | dirnam.nam$b_esl -= cp1 - esa - 1; |
---|
2727 | memcpy(esa,cp1 + 1,dirnam.nam$b_esl); |
---|
2728 | } |
---|
2729 | } |
---|
2730 | if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */ |
---|
2731 | /* Yep; check version while we're at it, if it's there. */ |
---|
2732 | cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4; |
---|
2733 | if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) { |
---|
2734 | /* Something other than .DIR[;1]. Bzzt. */ |
---|
2735 | dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; |
---|
2736 | dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); |
---|
2737 | set_errno(ENOTDIR); |
---|
2738 | set_vaxc_errno(RMS$_DIR); |
---|
2739 | return NULL; |
---|
2740 | } |
---|
2741 | } |
---|
2742 | esa[dirnam.nam$b_esl] = '\0'; |
---|
2743 | if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) { |
---|
2744 | /* They provided at least the name; we added the type, if necessary, */ |
---|
2745 | if (buf) retspec = buf; /* in sys$parse() */ |
---|
2746 | else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char); |
---|
2747 | else retspec = __fileify_retbuf; |
---|
2748 | strcpy(retspec,esa); |
---|
2749 | dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; |
---|
2750 | dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); |
---|
2751 | return retspec; |
---|
2752 | } |
---|
2753 | if ((cp1 = strstr(esa,".][000000]")) != NULL) { |
---|
2754 | for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2; |
---|
2755 | *cp1 = '\0'; |
---|
2756 | dirnam.nam$b_esl -= 9; |
---|
2757 | } |
---|
2758 | if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>'); |
---|
2759 | if (cp1 == NULL) { /* should never happen */ |
---|
2760 | dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; |
---|
2761 | dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); |
---|
2762 | return NULL; |
---|
2763 | } |
---|
2764 | term = *cp1; |
---|
2765 | *cp1 = '\0'; |
---|
2766 | retlen = strlen(esa); |
---|
2767 | if ((cp1 = strrchr(esa,'.')) != NULL) { |
---|
2768 | /* There's more than one directory in the path. Just roll back. */ |
---|
2769 | *cp1 = term; |
---|
2770 | if (buf) retspec = buf; |
---|
2771 | else if (ts) New(1311,retspec,retlen+7,char); |
---|
2772 | else retspec = __fileify_retbuf; |
---|
2773 | strcpy(retspec,esa); |
---|
2774 | } |
---|
2775 | else { |
---|
2776 | if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) { |
---|
2777 | /* Go back and expand rooted logical name */ |
---|
2778 | dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL; |
---|
2779 | if (!(sys$parse(&dirfab) & 1)) { |
---|
2780 | dirnam.nam$l_rlf = NULL; |
---|
2781 | dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); |
---|
2782 | set_errno(EVMSERR); |
---|
2783 | set_vaxc_errno(dirfab.fab$l_sts); |
---|
2784 | return NULL; |
---|
2785 | } |
---|
2786 | retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */ |
---|
2787 | if (buf) retspec = buf; |
---|
2788 | else if (ts) New(1312,retspec,retlen+16,char); |
---|
2789 | else retspec = __fileify_retbuf; |
---|
2790 | cp1 = strstr(esa,"]["); |
---|
2791 | dirlen = cp1 - esa; |
---|
2792 | memcpy(retspec,esa,dirlen); |
---|
2793 | if (!strncmp(cp1+2,"000000]",7)) { |
---|
2794 | retspec[dirlen-1] = '\0'; |
---|
2795 | for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ; |
---|
2796 | if (*cp1 == '.') *cp1 = ']'; |
---|
2797 | else { |
---|
2798 | memmove(cp1+8,cp1+1,retspec+dirlen-cp1); |
---|
2799 | memcpy(cp1+1,"000000]",7); |
---|
2800 | } |
---|
2801 | } |
---|
2802 | else { |
---|
2803 | memcpy(retspec+dirlen,cp1+2,retlen-dirlen); |
---|
2804 | retspec[retlen] = '\0'; |
---|
2805 | /* Convert last '.' to ']' */ |
---|
2806 | for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ; |
---|
2807 | if (*cp1 == '.') *cp1 = ']'; |
---|
2808 | else { |
---|
2809 | memmove(cp1+8,cp1+1,retspec+dirlen-cp1); |
---|
2810 | memcpy(cp1+1,"000000]",7); |
---|
2811 | } |
---|
2812 | } |
---|
2813 | } |
---|
2814 | else { /* This is a top-level dir. Add the MFD to the path. */ |
---|
2815 | if (buf) retspec = buf; |
---|
2816 | else if (ts) New(1312,retspec,retlen+16,char); |
---|
2817 | else retspec = __fileify_retbuf; |
---|
2818 | cp1 = esa; |
---|
2819 | cp2 = retspec; |
---|
2820 | while (*cp1 != ':') *(cp2++) = *(cp1++); |
---|
2821 | strcpy(cp2,":[000000]"); |
---|
2822 | cp1 += 2; |
---|
2823 | strcpy(cp2+9,cp1); |
---|
2824 | } |
---|
2825 | } |
---|
2826 | dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; |
---|
2827 | dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); |
---|
2828 | /* We've set up the string up through the filename. Add the |
---|
2829 | type and version, and we're done. */ |
---|
2830 | strcat(retspec,".DIR;1"); |
---|
2831 | |
---|
2832 | /* $PARSE may have upcased filespec, so convert output to lower |
---|
2833 | * case if input contained any lowercase characters. */ |
---|
2834 | if (haslower) __mystrtolower(retspec); |
---|
2835 | return retspec; |
---|
2836 | } |
---|
2837 | } /* end of do_fileify_dirspec() */ |
---|
2838 | /*}}}*/ |
---|
2839 | /* External entry points */ |
---|
2840 | char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf) |
---|
2841 | { return do_fileify_dirspec(dir,buf,0); } |
---|
2842 | char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf) |
---|
2843 | { return do_fileify_dirspec(dir,buf,1); } |
---|
2844 | |
---|
2845 | /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/ |
---|
2846 | static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts) |
---|
2847 | { |
---|
2848 | static char __pathify_retbuf[NAM$C_MAXRSS+1]; |
---|
2849 | unsigned long int retlen; |
---|
2850 | char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1]; |
---|
2851 | |
---|
2852 | if (!dir || !*dir) { |
---|
2853 | set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL; |
---|
2854 | } |
---|
2855 | |
---|
2856 | if (*dir) strcpy(trndir,dir); |
---|
2857 | else getcwd(trndir,sizeof trndir - 1); |
---|
2858 | |
---|
2859 | while (!strpbrk(trndir,"/]:>") && !no_translate_barewords |
---|
2860 | && my_trnlnm(trndir,trndir,0)) { |
---|
2861 | STRLEN trnlen = strlen(trndir); |
---|
2862 | |
---|
2863 | /* Trap simple rooted lnms, and return lnm:[000000] */ |
---|
2864 | if (!strcmp(trndir+trnlen-2,".]")) { |
---|
2865 | if (buf) retpath = buf; |
---|
2866 | else if (ts) New(1318,retpath,strlen(dir)+10,char); |
---|
2867 | else retpath = __pathify_retbuf; |
---|
2868 | strcpy(retpath,dir); |
---|
2869 | strcat(retpath,":[000000]"); |
---|
2870 | return retpath; |
---|
2871 | } |
---|
2872 | } |
---|
2873 | dir = trndir; |
---|
2874 | |
---|
2875 | if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */ |
---|
2876 | if (*dir == '.' && (*(dir+1) == '\0' || |
---|
2877 | (*(dir+1) == '.' && *(dir+2) == '\0'))) |
---|
2878 | retlen = 2 + (*(dir+1) != '\0'); |
---|
2879 | else { |
---|
2880 | if ( !(cp1 = strrchr(dir,'/')) && |
---|
2881 | !(cp1 = strrchr(dir,']')) && |
---|
2882 | !(cp1 = strrchr(dir,'>')) ) cp1 = dir; |
---|
2883 | if ((cp2 = strchr(cp1,'.')) != NULL && |
---|
2884 | (*(cp2-1) != '/' || /* Trailing '.', '..', */ |
---|
2885 | !(*(cp2+1) == '\0' || /* or '...' are dirs. */ |
---|
2886 | (*(cp2+1) == '.' && *(cp2+2) == '\0') || |
---|
2887 | (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) { |
---|
2888 | int ver; char *cp3; |
---|
2889 | if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */ |
---|
2890 | !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */ |
---|
2891 | !*(cp2+3) || toupper(*(cp2+3)) != 'R' || |
---|
2892 | (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') || |
---|
2893 | (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 && |
---|
2894 | (ver || *cp3)))))) { |
---|
2895 | set_errno(ENOTDIR); |
---|
2896 | set_vaxc_errno(RMS$_DIR); |
---|
2897 | return NULL; |
---|
2898 | } |
---|
2899 | retlen = cp2 - dir + 1; |
---|
2900 | } |
---|
2901 | else { /* No file type present. Treat the filename as a directory. */ |
---|
2902 | retlen = strlen(dir) + 1; |
---|
2903 | } |
---|
2904 | } |
---|
2905 | if (buf) retpath = buf; |
---|
2906 | else if (ts) New(1313,retpath,retlen+1,char); |
---|
2907 | else retpath = __pathify_retbuf; |
---|
2908 | strncpy(retpath,dir,retlen-1); |
---|
2909 | if (retpath[retlen-2] != '/') { /* If the path doesn't already end */ |
---|
2910 | retpath[retlen-1] = '/'; /* with '/', add it. */ |
---|
2911 | retpath[retlen] = '\0'; |
---|
2912 | } |
---|
2913 | else retpath[retlen-1] = '\0'; |
---|
2914 | } |
---|
2915 | else { /* VMS-style directory spec */ |
---|
2916 | char esa[NAM$C_MAXRSS+1], *cp; |
---|
2917 | unsigned long int sts, cmplen, haslower; |
---|
2918 | struct FAB dirfab = cc$rms_fab; |
---|
2919 | struct NAM savnam, dirnam = cc$rms_nam; |
---|
2920 | |
---|
2921 | /* If we've got an explicit filename, we can just shuffle the string. */ |
---|
2922 | if ( ( (cp1 = strrchr(dir,']')) != NULL || |
---|
2923 | (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) { |
---|
2924 | if ((cp2 = strchr(cp1,'.')) != NULL) { |
---|
2925 | int ver; char *cp3; |
---|
2926 | if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */ |
---|
2927 | !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */ |
---|
2928 | !*(cp2+3) || toupper(*(cp2+3)) != 'R' || |
---|
2929 | (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') || |
---|
2930 | (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 && |
---|
2931 | (ver || *cp3)))))) { |
---|
2932 | set_errno(ENOTDIR); |
---|
2933 | set_vaxc_errno(RMS$_DIR); |
---|
2934 | return NULL; |
---|
2935 | } |
---|
2936 | } |
---|
2937 | else { /* No file type, so just draw name into directory part */ |
---|
2938 | for (cp2 = cp1; *cp2; cp2++) ; |
---|
2939 | } |
---|
2940 | *cp2 = *cp1; |
---|
2941 | *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */ |
---|
2942 | *cp1 = '.'; |
---|
2943 | /* We've now got a VMS 'path'; fall through */ |
---|
2944 | } |
---|
2945 | dirfab.fab$b_fns = strlen(dir); |
---|
2946 | dirfab.fab$l_fna = dir; |
---|
2947 | if (dir[dirfab.fab$b_fns-1] == ']' || |
---|
2948 | dir[dirfab.fab$b_fns-1] == '>' || |
---|
2949 | dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */ |
---|
2950 | if (buf) retpath = buf; |
---|
2951 | else if (ts) New(1314,retpath,strlen(dir)+1,char); |
---|
2952 | else retpath = __pathify_retbuf; |
---|
2953 | strcpy(retpath,dir); |
---|
2954 | return retpath; |
---|
2955 | } |
---|
2956 | dirfab.fab$l_dna = ".DIR;1"; |
---|
2957 | dirfab.fab$b_dns = 6; |
---|
2958 | dirfab.fab$l_nam = &dirnam; |
---|
2959 | dirnam.nam$b_ess = (unsigned char) sizeof esa - 1; |
---|
2960 | dirnam.nam$l_esa = esa; |
---|
2961 | |
---|
2962 | for (cp = dir; *cp; cp++) |
---|
2963 | if (islower(*cp)) { haslower = 1; break; } |
---|
2964 | |
---|
2965 | if (!(sts = (sys$parse(&dirfab)&1))) { |
---|
2966 | if (dirfab.fab$l_sts == RMS$_DIR) { |
---|
2967 | dirnam.nam$b_nop |= NAM$M_SYNCHK; |
---|
2968 | sts = sys$parse(&dirfab) & 1; |
---|
2969 | } |
---|
2970 | if (!sts) { |
---|
2971 | set_errno(EVMSERR); |
---|
2972 | set_vaxc_errno(dirfab.fab$l_sts); |
---|
2973 | return NULL; |
---|
2974 | } |
---|
2975 | } |
---|
2976 | else { |
---|
2977 | savnam = dirnam; |
---|
2978 | if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */ |
---|
2979 | if (dirfab.fab$l_sts != RMS$_FNF) { |
---|
2980 | dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; |
---|
2981 | dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); |
---|
2982 | set_errno(EVMSERR); |
---|
2983 | set_vaxc_errno(dirfab.fab$l_sts); |
---|
2984 | return NULL; |
---|
2985 | } |
---|
2986 | dirnam = savnam; /* No; just work with potential name */ |
---|
2987 | } |
---|
2988 | } |
---|
2989 | if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */ |
---|
2990 | /* Yep; check version while we're at it, if it's there. */ |
---|
2991 | cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4; |
---|
2992 | if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) { |
---|
2993 | /* Something other than .DIR[;1]. Bzzt. */ |
---|
2994 | dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; |
---|
2995 | dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); |
---|
2996 | set_errno(ENOTDIR); |
---|
2997 | set_vaxc_errno(RMS$_DIR); |
---|
2998 | return NULL; |
---|
2999 | } |
---|
3000 | } |
---|
3001 | /* OK, the type was fine. Now pull any file name into the |
---|
3002 | directory path. */ |
---|
3003 | if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']'; |
---|
3004 | else { |
---|
3005 | cp1 = strrchr(esa,'>'); |
---|
3006 | *dirnam.nam$l_type = '>'; |
---|
3007 | } |
---|
3008 | *cp1 = '.'; |
---|
3009 | *(dirnam.nam$l_type + 1) = '\0'; |
---|
3010 | retlen = dirnam.nam$l_type - esa + 2; |
---|
3011 | if (buf) retpath = buf; |
---|
3012 | else if (ts) New(1314,retpath,retlen,char); |
---|
3013 | else retpath = __pathify_retbuf; |
---|
3014 | strcpy(retpath,esa); |
---|
3015 | dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; |
---|
3016 | dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); |
---|
3017 | /* $PARSE may have upcased filespec, so convert output to lower |
---|
3018 | * case if input contained any lowercase characters. */ |
---|
3019 | if (haslower) __mystrtolower(retpath); |
---|
3020 | } |
---|
3021 | |
---|
3022 | return retpath; |
---|
3023 | } /* end of do_pathify_dirspec() */ |
---|
3024 | /*}}}*/ |
---|
3025 | /* External entry points */ |
---|
3026 | char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf) |
---|
3027 | { return do_pathify_dirspec(dir,buf,0); } |
---|
3028 | char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf) |
---|
3029 | { return do_pathify_dirspec(dir,buf,1); } |
---|
3030 | |
---|
3031 | /*{{{ char *tounixspec[_ts](char *path, char *buf)*/ |
---|
3032 | static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts) |
---|
3033 | { |
---|
3034 | static char __tounixspec_retbuf[NAM$C_MAXRSS+1]; |
---|
3035 | char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1]; |
---|
3036 | int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0; |
---|
3037 | |
---|
3038 | if (spec == NULL) return NULL; |
---|
3039 | if (strlen(spec) > NAM$C_MAXRSS) return NULL; |
---|
3040 | if (buf) rslt = buf; |
---|
3041 | else if (ts) { |
---|
3042 | retlen = strlen(spec); |
---|
3043 | cp1 = strchr(spec,'['); |
---|
3044 | if (!cp1) cp1 = strchr(spec,'<'); |
---|
3045 | if (cp1) { |
---|
3046 | for (cp1++; *cp1; cp1++) { |
---|
3047 | if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */ |
---|
3048 | if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.') |
---|
3049 | { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */ |
---|
3050 | } |
---|
3051 | } |
---|
3052 | New(1315,rslt,retlen+2+2*expand,char); |
---|
3053 | } |
---|
3054 | else rslt = __tounixspec_retbuf; |
---|
3055 | if (strchr(spec,'/') != NULL) { |
---|
3056 | strcpy(rslt,spec); |
---|
3057 | return rslt; |
---|
3058 | } |
---|
3059 | |
---|
3060 | cp1 = rslt; |
---|
3061 | cp2 = spec; |
---|
3062 | dirend = strrchr(spec,']'); |
---|
3063 | if (dirend == NULL) dirend = strrchr(spec,'>'); |
---|
3064 | if (dirend == NULL) dirend = strchr(spec,':'); |
---|
3065 | if (dirend == NULL) { |
---|
3066 | strcpy(rslt,spec); |
---|
3067 | return rslt; |
---|
3068 | } |
---|
3069 | if (*cp2 != '[' && *cp2 != '<') { |
---|
3070 | *(cp1++) = '/'; |
---|
3071 | } |
---|
3072 | else { /* the VMS spec begins with directories */ |
---|
3073 | cp2++; |
---|
3074 | if (*cp2 == ']' || *cp2 == '>') { |
---|
3075 | *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0'; |
---|
3076 | return rslt; |
---|
3077 | } |
---|
3078 | else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */ |
---|
3079 | if (getcwd(tmp,sizeof tmp,1) == NULL) { |
---|
3080 | if (ts) Safefree(rslt); |
---|
3081 | return NULL; |
---|
3082 | } |
---|
3083 | do { |
---|
3084 | cp3 = tmp; |
---|
3085 | while (*cp3 != ':' && *cp3) cp3++; |
---|
3086 | *(cp3++) = '\0'; |
---|
3087 | if (strchr(cp3,']') != NULL) break; |
---|
3088 | } while (vmstrnenv(tmp,tmp,0,fildev,0)); |
---|
3089 | if (ts && !buf && |
---|
3090 | ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) { |
---|
3091 | retlen = devlen + dirlen; |
---|
3092 | Renew(rslt,retlen+1+2*expand,char); |
---|
3093 | cp1 = rslt; |
---|
3094 | } |
---|
3095 | cp3 = tmp; |
---|
3096 | *(cp1++) = '/'; |
---|
3097 | while (*cp3) { |
---|
3098 | *(cp1++) = *(cp3++); |
---|
3099 | if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */ |
---|
3100 | } |
---|
3101 | *(cp1++) = '/'; |
---|
3102 | } |
---|
3103 | else if ( *cp2 == '.') { |
---|
3104 | if (*(cp2+1) == '.' && *(cp2+2) == '.') { |
---|
3105 | *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/'; |
---|
3106 | cp2 += 3; |
---|
3107 | } |
---|
3108 | else cp2++; |
---|
3109 | } |
---|
3110 | } |
---|
3111 | for (; cp2 <= dirend; cp2++) { |
---|
3112 | if (*cp2 == ':') { |
---|
3113 | *(cp1++) = '/'; |
---|
3114 | if (*(cp2+1) == '[') cp2++; |
---|
3115 | } |
---|
3116 | else if (*cp2 == ']' || *cp2 == '>') { |
---|
3117 | if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */ |
---|
3118 | } |
---|
3119 | else if (*cp2 == '.') { |
---|
3120 | *(cp1++) = '/'; |
---|
3121 | if (*(cp2+1) == ']' || *(cp2+1) == '>') { |
---|
3122 | while (*(cp2+1) == ']' || *(cp2+1) == '>' || |
---|
3123 | *(cp2+1) == '[' || *(cp2+1) == '<') cp2++; |
---|
3124 | if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' || |
---|
3125 | *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7; |
---|
3126 | } |
---|
3127 | else if ( *(cp2+1) == '.' && *(cp2+2) == '.') { |
---|
3128 | *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/'; |
---|
3129 | cp2 += 2; |
---|
3130 | } |
---|
3131 | } |
---|
3132 | else if (*cp2 == '-') { |
---|
3133 | if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') { |
---|
3134 | while (*cp2 == '-') { |
---|
3135 | cp2++; |
---|
3136 | *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/'; |
---|
3137 | } |
---|
3138 | if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */ |
---|
3139 | if (ts) Safefree(rslt); /* filespecs like */ |
---|
3140 | set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */ |
---|
3141 | return NULL; |
---|
3142 | } |
---|
3143 | } |
---|
3144 | else *(cp1++) = *cp2; |
---|
3145 | } |
---|
3146 | else *(cp1++) = *cp2; |
---|
3147 | } |
---|
3148 | while (*cp2) *(cp1++) = *(cp2++); |
---|
3149 | *cp1 = '\0'; |
---|
3150 | |
---|
3151 | return rslt; |
---|
3152 | |
---|
3153 | } /* end of do_tounixspec() */ |
---|
3154 | /*}}}*/ |
---|
3155 | /* External entry points */ |
---|
3156 | char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); } |
---|
3157 | char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); } |
---|
3158 | |
---|
3159 | /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/ |
---|
3160 | static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) { |
---|
3161 | static char __tovmsspec_retbuf[NAM$C_MAXRSS+1]; |
---|
3162 | char *rslt, *dirend; |
---|
3163 | register char *cp1, *cp2; |
---|
3164 | unsigned long int infront = 0, hasdir = 1; |
---|
3165 | |
---|
3166 | if (path == NULL) return NULL; |
---|
3167 | if (buf) rslt = buf; |
---|
3168 | else if (ts) New(1316,rslt,strlen(path)+9,char); |
---|
3169 | else rslt = __tovmsspec_retbuf; |
---|
3170 | if (strpbrk(path,"]:>") || |
---|
3171 | (dirend = strrchr(path,'/')) == NULL) { |
---|
3172 | if (path[0] == '.') { |
---|
3173 | if (path[1] == '\0') strcpy(rslt,"[]"); |
---|
3174 | else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]"); |
---|
3175 | else strcpy(rslt,path); /* probably garbage */ |
---|
3176 | } |
---|
3177 | else strcpy(rslt,path); |
---|
3178 | return rslt; |
---|
3179 | } |
---|
3180 | if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */ |
---|
3181 | if (!*(dirend+2)) dirend +=2; |
---|
3182 | if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3; |
---|
3183 | if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4; |
---|
3184 | } |
---|
3185 | cp1 = rslt; |
---|
3186 | cp2 = path; |
---|
3187 | if (*cp2 == '/') { |
---|
3188 | char trndev[NAM$C_MAXRSS+1]; |
---|
3189 | int islnm, rooted; |
---|
3190 | STRLEN trnend; |
---|
3191 | |
---|
3192 | while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */ |
---|
3193 | if (!*(cp2+1)) { |
---|
3194 | if (!buf & ts) Renew(rslt,18,char); |
---|
3195 | strcpy(rslt,"sys$disk:[000000]"); |
---|
3196 | return rslt; |
---|
3197 | } |
---|
3198 | while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2; |
---|
3199 | *cp1 = '\0'; |
---|
3200 | islnm = my_trnlnm(rslt,trndev,0); |
---|
3201 | trnend = islnm ? strlen(trndev) - 1 : 0; |
---|
3202 | islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0; |
---|
3203 | rooted = islnm ? (trndev[trnend-1] == '.') : 0; |
---|
3204 | /* If the first element of the path is a logical name, determine |
---|
3205 | * whether it has to be translated so we can add more directories. */ |
---|
3206 | if (!islnm || rooted) { |
---|
3207 | *(cp1++) = ':'; |
---|
3208 | *(cp1++) = '['; |
---|
3209 | if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0'; |
---|
3210 | else cp2++; |
---|
3211 | } |
---|
3212 | else { |
---|
3213 | if (cp2 != dirend) { |
---|
3214 | if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char); |
---|
3215 | strcpy(rslt,trndev); |
---|
3216 | cp1 = rslt + trnend; |
---|
3217 | *(cp1++) = '.'; |
---|
3218 | cp2++; |
---|
3219 | } |
---|
3220 | else { |
---|
3221 | *(cp1++) = ':'; |
---|
3222 | hasdir = 0; |
---|
3223 | } |
---|
3224 | } |
---|
3225 | } |
---|
3226 | else { |
---|
3227 | *(cp1++) = '['; |
---|
3228 | if (*cp2 == '.') { |
---|
3229 | if (*(cp2+1) == '/' || *(cp2+1) == '\0') { |
---|
3230 | cp2 += 2; /* skip over "./" - it's redundant */ |
---|
3231 | *(cp1++) = '.'; /* but it does indicate a relative dirspec */ |
---|
3232 | } |
---|
3233 | else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) { |
---|
3234 | *(cp1++) = '-'; /* "../" --> "-" */ |
---|
3235 | cp2 += 3; |
---|
3236 | } |
---|
3237 | else if (*(cp2+1) == '.' && *(cp2+2) == '.' && |
---|
3238 | (*(cp2+3) == '/' || *(cp2+3) == '\0')) { |
---|
3239 | *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */ |
---|
3240 | if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */ |
---|
3241 | cp2 += 4; |
---|
3242 | } |
---|
3243 | if (cp2 > dirend) cp2 = dirend; |
---|
3244 | } |
---|
3245 | else *(cp1++) = '.'; |
---|
3246 | } |
---|
3247 | for (; cp2 < dirend; cp2++) { |
---|
3248 | if (*cp2 == '/') { |
---|
3249 | if (*(cp2-1) == '/') continue; |
---|
3250 | if (*(cp1-1) != '.') *(cp1++) = '.'; |
---|
3251 | infront = 0; |
---|
3252 | } |
---|
3253 | else if (!infront && *cp2 == '.') { |
---|
3254 | if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; } |
---|
3255 | else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */ |
---|
3256 | else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) { |
---|
3257 | if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */ |
---|
3258 | else if (*(cp1-2) == '[') *(cp1-1) = '-'; |
---|
3259 | else { /* back up over previous directory name */ |
---|
3260 | cp1--; |
---|
3261 | while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--; |
---|
3262 | if (*(cp1-1) == '[') { |
---|
3263 | memcpy(cp1,"000000.",7); |
---|
3264 | cp1 += 7; |
---|
3265 | } |
---|
3266 | } |
---|
3267 | cp2 += 2; |
---|
3268 | if (cp2 == dirend) break; |
---|
3269 | } |
---|
3270 | else if ( *(cp2+1) == '.' && *(cp2+2) == '.' && |
---|
3271 | (*(cp2+3) == '/' || *(cp2+3) == '\0') ) { |
---|
3272 | if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */ |
---|
3273 | *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */ |
---|
3274 | if (!*(cp2+3)) { |
---|
3275 | *(cp1++) = '.'; /* Simulate trailing '/' */ |
---|
3276 | cp2 += 2; /* for loop will incr this to == dirend */ |
---|
3277 | } |
---|
3278 | else cp2 += 3; /* Trailing '/' was there, so skip it, too */ |
---|
3279 | } |
---|
3280 | else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */ |
---|
3281 | } |
---|
3282 | else { |
---|
3283 | if (!infront && *(cp1-1) == '-') *(cp1++) = '.'; |
---|
3284 | if (*cp2 == '.') *(cp1++) = '_'; |
---|
3285 | else *(cp1++) = *cp2; |
---|
3286 | infront = 1; |
---|
3287 | } |
---|
3288 | } |
---|
3289 | if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */ |
---|
3290 | if (hasdir) *(cp1++) = ']'; |
---|
3291 | if (*cp2) cp2++; /* check in case we ended with trailing '..' */ |
---|
3292 | while (*cp2) *(cp1++) = *(cp2++); |
---|
3293 | *cp1 = '\0'; |
---|
3294 | |
---|
3295 | return rslt; |
---|
3296 | |
---|
3297 | } /* end of do_tovmsspec() */ |
---|
3298 | /*}}}*/ |
---|
3299 | /* External entry points */ |
---|
3300 | char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); } |
---|
3301 | char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); } |
---|
3302 | |
---|
3303 | /*{{{ char *tovmspath[_ts](char *path, char *buf)*/ |
---|
3304 | static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) { |
---|
3305 | static char __tovmspath_retbuf[NAM$C_MAXRSS+1]; |
---|
3306 | int vmslen; |
---|
3307 | char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp; |
---|
3308 | |
---|
3309 | if (path == NULL) return NULL; |
---|
3310 | if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL; |
---|
3311 | if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL; |
---|
3312 | if (buf) return buf; |
---|
3313 | else if (ts) { |
---|
3314 | vmslen = strlen(vmsified); |
---|
3315 | New(1317,cp,vmslen+1,char); |
---|
3316 | memcpy(cp,vmsified,vmslen); |
---|
3317 | cp[vmslen] = '\0'; |
---|
3318 | return cp; |
---|
3319 | } |
---|
3320 | else { |
---|
3321 | strcpy(__tovmspath_retbuf,vmsified); |
---|
3322 | return __tovmspath_retbuf; |
---|
3323 | } |
---|
3324 | |
---|
3325 | } /* end of do_tovmspath() */ |
---|
3326 | /*}}}*/ |
---|
3327 | /* External entry points */ |
---|
3328 | char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); } |
---|
3329 | char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); } |
---|
3330 | |
---|
3331 | |
---|
3332 | /*{{{ char *tounixpath[_ts](char *path, char *buf)*/ |
---|
3333 | static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) { |
---|
3334 | static char __tounixpath_retbuf[NAM$C_MAXRSS+1]; |
---|
3335 | int unixlen; |
---|
3336 | char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp; |
---|
3337 | |
---|
3338 | if (path == NULL) return NULL; |
---|
3339 | if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL; |
---|
3340 | if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL; |
---|
3341 | if (buf) return buf; |
---|
3342 | else if (ts) { |
---|
3343 | unixlen = strlen(unixified); |
---|
3344 | New(1317,cp,unixlen+1,char); |
---|
3345 | memcpy(cp,unixified,unixlen); |
---|
3346 | cp[unixlen] = '\0'; |
---|
3347 | return cp; |
---|
3348 | } |
---|
3349 | else { |
---|
3350 | strcpy(__tounixpath_retbuf,unixified); |
---|
3351 | return __tounixpath_retbuf; |
---|
3352 | } |
---|
3353 | |
---|
3354 | } /* end of do_tounixpath() */ |
---|
3355 | /*}}}*/ |
---|
3356 | /* External entry points */ |
---|
3357 | char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); } |
---|
3358 | char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); } |
---|
3359 | |
---|
3360 | /* |
---|
3361 | * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com) |
---|
3362 | * |
---|
3363 | ***************************************************************************** |
---|
3364 | * * |
---|
3365 | * Copyright (C) 1989-1994 by * |
---|
3366 | * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 * |
---|
3367 | * * |
---|
3368 | * Permission is hereby granted for the reproduction of this software, * |
---|
3369 | * on condition that this copyright notice is included in the reproduction, * |
---|
3370 | * and that such reproduction is not for purposes of profit or material * |
---|
3371 | * gain. * |
---|
3372 | * * |
---|
3373 | * 27-Aug-1994 Modified for inclusion in perl5 * |
---|
3374 | * by Charles Bailey bailey@newman.upenn.edu * |
---|
3375 | ***************************************************************************** |
---|
3376 | */ |
---|
3377 | |
---|
3378 | /* |
---|
3379 | * getredirection() is intended to aid in porting C programs |
---|
3380 | * to VMS (Vax-11 C). The native VMS environment does not support |
---|
3381 | * '>' and '<' I/O redirection, or command line wild card expansion, |
---|
3382 | * or a command line pipe mechanism using the '|' AND background |
---|
3383 | * command execution '&'. All of these capabilities are provided to any |
---|
3384 | * C program which calls this procedure as the first thing in the |
---|
3385 | * main program. |
---|
3386 | * The piping mechanism will probably work with almost any 'filter' type |
---|
3387 | * of program. With suitable modification, it may useful for other |
---|
3388 | * portability problems as well. |
---|
3389 | * |
---|
3390 | * Author: Mark Pizzolato mark@infocomm.com |
---|
3391 | */ |
---|
3392 | struct list_item |
---|
3393 | { |
---|
3394 | struct list_item *next; |
---|
3395 | char *value; |
---|
3396 | }; |
---|
3397 | |
---|
3398 | static void add_item(struct list_item **head, |
---|
3399 | struct list_item **tail, |
---|
3400 | char *value, |
---|
3401 | int *count); |
---|
3402 | |
---|
3403 | static void mp_expand_wild_cards(pTHX_ char *item, |
---|
3404 | struct list_item **head, |
---|
3405 | struct list_item **tail, |
---|
3406 | int *count); |
---|
3407 | |
---|
3408 | static int background_process(int argc, char **argv); |
---|
3409 | |
---|
3410 | static void pipe_and_fork(char **cmargv); |
---|
3411 | |
---|
3412 | /*{{{ void getredirection(int *ac, char ***av)*/ |
---|
3413 | static void |
---|
3414 | mp_getredirection(pTHX_ int *ac, char ***av) |
---|
3415 | /* |
---|
3416 | * Process vms redirection arg's. Exit if any error is seen. |
---|
3417 | * If getredirection() processes an argument, it is erased |
---|
3418 | * from the vector. getredirection() returns a new argc and argv value. |
---|
3419 | * In the event that a background command is requested (by a trailing "&"), |
---|
3420 | * this routine creates a background subprocess, and simply exits the program. |
---|
3421 | * |
---|
3422 | * Warning: do not try to simplify the code for vms. The code |
---|
3423 | * presupposes that getredirection() is called before any data is |
---|
3424 | * read from stdin or written to stdout. |
---|
3425 | * |
---|
3426 | * Normal usage is as follows: |
---|
3427 | * |
---|
3428 | * main(argc, argv) |
---|
3429 | * int argc; |
---|
3430 | * char *argv[]; |
---|
3431 | * { |
---|
3432 | * getredirection(&argc, &argv); |
---|
3433 | * } |
---|
3434 | */ |
---|
3435 | { |
---|
3436 | int argc = *ac; /* Argument Count */ |
---|
3437 | char **argv = *av; /* Argument Vector */ |
---|
3438 | char *ap; /* Argument pointer */ |
---|
3439 | int j; /* argv[] index */ |
---|
3440 | int item_count = 0; /* Count of Items in List */ |
---|
3441 | struct list_item *list_head = 0; /* First Item in List */ |
---|
3442 | struct list_item *list_tail; /* Last Item in List */ |
---|
3443 | char *in = NULL; /* Input File Name */ |
---|
3444 | char *out = NULL; /* Output File Name */ |
---|
3445 | char *outmode = "w"; /* Mode to Open Output File */ |
---|
3446 | char *err = NULL; /* Error File Name */ |
---|
3447 | char *errmode = "w"; /* Mode to Open Error File */ |
---|
3448 | int cmargc = 0; /* Piped Command Arg Count */ |
---|
3449 | char **cmargv = NULL;/* Piped Command Arg Vector */ |
---|
3450 | |
---|
3451 | /* |
---|
3452 | * First handle the case where the last thing on the line ends with |
---|
3453 | * a '&'. This indicates the desire for the command to be run in a |
---|
3454 | * subprocess, so we satisfy that desire. |
---|
3455 | */ |
---|
3456 | ap = argv[argc-1]; |
---|
3457 | if (0 == strcmp("&", ap)) |
---|
3458 | exit(background_process(--argc, argv)); |
---|
3459 | if (*ap && '&' == ap[strlen(ap)-1]) |
---|
3460 | { |
---|
3461 | ap[strlen(ap)-1] = '\0'; |
---|
3462 | exit(background_process(argc, argv)); |
---|
3463 | } |
---|
3464 | /* |
---|
3465 | * Now we handle the general redirection cases that involve '>', '>>', |
---|
3466 | * '<', and pipes '|'. |
---|
3467 | */ |
---|
3468 | for (j = 0; j < argc; ++j) |
---|
3469 | { |
---|
3470 | if (0 == strcmp("<", argv[j])) |
---|
3471 | { |
---|
3472 | if (j+1 >= argc) |
---|
3473 | { |
---|
3474 | PerlIO_printf(Perl_debug_log,"No input file after < on command line"); |
---|
3475 | exit(LIB$_WRONUMARG); |
---|
3476 | } |
---|
3477 | in = argv[++j]; |
---|
3478 | continue; |
---|
3479 | } |
---|
3480 | if ('<' == *(ap = argv[j])) |
---|
3481 | { |
---|
3482 | in = 1 + ap; |
---|
3483 | continue; |
---|
3484 | } |
---|
3485 | if (0 == strcmp(">", ap)) |
---|
3486 | { |
---|
3487 | if (j+1 >= argc) |
---|
3488 | { |
---|
3489 | PerlIO_printf(Perl_debug_log,"No output file after > on command line"); |
---|
3490 | exit(LIB$_WRONUMARG); |
---|
3491 | } |
---|
3492 | out = argv[++j]; |
---|
3493 | continue; |
---|
3494 | } |
---|
3495 | if ('>' == *ap) |
---|
3496 | { |
---|
3497 | if ('>' == ap[1]) |
---|
3498 | { |
---|
3499 | outmode = "a"; |
---|
3500 | if ('\0' == ap[2]) |
---|
3501 | out = argv[++j]; |
---|
3502 | else |
---|
3503 | out = 2 + ap; |
---|
3504 | } |
---|
3505 | else |
---|
3506 | out = 1 + ap; |
---|
3507 | if (j >= argc) |
---|
3508 | { |
---|
3509 | PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line"); |
---|
3510 | exit(LIB$_WRONUMARG); |
---|
3511 | } |
---|
3512 | continue; |
---|
3513 | } |
---|
3514 | if (('2' == *ap) && ('>' == ap[1])) |
---|
3515 | { |
---|
3516 | if ('>' == ap[2]) |
---|
3517 | { |
---|
3518 | errmode = "a"; |
---|
3519 | if ('\0' == ap[3]) |
---|
3520 | err = argv[++j]; |
---|
3521 | else |
---|
3522 | err = 3 + ap; |
---|
3523 | } |
---|
3524 | else |
---|
3525 | if ('\0' == ap[2]) |
---|
3526 | err = argv[++j]; |
---|
3527 | else |
---|
3528 | err = 2 + ap; |
---|
3529 | if (j >= argc) |
---|
3530 | { |
---|
3531 | PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line"); |
---|
3532 | exit(LIB$_WRONUMARG); |
---|
3533 | } |
---|
3534 | continue; |
---|
3535 | } |
---|
3536 | if (0 == strcmp("|", argv[j])) |
---|
3537 | { |
---|
3538 | if (j+1 >= argc) |
---|
3539 | { |
---|
3540 | PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line"); |
---|
3541 | exit(LIB$_WRONUMARG); |
---|
3542 | } |
---|
3543 | cmargc = argc-(j+1); |
---|
3544 | cmargv = &argv[j+1]; |
---|
3545 | argc = j; |
---|
3546 | continue; |
---|
3547 | } |
---|
3548 | if ('|' == *(ap = argv[j])) |
---|
3549 | { |
---|
3550 | ++argv[j]; |
---|
3551 | cmargc = argc-j; |
---|
3552 | cmargv = &argv[j]; |
---|
3553 | argc = j; |
---|
3554 | continue; |
---|
3555 | } |
---|
3556 | expand_wild_cards(ap, &list_head, &list_tail, &item_count); |
---|
3557 | } |
---|
3558 | /* |
---|
3559 | * Allocate and fill in the new argument vector, Some Unix's terminate |
---|
3560 | * the list with an extra null pointer. |
---|
3561 | */ |
---|
3562 | New(1302, argv, item_count+1, char *); |
---|
3563 | *av = argv; |
---|
3564 | for (j = 0; j < item_count; ++j, list_head = list_head->next) |
---|
3565 | argv[j] = list_head->value; |
---|
3566 | *ac = item_count; |
---|
3567 | if (cmargv != NULL) |
---|
3568 | { |
---|
3569 | if (out != NULL) |
---|
3570 | { |
---|
3571 | PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line"); |
---|
3572 | exit(LIB$_INVARGORD); |
---|
3573 | } |
---|
3574 | pipe_and_fork(cmargv); |
---|
3575 | } |
---|
3576 | |
---|
3577 | /* Check for input from a pipe (mailbox) */ |
---|
3578 | |
---|
3579 | if (in == NULL && 1 == isapipe(0)) |
---|
3580 | { |
---|
3581 | char mbxname[L_tmpnam]; |
---|
3582 | long int bufsize; |
---|
3583 | long int dvi_item = DVI$_DEVBUFSIZ; |
---|
3584 | $DESCRIPTOR(mbxnam, ""); |
---|
3585 | $DESCRIPTOR(mbxdevnam, ""); |
---|
3586 | |
---|
3587 | /* Input from a pipe, reopen it in binary mode to disable */ |
---|
3588 | /* carriage control processing. */ |
---|
3589 | |
---|
3590 | PerlIO_getname(stdin, mbxname); |
---|
3591 | mbxnam.dsc$a_pointer = mbxname; |
---|
3592 | mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer); |
---|
3593 | lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0); |
---|
3594 | mbxdevnam.dsc$a_pointer = mbxname; |
---|
3595 | mbxdevnam.dsc$w_length = sizeof(mbxname); |
---|
3596 | dvi_item = DVI$_DEVNAM; |
---|
3597 | lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length); |
---|
3598 | mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0'; |
---|
3599 | set_errno(0); |
---|
3600 | set_vaxc_errno(1); |
---|
3601 | freopen(mbxname, "rb", stdin); |
---|
3602 | if (errno != 0) |
---|
3603 | { |
---|
3604 | PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname); |
---|
3605 | exit(vaxc$errno); |
---|
3606 | } |
---|
3607 | } |
---|
3608 | if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2"))) |
---|
3609 | { |
---|
3610 | PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in); |
---|
3611 | exit(vaxc$errno); |
---|
3612 | } |
---|
3613 | if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2"))) |
---|
3614 | { |
---|
3615 | PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out); |
---|
3616 | exit(vaxc$errno); |
---|
3617 | } |
---|
3618 | if (out != NULL) Perl_vmssetuserlnm("SYS$OUTPUT",out); |
---|
3619 | |
---|
3620 | if (err != NULL) { |
---|
3621 | if (strcmp(err,"&1") == 0) { |
---|
3622 | dup2(fileno(stdout), fileno(Perl_debug_log)); |
---|
3623 | Perl_vmssetuserlnm("SYS$ERROR","SYS$OUTPUT"); |
---|
3624 | } else { |
---|
3625 | FILE *tmperr; |
---|
3626 | if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2"))) |
---|
3627 | { |
---|
3628 | PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err); |
---|
3629 | exit(vaxc$errno); |
---|
3630 | } |
---|
3631 | fclose(tmperr); |
---|
3632 | if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2")) |
---|
3633 | { |
---|
3634 | exit(vaxc$errno); |
---|
3635 | } |
---|
3636 | Perl_vmssetuserlnm("SYS$ERROR",err); |
---|
3637 | } |
---|
3638 | } |
---|
3639 | #ifdef ARGPROC_DEBUG |
---|
3640 | PerlIO_printf(Perl_debug_log, "Arglist:\n"); |
---|
3641 | for (j = 0; j < *ac; ++j) |
---|
3642 | PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]); |
---|
3643 | #endif |
---|
3644 | /* Clear errors we may have hit expanding wildcards, so they don't |
---|
3645 | show up in Perl's $! later */ |
---|
3646 | set_errno(0); set_vaxc_errno(1); |
---|
3647 | } /* end of getredirection() */ |
---|
3648 | /*}}}*/ |
---|
3649 | |
---|
3650 | static void add_item(struct list_item **head, |
---|
3651 | struct list_item **tail, |
---|
3652 | char *value, |
---|
3653 | int *count) |
---|
3654 | { |
---|
3655 | if (*head == 0) |
---|
3656 | { |
---|
3657 | New(1303,*head,1,struct list_item); |
---|
3658 | *tail = *head; |
---|
3659 | } |
---|
3660 | else { |
---|
3661 | New(1304,(*tail)->next,1,struct list_item); |
---|
3662 | *tail = (*tail)->next; |
---|
3663 | } |
---|
3664 | (*tail)->value = value; |
---|
3665 | ++(*count); |
---|
3666 | } |
---|
3667 | |
---|
3668 | static void mp_expand_wild_cards(pTHX_ char *item, |
---|
3669 | struct list_item **head, |
---|
3670 | struct list_item **tail, |
---|
3671 | int *count) |
---|
3672 | { |
---|
3673 | int expcount = 0; |
---|
3674 | unsigned long int context = 0; |
---|
3675 | int isunix = 0; |
---|
3676 | char *had_version; |
---|
3677 | char *had_device; |
---|
3678 | int had_directory; |
---|
3679 | char *devdir,*cp; |
---|
3680 | char vmsspec[NAM$C_MAXRSS+1]; |
---|
3681 | $DESCRIPTOR(filespec, ""); |
---|
3682 | $DESCRIPTOR(defaultspec, "SYS$DISK:[]"); |
---|
3683 | $DESCRIPTOR(resultspec, ""); |
---|
3684 | unsigned long int zero = 0, sts; |
---|
3685 | |
---|
3686 | for (cp = item; *cp; cp++) { |
---|
3687 | if (*cp == '*' || *cp == '%' || isspace(*cp)) break; |
---|
3688 | if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break; |
---|
3689 | } |
---|
3690 | if (!*cp || isspace(*cp)) |
---|
3691 | { |
---|
3692 | add_item(head, tail, item, count); |
---|
3693 | return; |
---|
3694 | } |
---|
3695 | resultspec.dsc$b_dtype = DSC$K_DTYPE_T; |
---|
3696 | resultspec.dsc$b_class = DSC$K_CLASS_D; |
---|
3697 | resultspec.dsc$a_pointer = NULL; |
---|
3698 | if ((isunix = (int) strchr(item,'/')) != (int) NULL) |
---|
3699 | filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0); |
---|
3700 | if (!isunix || !filespec.dsc$a_pointer) |
---|
3701 | filespec.dsc$a_pointer = item; |
---|
3702 | filespec.dsc$w_length = strlen(filespec.dsc$a_pointer); |
---|
3703 | /* |
---|
3704 | * Only return version specs, if the caller specified a version |
---|
3705 | */ |
---|
3706 | had_version = strchr(item, ';'); |
---|
3707 | /* |
---|
3708 | * Only return device and directory specs, if the caller specifed either. |
---|
3709 | */ |
---|
3710 | had_device = strchr(item, ':'); |
---|
3711 | had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<')); |
---|
3712 | |
---|
3713 | while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context, |
---|
3714 | &defaultspec, 0, 0, &zero)))) |
---|
3715 | { |
---|
3716 | char *string; |
---|
3717 | char *c; |
---|
3718 | |
---|
3719 | New(1305,string,resultspec.dsc$w_length+1,char); |
---|
3720 | strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length); |
---|
3721 | string[resultspec.dsc$w_length] = '\0'; |
---|
3722 | if (NULL == had_version) |
---|
3723 | *((char *)strrchr(string, ';')) = '\0'; |
---|
3724 | if ((!had_directory) && (had_device == NULL)) |
---|
3725 | { |
---|
3726 | if (NULL == (devdir = strrchr(string, ']'))) |
---|
3727 | devdir = strrchr(string, '>'); |
---|
3728 | strcpy(string, devdir + 1); |
---|
3729 | } |
---|
3730 | /* |
---|
3731 | * Be consistent with what the C RTL has already done to the rest of |
---|
3732 | * the argv items and lowercase all of these names. |
---|
3733 | */ |
---|
3734 | for (c = string; *c; ++c) |
---|
3735 | if (isupper(*c)) |
---|
3736 | *c = tolower(*c); |
---|
3737 | if (isunix) trim_unixpath(string,item,1); |
---|
3738 | add_item(head, tail, string, count); |
---|
3739 | ++expcount; |
---|
3740 | } |
---|
3741 | if (sts != RMS$_NMF) |
---|
3742 | { |
---|
3743 | set_vaxc_errno(sts); |
---|
3744 | switch (sts) |
---|
3745 | { |
---|
3746 | case RMS$_FNF: case RMS$_DNF: |
---|
3747 | set_errno(ENOENT); break; |
---|
3748 | case RMS$_DIR: |
---|
3749 | set_errno(ENOTDIR); break; |
---|
3750 | case RMS$_DEV: |
---|
3751 | set_errno(ENODEV); break; |
---|
3752 | case RMS$_FNM: case RMS$_SYN: |
---|
3753 | set_errno(EINVAL); break; |
---|
3754 | case RMS$_PRV: |
---|
3755 | set_errno(EACCES); break; |
---|
3756 | default: |
---|
3757 | _ckvmssts_noperl(sts); |
---|
3758 | } |
---|
3759 | } |
---|
3760 | if (expcount == 0) |
---|
3761 | add_item(head, tail, item, count); |
---|
3762 | _ckvmssts_noperl(lib$sfree1_dd(&resultspec)); |
---|
3763 | _ckvmssts_noperl(lib$find_file_end(&context)); |
---|
3764 | } |
---|
3765 | |
---|
3766 | static int child_st[2];/* Event Flag set when child process completes */ |
---|
3767 | |
---|
3768 | static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */ |
---|
3769 | |
---|
3770 | static unsigned long int exit_handler(int *status) |
---|
3771 | { |
---|
3772 | short iosb[4]; |
---|
3773 | |
---|
3774 | if (0 == child_st[0]) |
---|
3775 | { |
---|
3776 | #ifdef ARGPROC_DEBUG |
---|
3777 | PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n"); |
---|
3778 | #endif |
---|
3779 | fflush(stdout); /* Have to flush pipe for binary data to */ |
---|
3780 | /* terminate properly -- <tp@mccall.com> */ |
---|
3781 | sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0); |
---|
3782 | sys$dassgn(child_chan); |
---|
3783 | fclose(stdout); |
---|
3784 | sys$synch(0, child_st); |
---|
3785 | } |
---|
3786 | return(1); |
---|
3787 | } |
---|
3788 | |
---|
3789 | static void sig_child(int chan) |
---|
3790 | { |
---|
3791 | #ifdef ARGPROC_DEBUG |
---|
3792 | PerlIO_printf(Perl_debug_log, "Child Completion AST\n"); |
---|
3793 | #endif |
---|
3794 | if (child_st[0] == 0) |
---|
3795 | child_st[0] = 1; |
---|
3796 | } |
---|
3797 | |
---|
3798 | static struct exit_control_block exit_block = |
---|
3799 | { |
---|
3800 | 0, |
---|
3801 | exit_handler, |
---|
3802 | 1, |
---|
3803 | &exit_block.exit_status, |
---|
3804 | 0 |
---|
3805 | }; |
---|
3806 | |
---|
3807 | static void pipe_and_fork(char **cmargv) |
---|
3808 | { |
---|
3809 | char subcmd[2048]; |
---|
3810 | $DESCRIPTOR(cmddsc, ""); |
---|
3811 | static char mbxname[64]; |
---|
3812 | $DESCRIPTOR(mbxdsc, mbxname); |
---|
3813 | int pid, j; |
---|
3814 | unsigned long int zero = 0, one = 1; |
---|
3815 | |
---|
3816 | strcpy(subcmd, cmargv[0]); |
---|
3817 | for (j = 1; NULL != cmargv[j]; ++j) |
---|
3818 | { |
---|
3819 | strcat(subcmd, " \""); |
---|
3820 | strcat(subcmd, cmargv[j]); |
---|
3821 | strcat(subcmd, "\""); |
---|
3822 | } |
---|
3823 | cmddsc.dsc$a_pointer = subcmd; |
---|
3824 | cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer); |
---|
3825 | |
---|
3826 | create_mbx(&child_chan,&mbxdsc); |
---|
3827 | #ifdef ARGPROC_DEBUG |
---|
3828 | PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer); |
---|
3829 | PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer); |
---|
3830 | #endif |
---|
3831 | _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one, |
---|
3832 | 0, &pid, child_st, &zero, sig_child, |
---|
3833 | &child_chan)); |
---|
3834 | #ifdef ARGPROC_DEBUG |
---|
3835 | PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid); |
---|
3836 | #endif |
---|
3837 | sys$dclexh(&exit_block); |
---|
3838 | if (NULL == freopen(mbxname, "wb", stdout)) |
---|
3839 | { |
---|
3840 | PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname); |
---|
3841 | } |
---|
3842 | } |
---|
3843 | |
---|
3844 | static int background_process(int argc, char **argv) |
---|
3845 | { |
---|
3846 | char command[2048] = "$"; |
---|
3847 | $DESCRIPTOR(value, ""); |
---|
3848 | static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND"); |
---|
3849 | static $DESCRIPTOR(null, "NLA0:"); |
---|
3850 | static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID"); |
---|
3851 | char pidstring[80]; |
---|
3852 | $DESCRIPTOR(pidstr, ""); |
---|
3853 | int pid; |
---|
3854 | unsigned long int flags = 17, one = 1, retsts; |
---|
3855 | |
---|
3856 | strcat(command, argv[0]); |
---|
3857 | while (--argc) |
---|
3858 | { |
---|
3859 | strcat(command, " \""); |
---|
3860 | strcat(command, *(++argv)); |
---|
3861 | strcat(command, "\""); |
---|
3862 | } |
---|
3863 | value.dsc$a_pointer = command; |
---|
3864 | value.dsc$w_length = strlen(value.dsc$a_pointer); |
---|
3865 | _ckvmssts_noperl(lib$set_symbol(&cmd, &value)); |
---|
3866 | retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid); |
---|
3867 | if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */ |
---|
3868 | _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid)); |
---|
3869 | } |
---|
3870 | else { |
---|
3871 | _ckvmssts_noperl(retsts); |
---|
3872 | } |
---|
3873 | #ifdef ARGPROC_DEBUG |
---|
3874 | PerlIO_printf(Perl_debug_log, "%s\n", command); |
---|
3875 | #endif |
---|
3876 | sprintf(pidstring, "%08X", pid); |
---|
3877 | PerlIO_printf(Perl_debug_log, "%s\n", pidstring); |
---|
3878 | pidstr.dsc$a_pointer = pidstring; |
---|
3879 | pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer); |
---|
3880 | lib$set_symbol(&pidsymbol, &pidstr); |
---|
3881 | return(SS$_NORMAL); |
---|
3882 | } |
---|
3883 | /*}}}*/ |
---|
3884 | /***** End of code taken from Mark Pizzolato's argproc.c package *****/ |
---|
3885 | |
---|
3886 | |
---|
3887 | /* OS-specific initialization at image activation (not thread startup) */ |
---|
3888 | /* Older VAXC header files lack these constants */ |
---|
3889 | #ifndef JPI$_RIGHTS_SIZE |
---|
3890 | # define JPI$_RIGHTS_SIZE 817 |
---|
3891 | #endif |
---|
3892 | #ifndef KGB$M_SUBSYSTEM |
---|
3893 | # define KGB$M_SUBSYSTEM 0x8 |
---|
3894 | #endif |
---|
3895 | |
---|
3896 | /*{{{void vms_image_init(int *, char ***)*/ |
---|
3897 | void |
---|
3898 | vms_image_init(int *argcp, char ***argvp) |
---|
3899 | { |
---|
3900 | char eqv[LNM$C_NAMLENGTH+1] = ""; |
---|
3901 | unsigned int len, tabct = 8, tabidx = 0; |
---|
3902 | unsigned long int *mask, iosb[2], i, rlst[128], rsz; |
---|
3903 | unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)]; |
---|
3904 | unsigned short int dummy, rlen; |
---|
3905 | struct dsc$descriptor_s **tabvec; |
---|
3906 | dTHX; |
---|
3907 | struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy}, |
---|
3908 | {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen}, |
---|
3909 | { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy}, |
---|
3910 | { 0, 0, 0, 0} }; |
---|
3911 | |
---|
3912 | _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL)); |
---|
3913 | _ckvmssts(iosb[0]); |
---|
3914 | for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) { |
---|
3915 | if (iprv[i]) { /* Running image installed with privs? */ |
---|
3916 | _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */ |
---|
3917 | will_taint = TRUE; |
---|
3918 | break; |
---|
3919 | } |
---|
3920 | } |
---|
3921 | /* Rights identifiers might trigger tainting as well. */ |
---|
3922 | if (!will_taint && (rlen || rsz)) { |
---|
3923 | while (rlen < rsz) { |
---|
3924 | /* We didn't get all the identifiers on the first pass. Allocate a |
---|
3925 | * buffer much larger than $GETJPI wants (rsz is size in bytes that |
---|
3926 | * were needed to hold all identifiers at time of last call; we'll |
---|
3927 | * allocate that many unsigned long ints), and go back and get 'em. |
---|
3928 | * If it gave us less than it wanted to despite ample buffer space, |
---|
3929 | * something's broken. Is your system missing a system identifier? |
---|
3930 | */ |
---|
3931 | if (rsz <= jpilist[1].buflen) { |
---|
3932 | /* Perl_croak accvios when used this early in startup. */ |
---|
3933 | fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s", |
---|
3934 | rsz, (unsigned long) jpilist[1].buflen, |
---|
3935 | "Check your rights database for corruption.\n"); |
---|
3936 | exit(SS$_ABORT); |
---|
3937 | } |
---|
3938 | if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr); |
---|
3939 | jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int); |
---|
3940 | jpilist[1].buflen = rsz * sizeof(unsigned long int); |
---|
3941 | _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL)); |
---|
3942 | _ckvmssts(iosb[0]); |
---|
3943 | } |
---|
3944 | mask = jpilist[1].bufadr; |
---|
3945 | /* Check attribute flags for each identifier (2nd longword); protected |
---|
3946 | * subsystem identifiers trigger tainting. |
---|
3947 | */ |
---|
3948 | for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) { |
---|
3949 | if (mask[i] & KGB$M_SUBSYSTEM) { |
---|
3950 | will_taint = TRUE; |
---|
3951 | break; |
---|
3952 | } |
---|
3953 | } |
---|
3954 | if (mask != rlst) Safefree(mask); |
---|
3955 | } |
---|
3956 | /* We need to use this hack to tell Perl it should run with tainting, |
---|
3957 | * since its tainting flag may be part of the PL_curinterp struct, which |
---|
3958 | * hasn't been allocated when vms_image_init() is called. |
---|
3959 | */ |
---|
3960 | if (will_taint) { |
---|
3961 | char ***newap; |
---|
3962 | New(1320,newap,*argcp+2,char **); |
---|
3963 | newap[0] = argvp[0]; |
---|
3964 | *newap[1] = "-T"; |
---|
3965 | Copy(argvp[1],newap[2],*argcp-1,char **); |
---|
3966 | /* We orphan the old argv, since we don't know where it's come from, |
---|
3967 | * so we don't know how to free it. |
---|
3968 | */ |
---|
3969 | *argcp++; argvp = newap; |
---|
3970 | } |
---|
3971 | else { /* Did user explicitly request tainting? */ |
---|
3972 | int i; |
---|
3973 | char *cp, **av = *argvp; |
---|
3974 | for (i = 1; i < *argcp; i++) { |
---|
3975 | if (*av[i] != '-') break; |
---|
3976 | for (cp = av[i]+1; *cp; cp++) { |
---|
3977 | if (*cp == 'T') { will_taint = 1; break; } |
---|
3978 | else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' || |
---|
3979 | strchr("DFIiMmx",*cp)) break; |
---|
3980 | } |
---|
3981 | if (will_taint) break; |
---|
3982 | } |
---|
3983 | } |
---|
3984 | |
---|
3985 | for (tabidx = 0; |
---|
3986 | len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx); |
---|
3987 | tabidx++) { |
---|
3988 | if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *); |
---|
3989 | else if (tabidx >= tabct) { |
---|
3990 | tabct += 8; |
---|
3991 | Renew(tabvec,tabct,struct dsc$descriptor_s *); |
---|
3992 | } |
---|
3993 | New(1322,tabvec[tabidx],1,struct dsc$descriptor_s); |
---|
3994 | tabvec[tabidx]->dsc$w_length = 0; |
---|
3995 | tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T; |
---|
3996 | tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D; |
---|
3997 | tabvec[tabidx]->dsc$a_pointer = NULL; |
---|
3998 | _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx])); |
---|
3999 | } |
---|
4000 | if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; } |
---|
4001 | |
---|
4002 | getredirection(argcp,argvp); |
---|
4003 | #if defined(USE_THREADS) && ( defined(__DECC) || defined(__DECCXX) ) |
---|
4004 | { |
---|
4005 | # include <reentrancy.h> |
---|
4006 | (void) decc$set_reentrancy(C$C_MULTITHREAD); |
---|
4007 | } |
---|
4008 | #endif |
---|
4009 | return; |
---|
4010 | } |
---|
4011 | /*}}}*/ |
---|
4012 | |
---|
4013 | |
---|
4014 | /* trim_unixpath() |
---|
4015 | * Trim Unix-style prefix off filespec, so it looks like what a shell |
---|
4016 | * glob expansion would return (i.e. from specified prefix on, not |
---|
4017 | * full path). Note that returned filespec is Unix-style, regardless |
---|
4018 | * of whether input filespec was VMS-style or Unix-style. |
---|
4019 | * |
---|
4020 | * fspec is filespec to be trimmed, and wildspec is wildcard spec used to |
---|
4021 | * determine prefix (both may be in VMS or Unix syntax). opts is a bit |
---|
4022 | * vector of options; at present, only bit 0 is used, and if set tells |
---|
4023 | * trim unixpath to try the current default directory as a prefix when |
---|
4024 | * presented with a possibly ambiguous ... wildcard. |
---|
4025 | * |
---|
4026 | * Returns !=0 on success, with trimmed filespec replacing contents of |
---|
4027 | * fspec, and 0 on failure, with contents of fpsec unchanged. |
---|
4028 | */ |
---|
4029 | /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/ |
---|
4030 | int |
---|
4031 | Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts) |
---|
4032 | { |
---|
4033 | char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1], |
---|
4034 | *template, *base, *end, *cp1, *cp2; |
---|
4035 | register int tmplen, reslen = 0, dirs = 0; |
---|
4036 | |
---|
4037 | if (!wildspec || !fspec) return 0; |
---|
4038 | if (strpbrk(wildspec,"]>:") != NULL) { |
---|
4039 | if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0; |
---|
4040 | else template = unixwild; |
---|
4041 | } |
---|
4042 | else template = wildspec; |
---|
4043 | if (strpbrk(fspec,"]>:") != NULL) { |
---|
4044 | if (do_tounixspec(fspec,unixified,0) == NULL) return 0; |
---|
4045 | else base = unixified; |
---|
4046 | /* reslen != 0 ==> we had to unixify resultant filespec, so we must |
---|
4047 | * check to see that final result fits into (isn't longer than) fspec */ |
---|
4048 | reslen = strlen(fspec); |
---|
4049 | } |
---|
4050 | else base = fspec; |
---|
4051 | |
---|
4052 | /* No prefix or absolute path on wildcard, so nothing to remove */ |
---|
4053 | if (!*template || *template == '/') { |
---|
4054 | if (base == fspec) return 1; |
---|
4055 | tmplen = strlen(unixified); |
---|
4056 | if (tmplen > reslen) return 0; /* not enough space */ |
---|
4057 | /* Copy unixified resultant, including trailing NUL */ |
---|
4058 | memmove(fspec,unixified,tmplen+1); |
---|
4059 | return 1; |
---|
4060 | } |
---|
4061 | |
---|
4062 | for (end = base; *end; end++) ; /* Find end of resultant filespec */ |
---|
4063 | if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */ |
---|
4064 | for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++; |
---|
4065 | for (cp1 = end ;cp1 >= base; cp1--) |
---|
4066 | if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */ |
---|
4067 | { cp1++; break; } |
---|
4068 | if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1); |
---|
4069 | return 1; |
---|
4070 | } |
---|
4071 | else { |
---|
4072 | char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1]; |
---|
4073 | char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1; |
---|
4074 | int ells = 1, totells, segdirs, match; |
---|
4075 | struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl}, |
---|
4076 | resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; |
---|
4077 | |
---|
4078 | while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;} |
---|
4079 | totells = ells; |
---|
4080 | for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++; |
---|
4081 | if (ellipsis == template && opts & 1) { |
---|
4082 | /* Template begins with an ellipsis. Since we can't tell how many |
---|
4083 | * directory names at the front of the resultant to keep for an |
---|
4084 | * arbitrary starting point, we arbitrarily choose the current |
---|
4085 | * default directory as a starting point. If it's there as a prefix, |
---|
4086 | * clip it off. If not, fall through and act as if the leading |
---|
4087 | * ellipsis weren't there (i.e. return shortest possible path that |
---|
4088 | * could match template). |
---|
4089 | */ |
---|
4090 | if (getcwd(tpl, sizeof tpl,0) == NULL) return 0; |
---|
4091 | for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++) |
---|
4092 | if (_tolower(*cp1) != _tolower(*cp2)) break; |
---|
4093 | segdirs = dirs - totells; /* Min # of dirs we must have left */ |
---|
4094 | for (front = cp2+1; *front; front++) if (*front == '/') segdirs--; |
---|
4095 | if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) { |
---|
4096 | memcpy(fspec,cp2+1,end - cp2); |
---|
4097 | return 1; |
---|
4098 | } |
---|
4099 | } |
---|
4100 | /* First off, back up over constant elements at end of path */ |
---|
4101 | if (dirs) { |
---|
4102 | for (front = end ; front >= base; front--) |
---|
4103 | if (*front == '/' && !dirs--) { front++; break; } |
---|
4104 | } |
---|
4105 | for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres; |
---|
4106 | cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */ |
---|
4107 | if (cp1 != '\0') return 0; /* Path too long. */ |
---|
4108 | lcend = cp2; |
---|
4109 | *cp2 = '\0'; /* Pick up with memcpy later */ |
---|
4110 | lcfront = lcres + (front - base); |
---|
4111 | /* Now skip over each ellipsis and try to match the path in front of it. */ |
---|
4112 | while (ells--) { |
---|
4113 | for (cp1 = ellipsis - 2; cp1 >= template; cp1--) |
---|
4114 | if (*(cp1) == '.' && *(cp1+1) == '.' && |
---|
4115 | *(cp1+2) == '.' && *(cp1+3) == '/' ) break; |
---|
4116 | if (cp1 < template) break; /* template started with an ellipsis */ |
---|
4117 | if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */ |
---|
4118 | ellipsis = cp1; continue; |
---|
4119 | } |
---|
4120 | wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1; |
---|
4121 | nextell = cp1; |
---|
4122 | for (segdirs = 0, cp2 = tpl; |
---|
4123 | cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl; |
---|
4124 | cp1++, cp2++) { |
---|
4125 | if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */ |
---|
4126 | else *cp2 = _tolower(*cp1); /* else lowercase for match */ |
---|
4127 | if (*cp2 == '/') segdirs++; |
---|
4128 | } |
---|
4129 | if (cp1 != ellipsis - 1) return 0; /* Path too long */ |
---|
4130 | /* Back up at least as many dirs as in template before matching */ |
---|
4131 | for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--) |
---|
4132 | if (*cp1 == '/' && !segdirs--) { cp1++; break; } |
---|
4133 | for (match = 0; cp1 > lcres;) { |
---|
4134 | resdsc.dsc$a_pointer = cp1; |
---|
4135 | if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) { |
---|
4136 | match++; |
---|
4137 | if (match == 1) lcfront = cp1; |
---|
4138 | } |
---|
4139 | for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; } |
---|
4140 | } |
---|
4141 | if (!match) return 0; /* Can't find prefix ??? */ |
---|
4142 | if (match > 1 && opts & 1) { |
---|
4143 | /* This ... wildcard could cover more than one set of dirs (i.e. |
---|
4144 | * a set of similar dir names is repeated). If the template |
---|
4145 | * contains more than 1 ..., upstream elements could resolve the |
---|
4146 | * ambiguity, but it's not worth a full backtracking setup here. |
---|
4147 | * As a quick heuristic, clip off the current default directory |
---|
4148 | * if it's present to find the trimmed spec, else use the |
---|
4149 | * shortest string that this ... could cover. |
---|
4150 | */ |
---|
4151 | char def[NAM$C_MAXRSS+1], *st; |
---|
4152 | |
---|
4153 | if (getcwd(def, sizeof def,0) == NULL) return 0; |
---|
4154 | for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++) |
---|
4155 | if (_tolower(*cp1) != _tolower(*cp2)) break; |
---|
4156 | segdirs = dirs - totells; /* Min # of dirs we must have left */ |
---|
4157 | for (st = cp2+1; *st; st++) if (*st == '/') segdirs--; |
---|
4158 | if (*cp1 == '\0' && *cp2 == '/') { |
---|
4159 | memcpy(fspec,cp2+1,end - cp2); |
---|
4160 | return 1; |
---|
4161 | } |
---|
4162 | /* Nope -- stick with lcfront from above and keep going. */ |
---|
4163 | } |
---|
4164 | } |
---|
4165 | memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1); |
---|
4166 | return 1; |
---|
4167 | ellipsis = nextell; |
---|
4168 | } |
---|
4169 | |
---|
4170 | } /* end of trim_unixpath() */ |
---|
4171 | /*}}}*/ |
---|
4172 | |
---|
4173 | |
---|
4174 | /* |
---|
4175 | * VMS readdir() routines. |
---|
4176 | * Written by Rich $alz, <rsalz@bbn.com> in August, 1990. |
---|
4177 | * |
---|
4178 | * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu |
---|
4179 | * Minor modifications to original routines. |
---|
4180 | */ |
---|
4181 | |
---|
4182 | /* Number of elements in vms_versions array */ |
---|
4183 | #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0]) |
---|
4184 | |
---|
4185 | /* |
---|
4186 | * Open a directory, return a handle for later use. |
---|
4187 | */ |
---|
4188 | /*{{{ DIR *opendir(char*name) */ |
---|
4189 | DIR * |
---|
4190 | Perl_opendir(pTHX_ char *name) |
---|
4191 | { |
---|
4192 | DIR *dd; |
---|
4193 | char dir[NAM$C_MAXRSS+1]; |
---|
4194 | Stat_t sb; |
---|
4195 | |
---|
4196 | if (do_tovmspath(name,dir,0) == NULL) { |
---|
4197 | return NULL; |
---|
4198 | } |
---|
4199 | if (flex_stat(dir,&sb) == -1) return NULL; |
---|
4200 | if (!S_ISDIR(sb.st_mode)) { |
---|
4201 | set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR); |
---|
4202 | return NULL; |
---|
4203 | } |
---|
4204 | if (!cando_by_name(S_IRUSR,0,dir)) { |
---|
4205 | set_errno(EACCES); set_vaxc_errno(RMS$_PRV); |
---|
4206 | return NULL; |
---|
4207 | } |
---|
4208 | /* Get memory for the handle, and the pattern. */ |
---|
4209 | New(1306,dd,1,DIR); |
---|
4210 | New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char); |
---|
4211 | |
---|
4212 | /* Fill in the fields; mainly playing with the descriptor. */ |
---|
4213 | (void)sprintf(dd->pattern, "%s*.*",dir); |
---|
4214 | dd->context = 0; |
---|
4215 | dd->count = 0; |
---|
4216 | dd->vms_wantversions = 0; |
---|
4217 | dd->pat.dsc$a_pointer = dd->pattern; |
---|
4218 | dd->pat.dsc$w_length = strlen(dd->pattern); |
---|
4219 | dd->pat.dsc$b_dtype = DSC$K_DTYPE_T; |
---|
4220 | dd->pat.dsc$b_class = DSC$K_CLASS_S; |
---|
4221 | |
---|
4222 | return dd; |
---|
4223 | } /* end of opendir() */ |
---|
4224 | /*}}}*/ |
---|
4225 | |
---|
4226 | /* |
---|
4227 | * Set the flag to indicate we want versions or not. |
---|
4228 | */ |
---|
4229 | /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/ |
---|
4230 | void |
---|
4231 | vmsreaddirversions(DIR *dd, int flag) |
---|
4232 | { |
---|
4233 | dd->vms_wantversions = flag; |
---|
4234 | } |
---|
4235 | /*}}}*/ |
---|
4236 | |
---|
4237 | /* |
---|
4238 | * Free up an opened directory. |
---|
4239 | */ |
---|
4240 | /*{{{ void closedir(DIR *dd)*/ |
---|
4241 | void |
---|
4242 | closedir(DIR *dd) |
---|
4243 | { |
---|
4244 | (void)lib$find_file_end(&dd->context); |
---|
4245 | Safefree(dd->pattern); |
---|
4246 | Safefree((char *)dd); |
---|
4247 | } |
---|
4248 | /*}}}*/ |
---|
4249 | |
---|
4250 | /* |
---|
4251 | * Collect all the version numbers for the current file. |
---|
4252 | */ |
---|
4253 | static void |
---|
4254 | collectversions(dd) |
---|
4255 | DIR *dd; |
---|
4256 | { |
---|
4257 | struct dsc$descriptor_s pat; |
---|
4258 | struct dsc$descriptor_s res; |
---|
4259 | struct dirent *e; |
---|
4260 | char *p, *text, buff[sizeof dd->entry.d_name]; |
---|
4261 | int i; |
---|
4262 | unsigned long context, tmpsts; |
---|
4263 | dTHX; |
---|
4264 | |
---|
4265 | /* Convenient shorthand. */ |
---|
4266 | e = &dd->entry; |
---|
4267 | |
---|
4268 | /* Add the version wildcard, ignoring the "*.*" put on before */ |
---|
4269 | i = strlen(dd->pattern); |
---|
4270 | New(1308,text,i + e->d_namlen + 3,char); |
---|
4271 | (void)strcpy(text, dd->pattern); |
---|
4272 | (void)sprintf(&text[i - 3], "%s;*", e->d_name); |
---|
4273 | |
---|
4274 | /* Set up the pattern descriptor. */ |
---|
4275 | pat.dsc$a_pointer = text; |
---|
4276 | pat.dsc$w_length = i + e->d_namlen - 1; |
---|
4277 | pat.dsc$b_dtype = DSC$K_DTYPE_T; |
---|
4278 | pat.dsc$b_class = DSC$K_CLASS_S; |
---|
4279 | |
---|
4280 | /* Set up result descriptor. */ |
---|
4281 | res.dsc$a_pointer = buff; |
---|
4282 | res.dsc$w_length = sizeof buff - 2; |
---|
4283 | res.dsc$b_dtype = DSC$K_DTYPE_T; |
---|
4284 | res.dsc$b_class = DSC$K_CLASS_S; |
---|
4285 | |
---|
4286 | /* Read files, collecting versions. */ |
---|
4287 | for (context = 0, e->vms_verscount = 0; |
---|
4288 | e->vms_verscount < VERSIZE(e); |
---|
4289 | e->vms_verscount++) { |
---|
4290 | tmpsts = lib$find_file(&pat, &res, &context); |
---|
4291 | if (tmpsts == RMS$_NMF || context == 0) break; |
---|
4292 | _ckvmssts(tmpsts); |
---|
4293 | buff[sizeof buff - 1] = '\0'; |
---|
4294 | if ((p = strchr(buff, ';'))) |
---|
4295 | e->vms_versions[e->vms_verscount] = atoi(p + 1); |
---|
4296 | else |
---|
4297 | e->vms_versions[e->vms_verscount] = -1; |
---|
4298 | } |
---|
4299 | |
---|
4300 | _ckvmssts(lib$find_file_end(&context)); |
---|
4301 | Safefree(text); |
---|
4302 | |
---|
4303 | } /* end of collectversions() */ |
---|
4304 | |
---|
4305 | /* |
---|
4306 | * Read the next entry from the directory. |
---|
4307 | */ |
---|
4308 | /*{{{ struct dirent *readdir(DIR *dd)*/ |
---|
4309 | struct dirent * |
---|
4310 | readdir(DIR *dd) |
---|
4311 | { |
---|
4312 | struct dsc$descriptor_s res; |
---|
4313 | char *p, buff[sizeof dd->entry.d_name]; |
---|
4314 | unsigned long int tmpsts; |
---|
4315 | |
---|
4316 | /* Set up result descriptor, and get next file. */ |
---|
4317 | res.dsc$a_pointer = buff; |
---|
4318 | res.dsc$w_length = sizeof buff - 2; |
---|
4319 | res.dsc$b_dtype = DSC$K_DTYPE_T; |
---|
4320 | res.dsc$b_class = DSC$K_CLASS_S; |
---|
4321 | tmpsts = lib$find_file(&dd->pat, &res, &dd->context); |
---|
4322 | if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */ |
---|
4323 | if (!(tmpsts & 1)) { |
---|
4324 | set_vaxc_errno(tmpsts); |
---|
4325 | switch (tmpsts) { |
---|
4326 | case RMS$_PRV: |
---|
4327 | set_errno(EACCES); break; |
---|
4328 | case RMS$_DEV: |
---|
4329 | set_errno(ENODEV); break; |
---|
4330 | case RMS$_DIR: |
---|
4331 | set_errno(ENOTDIR); break; |
---|
4332 | case RMS$_FNF: case RMS$_DNF: |
---|
4333 | set_errno(ENOENT); break; |
---|
4334 | default: |
---|
4335 | set_errno(EVMSERR); |
---|
4336 | } |
---|
4337 | return NULL; |
---|
4338 | } |
---|
4339 | dd->count++; |
---|
4340 | /* Force the buffer to end with a NUL, and downcase name to match C convention. */ |
---|
4341 | buff[sizeof buff - 1] = '\0'; |
---|
4342 | for (p = buff; *p; p++) *p = _tolower(*p); |
---|
4343 | while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */ |
---|
4344 | *p = '\0'; |
---|
4345 | |
---|
4346 | /* Skip any directory component and just copy the name. */ |
---|
4347 | if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1); |
---|
4348 | else (void)strcpy(dd->entry.d_name, buff); |
---|
4349 | |
---|
4350 | /* Clobber the version. */ |
---|
4351 | if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0'; |
---|
4352 | |
---|
4353 | dd->entry.d_namlen = strlen(dd->entry.d_name); |
---|
4354 | dd->entry.vms_verscount = 0; |
---|
4355 | if (dd->vms_wantversions) collectversions(dd); |
---|
4356 | return &dd->entry; |
---|
4357 | |
---|
4358 | } /* end of readdir() */ |
---|
4359 | /*}}}*/ |
---|
4360 | |
---|
4361 | /* |
---|
4362 | * Return something that can be used in a seekdir later. |
---|
4363 | */ |
---|
4364 | /*{{{ long telldir(DIR *dd)*/ |
---|
4365 | long |
---|
4366 | telldir(DIR *dd) |
---|
4367 | { |
---|
4368 | return dd->count; |
---|
4369 | } |
---|
4370 | /*}}}*/ |
---|
4371 | |
---|
4372 | /* |
---|
4373 | * Return to a spot where we used to be. Brute force. |
---|
4374 | */ |
---|
4375 | /*{{{ void seekdir(DIR *dd,long count)*/ |
---|
4376 | void |
---|
4377 | seekdir(DIR *dd, long count) |
---|
4378 | { |
---|
4379 | int vms_wantversions; |
---|
4380 | dTHX; |
---|
4381 | |
---|
4382 | /* If we haven't done anything yet... */ |
---|
4383 | if (dd->count == 0) |
---|
4384 | return; |
---|
4385 | |
---|
4386 | /* Remember some state, and clear it. */ |
---|
4387 | vms_wantversions = dd->vms_wantversions; |
---|
4388 | dd->vms_wantversions = 0; |
---|
4389 | _ckvmssts(lib$find_file_end(&dd->context)); |
---|
4390 | dd->context = 0; |
---|
4391 | |
---|
4392 | /* The increment is in readdir(). */ |
---|
4393 | for (dd->count = 0; dd->count < count; ) |
---|
4394 | (void)readdir(dd); |
---|
4395 | |
---|
4396 | dd->vms_wantversions = vms_wantversions; |
---|
4397 | |
---|
4398 | } /* end of seekdir() */ |
---|
4399 | /*}}}*/ |
---|
4400 | |
---|
4401 | /* VMS subprocess management |
---|
4402 | * |
---|
4403 | * my_vfork() - just a vfork(), after setting a flag to record that |
---|
4404 | * the current script is trying a Unix-style fork/exec. |
---|
4405 | * |
---|
4406 | * vms_do_aexec() and vms_do_exec() are called in response to the |
---|
4407 | * perl 'exec' function. If this follows a vfork call, then they |
---|
4408 | * call out the the regular perl routines in doio.c which do an |
---|
4409 | * execvp (for those who really want to try this under VMS). |
---|
4410 | * Otherwise, they do exactly what the perl docs say exec should |
---|
4411 | * do - terminate the current script and invoke a new command |
---|
4412 | * (See below for notes on command syntax.) |
---|
4413 | * |
---|
4414 | * do_aspawn() and do_spawn() implement the VMS side of the perl |
---|
4415 | * 'system' function. |
---|
4416 | * |
---|
4417 | * Note on command arguments to perl 'exec' and 'system': When handled |
---|
4418 | * in 'VMSish fashion' (i.e. not after a call to vfork) The args |
---|
4419 | * are concatenated to form a DCL command string. If the first arg |
---|
4420 | * begins with '$' (i.e. the perl script had "\$ Type" or some such), |
---|
4421 | * the the command string is handed off to DCL directly. Otherwise, |
---|
4422 | * the first token of the command is taken as the filespec of an image |
---|
4423 | * to run. The filespec is expanded using a default type of '.EXE' and |
---|
4424 | * the process defaults for device, directory, etc., and if found, the resultant |
---|
4425 | * filespec is invoked using the DCL verb 'MCR', and passed the rest of |
---|
4426 | * the command string as parameters. This is perhaps a bit complicated, |
---|
4427 | * but I hope it will form a happy medium between what VMS folks expect |
---|
4428 | * from lib$spawn and what Unix folks expect from exec. |
---|
4429 | */ |
---|
4430 | |
---|
4431 | static int vfork_called; |
---|
4432 | |
---|
4433 | /*{{{int my_vfork()*/ |
---|
4434 | int |
---|
4435 | my_vfork() |
---|
4436 | { |
---|
4437 | vfork_called++; |
---|
4438 | return vfork(); |
---|
4439 | } |
---|
4440 | /*}}}*/ |
---|
4441 | |
---|
4442 | |
---|
4443 | static void |
---|
4444 | vms_execfree(pTHX) { |
---|
4445 | if (PL_Cmd) { |
---|
4446 | if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd); |
---|
4447 | PL_Cmd = Nullch; |
---|
4448 | } |
---|
4449 | if (VMScmd.dsc$a_pointer) { |
---|
4450 | Safefree(VMScmd.dsc$a_pointer); |
---|
4451 | VMScmd.dsc$w_length = 0; |
---|
4452 | VMScmd.dsc$a_pointer = Nullch; |
---|
4453 | } |
---|
4454 | } |
---|
4455 | |
---|
4456 | static char * |
---|
4457 | setup_argstr(SV *really, SV **mark, SV **sp) |
---|
4458 | { |
---|
4459 | dTHX; |
---|
4460 | char *junk, *tmps = Nullch; |
---|
4461 | register size_t cmdlen = 0; |
---|
4462 | size_t rlen; |
---|
4463 | register SV **idx; |
---|
4464 | STRLEN n_a; |
---|
4465 | |
---|
4466 | idx = mark; |
---|
4467 | if (really) { |
---|
4468 | tmps = SvPV(really,rlen); |
---|
4469 | if (*tmps) { |
---|
4470 | cmdlen += rlen + 1; |
---|
4471 | idx++; |
---|
4472 | } |
---|
4473 | } |
---|
4474 | |
---|
4475 | for (idx++; idx <= sp; idx++) { |
---|
4476 | if (*idx) { |
---|
4477 | junk = SvPVx(*idx,rlen); |
---|
4478 | cmdlen += rlen ? rlen + 1 : 0; |
---|
4479 | } |
---|
4480 | } |
---|
4481 | New(401,PL_Cmd,cmdlen+1,char); |
---|
4482 | |
---|
4483 | if (tmps && *tmps) { |
---|
4484 | strcpy(PL_Cmd,tmps); |
---|
4485 | mark++; |
---|
4486 | } |
---|
4487 | else *PL_Cmd = '\0'; |
---|
4488 | while (++mark <= sp) { |
---|
4489 | if (*mark) { |
---|
4490 | char *s = SvPVx(*mark,n_a); |
---|
4491 | if (!*s) continue; |
---|
4492 | if (*PL_Cmd) strcat(PL_Cmd," "); |
---|
4493 | strcat(PL_Cmd,s); |
---|
4494 | } |
---|
4495 | } |
---|
4496 | return PL_Cmd; |
---|
4497 | |
---|
4498 | } /* end of setup_argstr() */ |
---|
4499 | |
---|
4500 | |
---|
4501 | static unsigned long int |
---|
4502 | setup_cmddsc(char *cmd, int check_img) |
---|
4503 | { |
---|
4504 | char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1]; |
---|
4505 | $DESCRIPTOR(defdsc,".EXE"); |
---|
4506 | $DESCRIPTOR(defdsc2,"."); |
---|
4507 | $DESCRIPTOR(resdsc,resspec); |
---|
4508 | struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; |
---|
4509 | unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL; |
---|
4510 | register char *s, *rest, *cp, *wordbreak; |
---|
4511 | register int isdcl; |
---|
4512 | dTHX; |
---|
4513 | |
---|
4514 | if (strlen(cmd) > |
---|
4515 | (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec))) |
---|
4516 | return LIB$_INVARG; |
---|
4517 | s = cmd; |
---|
4518 | while (*s && isspace(*s)) s++; |
---|
4519 | |
---|
4520 | if (*s == '@' || *s == '$') { |
---|
4521 | vmsspec[0] = *s; rest = s + 1; |
---|
4522 | for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest; |
---|
4523 | } |
---|
4524 | else { cp = vmsspec; rest = s; } |
---|
4525 | if (*rest == '.' || *rest == '/') { |
---|
4526 | char *cp2; |
---|
4527 | for (cp2 = resspec; |
---|
4528 | *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec; |
---|
4529 | rest++, cp2++) *cp2 = *rest; |
---|
4530 | *cp2 = '\0'; |
---|
4531 | if (do_tovmsspec(resspec,cp,0)) { |
---|
4532 | s = vmsspec; |
---|
4533 | if (*rest) { |
---|
4534 | for (cp2 = vmsspec + strlen(vmsspec); |
---|
4535 | *rest && cp2 - vmsspec < sizeof vmsspec; |
---|
4536 | rest++, cp2++) *cp2 = *rest; |
---|
4537 | *cp2 = '\0'; |
---|
4538 | } |
---|
4539 | } |
---|
4540 | } |
---|
4541 | /* Intuit whether verb (first word of cmd) is a DCL command: |
---|
4542 | * - if first nonspace char is '@', it's a DCL indirection |
---|
4543 | * otherwise |
---|
4544 | * - if verb contains a filespec separator, it's not a DCL command |
---|
4545 | * - if it doesn't, caller tells us whether to default to a DCL |
---|
4546 | * command, or to a local image unless told it's DCL (by leading '$') |
---|
4547 | */ |
---|
4548 | if (*s == '@') isdcl = 1; |
---|
4549 | else { |
---|
4550 | register char *filespec = strpbrk(s,":<[.;"); |
---|
4551 | rest = wordbreak = strpbrk(s," \"\t/"); |
---|
4552 | if (!wordbreak) wordbreak = s + strlen(s); |
---|
4553 | if (*s == '$') check_img = 0; |
---|
4554 | if (filespec && (filespec < wordbreak)) isdcl = 0; |
---|
4555 | else isdcl = !check_img; |
---|
4556 | } |
---|
4557 | |
---|
4558 | if (!isdcl) { |
---|
4559 | imgdsc.dsc$a_pointer = s; |
---|
4560 | imgdsc.dsc$w_length = wordbreak - s; |
---|
4561 | retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags); |
---|
4562 | if (!(retsts&1)) { |
---|
4563 | _ckvmssts(lib$find_file_end(&cxt)); |
---|
4564 | retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags); |
---|
4565 | if (!(retsts & 1) && *s == '$') { |
---|
4566 | _ckvmssts(lib$find_file_end(&cxt)); |
---|
4567 | imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--; |
---|
4568 | retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags); |
---|
4569 | if (!(retsts&1)) { |
---|
4570 | _ckvmssts(lib$find_file_end(&cxt)); |
---|
4571 | retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags); |
---|
4572 | } |
---|
4573 | } |
---|
4574 | } |
---|
4575 | _ckvmssts(lib$find_file_end(&cxt)); |
---|
4576 | |
---|
4577 | if (retsts & 1) { |
---|
4578 | FILE *fp; |
---|
4579 | s = resspec; |
---|
4580 | while (*s && !isspace(*s)) s++; |
---|
4581 | *s = '\0'; |
---|
4582 | |
---|
4583 | /* check that it's really not DCL with no file extension */ |
---|
4584 | fp = fopen(resspec,"r","ctx=bin,shr=get"); |
---|
4585 | if (fp) { |
---|
4586 | char b[4] = {0,0,0,0}; |
---|
4587 | read(fileno(fp),b,4); |
---|
4588 | isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]); |
---|
4589 | fclose(fp); |
---|
4590 | } |
---|
4591 | if (check_img && isdcl) return RMS$_FNF; |
---|
4592 | |
---|
4593 | if (cando_by_name(S_IXUSR,0,resspec)) { |
---|
4594 | New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char); |
---|
4595 | if (!isdcl) { |
---|
4596 | strcpy(VMScmd.dsc$a_pointer,"$ MCR "); |
---|
4597 | } else { |
---|
4598 | strcpy(VMScmd.dsc$a_pointer,"@"); |
---|
4599 | } |
---|
4600 | strcat(VMScmd.dsc$a_pointer,resspec); |
---|
4601 | if (rest) strcat(VMScmd.dsc$a_pointer,rest); |
---|
4602 | VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer); |
---|
4603 | return retsts; |
---|
4604 | } |
---|
4605 | else retsts = RMS$_PRV; |
---|
4606 | } |
---|
4607 | } |
---|
4608 | /* It's either a DCL command or we couldn't find a suitable image */ |
---|
4609 | VMScmd.dsc$w_length = strlen(cmd); |
---|
4610 | if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd; |
---|
4611 | else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length); |
---|
4612 | if (!(retsts & 1)) { |
---|
4613 | /* just hand off status values likely to be due to user error */ |
---|
4614 | if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV || |
---|
4615 | retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN || |
---|
4616 | (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts; |
---|
4617 | else { _ckvmssts(retsts); } |
---|
4618 | } |
---|
4619 | |
---|
4620 | return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts); |
---|
4621 | |
---|
4622 | } /* end of setup_cmddsc() */ |
---|
4623 | |
---|
4624 | |
---|
4625 | /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */ |
---|
4626 | bool |
---|
4627 | vms_do_aexec(SV *really,SV **mark,SV **sp) |
---|
4628 | { |
---|
4629 | dTHX; |
---|
4630 | if (sp > mark) { |
---|
4631 | if (vfork_called) { /* this follows a vfork - act Unixish */ |
---|
4632 | vfork_called--; |
---|
4633 | if (vfork_called < 0) { |
---|
4634 | Perl_warn(aTHX_ "Internal inconsistency in tracking vforks"); |
---|
4635 | vfork_called = 0; |
---|
4636 | } |
---|
4637 | else return do_aexec(really,mark,sp); |
---|
4638 | } |
---|
4639 | /* no vfork - act VMSish */ |
---|
4640 | return vms_do_exec(setup_argstr(really,mark,sp)); |
---|
4641 | |
---|
4642 | } |
---|
4643 | |
---|
4644 | return FALSE; |
---|
4645 | } /* end of vms_do_aexec() */ |
---|
4646 | /*}}}*/ |
---|
4647 | |
---|
4648 | /* {{{bool vms_do_exec(char *cmd) */ |
---|
4649 | bool |
---|
4650 | vms_do_exec(char *cmd) |
---|
4651 | { |
---|
4652 | |
---|
4653 | dTHX; |
---|
4654 | if (vfork_called) { /* this follows a vfork - act Unixish */ |
---|
4655 | vfork_called--; |
---|
4656 | if (vfork_called < 0) { |
---|
4657 | Perl_warn(aTHX_ "Internal inconsistency in tracking vforks"); |
---|
4658 | vfork_called = 0; |
---|
4659 | } |
---|
4660 | else return do_exec(cmd); |
---|
4661 | } |
---|
4662 | |
---|
4663 | { /* no vfork - act VMSish */ |
---|
4664 | unsigned long int retsts; |
---|
4665 | |
---|
4666 | TAINT_ENV(); |
---|
4667 | TAINT_PROPER("exec"); |
---|
4668 | if ((retsts = setup_cmddsc(cmd,1)) & 1) |
---|
4669 | retsts = lib$do_command(&VMScmd); |
---|
4670 | |
---|
4671 | switch (retsts) { |
---|
4672 | case RMS$_FNF: case RMS$_DNF: |
---|
4673 | set_errno(ENOENT); break; |
---|
4674 | case RMS$_DIR: |
---|
4675 | set_errno(ENOTDIR); break; |
---|
4676 | case RMS$_DEV: |
---|
4677 | set_errno(ENODEV); break; |
---|
4678 | case RMS$_PRV: |
---|
4679 | set_errno(EACCES); break; |
---|
4680 | case RMS$_SYN: |
---|
4681 | set_errno(EINVAL); break; |
---|
4682 | case CLI$_BUFOVF: |
---|
4683 | set_errno(E2BIG); break; |
---|
4684 | case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */ |
---|
4685 | _ckvmssts(retsts); /* fall through */ |
---|
4686 | default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */ |
---|
4687 | set_errno(EVMSERR); |
---|
4688 | } |
---|
4689 | set_vaxc_errno(retsts); |
---|
4690 | if (ckWARN(WARN_EXEC)) { |
---|
4691 | Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s", |
---|
4692 | VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno)); |
---|
4693 | } |
---|
4694 | vms_execfree(aTHX); |
---|
4695 | } |
---|
4696 | |
---|
4697 | return FALSE; |
---|
4698 | |
---|
4699 | } /* end of vms_do_exec() */ |
---|
4700 | /*}}}*/ |
---|
4701 | |
---|
4702 | unsigned long int do_spawn(char *); |
---|
4703 | |
---|
4704 | /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */ |
---|
4705 | unsigned long int |
---|
4706 | do_aspawn(void *really,void **mark,void **sp) |
---|
4707 | { |
---|
4708 | dTHX; |
---|
4709 | if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp)); |
---|
4710 | |
---|
4711 | return SS$_ABORT; |
---|
4712 | } /* end of do_aspawn() */ |
---|
4713 | /*}}}*/ |
---|
4714 | |
---|
4715 | /* {{{unsigned long int do_spawn(char *cmd) */ |
---|
4716 | unsigned long int |
---|
4717 | do_spawn(char *cmd) |
---|
4718 | { |
---|
4719 | unsigned long int sts, substs, hadcmd = 1; |
---|
4720 | dTHX; |
---|
4721 | |
---|
4722 | TAINT_ENV(); |
---|
4723 | TAINT_PROPER("spawn"); |
---|
4724 | if (!cmd || !*cmd) { |
---|
4725 | hadcmd = 0; |
---|
4726 | sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0); |
---|
4727 | } |
---|
4728 | else if ((sts = setup_cmddsc(cmd,0)) & 1) { |
---|
4729 | sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0); |
---|
4730 | } |
---|
4731 | |
---|
4732 | if (!(sts & 1)) { |
---|
4733 | switch (sts) { |
---|
4734 | case RMS$_FNF: case RMS$_DNF: |
---|
4735 | set_errno(ENOENT); break; |
---|
4736 | case RMS$_DIR: |
---|
4737 | set_errno(ENOTDIR); break; |
---|
4738 | case RMS$_DEV: |
---|
4739 | set_errno(ENODEV); break; |
---|
4740 | case RMS$_PRV: |
---|
4741 | set_errno(EACCES); break; |
---|
4742 | case RMS$_SYN: |
---|
4743 | set_errno(EINVAL); break; |
---|
4744 | case CLI$_BUFOVF: |
---|
4745 | set_errno(E2BIG); break; |
---|
4746 | case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */ |
---|
4747 | _ckvmssts(sts); /* fall through */ |
---|
4748 | default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */ |
---|
4749 | set_errno(EVMSERR); |
---|
4750 | } |
---|
4751 | set_vaxc_errno(sts); |
---|
4752 | if (ckWARN(WARN_EXEC)) { |
---|
4753 | Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s", |
---|
4754 | hadcmd ? VMScmd.dsc$w_length : 0, |
---|
4755 | hadcmd ? VMScmd.dsc$a_pointer : "", |
---|
4756 | Strerror(errno)); |
---|
4757 | } |
---|
4758 | } |
---|
4759 | vms_execfree(aTHX); |
---|
4760 | return substs; |
---|
4761 | |
---|
4762 | } /* end of do_spawn() */ |
---|
4763 | /*}}}*/ |
---|
4764 | |
---|
4765 | |
---|
4766 | static unsigned int *sockflags, sockflagsize; |
---|
4767 | |
---|
4768 | /* |
---|
4769 | * Shim fdopen to identify sockets for my_fwrite later, since the stdio |
---|
4770 | * routines found in some versions of the CRTL can't deal with sockets. |
---|
4771 | * We don't shim the other file open routines since a socket isn't |
---|
4772 | * likely to be opened by a name. |
---|
4773 | */ |
---|
4774 | /*{{{ FILE *my_fdopen(int fd, char *mode)*/ |
---|
4775 | FILE *my_fdopen(int fd, char *mode) |
---|
4776 | { |
---|
4777 | FILE *fp = fdopen(fd,mode); |
---|
4778 | |
---|
4779 | if (fp) { |
---|
4780 | unsigned int fdoff = fd / sizeof(unsigned int); |
---|
4781 | struct stat sbuf; /* native stat; we don't need flex_stat */ |
---|
4782 | if (!sockflagsize || fdoff > sockflagsize) { |
---|
4783 | if (sockflags) Renew( sockflags,fdoff+2,unsigned int); |
---|
4784 | else New (1324,sockflags,fdoff+2,unsigned int); |
---|
4785 | memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize); |
---|
4786 | sockflagsize = fdoff + 2; |
---|
4787 | } |
---|
4788 | if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode)) |
---|
4789 | sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int)); |
---|
4790 | } |
---|
4791 | return fp; |
---|
4792 | |
---|
4793 | } |
---|
4794 | /*}}}*/ |
---|
4795 | |
---|
4796 | |
---|
4797 | /* |
---|
4798 | * Clear the corresponding bit when the (possibly) socket stream is closed. |
---|
4799 | * There still a small hole: we miss an implicit close which might occur |
---|
4800 | * via freopen(). >> Todo |
---|
4801 | */ |
---|
4802 | /*{{{ int my_fclose(FILE *fp)*/ |
---|
4803 | int my_fclose(FILE *fp) { |
---|
4804 | if (fp) { |
---|
4805 | unsigned int fd = fileno(fp); |
---|
4806 | unsigned int fdoff = fd / sizeof(unsigned int); |
---|
4807 | |
---|
4808 | if (sockflagsize && fdoff <= sockflagsize) |
---|
4809 | sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int)); |
---|
4810 | } |
---|
4811 | return fclose(fp); |
---|
4812 | } |
---|
4813 | /*}}}*/ |
---|
4814 | |
---|
4815 | |
---|
4816 | /* |
---|
4817 | * A simple fwrite replacement which outputs itmsz*nitm chars without |
---|
4818 | * introducing record boundaries every itmsz chars. |
---|
4819 | * We are using fputs, which depends on a terminating null. We may |
---|
4820 | * well be writing binary data, so we need to accommodate not only |
---|
4821 | * data with nulls sprinkled in the middle but also data with no null |
---|
4822 | * byte at the end. |
---|
4823 | */ |
---|
4824 | /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/ |
---|
4825 | int |
---|
4826 | my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest) |
---|
4827 | { |
---|
4828 | register char *cp, *end, *cpd, *data; |
---|
4829 | register unsigned int fd = fileno(dest); |
---|
4830 | register unsigned int fdoff = fd / sizeof(unsigned int); |
---|
4831 | int retval; |
---|
4832 | int bufsize = itmsz * nitm + 1; |
---|
4833 | |
---|
4834 | if (fdoff < sockflagsize && |
---|
4835 | (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) { |
---|
4836 | if (write(fd, src, itmsz * nitm) == EOF) return EOF; |
---|
4837 | return nitm; |
---|
4838 | } |
---|
4839 | |
---|
4840 | _ckvmssts_noperl(lib$get_vm(&bufsize, &data)); |
---|
4841 | memcpy( data, src, itmsz*nitm ); |
---|
4842 | data[itmsz*nitm] = '\0'; |
---|
4843 | |
---|
4844 | end = data + itmsz * nitm; |
---|
4845 | retval = (int) nitm; /* on success return # items written */ |
---|
4846 | |
---|
4847 | cpd = data; |
---|
4848 | while (cpd <= end) { |
---|
4849 | for (cp = cpd; cp <= end; cp++) if (!*cp) break; |
---|
4850 | if (fputs(cpd,dest) == EOF) { retval = EOF; break; } |
---|
4851 | if (cp < end) |
---|
4852 | if (fputc('\0',dest) == EOF) { retval = EOF; break; } |
---|
4853 | cpd = cp + 1; |
---|
4854 | } |
---|
4855 | |
---|
4856 | if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data)); |
---|
4857 | return retval; |
---|
4858 | |
---|
4859 | } /* end of my_fwrite() */ |
---|
4860 | /*}}}*/ |
---|
4861 | |
---|
4862 | /*{{{ int my_flush(FILE *fp)*/ |
---|
4863 | int |
---|
4864 | my_flush(FILE *fp) |
---|
4865 | { |
---|
4866 | int res; |
---|
4867 | if ((res = fflush(fp)) == 0 && fp) { |
---|
4868 | #ifdef VMS_DO_SOCKETS |
---|
4869 | Stat_t s; |
---|
4870 | if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode)) |
---|
4871 | #endif |
---|
4872 | res = fsync(fileno(fp)); |
---|
4873 | } |
---|
4874 | /* |
---|
4875 | * If the flush succeeded but set end-of-file, we need to clear |
---|
4876 | * the error because our caller may check ferror(). BTW, this |
---|
4877 | * probably means we just flushed an empty file. |
---|
4878 | */ |
---|
4879 | if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp); |
---|
4880 | |
---|
4881 | return res; |
---|
4882 | } |
---|
4883 | /*}}}*/ |
---|
4884 | |
---|
4885 | /* |
---|
4886 | * Here are replacements for the following Unix routines in the VMS environment: |
---|
4887 | * getpwuid Get information for a particular UIC or UID |
---|
4888 | * getpwnam Get information for a named user |
---|
4889 | * getpwent Get information for each user in the rights database |
---|
4890 | * setpwent Reset search to the start of the rights database |
---|
4891 | * endpwent Finish searching for users in the rights database |
---|
4892 | * |
---|
4893 | * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure |
---|
4894 | * (defined in pwd.h), which contains the following fields:- |
---|
4895 | * struct passwd { |
---|
4896 | * char *pw_name; Username (in lower case) |
---|
4897 | * char *pw_passwd; Hashed password |
---|
4898 | * unsigned int pw_uid; UIC |
---|
4899 | * unsigned int pw_gid; UIC group number |
---|
4900 | * char *pw_unixdir; Default device/directory (VMS-style) |
---|
4901 | * char *pw_gecos; Owner name |
---|
4902 | * char *pw_dir; Default device/directory (Unix-style) |
---|
4903 | * char *pw_shell; Default CLI name (eg. DCL) |
---|
4904 | * }; |
---|
4905 | * If the specified user does not exist, getpwuid and getpwnam return NULL. |
---|
4906 | * |
---|
4907 | * pw_uid is the full UIC (eg. what's returned by stat() in st_uid). |
---|
4908 | * not the UIC member number (eg. what's returned by getuid()), |
---|
4909 | * getpwuid() can accept either as input (if uid is specified, the caller's |
---|
4910 | * UIC group is used), though it won't recognise gid=0. |
---|
4911 | * |
---|
4912 | * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return |
---|
4913 | * information about other users in your group or in other groups, respectively. |
---|
4914 | * If the required privilege is not available, then these routines fill only |
---|
4915 | * the pw_name, pw_uid, and pw_gid fields (the others point to an empty |
---|
4916 | * string). |
---|
4917 | * |
---|
4918 | * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995. |
---|
4919 | */ |
---|
4920 | |
---|
4921 | /* sizes of various UAF record fields */ |
---|
4922 | #define UAI$S_USERNAME 12 |
---|
4923 | #define UAI$S_IDENT 31 |
---|
4924 | #define UAI$S_OWNER 31 |
---|
4925 | #define UAI$S_DEFDEV 31 |
---|
4926 | #define UAI$S_DEFDIR 63 |
---|
4927 | #define UAI$S_DEFCLI 31 |
---|
4928 | #define UAI$S_PWD 8 |
---|
4929 | |
---|
4930 | #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \ |
---|
4931 | (uic).uic$v_member != UIC$K_WILD_MEMBER && \ |
---|
4932 | (uic).uic$v_group != UIC$K_WILD_GROUP) |
---|
4933 | |
---|
4934 | static char __empty[]= ""; |
---|
4935 | static struct passwd __passwd_empty= |
---|
4936 | {(char *) __empty, (char *) __empty, 0, 0, |
---|
4937 | (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty}; |
---|
4938 | static int contxt= 0; |
---|
4939 | static struct passwd __pwdcache; |
---|
4940 | static char __pw_namecache[UAI$S_IDENT+1]; |
---|
4941 | |
---|
4942 | /* |
---|
4943 | * This routine does most of the work extracting the user information. |
---|
4944 | */ |
---|
4945 | static int fillpasswd (const char *name, struct passwd *pwd) |
---|
4946 | { |
---|
4947 | dTHX; |
---|
4948 | static struct { |
---|
4949 | unsigned char length; |
---|
4950 | char pw_gecos[UAI$S_OWNER+1]; |
---|
4951 | } owner; |
---|
4952 | static union uicdef uic; |
---|
4953 | static struct { |
---|
4954 | unsigned char length; |
---|
4955 | char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1]; |
---|
4956 | } defdev; |
---|
4957 | static struct { |
---|
4958 | unsigned char length; |
---|
4959 | char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1]; |
---|
4960 | } defdir; |
---|
4961 | static struct { |
---|
4962 | unsigned char length; |
---|
4963 | char pw_shell[UAI$S_DEFCLI+1]; |
---|
4964 | } defcli; |
---|
4965 | static char pw_passwd[UAI$S_PWD+1]; |
---|
4966 | |
---|
4967 | static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd; |
---|
4968 | struct dsc$descriptor_s name_desc; |
---|
4969 | unsigned long int sts; |
---|
4970 | |
---|
4971 | static struct itmlst_3 itmlst[]= { |
---|
4972 | {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner}, |
---|
4973 | {sizeof(uic), UAI$_UIC, &uic, &luic}, |
---|
4974 | {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev}, |
---|
4975 | {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir}, |
---|
4976 | {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli}, |
---|
4977 | {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd}, |
---|
4978 | {0, 0, NULL, NULL}}; |
---|
4979 | |
---|
4980 | name_desc.dsc$w_length= strlen(name); |
---|
4981 | name_desc.dsc$b_dtype= DSC$K_DTYPE_T; |
---|
4982 | name_desc.dsc$b_class= DSC$K_CLASS_S; |
---|
4983 | name_desc.dsc$a_pointer= (char *) name; |
---|
4984 | |
---|
4985 | /* Note that sys$getuai returns many fields as counted strings. */ |
---|
4986 | sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0); |
---|
4987 | if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) { |
---|
4988 | set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES); |
---|
4989 | } |
---|
4990 | else { _ckvmssts(sts); } |
---|
4991 | if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */ |
---|
4992 | |
---|
4993 | if ((int) owner.length < lowner) lowner= (int) owner.length; |
---|
4994 | if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length; |
---|
4995 | if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length; |
---|
4996 | if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length; |
---|
4997 | memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir); |
---|
4998 | owner.pw_gecos[lowner]= '\0'; |
---|
4999 | defdev.pw_dir[ldefdev+ldefdir]= '\0'; |
---|
5000 | defcli.pw_shell[ldefcli]= '\0'; |
---|
5001 | if (valid_uic(uic)) { |
---|
5002 | pwd->pw_uid= uic.uic$l_uic; |
---|
5003 | pwd->pw_gid= uic.uic$v_group; |
---|
5004 | } |
---|
5005 | else |
---|
5006 | Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\""); |
---|
5007 | pwd->pw_passwd= pw_passwd; |
---|
5008 | pwd->pw_gecos= owner.pw_gecos; |
---|
5009 | pwd->pw_dir= defdev.pw_dir; |
---|
5010 | pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1); |
---|
5011 | pwd->pw_shell= defcli.pw_shell; |
---|
5012 | if (pwd->pw_unixdir && pwd->pw_unixdir[0]) { |
---|
5013 | int ldir; |
---|
5014 | ldir= strlen(pwd->pw_unixdir) - 1; |
---|
5015 | if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0'; |
---|
5016 | } |
---|
5017 | else |
---|
5018 | strcpy(pwd->pw_unixdir, pwd->pw_dir); |
---|
5019 | __mystrtolower(pwd->pw_unixdir); |
---|
5020 | return 1; |
---|
5021 | } |
---|
5022 | |
---|
5023 | /* |
---|
5024 | * Get information for a named user. |
---|
5025 | */ |
---|
5026 | /*{{{struct passwd *getpwnam(char *name)*/ |
---|
5027 | struct passwd *my_getpwnam(char *name) |
---|
5028 | { |
---|
5029 | struct dsc$descriptor_s name_desc; |
---|
5030 | union uicdef uic; |
---|
5031 | unsigned long int status, sts; |
---|
5032 | dTHX; |
---|
5033 | |
---|
5034 | __pwdcache = __passwd_empty; |
---|
5035 | if (!fillpasswd(name, &__pwdcache)) { |
---|
5036 | /* We still may be able to determine pw_uid and pw_gid */ |
---|
5037 | name_desc.dsc$w_length= strlen(name); |
---|
5038 | name_desc.dsc$b_dtype= DSC$K_DTYPE_T; |
---|
5039 | name_desc.dsc$b_class= DSC$K_CLASS_S; |
---|
5040 | name_desc.dsc$a_pointer= (char *) name; |
---|
5041 | if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) { |
---|
5042 | __pwdcache.pw_uid= uic.uic$l_uic; |
---|
5043 | __pwdcache.pw_gid= uic.uic$v_group; |
---|
5044 | } |
---|
5045 | else { |
---|
5046 | if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) { |
---|
5047 | set_vaxc_errno(sts); |
---|
5048 | set_errno(sts == RMS$_PRV ? EACCES : EINVAL); |
---|
5049 | return NULL; |
---|
5050 | } |
---|
5051 | else { _ckvmssts(sts); } |
---|
5052 | } |
---|
5053 | } |
---|
5054 | strncpy(__pw_namecache, name, sizeof(__pw_namecache)); |
---|
5055 | __pw_namecache[sizeof __pw_namecache - 1] = '\0'; |
---|
5056 | __pwdcache.pw_name= __pw_namecache; |
---|
5057 | return &__pwdcache; |
---|
5058 | } /* end of my_getpwnam() */ |
---|
5059 | /*}}}*/ |
---|
5060 | |
---|
5061 | /* |
---|
5062 | * Get information for a particular UIC or UID. |
---|
5063 | * Called by my_getpwent with uid=-1 to list all users. |
---|
5064 | */ |
---|
5065 | /*{{{struct passwd *my_getpwuid(Uid_t uid)*/ |
---|
5066 | struct passwd *my_getpwuid(Uid_t uid) |
---|
5067 | { |
---|
5068 | const $DESCRIPTOR(name_desc,__pw_namecache); |
---|
5069 | unsigned short lname; |
---|
5070 | union uicdef uic; |
---|
5071 | unsigned long int status; |
---|
5072 | dTHX; |
---|
5073 | |
---|
5074 | if (uid == (unsigned int) -1) { |
---|
5075 | do { |
---|
5076 | status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt); |
---|
5077 | if (status == SS$_NOSUCHID || status == RMS$_PRV) { |
---|
5078 | set_vaxc_errno(status); |
---|
5079 | set_errno(status == RMS$_PRV ? EACCES : EINVAL); |
---|
5080 | my_endpwent(); |
---|
5081 | return NULL; |
---|
5082 | } |
---|
5083 | else { _ckvmssts(status); } |
---|
5084 | } while (!valid_uic (uic)); |
---|
5085 | } |
---|
5086 | else { |
---|
5087 | uic.uic$l_uic= uid; |
---|
5088 | if (!uic.uic$v_group) |
---|
5089 | uic.uic$v_group= PerlProc_getgid(); |
---|
5090 | if (valid_uic(uic)) |
---|
5091 | status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0); |
---|
5092 | else status = SS$_IVIDENT; |
---|
5093 | if (status == SS$_IVIDENT || status == SS$_NOSUCHID || |
---|
5094 | status == RMS$_PRV) { |
---|
5095 | set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL); |
---|
5096 | return NULL; |
---|
5097 | } |
---|
5098 | else { _ckvmssts(status); } |
---|
5099 | } |
---|
5100 | __pw_namecache[lname]= '\0'; |
---|
5101 | __mystrtolower(__pw_namecache); |
---|
5102 | |
---|
5103 | __pwdcache = __passwd_empty; |
---|
5104 | __pwdcache.pw_name = __pw_namecache; |
---|
5105 | |
---|
5106 | /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege). |
---|
5107 | The identifier's value is usually the UIC, but it doesn't have to be, |
---|
5108 | so if we can, we let fillpasswd update this. */ |
---|
5109 | __pwdcache.pw_uid = uic.uic$l_uic; |
---|
5110 | __pwdcache.pw_gid = uic.uic$v_group; |
---|
5111 | |
---|
5112 | fillpasswd(__pw_namecache, &__pwdcache); |
---|
5113 | return &__pwdcache; |
---|
5114 | |
---|
5115 | } /* end of my_getpwuid() */ |
---|
5116 | /*}}}*/ |
---|
5117 | |
---|
5118 | /* |
---|
5119 | * Get information for next user. |
---|
5120 | */ |
---|
5121 | /*{{{struct passwd *my_getpwent()*/ |
---|
5122 | struct passwd *my_getpwent() |
---|
5123 | { |
---|
5124 | return (my_getpwuid((unsigned int) -1)); |
---|
5125 | } |
---|
5126 | /*}}}*/ |
---|
5127 | |
---|
5128 | /* |
---|
5129 | * Finish searching rights database for users. |
---|
5130 | */ |
---|
5131 | /*{{{void my_endpwent()*/ |
---|
5132 | void my_endpwent() |
---|
5133 | { |
---|
5134 | dTHX; |
---|
5135 | if (contxt) { |
---|
5136 | _ckvmssts(sys$finish_rdb(&contxt)); |
---|
5137 | contxt= 0; |
---|
5138 | } |
---|
5139 | } |
---|
5140 | /*}}}*/ |
---|
5141 | |
---|
5142 | #ifdef HOMEGROWN_POSIX_SIGNALS |
---|
5143 | /* Signal handling routines, pulled into the core from POSIX.xs. |
---|
5144 | * |
---|
5145 | * We need these for threads, so they've been rolled into the core, |
---|
5146 | * rather than left in POSIX.xs. |
---|
5147 | * |
---|
5148 | * (DRS, Oct 23, 1997) |
---|
5149 | */ |
---|
5150 | |
---|
5151 | /* sigset_t is atomic under VMS, so these routines are easy */ |
---|
5152 | /*{{{int my_sigemptyset(sigset_t *) */ |
---|
5153 | int my_sigemptyset(sigset_t *set) { |
---|
5154 | if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; } |
---|
5155 | *set = 0; return 0; |
---|
5156 | } |
---|
5157 | /*}}}*/ |
---|
5158 | |
---|
5159 | |
---|
5160 | /*{{{int my_sigfillset(sigset_t *)*/ |
---|
5161 | int my_sigfillset(sigset_t *set) { |
---|
5162 | int i; |
---|
5163 | if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; } |
---|
5164 | for (i = 0; i < NSIG; i++) *set |= (1 << i); |
---|
5165 | return 0; |
---|
5166 | } |
---|
5167 | /*}}}*/ |
---|
5168 | |
---|
5169 | |
---|
5170 | /*{{{int my_sigaddset(sigset_t *set, int sig)*/ |
---|
5171 | int my_sigaddset(sigset_t *set, int sig) { |
---|
5172 | if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; } |
---|
5173 | if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; } |
---|
5174 | *set |= (1 << (sig - 1)); |
---|
5175 | return 0; |
---|
5176 | } |
---|
5177 | /*}}}*/ |
---|
5178 | |
---|
5179 | |
---|
5180 | /*{{{int my_sigdelset(sigset_t *set, int sig)*/ |
---|
5181 | int my_sigdelset(sigset_t *set, int sig) { |
---|
5182 | if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; } |
---|
5183 | if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; } |
---|
5184 | *set &= ~(1 << (sig - 1)); |
---|
5185 | return 0; |
---|
5186 | } |
---|
5187 | /*}}}*/ |
---|
5188 | |
---|
5189 | |
---|
5190 | /*{{{int my_sigismember(sigset_t *set, int sig)*/ |
---|
5191 | int my_sigismember(sigset_t *set, int sig) { |
---|
5192 | if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; } |
---|
5193 | if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; } |
---|
5194 | *set & (1 << (sig - 1)); |
---|
5195 | } |
---|
5196 | /*}}}*/ |
---|
5197 | |
---|
5198 | |
---|
5199 | /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/ |
---|
5200 | int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) { |
---|
5201 | sigset_t tempmask; |
---|
5202 | |
---|
5203 | /* If set and oset are both null, then things are badly wrong. Bail out. */ |
---|
5204 | if ((oset == NULL) && (set == NULL)) { |
---|
5205 | set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO); |
---|
5206 | return -1; |
---|
5207 | } |
---|
5208 | |
---|
5209 | /* If set's null, then we're just handling a fetch. */ |
---|
5210 | if (set == NULL) { |
---|
5211 | tempmask = sigblock(0); |
---|
5212 | } |
---|
5213 | else { |
---|
5214 | switch (how) { |
---|
5215 | case SIG_SETMASK: |
---|
5216 | tempmask = sigsetmask(*set); |
---|
5217 | break; |
---|
5218 | case SIG_BLOCK: |
---|
5219 | tempmask = sigblock(*set); |
---|
5220 | break; |
---|
5221 | case SIG_UNBLOCK: |
---|
5222 | tempmask = sigblock(0); |
---|
5223 | sigsetmask(*oset & ~tempmask); |
---|
5224 | break; |
---|
5225 | default: |
---|
5226 | set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); |
---|
5227 | return -1; |
---|
5228 | } |
---|
5229 | } |
---|
5230 | |
---|
5231 | /* Did they pass us an oset? If so, stick our holding mask into it */ |
---|
5232 | if (oset) |
---|
5233 | *oset = tempmask; |
---|
5234 | |
---|
5235 | return 0; |
---|
5236 | } |
---|
5237 | /*}}}*/ |
---|
5238 | #endif /* HOMEGROWN_POSIX_SIGNALS */ |
---|
5239 | |
---|
5240 | |
---|
5241 | /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(), |
---|
5242 | * my_utime(), and flex_stat(), all of which operate on UTC unless |
---|
5243 | * VMSISH_TIMES is true. |
---|
5244 | */ |
---|
5245 | /* method used to handle UTC conversions: |
---|
5246 | * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction |
---|
5247 | */ |
---|
5248 | static int gmtime_emulation_type; |
---|
5249 | /* number of secs to add to UTC POSIX-style time to get local time */ |
---|
5250 | static long int utc_offset_secs; |
---|
5251 | |
---|
5252 | /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc. |
---|
5253 | * in vmsish.h. #undef them here so we can call the CRTL routines |
---|
5254 | * directly. |
---|
5255 | */ |
---|
5256 | #undef gmtime |
---|
5257 | #undef localtime |
---|
5258 | #undef time |
---|
5259 | |
---|
5260 | |
---|
5261 | /* |
---|
5262 | * DEC C previous to 6.0 corrupts the behavior of the /prefix |
---|
5263 | * qualifier with the extern prefix pragma. This provisional |
---|
5264 | * hack circumvents this prefix pragma problem in previous |
---|
5265 | * precompilers. |
---|
5266 | */ |
---|
5267 | #if defined(__VMS_VER) && __VMS_VER >= 70000000 |
---|
5268 | # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000) |
---|
5269 | # pragma __extern_prefix save |
---|
5270 | # pragma __extern_prefix "" /* set to empty to prevent prefixing */ |
---|
5271 | # define gmtime decc$__utctz_gmtime |
---|
5272 | # define localtime decc$__utctz_localtime |
---|
5273 | # define time decc$__utc_time |
---|
5274 | # pragma __extern_prefix restore |
---|
5275 | |
---|
5276 | struct tm *gmtime(), *localtime(); |
---|
5277 | |
---|
5278 | # endif |
---|
5279 | #endif |
---|
5280 | |
---|
5281 | |
---|
5282 | static time_t toutc_dst(time_t loc) { |
---|
5283 | struct tm *rsltmp; |
---|
5284 | |
---|
5285 | if ((rsltmp = localtime(&loc)) == NULL) return -1; |
---|
5286 | loc -= utc_offset_secs; |
---|
5287 | if (rsltmp->tm_isdst) loc -= 3600; |
---|
5288 | return loc; |
---|
5289 | } |
---|
5290 | #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \ |
---|
5291 | ((gmtime_emulation_type || my_time(NULL)), \ |
---|
5292 | (gmtime_emulation_type == 1 ? toutc_dst(secs) : \ |
---|
5293 | ((secs) - utc_offset_secs)))) |
---|
5294 | |
---|
5295 | static time_t toloc_dst(time_t utc) { |
---|
5296 | struct tm *rsltmp; |
---|
5297 | |
---|
5298 | utc += utc_offset_secs; |
---|
5299 | if ((rsltmp = localtime(&utc)) == NULL) return -1; |
---|
5300 | if (rsltmp->tm_isdst) utc += 3600; |
---|
5301 | return utc; |
---|
5302 | } |
---|
5303 | #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \ |
---|
5304 | ((gmtime_emulation_type || my_time(NULL)), \ |
---|
5305 | (gmtime_emulation_type == 1 ? toloc_dst(secs) : \ |
---|
5306 | ((secs) + utc_offset_secs)))) |
---|
5307 | |
---|
5308 | #ifndef RTL_USES_UTC |
---|
5309 | /* |
---|
5310 | |
---|
5311 | ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical |
---|
5312 | DST starts on 1st sun of april at 02:00 std time |
---|
5313 | ends on last sun of october at 02:00 dst time |
---|
5314 | see the UCX management command reference, SET CONFIG TIMEZONE |
---|
5315 | for formatting info. |
---|
5316 | |
---|
5317 | No, it's not as general as it should be, but then again, NOTHING |
---|
5318 | will handle UK times in a sensible way. |
---|
5319 | */ |
---|
5320 | |
---|
5321 | |
---|
5322 | /* |
---|
5323 | parse the DST start/end info: |
---|
5324 | (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss] |
---|
5325 | */ |
---|
5326 | |
---|
5327 | static char * |
---|
5328 | tz_parse_startend(char *s, struct tm *w, int *past) |
---|
5329 | { |
---|
5330 | int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31}; |
---|
5331 | int ly, dozjd, d, m, n, hour, min, sec, j, k; |
---|
5332 | time_t g; |
---|
5333 | |
---|
5334 | if (!s) return 0; |
---|
5335 | if (!w) return 0; |
---|
5336 | if (!past) return 0; |
---|
5337 | |
---|
5338 | ly = 0; |
---|
5339 | if (w->tm_year % 4 == 0) ly = 1; |
---|
5340 | if (w->tm_year % 100 == 0) ly = 0; |
---|
5341 | if (w->tm_year+1900 % 400 == 0) ly = 1; |
---|
5342 | if (ly) dinm[1]++; |
---|
5343 | |
---|
5344 | dozjd = isdigit(*s); |
---|
5345 | if (*s == 'J' || *s == 'j' || dozjd) { |
---|
5346 | if (!dozjd && !isdigit(*++s)) return 0; |
---|
5347 | d = *s++ - '0'; |
---|
5348 | if (isdigit(*s)) { |
---|
5349 | d = d*10 + *s++ - '0'; |
---|
5350 | if (isdigit(*s)) { |
---|
5351 | d = d*10 + *s++ - '0'; |
---|
5352 | } |
---|
5353 | } |
---|
5354 | if (d == 0) return 0; |
---|
5355 | if (d > 366) return 0; |
---|
5356 | d--; |
---|
5357 | if (!dozjd && d > 58 && ly) d++; /* after 28 feb */ |
---|
5358 | g = d * 86400; |
---|
5359 | dozjd = 1; |
---|
5360 | } else if (*s == 'M' || *s == 'm') { |
---|
5361 | if (!isdigit(*++s)) return 0; |
---|
5362 | m = *s++ - '0'; |
---|
5363 | if (isdigit(*s)) m = 10*m + *s++ - '0'; |
---|
5364 | if (*s != '.') return 0; |
---|
5365 | if (!isdigit(*++s)) return 0; |
---|
5366 | n = *s++ - '0'; |
---|
5367 | if (n < 1 || n > 5) return 0; |
---|
5368 | if (*s != '.') return 0; |
---|
5369 | if (!isdigit(*++s)) return 0; |
---|
5370 | d = *s++ - '0'; |
---|
5371 | if (d > 6) return 0; |
---|
5372 | } |
---|
5373 | |
---|
5374 | if (*s == '/') { |
---|
5375 | if (!isdigit(*++s)) return 0; |
---|
5376 | hour = *s++ - '0'; |
---|
5377 | if (isdigit(*s)) hour = 10*hour + *s++ - '0'; |
---|
5378 | if (*s == ':') { |
---|
5379 | if (!isdigit(*++s)) return 0; |
---|
5380 | min = *s++ - '0'; |
---|
5381 | if (isdigit(*s)) min = 10*min + *s++ - '0'; |
---|
5382 | if (*s == ':') { |
---|
5383 | if (!isdigit(*++s)) return 0; |
---|
5384 | sec = *s++ - '0'; |
---|
5385 | if (isdigit(*s)) sec = 10*sec + *s++ - '0'; |
---|
5386 | } |
---|
5387 | } |
---|
5388 | } else { |
---|
5389 | hour = 2; |
---|
5390 | min = 0; |
---|
5391 | sec = 0; |
---|
5392 | } |
---|
5393 | |
---|
5394 | if (dozjd) { |
---|
5395 | if (w->tm_yday < d) goto before; |
---|
5396 | if (w->tm_yday > d) goto after; |
---|
5397 | } else { |
---|
5398 | if (w->tm_mon+1 < m) goto before; |
---|
5399 | if (w->tm_mon+1 > m) goto after; |
---|
5400 | |
---|
5401 | j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */ |
---|
5402 | k = d - j; /* mday of first d */ |
---|
5403 | if (k <= 0) k += 7; |
---|
5404 | k += 7 * ((n>4?4:n)-1); /* mday of n'th d */ |
---|
5405 | if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7; |
---|
5406 | if (w->tm_mday < k) goto before; |
---|
5407 | if (w->tm_mday > k) goto after; |
---|
5408 | } |
---|
5409 | |
---|
5410 | if (w->tm_hour < hour) goto before; |
---|
5411 | if (w->tm_hour > hour) goto after; |
---|
5412 | if (w->tm_min < min) goto before; |
---|
5413 | if (w->tm_min > min) goto after; |
---|
5414 | if (w->tm_sec < sec) goto before; |
---|
5415 | goto after; |
---|
5416 | |
---|
5417 | before: |
---|
5418 | *past = 0; |
---|
5419 | return s; |
---|
5420 | after: |
---|
5421 | *past = 1; |
---|
5422 | return s; |
---|
5423 | } |
---|
5424 | |
---|
5425 | |
---|
5426 | |
---|
5427 | |
---|
5428 | /* parse the offset: (+|-)hh[:mm[:ss]] */ |
---|
5429 | |
---|
5430 | static char * |
---|
5431 | tz_parse_offset(char *s, int *offset) |
---|
5432 | { |
---|
5433 | int hour = 0, min = 0, sec = 0; |
---|
5434 | int neg = 0; |
---|
5435 | if (!s) return 0; |
---|
5436 | if (!offset) return 0; |
---|
5437 | |
---|
5438 | if (*s == '-') {neg++; s++;} |
---|
5439 | if (*s == '+') s++; |
---|
5440 | if (!isdigit(*s)) return 0; |
---|
5441 | hour = *s++ - '0'; |
---|
5442 | if (isdigit(*s)) hour = hour*10+(*s++ - '0'); |
---|
5443 | if (hour > 24) return 0; |
---|
5444 | if (*s == ':') { |
---|
5445 | if (!isdigit(*++s)) return 0; |
---|
5446 | min = *s++ - '0'; |
---|
5447 | if (isdigit(*s)) min = min*10 + (*s++ - '0'); |
---|
5448 | if (min > 59) return 0; |
---|
5449 | if (*s == ':') { |
---|
5450 | if (!isdigit(*++s)) return 0; |
---|
5451 | sec = *s++ - '0'; |
---|
5452 | if (isdigit(*s)) sec = sec*10 + (*s++ - '0'); |
---|
5453 | if (sec > 59) return 0; |
---|
5454 | } |
---|
5455 | } |
---|
5456 | |
---|
5457 | *offset = (hour*60+min)*60 + sec; |
---|
5458 | if (neg) *offset = -*offset; |
---|
5459 | return s; |
---|
5460 | } |
---|
5461 | |
---|
5462 | /* |
---|
5463 | input time is w, whatever type of time the CRTL localtime() uses. |
---|
5464 | sets dst, the zone, and the gmtoff (seconds) |
---|
5465 | |
---|
5466 | caches the value of TZ and UCX$TZ env variables; note that |
---|
5467 | my_setenv looks for these and sets a flag if they're changed |
---|
5468 | for efficiency. |
---|
5469 | |
---|
5470 | We have to watch out for the "australian" case (dst starts in |
---|
5471 | october, ends in april)...flagged by "reverse" and checked by |
---|
5472 | scanning through the months of the previous year. |
---|
5473 | |
---|
5474 | */ |
---|
5475 | |
---|
5476 | static int |
---|
5477 | tz_parse(time_t *w, int *dst, char *zone, int *gmtoff) |
---|
5478 | { |
---|
5479 | time_t when; |
---|
5480 | struct tm *w2; |
---|
5481 | char *s,*s2; |
---|
5482 | char *dstzone, *tz, *s_start, *s_end; |
---|
5483 | int std_off, dst_off, isdst; |
---|
5484 | int y, dststart, dstend; |
---|
5485 | static char envtz[1025]; /* longer than any logical, symbol, ... */ |
---|
5486 | static char ucxtz[1025]; |
---|
5487 | static char reversed = 0; |
---|
5488 | |
---|
5489 | if (!w) return 0; |
---|
5490 | |
---|
5491 | if (tz_updated) { |
---|
5492 | tz_updated = 0; |
---|
5493 | reversed = -1; /* flag need to check */ |
---|
5494 | envtz[0] = ucxtz[0] = '\0'; |
---|
5495 | tz = my_getenv("TZ",0); |
---|
5496 | if (tz) strcpy(envtz, tz); |
---|
5497 | tz = my_getenv("UCX$TZ",0); |
---|
5498 | if (tz) strcpy(ucxtz, tz); |
---|
5499 | if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */ |
---|
5500 | } |
---|
5501 | tz = envtz; |
---|
5502 | if (!*tz) tz = ucxtz; |
---|
5503 | |
---|
5504 | s = tz; |
---|
5505 | while (isalpha(*s)) s++; |
---|
5506 | s = tz_parse_offset(s, &std_off); |
---|
5507 | if (!s) return 0; |
---|
5508 | if (!*s) { /* no DST, hurray we're done! */ |
---|
5509 | isdst = 0; |
---|
5510 | goto done; |
---|
5511 | } |
---|
5512 | |
---|
5513 | dstzone = s; |
---|
5514 | while (isalpha(*s)) s++; |
---|
5515 | s2 = tz_parse_offset(s, &dst_off); |
---|
5516 | if (s2) { |
---|
5517 | s = s2; |
---|
5518 | } else { |
---|
5519 | dst_off = std_off - 3600; |
---|
5520 | } |
---|
5521 | |
---|
5522 | if (!*s) { /* default dst start/end?? */ |
---|
5523 | if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */ |
---|
5524 | s = strchr(ucxtz,','); |
---|
5525 | } |
---|
5526 | if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */ |
---|
5527 | } |
---|
5528 | if (*s != ',') return 0; |
---|
5529 | |
---|
5530 | when = *w; |
---|
5531 | when = _toutc(when); /* convert to utc */ |
---|
5532 | when = when - std_off; /* convert to pseudolocal time*/ |
---|
5533 | |
---|
5534 | w2 = localtime(&when); |
---|
5535 | y = w2->tm_year; |
---|
5536 | s_start = s+1; |
---|
5537 | s = tz_parse_startend(s_start,w2,&dststart); |
---|
5538 | if (!s) return 0; |
---|
5539 | if (*s != ',') return 0; |
---|
5540 | |
---|
5541 | when = *w; |
---|
5542 | when = _toutc(when); /* convert to utc */ |
---|
5543 | when = when - dst_off; /* convert to pseudolocal time*/ |
---|
5544 | w2 = localtime(&when); |
---|
5545 | if (w2->tm_year != y) { /* spans a year, just check one time */ |
---|
5546 | when += dst_off - std_off; |
---|
5547 | w2 = localtime(&when); |
---|
5548 | } |
---|
5549 | s_end = s+1; |
---|
5550 | s = tz_parse_startend(s_end,w2,&dstend); |
---|
5551 | if (!s) return 0; |
---|
5552 | |
---|
5553 | if (reversed == -1) { /* need to check if start later than end */ |
---|
5554 | int j, ds, de; |
---|
5555 | |
---|
5556 | when = *w; |
---|
5557 | if (when < 2*365*86400) { |
---|
5558 | when += 2*365*86400; |
---|
5559 | } else { |
---|
5560 | when -= 365*86400; |
---|
5561 | } |
---|
5562 | w2 =localtime(&when); |
---|
5563 | when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */ |
---|
5564 | |
---|
5565 | for (j = 0; j < 12; j++) { |
---|
5566 | w2 =localtime(&when); |
---|
5567 | (void) tz_parse_startend(s_start,w2,&ds); |
---|
5568 | (void) tz_parse_startend(s_end,w2,&de); |
---|
5569 | if (ds != de) break; |
---|
5570 | when += 30*86400; |
---|
5571 | } |
---|
5572 | reversed = 0; |
---|
5573 | if (de && !ds) reversed = 1; |
---|
5574 | } |
---|
5575 | |
---|
5576 | isdst = dststart && !dstend; |
---|
5577 | if (reversed) isdst = dststart || !dstend; |
---|
5578 | |
---|
5579 | done: |
---|
5580 | if (dst) *dst = isdst; |
---|
5581 | if (gmtoff) *gmtoff = isdst ? dst_off : std_off; |
---|
5582 | if (isdst) tz = dstzone; |
---|
5583 | if (zone) { |
---|
5584 | while(isalpha(*tz)) *zone++ = *tz++; |
---|
5585 | *zone = '\0'; |
---|
5586 | } |
---|
5587 | return 1; |
---|
5588 | } |
---|
5589 | |
---|
5590 | #endif /* !RTL_USES_UTC */ |
---|
5591 | |
---|
5592 | /* my_time(), my_localtime(), my_gmtime() |
---|
5593 | * By default traffic in UTC time values, using CRTL gmtime() or |
---|
5594 | * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone. |
---|
5595 | * Note: We need to use these functions even when the CRTL has working |
---|
5596 | * UTC support, since they also handle C<use vmsish qw(times);> |
---|
5597 | * |
---|
5598 | * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu> |
---|
5599 | * Modified by Charles Bailey <bailey@newman.upenn.edu> |
---|
5600 | */ |
---|
5601 | |
---|
5602 | /*{{{time_t my_time(time_t *timep)*/ |
---|
5603 | time_t my_time(time_t *timep) |
---|
5604 | { |
---|
5605 | dTHX; |
---|
5606 | time_t when; |
---|
5607 | struct tm *tm_p; |
---|
5608 | |
---|
5609 | if (gmtime_emulation_type == 0) { |
---|
5610 | int dstnow; |
---|
5611 | time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */ |
---|
5612 | /* results of calls to gmtime() and localtime() */ |
---|
5613 | /* for same &base */ |
---|
5614 | |
---|
5615 | gmtime_emulation_type++; |
---|
5616 | if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */ |
---|
5617 | char off[LNM$C_NAMLENGTH+1];; |
---|
5618 | |
---|
5619 | gmtime_emulation_type++; |
---|
5620 | if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) { |
---|
5621 | gmtime_emulation_type++; |
---|
5622 | utc_offset_secs = 0; |
---|
5623 | Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC"); |
---|
5624 | } |
---|
5625 | else { utc_offset_secs = atol(off); } |
---|
5626 | } |
---|
5627 | else { /* We've got a working gmtime() */ |
---|
5628 | struct tm gmt, local; |
---|
5629 | |
---|
5630 | gmt = *tm_p; |
---|
5631 | tm_p = localtime(&base); |
---|
5632 | local = *tm_p; |
---|
5633 | utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400; |
---|
5634 | utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600; |
---|
5635 | utc_offset_secs += (local.tm_min - gmt.tm_min) * 60; |
---|
5636 | utc_offset_secs += (local.tm_sec - gmt.tm_sec); |
---|
5637 | } |
---|
5638 | } |
---|
5639 | |
---|
5640 | when = time(NULL); |
---|
5641 | # ifdef VMSISH_TIME |
---|
5642 | # ifdef RTL_USES_UTC |
---|
5643 | if (VMSISH_TIME) when = _toloc(when); |
---|
5644 | # else |
---|
5645 | if (!VMSISH_TIME) when = _toutc(when); |
---|
5646 | # endif |
---|
5647 | # endif |
---|
5648 | if (timep != NULL) *timep = when; |
---|
5649 | return when; |
---|
5650 | |
---|
5651 | } /* end of my_time() */ |
---|
5652 | /*}}}*/ |
---|
5653 | |
---|
5654 | |
---|
5655 | /*{{{struct tm *my_gmtime(const time_t *timep)*/ |
---|
5656 | struct tm * |
---|
5657 | my_gmtime(const time_t *timep) |
---|
5658 | { |
---|
5659 | dTHX; |
---|
5660 | char *p; |
---|
5661 | time_t when; |
---|
5662 | struct tm *rsltmp; |
---|
5663 | |
---|
5664 | if (timep == NULL) { |
---|
5665 | set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); |
---|
5666 | return NULL; |
---|
5667 | } |
---|
5668 | if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */ |
---|
5669 | |
---|
5670 | when = *timep; |
---|
5671 | # ifdef VMSISH_TIME |
---|
5672 | if (VMSISH_TIME) when = _toutc(when); /* Input was local time */ |
---|
5673 | # endif |
---|
5674 | # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */ |
---|
5675 | return gmtime(&when); |
---|
5676 | # else |
---|
5677 | /* CRTL localtime() wants local time as input, so does no tz correction */ |
---|
5678 | rsltmp = localtime(&when); |
---|
5679 | if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */ |
---|
5680 | return rsltmp; |
---|
5681 | #endif |
---|
5682 | } /* end of my_gmtime() */ |
---|
5683 | /*}}}*/ |
---|
5684 | |
---|
5685 | |
---|
5686 | /*{{{struct tm *my_localtime(const time_t *timep)*/ |
---|
5687 | struct tm * |
---|
5688 | my_localtime(const time_t *timep) |
---|
5689 | { |
---|
5690 | dTHX; |
---|
5691 | time_t when, whenutc; |
---|
5692 | struct tm *rsltmp; |
---|
5693 | int dst, offset; |
---|
5694 | |
---|
5695 | if (timep == NULL) { |
---|
5696 | set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); |
---|
5697 | return NULL; |
---|
5698 | } |
---|
5699 | if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */ |
---|
5700 | if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */ |
---|
5701 | |
---|
5702 | when = *timep; |
---|
5703 | # ifdef RTL_USES_UTC |
---|
5704 | # ifdef VMSISH_TIME |
---|
5705 | if (VMSISH_TIME) when = _toutc(when); |
---|
5706 | # endif |
---|
5707 | /* CRTL localtime() wants UTC as input, does tz correction itself */ |
---|
5708 | return localtime(&when); |
---|
5709 | |
---|
5710 | # else /* !RTL_USES_UTC */ |
---|
5711 | whenutc = when; |
---|
5712 | # ifdef VMSISH_TIME |
---|
5713 | if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */ |
---|
5714 | if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */ |
---|
5715 | # endif |
---|
5716 | dst = -1; |
---|
5717 | #ifndef RTL_USES_UTC |
---|
5718 | if (tz_parse(&when, &dst, 0, &offset)) { /* truelocal determines DST*/ |
---|
5719 | when = whenutc - offset; /* pseudolocal time*/ |
---|
5720 | } |
---|
5721 | # endif |
---|
5722 | /* CRTL localtime() wants local time as input, so does no tz correction */ |
---|
5723 | rsltmp = localtime(&when); |
---|
5724 | if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst; |
---|
5725 | return rsltmp; |
---|
5726 | # endif |
---|
5727 | |
---|
5728 | } /* end of my_localtime() */ |
---|
5729 | /*}}}*/ |
---|
5730 | |
---|
5731 | /* Reset definitions for later calls */ |
---|
5732 | #define gmtime(t) my_gmtime(t) |
---|
5733 | #define localtime(t) my_localtime(t) |
---|
5734 | #define time(t) my_time(t) |
---|
5735 | |
---|
5736 | |
---|
5737 | /* my_utime - update modification time of a file |
---|
5738 | * calling sequence is identical to POSIX utime(), but under |
---|
5739 | * VMS only the modification time is changed; ODS-2 does not |
---|
5740 | * maintain access times. Restrictions differ from the POSIX |
---|
5741 | * definition in that the time can be changed as long as the |
---|
5742 | * caller has permission to execute the necessary IO$_MODIFY $QIO; |
---|
5743 | * no separate checks are made to insure that the caller is the |
---|
5744 | * owner of the file or has special privs enabled. |
---|
5745 | * Code here is based on Joe Meadows' FILE utility. |
---|
5746 | */ |
---|
5747 | |
---|
5748 | /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00) |
---|
5749 | * to VMS epoch (01-JAN-1858 00:00:00.00) |
---|
5750 | * in 100 ns intervals. |
---|
5751 | */ |
---|
5752 | static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 }; |
---|
5753 | |
---|
5754 | /*{{{int my_utime(char *path, struct utimbuf *utimes)*/ |
---|
5755 | int my_utime(char *file, struct utimbuf *utimes) |
---|
5756 | { |
---|
5757 | dTHX; |
---|
5758 | register int i; |
---|
5759 | long int bintime[2], len = 2, lowbit, unixtime, |
---|
5760 | secscale = 10000000; /* seconds --> 100 ns intervals */ |
---|
5761 | unsigned long int chan, iosb[2], retsts; |
---|
5762 | char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS]; |
---|
5763 | struct FAB myfab = cc$rms_fab; |
---|
5764 | struct NAM mynam = cc$rms_nam; |
---|
5765 | #if defined (__DECC) && defined (__VAX) |
---|
5766 | /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr, |
---|
5767 | * at least through VMS V6.1, which causes a type-conversion warning. |
---|
5768 | */ |
---|
5769 | # pragma message save |
---|
5770 | # pragma message disable cvtdiftypes |
---|
5771 | #endif |
---|
5772 | struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}}; |
---|
5773 | struct fibdef myfib; |
---|
5774 | #if defined (__DECC) && defined (__VAX) |
---|
5775 | /* This should be right after the declaration of myatr, but due |
---|
5776 | * to a bug in VAX DEC C, this takes effect a statement early. |
---|
5777 | */ |
---|
5778 | # pragma message restore |
---|
5779 | #endif |
---|
5780 | struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib}, |
---|
5781 | devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0}, |
---|
5782 | fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0}; |
---|
5783 | |
---|
5784 | if (file == NULL || *file == '\0') { |
---|
5785 | set_errno(ENOENT); |
---|
5786 | set_vaxc_errno(LIB$_INVARG); |
---|
5787 | return -1; |
---|
5788 | } |
---|
5789 | if (do_tovmsspec(file,vmsspec,0) == NULL) return -1; |
---|
5790 | |
---|
5791 | if (utimes != NULL) { |
---|
5792 | /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00) |
---|
5793 | * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00). |
---|
5794 | * Since time_t is unsigned long int, and lib$emul takes a signed long int |
---|
5795 | * as input, we force the sign bit to be clear by shifting unixtime right |
---|
5796 | * one bit, then multiplying by an extra factor of 2 in lib$emul(). |
---|
5797 | */ |
---|
5798 | lowbit = (utimes->modtime & 1) ? secscale : 0; |
---|
5799 | unixtime = (long int) utimes->modtime; |
---|
5800 | # ifdef VMSISH_TIME |
---|
5801 | /* If input was UTC; convert to local for sys svc */ |
---|
5802 | if (!VMSISH_TIME) unixtime = _toloc(unixtime); |
---|
5803 | # endif |
---|
5804 | unixtime >>= 1; secscale <<= 1; |
---|
5805 | retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime); |
---|
5806 | if (!(retsts & 1)) { |
---|
5807 | set_errno(EVMSERR); |
---|
5808 | set_vaxc_errno(retsts); |
---|
5809 | return -1; |
---|
5810 | } |
---|
5811 | retsts = lib$addx(bintime,utime_baseadjust,bintime,&len); |
---|
5812 | if (!(retsts & 1)) { |
---|
5813 | set_errno(EVMSERR); |
---|
5814 | set_vaxc_errno(retsts); |
---|
5815 | return -1; |
---|
5816 | } |
---|
5817 | } |
---|
5818 | else { |
---|
5819 | /* Just get the current time in VMS format directly */ |
---|
5820 | retsts = sys$gettim(bintime); |
---|
5821 | if (!(retsts & 1)) { |
---|
5822 | set_errno(EVMSERR); |
---|
5823 | set_vaxc_errno(retsts); |
---|
5824 | return -1; |
---|
5825 | } |
---|
5826 | } |
---|
5827 | |
---|
5828 | myfab.fab$l_fna = vmsspec; |
---|
5829 | myfab.fab$b_fns = (unsigned char) strlen(vmsspec); |
---|
5830 | myfab.fab$l_nam = &mynam; |
---|
5831 | mynam.nam$l_esa = esa; |
---|
5832 | mynam.nam$b_ess = (unsigned char) sizeof esa; |
---|
5833 | mynam.nam$l_rsa = rsa; |
---|
5834 | mynam.nam$b_rss = (unsigned char) sizeof rsa; |
---|
5835 | |
---|
5836 | /* Look for the file to be affected, letting RMS parse the file |
---|
5837 | * specification for us as well. I have set errno using only |
---|
5838 | * values documented in the utime() man page for VMS POSIX. |
---|
5839 | */ |
---|
5840 | retsts = sys$parse(&myfab,0,0); |
---|
5841 | if (!(retsts & 1)) { |
---|
5842 | set_vaxc_errno(retsts); |
---|
5843 | if (retsts == RMS$_PRV) set_errno(EACCES); |
---|
5844 | else if (retsts == RMS$_DIR) set_errno(ENOTDIR); |
---|
5845 | else set_errno(EVMSERR); |
---|
5846 | return -1; |
---|
5847 | } |
---|
5848 | retsts = sys$search(&myfab,0,0); |
---|
5849 | if (!(retsts & 1)) { |
---|
5850 | mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL; |
---|
5851 | myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); |
---|
5852 | set_vaxc_errno(retsts); |
---|
5853 | if (retsts == RMS$_PRV) set_errno(EACCES); |
---|
5854 | else if (retsts == RMS$_FNF) set_errno(ENOENT); |
---|
5855 | else set_errno(EVMSERR); |
---|
5856 | return -1; |
---|
5857 | } |
---|
5858 | |
---|
5859 | devdsc.dsc$w_length = mynam.nam$b_dev; |
---|
5860 | devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev; |
---|
5861 | |
---|
5862 | retsts = sys$assign(&devdsc,&chan,0,0); |
---|
5863 | if (!(retsts & 1)) { |
---|
5864 | mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL; |
---|
5865 | myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); |
---|
5866 | set_vaxc_errno(retsts); |
---|
5867 | if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR); |
---|
5868 | else if (retsts == SS$_NOPRIV) set_errno(EACCES); |
---|
5869 | else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR); |
---|
5870 | else set_errno(EVMSERR); |
---|
5871 | return -1; |
---|
5872 | } |
---|
5873 | |
---|
5874 | fnmdsc.dsc$a_pointer = mynam.nam$l_name; |
---|
5875 | fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver; |
---|
5876 | |
---|
5877 | memset((void *) &myfib, 0, sizeof myfib); |
---|
5878 | #if defined(__DECC) || defined(__DECCXX) |
---|
5879 | for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i]; |
---|
5880 | for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i]; |
---|
5881 | /* This prevents the revision time of the file being reset to the current |
---|
5882 | * time as a result of our IO$_MODIFY $QIO. */ |
---|
5883 | myfib.fib$l_acctl = FIB$M_NORECORD; |
---|
5884 | #else |
---|
5885 | for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i]; |
---|
5886 | for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i]; |
---|
5887 | myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD; |
---|
5888 | #endif |
---|
5889 | retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0); |
---|
5890 | mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL; |
---|
5891 | myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); |
---|
5892 | _ckvmssts(sys$dassgn(chan)); |
---|
5893 | if (retsts & 1) retsts = iosb[0]; |
---|
5894 | if (!(retsts & 1)) { |
---|
5895 | set_vaxc_errno(retsts); |
---|
5896 | if (retsts == SS$_NOPRIV) set_errno(EACCES); |
---|
5897 | else set_errno(EVMSERR); |
---|
5898 | return -1; |
---|
5899 | } |
---|
5900 | |
---|
5901 | return 0; |
---|
5902 | } /* end of my_utime() */ |
---|
5903 | /*}}}*/ |
---|
5904 | |
---|
5905 | /* |
---|
5906 | * flex_stat, flex_fstat |
---|
5907 | * basic stat, but gets it right when asked to stat |
---|
5908 | * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3) |
---|
5909 | */ |
---|
5910 | |
---|
5911 | /* encode_dev packs a VMS device name string into an integer to allow |
---|
5912 | * simple comparisons. This can be used, for example, to check whether two |
---|
5913 | * files are located on the same device, by comparing their encoded device |
---|
5914 | * names. Even a string comparison would not do, because stat() reuses the |
---|
5915 | * device name buffer for each call; so without encode_dev, it would be |
---|
5916 | * necessary to save the buffer and use strcmp (this would mean a number of |
---|
5917 | * changes to the standard Perl code, to say nothing of what a Perl script |
---|
5918 | * would have to do. |
---|
5919 | * |
---|
5920 | * The device lock id, if it exists, should be unique (unless perhaps compared |
---|
5921 | * with lock ids transferred from other nodes). We have a lock id if the disk is |
---|
5922 | * mounted cluster-wide, which is when we tend to get long (host-qualified) |
---|
5923 | * device names. Thus we use the lock id in preference, and only if that isn't |
---|
5924 | * available, do we try to pack the device name into an integer (flagged by |
---|
5925 | * the sign bit (LOCKID_MASK) being set). |
---|
5926 | * |
---|
5927 | * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device |
---|
5928 | * name and its encoded form, but it seems very unlikely that we will find |
---|
5929 | * two files on different disks that share the same encoded device names, |
---|
5930 | * and even more remote that they will share the same file id (if the test |
---|
5931 | * is to check for the same file). |
---|
5932 | * |
---|
5933 | * A better method might be to use sys$device_scan on the first call, and to |
---|
5934 | * search for the device, returning an index into the cached array. |
---|
5935 | * The number returned would be more intelligable. |
---|
5936 | * This is probably not worth it, and anyway would take quite a bit longer |
---|
5937 | * on the first call. |
---|
5938 | */ |
---|
5939 | #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */ |
---|
5940 | static mydev_t encode_dev (const char *dev) |
---|
5941 | { |
---|
5942 | int i; |
---|
5943 | unsigned long int f; |
---|
5944 | mydev_t enc; |
---|
5945 | char c; |
---|
5946 | const char *q; |
---|
5947 | dTHX; |
---|
5948 | |
---|
5949 | if (!dev || !dev[0]) return 0; |
---|
5950 | |
---|
5951 | #if LOCKID_MASK |
---|
5952 | { |
---|
5953 | struct dsc$descriptor_s dev_desc; |
---|
5954 | unsigned long int status, lockid, item = DVI$_LOCKID; |
---|
5955 | |
---|
5956 | /* For cluster-mounted disks, the disk lock identifier is unique, so we |
---|
5957 | can try that first. */ |
---|
5958 | dev_desc.dsc$w_length = strlen (dev); |
---|
5959 | dev_desc.dsc$b_dtype = DSC$K_DTYPE_T; |
---|
5960 | dev_desc.dsc$b_class = DSC$K_CLASS_S; |
---|
5961 | dev_desc.dsc$a_pointer = (char *) dev; |
---|
5962 | _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0)); |
---|
5963 | if (lockid) return (lockid & ~LOCKID_MASK); |
---|
5964 | } |
---|
5965 | #endif |
---|
5966 | |
---|
5967 | /* Otherwise we try to encode the device name */ |
---|
5968 | enc = 0; |
---|
5969 | f = 1; |
---|
5970 | i = 0; |
---|
5971 | for (q = dev + strlen(dev); q--; q >= dev) { |
---|
5972 | if (isdigit (*q)) |
---|
5973 | c= (*q) - '0'; |
---|
5974 | else if (isalpha (toupper (*q))) |
---|
5975 | c= toupper (*q) - 'A' + (char)10; |
---|
5976 | else |
---|
5977 | continue; /* Skip '$'s */ |
---|
5978 | i++; |
---|
5979 | if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */ |
---|
5980 | if (i>1) f *= 36; |
---|
5981 | enc += f * (unsigned long int) c; |
---|
5982 | } |
---|
5983 | return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */ |
---|
5984 | |
---|
5985 | } /* end of encode_dev() */ |
---|
5986 | |
---|
5987 | static char namecache[NAM$C_MAXRSS+1]; |
---|
5988 | |
---|
5989 | static int |
---|
5990 | is_null_device(name) |
---|
5991 | const char *name; |
---|
5992 | { |
---|
5993 | dTHX; |
---|
5994 | /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:". |
---|
5995 | The underscore prefix, controller letter, and unit number are |
---|
5996 | independently optional; for our purposes, the colon punctuation |
---|
5997 | is not. The colon can be trailed by optional directory and/or |
---|
5998 | filename, but two consecutive colons indicates a nodename rather |
---|
5999 | than a device. [pr] */ |
---|
6000 | if (*name == '_') ++name; |
---|
6001 | if (tolower(*name++) != 'n') return 0; |
---|
6002 | if (tolower(*name++) != 'l') return 0; |
---|
6003 | if (tolower(*name) == 'a') ++name; |
---|
6004 | if (*name == '0') ++name; |
---|
6005 | return (*name++ == ':') && (*name != ':'); |
---|
6006 | } |
---|
6007 | |
---|
6008 | /* Do the permissions allow some operation? Assumes PL_statcache already set. */ |
---|
6009 | /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a |
---|
6010 | * subset of the applicable information. |
---|
6011 | */ |
---|
6012 | bool |
---|
6013 | Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp) |
---|
6014 | { |
---|
6015 | char fname_phdev[NAM$C_MAXRSS+1]; |
---|
6016 | if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache); |
---|
6017 | else { |
---|
6018 | char fname[NAM$C_MAXRSS+1]; |
---|
6019 | unsigned long int retsts; |
---|
6020 | struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}, |
---|
6021 | namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; |
---|
6022 | |
---|
6023 | /* If the struct mystat is stale, we're OOL; stat() overwrites the |
---|
6024 | device name on successive calls */ |
---|
6025 | devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam; |
---|
6026 | devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam); |
---|
6027 | namdsc.dsc$a_pointer = fname; |
---|
6028 | namdsc.dsc$w_length = sizeof fname - 1; |
---|
6029 | |
---|
6030 | retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino), |
---|
6031 | &namdsc,&namdsc.dsc$w_length,0,0); |
---|
6032 | if (retsts & 1) { |
---|
6033 | fname[namdsc.dsc$w_length] = '\0'; |
---|
6034 | /* |
---|
6035 | * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name, |
---|
6036 | * but if someone has redefined that logical, Perl gets very lost. Since |
---|
6037 | * we have the physical device name from the stat buffer, just paste it on. |
---|
6038 | */ |
---|
6039 | strcpy( fname_phdev, statbufp->st_devnam ); |
---|
6040 | strcat( fname_phdev, strrchr(fname, ':') ); |
---|
6041 | |
---|
6042 | return cando_by_name(bit,effective,fname_phdev); |
---|
6043 | } |
---|
6044 | else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) { |
---|
6045 | Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n"); |
---|
6046 | return FALSE; |
---|
6047 | } |
---|
6048 | _ckvmssts(retsts); |
---|
6049 | return FALSE; /* Should never get to here */ |
---|
6050 | } |
---|
6051 | } /* end of cando() */ |
---|
6052 | /*}}}*/ |
---|
6053 | |
---|
6054 | |
---|
6055 | /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/ |
---|
6056 | I32 |
---|
6057 | cando_by_name(I32 bit, Uid_t effective, char *fname) |
---|
6058 | { |
---|
6059 | static char usrname[L_cuserid]; |
---|
6060 | static struct dsc$descriptor_s usrdsc = |
---|
6061 | {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname}; |
---|
6062 | char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1]; |
---|
6063 | unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2]; |
---|
6064 | unsigned short int retlen; |
---|
6065 | dTHX; |
---|
6066 | struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; |
---|
6067 | union prvdef curprv; |
---|
6068 | struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen}, |
---|
6069 | {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}}; |
---|
6070 | struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen}, |
---|
6071 | {0,0,0,0}}; |
---|
6072 | |
---|
6073 | if (!fname || !*fname) return FALSE; |
---|
6074 | /* Make sure we expand logical names, since sys$check_access doesn't */ |
---|
6075 | if (!strpbrk(fname,"/]>:")) { |
---|
6076 | strcpy(fileified,fname); |
---|
6077 | while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ; |
---|
6078 | fname = fileified; |
---|
6079 | } |
---|
6080 | if (!do_tovmsspec(fname,vmsname,1)) return FALSE; |
---|
6081 | retlen = namdsc.dsc$w_length = strlen(vmsname); |
---|
6082 | namdsc.dsc$a_pointer = vmsname; |
---|
6083 | if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' || |
---|
6084 | vmsname[retlen-1] == ':') { |
---|
6085 | if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE; |
---|
6086 | namdsc.dsc$w_length = strlen(fileified); |
---|
6087 | namdsc.dsc$a_pointer = fileified; |
---|
6088 | } |
---|
6089 | |
---|
6090 | if (!usrdsc.dsc$w_length) { |
---|
6091 | cuserid(usrname); |
---|
6092 | usrdsc.dsc$w_length = strlen(usrname); |
---|
6093 | } |
---|
6094 | |
---|
6095 | switch (bit) { |
---|
6096 | case S_IXUSR: case S_IXGRP: case S_IXOTH: |
---|
6097 | access = ARM$M_EXECUTE; break; |
---|
6098 | case S_IRUSR: case S_IRGRP: case S_IROTH: |
---|
6099 | access = ARM$M_READ; break; |
---|
6100 | case S_IWUSR: case S_IWGRP: case S_IWOTH: |
---|
6101 | access = ARM$M_WRITE; break; |
---|
6102 | case S_IDUSR: case S_IDGRP: case S_IDOTH: |
---|
6103 | access = ARM$M_DELETE; break; |
---|
6104 | default: |
---|
6105 | return FALSE; |
---|
6106 | } |
---|
6107 | |
---|
6108 | retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst); |
---|
6109 | if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT || |
---|
6110 | retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN || |
---|
6111 | retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) { |
---|
6112 | set_vaxc_errno(retsts); |
---|
6113 | if (retsts == SS$_NOPRIV) set_errno(EACCES); |
---|
6114 | else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL); |
---|
6115 | else set_errno(ENOENT); |
---|
6116 | return FALSE; |
---|
6117 | } |
---|
6118 | if (retsts == SS$_NORMAL) { |
---|
6119 | if (!privused) return TRUE; |
---|
6120 | /* We can get access, but only by using privs. Do we have the |
---|
6121 | necessary privs currently enabled? */ |
---|
6122 | _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0)); |
---|
6123 | if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE; |
---|
6124 | if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv && |
---|
6125 | !curprv.prv$v_bypass) return FALSE; |
---|
6126 | if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv && |
---|
6127 | !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE; |
---|
6128 | if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE; |
---|
6129 | return TRUE; |
---|
6130 | } |
---|
6131 | if (retsts == SS$_ACCONFLICT) { |
---|
6132 | return TRUE; |
---|
6133 | } |
---|
6134 | _ckvmssts(retsts); |
---|
6135 | |
---|
6136 | return FALSE; /* Should never get here */ |
---|
6137 | |
---|
6138 | } /* end of cando_by_name() */ |
---|
6139 | /*}}}*/ |
---|
6140 | |
---|
6141 | |
---|
6142 | /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/ |
---|
6143 | int |
---|
6144 | flex_fstat(int fd, Stat_t *statbufp) |
---|
6145 | { |
---|
6146 | dTHX; |
---|
6147 | if (!fstat(fd,(stat_t *) statbufp)) { |
---|
6148 | if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0'; |
---|
6149 | statbufp->st_dev = encode_dev(statbufp->st_devnam); |
---|
6150 | # ifdef RTL_USES_UTC |
---|
6151 | # ifdef VMSISH_TIME |
---|
6152 | if (VMSISH_TIME) { |
---|
6153 | statbufp->st_mtime = _toloc(statbufp->st_mtime); |
---|
6154 | statbufp->st_atime = _toloc(statbufp->st_atime); |
---|
6155 | statbufp->st_ctime = _toloc(statbufp->st_ctime); |
---|
6156 | } |
---|
6157 | # endif |
---|
6158 | # else |
---|
6159 | # ifdef VMSISH_TIME |
---|
6160 | if (!VMSISH_TIME) { /* Return UTC instead of local time */ |
---|
6161 | # else |
---|
6162 | if (1) { |
---|
6163 | # endif |
---|
6164 | statbufp->st_mtime = _toutc(statbufp->st_mtime); |
---|
6165 | statbufp->st_atime = _toutc(statbufp->st_atime); |
---|
6166 | statbufp->st_ctime = _toutc(statbufp->st_ctime); |
---|
6167 | } |
---|
6168 | #endif |
---|
6169 | return 0; |
---|
6170 | } |
---|
6171 | return -1; |
---|
6172 | |
---|
6173 | } /* end of flex_fstat() */ |
---|
6174 | /*}}}*/ |
---|
6175 | |
---|
6176 | /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/ |
---|
6177 | int |
---|
6178 | flex_stat(const char *fspec, Stat_t *statbufp) |
---|
6179 | { |
---|
6180 | dTHX; |
---|
6181 | char fileified[NAM$C_MAXRSS+1]; |
---|
6182 | char temp_fspec[NAM$C_MAXRSS+300]; |
---|
6183 | int retval = -1; |
---|
6184 | |
---|
6185 | strcpy(temp_fspec, fspec); |
---|
6186 | if (statbufp == (Stat_t *) &PL_statcache) |
---|
6187 | do_tovmsspec(temp_fspec,namecache,0); |
---|
6188 | if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */ |
---|
6189 | memset(statbufp,0,sizeof *statbufp); |
---|
6190 | statbufp->st_dev = encode_dev("_NLA0:"); |
---|
6191 | statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC; |
---|
6192 | statbufp->st_uid = 0x00010001; |
---|
6193 | statbufp->st_gid = 0x0001; |
---|
6194 | time((time_t *)&statbufp->st_mtime); |
---|
6195 | statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime; |
---|
6196 | return 0; |
---|
6197 | } |
---|
6198 | |
---|
6199 | /* Try for a directory name first. If fspec contains a filename without |
---|
6200 | * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir |
---|
6201 | * and sea:[wine.dark]water. exist, we prefer the directory here. |
---|
6202 | * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir, |
---|
6203 | * not sea:[wine.dark]., if the latter exists. If the intended target is |
---|
6204 | * the file with null type, specify this by calling flex_stat() with |
---|
6205 | * a '.' at the end of fspec. |
---|
6206 | */ |
---|
6207 | if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) { |
---|
6208 | retval = stat(fileified,(stat_t *) statbufp); |
---|
6209 | if (!retval && statbufp == (Stat_t *) &PL_statcache) |
---|
6210 | strcpy(namecache,fileified); |
---|
6211 | } |
---|
6212 | if (retval) retval = stat(temp_fspec,(stat_t *) statbufp); |
---|
6213 | if (!retval) { |
---|
6214 | statbufp->st_dev = encode_dev(statbufp->st_devnam); |
---|
6215 | # ifdef RTL_USES_UTC |
---|
6216 | # ifdef VMSISH_TIME |
---|
6217 | if (VMSISH_TIME) { |
---|
6218 | statbufp->st_mtime = _toloc(statbufp->st_mtime); |
---|
6219 | statbufp->st_atime = _toloc(statbufp->st_atime); |
---|
6220 | statbufp->st_ctime = _toloc(statbufp->st_ctime); |
---|
6221 | } |
---|
6222 | # endif |
---|
6223 | # else |
---|
6224 | # ifdef VMSISH_TIME |
---|
6225 | if (!VMSISH_TIME) { /* Return UTC instead of local time */ |
---|
6226 | # else |
---|
6227 | if (1) { |
---|
6228 | # endif |
---|
6229 | statbufp->st_mtime = _toutc(statbufp->st_mtime); |
---|
6230 | statbufp->st_atime = _toutc(statbufp->st_atime); |
---|
6231 | statbufp->st_ctime = _toutc(statbufp->st_ctime); |
---|
6232 | } |
---|
6233 | # endif |
---|
6234 | } |
---|
6235 | return retval; |
---|
6236 | |
---|
6237 | } /* end of flex_stat() */ |
---|
6238 | /*}}}*/ |
---|
6239 | |
---|
6240 | |
---|
6241 | /*{{{char *my_getlogin()*/ |
---|
6242 | /* VMS cuserid == Unix getlogin, except calling sequence */ |
---|
6243 | char * |
---|
6244 | my_getlogin() |
---|
6245 | { |
---|
6246 | static char user[L_cuserid]; |
---|
6247 | return cuserid(user); |
---|
6248 | } |
---|
6249 | /*}}}*/ |
---|
6250 | |
---|
6251 | |
---|
6252 | /* rmscopy - copy a file using VMS RMS routines |
---|
6253 | * |
---|
6254 | * Copies contents and attributes of spec_in to spec_out, except owner |
---|
6255 | * and protection information. Name and type of spec_in are used as |
---|
6256 | * defaults for spec_out. The third parameter specifies whether rmscopy() |
---|
6257 | * should try to propagate timestamps from the input file to the output file. |
---|
6258 | * If it is less than 0, no timestamps are preserved. If it is 0, then |
---|
6259 | * rmscopy() will behave similarly to the DCL COPY command: timestamps are |
---|
6260 | * propagated to the output file at creation iff the output file specification |
---|
6261 | * did not contain an explicit name or type, and the revision date is always |
---|
6262 | * updated at the end of the copy operation. If it is greater than 0, then |
---|
6263 | * it is interpreted as a bitmask, in which bit 0 indicates that timestamps |
---|
6264 | * other than the revision date should be propagated, and bit 1 indicates |
---|
6265 | * that the revision date should be propagated. |
---|
6266 | * |
---|
6267 | * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure. |
---|
6268 | * |
---|
6269 | * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>. |
---|
6270 | * Incorporates, with permission, some code from EZCOPY by Tim Adye |
---|
6271 | * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code |
---|
6272 | * as part of the Perl standard distribution under the terms of the |
---|
6273 | * GNU General Public License or the Perl Artistic License. Copies |
---|
6274 | * of each may be found in the Perl standard distribution. |
---|
6275 | */ |
---|
6276 | /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/ |
---|
6277 | int |
---|
6278 | Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates) |
---|
6279 | { |
---|
6280 | char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS], |
---|
6281 | rsa[NAM$C_MAXRSS], ubf[32256]; |
---|
6282 | unsigned long int i, sts, sts2; |
---|
6283 | struct FAB fab_in, fab_out; |
---|
6284 | struct RAB rab_in, rab_out; |
---|
6285 | struct NAM nam; |
---|
6286 | struct XABDAT xabdat; |
---|
6287 | struct XABFHC xabfhc; |
---|
6288 | struct XABRDT xabrdt; |
---|
6289 | struct XABSUM xabsum; |
---|
6290 | |
---|
6291 | if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) || |
---|
6292 | !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) { |
---|
6293 | set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); |
---|
6294 | return 0; |
---|
6295 | } |
---|
6296 | |
---|
6297 | fab_in = cc$rms_fab; |
---|
6298 | fab_in.fab$l_fna = vmsin; |
---|
6299 | fab_in.fab$b_fns = strlen(vmsin); |
---|
6300 | fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI; |
---|
6301 | fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET; |
---|
6302 | fab_in.fab$l_fop = FAB$M_SQO; |
---|
6303 | fab_in.fab$l_nam = &nam; |
---|
6304 | fab_in.fab$l_xab = (void *) &xabdat; |
---|
6305 | |
---|
6306 | nam = cc$rms_nam; |
---|
6307 | nam.nam$l_rsa = rsa; |
---|
6308 | nam.nam$b_rss = sizeof(rsa); |
---|
6309 | nam.nam$l_esa = esa; |
---|
6310 | nam.nam$b_ess = sizeof (esa); |
---|
6311 | nam.nam$b_esl = nam.nam$b_rsl = 0; |
---|
6312 | |
---|
6313 | xabdat = cc$rms_xabdat; /* To get creation date */ |
---|
6314 | xabdat.xab$l_nxt = (void *) &xabfhc; |
---|
6315 | |
---|
6316 | xabfhc = cc$rms_xabfhc; /* To get record length */ |
---|
6317 | xabfhc.xab$l_nxt = (void *) &xabsum; |
---|
6318 | |
---|
6319 | xabsum = cc$rms_xabsum; /* To get key and area information */ |
---|
6320 | |
---|
6321 | if (!((sts = sys$open(&fab_in)) & 1)) { |
---|
6322 | set_vaxc_errno(sts); |
---|
6323 | switch (sts) { |
---|
6324 | case RMS$_FNF: case RMS$_DNF: |
---|
6325 | set_errno(ENOENT); break; |
---|
6326 | case RMS$_DIR: |
---|
6327 | set_errno(ENOTDIR); break; |
---|
6328 | case RMS$_DEV: |
---|
6329 | set_errno(ENODEV); break; |
---|
6330 | case RMS$_SYN: |
---|
6331 | set_errno(EINVAL); break; |
---|
6332 | case RMS$_PRV: |
---|
6333 | set_errno(EACCES); break; |
---|
6334 | default: |
---|
6335 | set_errno(EVMSERR); |
---|
6336 | } |
---|
6337 | return 0; |
---|
6338 | } |
---|
6339 | |
---|
6340 | fab_out = fab_in; |
---|
6341 | fab_out.fab$w_ifi = 0; |
---|
6342 | fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT; |
---|
6343 | fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI; |
---|
6344 | fab_out.fab$l_fop = FAB$M_SQO; |
---|
6345 | fab_out.fab$l_fna = vmsout; |
---|
6346 | fab_out.fab$b_fns = strlen(vmsout); |
---|
6347 | fab_out.fab$l_dna = nam.nam$l_name; |
---|
6348 | fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0; |
---|
6349 | |
---|
6350 | if (preserve_dates == 0) { /* Act like DCL COPY */ |
---|
6351 | nam.nam$b_nop = NAM$M_SYNCHK; |
---|
6352 | fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */ |
---|
6353 | if (!((sts = sys$parse(&fab_out)) & 1)) { |
---|
6354 | set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR); |
---|
6355 | set_vaxc_errno(sts); |
---|
6356 | return 0; |
---|
6357 | } |
---|
6358 | fab_out.fab$l_xab = (void *) &xabdat; |
---|
6359 | if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1; |
---|
6360 | } |
---|
6361 | fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */ |
---|
6362 | if (preserve_dates < 0) /* Clear all bits; we'll use it as a */ |
---|
6363 | preserve_dates =0; /* bitmask from this point forward */ |
---|
6364 | |
---|
6365 | if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc; |
---|
6366 | if (!((sts = sys$create(&fab_out)) & 1)) { |
---|
6367 | set_vaxc_errno(sts); |
---|
6368 | switch (sts) { |
---|
6369 | case RMS$_DNF: |
---|
6370 | set_errno(ENOENT); break; |
---|
6371 | case RMS$_DIR: |
---|
6372 | set_errno(ENOTDIR); break; |
---|
6373 | case RMS$_DEV: |
---|
6374 | set_errno(ENODEV); break; |
---|
6375 | case RMS$_SYN: |
---|
6376 | set_errno(EINVAL); break; |
---|
6377 | case RMS$_PRV: |
---|
6378 | set_errno(EACCES); break; |
---|
6379 | default: |
---|
6380 | set_errno(EVMSERR); |
---|
6381 | } |
---|
6382 | return 0; |
---|
6383 | } |
---|
6384 | fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */ |
---|
6385 | if (preserve_dates & 2) { |
---|
6386 | /* sys$close() will process xabrdt, not xabdat */ |
---|
6387 | xabrdt = cc$rms_xabrdt; |
---|
6388 | #ifndef __GNUC__ |
---|
6389 | xabrdt.xab$q_rdt = xabdat.xab$q_rdt; |
---|
6390 | #else |
---|
6391 | /* gcc doesn't like the assignment, since its prototype for xab$q_rdt |
---|
6392 | * is unsigned long[2], while DECC & VAXC use a struct */ |
---|
6393 | memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt); |
---|
6394 | #endif |
---|
6395 | fab_out.fab$l_xab = (void *) &xabrdt; |
---|
6396 | } |
---|
6397 | |
---|
6398 | rab_in = cc$rms_rab; |
---|
6399 | rab_in.rab$l_fab = &fab_in; |
---|
6400 | rab_in.rab$l_rop = RAB$M_BIO; |
---|
6401 | rab_in.rab$l_ubf = ubf; |
---|
6402 | rab_in.rab$w_usz = sizeof ubf; |
---|
6403 | if (!((sts = sys$connect(&rab_in)) & 1)) { |
---|
6404 | sys$close(&fab_in); sys$close(&fab_out); |
---|
6405 | set_errno(EVMSERR); set_vaxc_errno(sts); |
---|
6406 | return 0; |
---|
6407 | } |
---|
6408 | |
---|
6409 | rab_out = cc$rms_rab; |
---|
6410 | rab_out.rab$l_fab = &fab_out; |
---|
6411 | rab_out.rab$l_rbf = ubf; |
---|
6412 | if (!((sts = sys$connect(&rab_out)) & 1)) { |
---|
6413 | sys$close(&fab_in); sys$close(&fab_out); |
---|
6414 | set_errno(EVMSERR); set_vaxc_errno(sts); |
---|
6415 | return 0; |
---|
6416 | } |
---|
6417 | |
---|
6418 | while ((sts = sys$read(&rab_in))) { /* always true */ |
---|
6419 | if (sts == RMS$_EOF) break; |
---|
6420 | rab_out.rab$w_rsz = rab_in.rab$w_rsz; |
---|
6421 | if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) { |
---|
6422 | sys$close(&fab_in); sys$close(&fab_out); |
---|
6423 | set_errno(EVMSERR); set_vaxc_errno(sts); |
---|
6424 | return 0; |
---|
6425 | } |
---|
6426 | } |
---|
6427 | |
---|
6428 | fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */ |
---|
6429 | sys$close(&fab_in); sys$close(&fab_out); |
---|
6430 | sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts; |
---|
6431 | if (!(sts & 1)) { |
---|
6432 | set_errno(EVMSERR); set_vaxc_errno(sts); |
---|
6433 | return 0; |
---|
6434 | } |
---|
6435 | |
---|
6436 | return 1; |
---|
6437 | |
---|
6438 | } /* end of rmscopy() */ |
---|
6439 | /*}}}*/ |
---|
6440 | |
---|
6441 | |
---|
6442 | /*** The following glue provides 'hooks' to make some of the routines |
---|
6443 | * from this file available from Perl. These routines are sufficiently |
---|
6444 | * basic, and are required sufficiently early in the build process, |
---|
6445 | * that's it's nice to have them available to miniperl as well as the |
---|
6446 | * full Perl, so they're set up here instead of in an extension. The |
---|
6447 | * Perl code which handles importation of these names into a given |
---|
6448 | * package lives in [.VMS]Filespec.pm in @INC. |
---|
6449 | */ |
---|
6450 | |
---|
6451 | void |
---|
6452 | rmsexpand_fromperl(pTHX_ CV *cv) |
---|
6453 | { |
---|
6454 | dXSARGS; |
---|
6455 | char *fspec, *defspec = NULL, *rslt; |
---|
6456 | STRLEN n_a; |
---|
6457 | |
---|
6458 | if (!items || items > 2) |
---|
6459 | Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])"); |
---|
6460 | fspec = SvPV(ST(0),n_a); |
---|
6461 | if (!fspec || !*fspec) XSRETURN_UNDEF; |
---|
6462 | if (items == 2) defspec = SvPV(ST(1),n_a); |
---|
6463 | |
---|
6464 | rslt = do_rmsexpand(fspec,NULL,1,defspec,0); |
---|
6465 | ST(0) = sv_newmortal(); |
---|
6466 | if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt)); |
---|
6467 | XSRETURN(1); |
---|
6468 | } |
---|
6469 | |
---|
6470 | void |
---|
6471 | vmsify_fromperl(pTHX_ CV *cv) |
---|
6472 | { |
---|
6473 | dXSARGS; |
---|
6474 | char *vmsified; |
---|
6475 | STRLEN n_a; |
---|
6476 | |
---|
6477 | if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)"); |
---|
6478 | vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1); |
---|
6479 | ST(0) = sv_newmortal(); |
---|
6480 | if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified)); |
---|
6481 | XSRETURN(1); |
---|
6482 | } |
---|
6483 | |
---|
6484 | void |
---|
6485 | unixify_fromperl(pTHX_ CV *cv) |
---|
6486 | { |
---|
6487 | dXSARGS; |
---|
6488 | char *unixified; |
---|
6489 | STRLEN n_a; |
---|
6490 | |
---|
6491 | if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)"); |
---|
6492 | unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1); |
---|
6493 | ST(0) = sv_newmortal(); |
---|
6494 | if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified)); |
---|
6495 | XSRETURN(1); |
---|
6496 | } |
---|
6497 | |
---|
6498 | void |
---|
6499 | fileify_fromperl(pTHX_ CV *cv) |
---|
6500 | { |
---|
6501 | dXSARGS; |
---|
6502 | char *fileified; |
---|
6503 | STRLEN n_a; |
---|
6504 | |
---|
6505 | if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)"); |
---|
6506 | fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1); |
---|
6507 | ST(0) = sv_newmortal(); |
---|
6508 | if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified)); |
---|
6509 | XSRETURN(1); |
---|
6510 | } |
---|
6511 | |
---|
6512 | void |
---|
6513 | pathify_fromperl(pTHX_ CV *cv) |
---|
6514 | { |
---|
6515 | dXSARGS; |
---|
6516 | char *pathified; |
---|
6517 | STRLEN n_a; |
---|
6518 | |
---|
6519 | if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)"); |
---|
6520 | pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1); |
---|
6521 | ST(0) = sv_newmortal(); |
---|
6522 | if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified)); |
---|
6523 | XSRETURN(1); |
---|
6524 | } |
---|
6525 | |
---|
6526 | void |
---|
6527 | vmspath_fromperl(pTHX_ CV *cv) |
---|
6528 | { |
---|
6529 | dXSARGS; |
---|
6530 | char *vmspath; |
---|
6531 | STRLEN n_a; |
---|
6532 | |
---|
6533 | if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)"); |
---|
6534 | vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1); |
---|
6535 | ST(0) = sv_newmortal(); |
---|
6536 | if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath)); |
---|
6537 | XSRETURN(1); |
---|
6538 | } |
---|
6539 | |
---|
6540 | void |
---|
6541 | unixpath_fromperl(pTHX_ CV *cv) |
---|
6542 | { |
---|
6543 | dXSARGS; |
---|
6544 | char *unixpath; |
---|
6545 | STRLEN n_a; |
---|
6546 | |
---|
6547 | if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)"); |
---|
6548 | unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1); |
---|
6549 | ST(0) = sv_newmortal(); |
---|
6550 | if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath)); |
---|
6551 | XSRETURN(1); |
---|
6552 | } |
---|
6553 | |
---|
6554 | void |
---|
6555 | candelete_fromperl(pTHX_ CV *cv) |
---|
6556 | { |
---|
6557 | dXSARGS; |
---|
6558 | char fspec[NAM$C_MAXRSS+1], *fsp; |
---|
6559 | SV *mysv; |
---|
6560 | IO *io; |
---|
6561 | STRLEN n_a; |
---|
6562 | |
---|
6563 | if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)"); |
---|
6564 | |
---|
6565 | mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0); |
---|
6566 | if (SvTYPE(mysv) == SVt_PVGV) { |
---|
6567 | if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) { |
---|
6568 | set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); |
---|
6569 | ST(0) = &PL_sv_no; |
---|
6570 | XSRETURN(1); |
---|
6571 | } |
---|
6572 | fsp = fspec; |
---|
6573 | } |
---|
6574 | else { |
---|
6575 | if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) { |
---|
6576 | set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); |
---|
6577 | ST(0) = &PL_sv_no; |
---|
6578 | XSRETURN(1); |
---|
6579 | } |
---|
6580 | } |
---|
6581 | |
---|
6582 | ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp)); |
---|
6583 | XSRETURN(1); |
---|
6584 | } |
---|
6585 | |
---|
6586 | void |
---|
6587 | rmscopy_fromperl(pTHX_ CV *cv) |
---|
6588 | { |
---|
6589 | dXSARGS; |
---|
6590 | char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp; |
---|
6591 | int date_flag; |
---|
6592 | struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}, |
---|
6593 | outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; |
---|
6594 | unsigned long int sts; |
---|
6595 | SV *mysv; |
---|
6596 | IO *io; |
---|
6597 | STRLEN n_a; |
---|
6598 | |
---|
6599 | if (items < 2 || items > 3) |
---|
6600 | Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])"); |
---|
6601 | |
---|
6602 | mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0); |
---|
6603 | if (SvTYPE(mysv) == SVt_PVGV) { |
---|
6604 | if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) { |
---|
6605 | set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); |
---|
6606 | ST(0) = &PL_sv_no; |
---|
6607 | XSRETURN(1); |
---|
6608 | } |
---|
6609 | inp = inspec; |
---|
6610 | } |
---|
6611 | else { |
---|
6612 | if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) { |
---|
6613 | set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); |
---|
6614 | ST(0) = &PL_sv_no; |
---|
6615 | XSRETURN(1); |
---|
6616 | } |
---|
6617 | } |
---|
6618 | mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1); |
---|
6619 | if (SvTYPE(mysv) == SVt_PVGV) { |
---|
6620 | if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) { |
---|
6621 | set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); |
---|
6622 | ST(0) = &PL_sv_no; |
---|
6623 | XSRETURN(1); |
---|
6624 | } |
---|
6625 | outp = outspec; |
---|
6626 | } |
---|
6627 | else { |
---|
6628 | if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) { |
---|
6629 | set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); |
---|
6630 | ST(0) = &PL_sv_no; |
---|
6631 | XSRETURN(1); |
---|
6632 | } |
---|
6633 | } |
---|
6634 | date_flag = (items == 3) ? SvIV(ST(2)) : 0; |
---|
6635 | |
---|
6636 | ST(0) = boolSV(rmscopy(inp,outp,date_flag)); |
---|
6637 | XSRETURN(1); |
---|
6638 | } |
---|
6639 | |
---|
6640 | |
---|
6641 | void |
---|
6642 | mod2fname(CV *cv) |
---|
6643 | { |
---|
6644 | dXSARGS; |
---|
6645 | char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1], |
---|
6646 | workbuff[NAM$C_MAXRSS*1 + 1]; |
---|
6647 | int total_namelen = 3, counter, num_entries; |
---|
6648 | /* ODS-5 ups this, but we want to be consistent, so... */ |
---|
6649 | int max_name_len = 39; |
---|
6650 | AV *in_array = (AV *)SvRV(ST(0)); |
---|
6651 | |
---|
6652 | num_entries = av_len(in_array); |
---|
6653 | |
---|
6654 | /* All the names start with PL_. */ |
---|
6655 | strcpy(ultimate_name, "PL_"); |
---|
6656 | |
---|
6657 | /* Clean up our working buffer */ |
---|
6658 | Zero(work_name, sizeof(work_name), char); |
---|
6659 | |
---|
6660 | /* Run through the entries and build up a working name */ |
---|
6661 | for(counter = 0; counter <= num_entries; counter++) { |
---|
6662 | /* If it's not the first name then tack on a __ */ |
---|
6663 | if (counter) { |
---|
6664 | strcat(work_name, "__"); |
---|
6665 | } |
---|
6666 | strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE), |
---|
6667 | PL_na)); |
---|
6668 | } |
---|
6669 | |
---|
6670 | /* Check to see if we actually have to bother...*/ |
---|
6671 | if (strlen(work_name) + 3 <= max_name_len) { |
---|
6672 | strcat(ultimate_name, work_name); |
---|
6673 | } else { |
---|
6674 | /* It's too darned big, so we need to go strip. We use the same */ |
---|
6675 | /* algorithm as xsubpp does. First, strip out doubled __ */ |
---|
6676 | char *source, *dest, last; |
---|
6677 | dest = workbuff; |
---|
6678 | last = 0; |
---|
6679 | for (source = work_name; *source; source++) { |
---|
6680 | if (last == *source && last == '_') { |
---|
6681 | continue; |
---|
6682 | } |
---|
6683 | *dest++ = *source; |
---|
6684 | last = *source; |
---|
6685 | } |
---|
6686 | /* Go put it back */ |
---|
6687 | strcpy(work_name, workbuff); |
---|
6688 | /* Is it still too big? */ |
---|
6689 | if (strlen(work_name) + 3 > max_name_len) { |
---|
6690 | /* Strip duplicate letters */ |
---|
6691 | last = 0; |
---|
6692 | dest = workbuff; |
---|
6693 | for (source = work_name; *source; source++) { |
---|
6694 | if (last == toupper(*source)) { |
---|
6695 | continue; |
---|
6696 | } |
---|
6697 | *dest++ = *source; |
---|
6698 | last = toupper(*source); |
---|
6699 | } |
---|
6700 | strcpy(work_name, workbuff); |
---|
6701 | } |
---|
6702 | |
---|
6703 | /* Is it *still* too big? */ |
---|
6704 | if (strlen(work_name) + 3 > max_name_len) { |
---|
6705 | /* Too bad, we truncate */ |
---|
6706 | work_name[max_name_len - 2] = 0; |
---|
6707 | } |
---|
6708 | strcat(ultimate_name, work_name); |
---|
6709 | } |
---|
6710 | |
---|
6711 | /* Okay, return it */ |
---|
6712 | ST(0) = sv_2mortal(newSVpv(ultimate_name, 0)); |
---|
6713 | XSRETURN(1); |
---|
6714 | } |
---|
6715 | |
---|
6716 | void |
---|
6717 | init_os_extras() |
---|
6718 | { |
---|
6719 | char* file = __FILE__; |
---|
6720 | dTHX; |
---|
6721 | char temp_buff[512]; |
---|
6722 | if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) { |
---|
6723 | no_translate_barewords = TRUE; |
---|
6724 | } else { |
---|
6725 | no_translate_barewords = FALSE; |
---|
6726 | } |
---|
6727 | |
---|
6728 | newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$"); |
---|
6729 | newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$"); |
---|
6730 | newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$"); |
---|
6731 | newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$"); |
---|
6732 | newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$"); |
---|
6733 | newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$"); |
---|
6734 | newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$"); |
---|
6735 | newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$"); |
---|
6736 | newXSproto("DynaLoader::mod2fname", mod2fname, file, "$"); |
---|
6737 | newXS("File::Copy::rmscopy",rmscopy_fromperl,file); |
---|
6738 | |
---|
6739 | store_pipelocs(); |
---|
6740 | |
---|
6741 | return; |
---|
6742 | } |
---|
6743 | |
---|
6744 | /* End of vms.c */ |
---|