X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_sys.c;h=5fa86d62aaa965c0e3c23b37c8ccfac667986c8b;hb=23f3aea032e3289acf8e6a178372c27e8e03f4a0;hp=a95c43c94581903efc1560aa5fb3b398e13d471d;hpb=6aa016ca806d78082f3fdac943515dc35707c664;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_sys.c b/pp_sys.c index a95c43c..5fa86d6 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -29,7 +29,7 @@ * --jhi */ # ifdef __hpux__ /* There is a MAXINT coming from <- <- - * and another MAXINT from "perl.h" <- . */ + * and another MAXINT from "perl.h" <- . */ # undef MAXINT # endif # include @@ -40,8 +40,8 @@ # include #endif -#ifdef HAS_SYSCALL -#ifdef __cplusplus +#ifdef HAS_SYSCALL +#ifdef __cplusplus extern "C" int syscall(unsigned long,...); #endif #endif @@ -58,7 +58,7 @@ extern "C" int syscall(unsigned long,...); # include # if defined(USE_SOCKS) && defined(I_SOCKS) # include -# endif +# endif # ifdef I_NETDB # include # endif @@ -703,7 +703,7 @@ PP(pp_binmode) if (MAXARG > 1) discp = POPs; - gv = (GV*)POPs; + gv = (GV*)POPs; if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) { PUSHMARK(SP); @@ -722,7 +722,7 @@ PP(pp_binmode) if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) RETPUSHUNDEF; - if (do_binmode(fp,IoTYPE(io),mode_from_discipline(discp))) + if (do_binmode(fp,IoTYPE(io),mode_from_discipline(discp))) RETPUSHYES; else RETPUSHUNDEF; @@ -769,7 +769,7 @@ PP(pp_tie) PUSHs(*MARK++); PUTBACK; call_method(methname, G_SCALAR); - } + } else { /* Not clear why we don't call call_method here too. * perhaps to get different error message ? @@ -777,7 +777,7 @@ PP(pp_tie) stash = gv_stashsv(*MARK, FALSE); if (!stash || !(gv = gv_fetchmethod(stash, methname))) { DIE(aTHX_ "Can't locate object method \"%s\" via package \"%s\"", - methname, SvPV(*MARK,n_a)); + methname, SvPV(*MARK,n_a)); } ENTER; PUSHSTACKi(PERLSI_MAGIC); @@ -808,16 +808,29 @@ PP(pp_untie) SV *sv = POPs; char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q'; - if (ckWARN(WARN_UNTIE)) { MAGIC * mg ; if ((mg = SvTIED_mg(sv, how))) { - if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1) + 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(SvRV(mg->mg_obj)) - 1 ) ; + (UV)SvREFCNT(obj) - 1 ) ; } } - sv_unmagic(sv, how); RETPUSHYES; } @@ -889,7 +902,7 @@ PP(pp_dbmopen) } if (sv_isobject(TOPs)) { - sv_unmagic((SV *) hv, 'P'); + sv_unmagic((SV *) hv, 'P'); sv_magic((SV*)hv, TOPs, 'P', Nullch, 0); } LEAVE; @@ -1070,7 +1083,7 @@ PP(pp_select) else { GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE); if (gvp && *gvp == egv) { - gv_efullname4(TARG, PL_defoutgv, Nullch, FALSE); + gv_efullname4(TARG, PL_defoutgv, Nullch, TRUE); XPUSHTARG; } else { @@ -1776,7 +1789,7 @@ PP(pp_eof) PP(pp_tell) { djSP; dTARGET; - GV *gv; + GV *gv; MAGIC *mg; if (MAXARG == 0) @@ -1878,7 +1891,7 @@ PP(pp_truncate) len = (Off_t)POPi; #endif /* Checking for length < 0 is problematic as the type might or - * might not be signed: if it is not, clever compilers will moan. */ + * 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) @@ -1892,7 +1905,7 @@ PP(pp_truncate) PerlIO_flush(IoIFP(GvIOp(tmpgv))); #ifdef HAS_TRUNCATE if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0) -#else +#else if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0) #endif result = 0; @@ -1993,7 +2006,7 @@ PP(pp_ioctl) retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s); #else retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s); -#endif +#endif #else DIE(aTHX_ "fcntl is not implemented"); #endif @@ -2315,6 +2328,10 @@ PP(pp_accept) fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */ #endif +#ifdef EPOC + len = sizeof saddr; /* EPOC somehow truncates info */ +#endif + PUSHp((char *)&saddr, len); RETURN; @@ -2480,7 +2497,7 @@ PP(pp_getpeername) if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET && !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere, sizeof(u_short) + sizeof(struct in_addr))) { - goto nuts2; + goto nuts2; } } #endif @@ -2592,7 +2609,7 @@ PP(pp_stat) PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid))); # endif #endif -#if Gid_t_size > IVSIZE +#if Gid_t_size > IVSIZE PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid))); #else # if Gid_t_sign <= 0 @@ -3144,7 +3161,7 @@ PP(pp_fttext) break; } #ifdef EBCDIC - else if (!(isPRINT(*s) || isSPACE(*s))) + else if (!(isPRINT(*s) || isSPACE(*s))) odd++; #else else if (*s & 128) { @@ -3732,7 +3749,7 @@ PP(pp_fork) PP(pp_wait) { -#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) +#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) djSP; dTARGET; Pid_t childpid; int argflags; @@ -3753,7 +3770,7 @@ PP(pp_wait) PP(pp_waitpid) { -#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) +#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) djSP; dTARGET; Pid_t childpid; int optype; @@ -4547,7 +4564,7 @@ PP(pp_gprotoent) #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT) I32 which = PL_op->op_type; register char **elem; - register SV *sv; + 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); @@ -4832,7 +4849,7 @@ PP(pp_gpwent) register SV *sv; STRLEN n_a; struct passwd *pwent = NULL; - /* + /* * We currently support only the SysV getsp* shadow password interface. * The interface is declared in and often one needs to link * with -lsecurity or some such. @@ -4873,7 +4890,7 @@ PP(pp_gpwent) * * Note that is already probed for, but currently * 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 * is available) one needs to link with -lsecurity -ldb -laud -lm. @@ -4955,8 +4972,10 @@ PP(pp_gpwent) sv_setpv(sv, spwent->sp_pwdp); } # endif +# ifdef PWPASSWD if (!SvPOK(sv)) /* Use the standard password, then. */ sv_setpv(sv, pwent->pw_passwd); +# endif # ifndef INCOMPLETE_TAINTS /* passwd is tainted because user himself can diddle with it. @@ -5204,7 +5223,7 @@ PP(pp_syscall) a[i++] = SvIV(*MARK); else if (*MARK == &PL_sv_undef) a[i++] = 0; - else + else a[i++] = (unsigned long)SvPV_force(*MARK, n_a); if (i > 15) break; @@ -5272,7 +5291,7 @@ PP(pp_syscall) } #ifdef FCNTL_EMULATE_FLOCK - + /* XXX Emulate flock() with fcntl(). What's really needed is a good file locking module. */ @@ -5281,7 +5300,7 @@ static int fcntl_emulate_flock(int fd, int operation) { struct flock flock; - + switch (operation & ~LOCK_NB) { case LOCK_SH: flock.l_type = F_RDLCK; @@ -5298,7 +5317,7 @@ fcntl_emulate_flock(int fd, int operation) } flock.l_whence = SEEK_SET; flock.l_start = flock.l_len = (Off_t)0; - + return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock); }