#define PERL_IN_PP_SYS_C
#include "perl.h"
#include "time64.h"
-#include "time64.c"
#ifdef I_SHADOW
/* Shadow password support for solaris - pdo@cs.umd.edu
# include <sys/access.h>
#endif
-#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
-# define FD_CLOEXEC 1 /* NeXT needs this */
-#endif
-
#include "reentr.h"
#ifdef __Lynx__
void endservent(void);
#endif
+#ifdef __amigaos4__
+# include "amigaos4/amigaio.h"
+#endif
+
#undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
/* F_OK unused: if stat() cannot find it... */
PP(pp_backtick)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
PerlIO *fp;
const char * const tmps = POPpconstx;
- const I32 gimme = GIMME_V;
+ const U8 gimme = GIMME_V;
const char *mode = "r";
TAINT_PROPER("``");
ENTER_with_name("backtick");
SAVESPTR(PL_rs);
PL_rs = &PL_sv_undef;
- sv_setpvs(TARG, ""); /* note that this preserves previous buffer */
+ SvPVCLEAR(TARG); /* note that this preserves previous buffer */
while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
NOOP;
LEAVE_with_name("backtick");
PP(pp_glob)
{
- dVAR;
OP *result;
dSP;
+ GV * const gv = (PL_op->op_flags & OPf_SPECIAL) ? NULL : (GV *)POPs;
+
+ PUTBACK;
+
/* make a copy of the pattern if it is gmagical, to ensure that magic
* is called once and only once */
- if (SvGMAGICAL(TOPm1s)) TOPm1s = sv_2mortal(newSVsv(TOPm1s));
+ if (SvGMAGICAL(TOPs)) TOPs = sv_2mortal(newSVsv(TOPs));
- tryAMAGICunTARGETlist(iter_amg, -1, (PL_op->op_flags & OPf_SPECIAL));
+ tryAMAGICunTARGETlist(iter_amg, (PL_op->op_flags & OPf_SPECIAL));
if (PL_op->op_flags & OPf_SPECIAL) {
/* call Perl-level glob function instead. Stack args are:
- * MARK, wildcard, csh_glob context index
+ * MARK, wildcard
* and following OPs should be: gv(CORE::GLOBAL::glob), entersub
* */
return NORMAL;
}
- /* stack args are: wildcard, gv(_GEN_n) */
-
if (PL_globhook) {
- SETs(GvSV(TOPs));
PL_globhook(aTHX);
return NORMAL;
}
ENTER_with_name("glob");
#ifndef VMS
- if (PL_tainting) {
+ if (TAINTING_get) {
/*
* The external globbing program may use things we can't control,
* so for security reasons we must assume the worst.
#endif /* !VMS */
SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
- PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
+ PL_last_in_gv = gv;
SAVESPTR(PL_rs); /* This is not permanent, either. */
PL_rs = newSVpvs_flags("\000", SVs_TEMP);
PP(pp_rcatline)
{
- dVAR;
PL_last_in_gv = cGVOP_gv;
return do_readline();
}
PP(pp_warn)
{
- dVAR; dSP; dMARK;
+ dSP; dMARK;
SV *exsv;
STRLEN len;
if (SP - MARK > 1) {
/* well-formed exception supplied */
}
else {
- SvGETMAGIC(ERRSV);
- if (SvROK(ERRSV)) {
- if (SvGMAGICAL(ERRSV)) {
+ SV * const errsv = ERRSV;
+ SvGETMAGIC(errsv);
+ if (SvROK(errsv)) {
+ if (SvGMAGICAL(errsv)) {
exsv = sv_newmortal();
- sv_setsv_nomg(exsv, ERRSV);
+ sv_setsv_nomg(exsv, errsv);
}
- else exsv = ERRSV;
+ else exsv = errsv;
}
- else if (SvPOKp(ERRSV) ? SvCUR(ERRSV) : SvNIOKp(ERRSV)) {
+ else if (SvPOKp(errsv) ? SvCUR(errsv) : SvNIOKp(errsv)) {
exsv = sv_newmortal();
- sv_setsv_nomg(exsv, ERRSV);
+ sv_setsv_nomg(exsv, errsv);
sv_catpvs(exsv, "\t...caught");
}
else {
}
}
if (SvROK(exsv) && !PL_warnhook)
- Perl_warn(aTHX_ "%"SVf, SVfARG(exsv));
+ Perl_warn(aTHX_ "%" SVf, SVfARG(exsv));
else warn_sv(exsv);
RETSETYES;
}
PP(pp_die)
{
- dVAR; dSP; dMARK;
+ dSP; dMARK;
SV *exsv;
STRLEN len;
#ifdef VMS
- VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
+ VMSISH_HUSHED =
+ VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
#endif
if (SP - MARK != 1) {
dTARGET;
if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
/* well-formed exception supplied */
}
- else if (SvROK(ERRSV)) {
- exsv = ERRSV;
- if (sv_isobject(exsv)) {
- HV * const stash = SvSTASH(SvRV(exsv));
- GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
- if (gv) {
- SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
- SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
- EXTEND(SP, 3);
- PUSHMARK(SP);
- PUSHs(exsv);
- PUSHs(file);
- PUSHs(line);
- PUTBACK;
- call_sv(MUTABLE_SV(GvCV(gv)),
- G_SCALAR|G_EVAL|G_KEEPERR);
- exsv = sv_mortalcopy(*PL_stack_sp--);
+ else {
+ SV * const errsv = ERRSV;
+ SvGETMAGIC(errsv);
+ if (SvROK(errsv)) {
+ exsv = errsv;
+ if (sv_isobject(exsv)) {
+ HV * const stash = SvSTASH(SvRV(exsv));
+ GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
+ if (gv) {
+ SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
+ SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
+ EXTEND(SP, 3);
+ PUSHMARK(SP);
+ PUSHs(exsv);
+ PUSHs(file);
+ PUSHs(line);
+ PUTBACK;
+ call_sv(MUTABLE_SV(GvCV(gv)),
+ G_SCALAR|G_EVAL|G_KEEPERR);
+ exsv = sv_mortalcopy(*PL_stack_sp--);
+ }
}
}
+ else if (SvPOK(errsv) && SvCUR(errsv)) {
+ exsv = sv_mortalcopy(errsv);
+ sv_catpvs(exsv, "\t...propagated");
+ }
+ else {
+ exsv = newSVpvs_flags("Died", SVs_TEMP);
+ }
}
- else if (SvPV_const(ERRSV, len), len) {
- exsv = sv_mortalcopy(ERRSV);
- sv_catpvs(exsv, "\t...propagated");
- }
- else {
- exsv = newSVpvs_flags("Died", SVs_TEMP);
- }
- return die_sv(exsv);
+ die_sv(exsv);
+ NOT_REACHED; /* NOTREACHED */
+ return NULL; /* avoid missing return from non-void function warning */
}
/* I/O. */
OP *
-Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv,
+Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv,
const MAGIC *const mg, const U32 flags, U32 argc, ...)
{
SV **orig_sp = sp;
I32 ret_args;
+ SSize_t extend_size;
PERL_ARGS_ASSERT_TIED_METHOD;
/* Ensure that our flag bits do not overlap. */
- assert((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
- assert((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
- assert((TIED_METHOD_SAY & G_WANT) == 0);
+ STATIC_ASSERT_STMT((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
+ STATIC_ASSERT_STMT((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
+ STATIC_ASSERT_STMT((TIED_METHOD_SAY & G_WANT) == 0);
PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */
PUSHSTACKi(PERLSI_MAGIC);
- EXTEND(SP, argc+1); /* object + args */
+ /* extend for object + args. If argc might wrap/truncate when cast
+ * to SSize_t and incremented, set to -1, which will trigger a panic in
+ * EXTEND().
+ * The weird way this is written is because g++ is dumb enough to
+ * warn "comparison is always false" on something like:
+ *
+ * sizeof(a) >= sizeof(b) && a >= B_t_MAX -1
+ *
+ * (where the LH condition is false)
+ */
+ extend_size =
+ (argc > (sizeof(argc) >= sizeof(SSize_t) ? SSize_t_MAX - 1 : argc))
+ ? -1 : (SSize_t)argc + 1;
+ EXTEND(SP, extend_size);
PUSHMARK(sp);
PUSHs(SvTIED_obj(sv, mg));
if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
SAVEGENERICSV(PL_ors_sv);
PL_ors_sv = newSVpvs("\n");
}
- ret_args = call_method(methname, flags & G_WANT);
+ ret_args = call_sv(methname, (flags & G_WANT)|G_METHOD_NAMED);
SPAGAIN;
orig_sp = sp;
POPSTACK;
PP(pp_open)
{
- dVAR; dSP;
+ dSP;
dMARK; dORIGMARK;
dTARGET;
SV *sv;
IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
if (IoDIRP(io))
- Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
- "Opening dirhandle %"HEKf" also as a file",
+ Perl_croak(aTHX_ "Cannot open %" HEKf " as a filehandle: it is already open as a dirhandle",
HEKfARG(GvENAME_HEK(gv)));
mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
/* Method's args are same as ours ... */
/* ... except handle is replaced by the object */
- return Perl_tied_method(aTHX_ "OPEN", mark - 1, MUTABLE_SV(io), mg,
+ return Perl_tied_method(aTHX_ SV_CONST(OPEN), mark - 1, MUTABLE_SV(io), mg,
G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
sp - mark);
}
}
tmps = SvPV_const(sv, len);
- ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
+ ok = do_open6(gv, tmps, len, NULL, MARK+1, (SP-MARK));
SP = ORIGMARK;
if (ok)
PUSHi( (I32)PL_forkprocess );
PP(pp_close)
{
- dVAR; dSP;
+ dSP;
GV * const gv =
MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs);
if (io) {
const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
- return tied_method0("CLOSE", SP, MUTABLE_SV(io), mg);
+ return tied_method0(SV_CONST(CLOSE), SP, MUTABLE_SV(io), mg);
}
}
}
PP(pp_pipe_op)
{
#ifdef HAS_PIPE
- dVAR;
dSP;
- register IO *rstio;
- register IO *wstio;
+ IO *rstio;
+ IO *wstio;
int fd[2];
GV * const wgv = MUTABLE_GV(POPs);
GV * const rgv = MUTABLE_GV(POPs);
- if (!rgv || !wgv)
- goto badexit;
-
- if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv))
- DIE(aTHX_ PL_no_usym, "filehandle");
rstio = GvIOn(rgv);
- wstio = GvIOn(wgv);
-
if (IoIFP(rstio))
do_close(rgv, FALSE);
+
+ wstio = GvIOn(wgv);
if (IoIFP(wstio))
do_close(wgv, FALSE);
if (PerlProc_pipe(fd) < 0)
goto badexit;
- IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
- IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
+ IoIFP(rstio) = PerlIO_fdopen(fd[0], "r" PIPE_OPEN_MODE);
+ IoOFP(wstio) = PerlIO_fdopen(fd[1], "w" PIPE_OPEN_MODE);
IoOFP(rstio) = IoIFP(rstio);
IoIFP(wstio) = IoOFP(wstio);
IoTYPE(rstio) = IoTYPE_RDONLY;
PerlLIO_close(fd[1]);
goto badexit;
}
-#if defined(HAS_FCNTL) && defined(F_SETFD)
- fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
- fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
+#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
+ /* ensure close-on-exec */
+ if ((fd[0] > PL_maxsysfd && fcntl(fd[0], F_SETFD, FD_CLOEXEC) < 0) ||
+ (fd[1] > PL_maxsysfd && fcntl(fd[1], F_SETFD, FD_CLOEXEC) < 0))
+ goto badexit;
#endif
RETPUSHYES;
-badexit:
+ badexit:
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_func, "pipe");
PP(pp_fileno)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
GV *gv;
IO *io;
PerlIO *fp;
if (io
&& (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
{
- return tied_method0("FILENO", SP, MUTABLE_SV(io), mg);
+ return tied_method0(SV_CONST(FILENO), SP, MUTABLE_SV(io), mg);
+ }
+
+ if (io && IoDIRP(io)) {
+#if defined(HAS_DIRFD) || defined(HAS_DIR_DD_FD)
+ PUSHi(my_dirfd(IoDIRP(io)));
+ RETURN;
+#elif defined(ENOTSUP)
+ errno = ENOTSUP; /* Operation not supported */
+ RETPUSHUNDEF;
+#elif defined(EOPNOTSUPP)
+ errno = EOPNOTSUPP; /* Operation not supported on socket */
+ RETPUSHUNDEF;
+#else
+ errno = EINVAL; /* Invalid argument */
+ RETPUSHUNDEF;
+#endif
}
if (!io || !(fp = IoIFP(io))) {
PP(pp_umask)
{
- dVAR;
dSP;
#ifdef HAS_UMASK
dTARGET;
PP(pp_binmode)
{
- dVAR; dSP;
+ dSP;
GV *gv;
IO *io;
PerlIO *fp;
function, which I don't think that the optimiser will be able to
figure out. Although, as it's a static function, in theory it
could. */
- return Perl_tied_method(aTHX_ "BINMODE", SP, MUTABLE_SV(io), mg,
+ return Perl_tied_method(aTHX_ SV_CONST(BINMODE), SP, MUTABLE_SV(io), mg,
G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
discp ? 1 : 0, discp);
}
PP(pp_tie)
{
- dVAR; dSP; dMARK;
+ dSP; dMARK;
HV* stash;
GV *gv = NULL;
SV *sv;
switch(SvTYPE(varsv)) {
case SVt_PVHV:
+ {
+ HE *entry;
methname = "TIEHASH";
+ if (HvLAZYDEL(varsv) && (entry = HvEITER((HV *)varsv))) {
+ HvLAZYDEL_off(varsv);
+ hv_free_ent((HV *)varsv, entry);
+ }
HvEITER_set(MUTABLE_HV(varsv), 0);
break;
+ }
case SVt_PVAV:
methname = "TIEARRAY";
if (!AvREAL(varsv)) {
varsv = MUTABLE_SV(GvIOp(varsv));
break;
}
- /* FALL THROUGH */
+ if (SvTYPE(varsv) == SVt_PVLV && LvTYPE(varsv) == 'y') {
+ vivify_defelem(varsv);
+ varsv = LvTARG(varsv);
+ }
+ /* FALLTHROUGH */
default:
methname = "TIESCALAR";
how = PERL_MAGIC_tiedscalar;
* (Sorry obfuscation writers. You're not going to be given this one.)
*/
stash = gv_stashsv(*MARK, 0);
- if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
- DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
- methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
- }
+ if (!stash) {
+ if (SvROK(*MARK))
+ DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\"",
+ methname, SVfARG(*MARK));
+ else if (isGV(*MARK)) {
+ /* If the glob doesn't name an existing package, using
+ * SVfARG(*MARK) would yield "*Foo::Bar" or *main::Foo. So
+ * generate the name for the error message explicitly. */
+ SV *stashname = sv_2mortal(newSV(0));
+ gv_fullname4(stashname, (GV *) *MARK, NULL, FALSE);
+ DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\"",
+ methname, SVfARG(stashname));
+ }
+ else {
+ SV *stashname = !SvPOK(*MARK) ? &PL_sv_no
+ : SvCUR(*MARK) ? *MARK
+ : sv_2mortal(newSVpvs("main"));
+ DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\""
+ " (perhaps you forgot to load \"%" SVf "\"?)",
+ methname, SVfARG(stashname), SVfARG(stashname));
+ }
+ }
+ else if (!(gv = gv_fetchmethod(stash, methname))) {
+ /* The effective name can only be NULL for stashes that have
+ * been deleted from the symbol table, which this one can't
+ * be, since we just looked it up by name.
+ */
+ DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" HEKf "\"",
+ methname, HvENAME_HEK_NN(stash));
+ }
ENTER_with_name("call_TIE");
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
RETURN;
}
+
+/* also used for: pp_dbmclose() */
+
PP(pp_untie)
{
- dVAR; dSP;
+ dSP;
MAGIC *mg;
SV *sv = POPs;
const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
RETPUSHYES;
+ if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
+ !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
+
if ((mg = SvTIED_mg(sv, how))) {
SV * const obj = SvRV(SvTIED_obj(sv, mg));
if (obj) {
}
else if (mg && SvREFCNT(obj) > 1) {
Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
- "untie attempted while %"UVuf" inner references still exist",
+ "untie attempted while %" UVuf " inner references still exist",
(UV)SvREFCNT(obj) - 1 ) ;
}
}
PP(pp_tied)
{
- dVAR;
dSP;
const MAGIC *mg;
- SV *sv = POPs;
+ dTOPss;
const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
- RETPUSHUNDEF;
+ goto ret_undef;
+
+ if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
+ !(sv = defelem_target(sv, NULL))) goto ret_undef;
if ((mg = SvTIED_mg(sv, how))) {
- PUSHs(SvTIED_obj(sv, mg));
- RETURN;
+ SETs(SvTIED_obj(sv, mg));
+ return NORMAL; /* PUTBACK not needed, pp_tied never moves SP */
}
- RETPUSHUNDEF;
+ ret_undef:
+ SETs(&PL_sv_undef);
+ return NORMAL;
}
PP(pp_dbmopen)
{
- dVAR; dSP;
+ dSP;
dPOPPOPssrl;
HV* stash;
GV *gv = NULL;
PUTBACK;
call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
SPAGAIN;
+ if (sv_isobject(TOPs))
+ goto retie;
}
-
- if (sv_isobject(TOPs)) {
+ else {
+ retie:
sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
}
PP(pp_sselect)
{
#ifdef HAS_SELECT
- dVAR; dSP; dTARGET;
- register I32 i;
- register I32 j;
- register char *s;
- register SV *sv;
+ dSP; dTARGET;
+ I32 i;
+ I32 j;
+ char *s;
+ SV *sv;
NV value;
I32 maxlen = 0;
I32 nfound;
if (!SvOK(sv))
continue;
if (SvREADONLY(sv)) {
- if (SvIsCOW(sv))
- sv_force_normal_flags(sv, 0);
- if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
- Perl_croak_no_modify(aTHX);
+ if (!(SvPOK(sv) && SvCUR(sv) == 0))
+ Perl_croak_no_modify();
}
+ else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
if (!SvPOK(sv)) {
if (!SvPOKp(sv))
Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
/* If SELECT_MIN_BITS is greater than one we most probably will want
* to align the sizes with SELECT_MIN_BITS/8 because for example
* in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
- * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
+ * UNIX, Solaris, Darwin) the smallest quantum select() operates
* on (sets/tests/clears bits) is 32 bits. */
growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
# endif
sv = SP[4];
+ SvGETMAGIC(sv);
if (SvOK(sv)) {
- value = SvNV(sv);
+ value = SvNV_nomg(sv);
if (value < 0.0)
value = 0.0;
timebuf.tv_sec = (long)value;
}
PUSHi(nfound);
- if (GIMME == G_ARRAY && tbuf) {
+ if (GIMME_V == G_ARRAY && tbuf) {
value = (NV)(timebuf.tv_sec) +
(NV)(timebuf.tv_usec) / 1000000.0;
mPUSHn(value);
}
/*
+
+=head1 GV Functions
+
=for apidoc setdefout
-Sets PL_defoutgv, the default file handle for output, to the passed in
-typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
+Sets C<PL_defoutgv>, the default file handle for output, to the passed in
+typeglob. As C<PL_defoutgv> "owns" a reference on its typeglob, the reference
count of the passed in typeglob is increased by one, and the reference count
-of the typeglob that PL_defoutgv points to is decreased by one.
+of the typeglob that C<PL_defoutgv> points to is decreased by one.
=cut
*/
void
Perl_setdefout(pTHX_ GV *gv)
{
- dVAR;
+ GV *oldgv = PL_defoutgv;
+
PERL_ARGS_ASSERT_SETDEFOUT;
+
SvREFCNT_inc_simple_void_NN(gv);
- SvREFCNT_dec(PL_defoutgv);
PL_defoutgv = gv;
+ SvREFCNT_dec(oldgv);
}
PP(pp_select)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
HV *hv;
GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
GV * egv = GvEGVx(PL_defoutgv);
PP(pp_getc)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
GV * const gv =
MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
IO *const io = GvIO(gv);
if (io) {
const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
- const U32 gimme = GIMME_V;
- Perl_tied_method(aTHX_ "GETC", SP, MUTABLE_SV(io), mg, gimme, 0);
+ const U8 gimme = GIMME_V;
+ Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0);
if (gimme == G_SCALAR) {
SPAGAIN;
SvSetMagicSV_nosteal(TARG, TOPs);
}
SvUTF8_on(TARG);
}
+ else SvUTF8_off(TARG);
PUSHTARG;
RETURN;
}
STATIC OP *
S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
{
- dVAR;
- register PERL_CONTEXT *cx;
- const I32 gimme = GIMME_V;
+ PERL_CONTEXT *cx;
+ const U8 gimme = GIMME_V;
PERL_ARGS_ASSERT_DOFORM;
- if (cv && CvCLONE(cv))
+ if (CvCLONE(cv))
cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
- ENTER;
- SAVETMPS;
-
- PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
- PUSHFORMAT(cx, retop);
- SAVECOMPPAD();
- PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
+ cx = cx_pushblock(CXt_FORMAT, gimme, PL_stack_sp, PL_savestack_ix);
+ cx_pushformat(cx, cv, retop, gv);
+ if (CvDEPTH(cv) >= 2)
+ pad_push(CvPADLIST(cv), CvDEPTH(cv));
+ PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
setdefout(gv); /* locally select filehandle so $% et al work */
return CvSTART(cv);
PP(pp_enterwrite)
{
- dVAR;
dSP;
- register GV *gv;
- register IO *io;
+ GV *gv;
+ IO *io;
GV *fgv;
CV *cv = NULL;
- SV *tmpsv = NULL;
if (MAXARG == 0) {
- gv = PL_defoutgv;
EXTEND(SP, 1);
+ gv = PL_defoutgv;
}
else {
gv = MUTABLE_GV(POPs);
cv = GvFORM(fgv);
if (!cv) {
- tmpsv = sv_newmortal();
+ SV * const tmpsv = sv_newmortal();
gv_efullname4(tmpsv, fgv, NULL, FALSE);
- DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
+ DIE(aTHX_ "Undefined format \"%" SVf "\" called", SVfARG(tmpsv));
}
IoFLAGS(io) &= ~IOf_DIDTOP;
RETURNOP(doform(cv,gv,PL_op->op_next));
PP(pp_leavewrite)
{
- dVAR; dSP;
- GV * const gv = cxstack[cxstack_ix].blk_format.gv;
- register IO * const io = GvIOp(gv);
+ dSP;
+ GV * const gv = CX_CUR()->blk_format.gv;
+ IO * const io = GvIOp(gv);
PerlIO *ofp;
PerlIO *fp;
- SV **newsp;
- I32 gimme;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
OP *retop;
+ bool is_return = cBOOL(PL_op->op_type == OP_RETURN);
- /* I'm not sure why, but executing the format leaves an extra value on the
- * stack. There's probably a better place to be handling this (probably
- * by avoiding pushing it in the first place!) but I don't quite know
- * where to look. -doy */
- (void)POPs;
-
- if (!io || !(ofp = IoOFP(io)))
+ if (is_return || !io || !(ofp = IoOFP(io)))
goto forget_top;
DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
SV *topname;
if (!IoFMT_NAME(io))
IoFMT_NAME(io) = savepv(GvNAME(gv));
- topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP",
+ topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%" HEKf "_TOP",
HEKfARG(GvNAME_HEK(gv))));
topgv = gv_fetchsv(topname, 0, SVt_PVFM);
if ((topgv && GvFORM(topgv)) ||
}
}
if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
- do_print(PL_formfeed, ofp);
+ do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
IoLINES_LEFT(io) = IoPAGE_LEN(io);
IoPAGE(io)++;
PL_formtarget = PL_toptarget;
IoFLAGS(io) |= IOf_DIDTOP;
fgv = IoTOP_GV(io);
- if (!fgv)
- DIE(aTHX_ "bad top format reference");
+ assert(fgv); /* IoTOP_GV(io) should have been set above */
cv = GvFORM(fgv);
if (!cv) {
SV * const sv = sv_newmortal();
gv_efullname4(sv, fgv, NULL, FALSE);
- DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
+ DIE(aTHX_ "Undefined top format \"%" SVf "\" called", SVfARG(sv));
}
- RETURNOP(doform(cv, gv, PL_op));
+ return doform(cv, gv, PL_op);
}
forget_top:
- POPBLOCK(cx,PL_curpm);
- POPFORMAT(cx);
+ cx = CX_CUR();
+ assert(CxTYPE(cx) == CXt_FORMAT);
+ SP = PL_stack_base + cx->blk_oldsp; /* ignore retval of formline */
+ CX_LEAVE_SCOPE(cx);
+ cx_popformat(cx);
+ cx_popblock(cx);
retop = cx->blk_sub.retop;
- LEAVE;
+ CX_POP(cx);
- fp = IoOFP(io);
- if (!fp) {
- if (IoIFP(io))
+ if (is_return)
+ /* XXX the semantics of doing 'return' in a format aren't documented.
+ * Currently we ignore any args to 'return' and just return
+ * a single undef in both scalar and list contexts
+ */
+ PUSHs(&PL_sv_undef);
+ else if (!io || !(fp = IoOFP(io))) {
+ if (io && IoIFP(io))
report_wrongway_fh(gv, '<');
else
report_evil_fh(gv);
PUSHs(&PL_sv_yes);
}
}
- /* bad_ofp: */
PL_formtarget = PL_bodytarget;
- PERL_UNUSED_VAR(newsp);
- PERL_UNUSED_VAR(gimme);
RETURNOP(retop);
}
PP(pp_prtf)
{
- dVAR; dSP; dMARK; dORIGMARK;
+ dSP; dMARK; dORIGMARK;
PerlIO *fp;
- SV *sv;
GV * const gv
= (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
IO *const io = GvIO(gv);
+ /* Treat empty list as "" */
+ if (MARK == SP) XPUSHs(&PL_sv_no);
+
if (io) {
const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
++SP;
}
- return Perl_tied_method(aTHX_ "PRINTF", mark - 1, MUTABLE_SV(io),
+ return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
mg,
G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
sp - mark);
}
}
- sv = newSV(0);
if (!io) {
report_evil_fh(gv);
SETERRNO(EBADF,RMS_IFI);
goto just_say_no;
}
else {
+ SV *sv = sv_newmortal();
do_sprintf(sv, SP - MARK, MARK + 1);
if (!do_print(sv, fp))
goto just_say_no;
if (PerlIO_flush(fp) == EOF)
goto just_say_no;
}
- SvREFCNT_dec(sv);
SP = ORIGMARK;
PUSHs(&PL_sv_yes);
RETURN;
just_say_no:
- SvREFCNT_dec(sv);
SP = ORIGMARK;
PUSHs(&PL_sv_undef);
RETURN;
PP(pp_sysopen)
{
- dVAR;
dSP;
const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
const int mode = POPi;
/* Need TIEHANDLE method ? */
const char * const tmps = SvPV_const(sv, len);
- /* FIXME? do_open should do const */
- if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
+ if (do_open_raw(gv, tmps, len, mode, perm, NULL)) {
IoLINES(GvIOp(gv)) = 0;
PUSHs(&PL_sv_yes);
}
RETURN;
}
+
+/* also used for: pp_read() and pp_recv() (where supported) */
+
PP(pp_sysread)
{
- dVAR; dSP; dMARK; dORIGMARK; dTARGET;
+ dSP; dMARK; dORIGMARK; dTARGET;
SSize_t offset;
IO *io;
char *buffer;
bool charstart = FALSE;
STRLEN charskip = 0;
STRLEN skip = 0;
-
GV * const gv = MUTABLE_GV(*++MARK);
+ int fd;
+
if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
&& gv && (io = GvIO(gv)) )
{
const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
- return Perl_tied_method(aTHX_ "READ", mark - 1, MUTABLE_SV(io), mg,
+ return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg,
G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
sp - mark);
}
goto say_undef;
bufsv = *++MARK;
if (! SvOK(bufsv))
- sv_setpvs(bufsv, "");
+ SvPVCLEAR(bufsv);
length = SvIVx(*++MARK);
+ if (length < 0)
+ DIE(aTHX_ "Negative length");
SETERRNO(0,0);
if (MARK < SP)
offset = SvIVx(*++MARK);
SETERRNO(EBADF,RMS_IFI);
goto say_undef;
}
+
+ /* Note that fd can here validly be -1, don't check it yet. */
+ fd = PerlIO_fileno(IoIFP(io));
+
if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
+ if (PL_op->op_type == OP_SYSREAD || PL_op->op_type == OP_RECV) {
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+ "%s() is deprecated on :utf8 handles. "
+ "This will be a fatal error in Perl 5.30",
+ OP_DESC(PL_op));
+ }
buffer = SvPVutf8_force(bufsv, blen);
/* UTF-8 may not have been set if they are all low bytes */
SvUTF8_on(bufsv);
buffer = SvPV_force(bufsv, blen);
buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
}
- if (length < 0)
- DIE(aTHX_ "Negative length");
- wanted = length;
+ if (DO_UTF8(bufsv)) {
+ blen = sv_len_utf8_nomg(bufsv);
+ }
charstart = TRUE;
charskip = 0;
skip = 0;
+ wanted = length;
#ifdef HAS_SOCKET
if (PL_op->op_type == OP_RECV) {
Sock_size_t bufsize;
char namebuf[MAXPATHLEN];
-#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
+ if (fd < 0) {
+ SETERRNO(EBADF,SS_IVCHAN);
+ RETPUSHUNDEF;
+ }
+#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
bufsize = sizeof (struct sockaddr_in);
#else
bufsize = sizeof namebuf;
#endif
buffer = SvGROW(bufsv, (STRLEN)(length+1));
/* 'offset' means 'flags' here */
- count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
+ count = PerlSock_recvfrom(fd, buffer, length, offset,
(struct sockaddr *)namebuf, &bufsize);
if (count < 0)
RETPUSHUNDEF;
/* MSG_TRUNC can give oversized count; quietly lose it */
if (count > length)
count = length;
-#ifdef EPOC
- /* Bogus return without padding */
- bufsize = sizeof (struct sockaddr_in);
-#endif
SvCUR_set(bufsv, count);
*SvEND(bufsv) = '\0';
(void)SvPOK_only(bufsv);
if (!(IoFLAGS(io) & IOf_UNTAINT))
SvTAINTED_on(bufsv);
SP = ORIGMARK;
+#if defined(__CYGWIN__)
+ /* recvfrom() on cygwin doesn't set bufsize at all for
+ connected sockets, leaving us with trash in the returned
+ name, so use the same test as the Win32 code to check if it
+ wasn't set, and set it [perl #118843] */
+ if (bufsize == sizeof namebuf)
+ bufsize = 0;
+#endif
sv_setpvn(TARG, namebuf, bufsize);
PUSHs(TARG);
RETURN;
}
#endif
- if (DO_UTF8(bufsv)) {
- /* offset adjust in characters not bytes */
- blen = sv_len_utf8(bufsv);
- }
if (offset < 0) {
if (-offset > (SSize_t)blen)
DIE(aTHX_ "Offset outside string");
else
offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
}
+
more_bytes:
+ /* Reestablish the fd in case it shifted from underneath us. */
+ fd = PerlIO_fileno(IoIFP(io));
+
orig_size = SvCUR(bufsv);
/* Allocating length + offset + 1 isn't perfect in the case of reading
bytes from a byte file handle into a UTF8 buffer, but it won't harm us
unduly.
(should be 2 * length + offset + 1, or possibly something longer if
- PL_encoding is true) */
+ IN_ENCODING Is true) */
buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
Zero(buffer+orig_size, offset-orig_size, char);
if (PL_op->op_type == OP_SYSREAD) {
#ifdef PERL_SOCK_SYSREAD_IS_RECV
if (IoTYPE(io) == IoTYPE_SOCKET) {
- count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
- buffer, length, 0);
+ if (fd < 0) {
+ SETERRNO(EBADF,SS_IVCHAN);
+ count = -1;
+ }
+ else
+ count = PerlSock_recv(fd, buffer, length, 0);
}
else
#endif
{
- count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
- buffer, length);
+ if (fd < 0) {
+ SETERRNO(EBADF,RMS_IFI);
+ count = -1;
+ }
+ else
+ count = PerlLIO_read(fd, buffer, length);
}
}
else
-#ifdef HAS_SOCKET__bad_code_maybe
- if (IoTYPE(io) == IoTYPE_SOCKET) {
- Sock_size_t bufsize;
- char namebuf[MAXPATHLEN];
-#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
- bufsize = sizeof (struct sockaddr_in);
-#else
- bufsize = sizeof namebuf;
-#endif
- count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
- (struct sockaddr *)namebuf, &bufsize);
- }
- else
-#endif
{
count = PerlIO_read(IoIFP(io), buffer, length);
/* PerlIO_read() - like fread() returns 0 on both error and EOF */
RETPUSHUNDEF;
}
+
+/* also used for: pp_send() where defined */
+
PP(pp_syswrite)
{
- dVAR; dSP; dMARK; dORIGMARK; dTARGET;
+ dSP; dMARK; dORIGMARK; dTARGET;
SV *bufsv;
const char *buffer;
SSize_t retval;
U8 *tmpbuf = NULL;
GV *const gv = MUTABLE_GV(*++MARK);
IO *const io = GvIO(gv);
+ int fd;
if (op_type == OP_SYSWRITE && io) {
const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
PUTBACK;
}
- return Perl_tied_method(aTHX_ "WRITE", mark - 1, MUTABLE_SV(io), mg,
+ return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
sp - mark);
}
SETERRNO(EBADF,RMS_IFI);
goto say_undef;
}
+ fd = PerlIO_fileno(IoIFP(io));
+ if (fd < 0) {
+ SETERRNO(EBADF,SS_IVCHAN);
+ retval = -1;
+ goto say_undef;
+ }
/* Do this first to trigger any overloading. */
buffer = SvPV_const(bufsv, blen);
doing_utf8 = DO_UTF8(bufsv);
if (PerlIO_isutf8(IoIFP(io))) {
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+ "%s() is deprecated on :utf8 handles. "
+ "This will be a fatal error in Perl 5.30",
+ OP_DESC(PL_op));
if (!SvUTF8(bufsv)) {
/* We don't modify the original scalar. */
tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
if (SP > MARK) {
STRLEN mlen;
char * const sockbuf = SvPVx(*++MARK, mlen);
- retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
+ retval = PerlSock_sendto(fd, buffer, blen,
flags, (struct sockaddr *)sockbuf, mlen);
}
else {
- retval
- = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
+ retval = PerlSock_send(fd, buffer, blen, flags);
}
}
else
blen_chars = orig_blen_bytes;
} else {
/* The SV really is UTF-8. */
- if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
- /* Don't call sv_len_utf8 again because it will call magic
- or overloading a second time, and we might get back a
- different result. */
- blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
- } else {
- /* It's safe, and it may well be cached. */
- blen_chars = sv_len_utf8(bufsv);
- }
+ /* Don't call sv_len_utf8 on a magical or overloaded
+ scalar, as we might get back a different result. */
+ blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
}
} else {
blen_chars = blen;
}
#ifdef PERL_SOCK_SYSWRITE_IS_SEND
if (IoTYPE(io) == IoTYPE_SOCKET) {
- retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
- buffer, length, 0);
+ retval = PerlSock_send(fd, buffer, length, 0);
}
else
#endif
{
/* See the note at doio.c:do_print about filesize limits. --jhi */
- retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
- buffer, length);
+ retval = PerlLIO_write(fd, buffer, length);
}
}
PP(pp_eof)
{
- dVAR; dSP;
+ dSP;
GV *gv;
IO *io;
const MAGIC *mg;
RETPUSHNO;
if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
- return tied_method1("EOF", SP, MUTABLE_SV(io), mg, newSVuv(which));
+ return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
}
if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
if (io && !IoIFP(io)) {
- if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
+ if ((IoFLAGS(io) & IOf_START) && av_tindex(GvAVn(gv)) < 0) {
+ SV ** svp;
IoLINES(io) = 0;
IoFLAGS(io) &= ~IOf_START;
- do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
- if (GvSV(gv))
- sv_setpvs(GvSV(gv), "-");
+ do_open6(gv, "-", 1, NULL, NULL, 0);
+ svp = &GvSV(gv);
+ if (*svp) {
+ SV * sv = *svp;
+ sv_setpvs(sv, "-");
+ SvSETMAGIC(sv);
+ }
else
- GvSV(gv) = newSVpvs("-");
- SvSETMAGIC(GvSV(gv));
+ *svp = newSVpvs("-");
}
- else if (!nextargv(gv))
+ else if (!nextargv(gv, FALSE))
RETPUSHYES;
}
}
PP(pp_tell)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
GV *gv;
IO *io;
if (io) {
const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
- return tied_method0("TELL", SP, MUTABLE_SV(io), mg);
+ return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
}
}
else if (!gv) {
RETURN;
}
+
+/* also used for: pp_seek() */
+
PP(pp_sysseek)
{
- dVAR; dSP;
+ dSP;
const int whence = POPi;
#if LSEEKSIZE > IVSIZE
const Off_t offset = (Off_t)SvNVx(POPs);
SV *const offset_sv = newSViv(offset);
#endif
- return tied_method2("SEEK", SP, MUTABLE_SV(io), mg, offset_sv,
+ return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
newSViv(whence));
}
}
PP(pp_truncate)
{
- dVAR;
dSP;
/* There seems to be no consensus on the length type of truncate()
* and ftruncate(), both off_t and size_t have supporters. In
GV *tmpgv;
IO *io;
- if ((tmpgv = PL_op->op_flags & OPf_SPECIAL
- ? gv_fetchsv(sv, 0, SVt_PVIO)
- : MAYBE_DEREF_GV(sv) )) {
+ if (PL_op->op_flags & OPf_SPECIAL
+ ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
+ : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
io = GvIO(tmpgv);
if (!io)
result = 0;
result = 0;
}
else {
- PerlIO_flush(fp);
+ int fd = PerlIO_fileno(fp);
+ if (fd < 0) {
+ SETERRNO(EBADF,RMS_IFI);
+ result = 0;
+ } else {
+ if (len < 0) {
+ SETERRNO(EINVAL, LIB_INVARG);
+ result = 0;
+ } else {
+ PerlIO_flush(fp);
#ifdef HAS_TRUNCATE
- if (ftruncate(PerlIO_fileno(fp), len) < 0)
+ if (ftruncate(fd, len) < 0)
#else
- if (my_chsize(PerlIO_fileno(fp), len) < 0)
+ if (my_chsize(fd, len) < 0)
#endif
- result = 0;
+ result = 0;
+ }
+ }
}
}
}
result = 0;
#else
{
- const int tmpfd = PerlLIO_open(name, O_RDWR);
+ int mode = O_RDWR;
+ int tmpfd;
+
+#if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
+ mode |= O_LARGEFILE; /* Transparently largefiley. */
+#endif
+#ifdef O_BINARY
+ /* On open(), the Win32 CRT tries to seek around text
+ * files using 32-bit offsets, which causes the open()
+ * to fail on large files, so open in binary mode.
+ */
+ mode |= O_BINARY;
+#endif
+ tmpfd = PerlLIO_open(name, mode);
- if (tmpfd < 0)
+ if (tmpfd < 0) {
result = 0;
- else {
+ } else {
if (my_chsize(tmpfd, len) < 0)
result = 0;
PerlLIO_close(tmpfd);
}
}
+
+/* also used for: pp_fcntl() */
+
PP(pp_ioctl)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
SV * const argsv = POPs;
const unsigned int func = POPu;
- const int optype = PL_op->op_type;
+ int optype;
GV * const gv = MUTABLE_GV(POPs);
- IO * const io = gv ? GvIOn(gv) : NULL;
+ IO * const io = GvIOn(gv);
char *s;
IV retval;
- if (!io || !argsv || !IoIFP(io)) {
+ if (!IoIFP(io)) {
report_evil_fh(gv);
SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
RETPUSHUNDEF;
s = INT2PTR(char*,retval); /* ouch */
}
+ optype = PL_op->op_type;
TAINT_PROPER(PL_op_desc[optype]);
if (optype == OP_IOCTL)
PP(pp_flock)
{
#ifdef FLOCK
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
I32 value;
const int argtype = POPi;
GV * const gv = MUTABLE_GV(POPs);
PUSHi(value);
RETURN;
#else
- DIE(aTHX_ PL_no_func, "flock()");
+ DIE(aTHX_ PL_no_func, "flock");
#endif
}
PP(pp_socket)
{
- dVAR; dSP;
+ dSP;
const int protocol = POPi;
const int type = POPi;
const int domain = POPi;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = gv ? GvIOn(gv) : NULL;
+ IO * const io = GvIOn(gv);
int fd;
- if (!io) {
- report_evil_fh(gv);
- if (io && IoIFP(io))
- do_close(gv, FALSE);
- SETERRNO(EBADF,LIB_INVARG);
- RETPUSHUNDEF;
- }
-
if (IoIFP(io))
do_close(gv, FALSE);
TAINT_PROPER("socket");
fd = PerlSock_socket(domain, type, protocol);
- if (fd < 0)
+ if (fd < 0) {
RETPUSHUNDEF;
- IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
- IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
+ }
+ IoIFP(io) = PerlIO_fdopen(fd, "r" SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
+ IoOFP(io) = PerlIO_fdopen(fd, "w" SOCKET_OPEN_MODE);
IoTYPE(io) = IoTYPE_SOCKET;
if (!IoIFP(io) || !IoOFP(io)) {
if (IoIFP(io)) PerlIO_close(IoIFP(io));
if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
RETPUSHUNDEF;
}
-#if defined(HAS_FCNTL) && defined(F_SETFD)
- fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
-#endif
-
-#ifdef EPOC
- setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
+#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
+ /* ensure close-on-exec */
+ if (fd > PL_maxsysfd && fcntl(fd, F_SETFD, FD_CLOEXEC) < 0)
+ RETPUSHUNDEF;
#endif
RETPUSHYES;
PP(pp_sockpair)
{
#if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
- dVAR; dSP;
+ dSP;
+ int fd[2];
const int protocol = POPi;
const int type = POPi;
const int domain = POPi;
+
GV * const gv2 = MUTABLE_GV(POPs);
+ IO * const io2 = GvIOn(gv2);
GV * const gv1 = MUTABLE_GV(POPs);
- register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
- register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
- int fd[2];
+ IO * const io1 = GvIOn(gv1);
- if (!io1)
- report_evil_fh(gv1);
- if (!io2)
- report_evil_fh(gv2);
-
- if (io1 && IoIFP(io1))
+ if (IoIFP(io1))
do_close(gv1, FALSE);
- if (io2 && IoIFP(io2))
+ if (IoIFP(io2))
do_close(gv2, FALSE);
- if (!io1 || !io2)
- RETPUSHUNDEF;
-
TAINT_PROPER("socketpair");
if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
RETPUSHUNDEF;
- IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
- IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
+ IoIFP(io1) = PerlIO_fdopen(fd[0], "r" SOCKET_OPEN_MODE);
+ IoOFP(io1) = PerlIO_fdopen(fd[0], "w" SOCKET_OPEN_MODE);
IoTYPE(io1) = IoTYPE_SOCKET;
- IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
- IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
+ IoIFP(io2) = PerlIO_fdopen(fd[1], "r" SOCKET_OPEN_MODE);
+ IoOFP(io2) = PerlIO_fdopen(fd[1], "w" SOCKET_OPEN_MODE);
IoTYPE(io2) = IoTYPE_SOCKET;
if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
RETPUSHUNDEF;
}
-#if defined(HAS_FCNTL) && defined(F_SETFD)
- fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
- fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
+#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
+ /* ensure close-on-exec */
+ if ((fd[0] > PL_maxsysfd && fcntl(fd[0], F_SETFD, FD_CLOEXEC) < 0) ||
+ (fd[1] > PL_maxsysfd && fcntl(fd[1], F_SETFD, FD_CLOEXEC) < 0))
+ RETPUSHUNDEF;
#endif
RETPUSHYES;
#ifdef HAS_SOCKET
+/* also used for: pp_connect() */
+
PP(pp_bind)
{
- dVAR; dSP;
+ dSP;
SV * const addrsv = POPs;
/* OK, so on what platform does bind modify addr? */
const char *addr;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
+ IO * const io = GvIOn(gv);
STRLEN len;
- const int op_type = PL_op->op_type;
+ int op_type;
+ int fd;
- if (!io || !IoIFP(io))
+ if (!IoIFP(io))
goto nuts;
+ fd = PerlIO_fileno(IoIFP(io));
+ if (fd < 0)
+ goto nuts;
addr = SvPV_const(addrsv, len);
+ op_type = PL_op->op_type;
TAINT_PROPER(PL_op_desc[op_type]);
if ((op_type == OP_BIND
- ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
- : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
+ ? PerlSock_bind(fd, (struct sockaddr *)addr, len)
+ : PerlSock_connect(fd, (struct sockaddr *)addr, len))
>= 0)
RETPUSHYES;
else
RETPUSHUNDEF;
-nuts:
+ nuts:
report_evil_fh(gv);
SETERRNO(EBADF,SS_IVCHAN);
RETPUSHUNDEF;
PP(pp_listen)
{
- dVAR; dSP;
+ dSP;
const int backlog = POPi;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = gv ? GvIOn(gv) : NULL;
+ IO * const io = GvIOn(gv);
- if (!io || !IoIFP(io))
+ if (!IoIFP(io))
goto nuts;
if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
else
RETPUSHUNDEF;
-nuts:
+ nuts:
report_evil_fh(gv);
SETERRNO(EBADF,SS_IVCHAN);
RETPUSHUNDEF;
PP(pp_accept)
{
- dVAR; dSP; dTARGET;
- register IO *nstio;
- register IO *gstio;
+ dSP; dTARGET;
+ IO *nstio;
char namebuf[MAXPATHLEN];
-#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
+#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
Sock_size_t len = sizeof (struct sockaddr_in);
#else
Sock_size_t len = sizeof namebuf;
GV * const ngv = MUTABLE_GV(POPs);
int fd;
- if (!ngv)
- goto badexit;
- if (!ggv)
- goto nuts;
-
- gstio = GvIO(ggv);
+ IO * const gstio = GvIO(ggv);
if (!gstio || !IoIFP(gstio))
goto nuts;
goto badexit;
if (IoIFP(nstio))
do_close(ngv, FALSE);
- IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
- IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
+ IoIFP(nstio) = PerlIO_fdopen(fd, "r" SOCKET_OPEN_MODE);
+ IoOFP(nstio) = PerlIO_fdopen(fd, "w" SOCKET_OPEN_MODE);
IoTYPE(nstio) = IoTYPE_SOCKET;
if (!IoIFP(nstio) || !IoOFP(nstio)) {
if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
goto badexit;
}
-#if defined(HAS_FCNTL) && defined(F_SETFD)
- fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
+#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
+ /* ensure close-on-exec */
+ if (fd > PL_maxsysfd && fcntl(fd, F_SETFD, FD_CLOEXEC) < 0)
+ goto badexit;
#endif
-#ifdef EPOC
- len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
- setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
-#endif
#ifdef __SCO_VERSION__
len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
#endif
PUSHp(namebuf, len);
RETURN;
-nuts:
+ nuts:
report_evil_fh(ggv);
SETERRNO(EBADF,SS_IVCHAN);
-badexit:
+ badexit:
RETPUSHUNDEF;
}
PP(pp_shutdown)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
const int how = POPi;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
+ IO * const io = GvIOn(gv);
- if (!io || !IoIFP(io))
+ if (!IoIFP(io))
goto nuts;
PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
RETURN;
-nuts:
+ nuts:
report_evil_fh(gv);
SETERRNO(EBADF,SS_IVCHAN);
RETPUSHUNDEF;
}
+
+/* also used for: pp_gsockopt() */
+
PP(pp_ssockopt)
{
- dVAR; dSP;
+ dSP;
const int optype = PL_op->op_type;
SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
const unsigned int optname = (unsigned int) POPi;
const unsigned int lvl = (unsigned int) POPi;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
+ IO * const io = GvIOn(gv);
int fd;
Sock_size_t len;
- if (!io || !IoIFP(io))
+ if (!IoIFP(io))
goto nuts;
fd = PerlIO_fileno(IoIFP(io));
+ if (fd < 0)
+ goto nuts;
switch (optype) {
case OP_GSOCKOPT:
SvGROW(sv, 257);
len = SvCUR(sv);
if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
goto nuts2;
+#if defined(_AIX)
+ /* XXX Configure test: does getsockopt set the length properly? */
+ if (len == 256)
+ len = sizeof(int);
+#endif
SvCUR_set(sv, len);
*SvEND(sv) ='\0';
PUSHs(sv);
}
RETURN;
-nuts:
+ nuts:
report_evil_fh(gv);
SETERRNO(EBADF,SS_IVCHAN);
-nuts2:
+ nuts2:
RETPUSHUNDEF;
}
+
+/* also used for: pp_getsockname() */
+
PP(pp_getpeername)
{
- dVAR; dSP;
+ dSP;
const int optype = PL_op->op_type;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
+ IO * const io = GvIOn(gv);
Sock_size_t len;
SV *sv;
int fd;
- if (!io || !IoIFP(io))
+ if (!IoIFP(io))
goto nuts;
sv = sv_2mortal(newSV(257));
SvCUR_set(sv, len);
*SvEND(sv) ='\0';
fd = PerlIO_fileno(IoIFP(io));
+ if (fd < 0)
+ goto nuts;
switch (optype) {
case OP_GETSOCKNAME:
if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
PUSHs(sv);
RETURN;
-nuts:
+ nuts:
report_evil_fh(gv);
SETERRNO(EBADF,SS_IVCHAN);
-nuts2:
+ nuts2:
RETPUSHUNDEF;
}
/* Stat calls. */
+/* also used for: pp_lstat() */
+
PP(pp_stat)
{
- dVAR;
dSP;
GV *gv = NULL;
IO *io = NULL;
- I32 gimme;
+ U8 gimme;
I32 max = 13;
SV* sv;
if (gv != PL_defgv) {
do_fstat_warning_check:
Perl_ck_warner(aTHX_ packWARN(WARN_IO),
- "lstat() on filehandle%s%"SVf,
+ "lstat() on filehandle%s%" SVf,
gv ? " " : "",
SVfARG(gv
? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
havefp = FALSE;
PL_laststype = OP_STAT;
PL_statgv = gv ? gv : (GV *)io;
- sv_setpvs(PL_statname, "");
+ SvPVCLEAR(PL_statname);
if(gv) {
io = GvIO(gv);
}
if (io) {
if (IoIFP(io)) {
- PL_laststatval =
- PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
- havefp = TRUE;
+ int fd = PerlIO_fileno(IoIFP(io));
+ if (fd < 0) {
+ PL_laststatval = -1;
+ SETERRNO(EBADF,RMS_IFI);
+ } else {
+ PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
+ havefp = TRUE;
+ }
} else if (IoDIRP(io)) {
PL_laststatval =
PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
}
}
else {
+ const char *file;
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
io = MUTABLE_IO(SvRV(sv));
if (PL_op->op_type == OP_LSTAT)
goto do_fstat_have_io;
}
+ SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
PL_statgv = NULL;
PL_laststype = PL_op->op_type;
+ file = SvPV_nolen_const(PL_statname);
if (PL_op->op_type == OP_LSTAT)
- PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
+ PL_laststatval = PerlLIO_lstat(file, &PL_statcache);
else
- PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
+ PL_laststatval = PerlLIO_stat(file, &PL_statcache);
if (PL_laststatval < 0) {
- if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
+ if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
+ /* PL_warn_nl is constant */
+ GCC_DIAG_IGNORE(-Wformat-nonliteral);
Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
+ GCC_DIAG_RESTORE;
+ }
max = 0;
}
}
#endif
mPUSHu(PL_statcache.st_mode);
mPUSHu(PL_statcache.st_nlink);
-#if Uid_t_size > IVSIZE
- mPUSHn(PL_statcache.st_uid);
-#else
-# if Uid_t_sign <= 0
- mPUSHi(PL_statcache.st_uid);
-# else
- mPUSHu(PL_statcache.st_uid);
-# endif
-#endif
-#if Gid_t_size > IVSIZE
- mPUSHn(PL_statcache.st_gid);
-#else
-# if Gid_t_sign <= 0
- mPUSHi(PL_statcache.st_gid);
-# else
- mPUSHu(PL_statcache.st_gid);
-# endif
-#endif
+
+ sv_setuid(PUSHmortal, PL_statcache.st_uid);
+ sv_setgid(PUSHmortal, PL_statcache.st_gid);
+
#ifdef USE_STAT_RDEV
mPUSHi(PL_statcache.st_rdev);
#else
RETURN;
}
+/* All filetest ops avoid manipulating the perl stack pointer in their main
+ bodies (since commit d2c4d2d1e22d3125), and return using either
+ S_ft_return_false() or S_ft_return_true(). These two helper functions are
+ the only two which manipulate the perl stack. To ensure that no stack
+ manipulation macros are used, the filetest ops avoid defining a local copy
+ of the stack pointer with dSP. */
+
/* If the next filetest is stacked up with this one
(PL_op->op_private & OPpFT_STACKING), we leave
the original argument on the stack for success,
*/
static OP *
-S_ft_stacking_return_false(pTHX_ SV *ret) {
- dSP;
+S_ft_return_false(pTHX_ SV *ret) {
OP *next = NORMAL;
- while (OP_IS_FILETEST(next->op_type)
- && next->op_private & OPpFT_STACKED)
- next = next->op_next;
+ dSP;
+
if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
else SETs(ret);
PUTBACK;
+
+ if (PL_op->op_private & OPpFT_STACKING) {
+ while (OP_IS_FILETEST(next->op_type)
+ && next->op_private & OPpFT_STACKED)
+ next = next->op_next;
+ }
return next;
}
-#define FT_RETURN_FALSE(X) \
- STMT_START { \
- if (PL_op->op_private & OPpFT_STACKING) \
- return S_ft_stacking_return_false(aTHX_ X); \
- RETURNX(PL_op->op_flags & OPf_REF ? XPUSHs(X) : SETs(X)); \
- } STMT_END
-#define FT_RETURN_TRUE(X) \
- RETURNX((void)( \
- PL_op->op_flags & OPf_REF \
- ? (bool)XPUSHs( \
- PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (X) \
- ) \
- : (PL_op->op_private & OPpFT_STACKING || SETs(X)) \
- ))
-
-#define FT_RETURNNO FT_RETURN_FALSE(&PL_sv_no)
-#define FT_RETURNUNDEF FT_RETURN_FALSE(&PL_sv_undef)
-#define FT_RETURNYES FT_RETURN_TRUE(&PL_sv_yes)
+PERL_STATIC_INLINE OP *
+S_ft_return_true(pTHX_ SV *ret) {
+ dSP;
+ if (PL_op->op_flags & OPf_REF)
+ XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
+ else if (!(PL_op->op_private & OPpFT_STACKING))
+ SETs(ret);
+ PUTBACK;
+ return NORMAL;
+}
+
+#define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no)
+#define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef)
+#define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes)
#define tryAMAGICftest_MG(chr) STMT_START { \
- if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \
+ if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
&& PL_op->op_flags & OPf_KIDS) { \
OP *next = S_try_amagic_ftest(aTHX_ chr); \
if (next) return next; \
STATIC OP *
S_try_amagic_ftest(pTHX_ char chr) {
- dVAR;
- dSP;
- SV* const arg = TOPs;
+ SV *const arg = *PL_stack_sp;
assert(chr != '?');
if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
- if (SvAMAGIC(TOPs))
+ if (SvAMAGIC(arg))
{
const char tmpchr = chr;
SV * const tmpsv = amagic_call(arg,
if (!tmpsv)
return NULL;
- if (SvTRUE(tmpsv)) FT_RETURN_TRUE(tmpsv);
- FT_RETURN_FALSE(tmpsv);
+ return SvTRUE(tmpsv)
+ ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
}
return NULL;
}
+/* also used for: pp_fteexec() pp_fteread() pp_ftewrite() pp_ftrexec()
+ * pp_ftrwrite() */
+
PP(pp_ftrread)
{
- dVAR;
I32 result;
/* Not const, because things tweak this below. Not bool, because there's
- no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
+ no guarantee that OPpFT_ACCESS is <= CHAR_MAX */
#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
I32 use_access = PL_op->op_private & OPpFT_ACCESS;
/* Giving some sort of initial value silences compilers. */
bool effective = FALSE;
char opchar = '?';
- dSP;
switch (PL_op->op_type) {
case OP_FTRREAD: opchar = 'R'; break;
access_mode = W_OK;
#endif
stat_mode = S_IWUSR;
- /* fall through */
+ /* FALLTHROUGH */
case OP_FTEREAD:
#ifndef PERL_EFF_ACCESS
if (use_access) {
#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
- const char *name = TOPpx;
+ const char *name = SvPV_nolen(*PL_stack_sp);
if (effective) {
# ifdef PERL_EFF_ACCESS
result = PERL_EFF_ACCESS(name, access_mode);
FT_RETURNNO;
}
+
+/* also used for: pp_ftatime() pp_ftctime() pp_ftmtime() pp_ftsize() */
+
PP(pp_ftis)
{
- dVAR;
I32 result;
const int op_type = PL_op->op_type;
char opchar = '?';
- dSP;
switch (op_type) {
case OP_FTIS: opchar = 'e'; break;
break;
}
SvSETMAGIC(TARG);
- if (SvTRUE_nomg(TARG)) FT_RETURN_TRUE(TARG);
- else FT_RETURN_FALSE(TARG);
+ return SvTRUE_nomg(TARG)
+ ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
}
}
+
+/* also used for: pp_ftblk() pp_ftchr() pp_ftdir() pp_fteowned()
+ * pp_ftfile() pp_ftpipe() pp_ftsgid() pp_ftsock()
+ * pp_ftsuid() pp_ftsvtx() pp_ftzero() */
+
PP(pp_ftrowned)
{
- dVAR;
I32 result;
char opchar = '?';
- dSP;
switch (PL_op->op_type) {
case OP_FTROWNED: opchar = 'O'; break;
PP(pp_ftlink)
{
- dVAR;
- dSP;
I32 result;
tryAMAGICftest_MG('l');
PP(pp_fttty)
{
- dVAR;
- dSP;
int fd;
GV *gv;
char *name = NULL;
STRLEN namelen;
+ UV uv;
tryAMAGICftest_MG('t');
if (PL_op->op_flags & OPf_REF)
gv = cGVOP_gv;
else {
- SV *tmpsv = TOPs;
+ SV *tmpsv = *PL_stack_sp;
if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
name = SvPV_nomg(tmpsv, namelen);
gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
if (GvIO(gv) && IoIFP(GvIOp(gv)))
fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
- else if (name && isDIGIT(*name))
- fd = atoi(name);
+ else if (name && isDIGIT(*name) && grok_atoUV(name, &uv, NULL) && uv <= PERL_INT_MAX)
+ fd = (int)uv;
else
FT_RETURNUNDEF;
+ if (fd < 0) {
+ SETERRNO(EBADF,RMS_IFI);
+ FT_RETURNUNDEF;
+ }
if (PerlLIO_isatty(fd))
FT_RETURNYES;
FT_RETURNNO;
}
-#if defined(atarist) /* this will work with atariST. Configure will
- make guesses for other systems. */
-# define FILE_base(f) ((f)->_base)
-# define FILE_ptr(f) ((f)->_ptr)
-# define FILE_cnt(f) ((f)->_cnt)
-# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
-#endif
+
+/* also used for: pp_ftbinary() */
PP(pp_fttext)
{
- dVAR;
- dSP;
I32 i;
- I32 len;
+ SSize_t len;
I32 odd = 0;
STDCHAR tbuf[512];
- register STDCHAR *s;
- register IO *io;
- register SV *sv = NULL;
+ STDCHAR *s;
+ IO *io;
+ SV *sv = NULL;
GV *gv;
PerlIO *fp;
== OPpFT_STACKED)
gv = PL_defgv;
else {
- sv = TOPs;
+ sv = *PL_stack_sp;
gv = MAYBE_DEREF_GV_nomg(sv);
}
}
else {
PL_statgv = gv;
- sv_setpvs(PL_statname, "");
+ SvPVCLEAR(PL_statname);
io = GvIO(PL_statgv);
}
PL_laststatval = -1;
PL_laststype = OP_STAT;
if (io && IoIFP(io)) {
+ int fd;
if (! PerlIO_has_base(IoIFP(io)))
DIE(aTHX_ "-T and -B not implemented on filehandles");
- PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
+ fd = PerlIO_fileno(IoIFP(io));
+ if (fd < 0) {
+ SETERRNO(EBADF,RMS_IFI);
+ FT_RETURNUNDEF;
+ }
+ PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
if (PL_laststatval < 0)
FT_RETURNUNDEF;
if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
i = PerlIO_getc(IoIFP(io));
if (i != EOF)
(void)PerlIO_ungetc(IoIFP(io),i);
+ else
+ /* null file is anything */
+ FT_RETURNYES;
}
- if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
- FT_RETURNYES;
len = PerlIO_get_bufsiz(IoIFP(io));
s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
/* sfio can have large buffers - limit to 512 */
}
}
else {
+ const char *file;
+ int fd;
+
+ assert(sv);
sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
really_filename:
+ file = SvPVX_const(PL_statname);
PL_statgv = NULL;
- if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
+ if (!(fp = PerlIO_open(file, "r"))) {
if (!gv) {
PL_laststatval = -1;
PL_laststype = OP_STAT;
}
- if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
- '\n'))
+ if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
+ /* PL_warn_nl is constant */
+ GCC_DIAG_IGNORE(-Wformat-nonliteral);
Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
+ GCC_DIAG_RESTORE;
+ }
FT_RETURNUNDEF;
}
PL_laststype = OP_STAT;
- PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
+ fd = PerlIO_fileno(fp);
+ if (fd < 0) {
+ (void)PerlIO_close(fp);
+ SETERRNO(EBADF,RMS_IFI);
+ FT_RETURNUNDEF;
+ }
+ PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
if (PL_laststatval < 0) {
+ dSAVE_ERRNO;
(void)PerlIO_close(fp);
+ RESTORE_ERRNO;
FT_RETURNUNDEF;
}
PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
}
/* now scan s to look for textiness */
- /* XXX ASCII dependent code */
#if defined(DOSISH) || defined(USEMYBINMODE)
/* ignore trailing ^Z on short files */
--len;
#endif
+ assert(len);
+ if (! is_utf8_invariant_string((U8 *) s, len)) {
+
+ /* Here contains a variant under UTF-8 . See if the entire string is
+ * UTF-8. */
+ if (is_utf8_fixed_width_buf_flags((U8 *) s, len, 0)) {
+ if (PL_op->op_type == OP_FTTEXT) {
+ FT_RETURNYES;
+ }
+ else {
+ FT_RETURNNO;
+ }
+ }
+ }
+
+ /* Here, is not UTF-8 or is entirely ASCII. Look through the buffer for
+ * things that wouldn't be in ASCII text or rich ASCII text. Count these
+ * in 'odd' */
for (i = 0; i < len; i++, s++) {
if (!*s) { /* null never allowed in text */
odd += len;
break;
}
-#ifdef EBCDIC
- else if (!(isPRINT(*s) || isSPACE(*s)))
- odd++;
-#else
- else if (*s & 128) {
-#ifdef USE_LOCALE
- if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
+#ifdef USE_LOCALE_CTYPE
+ if (IN_LC_RUNTIME(LC_CTYPE)) {
+ if ( isPRINT_LC(*s) || isSPACE_LC(*s)) {
continue;
+ }
+ }
+ else
#endif
- /* utf8 characters don't count as odd */
- if (UTF8_IS_START(*s)) {
- int ulen = UTF8SKIP(s);
- if (ulen < len - i) {
- int j;
- for (j = 1; j < ulen; j++) {
- if (!UTF8_IS_CONTINUATION(s[j]))
- goto not_utf8;
- }
- --ulen; /* loop does extra increment */
- s += ulen;
- i += ulen;
- continue;
- }
- }
- not_utf8:
- odd++;
- }
- else if (*s < 32 &&
- *s != '\n' && *s != '\r' && *s != '\b' &&
- *s != '\t' && *s != '\f' && *s != 27)
- odd++;
-#endif
+ if ( isPRINT_A(*s)
+ /* VT occurs so rarely in text, that we consider it odd */
+ || (isSPACE_A(*s) && *s != VT_NATIVE)
+
+ /* But there is a fair amount of backspaces and escapes in
+ * some text */
+ || *s == '\b'
+ || *s == ESC_NATIVE)
+ {
+ continue;
+ }
+ odd++;
}
if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
PP(pp_chdir)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
const char *tmps = NULL;
GV *gv = NULL;
SV * const sv = POPs;
if (PL_op->op_flags & OPf_SPECIAL) {
gv = gv_fetchsv(sv, 0, SVt_PVIO);
+ if (!gv) {
+ if (ckWARN(WARN_UNOPENED)) {
+ Perl_warner(aTHX_ packWARN(WARN_UNOPENED),
+ "chdir() on unopened filehandle %" SVf, sv);
+ }
+ SETERRNO(EBADF,RMS_IFI);
+ PUSHi(0);
+ TAINT_PROPER("chdir");
+ RETURN;
+ }
}
else if (!(gv = MAYBE_DEREF_GV(sv)))
tmps = SvPV_nomg_const_nolen(sv);
}
-
- if( !gv && (!tmps || !*tmps) ) {
+ else {
HV * const table = GvHVn(PL_envgv);
SV **svp;
+ EXTEND(SP, 1);
if ( (svp = hv_fetchs(table, "HOME", FALSE))
|| (svp = hv_fetchs(table, "LOGDIR", FALSE))
#ifdef VMS
#endif
)
{
- if( MAXARG == 1 )
- deprecate("chdir('') or chdir(undef) as chdir()");
tmps = SvPV_nolen_const(*svp);
}
else {
PUSHi(0);
+ SETERRNO(EINVAL, LIB_INVARG);
TAINT_PROPER("chdir");
RETURN;
}
if (IoDIRP(io)) {
PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
} else if (IoIFP(io)) {
- PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
+ int fd = PerlIO_fileno(IoIFP(io));
+ if (fd < 0) {
+ goto nuts;
+ }
+ PUSHi(fchdir(fd) >= 0);
}
else {
- report_evil_fh(gv);
- SETERRNO(EBADF, RMS_IFI);
- PUSHi(0);
+ goto nuts;
}
+ } else {
+ goto nuts;
}
- else {
- report_evil_fh(gv);
- SETERRNO(EBADF,RMS_IFI);
- PUSHi(0);
- }
+
#else
DIE(aTHX_ PL_no_func, "fchdir");
#endif
hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
#endif
RETURN;
+
+#ifdef HAS_FCHDIR
+ nuts:
+ report_evil_fh(gv);
+ SETERRNO(EBADF,RMS_IFI);
+ PUSHi(0);
+ RETURN;
+#endif
}
+
+/* also used for: pp_chmod() pp_kill() pp_unlink() pp_utime() */
+
PP(pp_chown)
{
- dVAR; dSP; dMARK; dTARGET;
+ dSP; dMARK; dTARGET;
const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
SP = MARK;
PP(pp_chroot)
{
#ifdef HAS_CHROOT
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
char * const tmps = POPpx;
TAINT_PROPER("chroot");
PUSHi( chroot(tmps) >= 0 );
PP(pp_rename)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
int anum;
+#ifndef HAS_RENAME
+ Stat_t statbuf;
+#endif
const char * const tmps2 = POPpconstx;
const char * const tmps = SvPV_nolen_const(TOPs);
TAINT_PROPER("rename");
#ifdef HAS_RENAME
anum = PerlLIO_rename(tmps, tmps2);
#else
- if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
+ if (!(anum = PerlLIO_stat(tmps, &statbuf))) {
if (same_dirent(tmps2, tmps)) /* can always rename to same name */
anum = 1;
else {
- if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
+ if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
(void)UNLINK(tmps2);
if (!(anum = link(tmps, tmps2)))
anum = UNLINK(tmps);
RETURN;
}
+
+/* also used for: pp_symlink() */
+
#if defined(HAS_LINK) || defined(HAS_SYMLINK)
PP(pp_link)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
const int op_type = PL_op->op_type;
int result;
RETURN;
}
#else
+
+/* also used for: pp_symlink() */
+
PP(pp_link)
{
/* Have neither. */
PP(pp_readlink)
{
- dVAR;
dSP;
#ifdef HAS_SYMLINK
dTARGET;
const char *tmps;
char buf[MAXPATHLEN];
- int len;
+ SSize_t len;
-#ifndef INCOMPLETE_TAINTS
TAINT;
-#endif
tmps = POPpconstx;
+ /* NOTE: if the length returned by readlink() is sizeof(buf) - 1,
+ * it is impossible to know whether the result was truncated. */
len = readlink(tmps, buf, sizeof(buf) - 1);
if (len < 0)
RETPUSHUNDEF;
+ if (len != -1)
+ buf[len] = '\0';
PUSHp(buf, len);
RETURN;
#else
; e++)
{
/* you don't see this */
- const char * const errmsg =
-#ifdef HAS_SYS_ERRLIST
- sys_errlist[e]
-#else
- strerror(e)
-#endif
- ;
+ const char * const errmsg = Strerror(e) ;
if (!errmsg)
break;
if (instr(s, errmsg)) {
return 0;
}
else { /* some mkdirs return no failure indication */
- anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
+ Stat_t statbuf;
+ anum = (PerlLIO_stat(save_filename, &statbuf) >= 0);
if (PL_op->op_type == OP_RMDIR)
anum = !anum;
if (anum)
PP(pp_mkdir)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
STRLEN len;
const char *tmps;
bool copy = FALSE;
- const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
+ const unsigned int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPu : 0777;
TRIMSLASHES(tmps,len,copy);
PP(pp_rmdir)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
STRLEN len;
const char *tmps;
bool copy = FALSE;
PP(pp_open_dir)
{
#if defined(Direntry_t) && defined(HAS_READDIR)
- dVAR; dSP;
+ dSP;
const char * const dirname = POPpconstx;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
-
- if (!io)
- goto nope;
+ IO * const io = GvIOn(gv);
if ((IoIFP(io) || IoOFP(io)))
- Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
- "Opening filehandle %"HEKf" also as a directory",
- HEKfARG(GvENAME_HEK(gv)) );
+ Perl_croak(aTHX_ "Cannot open %" HEKf " as a dirhandle: it is already open as a filehandle",
+ HEKfARG(GvENAME_HEK(gv)));
if (IoDIRP(io))
PerlDir_close(IoDIRP(io));
if (!(IoDIRP(io) = PerlDir_open(dirname)))
goto nope;
RETPUSHYES;
-nope:
+ nope:
if (!errno)
SETERRNO(EBADF,RMS_DIR);
RETPUSHUNDEF;
#if !defined(I_DIRENT) && !defined(VMS)
Direntry_t *readdir (DIR *);
#endif
- dVAR;
dSP;
SV *sv;
- const I32 gimme = GIMME;
+ const U8 gimme = GIMME_V;
GV * const gv = MUTABLE_GV(POPs);
- register const Direntry_t *dp;
- register IO * const io = GvIOn(gv);
+ const Direntry_t *dp;
+ IO * const io = GvIOn(gv);
- if (!io || !IoDIRP(io)) {
+ if (!IoDIRP(io)) {
Perl_ck_warner(aTHX_ packWARN(WARN_IO),
- "readdir() attempted on invalid dirhandle %"HEKf,
+ "readdir() attempted on invalid dirhandle %" HEKf,
HEKfARG(GvENAME_HEK(gv)));
goto nope;
}
#else
sv = newSVpv(dp->d_name, 0);
#endif
-#ifndef INCOMPLETE_TAINTS
if (!(IoFLAGS(io) & IOf_UNTAINT))
SvTAINTED_on(sv);
-#endif
mXPUSHs(sv);
} while (gimme == G_ARRAY);
if (!dp && gimme != G_ARRAY)
- goto nope;
+ RETPUSHUNDEF;
RETURN;
-nope:
+ nope:
if (!errno)
SETERRNO(EBADF,RMS_ISI);
- if (GIMME == G_ARRAY)
+ if (gimme == G_ARRAY)
RETURN;
else
RETPUSHUNDEF;
PP(pp_telldir)
{
#if defined(HAS_TELLDIR) || defined(telldir)
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
/* XXX does _anyone_ need this? --AD 2/20/1998 */
/* XXX netbsd still seemed to.
XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
long telldir (DIR *);
# endif
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
+ IO * const io = GvIOn(gv);
- if (!io || !IoDIRP(io)) {
+ if (!IoDIRP(io)) {
Perl_ck_warner(aTHX_ packWARN(WARN_IO),
- "telldir() attempted on invalid dirhandle %"HEKf,
+ "telldir() attempted on invalid dirhandle %" HEKf,
HEKfARG(GvENAME_HEK(gv)));
goto nope;
}
PUSHi( PerlDir_tell(IoDIRP(io)) );
RETURN;
-nope:
+ nope:
if (!errno)
SETERRNO(EBADF,RMS_ISI);
RETPUSHUNDEF;
PP(pp_seekdir)
{
#if defined(HAS_SEEKDIR) || defined(seekdir)
- dVAR; dSP;
+ dSP;
const long along = POPl;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
+ IO * const io = GvIOn(gv);
- if (!io || !IoDIRP(io)) {
+ if (!IoDIRP(io)) {
Perl_ck_warner(aTHX_ packWARN(WARN_IO),
- "seekdir() attempted on invalid dirhandle %"HEKf,
+ "seekdir() attempted on invalid dirhandle %" HEKf,
HEKfARG(GvENAME_HEK(gv)));
goto nope;
}
(void)PerlDir_seek(IoDIRP(io), along);
RETPUSHYES;
-nope:
+ nope:
if (!errno)
SETERRNO(EBADF,RMS_ISI);
RETPUSHUNDEF;
PP(pp_rewinddir)
{
#if defined(HAS_REWINDDIR) || defined(rewinddir)
- dVAR; dSP;
+ dSP;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
+ IO * const io = GvIOn(gv);
- if (!io || !IoDIRP(io)) {
+ if (!IoDIRP(io)) {
Perl_ck_warner(aTHX_ packWARN(WARN_IO),
- "rewinddir() attempted on invalid dirhandle %"HEKf,
+ "rewinddir() attempted on invalid dirhandle %" HEKf,
HEKfARG(GvENAME_HEK(gv)));
goto nope;
}
(void)PerlDir_rewind(IoDIRP(io));
RETPUSHYES;
-nope:
+ nope:
if (!errno)
SETERRNO(EBADF,RMS_ISI);
RETPUSHUNDEF;
PP(pp_closedir)
{
#if defined(Direntry_t) && defined(HAS_READDIR)
- dVAR; dSP;
+ dSP;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
+ IO * const io = GvIOn(gv);
- if (!io || !IoDIRP(io)) {
+ if (!IoDIRP(io)) {
Perl_ck_warner(aTHX_ packWARN(WARN_IO),
- "closedir() attempted on invalid dirhandle %"HEKf,
+ "closedir() attempted on invalid dirhandle %" HEKf,
HEKfARG(GvENAME_HEK(gv)));
goto nope;
}
IoDIRP(io) = 0;
RETPUSHYES;
-nope:
+ nope:
if (!errno)
SETERRNO(EBADF,RMS_IFI);
RETPUSHUNDEF;
PP(pp_fork)
{
#ifdef HAS_FORK
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
Pid_t childpid;
-#if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
+#ifdef HAS_SIGPROCMASK
sigset_t oldmask, newmask;
#endif
EXTEND(SP, 1);
PERL_FLUSHALL_FOR_CHILD;
-#if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
+#ifdef HAS_SIGPROCMASK
sigfillset(&newmask);
sigprocmask(SIG_SETMASK, &newmask, &oldmask);
#endif
for (sig = 1; sig < SIG_SIZE; sig++)
PL_psig_pend[sig] = 0;
}
-#if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
+#ifdef HAS_SIGPROCMASK
{
dSAVE_ERRNO;
sigprocmask(SIG_SETMASK, &oldmask, NULL);
}
#endif
if (childpid < 0)
- RETSETUNDEF;
+ RETPUSHUNDEF;
if (!childpid) {
#ifdef PERL_USES_PL_PIDSTATUS
hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
PUSHi(childpid);
RETURN;
#else
-# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
+# if (defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)) || defined(__amigaos4__)
dSP; dTARGET;
Pid_t childpid;
PERL_FLUSHALL_FOR_CHILD;
childpid = PerlProc_fork();
if (childpid == -1)
- RETSETUNDEF;
+ RETPUSHUNDEF;
PUSHi(childpid);
RETURN;
# else
PP(pp_wait)
{
#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
Pid_t childpid;
int argflags;
PP(pp_waitpid)
{
#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
const int optype = POPi;
const Pid_t pid = TOPi;
Pid_t result;
+#ifdef __amigaos4__
+ int argflags = 0;
+ result = amigaos_waitpid(aTHX_ optype, pid, &argflags);
+ STATUS_NATIVE_CHILD_SET((result >= 0) ? argflags : -1);
+ result = result == 0 ? pid : -1;
+#else
int argflags;
if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
# else
STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
# endif
+# endif /* __amigaos4__ */
SETi(result);
RETURN;
#else
PP(pp_system)
{
- dVAR; dSP; dMARK; dORIGMARK; dTARGET;
+ dSP; dMARK; dORIGMARK; dTARGET;
#if defined(__LIBCATAMOUNT__)
PL_statusvalue = -1;
SP = ORIGMARK;
XPUSHi(-1);
#else
I32 value;
+# ifdef __amigaos4__
+ void * result;
+# else
int result;
+# endif
- if (PL_tainting) {
+ if (TAINTING_get) {
TAINT_ENV();
while (++MARK <= SP) {
(void)SvPV_nolen_const(*MARK); /* stringify for taint check */
- if (PL_tainted)
+ if (TAINT_get)
break;
}
MARK = ORIGMARK;
TAINT_PROPER("system");
}
PERL_FLUSHALL_FOR_CHILD;
-#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
+#if (defined(HAS_FORK) || defined(__amigaos4__)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
{
+#ifdef __amigaos4__
+ struct UserData userdata;
+ pthread_t proc;
+#else
Pid_t childpid;
+#endif
int pp[2];
I32 did_pipes = 0;
-#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
+ bool child_success = FALSE;
+#ifdef HAS_SIGPROCMASK
sigset_t newset, oldset;
#endif
if (PerlProc_pipe(pp) >= 0)
did_pipes = 1;
-#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
+#ifdef __amigaos4__
+ amigaos_fork_set_userdata(aTHX_
+ &userdata,
+ did_pipes,
+ pp[1],
+ SP,
+ mark);
+ pthread_create(&proc,NULL,amigaos_system_child,(void *)&userdata);
+ child_success = proc > 0;
+#else
+#ifdef HAS_SIGPROCMASK
sigemptyset(&newset);
sigaddset(&newset, SIGCHLD);
sigprocmask(SIG_BLOCK, &newset, &oldset);
PerlLIO_close(pp[0]);
PerlLIO_close(pp[1]);
}
-#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
+#ifdef HAS_SIGPROCMASK
sigprocmask(SIG_SETMASK, &oldset, NULL);
#endif
RETURN;
}
sleep(5);
}
- if (childpid > 0) {
+ child_success = childpid > 0;
+#endif
+ if (child_success) {
Sigsave_t ihand,qhand; /* place to save signals during system() */
int status;
+#ifndef __amigaos4__
if (did_pipes)
PerlLIO_close(pp[1]);
+#endif
#ifndef PERL_MICRO
rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
#endif
+#ifdef __amigaos4__
+ result = pthread_join(proc, (void **)&status);
+#else
do {
result = wait4pid(childpid, &status, 0);
} while (result == -1 && errno == EINTR);
+#endif
#ifndef PERL_MICRO
#ifdef HAS_SIGPROCMASK
sigprocmask(SIG_SETMASK, &oldset, NULL);
if (did_pipes) {
int errkid;
unsigned n = 0;
- SSize_t n1;
while (n < sizeof(int)) {
- n1 = PerlLIO_read(pp[0],
+ const SSize_t n1 = PerlLIO_read(pp[0],
(void*)(((char*)&errkid)+n),
(sizeof(int)) - n);
if (n1 <= 0)
if (n != sizeof(int))
DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
errno = errkid; /* Propagate errno from kid */
- STATUS_NATIVE_CHILD_SET(-1);
+#ifdef __amigaos4__
+ /* The pipe always has something in it
+ * so n alone is not enough. */
+ if (errno > 0)
+#endif
+ {
+ STATUS_NATIVE_CHILD_SET(-1);
+ }
}
}
XPUSHi(STATUS_CURRENT);
RETURN;
}
-#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
+#ifndef __amigaos4__
+#ifdef HAS_SIGPROCMASK
sigprocmask(SIG_SETMASK, &oldset, NULL);
#endif
if (did_pipes) {
PerlLIO_close(pp[0]);
-#if defined(HAS_FCNTL) && defined(F_SETFD)
- fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
+ if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
+ RETPUSHUNDEF;
#endif
}
if (PL_op->op_flags & OPf_STACKED) {
else {
value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
}
+#endif /* __amigaos4__ */
PerlProc__exit(-1);
}
#else /* ! FORK or VMS or OS/2 */
PP(pp_exec)
{
- dVAR; dSP; dMARK; dORIGMARK; dTARGET;
+ dSP; dMARK; dORIGMARK; dTARGET;
I32 value;
- if (PL_tainting) {
+ if (TAINTING_get) {
TAINT_ENV();
while (++MARK <= SP) {
(void)SvPV_nolen_const(*MARK); /* stringify for taint check */
- if (PL_tainted)
+ if (TAINT_get)
break;
}
MARK = ORIGMARK;
TAINT_PROPER("exec");
}
+
PERL_FLUSHALL_FOR_CHILD;
if (PL_op->op_flags & OPf_STACKED) {
SV * const really = *++MARK;
#ifdef VMS
value = (I32)vms_do_aexec(NULL, MARK, SP);
#else
-# ifdef __OPEN_VM
- {
- (void ) do_aspawn(NULL, MARK, SP);
- value = 0;
- }
-# else
value = (I32)do_aexec(NULL, MARK, SP);
-# endif
#endif
else {
#ifdef VMS
value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
#else
-# ifdef __OPEN_VM
- (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
- value = 0;
-# else
value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
-# endif
#endif
}
-
SP = ORIGMARK;
XPUSHi(value);
RETURN;
PP(pp_getppid)
{
#ifdef HAS_GETPPID
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
XPUSHi( getppid() );
RETURN;
#else
PP(pp_getpgrp)
{
#ifdef HAS_GETPGRP
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
Pid_t pgrp;
const Pid_t pid =
(MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
XPUSHi(pgrp);
RETURN;
#else
- DIE(aTHX_ PL_no_func, "getpgrp()");
+ DIE(aTHX_ PL_no_func, "getpgrp");
#endif
}
PP(pp_setpgrp)
{
#ifdef HAS_SETPGRP
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
Pid_t pgrp;
Pid_t pid;
pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
- if (MAXARG > 0) pid = TOPs && TOPi;
+ if (MAXARG > 0) pid = TOPs ? TOPi : 0;
else {
pid = 0;
- XPUSHi(-1);
+ EXTEND(SP,1);
+ SP++;
}
TAINT_PROPER("setpgrp");
#endif /* USE_BSDPGRP */
RETURN;
#else
- DIE(aTHX_ PL_no_func, "setpgrp()");
+ DIE(aTHX_ PL_no_func, "setpgrp");
#endif
}
PP(pp_getpriority)
{
#ifdef HAS_GETPRIORITY
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
const int who = POPi;
const int which = TOPi;
SETi( getpriority(PRIORITY_WHICH_T(which), who) );
RETURN;
#else
- DIE(aTHX_ PL_no_func, "getpriority()");
+ DIE(aTHX_ PL_no_func, "getpriority");
#endif
}
PP(pp_setpriority)
{
#ifdef HAS_SETPRIORITY
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
const int niceval = POPi;
const int who = POPi;
const int which = TOPi;
SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
RETURN;
#else
- DIE(aTHX_ PL_no_func, "setpriority()");
+ DIE(aTHX_ PL_no_func, "setpriority");
#endif
}
PP(pp_time)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
#ifdef BIG_TIME
XPUSHn( time(NULL) );
#else
PP(pp_tms)
{
#ifdef HAS_TIMES
- dVAR;
dSP;
+ struct tms timesbuf;
+
EXTEND(SP, 4);
-#ifndef VMS
- (void)PerlProc_times(&PL_timesbuf);
-#else
- (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
- /* struct tms, though same data */
- /* is returned. */
-#endif
+ (void)PerlProc_times(×buf);
- mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
- if (GIMME == G_ARRAY) {
- mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
- mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
- mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
+ mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick);
+ if (GIMME_V == G_ARRAY) {
+ mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick);
+ mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick);
+ mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick);
}
RETURN;
#else
dSP;
mPUSHn(0.0);
EXTEND(SP, 4);
- if (GIMME == G_ARRAY) {
+ if (GIMME_V == G_ARRAY) {
mPUSHn(0.0);
mPUSHn(0.0);
mPUSHn(0.0);
/* Sun Dec 29 12:00:00 2147483647 */
#define TIME_UPPER_BOUND 67767976233316800.0
+
+/* also used for: pp_localtime() */
+
PP(pp_gmtime)
{
- dVAR;
dSP;
Time64_T when;
struct TM tmbuf;
}
else {
NV input = Perl_floor(POPn);
+ const bool pl_isnan = Perl_isnan(input);
when = (Time64_T)input;
- if (when != input) {
+ if (UNLIKELY(pl_isnan || when != input)) {
/* diag_listed_as: gmtime(%f) too large */
Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
"%s(%.0" NVff ") too large", opname, input);
+ if (pl_isnan) {
+ err = NULL;
+ goto failed;
+ }
}
}
}
else {
if (PL_op->op_type == OP_LOCALTIME)
- err = S_localtime64_r(&when, &tmbuf);
+ err = Perl_localtime64_r(&when, &tmbuf);
else
- err = S_gmtime64_r(&when, &tmbuf);
+ err = Perl_gmtime64_r(&when, &tmbuf);
}
if (err == NULL) {
+ /* diag_listed_as: gmtime(%f) failed */
/* XXX %lld broken for quads */
+ failed:
Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
"%s(%.0" NVff ") failed", opname, when);
}
- if (GIMME != G_ARRAY) { /* scalar context */
- SV *tsv;
- /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
- double year = (double)tmbuf.tm_year + 1900;
-
+ if (GIMME_V != G_ARRAY) { /* scalar context */
EXTEND(SP, 1);
- EXTEND_MORTAL(1);
if (err == NULL)
RETPUSHUNDEF;
-
- tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
- dayname[tmbuf.tm_wday],
- monname[tmbuf.tm_mon],
- tmbuf.tm_mday,
- tmbuf.tm_hour,
- tmbuf.tm_min,
- tmbuf.tm_sec,
- year);
- mPUSHs(tsv);
+ else {
+ dTARGET;
+ PUSHs(TARG);
+ Perl_sv_setpvf_mg(aTHX_ TARG, "%s %s %2d %02d:%02d:%02d %" IVdf,
+ dayname[tmbuf.tm_wday],
+ monname[tmbuf.tm_mon],
+ tmbuf.tm_mday,
+ tmbuf.tm_hour,
+ tmbuf.tm_min,
+ tmbuf.tm_sec,
+ (IV)tmbuf.tm_year + 1900);
+ }
}
else { /* list context */
if ( err == NULL )
PP(pp_alarm)
{
#ifdef HAS_ALARM
- dVAR; dSP; dTARGET;
- int anum;
- anum = POPi;
- anum = alarm((unsigned int)anum);
- if (anum < 0)
- RETPUSHUNDEF;
- PUSHi(anum);
- RETURN;
+ dSP; dTARGET;
+ /* alarm() takes an unsigned int number of seconds, and return the
+ * unsigned int number of seconds remaining in the previous alarm
+ * (alarms don't stack). Therefore negative return values are not
+ * possible. */
+ int anum = POPi;
+ if (anum < 0) {
+ /* Note that while the C library function alarm() as such has
+ * no errors defined (or in other words, properly behaving client
+ * code shouldn't expect any), alarm() being obsoleted by
+ * setitimer() and often being implemented in terms of
+ * setitimer(), can fail. */
+ /* diag_listed_as: %s() with negative argument */
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
+ "alarm() with negative argument");
+ SETERRNO(EINVAL, LIB_INVARG);
+ RETPUSHUNDEF;
+ }
+ else {
+ unsigned int retval = alarm(anum);
+ if ((int)retval < 0) /* Strictly speaking "cannot happen". */
+ RETPUSHUNDEF;
+ PUSHu(retval);
+ RETURN;
+ }
#else
DIE(aTHX_ PL_no_func, "alarm");
#endif
PP(pp_sleep)
{
- dVAR; dSP; dTARGET;
- I32 duration;
+ dSP; dTARGET;
Time_t lasttime;
Time_t when;
if (MAXARG < 1 || (!TOPs && !POPs))
PerlProc_pause();
else {
- duration = POPi;
- PerlProc_sleep((unsigned int)duration);
+ const I32 duration = POPi;
+ if (duration < 0) {
+ /* diag_listed_as: %s() with negative argument */
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
+ "sleep() with negative argument");
+ SETERRNO(EINVAL, LIB_INVARG);
+ XPUSHi(0);
+ RETURN;
+ } else {
+ PerlProc_sleep((unsigned int)duration);
+ }
}
(void)time(&when);
XPUSHi(when - lasttime);
/* Shared memory. */
/* Merged with some message passing. */
+/* also used for: pp_msgrcv() pp_msgsnd() pp_semop() pp_shmread() */
+
PP(pp_shmwrite)
{
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
- dVAR; dSP; dMARK; dTARGET;
+ dSP; dMARK; dTARGET;
const int op_type = PL_op->op_type;
I32 value;
/* Semaphores. */
+/* also used for: pp_msgget() pp_shmget() */
+
PP(pp_semget)
{
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
- dVAR; dSP; dMARK; dTARGET;
+ dSP; dMARK; dTARGET;
const int anum = do_ipcget(PL_op->op_type, MARK, SP);
SP = MARK;
if (anum == -1)
#endif
}
+/* also used for: pp_msgctl() pp_shmctl() */
+
PP(pp_semctl)
{
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
- dVAR; dSP; dMARK; dTARGET;
+ dSP; dMARK; dTARGET;
const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
SP = MARK;
if (anum == -1)
- RETSETUNDEF;
+ RETPUSHUNDEF;
if (anum != 0) {
PUSHi(anum);
}
{
SV *target;
- PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
-
if (array && *array) {
target = newSVpvs_flags("", SVs_TEMP);
while (1) {
/* Get system info. */
+/* also used for: pp_ghbyaddr() pp_ghbyname() */
+
PP(pp_ghostent)
{
#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
- dVAR; dSP;
+ dSP;
I32 which = PL_op->op_type;
- register char **elem;
- register SV *sv;
+ char **elem;
+ SV *sv;
#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
struct hostent *gethostbyname(Netdb_name_t);
}
#endif
- if (GIMME != G_ARRAY) {
+ if (GIMME_V != G_ARRAY) {
PUSHs(sv = sv_newmortal());
if (hent) {
if (which == OP_GHBYNAME) {
#endif
}
+/* also used for: pp_gnbyaddr() pp_gnbyname() */
+
PP(pp_gnetent)
{
#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
- dVAR; dSP;
+ dSP;
I32 which = PL_op->op_type;
- register SV *sv;
+ SV *sv;
#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
struct netent *getnetbyaddr(Netdb_net_t, int);
struct netent *getnetbyname(Netdb_name_t);
#endif
EXTEND(SP, 4);
- if (GIMME != G_ARRAY) {
+ if (GIMME_V != G_ARRAY) {
PUSHs(sv = sv_newmortal());
if (nent) {
if (which == OP_GNBYNAME)
#endif
}
+
+/* also used for: pp_gpbyname() pp_gpbynumber() */
+
PP(pp_gprotoent)
{
#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
- dVAR; dSP;
+ dSP;
I32 which = PL_op->op_type;
- register SV *sv;
+ SV *sv;
#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
struct protoent *getprotobyname(Netdb_name_t);
struct protoent *getprotobynumber(int);
#endif
EXTEND(SP, 3);
- if (GIMME != G_ARRAY) {
+ if (GIMME_V != G_ARRAY) {
PUSHs(sv = sv_newmortal());
if (pent) {
if (which == OP_GPBYNAME)
#endif
}
+
+/* also used for: pp_gsbyname() pp_gsbyport() */
+
PP(pp_gservent)
{
#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
- dVAR; dSP;
+ dSP;
I32 which = PL_op->op_type;
- register SV *sv;
+ SV *sv;
#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
struct servent *getservbyport(int, Netdb_name_t);
#ifdef HAS_GETSERVBYPORT
const char * const proto = POPpbytex;
unsigned short port = (unsigned short)POPu;
-#ifdef HAS_HTONS
port = PerlSock_htons(port);
-#endif
sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
#else
DIE(aTHX_ PL_no_sock_func, "getservbyport");
#endif
EXTEND(SP, 4);
- if (GIMME != G_ARRAY) {
+ if (GIMME_V != G_ARRAY) {
PUSHs(sv = sv_newmortal());
if (sent) {
if (which == OP_GSBYNAME) {
-#ifdef HAS_NTOHS
sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
-#else
- sv_setiv(sv, (IV)(sent->s_port));
-#endif
}
else
sv_setpv(sv, sent->s_name);
if (sent) {
mPUSHs(newSVpv(sent->s_name, 0));
PUSHs(space_join_names_mortal(sent->s_aliases));
-#ifdef HAS_NTOHS
mPUSHi(PerlSock_ntohs(sent->s_port));
-#else
- mPUSHi(sent->s_port);
-#endif
mPUSHs(newSVpv(sent->s_proto, 0));
}
#endif
}
+
+/* also used for: pp_snetent() pp_sprotoent() pp_sservent() */
+
PP(pp_shostent)
{
- dVAR; dSP;
+ dSP;
const int stayopen = TOPi;
switch(PL_op->op_type) {
case OP_SHOSTENT:
RETSETYES;
}
+
+/* also used for: pp_egrent() pp_enetent() pp_eprotoent() pp_epwent()
+ * pp_eservent() pp_sgrent() pp_spwent() */
+
PP(pp_ehostent)
{
- dVAR; dSP;
+ dSP;
switch(PL_op->op_type) {
case OP_EHOSTENT:
#ifdef HAS_ENDHOSTENT
RETPUSHYES;
}
+
+/* also used for: pp_gpwnam() pp_gpwuid() */
+
PP(pp_gpwent)
{
#ifdef HAS_PASSWD
- dVAR; dSP;
+ dSP;
I32 which = PL_op->op_type;
- register SV *sv;
+ SV *sv;
struct passwd *pwent = NULL;
/*
* We currently support only the SysV getsp* shadow password interface.
}
EXTEND(SP, 10);
- if (GIMME != G_ARRAY) {
+ if (GIMME_V != G_ARRAY) {
PUSHs(sv = sv_newmortal());
if (pwent) {
if (which == OP_GPWNAM)
-# if Uid_t_sign <= 0
- sv_setiv(sv, (IV)pwent->pw_uid);
-# else
- sv_setuv(sv, (UV)pwent->pw_uid);
-# endif
+ sv_setuid(sv, pwent->pw_uid);
else
sv_setpv(sv, pwent->pw_name);
}
sv_setpv(sv, pwent->pw_passwd);
# endif
-# ifndef INCOMPLETE_TAINTS
/* passwd is tainted because user himself can diddle with it.
* admittedly not much and in a very limited way, but nevertheless. */
SvTAINTED_on(sv);
-# endif
-# if Uid_t_sign <= 0
- mPUSHi(pwent->pw_uid);
-# else
- mPUSHu(pwent->pw_uid);
-# endif
+ sv_setuid(PUSHmortal, pwent->pw_uid);
+ sv_setgid(PUSHmortal, pwent->pw_gid);
-# if Uid_t_sign <= 0
- mPUSHi(pwent->pw_gid);
-# else
- mPUSHu(pwent->pw_gid);
-# endif
/* pw_change, pw_quota, and pw_age are mutually exclusive--
* because of the poor interface of the Perl getpw*(),
* not because there's some standard/convention saying so.
# else
PUSHs(sv = sv_mortalcopy(&PL_sv_no));
# endif
-# ifndef INCOMPLETE_TAINTS
/* pw_gecos is tainted because user himself can diddle with it. */
SvTAINTED_on(sv);
-# endif
mPUSHs(newSVpv(pwent->pw_dir, 0));
PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
-# ifndef INCOMPLETE_TAINTS
/* pw_shell is tainted because user himself can diddle with it. */
SvTAINTED_on(sv);
-# endif
# ifdef PWEXPIRE
mPUSHi(pwent->pw_expire);
#endif
}
+
+/* also used for: pp_ggrgid() pp_ggrnam() */
+
PP(pp_ggrent)
{
#ifdef HAS_GROUP
- dVAR; dSP;
+ dSP;
const I32 which = PL_op->op_type;
const struct group *grent;
grent = (const struct group *)getgrnam(name);
}
else if (which == OP_GGRGID) {
+#if Gid_t_sign == 1
+ const Gid_t gid = POPu;
+#elif Gid_t_sign == -1
const Gid_t gid = POPi;
+#else
+# error "Unexpected Gid_t_sign"
+#endif
grent = (const struct group *)getgrgid(gid);
}
else
#endif
EXTEND(SP, 4);
- if (GIMME != G_ARRAY) {
+ if (GIMME_V != G_ARRAY) {
SV * const sv = sv_newmortal();
PUSHs(sv);
if (grent) {
if (which == OP_GGRNAM)
-#if Gid_t_sign <= 0
- sv_setiv(sv, (IV)grent->gr_gid);
-#else
- sv_setuv(sv, (UV)grent->gr_gid);
-#endif
+ sv_setgid(sv, grent->gr_gid);
else
sv_setpv(sv, grent->gr_name);
}
PUSHs(sv_mortalcopy(&PL_sv_no));
#endif
-#if Gid_t_sign <= 0
- mPUSHi(grent->gr_gid);
-#else
- mPUSHu(grent->gr_gid);
-#endif
+ sv_setgid(PUSHmortal, grent->gr_gid);
#if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
/* In UNICOS/mk (_CRAYMPP) the multithreading
PP(pp_getlogin)
{
#ifdef HAS_GETLOGIN
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
char *tmps;
EXTEND(SP, 1);
if (!(tmps = PerlProc_getlogin()))
PP(pp_syscall)
{
#ifdef HAS_SYSCALL
- dVAR; dSP; dMARK; dORIGMARK; dTARGET;
- register I32 items = SP - MARK;
+ dSP; dMARK; dORIGMARK; dTARGET;
+ I32 items = SP - MARK;
unsigned long a[20];
- register I32 i = 0;
+ I32 i = 0;
IV retval = -1;
- if (PL_tainting) {
+ if (TAINTING_get) {
while (++MARK <= SP) {
if (SvTAINTED(*MARK)) {
TAINT;
case 8:
retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
break;
-#ifdef atarist
- case 9:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
- break;
- case 10:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
- break;
- case 11:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
- a[10]);
- break;
- case 12:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
- a[10],a[11]);
- break;
- case 13:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
- a[10],a[11],a[12]);
- break;
- case 14:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
- a[10],a[11],a[12],a[13]);
- break;
-#endif /* atarist */
}
SP = ORIGMARK;
PUSHi(retval);
#endif /* LOCKF_EMULATE_FLOCK */
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff