# 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
# 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>
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 *tmps = POPpconstx;
+ const I32 gimme = GIMME_V;
+ const char *mode = "r";
TAINT_PROPER("``");
if (PL_op->op_private & OPpOPEN_IN_RAW)
mode = "rb";
else if (PL_op->op_private & OPpOPEN_IN_CRLF)
mode = "rt";
- fp = PerlProc_popen(tmps, mode);
+ fp = PerlProc_popen((char*)tmps, (char *)mode);
if (fp) {
- char *type = NULL;
+ const char *type = NULL;
if (PL_curcop->cop_io) {
type = SvPV_nolen(PL_curcop->cop_io);
}
;
}
else if (gimme == G_SCALAR) {
- SV *oldrs = PL_rs;
+ 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*/
;
- PL_rs = oldrs;
+ LEAVE;
XPUSHs(TARG);
SvTAINTED_on(TARG);
}
}
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);
}
PP(pp_glob)
{
+ dVAR;
OP *result;
tryAMAGICunTARGET(iter, -1);
{
dSP; dMARK;
SV *tmpsv;
- char *tmps;
+ const char *tmps;
STRLEN len;
if (SP - MARK != 1) {
dTARGET;
tmps = SvPV(tmpsv, len);
if ((!tmps || !len) && PL_errgv) {
SV *error = ERRSV;
- (void)SvUPGRADE(error, SVt_PV);
+ SvUPGRADE(error, SVt_PV);
if (SvPOK(error) && SvCUR(error))
sv_catpv(error, "\t...caught");
tmpsv = error;
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);
+ SvUPGRADE(error, SVt_PV);
if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
if (!multiarg)
SvSetSV(error,tmpsv);
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;
sv = GvSV(gv);
}
- tmps = SvPV(sv, len);
- ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp, MARK+1, (SP-MARK));
+ tmps = SvPV_const(sv, len);
+ ok = do_openn(gv, (char *)tmps, len, FALSE, O_RDONLY, 0, Nullfp, MARK+1, (SP-MARK));
SP = ORIGMARK;
if (ok)
PUSHi( (I32)PL_forkprocess );
PP(pp_close)
{
- dSP;
+ dVAR; dSP;
GV *gv;
IO *io;
MAGIC *mg;
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;
PP(pp_tie)
{
- dSP;
- dMARK;
+ dVAR; dSP; dMARK;
SV *varsv;
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;
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)))
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)))
PP(pp_dbmopen)
{
- dSP;
+ dVAR; dSP;
HV *hv;
dPOPPOPssrl;
HV* stash;
}
}
- PUSHi(nfound);
+ if (nfound == -1)
+ PUSHs(&PL_sv_undef);
+ else
+ PUSHi(nfound);
if (GIMME == G_ARRAY && tbuf) {
value = (NV)(timebuf.tv_sec) +
(NV)(timebuf.tv_usec) / 1000000.0;
PP(pp_select)
{
dSP; dTARGET;
- GV *newdefout, *egv;
+ GV *egv;
HV *hv;
- newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
+ GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
egv = GvEGV(PL_defoutgv);
if (!egv)
PP(pp_getc)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
GV *gv;
IO *io = NULL;
MAGIC *mg;
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;
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);
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;
cv = GvFORM(fgv);
if (!cv) {
- char *name = NULL;
if (fgv) {
- SV *tmpsv = sv_newmortal();
+ SV * const tmpsv = sv_newmortal();
+ char *name;
gv_efullname4(tmpsv, fgv, Nullch, FALSE);
name = SvPV_nolen(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;
+ dVAR; dSP;
GV *gv = cxstack[cxstack_ix].blk_sub.gv;
register IO *io = GvIOp(gv);
PerlIO *ofp = IoOFP(io);
}
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(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);
PP(pp_prtf)
{
- dSP; dMARK; dORIGMARK;
+ dVAR; dSP; dMARK; dORIGMARK;
GV *gv;
IO *io;
PerlIO *fp;
SV *sv;
char *tmps;
STRLEN len;
- int mode, perm;
+ const int perm = (MAXARG > 3) ? POPi : 0666;
+ const int mode = POPi;
- if (MAXARG > 3)
- perm = POPi;
- else
- perm = 0666;
- mode = POPi;
sv = POPs;
gv = (GV *)POPs;
PP(pp_sysread)
{
- dSP; dMARK; dORIGMARK; dTARGET;
+ dVAR; dSP; dMARK; dORIGMARK; dTARGET;
int offset;
GV *gv;
IO *io;
(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 */
PP(pp_syswrite)
{
- dSP;
- int items = (SP - PL_stack_base) - TOPMARK;
+ dVAR; dSP;
+ const int items = (SP - PL_stack_base) - TOPMARK;
if (items == 2) {
SV *sv;
EXTEND(SP, 1);
PP(pp_send)
{
- dSP; dMARK; dORIGMARK; dTARGET;
+ dVAR; dSP; dMARK; dORIGMARK; dTARGET;
GV *gv;
IO *io;
SV *bufsv;
}
#ifdef HAS_SOCKET
else if (SP > MARK) {
- char *sockbuf;
STRLEN mlen;
- sockbuf = SvPVx(*++MARK, mlen);
+ char * const sockbuf = SvPVx(*++MARK, mlen);
/* length is really flags */
retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
length, (struct sockaddr *)sockbuf, mlen);
PP(pp_eof)
{
- dSP;
+ dVAR; dSP;
GV *gv;
IO *io;
MAGIC *mg;
if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
IoLINES(io) = 0;
IoFLAGS(io) &= ~IOf_START;
- do_open(gv, "-", 1, FALSE, O_RDONLY, 0, Nullfp);
+ do_open(gv, (char *)"-", 1, FALSE, O_RDONLY, 0, Nullfp);
sv_setpvn(GvSV(gv), "-", 1);
SvSETMAGIC(GvSV(gv));
}
PP(pp_tell)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
GV *gv;
IO *io;
MAGIC *mg;
PP(pp_sysseek)
{
- dSP;
+ dVAR; dSP;
GV *gv;
IO *io;
- int whence = POPi;
+ const int whence = POPi;
#if LSEEKSIZE > IVSIZE
Off_t offset = (Off_t)SvNVx(POPs);
#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;
SETERRNO(EBADF,RMS_IFI);
RETPUSHUNDEF;
}
-#else
- DIE(aTHX_ "truncate not implemented");
-#endif
}
PP(pp_fcntl)
{
dSP; dTARGET;
SV *argsv = POPs;
- unsigned int func = POPu;
- int optype = PL_op->op_type;
+ const unsigned int func = POPu;
+ const int optype = PL_op->op_type;
char *s;
IV retval;
GV *gv = (GV*)POPs;
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);
}
"lstat() on filehandle %s", GvENAME(gv));
goto do_fstat;
}
- sv_setpv(PL_statname, SvPV(sv,n_a));
+ sv_setpv(PL_statname, SvPV_const(sv,n_a));
PL_statgv = Nullgv;
-#ifdef HAS_LSTAT
PL_laststype = PL_op->op_type;
if (PL_op->op_type == OP_LSTAT)
PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
else
-#endif
PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
if (PL_laststatval < 0) {
if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
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 (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
RETPUSHUNDEF;
PP(pp_chdir)
{
dSP; dTARGET;
- char *tmps;
+ const char *tmps;
SV **svp;
STRLEN n_a;
if( MAXARG == 1 )
- tmps = POPpx;
+ tmps = POPpconstx;
else
tmps = 0;
{
if( MAXARG == 1 )
deprecate("chdir('') or chdir(undef) as chdir()");
- tmps = SvPV(*svp, n_a);
+ tmps = SvPV_const(*svp, n_a);
}
else {
PUSHi(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;
* -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)--; \
int oldumask;
#endif
STRLEN len;
- char *tmps;
+ const char *tmps;
bool copy = FALSE;
if (MAXARG > 1)
{
dSP; dTARGET;
STRLEN len;
- char *tmps;
+ const char *tmps;
bool copy = FALSE;
TRIMSLASHES(tmps,len,copy);
dSP;
SV *sv;
- I32 gimme = GIMME;
+ const I32 gimme = GIMME;
GV *gv = (GV *)POPs;
register Direntry_t *dp;
register IO *io = GvIOn(gv);
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.
I32 value;
STRLEN n_a;
int result;
- I32 did_pipes = 0;
if (PL_tainting) {
TAINT_ENV();
{
Pid_t childpid;
int pp[2];
+ I32 did_pipes = 0;
if (PerlProc_pipe(pp) >= 0)
did_pipes = 1;
result = 0;
if (PL_op->op_flags & OPf_STACKED) {
SV *really = *++MARK;
-# if defined(WIN32) || defined(OS2)
+# if defined(WIN32) || defined(OS2) || defined(SYMBIAN)
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(SYMBIAN)
value = (I32)do_aspawn(Nullsv, MARK, SP);
# else
value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
#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() );
{
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);
* indent-tabs-mode: t
* End:
*
- * vim: expandtab shiftwidth=4:
-*/
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */