X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FPOSIX%2FPOSIX.xs;h=7bdd6339b7a057806236b1c12c37eb4bf425075f;hb=fabb67aac748c1bf94bbc4a173a67dbd9a00b4df;hp=3e17039b2724c78ba0245c292f2aa23bd7a8cb63;hpb=183bde56275d411115d70eb0564a586647b40e23;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index 3e17039..7bdd633 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -1,6 +1,4 @@ -#ifdef WIN32 -#define _POSIX_ -#endif +#define PERL_EXT_POSIX #ifdef NETWARE #define _POSIX_ @@ -19,7 +17,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 @@ -53,7 +51,7 @@ #include #endif -/* XXX This comment is just to make I_TERMIO and I_SGTTY visible to +/* XXX This comment is just to make I_TERMIO and I_SGTTY visible to metaconfig for future extension writers. We don't use them in POSIX. (This is really sneaky :-) --AD */ @@ -63,28 +61,47 @@ #ifdef I_STDLIB #include #endif +#ifndef __ultrix__ #include +#endif #include #include #include #ifdef I_UNISTD #include #endif -#ifdef MACOS_TRADITIONAL -#undef fdopen -#endif #include #ifdef HAS_TZNAME -# if !defined(WIN32) && !defined(__CYGWIN__) && !defined(NETWARE) +# if !defined(WIN32) && !defined(__CYGWIN__) && !defined(NETWARE) && !defined(__UWIN__) extern char *tzname[]; # endif #else -#if !defined(WIN32) || (defined(__MINGW32__) && !defined(tzname)) +#if !defined(WIN32) && !defined(__UWIN__) || (defined(__MINGW32__) && !defined(tzname)) char *tzname[] = { "" , "" }; #endif #endif +#ifndef PERL_UNUSED_DECL +# ifdef HASATTRIBUTE +# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) +# define PERL_UNUSED_DECL +# else +# define PERL_UNUSED_DECL __attribute__((unused)) +# endif +# else +# define PERL_UNUSED_DECL +# endif +#endif + +#ifndef dNOOP +#define dNOOP extern int Perl___notused PERL_UNUSED_DECL +#endif + +#ifndef dVAR +#define dVAR dNOOP +#endif + #if defined(__VMS) && !defined(__POSIX_SOURCE) # include /* LIB$_INVARG constant */ # include /* prototype for lib$ediv() */ @@ -168,38 +185,160 @@ 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 */ #else # ifndef HAS_MKFIFO -# if defined(OS2) || defined(MACOS_TRADITIONAL) +# if defined(OS2) # define mkfifo(a,b) not_here("mkfifo") -# else /* !( defined OS2 ) */ +# else /* !( defined OS2 ) */ # ifndef mkfifo # define mkfifo(path, mode) (mknod((path), (mode) | S_IFIFO, 0)) # endif # endif # endif /* !HAS_MKFIFO */ -# ifdef MACOS_TRADITIONAL -# define ttyname(a) (char*)not_here("ttyname") -# define tzset() not_here("tzset") -# else +# ifdef I_GRP # include -# include -# ifdef HAS_UNAME -# include -# endif -# include # endif +# include +# ifdef HAS_UNAME +# include +# endif +# include # ifdef I_UTIME # include # endif #endif /* WIN32 || NETWARE */ #endif /* __VMS */ +#ifdef WIN32 + /* Perl on Windows assigns WSAGetLastError() return values to errno + * (in win32/win32sck.c). Therefore we need to map these values + * back to standard symbolic names, as long as the same name isn't + * already defined by errno.h itself. The Errno.pm module does + * a similar mapping. + */ +# ifndef EWOULDBLOCK +# define EWOULDBLOCK WSAEWOULDBLOCK +# endif +# ifndef EINPROGRESS +# define EINPROGRESS WSAEINPROGRESS +# endif +# ifndef EALREADY +# define EALREADY WSAEALREADY +# endif +# ifndef ENOTSOCK +# define ENOTSOCK WSAENOTSOCK +# endif +# ifndef EDESTADDRREQ +# define EDESTADDRREQ WSAEDESTADDRREQ +# endif +# ifndef EMSGSIZE +# define EMSGSIZE WSAEMSGSIZE +# endif +# ifndef EPROTOTYPE +# define EPROTOTYPE WSAEPROTOTYPE +# endif +# ifndef ENOPROTOOPT +# define ENOPROTOOPT WSAENOPROTOOPT +# endif +# ifndef EPROTONOSUPPORT +# define EPROTONOSUPPORT WSAEPROTONOSUPPORT +# endif +# ifndef ESOCKTNOSUPPORT +# define ESOCKTNOSUPPORT WSAESOCKTNOSUPPORT +# endif +# ifndef EOPNOTSUPP +# define EOPNOTSUPP WSAEOPNOTSUPP +# endif +# ifndef EPFNOSUPPORT +# define EPFNOSUPPORT WSAEPFNOSUPPORT +# endif +# ifndef EAFNOSUPPORT +# define EAFNOSUPPORT WSAEAFNOSUPPORT +# endif +# ifndef EADDRINUSE +# define EADDRINUSE WSAEADDRINUSE +# endif +# ifndef EADDRNOTAVAIL +# define EADDRNOTAVAIL WSAEADDRNOTAVAIL +# endif +# ifndef ENETDOWN +# define ENETDOWN WSAENETDOWN +# endif +# ifndef ENETUNREACH +# define ENETUNREACH WSAENETUNREACH +# endif +# ifndef ENETRESET +# define ENETRESET WSAENETRESET +# endif +# ifndef ECONNABORTED +# define ECONNABORTED WSAECONNABORTED +# endif +# ifndef ECONNRESET +# define ECONNRESET WSAECONNRESET +# endif +# ifndef ENOBUFS +# define ENOBUFS WSAENOBUFS +# endif +# ifndef EISCONN +# define EISCONN WSAEISCONN +# endif +# ifndef ENOTCONN +# define ENOTCONN WSAENOTCONN +# endif +# ifndef ESHUTDOWN +# define ESHUTDOWN WSAESHUTDOWN +# endif +# ifndef ETOOMANYREFS +# define ETOOMANYREFS WSAETOOMANYREFS +# endif +# ifndef ETIMEDOUT +# define ETIMEDOUT WSAETIMEDOUT +# endif +# ifndef ECONNREFUSED +# define ECONNREFUSED WSAECONNREFUSED +# endif +# ifndef ELOOP +# define ELOOP WSAELOOP +# endif +# ifndef ENAMETOOLONG +# define ENAMETOOLONG WSAENAMETOOLONG +# endif +# ifndef EHOSTDOWN +# define EHOSTDOWN WSAEHOSTDOWN +# endif +# ifndef EHOSTUNREACH +# define EHOSTUNREACH WSAEHOSTUNREACH +# endif +# ifndef ENOTEMPTY +# define ENOTEMPTY WSAENOTEMPTY +# endif +# ifndef EPROCLIM +# define EPROCLIM WSAEPROCLIM +# endif +# ifndef EUSERS +# define EUSERS WSAEUSERS +# endif +# ifndef EDQUOT +# define EDQUOT WSAEDQUOT +# endif +# ifndef ESTALE +# define ESTALE WSAESTALE +# endif +# ifndef EREMOTE +# define EREMOTE WSAEREMOTE +# endif +# ifndef EDISCON +# define EDISCON WSAEDISCON +# endif +#endif + typedef int SysRet; typedef long SysRetLong; typedef sigset_t* POSIX__SigSet; @@ -225,21 +364,19 @@ typedef struct termios* POSIX__Termios; #endif /* 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); - -#ifndef HAS_CUSERID -#define cuserid(a) (char *) not_here("cuserid") #endif + #ifndef HAS_DIFFTIME #ifndef difftime #define difftime(a,b) not_here("difftime") #endif #endif #ifndef HAS_FPATHCONF -#define fpathconf(f,n) (SysRetLong) not_here("fpathconf") +#define fpathconf(f,n) (SysRetLong) not_here("fpathconf") #endif #ifndef HAS_MKTIME #define mktime(a) not_here("mktime") @@ -248,10 +385,10 @@ unsigned long strtoul (const char *, char **, int); #define nice(a) not_here("nice") #endif #ifndef HAS_PATHCONF -#define pathconf(f,n) (SysRetLong) not_here("pathconf") +#define pathconf(f,n) (SysRetLong) not_here("pathconf") #endif #ifndef HAS_SYSCONF -#define sysconf(n) (SysRetLong) not_here("sysconf") +#define sysconf(n) (SysRetLong) not_here("sysconf") #endif #ifndef HAS_READLINK #define readlink(a,b,c) not_here("readlink") @@ -345,203 +482,170 @@ 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 */ +/* In actual fact the code below is to blame here. Perl has an internal + * representation of the exit status ($?), which it re-composes from the + * OS's representation using the W*() POSIX macros. The code below + * incorrectly uses the W*() macros on the internal representation, + * which fails for OSs that have a different representation (namely BeOS + * and Haiku). WMUNGE() is a hack that converts the internal + * representation into the OS specific one, so that the W*() macros work + * as expected. The better solution would be not to use the W*() macros + * in the first place, though. -- Ingo Weinhold + */ +#if defined(__BEOS__) || defined(__HAIKU__) +# define WMUNGE(x) (((x) & 0xFF00) >> 8 | ((x) & 0x00FF) << 8) +#else +# define WMUNGE(x) (x) +#endif + static int -not_here(char *s) +not_here(const char *s) { croak("POSIX::%s not implemented on this architecture", 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. */ -static int -int_macro_int (const char *name, STRLEN len, IV *arg_result) { - /* Initially switch on the length of the name. */ - /* This code has been edited from a "constant" function generated by: +static void +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. + */ + sigset_t *ossetp = (sigset_t *) SvPV_nolen( osset_sv ); + (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0); +} -use ExtUtils::Constant qw (constant_types C_constant XS_constant); +#ifdef WIN32 -my $types = {map {($_, 1)} qw(IV)}; -my @names = (qw(S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG WEXITSTATUS WIFEXITED - WIFSIGNALED WIFSTOPPED WSTOPSIG WTERMSIG)); +/* + * (1) The CRT maintains its own copy of the environment, separate from + * the Win32API copy. + * + * (2) CRT getenv() retrieves from this copy. CRT putenv() updates this + * copy, and then calls SetEnvironmentVariableA() to update the Win32API + * copy. + * + * (3) win32_getenv() and win32_putenv() call GetEnvironmentVariableA() and + * SetEnvironmentVariableA() directly, bypassing the CRT copy of the + * environment. + * + * (4) The CRT strftime() "%Z" implementation calls __tzset(). That + * calls CRT tzset(), but only the first time it is called, and in turn + * that uses CRT getenv("TZ") to retrieve the timezone info from the CRT + * local copy of the environment and hence gets the original setting as + * perl never updates the CRT copy when assigning to $ENV{TZ}. + * + * Therefore, we need to retrieve the value of $ENV{TZ} and call CRT + * putenv() to update the CRT copy of the environment (if it is different) + * whenever we're about to call tzset(). + * + * In addition to all that, when perl is built with PERL_IMPLICIT_SYS + * defined: + * + * (a) Each interpreter has its own copy of the environment inside the + * perlhost structure. That allows applications that host multiple + * independent Perl interpreters to isolate environment changes from + * each other. (This is similar to how the perlhost mechanism keeps a + * separate working directory for each Perl interpreter, so that calling + * chdir() will not affect other interpreters.) + * + * (b) Only the first Perl interpreter instantiated within a process will + * "write through" environment changes to the process environment. + * + * (c) Even the primary Perl interpreter won't update the CRT copy of the + * the environment, only the Win32API copy (it calls win32_putenv()). + * + * As with CPerlHost::Getenv() and CPerlHost::Putenv() themselves, it makes + * sense to only update the process environment when inside the main + * interpreter, but we don't have access to CPerlHost's m_bTopLevel member + * from here so we'll just have to check PL_curinterp instead. + * + * Therefore, we can simply #undef getenv() and putenv() so that those names + * always refer to the CRT functions, and explicitly call win32_getenv() to + * access perl's %ENV. + * + * We also #undef malloc() and free() to be sure we are using the CRT + * functions otherwise under PERL_IMPLICIT_SYS they are redefined to calls + * into VMem::Malloc() and VMem::Free() and all allocations will be freed + * when the Perl interpreter is being destroyed so we'd end up with a pointer + * into deallocated memory in environ[] if a program embedding a Perl + * interpreter continues to operate even after the main Perl interpreter has + * been destroyed. + * + * Note that we don't free() the malloc()ed memory unless and until we call + * malloc() again ourselves because the CRT putenv() function simply puts its + * pointer argument into the environ[] arrary (it doesn't make a copy of it) + * so this memory must otherwise be leaked. + */ + +#undef getenv +#undef putenv +#undef malloc +#undef free -print constant_types(); # macro defs -foreach (C_constant ("POSIX", 'int_macro_int', 'IV', $types, undef, 5, @names) ) { - print $_, "\n"; # C constant subs -} -print "#### XS Section:\n"; -print XS_constant ("POSIX", $types); -__END__ - */ - - switch (len) { - case 7: - /* Names all of length 7. */ - /* S_ISBLK S_ISCHR S_ISDIR S_ISREG */ - /* Offset 5 gives the best switch position. */ - switch (name[5]) { - case 'E': - if (memEQ(name, "S_ISREG", 7)) { - /* ^ */ -#ifdef S_ISREG - *arg_result = S_ISREG(*arg_result); - return PERL_constant_ISIV; -#else - return PERL_constant_NOTDEF; -#endif - } - break; - case 'H': - if (memEQ(name, "S_ISCHR", 7)) { - /* ^ */ -#ifdef S_ISCHR - *arg_result = S_ISCHR(*arg_result); - return PERL_constant_ISIV; -#else - return PERL_constant_NOTDEF; -#endif - } - break; - case 'I': - if (memEQ(name, "S_ISDIR", 7)) { - /* ^ */ -#ifdef S_ISDIR - *arg_result = S_ISDIR(*arg_result); - return PERL_constant_ISIV; -#else - return PERL_constant_NOTDEF; -#endif - } - break; - case 'L': - if (memEQ(name, "S_ISBLK", 7)) { - /* ^ */ -#ifdef S_ISBLK - *arg_result = S_ISBLK(*arg_result); - return PERL_constant_ISIV; -#else - return PERL_constant_NOTDEF; -#endif - } - break; - } - break; - case 8: - /* Names all of length 8. */ - /* S_ISFIFO WSTOPSIG WTERMSIG */ - /* Offset 3 gives the best switch position. */ - switch (name[3]) { - case 'O': - if (memEQ(name, "WSTOPSIG", 8)) { - /* ^ */ -#ifdef WSTOPSIG - *arg_result = WSTOPSIG(*arg_result); - return PERL_constant_ISIV; -#else - return PERL_constant_NOTDEF; -#endif - } - break; - case 'R': - if (memEQ(name, "WTERMSIG", 8)) { - /* ^ */ -#ifdef WTERMSIG - *arg_result = WTERMSIG(*arg_result); - return PERL_constant_ISIV; -#else - return PERL_constant_NOTDEF; -#endif - } - break; - case 'S': - if (memEQ(name, "S_ISFIFO", 8)) { - /* ^ */ -#ifdef S_ISFIFO - *arg_result = S_ISFIFO(*arg_result); - return PERL_constant_ISIV; -#else - return PERL_constant_NOTDEF; -#endif - } - break; - } - break; - case 9: - if (memEQ(name, "WIFEXITED", 9)) { -#ifdef WIFEXITED - *arg_result = WIFEXITED(*arg_result); - return PERL_constant_ISIV; -#else - return PERL_constant_NOTDEF; -#endif - } - break; - case 10: - if (memEQ(name, "WIFSTOPPED", 10)) { -#ifdef WIFSTOPPED - *arg_result = WIFSTOPPED(*arg_result); - return PERL_constant_ISIV; -#else - return PERL_constant_NOTDEF; -#endif - } - break; - case 11: - /* Names all of length 11. */ - /* WEXITSTATUS WIFSIGNALED */ - /* Offset 1 gives the best switch position. */ - switch (name[1]) { - case 'E': - if (memEQ(name, "WEXITSTATUS", 11)) { - /* ^ */ -#ifdef WEXITSTATUS - *arg_result = WEXITSTATUS(*arg_result); - return PERL_constant_ISIV; -#else - return PERL_constant_NOTDEF; -#endif - } - break; - case 'I': - if (memEQ(name, "WIFSIGNALED", 11)) { - /* ^ */ -#ifdef WIFSIGNALED - *arg_result = WIFSIGNALED(*arg_result); - return PERL_constant_ISIV; -#else - return PERL_constant_NOTDEF; -#endif - } - break; +static void +fix_win32_tzenv(void) +{ + static char* oldenv = NULL; + char* newenv; + const char* perl_tz_env = win32_getenv("TZ"); + const char* crt_tz_env = getenv("TZ"); + if (perl_tz_env == NULL) + perl_tz_env = ""; + if (crt_tz_env == NULL) + crt_tz_env = ""; + if (strcmp(perl_tz_env, crt_tz_env) != 0) { + newenv = (char*)malloc((strlen(perl_tz_env) + 4) * sizeof(char)); + if (newenv != NULL) { + sprintf(newenv, "TZ=%s", perl_tz_env); + putenv(newenv); + if (oldenv != NULL) + free(oldenv); + oldenv = newenv; + } } - break; - } - return PERL_constant_NOTFOUND; } +#endif + +/* + * my_tzset - wrapper to tzset() with a fix to make it work (better) on Win32. + * This code is duplicated in the Time-Piece module, so any changes made here + * should be made there too. + */ static void -restore_sigmask(SV *osset_sv) +my_tzset(pTHX) { - /* 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); +#ifdef WIN32 +#if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) + if (PL_curinterp == aTHX) +#endif + fix_win32_tzenv(); +#endif + tzset(); } MODULE = SigSet PACKAGE = POSIX::SigSet PREFIX = sig POSIX::SigSet new(packname = "POSIX::SigSet", ...) - char * packname + const char * packname CODE: { int i; - New(0, RETVAL, 1, sigset_t); + Newx(RETVAL, 1, sigset_t); sigemptyset(RETVAL); for (i = 1; i < items; i++) sigaddset(RETVAL, SvIV(ST(i))); @@ -578,16 +682,15 @@ sigismember(sigset, sig) POSIX::SigSet sigset int sig - MODULE = Termios PACKAGE = POSIX::Termios PREFIX = cf POSIX::Termios new(packname = "POSIX::Termios", ...) - char * packname + const char * packname CODE: { #ifdef I_TERMIOS - New(0, RETVAL, 1, struct termios); + Newx(RETVAL, 1, struct termios); #else not_here("termios"); RETVAL = 0; @@ -688,7 +791,7 @@ getlflag(termios_ref) cc_t getcc(termios_ref, ccix) POSIX::Termios termios_ref - int ccix + unsigned int ccix CODE: #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ if (ccix >= NCCS) @@ -758,7 +861,7 @@ setlflag(termios_ref, lflag) void setcc(termios_ref, ccix, cc) POSIX::Termios termios_ref - int ccix + unsigned int ccix cc_t cc CODE: #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ @@ -772,56 +875,80 @@ setcc(termios_ref, ccix, cc) MODULE = POSIX PACKAGE = POSIX -INCLUDE: constants.xs +INCLUDE: const-xs.inc -void -int_macro_int(sv, iv) - PREINIT: - dXSTARG; - STRLEN len; - int type; - INPUT: - SV * sv; - const char * s = SvPV(sv, len); - IV iv; - PPCODE: - /* Change this to int_macro_int(s, len, &iv, &nv); - if you need to return both NVs and IVs */ - type = int_macro_int(s, len, &iv); - /* Return 1 or 2 items. First is error message, or undef if no error. - Second, if present, is found value */ - switch (type) { - case PERL_constant_NOTFOUND: - sv = sv_2mortal(newSVpvf("%s is not a valid POSIX macro", s)); - EXTEND(SP, 1); - PUSHs(&PL_sv_undef); - PUSHs(sv); - break; - case PERL_constant_NOTDEF: - sv = sv_2mortal(newSVpvf( - "Your vendor has not defined POSIX macro %s, used", s)); - EXTEND(SP, 1); - PUSHs(&PL_sv_undef); - PUSHs(sv); - break; - case PERL_constant_ISIV: - PUSHi(iv); - break; - default: - sv = sv_2mortal(newSVpvf( - "Unexpected return type %d while processing POSIX macro %s, used", - type, s)); - EXTEND(SP, 1); - PUSHs(&PL_sv_undef); - PUSHs(sv); - } +int +WEXITSTATUS(status) + int status + ALIAS: + POSIX::WIFEXITED = 1 + POSIX::WIFSIGNALED = 2 + POSIX::WIFSTOPPED = 3 + POSIX::WSTOPSIG = 4 + POSIX::WTERMSIG = 5 + CODE: +#if !defined(WEXITSTATUS) || !defined(WIFEXITED) || !defined(WIFSIGNALED) \ + || !defined(WIFSTOPPED) || !defined(WSTOPSIG) || !defined(WTERMSIG) + RETVAL = 0; /* Silence compilers that notice this, but don't realise + that not_here() can't return. */ +#endif + switch(ix) { + case 0: +#ifdef WEXITSTATUS + RETVAL = WEXITSTATUS(WMUNGE(status)); +#else + not_here("WEXITSTATUS"); +#endif + break; + case 1: +#ifdef WIFEXITED + RETVAL = WIFEXITED(WMUNGE(status)); +#else + not_here("WIFEXITED"); +#endif + break; + case 2: +#ifdef WIFSIGNALED + RETVAL = WIFSIGNALED(WMUNGE(status)); +#else + not_here("WIFSIGNALED"); +#endif + break; + case 3: +#ifdef WIFSTOPPED + RETVAL = WIFSTOPPED(WMUNGE(status)); +#else + not_here("WIFSTOPPED"); +#endif + break; + case 4: +#ifdef WSTOPSIG + RETVAL = WSTOPSIG(WMUNGE(status)); +#else + not_here("WSTOPSIG"); +#endif + break; + case 5: +#ifdef WTERMSIG + RETVAL = WTERMSIG(WMUNGE(status)); +#else + not_here("WTERMSIG"); +#endif + break; + default: + Perl_croak(aTHX_ "Illegal alias %d for POSIX::W*", ix); + } + OUTPUT: + RETVAL int isalnum(charstring) - unsigned char * charstring + SV * charstring + PREINIT: + STRLEN len; CODE: - unsigned char *s = charstring; - unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ + unsigned char *s = (unsigned char *) SvPV(charstring, len); + unsigned char *e = s + len; for (RETVAL = 1; RETVAL && s < e; s++) if (!isalnum(*s)) RETVAL = 0; @@ -830,10 +957,12 @@ isalnum(charstring) int isalpha(charstring) - unsigned char * charstring + SV * charstring + PREINIT: + STRLEN len; CODE: - unsigned char *s = charstring; - unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ + unsigned char *s = (unsigned char *) SvPV(charstring, len); + unsigned char *e = s + len; for (RETVAL = 1; RETVAL && s < e; s++) if (!isalpha(*s)) RETVAL = 0; @@ -842,10 +971,12 @@ isalpha(charstring) int iscntrl(charstring) - unsigned char * charstring + SV * charstring + PREINIT: + STRLEN len; CODE: - unsigned char *s = charstring; - unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ + unsigned char *s = (unsigned char *) SvPV(charstring, len); + unsigned char *e = s + len; for (RETVAL = 1; RETVAL && s < e; s++) if (!iscntrl(*s)) RETVAL = 0; @@ -854,10 +985,12 @@ iscntrl(charstring) int isdigit(charstring) - unsigned char * charstring + SV * charstring + PREINIT: + STRLEN len; CODE: - unsigned char *s = charstring; - unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ + unsigned char *s = (unsigned char *) SvPV(charstring, len); + unsigned char *e = s + len; for (RETVAL = 1; RETVAL && s < e; s++) if (!isdigit(*s)) RETVAL = 0; @@ -866,10 +999,12 @@ isdigit(charstring) int isgraph(charstring) - unsigned char * charstring + SV * charstring + PREINIT: + STRLEN len; CODE: - unsigned char *s = charstring; - unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ + unsigned char *s = (unsigned char *) SvPV(charstring, len); + unsigned char *e = s + len; for (RETVAL = 1; RETVAL && s < e; s++) if (!isgraph(*s)) RETVAL = 0; @@ -878,10 +1013,12 @@ isgraph(charstring) int islower(charstring) - unsigned char * charstring + SV * charstring + PREINIT: + STRLEN len; CODE: - unsigned char *s = charstring; - unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ + unsigned char *s = (unsigned char *) SvPV(charstring, len); + unsigned char *e = s + len; for (RETVAL = 1; RETVAL && s < e; s++) if (!islower(*s)) RETVAL = 0; @@ -890,10 +1027,12 @@ islower(charstring) int isprint(charstring) - unsigned char * charstring + SV * charstring + PREINIT: + STRLEN len; CODE: - unsigned char *s = charstring; - unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ + unsigned char *s = (unsigned char *) SvPV(charstring, len); + unsigned char *e = s + len; for (RETVAL = 1; RETVAL && s < e; s++) if (!isprint(*s)) RETVAL = 0; @@ -902,10 +1041,12 @@ isprint(charstring) int ispunct(charstring) - unsigned char * charstring + SV * charstring + PREINIT: + STRLEN len; CODE: - unsigned char *s = charstring; - unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ + unsigned char *s = (unsigned char *) SvPV(charstring, len); + unsigned char *e = s + len; for (RETVAL = 1; RETVAL && s < e; s++) if (!ispunct(*s)) RETVAL = 0; @@ -914,10 +1055,12 @@ ispunct(charstring) int isspace(charstring) - unsigned char * charstring + SV * charstring + PREINIT: + STRLEN len; CODE: - unsigned char *s = charstring; - unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ + unsigned char *s = (unsigned char *) SvPV(charstring, len); + unsigned char *e = s + len; for (RETVAL = 1; RETVAL && s < e; s++) if (!isspace(*s)) RETVAL = 0; @@ -926,10 +1069,12 @@ isspace(charstring) int isupper(charstring) - unsigned char * charstring + SV * charstring + PREINIT: + STRLEN len; CODE: - unsigned char *s = charstring; - unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ + unsigned char *s = (unsigned char *) SvPV(charstring, len); + unsigned char *e = s + len; for (RETVAL = 1; RETVAL && s < e; s++) if (!isupper(*s)) RETVAL = 0; @@ -938,10 +1083,12 @@ isupper(charstring) int isxdigit(charstring) - unsigned char * charstring + SV * charstring + PREINIT: + STRLEN len; CODE: - unsigned char *s = charstring; - unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ + unsigned char *s = (unsigned char *) SvPV(charstring, len); + unsigned char *e = s + len; for (RETVAL = 1; RETVAL && s < e; s++) if (!isxdigit(*s)) RETVAL = 0; @@ -967,6 +1114,7 @@ localeconv() #ifdef HAS_LOCALECONV struct lconv *lcbuf; RETVAL = newHV(); + sv_2mortal((SV*)RETVAL); if ((lcbuf = localeconv())) { /* the strings */ if (lcbuf->decimal_point && *lcbuf->decimal_point) @@ -993,7 +1141,7 @@ localeconv() if (lcbuf->mon_thousands_sep && *lcbuf->mon_thousands_sep) hv_store(RETVAL, "mon_thousands_sep", 17, newSVpv(lcbuf->mon_thousands_sep, 0), 0); -#endif +#endif #ifndef NO_LOCALECONV_MON_GROUPING if (lcbuf->mon_grouping && *lcbuf->mon_grouping) hv_store(RETVAL, "mon_grouping", 12, @@ -1041,9 +1189,14 @@ char * setlocale(category, locale = 0) int category char * locale + PREINIT: + char * retval; CODE: - RETVAL = setlocale(category, locale); - if (RETVAL) { + retval = setlocale(category, locale); + if (retval) { + /* Save retval since subsequent setlocale() calls + * may overwrite it. */ + RETVAL = savepv(retval); #ifdef USE_LOCALE_CTYPE if (category == LC_CTYPE #ifdef LC_ALL @@ -1096,9 +1249,13 @@ setlocale(category, locale = 0) } #endif /* USE_LOCALE_NUMERIC */ } + else + RETVAL = NULL; OUTPUT: RETVAL - + CLEANUP: + if (RETVAL) + Safefree(RETVAL); NV acos(x) @@ -1181,8 +1338,9 @@ sigaction(sig, optaction, oldaction = 0) # interface look beautiful, which is hard. { + dVAR; POSIX__SigAction action; - GV *siggv = gv_fetchpv("SIG", TRUE, SVt_PVHV); + GV *siggv = gv_fetchpvs("SIG", GV_ADD, SVt_PVHV); struct sigaction act; struct sigaction oact; sigset_t sset; @@ -1190,10 +1348,38 @@ sigaction(sig, optaction, oldaction = 0) sigset_t osset; POSIX__SigSet sigset; SV** svp; - SV** sigsvp = hv_fetch(GvHVn(siggv), - PL_sig_name[sig], - strlen(PL_sig_name[sig]), - TRUE); + SV** sigsvp; + + if (sig < 0) { + croak("Negative signals are not allowed"); + } + + if (sig == 0 && SvPOK(ST(0))) { + const char *s = SvPVX_const(ST(0)); + int i = whichsig(s); + + if (i < 0 && memEQ(s, "SIG", 3)) + i = whichsig(s + 3); + if (i < 0) { + if (ckWARN(WARN_SIGNAL)) + Perl_warner(aTHX_ packWARN(WARN_SIGNAL), + "No such signal: SIG%s", s); + XSRETURN_UNDEF; + } + else + sig = i; + } +#ifdef NSIG + if (sig > NSIG) { /* NSIG - 1 is still okay. */ + Perl_warner(aTHX_ packWARN(WARN_SIGNAL), + "No such signal: %d", sig); + XSRETURN_UNDEF; + } +#endif + sigsvp = hv_fetch(GvHVn(siggv), + PL_sig_name[sig], + strlen(PL_sig_name[sig]), + TRUE); /* Check optaction and set action */ if(SvTRUE(optaction)) { @@ -1217,69 +1403,89 @@ sigaction(sig, optaction, oldaction = 0) XSRETURN_UNDEF; ENTER; /* Restore signal mask no matter how we exit this block. */ - osset_sv = newSVpv((char *)(&osset), sizeof(sigset_t)); + osset_sv = newSVpvn((char *)(&osset), sizeof(sigset_t)); SAVEFREESV( osset_sv ); - SAVEDESTRUCTOR(restore_sigmask, osset_sv); + SAVEDESTRUCTOR_X(restore_sigmask, osset_sv); RETVAL=-1; /* In case both oldaction and action are 0. */ /* Remember old disposition if desired. */ if (oldaction) { - svp = hv_fetch(oldaction, "HANDLER", 7, TRUE); + svp = hv_fetchs(oldaction, "HANDLER", TRUE); if(!svp) croak("Can't supply an oldaction without a HANDLER"); if(SvTRUE(*sigsvp)) { /* TBD: what if "0"? */ sv_setsv(*svp, *sigsvp); } else { - sv_setpv(*svp, "DEFAULT"); + sv_setpvs(*svp, "DEFAULT"); } RETVAL = sigaction(sig, (struct sigaction *)0, & oact); - if(RETVAL == -1) + if(RETVAL == -1) { + LEAVE; XSRETURN_UNDEF; + } /* Get back the mask. */ - svp = hv_fetch(oldaction, "MASK", 4, TRUE); + svp = hv_fetchs(oldaction, "MASK", TRUE); if (sv_isa(*svp, "POSIX::SigSet")) { IV tmp = SvIV((SV*)SvRV(*svp)); sigset = INT2PTR(sigset_t*, tmp); } else { - New(0, sigset, 1, sigset_t); + Newx(sigset, 1, sigset_t); sv_setptrobj(*svp, sigset, "POSIX::SigSet"); } *sigset = oact.sa_mask; /* Get back the flags. */ - svp = hv_fetch(oldaction, "FLAGS", 5, TRUE); + svp = hv_fetchs(oldaction, "FLAGS", TRUE); sv_setiv(*svp, oact.sa_flags); + + /* Get back whether the old handler used safe signals. */ + svp = hv_fetchs(oldaction, "SAFE", TRUE); + sv_setiv(*svp, + /* compare incompatible pointers by casting to integer */ + PTR2nat(oact.sa_handler) == PTR2nat(PL_csighandlerp)); } if (action) { - /* Vector new handler through %SIG. (We always use sighandler - for the C signal handler, which reads %SIG to dispatch.) */ - svp = hv_fetch(action, "HANDLER", 7, FALSE); + /* Safe signals use "csighandler", which vectors through the + PL_sighandlerp pointer when it's safe to do so. + (BTW, "csighandler" is very different from "sighandler".) */ + svp = hv_fetchs(action, "SAFE", FALSE); + act.sa_handler = + DPTR2FPTR( + void (*)(int), + (*svp && SvTRUE(*svp)) + ? PL_csighandlerp : PL_sighandlerp + ); + + /* Vector new Perl handler through %SIG. + (The core signal handlers read %SIG to dispatch.) */ + svp = hv_fetchs(action, "HANDLER", FALSE); if (!svp) croak("Can't supply an action without a HANDLER"); sv_setsv(*sigsvp, *svp); - mg_set(*sigsvp); /* handles DEFAULT and IGNORE */ + + /* This call actually calls sigaction() with almost the + right settings, including appropriate interpretation + of DEFAULT and IGNORE. However, why are we doing + this when we're about to do it again just below? XXX */ + mg_set(*sigsvp); + + /* And here again we duplicate -- DEFAULT/IGNORE checking. */ if(SvPOK(*svp)) { - char *s=SvPVX(*svp); + const char *s=SvPVX_const(*svp); if(strEQ(s,"IGNORE")) { act.sa_handler = SIG_IGN; } else if(strEQ(s,"DEFAULT")) { act.sa_handler = SIG_DFL; } - else { - act.sa_handler = PL_sighandlerp; - } - } - else { - act.sa_handler = PL_sighandlerp; } /* Set up any desired mask. */ - svp = hv_fetch(action, "MASK", 4, FALSE); + svp = hv_fetchs(action, "MASK", FALSE); if (svp && sv_isa(*svp, "POSIX::SigSet")) { IV tmp = SvIV((SV*)SvRV(*svp)); sigset = INT2PTR(sigset_t*, tmp); @@ -1289,7 +1495,7 @@ sigaction(sig, optaction, oldaction = 0) sigemptyset(& act.sa_mask); /* Set up any desired flags. */ - svp = hv_fetch(action, "FLAGS", 5, FALSE); + svp = hv_fetchs(action, "FLAGS", FALSE); act.sa_flags = svp ? SvIV(*svp) : 0; /* Don't worry about cleaning up *sigsvp if this fails, @@ -1298,8 +1504,10 @@ sigaction(sig, optaction, oldaction = 0) * essentially meaningless anyway. */ RETVAL = sigaction(sig, & act, (struct sigaction *)0); - if(RETVAL == -1) - XSRETURN_UNDEF; + if(RETVAL == -1) { + LEAVE; + XSRETURN_UNDEF; + } } LEAVE; @@ -1315,20 +1523,25 @@ sigpending(sigset) SysRet sigprocmask(how, sigset, oldsigset = 0) int how - POSIX::SigSet sigset + POSIX::SigSet sigset = NO_INIT POSIX::SigSet oldsigset = NO_INIT INIT: - if ( items < 3 ) { - oldsigset = 0; + if (! SvOK(ST(1))) { + sigset = NULL; + } else if (sv_isa(ST(1), "POSIX::SigSet")) { + IV tmp = SvIV((SV*)SvRV(ST(1))); + sigset = INT2PTR(POSIX__SigSet,tmp); + } else { + croak("sigset is not of type POSIX::SigSet"); } - else if (sv_derived_from(ST(2), "POSIX::SigSet")) { + + if (items < 3 || ! SvOK(ST(2))) { + oldsigset = NULL; + } else if (sv_isa(ST(2), "POSIX::SigSet")) { IV tmp = SvIV((SV*)SvRV(ST(2))); oldsigset = INT2PTR(POSIX__SigSet,tmp); - } - else { - New(0, oldsigset, 1, sigset_t); - sigemptyset(oldsigset); - sv_setref_pv(ST(2), "POSIX::SigSet", (void*)oldsigset); + } else { + croak("oldsigset is not of type POSIX::SigSet"); } SysRet @@ -1352,15 +1565,29 @@ dup2(fd1, fd2) int fd1 int fd2 -SysRetLong +SV * lseek(fd, offset, whence) int fd Off_t offset int whence + CODE: + Off_t pos = PerlLIO_lseek(fd, offset, whence); + RETVAL = sizeof(Off_t) > sizeof(IV) + ? newSVnv((NV)pos) : newSViv((IV)pos); + OUTPUT: + RETVAL -SysRet +void nice(incr) int incr + PPCODE: + errno = 0; + if ((incr = nice(incr)) != -1 || errno == 0) { + if (incr == 0) + XPUSHs(newSVpvs_flags("0 but true", SVs_TEMP)); + else + XPUSHs(sv_2mortal(newSViv(incr))); + } void pipe() @@ -1382,7 +1609,7 @@ read(fd, buffer, nbytes) char * buffer = sv_grow( sv_buffer, nbytes+1 ); CLEANUP: if (RETVAL >= 0) { - SvCUR(sv_buffer) = RETVAL; + SvCUR_set(sv_buffer, RETVAL); SvPOK_only(sv_buffer); *SvEND(sv_buffer) = '\0'; SvTAINTED_on(sv_buffer); @@ -1412,11 +1639,11 @@ uname() struct utsname buf; if (uname(&buf) >= 0) { EXTEND(SP, 5); - PUSHs(sv_2mortal(newSVpv(buf.sysname, 0))); - PUSHs(sv_2mortal(newSVpv(buf.nodename, 0))); - PUSHs(sv_2mortal(newSVpv(buf.release, 0))); - PUSHs(sv_2mortal(newSVpv(buf.version, 0))); - PUSHs(sv_2mortal(newSVpv(buf.machine, 0))); + PUSHs(newSVpvn_flags(buf.sysname, strlen(buf.sysname), SVs_TEMP)); + PUSHs(newSVpvn_flags(buf.nodename, strlen(buf.nodename), SVs_TEMP)); + PUSHs(newSVpvn_flags(buf.release, strlen(buf.release), SVs_TEMP)); + PUSHs(newSVpvn_flags(buf.version, strlen(buf.version), SVs_TEMP)); + PUSHs(newSVpvn_flags(buf.machine, strlen(buf.machine), SVs_TEMP)); } #else uname((char *) 0); /* A stub to call not_here(). */ @@ -1520,17 +1747,19 @@ strtol(str, base = 0) void strtoul(str, base = 0) - char * str + const char * str int base PREINIT: unsigned long num; char *unparsed; PPCODE: num = strtoul(str, &unparsed, base); - if (num <= IV_MAX) - PUSHs(sv_2mortal(newSViv((IV)num))); - else +#if IVSIZE <= LONGSIZE + if (num > IV_MAX) PUSHs(sv_2mortal(newSVnv((double)num))); + else +#endif + PUSHs(sv_2mortal(newSViv((IV)num))); if (GIMME == G_ARRAY) { EXTEND(SP, 1); if (unparsed) @@ -1548,7 +1777,7 @@ strxfrm(src) STRLEN dstlen; char *p = SvPV(src,srclen); srclen++; - ST(0) = sv_2mortal(NEWSV(800,srclen)); + ST(0) = sv_2mortal(newSV(srclen*4+1)); dstlen = strxfrm(SvPVX(ST(0)), p, (size_t)srclen); if (dstlen > srclen) { dstlen++; @@ -1556,7 +1785,7 @@ strxfrm(src) strxfrm(SvPVX(ST(0)), p, (size_t)dstlen); dstlen--; } - SvCUR(ST(0)) = dstlen; + SvCUR_set(ST(0), dstlen); SvPOK_only(ST(0)); } @@ -1592,7 +1821,7 @@ tcsendbreak(fd, duration) int duration char * -asctime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0) +asctime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1) int sec int min int hour @@ -1646,7 +1875,7 @@ difftime(time1, time2) Time_t time2 SysRetLong -mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0) +mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1) int sec int min int hour @@ -1669,7 +1898,7 @@ mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0) mytm.tm_wday = wday; mytm.tm_yday = yday; mytm.tm_isdst = isdst; - RETVAL = mktime(&mytm); + RETVAL = (SysRetLong) mktime(&mytm); } OUTPUT: RETVAL @@ -1679,7 +1908,7 @@ mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0) # ST(0) = sv_2mortal(newSVpv(...)) void strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1) - char * fmt + SV * fmt int sec int min int hour @@ -1691,22 +1920,28 @@ strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1) int isdst CODE: { - char *buf = my_strftime(fmt, sec, min, hour, mday, mon, year, wday, yday, isdst); + char *buf = my_strftime(SvPV_nolen(fmt), sec, min, hour, mday, mon, year, wday, yday, isdst); if (buf) { - ST(0) = sv_2mortal(newSVpv(buf, 0)); - Safefree(buf); + SV *const sv = sv_newmortal(); + sv_usepvn_flags(sv, buf, strlen(buf), SV_HAS_TRAILING_NUL); + if (SvUTF8(fmt)) { + SvUTF8_on(sv); + } + ST(0) = sv; } } void tzset() + PPCODE: + my_tzset(aTHX); void tzname() PPCODE: EXTEND(SP,2); - PUSHs(sv_2mortal(newSVpvn(tzname[0],strlen(tzname[0])))); - PUSHs(sv_2mortal(newSVpvn(tzname[1],strlen(tzname[1])))); + PUSHs(newSVpvn_flags(tzname[0], strlen(tzname[0]), SVs_TEMP)); + PUSHs(newSVpvn_flags(tzname[1], strlen(tzname[1]), SVs_TEMP)); SysRet access(filename, mode) @@ -1715,11 +1950,31 @@ access(filename, mode) char * ctermid(s = 0) - char * s = 0; + char * s = 0; + CODE: +#ifdef HAS_CTERMID_R + s = (char *) safemalloc((size_t) L_ctermid); +#endif + RETVAL = ctermid(s); + OUTPUT: + RETVAL + CLEANUP: +#ifdef HAS_CTERMID_R + Safefree(s); +#endif char * cuserid(s = 0) char * s = 0; + CODE: +#ifdef HAS_CUSERID + RETVAL = cuserid(s); +#else + RETVAL = 0; + not_here("cuserid"); +#endif + OUTPUT: + RETVAL SysRetLong fpathconf(fd, name) @@ -1737,10 +1992,24 @@ pause() SysRet setgid(gid) Gid_t gid + CLEANUP: +#ifndef WIN32 + if (RETVAL >= 0) { + PL_gid = getgid(); + PL_egid = getegid(); + } +#endif SysRet setuid(uid) Uid_t uid + CLEANUP: +#ifndef WIN32 + if (RETVAL >= 0) { + PL_uid = getuid(); + PL_euid = geteuid(); + } +#endif SysRetLong sysconf(name) @@ -1759,3 +2028,18 @@ getcwd() XSprePUSH; PUSHTARG; } +SysRet +lchown(uid, gid, path) + Uid_t uid + Gid_t gid + char * path + CODE: +#ifdef HAS_LCHOWN + /* yes, the order of arguments is different, + * but consistent with CORE::chown() */ + RETVAL = lchown(path, uid, gid); +#else + RETVAL = not_here("lchown"); +#endif + OUTPUT: + RETVAL