# include <shadow.h>
#endif
-#ifdef HAS_SYSCALL
-#ifdef __cplusplus
-extern "C" int syscall(unsigned long,...);
-#endif
-#endif
-
#ifdef I_SYS_WAIT
# include <sys/wait.h>
#endif
#ifndef getpwent
struct passwd *getpwent (void);
#elif defined (VMS) && defined (my_getpwent)
- struct passwd *Perl_my_getpwent (void);
+ struct passwd *Perl_my_getpwent (pTHX);
#endif
# endif
#endif
# undef my_chsize
# endif
# define my_chsize PerlLIO_chsize
+#else
+# ifdef HAS_TRUNCATE
+# define my_chsize PerlLIO_chsize
+# else
+I32 my_chsize(int fd, Off_t length);
+# endif
#endif
#ifdef HAS_FLOCK
#endif /* no flock() */
#define ZBTLEN 10
-static char zero_but_true[ZBTLEN + 1] = "0 but true";
+static const char zero_but_true[ZBTLEN + 1] = "0 but true";
#if defined(I_SYS_ACCESS) && !defined(R_OK)
# include <sys/access.h>
void endservent(void);
#endif
-#undef PERL_EFF_ACCESS_R_OK /* EFFective uid/gid ACCESS R_OK */
-#undef PERL_EFF_ACCESS_W_OK
-#undef PERL_EFF_ACCESS_X_OK
+#undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
+
+/* AIX 5.2 and below use mktime for localtime, and defines the edge case
+ * for time 0x7fffffff to be valid only in UTC. AIX 5.3 provides localtime64
+ * available in the 32bit environment, which could warrant Configure
+ * checks in the future.
+ */
+#ifdef _AIX
+#define LOCALTIME_EDGECASE_BROKEN
+#endif
/* F_OK unused: if stat() cannot find it... */
-#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
+#if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
/* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
-# define PERL_EFF_ACCESS_R_OK(p) (access((p), R_OK | EFF_ONLY_OK))
-# define PERL_EFF_ACCESS_W_OK(p) (access((p), W_OK | EFF_ONLY_OK))
-# define PERL_EFF_ACCESS_X_OK(p) (access((p), X_OK | EFF_ONLY_OK))
+# define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
#endif
-#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_EACCESS)
+#if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
# ifdef I_SYS_SECURITY
# include <sys/security.h>
# endif
# ifdef ACC_SELF
/* HP SecureWare */
-# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK, ACC_SELF))
-# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK, ACC_SELF))
-# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK, ACC_SELF))
+# define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
# else
/* SCO */
-# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK))
-# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK))
-# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK))
+# define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
# endif
#endif
-#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESSX) && defined(ACC_SELF)
+#if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
/* AIX */
-# define PERL_EFF_ACCESS_R_OK(p) (accessx((p), R_OK, ACC_SELF))
-# define PERL_EFF_ACCESS_W_OK(p) (accessx((p), W_OK, ACC_SELF))
-# define PERL_EFF_ACCESS_X_OK(p) (accessx((p), X_OK, ACC_SELF))
+# define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
#endif
-#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) \
+
+#if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
&& (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
|| defined(HAS_SETREGID) || defined(HAS_SETRESGID))
/* The Hard Way. */
STATIC int
S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
{
- Uid_t ruid = getuid();
- Uid_t euid = geteuid();
- Gid_t rgid = getgid();
- Gid_t egid = getegid();
+ const Uid_t ruid = getuid();
+ const Uid_t euid = geteuid();
+ const Gid_t rgid = getgid();
+ const Gid_t egid = getegid();
int res;
LOCK_CRED_MUTEX;
return res;
}
-# define PERL_EFF_ACCESS_R_OK(p) (emulate_eaccess((p), R_OK))
-# define PERL_EFF_ACCESS_W_OK(p) (emulate_eaccess((p), W_OK))
-# define PERL_EFF_ACCESS_X_OK(p) (emulate_eaccess((p), X_OK))
+# define PERL_EFF_ACCESS(p,f) (emulate_eaccess((p), (f)))
#endif
-#if !defined(PERL_EFF_ACCESS_R_OK)
+#if !defined(PERL_EFF_ACCESS)
/* With it or without it: anyway you get a warning: either that
it is unused, or it is declared static and never defined.
*/
STATIC int
S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
{
+ (void)path;
+ (void)mode;
Perl_croak(aTHX_ "switching effective uid is not implemented");
/*NOTREACHED*/
return -1;
{
dSP; dTARGET;
PerlIO *fp;
- STRLEN n_a;
- char *tmps = POPpx;
- I32 gimme = GIMME_V;
- char *mode = "r";
+ const char * const tmps = POPpconstx;
+ const I32 gimme = GIMME_V;
+ const char *mode = "r";
TAINT_PROPER("``");
if (PL_op->op_private & OPpOPEN_IN_RAW)
mode = "rt";
fp = PerlProc_popen(tmps, mode);
if (fp) {
- char *type = NULL;
- if (PL_curcop->cop_io) {
- type = SvPV_nolen(PL_curcop->cop_io);
- }
+ const char * const type = PL_curcop->cop_io ? SvPV_nolen_const(PL_curcop->cop_io) : NULL;
if (type && *type)
PerlIO_apply_layers(aTHX_ fp,mode,type);
if (gimme == G_VOID) {
char tmpbuf[256];
while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
- /*SUPPRESS 530*/
;
}
else if (gimme == G_SCALAR) {
ENTER;
SAVESPTR(PL_rs);
PL_rs = &PL_sv_undef;
- sv_setpv(TARG, ""); /* note that this preserves previous buffer */
+ sv_setpvn(TARG, "", 0); /* note that this preserves previous buffer */
while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
- /*SUPPRESS 530*/
;
LEAVE;
XPUSHs(TARG);
SvTAINTED_on(TARG);
}
else {
- SV *sv;
-
for (;;) {
- sv = NEWSV(56, 79);
+ SV * const sv = NEWSV(56, 79);
if (sv_gets(sv, fp, 0) == Nullch) {
SvREFCNT_dec(sv);
break;
}
XPUSHs(sv_2mortal(sv));
if (SvLEN(sv) - SvCUR(sv) > 20) {
- SvLEN_set(sv, SvCUR(sv)+1);
- Renew(SvPVX(sv), SvLEN(sv), char);
+ SvPV_shrink_to_cur(sv);
}
SvTAINTED_on(sv);
}
}
- STATUS_NATIVE_SET(PerlProc_pclose(fp));
+ STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
TAINT; /* "I believe that this is not gratuitous!" */
}
else {
- STATUS_NATIVE_SET(-1);
+ STATUS_NATIVE_CHILD_SET(-1);
if (gimme == G_SCALAR)
RETPUSHUNDEF;
}
PP(pp_glob)
{
+ dVAR;
OP *result;
tryAMAGICunTARGET(iter, -1);
{
dSP; dMARK;
SV *tmpsv;
- char *tmps;
+ const char *tmps;
STRLEN len;
- if (SP - MARK != 1) {
+ if (SP - MARK > 1) {
dTARGET;
do_join(TARG, &PL_sv_no, MARK, SP);
tmpsv = TARG;
SP = MARK + 1;
}
+ else if (SP == MARK) {
+ tmpsv = &PL_sv_no;
+ EXTEND(SP, 1);
+ }
else {
tmpsv = TOPs;
}
- tmps = SvPV(tmpsv, len);
+ tmps = SvPV_const(tmpsv, len);
if ((!tmps || !len) && PL_errgv) {
- SV *error = ERRSV;
- (void)SvUPGRADE(error, SVt_PV);
+ SV * const error = ERRSV;
+ SvUPGRADE(error, SVt_PV);
if (SvPOK(error) && SvCUR(error))
sv_catpv(error, "\t...caught");
tmpsv = error;
- tmps = SvPV(tmpsv, len);
+ tmps = SvPV_const(tmpsv, len);
}
if (!tmps || !len)
tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26));
PP(pp_die)
{
dSP; dMARK;
- char *tmps;
+ const char *tmps;
SV *tmpsv;
STRLEN len;
bool multiarg = 0;
dTARGET;
do_join(TARG, &PL_sv_no, MARK, SP);
tmpsv = TARG;
- tmps = SvPV(tmpsv, len);
+ tmps = SvPV_const(tmpsv, len);
multiarg = 1;
SP = MARK + 1;
}
else {
tmpsv = TOPs;
- tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, len);
+ tmps = SvROK(tmpsv) ? Nullch : SvPV_const(tmpsv, len);
}
if (!tmps || !len) {
- SV *error = ERRSV;
- (void)SvUPGRADE(error, SVt_PV);
+ SV * const error = ERRSV;
+ SvUPGRADE(error, SVt_PV);
if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
if (!multiarg)
SvSetSV(error,tmpsv);
else if (sv_isobject(error)) {
- HV *stash = SvSTASH(SvRV(error));
- GV *gv = gv_fetchmethod(stash, "PROPAGATE");
+ HV * const stash = SvSTASH(SvRV(error));
+ GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
if (gv) {
- SV *file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
- SV *line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
+ 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(error);
sv_setsv(error,*PL_stack_sp--);
}
}
- DIE_NULL;
+ DIE(aTHX_ Nullch);
}
else {
if (SvPOK(error) && SvCUR(error))
sv_catpv(error, "\t...propagated");
tmpsv = error;
- tmps = SvPV(tmpsv, len);
+ if (SvOK(tmpsv))
+ tmps = SvPV_const(tmpsv, len);
+ else
+ tmps = Nullch;
}
}
if (!tmps || !len)
PP(pp_open)
{
- dSP;
+ dVAR; dSP;
dMARK; dORIGMARK;
dTARGET;
- GV *gv;
SV *sv;
IO *io;
- char *tmps;
+ const char *tmps;
STRLEN len;
- MAGIC *mg;
bool ok;
- gv = (GV *)*++MARK;
+ GV * const gv = (GV *)*++MARK;
+
if (!isGV(gv))
DIE(aTHX_ PL_no_usym, "filehandle");
if ((io = GvIOp(gv)))
IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
- if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
- /* Method's args are same as ours ... */
- /* ... except handle is replaced by the object */
- *MARK-- = SvTIED_obj((SV*)io, mg);
- PUSHMARK(MARK);
- PUTBACK;
- ENTER;
- call_method("OPEN", G_SCALAR);
- LEAVE;
- SPAGAIN;
- RETURN;
+ if (io) {
+ MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
+ if (mg) {
+ /* Method's args are same as ours ... */
+ /* ... except handle is replaced by the object */
+ *MARK-- = SvTIED_obj((SV*)io, mg);
+ PUSHMARK(MARK);
+ PUTBACK;
+ ENTER;
+ call_method("OPEN", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
}
if (MARK < SP) {
sv = *++MARK;
}
else {
- sv = GvSV(gv);
+ sv = GvSVn(gv);
}
- tmps = SvPV(sv, len);
+ tmps = SvPV_const(sv, len);
ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp, MARK+1, (SP-MARK));
SP = ORIGMARK;
if (ok)
PP(pp_close)
{
- dSP;
- GV *gv;
+ dVAR; dSP;
IO *io;
MAGIC *mg;
-
- if (MAXARG == 0)
- gv = PL_defoutgv;
- else
- gv = (GV*)POPs;
+ GV * const gv = (MAXARG == 0) ? PL_defoutgv : (GV*)POPs;
if (gv && (io = GvIO(gv))
&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
{
#ifdef HAS_PIPE
dSP;
- GV *rgv;
- GV *wgv;
register IO *rstio;
register IO *wstio;
int fd[2];
- wgv = (GV*)POPs;
- rgv = (GV*)POPs;
+ GV * const wgv = (GV*)POPs;
+ GV * const rgv = (GV*)POPs;
if (!rgv || !wgv)
goto badexit;
PP(pp_fileno)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
GV *gv;
IO *io;
PerlIO *fp;
PP(pp_umask)
{
- dSP; dTARGET;
+ dSP;
#ifdef HAS_UMASK
+ dTARGET;
Mode_t anum;
if (MAXARG < 1) {
TAINT_PROPER("umask");
XPUSHi(anum);
#else
- /* Only DIE if trying to restrict permissions on `user' (self).
+ /* Only DIE if trying to restrict permissions on "user" (self).
* Otherwise it's harmless and more useful to just return undef
* since 'group' and 'other' concepts probably don't exist here. */
if (MAXARG >= 1 && (POPi & 0700))
PP(pp_binmode)
{
- dSP;
+ dVAR; dSP;
GV *gv;
IO *io;
PerlIO *fp;
PUTBACK;
if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp),
- (discp) ? SvPV_nolen(discp) : Nullch)) {
+ (discp) ? SvPV_nolen_const(discp) : Nullch)) {
if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
if (!PerlIO_binmode(aTHX_ IoOFP(io),IoTYPE(io),
mode_from_discipline(discp),
- (discp) ? SvPV_nolen(discp) : Nullch)) {
+ (discp) ? SvPV_nolen_const(discp) : Nullch)) {
SPAGAIN;
RETPUSHUNDEF;
}
PP(pp_tie)
{
- dSP;
- dMARK;
- SV *varsv;
+ dVAR; dSP; dMARK;
HV* stash;
GV *gv;
SV *sv;
- I32 markoff = MARK - PL_stack_base;
- char *methname;
+ const I32 markoff = MARK - PL_stack_base;
+ const char *methname;
int how = PERL_MAGIC_tied;
U32 items;
+ SV *varsv = *++MARK;
- varsv = *++MARK;
switch(SvTYPE(varsv)) {
case SVt_PVHV:
methname = "TIEHASH";
- HvEITER((HV *)varsv) = Null(HE *);
+ HvEITER_set((HV *)varsv, 0);
break;
case SVt_PVAV:
methname = "TIEARRAY";
PP(pp_untie)
{
- dSP;
+ dVAR; dSP;
MAGIC *mg;
SV *sv = POPs;
- char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
+ const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
RETPUSHYES;
if ((mg = SvTIED_mg(sv, how))) {
- SV *obj = SvRV(SvTIED_obj(sv, mg));
- GV *gv;
+ SV * const obj = SvRV(SvTIED_obj(sv, mg));
CV *cv = NULL;
if (obj) {
- if ((gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE)) &&
- isGV(gv) && (cv = GvCV(gv))) {
+ GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
+ if (gv && isGV(gv) && (cv = GvCV(gv))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)gv, mg));
XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
LEAVE;
SPAGAIN;
}
- else if (ckWARN(WARN_UNTIE)) {
- if (mg && SvREFCNT(obj) > 1)
+ else if (mg && SvREFCNT(obj) > 1 && ckWARN(WARN_UNTIE)) {
Perl_warner(aTHX_ packWARN(WARN_UNTIE),
"untie attempted while %"UVuf" inner references still exist",
(UV)SvREFCNT(obj) - 1 ) ;
- }
+ }
}
}
sv_unmagic(sv, how) ;
PP(pp_tied)
{
dSP;
- MAGIC *mg;
+ const MAGIC *mg;
SV *sv = POPs;
- char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
+ const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
PP(pp_dbmopen)
{
- dSP;
- HV *hv;
+ dVAR; dSP;
dPOPPOPssrl;
HV* stash;
GV *gv;
- SV *sv;
- hv = (HV*)POPs;
+ HV * const hv = (HV*)POPs;
+ SV * const sv = sv_mortalcopy(&PL_sv_no);
- sv = sv_mortalcopy(&PL_sv_no);
sv_setpv(sv, "AnyDBM_File");
stash = gv_stashsv(sv, FALSE);
if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
RETURN;
}
-PP(pp_dbmclose)
-{
- return pp_untie();
-}
-
PP(pp_sselect)
{
#ifdef HAS_SELECT
struct timeval *tbuf = &timebuf;
I32 growsize;
char *fd_sets[4];
- STRLEN n_a;
#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
I32 masksize;
I32 offset;
SP -= 4;
for (i = 1; i <= 3; i++) {
- if (!SvPOK(SP[i]))
+ SV * const sv = SP[i];
+ if (!SvOK(sv))
continue;
- j = SvCUR(SP[i]);
+ if (SvREADONLY(sv)) {
+ if (SvIsCOW(sv))
+ sv_force_normal_flags(sv, 0);
+ if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
+ DIE(aTHX_ PL_no_modify);
+ }
+ if (!SvPOK(sv)) {
+ if (ckWARN(WARN_MISC))
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
+ SvPV_force_nolen(sv); /* force string conversion */
+ }
+ j = SvCUR(sv);
if (maxlen < j)
maxlen = j;
}
for (i = 1; i <= 3; i++) {
sv = SP[i];
- if (!SvOK(sv)) {
+ if (!SvOK(sv) || SvCUR(sv) == 0) {
fd_sets[i] = 0;
continue;
}
- else if (!SvPOK(sv))
- SvPV_force(sv,n_a); /* force string conversion */
+ assert(SvPOK(sv));
j = SvLEN(sv);
if (j < growsize) {
Sv_Grow(sv, growsize);
#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
s = SvPVX(sv);
- New(403, fd_sets[i], growsize, char);
+ Newx(fd_sets[i], growsize, char);
for (offset = 0; offset < growsize; offset += masksize) {
for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
fd_sets[i][j+offset] = s[(k % masksize) + offset];
PP(pp_select)
{
dSP; dTARGET;
- GV *newdefout, *egv;
HV *hv;
+ GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
+ GV * egv = GvEGV(PL_defoutgv);
- newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
-
- egv = GvEGV(PL_defoutgv);
if (!egv)
egv = PL_defoutgv;
hv = GvSTASH(egv);
if (! hv)
XPUSHs(&PL_sv_undef);
else {
- GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
+ GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
if (gvp && *gvp == egv) {
gv_efullname4(TARG, PL_defoutgv, Nullch, TRUE);
XPUSHTARG;
PP(pp_getc)
{
- dSP; dTARGET;
- GV *gv;
+ dVAR; dSP; dTARGET;
IO *io = NULL;
MAGIC *mg;
-
- if (MAXARG == 0)
- gv = PL_stdingv;
- else
- gv = (GV*)POPs;
+ GV * const gv = (MAXARG==0) ? PL_stdingv : (GV*)POPs;
if (gv && (io = GvIO(gv))
&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
{
- I32 gimme = GIMME_V;
+ const I32 gimme = GIMME_V;
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)io, mg));
PUTBACK;
RETURN;
}
if (!gv || do_eof(gv)) { /* make sure we have fp with something */
- if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)
- && (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY)))
+ if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
+ && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
SETERRNO(EBADF,RMS_IFI);
RETPUSHUNDEF;
}
TAINT;
- sv_setpv(TARG, " ");
+ sv_setpvn(TARG, " ", 1);
*SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
/* Find out how many bytes the char needs */
- Size_t len = UTF8SKIP(SvPVX(TARG));
+ Size_t len = UTF8SKIP(SvPVX_const(TARG));
if (len > 1) {
SvGROW(TARG,len+1);
len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
RETURN;
}
-PP(pp_read)
-{
- return pp_sysread();
-}
-
STATIC OP *
S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
{
+ dVAR;
register PERL_CONTEXT *cx;
- I32 gimme = GIMME_V;
+ const I32 gimme = GIMME_V;
ENTER;
SAVETMPS;
PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
PUSHFORMAT(cx);
cx->blk_sub.retop = retop;
- PAD_SET_CUR(CvPADLIST(cv), 1);
+ SAVECOMPPAD();
+ PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
setdefout(gv); /* locally select filehandle so $% et al work */
return CvSTART(cv);
cv = GvFORM(fgv);
if (!cv) {
- char *name = NULL;
if (fgv) {
- SV *tmpsv = sv_newmortal();
+ SV * const tmpsv = sv_newmortal();
+ const char *name;
gv_efullname4(tmpsv, fgv, Nullch, FALSE);
- name = SvPV_nolen(tmpsv);
+ name = SvPV_nolen_const(tmpsv);
+ if (name && *name)
+ DIE(aTHX_ "Undefined format \"%s\" called", name);
}
- if (name && *name)
- DIE(aTHX_ "Undefined format \"%s\" called", name);
DIE(aTHX_ "Not a format reference");
}
if (CvCLONE(cv))
PP(pp_leavewrite)
{
- dSP;
- GV *gv = cxstack[cxstack_ix].blk_sub.gv;
- register IO *io = GvIOp(gv);
- PerlIO *ofp = IoOFP(io);
+ dVAR; dSP;
+ GV * const gv = cxstack[cxstack_ix].blk_sub.gv;
+ register IO * const io = GvIOp(gv);
+ PerlIO * const ofp = IoOFP(io);
PerlIO *fp;
SV **newsp;
I32 gimme;
CV *cv;
if (!IoTOP_GV(io)) {
GV *topgv;
- SV *topname;
if (!IoTOP_NAME(io)) {
+ SV *topname;
if (!IoFMT_NAME(io))
IoFMT_NAME(io) = savepv(GvNAME(gv));
topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
}
topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
if (!topgv || !GvFORM(topgv)) {
- IoLINES_LEFT(io) = 100000000;
+ IoLINES_LEFT(io) = IoPAGE_LEN(io);
goto forget_top;
}
IoTOP_GV(io) = topgv;
}
if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
I32 lines = IoLINES_LEFT(io);
- char *s = SvPVX(PL_formtarget);
+ const char *s = SvPVX_const(PL_formtarget);
if (lines <= 0) /* Yow, header didn't even fit!!! */
goto forget_top;
while (lines-- > 0) {
s++;
}
if (s) {
- STRLEN save = SvCUR(PL_formtarget);
- SvCUR_set(PL_formtarget, s - SvPVX(PL_formtarget));
+ const STRLEN save = SvCUR(PL_formtarget);
+ SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
do_print(PL_formtarget, ofp);
SvCUR_set(PL_formtarget, save);
sv_chop(PL_formtarget, s);
if (!fgv)
DIE(aTHX_ "bad top format reference");
cv = GvFORM(fgv);
- {
- char *name = NULL;
- if (!cv) {
- SV *sv = sv_newmortal();
- gv_efullname4(sv, fgv, Nullch, FALSE);
- name = SvPV_nolen(sv);
- }
+ if (!cv) {
+ SV * const sv = sv_newmortal();
+ const char *name;
+ gv_efullname4(sv, fgv, Nullch, FALSE);
+ name = SvPV_nolen_const(sv);
if (name && *name)
- DIE(aTHX_ "Undefined top format \"%s\" called",name);
- /* why no:
- else
- DIE(aTHX_ "Undefined top format called");
- ?*/
+ DIE(aTHX_ "Undefined top format \"%s\" called",name);
}
+ /* why no:
+ else
+ DIE(aTHX_ "Undefined top format called");
+ ?*/
if (CvCLONE(cv))
cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
return doform(cv,gv,PL_op);
/* bad_ofp: */
PL_formtarget = PL_bodytarget;
PUTBACK;
+ PERL_UNUSED_VAR(newsp);
+ PERL_UNUSED_VAR(gimme);
return cx->blk_sub.retop;
}
PP(pp_prtf)
{
- dSP; dMARK; dORIGMARK;
- GV *gv;
+ dVAR; dSP; dMARK; dORIGMARK;
IO *io;
PerlIO *fp;
SV *sv;
MAGIC *mg;
- if (PL_op->op_flags & OPf_STACKED)
- gv = (GV*)*++MARK;
- else
- gv = PL_defoutgv;
+ GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
if (gv && (io = GvIO(gv))
&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
PP(pp_sysopen)
{
dSP;
- GV *gv;
- SV *sv;
- char *tmps;
+ const int perm = (MAXARG > 3) ? POPi : 0666;
+ const int mode = POPi;
+ SV * const sv = POPs;
+ GV * const gv = (GV *)POPs;
STRLEN len;
- int mode, perm;
-
- if (MAXARG > 3)
- perm = POPi;
- else
- perm = 0666;
- mode = POPi;
- sv = POPs;
- gv = (GV *)POPs;
/* Need TIEHANDLE method ? */
-
- tmps = SvPV(sv, len);
+ const char * const tmps = SvPV_const(sv, len);
+ /* FIXME? do_open should do const */
if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
IoLINES(GvIOp(gv)) = 0;
PUSHs(&PL_sv_yes);
PP(pp_sysread)
{
- dSP; dMARK; dORIGMARK; dTARGET;
+ dVAR; dSP; dMARK; dORIGMARK; dTARGET;
int offset;
- GV *gv;
IO *io;
char *buffer;
SSize_t length;
Sock_size_t bufsize;
SV *bufsv;
STRLEN blen;
- MAGIC *mg;
int fp_utf8;
int buffer_utf8;
SV *read_target;
STRLEN charskip = 0;
STRLEN skip = 0;
- gv = (GV*)*++MARK;
+ GV * const gv = (GV*)*++MARK;
if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
- && gv && (io = GvIO(gv))
- && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ && gv && (io = GvIO(gv)) )
{
- SV *sv;
-
- PUSHMARK(MARK-1);
- *MARK = SvTIED_obj((SV*)io, mg);
- ENTER;
- call_method("READ", G_SCALAR);
- LEAVE;
- SPAGAIN;
- sv = POPs;
- SP = ORIGMARK;
- PUSHs(sv);
- RETURN;
+ const MAGIC * mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
+ if (mg) {
+ SV *sv;
+ PUSHMARK(MARK-1);
+ *MARK = SvTIED_obj((SV*)io, mg);
+ ENTER;
+ call_method("READ", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ sv = POPs;
+ SP = ORIGMARK;
+ PUSHs(sv);
+ RETURN;
+ }
}
if (!gv)
(should be 2 * length + offset + 1, or possibly something longer if
PL_encoding is true) */
buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
- if (offset > bufsize) { /* Zero any newly allocated space */
+ if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
Zero(buffer+bufsize, offset-bufsize, char);
}
buffer = buffer + offset;
read_target = sv_newmortal();
SvUPGRADE(read_target, SVt_PV);
- buffer = SvGROW(read_target, length + 1);
+ buffer = SvGROW(read_target, (STRLEN)(length + 1));
}
if (PL_op->op_type == OP_SYSREAD) {
report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
goto say_undef;
}
- SvCUR_set(read_target, count+(buffer - SvPVX(read_target)));
+ SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
*SvEND(read_target) = '\0';
(void)SvPOK_only(read_target);
if (fp_utf8 && !IN_BYTES) {
/* Look at utf8 we got back and count the characters */
- char *bend = buffer + count;
+ const char *bend = buffer + count;
while (buffer < bend) {
if (charstart) {
skip = UTF8SKIP(buffer);
if (buffer - charskip + skip > bend) {
/* partial character - try for rest of it */
length = skip - (bend-buffer);
- offset = bend - SvPVX(bufsv);
+ offset = bend - SvPVX_const(bufsv);
charstart = FALSE;
charskip += count;
goto more_bytes;
*/
if (got < wanted && count == length) {
length = wanted - got;
- offset = bend - SvPVX(bufsv);
+ offset = bend - SvPVX_const(bufsv);
goto more_bytes;
}
/* return value is character count */
RETPUSHUNDEF;
}
-PP(pp_syswrite)
-{
- dSP;
- int items = (SP - PL_stack_base) - TOPMARK;
- if (items == 2) {
- SV *sv;
- EXTEND(SP, 1);
- sv = sv_2mortal(newSViv(sv_len(*SP)));
- PUSHs(sv);
- PUTBACK;
- }
- return pp_send();
-}
-
PP(pp_send)
{
- dSP; dMARK; dORIGMARK; dTARGET;
- GV *gv;
+ dVAR; dSP; dMARK; dORIGMARK; dTARGET;
IO *io;
SV *bufsv;
- char *buffer;
- Size_t length;
+ const char *buffer;
+ Size_t length = 0;
SSize_t retval;
STRLEN blen;
MAGIC *mg;
-
- gv = (GV*)*++MARK;
+ const int op_type = PL_op->op_type;
+
+ GV *const gv = (GV*)*++MARK;
if (PL_op->op_type == OP_SYSWRITE
&& gv && (io = GvIO(gv))
&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
{
SV *sv;
+
+ if (MARK == SP - 1) {
+ EXTEND(SP, 1000);
+ sv = sv_2mortal(newSViv(sv_len(*SP)));
+ PUSHs(sv);
+ PUTBACK;
+ }
- PUSHMARK(MARK-1);
- *MARK = SvTIED_obj((SV*)io, mg);
+ PUSHMARK(ORIGMARK);
+ *(ORIGMARK+1) = SvTIED_obj((SV*)io, mg);
ENTER;
call_method("WRITE", G_SCALAR);
LEAVE;
}
if (!gv)
goto say_undef;
+
bufsv = *++MARK;
+
+ if (op_type == OP_SYSWRITE) {
+ if (MARK >= SP) {
+ length = (Size_t) sv_len(bufsv);
+ } else {
#if Size_t_size > IVSIZE
- length = (Size_t)SvNVx(*++MARK);
+ length = (Size_t)SvNVx(*++MARK);
#else
- length = (Size_t)SvIVx(*++MARK);
+ length = (Size_t)SvIVx(*++MARK);
#endif
- if ((SSize_t)length < 0)
- DIE(aTHX_ "Negative length");
+ if ((SSize_t)length < 0)
+ DIE(aTHX_ "Negative length");
+ }
+ }
SETERRNO(0,0);
io = GvIO(gv);
if (!io || !IoIFP(io)) {
bufsv = sv_2mortal(newSVsv(bufsv));
buffer = sv_2pvutf8(bufsv, &blen);
} else
- buffer = SvPV(bufsv, blen);
+ buffer = SvPV_const(bufsv, blen);
}
else {
if (DO_UTF8(bufsv)) {
bufsv = sv_2mortal(newSVsv(bufsv));
sv_utf8_downgrade(bufsv, FALSE);
}
- buffer = SvPV(bufsv, blen);
+ buffer = SvPV_const(bufsv, blen);
}
- if (PL_op->op_type == OP_SYSWRITE) {
+ if (op_type == OP_SYSWRITE) {
IV offset;
if (DO_UTF8(bufsv)) {
/* length and offset are in chars */
if (length > blen - offset)
length = blen - offset;
if (DO_UTF8(bufsv)) {
- buffer = (char*)utf8_hop((U8 *)buffer, offset);
+ buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
}
else {
}
}
#ifdef HAS_SOCKET
- else if (SP > MARK) {
- char *sockbuf;
- STRLEN mlen;
- sockbuf = SvPVx(*++MARK, mlen);
- /* length is really flags */
- retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
- length, (struct sockaddr *)sockbuf, mlen);
+ else {
+ const int flags = SvIVx(*++MARK);
+ if (SP > MARK) {
+ STRLEN mlen;
+ char * const sockbuf = SvPVx(*++MARK, mlen);
+ retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
+ flags, (struct sockaddr *)sockbuf, mlen);
+ }
+ else {
+ retval
+ = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
+ }
}
- else
- /* length is really flags */
- retval = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
#else
else
DIE(aTHX_ PL_no_sock_func, "send");
RETPUSHUNDEF;
}
-PP(pp_recv)
-{
- return pp_sysread();
-}
-
PP(pp_eof)
{
- dSP;
+ dVAR; dSP;
GV *gv;
IO *io;
MAGIC *mg;
PP(pp_tell)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
GV *gv;
IO *io;
MAGIC *mg;
- if (MAXARG == 0)
- gv = PL_last_in_gv;
- else
- gv = PL_last_in_gv = (GV*)POPs;
+ if (MAXARG != 0)
+ PL_last_in_gv = (GV*)POPs;
+ gv = PL_last_in_gv;
if (gv && (io = GvIO(gv))
&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
RETURN;
}
-PP(pp_seek)
-{
- return pp_sysseek();
-}
-
PP(pp_sysseek)
{
- dSP;
- GV *gv;
+ dVAR; dSP;
IO *io;
- int whence = POPi;
+ const int whence = POPi;
#if LSEEKSIZE > IVSIZE
- Off_t offset = (Off_t)SvNVx(POPs);
+ const Off_t offset = (Off_t)SvNVx(POPs);
#else
- Off_t offset = (Off_t)SvIVx(POPs);
+ const Off_t offset = (Off_t)SvIVx(POPs);
#endif
MAGIC *mg;
- gv = PL_last_in_gv = (GV*)POPs;
+ GV * const gv = PL_last_in_gv = (GV*)POPs;
if (gv && (io = GvIO(gv))
&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
if (PL_op->op_type == OP_SEEK)
PUSHs(boolSV(do_seek(gv, offset, whence)));
else {
- Off_t sought = do_sysseek(gv, offset, whence);
+ const Off_t sought = do_sysseek(gv, offset, whence);
if (sought < 0)
PUSHs(&PL_sv_undef);
else {
- SV* sv = sought ?
+ SV* const sv = sought ?
#if LSEEKSIZE > IVSIZE
newSVnv((NV)sought)
#else
* might not be signed: if it is not, clever compilers will moan. */
/* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
SETERRNO(0,0);
-#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
{
int result = 1;
GV *tmpgv;
}
}
else {
- SV *sv = POPs;
- char *name;
- STRLEN n_a;
+ SV * const sv = POPs;
+ const char *name;
if (SvTYPE(sv) == SVt_PVGV) {
tmpgv = (GV*)sv; /* *main::FRED for example */
goto do_ftruncate_io;
}
- name = SvPV(sv, n_a);
+ name = SvPV_nolen_const(sv);
TAINT_PROPER("truncate");
#ifdef HAS_TRUNCATE
if (truncate(name, len) < 0)
result = 0;
#else
{
- int tmpfd;
+ const int tmpfd = PerlLIO_open(name, O_RDWR);
- if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
+ if (tmpfd < 0)
result = 0;
else {
if (my_chsize(tmpfd, len) < 0)
SETERRNO(EBADF,RMS_IFI);
RETPUSHUNDEF;
}
-#else
- DIE(aTHX_ "truncate not implemented");
-#endif
-}
-
-PP(pp_fcntl)
-{
- return pp_ioctl();
}
PP(pp_ioctl)
{
dSP; dTARGET;
- SV *argsv = POPs;
- unsigned int func = POPu;
- int optype = PL_op->op_type;
+ SV * const argsv = POPs;
+ const unsigned int func = POPu;
+ const int optype = PL_op->op_type;
+ GV * const gv = (GV*)POPs;
+ IO * const io = gv ? GvIOn(gv) : Null(IO*);
char *s;
IV retval;
- GV *gv = (GV*)POPs;
- IO *io = gv ? GvIOn(gv) : 0;
if (!io || !argsv || !IoIFP(io)) {
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
#ifdef FLOCK
dSP; dTARGET;
I32 value;
- int argtype;
- GV *gv;
IO *io = NULL;
PerlIO *fp;
+ const int argtype = POPi;
+ GV * const gv = (MAXARG == 0) ? PL_last_in_gv : (GV*)POPs;
- argtype = POPi;
- if (MAXARG == 0)
- gv = PL_last_in_gv;
- else
- gv = (GV*)POPs;
if (gv && (io = GvIO(gv)))
fp = IoIFP(io);
else {
fp = Nullfp;
io = NULL;
}
+ /* XXX Looks to me like io is always NULL at this point */
if (fp) {
(void)PerlIO_flush(fp);
value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
{
#ifdef HAS_SOCKET
dSP;
- GV *gv;
- register IO *io;
- int protocol = POPi;
- int type = POPi;
- int domain = POPi;
+ const int protocol = POPi;
+ const int type = POPi;
+ const int domain = POPi;
+ GV * const gv = (GV*)POPs;
+ register IO * const io = gv ? GvIOn(gv) : NULL;
int fd;
- gv = (GV*)POPs;
- io = gv ? GvIOn(gv) : NULL;
-
if (!gv || !io) {
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
{
#if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
dSP;
- GV *gv1;
- GV *gv2;
- register IO *io1;
- register IO *io2;
- int protocol = POPi;
- int type = POPi;
- int domain = POPi;
+ const int protocol = POPi;
+ const int type = POPi;
+ const int domain = POPi;
+ GV * const gv2 = (GV*)POPs;
+ GV * const gv1 = (GV*)POPs;
+ register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
+ register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
int fd[2];
- gv2 = (GV*)POPs;
- gv1 = (GV*)POPs;
- io1 = gv1 ? GvIOn(gv1) : NULL;
- io2 = gv2 ? GvIOn(gv2) : NULL;
if (!gv1 || !gv2 || !io1 || !io2) {
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
if (!gv1 || !io1)
extern void GETPRIVMODE();
extern void GETUSERMODE();
#endif
- SV *addrsv = POPs;
- char *addr;
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
+ SV * const addrsv = POPs;
+ /* OK, so on what platform does bind modify addr? */
+ const char *addr;
+ GV * const gv = (GV*)POPs;
+ register IO * const io = GvIOn(gv);
STRLEN len;
int bind_ok = 0;
#ifdef MPE
if (!io || !IoIFP(io))
goto nuts;
- addr = SvPV(addrsv, len);
+ addr = SvPV_const(addrsv, len);
TAINT_PROPER("bind");
#ifdef MPE /* Deal with MPE bind() peculiarities */
if (((struct sockaddr *)addr)->sa_family == AF_INET) {
{
#ifdef HAS_SOCKET
dSP;
- SV *addrsv = POPs;
- char *addr;
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
+ SV * const addrsv = POPs;
+ GV * const gv = (GV*)POPs;
+ register IO * const io = GvIOn(gv);
+ const char *addr;
STRLEN len;
if (!io || !IoIFP(io))
goto nuts;
- addr = SvPV(addrsv, len);
+ addr = SvPV_const(addrsv, len);
TAINT_PROPER("connect");
if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
RETPUSHYES;
{
#ifdef HAS_SOCKET
dSP;
- int backlog = POPi;
- GV *gv = (GV*)POPs;
- register IO *io = gv ? GvIOn(gv) : NULL;
+ const int backlog = POPi;
+ GV * const gv = (GV*)POPs;
+ register IO * const io = gv ? GvIOn(gv) : NULL;
if (!gv || !io || !IoIFP(io))
goto nuts;
{
#ifdef HAS_SOCKET
dSP; dTARGET;
- GV *ngv;
- GV *ggv;
register IO *nstio;
register IO *gstio;
char namebuf[MAXPATHLEN];
#else
Sock_size_t len = sizeof namebuf;
#endif
+ GV * const ggv = (GV*)POPs;
+ GV * const ngv = (GV*)POPs;
int fd;
- ggv = (GV*)POPs;
- ngv = (GV*)POPs;
-
if (!ngv)
goto badexit;
if (!ggv)
{
#ifdef HAS_SOCKET
dSP; dTARGET;
- int how = POPi;
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
+ const int how = POPi;
+ GV * const gv = (GV*)POPs;
+ register IO * const io = GvIOn(gv);
if (!io || !IoIFP(io))
goto nuts;
#endif
}
-PP(pp_gsockopt)
-{
-#ifdef HAS_SOCKET
- return pp_ssockopt();
-#else
- DIE(aTHX_ PL_no_sock_func, "getsockopt");
-#endif
-}
-
PP(pp_ssockopt)
{
#ifdef HAS_SOCKET
dSP;
- int optype = PL_op->op_type;
- SV *sv;
+ const int optype = PL_op->op_type;
+ SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(NEWSV(22, 257)) : POPs;
+ const unsigned int optname = (unsigned int) POPi;
+ const unsigned int lvl = (unsigned int) POPi;
+ GV * const gv = (GV*)POPs;
+ register IO * const io = GvIOn(gv);
int fd;
- unsigned int optname;
- unsigned int lvl;
- GV *gv;
- register IO *io;
Sock_size_t len;
- if (optype == OP_GSOCKOPT)
- sv = sv_2mortal(NEWSV(22, 257));
- else
- sv = POPs;
- optname = (unsigned int) POPi;
- lvl = (unsigned int) POPi;
-
- gv = (GV*)POPs;
- io = GvIOn(gv);
if (!io || !IoIFP(io))
goto nuts;
PUSHs(sv);
break;
case OP_SSOCKOPT: {
- char *buf;
+#if defined(__SYMBIAN32__)
+# define SETSOCKOPT_OPTION_VALUE_T void *
+#else
+# define SETSOCKOPT_OPTION_VALUE_T const char *
+#endif
+ /* XXX TODO: We need to have a proper type (a Configure probe,
+ * etc.) for what the C headers think of the third argument of
+ * setsockopt(), the option_value read-only buffer: is it
+ * a "char *", or a "void *", const or not. Some compilers
+ * don't take kindly to e.g. assuming that "char *" implicitly
+ * promotes to a "void *", or to explicitly promoting/demoting
+ * consts to non/vice versa. The "const void *" is the SUS
+ * definition, but that does not fly everywhere for the above
+ * reasons. */
+ SETSOCKOPT_OPTION_VALUE_T buf;
int aint;
if (SvPOKp(sv)) {
STRLEN l;
- buf = SvPV(sv, l);
+ buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
len = l;
}
else {
aint = (int)SvIV(sv);
- buf = (char*)&aint;
+ buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
len = sizeof(int);
}
if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
RETPUSHUNDEF;
#else
- DIE(aTHX_ PL_no_sock_func, "setsockopt");
-#endif
-}
-
-PP(pp_getsockname)
-{
-#ifdef HAS_SOCKET
- return pp_getpeername();
-#else
- DIE(aTHX_ PL_no_sock_func, "getsockname");
+ DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
#endif
}
{
#ifdef HAS_SOCKET
dSP;
- int optype = PL_op->op_type;
+ const int optype = PL_op->op_type;
+ GV * const gv = (GV*)POPs;
+ register IO * const io = GvIOn(gv);
+ Sock_size_t len;
SV *sv;
int fd;
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
- Sock_size_t len;
if (!io || !IoIFP(io))
goto nuts;
{
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";
/* If the call succeeded, make sure we don't have a zeroed port/addr */
- if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
- !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
+ if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
+ !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
sizeof(u_short) + sizeof(struct in_addr))) {
goto nuts2;
}
RETPUSHUNDEF;
#else
- DIE(aTHX_ PL_no_sock_func, "getpeername");
+ DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
#endif
}
/* Stat calls. */
-PP(pp_lstat)
-{
- return pp_stat();
-}
-
PP(pp_stat)
{
dSP;
GV *gv;
I32 gimme;
I32 max = 13;
- STRLEN n_a;
if (PL_op->op_flags & OPf_REF) {
gv = cGVOP_gv;
if (PL_op->op_type == OP_LSTAT) {
if (gv != PL_defgv) {
+ do_fstat_warning_check:
if (ckWARN(WARN_IO))
Perl_warner(aTHX_ packWARN(WARN_IO),
"lstat() on filehandle %s", GvENAME(gv));
if (gv != PL_defgv) {
PL_laststype = OP_STAT;
PL_statgv = gv;
- sv_setpv(PL_statname, "");
+ sv_setpvn(PL_statname, "", 0);
PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv))
? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1);
}
}
}
else {
- SV* sv = POPs;
+ SV* const sv = POPs;
if (SvTYPE(sv) == SVt_PVGV) {
gv = (GV*)sv;
goto do_fstat;
}
else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
gv = (GV*)SvRV(sv);
- if (PL_op->op_type == OP_LSTAT && ckWARN(WARN_IO))
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "lstat() on filehandle %s", GvENAME(gv));
+ if (PL_op->op_type == OP_LSTAT)
+ goto do_fstat_warning_check;
goto do_fstat;
}
- sv_setpv(PL_statname, SvPV(sv,n_a));
+ sv_setpv(PL_statname, SvPV_nolen_const(sv));
PL_statgv = Nullgv;
PL_laststype = PL_op->op_type;
if (PL_op->op_type == OP_LSTAT)
- PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
+ PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
else
- PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
+ PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
if (PL_laststatval < 0) {
- if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
+ if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
max = 0;
}
PP(pp_ftrread)
{
I32 result;
+ /* Not const, because things tweak this below. Not bool, because there's
+ no guarantee that OPp_FT_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. */
+# ifdef R_OK
+ int access_mode = R_OK;
+# else
+ int access_mode = 0;
+# endif
+#else
+ /* access_mode is never used, but leaving use_access in makes the
+ conditional compiling below much clearer. */
+ I32 use_access = 0;
+#endif
+ int stat_mode = S_IRUSR;
+
+ bool effective = FALSE;
dSP;
+
STACKED_FTEST_CHECK;
-#if defined(HAS_ACCESS) && defined(R_OK)
- if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
- STRLEN n_a;
- result = access(POPpx, R_OK);
+
+ switch (PL_op->op_type) {
+ case OP_FTRREAD:
+#if !(defined(HAS_ACCESS) && defined(R_OK))
+ use_access = 0;
+#endif
+ break;
+
+ case OP_FTRWRITE:
+#if defined(HAS_ACCESS) && defined(W_OK)
+ access_mode = W_OK;
+#else
+ use_access = 0;
+#endif
+ stat_mode = S_IWUSR;
+ break;
+
+ case OP_FTREXEC:
+#if defined(HAS_ACCESS) && defined(X_OK)
+ access_mode = X_OK;
+#else
+ use_access = 0;
+#endif
+ stat_mode = S_IXUSR;
+ break;
+
+ case OP_FTEWRITE:
+#ifdef PERL_EFF_ACCESS
+ access_mode = W_OK;
+#endif
+ stat_mode = S_IWUSR;
+ /* Fall through */
+
+ case OP_FTEREAD:
+#ifndef PERL_EFF_ACCESS
+ use_access = 0;
+#endif
+ effective = TRUE;
+ break;
+
+
+ case OP_FTEEXEC:
+#ifdef PERL_EFF_ACCESS
+ access_mode = W_OK;
+#else
+ use_access = 0;
+#endif
+ stat_mode = S_IXUSR;
+ effective = TRUE;
+ break;
+ }
+
+ if (use_access) {
+#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
+ const char *const name = POPpx;
+ if (effective) {
+# ifdef PERL_EFF_ACCESS
+ result = PERL_EFF_ACCESS(name, access_mode);
+# else
+ DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
+ OP_NAME(PL_op));
+# endif
+ }
+ else {
+# ifdef HAS_ACCESS
+ result = access(name, access_mode);
+# else
+ DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
+# endif
+ }
if (result == 0)
RETPUSHYES;
if (result < 0)
RETPUSHUNDEF;
RETPUSHNO;
+#endif
}
- else
- result = my_stat();
-#else
+
result = my_stat();
-#endif
SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
- if (cando(S_IRUSR, 0, &PL_statcache))
+ if (cando(stat_mode, effective, &PL_statcache))
RETPUSHYES;
RETPUSHNO;
}
-PP(pp_ftrwrite)
+PP(pp_ftis)
{
I32 result;
+ const int op_type = PL_op->op_type;
dSP;
STACKED_FTEST_CHECK;
-#if defined(HAS_ACCESS) && defined(W_OK)
- if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
- STRLEN n_a;
- result = access(POPpx, W_OK);
- if (result == 0)
- RETPUSHYES;
- if (result < 0)
- RETPUSHUNDEF;
- RETPUSHNO;
- }
- else
- result = my_stat();
-#else
result = my_stat();
-#endif
SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
- if (cando(S_IWUSR, 0, &PL_statcache))
+ if (op_type == OP_FTIS)
RETPUSHYES;
- RETPUSHNO;
+ {
+ /* You can't dTARGET inside OP_FTIS, because you'll get
+ "panic: pad_sv po" - the op is not flagged to have a target. */
+ dTARGET;
+ switch (op_type) {
+ case OP_FTSIZE:
+#if Off_t_size > IVSIZE
+ PUSHn(PL_statcache.st_size);
+#else
+ PUSHi(PL_statcache.st_size);
+#endif
+ break;
+ case OP_FTMTIME:
+ PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
+ break;
+ case OP_FTATIME:
+ PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
+ break;
+ case OP_FTCTIME:
+ PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
+ break;
+ }
+ }
+ RETURN;
}
-PP(pp_ftrexec)
+PP(pp_ftrowned)
{
I32 result;
dSP;
- STACKED_FTEST_CHECK;
-#if defined(HAS_ACCESS) && defined(X_OK)
- if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
- STRLEN n_a;
- result = access(POPpx, X_OK);
- if (result == 0)
- RETPUSHYES;
- if (result < 0)
- RETPUSHUNDEF;
- RETPUSHNO;
- }
- else
- result = my_stat();
-#else
- result = my_stat();
-#endif
- SPAGAIN;
- if (result < 0)
- RETPUSHUNDEF;
- if (cando(S_IXUSR, 0, &PL_statcache))
- RETPUSHYES;
- RETPUSHNO;
-}
-PP(pp_fteread)
-{
- I32 result;
- dSP;
- STACKED_FTEST_CHECK;
-#ifdef PERL_EFF_ACCESS_R_OK
- if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
- STRLEN n_a;
- result = PERL_EFF_ACCESS_R_OK(POPpx);
- if (result == 0)
- RETPUSHYES;
- if (result < 0)
- RETPUSHUNDEF;
+ /* I believe that all these three are likely to be defined on most every
+ system these days. */
+#ifndef S_ISUID
+ if(PL_op->op_type == OP_FTSUID)
RETPUSHNO;
- }
- else
- result = my_stat();
-#else
- result = my_stat();
#endif
- SPAGAIN;
- if (result < 0)
- RETPUSHUNDEF;
- if (cando(S_IRUSR, 1, &PL_statcache))
- RETPUSHYES;
- RETPUSHNO;
-}
-
-PP(pp_ftewrite)
-{
- I32 result;
- dSP;
- STACKED_FTEST_CHECK;
-#ifdef PERL_EFF_ACCESS_W_OK
- if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
- STRLEN n_a;
- result = PERL_EFF_ACCESS_W_OK(POPpx);
- if (result == 0)
- RETPUSHYES;
- if (result < 0)
- RETPUSHUNDEF;
+#ifndef S_ISGID
+ if(PL_op->op_type == OP_FTSGID)
RETPUSHNO;
- }
- else
- result = my_stat();
-#else
- result = my_stat();
#endif
- SPAGAIN;
- if (result < 0)
- RETPUSHUNDEF;
- if (cando(S_IWUSR, 1, &PL_statcache))
- RETPUSHYES;
- RETPUSHNO;
-}
-
-PP(pp_fteexec)
-{
- I32 result;
- dSP;
- STACKED_FTEST_CHECK;
-#ifdef PERL_EFF_ACCESS_X_OK
- if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
- STRLEN n_a;
- result = PERL_EFF_ACCESS_X_OK(POPpx);
- if (result == 0)
- RETPUSHYES;
- if (result < 0)
- RETPUSHUNDEF;
+#ifndef S_ISVTX
+ if(PL_op->op_type == OP_FTSVTX)
RETPUSHNO;
- }
- else
- result = my_stat();
-#else
- result = my_stat();
#endif
- SPAGAIN;
- if (result < 0)
- RETPUSHUNDEF;
- if (cando(S_IXUSR, 1, &PL_statcache))
- RETPUSHYES;
- RETPUSHNO;
-}
-PP(pp_ftis)
-{
- I32 result;
- dSP;
- STACKED_FTEST_CHECK;
- result = my_stat();
- SPAGAIN;
- if (result < 0)
- RETPUSHUNDEF;
- RETPUSHYES;
-}
-
-PP(pp_fteowned)
-{
- return pp_ftrowned();
-}
-
-PP(pp_ftrowned)
-{
- I32 result;
- dSP;
- STACKED_FTEST_CHECK;
- result = my_stat();
- SPAGAIN;
- if (result < 0)
- RETPUSHUNDEF;
- if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
- PL_euid : PL_uid) )
- RETPUSHYES;
- RETPUSHNO;
-}
-
-PP(pp_ftzero)
-{
- I32 result;
- dSP;
- STACKED_FTEST_CHECK;
- result = my_stat();
- SPAGAIN;
- if (result < 0)
- RETPUSHUNDEF;
- if (PL_statcache.st_size == 0)
- RETPUSHYES;
- RETPUSHNO;
-}
-
-PP(pp_ftsize)
-{
- I32 result;
- dSP; dTARGET;
STACKED_FTEST_CHECK;
result = my_stat();
SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
-#if Off_t_size > IVSIZE
- PUSHn(PL_statcache.st_size);
-#else
- PUSHi(PL_statcache.st_size);
-#endif
- RETURN;
-}
-
-PP(pp_ftmtime)
-{
- I32 result;
- dSP; dTARGET;
- STACKED_FTEST_CHECK;
- result = my_stat();
- SPAGAIN;
- if (result < 0)
- RETPUSHUNDEF;
- PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
- RETURN;
-}
-
-PP(pp_ftatime)
-{
- I32 result;
- dSP; dTARGET;
- STACKED_FTEST_CHECK;
- result = my_stat();
- SPAGAIN;
- if (result < 0)
- RETPUSHUNDEF;
- PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
- RETURN;
-}
-
-PP(pp_ftctime)
-{
- I32 result;
- dSP; dTARGET;
- STACKED_FTEST_CHECK;
- result = my_stat();
- SPAGAIN;
- if (result < 0)
- RETPUSHUNDEF;
- PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
- RETURN;
-}
-
-PP(pp_ftsock)
-{
- I32 result;
- dSP;
- STACKED_FTEST_CHECK;
- result = my_stat();
- SPAGAIN;
- if (result < 0)
- RETPUSHUNDEF;
- if (S_ISSOCK(PL_statcache.st_mode))
- RETPUSHYES;
- RETPUSHNO;
-}
-
-PP(pp_ftchr)
-{
- I32 result;
- dSP;
- STACKED_FTEST_CHECK;
- result = my_stat();
- SPAGAIN;
- if (result < 0)
- RETPUSHUNDEF;
- if (S_ISCHR(PL_statcache.st_mode))
- RETPUSHYES;
- RETPUSHNO;
-}
-
-PP(pp_ftblk)
-{
- I32 result;
- dSP;
- STACKED_FTEST_CHECK;
- result = my_stat();
- SPAGAIN;
- if (result < 0)
- RETPUSHUNDEF;
- if (S_ISBLK(PL_statcache.st_mode))
- RETPUSHYES;
- RETPUSHNO;
-}
-
-PP(pp_ftfile)
-{
- I32 result;
- dSP;
- STACKED_FTEST_CHECK;
- result = my_stat();
- SPAGAIN;
- if (result < 0)
- RETPUSHUNDEF;
- if (S_ISREG(PL_statcache.st_mode))
- RETPUSHYES;
- RETPUSHNO;
-}
-
-PP(pp_ftdir)
-{
- I32 result;
- dSP;
- STACKED_FTEST_CHECK;
- result = my_stat();
- SPAGAIN;
- if (result < 0)
- RETPUSHUNDEF;
- if (S_ISDIR(PL_statcache.st_mode))
- RETPUSHYES;
- RETPUSHNO;
-}
-
-PP(pp_ftpipe)
-{
- I32 result;
- dSP;
- STACKED_FTEST_CHECK;
- result = my_stat();
- SPAGAIN;
- if (result < 0)
- RETPUSHUNDEF;
- if (S_ISFIFO(PL_statcache.st_mode))
- RETPUSHYES;
- RETPUSHNO;
-}
-
-PP(pp_ftlink)
-{
- I32 result = my_lstat();
- dSP;
- if (result < 0)
- RETPUSHUNDEF;
- if (S_ISLNK(PL_statcache.st_mode))
- RETPUSHYES;
- RETPUSHNO;
-}
-
-PP(pp_ftsuid)
-{
- dSP;
+ switch (PL_op->op_type) {
+ case OP_FTROWNED:
+ if (PL_statcache.st_uid == PL_uid)
+ RETPUSHYES;
+ break;
+ case OP_FTEOWNED:
+ if (PL_statcache.st_uid == PL_euid)
+ RETPUSHYES;
+ break;
+ case OP_FTZERO:
+ if (PL_statcache.st_size == 0)
+ RETPUSHYES;
+ break;
+ case OP_FTSOCK:
+ if (S_ISSOCK(PL_statcache.st_mode))
+ RETPUSHYES;
+ break;
+ case OP_FTCHR:
+ if (S_ISCHR(PL_statcache.st_mode))
+ RETPUSHYES;
+ break;
+ case OP_FTBLK:
+ if (S_ISBLK(PL_statcache.st_mode))
+ RETPUSHYES;
+ break;
+ case OP_FTFILE:
+ if (S_ISREG(PL_statcache.st_mode))
+ RETPUSHYES;
+ break;
+ case OP_FTDIR:
+ if (S_ISDIR(PL_statcache.st_mode))
+ RETPUSHYES;
+ break;
+ case OP_FTPIPE:
+ if (S_ISFIFO(PL_statcache.st_mode))
+ RETPUSHYES;
+ break;
#ifdef S_ISUID
- I32 result;
- STACKED_FTEST_CHECK;
- result = my_stat();
- SPAGAIN;
- if (result < 0)
- RETPUSHUNDEF;
- if (PL_statcache.st_mode & S_ISUID)
- RETPUSHYES;
+ case OP_FTSUID:
+ if (PL_statcache.st_mode & S_ISUID)
+ RETPUSHYES;
+ break;
#endif
- RETPUSHNO;
-}
-
-PP(pp_ftsgid)
-{
- dSP;
#ifdef S_ISGID
- I32 result;
- STACKED_FTEST_CHECK;
- result = my_stat();
- SPAGAIN;
- if (result < 0)
- RETPUSHUNDEF;
- if (PL_statcache.st_mode & S_ISGID)
- RETPUSHYES;
+ case OP_FTSGID:
+ if (PL_statcache.st_mode & S_ISGID)
+ RETPUSHYES;
+ break;
+#endif
+#ifdef S_ISVTX
+ case OP_FTSVTX:
+ if (PL_statcache.st_mode & S_ISVTX)
+ RETPUSHYES;
+ break;
#endif
+ }
RETPUSHNO;
}
-PP(pp_ftsvtx)
+PP(pp_ftlink)
{
+ I32 result = my_lstat();
dSP;
-#ifdef S_ISVTX
- I32 result;
- STACKED_FTEST_CHECK;
- result = my_stat();
- SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
- if (PL_statcache.st_mode & S_ISVTX)
+ if (S_ISLNK(PL_statcache.st_mode))
RETPUSHYES;
-#endif
RETPUSHNO;
}
if (GvIO(gv) && IoIFP(GvIOp(gv)))
fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
else if (tmpsv && SvOK(tmpsv)) {
- STRLEN n_a;
- char *tmps = SvPV(tmpsv, n_a);
+ const char *tmps = SvPV_nolen_const(tmpsv);
if (isDIGIT(*tmps))
fd = atoi(tmps);
else
register IO *io;
register SV *sv;
GV *gv;
- STRLEN n_a;
PerlIO *fp;
STACKED_FTEST_CHECK;
else {
PL_statgv = gv;
PL_laststatval = -1;
- sv_setpv(PL_statname, "");
+ sv_setpvn(PL_statname, "", 0);
io = GvIO(PL_statgv);
}
if (io && IoIFP(io)) {
sv = POPs;
really_filename:
PL_statgv = Nullgv;
- PL_laststatval = -1;
PL_laststype = OP_STAT;
- sv_setpv(PL_statname, SvPV(sv, n_a));
- if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
- if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
+ sv_setpv(PL_statname, SvPV_nolen_const(sv));
+ if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
+ if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
+ '\n'))
Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
RETPUSHUNDEF;
}
RETPUSHYES;
}
-PP(pp_ftbinary)
-{
- return pp_fttext();
-}
-
/* File calls. */
PP(pp_chdir)
{
dSP; dTARGET;
- char *tmps;
- SV **svp;
- STRLEN n_a;
+ const char *tmps = 0;
+ GV *gv = NULL;
- if( MAXARG == 1 )
- tmps = POPpx;
- else
- tmps = 0;
+ if( MAXARG == 1 ) {
+ SV * const sv = POPs;
+ if (SvTYPE(sv) == SVt_PVGV) {
+ gv = (GV*)sv;
+ }
+ else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
+ gv = (GV*)SvRV(sv);
+ }
+ else {
+ tmps = SvPVx_nolen_const(sv);
+ }
+ }
+
+ if( !gv && (!tmps || !*tmps) ) {
+ HV * const table = GvHVn(PL_envgv);
+ SV **svp;
- if( !tmps || !*tmps ) {
- if ( (svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE))
- || (svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE))
+ if ( (svp = hv_fetch(table, "HOME", 4, FALSE))
+ || (svp = hv_fetch(table, "LOGDIR", 6, FALSE))
#ifdef VMS
- || (svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE))
+ || (svp = hv_fetch(table, "SYS$LOGIN", 9, FALSE))
#endif
)
{
if( MAXARG == 1 )
deprecate("chdir('') or chdir(undef) as chdir()");
- tmps = SvPV(*svp, n_a);
+ tmps = SvPV_nolen_const(*svp);
}
else {
PUSHi(0);
}
TAINT_PROPER("chdir");
- PUSHi( PerlDir_chdir(tmps) >= 0 );
+ if (gv) {
+#ifdef HAS_FCHDIR
+ IO* const io = GvIO(gv);
+ if (io) {
+ if (IoIFP(io)) {
+ PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
+ }
+ else if (IoDIRP(io)) {
+#ifdef HAS_DIRFD
+ PUSHi(fchdir(dirfd(IoDIRP(io))) >= 0);
+#else
+ DIE(aTHX_ PL_no_func, "dirfd");
+#endif
+ }
+ else {
+ PUSHi(0);
+ }
+ }
+ else {
+ PUSHi(0);
+ }
+#else
+ DIE(aTHX_ PL_no_func, "fchdir");
+#endif
+ }
+ else
+ PUSHi( PerlDir_chdir(tmps) >= 0 );
#ifdef VMS
/* Clear the DEFAULT element of ENV so we'll get the new value
* in the future. */
PP(pp_chown)
{
-#ifdef HAS_CHOWN
dSP; dMARK; dTARGET;
- I32 value = (I32)apply(PL_op->op_type, MARK, SP);
+ const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
SP = MARK;
- PUSHi(value);
+ XPUSHi(value);
RETURN;
-#else
- DIE(aTHX_ PL_no_func, "chown");
-#endif
}
PP(pp_chroot)
{
#ifdef HAS_CHROOT
dSP; dTARGET;
- STRLEN n_a;
- char *tmps = POPpx;
+ char * const tmps = POPpx;
TAINT_PROPER("chroot");
PUSHi( chroot(tmps) >= 0 );
RETURN;
#endif
}
-PP(pp_unlink)
-{
- dSP; dMARK; dTARGET;
- I32 value;
- value = (I32)apply(PL_op->op_type, MARK, SP);
- SP = MARK;
- PUSHi(value);
- RETURN;
-}
-
-PP(pp_chmod)
-{
- dSP; dMARK; dTARGET;
- I32 value;
- value = (I32)apply(PL_op->op_type, MARK, SP);
- SP = MARK;
- PUSHi(value);
- RETURN;
-}
-
-PP(pp_utime)
-{
- dSP; dMARK; dTARGET;
- I32 value;
- value = (I32)apply(PL_op->op_type, MARK, SP);
- SP = MARK;
- PUSHi(value);
- RETURN;
-}
-
PP(pp_rename)
{
dSP; dTARGET;
int anum;
- STRLEN n_a;
-
- char *tmps2 = POPpx;
- char *tmps = SvPV(TOPs, n_a);
+ const char * const tmps2 = POPpconstx;
+ const char * const tmps = SvPV_nolen_const(TOPs);
TAINT_PROPER("rename");
#ifdef HAS_RENAME
anum = PerlLIO_rename(tmps, tmps2);
RETURN;
}
+#if defined(HAS_LINK) || defined(HAS_SYMLINK)
PP(pp_link)
{
-#ifdef HAS_LINK
dSP; dTARGET;
- STRLEN n_a;
- char *tmps2 = POPpx;
- char *tmps = SvPV(TOPs, n_a);
- TAINT_PROPER("link");
- SETi( PerlLIO_link(tmps, tmps2) >= 0 );
- RETURN;
-#else
- DIE(aTHX_ PL_no_func, "link");
-#endif
-}
+ const int op_type = PL_op->op_type;
+ int result;
-PP(pp_symlink)
-{
-#ifdef HAS_SYMLINK
- dSP; dTARGET;
- STRLEN n_a;
- char *tmps2 = POPpx;
- char *tmps = SvPV(TOPs, n_a);
- TAINT_PROPER("symlink");
- SETi( symlink(tmps, tmps2) >= 0 );
+# ifndef HAS_LINK
+ if (op_type == OP_LINK)
+ DIE(aTHX_ PL_no_func, "link");
+# endif
+# ifndef HAS_SYMLINK
+ if (op_type == OP_SYMLINK)
+ DIE(aTHX_ PL_no_func, "symlink");
+# endif
+
+ {
+ const char * const tmps2 = POPpconstx;
+ const char * const tmps = SvPV_nolen_const(TOPs);
+ TAINT_PROPER(PL_op_desc[op_type]);
+ result =
+# if defined(HAS_LINK)
+# if defined(HAS_SYMLINK)
+ /* Both present - need to choose which. */
+ (op_type == OP_LINK) ?
+ PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
+# else
+ /* Only have link, so calls to pp_symlink will have DIE()d above. */
+ PerlLIO_link(tmps, tmps2);
+# endif
+# else
+# if defined(HAS_SYMLINK)
+ /* Only have symlink, so calls to pp_link will have DIE()d above. */
+ symlink(tmps, tmps2);
+# endif
+# endif
+ }
+
+ SETi( result >= 0 );
RETURN;
+}
#else
- DIE(aTHX_ PL_no_func, "symlink");
-#endif
+PP(pp_link)
+{
+ /* Have neither. */
+ DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
}
+#endif
PP(pp_readlink)
{
dSP;
#ifdef HAS_SYMLINK
dTARGET;
- char *tmps;
+ const char *tmps;
char buf[MAXPATHLEN];
int len;
- STRLEN n_a;
#ifndef INCOMPLETE_TAINTS
TAINT;
#endif
- tmps = POPpx;
+ tmps = POPpconstx;
len = readlink(tmps, buf, sizeof(buf) - 1);
EXTEND(SP, 1);
if (len < 0)
#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
STATIC int
-S_dooneliner(pTHX_ char *cmd, char *filename)
+S_dooneliner(pTHX_ const char *cmd, const char *filename)
{
- char *save_filename = filename;
+ char * const save_filename = filename;
char *cmdline;
char *s;
PerlIO *myfp;
int anum = 1;
- New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
+ Newx(cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
strcpy(cmdline, cmd);
strcat(cmdline, " ");
for (s = cmdline + strlen(cmdline); *filename; ) {
Safefree(cmdline);
if (myfp) {
- SV *tmpsv = sv_newmortal();
+ SV * const tmpsv = sv_newmortal();
/* Need to save/restore 'PL_rs' ?? */
s = sv_gets(tmpsv, myfp, 0);
(void)PerlProc_pclose(myfp);
* -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
* (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
-#define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV(TOPs, (len)); \
+#define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
if ((len) > 1 && (tmps)[(len)-1] == '/') { \
do { \
(len)--; \
PP(pp_mkdir)
{
dSP; dTARGET;
- int mode;
-#ifndef HAS_MKDIR
- int oldumask;
-#endif
STRLEN len;
- char *tmps;
+ const char *tmps;
bool copy = FALSE;
-
- if (MAXARG > 1)
- mode = POPi;
- else
- mode = 0777;
+ const int mode = (MAXARG > 1) ? POPi : 0777;
TRIMSLASHES(tmps,len,copy);
#ifdef HAS_MKDIR
SETi( PerlDir_mkdir(tmps, mode) >= 0 );
#else
+ {
+ int oldumask;
SETi( dooneliner("mkdir", tmps) );
oldumask = PerlLIO_umask(0);
PerlLIO_umask(oldumask);
PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
+ }
#endif
if (copy)
Safefree(tmps);
{
dSP; dTARGET;
STRLEN len;
- char *tmps;
+ const char *tmps;
bool copy = FALSE;
TRIMSLASHES(tmps,len,copy);
{
#if defined(Direntry_t) && defined(HAS_READDIR)
dSP;
- STRLEN n_a;
- char *dirname = POPpx;
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
+ const char * const dirname = POPpconstx;
+ GV * const gv = (GV*)POPs;
+ register IO * const io = GvIOn(gv);
if (!io)
goto nope;
dSP;
SV *sv;
- I32 gimme = GIMME;
- GV *gv = (GV *)POPs;
- register Direntry_t *dp;
- register IO *io = GvIOn(gv);
+ const I32 gimme = GIMME;
+ GV * const gv = (GV *)POPs;
+ register const Direntry_t *dp;
+ register IO * const io = GvIOn(gv);
if (!io || !IoDIRP(io))
goto nope;
PP(pp_telldir)
{
#if defined(HAS_TELLDIR) || defined(telldir)
- dSP; dTARGET;
+ dVAR; 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.
# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
long telldir (DIR *);
# endif
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
+ GV * const gv = (GV*)POPs;
+ register IO * const io = GvIOn(gv);
if (!io || !IoDIRP(io))
goto nope;
{
#if defined(HAS_SEEKDIR) || defined(seekdir)
dSP;
- long along = POPl;
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
+ const long along = POPl;
+ GV * const gv = (GV*)POPs;
+ register IO * const io = GvIOn(gv);
if (!io || !IoDIRP(io))
goto nope;
{
#if defined(HAS_REWINDDIR) || defined(rewinddir)
dSP;
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
+ GV * const gv = (GV*)POPs;
+ register IO * const io = GvIOn(gv);
if (!io || !IoDIRP(io))
goto nope;
{
#if defined(Direntry_t) && defined(HAS_READDIR)
dSP;
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
+ GV * const gv = (GV*)POPs;
+ register IO * const io = GvIOn(gv);
if (!io || !IoDIRP(io))
goto nope;
#ifdef HAS_FORK
dSP; dTARGET;
Pid_t childpid;
- GV *tmpgv;
EXTEND(SP, 1);
PERL_FLUSHALL_FOR_CHILD;
if (childpid < 0)
RETSETUNDEF;
if (!childpid) {
- /*SUPPRESS 560*/
- if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV))) {
+ GV * const tmpgv = gv_fetchpv("$", TRUE, SVt_PV);
+ if (tmpgv) {
SvREADONLY_off(GvSV(tmpgv));
sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
SvREADONLY_on(GvSV(tmpgv));
#ifdef THREADS_HAVE_PIDS
PL_ppid = (IV)getppid();
#endif
+#ifdef PERL_USES_PL_PIDSTATUS
hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
+#endif
}
PUSHi(childpid);
RETURN;
}
# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
/* 0 and -1 are both error returns (the former applies to WNOHANG case) */
- STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
+ STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
# else
- STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
+ STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
# endif
XPUSHi(childpid);
RETURN;
{
#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
dSP; dTARGET;
- Pid_t pid;
+ const int optype = POPi;
+ const Pid_t pid = TOPi;
Pid_t result;
- int optype;
int argflags;
- optype = POPi;
- pid = TOPi;
if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
result = wait4pid(pid, &argflags, optype);
else {
}
# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
/* 0 and -1 are both error returns (the former applies to WNOHANG case) */
- STATUS_NATIVE_SET((result && result != -1) ? argflags : -1);
+ STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
# else
- STATUS_NATIVE_SET((result > 0) ? argflags : -1);
+ STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
# endif
SETi(result);
RETURN;
{
dSP; dMARK; dORIGMARK; dTARGET;
I32 value;
- STRLEN n_a;
int result;
- I32 did_pipes = 0;
if (PL_tainting) {
TAINT_ENV();
while (++MARK <= SP) {
- (void)SvPV_nolen(*MARK); /* stringify for taint check */
+ (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
if (PL_tainted)
break;
}
{
Pid_t childpid;
int pp[2];
+ I32 did_pipes = 0;
if (PerlProc_pipe(pp) >= 0)
did_pipes = 1;
if (errno != EAGAIN) {
value = -1;
SP = ORIGMARK;
- PUSHi(value);
+ XPUSHi(value);
if (did_pipes) {
PerlLIO_close(pp[0]);
PerlLIO_close(pp[1]);
if (did_pipes)
PerlLIO_close(pp[1]);
#ifndef PERL_MICRO
- rsignal_save(SIGINT, SIG_IGN, &ihand);
- rsignal_save(SIGQUIT, SIG_IGN, &qhand);
+ rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
+ rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
#endif
do {
result = wait4pid(childpid, &status, 0);
(void)rsignal_restore(SIGINT, &ihand);
(void)rsignal_restore(SIGQUIT, &qhand);
#endif
- STATUS_NATIVE_SET(result == -1 ? -1 : status);
+ STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
do_execfree(); /* free any memory child malloced on fork */
SP = ORIGMARK;
if (did_pipes) {
if (n != sizeof(int))
DIE(aTHX_ "panic: kid popen errno read");
errno = errkid; /* Propagate errno from kid */
- STATUS_CURRENT = -1;
+ STATUS_NATIVE_CHILD_SET(-1);
}
}
- PUSHi(STATUS_CURRENT);
+ XPUSHi(STATUS_CURRENT);
RETURN;
}
if (did_pipes) {
#endif
}
if (PL_op->op_flags & OPf_STACKED) {
- SV *really = *++MARK;
+ SV * const really = *++MARK;
value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
}
else if (SP - MARK != 1)
value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
else {
- value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
+ value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
}
PerlProc__exit(-1);
}
PL_statusvalue = 0;
result = 0;
if (PL_op->op_flags & OPf_STACKED) {
- SV *really = *++MARK;
-# if defined(WIN32) || defined(OS2)
+ SV * const really = *++MARK;
+# if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
value = (I32)do_aspawn(really, MARK, SP);
# else
value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
# endif
}
else if (SP - MARK != 1) {
-# if defined(WIN32) || defined(OS2)
+# if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
value = (I32)do_aspawn(Nullsv, MARK, SP);
# else
value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
# endif
}
else {
- value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
+ value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
}
if (PL_statusvalue == -1) /* hint that value must be returned as is */
result = 1;
- STATUS_NATIVE_SET(value);
+ STATUS_NATIVE_CHILD_SET(value);
do_execfree();
SP = ORIGMARK;
- PUSHi(result ? value : STATUS_CURRENT);
+ XPUSHi(result ? value : STATUS_CURRENT);
#endif /* !FORK or VMS */
RETURN;
}
{
dSP; dMARK; dORIGMARK; dTARGET;
I32 value;
- STRLEN n_a;
if (PL_tainting) {
TAINT_ENV();
while (++MARK <= SP) {
- (void)SvPV_nolen(*MARK); /* stringify for taint check */
+ (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
if (PL_tainted)
break;
}
}
PERL_FLUSHALL_FOR_CHILD;
if (PL_op->op_flags & OPf_STACKED) {
- SV *really = *++MARK;
+ SV * const really = *++MARK;
value = (I32)do_aexec(really, MARK, SP);
}
else if (SP - MARK != 1)
#endif
else {
#ifdef VMS
- value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
+ value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
#else
# ifdef __OPEN_VM
- (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
+ (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
value = 0;
# else
- value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
+ value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
# endif
#endif
}
SP = ORIGMARK;
- PUSHi(value);
- RETURN;
-}
-
-PP(pp_kill)
-{
-#ifdef HAS_KILL
- dSP; dMARK; dTARGET;
- I32 value;
- value = (I32)apply(PL_op->op_type, MARK, SP);
- SP = MARK;
- PUSHi(value);
+ XPUSHi(value);
RETURN;
-#else
- DIE(aTHX_ PL_no_func, "kill");
-#endif
}
PP(pp_getppid)
#ifdef HAS_GETPPID
dSP; dTARGET;
# ifdef THREADS_HAVE_PIDS
+ if (PL_ppid != 1 && getppid() == 1)
+ /* maybe the parent process has died. Refresh ppid cache */
+ PL_ppid = 1;
XPUSHi( PL_ppid );
# else
XPUSHi( getppid() );
{
#ifdef HAS_GETPGRP
dSP; dTARGET;
- Pid_t pid;
Pid_t pgrp;
+ const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
- if (MAXARG < 1)
- pid = 0;
- else
- pid = SvIVx(POPs);
#ifdef BSD_GETPGRP
pgrp = (I32)BSD_GETPGRP(pid);
#else
{
#ifdef HAS_GETPRIORITY
dSP; dTARGET;
- int who = POPi;
- int which = TOPi;
+ const int who = POPi;
+ const int which = TOPi;
SETi( getpriority(which, who) );
RETURN;
#else
{
#ifdef HAS_SETPRIORITY
dSP; dTARGET;
- int niceval = POPi;
- int who = POPi;
- int which = TOPi;
+ const int niceval = POPi;
+ const int who = POPi;
+ const int which = TOPi;
TAINT_PROPER("setpriority");
SETi( setpriority(which, who, niceval) >= 0 );
RETURN;
#endif /* HAS_TIMES */
}
-PP(pp_localtime)
-{
- return pp_gmtime();
-}
+#ifdef LOCALTIME_EDGECASE_BROKEN
+static struct tm *S_my_localtime (pTHX_ Time_t *tp)
+{
+ auto time_t T;
+ auto struct tm *P;
+
+ /* No workarounds in the valid range */
+ if (!tp || *tp < 0x7fff573f || *tp >= 0x80000000)
+ return (localtime (tp));
+
+ /* This edge case is to workaround the undefined behaviour, where the
+ * TIMEZONE makes the time go beyond the defined range.
+ * gmtime (0x7fffffff) => 2038-01-19 03:14:07
+ * If there is a negative offset in TZ, like MET-1METDST, some broken
+ * implementations of localtime () (like AIX 5.2) barf with bogus
+ * return values:
+ * 0x7fffffff gmtime 2038-01-19 03:14:07
+ * 0x7fffffff localtime 1901-12-13 21:45:51
+ * 0x7fffffff mylocaltime 2038-01-19 04:14:07
+ * 0x3c19137f gmtime 2001-12-13 20:45:51
+ * 0x3c19137f localtime 2001-12-13 21:45:51
+ * 0x3c19137f mylocaltime 2001-12-13 21:45:51
+ * Given that legal timezones are typically between GMT-12 and GMT+12
+ * we turn back the clock 23 hours before calling the localtime
+ * function, and add those to the return value. This will never cause
+ * day wrapping problems, since the edge case is Tue Jan *19*
+ */
+ T = *tp - 82800; /* 23 hour. allows up to GMT-23 */
+ P = localtime (&T);
+ P->tm_hour += 23;
+ if (P->tm_hour >= 24) {
+ P->tm_hour -= 24;
+ P->tm_mday++; /* 18 -> 19 */
+ P->tm_wday++; /* Mon -> Tue */
+ P->tm_yday++; /* 18 -> 19 */
+ }
+ return (P);
+} /* S_my_localtime */
+#endif
PP(pp_gmtime)
{
dSP;
Time_t when;
- struct tm *tmbuf;
- static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
- static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
- "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
+ const struct tm *tmbuf;
+ static const char * const dayname[] =
+ {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
+ static const char * const monname[] =
+ {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
+ "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
if (MAXARG < 1)
(void)time(&when);
#endif
if (PL_op->op_type == OP_LOCALTIME)
+#ifdef LOCALTIME_EDGECASE_BROKEN
+ tmbuf = S_my_localtime(aTHX_ &when);
+#else
tmbuf = localtime(&when);
+#endif
else
tmbuf = gmtime(&when);
}
/* Shared memory. */
-
-PP(pp_shmget)
-{
- return pp_semget();
-}
-
-PP(pp_shmctl)
-{
- return pp_semctl();
-}
-
-PP(pp_shmread)
-{
- return pp_shmwrite();
-}
+/* Merged with some message passing. */
PP(pp_shmwrite)
{
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
dSP; dMARK; dTARGET;
- I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
- SP = MARK;
- PUSHi(value);
- RETURN;
-#else
- return pp_semget();
-#endif
-}
-
-/* Message passing. */
-
-PP(pp_msgget)
-{
- return pp_semget();
-}
-
-PP(pp_msgctl)
-{
- return pp_semctl();
-}
+ const int op_type = PL_op->op_type;
+ I32 value;
-PP(pp_msgsnd)
-{
-#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
- dSP; dMARK; dTARGET;
- I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
- SP = MARK;
- PUSHi(value);
- RETURN;
-#else
- return pp_semget();
-#endif
-}
+ switch (op_type) {
+ case OP_MSGSND:
+ value = (I32)(do_msgsnd(MARK, SP) >= 0);
+ break;
+ case OP_MSGRCV:
+ value = (I32)(do_msgrcv(MARK, SP) >= 0);
+ break;
+ case OP_SEMOP:
+ value = (I32)(do_semop(MARK, SP) >= 0);
+ break;
+ default:
+ value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
+ break;
+ }
-PP(pp_msgrcv)
-{
-#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
- dSP; dMARK; dTARGET;
- I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
SP = MARK;
PUSHi(value);
RETURN;
{
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
dSP; dMARK; dTARGET;
- int anum = do_ipcget(PL_op->op_type, MARK, SP);
+ const int anum = do_ipcget(PL_op->op_type, MARK, SP);
SP = MARK;
if (anum == -1)
RETPUSHUNDEF;
{
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
dSP; dMARK; dTARGET;
- int anum = do_ipcctl(PL_op->op_type, MARK, SP);
+ const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
SP = MARK;
if (anum == -1)
RETSETUNDEF;
#endif
}
-PP(pp_semop)
-{
-#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
- dSP; dMARK; dTARGET;
- I32 value = (I32)(do_semop(MARK, SP) >= 0);
- SP = MARK;
- PUSHi(value);
- RETURN;
-#else
- return pp_semget();
-#endif
-}
-
/* Get system info. */
-PP(pp_ghbyname)
-{
-#ifdef HAS_GETHOSTBYNAME
- return pp_ghostent();
-#else
- DIE(aTHX_ PL_no_sock_func, "gethostbyname");
-#endif
-}
-
-PP(pp_ghbyaddr)
-{
-#ifdef HAS_GETHOSTBYADDR
- return pp_ghostent();
-#else
- DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
-#endif
-}
-
PP(pp_ghostent)
{
#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
#endif
struct hostent *hent;
unsigned long len;
- STRLEN n_a;
EXTEND(SP, 10);
if (which == OP_GHBYNAME) {
#ifdef HAS_GETHOSTBYNAME
- char* name = POPpbytex;
+ const char* const name = POPpbytex;
hent = PerlSock_gethostbyname(name);
#else
DIE(aTHX_ PL_no_sock_func, "gethostbyname");
}
else if (which == OP_GHBYADDR) {
#ifdef HAS_GETHOSTBYADDR
- int addrtype = POPi;
- SV *addrsv = POPs;
+ const int addrtype = POPi;
+ SV * const addrsv = POPs;
STRLEN addrlen;
Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
h_errno = PL_reentrant_buffer->_gethostent_errno;
# endif
#endif
- STATUS_NATIVE_SET(h_errno);
+ STATUS_UNIX_SET(h_errno);
}
#endif
#endif
}
-PP(pp_gnbyname)
-{
-#ifdef HAS_GETNETBYNAME
- return pp_gnetent();
-#else
- DIE(aTHX_ PL_no_sock_func, "getnetbyname");
-#endif
-}
-
-PP(pp_gnbyaddr)
-{
-#ifdef HAS_GETNETBYADDR
- return pp_gnetent();
-#else
- DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
-#endif
-}
-
PP(pp_gnetent)
{
#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
struct netent *getnetent(void);
#endif
struct netent *nent;
- STRLEN n_a;
if (which == OP_GNBYNAME){
#ifdef HAS_GETNETBYNAME
- char *name = POPpbytex;
+ const char * const name = POPpbytex;
nent = PerlSock_getnetbyname(name);
#else
DIE(aTHX_ PL_no_sock_func, "getnetbyname");
}
else if (which == OP_GNBYADDR) {
#ifdef HAS_GETNETBYADDR
- int addrtype = POPi;
- Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
+ const int addrtype = POPi;
+ const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
nent = PerlSock_getnetbyaddr(addr, addrtype);
#else
DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
h_errno = PL_reentrant_buffer->_getnetent_errno;
# endif
#endif
- STATUS_NATIVE_SET(h_errno);
+ STATUS_UNIX_SET(h_errno);
}
#endif
#endif
}
-PP(pp_gpbyname)
-{
-#ifdef HAS_GETPROTOBYNAME
- return pp_gprotoent();
-#else
- DIE(aTHX_ PL_no_sock_func, "getprotobyname");
-#endif
-}
-
-PP(pp_gpbynumber)
-{
-#ifdef HAS_GETPROTOBYNUMBER
- return pp_gprotoent();
-#else
- DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
-#endif
-}
-
PP(pp_gprotoent)
{
#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
struct protoent *getprotoent(void);
#endif
struct protoent *pent;
- STRLEN n_a;
if (which == OP_GPBYNAME) {
#ifdef HAS_GETPROTOBYNAME
- char* name = POPpbytex;
+ const char* const name = POPpbytex;
pent = PerlSock_getprotobyname(name);
#else
DIE(aTHX_ PL_no_sock_func, "getprotobyname");
}
else if (which == OP_GPBYNUMBER) {
#ifdef HAS_GETPROTOBYNUMBER
- int number = POPi;
+ const int number = POPi;
pent = PerlSock_getprotobynumber(number);
#else
DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
#endif
}
-PP(pp_gsbyname)
-{
-#ifdef HAS_GETSERVBYNAME
- return pp_gservent();
-#else
- DIE(aTHX_ PL_no_sock_func, "getservbyname");
-#endif
-}
-
-PP(pp_gsbyport)
-{
-#ifdef HAS_GETSERVBYPORT
- return pp_gservent();
-#else
- DIE(aTHX_ PL_no_sock_func, "getservbyport");
-#endif
-}
-
PP(pp_gservent)
{
#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
struct servent *getservent(void);
#endif
struct servent *sent;
- STRLEN n_a;
if (which == OP_GSBYNAME) {
#ifdef HAS_GETSERVBYNAME
- char *proto = POPpbytex;
- char *name = POPpbytex;
-
- if (proto && !*proto)
- proto = Nullch;
-
- sent = PerlSock_getservbyname(name, proto);
+ const char * const proto = POPpbytex;
+ const char * const name = POPpbytex;
+ sent = PerlSock_getservbyname(name, (proto && !*proto) ? Nullch : proto);
#else
DIE(aTHX_ PL_no_sock_func, "getservbyname");
#endif
}
else if (which == OP_GSBYPORT) {
#ifdef HAS_GETSERVBYPORT
- char *proto = POPpbytex;
+ const char * const proto = POPpbytex;
unsigned short port = (unsigned short)POPu;
-
- if (proto && !*proto)
- proto = Nullch;
-
#ifdef HAS_HTONS
port = PerlSock_htons(port);
#endif
- sent = PerlSock_getservbyport(port, proto);
+ sent = PerlSock_getservbyport(port, (proto && !*proto) ? Nullch : proto);
#else
DIE(aTHX_ PL_no_sock_func, "getservbyport");
#endif
#endif
}
-PP(pp_gpwnam)
-{
-#ifdef HAS_PASSWD
- return pp_gpwent();
-#else
- DIE(aTHX_ PL_no_func, "getpwnam");
-#endif
-}
-
-PP(pp_gpwuid)
-{
-#ifdef HAS_PASSWD
- return pp_gpwent();
-#else
- DIE(aTHX_ PL_no_func, "getpwuid");
-#endif
-}
-
PP(pp_gpwent)
{
#ifdef HAS_PASSWD
dSP;
I32 which = PL_op->op_type;
register SV *sv;
- STRLEN n_a;
struct passwd *pwent = NULL;
/*
* We currently support only the SysV getsp* shadow password interface.
switch (which) {
case OP_GPWNAM:
{
- char* name = POPpbytex;
+ const char* const name = POPpbytex;
pwent = getpwnam(name);
}
break;
* has a different API than the Solaris/IRIX one. */
# if defined(HAS_GETSPNAM) && !defined(_AIX)
{
- struct spwd *spwent;
- int saverrno; /* Save and restore errno so that
+ const int saverrno = errno;
+ const struct spwd * const spwent = getspnam(pwent->pw_name);
+ /* Save and restore errno so that
* underprivileged attempts seem
* to have never made the unsccessful
* attempt to retrieve the shadow password. */
-
- saverrno = errno;
- spwent = getspnam(pwent->pw_name);
errno = saverrno;
if (spwent && spwent->sp_pwdp)
sv_setpv(sv, spwent->sp_pwdp);
}
RETURN;
#else
- DIE(aTHX_ PL_no_func, "getpwent");
+ DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
#endif
}
#endif
}
-PP(pp_ggrnam)
-{
-#ifdef HAS_GROUP
- return pp_ggrent();
-#else
- DIE(aTHX_ PL_no_func, "getgrnam");
-#endif
-}
-
-PP(pp_ggrgid)
-{
-#ifdef HAS_GROUP
- return pp_ggrent();
-#else
- DIE(aTHX_ PL_no_func, "getgrgid");
-#endif
-}
-
PP(pp_ggrent)
{
#ifdef HAS_GROUP
register char **elem;
register SV *sv;
struct group *grent;
- STRLEN n_a;
if (which == OP_GGRNAM) {
- char* name = POPpbytex;
+ const char* const name = POPpbytex;
grent = (struct group *)getgrnam(name);
}
else if (which == OP_GGRGID) {
- Gid_t gid = POPi;
+ const Gid_t gid = POPi;
grent = (struct group *)getgrgid(gid);
}
else
RETURN;
#else
- DIE(aTHX_ PL_no_func, "getgrent");
+ DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
#endif
}
unsigned long a[20];
register I32 i = 0;
I32 retval = -1;
- STRLEN n_a;
if (PL_tainting) {
while (++MARK <= SP) {
else if (*MARK == &PL_sv_undef)
a[i++] = 0;
else
- a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
+ a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
if (i > 15)
break;
}
lockf_emulate_flock(int fd, int operation)
{
int i;
- int save_errno;
+ const int save_errno = errno;
Off_t pos;
/* flock locks entire file so for lockf we need to do the same */
- save_errno = errno;
pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
if (pos > 0) /* is seekable and needs to be repositioned */
if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
* indent-tabs-mode: t
* End:
*
- * vim: shiftwidth=4:
-*/
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
https://perl5.git.perl.org / perl5.git / blobdiff