1 /* pp_sys.c
2 *
3 * Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
4 * 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
9 */
10
11 /*
12 * But only a short way ahead its floor and the walls on either side were
13 * cloven by a great fissure, out of which the red glare came, now leaping
14 * up, now dying down into darkness; and all the while far below there was
15 * a rumour and a trouble as of great engines throbbing and labouring.
16 *
17 * [p.945 of _The Lord of the Rings_, VI/iii: "Mount Doom"]
18 */
19
20 /* This file contains system pp ("push/pop") functions that
21 * execute the opcodes that make up a perl program. A typical pp function
22 * expects to find its arguments on the stack, and usually pushes its
23 * results onto the stack, hence the 'pp' terminology. Each OP structure
24 * contains a pointer to the relevant pp_foo() function.
25 *
26 * By 'system', we mean ops which interact with the OS, such as pp_open().
27 */
28
29 #include "EXTERN.h"
30 #define PERL_IN_PP_SYS_C
31 #include "perl.h"
32 #include "time64.h"
33
34 #ifdef I_SHADOW
35 /* Shadow password support for solaris - pdo@cs.umd.edu
36 * Not just Solaris: at least HP-UX, IRIX, Linux.
37 * The API is from SysV.
38 *
39 * There are at least two more shadow interfaces,
40 * see the comments in pp_gpwent().
41 *
42 * --jhi */
43 # ifdef __hpux__
44 /* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
45 * and another MAXINT from "perl.h" <- <sys/param.h>. */
46 # undef MAXINT
47 # endif
48 # include <shadow.h>
49 #endif
50
51 #ifdef I_SYS_RESOURCE
52 # include <sys/resource.h>
53 #endif
54
55 #ifdef HAS_SELECT
56 # ifdef I_SYS_SELECT
57 # include <sys/select.h>
58 # endif
59 #endif
60
61 /* XXX Configure test needed.
62 h_errno might not be a simple 'int', especially for multi-threaded
63 applications, see "extern int errno in perl.h". Creating such
64 a test requires taking into account the differences between
65 compiling multithreaded and singlethreaded ($ccflags et al).
66 HOST_NOT_FOUND is typically defined in <netdb.h>.
67 */
68 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
69 extern int h_errno;
70 #endif
71
72 #ifdef HAS_PASSWD
73 # ifdef I_PWD
74 # include <pwd.h>
75 # elif !defined(VMS)
76 struct passwd *getpwnam (char *);
77 struct passwd *getpwuid (Uid_t);
78 # endif
79 # ifdef HAS_GETPWENT
80 # ifndef getpwent
81 struct passwd *getpwent (void);
82 # elif defined (VMS) && defined (my_getpwent)
83 struct passwd *Perl_my_getpwent (pTHX);
84 # endif
85 # endif
86 #endif
87
88 #ifdef HAS_GROUP
89 # ifdef I_GRP
90 # include <grp.h>
91 # else
92 struct group *getgrnam (char *);
93 struct group *getgrgid (Gid_t);
94 # endif
95 # ifdef HAS_GETGRENT
96 # ifndef getgrent
97 struct group *getgrent (void);
98 # endif
99 # endif
100 #endif
101
102 #ifdef I_UTIME
103 # if defined(_MSC_VER) || defined(__MINGW32__)
104 # include <sys/utime.h>
105 # else
106 # include <utime.h>
107 # endif
108 #endif
109
110 #ifdef HAS_CHSIZE
111 # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
112 # undef my_chsize
113 # endif
114 # define my_chsize PerlLIO_chsize
115 #elif defined(HAS_TRUNCATE)
116 # define my_chsize PerlLIO_chsize
117 #else
118 I32 my_chsize(int fd, Off_t length);
119 #endif
120
121 #ifdef HAS_FLOCK
122 # define FLOCK flock
123 #else /* no flock() */
124
125 /* fcntl.h might not have been included, even if it exists, because
126 the current Configure only sets I_FCNTL if it's needed to pick up
127 the *_OK constants. Make sure it has been included before testing
128 the fcntl() locking constants. */
129 # if defined(HAS_FCNTL) && !defined(I_FCNTL)
130 # include <fcntl.h>
131 # endif
132
133 # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
134 # define FLOCK fcntl_emulate_flock
135 # define FCNTL_EMULATE_FLOCK
136 # elif defined(HAS_LOCKF)
137 # define FLOCK lockf_emulate_flock
138 # define LOCKF_EMULATE_FLOCK
139 # endif
140
141 # ifdef FLOCK
142 static int FLOCK (int, int);
143
144 /*
145 * These are the flock() constants. Since this sytems doesn't have
146 * flock(), the values of the constants are probably not available.
147 */
148 # ifndef LOCK_SH
149 # define LOCK_SH 1
150 # endif
151 # ifndef LOCK_EX
152 # define LOCK_EX 2
153 # endif
154 # ifndef LOCK_NB
155 # define LOCK_NB 4
156 # endif
157 # ifndef LOCK_UN
158 # define LOCK_UN 8
159 # endif
160 # endif /* emulating flock() */
161
162 #endif /* no flock() */
163
164 #define ZBTLEN 10
165 static const char zero_but_true[ZBTLEN + 1] = "0 but true";
166
167 #if defined(I_SYS_ACCESS) && !defined(R_OK)
168 # include <sys/access.h>
169 #endif
170
171 #include "reentr.h"
172
173 #ifdef __Lynx__
174 /* Missing protos on LynxOS */
175 void sethostent(int);
176 void endhostent(void);
177 void setnetent(int);
178 void endnetent(void);
179 void setprotoent(int);
180 void endprotoent(void);
181 void setservent(int);
182 void endservent(void);
183 #endif
184
185 #ifdef __amigaos4__
186 # include "amigaos4/amigaio.h"
187 #endif
188
189 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
190
191 /* F_OK unused: if stat() cannot find it... */
192
193 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
194 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
195 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
196 #endif
197
198 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
199 # ifdef I_SYS_SECURITY
200 # include <sys/security.h>
201 # endif
202 # ifdef ACC_SELF
203 /* HP SecureWare */
204 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
205 # else
206 /* SCO */
207 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
208 # endif
209 #endif
210
211 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
212 /* AIX's accessx() doesn't declare its argument const, unlike every other platform */
213 # define PERL_EFF_ACCESS(p,f) (accessx((char*)(p), (f), ACC_SELF))
214 #endif
215
216
217 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
218 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
219 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
220 /* The Hard Way. */
221 STATIC int
S_emulate_eaccess(pTHX_ const char * path,Mode_t mode)222 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
223 {
224 const Uid_t ruid = getuid();
225 const Uid_t euid = geteuid();
226 const Gid_t rgid = getgid();
227 const Gid_t egid = getegid();
228 int res;
229
230 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
231 Perl_croak(aTHX_ "switching effective uid is not implemented");
232 #else
233 # ifdef HAS_SETREUID
234 if (setreuid(euid, ruid))
235 # elif defined(HAS_SETRESUID)
236 if (setresuid(euid, ruid, (Uid_t)-1))
237 # endif
238 /* diag_listed_as: entering effective %s failed */
239 Perl_croak(aTHX_ "entering effective uid failed");
240 #endif
241
242 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
243 Perl_croak(aTHX_ "switching effective gid is not implemented");
244 #else
245 # ifdef HAS_SETREGID
246 if (setregid(egid, rgid))
247 # elif defined(HAS_SETRESGID)
248 if (setresgid(egid, rgid, (Gid_t)-1))
249 # endif
250 /* diag_listed_as: entering effective %s failed */
251 Perl_croak(aTHX_ "entering effective gid failed");
252 #endif
253
254 res = access(path, mode);
255
256 #ifdef HAS_SETREUID
257 if (setreuid(ruid, euid))
258 #elif defined(HAS_SETRESUID)
259 if (setresuid(ruid, euid, (Uid_t)-1))
260 #endif
261 /* diag_listed_as: leaving effective %s failed */
262 Perl_croak(aTHX_ "leaving effective uid failed");
263
264 #ifdef HAS_SETREGID
265 if (setregid(rgid, egid))
266 #elif defined(HAS_SETRESGID)
267 if (setresgid(rgid, egid, (Gid_t)-1))
268 #endif
269 /* diag_listed_as: leaving effective %s failed */
270 Perl_croak(aTHX_ "leaving effective gid failed");
271
272 return res;
273 }
274 # define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f)))
275 #endif
276
PP(pp_backtick)277 PP(pp_backtick)
278 {
279 dSP; dTARGET;
280 PerlIO *fp;
281 const char * const tmps = POPpconstx;
282 const U8 gimme = GIMME_V;
283 const char *mode = "r";
284
285 TAINT_PROPER("``");
286 if (PL_op->op_private & OPpOPEN_IN_RAW)
287 mode = "rb";
288 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
289 mode = "rt";
290 fp = PerlProc_popen(tmps, mode);
291 if (fp) {
292 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
293 if (type && *type)
294 PerlIO_apply_layers(aTHX_ fp,mode,type);
295
296 if (gimme == G_VOID) {
297 char tmpbuf[256];
298 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
299 NOOP;
300 }
301 else if (gimme == G_SCALAR) {
302 ENTER_with_name("backtick");
303 SAVESPTR(PL_rs);
304 PL_rs = &PL_sv_undef;
305 SvPVCLEAR(TARG); /* note that this preserves previous buffer */
306 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
307 NOOP;
308 LEAVE_with_name("backtick");
309 XPUSHs(TARG);
310 SvTAINTED_on(TARG);
311 }
312 else {
313 for (;;) {
314 SV * const sv = newSV(79);
315 if (sv_gets(sv, fp, 0) == NULL) {
316 SvREFCNT_dec(sv);
317 break;
318 }
319 mXPUSHs(sv);
320 if (SvLEN(sv) - SvCUR(sv) > 20) {
321 SvPV_shrink_to_cur(sv);
322 }
323 SvTAINTED_on(sv);
324 }
325 }
326 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
327 TAINT; /* "I believe that this is not gratuitous!" */
328 }
329 else {
330 STATUS_NATIVE_CHILD_SET(-1);
331 if (gimme == G_SCALAR)
332 RETPUSHUNDEF;
333 }
334
335 RETURN;
336 }
337
PP(pp_glob)338 PP(pp_glob)
339 {
340 OP *result;
341 dSP;
342 GV * const gv = (PL_op->op_flags & OPf_SPECIAL) ? NULL : (GV *)POPs;
343
344 PUTBACK;
345
346 /* make a copy of the pattern if it is gmagical, to ensure that magic
347 * is called once and only once */
348 if (SvGMAGICAL(TOPs)) TOPs = sv_2mortal(newSVsv(TOPs));
349
350 tryAMAGICunTARGETlist(iter_amg, (PL_op->op_flags & OPf_SPECIAL));
351
352 if (PL_op->op_flags & OPf_SPECIAL) {
353 /* call Perl-level glob function instead. Stack args are:
354 * MARK, wildcard
355 * and following OPs should be: gv(CORE::GLOBAL::glob), entersub
356 * */
357 return NORMAL;
358 }
359 if (PL_globhook) {
360 PL_globhook(aTHX);
361 return NORMAL;
362 }
363
364 /* Note that we only ever get here if File::Glob fails to load
365 * without at the same time croaking, for some reason, or if
366 * perl was built with PERL_EXTERNAL_GLOB */
367
368 ENTER_with_name("glob");
369
370 #ifndef VMS
371 if (TAINTING_get) {
372 /*
373 * The external globbing program may use things we can't control,
374 * so for security reasons we must assume the worst.
375 */
376 TAINT;
377 taint_proper(PL_no_security, "glob");
378 }
379 #endif /* !VMS */
380
381 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
382 PL_last_in_gv = gv;
383
384 SAVESPTR(PL_rs); /* This is not permanent, either. */
385 PL_rs = newSVpvs_flags("\000", SVs_TEMP);
386 #ifndef DOSISH
387 #ifndef CSH
388 *SvPVX(PL_rs) = '\n';
389 #endif /* !CSH */
390 #endif /* !DOSISH */
391
392 result = do_readline();
393 LEAVE_with_name("glob");
394 return result;
395 }
396
PP(pp_rcatline)397 PP(pp_rcatline)
398 {
399 PL_last_in_gv = cGVOP_gv;
400 return do_readline();
401 }
402
PP(pp_warn)403 PP(pp_warn)
404 {
405 dSP; dMARK;
406 SV *exsv;
407 STRLEN len;
408 if (SP - MARK > 1) {
409 dTARGET;
410 do_join(TARG, &PL_sv_no, MARK, SP);
411 exsv = TARG;
412 SP = MARK + 1;
413 }
414 else if (SP == MARK) {
415 exsv = &PL_sv_no;
416 MEXTEND(SP, 1);
417 SP = MARK + 1;
418 }
419 else {
420 exsv = TOPs;
421 if (SvGMAGICAL(exsv)) exsv = sv_mortalcopy(exsv);
422 }
423
424 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
425 /* well-formed exception supplied */
426 }
427 else {
428 SV * const errsv = ERRSV;
429 SvGETMAGIC(errsv);
430 if (SvROK(errsv)) {
431 if (SvGMAGICAL(errsv)) {
432 exsv = sv_newmortal();
433 sv_setsv_nomg(exsv, errsv);
434 }
435 else exsv = errsv;
436 }
437 else if (SvPOKp(errsv) ? SvCUR(errsv) : SvNIOKp(errsv)) {
438 exsv = sv_newmortal();
439 sv_setsv_nomg(exsv, errsv);
440 sv_catpvs(exsv, "\t...caught");
441 }
442 else {
443 exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
444 }
445 }
446 if (SvROK(exsv) && !PL_warnhook)
447 Perl_warn(aTHX_ "%" SVf, SVfARG(exsv));
448 else warn_sv(exsv);
449 RETSETYES;
450 }
451
PP(pp_die)452 PP(pp_die)
453 {
454 dSP; dMARK;
455 SV *exsv;
456 STRLEN len;
457 #ifdef VMS
458 VMSISH_HUSHED =
459 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
460 #endif
461 if (SP - MARK != 1) {
462 dTARGET;
463 do_join(TARG, &PL_sv_no, MARK, SP);
464 exsv = TARG;
465 SP = MARK + 1;
466 }
467 else {
468 exsv = TOPs;
469 }
470
471 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
472 /* well-formed exception supplied */
473 }
474 else {
475 SV * const errsv = ERRSV;
476 SvGETMAGIC(errsv);
477 if (SvROK(errsv)) {
478 exsv = errsv;
479 if (sv_isobject(exsv)) {
480 HV * const stash = SvSTASH(SvRV(exsv));
481 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
482 if (gv) {
483 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
484 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
485 EXTEND(SP, 3);
486 PUSHMARK(SP);
487 PUSHs(exsv);
488 PUSHs(file);
489 PUSHs(line);
490 PUTBACK;
491 call_sv(MUTABLE_SV(GvCV(gv)),
492 G_SCALAR|G_EVAL|G_KEEPERR);
493 exsv = sv_mortalcopy(*PL_stack_sp--);
494 }
495 }
496 }
497 else if (SvOK(errsv) && (SvPV_nomg(errsv,len), len)) {
498 exsv = sv_mortalcopy(errsv);
499 sv_catpvs(exsv, "\t...propagated");
500 }
501 else {
502 exsv = newSVpvs_flags("Died", SVs_TEMP);
503 }
504 }
505 die_sv(exsv);
506 NOT_REACHED; /* NOTREACHED */
507 return NULL; /* avoid missing return from non-void function warning */
508 }
509
510 /* I/O. */
511
512 OP *
Perl_tied_method(pTHX_ SV * methname,SV ** sp,SV * const sv,const MAGIC * const mg,const U32 flags,U32 argc,...)513 Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv,
514 const MAGIC *const mg, const U32 flags, U32 argc, ...)
515 {
516 SV **orig_sp = sp;
517 I32 ret_args;
518 SSize_t extend_size;
519
520 PERL_ARGS_ASSERT_TIED_METHOD;
521
522 /* Ensure that our flag bits do not overlap. */
523 STATIC_ASSERT_STMT((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
524 STATIC_ASSERT_STMT((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
525 STATIC_ASSERT_STMT((TIED_METHOD_SAY & G_WANT) == 0);
526
527 PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */
528 PUSHSTACKi(PERLSI_MAGIC);
529 /* extend for object + args. If argc might wrap/truncate when cast
530 * to SSize_t and incremented, set to -1, which will trigger a panic in
531 * EXTEND().
532 * The weird way this is written is because g++ is dumb enough to
533 * warn "comparison is always false" on something like:
534 *
535 * sizeof(a) >= sizeof(b) && a >= B_t_MAX -1
536 *
537 * (where the LH condition is false)
538 */
539 extend_size =
540 (argc > (sizeof(argc) >= sizeof(SSize_t) ? SSize_t_MAX - 1 : argc))
541 ? -1 : (SSize_t)argc + 1;
542 EXTEND(SP, extend_size);
543 PUSHMARK(sp);
544 PUSHs(SvTIED_obj(sv, mg));
545 if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
546 Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */
547 sp += argc;
548 }
549 else if (argc) {
550 const U32 mortalize_not_needed
551 = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
552 va_list args;
553 va_start(args, argc);
554 do {
555 SV *const arg = va_arg(args, SV *);
556 if(mortalize_not_needed)
557 PUSHs(arg);
558 else
559 mPUSHs(arg);
560 } while (--argc);
561 va_end(args);
562 }
563
564 PUTBACK;
565 ENTER_with_name("call_tied_method");
566 if (flags & TIED_METHOD_SAY) {
567 /* local $\ = "\n" */
568 SAVEGENERICSV(PL_ors_sv);
569 PL_ors_sv = newSVpvs("\n");
570 }
571 ret_args = call_sv(methname, (flags & G_WANT)|G_METHOD_NAMED);
572 SPAGAIN;
573 orig_sp = sp;
574 POPSTACK;
575 SPAGAIN;
576 if (ret_args) { /* copy results back to original stack */
577 EXTEND(sp, ret_args);
578 Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*);
579 sp += ret_args;
580 PUTBACK;
581 }
582 LEAVE_with_name("call_tied_method");
583 return NORMAL;
584 }
585
586 #define tied_method0(a,b,c,d) \
587 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0)
588 #define tied_method1(a,b,c,d,e) \
589 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e)
590 #define tied_method2(a,b,c,d,e,f) \
591 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f)
592
PP(pp_open)593 PP(pp_open)
594 {
595 dSP;
596 dMARK; dORIGMARK;
597 dTARGET;
598 SV *sv;
599 IO *io;
600 const char *tmps;
601 STRLEN len;
602 bool ok;
603
604 GV * const gv = MUTABLE_GV(*++MARK);
605
606 if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
607 DIE(aTHX_ PL_no_usym, "filehandle");
608
609 if ((io = GvIOp(gv))) {
610 const MAGIC *mg;
611 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
612
613 if (IoDIRP(io))
614 Perl_croak(aTHX_ "Cannot open %" HEKf " as a filehandle: it is already open as a dirhandle",
615 HEKfARG(GvENAME_HEK(gv)));
616
617 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
618 if (mg) {
619 /* Method's args are same as ours ... */
620 /* ... except handle is replaced by the object */
621 return Perl_tied_method(aTHX_ SV_CONST(OPEN), mark - 1, MUTABLE_SV(io), mg,
622 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
623 sp - mark);
624 }
625 }
626
627 if (MARK < SP) {
628 sv = *++MARK;
629 }
630 else {
631 sv = GvSVn(gv);
632 }
633
634 tmps = SvPV_const(sv, len);
635 ok = do_open6(gv, tmps, len, NULL, MARK+1, (SP-MARK));
636 SP = ORIGMARK;
637 if (ok)
638 PUSHi( (I32)PL_forkprocess );
639 else if (PL_forkprocess == 0) /* we are a new child */
640 PUSHs(&PL_sv_zero);
641 else
642 RETPUSHUNDEF;
643 RETURN;
644 }
645
PP(pp_close)646 PP(pp_close)
647 {
648 dSP;
649 /* pp_coreargs pushes a NULL to indicate no args passed to
650 * CORE::close() */
651 GV * const gv =
652 MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs);
653
654 if (MAXARG == 0)
655 EXTEND(SP, 1);
656
657 if (gv) {
658 IO * const io = GvIO(gv);
659 if (io) {
660 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
661 if (mg) {
662 return tied_method0(SV_CONST(CLOSE), SP, MUTABLE_SV(io), mg);
663 }
664 }
665 }
666 PUSHs(boolSV(do_close(gv, TRUE)));
667 RETURN;
668 }
669
PP(pp_pipe_op)670 PP(pp_pipe_op)
671 {
672 #ifdef HAS_PIPE
673 dSP;
674 IO *rstio;
675 IO *wstio;
676 int fd[2];
677
678 GV * const wgv = MUTABLE_GV(POPs);
679 GV * const rgv = MUTABLE_GV(POPs);
680
681 rstio = GvIOn(rgv);
682 if (IoIFP(rstio))
683 do_close(rgv, FALSE);
684
685 wstio = GvIOn(wgv);
686 if (IoIFP(wstio))
687 do_close(wgv, FALSE);
688
689 if (PerlProc_pipe_cloexec(fd) < 0)
690 goto badexit;
691
692 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r" PIPE_OPEN_MODE);
693 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w" PIPE_OPEN_MODE);
694 IoOFP(rstio) = IoIFP(rstio);
695 IoIFP(wstio) = IoOFP(wstio);
696 IoTYPE(rstio) = IoTYPE_RDONLY;
697 IoTYPE(wstio) = IoTYPE_WRONLY;
698
699 if (!IoIFP(rstio) || !IoOFP(wstio)) {
700 if (IoIFP(rstio))
701 PerlIO_close(IoIFP(rstio));
702 else
703 PerlLIO_close(fd[0]);
704 if (IoOFP(wstio))
705 PerlIO_close(IoOFP(wstio));
706 else
707 PerlLIO_close(fd[1]);
708 goto badexit;
709 }
710 RETPUSHYES;
711
712 badexit:
713 RETPUSHUNDEF;
714 #else
715 DIE(aTHX_ PL_no_func, "pipe");
716 #endif
717 }
718
PP(pp_fileno)719 PP(pp_fileno)
720 {
721 dSP; dTARGET;
722 GV *gv;
723 IO *io;
724 PerlIO *fp;
725 const MAGIC *mg;
726
727 if (MAXARG < 1)
728 RETPUSHUNDEF;
729 gv = MUTABLE_GV(POPs);
730 io = GvIO(gv);
731
732 if (io
733 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
734 {
735 return tied_method0(SV_CONST(FILENO), SP, MUTABLE_SV(io), mg);
736 }
737
738 if (io && IoDIRP(io)) {
739 #if defined(HAS_DIRFD) || defined(HAS_DIR_DD_FD)
740 PUSHi(my_dirfd(IoDIRP(io)));
741 RETURN;
742 #elif defined(ENOTSUP)
743 errno = ENOTSUP; /* Operation not supported */
744 RETPUSHUNDEF;
745 #elif defined(EOPNOTSUPP)
746 errno = EOPNOTSUPP; /* Operation not supported on socket */
747 RETPUSHUNDEF;
748 #else
749 errno = EINVAL; /* Invalid argument */
750 RETPUSHUNDEF;
751 #endif
752 }
753
754 if (!io || !(fp = IoIFP(io))) {
755 /* Can't do this because people seem to do things like
756 defined(fileno($foo)) to check whether $foo is a valid fh.
757
758 report_evil_fh(gv);
759 */
760 RETPUSHUNDEF;
761 }
762
763 PUSHi(PerlIO_fileno(fp));
764 RETURN;
765 }
766
PP(pp_umask)767 PP(pp_umask)
768 {
769 dSP;
770 #ifdef HAS_UMASK
771 dTARGET;
772 Mode_t anum;
773
774 if (MAXARG < 1 || (!TOPs && !POPs)) {
775 anum = PerlLIO_umask(022);
776 /* setting it to 022 between the two calls to umask avoids
777 * to have a window where the umask is set to 0 -- meaning
778 * that another thread could create world-writeable files. */
779 if (anum != 022)
780 (void)PerlLIO_umask(anum);
781 }
782 else
783 anum = PerlLIO_umask(POPi);
784 TAINT_PROPER("umask");
785 XPUSHi(anum);
786 #else
787 /* Only DIE if trying to restrict permissions on "user" (self).
788 * Otherwise it's harmless and more useful to just return undef
789 * since 'group' and 'other' concepts probably don't exist here. */
790 if (MAXARG >= 1 && (TOPs||POPs) && (POPi & 0700))
791 DIE(aTHX_ "umask not implemented");
792 XPUSHs(&PL_sv_undef);
793 #endif
794 RETURN;
795 }
796
PP(pp_binmode)797 PP(pp_binmode)
798 {
799 dSP;
800 GV *gv;
801 IO *io;
802 PerlIO *fp;
803 SV *discp = NULL;
804
805 if (MAXARG < 1)
806 RETPUSHUNDEF;
807 if (MAXARG > 1) {
808 discp = POPs;
809 }
810
811 gv = MUTABLE_GV(POPs);
812 io = GvIO(gv);
813
814 if (io) {
815 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
816 if (mg) {
817 /* This takes advantage of the implementation of the varargs
818 function, which I don't think that the optimiser will be able to
819 figure out. Although, as it's a static function, in theory it
820 could. */
821 return Perl_tied_method(aTHX_ SV_CONST(BINMODE), SP, MUTABLE_SV(io), mg,
822 G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
823 discp ? 1 : 0, discp);
824 }
825 }
826
827 if (!io || !(fp = IoIFP(io))) {
828 report_evil_fh(gv);
829 SETERRNO(EBADF,RMS_IFI);
830 RETPUSHUNDEF;
831 }
832
833 PUTBACK;
834 {
835 STRLEN len = 0;
836 const char *d = NULL;
837 int mode;
838 if (discp)
839 d = SvPV_const(discp, len);
840 mode = mode_from_discipline(d, len);
841 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
842 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
843 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
844 SPAGAIN;
845 RETPUSHUNDEF;
846 }
847 }
848 SPAGAIN;
849 RETPUSHYES;
850 }
851 else {
852 SPAGAIN;
853 RETPUSHUNDEF;
854 }
855 }
856 }
857
PP(pp_tie)858 PP(pp_tie)
859 {
860 dSP; dMARK;
861 HV* stash;
862 GV *gv = NULL;
863 SV *sv;
864 const I32 markoff = MARK - PL_stack_base;
865 const char *methname;
866 int how = PERL_MAGIC_tied;
867 U32 items;
868 SV *varsv = *++MARK;
869
870 switch(SvTYPE(varsv)) {
871 case SVt_PVHV:
872 {
873 HE *entry;
874 methname = "TIEHASH";
875 if (HvLAZYDEL(varsv) && (entry = HvEITER_get((HV *)varsv))) {
876 HvLAZYDEL_off(varsv);
877 hv_free_ent((HV *)varsv, entry);
878 }
879 HvEITER_set(MUTABLE_HV(varsv), 0);
880 HvRITER_set(MUTABLE_HV(varsv), -1);
881 break;
882 }
883 case SVt_PVAV:
884 methname = "TIEARRAY";
885 if (!AvREAL(varsv)) {
886 if (!AvREIFY(varsv))
887 Perl_croak(aTHX_ "Cannot tie unreifiable array");
888 av_clear((AV *)varsv);
889 AvREIFY_off(varsv);
890 AvREAL_on(varsv);
891 }
892 break;
893 case SVt_PVGV:
894 case SVt_PVLV:
895 if (isGV_with_GP(varsv) && !SvFAKE(varsv)) {
896 methname = "TIEHANDLE";
897 how = PERL_MAGIC_tiedscalar;
898 /* For tied filehandles, we apply tiedscalar magic to the IO
899 slot of the GP rather than the GV itself. AMS 20010812 */
900 if (!GvIOp(varsv))
901 GvIOp(varsv) = newIO();
902 varsv = MUTABLE_SV(GvIOp(varsv));
903 break;
904 }
905 if (SvTYPE(varsv) == SVt_PVLV && LvTYPE(varsv) == 'y') {
906 vivify_defelem(varsv);
907 varsv = LvTARG(varsv);
908 }
909 /* FALLTHROUGH */
910 default:
911 methname = "TIESCALAR";
912 how = PERL_MAGIC_tiedscalar;
913 break;
914 }
915 items = SP - MARK++;
916 if (sv_isobject(*MARK)) { /* Calls GET magic. */
917 ENTER_with_name("call_TIE");
918 PUSHSTACKi(PERLSI_MAGIC);
919 PUSHMARK(SP);
920 EXTEND(SP,(I32)items);
921 while (items--)
922 PUSHs(*MARK++);
923 PUTBACK;
924 call_method(methname, G_SCALAR);
925 }
926 else {
927 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
928 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
929 * wrong error message, and worse case, supreme action at a distance.
930 * (Sorry obfuscation writers. You're not going to be given this one.)
931 */
932 stash = gv_stashsv(*MARK, 0);
933 if (!stash) {
934 if (SvROK(*MARK))
935 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\"",
936 methname, SVfARG(*MARK));
937 else if (isGV(*MARK)) {
938 /* If the glob doesn't name an existing package, using
939 * SVfARG(*MARK) would yield "*Foo::Bar" or *main::Foo. So
940 * generate the name for the error message explicitly. */
941 SV *stashname = sv_2mortal(newSV(0));
942 gv_fullname4(stashname, (GV *) *MARK, NULL, FALSE);
943 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\"",
944 methname, SVfARG(stashname));
945 }
946 else {
947 SV *stashname = !SvPOK(*MARK) ? &PL_sv_no
948 : SvCUR(*MARK) ? *MARK
949 : sv_2mortal(newSVpvs("main"));
950 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\""
951 " (perhaps you forgot to load \"%" SVf "\"?)",
952 methname, SVfARG(stashname), SVfARG(stashname));
953 }
954 }
955 else if (!(gv = gv_fetchmethod(stash, methname))) {
956 /* The effective name can only be NULL for stashes that have
957 * been deleted from the symbol table, which this one can't
958 * be, since we just looked it up by name.
959 */
960 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" HEKf "\"",
961 methname, HvENAME_HEK_NN(stash));
962 }
963 ENTER_with_name("call_TIE");
964 PUSHSTACKi(PERLSI_MAGIC);
965 PUSHMARK(SP);
966 EXTEND(SP,(I32)items);
967 while (items--)
968 PUSHs(*MARK++);
969 PUTBACK;
970 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
971 }
972 SPAGAIN;
973
974 sv = TOPs;
975 POPSTACK;
976 if (sv_isobject(sv)) {
977 sv_unmagic(varsv, how);
978 /* Croak if a self-tie on an aggregate is attempted. */
979 if (varsv == SvRV(sv) &&
980 (SvTYPE(varsv) == SVt_PVAV ||
981 SvTYPE(varsv) == SVt_PVHV))
982 Perl_croak(aTHX_
983 "Self-ties of arrays and hashes are not supported");
984 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
985 }
986 LEAVE_with_name("call_TIE");
987 SP = PL_stack_base + markoff;
988 PUSHs(sv);
989 RETURN;
990 }
991
992
993 /* also used for: pp_dbmclose() */
994
PP(pp_untie)995 PP(pp_untie)
996 {
997 dSP;
998 MAGIC *mg;
999 SV *sv = POPs;
1000 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1001 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1002
1003 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1004 RETPUSHYES;
1005
1006 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
1007 !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
1008
1009 if ((mg = SvTIED_mg(sv, how))) {
1010 SV * const obj = SvRV(SvTIED_obj(sv, mg));
1011 if (obj && SvSTASH(obj)) {
1012 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
1013 CV *cv;
1014 if (gv && isGV(gv) && (cv = GvCV(gv))) {
1015 PUSHMARK(SP);
1016 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
1017 mXPUSHi(SvREFCNT(obj) - 1);
1018 PUTBACK;
1019 ENTER_with_name("call_UNTIE");
1020 call_sv(MUTABLE_SV(cv), G_VOID);
1021 LEAVE_with_name("call_UNTIE");
1022 SPAGAIN;
1023 }
1024 else if (mg && SvREFCNT(obj) > 1) {
1025 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
1026 "untie attempted while %" UVuf " inner references still exist",
1027 (UV)SvREFCNT(obj) - 1 ) ;
1028 }
1029 }
1030 }
1031 sv_unmagic(sv, how) ;
1032
1033 if (SvTYPE(sv) == SVt_PVHV) {
1034 /* If the tied hash was partway through iteration, free the iterator and
1035 * any key that it is pointing to. */
1036 HE *entry;
1037 if (HvLAZYDEL(sv) && (entry = HvEITER_get((HV *)sv))) {
1038 HvLAZYDEL_off(sv);
1039 hv_free_ent((HV *)sv, entry);
1040 HvEITER_set(MUTABLE_HV(sv), 0);
1041 }
1042 }
1043
1044 RETPUSHYES;
1045 }
1046
PP(pp_tied)1047 PP(pp_tied)
1048 {
1049 dSP;
1050 const MAGIC *mg;
1051 dTOPss;
1052 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1053 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1054
1055 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1056 goto ret_undef;
1057
1058 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
1059 !(sv = defelem_target(sv, NULL))) goto ret_undef;
1060
1061 if ((mg = SvTIED_mg(sv, how))) {
1062 SETs(SvTIED_obj(sv, mg));
1063 return NORMAL; /* PUTBACK not needed, pp_tied never moves SP */
1064 }
1065 ret_undef:
1066 SETs(&PL_sv_undef);
1067 return NORMAL;
1068 }
1069
PP(pp_dbmopen)1070 PP(pp_dbmopen)
1071 {
1072 dSP;
1073 dPOPPOPssrl;
1074 HV* stash;
1075 GV *gv = NULL;
1076
1077 HV * const hv = MUTABLE_HV(POPs);
1078 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
1079 stash = gv_stashsv(sv, 0);
1080 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
1081 PUTBACK;
1082 require_pv("AnyDBM_File.pm");
1083 SPAGAIN;
1084 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
1085 DIE(aTHX_ "No dbm on this machine");
1086 }
1087
1088 ENTER;
1089 PUSHMARK(SP);
1090
1091 EXTEND(SP, 5);
1092 PUSHs(sv);
1093 PUSHs(left);
1094 if (SvIV(right))
1095 mPUSHu(O_RDWR|O_CREAT);
1096 else
1097 {
1098 mPUSHu(O_RDWR);
1099 if (!SvOK(right)) right = &PL_sv_no;
1100 }
1101 PUSHs(right);
1102 PUTBACK;
1103 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1104 SPAGAIN;
1105
1106 if (!sv_isobject(TOPs)) {
1107 SP--;
1108 PUSHMARK(SP);
1109 PUSHs(sv);
1110 PUSHs(left);
1111 mPUSHu(O_RDONLY);
1112 PUSHs(right);
1113 PUTBACK;
1114 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1115 SPAGAIN;
1116 if (sv_isobject(TOPs))
1117 goto retie;
1118 }
1119 else {
1120 retie:
1121 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1122 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1123 }
1124 LEAVE;
1125 RETURN;
1126 }
1127
PP(pp_sselect)1128 PP(pp_sselect)
1129 {
1130 #ifdef HAS_SELECT
1131 dSP; dTARGET;
1132 I32 i;
1133 I32 j;
1134 char *s;
1135 SV *sv;
1136 NV value;
1137 I32 maxlen = 0;
1138 I32 nfound;
1139 struct timeval timebuf;
1140 struct timeval *tbuf = &timebuf;
1141 I32 growsize;
1142 char *fd_sets[4];
1143 SV *svs[4];
1144 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1145 I32 masksize;
1146 I32 offset;
1147 I32 k;
1148
1149 # if BYTEORDER & 0xf0000
1150 # define ORDERBYTE (0x88888888 - BYTEORDER)
1151 # else
1152 # define ORDERBYTE (0x4444 - BYTEORDER)
1153 # endif
1154
1155 #endif
1156
1157 SP -= 4;
1158 for (i = 1; i <= 3; i++) {
1159 SV * const sv = svs[i] = SP[i];
1160 SvGETMAGIC(sv);
1161 if (!SvOK(sv))
1162 continue;
1163 if (SvREADONLY(sv)) {
1164 if (!(SvPOK(sv) && SvCUR(sv) == 0))
1165 Perl_croak_no_modify();
1166 }
1167 else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
1168 if (!SvPOK(sv)) {
1169 if (!SvPOKp(sv))
1170 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1171 "Non-string passed as bitmask");
1172 if (SvGAMAGIC(sv)) {
1173 svs[i] = sv_newmortal();
1174 sv_copypv_nomg(svs[i], sv);
1175 }
1176 else
1177 SvPV_force_nomg_nolen(sv); /* force string conversion */
1178 }
1179 j = SvCUR(svs[i]);
1180 if (maxlen < j)
1181 maxlen = j;
1182 }
1183
1184 /* little endians can use vecs directly */
1185 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1186 # ifdef NFDBITS
1187
1188 # ifndef NBBY
1189 # define NBBY 8
1190 # endif
1191
1192 masksize = NFDBITS / NBBY;
1193 # else
1194 masksize = sizeof(long); /* documented int, everyone seems to use long */
1195 # endif
1196 Zero(&fd_sets[0], 4, char*);
1197 #endif
1198
1199 # if SELECT_MIN_BITS == 1
1200 growsize = sizeof(fd_set);
1201 # else
1202 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1203 # undef SELECT_MIN_BITS
1204 # define SELECT_MIN_BITS __FD_SETSIZE
1205 # endif
1206 /* If SELECT_MIN_BITS is greater than one we most probably will want
1207 * to align the sizes with SELECT_MIN_BITS/8 because for example
1208 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1209 * UNIX, Solaris, Darwin) the smallest quantum select() operates
1210 * on (sets/tests/clears bits) is 32 bits. */
1211 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1212 # endif
1213
1214 sv = SP[4];
1215 SvGETMAGIC(sv);
1216 if (SvOK(sv)) {
1217 value = SvNV_nomg(sv);
1218 if (value < 0.0)
1219 value = 0.0;
1220 timebuf.tv_sec = (long)value;
1221 value -= (NV)timebuf.tv_sec;
1222 timebuf.tv_usec = (long)(value * 1000000.0);
1223 }
1224 else
1225 tbuf = NULL;
1226
1227 for (i = 1; i <= 3; i++) {
1228 sv = svs[i];
1229 if (!SvOK(sv) || SvCUR(sv) == 0) {
1230 fd_sets[i] = 0;
1231 continue;
1232 }
1233 assert(SvPOK(sv));
1234 j = SvLEN(sv);
1235 if (j < growsize) {
1236 Sv_Grow(sv, growsize);
1237 }
1238 j = SvCUR(sv);
1239 s = SvPVX(sv) + j;
1240 while (++j <= growsize) {
1241 *s++ = '\0';
1242 }
1243
1244 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1245 s = SvPVX(sv);
1246 Newx(fd_sets[i], growsize, char);
1247 for (offset = 0; offset < growsize; offset += masksize) {
1248 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1249 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1250 }
1251 #else
1252 fd_sets[i] = SvPVX(sv);
1253 #endif
1254 }
1255
1256 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1257 /* Can't make just the (void*) conditional because that would be
1258 * cpp #if within cpp macro, and not all compilers like that. */
1259 nfound = PerlSock_select(
1260 maxlen * 8,
1261 (Select_fd_set_t) fd_sets[1],
1262 (Select_fd_set_t) fd_sets[2],
1263 (Select_fd_set_t) fd_sets[3],
1264 (void*) tbuf); /* Workaround for compiler bug. */
1265 #else
1266 nfound = PerlSock_select(
1267 maxlen * 8,
1268 (Select_fd_set_t) fd_sets[1],
1269 (Select_fd_set_t) fd_sets[2],
1270 (Select_fd_set_t) fd_sets[3],
1271 tbuf);
1272 #endif
1273 for (i = 1; i <= 3; i++) {
1274 if (fd_sets[i]) {
1275 sv = svs[i];
1276 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1277 s = SvPVX(sv);
1278 for (offset = 0; offset < growsize; offset += masksize) {
1279 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1280 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1281 }
1282 Safefree(fd_sets[i]);
1283 #endif
1284 if (sv != SP[i])
1285 SvSetMagicSV(SP[i], sv);
1286 else
1287 SvSETMAGIC(sv);
1288 }
1289 }
1290
1291 PUSHi(nfound);
1292 if (GIMME_V == G_LIST && tbuf) {
1293 value = (NV)(timebuf.tv_sec) +
1294 (NV)(timebuf.tv_usec) / 1000000.0;
1295 mPUSHn(value);
1296 }
1297 RETURN;
1298 #else
1299 DIE(aTHX_ "select not implemented");
1300 #endif
1301 }
1302
1303 /*
1304
1305 =for apidoc_section $GV
1306
1307 =for apidoc setdefout
1308
1309 Sets C<PL_defoutgv>, the default file handle for output, to the passed in
1310 typeglob. As C<PL_defoutgv> "owns" a reference on its typeglob, the reference
1311 count of the passed in typeglob is increased by one, and the reference count
1312 of the typeglob that C<PL_defoutgv> points to is decreased by one.
1313
1314 =cut
1315 */
1316
1317 void
Perl_setdefout(pTHX_ GV * gv)1318 Perl_setdefout(pTHX_ GV *gv)
1319 {
1320 GV *oldgv = PL_defoutgv;
1321
1322 PERL_ARGS_ASSERT_SETDEFOUT;
1323
1324 SvREFCNT_inc_simple_void_NN(gv);
1325 PL_defoutgv = gv;
1326 SvREFCNT_dec(oldgv);
1327 }
1328
PP(pp_select)1329 PP(pp_select)
1330 {
1331 dSP; dTARGET;
1332 HV *hv;
1333 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1334 GV * egv = GvEGVx(PL_defoutgv);
1335 GV * const *gvp;
1336
1337 if (!egv)
1338 egv = PL_defoutgv;
1339 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1340 gvp = hv && HvENAME(hv)
1341 ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
1342 : NULL;
1343 if (gvp && *gvp == egv) {
1344 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1345 XPUSHTARG;
1346 }
1347 else {
1348 mXPUSHs(newRV(MUTABLE_SV(egv)));
1349 }
1350
1351 if (newdefout) {
1352 if (!GvIO(newdefout))
1353 gv_IOadd(newdefout);
1354 setdefout(newdefout);
1355 }
1356
1357 RETURN;
1358 }
1359
PP(pp_getc)1360 PP(pp_getc)
1361 {
1362 dSP; dTARGET;
1363 /* pp_coreargs pushes a NULL to indicate no args passed to
1364 * CORE::getc() */
1365 GV * const gv =
1366 MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
1367 IO *const io = GvIO(gv);
1368
1369 if (MAXARG == 0)
1370 EXTEND(SP, 1);
1371
1372 if (io) {
1373 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1374 if (mg) {
1375 const U8 gimme = GIMME_V;
1376 Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0);
1377 if (gimme == G_SCALAR) {
1378 SPAGAIN;
1379 SvSetMagicSV_nosteal(TARG, TOPs);
1380 }
1381 return NORMAL;
1382 }
1383 }
1384 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1385 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1386 report_evil_fh(gv);
1387 SETERRNO(EBADF,RMS_IFI);
1388 RETPUSHUNDEF;
1389 }
1390 TAINT;
1391 sv_setpvs(TARG, " ");
1392 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1393 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1394 /* Find out how many bytes the char needs */
1395 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1396 if (len > 1) {
1397 SvGROW(TARG,len+1);
1398 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1399 SvCUR_set(TARG,1+len);
1400 }
1401 SvUTF8_on(TARG);
1402 }
1403 else SvUTF8_off(TARG);
1404 PUSHTARG;
1405 RETURN;
1406 }
1407
1408 STATIC OP *
S_doform(pTHX_ CV * cv,GV * gv,OP * retop)1409 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1410 {
1411 PERL_CONTEXT *cx;
1412 const U8 gimme = GIMME_V;
1413
1414 PERL_ARGS_ASSERT_DOFORM;
1415
1416 if (CvCLONE(cv))
1417 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1418
1419 cx = cx_pushblock(CXt_FORMAT, gimme, PL_stack_sp, PL_savestack_ix);
1420 cx_pushformat(cx, cv, retop, gv);
1421 if (CvDEPTH(cv) >= 2)
1422 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1423 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1424
1425 setdefout(gv); /* locally select filehandle so $% et al work */
1426 return CvSTART(cv);
1427 }
1428
PP(pp_enterwrite)1429 PP(pp_enterwrite)
1430 {
1431 dSP;
1432 GV *gv;
1433 IO *io;
1434 GV *fgv;
1435 CV *cv = NULL;
1436
1437 if (MAXARG == 0) {
1438 EXTEND(SP, 1);
1439 gv = PL_defoutgv;
1440 }
1441 else {
1442 gv = MUTABLE_GV(POPs);
1443 if (!gv)
1444 gv = PL_defoutgv;
1445 }
1446 io = GvIO(gv);
1447 if (!io) {
1448 RETPUSHNO;
1449 }
1450 if (IoFMT_GV(io))
1451 fgv = IoFMT_GV(io);
1452 else
1453 fgv = gv;
1454
1455 assert(fgv);
1456
1457 cv = GvFORM(fgv);
1458 if (!cv) {
1459 SV * const tmpsv = sv_newmortal();
1460 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1461 DIE(aTHX_ "Undefined format \"%" SVf "\" called", SVfARG(tmpsv));
1462 }
1463 IoFLAGS(io) &= ~IOf_DIDTOP;
1464 RETURNOP(doform(cv,gv,PL_op->op_next));
1465 }
1466
PP(pp_leavewrite)1467 PP(pp_leavewrite)
1468 {
1469 dSP;
1470 GV * const gv = CX_CUR()->blk_format.gv;
1471 IO * const io = GvIOp(gv);
1472 PerlIO *ofp;
1473 PerlIO *fp;
1474 PERL_CONTEXT *cx;
1475 OP *retop;
1476 bool is_return = cBOOL(PL_op->op_type == OP_RETURN);
1477
1478 if (is_return || !io || !(ofp = IoOFP(io)))
1479 goto forget_top;
1480
1481 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1482 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1483
1484 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1485 PL_formtarget != PL_toptarget)
1486 {
1487 GV *fgv;
1488 CV *cv;
1489 if (!IoTOP_GV(io)) {
1490 GV *topgv;
1491
1492 if (!IoTOP_NAME(io)) {
1493 SV *topname;
1494 if (!IoFMT_NAME(io))
1495 IoFMT_NAME(io) = savepv(GvNAME(gv));
1496 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%" HEKf "_TOP",
1497 HEKfARG(GvNAME_HEK(gv))));
1498 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1499 if ((topgv && GvFORM(topgv)) ||
1500 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1501 IoTOP_NAME(io) = savesvpv(topname);
1502 else
1503 IoTOP_NAME(io) = savepvs("top");
1504 }
1505 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1506 if (!topgv || !GvFORM(topgv)) {
1507 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1508 goto forget_top;
1509 }
1510 IoTOP_GV(io) = topgv;
1511 }
1512 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1513 I32 lines = IoLINES_LEFT(io);
1514 const char *s = SvPVX_const(PL_formtarget);
1515 const char *e = SvEND(PL_formtarget);
1516 if (lines <= 0) /* Yow, header didn't even fit!!! */
1517 goto forget_top;
1518 while (lines-- > 0) {
1519 s = (char *) memchr(s, '\n', e - s);
1520 if (!s)
1521 break;
1522 s++;
1523 }
1524 if (s) {
1525 const STRLEN save = SvCUR(PL_formtarget);
1526 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1527 do_print(PL_formtarget, ofp);
1528 SvCUR_set(PL_formtarget, save);
1529 sv_chop(PL_formtarget, s);
1530 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1531 }
1532 }
1533 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1534 do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
1535 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1536 IoPAGE(io)++;
1537 PL_formtarget = PL_toptarget;
1538 IoFLAGS(io) |= IOf_DIDTOP;
1539 fgv = IoTOP_GV(io);
1540 assert(fgv); /* IoTOP_GV(io) should have been set above */
1541 cv = GvFORM(fgv);
1542 if (!cv) {
1543 SV * const sv = sv_newmortal();
1544 gv_efullname4(sv, fgv, NULL, FALSE);
1545 DIE(aTHX_ "Undefined top format \"%" SVf "\" called", SVfARG(sv));
1546 }
1547 return doform(cv, gv, PL_op);
1548 }
1549
1550 forget_top:
1551 cx = CX_CUR();
1552 assert(CxTYPE(cx) == CXt_FORMAT);
1553 SP = PL_stack_base + cx->blk_oldsp; /* ignore retval of formline */
1554 CX_LEAVE_SCOPE(cx);
1555 cx_popformat(cx);
1556 cx_popblock(cx);
1557 retop = cx->blk_sub.retop;
1558 CX_POP(cx);
1559
1560 EXTEND(SP, 1);
1561
1562 if (is_return)
1563 /* XXX the semantics of doing 'return' in a format aren't documented.
1564 * Currently we ignore any args to 'return' and just return
1565 * a single undef in both scalar and list contexts
1566 */
1567 PUSHs(&PL_sv_undef);
1568 else if (!io || !(fp = IoOFP(io))) {
1569 if (io && IoIFP(io))
1570 report_wrongway_fh(gv, '<');
1571 else
1572 report_evil_fh(gv);
1573 PUSHs(&PL_sv_no);
1574 }
1575 else {
1576 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1577 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1578 }
1579 if (!do_print(PL_formtarget, fp))
1580 PUSHs(&PL_sv_no);
1581 else {
1582 FmLINES(PL_formtarget) = 0;
1583 SvCUR_set(PL_formtarget, 0);
1584 *SvEND(PL_formtarget) = '\0';
1585 if (IoFLAGS(io) & IOf_FLUSH)
1586 (void)PerlIO_flush(fp);
1587 PUSHs(&PL_sv_yes);
1588 }
1589 }
1590 PL_formtarget = PL_bodytarget;
1591 RETURNOP(retop);
1592 }
1593
PP(pp_prtf)1594 PP(pp_prtf)
1595 {
1596 dSP; dMARK; dORIGMARK;
1597 PerlIO *fp;
1598
1599 GV * const gv
1600 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1601 IO *const io = GvIO(gv);
1602
1603 /* Treat empty list as "" */
1604 if (MARK == SP) XPUSHs(&PL_sv_no);
1605
1606 if (io) {
1607 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1608 if (mg) {
1609 if (MARK == ORIGMARK) {
1610 MEXTEND(SP, 1);
1611 ++MARK;
1612 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1613 ++SP;
1614 }
1615 return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
1616 mg,
1617 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1618 sp - mark);
1619 }
1620 }
1621
1622 if (!io) {
1623 report_evil_fh(gv);
1624 SETERRNO(EBADF,RMS_IFI);
1625 goto just_say_no;
1626 }
1627 else if (!(fp = IoOFP(io))) {
1628 if (IoIFP(io))
1629 report_wrongway_fh(gv, '<');
1630 else if (ckWARN(WARN_CLOSED))
1631 report_evil_fh(gv);
1632 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1633 goto just_say_no;
1634 }
1635 else {
1636 SV *sv = sv_newmortal();
1637 do_sprintf(sv, SP - MARK, MARK + 1);
1638 if (!do_print(sv, fp))
1639 goto just_say_no;
1640
1641 if (IoFLAGS(io) & IOf_FLUSH)
1642 if (PerlIO_flush(fp) == EOF)
1643 goto just_say_no;
1644 }
1645 SP = ORIGMARK;
1646 PUSHs(&PL_sv_yes);
1647 RETURN;
1648
1649 just_say_no:
1650 SP = ORIGMARK;
1651 PUSHs(&PL_sv_undef);
1652 RETURN;
1653 }
1654
PP(pp_sysopen)1655 PP(pp_sysopen)
1656 {
1657 dSP;
1658 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1659 const int mode = POPi;
1660 SV * const sv = POPs;
1661 GV * const gv = MUTABLE_GV(POPs);
1662 STRLEN len;
1663
1664 /* Need TIEHANDLE method ? */
1665 const char * const tmps = SvPV_const(sv, len);
1666 if (do_open_raw(gv, tmps, len, mode, perm, NULL)) {
1667 IoLINES(GvIOp(gv)) = 0;
1668 PUSHs(&PL_sv_yes);
1669 }
1670 else {
1671 PUSHs(&PL_sv_undef);
1672 }
1673 RETURN;
1674 }
1675
1676
1677 /* also used for: pp_read() and pp_recv() (where supported) */
1678
PP(pp_sysread)1679 PP(pp_sysread)
1680 {
1681 dSP; dMARK; dORIGMARK; dTARGET;
1682 SSize_t offset;
1683 IO *io;
1684 char *buffer;
1685 STRLEN orig_size;
1686 SSize_t length;
1687 SSize_t count;
1688 SV *bufsv;
1689 STRLEN blen;
1690 int fp_utf8;
1691 int buffer_utf8;
1692 SV *read_target;
1693 Size_t got = 0;
1694 Size_t wanted;
1695 bool charstart = FALSE;
1696 STRLEN charskip = 0;
1697 STRLEN skip = 0;
1698 GV * const gv = MUTABLE_GV(*++MARK);
1699 int fd;
1700
1701 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1702 && gv && (io = GvIO(gv)) )
1703 {
1704 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1705 if (mg) {
1706 return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg,
1707 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1708 sp - mark);
1709 }
1710 }
1711
1712 if (!gv)
1713 goto say_undef;
1714 bufsv = *++MARK;
1715 if (! SvOK(bufsv))
1716 SvPVCLEAR(bufsv);
1717 length = SvIVx(*++MARK);
1718 if (length < 0)
1719 DIE(aTHX_ "Negative length");
1720 SETERRNO(0,0);
1721 if (MARK < SP)
1722 offset = SvIVx(*++MARK);
1723 else
1724 offset = 0;
1725 io = GvIO(gv);
1726 if (!io || !IoIFP(io)) {
1727 report_evil_fh(gv);
1728 SETERRNO(EBADF,RMS_IFI);
1729 goto say_undef;
1730 }
1731
1732 /* Note that fd can here validly be -1, don't check it yet. */
1733 fd = PerlIO_fileno(IoIFP(io));
1734
1735 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1736 if (PL_op->op_type == OP_SYSREAD || PL_op->op_type == OP_RECV) {
1737 Perl_croak(aTHX_
1738 "%s() isn't allowed on :utf8 handles",
1739 OP_DESC(PL_op));
1740 }
1741 buffer = SvPVutf8_force(bufsv, blen);
1742 /* UTF-8 may not have been set if they are all low bytes */
1743 SvUTF8_on(bufsv);
1744 buffer_utf8 = 0;
1745 }
1746 else {
1747 buffer = SvPV_force(bufsv, blen);
1748 buffer_utf8 = DO_UTF8(bufsv);
1749 }
1750 if (DO_UTF8(bufsv)) {
1751 blen = sv_len_utf8_nomg(bufsv);
1752 }
1753
1754 charstart = TRUE;
1755 charskip = 0;
1756 skip = 0;
1757 wanted = length;
1758
1759 #ifdef HAS_SOCKET
1760 if (PL_op->op_type == OP_RECV) {
1761 Sock_size_t bufsize;
1762 char namebuf[MAXPATHLEN];
1763 if (fd < 0) {
1764 SETERRNO(EBADF,SS_IVCHAN);
1765 goto say_undef;
1766 }
1767 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
1768 bufsize = sizeof (struct sockaddr_in);
1769 #else
1770 bufsize = sizeof namebuf;
1771 #endif
1772 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1773 if (bufsize >= 256)
1774 bufsize = 255;
1775 #endif
1776 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1777 /* 'offset' means 'flags' here */
1778 count = PerlSock_recvfrom(fd, buffer, length, offset,
1779 (struct sockaddr *)namebuf, &bufsize);
1780 if (count < 0)
1781 goto say_undef;
1782 /* MSG_TRUNC can give oversized count; quietly lose it */
1783 if (count > length)
1784 count = length;
1785 SvCUR_set(bufsv, count);
1786 *SvEND(bufsv) = '\0';
1787 (void)SvPOK_only(bufsv);
1788 if (fp_utf8)
1789 SvUTF8_on(bufsv);
1790 SvSETMAGIC(bufsv);
1791 /* This should not be marked tainted if the fp is marked clean */
1792 if (!(IoFLAGS(io) & IOf_UNTAINT))
1793 SvTAINTED_on(bufsv);
1794 SP = ORIGMARK;
1795 #if defined(__CYGWIN__)
1796 /* recvfrom() on cygwin doesn't set bufsize at all for
1797 connected sockets, leaving us with trash in the returned
1798 name, so use the same test as the Win32 code to check if it
1799 wasn't set, and set it [perl #118843] */
1800 if (bufsize == sizeof namebuf)
1801 bufsize = 0;
1802 #endif
1803 sv_setpvn(TARG, namebuf, bufsize);
1804 PUSHs(TARG);
1805 RETURN;
1806 }
1807 #endif
1808 if (offset < 0) {
1809 if (-offset > (SSize_t)blen)
1810 DIE(aTHX_ "Offset outside string");
1811 offset += blen;
1812 }
1813 if (DO_UTF8(bufsv)) {
1814 /* convert offset-as-chars to offset-as-bytes */
1815 if (offset >= (SSize_t)blen)
1816 offset += SvCUR(bufsv) - blen;
1817 else
1818 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1819 }
1820
1821 more_bytes:
1822 /* Reestablish the fd in case it shifted from underneath us. */
1823 fd = PerlIO_fileno(IoIFP(io));
1824
1825 orig_size = SvCUR(bufsv);
1826 /* Allocating length + offset + 1 isn't perfect in the case of reading
1827 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1828 unduly.
1829 (should be 2 * length + offset + 1, or possibly something longer if
1830 IN_ENCODING Is true) */
1831 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1832 if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1833 Zero(buffer+orig_size, offset-orig_size, char);
1834 }
1835 buffer = buffer + offset;
1836 if (!buffer_utf8) {
1837 read_target = bufsv;
1838 } else {
1839 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1840 concatenate it to the current buffer. */
1841
1842 /* Truncate the existing buffer to the start of where we will be
1843 reading to: */
1844 SvCUR_set(bufsv, offset);
1845
1846 read_target = sv_newmortal();
1847 SvUPGRADE(read_target, SVt_PV);
1848 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1849 }
1850
1851 if (PL_op->op_type == OP_SYSREAD) {
1852 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1853 if (IoTYPE(io) == IoTYPE_SOCKET) {
1854 if (fd < 0) {
1855 SETERRNO(EBADF,SS_IVCHAN);
1856 count = -1;
1857 }
1858 else
1859 count = PerlSock_recv(fd, buffer, length, 0);
1860 }
1861 else
1862 #endif
1863 {
1864 if (fd < 0) {
1865 SETERRNO(EBADF,RMS_IFI);
1866 count = -1;
1867 }
1868 else
1869 count = PerlLIO_read(fd, buffer, length);
1870 }
1871 }
1872 else
1873 {
1874 count = PerlIO_read(IoIFP(io), buffer, length);
1875 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1876 if (count == 0 && PerlIO_error(IoIFP(io)))
1877 count = -1;
1878 }
1879 if (count < 0) {
1880 if (IoTYPE(io) == IoTYPE_WRONLY)
1881 report_wrongway_fh(gv, '>');
1882 goto say_undef;
1883 }
1884 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1885 *SvEND(read_target) = '\0';
1886 (void)SvPOK_only(read_target);
1887 if (fp_utf8 && !IN_BYTES) {
1888 /* Look at utf8 we got back and count the characters */
1889 const char *bend = buffer + count;
1890 while (buffer < bend) {
1891 if (charstart) {
1892 skip = UTF8SKIP(buffer);
1893 charskip = 0;
1894 }
1895 if (buffer - charskip + skip > bend) {
1896 /* partial character - try for rest of it */
1897 length = skip - (bend-buffer);
1898 offset = bend - SvPVX_const(bufsv);
1899 charstart = FALSE;
1900 charskip += count;
1901 goto more_bytes;
1902 }
1903 else {
1904 got++;
1905 buffer += skip;
1906 charstart = TRUE;
1907 charskip = 0;
1908 }
1909 }
1910 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1911 provided amount read (count) was what was requested (length)
1912 */
1913 if (got < wanted && count == length) {
1914 length = wanted - got;
1915 offset = bend - SvPVX_const(bufsv);
1916 goto more_bytes;
1917 }
1918 /* return value is character count */
1919 count = got;
1920 SvUTF8_on(bufsv);
1921 }
1922 else if (buffer_utf8) {
1923 /* Let svcatsv upgrade the bytes we read in to utf8.
1924 The buffer is a mortal so will be freed soon. */
1925 sv_catsv_nomg(bufsv, read_target);
1926 }
1927 SvSETMAGIC(bufsv);
1928 /* This should not be marked tainted if the fp is marked clean */
1929 if (!(IoFLAGS(io) & IOf_UNTAINT))
1930 SvTAINTED_on(bufsv);
1931 SP = ORIGMARK;
1932 PUSHi(count);
1933 RETURN;
1934
1935 say_undef:
1936 SP = ORIGMARK;
1937 RETPUSHUNDEF;
1938 }
1939
1940
1941 /* also used for: pp_send() where defined */
1942
PP(pp_syswrite)1943 PP(pp_syswrite)
1944 {
1945 dSP; dMARK; dORIGMARK; dTARGET;
1946 SV *bufsv;
1947 const char *buffer;
1948 SSize_t retval;
1949 STRLEN blen;
1950 const int op_type = PL_op->op_type;
1951 bool doing_utf8;
1952 U8 *tmpbuf = NULL;
1953 GV *const gv = MUTABLE_GV(*++MARK);
1954 IO *const io = GvIO(gv);
1955 int fd;
1956
1957 if (op_type == OP_SYSWRITE && io) {
1958 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1959 if (mg) {
1960 if (MARK == SP - 1) {
1961 SV *sv = *SP;
1962 mXPUSHi(sv_len(sv));
1963 PUTBACK;
1964 }
1965
1966 return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
1967 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1968 sp - mark);
1969 }
1970 }
1971 if (!gv)
1972 goto say_undef;
1973
1974 bufsv = *++MARK;
1975
1976 SETERRNO(0,0);
1977 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1978 retval = -1;
1979 if (io && IoIFP(io))
1980 report_wrongway_fh(gv, '<');
1981 else
1982 report_evil_fh(gv);
1983 SETERRNO(EBADF,RMS_IFI);
1984 goto say_undef;
1985 }
1986 fd = PerlIO_fileno(IoIFP(io));
1987 if (fd < 0) {
1988 SETERRNO(EBADF,SS_IVCHAN);
1989 retval = -1;
1990 goto say_undef;
1991 }
1992
1993 /* Do this first to trigger any overloading. */
1994 buffer = SvPV_const(bufsv, blen);
1995 doing_utf8 = DO_UTF8(bufsv);
1996
1997 if (PerlIO_isutf8(IoIFP(io))) {
1998 Perl_croak(aTHX_
1999 "%s() isn't allowed on :utf8 handles",
2000 OP_DESC(PL_op));
2001 }
2002 else if (doing_utf8) {
2003 STRLEN tmplen = blen;
2004 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
2005 if (!doing_utf8) {
2006 tmpbuf = result;
2007 buffer = (char *) tmpbuf;
2008 blen = tmplen;
2009 }
2010 else {
2011 assert((char *)result == buffer);
2012 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
2013 }
2014 }
2015
2016 #ifdef HAS_SOCKET
2017 if (op_type == OP_SEND) {
2018 const int flags = SvIVx(*++MARK);
2019 if (SP > MARK) {
2020 STRLEN mlen;
2021 char * const sockbuf = SvPVx(*++MARK, mlen);
2022 retval = PerlSock_sendto(fd, buffer, blen,
2023 flags, (struct sockaddr *)sockbuf, mlen);
2024 }
2025 else {
2026 retval = PerlSock_send(fd, buffer, blen, flags);
2027 }
2028 }
2029 else
2030 #endif
2031 {
2032 Size_t length = 0; /* This length is in characters. */
2033 IV offset;
2034
2035 if (MARK >= SP) {
2036 length = blen;
2037 } else {
2038 #if Size_t_size > IVSIZE
2039 length = (Size_t)SvNVx(*++MARK);
2040 #else
2041 length = (Size_t)SvIVx(*++MARK);
2042 #endif
2043 if ((SSize_t)length < 0) {
2044 Safefree(tmpbuf);
2045 DIE(aTHX_ "Negative length");
2046 }
2047 }
2048
2049 if (MARK < SP) {
2050 offset = SvIVx(*++MARK);
2051 if (offset < 0) {
2052 if (-offset > (IV)blen) {
2053 Safefree(tmpbuf);
2054 DIE(aTHX_ "Offset outside string");
2055 }
2056 offset += blen;
2057 } else if (offset > (IV)blen) {
2058 Safefree(tmpbuf);
2059 DIE(aTHX_ "Offset outside string");
2060 }
2061 } else
2062 offset = 0;
2063 if (length > blen - offset)
2064 length = blen - offset;
2065 buffer = buffer+offset;
2066
2067 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2068 if (IoTYPE(io) == IoTYPE_SOCKET) {
2069 retval = PerlSock_send(fd, buffer, length, 0);
2070 }
2071 else
2072 #endif
2073 {
2074 /* See the note at doio.c:do_print about filesize limits. --jhi */
2075 retval = PerlLIO_write(fd, buffer, length);
2076 }
2077 }
2078
2079 if (retval < 0)
2080 goto say_undef;
2081 SP = ORIGMARK;
2082
2083 Safefree(tmpbuf);
2084 #if Size_t_size > IVSIZE
2085 PUSHn(retval);
2086 #else
2087 PUSHi(retval);
2088 #endif
2089 RETURN;
2090
2091 say_undef:
2092 Safefree(tmpbuf);
2093 SP = ORIGMARK;
2094 RETPUSHUNDEF;
2095 }
2096
PP(pp_eof)2097 PP(pp_eof)
2098 {
2099 dSP;
2100 GV *gv;
2101 IO *io;
2102 const MAGIC *mg;
2103 /*
2104 * in Perl 5.12 and later, the additional parameter is a bitmask:
2105 * 0 = eof
2106 * 1 = eof(FH)
2107 * 2 = eof() <- ARGV magic
2108 *
2109 * I'll rely on the compiler's trace flow analysis to decide whether to
2110 * actually assign this out here, or punt it into the only block where it is
2111 * used. Doing it out here is DRY on the condition logic.
2112 */
2113 unsigned int which;
2114
2115 if (MAXARG) {
2116 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2117 which = 1;
2118 }
2119 else {
2120 EXTEND(SP, 1);
2121
2122 if (PL_op->op_flags & OPf_SPECIAL) {
2123 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2124 which = 2;
2125 }
2126 else {
2127 gv = PL_last_in_gv; /* eof */
2128 which = 0;
2129 }
2130 }
2131
2132 if (!gv)
2133 RETPUSHYES;
2134
2135 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2136 return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
2137 }
2138
2139 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2140 if (io && !IoIFP(io)) {
2141 if ((IoFLAGS(io) & IOf_START) && av_count(GvAVn(gv)) == 0) {
2142 SV ** svp;
2143 IoLINES(io) = 0;
2144 IoFLAGS(io) &= ~IOf_START;
2145 do_open6(gv, "-", 1, NULL, NULL, 0);
2146 svp = &GvSV(gv);
2147 if (*svp) {
2148 SV * sv = *svp;
2149 sv_setpvs(sv, "-");
2150 SvSETMAGIC(sv);
2151 }
2152 else
2153 *svp = newSVpvs("-");
2154 }
2155 else if (!nextargv(gv, FALSE))
2156 RETPUSHYES;
2157 }
2158 }
2159
2160 PUSHs(boolSV(do_eof(gv)));
2161 RETURN;
2162 }
2163
PP(pp_tell)2164 PP(pp_tell)
2165 {
2166 dSP; dTARGET;
2167 GV *gv;
2168 IO *io;
2169
2170 if (MAXARG != 0 && (TOPs || POPs))
2171 PL_last_in_gv = MUTABLE_GV(POPs);
2172 else
2173 EXTEND(SP, 1);
2174 gv = PL_last_in_gv;
2175
2176 io = GvIO(gv);
2177 if (io) {
2178 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2179 if (mg) {
2180 return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
2181 }
2182 }
2183 else if (!gv) {
2184 if (!errno)
2185 SETERRNO(EBADF,RMS_IFI);
2186 PUSHi(-1);
2187 RETURN;
2188 }
2189
2190 #if LSEEKSIZE > IVSIZE
2191 PUSHn( (NV)do_tell(gv) );
2192 #else
2193 PUSHi( (IV)do_tell(gv) );
2194 #endif
2195 RETURN;
2196 }
2197
2198
2199 /* also used for: pp_seek() */
2200
PP(pp_sysseek)2201 PP(pp_sysseek)
2202 {
2203 dSP;
2204 const int whence = POPi;
2205 #if LSEEKSIZE > IVSIZE
2206 const Off_t offset = (Off_t)SvNVx(POPs);
2207 #else
2208 const Off_t offset = (Off_t)SvIVx(POPs);
2209 #endif
2210
2211 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2212 IO *const io = GvIO(gv);
2213
2214 if (io) {
2215 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2216 if (mg) {
2217 #if LSEEKSIZE > IVSIZE
2218 SV *const offset_sv = newSVnv((NV) offset);
2219 #else
2220 SV *const offset_sv = newSViv(offset);
2221 #endif
2222
2223 return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
2224 newSViv(whence));
2225 }
2226 }
2227
2228 if (PL_op->op_type == OP_SEEK)
2229 PUSHs(boolSV(do_seek(gv, offset, whence)));
2230 else {
2231 const Off_t sought = do_sysseek(gv, offset, whence);
2232 if (sought < 0)
2233 PUSHs(&PL_sv_undef);
2234 else {
2235 SV* const sv = sought ?
2236 #if LSEEKSIZE > IVSIZE
2237 newSVnv((NV)sought)
2238 #else
2239 newSViv(sought)
2240 #endif
2241 : newSVpvn(zero_but_true, ZBTLEN);
2242 mPUSHs(sv);
2243 }
2244 }
2245 RETURN;
2246 }
2247
PP(pp_truncate)2248 PP(pp_truncate)
2249 {
2250 dSP;
2251 /* There seems to be no consensus on the length type of truncate()
2252 * and ftruncate(), both off_t and size_t have supporters. In
2253 * general one would think that when using large files, off_t is
2254 * at least as wide as size_t, so using an off_t should be okay. */
2255 /* XXX Configure probe for the length type of *truncate() needed XXX */
2256 Off_t len;
2257
2258 #if Off_t_size > IVSIZE
2259 len = (Off_t)POPn;
2260 #else
2261 len = (Off_t)POPi;
2262 #endif
2263 /* Checking for length < 0 is problematic as the type might or
2264 * might not be signed: if it is not, clever compilers will moan. */
2265 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2266 SETERRNO(0,0);
2267 {
2268 SV * const sv = POPs;
2269 int result = 1;
2270 GV *tmpgv;
2271 IO *io;
2272
2273 if (PL_op->op_flags & OPf_SPECIAL
2274 ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2275 : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2276 io = GvIO(tmpgv);
2277 if (!io)
2278 result = 0;
2279 else {
2280 PerlIO *fp;
2281 do_ftruncate_io:
2282 TAINT_PROPER("truncate");
2283 if (!(fp = IoIFP(io))) {
2284 result = 0;
2285 }
2286 else {
2287 int fd = PerlIO_fileno(fp);
2288 if (fd < 0) {
2289 SETERRNO(EBADF,RMS_IFI);
2290 result = 0;
2291 } else {
2292 if (len < 0) {
2293 SETERRNO(EINVAL, LIB_INVARG);
2294 result = 0;
2295 } else {
2296 PerlIO_flush(fp);
2297 #ifdef HAS_TRUNCATE
2298 if (ftruncate(fd, len) < 0)
2299 #else
2300 if (my_chsize(fd, len) < 0)
2301 #endif
2302 result = 0;
2303 }
2304 }
2305 }
2306 }
2307 }
2308 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2309 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2310 goto do_ftruncate_io;
2311 }
2312 else {
2313 const char * const name = SvPV_nomg_const_nolen(sv);
2314 TAINT_PROPER("truncate");
2315 #ifdef HAS_TRUNCATE
2316 if (truncate(name, len) < 0)
2317 result = 0;
2318 #else
2319 {
2320 int mode = O_RDWR;
2321 int tmpfd;
2322
2323 #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
2324 mode |= O_LARGEFILE; /* Transparently largefiley. */
2325 #endif
2326 #ifdef O_BINARY
2327 /* On open(), the Win32 CRT tries to seek around text
2328 * files using 32-bit offsets, which causes the open()
2329 * to fail on large files, so open in binary mode.
2330 */
2331 mode |= O_BINARY;
2332 #endif
2333 tmpfd = PerlLIO_open_cloexec(name, mode);
2334
2335 if (tmpfd < 0) {
2336 result = 0;
2337 } else {
2338 if (my_chsize(tmpfd, len) < 0)
2339 result = 0;
2340 PerlLIO_close(tmpfd);
2341 }
2342 }
2343 #endif
2344 }
2345
2346 if (result)
2347 RETPUSHYES;
2348 if (!errno)
2349 SETERRNO(EBADF,RMS_IFI);
2350 RETPUSHUNDEF;
2351 }
2352 }
2353
2354
2355 /* also used for: pp_fcntl() */
2356
PP(pp_ioctl)2357 PP(pp_ioctl)
2358 {
2359 dSP; dTARGET;
2360 SV * const argsv = POPs;
2361 const unsigned int func = POPu;
2362 int optype;
2363 GV * const gv = MUTABLE_GV(POPs);
2364 IO * const io = GvIOn(gv);
2365 char *s;
2366 IV retval;
2367
2368 if (!IoIFP(io)) {
2369 report_evil_fh(gv);
2370 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2371 RETPUSHUNDEF;
2372 }
2373
2374 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2375 STRLEN len;
2376 STRLEN need;
2377 s = SvPV_force(argsv, len);
2378 need = IOCPARM_LEN(func);
2379 if (len < need) {
2380 s = Sv_Grow(argsv, need + 1);
2381 SvCUR_set(argsv, need);
2382 }
2383
2384 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2385 }
2386 else {
2387 retval = SvIV(argsv);
2388 s = INT2PTR(char*,retval); /* ouch */
2389 }
2390
2391 optype = PL_op->op_type;
2392 TAINT_PROPER(PL_op_desc[optype]);
2393
2394 if (optype == OP_IOCTL)
2395 #ifdef HAS_IOCTL
2396 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2397 #else
2398 DIE(aTHX_ "ioctl is not implemented");
2399 #endif
2400 else
2401 #ifndef HAS_FCNTL
2402 DIE(aTHX_ "fcntl is not implemented");
2403 #elif defined(OS2) && defined(__EMX__)
2404 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2405 #else
2406 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2407 #endif
2408
2409 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2410 if (SvPOK(argsv)) {
2411 if (s[SvCUR(argsv)] != 17)
2412 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2413 OP_NAME(PL_op));
2414 s[SvCUR(argsv)] = 0; /* put our null back */
2415 SvSETMAGIC(argsv); /* Assume it has changed */
2416 }
2417
2418 if (retval == -1)
2419 RETPUSHUNDEF;
2420 if (retval != 0) {
2421 PUSHi(retval);
2422 }
2423 else {
2424 PUSHp(zero_but_true, ZBTLEN);
2425 }
2426 #endif
2427 RETURN;
2428 }
2429
PP(pp_flock)2430 PP(pp_flock)
2431 {
2432 #ifdef FLOCK
2433 dSP; dTARGET;
2434 I32 value;
2435 const int argtype = POPi;
2436 GV * const gv = MUTABLE_GV(POPs);
2437 IO *const io = GvIO(gv);
2438 PerlIO *const fp = io ? IoIFP(io) : NULL;
2439
2440 /* XXX Looks to me like io is always NULL at this point */
2441 if (fp) {
2442 (void)PerlIO_flush(fp);
2443 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2444 }
2445 else {
2446 report_evil_fh(gv);
2447 value = 0;
2448 SETERRNO(EBADF,RMS_IFI);
2449 }
2450 PUSHi(value);
2451 RETURN;
2452 #else
2453 DIE(aTHX_ PL_no_func, "flock");
2454 #endif
2455 }
2456
2457 /* Sockets. */
2458
2459 #ifdef HAS_SOCKET
2460
PP(pp_socket)2461 PP(pp_socket)
2462 {
2463 dSP;
2464 const int protocol = POPi;
2465 const int type = POPi;
2466 const int domain = POPi;
2467 GV * const gv = MUTABLE_GV(POPs);
2468 IO * const io = GvIOn(gv);
2469 int fd;
2470
2471 if (IoIFP(io))
2472 do_close(gv, FALSE);
2473
2474 TAINT_PROPER("socket");
2475 fd = PerlSock_socket_cloexec(domain, type, protocol);
2476 if (fd < 0) {
2477 RETPUSHUNDEF;
2478 }
2479 IoIFP(io) = PerlIO_fdopen(fd, "r" SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2480 IoOFP(io) = PerlIO_fdopen(fd, "w" SOCKET_OPEN_MODE);
2481 IoTYPE(io) = IoTYPE_SOCKET;
2482 if (!IoIFP(io) || !IoOFP(io)) {
2483 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2484 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2485 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2486 RETPUSHUNDEF;
2487 }
2488
2489 RETPUSHYES;
2490 }
2491 #endif
2492
PP(pp_sockpair)2493 PP(pp_sockpair)
2494 {
2495 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2496 dSP;
2497 int fd[2];
2498 const int protocol = POPi;
2499 const int type = POPi;
2500 const int domain = POPi;
2501
2502 GV * const gv2 = MUTABLE_GV(POPs);
2503 IO * const io2 = GvIOn(gv2);
2504 GV * const gv1 = MUTABLE_GV(POPs);
2505 IO * const io1 = GvIOn(gv1);
2506
2507 if (IoIFP(io1))
2508 do_close(gv1, FALSE);
2509 if (IoIFP(io2))
2510 do_close(gv2, FALSE);
2511
2512 TAINT_PROPER("socketpair");
2513 if (PerlSock_socketpair_cloexec(domain, type, protocol, fd) < 0)
2514 RETPUSHUNDEF;
2515 IoIFP(io1) = PerlIO_fdopen(fd[0], "r" SOCKET_OPEN_MODE);
2516 IoOFP(io1) = PerlIO_fdopen(fd[0], "w" SOCKET_OPEN_MODE);
2517 IoTYPE(io1) = IoTYPE_SOCKET;
2518 IoIFP(io2) = PerlIO_fdopen(fd[1], "r" SOCKET_OPEN_MODE);
2519 IoOFP(io2) = PerlIO_fdopen(fd[1], "w" SOCKET_OPEN_MODE);
2520 IoTYPE(io2) = IoTYPE_SOCKET;
2521 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2522 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2523 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2524 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2525 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2526 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2527 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2528 RETPUSHUNDEF;
2529 }
2530
2531 RETPUSHYES;
2532 #else
2533 DIE(aTHX_ PL_no_sock_func, "socketpair");
2534 #endif
2535 }
2536
2537 #ifdef HAS_SOCKET
2538
2539 /* also used for: pp_connect() */
2540
PP(pp_bind)2541 PP(pp_bind)
2542 {
2543 dSP;
2544 SV * const addrsv = POPs;
2545 /* OK, so on what platform does bind modify addr? */
2546 const char *addr;
2547 GV * const gv = MUTABLE_GV(POPs);
2548 IO * const io = GvIOn(gv);
2549 STRLEN len;
2550 int op_type;
2551 int fd;
2552
2553 if (!IoIFP(io))
2554 goto nuts;
2555 fd = PerlIO_fileno(IoIFP(io));
2556 if (fd < 0)
2557 goto nuts;
2558
2559 addr = SvPV_const(addrsv, len);
2560 op_type = PL_op->op_type;
2561 TAINT_PROPER(PL_op_desc[op_type]);
2562 if ((op_type == OP_BIND
2563 ? PerlSock_bind(fd, (struct sockaddr *)addr, len)
2564 : PerlSock_connect(fd, (struct sockaddr *)addr, len))
2565 >= 0)
2566 RETPUSHYES;
2567 else
2568 RETPUSHUNDEF;
2569
2570 nuts:
2571 report_evil_fh(gv);
2572 SETERRNO(EBADF,SS_IVCHAN);
2573 RETPUSHUNDEF;
2574 }
2575
PP(pp_listen)2576 PP(pp_listen)
2577 {
2578 dSP;
2579 const int backlog = POPi;
2580 GV * const gv = MUTABLE_GV(POPs);
2581 IO * const io = GvIOn(gv);
2582
2583 if (!IoIFP(io))
2584 goto nuts;
2585
2586 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2587 RETPUSHYES;
2588 else
2589 RETPUSHUNDEF;
2590
2591 nuts:
2592 report_evil_fh(gv);
2593 SETERRNO(EBADF,SS_IVCHAN);
2594 RETPUSHUNDEF;
2595 }
2596
PP(pp_accept)2597 PP(pp_accept)
2598 {
2599 dSP; dTARGET;
2600 IO *nstio;
2601 char namebuf[MAXPATHLEN];
2602 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
2603 Sock_size_t len = sizeof (struct sockaddr_in);
2604 #else
2605 Sock_size_t len = sizeof namebuf;
2606 #endif
2607 GV * const ggv = MUTABLE_GV(POPs);
2608 GV * const ngv = MUTABLE_GV(POPs);
2609 int fd;
2610
2611 IO * const gstio = GvIO(ggv);
2612 if (!gstio || !IoIFP(gstio))
2613 goto nuts;
2614
2615 nstio = GvIOn(ngv);
2616 fd = PerlSock_accept_cloexec(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2617 #if defined(OEMVS)
2618 if (len == 0) {
2619 /* Some platforms indicate zero length when an AF_UNIX client is
2620 * not bound. Simulate a non-zero-length sockaddr structure in
2621 * this case. */
2622 namebuf[0] = 0; /* sun_len */
2623 namebuf[1] = AF_UNIX; /* sun_family */
2624 len = 2;
2625 }
2626 #endif
2627
2628 if (fd < 0)
2629 goto badexit;
2630 if (IoIFP(nstio))
2631 do_close(ngv, FALSE);
2632 IoIFP(nstio) = PerlIO_fdopen(fd, "r" SOCKET_OPEN_MODE);
2633 IoOFP(nstio) = PerlIO_fdopen(fd, "w" SOCKET_OPEN_MODE);
2634 IoTYPE(nstio) = IoTYPE_SOCKET;
2635 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2636 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2637 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2638 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2639 goto badexit;
2640 }
2641
2642 #ifdef __SCO_VERSION__
2643 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2644 #endif
2645
2646 PUSHp(namebuf, len);
2647 RETURN;
2648
2649 nuts:
2650 report_evil_fh(ggv);
2651 SETERRNO(EBADF,SS_IVCHAN);
2652
2653 badexit:
2654 RETPUSHUNDEF;
2655
2656 }
2657
PP(pp_shutdown)2658 PP(pp_shutdown)
2659 {
2660 dSP; dTARGET;
2661 const int how = POPi;
2662 GV * const gv = MUTABLE_GV(POPs);
2663 IO * const io = GvIOn(gv);
2664
2665 if (!IoIFP(io))
2666 goto nuts;
2667
2668 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2669 RETURN;
2670
2671 nuts:
2672 report_evil_fh(gv);
2673 SETERRNO(EBADF,SS_IVCHAN);
2674 RETPUSHUNDEF;
2675 }
2676
2677
2678 /* also used for: pp_gsockopt() */
2679
PP(pp_ssockopt)2680 PP(pp_ssockopt)
2681 {
2682 dSP;
2683 const int optype = PL_op->op_type;
2684 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2685 const unsigned int optname = (unsigned int) POPi;
2686 const unsigned int lvl = (unsigned int) POPi;
2687 GV * const gv = MUTABLE_GV(POPs);
2688 IO * const io = GvIOn(gv);
2689 int fd;
2690 Sock_size_t len;
2691
2692 if (!IoIFP(io))
2693 goto nuts;
2694
2695 fd = PerlIO_fileno(IoIFP(io));
2696 if (fd < 0)
2697 goto nuts;
2698 switch (optype) {
2699 case OP_GSOCKOPT:
2700 SvGROW(sv, 257);
2701 (void)SvPOK_only(sv);
2702 SvCUR_set(sv,256);
2703 *SvEND(sv) ='\0';
2704 len = SvCUR(sv);
2705 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2706 goto nuts2;
2707 #if defined(_AIX)
2708 /* XXX Configure test: does getsockopt set the length properly? */
2709 if (len == 256)
2710 len = sizeof(int);
2711 #endif
2712 SvCUR_set(sv, len);
2713 *SvEND(sv) ='\0';
2714 PUSHs(sv);
2715 break;
2716 case OP_SSOCKOPT: {
2717 const char *buf;
2718 int aint;
2719 SvGETMAGIC(sv);
2720 if (SvPOKp(sv)) {
2721 STRLEN l;
2722 buf = SvPVbyte_nomg(sv, l);
2723 len = l;
2724 }
2725 else {
2726 aint = (int)SvIV_nomg(sv);
2727 buf = (const char *) &aint;
2728 len = sizeof(int);
2729 }
2730 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2731 goto nuts2;
2732 PUSHs(&PL_sv_yes);
2733 }
2734 break;
2735 }
2736 RETURN;
2737
2738 nuts:
2739 report_evil_fh(gv);
2740 SETERRNO(EBADF,SS_IVCHAN);
2741 nuts2:
2742 RETPUSHUNDEF;
2743
2744 }
2745
2746
2747 /* also used for: pp_getsockname() */
2748
PP(pp_getpeername)2749 PP(pp_getpeername)
2750 {
2751 dSP;
2752 const int optype = PL_op->op_type;
2753 GV * const gv = MUTABLE_GV(POPs);
2754 IO * const io = GvIOn(gv);
2755 Sock_size_t len;
2756 SV *sv;
2757 int fd;
2758
2759 if (!IoIFP(io))
2760 goto nuts;
2761
2762 #ifdef HAS_SOCKADDR_STORAGE
2763 len = sizeof(struct sockaddr_storage);
2764 #else
2765 len = 256;
2766 #endif
2767 sv = sv_2mortal(newSV(len+1));
2768 (void)SvPOK_only(sv);
2769 SvCUR_set(sv, len);
2770 *SvEND(sv) ='\0';
2771 fd = PerlIO_fileno(IoIFP(io));
2772 if (fd < 0)
2773 goto nuts;
2774 switch (optype) {
2775 case OP_GETSOCKNAME:
2776 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2777 goto nuts2;
2778 break;
2779 case OP_GETPEERNAME:
2780 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2781 goto nuts2;
2782 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2783 {
2784 static const char nowhere[] = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
2785 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2786 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2787 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2788 sizeof(u_short) + sizeof(struct in_addr))) {
2789 goto nuts2;
2790 }
2791 }
2792 #endif
2793 break;
2794 }
2795 #ifdef BOGUS_GETNAME_RETURN
2796 /* Interactive Unix, getpeername() and getsockname()
2797 does not return valid namelen */
2798 if (len == BOGUS_GETNAME_RETURN)
2799 len = sizeof(struct sockaddr);
2800 #endif
2801 SvCUR_set(sv, len);
2802 *SvEND(sv) ='\0';
2803 PUSHs(sv);
2804 RETURN;
2805
2806 nuts:
2807 report_evil_fh(gv);
2808 SETERRNO(EBADF,SS_IVCHAN);
2809 nuts2:
2810 RETPUSHUNDEF;
2811 }
2812
2813 #endif
2814
2815 /* Stat calls. */
2816
2817 /* also used for: pp_lstat() */
2818
PP(pp_stat)2819 PP(pp_stat)
2820 {
2821 dSP;
2822 GV *gv = NULL;
2823 IO *io = NULL;
2824 U8 gimme;
2825 I32 max = 13;
2826 SV* sv;
2827
2828 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2829 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2830 if (PL_op->op_type == OP_LSTAT) {
2831 if (gv != PL_defgv) {
2832 do_fstat_warning_check:
2833 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2834 "lstat() on filehandle%s%" SVf,
2835 gv ? " " : "",
2836 SVfARG(gv
2837 ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2838 : &PL_sv_no));
2839 } else if (PL_laststype != OP_LSTAT)
2840 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2841 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2842 }
2843
2844 if (gv == PL_defgv) {
2845 if (PL_laststatval < 0)
2846 SETERRNO(EBADF,RMS_IFI);
2847 } else {
2848 do_fstat_have_io:
2849 PL_laststype = OP_STAT;
2850 PL_statgv = gv ? gv : (GV *)io;
2851 SvPVCLEAR(PL_statname);
2852 if(gv) {
2853 io = GvIO(gv);
2854 }
2855 if (io) {
2856 if (IoIFP(io)) {
2857 int fd = PerlIO_fileno(IoIFP(io));
2858 if (fd < 0) {
2859 report_evil_fh(gv);
2860 PL_laststatval = -1;
2861 SETERRNO(EBADF,RMS_IFI);
2862 } else {
2863 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
2864 }
2865 } else if (IoDIRP(io)) {
2866 PL_laststatval =
2867 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2868 } else {
2869 report_evil_fh(gv);
2870 PL_laststatval = -1;
2871 SETERRNO(EBADF,RMS_IFI);
2872 }
2873 } else {
2874 report_evil_fh(gv);
2875 PL_laststatval = -1;
2876 SETERRNO(EBADF,RMS_IFI);
2877 }
2878 }
2879
2880 if (PL_laststatval < 0) {
2881 max = 0;
2882 }
2883 }
2884 else {
2885 const char *file;
2886 const char *temp;
2887 STRLEN len;
2888 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2889 io = MUTABLE_IO(SvRV(sv));
2890 if (PL_op->op_type == OP_LSTAT)
2891 goto do_fstat_warning_check;
2892 goto do_fstat_have_io;
2893 }
2894 SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2895 temp = SvPV_nomg_const(sv, len);
2896 sv_setpv(PL_statname, temp);
2897 PL_statgv = NULL;
2898 PL_laststype = PL_op->op_type;
2899 file = SvPV_nolen_const(PL_statname);
2900 if (!IS_SAFE_PATHNAME(temp, len, OP_NAME(PL_op))) {
2901 PL_laststatval = -1;
2902 }
2903 else if (PL_op->op_type == OP_LSTAT)
2904 PL_laststatval = PerlLIO_lstat(file, &PL_statcache);
2905 else
2906 PL_laststatval = PerlLIO_stat(file, &PL_statcache);
2907 if (PL_laststatval < 0) {
2908 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
2909 /* PL_warn_nl is constant */
2910 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
2911 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2912 GCC_DIAG_RESTORE_STMT;
2913 }
2914 max = 0;
2915 }
2916 }
2917
2918 gimme = GIMME_V;
2919 if (gimme != G_LIST) {
2920 if (gimme != G_VOID)
2921 XPUSHs(boolSV(max));
2922 RETURN;
2923 }
2924 if (max) {
2925 EXTEND(SP, max);
2926 EXTEND_MORTAL(max);
2927 #if ST_DEV_SIZE < IVSIZE || (ST_DEV_SIZE == IVSIZE && ST_DEV_SIGN < 0)
2928 mPUSHi(PL_statcache.st_dev);
2929 #elif ST_DEV_SIZE == IVSIZE
2930 mPUSHu(PL_statcache.st_dev);
2931 #else
2932 # if ST_DEV_SIGN < 0
2933 if (LIKELY((IV)PL_statcache.st_dev == PL_statcache.st_dev)) {
2934 mPUSHi((IV)PL_statcache.st_dev);
2935 }
2936 # else
2937 if (LIKELY((UV)PL_statcache.st_dev == PL_statcache.st_dev)) {
2938 mPUSHu((UV)PL_statcache.st_dev);
2939 }
2940 # endif
2941 else {
2942 char buf[sizeof(PL_statcache.st_dev)*3+1];
2943 /* sv_catpvf() casts 'j' size values down to IV, so it
2944 isn't suitable for use here.
2945 */
2946 # if defined(I_INTTYPES) && defined(HAS_SNPRINTF)
2947 # if ST_DEV_SIGN < 0
2948 int size = snprintf(buf, sizeof(buf), "%" PRIdMAX, (intmax_t)PL_statcache.st_dev);
2949 # else
2950 int size = snprintf(buf, sizeof(buf), "%" PRIuMAX, (uintmax_t)PL_statcache.st_dev);
2951 # endif
2952 STATIC_ASSERT_STMT(sizeof(intmax_t) >= sizeof(PL_statcache.st_dev));
2953 mPUSHp(buf, size);
2954 # else
2955 # error extraordinarily large st_dev but no inttypes.h or no snprintf
2956 # endif
2957 }
2958 #endif
2959 {
2960 /*
2961 * We try to represent st_ino as a native IV or UV where
2962 * possible, but fall back to a decimal string where
2963 * necessary. The code to generate these decimal strings
2964 * is quite obtuse, because (a) we're portable to non-POSIX
2965 * platforms where st_ino might be signed; (b) we didn't
2966 * necessarily detect at Configure time whether st_ino is
2967 * signed; (c) we're portable to non-POSIX platforms where
2968 * ino_t isn't defined, so have no name for the type of
2969 * st_ino; and (d) sprintf() doesn't necessarily support
2970 * integers as large as st_ino.
2971 */
2972 bool neg;
2973 Stat_t s;
2974 CLANG_DIAG_IGNORE_STMT(-Wtautological-compare);
2975 GCC_DIAG_IGNORE_STMT(-Wtype-limits);
2976 neg = PL_statcache.st_ino < 0;
2977 GCC_DIAG_RESTORE_STMT;
2978 CLANG_DIAG_RESTORE_STMT;
2979 if (neg) {
2980 s.st_ino = (IV)PL_statcache.st_ino;
2981 if (LIKELY(s.st_ino == PL_statcache.st_ino)) {
2982 mPUSHi(s.st_ino);
2983 } else {
2984 char buf[sizeof(s.st_ino)*3+1], *p;
2985 s.st_ino = PL_statcache.st_ino;
2986 for (p = buf + sizeof(buf); p != buf+1; ) {
2987 Stat_t t;
2988 t.st_ino = s.st_ino / 10;
2989 *--p = '0' + (int)(t.st_ino*10 - s.st_ino);
2990 s.st_ino = t.st_ino;
2991 }
2992 while (*p == '0')
2993 p++;
2994 *--p = '-';
2995 mPUSHp(p, buf+sizeof(buf) - p);
2996 }
2997 } else {
2998 s.st_ino = (UV)PL_statcache.st_ino;
2999 if (LIKELY(s.st_ino == PL_statcache.st_ino)) {
3000 mPUSHu(s.st_ino);
3001 } else {
3002 char buf[sizeof(s.st_ino)*3], *p;
3003 s.st_ino = PL_statcache.st_ino;
3004 for (p = buf + sizeof(buf); p != buf; ) {
3005 Stat_t t;
3006 t.st_ino = s.st_ino / 10;
3007 *--p = '0' + (int)(s.st_ino - t.st_ino*10);
3008 s.st_ino = t.st_ino;
3009 }
3010 while (*p == '0')
3011 p++;
3012 mPUSHp(p, buf+sizeof(buf) - p);
3013 }
3014 }
3015 }
3016 mPUSHu(PL_statcache.st_mode);
3017 mPUSHu(PL_statcache.st_nlink);
3018
3019 sv_setuid(PUSHmortal, PL_statcache.st_uid);
3020 sv_setgid(PUSHmortal, PL_statcache.st_gid);
3021
3022 #ifdef USE_STAT_RDEV
3023 mPUSHi(PL_statcache.st_rdev);
3024 #else
3025 PUSHs(newSVpvs_flags("", SVs_TEMP));
3026 #endif
3027 #if Off_t_size > IVSIZE
3028 mPUSHn(PL_statcache.st_size);
3029 #else
3030 mPUSHi(PL_statcache.st_size);
3031 #endif
3032 #ifdef BIG_TIME
3033 mPUSHn(PL_statcache.st_atime);
3034 mPUSHn(PL_statcache.st_mtime);
3035 mPUSHn(PL_statcache.st_ctime);
3036 #else
3037 mPUSHi(PL_statcache.st_atime);
3038 mPUSHi(PL_statcache.st_mtime);
3039 mPUSHi(PL_statcache.st_ctime);
3040 #endif
3041 #ifdef USE_STAT_BLOCKS
3042 mPUSHu(PL_statcache.st_blksize);
3043 mPUSHu(PL_statcache.st_blocks);
3044 #else
3045 PUSHs(newSVpvs_flags("", SVs_TEMP));
3046 PUSHs(newSVpvs_flags("", SVs_TEMP));
3047 #endif
3048 }
3049 RETURN;
3050 }
3051
3052 /* All filetest ops avoid manipulating the perl stack pointer in their main
3053 bodies (since commit d2c4d2d1e22d3125), and return using either
3054 S_ft_return_false() or S_ft_return_true(). These two helper functions are
3055 the only two which manipulate the perl stack. To ensure that no stack
3056 manipulation macros are used, the filetest ops avoid defining a local copy
3057 of the stack pointer with dSP. */
3058
3059 /* If the next filetest is stacked up with this one
3060 (PL_op->op_private & OPpFT_STACKING), we leave
3061 the original argument on the stack for success,
3062 and skip the stacked operators on failure.
3063 The next few macros/functions take care of this.
3064 */
3065
3066 static OP *
S_ft_return_false(pTHX_ SV * ret)3067 S_ft_return_false(pTHX_ SV *ret) {
3068 OP *next = NORMAL;
3069 dSP;
3070
3071 if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
3072 else SETs(ret);
3073 PUTBACK;
3074
3075 if (PL_op->op_private & OPpFT_STACKING) {
3076 while (next && OP_IS_FILETEST(next->op_type)
3077 && next->op_private & OPpFT_STACKED)
3078 next = next->op_next;
3079 }
3080 return next;
3081 }
3082
3083 PERL_STATIC_INLINE OP *
S_ft_return_true(pTHX_ SV * ret)3084 S_ft_return_true(pTHX_ SV *ret) {
3085 dSP;
3086 if (PL_op->op_flags & OPf_REF)
3087 XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
3088 else if (!(PL_op->op_private & OPpFT_STACKING))
3089 SETs(ret);
3090 PUTBACK;
3091 return NORMAL;
3092 }
3093
3094 #define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no)
3095 #define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef)
3096 #define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes)
3097
3098 #define tryAMAGICftest_MG(chr) STMT_START { \
3099 if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
3100 && PL_op->op_flags & OPf_KIDS) { \
3101 OP *next = S_try_amagic_ftest(aTHX_ chr); \
3102 if (next) return next; \
3103 } \
3104 } STMT_END
3105
3106 STATIC OP *
S_try_amagic_ftest(pTHX_ char chr)3107 S_try_amagic_ftest(pTHX_ char chr) {
3108 SV *const arg = *PL_stack_sp;
3109
3110 assert(chr != '?');
3111 if (!(PL_op->op_private & OPpFT_STACKED)) SvGETMAGIC(arg);
3112
3113 if (SvAMAGIC(arg))
3114 {
3115 const char tmpchr = chr;
3116 SV * const tmpsv = amagic_call(arg,
3117 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
3118 ftest_amg, AMGf_unary);
3119
3120 if (!tmpsv)
3121 return NULL;
3122
3123 return SvTRUE(tmpsv)
3124 ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
3125 }
3126 return NULL;
3127 }
3128
3129
3130 /* also used for: pp_fteexec() pp_fteread() pp_ftewrite() pp_ftrexec()
3131 * pp_ftrwrite() */
3132
PP(pp_ftrread)3133 PP(pp_ftrread)
3134 {
3135 I32 result;
3136 /* Not const, because things tweak this below. Not bool, because there's
3137 no guarantee that OPpFT_ACCESS is <= CHAR_MAX */
3138 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3139 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
3140 /* Giving some sort of initial value silences compilers. */
3141 # ifdef R_OK
3142 int access_mode = R_OK;
3143 # else
3144 int access_mode = 0;
3145 # endif
3146 #else
3147 /* access_mode is never used, but leaving use_access in makes the
3148 conditional compiling below much clearer. */
3149 I32 use_access = 0;
3150 #endif
3151 Mode_t stat_mode = S_IRUSR;
3152
3153 bool effective = FALSE;
3154 char opchar = '?';
3155
3156 switch (PL_op->op_type) {
3157 case OP_FTRREAD: opchar = 'R'; break;
3158 case OP_FTRWRITE: opchar = 'W'; break;
3159 case OP_FTREXEC: opchar = 'X'; break;
3160 case OP_FTEREAD: opchar = 'r'; break;
3161 case OP_FTEWRITE: opchar = 'w'; break;
3162 case OP_FTEEXEC: opchar = 'x'; break;
3163 }
3164 tryAMAGICftest_MG(opchar);
3165
3166 switch (PL_op->op_type) {
3167 case OP_FTRREAD:
3168 #if !(defined(HAS_ACCESS) && defined(R_OK))
3169 use_access = 0;
3170 #endif
3171 break;
3172
3173 case OP_FTRWRITE:
3174 #if defined(HAS_ACCESS) && defined(W_OK)
3175 access_mode = W_OK;
3176 #else
3177 use_access = 0;
3178 #endif
3179 stat_mode = S_IWUSR;
3180 break;
3181
3182 case OP_FTREXEC:
3183 #if defined(HAS_ACCESS) && defined(X_OK)
3184 access_mode = X_OK;
3185 #else
3186 use_access = 0;
3187 #endif
3188 stat_mode = S_IXUSR;
3189 break;
3190
3191 case OP_FTEWRITE:
3192 #ifdef PERL_EFF_ACCESS
3193 access_mode = W_OK;
3194 #endif
3195 stat_mode = S_IWUSR;
3196 /* FALLTHROUGH */
3197
3198 case OP_FTEREAD:
3199 #ifndef PERL_EFF_ACCESS
3200 use_access = 0;
3201 #endif
3202 effective = TRUE;
3203 break;
3204
3205 case OP_FTEEXEC:
3206 #ifdef PERL_EFF_ACCESS
3207 access_mode = X_OK;
3208 #else
3209 use_access = 0;
3210 #endif
3211 stat_mode = S_IXUSR;
3212 effective = TRUE;
3213 break;
3214 }
3215
3216 if (use_access) {
3217 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3218 STRLEN len;
3219 const char *name = SvPV(*PL_stack_sp, len);
3220 if (!IS_SAFE_PATHNAME(name, len, OP_NAME(PL_op))) {
3221 result = -1;
3222 }
3223 else if (effective) {
3224 # ifdef PERL_EFF_ACCESS
3225 result = PERL_EFF_ACCESS(name, access_mode);
3226 # else
3227 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3228 OP_NAME(PL_op));
3229 # endif
3230 }
3231 else {
3232 # ifdef HAS_ACCESS
3233 result = access(name, access_mode);
3234 # else
3235 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3236 # endif
3237 }
3238 if (result == 0)
3239 FT_RETURNYES;
3240 if (result < 0)
3241 FT_RETURNUNDEF;
3242 FT_RETURNNO;
3243 #endif
3244 }
3245
3246 result = my_stat_flags(0);
3247 if (result < 0)
3248 FT_RETURNUNDEF;
3249 if (cando(stat_mode, effective, &PL_statcache))
3250 FT_RETURNYES;
3251 FT_RETURNNO;
3252 }
3253
3254
3255 /* also used for: pp_ftatime() pp_ftctime() pp_ftmtime() pp_ftsize() */
3256
PP(pp_ftis)3257 PP(pp_ftis)
3258 {
3259 I32 result;
3260 const int op_type = PL_op->op_type;
3261 char opchar = '?';
3262
3263 switch (op_type) {
3264 case OP_FTIS: opchar = 'e'; break;
3265 case OP_FTSIZE: opchar = 's'; break;
3266 case OP_FTMTIME: opchar = 'M'; break;
3267 case OP_FTCTIME: opchar = 'C'; break;
3268 case OP_FTATIME: opchar = 'A'; break;
3269 }
3270 tryAMAGICftest_MG(opchar);
3271
3272 result = my_stat_flags(0);
3273 if (result < 0)
3274 FT_RETURNUNDEF;
3275 if (op_type == OP_FTIS)
3276 FT_RETURNYES;
3277 {
3278 /* You can't dTARGET inside OP_FTIS, because you'll get
3279 "panic: pad_sv po" - the op is not flagged to have a target. */
3280 dTARGET;
3281 switch (op_type) {
3282 case OP_FTSIZE:
3283 #if Off_t_size > IVSIZE
3284 sv_setnv(TARG, (NV)PL_statcache.st_size);
3285 #else
3286 sv_setiv(TARG, (IV)PL_statcache.st_size);
3287 #endif
3288 break;
3289 case OP_FTMTIME:
3290 sv_setnv(TARG,
3291 ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3292 break;
3293 case OP_FTATIME:
3294 sv_setnv(TARG,
3295 ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3296 break;
3297 case OP_FTCTIME:
3298 sv_setnv(TARG,
3299 ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3300 break;
3301 }
3302 SvSETMAGIC(TARG);
3303 return SvTRUE_nomg_NN(TARG)
3304 ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3305 }
3306 }
3307
3308
3309 /* also used for: pp_ftblk() pp_ftchr() pp_ftdir() pp_fteowned()
3310 * pp_ftfile() pp_ftpipe() pp_ftsgid() pp_ftsock()
3311 * pp_ftsuid() pp_ftsvtx() pp_ftzero() */
3312
PP(pp_ftrowned)3313 PP(pp_ftrowned)
3314 {
3315 I32 result;
3316 char opchar = '?';
3317
3318 switch (PL_op->op_type) {
3319 case OP_FTROWNED: opchar = 'O'; break;
3320 case OP_FTEOWNED: opchar = 'o'; break;
3321 case OP_FTZERO: opchar = 'z'; break;
3322 case OP_FTSOCK: opchar = 'S'; break;
3323 case OP_FTCHR: opchar = 'c'; break;
3324 case OP_FTBLK: opchar = 'b'; break;
3325 case OP_FTFILE: opchar = 'f'; break;
3326 case OP_FTDIR: opchar = 'd'; break;
3327 case OP_FTPIPE: opchar = 'p'; break;
3328 case OP_FTSUID: opchar = 'u'; break;
3329 case OP_FTSGID: opchar = 'g'; break;
3330 case OP_FTSVTX: opchar = 'k'; break;
3331 }
3332 tryAMAGICftest_MG(opchar);
3333
3334 result = my_stat_flags(0);
3335 if (result < 0)
3336 FT_RETURNUNDEF;
3337 switch (PL_op->op_type) {
3338 case OP_FTROWNED:
3339 if (PL_statcache.st_uid == PerlProc_getuid())
3340 FT_RETURNYES;
3341 break;
3342 case OP_FTEOWNED:
3343 if (PL_statcache.st_uid == PerlProc_geteuid())
3344 FT_RETURNYES;
3345 break;
3346 case OP_FTZERO:
3347 if (PL_statcache.st_size == 0)
3348 FT_RETURNYES;
3349 break;
3350 case OP_FTSOCK:
3351 if (S_ISSOCK(PL_statcache.st_mode))
3352 FT_RETURNYES;
3353 break;
3354 case OP_FTCHR:
3355 if (S_ISCHR(PL_statcache.st_mode))
3356 FT_RETURNYES;
3357 break;
3358 case OP_FTBLK:
3359 if (S_ISBLK(PL_statcache.st_mode))
3360 FT_RETURNYES;
3361 break;
3362 case OP_FTFILE:
3363 if (S_ISREG(PL_statcache.st_mode))
3364 FT_RETURNYES;
3365 break;
3366 case OP_FTDIR:
3367 if (S_ISDIR(PL_statcache.st_mode))
3368 FT_RETURNYES;
3369 break;
3370 case OP_FTPIPE:
3371 if (S_ISFIFO(PL_statcache.st_mode))
3372 FT_RETURNYES;
3373 break;
3374 #ifdef S_ISUID
3375 case OP_FTSUID:
3376 if (PL_statcache.st_mode & S_ISUID)
3377 FT_RETURNYES;
3378 break;
3379 #endif
3380 #ifdef S_ISGID
3381 case OP_FTSGID:
3382 if (PL_statcache.st_mode & S_ISGID)
3383 FT_RETURNYES;
3384 break;
3385 #endif
3386 #ifdef S_ISVTX
3387 case OP_FTSVTX:
3388 if (PL_statcache.st_mode & S_ISVTX)
3389 FT_RETURNYES;
3390 break;
3391 #endif
3392 }
3393 FT_RETURNNO;
3394 }
3395
PP(pp_ftlink)3396 PP(pp_ftlink)
3397 {
3398 I32 result;
3399
3400 tryAMAGICftest_MG('l');
3401 result = my_lstat_flags(0);
3402
3403 if (result < 0)
3404 FT_RETURNUNDEF;
3405 if (S_ISLNK(PL_statcache.st_mode))
3406 FT_RETURNYES;
3407 FT_RETURNNO;
3408 }
3409
PP(pp_fttty)3410 PP(pp_fttty)
3411 {
3412 int fd;
3413 GV *gv;
3414 char *name = NULL;
3415 STRLEN namelen;
3416 UV uv;
3417
3418 tryAMAGICftest_MG('t');
3419
3420 if (PL_op->op_flags & OPf_REF)
3421 gv = cGVOP_gv;
3422 else {
3423 SV *tmpsv = *PL_stack_sp;
3424 if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3425 name = SvPV_nomg(tmpsv, namelen);
3426 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3427 }
3428 }
3429
3430 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3431 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3432 else if (name && isDIGIT(*name) && grok_atoUV(name, &uv, NULL) && uv <= PERL_INT_MAX)
3433 fd = (int)uv;
3434 else
3435 fd = -1;
3436 if (fd < 0) {
3437 SETERRNO(EBADF,RMS_IFI);
3438 FT_RETURNUNDEF;
3439 }
3440 if (PerlLIO_isatty(fd))
3441 FT_RETURNYES;
3442 FT_RETURNNO;
3443 }
3444
3445
3446 /* also used for: pp_ftbinary() */
3447
PP(pp_fttext)3448 PP(pp_fttext)
3449 {
3450 I32 i;
3451 SSize_t len;
3452 I32 odd = 0;
3453 STDCHAR tbuf[512];
3454 STDCHAR *s;
3455 IO *io;
3456 SV *sv = NULL;
3457 GV *gv;
3458 PerlIO *fp;
3459 const U8 * first_variant;
3460
3461 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3462
3463 if (PL_op->op_flags & OPf_REF)
3464 gv = cGVOP_gv;
3465 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3466 == OPpFT_STACKED)
3467 gv = PL_defgv;
3468 else {
3469 sv = *PL_stack_sp;
3470 gv = MAYBE_DEREF_GV_nomg(sv);
3471 }
3472
3473 if (gv) {
3474 if (gv == PL_defgv) {
3475 if (PL_statgv)
3476 io = SvTYPE(PL_statgv) == SVt_PVIO
3477 ? (IO *)PL_statgv
3478 : GvIO(PL_statgv);
3479 else {
3480 goto really_filename;
3481 }
3482 }
3483 else {
3484 PL_statgv = gv;
3485 SvPVCLEAR(PL_statname);
3486 io = GvIO(PL_statgv);
3487 }
3488 PL_laststatval = -1;
3489 PL_laststype = OP_STAT;
3490 if (io && IoIFP(io)) {
3491 int fd;
3492 if (! PerlIO_has_base(IoIFP(io)))
3493 DIE(aTHX_ "-T and -B not implemented on filehandles");
3494 fd = PerlIO_fileno(IoIFP(io));
3495 if (fd < 0) {
3496 SETERRNO(EBADF,RMS_IFI);
3497 FT_RETURNUNDEF;
3498 }
3499 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3500 if (PL_laststatval < 0)
3501 FT_RETURNUNDEF;
3502 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3503 if (PL_op->op_type == OP_FTTEXT)
3504 FT_RETURNNO;
3505 else
3506 FT_RETURNYES;
3507 }
3508 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3509 i = PerlIO_getc(IoIFP(io));
3510 if (i != EOF)
3511 (void)PerlIO_ungetc(IoIFP(io),i);
3512 else
3513 /* null file is anything */
3514 FT_RETURNYES;
3515 }
3516 len = PerlIO_get_bufsiz(IoIFP(io));
3517 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3518 /* sfio can have large buffers - limit to 512 */
3519 if (len > 512)
3520 len = 512;
3521 }
3522 else {
3523 SETERRNO(EBADF,RMS_IFI);
3524 report_evil_fh(gv);
3525 SETERRNO(EBADF,RMS_IFI);
3526 FT_RETURNUNDEF;
3527 }
3528 }
3529 else {
3530 const char *file;
3531 const char *temp;
3532 STRLEN temp_len;
3533 int fd;
3534
3535 assert(sv);
3536 temp = SvPV_nomg_const(sv, temp_len);
3537 sv_setpv(PL_statname, temp);
3538 if (!IS_SAFE_PATHNAME(temp, temp_len, OP_NAME(PL_op))) {
3539 PL_laststatval = -1;
3540 PL_laststype = OP_STAT;
3541 FT_RETURNUNDEF;
3542 }
3543 really_filename:
3544 file = SvPVX_const(PL_statname);
3545 PL_statgv = NULL;
3546 if (!(fp = PerlIO_open(file, "r"))) {
3547 if (!gv) {
3548 PL_laststatval = -1;
3549 PL_laststype = OP_STAT;
3550 }
3551 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
3552 /* PL_warn_nl is constant */
3553 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
3554 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3555 GCC_DIAG_RESTORE_STMT;
3556 }
3557 FT_RETURNUNDEF;
3558 }
3559 PL_laststype = OP_STAT;
3560 fd = PerlIO_fileno(fp);
3561 if (fd < 0) {
3562 (void)PerlIO_close(fp);
3563 SETERRNO(EBADF,RMS_IFI);
3564 FT_RETURNUNDEF;
3565 }
3566 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3567 if (PL_laststatval < 0) {
3568 dSAVE_ERRNO;
3569 (void)PerlIO_close(fp);
3570 RESTORE_ERRNO;
3571 FT_RETURNUNDEF;
3572 }
3573 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3574 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3575 (void)PerlIO_close(fp);
3576 if (len <= 0) {
3577 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3578 FT_RETURNNO; /* special case NFS directories */
3579 FT_RETURNYES; /* null file is anything */
3580 }
3581 s = tbuf;
3582 }
3583
3584 /* now scan s to look for textiness */
3585
3586 #if defined(DOSISH) || defined(USEMYBINMODE)
3587 /* ignore trailing ^Z on short files */
3588 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3589 --len;
3590 #endif
3591
3592 assert(len);
3593 if (! is_utf8_invariant_string_loc((U8 *) s, len, &first_variant)) {
3594
3595 /* Here contains a variant under UTF-8 . See if the entire string is
3596 * UTF-8. */
3597 if (is_utf8_fixed_width_buf_flags(first_variant,
3598 len - ((char *) first_variant - (char *) s),
3599 0))
3600 {
3601 if (PL_op->op_type == OP_FTTEXT) {
3602 FT_RETURNYES;
3603 }
3604 else {
3605 FT_RETURNNO;
3606 }
3607 }
3608 }
3609
3610 /* Here, is not UTF-8 or is entirely ASCII. Look through the buffer for
3611 * things that wouldn't be in ASCII text or rich ASCII text. Count these
3612 * in 'odd' */
3613 for (i = 0; i < len; i++, s++) {
3614 if (!*s) { /* null never allowed in text */
3615 odd += len;
3616 break;
3617 }
3618 #ifdef USE_LOCALE_CTYPE
3619 if (IN_LC_RUNTIME(LC_CTYPE)) {
3620 if ( isPRINT_LC(*s) || isSPACE_LC(*s)) {
3621 continue;
3622 }
3623 }
3624 else
3625 #endif
3626 if ( isPRINT_A(*s)
3627 /* VT occurs so rarely in text, that we consider it odd */
3628 || (isSPACE_A(*s) && *s != VT_NATIVE)
3629
3630 /* But there is a fair amount of backspaces and escapes in
3631 * some text */
3632 || *s == '\b'
3633 || *s == ESC_NATIVE)
3634 {
3635 continue;
3636 }
3637 odd++;
3638 }
3639
3640 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3641 FT_RETURNNO;
3642 else
3643 FT_RETURNYES;
3644 }
3645
3646 /* File calls. */
3647
PP(pp_chdir)3648 PP(pp_chdir)
3649 {
3650 dSP; dTARGET;
3651 const char *tmps = NULL;
3652 GV *gv = NULL;
3653
3654 if( MAXARG == 1 ) {
3655 SV * const sv = POPs;
3656 if (PL_op->op_flags & OPf_SPECIAL) {
3657 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3658 if (!gv) {
3659 if (ckWARN(WARN_UNOPENED)) {
3660 Perl_warner(aTHX_ packWARN(WARN_UNOPENED),
3661 "chdir() on unopened filehandle %" SVf, sv);
3662 }
3663 SETERRNO(EBADF,RMS_IFI);
3664 PUSHs(&PL_sv_zero);
3665 TAINT_PROPER("chdir");
3666 RETURN;
3667 }
3668 }
3669 else if (!(gv = MAYBE_DEREF_GV(sv)))
3670 tmps = SvPV_nomg_const_nolen(sv);
3671 }
3672 else {
3673 HV * const table = GvHVn(PL_envgv);
3674 SV **svp;
3675
3676 EXTEND(SP, 1);
3677 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3678 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3679 #ifdef VMS
3680 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3681 #endif
3682 )
3683 {
3684 tmps = SvPV_nolen_const(*svp);
3685 }
3686 else {
3687 PUSHs(&PL_sv_zero);
3688 SETERRNO(EINVAL, LIB_INVARG);
3689 TAINT_PROPER("chdir");
3690 RETURN;
3691 }
3692 }
3693
3694 TAINT_PROPER("chdir");
3695 if (gv) {
3696 #ifdef HAS_FCHDIR
3697 IO* const io = GvIO(gv);
3698 if (io) {
3699 if (IoDIRP(io)) {
3700 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3701 } else if (IoIFP(io)) {
3702 int fd = PerlIO_fileno(IoIFP(io));
3703 if (fd < 0) {
3704 goto nuts;
3705 }
3706 PUSHi(fchdir(fd) >= 0);
3707 }
3708 else {
3709 goto nuts;
3710 }
3711 } else {
3712 goto nuts;
3713 }
3714
3715 #else
3716 DIE(aTHX_ PL_no_func, "fchdir");
3717 #endif
3718 }
3719 else
3720 PUSHi( PerlDir_chdir(tmps) >= 0 );
3721 #ifdef VMS
3722 /* Clear the DEFAULT element of ENV so we'll get the new value
3723 * in the future. */
3724 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3725 #endif
3726 RETURN;
3727
3728 #ifdef HAS_FCHDIR
3729 nuts:
3730 report_evil_fh(gv);
3731 SETERRNO(EBADF,RMS_IFI);
3732 PUSHs(&PL_sv_zero);
3733 RETURN;
3734 #endif
3735 }
3736
3737
3738 /* also used for: pp_chmod() pp_kill() pp_unlink() pp_utime() */
3739
PP(pp_chown)3740 PP(pp_chown)
3741 {
3742 dSP; dMARK; dTARGET;
3743 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3744
3745 SP = MARK;
3746 XPUSHi(value);
3747 RETURN;
3748 }
3749
PP(pp_chroot)3750 PP(pp_chroot)
3751 {
3752 #ifdef HAS_CHROOT
3753 dSP; dTARGET;
3754 char * const tmps = POPpx;
3755 TAINT_PROPER("chroot");
3756 PUSHi( chroot(tmps) >= 0 );
3757 RETURN;
3758 #else
3759 DIE(aTHX_ PL_no_func, "chroot");
3760 #endif
3761 }
3762
PP(pp_rename)3763 PP(pp_rename)
3764 {
3765 dSP; dTARGET;
3766 int anum;
3767 #ifndef HAS_RENAME
3768 Stat_t statbuf;
3769 #endif
3770 const char * const tmps2 = POPpconstx;
3771 const char * const tmps = SvPV_nolen_const(TOPs);
3772 TAINT_PROPER("rename");
3773 #ifdef HAS_RENAME
3774 anum = PerlLIO_rename(tmps, tmps2);
3775 #else
3776 if (!(anum = PerlLIO_stat(tmps, &statbuf))) {
3777 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3778 anum = 1;
3779 else {
3780 if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
3781 (void)UNLINK(tmps2);
3782 if (!(anum = link(tmps, tmps2)))
3783 anum = UNLINK(tmps);
3784 }
3785 }
3786 #endif
3787 SETi( anum >= 0 );
3788 RETURN;
3789 }
3790
3791
3792 /* also used for: pp_symlink() */
3793
3794 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
PP(pp_link)3795 PP(pp_link)
3796 {
3797 dSP; dTARGET;
3798 const int op_type = PL_op->op_type;
3799 int result;
3800
3801 # ifndef HAS_LINK
3802 if (op_type == OP_LINK)
3803 DIE(aTHX_ PL_no_func, "link");
3804 # endif
3805 # ifndef HAS_SYMLINK
3806 if (op_type == OP_SYMLINK)
3807 DIE(aTHX_ PL_no_func, "symlink");
3808 # endif
3809
3810 {
3811 const char * const tmps2 = POPpconstx;
3812 const char * const tmps = SvPV_nolen_const(TOPs);
3813 TAINT_PROPER(PL_op_desc[op_type]);
3814 result =
3815 # if defined(HAS_LINK) && defined(HAS_SYMLINK)
3816 /* Both present - need to choose which. */
3817 (op_type == OP_LINK) ?
3818 PerlLIO_link(tmps, tmps2) : PerlLIO_symlink(tmps, tmps2);
3819 # elif defined(HAS_LINK)
3820 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3821 PerlLIO_link(tmps, tmps2);
3822 # elif defined(HAS_SYMLINK)
3823 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3824 PerlLIO_symlink(tmps, tmps2);
3825 # endif
3826 }
3827
3828 SETi( result >= 0 );
3829 RETURN;
3830 }
3831 #else
3832
3833 /* also used for: pp_symlink() */
3834
PP(pp_link)3835 PP(pp_link)
3836 {
3837 /* Have neither. */
3838 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3839 }
3840 #endif
3841
PP(pp_readlink)3842 PP(pp_readlink)
3843 {
3844 dSP;
3845 #ifdef HAS_SYMLINK
3846 dTARGET;
3847 const char *tmps;
3848 char buf[MAXPATHLEN];
3849 SSize_t len;
3850
3851 TAINT;
3852 tmps = POPpconstx;
3853 /* NOTE: if the length returned by readlink() is sizeof(buf) - 1,
3854 * it is impossible to know whether the result was truncated. */
3855 len = PerlLIO_readlink(tmps, buf, sizeof(buf) - 1);
3856 if (len < 0)
3857 RETPUSHUNDEF;
3858 buf[len] = '\0';
3859 PUSHp(buf, len);
3860 RETURN;
3861 #else
3862 EXTEND(SP, 1);
3863 RETSETUNDEF; /* just pretend it's a normal file */
3864 #endif
3865 }
3866
3867 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3868 STATIC int
S_dooneliner(pTHX_ const char * cmd,const char * filename)3869 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3870 {
3871 char * const save_filename = filename;
3872 char *cmdline;
3873 char *s;
3874 PerlIO *myfp;
3875 int anum = 1;
3876 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3877
3878 PERL_ARGS_ASSERT_DOONELINER;
3879
3880 Newx(cmdline, size, char);
3881 my_strlcpy(cmdline, cmd, size);
3882 my_strlcat(cmdline, " ", size);
3883 for (s = cmdline + strlen(cmdline); *filename; ) {
3884 *s++ = '\\';
3885 *s++ = *filename++;
3886 }
3887 if (s - cmdline < size)
3888 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3889 myfp = PerlProc_popen(cmdline, "r");
3890 Safefree(cmdline);
3891
3892 if (myfp) {
3893 SV * const tmpsv = sv_newmortal();
3894 /* Need to save/restore 'PL_rs' ?? */
3895 s = sv_gets(tmpsv, myfp, 0);
3896 (void)PerlProc_pclose(myfp);
3897 if (s != NULL) {
3898 int e;
3899 for (e = 1;
3900 #ifdef HAS_SYS_ERRLIST
3901 e <= sys_nerr
3902 #endif
3903 ; e++)
3904 {
3905 /* you don't see this */
3906 const char * const errmsg = Strerror(e) ;
3907 if (!errmsg)
3908 break;
3909 if (instr(s, errmsg)) {
3910 SETERRNO(e,0);
3911 return 0;
3912 }
3913 }
3914 SETERRNO(0,0);
3915 #ifndef EACCES
3916 #define EACCES EPERM
3917 #endif
3918 if (instr(s, "cannot make"))
3919 SETERRNO(EEXIST,RMS_FEX);
3920 else if (instr(s, "existing file"))
3921 SETERRNO(EEXIST,RMS_FEX);
3922 else if (instr(s, "ile exists"))
3923 SETERRNO(EEXIST,RMS_FEX);
3924 else if (instr(s, "non-exist"))
3925 SETERRNO(ENOENT,RMS_FNF);
3926 else if (instr(s, "does not exist"))
3927 SETERRNO(ENOENT,RMS_FNF);
3928 else if (instr(s, "not empty"))
3929 SETERRNO(EBUSY,SS_DEVOFFLINE);
3930 else if (instr(s, "cannot access"))
3931 SETERRNO(EACCES,RMS_PRV);
3932 else
3933 SETERRNO(EPERM,RMS_PRV);
3934 return 0;
3935 }
3936 else { /* some mkdirs return no failure indication */
3937 Stat_t statbuf;
3938 anum = (PerlLIO_stat(save_filename, &statbuf) >= 0);
3939 if (PL_op->op_type == OP_RMDIR)
3940 anum = !anum;
3941 if (anum)
3942 SETERRNO(0,0);
3943 else
3944 SETERRNO(EACCES,RMS_PRV); /* a guess */
3945 }
3946 return anum;
3947 }
3948 else
3949 return 0;
3950 }
3951 #endif
3952
3953 /* This macro removes trailing slashes from a directory name.
3954 * Different operating and file systems take differently to
3955 * trailing slashes. According to POSIX 1003.1 1996 Edition
3956 * any number of trailing slashes should be allowed.
3957 * Thusly we snip them away so that even non-conforming
3958 * systems are happy.
3959 * We should probably do this "filtering" for all
3960 * the functions that expect (potentially) directory names:
3961 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3962 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3963
3964 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3965 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3966 do { \
3967 (len)--; \
3968 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3969 (tmps) = savepvn((tmps), (len)); \
3970 (copy) = TRUE; \
3971 }
3972
PP(pp_mkdir)3973 PP(pp_mkdir)
3974 {
3975 dSP; dTARGET;
3976 STRLEN len;
3977 const char *tmps;
3978 bool copy = FALSE;
3979 const unsigned int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPu : 0777;
3980
3981 TRIMSLASHES(tmps,len,copy);
3982
3983 TAINT_PROPER("mkdir");
3984 #ifdef HAS_MKDIR
3985 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3986 #else
3987 {
3988 int oldumask;
3989 SETi( dooneliner("mkdir", tmps) );
3990 oldumask = PerlLIO_umask(0);
3991 PerlLIO_umask(oldumask);
3992 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3993 }
3994 #endif
3995 if (copy)
3996 Safefree(tmps);
3997 RETURN;
3998 }
3999
PP(pp_rmdir)4000 PP(pp_rmdir)
4001 {
4002 dSP; dTARGET;
4003 STRLEN len;
4004 const char *tmps;
4005 bool copy = FALSE;
4006
4007 TRIMSLASHES(tmps,len,copy);
4008 TAINT_PROPER("rmdir");
4009 #ifdef HAS_RMDIR
4010 SETi( PerlDir_rmdir(tmps) >= 0 );
4011 #else
4012 SETi( dooneliner("rmdir", tmps) );
4013 #endif
4014 if (copy)
4015 Safefree(tmps);
4016 RETURN;
4017 }
4018
4019 /* Directory calls. */
4020
PP(pp_open_dir)4021 PP(pp_open_dir)
4022 {
4023 #if defined(Direntry_t) && defined(HAS_READDIR)
4024 dSP;
4025 const char * const dirname = POPpconstx;
4026 GV * const gv = MUTABLE_GV(POPs);
4027 IO * const io = GvIOn(gv);
4028
4029 if ((IoIFP(io) || IoOFP(io)))
4030 Perl_croak(aTHX_ "Cannot open %" HEKf " as a dirhandle: it is already open as a filehandle",
4031 HEKfARG(GvENAME_HEK(gv)));
4032 if (IoDIRP(io))
4033 PerlDir_close(IoDIRP(io));
4034 if (!(IoDIRP(io) = PerlDir_open(dirname)))
4035 goto nope;
4036
4037 RETPUSHYES;
4038 nope:
4039 if (!errno)
4040 SETERRNO(EBADF,RMS_DIR);
4041 RETPUSHUNDEF;
4042 #else
4043 DIE(aTHX_ PL_no_dir_func, "opendir");
4044 #endif
4045 }
4046
PP(pp_readdir)4047 PP(pp_readdir)
4048 {
4049 #if !defined(Direntry_t) || !defined(HAS_READDIR)
4050 DIE(aTHX_ PL_no_dir_func, "readdir");
4051 #else
4052 #if !defined(I_DIRENT) && !defined(VMS)
4053 Direntry_t *readdir (DIR *);
4054 #endif
4055 dSP;
4056
4057 SV *sv;
4058 const U8 gimme = GIMME_V;
4059 GV * const gv = MUTABLE_GV(POPs);
4060 const Direntry_t *dp;
4061 IO * const io = GvIOn(gv);
4062
4063 if (!IoDIRP(io)) {
4064 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4065 "readdir() attempted on invalid dirhandle %" HEKf,
4066 HEKfARG(GvENAME_HEK(gv)));
4067 goto nope;
4068 }
4069
4070 do {
4071 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
4072 if (!dp)
4073 break;
4074 #ifdef DIRNAMLEN
4075 sv = newSVpvn(dp->d_name, dp->d_namlen);
4076 #else
4077 sv = newSVpv(dp->d_name, 0);
4078 #endif
4079 if (!(IoFLAGS(io) & IOf_UNTAINT))
4080 SvTAINTED_on(sv);
4081 mXPUSHs(sv);
4082 } while (gimme == G_LIST);
4083
4084 if (!dp && gimme != G_LIST)
4085 RETPUSHUNDEF;
4086
4087 RETURN;
4088
4089 nope:
4090 if (!errno)
4091 SETERRNO(EBADF,RMS_ISI);
4092 if (gimme == G_LIST)
4093 RETURN;
4094 else
4095 RETPUSHUNDEF;
4096 #endif
4097 }
4098
PP(pp_telldir)4099 PP(pp_telldir)
4100 {
4101 #if defined(HAS_TELLDIR) || defined(telldir)
4102 dSP; dTARGET;
4103 /* XXX does _anyone_ need this? --AD 2/20/1998 */
4104 /* XXX netbsd still seemed to.
4105 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
4106 --JHI 1999-Feb-02 */
4107 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
4108 long telldir (DIR *);
4109 # endif
4110 GV * const gv = MUTABLE_GV(POPs);
4111 IO * const io = GvIOn(gv);
4112
4113 if (!IoDIRP(io)) {
4114 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4115 "telldir() attempted on invalid dirhandle %" HEKf,
4116 HEKfARG(GvENAME_HEK(gv)));
4117 goto nope;
4118 }
4119
4120 PUSHi( PerlDir_tell(IoDIRP(io)) );
4121 RETURN;
4122 nope:
4123 if (!errno)
4124 SETERRNO(EBADF,RMS_ISI);
4125 RETPUSHUNDEF;
4126 #else
4127 DIE(aTHX_ PL_no_dir_func, "telldir");
4128 #endif
4129 }
4130
PP(pp_seekdir)4131 PP(pp_seekdir)
4132 {
4133 #if defined(HAS_SEEKDIR) || defined(seekdir)
4134 dSP;
4135 const long along = POPl;
4136 GV * const gv = MUTABLE_GV(POPs);
4137 IO * const io = GvIOn(gv);
4138
4139 if (!IoDIRP(io)) {
4140 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4141 "seekdir() attempted on invalid dirhandle %" HEKf,
4142 HEKfARG(GvENAME_HEK(gv)));
4143 goto nope;
4144 }
4145 (void)PerlDir_seek(IoDIRP(io), along);
4146
4147 RETPUSHYES;
4148 nope:
4149 if (!errno)
4150 SETERRNO(EBADF,RMS_ISI);
4151 RETPUSHUNDEF;
4152 #else
4153 DIE(aTHX_ PL_no_dir_func, "seekdir");
4154 #endif
4155 }
4156
PP(pp_rewinddir)4157 PP(pp_rewinddir)
4158 {
4159 #if defined(HAS_REWINDDIR) || defined(rewinddir)
4160 dSP;
4161 GV * const gv = MUTABLE_GV(POPs);
4162 IO * const io = GvIOn(gv);
4163
4164 if (!IoDIRP(io)) {
4165 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4166 "rewinddir() attempted on invalid dirhandle %" HEKf,
4167 HEKfARG(GvENAME_HEK(gv)));
4168 goto nope;
4169 }
4170 (void)PerlDir_rewind(IoDIRP(io));
4171 RETPUSHYES;
4172 nope:
4173 if (!errno)
4174 SETERRNO(EBADF,RMS_ISI);
4175 RETPUSHUNDEF;
4176 #else
4177 DIE(aTHX_ PL_no_dir_func, "rewinddir");
4178 #endif
4179 }
4180
PP(pp_closedir)4181 PP(pp_closedir)
4182 {
4183 #if defined(Direntry_t) && defined(HAS_READDIR)
4184 dSP;
4185 GV * const gv = MUTABLE_GV(POPs);
4186 IO * const io = GvIOn(gv);
4187
4188 if (!IoDIRP(io)) {
4189 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4190 "closedir() attempted on invalid dirhandle %" HEKf,
4191 HEKfARG(GvENAME_HEK(gv)));
4192 goto nope;
4193 }
4194 #ifdef VOID_CLOSEDIR
4195 PerlDir_close(IoDIRP(io));
4196 #else
4197 if (PerlDir_close(IoDIRP(io)) < 0) {
4198 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4199 goto nope;
4200 }
4201 #endif
4202 IoDIRP(io) = 0;
4203
4204 RETPUSHYES;
4205 nope:
4206 if (!errno)
4207 SETERRNO(EBADF,RMS_IFI);
4208 RETPUSHUNDEF;
4209 #else
4210 DIE(aTHX_ PL_no_dir_func, "closedir");
4211 #endif
4212 }
4213
4214 /* Process control. */
4215
PP(pp_fork)4216 PP(pp_fork)
4217 {
4218 #ifdef HAS_FORK
4219 dSP; dTARGET;
4220 Pid_t childpid;
4221 #ifdef HAS_SIGPROCMASK
4222 sigset_t oldmask, newmask;
4223 #endif
4224
4225 EXTEND(SP, 1);
4226 PERL_FLUSHALL_FOR_CHILD;
4227 #ifdef HAS_SIGPROCMASK
4228 sigfillset(&newmask);
4229 sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4230 #endif
4231 childpid = PerlProc_fork();
4232 if (childpid == 0) {
4233 int sig;
4234 PL_sig_pending = 0;
4235 if (PL_psig_pend)
4236 for (sig = 1; sig < SIG_SIZE; sig++)
4237 PL_psig_pend[sig] = 0;
4238 }
4239 #ifdef HAS_SIGPROCMASK
4240 {
4241 dSAVE_ERRNO;
4242 sigprocmask(SIG_SETMASK, &oldmask, NULL);
4243 RESTORE_ERRNO;
4244 }
4245 #endif
4246 if (childpid < 0)
4247 RETPUSHUNDEF;
4248 if (!childpid) {
4249 #ifdef PERL_USES_PL_PIDSTATUS
4250 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4251 #endif
4252 }
4253 PUSHi(childpid);
4254 RETURN;
4255 #elif (defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)) || defined(__amigaos4__)
4256 dSP; dTARGET;
4257 Pid_t childpid;
4258
4259 EXTEND(SP, 1);
4260 PERL_FLUSHALL_FOR_CHILD;
4261 childpid = PerlProc_fork();
4262 if (childpid == -1)
4263 RETPUSHUNDEF;
4264 PUSHi(childpid);
4265 RETURN;
4266 #else
4267 DIE(aTHX_ PL_no_func, "fork");
4268 #endif
4269 }
4270
PP(pp_wait)4271 PP(pp_wait)
4272 {
4273 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4274 dSP; dTARGET;
4275 Pid_t childpid;
4276 int argflags;
4277
4278 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4279 childpid = wait4pid(-1, &argflags, 0);
4280 else {
4281 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4282 errno == EINTR) {
4283 PERL_ASYNC_CHECK();
4284 }
4285 }
4286 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4287 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4288 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4289 # else
4290 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4291 # endif
4292 XPUSHi(childpid);
4293 RETURN;
4294 #else
4295 DIE(aTHX_ PL_no_func, "wait");
4296 #endif
4297 }
4298
PP(pp_waitpid)4299 PP(pp_waitpid)
4300 {
4301 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4302 dSP; dTARGET;
4303 const int optype = POPi;
4304 const Pid_t pid = TOPi;
4305 Pid_t result;
4306 #ifdef __amigaos4__
4307 int argflags = 0;
4308 result = amigaos_waitpid(aTHX_ optype, pid, &argflags);
4309 STATUS_NATIVE_CHILD_SET((result >= 0) ? argflags : -1);
4310 result = result == 0 ? pid : -1;
4311 #else
4312 int argflags;
4313
4314 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4315 result = wait4pid(pid, &argflags, optype);
4316 else {
4317 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4318 errno == EINTR) {
4319 PERL_ASYNC_CHECK();
4320 }
4321 }
4322 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4323 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4324 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4325 # else
4326 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4327 # endif
4328 # endif /* __amigaos4__ */
4329 SETi(result);
4330 RETURN;
4331 #else
4332 DIE(aTHX_ PL_no_func, "waitpid");
4333 #endif
4334 }
4335
PP(pp_system)4336 PP(pp_system)
4337 {
4338 dSP; dMARK; dORIGMARK; dTARGET;
4339 #if defined(__LIBCATAMOUNT__)
4340 PL_statusvalue = -1;
4341 SP = ORIGMARK;
4342 XPUSHi(-1);
4343 #else
4344 I32 value;
4345 # ifdef __amigaos4__
4346 void * result;
4347 # else
4348 int result;
4349 # endif
4350
4351 while (++MARK <= SP) {
4352 SV *origsv = *MARK, *copysv;
4353 STRLEN len;
4354 char *pv;
4355 SvGETMAGIC(origsv);
4356 #if defined(WIN32) || defined(__VMS)
4357 /*
4358 * Because of a nasty platform-specific variation on the meaning
4359 * of arguments to this op, we must preserve numeric arguments
4360 * as numeric, not just retain the string value.
4361 */
4362 if (SvNIOK(origsv) || SvNIOKp(origsv)) {
4363 copysv = newSV_type(SVt_PVNV);
4364 sv_2mortal(copysv);
4365 if (SvPOK(origsv) || SvPOKp(origsv)) {
4366 pv = SvPV_nomg(origsv, len);
4367 sv_setpvn(copysv, pv, len);
4368 SvPOK_off(copysv);
4369 }
4370 if (SvIOK(origsv) || SvIOKp(origsv))
4371 SvIV_set(copysv, SvIVX(origsv));
4372 if (SvNOK(origsv) || SvNOKp(origsv))
4373 SvNV_set(copysv, SvNVX(origsv));
4374 SvFLAGS(copysv) |= SvFLAGS(origsv) &
4375 (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK|
4376 SVf_UTF8|SVf_IVisUV);
4377 } else
4378 #endif
4379 {
4380 pv = SvPV_nomg(origsv, len);
4381 copysv = newSVpvn_flags(pv, len,
4382 (SvFLAGS(origsv) & SVf_UTF8) | SVs_TEMP);
4383 }
4384 *MARK = copysv;
4385 }
4386 MARK = ORIGMARK;
4387
4388 if (TAINTING_get) {
4389 TAINT_ENV();
4390 TAINT_PROPER("system");
4391 }
4392 PERL_FLUSHALL_FOR_CHILD;
4393 #if (defined(HAS_FORK) || defined(__amigaos4__)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4394 {
4395 #ifdef __amigaos4__
4396 struct UserData userdata;
4397 pthread_t proc;
4398 #else
4399 Pid_t childpid;
4400 #endif
4401 int pp[2];
4402 I32 did_pipes = 0;
4403 bool child_success = FALSE;
4404 #ifdef HAS_SIGPROCMASK
4405 sigset_t newset, oldset;
4406 #endif
4407
4408 if (PerlProc_pipe_cloexec(pp) >= 0)
4409 did_pipes = 1;
4410 #ifdef __amigaos4__
4411 amigaos_fork_set_userdata(aTHX_
4412 &userdata,
4413 did_pipes,
4414 pp[1],
4415 SP,
4416 mark);
4417 pthread_create(&proc,NULL,amigaos_system_child,(void *)&userdata);
4418 child_success = proc > 0;
4419 #else
4420 #ifdef HAS_SIGPROCMASK
4421 sigemptyset(&newset);
4422 sigaddset(&newset, SIGCHLD);
4423 sigprocmask(SIG_BLOCK, &newset, &oldset);
4424 #endif
4425 while ((childpid = PerlProc_fork()) == -1) {
4426 if (errno != EAGAIN) {
4427 value = -1;
4428 SP = ORIGMARK;
4429 XPUSHi(value);
4430 if (did_pipes) {
4431 PerlLIO_close(pp[0]);
4432 PerlLIO_close(pp[1]);
4433 }
4434 #ifdef HAS_SIGPROCMASK
4435 sigprocmask(SIG_SETMASK, &oldset, NULL);
4436 #endif
4437 RETURN;
4438 }
4439 sleep(5);
4440 }
4441 child_success = childpid > 0;
4442 #endif
4443 if (child_success) {
4444 Sigsave_t ihand,qhand; /* place to save signals during system() */
4445 int status;
4446
4447 #ifndef __amigaos4__
4448 if (did_pipes)
4449 PerlLIO_close(pp[1]);
4450 #endif
4451 #ifndef PERL_MICRO
4452 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4453 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4454 #endif
4455 #ifdef __amigaos4__
4456 result = pthread_join(proc, (void **)&status);
4457 #else
4458 do {
4459 result = wait4pid(childpid, &status, 0);
4460 } while (result == -1 && errno == EINTR);
4461 #endif
4462 #ifndef PERL_MICRO
4463 #ifdef HAS_SIGPROCMASK
4464 sigprocmask(SIG_SETMASK, &oldset, NULL);
4465 #endif
4466 (void)rsignal_restore(SIGINT, &ihand);
4467 (void)rsignal_restore(SIGQUIT, &qhand);
4468 #endif
4469 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4470 SP = ORIGMARK;
4471 if (did_pipes) {
4472 int errkid;
4473 unsigned n = 0;
4474
4475 while (n < sizeof(int)) {
4476 const SSize_t n1 = PerlLIO_read(pp[0],
4477 (void*)(((char*)&errkid)+n),
4478 (sizeof(int)) - n);
4479 if (n1 <= 0)
4480 break;
4481 n += n1;
4482 }
4483 PerlLIO_close(pp[0]);
4484 if (n) { /* Error */
4485 if (n != sizeof(int))
4486 DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4487 errno = errkid; /* Propagate errno from kid */
4488 #ifdef __amigaos4__
4489 /* The pipe always has something in it
4490 * so n alone is not enough. */
4491 if (errno > 0)
4492 #endif
4493 {
4494 STATUS_NATIVE_CHILD_SET(-1);
4495 }
4496 }
4497 }
4498 XPUSHi(STATUS_CURRENT);
4499 RETURN;
4500 }
4501 #ifndef __amigaos4__
4502 #ifdef HAS_SIGPROCMASK
4503 sigprocmask(SIG_SETMASK, &oldset, NULL);
4504 #endif
4505 if (did_pipes)
4506 PerlLIO_close(pp[0]);
4507 if (PL_op->op_flags & OPf_STACKED) {
4508 SV * const really = *++MARK;
4509 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4510 }
4511 else if (SP - MARK != 1)
4512 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4513 else {
4514 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4515 }
4516 #endif /* __amigaos4__ */
4517 PerlProc__exit(-1);
4518 }
4519 #else /* ! FORK or VMS or OS/2 */
4520 PL_statusvalue = 0;
4521 result = 0;
4522 if (PL_op->op_flags & OPf_STACKED) {
4523 SV * const really = *++MARK;
4524 # if defined(WIN32) || defined(OS2) || defined(__VMS)
4525 value = (I32)do_aspawn(really, MARK, SP);
4526 # else
4527 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4528 # endif
4529 }
4530 else if (SP - MARK != 1) {
4531 # if defined(WIN32) || defined(OS2) || defined(__VMS)
4532 value = (I32)do_aspawn(NULL, MARK, SP);
4533 # else
4534 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4535 # endif
4536 }
4537 else {
4538 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4539 }
4540 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4541 result = 1;
4542 STATUS_NATIVE_CHILD_SET(value);
4543 SP = ORIGMARK;
4544 XPUSHi(result ? value : STATUS_CURRENT);
4545 #endif /* !FORK or VMS or OS/2 */
4546 #endif
4547 RETURN;
4548 }
4549
PP(pp_exec)4550 PP(pp_exec)
4551 {
4552 dSP; dMARK; dORIGMARK; dTARGET;
4553 I32 value;
4554
4555 if (TAINTING_get) {
4556 TAINT_ENV();
4557 while (++MARK <= SP) {
4558 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4559 if (TAINT_get)
4560 break;
4561 }
4562 MARK = ORIGMARK;
4563 TAINT_PROPER("exec");
4564 }
4565
4566 PERL_FLUSHALL_FOR_CHILD;
4567 if (PL_op->op_flags & OPf_STACKED) {
4568 SV * const really = *++MARK;
4569 value = (I32)do_aexec(really, MARK, SP);
4570 }
4571 else if (SP - MARK != 1)
4572 #ifdef VMS
4573 value = (I32)vms_do_aexec(NULL, MARK, SP);
4574 #else
4575 value = (I32)do_aexec(NULL, MARK, SP);
4576 #endif
4577 else {
4578 #ifdef VMS
4579 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4580 #else
4581 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4582 #endif
4583 }
4584 SP = ORIGMARK;
4585 XPUSHi(value);
4586 RETURN;
4587 }
4588
PP(pp_getppid)4589 PP(pp_getppid)
4590 {
4591 #ifdef HAS_GETPPID
4592 dSP; dTARGET;
4593 XPUSHi( getppid() );
4594 RETURN;
4595 #else
4596 DIE(aTHX_ PL_no_func, "getppid");
4597 #endif
4598 }
4599
PP(pp_getpgrp)4600 PP(pp_getpgrp)
4601 {
4602 #ifdef HAS_GETPGRP
4603 dSP; dTARGET;
4604 Pid_t pgrp;
4605 const Pid_t pid =
4606 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4607
4608 #ifdef BSD_GETPGRP
4609 pgrp = (I32)BSD_GETPGRP(pid);
4610 #else
4611 if (pid != 0 && pid != PerlProc_getpid())
4612 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4613 pgrp = getpgrp();
4614 #endif
4615 XPUSHi(pgrp);
4616 RETURN;
4617 #else
4618 DIE(aTHX_ PL_no_func, "getpgrp");
4619 #endif
4620 }
4621
PP(pp_setpgrp)4622 PP(pp_setpgrp)
4623 {
4624 #ifdef HAS_SETPGRP
4625 dSP; dTARGET;
4626 Pid_t pgrp;
4627 Pid_t pid;
4628 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4629 if (MAXARG > 0) pid = TOPs ? TOPi : 0;
4630 else {
4631 pid = 0;
4632 EXTEND(SP,1);
4633 SP++;
4634 }
4635
4636 TAINT_PROPER("setpgrp");
4637 #ifdef BSD_SETPGRP
4638 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4639 #else
4640 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4641 || (pid != 0 && pid != PerlProc_getpid()))
4642 {
4643 DIE(aTHX_ "setpgrp can't take arguments");
4644 }
4645 SETi( setpgrp() >= 0 );
4646 #endif /* USE_BSDPGRP */
4647 RETURN;
4648 #else
4649 DIE(aTHX_ PL_no_func, "setpgrp");
4650 #endif
4651 }
4652
4653 /*
4654 * The glibc headers typedef __priority_which_t to an enum under C, but
4655 * under C++, it keeps it as int. -Wc++-compat doesn't know this, so we
4656 * need to explicitly cast it to shut up the warning.
4657 */
4658 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4659 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4660 #else
4661 # define PRIORITY_WHICH_T(which) which
4662 #endif
4663
PP(pp_getpriority)4664 PP(pp_getpriority)
4665 {
4666 #ifdef HAS_GETPRIORITY
4667 dSP; dTARGET;
4668 const int who = POPi;
4669 const int which = TOPi;
4670 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4671 RETURN;
4672 #else
4673 DIE(aTHX_ PL_no_func, "getpriority");
4674 #endif
4675 }
4676
PP(pp_setpriority)4677 PP(pp_setpriority)
4678 {
4679 #ifdef HAS_SETPRIORITY
4680 dSP; dTARGET;
4681 const int niceval = POPi;
4682 const int who = POPi;
4683 const int which = TOPi;
4684 TAINT_PROPER("setpriority");
4685 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4686 RETURN;
4687 #else
4688 DIE(aTHX_ PL_no_func, "setpriority");
4689 #endif
4690 }
4691
4692 #undef PRIORITY_WHICH_T
4693
4694 /* Time calls. */
4695
PP(pp_time)4696 PP(pp_time)
4697 {
4698 dSP; dTARGET;
4699 #ifdef BIG_TIME
4700 XPUSHn( (NV)time(NULL) );
4701 #else
4702 XPUSHu( (UV)time(NULL) );
4703 #endif
4704 RETURN;
4705 }
4706
PP(pp_tms)4707 PP(pp_tms)
4708 {
4709 #ifdef HAS_TIMES
4710 dSP;
4711 struct tms timesbuf;
4712
4713 EXTEND(SP, 4);
4714 (void)PerlProc_times(×buf);
4715
4716 mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick);
4717 if (GIMME_V == G_LIST) {
4718 mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick);
4719 mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick);
4720 mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick);
4721 }
4722 RETURN;
4723 #elif defined(PERL_MICRO)
4724 dSP;
4725 mPUSHn(0.0);
4726 EXTEND(SP, 4);
4727 if (GIMME_V == G_LIST) {
4728 mPUSHn(0.0);
4729 mPUSHn(0.0);
4730 mPUSHn(0.0);
4731 }
4732 RETURN;
4733 #else
4734 DIE(aTHX_ "times not implemented");
4735 #endif /* HAS_TIMES */
4736 }
4737
4738 /* The 32 bit int year limits the times we can represent to these
4739 boundaries with a few days wiggle room to account for time zone
4740 offsets
4741 */
4742 /* Sat Jan 3 00:00:00 -2147481748 */
4743 #define TIME_LOWER_BOUND -67768100567755200.0
4744 /* Sun Dec 29 12:00:00 2147483647 */
4745 #define TIME_UPPER_BOUND 67767976233316800.0
4746
4747
4748 /* also used for: pp_localtime() */
4749
PP(pp_gmtime)4750 PP(pp_gmtime)
4751 {
4752 dSP;
4753 Time64_T when;
4754 struct TM tmbuf;
4755 struct TM *err;
4756 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4757 static const char * const dayname[] =
4758 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4759 static const char * const monname[] =
4760 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4761 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4762
4763 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4764 time_t now;
4765 (void)time(&now);
4766 when = (Time64_T)now;
4767 }
4768 else {
4769 NV input = Perl_floor(POPn);
4770 const bool pl_isnan = Perl_isnan(input);
4771 when = (Time64_T)input;
4772 if (UNLIKELY(pl_isnan || when != input)) {
4773 /* diag_listed_as: gmtime(%f) too large */
4774 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4775 "%s(%.0" NVff ") too large", opname, input);
4776 if (pl_isnan) {
4777 err = NULL;
4778 goto failed;
4779 }
4780 }
4781 }
4782
4783 if ( TIME_LOWER_BOUND > when ) {
4784 /* diag_listed_as: gmtime(%f) too small */
4785 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4786 "%s(%.0" NVff ") too small", opname, when);
4787 err = NULL;
4788 }
4789 else if( when > TIME_UPPER_BOUND ) {
4790 /* diag_listed_as: gmtime(%f) too small */
4791 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4792 "%s(%.0" NVff ") too large", opname, when);
4793 err = NULL;
4794 }
4795 else {
4796 if (PL_op->op_type == OP_LOCALTIME)
4797 err = Perl_localtime64_r(&when, &tmbuf);
4798 else
4799 err = Perl_gmtime64_r(&when, &tmbuf);
4800 }
4801
4802 if (err == NULL) {
4803 /* diag_listed_as: gmtime(%f) failed */
4804 /* XXX %lld broken for quads */
4805 failed:
4806 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4807 "%s(%.0" NVff ") failed", opname, when);
4808 }
4809
4810 if (GIMME_V != G_LIST) { /* scalar context */
4811 EXTEND(SP, 1);
4812 if (err == NULL)
4813 RETPUSHUNDEF;
4814 else {
4815 dTARGET;
4816 PUSHs(TARG);
4817 Perl_sv_setpvf_mg(aTHX_ TARG, "%s %s %2d %02d:%02d:%02d %" IVdf,
4818 dayname[tmbuf.tm_wday],
4819 monname[tmbuf.tm_mon],
4820 tmbuf.tm_mday,
4821 tmbuf.tm_hour,
4822 tmbuf.tm_min,
4823 tmbuf.tm_sec,
4824 (IV)tmbuf.tm_year + 1900);
4825 }
4826 }
4827 else { /* list context */
4828 if ( err == NULL )
4829 RETURN;
4830
4831 EXTEND(SP, 9);
4832 EXTEND_MORTAL(9);
4833 mPUSHi(tmbuf.tm_sec);
4834 mPUSHi(tmbuf.tm_min);
4835 mPUSHi(tmbuf.tm_hour);
4836 mPUSHi(tmbuf.tm_mday);
4837 mPUSHi(tmbuf.tm_mon);
4838 mPUSHn(tmbuf.tm_year);
4839 mPUSHi(tmbuf.tm_wday);
4840 mPUSHi(tmbuf.tm_yday);
4841 mPUSHi(tmbuf.tm_isdst);
4842 }
4843 RETURN;
4844 }
4845
PP(pp_alarm)4846 PP(pp_alarm)
4847 {
4848 #ifdef HAS_ALARM
4849 dSP; dTARGET;
4850 /* alarm() takes an unsigned int number of seconds, and return the
4851 * unsigned int number of seconds remaining in the previous alarm
4852 * (alarms don't stack). Therefore negative return values are not
4853 * possible. */
4854 int anum = POPi;
4855 if (anum < 0) {
4856 /* Note that while the C library function alarm() as such has
4857 * no errors defined (or in other words, properly behaving client
4858 * code shouldn't expect any), alarm() being obsoleted by
4859 * setitimer() and often being implemented in terms of
4860 * setitimer(), can fail. */
4861 /* diag_listed_as: %s() with negative argument */
4862 Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
4863 "alarm() with negative argument");
4864 SETERRNO(EINVAL, LIB_INVARG);
4865 RETPUSHUNDEF;
4866 }
4867 else {
4868 unsigned int retval = alarm(anum);
4869 if ((int)retval < 0) /* Strictly speaking "cannot happen". */
4870 RETPUSHUNDEF;
4871 PUSHu(retval);
4872 RETURN;
4873 }
4874 #else
4875 DIE(aTHX_ PL_no_func, "alarm");
4876 #endif
4877 }
4878
PP(pp_sleep)4879 PP(pp_sleep)
4880 {
4881 dSP; dTARGET;
4882 Time_t lasttime;
4883 Time_t when;
4884
4885 (void)time(&lasttime);
4886 if (MAXARG < 1 || (!TOPs && !POPs))
4887 PerlProc_pause();
4888 else {
4889 const I32 duration = POPi;
4890 if (duration < 0) {
4891 /* diag_listed_as: %s() with negative argument */
4892 Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
4893 "sleep() with negative argument");
4894 SETERRNO(EINVAL, LIB_INVARG);
4895 XPUSHs(&PL_sv_zero);
4896 RETURN;
4897 } else {
4898 PerlProc_sleep((unsigned int)duration);
4899 }
4900 }
4901 (void)time(&when);
4902 XPUSHu((UV)(when - lasttime));
4903 RETURN;
4904 }
4905
4906 /* Shared memory. */
4907 /* Merged with some message passing. */
4908
4909 /* also used for: pp_msgrcv() pp_msgsnd() pp_semop() pp_shmread() */
4910
PP(pp_shmwrite)4911 PP(pp_shmwrite)
4912 {
4913 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4914 dSP; dMARK; dTARGET;
4915 const int op_type = PL_op->op_type;
4916 I32 value;
4917
4918 switch (op_type) {
4919 case OP_MSGSND:
4920 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4921 break;
4922 case OP_MSGRCV:
4923 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4924 break;
4925 case OP_SEMOP:
4926 value = (I32)(do_semop(MARK, SP) >= 0);
4927 break;
4928 default:
4929 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4930 break;
4931 }
4932
4933 SP = MARK;
4934 PUSHi(value);
4935 RETURN;
4936 #else
4937 return Perl_pp_semget(aTHX);
4938 #endif
4939 }
4940
4941 /* Semaphores. */
4942
4943 /* also used for: pp_msgget() pp_shmget() */
4944
PP(pp_semget)4945 PP(pp_semget)
4946 {
4947 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4948 dSP; dMARK; dTARGET;
4949 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4950 SP = MARK;
4951 if (anum == -1)
4952 RETPUSHUNDEF;
4953 PUSHi(anum);
4954 RETURN;
4955 #else
4956 DIE(aTHX_ "System V IPC is not implemented on this machine");
4957 #endif
4958 }
4959
4960 /* also used for: pp_msgctl() pp_shmctl() */
4961
PP(pp_semctl)4962 PP(pp_semctl)
4963 {
4964 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4965 dSP; dMARK; dTARGET;
4966 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4967 SP = MARK;
4968 if (anum == -1)
4969 RETPUSHUNDEF;
4970 if (anum != 0) {
4971 PUSHi(anum);
4972 }
4973 else {
4974 PUSHp(zero_but_true, ZBTLEN);
4975 }
4976 RETURN;
4977 #else
4978 return Perl_pp_semget(aTHX);
4979 #endif
4980 }
4981
4982 /* I can't const this further without getting warnings about the types of
4983 various arrays passed in from structures. */
4984 static SV *
S_space_join_names_mortal(pTHX_ char * const * array)4985 S_space_join_names_mortal(pTHX_ char *const *array)
4986 {
4987 SV *target;
4988
4989 if (array && *array) {
4990 target = newSVpvs_flags("", SVs_TEMP);
4991 while (1) {
4992 sv_catpv(target, *array);
4993 if (!*++array)
4994 break;
4995 sv_catpvs(target, " ");
4996 }
4997 } else {
4998 target = sv_mortalcopy(&PL_sv_no);
4999 }
5000 return target;
5001 }
5002
5003 /* Get system info. */
5004
5005 /* also used for: pp_ghbyaddr() pp_ghbyname() */
5006
PP(pp_ghostent)5007 PP(pp_ghostent)
5008 {
5009 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
5010 dSP;
5011 I32 which = PL_op->op_type;
5012 char **elem;
5013 SV *sv;
5014 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
5015 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
5016 struct hostent *gethostbyname(Netdb_name_t);
5017 struct hostent *gethostent(void);
5018 #endif
5019 struct hostent *hent = NULL;
5020 unsigned long len;
5021
5022 EXTEND(SP, 10);
5023 if (which == OP_GHBYNAME) {
5024 #ifdef HAS_GETHOSTBYNAME
5025 const char* const name = POPpbytex;
5026 hent = PerlSock_gethostbyname(name);
5027 #else
5028 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
5029 #endif
5030 }
5031 else if (which == OP_GHBYADDR) {
5032 #ifdef HAS_GETHOSTBYADDR
5033 const int addrtype = POPi;
5034 SV * const addrsv = POPs;
5035 STRLEN addrlen;
5036 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
5037
5038 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
5039 #else
5040 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
5041 #endif
5042 }
5043 else
5044 #ifdef HAS_GETHOSTENT
5045 hent = PerlSock_gethostent();
5046 #else
5047 DIE(aTHX_ PL_no_sock_func, "gethostent");
5048 #endif
5049
5050 #ifdef HOST_NOT_FOUND
5051 if (!hent) {
5052 #ifdef USE_REENTRANT_API
5053 # ifdef USE_GETHOSTENT_ERRNO
5054 h_errno = PL_reentrant_buffer->_gethostent_errno;
5055 # endif
5056 #endif
5057 STATUS_UNIX_SET(h_errno);
5058 }
5059 #endif
5060
5061 if (GIMME_V != G_LIST) {
5062 PUSHs(sv = sv_newmortal());
5063 if (hent) {
5064 if (which == OP_GHBYNAME) {
5065 if (hent->h_addr)
5066 sv_setpvn(sv, hent->h_addr, hent->h_length);
5067 }
5068 else
5069 sv_setpv(sv, (char*)hent->h_name);
5070 }
5071 RETURN;
5072 }
5073
5074 if (hent) {
5075 mPUSHs(newSVpv((char*)hent->h_name, 0));
5076 PUSHs(space_join_names_mortal(hent->h_aliases));
5077 mPUSHi(hent->h_addrtype);
5078 len = hent->h_length;
5079 mPUSHi(len);
5080 #ifdef h_addr
5081 for (elem = hent->h_addr_list; elem && *elem; elem++) {
5082 mXPUSHp(*elem, len);
5083 }
5084 #else
5085 if (hent->h_addr)
5086 mPUSHp(hent->h_addr, len);
5087 else
5088 PUSHs(sv_mortalcopy(&PL_sv_no));
5089 #endif /* h_addr */
5090 }
5091 RETURN;
5092 #else
5093 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5094 #endif
5095 }
5096
5097 /* also used for: pp_gnbyaddr() pp_gnbyname() */
5098
PP(pp_gnetent)5099 PP(pp_gnetent)
5100 {
5101 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
5102 dSP;
5103 I32 which = PL_op->op_type;
5104 SV *sv;
5105 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
5106 struct netent *getnetbyaddr(Netdb_net_t, int);
5107 struct netent *getnetbyname(Netdb_name_t);
5108 struct netent *getnetent(void);
5109 #endif
5110 struct netent *nent;
5111
5112 if (which == OP_GNBYNAME){
5113 #ifdef HAS_GETNETBYNAME
5114 const char * const name = POPpbytex;
5115 nent = PerlSock_getnetbyname(name);
5116 #else
5117 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
5118 #endif
5119 }
5120 else if (which == OP_GNBYADDR) {
5121 #ifdef HAS_GETNETBYADDR
5122 const int addrtype = POPi;
5123 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
5124 nent = PerlSock_getnetbyaddr(addr, addrtype);
5125 #else
5126 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
5127 #endif
5128 }
5129 else
5130 #ifdef HAS_GETNETENT
5131 nent = PerlSock_getnetent();
5132 #else
5133 DIE(aTHX_ PL_no_sock_func, "getnetent");
5134 #endif
5135
5136 #ifdef HOST_NOT_FOUND
5137 if (!nent) {
5138 #ifdef USE_REENTRANT_API
5139 # ifdef USE_GETNETENT_ERRNO
5140 h_errno = PL_reentrant_buffer->_getnetent_errno;
5141 # endif
5142 #endif
5143 STATUS_UNIX_SET(h_errno);
5144 }
5145 #endif
5146
5147 EXTEND(SP, 4);
5148 if (GIMME_V != G_LIST) {
5149 PUSHs(sv = sv_newmortal());
5150 if (nent) {
5151 if (which == OP_GNBYNAME)
5152 sv_setiv(sv, (IV)nent->n_net);
5153 else
5154 sv_setpv(sv, nent->n_name);
5155 }
5156 RETURN;
5157 }
5158
5159 if (nent) {
5160 mPUSHs(newSVpv(nent->n_name, 0));
5161 PUSHs(space_join_names_mortal(nent->n_aliases));
5162 mPUSHi(nent->n_addrtype);
5163 mPUSHi(nent->n_net);
5164 }
5165
5166 RETURN;
5167 #else
5168 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5169 #endif
5170 }
5171
5172
5173 /* also used for: pp_gpbyname() pp_gpbynumber() */
5174
PP(pp_gprotoent)5175 PP(pp_gprotoent)
5176 {
5177 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
5178 dSP;
5179 I32 which = PL_op->op_type;
5180 SV *sv;
5181 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
5182 struct protoent *getprotobyname(Netdb_name_t);
5183 struct protoent *getprotobynumber(int);
5184 struct protoent *getprotoent(void);
5185 #endif
5186 struct protoent *pent;
5187
5188 if (which == OP_GPBYNAME) {
5189 #ifdef HAS_GETPROTOBYNAME
5190 const char* const name = POPpbytex;
5191 pent = PerlSock_getprotobyname(name);
5192 #else
5193 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
5194 #endif
5195 }
5196 else if (which == OP_GPBYNUMBER) {
5197 #ifdef HAS_GETPROTOBYNUMBER
5198 const int number = POPi;
5199 pent = PerlSock_getprotobynumber(number);
5200 #else
5201 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
5202 #endif
5203 }
5204 else
5205 #ifdef HAS_GETPROTOENT
5206 pent = PerlSock_getprotoent();
5207 #else
5208 DIE(aTHX_ PL_no_sock_func, "getprotoent");
5209 #endif
5210
5211 EXTEND(SP, 3);
5212 if (GIMME_V != G_LIST) {
5213 PUSHs(sv = sv_newmortal());
5214 if (pent) {
5215 if (which == OP_GPBYNAME)
5216 sv_setiv(sv, (IV)pent->p_proto);
5217 else
5218 sv_setpv(sv, pent->p_name);
5219 }
5220 RETURN;
5221 }
5222
5223 if (pent) {
5224 mPUSHs(newSVpv(pent->p_name, 0));
5225 PUSHs(space_join_names_mortal(pent->p_aliases));
5226 mPUSHi(pent->p_proto);
5227 }
5228
5229 RETURN;
5230 #else
5231 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5232 #endif
5233 }
5234
5235
5236 /* also used for: pp_gsbyname() pp_gsbyport() */
5237
PP(pp_gservent)5238 PP(pp_gservent)
5239 {
5240 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
5241 dSP;
5242 I32 which = PL_op->op_type;
5243 SV *sv;
5244 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
5245 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
5246 struct servent *getservbyport(int, Netdb_name_t);
5247 struct servent *getservent(void);
5248 #endif
5249 struct servent *sent;
5250
5251 if (which == OP_GSBYNAME) {
5252 #ifdef HAS_GETSERVBYNAME
5253 const char * const proto = POPpbytex;
5254 const char * const name = POPpbytex;
5255 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
5256 #else
5257 DIE(aTHX_ PL_no_sock_func, "getservbyname");
5258 #endif
5259 }
5260 else if (which == OP_GSBYPORT) {
5261 #ifdef HAS_GETSERVBYPORT
5262 const char * const proto = POPpbytex;
5263 unsigned short port = (unsigned short)POPu;
5264 port = PerlSock_htons(port);
5265 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
5266 #else
5267 DIE(aTHX_ PL_no_sock_func, "getservbyport");
5268 #endif
5269 }
5270 else
5271 #ifdef HAS_GETSERVENT
5272 sent = PerlSock_getservent();
5273 #else
5274 DIE(aTHX_ PL_no_sock_func, "getservent");
5275 #endif
5276
5277 EXTEND(SP, 4);
5278 if (GIMME_V != G_LIST) {
5279 PUSHs(sv = sv_newmortal());
5280 if (sent) {
5281 if (which == OP_GSBYNAME) {
5282 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5283 }
5284 else
5285 sv_setpv(sv, sent->s_name);
5286 }
5287 RETURN;
5288 }
5289
5290 if (sent) {
5291 mPUSHs(newSVpv(sent->s_name, 0));
5292 PUSHs(space_join_names_mortal(sent->s_aliases));
5293 mPUSHi(PerlSock_ntohs(sent->s_port));
5294 mPUSHs(newSVpv(sent->s_proto, 0));
5295 }
5296
5297 RETURN;
5298 #else
5299 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5300 #endif
5301 }
5302
5303
5304 /* also used for: pp_snetent() pp_sprotoent() pp_sservent() */
5305
PP(pp_shostent)5306 PP(pp_shostent)
5307 {
5308 dSP;
5309 const int stayopen = TOPi;
5310 switch(PL_op->op_type) {
5311 case OP_SHOSTENT:
5312 #ifdef HAS_SETHOSTENT
5313 PerlSock_sethostent(stayopen);
5314 #else
5315 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5316 #endif
5317 break;
5318 case OP_SNETENT:
5319 #ifdef HAS_SETNETENT
5320 PerlSock_setnetent(stayopen);
5321 #else
5322 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5323 #endif
5324 break;
5325 case OP_SPROTOENT:
5326 #ifdef HAS_SETPROTOENT
5327 PerlSock_setprotoent(stayopen);
5328 #else
5329 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5330 #endif
5331 break;
5332 case OP_SSERVENT:
5333 #ifdef HAS_SETSERVENT
5334 PerlSock_setservent(stayopen);
5335 #else
5336 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5337 #endif
5338 break;
5339 }
5340 RETSETYES;
5341 }
5342
5343
5344 /* also used for: pp_egrent() pp_enetent() pp_eprotoent() pp_epwent()
5345 * pp_eservent() pp_sgrent() pp_spwent() */
5346
PP(pp_ehostent)5347 PP(pp_ehostent)
5348 {
5349 dSP;
5350 switch(PL_op->op_type) {
5351 case OP_EHOSTENT:
5352 #ifdef HAS_ENDHOSTENT
5353 PerlSock_endhostent();
5354 #else
5355 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5356 #endif
5357 break;
5358 case OP_ENETENT:
5359 #ifdef HAS_ENDNETENT
5360 PerlSock_endnetent();
5361 #else
5362 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5363 #endif
5364 break;
5365 case OP_EPROTOENT:
5366 #ifdef HAS_ENDPROTOENT
5367 PerlSock_endprotoent();
5368 #else
5369 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5370 #endif
5371 break;
5372 case OP_ESERVENT:
5373 #ifdef HAS_ENDSERVENT
5374 PerlSock_endservent();
5375 #else
5376 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5377 #endif
5378 break;
5379 case OP_SGRENT:
5380 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5381 setgrent();
5382 #else
5383 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5384 #endif
5385 break;
5386 case OP_EGRENT:
5387 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5388 endgrent();
5389 #else
5390 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5391 #endif
5392 break;
5393 case OP_SPWENT:
5394 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5395 setpwent();
5396 #else
5397 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5398 #endif
5399 break;
5400 case OP_EPWENT:
5401 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5402 endpwent();
5403 #else
5404 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5405 #endif
5406 break;
5407 }
5408 EXTEND(SP,1);
5409 RETPUSHYES;
5410 }
5411
5412
5413 /* also used for: pp_gpwnam() pp_gpwuid() */
5414
PP(pp_gpwent)5415 PP(pp_gpwent)
5416 {
5417 #ifdef HAS_PASSWD
5418 dSP;
5419 I32 which = PL_op->op_type;
5420 SV *sv;
5421 struct passwd *pwent = NULL;
5422 /*
5423 * We currently support only the SysV getsp* shadow password interface.
5424 * The interface is declared in <shadow.h> and often one needs to link
5425 * with -lsecurity or some such.
5426 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5427 * (and SCO?)
5428 *
5429 * AIX getpwnam() is clever enough to return the encrypted password
5430 * only if the caller (euid?) is root.
5431 *
5432 * There are at least three other shadow password APIs. Many platforms
5433 * seem to contain more than one interface for accessing the shadow
5434 * password databases, possibly for compatibility reasons.
5435 * The getsp*() is by far he simplest one, the other two interfaces
5436 * are much more complicated, but also very similar to each other.
5437 *
5438 * <sys/types.h>
5439 * <sys/security.h>
5440 * <prot.h>
5441 * struct pr_passwd *getprpw*();
5442 * The password is in
5443 * char getprpw*(...).ufld.fd_encrypt[]
5444 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5445 *
5446 * <sys/types.h>
5447 * <sys/security.h>
5448 * <prot.h>
5449 * struct es_passwd *getespw*();
5450 * The password is in
5451 * char *(getespw*(...).ufld.fd_encrypt)
5452 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5453 *
5454 * <userpw.h> (AIX)
5455 * struct userpw *getuserpw();
5456 * The password is in
5457 * char *(getuserpw(...)).spw_upw_passwd
5458 * (but the de facto standard getpwnam() should work okay)
5459 *
5460 * Mention I_PROT here so that Configure probes for it.
5461 *
5462 * In HP-UX for getprpw*() the manual page claims that one should include
5463 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5464 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5465 * and pp_sys.c already includes <shadow.h> if there is such.
5466 *
5467 * Note that <sys/security.h> is already probed for, but currently
5468 * it is only included in special cases.
5469 *
5470 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5471 * the preferred interface, even though also the getprpw*() interface
5472 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5473 * One also needs to call set_auth_parameters() in main() before
5474 * doing anything else, whether one is using getespw*() or getprpw*().
5475 *
5476 * Note that accessing the shadow databases can be magnitudes
5477 * slower than accessing the standard databases.
5478 *
5479 * --jhi
5480 */
5481
5482 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5483 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5484 * the pw_comment is left uninitialized. */
5485 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5486 # endif
5487
5488 switch (which) {
5489 case OP_GPWNAM:
5490 {
5491 const char* const name = POPpbytex;
5492 pwent = getpwnam(name);
5493 }
5494 break;
5495 case OP_GPWUID:
5496 {
5497 Uid_t uid = POPi;
5498 pwent = getpwuid(uid);
5499 }
5500 break;
5501 case OP_GPWENT:
5502 # ifdef HAS_GETPWENT
5503 pwent = getpwent();
5504 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5505 if (pwent) pwent = getpwnam(pwent->pw_name);
5506 #endif
5507 # else
5508 DIE(aTHX_ PL_no_func, "getpwent");
5509 # endif
5510 break;
5511 }
5512
5513 EXTEND(SP, 10);
5514 if (GIMME_V != G_LIST) {
5515 PUSHs(sv = sv_newmortal());
5516 if (pwent) {
5517 if (which == OP_GPWNAM)
5518 sv_setuid(sv, pwent->pw_uid);
5519 else
5520 sv_setpv(sv, pwent->pw_name);
5521 }
5522 RETURN;
5523 }
5524
5525 if (pwent) {
5526 mPUSHs(newSVpv(pwent->pw_name, 0));
5527
5528 sv = newSViv(0);
5529 mPUSHs(sv);
5530 /* If we have getspnam(), we try to dig up the shadow
5531 * password. If we are underprivileged, the shadow
5532 * interface will set the errno to EACCES or similar,
5533 * and return a null pointer. If this happens, we will
5534 * use the dummy password (usually "*" or "x") from the
5535 * standard password database.
5536 *
5537 * In theory we could skip the shadow call completely
5538 * if euid != 0 but in practice we cannot know which
5539 * security measures are guarding the shadow databases
5540 * on a random platform.
5541 *
5542 * Resist the urge to use additional shadow interfaces.
5543 * Divert the urge to writing an extension instead.
5544 *
5545 * --jhi */
5546 /* Some AIX setups falsely(?) detect some getspnam(), which
5547 * has a different API than the Solaris/IRIX one. */
5548 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5549 {
5550 dSAVE_ERRNO;
5551 const struct spwd * const spwent = getspnam(pwent->pw_name);
5552 /* Save and restore errno so that
5553 * underprivileged attempts seem
5554 * to have never made the unsuccessful
5555 * attempt to retrieve the shadow password. */
5556 RESTORE_ERRNO;
5557 if (spwent && spwent->sp_pwdp)
5558 sv_setpv(sv, spwent->sp_pwdp);
5559 }
5560 # endif
5561 # ifdef PWPASSWD
5562 if (!SvPOK(sv)) /* Use the standard password, then. */
5563 sv_setpv(sv, pwent->pw_passwd);
5564 # endif
5565
5566 /* passwd is tainted because user himself can diddle with it.
5567 * admittedly not much and in a very limited way, but nevertheless. */
5568 SvTAINTED_on(sv);
5569
5570 sv_setuid(PUSHmortal, pwent->pw_uid);
5571 sv_setgid(PUSHmortal, pwent->pw_gid);
5572
5573 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5574 * because of the poor interface of the Perl getpw*(),
5575 * not because there's some standard/convention saying so.
5576 * A better interface would have been to return a hash,
5577 * but we are accursed by our history, alas. --jhi. */
5578 # ifdef PWCHANGE
5579 mPUSHi(pwent->pw_change);
5580 # elif defined(PWQUOTA)
5581 mPUSHi(pwent->pw_quota);
5582 # elif defined(PWAGE)
5583 mPUSHs(newSVpv(pwent->pw_age, 0));
5584 # else
5585 /* I think that you can never get this compiled, but just in case. */
5586 PUSHs(sv_mortalcopy(&PL_sv_no));
5587 # endif
5588
5589 /* pw_class and pw_comment are mutually exclusive--.
5590 * see the above note for pw_change, pw_quota, and pw_age. */
5591 # ifdef PWCLASS
5592 mPUSHs(newSVpv(pwent->pw_class, 0));
5593 # elif defined(PWCOMMENT)
5594 mPUSHs(newSVpv(pwent->pw_comment, 0));
5595 # else
5596 /* I think that you can never get this compiled, but just in case. */
5597 PUSHs(sv_mortalcopy(&PL_sv_no));
5598 # endif
5599
5600 # ifdef PWGECOS
5601 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5602 # else
5603 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5604 # endif
5605 /* pw_gecos is tainted because user himself can diddle with it. */
5606 SvTAINTED_on(sv);
5607
5608 mPUSHs(newSVpv(pwent->pw_dir, 0));
5609
5610 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5611 /* pw_shell is tainted because user himself can diddle with it. */
5612 SvTAINTED_on(sv);
5613
5614 # ifdef PWEXPIRE
5615 mPUSHi(pwent->pw_expire);
5616 # endif
5617 }
5618 RETURN;
5619 #else
5620 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5621 #endif
5622 }
5623
5624
5625 /* also used for: pp_ggrgid() pp_ggrnam() */
5626
PP(pp_ggrent)5627 PP(pp_ggrent)
5628 {
5629 #ifdef HAS_GROUP
5630 dSP;
5631 const I32 which = PL_op->op_type;
5632 const struct group *grent;
5633
5634 if (which == OP_GGRNAM) {
5635 const char* const name = POPpbytex;
5636 grent = (const struct group *)getgrnam(name);
5637 }
5638 else if (which == OP_GGRGID) {
5639 #if Gid_t_sign == 1
5640 const Gid_t gid = POPu;
5641 #elif Gid_t_sign == -1
5642 const Gid_t gid = POPi;
5643 #else
5644 # error "Unexpected Gid_t_sign"
5645 #endif
5646 grent = (const struct group *)getgrgid(gid);
5647 }
5648 else
5649 #ifdef HAS_GETGRENT
5650 grent = (struct group *)getgrent();
5651 #else
5652 DIE(aTHX_ PL_no_func, "getgrent");
5653 #endif
5654
5655 EXTEND(SP, 4);
5656 if (GIMME_V != G_LIST) {
5657 SV * const sv = sv_newmortal();
5658
5659 PUSHs(sv);
5660 if (grent) {
5661 if (which == OP_GGRNAM)
5662 sv_setgid(sv, grent->gr_gid);
5663 else
5664 sv_setpv(sv, grent->gr_name);
5665 }
5666 RETURN;
5667 }
5668
5669 if (grent) {
5670 mPUSHs(newSVpv(grent->gr_name, 0));
5671
5672 #ifdef GRPASSWD
5673 mPUSHs(newSVpv(grent->gr_passwd, 0));
5674 #else
5675 PUSHs(sv_mortalcopy(&PL_sv_no));
5676 #endif
5677
5678 sv_setgid(PUSHmortal, grent->gr_gid);
5679
5680 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5681 /* In UNICOS/mk (_CRAYMPP) the multithreading
5682 * versions (getgrnam_r, getgrgid_r)
5683 * seem to return an illegal pointer
5684 * as the group members list, gr_mem.
5685 * getgrent() doesn't even have a _r version
5686 * but the gr_mem is poisonous anyway.
5687 * So yes, you cannot get the list of group
5688 * members if building multithreaded in UNICOS/mk. */
5689 PUSHs(space_join_names_mortal(grent->gr_mem));
5690 #endif
5691 }
5692
5693 RETURN;
5694 #else
5695 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5696 #endif
5697 }
5698
PP(pp_getlogin)5699 PP(pp_getlogin)
5700 {
5701 #ifdef HAS_GETLOGIN
5702 dSP; dTARGET;
5703 char *tmps;
5704 EXTEND(SP, 1);
5705 if (!(tmps = PerlProc_getlogin()))
5706 RETPUSHUNDEF;
5707 sv_setpv_mg(TARG, tmps);
5708 PUSHs(TARG);
5709 RETURN;
5710 #else
5711 DIE(aTHX_ PL_no_func, "getlogin");
5712 #endif
5713 }
5714
5715 /* Miscellaneous. */
5716
PP(pp_syscall)5717 PP(pp_syscall)
5718 {
5719 #ifdef HAS_SYSCALL
5720 dSP; dMARK; dORIGMARK; dTARGET;
5721 I32 items = SP - MARK;
5722 unsigned long a[20];
5723 I32 i = 0;
5724 IV retval = -1;
5725
5726 if (TAINTING_get) {
5727 while (++MARK <= SP) {
5728 if (SvTAINTED(*MARK)) {
5729 TAINT;
5730 break;
5731 }
5732 }
5733 MARK = ORIGMARK;
5734 TAINT_PROPER("syscall");
5735 }
5736
5737 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5738 * or where sizeof(long) != sizeof(char*). But such machines will
5739 * not likely have syscall implemented either, so who cares?
5740 */
5741 while (++MARK <= SP) {
5742 if (SvNIOK(*MARK) || !i)
5743 a[i++] = SvIV(*MARK);
5744 else if (*MARK == &PL_sv_undef)
5745 a[i++] = 0;
5746 else
5747 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5748 if (i > 15)
5749 break;
5750 }
5751 switch (items) {
5752 default:
5753 DIE(aTHX_ "Too many args to syscall");
5754 case 0:
5755 DIE(aTHX_ "Too few args to syscall");
5756 case 1:
5757 retval = syscall(a[0]);
5758 break;
5759 case 2:
5760 retval = syscall(a[0],a[1]);
5761 break;
5762 case 3:
5763 retval = syscall(a[0],a[1],a[2]);
5764 break;
5765 case 4:
5766 retval = syscall(a[0],a[1],a[2],a[3]);
5767 break;
5768 case 5:
5769 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5770 break;
5771 case 6:
5772 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5773 break;
5774 case 7:
5775 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5776 break;
5777 case 8:
5778 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5779 break;
5780 }
5781 SP = ORIGMARK;
5782 PUSHi(retval);
5783 RETURN;
5784 #else
5785 DIE(aTHX_ PL_no_func, "syscall");
5786 #endif
5787 }
5788
5789 #ifdef FCNTL_EMULATE_FLOCK
5790
5791 /* XXX Emulate flock() with fcntl().
5792 What's really needed is a good file locking module.
5793 */
5794
5795 static int
fcntl_emulate_flock(int fd,int operation)5796 fcntl_emulate_flock(int fd, int operation)
5797 {
5798 int res;
5799 struct flock flock;
5800
5801 switch (operation & ~LOCK_NB) {
5802 case LOCK_SH:
5803 flock.l_type = F_RDLCK;
5804 break;
5805 case LOCK_EX:
5806 flock.l_type = F_WRLCK;
5807 break;
5808 case LOCK_UN:
5809 flock.l_type = F_UNLCK;
5810 break;
5811 default:
5812 errno = EINVAL;
5813 return -1;
5814 }
5815 flock.l_whence = SEEK_SET;
5816 flock.l_start = flock.l_len = (Off_t)0;
5817
5818 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5819 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5820 errno = EWOULDBLOCK;
5821 return res;
5822 }
5823
5824 #endif /* FCNTL_EMULATE_FLOCK */
5825
5826 #ifdef LOCKF_EMULATE_FLOCK
5827
5828 /* XXX Emulate flock() with lockf(). This is just to increase
5829 portability of scripts. The calls are not completely
5830 interchangeable. What's really needed is a good file
5831 locking module.
5832 */
5833
5834 /* The lockf() constants might have been defined in <unistd.h>.
5835 Unfortunately, <unistd.h> causes troubles on some mixed
5836 (BSD/POSIX) systems, such as SunOS 4.1.3.
5837
5838 Further, the lockf() constants aren't POSIX, so they might not be
5839 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5840 just stick in the SVID values and be done with it. Sigh.
5841 */
5842
5843 # ifndef F_ULOCK
5844 # define F_ULOCK 0 /* Unlock a previously locked region */
5845 # endif
5846 # ifndef F_LOCK
5847 # define F_LOCK 1 /* Lock a region for exclusive use */
5848 # endif
5849 # ifndef F_TLOCK
5850 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5851 # endif
5852 # ifndef F_TEST
5853 # define F_TEST 3 /* Test a region for other processes locks */
5854 # endif
5855
5856 static int
lockf_emulate_flock(int fd,int operation)5857 lockf_emulate_flock(int fd, int operation)
5858 {
5859 int i;
5860 Off_t pos;
5861 dSAVE_ERRNO;
5862
5863 /* flock locks entire file so for lockf we need to do the same */
5864 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5865 if (pos > 0) /* is seekable and needs to be repositioned */
5866 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5867 pos = -1; /* seek failed, so don't seek back afterwards */
5868 RESTORE_ERRNO;
5869
5870 switch (operation) {
5871
5872 /* LOCK_SH - get a shared lock */
5873 case LOCK_SH:
5874 /* LOCK_EX - get an exclusive lock */
5875 case LOCK_EX:
5876 i = lockf (fd, F_LOCK, 0);
5877 break;
5878
5879 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5880 case LOCK_SH|LOCK_NB:
5881 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5882 case LOCK_EX|LOCK_NB:
5883 i = lockf (fd, F_TLOCK, 0);
5884 if (i == -1)
5885 if ((errno == EAGAIN) || (errno == EACCES))
5886 errno = EWOULDBLOCK;
5887 break;
5888
5889 /* LOCK_UN - unlock (non-blocking is a no-op) */
5890 case LOCK_UN:
5891 case LOCK_UN|LOCK_NB:
5892 i = lockf (fd, F_ULOCK, 0);
5893 break;
5894
5895 /* Default - can't decipher operation */
5896 default:
5897 i = -1;
5898 errno = EINVAL;
5899 break;
5900 }
5901
5902 if (pos > 0) /* need to restore position of the handle */
5903 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5904
5905 return (i);
5906 }
5907
5908 #endif /* LOCKF_EMULATE_FLOCK */
5909
5910 /*
5911 * ex: set ts=8 sts=4 sw=4 et:
5912 */
5913