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