X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/8d629a78e79c19651f98fd50647911d78b7de698..6987f4434e4dfee71506125954ee1ae41c46f1cb:/pp_sys.c diff --git a/pp_sys.c b/pp_sys.c index 4ae475d..5c9f768 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -213,8 +213,8 @@ void endservent(void); #endif #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF) - /* AIX */ -# define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF)) + /* AIX's accessx() doesn't declare its argument const, unlike every other platform */ +# define PERL_EFF_ACCESS(p,f) (accessx((char*)(p), (f), ACC_SELF)) #endif @@ -498,7 +498,7 @@ PP(pp_die) } } } - else if (SvPOK(errsv) && SvCUR(errsv)) { + else if (SvOK(errsv) && (SvPV_nomg(errsv,len), len)) { exsv = sv_mortalcopy(errsv); sv_catpvs(exsv, "\t...propagated"); } @@ -1293,7 +1293,7 @@ PP(pp_sselect) /* -=head1 GV Functions +=for apidoc_section $GV =for apidoc setdefout @@ -1725,10 +1725,9 @@ PP(pp_sysread) if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) { if (PL_op->op_type == OP_SYSREAD || PL_op->op_type == OP_RECV) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "%s() is deprecated on :utf8 handles. " - "This will be a fatal error in Perl 5.30", - OP_DESC(PL_op)); + Perl_croak(aTHX_ + "%s() isn't allowed on :utf8 handles", + OP_DESC(PL_op)); } buffer = SvPVutf8_force(bufsv, blen); /* UTF-8 may not have been set if they are all low bytes */ @@ -1737,7 +1736,7 @@ PP(pp_sysread) } else { buffer = SvPV_force(bufsv, blen); - buffer_utf8 = !IN_BYTES && SvUTF8(bufsv); + buffer_utf8 = DO_UTF8(bufsv); } if (DO_UTF8(bufsv)) { blen = sv_len_utf8_nomg(bufsv); @@ -1939,7 +1938,6 @@ PP(pp_syswrite) const char *buffer; SSize_t retval; STRLEN blen; - STRLEN orig_blen_bytes; const int op_type = PL_op->op_type; bool doing_utf8; U8 *tmpbuf = NULL; @@ -1985,20 +1983,12 @@ PP(pp_syswrite) /* Do this first to trigger any overloading. */ buffer = SvPV_const(bufsv, blen); - orig_blen_bytes = blen; doing_utf8 = DO_UTF8(bufsv); if (PerlIO_isutf8(IoIFP(io))) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "%s() is deprecated on :utf8 handles. " - "This will be a fatal error in Perl 5.30", - OP_DESC(PL_op)); - if (!SvUTF8(bufsv)) { - /* We don't modify the original scalar. */ - tmpbuf = bytes_to_utf8((const U8*) buffer, &blen); - buffer = (char *) tmpbuf; - doing_utf8 = TRUE; - } + Perl_croak(aTHX_ + "%s() isn't allowed on :utf8 handles", + OP_DESC(PL_op)); } else if (doing_utf8) { STRLEN tmplen = blen; @@ -2031,25 +2021,10 @@ PP(pp_syswrite) #endif { Size_t length = 0; /* This length is in characters. */ - STRLEN blen_chars; IV offset; - if (doing_utf8) { - if (tmpbuf) { - /* The SV is bytes, and we've had to upgrade it. */ - blen_chars = orig_blen_bytes; - } else { - /* The SV really is UTF-8. */ - /* Don't call sv_len_utf8 on a magical or overloaded - scalar, as we might get back a different result. */ - blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen); - } - } else { - blen_chars = blen; - } - if (MARK >= SP) { - length = blen_chars; + length = blen; } else { #if Size_t_size > IVSIZE length = (Size_t)SvNVx(*++MARK); @@ -2065,46 +2040,21 @@ PP(pp_syswrite) if (MARK < SP) { offset = SvIVx(*++MARK); if (offset < 0) { - if (-offset > (IV)blen_chars) { + if (-offset > (IV)blen) { Safefree(tmpbuf); DIE(aTHX_ "Offset outside string"); } - offset += blen_chars; - } else if (offset > (IV)blen_chars) { + offset += blen; + } else if (offset > (IV)blen) { Safefree(tmpbuf); DIE(aTHX_ "Offset outside string"); } } else offset = 0; - if (length > blen_chars - offset) - length = blen_chars - offset; - if (doing_utf8) { - /* Here we convert length from characters to bytes. */ - if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) { - /* Either we had to convert the SV, or the SV is magical, or - the SV has overloading, in which case we can't or mustn't - or mustn't call it again. */ - - buffer = (const char*)utf8_hop((const U8 *)buffer, offset); - length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer; - } else { - /* It's a real UTF-8 SV, and it's not going to change under - us. Take advantage of any cache. */ - I32 start = offset; - I32 len_I32 = length; - - /* Convert the start and end character positions to bytes. - Remember that the second argument to sv_pos_u2b is relative - to the first. */ - sv_pos_u2b(bufsv, &start, &len_I32); - - buffer += start; - length = len_I32; - } - } - else { - buffer = buffer+offset; - } + if (length > blen - offset) + length = blen - offset; + buffer = buffer+offset; + #ifdef PERL_SOCK_SYSWRITE_IS_SEND if (IoTYPE(io) == IoTYPE_SOCKET) { retval = PerlSock_send(fd, buffer, length, 0); @@ -2120,8 +2070,6 @@ PP(pp_syswrite) if (retval < 0) goto say_undef; SP = ORIGMARK; - if (doing_utf8) - retval = utf8_length((U8*)buffer, (U8*)buffer + retval); Safefree(tmpbuf); #if Size_t_size > IVSIZE @@ -2173,7 +2121,7 @@ PP(pp_eof) } if (!gv) - RETPUSHNO; + RETPUSHYES; if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) { return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which)); @@ -2181,7 +2129,7 @@ PP(pp_eof) if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */ if (io && !IoIFP(io)) { - if ((IoFLAGS(io) & IOf_START) && av_tindex(GvAVn(gv)) < 0) { + if ((IoFLAGS(io) & IOf_START) && av_count(GvAVn(gv)) == 0) { SV ** svp; IoLINES(io) = 0; IoFLAGS(io) &= ~IOf_START; @@ -2231,9 +2179,9 @@ PP(pp_tell) } #if LSEEKSIZE > IVSIZE - PUSHn( do_tell(gv) ); + PUSHn( (NV)do_tell(gv) ); #else - PUSHi( do_tell(gv) ); + PUSHi( (IV)do_tell(gv) ); #endif RETURN; } @@ -2757,30 +2705,16 @@ PP(pp_ssockopt) PUSHs(sv); break; case OP_SSOCKOPT: { -#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; + const char *buf; int aint; if (SvPOKp(sv)) { STRLEN l; - buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l); + buf = SvPV_const(sv, l); len = l; } else { aint = (int)SvIV(sv); - buf = (SETSOCKOPT_OPTION_VALUE_T) &aint; + buf = (const char *) &aint; len = sizeof(int); } if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0) @@ -2815,9 +2749,13 @@ PP(pp_getpeername) if (!IoIFP(io)) goto nuts; - sv = sv_2mortal(newSV(257)); - (void)SvPOK_only(sv); +#ifdef HAS_SOCKADDR_STORAGE + len = sizeof(struct sockaddr_storage); +#else len = 256; +#endif + sv = sv_2mortal(newSV(len+1)); + (void)SvPOK_only(sv); SvCUR_set(sv, len); *SvEND(sv) ='\0'; fd = PerlIO_fileno(IoIFP(io)); @@ -3129,7 +3067,7 @@ S_try_amagic_ftest(pTHX_ char chr) { SV *const arg = *PL_stack_sp; assert(chr != '?'); - if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg); + if (!(PL_op->op_private & OPpFT_STACKED)) SvGETMAGIC(arg); if (SvAMAGIC(arg)) { @@ -3876,8 +3814,7 @@ PP(pp_readlink) len = readlink(tmps, buf, sizeof(buf) - 1); if (len < 0) RETPUSHUNDEF; - if (len != -1) - buf[len] = '\0'; + buf[len] = '\0'; PUSHp(buf, len); RETURN; #else @@ -4543,14 +4480,14 @@ PP(pp_system) result = 0; if (PL_op->op_flags & OPf_STACKED) { SV * const really = *++MARK; -# if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS) +# if defined(WIN32) || defined(OS2) || defined(__VMS) 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) || defined(__SYMBIAN32__) || defined(__VMS) +# if defined(WIN32) || defined(OS2) || defined(__VMS) value = (I32)do_aspawn(NULL, MARK, SP); # else value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP); @@ -4672,6 +4609,11 @@ PP(pp_setpgrp) #endif } +/* + * The glibc headers typedef __priority_which_t to an enum under C, but + * under C++, it keeps it as int. -Wc++-compat doesn't know this, so we + * need to explicitly cast it to shut up the warning. + */ #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2)) # define PRIORITY_WHICH_T(which) (__priority_which_t)which #else @@ -4714,9 +4656,9 @@ PP(pp_time) { dSP; dTARGET; #ifdef BIG_TIME - XPUSHn( time(NULL) ); + XPUSHn( (NV)time(NULL) ); #else - XPUSHi( time(NULL) ); + XPUSHu( (UV)time(NULL) ); #endif RETURN; } @@ -4916,7 +4858,7 @@ PP(pp_sleep) } } (void)time(&when); - XPUSHi(when - lasttime); + XPUSHu((UV)(when - lasttime)); RETURN; } @@ -5332,8 +5274,8 @@ PP(pp_shostent) DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); #endif break; -#ifdef HAS_SETNETENT case OP_SNETENT: +#ifdef HAS_SETNETENT PerlSock_setnetent(stayopen); #else DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); @@ -5485,7 +5427,7 @@ PP(pp_gpwent) * it is only included in special cases. * * In Digital UNIX/Tru64 if using the getespw*() (which seems to be - * be preferred interface, even though also the getprpw*() interface + * the preferred interface, even though also the getprpw*() interface * is available) one needs to link with -lsecurity -ldb -laud -lm. * One also needs to call set_auth_parameters() in main() before * doing anything else, whether one is using getespw*() or getprpw*().