/* pp_sys.c
*
- * Copyright (c) 1991-2001, Larry Wall
+ * Copyright (c) 1991-2002, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
SV *obj = SvRV(mg->mg_obj);
GV *gv;
CV *cv = NULL;
- if ((gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE)) &&
- isGV(gv) && (cv = GvCV(gv))) {
- PUSHMARK(SP);
- XPUSHs(SvTIED_obj((SV*)gv, mg));
- XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
- PUTBACK;
- ENTER;
- call_sv((SV *)cv, G_VOID);
- LEAVE;
- SPAGAIN;
- }
- else if (ckWARN(WARN_UNTIE)) {
- if (mg && SvREFCNT(obj) > 1)
- Perl_warner(aTHX_ WARN_UNTIE,
- "untie attempted while %"UVuf" inner references still exist",
- (UV)SvREFCNT(obj) - 1 ) ;
+ if (obj) {
+ if ((gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE)) &&
+ isGV(gv) && (cv = GvCV(gv))) {
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)gv, mg));
+ XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
+ PUTBACK;
+ ENTER;
+ call_sv((SV *)cv, G_VOID);
+ LEAVE;
+ SPAGAIN;
+ }
+ else if (ckWARN(WARN_UNTIE)) {
+ if (mg && SvREFCNT(obj) > 1)
+ Perl_warner(aTHX_ packWARN(WARN_UNTIE),
+ "untie attempted while %"UVuf" inner references still exist",
+ (UV)SvREFCNT(obj) - 1 ) ;
+ }
}
- sv_unmagic(sv, how);
+ sv_unmagic(sv, how) ;
}
RETPUSHYES;
}
}
/* little endians can use vecs directly */
-#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
-# if SELECT_MIN_BITS > 1
- /* If SELECT_MIN_BITS is greater than one we most probably will want
- * to align the sizes with SELECT_MIN_BITS/8 because for example
- * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
- * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
- * on (sets/tests/clears bits) is 32 bits. */
- growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
-# else
- growsize = sizeof(fd_set);
-# endif
-# else
+#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
# ifdef NFDBITS
# ifndef NBBY
# else
masksize = sizeof(long); /* documented int, everyone seems to use long */
# endif
- growsize = maxlen + (masksize - (maxlen % masksize));
Zero(&fd_sets[0], 4, char*);
#endif
+# if SELECT_MIN_BITS > 1
+ /* If SELECT_MIN_BITS is greater than one we most probably will want
+ * to align the sizes with SELECT_MIN_BITS/8 because for example
+ * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
+ * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
+ * on (sets/tests/clears bits) is 32 bits. */
+ growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
+# else
+ growsize = sizeof(fd_set);
+# endif
+
sv = SP[4];
if (SvOK(sv)) {
value = SvNV(sv);
{
dSP; dTARGET;
GV *gv;
- IO *io;
+ IO *io = NULL;
MAGIC *mg;
if (MAXARG == 0)
SvSetMagicSV_nosteal(TARG, TOPs);
RETURN;
}
- if (!gv || do_eof(gv)) /* make sure we have fp with something */
+ 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)))
+ report_evil_fh(gv, io, PL_op->op_type);
RETPUSHUNDEF;
+ }
TAINT;
sv_setpv(TARG, " ");
*SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
name = SvPV_nolen(sv);
}
if (name && *name)
- Perl_warner(aTHX_ WARN_IO,
+ Perl_warner(aTHX_ packWARN(WARN_IO),
"Filehandle %s opened only for input", name);
else
- Perl_warner(aTHX_ WARN_IO,
+ Perl_warner(aTHX_ packWARN(WARN_IO),
"Filehandle opened only for input");
}
else if (ckWARN(WARN_CLOSED))
else {
if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
if (ckWARN(WARN_IO))
- Perl_warner(aTHX_ WARN_IO, "page overflow");
+ Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow");
}
if (!do_print(PL_formtarget, fp))
PUSHs(&PL_sv_no);
name = SvPV_nolen(sv);
}
if (name && *name)
- Perl_warner(aTHX_ WARN_IO,
+ Perl_warner(aTHX_ packWARN(WARN_IO),
"Filehandle %s opened only for input", name);
else
- Perl_warner(aTHX_ WARN_IO,
+ Perl_warner(aTHX_ packWARN(WARN_IO),
"Filehandle opened only for input");
}
else if (ckWARN(WARN_CLOSED))
name = SvPV_nolen(sv);
}
if (name && *name)
- Perl_warner(aTHX_ WARN_IO,
+ Perl_warner(aTHX_ packWARN(WARN_IO),
"Filehandle %s opened only for output", name);
else
- Perl_warner(aTHX_ WARN_IO,
+ Perl_warner(aTHX_ packWARN(WARN_IO),
"Filehandle opened only for output");
}
goto say_undef;
if (MAXARG == 0) {
if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
IO *io;
- gv = PL_last_in_gv = PL_argvgv;
+ gv = PL_last_in_gv = GvEGV(PL_argvgv);
io = GvIO(gv);
if (io && !IoIFP(io)) {
if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
else {
SV *sv = POPs;
char *name;
-
+
if (SvTYPE(sv) == SVt_PVGV) {
tmpgv = (GV*)sv; /* *main::FRED for example */
goto do_ftruncate;
PP(pp_sockpair)
{
-#ifdef HAS_SOCKETPAIR
+#if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
dSP;
GV *gv1;
GV *gv2;
struct sockaddr saddr; /* use a struct to avoid alignment problems */
Sock_size_t len = sizeof saddr;
int fd;
+ int fd2;
ggv = (GV*)POPs;
ngv = (GV*)POPs;
if (IoIFP(nstio))
do_close(ngv, FALSE);
IoIFP(nstio) = PerlIO_fdopen(fd, "r");
- IoOFP(nstio) = PerlIO_fdopen(fd, "w");
+ /* FIXME: we dup(fd) here so that refcounting of fd's does not inhibit
+ fclose of IoOFP's FILE * - and hence leak memory.
+ Special treatment of _this_ case of IoIFP != IoOFP seems wrong.
+ */
+ IoOFP(nstio) = PerlIO_fdopen(fd2 = PerlLIO_dup(fd), "w");
IoTYPE(nstio) = IoTYPE_SOCKET;
if (!IoIFP(nstio) || !IoOFP(nstio)) {
if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
}
#if defined(HAS_FCNTL) && defined(F_SETFD)
fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
+ fcntl(fd2, F_SETFD, fd2 > PL_maxsysfd); /* ensure close-on-exec */
#endif
#ifdef EPOC
if (PL_op->op_flags & OPf_REF) {
gv = cGVOP_gv;
if (PL_op->op_type == OP_LSTAT) {
- if (PL_laststype != OP_LSTAT)
- Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
- if (ckWARN(WARN_IO) && gv != PL_defgv)
- Perl_warner(aTHX_ WARN_IO,
+ if (gv != PL_defgv) {
+ if (ckWARN(WARN_IO))
+ Perl_warner(aTHX_ packWARN(WARN_IO),
"lstat() on filehandle %s", GvENAME(gv));
- /* Perl_my_lstat (-l) croak's on filehandle, why warn here? */
+ } else if (PL_laststype != OP_LSTAT)
+ Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
}
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));
goto do_fstat;
}
sv_setpv(PL_statname, SvPV(sv,n_a));
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'))
- Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
+ Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
max = 0;
}
}
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(sv, n_a), '\n'))
- Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
+ Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
RETPUSHUNDEF;
}
PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
deprecate("chdir('') or chdir(undef) as chdir()");
tmps = SvPV(*svp, n_a);
}
- else {
+ else {
PUSHi(0);
+ TAINT_PROPER("chdir");
RETURN;
}
}
PP(pp_link)
{
- dSP;
#ifdef HAS_LINK
- dTARGET;
+ dSP; dTARGET;
STRLEN n_a;
char *tmps2 = POPpx;
char *tmps = SvPV(TOPs, n_a);
int pp[2];
I32 did_pipes = 0;
- if (SP - MARK == 1) {
- if (PL_tainting) {
- (void)SvPV_nolen(TOPs); /* stringify for taint check */
- TAINT_ENV();
+ if (PL_tainting) {
+ TAINT_ENV();
+ while (++MARK <= SP) {
+ (void)SvPV_nolen(*MARK); /* stringify for taint check */
+ if (PL_tainted)
+ break;
+ }
+ MARK = ORIGMARK;
+ /* XXX Remove warning at end of deprecation cycle --RD 2002-02 */
+ if (SP - MARK == 1) {
TAINT_PROPER("system");
}
+ else if (ckWARN2(WARN_TAINT, WARN_DEPRECATED)) {
+ Perl_warner(aTHX_ packWARN2(WARN_TAINT, WARN_DEPRECATED),
+ "Use of tainted arguments in %s is deprecated", "system");
+ }
}
PERL_FLUSHALL_FOR_CHILD;
#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
Pid_t childpid;
int status;
Sigsave_t ihand,qhand; /* place to save signals during system() */
-
- if (PL_tainting) {
- SV *cmd = NULL;
- if (PL_op->op_flags & OPf_STACKED)
- cmd = *(MARK + 1);
- else if (SP - MARK != 1)
- cmd = *SP;
- if (cmd && *(SvPV_nolen(cmd)) != '/')
- TAINT_ENV();
- }
if (PerlProc_pipe(pp) >= 0)
did_pipes = 1;
if (did_pipes) {
int errkid;
int n = 0, n1;
-
+
while (n < sizeof(int)) {
n1 = PerlLIO_read(pp[0],
(void*)(((char*)&errkid)+n),
I32 value;
STRLEN n_a;
+ if (PL_tainting) {
+ TAINT_ENV();
+ while (++MARK <= SP) {
+ (void)SvPV_nolen(*MARK); /* stringify for taint check */
+ if (PL_tainted)
+ break;
+ }
+ MARK = ORIGMARK;
+ /* XXX Remove warning at end of deprecation cycle --RD 2002-02 */
+ if (SP - MARK == 1) {
+ TAINT_PROPER("exec");
+ }
+ else if (ckWARN2(WARN_TAINT, WARN_DEPRECATED)) {
+ Perl_warner(aTHX_ packWARN2(WARN_TAINT, WARN_DEPRECATED),
+ "Use of tainted arguments in %s is deprecated", "exec");
+ }
+ }
PERL_FLUSHALL_FOR_CHILD;
if (PL_op->op_flags & OPf_STACKED) {
SV *really = *++MARK;
# endif
#endif
else {
- if (PL_tainting) {
- (void)SvPV_nolen(*SP); /* stringify for taint check */
- TAINT_ENV();
- TAINT_PROPER("exec");
- }
#ifdef VMS
value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
#else
it's supported. --AD 9/96.
*/
+#ifdef __BEOS__
+# define HZ 1000000
+#endif
+
#ifndef HZ
# ifdef CLK_TCK
# define HZ CLK_TCK
register char **elem;
register SV *sv;
#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
- struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
- struct hostent *PerlSock_gethostbyname(Netdb_name_t);
- struct hostent *PerlSock_gethostent(void);
+ struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
+ struct hostent *gethostbyname(Netdb_name_t);
+ struct hostent *gethostent(void);
#endif
struct hostent *hent;
unsigned long len;
register char **elem;
register SV *sv;
#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
- struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
- struct netent *PerlSock_getnetbyname(Netdb_name_t);
- struct netent *PerlSock_getnetent(void);
+ struct netent *getnetbyaddr(Netdb_net_t, int);
+ struct netent *getnetbyname(Netdb_name_t);
+ struct netent *getnetent(void);
#endif
struct netent *nent;
STRLEN n_a;
register char **elem;
register SV *sv;
#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
- struct protoent *PerlSock_getprotobyname(Netdb_name_t);
- struct protoent *PerlSock_getprotobynumber(int);
- struct protoent *PerlSock_getprotoent(void);
+ struct protoent *getprotobyname(Netdb_name_t);
+ struct protoent *getprotobynumber(int);
+ struct protoent *getprotoent(void);
#endif
struct protoent *pent;
STRLEN n_a;
register char **elem;
register SV *sv;
#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
- struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
- struct servent *PerlSock_getservbyport(int, Netdb_name_t);
- struct servent *PerlSock_getservent(void);
+ struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
+ struct servent *getservbyport(int, Netdb_name_t);
+ struct servent *getservent(void);
#endif
struct servent *sent;
STRLEN n_a;
https://perl5.git.perl.org / perl5.git / blobdiff