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