From: Perl 5 Porters Date: Thu, 25 Jul 1996 20:32:41 +0000 (+0000) Subject: perl 5.003_01: pp_sys.c X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=cbdc8872ffece705964522f9a9d92e9a36b58bfc;p=p5sagit%2Fp5-mst-13.2.git perl 5.003_01: pp_sys.c Use home-grown name for chsize() to avoid possible collision with function which exists in system libraries but isn't used Support home-grown analogue to binmode() Give debugger access to function call executing "tie" and "dbmopen" Implement strict untie Add casts to reflect new GV type Allow redirection of debug messages Fix handling of file truncation Handle missing rdev field in struct stat Handle 64-bit time values --- diff --git a/pp_sys.c b/pp_sys.c index ba1f105..ee51347 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -89,6 +89,11 @@ extern int h_errno; #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR) static int dooneliner _((char *cmd, char *filename)); #endif + +#ifdef HAS_CHSIZE +# define my_chsize chsize +#endif + /* Pushy I/O. */ PP(pp_backtick) @@ -376,8 +381,16 @@ PP(pp_binmode) RETPUSHUNDEF; #endif #else +#if defined(USEMYBINMODE) + if (my_binmode(fp,IoTYPE(io)) != NULL) + RETPUSHYES; + else + RETPUSHUNDEF; +#else RETPUSHYES; #endif +#endif + } PP(pp_tie) @@ -415,8 +428,10 @@ PP(pp_tie) ENTER; SAVESPTR(op); op = (OP *) &myop; + if (perldb && curstash != debstash) + op->op_private |= OPpENTERSUB_DB; - XPUSHs(gv); + XPUSHs((SV*)gv); PUTBACK; if (op = pp_entersub()) @@ -443,10 +458,28 @@ PP(pp_tie) PP(pp_untie) { dSP; - if (SvTYPE(TOPs) == SVt_PVHV || SvTYPE(TOPs) == SVt_PVAV) - sv_unmagic(TOPs, 'P'); + SV * sv ; + + sv = POPs; + if (hints & HINT_STRICT_UNTIE) + { + MAGIC * mg ; + if (SvMAGICAL(sv)) { + if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) + mg = mg_find(sv, 'P') ; + else + mg = mg_find(sv, 'q') ; + + if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1) + croak("Can't untie: %d inner references still exist", + SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ; + } + } + + if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) + sv_unmagic(sv, 'P'); else - sv_unmagic(TOPs, 'q'); + sv_unmagic(sv, 'q'); RETSETYES; } @@ -503,6 +536,8 @@ PP(pp_dbmopen) ENTER; SAVESPTR(op); op = (OP *) &myop; + if (perldb && curstash != debstash) + op->op_private |= OPpENTERSUB_DB; PUTBACK; pp_pushmark(); @@ -514,7 +549,7 @@ PP(pp_dbmopen) else PUSHs(sv_2mortal(newSViv(O_RDWR))); PUSHs(right); - PUSHs(gv); + PUSHs((SV*)gv); PUTBACK; if (op = pp_entersub()) @@ -531,7 +566,7 @@ PP(pp_dbmopen) PUSHs(left); PUSHs(sv_2mortal(newSViv(O_RDONLY))); PUSHs(right); - PUSHs(gv); + PUSHs((SV*)gv); PUTBACK; if (op = pp_entersub()) @@ -710,11 +745,11 @@ PP(pp_select) if (! hv) XPUSHs(&sv_undef); else { - GV **gvp = hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE); + GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE); if (gvp && *gvp == egv) gv_efullname(TARG, defoutgv); else - sv_setsv(TARG, sv_2mortal(newRV(egv))); + sv_setsv(TARG, sv_2mortal(newRV((SV*)egv))); XPUSHTARG; } @@ -827,7 +862,7 @@ PP(pp_leavewrite) I32 gimme; register CONTEXT *cx; - DEBUG_f(fprintf(stderr,"left=%ld, todo=%ld\n", + DEBUG_f(fprintf(Perl_debug_log,"left=%ld, todo=%ld\n", (long)IoLINES_LEFT(io), (long)FmLINES(formtarget))); if (IoLINES_LEFT(io) < FmLINES(formtarget) && formtarget != toptarget) @@ -1211,34 +1246,44 @@ PP(pp_truncate) SETERRNO(0,0); #if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP) -#ifdef HAS_TRUNCATE if (op->op_flags & OPf_SPECIAL) { tmpgv = gv_fetchpv(POPp,FALSE, SVt_PVIO); + do_ftruncate: if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) || +#ifdef HAS_TRUNCATE ftruncate(fileno(IoIFP(GvIOn(tmpgv))), len) < 0) - result = 0; - } - else if (truncate(POPp, len) < 0) - result = 0; -#else - if (op->op_flags & OPf_SPECIAL) { - tmpgv = gv_fetchpv(POPp,FALSE, SVt_PVIO); - if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) || - chsize(fileno(IoIFP(GvIOn(tmpgv))), len) < 0) +#else + my_chsize(fileno(IoIFP(GvIOn(tmpgv))), len) < 0) +#endif result = 0; } else { - int tmpfd; - - if ((tmpfd = open(POPp, 0)) < 0) + SV *sv = POPs; + if (SvTYPE(sv) == SVt_PVGV) { + tmpgv = (GV*)sv; /* *main::FRED for example */ + goto do_ftruncate; + } + else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) { + tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */ + goto do_ftruncate; + } +#ifdef HAS_TRUNCATE + if (truncate (SvPV (sv, na), len) < 0) result = 0; - else { - if (chsize(tmpfd, len) < 0) - result = 0; - close(tmpfd); +#else + { + int tmpfd; + + if ((tmpfd = open(SvPV (sv, na), 0)) < 0) + result = 0; + else { + if (my_chsize(tmpfd, len) < 0) + result = 0; + close(tmpfd); + } } - } #endif + } if (result) RETPUSHYES; @@ -1831,11 +1876,21 @@ PP(pp_stat) PUSHs(sv_2mortal(newSViv((I32)statcache.st_nlink))); PUSHs(sv_2mortal(newSViv((I32)statcache.st_uid))); PUSHs(sv_2mortal(newSViv((I32)statcache.st_gid))); +#ifdef USE_STAT_RDEV PUSHs(sv_2mortal(newSViv((I32)statcache.st_rdev))); +#else + PUSHs(sv_2mortal(newSVpv("", 0))); +#endif PUSHs(sv_2mortal(newSViv((I32)statcache.st_size))); +#ifdef BIG_TIME + PUSHs(sv_2mortal(newSVnv((U32)statcache.st_atime))); + PUSHs(sv_2mortal(newSVnv((U32)statcache.st_mtime))); + PUSHs(sv_2mortal(newSVnv((U32)statcache.st_ctime))); +#else PUSHs(sv_2mortal(newSViv((I32)statcache.st_atime))); PUSHs(sv_2mortal(newSViv((I32)statcache.st_mtime))); PUSHs(sv_2mortal(newSViv((I32)statcache.st_ctime))); +#endif #ifdef USE_STAT_BLOCKS PUSHs(sv_2mortal(newSViv((I32)statcache.st_blksize))); PUSHs(sv_2mortal(newSViv((I32)statcache.st_blocks))); @@ -2984,7 +3039,11 @@ PP(pp_setpriority) PP(pp_time) { dSP; dTARGET; +#ifdef BIG_TIME + XPUSHn( time(Null(Time_t*)) ); +#else XPUSHi( time(Null(Time_t*)) ); +#endif RETURN; } @@ -3038,7 +3097,11 @@ PP(pp_gmtime) if (MAXARG < 1) (void)time(&when); else +#ifdef BIG_TIME + when = (Time_t)SvNVx(POPs); +#else when = (Time_t)SvIVx(POPs); +#endif if (op->op_type == OP_LOCALTIME) tmbuf = localtime(&when);