#include "EXTERN.h"
#define PERL_IN_PP_SYS_C
#include "perl.h"
-#if !defined(PERL_MICRO) && defined(Quad_t)
-# include "time64.h"
-# include "time64.c"
-#endif
+#include "time64.h"
+#include "time64.c"
#ifdef I_SHADOW
/* Shadow password support for solaris - pdo@cs.umd.edu
const Gid_t egid = getegid();
int res;
- LOCK_CRED_MUTEX;
#if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
Perl_croak(aTHX_ "switching effective uid is not implemented");
#else
#endif
#endif
Perl_croak(aTHX_ "leaving effective gid failed");
- UNLOCK_CRED_MUTEX;
return res;
}
NOOP;
}
else if (gimme == G_SCALAR) {
- ENTER;
+ ENTER_with_name("backtick");
SAVESPTR(PL_rs);
PL_rs = &PL_sv_undef;
sv_setpvs(TARG, ""); /* note that this preserves previous buffer */
while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
NOOP;
- LEAVE;
+ LEAVE_with_name("backtick");
XPUSHs(TARG);
SvTAINTED_on(TARG);
}
* without at the same time croaking, for some reason, or if
* perl was built with PERL_EXTERNAL_GLOB */
- ENTER;
+ ENTER_with_name("glob");
#ifndef VMS
if (PL_tainting) {
#endif /* !DOSISH */
result = do_readline();
- LEAVE;
+ LEAVE_with_name("glob");
return result;
}
tmpsv = newSVpvs_flags("Died", SVs_TEMP);
DIE(aTHX_ "%"SVf, SVfARG(tmpsv));
+ RETURN;
}
/* I/O. */
MAGIC *mg;
IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
- if (IoDIRP(io) && ckWARN2(WARN_IO, WARN_DEPRECATED))
- Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
- "Opening dirhandle %s also as a file", GvENAME(gv));
+ if (IoDIRP(io))
+ Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
+ "Opening dirhandle %s also as a file",
+ GvENAME(gv));
mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
*MARK-- = SvTIED_obj(MUTABLE_SV(io), mg);
PUSHMARK(MARK);
PUTBACK;
- ENTER;
+ ENTER_with_name("call_OPEN");
call_method("OPEN", G_SCALAR);
- LEAVE;
+ LEAVE_with_name("call_OPEN");
SPAGAIN;
RETURN;
}
PUSHMARK(SP);
XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
PUTBACK;
- ENTER;
+ ENTER_with_name("call_CLOSE");
call_method("CLOSE", G_SCALAR);
- LEAVE;
+ LEAVE_with_name("call_CLOSE");
SPAGAIN;
RETURN;
}
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_func, "pipe");
+ return NORMAL;
#endif
}
PUSHMARK(SP);
XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
PUTBACK;
- ENTER;
+ ENTER_with_name("call_FILENO");
call_method("FILENO", G_SCALAR);
- LEAVE;
+ LEAVE_with_name("call_FILENO");
SPAGAIN;
RETURN;
}
if (discp)
XPUSHs(discp);
PUTBACK;
- ENTER;
+ ENTER_with_name("call_BINMODE");
call_method("BINMODE", G_SCALAR);
- LEAVE;
+ LEAVE_with_name("call_BINMODE");
SPAGAIN;
RETURN;
}
break;
case SVt_PVGV:
if (isGV_with_GP(varsv)) {
-#ifdef GV_UNIQUE_CHECK
- if (GvUNIQUE((const GV *)varsv)) {
- Perl_croak(aTHX_ "Attempt to tie unique GV");
- }
-#endif
methname = "TIEHANDLE";
how = PERL_MAGIC_tiedscalar;
/* For tied filehandles, we apply tiedscalar magic to the IO
}
items = SP - MARK++;
if (sv_isobject(*MARK)) { /* Calls GET magic. */
- ENTER;
+ ENTER_with_name("call_TIE");
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
EXTEND(SP,(I32)items);
DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
}
- ENTER;
+ ENTER_with_name("call_TIE");
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
EXTEND(SP,(I32)items);
"Self-ties of arrays and hashes are not supported");
sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
}
- LEAVE;
+ LEAVE_with_name("call_TIE");
SP = PL_stack_base + markoff;
PUSHs(sv);
RETURN;
XPUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
mXPUSHi(SvREFCNT(obj) - 1);
PUTBACK;
- ENTER;
+ ENTER_with_name("call_UNTIE");
call_sv(MUTABLE_SV(cv), G_VOID);
- LEAVE;
+ LEAVE_with_name("call_UNTIE");
SPAGAIN;
}
- 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 ) ;
+ else if (mg && SvREFCNT(obj) > 1) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
+ "untie attempted while %"UVuf" inner references still exist",
+ (UV)SvREFCNT(obj) - 1 ) ;
}
}
}
DIE(aTHX_ "%s", PL_no_modify);
}
if (!SvPOK(sv)) {
- if (ckWARN(WARN_MISC))
- Perl_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
SvPV_force_nolen(sv); /* force string conversion */
}
j = SvCUR(sv);
RETURN;
#else
DIE(aTHX_ "select not implemented");
+ return NORMAL;
#endif
}
{
dVAR;
SvREFCNT_inc_simple_void(gv);
- if (PL_defoutgv)
- SvREFCNT_dec(PL_defoutgv);
+ SvREFCNT_dec(PL_defoutgv);
PL_defoutgv = gv;
}
}
else {
if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
- if (ckWARN(WARN_IO))
- Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow");
+ Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
}
if (!do_print(PL_formtarget, fp))
PUSHs(&PL_sv_no);
DIE(aTHX_ "Offset outside string");
}
offset += blen_chars;
- } else if (offset >= (IV)blen_chars && blen_chars > 0) {
+ } else if (offset > (IV)blen_chars) {
Safefree(tmpbuf);
DIE(aTHX_ "Offset outside string");
}
RETURN;
}
}
+ else if (!gv) {
+ if (!errno)
+ SETERRNO(EBADF,RMS_IFI);
+ PUSHi(-1);
+ RETURN;
+ }
#if LSEEKSIZE > IVSIZE
PUSHn( do_tell(gv) );
RETURN;
#else
DIE(aTHX_ PL_no_func, "flock()");
+ return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_sock_func, "socket");
+ return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_sock_func, "socketpair");
+ return NORMAL;
#endif
}
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_sock_func, "bind");
+ return NORMAL;
#endif
}
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_sock_func, "connect");
+ return NORMAL;
#endif
}
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_sock_func, "listen");
+ return NORMAL;
#endif
}
#else
DIE(aTHX_ PL_no_sock_func, "accept");
+ return NORMAL;
#endif
}
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_sock_func, "shutdown");
+ return NORMAL;
#endif
}
#else
DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
+ return NORMAL;
#endif
}
#else
DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
+ return NORMAL;
#endif
}
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", gv ? GvENAME(gv) : "");
+ Perl_ck_warner(aTHX_ packWARN(WARN_IO),
+ "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
} else if (PL_laststype != OP_LSTAT)
Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
}
PP(pp_ftlink)
{
dVAR;
- I32 result;
dSP;
+ I32 result;
tryAMAGICftest('l');
result = my_lstat();
+ SPAGAIN;
+
if (result < 0)
RETPUSHUNDEF;
if (S_ISLNK(PL_statcache.st_mode))
RETURN;
#else
DIE(aTHX_ PL_no_func, "chroot");
+ return NORMAL;
#endif
}
{
/* Have neither. */
DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
+ return NORMAL;
}
#endif
if (!io)
goto nope;
- if ((IoIFP(io) || IoOFP(io)) && ckWARN2(WARN_IO, WARN_DEPRECATED))
- Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
- "Opening filehandle %s also as a directory", GvENAME(gv));
+ if ((IoIFP(io) || IoOFP(io)))
+ Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
+ "Opening filehandle %s also as a directory",
+ GvENAME(gv));
if (IoDIRP(io))
PerlDir_close(IoDIRP(io));
if (!(IoDIRP(io) = PerlDir_open(dirname)))
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_dir_func, "opendir");
+ return NORMAL;
#endif
}
{
#if !defined(Direntry_t) || !defined(HAS_READDIR)
DIE(aTHX_ PL_no_dir_func, "readdir");
+ return NORMAL;
#else
#if !defined(I_DIRENT) && !defined(VMS)
Direntry_t *readdir (DIR *);
register IO * const io = GvIOn(gv);
if (!io || !IoDIRP(io)) {
- if(ckWARN(WARN_IO)) {
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
- }
+ Perl_ck_warner(aTHX_ packWARN(WARN_IO),
+ "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
goto nope;
}
register IO * const io = GvIOn(gv);
if (!io || !IoDIRP(io)) {
- if(ckWARN(WARN_IO)) {
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
- }
+ Perl_ck_warner(aTHX_ packWARN(WARN_IO),
+ "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
goto nope;
}
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_dir_func, "telldir");
+ return NORMAL;
#endif
}
register IO * const io = GvIOn(gv);
if (!io || !IoDIRP(io)) {
- if(ckWARN(WARN_IO)) {
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
- }
+ Perl_ck_warner(aTHX_ packWARN(WARN_IO),
+ "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
goto nope;
}
(void)PerlDir_seek(IoDIRP(io), along);
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_dir_func, "seekdir");
+ return NORMAL;
#endif
}
register IO * const io = GvIOn(gv);
if (!io || !IoDIRP(io)) {
- if(ckWARN(WARN_IO)) {
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
- }
+ Perl_ck_warner(aTHX_ packWARN(WARN_IO),
+ "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
goto nope;
}
(void)PerlDir_rewind(IoDIRP(io));
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_dir_func, "rewinddir");
+ return NORMAL;
#endif
}
register IO * const io = GvIOn(gv);
if (!io || !IoDIRP(io)) {
- if(ckWARN(WARN_IO)) {
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
- }
+ Perl_ck_warner(aTHX_ packWARN(WARN_IO),
+ "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
goto nope;
}
#ifdef VOID_CLOSEDIR
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_dir_func, "closedir");
+ return NORMAL;
#endif
}
RETURN;
# else
DIE(aTHX_ PL_no_func, "fork");
+ return NORMAL;
# endif
#endif
}
PP(pp_wait)
{
-#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
dVAR; dSP; dTARGET;
Pid_t childpid;
int argflags;
RETURN;
#else
DIE(aTHX_ PL_no_func, "wait");
+ return NORMAL;
#endif
}
PP(pp_waitpid)
{
-#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
dVAR; dSP; dTARGET;
const int optype = POPi;
const Pid_t pid = TOPi;
RETURN;
#else
DIE(aTHX_ PL_no_func, "waitpid");
+ return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "getppid");
+ return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "getpgrp()");
+ return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "setpgrp()");
+ return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "getpriority()");
+ return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "setpriority()");
+ return NORMAL;
#endif
}
RETURN;
# else
DIE(aTHX_ "times not implemented");
+ return NORMAL;
# endif
#endif /* HAS_TIMES */
}
{
dVAR;
dSP;
-#if defined(PERL_MICRO) || !defined(Quad_t)
- Time_t when;
- const struct tm *err;
- struct tm tmbuf;
-#else
Time64_T when;
struct TM tmbuf;
struct TM *err;
-#endif
const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
static const char * const dayname[] =
{"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
{"Jan", "Feb", "Mar", "Apr", "May", "Jun",
"Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
-#if defined(PERL_MICRO) || !defined(Quad_t)
- if (MAXARG < 1)
- (void)time(&when);
- else
- when = (Time_t)SvIVx(POPs);
-
- if (PL_op->op_type == OP_LOCALTIME)
- err = localtime(&when);
- else
- err = gmtime(&when);
-
- if (!err)
- tmbuf = *err;
-#else
if (MAXARG < 1) {
time_t now;
(void)time(&now);
when = (Time64_T)now;
}
else {
- /* XXX POPq uses an SvIV so it won't work with 32 bit integer scalars
- using a double causes an unfortunate loss of accuracy on high numbers.
- What we really need is an SvQV.
- */
double input = Perl_floor(POPn);
when = (Time64_T)input;
- if (when != input && ckWARN(WARN_OVERFLOW)) {
- Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
- "%s(%.0f) too large", opname, input);
+ if (when != input) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
+ "%s(%.0f) too large", opname, input);
}
}
if (PL_op->op_type == OP_LOCALTIME)
- err = localtime64_r(&when, &tmbuf);
+ err = S_localtime64_r(&when, &tmbuf);
else
- err = gmtime64_r(&when, &tmbuf);
-#endif
+ err = S_gmtime64_r(&when, &tmbuf);
- if (err == NULL && ckWARN(WARN_OVERFLOW)) {
+ if (err == NULL) {
/* XXX %lld broken for quads */
- Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
- "%s(%.0f) failed", opname, (double)when);
+ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
+ "%s(%.0f) failed", opname, (double)when);
}
if (GIMME != G_ARRAY) { /* scalar context */
RETURN;
#else
DIE(aTHX_ PL_no_func, "alarm");
+ return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ "System V IPC is not implemented on this machine");
+ return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_sock_func, "gethostent");
+ return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_sock_func, "getnetent");
+ return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_sock_func, "getprotoent");
+ return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_sock_func, "getservent");
+ return NORMAL;
#endif
}
RETSETYES;
#else
DIE(aTHX_ PL_no_sock_func, "sethostent");
+ return NORMAL;
#endif
}
RETSETYES;
#else
DIE(aTHX_ PL_no_sock_func, "setnetent");
+ return NORMAL;
#endif
}
RETSETYES;
#else
DIE(aTHX_ PL_no_sock_func, "setprotoent");
+ return NORMAL;
#endif
}
RETSETYES;
#else
DIE(aTHX_ PL_no_sock_func, "setservent");
+ return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_sock_func, "endhostent");
+ return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_sock_func, "endnetent");
+ return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_sock_func, "endprotoent");
+ return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_sock_func, "endservent");
+ return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
+ return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_func, "setpwent");
+ return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_func, "endpwent");
+ return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
+ return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_func, "setgrent");
+ return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_func, "endgrent");
+ return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "getlogin");
+ return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "syscall");
+ return NORMAL;
#endif
}