X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_sys.c;h=0451d5a80264316fed604552c548c1fda7a2fb21;hb=3e9bebd5e3537348bf6b698defecf0de0d19dde7;hp=d3cf17f613d922b7390e7d03777736e2cf71ae2b;hpb=273b0206b8797b55ea5c05965028980ae791780b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_sys.c b/pp_sys.c index d3cf17f..0451d5a 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -577,8 +577,8 @@ PP(pp_close) PP(pp_pipe_op) { - dSP; #ifdef HAS_PIPE + dSP; GV *rgv; GV *wgv; register IO *rstio; @@ -669,9 +669,9 @@ PP(pp_fileno) PP(pp_umask) { dSP; dTARGET; +#ifdef HAS_UMASK Mode_t anum; -#ifdef HAS_UMASK if (MAXARG < 1) { anum = PerlLIO_umask(0); (void)PerlLIO_umask(anum); @@ -699,8 +699,6 @@ PP(pp_binmode) PerlIO *fp; MAGIC *mg; SV *discp = Nullsv; - STRLEN len = 0; - char *names = NULL; if (MAXARG < 1) RETPUSHUNDEF; @@ -730,10 +728,6 @@ PP(pp_binmode) RETPUSHUNDEF; } - if (discp) { - names = SvPV(discp,len); - } - if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp), (discp) ? SvPV_nolen(discp) : Nullch)) RETPUSHYES; @@ -764,9 +758,9 @@ PP(pp_tie) methname = "TIEARRAY"; break; case SVt_PVGV: -#ifdef GV_SHARED_CHECK - if (GvSHARED((GV*)varsv)) { - Perl_croak(aTHX_ "Attempt to tie shared GV"); +#ifdef GV_UNIQUE_CHECK + if (GvUNIQUE((GV*)varsv)) { + Perl_croak(aTHX_ "Attempt to tie unique GV"); } #endif methname = "TIEHANDLE"; @@ -942,8 +936,8 @@ PP(pp_dbmclose) PP(pp_sselect) { - dSP; dTARGET; #ifdef HAS_SELECT + dSP; dTARGET; register I32 i; register I32 j; register char *s; @@ -2152,6 +2146,7 @@ PP(pp_ioctl) PP(pp_flock) { +#ifdef FLOCK dSP; dTARGET; I32 value; int argtype; @@ -2159,7 +2154,6 @@ PP(pp_flock) IO *io = NULL; PerlIO *fp; -#ifdef FLOCK argtype = POPi; if (MAXARG == 0) gv = PL_last_in_gv; @@ -2192,8 +2186,8 @@ PP(pp_flock) PP(pp_socket) { - dSP; #ifdef HAS_SOCKET + dSP; GV *gv; register IO *io; int protocol = POPi; @@ -2310,8 +2304,8 @@ PP(pp_sockpair) PP(pp_bind) { - dSP; #ifdef HAS_SOCKET + dSP; #ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */ extern void GETPRIVMODE(); extern void GETUSERMODE(); @@ -2369,8 +2363,8 @@ nuts: PP(pp_connect) { - dSP; #ifdef HAS_SOCKET + dSP; SV *addrsv = POPs; char *addr; GV *gv = (GV*)POPs; @@ -2399,8 +2393,8 @@ nuts: PP(pp_listen) { - dSP; #ifdef HAS_SOCKET + dSP; int backlog = POPi; GV *gv = (GV*)POPs; register IO *io = gv ? GvIOn(gv) : NULL; @@ -2425,8 +2419,8 @@ nuts: PP(pp_accept) { - dSP; dTARGET; #ifdef HAS_SOCKET + dSP; dTARGET; GV *ngv; GV *ggv; register IO *nstio; @@ -2490,8 +2484,8 @@ badexit: PP(pp_shutdown) { - dSP; dTARGET; #ifdef HAS_SOCKET + dSP; dTARGET; int how = POPi; GV *gv = (GV*)POPs; register IO *io = GvIOn(gv); @@ -2523,8 +2517,8 @@ PP(pp_gsockopt) PP(pp_ssockopt) { - dSP; #ifdef HAS_SOCKET + dSP; int optype = PL_op->op_type; SV *sv; int fd; @@ -2604,8 +2598,8 @@ PP(pp_getsockname) PP(pp_getpeername) { - dSP; #ifdef HAS_SOCKET + dSP; int optype = PL_op->op_type; SV *sv; int fd; @@ -3485,17 +3479,16 @@ PP(pp_link) char *tmps = SvPV(TOPs, n_a); TAINT_PROPER("link"); SETi( PerlLIO_link(tmps, tmps2) >= 0 ); + RETURN; #else DIE(aTHX_ PL_no_func, "link"); #endif - RETURN; } PP(pp_symlink) { #ifdef HAS_SYMLINK - dSP; - dTARGET; + dSP; dTARGET; STRLEN n_a; char *tmps2 = POPpx; char *tmps = SvPV(TOPs, n_a); @@ -3687,8 +3680,8 @@ PP(pp_rmdir) PP(pp_open_dir) { - dSP; #if defined(Direntry_t) && defined(HAS_READDIR) + dSP; STRLEN n_a; char *dirname = POPpx; GV *gv = (GV*)POPs; @@ -3714,8 +3707,8 @@ nope: PP(pp_readdir) { - dSP; #if defined(Direntry_t) && defined(HAS_READDIR) + dSP; #if !defined(I_DIRENT) && !defined(VMS) Direntry_t *readdir (DIR *); #endif @@ -3772,8 +3765,8 @@ nope: PP(pp_telldir) { - dSP; dTARGET; #if defined(HAS_TELLDIR) || defined(telldir) + 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. @@ -3800,8 +3793,8 @@ nope: PP(pp_seekdir) { - dSP; #if defined(HAS_SEEKDIR) || defined(seekdir) + dSP; long along = POPl; GV *gv = (GV*)POPs; register IO *io = GvIOn(gv); @@ -3823,8 +3816,8 @@ nope: PP(pp_rewinddir) { - dSP; #if defined(HAS_REWINDDIR) || defined(rewinddir) + dSP; GV *gv = (GV*)POPs; register IO *io = GvIOn(gv); @@ -3844,8 +3837,8 @@ nope: PP(pp_closedir) { - dSP; #if defined(Direntry_t) && defined(HAS_READDIR) + dSP; GV *gv = (GV*)POPs; register IO *io = GvIOn(gv); @@ -3987,72 +3980,72 @@ PP(pp_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 (PerlProc_pipe(pp) >= 0) - did_pipes = 1; - while ((childpid = vfork()) == -1) { - if (errno != EAGAIN) { - value = -1; - SP = ORIGMARK; - PUSHi(value); - if (did_pipes) { - PerlLIO_close(pp[0]); - PerlLIO_close(pp[1]); - } - RETURN; - } - sleep(5); - } - if (childpid > 0) { - if (did_pipes) - PerlLIO_close(pp[1]); + { + Pid_t childpid; + int status; + Sigsave_t ihand,qhand; /* place to save signals during system() */ + + if (PerlProc_pipe(pp) >= 0) + did_pipes = 1; + while ((childpid = vfork()) == -1) { + if (errno != EAGAIN) { + value = -1; + SP = ORIGMARK; + PUSHi(value); + if (did_pipes) { + PerlLIO_close(pp[0]); + PerlLIO_close(pp[1]); + } + RETURN; + } + sleep(5); + } + if (childpid > 0) { + if (did_pipes) + PerlLIO_close(pp[1]); #ifndef PERL_MICRO - rsignal_save(SIGINT, SIG_IGN, &ihand); - rsignal_save(SIGQUIT, SIG_IGN, &qhand); + rsignal_save(SIGINT, SIG_IGN, &ihand); + rsignal_save(SIGQUIT, SIG_IGN, &qhand); #endif - do { - result = wait4pid(childpid, &status, 0); - } while (result == -1 && errno == EINTR); + do { + result = wait4pid(childpid, &status, 0); + } while (result == -1 && errno == EINTR); #ifndef PERL_MICRO - (void)rsignal_restore(SIGINT, &ihand); - (void)rsignal_restore(SIGQUIT, &qhand); -#endif - STATUS_NATIVE_SET(result == -1 ? -1 : status); - do_execfree(); /* free any memory child malloced on vfork */ - SP = ORIGMARK; - if (did_pipes) { - int errkid; - int n = 0, n1; - - while (n < sizeof(int)) { - n1 = PerlLIO_read(pp[0], - (void*)(((char*)&errkid)+n), - (sizeof(int)) - n); - if (n1 <= 0) - break; - n += n1; - } - PerlLIO_close(pp[0]); - if (n) { /* Error */ - if (n != sizeof(int)) - DIE(aTHX_ "panic: kid popen errno read"); - errno = errkid; /* Propagate errno from kid */ - STATUS_CURRENT = -1; - } - } - PUSHi(STATUS_CURRENT); - RETURN; - } - if (did_pipes) { - PerlLIO_close(pp[0]); + (void)rsignal_restore(SIGINT, &ihand); + (void)rsignal_restore(SIGQUIT, &qhand); +#endif + STATUS_NATIVE_SET(result == -1 ? -1 : status); + do_execfree(); /* free any memory child malloced on vfork */ + SP = ORIGMARK; + if (did_pipes) { + int errkid; + int n = 0, n1; + + while (n < sizeof(int)) { + n1 = PerlLIO_read(pp[0], + (void*)(((char*)&errkid)+n), + (sizeof(int)) - n); + if (n1 <= 0) + break; + n += n1; + } + PerlLIO_close(pp[0]); + if (n) { /* Error */ + if (n != sizeof(int)) + DIE(aTHX_ "panic: kid popen errno read"); + errno = errkid; /* Propagate errno from kid */ + STATUS_CURRENT = -1; + } + } + PUSHi(STATUS_CURRENT); + RETURN; + } + if (did_pipes) { + PerlLIO_close(pp[0]); #if defined(HAS_FCNTL) && defined(F_SETFD) - fcntl(pp[1], F_SETFD, FD_CLOEXEC); - } + fcntl(pp[1], F_SETFD, FD_CLOEXEC); #endif + } } if (PL_op->op_flags & OPf_STACKED) { SV *really = *++MARK; @@ -4128,11 +4121,6 @@ PP(pp_exec) #endif } -#if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) - if (value >= 0) - my_exit(value); -#endif - SP = ORIGMARK; PUSHi(value); RETURN; @@ -4140,9 +4128,9 @@ PP(pp_exec) PP(pp_kill) { +#ifdef HAS_KILL dSP; dMARK; dTARGET; I32 value; -#ifdef HAS_KILL value = (I32)apply(PL_op->op_type, MARK, SP); SP = MARK; PUSHi(value); @@ -4222,8 +4210,8 @@ PP(pp_setpgrp) PP(pp_getpriority) { - dSP; dTARGET; #ifdef HAS_GETPRIORITY + dSP; dTARGET; int who = POPi; int which = TOPi; SETi( getpriority(which, who) ); @@ -4235,8 +4223,8 @@ PP(pp_getpriority) PP(pp_setpriority) { - dSP; dTARGET; #ifdef HAS_SETPRIORITY + dSP; dTARGET; int niceval = POPi; int who = POPi; int which = TOPi; @@ -4279,13 +4267,9 @@ PP(pp_time) PP(pp_tms) { +#ifdef HAS_TIMES dSP; - -#ifndef HAS_TIMES - DIE(aTHX_ "times not implemented"); -#else EXTEND(SP, 4); - #ifndef VMS (void)PerlProc_times(&PL_timesbuf); #else @@ -4301,6 +4285,8 @@ PP(pp_tms) PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ))); } RETURN; +#else + DIE(aTHX_ "times not implemented"); #endif /* HAS_TIMES */ } @@ -4332,10 +4318,10 @@ PP(pp_gmtime) else tmbuf = gmtime(&when); - EXTEND(SP, 9); - EXTEND_MORTAL(9); if (GIMME != G_ARRAY) { SV *tsv; + EXTEND(SP, 1); + EXTEND_MORTAL(1); if (!tmbuf) RETPUSHUNDEF; tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d", @@ -4349,7 +4335,9 @@ PP(pp_gmtime) PUSHs(sv_2mortal(tsv)); } else if (tmbuf) { - PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec))); + EXTEND(SP, 9); + EXTEND_MORTAL(9); + PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec))); PUSHs(sv_2mortal(newSViv(tmbuf->tm_min))); PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour))); PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday))); @@ -4364,9 +4352,9 @@ PP(pp_gmtime) PP(pp_alarm) { +#ifdef HAS_ALARM dSP; dTARGET; int anum; -#ifdef HAS_ALARM anum = POPi; anum = alarm((unsigned int)anum); EXTEND(SP, 1); @@ -4538,8 +4526,8 @@ PP(pp_ghbyaddr) PP(pp_ghostent) { - dSP; #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT) + dSP; I32 which = PL_op->op_type; register char **elem; register SV *sv; @@ -4647,8 +4635,8 @@ PP(pp_gnbyaddr) PP(pp_gnetent) { - dSP; #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT) + dSP; I32 which = PL_op->op_type; register char **elem; register SV *sv; @@ -4735,8 +4723,8 @@ PP(pp_gpbynumber) PP(pp_gprotoent) { - dSP; #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT) + dSP; I32 which = PL_op->op_type; register char **elem; register SV *sv; @@ -4818,8 +4806,8 @@ PP(pp_gsbyport) PP(pp_gservent) { - dSP; #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT) + dSP; I32 which = PL_op->op_type; register char **elem; register SV *sv; @@ -4908,8 +4896,8 @@ PP(pp_gservent) PP(pp_shostent) { - dSP; #ifdef HAS_SETHOSTENT + dSP; PerlSock_sethostent(TOPi); RETSETYES; #else @@ -4919,8 +4907,8 @@ PP(pp_shostent) PP(pp_snetent) { - dSP; #ifdef HAS_SETNETENT + dSP; PerlSock_setnetent(TOPi); RETSETYES; #else @@ -4930,8 +4918,8 @@ PP(pp_snetent) PP(pp_sprotoent) { - dSP; #ifdef HAS_SETPROTOENT + dSP; PerlSock_setprotoent(TOPi); RETSETYES; #else @@ -4941,8 +4929,8 @@ PP(pp_sprotoent) PP(pp_sservent) { - dSP; #ifdef HAS_SETSERVENT + dSP; PerlSock_setservent(TOPi); RETSETYES; #else @@ -4952,8 +4940,8 @@ PP(pp_sservent) PP(pp_ehostent) { - dSP; #ifdef HAS_ENDHOSTENT + dSP; PerlSock_endhostent(); EXTEND(SP,1); RETPUSHYES; @@ -4964,8 +4952,8 @@ PP(pp_ehostent) PP(pp_enetent) { - dSP; #ifdef HAS_ENDNETENT + dSP; PerlSock_endnetent(); EXTEND(SP,1); RETPUSHYES; @@ -4976,8 +4964,8 @@ PP(pp_enetent) PP(pp_eprotoent) { - dSP; #ifdef HAS_ENDPROTOENT + dSP; PerlSock_endprotoent(); EXTEND(SP,1); RETPUSHYES; @@ -4988,8 +4976,8 @@ PP(pp_eprotoent) PP(pp_eservent) { - dSP; #ifdef HAS_ENDSERVENT + dSP; PerlSock_endservent(); EXTEND(SP,1); RETPUSHYES; @@ -5018,8 +5006,8 @@ PP(pp_gpwuid) PP(pp_gpwent) { - dSP; #ifdef HAS_PASSWD + dSP; I32 which = PL_op->op_type; register SV *sv; STRLEN n_a; @@ -5232,8 +5220,8 @@ PP(pp_gpwent) PP(pp_spwent) { - dSP; #if defined(HAS_PASSWD) && defined(HAS_SETPWENT) + dSP; setpwent(); RETPUSHYES; #else @@ -5243,8 +5231,8 @@ PP(pp_spwent) PP(pp_epwent) { - dSP; #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT) + dSP; endpwent(); RETPUSHYES; #else @@ -5272,8 +5260,8 @@ PP(pp_ggrgid) PP(pp_ggrent) { - dSP; #ifdef HAS_GROUP + dSP; I32 which = PL_op->op_type; register char **elem; register SV *sv; @@ -5331,8 +5319,8 @@ PP(pp_ggrent) PP(pp_sgrent) { - dSP; #if defined(HAS_GROUP) && defined(HAS_SETGRENT) + dSP; setgrent(); RETPUSHYES; #else @@ -5342,8 +5330,8 @@ PP(pp_sgrent) PP(pp_egrent) { - dSP; #if defined(HAS_GROUP) && defined(HAS_ENDGRENT) + dSP; endgrent(); RETPUSHYES; #else @@ -5353,8 +5341,8 @@ PP(pp_egrent) PP(pp_getlogin) { - dSP; dTARGET; #ifdef HAS_GETLOGIN + dSP; dTARGET; char *tmps; EXTEND(SP, 1); if (!(tmps = PerlProc_getlogin()))