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