X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FPOSIX%2FPOSIX.xs;h=238c5285ef242ef4fd7c8585f4fe6d74379ddcf0;hb=1cb0fb506639f41107792256805556ee04e5463a;hp=c2e9852494a5dca64a419997e3bebb2b4e278043;hpb=2986a63f7e513cf37f46db9f211b77071260031f;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index c2e9852..238c528 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -1,13 +1,17 @@ +#define PERL_EXT_POSIX + #ifdef WIN32 #define _POSIX_ #endif #ifdef NETWARE #define _POSIX_ - //Ideally this should be somewhere down in the includes - //but putting it in other places is giving compiler errors. - //Also here I am unable to check for HAS_UNAME since it wouldn't have yet - //come into the file at this stage - sgp 18th Oct 2000 + /* + * Ideally this should be somewhere down in the includes + * but putting it in other places is giving compiler errors. + * Also here I am unable to check for HAS_UNAME since it wouldn't have + * yet come into the file at this stage - sgp 18th Oct 2000 + */ #include #endif /* NETWARE */ @@ -17,7 +21,7 @@ #define PERLIO_NOT_STDIO 1 #include "perl.h" #include "XSUB.h" -#if defined(PERL_OBJECT) || defined(PERL_CAPI) || defined(PERL_IMPLICIT_SYS) +#if defined(PERL_IMPLICIT_SYS) # undef signal # undef open # undef setmode @@ -166,6 +170,8 @@ char *tzname[] = { "" , "" }; # define sigfillset(a) not_here("sigfillset") # define sigismember(a,b) not_here("sigismember") #ifndef NETWARE +# undef setuid +# undef setgid # define setuid(a) not_here("setuid") # define setgid(a) not_here("setgid") #endif /* NETWARE */ @@ -224,9 +230,11 @@ typedef struct termios* POSIX__Termios; /* Possibly needed prototypes */ char *cuserid (char *); +#ifndef WIN32 double strtod (const char *, char **); long strtol (const char *, char **, int); unsigned long strtoul (const char *, char **, int); +#endif #ifndef HAS_CUSERID #define cuserid(a) (char *) not_here("cuserid") @@ -343,6 +351,20 @@ unsigned long strtoul (const char *, char **, int); #endif #endif +/* Background: in most systems the low byte of the wait status + * is the signal (the lowest 7 bits) and the coredump flag is + * the eight bit, and the second lowest byte is the exit status. + * BeOS bucks the trend and has the bytes in different order. + * See beos/beos.c for how the reality is bent even in BeOS + * to follow the traditional. However, to make the POSIX + * wait W*() macros to work in BeOS, we need to unbend the + * reality back in place. --jhi */ +#ifdef __BEOS__ +# define WMUNGE(x) (((x) & 0xFF00) >> 8 | ((x) & 0x00FF) << 8) +#else +# define WMUNGE(x) (x) +#endif + static int not_here(char *s) { @@ -350,7 +372,7 @@ not_here(char *s) return -1; } -#include "constants.c" +#include "const-c.inc" /* These were implemented in the old "constant" subroutine. They are actually macros that take an integer argument and return an integer result. */ @@ -435,7 +457,7 @@ __END__ if (memEQ(name, "WSTOPSIG", 8)) { /* ^ */ #ifdef WSTOPSIG - *arg_result = WSTOPSIG(*arg_result); + *arg_result = WSTOPSIG(WMUNGE(*arg_result)); return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; @@ -446,7 +468,7 @@ __END__ if (memEQ(name, "WTERMSIG", 8)) { /* ^ */ #ifdef WTERMSIG - *arg_result = WTERMSIG(*arg_result); + *arg_result = WTERMSIG(WMUNGE(*arg_result)); return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; @@ -469,7 +491,7 @@ __END__ case 9: if (memEQ(name, "WIFEXITED", 9)) { #ifdef WIFEXITED - *arg_result = WIFEXITED(*arg_result); + *arg_result = WIFEXITED(WMUNGE(*arg_result)); return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; @@ -479,7 +501,7 @@ __END__ case 10: if (memEQ(name, "WIFSTOPPED", 10)) { #ifdef WIFSTOPPED - *arg_result = WIFSTOPPED(*arg_result); + *arg_result = WIFSTOPPED(WMUNGE(*arg_result)); return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; @@ -495,7 +517,7 @@ __END__ if (memEQ(name, "WEXITSTATUS", 11)) { /* ^ */ #ifdef WEXITSTATUS - *arg_result = WEXITSTATUS(*arg_result); + *arg_result = WEXITSTATUS(WMUNGE(*arg_result)); return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; @@ -506,7 +528,7 @@ __END__ if (memEQ(name, "WIFSIGNALED", 11)) { /* ^ */ #ifdef WIFSIGNALED - *arg_result = WIFSIGNALED(*arg_result); + *arg_result = WIFSIGNALED(WMUNGE(*arg_result)); return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; @@ -520,14 +542,15 @@ __END__ } static void -restore_sigmask(sigset_t *ossetp) +restore_sigmask(pTHX_ SV *osset_sv) { - /* Fortunately, restoring the signal mask can't fail, because - * there's nothing we can do about it if it does -- we're not - * supposed to return -1 from sigaction unless the disposition - * was unaffected. - */ - (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0); + /* Fortunately, restoring the signal mask can't fail, because + * there's nothing we can do about it if it does -- we're not + * supposed to return -1 from sigaction unless the disposition + * was unaffected. + */ + sigset_t *ossetp = (sigset_t *) SvPV_nolen( osset_sv ); + (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0); } MODULE = SigSet PACKAGE = POSIX::SigSet PREFIX = sig @@ -769,7 +792,7 @@ setcc(termios_ref, ccix, cc) MODULE = POSIX PACKAGE = POSIX -INCLUDE: constants.xs +INCLUDE: const-xs.inc void int_macro_int(sv, iv) @@ -1183,6 +1206,7 @@ sigaction(sig, optaction, oldaction = 0) struct sigaction act; struct sigaction oact; sigset_t sset; + SV *osset_sv; sigset_t osset; POSIX__SigSet sigset; SV** svp; @@ -1210,10 +1234,12 @@ sigaction(sig, optaction, oldaction = 0) sigfillset(&sset); RETVAL=sigprocmask(SIG_BLOCK, &sset, &osset); if(RETVAL == -1) - XSRETURN(1); + XSRETURN_UNDEF; ENTER; /* Restore signal mask no matter how we exit this block. */ - SAVEDESTRUCTOR(restore_sigmask, &osset); + osset_sv = newSVpv((char *)(&osset), sizeof(sigset_t)); + SAVEFREESV( osset_sv ); + SAVEDESTRUCTOR_X(restore_sigmask, osset_sv); RETVAL=-1; /* In case both oldaction and action are 0. */ @@ -1230,7 +1256,7 @@ sigaction(sig, optaction, oldaction = 0) } RETVAL = sigaction(sig, (struct sigaction *)0, & oact); if(RETVAL == -1) - XSRETURN(1); + XSRETURN_UNDEF; /* Get back the mask. */ svp = hv_fetch(oldaction, "MASK", 4, TRUE); if (sv_isa(*svp, "POSIX::SigSet")) { @@ -1292,6 +1318,8 @@ sigaction(sig, optaction, oldaction = 0) * essentially meaningless anyway. */ RETVAL = sigaction(sig, & act, (struct sigaction *)0); + if(RETVAL == -1) + XSRETURN_UNDEF; } LEAVE; @@ -1742,40 +1770,12 @@ char * ttyname(fd) int fd -#XXX: use sv_getcwd() void getcwd() - PPCODE: -#ifdef HAS_GETCWD - char * buf; - int buflen = 128; - - New(0, buf, buflen, char); - /* Many getcwd()s know how to automatically allocate memory - * for the directory if the buffer argument is NULL but... - * (1) we cannot assume all getcwd()s do that - * (2) this may interfere with Perl's malloc - * So let's not. --jhi */ - while ((getcwd(buf, buflen) == NULL) && errno == ERANGE) { - buflen += 128; - if (buflen > MAXPATHLEN) { - Safefree(buf); - buf = NULL; - break; - } - Renew(buf, buflen, char); - } - if (buf) { - PUSHs(sv_2mortal(newSVpv(buf, 0))); - Safefree(buf); - } - else - PUSHs(&PL_sv_undef); -#else - require_pv("Cwd.pm"); - /* Module require may have grown the stack */ - SPAGAIN; - PUSHMARK(sp); - PUTBACK; - XSRETURN(call_pv("Cwd::cwd", GIMME_V)); -#endif + PPCODE: + { + dXSTARG; + getcwd_sv(TARG); + XSprePUSH; PUSHTARG; + } +