File Coverage

ext/POSIX/POSIX.xs
Criterion Covered Total %
statement 249 355 70.1
branch n/a
condition n/a
subroutine n/a
total 249 355 70.1


line stmt bran cond sub time code
1           #define PERL_EXT_POSIX
2            
3           #ifdef NETWARE
4           #define _POSIX_
5           /*
6           * Ideally this should be somewhere down in the includes
7           * but putting it in other places is giving compiler errors.
8           * Also here I am unable to check for HAS_UNAME since it wouldn't have
9           * yet come into the file at this stage - sgp 18th Oct 2000
10           */
11           #include
12           #endif /* NETWARE */
13            
14           #define PERL_NO_GET_CONTEXT
15            
16           #include "EXTERN.h"
17           #define PERLIO_NOT_STDIO 1
18           #include "perl.h"
19           #include "XSUB.h"
20           #if defined(PERL_IMPLICIT_SYS)
21           # undef signal
22           # undef open
23           # undef setmode
24           # define open PerlLIO_open3
25           #endif
26           #include
27           #ifdef I_DIRENT /* XXX maybe better to just rely on perl.h? */
28           #include
29           #endif
30           #include
31           #ifdef I_FLOAT
32           #include
33           #endif
34           #ifdef I_LIMITS
35           #include
36           #endif
37           #include
38           #include
39           #ifdef I_PWD
40           #include
41           #endif
42           #include
43           #include
44           #include
45            
46           #ifdef I_STDDEF
47           #include
48           #endif
49            
50           #ifdef I_UNISTD
51           #include
52           #endif
53            
54           /* XXX This comment is just to make I_TERMIO and I_SGTTY visible to
55           metaconfig for future extension writers. We don't use them in POSIX.
56           (This is really sneaky :-) --AD
57           */
58           #if defined(I_TERMIOS)
59           #include
60           #endif
61           #ifdef I_STDLIB
62           #include
63           #endif
64           #ifndef __ultrix__
65           #include
66           #endif
67           #include
68           #include
69           #include
70           #ifdef I_UNISTD
71           #include
72           #endif
73           #include
74            
75           #ifdef HAS_TZNAME
76           # if !defined(WIN32) && !defined(__CYGWIN__) && !defined(NETWARE) && !defined(__UWIN__)
77           extern char *tzname[];
78           # endif
79           #else
80           #if !defined(WIN32) && !defined(__UWIN__) || (defined(__MINGW32__) && !defined(tzname))
81           char *tzname[] = { "" , "" };
82           #endif
83           #endif
84            
85           #if defined(__VMS) && !defined(__POSIX_SOURCE)
86           # include /* LIB$_INVARG constant */
87           # include /* prototype for lib$ediv() */
88           # include /* prototype for sys$gettim() */
89           # if DECC_VERSION < 50000000
90           # define pid_t int /* old versions of DECC miss this in types.h */
91           # endif
92            
93           # undef mkfifo
94           # define mkfifo(a,b) (not_here("mkfifo"),-1)
95           # define tzset() not_here("tzset")
96            
97           #if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)
98           # define HAS_TZNAME /* shows up in VMS 7.0 or Dec C 5.6 */
99           # include
100           # endif /* __VMS_VER >= 70000000 or Dec C 5.6 */
101            
102           /* The POSIX notion of ttyname() is better served by getname() under VMS */
103           static char ttnambuf[64];
104           # define ttyname(fd) (isatty(fd) > 0 ? getname(fd,ttnambuf,0) : NULL)
105            
106           /* The non-POSIX CRTL times() has void return type, so we just get the
107           current time directly */
108           clock_t vms_times(struct tms *bufptr) {
109           dTHX;
110           clock_t retval;
111           /* Get wall time and convert to 10 ms intervals to
112           * produce the return value that the POSIX standard expects */
113           # if defined(__DECC) && defined (__ALPHA)
114           # include
115           uint64 vmstime;
116           _ckvmssts(sys$gettim(&vmstime));
117           vmstime /= 100000;
118           retval = vmstime & 0x7fffffff;
119           # else
120           /* (Older hw or ccs don't have an atomic 64-bit type, so we
121           * juggle 32-bit ints (and a float) to produce a time_t result
122           * with minimal loss of information.) */
123           long int vmstime[2],remainder,divisor = 100000;
124           _ckvmssts(sys$gettim((unsigned long int *)vmstime));
125           vmstime[1] &= 0x7fff; /* prevent overflow in EDIV */
126           _ckvmssts(lib$ediv(&divisor,vmstime,(long int *)&retval,&remainder));
127           # endif
128           /* Fill in the struct tms using the CRTL routine . . .*/
129           times((tbuffer_t *)bufptr);
130           return (clock_t) retval;
131           }
132           # define times(t) vms_times(t)
133           #else
134           #if defined (__CYGWIN__)
135           # define tzname _tzname
136           #endif
137           #if defined (WIN32) || defined (NETWARE)
138           # undef mkfifo
139           # define mkfifo(a,b) not_here("mkfifo")
140           # define ttyname(a) (char*)not_here("ttyname")
141           # define sigset_t long
142           # define pid_t long
143           # ifdef _MSC_VER
144           # define mode_t short
145           # endif
146           # ifdef __MINGW32__
147           # define mode_t short
148           # ifndef tzset
149           # define tzset() not_here("tzset")
150           # endif
151           # ifndef _POSIX_OPEN_MAX
152           # define _POSIX_OPEN_MAX FOPEN_MAX /* XXX bogus ? */
153           # endif
154           # endif
155           # define sigaction(a,b,c) not_here("sigaction")
156           # define sigpending(a) not_here("sigpending")
157           # define sigprocmask(a,b,c) not_here("sigprocmask")
158           # define sigsuspend(a) not_here("sigsuspend")
159           # define sigemptyset(a) not_here("sigemptyset")
160           # define sigaddset(a,b) not_here("sigaddset")
161           # define sigdelset(a,b) not_here("sigdelset")
162           # define sigfillset(a) not_here("sigfillset")
163           # define sigismember(a,b) not_here("sigismember")
164           #ifndef NETWARE
165           # undef setuid
166           # undef setgid
167           # define setuid(a) not_here("setuid")
168           # define setgid(a) not_here("setgid")
169           #endif /* NETWARE */
170           #else
171            
172           # ifndef HAS_MKFIFO
173           # if defined(OS2)
174           # define mkfifo(a,b) not_here("mkfifo")
175           # else /* !( defined OS2 ) */
176           # ifndef mkfifo
177           # define mkfifo(path, mode) (mknod((path), (mode) | S_IFIFO, 0))
178           # endif
179           # endif
180           # endif /* !HAS_MKFIFO */
181            
182           # ifdef I_GRP
183           # include
184           # endif
185           # include
186           # ifdef HAS_UNAME
187           # include
188           # endif
189           # include
190           # ifdef I_UTIME
191           # include
192           # endif
193           #endif /* WIN32 || NETWARE */
194           #endif /* __VMS */
195            
196           #ifdef WIN32
197           /* Perl on Windows assigns WSAGetLastError() return values to errno
198           * (in win32/win32sck.c). Therefore we need to map these values
199           * back to standard symbolic names, but only for those names having
200           * no existing value or an existing value >= 100. (VC++ 2010 defines
201           * a group of names with values >= 100 in its errno.h which we *do*
202           * need to redefine.) The Errno.pm module does a similar mapping.
203           */
204           # ifdef EWOULDBLOCK
205           # undef EWOULDBLOCK
206           # endif
207           # define EWOULDBLOCK WSAEWOULDBLOCK
208           # ifdef EINPROGRESS
209           # undef EINPROGRESS
210           # endif
211           # define EINPROGRESS WSAEINPROGRESS
212           # ifdef EALREADY
213           # undef EALREADY
214           # endif
215           # define EALREADY WSAEALREADY
216           # ifdef ENOTSOCK
217           # undef ENOTSOCK
218           # endif
219           # define ENOTSOCK WSAENOTSOCK
220           # ifdef EDESTADDRREQ
221           # undef EDESTADDRREQ
222           # endif
223           # define EDESTADDRREQ WSAEDESTADDRREQ
224           # ifdef EMSGSIZE
225           # undef EMSGSIZE
226           # endif
227           # define EMSGSIZE WSAEMSGSIZE
228           # ifdef EPROTOTYPE
229           # undef EPROTOTYPE
230           # endif
231           # define EPROTOTYPE WSAEPROTOTYPE
232           # ifdef ENOPROTOOPT
233           # undef ENOPROTOOPT
234           # endif
235           # define ENOPROTOOPT WSAENOPROTOOPT
236           # ifdef EPROTONOSUPPORT
237           # undef EPROTONOSUPPORT
238           # endif
239           # define EPROTONOSUPPORT WSAEPROTONOSUPPORT
240           # ifdef ESOCKTNOSUPPORT
241           # undef ESOCKTNOSUPPORT
242           # endif
243           # define ESOCKTNOSUPPORT WSAESOCKTNOSUPPORT
244           # ifdef EOPNOTSUPP
245           # undef EOPNOTSUPP
246           # endif
247           # define EOPNOTSUPP WSAEOPNOTSUPP
248           # ifdef EPFNOSUPPORT
249           # undef EPFNOSUPPORT
250           # endif
251           # define EPFNOSUPPORT WSAEPFNOSUPPORT
252           # ifdef EAFNOSUPPORT
253           # undef EAFNOSUPPORT
254           # endif
255           # define EAFNOSUPPORT WSAEAFNOSUPPORT
256           # ifdef EADDRINUSE
257           # undef EADDRINUSE
258           # endif
259           # define EADDRINUSE WSAEADDRINUSE
260           # ifdef EADDRNOTAVAIL
261           # undef EADDRNOTAVAIL
262           # endif
263           # define EADDRNOTAVAIL WSAEADDRNOTAVAIL
264           # ifdef ENETDOWN
265           # undef ENETDOWN
266           # endif
267           # define ENETDOWN WSAENETDOWN
268           # ifdef ENETUNREACH
269           # undef ENETUNREACH
270           # endif
271           # define ENETUNREACH WSAENETUNREACH
272           # ifdef ENETRESET
273           # undef ENETRESET
274           # endif
275           # define ENETRESET WSAENETRESET
276           # ifdef ECONNABORTED
277           # undef ECONNABORTED
278           # endif
279           # define ECONNABORTED WSAECONNABORTED
280           # ifdef ECONNRESET
281           # undef ECONNRESET
282           # endif
283           # define ECONNRESET WSAECONNRESET
284           # ifdef ENOBUFS
285           # undef ENOBUFS
286           # endif
287           # define ENOBUFS WSAENOBUFS
288           # ifdef EISCONN
289           # undef EISCONN
290           # endif
291           # define EISCONN WSAEISCONN
292           # ifdef ENOTCONN
293           # undef ENOTCONN
294           # endif
295           # define ENOTCONN WSAENOTCONN
296           # ifdef ESHUTDOWN
297           # undef ESHUTDOWN
298           # endif
299           # define ESHUTDOWN WSAESHUTDOWN
300           # ifdef ETOOMANYREFS
301           # undef ETOOMANYREFS
302           # endif
303           # define ETOOMANYREFS WSAETOOMANYREFS
304           # ifdef ETIMEDOUT
305           # undef ETIMEDOUT
306           # endif
307           # define ETIMEDOUT WSAETIMEDOUT
308           # ifdef ECONNREFUSED
309           # undef ECONNREFUSED
310           # endif
311           # define ECONNREFUSED WSAECONNREFUSED
312           # ifdef ELOOP
313           # undef ELOOP
314           # endif
315           # define ELOOP WSAELOOP
316           # ifdef EHOSTDOWN
317           # undef EHOSTDOWN
318           # endif
319           # define EHOSTDOWN WSAEHOSTDOWN
320           # ifdef EHOSTUNREACH
321           # undef EHOSTUNREACH
322           # endif
323           # define EHOSTUNREACH WSAEHOSTUNREACH
324           # ifdef EPROCLIM
325           # undef EPROCLIM
326           # endif
327           # define EPROCLIM WSAEPROCLIM
328           # ifdef EUSERS
329           # undef EUSERS
330           # endif
331           # define EUSERS WSAEUSERS
332           # ifdef EDQUOT
333           # undef EDQUOT
334           # endif
335           # define EDQUOT WSAEDQUOT
336           # ifdef ESTALE
337           # undef ESTALE
338           # endif
339           # define ESTALE WSAESTALE
340           # ifdef EREMOTE
341           # undef EREMOTE
342           # endif
343           # define EREMOTE WSAEREMOTE
344           # ifdef EDISCON
345           # undef EDISCON
346           # endif
347           # define EDISCON WSAEDISCON
348           #endif
349            
350           typedef int SysRet;
351           typedef long SysRetLong;
352           typedef sigset_t* POSIX__SigSet;
353           typedef HV* POSIX__SigAction;
354           #ifdef I_TERMIOS
355           typedef struct termios* POSIX__Termios;
356           #else /* Define termios types to int, and call not_here for the functions.*/
357           #define POSIX__Termios int
358           #define speed_t int
359           #define tcflag_t int
360           #define cc_t int
361           #define cfgetispeed(x) not_here("cfgetispeed")
362           #define cfgetospeed(x) not_here("cfgetospeed")
363           #define tcdrain(x) not_here("tcdrain")
364           #define tcflush(x,y) not_here("tcflush")
365           #define tcsendbreak(x,y) not_here("tcsendbreak")
366           #define cfsetispeed(x,y) not_here("cfsetispeed")
367           #define cfsetospeed(x,y) not_here("cfsetospeed")
368           #define ctermid(x) (char *) not_here("ctermid")
369           #define tcflow(x,y) not_here("tcflow")
370           #define tcgetattr(x,y) not_here("tcgetattr")
371           #define tcsetattr(x,y,z) not_here("tcsetattr")
372           #endif
373            
374           /* Possibly needed prototypes */
375           #ifndef WIN32
376           START_EXTERN_C
377           double strtod (const char *, char **);
378           long strtol (const char *, char **, int);
379           unsigned long strtoul (const char *, char **, int);
380           END_EXTERN_C
381           #endif
382            
383           #ifndef HAS_DIFFTIME
384           #ifndef difftime
385           #define difftime(a,b) not_here("difftime")
386           #endif
387           #endif
388           #ifndef HAS_FPATHCONF
389           #define fpathconf(f,n) (SysRetLong) not_here("fpathconf")
390           #endif
391           #ifndef HAS_MKTIME
392           #define mktime(a) not_here("mktime")
393           #endif
394           #ifndef HAS_NICE
395           #define nice(a) not_here("nice")
396           #endif
397           #ifndef HAS_PATHCONF
398           #define pathconf(f,n) (SysRetLong) not_here("pathconf")
399           #endif
400           #ifndef HAS_SYSCONF
401           #define sysconf(n) (SysRetLong) not_here("sysconf")
402           #endif
403           #ifndef HAS_READLINK
404           #define readlink(a,b,c) not_here("readlink")
405           #endif
406           #ifndef HAS_SETPGID
407           #define setpgid(a,b) not_here("setpgid")
408           #endif
409           #ifndef HAS_SETSID
410           #define setsid() not_here("setsid")
411           #endif
412           #ifndef HAS_STRCOLL
413           #define strcoll(s1,s2) not_here("strcoll")
414           #endif
415           #ifndef HAS_STRTOD
416           #define strtod(s1,s2) not_here("strtod")
417           #endif
418           #ifndef HAS_STRTOL
419           #define strtol(s1,s2,b) not_here("strtol")
420           #endif
421           #ifndef HAS_STRTOUL
422           #define strtoul(s1,s2,b) not_here("strtoul")
423           #endif
424           #ifndef HAS_STRXFRM
425           #define strxfrm(s1,s2,n) not_here("strxfrm")
426           #endif
427           #ifndef HAS_TCGETPGRP
428           #define tcgetpgrp(a) not_here("tcgetpgrp")
429           #endif
430           #ifndef HAS_TCSETPGRP
431           #define tcsetpgrp(a,b) not_here("tcsetpgrp")
432           #endif
433           #ifndef HAS_TIMES
434           #ifndef NETWARE
435           #define times(a) not_here("times")
436           #endif /* NETWARE */
437           #endif
438           #ifndef HAS_UNAME
439           #define uname(a) not_here("uname")
440           #endif
441           #ifndef HAS_WAITPID
442           #define waitpid(a,b,c) not_here("waitpid")
443           #endif
444            
445           #ifndef HAS_MBLEN
446           #ifndef mblen
447           #define mblen(a,b) not_here("mblen")
448           #endif
449           #endif
450           #ifndef HAS_MBSTOWCS
451           #define mbstowcs(s, pwcs, n) not_here("mbstowcs")
452           #endif
453           #ifndef HAS_MBTOWC
454           #define mbtowc(pwc, s, n) not_here("mbtowc")
455           #endif
456           #ifndef HAS_WCSTOMBS
457           #define wcstombs(s, pwcs, n) not_here("wcstombs")
458           #endif
459           #ifndef HAS_WCTOMB
460           #define wctomb(s, wchar) not_here("wcstombs")
461           #endif
462           #if !defined(HAS_MBLEN) && !defined(HAS_MBSTOWCS) && !defined(HAS_MBTOWC) && !defined(HAS_WCSTOMBS) && !defined(HAS_WCTOMB)
463           /* If we don't have these functions, then we wouldn't have gotten a typedef
464           for wchar_t, the wide character type. Defining wchar_t allows the
465           functions referencing it to compile. Its actual type is then meaningless,
466           since without the above functions, all sections using it end up calling
467           not_here() and croak. --Kaveh Ghazi (ghazi@noc.rutgers.edu) 9/18/94. */
468           #ifndef wchar_t
469           #define wchar_t char
470           #endif
471           #endif
472            
473           #ifdef HAS_LOCALECONV
474           struct lconv_offset {
475           const char *name;
476           size_t offset;
477           };
478            
479           const struct lconv_offset lconv_strings[] = {
480           {"decimal_point", offsetof(struct lconv, decimal_point)},
481           {"thousands_sep", offsetof(struct lconv, thousands_sep)},
482           #ifndef NO_LOCALECONV_GROUPING
483           {"grouping", offsetof(struct lconv, grouping)},
484           #endif
485           {"int_curr_symbol", offsetof(struct lconv, int_curr_symbol)},
486           {"currency_symbol", offsetof(struct lconv, currency_symbol)},
487           {"mon_decimal_point", offsetof(struct lconv, mon_decimal_point)},
488           #ifndef NO_LOCALECONV_MON_THOUSANDS_SEP
489           {"mon_thousands_sep", offsetof(struct lconv, mon_thousands_sep)},
490           #endif
491           #ifndef NO_LOCALECONV_MON_GROUPING
492           {"mon_grouping", offsetof(struct lconv, mon_grouping)},
493           #endif
494           {"positive_sign", offsetof(struct lconv, positive_sign)},
495           {"negative_sign", offsetof(struct lconv, negative_sign)},
496           {NULL, 0}
497           };
498            
499           const struct lconv_offset lconv_integers[] = {
500           {"int_frac_digits", offsetof(struct lconv, int_frac_digits)},
501           {"frac_digits", offsetof(struct lconv, frac_digits)},
502           {"p_cs_precedes", offsetof(struct lconv, p_cs_precedes)},
503           {"p_sep_by_space", offsetof(struct lconv, p_sep_by_space)},
504           {"n_cs_precedes", offsetof(struct lconv, n_cs_precedes)},
505           {"n_sep_by_space", offsetof(struct lconv, n_sep_by_space)},
506           {"p_sign_posn", offsetof(struct lconv, p_sign_posn)},
507           {"n_sign_posn", offsetof(struct lconv, n_sign_posn)},
508           {NULL, 0}
509           };
510            
511           #else
512           #define localeconv() not_here("localeconv")
513           #endif
514            
515           #ifdef HAS_LONG_DOUBLE
516           # if LONG_DOUBLESIZE > NVSIZE
517           # undef HAS_LONG_DOUBLE /* XXX until we figure out how to use them */
518           # endif
519           #endif
520            
521           #ifndef HAS_LONG_DOUBLE
522           #ifdef LDBL_MAX
523           #undef LDBL_MAX
524           #endif
525           #ifdef LDBL_MIN
526           #undef LDBL_MIN
527           #endif
528           #ifdef LDBL_EPSILON
529           #undef LDBL_EPSILON
530           #endif
531           #endif
532            
533           /* Background: in most systems the low byte of the wait status
534           * is the signal (the lowest 7 bits) and the coredump flag is
535           * the eight bit, and the second lowest byte is the exit status.
536           * BeOS bucks the trend and has the bytes in different order.
537           * See beos/beos.c for how the reality is bent even in BeOS
538           * to follow the traditional. However, to make the POSIX
539           * wait W*() macros to work in BeOS, we need to unbend the
540           * reality back in place. --jhi */
541           /* In actual fact the code below is to blame here. Perl has an internal
542           * representation of the exit status ($?), which it re-composes from the
543           * OS's representation using the W*() POSIX macros. The code below
544           * incorrectly uses the W*() macros on the internal representation,
545           * which fails for OSs that have a different representation (namely BeOS
546           * and Haiku). WMUNGE() is a hack that converts the internal
547           * representation into the OS specific one, so that the W*() macros work
548           * as expected. The better solution would be not to use the W*() macros
549           * in the first place, though. -- Ingo Weinhold
550           */
551           #if defined(__HAIKU__)
552           # define WMUNGE(x) (((x) & 0xFF00) >> 8 | ((x) & 0x00FF) << 8)
553           #else
554           # define WMUNGE(x) (x)
555           #endif
556            
557           static int
558           not_here(const char *s)
559           {
560           croak("POSIX::%s not implemented on this architecture", s);
561           return -1;
562           }
563            
564           #include "const-c.inc"
565            
566           static void
567 52         restore_sigmask(pTHX_ SV *osset_sv)
568           {
569           /* Fortunately, restoring the signal mask can't fail, because
570           * there's nothing we can do about it if it does -- we're not
571           * supposed to return -1 from sigaction unless the disposition
572           * was unaffected.
573           */
574 52         sigset_t *ossetp = (sigset_t *) SvPV_nolen( osset_sv );
575 52         (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
576 52         }
577            
578           static void *
579 40         allocate_struct(pTHX_ SV *rv, const STRLEN size, const char *packname) {
580 40         SV *const t = newSVrv(rv, packname);
581 40         void *const p = sv_grow(t, size + 1);
582            
583 40         SvCUR_set(t, size);
584 40         SvPOK_on(t);
585 40         return p;
586           }
587            
588           #ifdef WIN32
589            
590           /*
591           * (1) The CRT maintains its own copy of the environment, separate from
592           * the Win32API copy.
593           *
594           * (2) CRT getenv() retrieves from this copy. CRT putenv() updates this
595           * copy, and then calls SetEnvironmentVariableA() to update the Win32API
596           * copy.
597           *
598           * (3) win32_getenv() and win32_putenv() call GetEnvironmentVariableA() and
599           * SetEnvironmentVariableA() directly, bypassing the CRT copy of the
600           * environment.
601           *
602           * (4) The CRT strftime() "%Z" implementation calls __tzset(). That
603           * calls CRT tzset(), but only the first time it is called, and in turn
604           * that uses CRT getenv("TZ") to retrieve the timezone info from the CRT
605           * local copy of the environment and hence gets the original setting as
606           * perl never updates the CRT copy when assigning to $ENV{TZ}.
607           *
608           * Therefore, we need to retrieve the value of $ENV{TZ} and call CRT
609           * putenv() to update the CRT copy of the environment (if it is different)
610           * whenever we're about to call tzset().
611           *
612           * In addition to all that, when perl is built with PERL_IMPLICIT_SYS
613           * defined:
614           *
615           * (a) Each interpreter has its own copy of the environment inside the
616           * perlhost structure. That allows applications that host multiple
617           * independent Perl interpreters to isolate environment changes from
618           * each other. (This is similar to how the perlhost mechanism keeps a
619           * separate working directory for each Perl interpreter, so that calling
620           * chdir() will not affect other interpreters.)
621           *
622           * (b) Only the first Perl interpreter instantiated within a process will
623           * "write through" environment changes to the process environment.
624           *
625           * (c) Even the primary Perl interpreter won't update the CRT copy of the
626           * the environment, only the Win32API copy (it calls win32_putenv()).
627           *
628           * As with CPerlHost::Getenv() and CPerlHost::Putenv() themselves, it makes
629           * sense to only update the process environment when inside the main
630           * interpreter, but we don't have access to CPerlHost's m_bTopLevel member
631           * from here so we'll just have to check PL_curinterp instead.
632           *
633           * Therefore, we can simply #undef getenv() and putenv() so that those names
634           * always refer to the CRT functions, and explicitly call win32_getenv() to
635           * access perl's %ENV.
636           *
637           * We also #undef malloc() and free() to be sure we are using the CRT
638           * functions otherwise under PERL_IMPLICIT_SYS they are redefined to calls
639           * into VMem::Malloc() and VMem::Free() and all allocations will be freed
640           * when the Perl interpreter is being destroyed so we'd end up with a pointer
641           * into deallocated memory in environ[] if a program embedding a Perl
642           * interpreter continues to operate even after the main Perl interpreter has
643           * been destroyed.
644           *
645           * Note that we don't free() the malloc()ed memory unless and until we call
646           * malloc() again ourselves because the CRT putenv() function simply puts its
647           * pointer argument into the environ[] array (it doesn't make a copy of it)
648           * so this memory must otherwise be leaked.
649           */
650            
651           #undef getenv
652           #undef putenv
653           #undef malloc
654           #undef free
655            
656           static void
657           fix_win32_tzenv(void)
658           {
659           static char* oldenv = NULL;
660           char* newenv;
661           const char* perl_tz_env = win32_getenv("TZ");
662           const char* crt_tz_env = getenv("TZ");
663           if (perl_tz_env == NULL)
664           perl_tz_env = "";
665           if (crt_tz_env == NULL)
666           crt_tz_env = "";
667           if (strcmp(perl_tz_env, crt_tz_env) != 0) {
668           newenv = (char*)malloc((strlen(perl_tz_env) + 4) * sizeof(char));
669           if (newenv != NULL) {
670           sprintf(newenv, "TZ=%s", perl_tz_env);
671           putenv(newenv);
672           if (oldenv != NULL)
673           free(oldenv);
674           oldenv = newenv;
675           }
676           }
677           }
678            
679           #endif
680            
681           /*
682           * my_tzset - wrapper to tzset() with a fix to make it work (better) on Win32.
683           * This code is duplicated in the Time-Piece module, so any changes made here
684           * should be made there too.
685           */
686           static void
687           my_tzset(pTHX)
688           {
689           #ifdef WIN32
690           #if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
691           if (PL_curinterp == aTHX)
692           #endif
693           fix_win32_tzenv();
694           #endif
695 2         tzset();
696           }
697            
698           typedef int (*isfunc_t)(int);
699           typedef void (*any_dptr_t)(void *);
700            
701           /* This needs to be ALIASed in a custom way, hence can't easily be defined as
702           a regular XSUB. */
703           static XSPROTO(is_common); /* prototype to pass -Wmissing-prototypes */
704 418         static XSPROTO(is_common)
705           {
706 418         dXSARGS;
707 418         if (items != 1)
708 0         croak_xs_usage(cv, "charstring");
709            
710           {
711 418         dXSTARG;
712           STRLEN len;
713           int RETVAL;
714 418         unsigned char *s = (unsigned char *) SvPV(ST(0), len);
715 418         unsigned char *e = s + len;
716 418         isfunc_t isfunc = (isfunc_t) XSANY.any_dptr;
717            
718 1000         for (RETVAL = 1; RETVAL && s < e; s++)
719 582         if (!isfunc(*s))
720           RETVAL = 0;
721 418         XSprePUSH;
722 418         PUSHi((IV)RETVAL);
723           }
724 418         XSRETURN(1);
725           }
726            
727           MODULE = POSIX PACKAGE = POSIX
728            
729           BOOT:
730           {
731           CV *cv;
732           const char *file = __FILE__;
733            
734           /* Ensure we get the function, not a macro implementation. Like the C89
735           standard says we can... */
736           #undef isalnum
737 1188         cv = newXS("POSIX::isalnum", is_common, file);
738 1188         XSANY.any_dptr = (any_dptr_t) &isalnum;
739           #undef isalpha
740 1188         cv = newXS("POSIX::isalpha", is_common, file);
741 1188         XSANY.any_dptr = (any_dptr_t) &isalpha;
742           #undef iscntrl
743 1188         cv = newXS("POSIX::iscntrl", is_common, file);
744 1188         XSANY.any_dptr = (any_dptr_t) &iscntrl;
745           #undef isdigit
746 1188         cv = newXS("POSIX::isdigit", is_common, file);
747 1188         XSANY.any_dptr = (any_dptr_t) &isdigit;
748           #undef isgraph
749 1188         cv = newXS("POSIX::isgraph", is_common, file);
750 1188         XSANY.any_dptr = (any_dptr_t) &isgraph;
751           #undef islower
752 1188         cv = newXS("POSIX::islower", is_common, file);
753 1188         XSANY.any_dptr = (any_dptr_t) &islower;
754           #undef isprint
755 1188         cv = newXS("POSIX::isprint", is_common, file);
756 1188         XSANY.any_dptr = (any_dptr_t) &isprint;
757           #undef ispunct
758 1188         cv = newXS("POSIX::ispunct", is_common, file);
759 1188         XSANY.any_dptr = (any_dptr_t) &ispunct;
760           #undef isspace
761 1188         cv = newXS("POSIX::isspace", is_common, file);
762 1188         XSANY.any_dptr = (any_dptr_t) &isspace;
763           #undef isupper
764 1188         cv = newXS("POSIX::isupper", is_common, file);
765 1188         XSANY.any_dptr = (any_dptr_t) &isupper;
766           #undef isxdigit
767 1188         cv = newXS("POSIX::isxdigit", is_common, file);
768 1188         XSANY.any_dptr = (any_dptr_t) &isxdigit;
769           }
770            
771           MODULE = SigSet PACKAGE = POSIX::SigSet PREFIX = sig
772            
773           void
774           new(packname = "POSIX::SigSet", ...)
775           const char * packname
776           CODE:
777           {
778           int i;
779 30         sigset_t *const s
780 30         = (sigset_t *) allocate_struct(aTHX_ (ST(0) = sv_newmortal()),
781           sizeof(sigset_t),
782           packname);
783 30         sigemptyset(s);
784 48         for (i = 1; i < items; i++)
785 18         sigaddset(s, SvIV(ST(i)));
786 30         XSRETURN(1);
787           }
788            
789           SysRet
790           addset(sigset, sig)
791           POSIX::SigSet sigset
792           int sig
793           ALIAS:
794           delset = 1
795           CODE:
796 30         RETVAL = ix ? sigdelset(sigset, sig) : sigaddset(sigset, sig);
797           OUTPUT:
798           RETVAL
799            
800           SysRet
801           emptyset(sigset)
802           POSIX::SigSet sigset
803           ALIAS:
804           fillset = 1
805           CODE:
806 6         RETVAL = ix ? sigfillset(sigset) : sigemptyset(sigset);
807           OUTPUT:
808           RETVAL
809            
810           int
811           sigismember(sigset, sig)
812           POSIX::SigSet sigset
813           int sig
814            
815           MODULE = Termios PACKAGE = POSIX::Termios PREFIX = cf
816            
817           void
818           new(packname = "POSIX::Termios", ...)
819           const char * packname
820           CODE:
821           {
822           #ifdef I_TERMIOS
823 4         void *const p = allocate_struct(aTHX_ (ST(0) = sv_newmortal()),
824           sizeof(struct termios), packname);
825           /* The previous implementation stored a pointer to an uninitialised
826           struct termios. Seems safer to initialise it, particularly as
827           this implementation exposes the struct to prying from perl-space.
828           */
829           memset(p, 0, 1 + sizeof(struct termios));
830 4         XSRETURN(1);
831           #else
832           not_here("termios");
833           #endif
834           }
835            
836           SysRet
837           getattr(termios_ref, fd = 0)
838           POSIX::Termios termios_ref
839           int fd
840           CODE:
841 4         RETVAL = tcgetattr(fd, termios_ref);
842           OUTPUT:
843           RETVAL
844            
845           # If we define TCSANOW here then both a found and not found constant sub
846           # are created causing a Constant subroutine TCSANOW redefined warning
847           #ifndef TCSANOW
848           # define DEF_SETATTR_ACTION 0
849           #else
850           # define DEF_SETATTR_ACTION TCSANOW
851           #endif
852           SysRet
853           setattr(termios_ref, fd = 0, optional_actions = DEF_SETATTR_ACTION)
854           POSIX::Termios termios_ref
855           int fd
856           int optional_actions
857           CODE:
858           /* The second argument to the call is mandatory, but we'd like to give
859           it a useful default. 0 isn't valid on all operating systems - on
860           Solaris (at least) TCSANOW, TCSADRAIN and TCSAFLUSH have the same
861           values as the equivalent ioctls, TCSETS, TCSETSW and TCSETSF. */
862 0         RETVAL = tcsetattr(fd, optional_actions, termios_ref);
863           OUTPUT:
864           RETVAL
865            
866           speed_t
867           getispeed(termios_ref)
868           POSIX::Termios termios_ref
869           ALIAS:
870           getospeed = 1
871           CODE:
872 8         RETVAL = ix ? cfgetospeed(termios_ref) : cfgetispeed(termios_ref);
873           OUTPUT:
874           RETVAL
875            
876           tcflag_t
877           getiflag(termios_ref)
878           POSIX::Termios termios_ref
879           ALIAS:
880           getoflag = 1
881           getcflag = 2
882           getlflag = 3
883           CODE:
884           #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
885 0         switch(ix) {
886           case 0:
887 0         RETVAL = termios_ref->c_iflag;
888 0         break;
889           case 1:
890 0         RETVAL = termios_ref->c_oflag;
891 0         break;
892           case 2:
893 0         RETVAL = termios_ref->c_cflag;
894 0         break;
895           case 3:
896 0         RETVAL = termios_ref->c_lflag;
897 0         break;
898           }
899           #else
900           not_here(GvNAME(CvGV(cv)));
901           RETVAL = 0;
902           #endif
903           OUTPUT:
904           RETVAL
905            
906           cc_t
907           getcc(termios_ref, ccix)
908           POSIX::Termios termios_ref
909           unsigned int ccix
910           CODE:
911           #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
912 0         if (ccix >= NCCS)
913 0         croak("Bad getcc subscript");
914 0         RETVAL = termios_ref->c_cc[ccix];
915           #else
916           not_here("getcc");
917           RETVAL = 0;
918           #endif
919           OUTPUT:
920           RETVAL
921            
922           SysRet
923           setispeed(termios_ref, speed)
924           POSIX::Termios termios_ref
925           speed_t speed
926           ALIAS:
927           setospeed = 1
928           CODE:
929           RETVAL = ix
930 0         ? cfsetospeed(termios_ref, speed) : cfsetispeed(termios_ref, speed);
931           OUTPUT:
932           RETVAL
933            
934           void
935           setiflag(termios_ref, flag)
936           POSIX::Termios termios_ref
937           tcflag_t flag
938           ALIAS:
939           setoflag = 1
940           setcflag = 2
941           setlflag = 3
942           CODE:
943           #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
944 0         switch(ix) {
945           case 0:
946 0         termios_ref->c_iflag = flag;
947 0         break;
948           case 1:
949 0         termios_ref->c_oflag = flag;
950 0         break;
951           case 2:
952 0         termios_ref->c_cflag = flag;
953 0         break;
954           case 3:
955 0         termios_ref->c_lflag = flag;
956 0         break;
957           }
958           #else
959           not_here(GvNAME(CvGV(cv)));
960           #endif
961            
962           void
963           setcc(termios_ref, ccix, cc)
964           POSIX::Termios termios_ref
965           unsigned int ccix
966           cc_t cc
967           CODE:
968           #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
969 0         if (ccix >= NCCS)
970 0         croak("Bad setcc subscript");
971 0         termios_ref->c_cc[ccix] = cc;
972           #else
973           not_here("setcc");
974           #endif
975            
976            
977           MODULE = POSIX PACKAGE = POSIX
978            
979           INCLUDE: const-xs.inc
980            
981           int
982           WEXITSTATUS(status)
983           int status
984           ALIAS:
985           POSIX::WIFEXITED = 1
986           POSIX::WIFSIGNALED = 2
987           POSIX::WIFSTOPPED = 3
988           POSIX::WSTOPSIG = 4
989           POSIX::WTERMSIG = 5
990           CODE:
991           #if !defined(WEXITSTATUS) || !defined(WIFEXITED) || !defined(WIFSIGNALED) \
992           || !defined(WIFSTOPPED) || !defined(WSTOPSIG) || !defined(WTERMSIG)
993           RETVAL = 0; /* Silence compilers that notice this, but don't realise
994           that not_here() can't return. */
995           #endif
996 1554         switch(ix) {
997           case 0:
998           #ifdef WEXITSTATUS
999 1538         RETVAL = WEXITSTATUS(WMUNGE(status));
1000           #else
1001           not_here("WEXITSTATUS");
1002           #endif
1003 1538         break;
1004           case 1:
1005           #ifdef WIFEXITED
1006 10         RETVAL = WIFEXITED(WMUNGE(status));
1007           #else
1008           not_here("WIFEXITED");
1009           #endif
1010 10         break;
1011           case 2:
1012           #ifdef WIFSIGNALED
1013 4         RETVAL = WIFSIGNALED(WMUNGE(status));
1014           #else
1015           not_here("WIFSIGNALED");
1016           #endif
1017 4         break;
1018           case 3:
1019           #ifdef WIFSTOPPED
1020 0         RETVAL = WIFSTOPPED(WMUNGE(status));
1021           #else
1022           not_here("WIFSTOPPED");
1023           #endif
1024 0         break;
1025           case 4:
1026           #ifdef WSTOPSIG
1027 0         RETVAL = WSTOPSIG(WMUNGE(status));
1028           #else
1029           not_here("WSTOPSIG");
1030           #endif
1031 0         break;
1032           case 5:
1033           #ifdef WTERMSIG
1034 2         RETVAL = WTERMSIG(WMUNGE(status));
1035           #else
1036           not_here("WTERMSIG");
1037           #endif
1038 2         break;
1039           default:
1040 0         Perl_croak(aTHX_ "Illegal alias %d for POSIX::W*", (int)ix);
1041           }
1042           OUTPUT:
1043           RETVAL
1044            
1045           SysRet
1046           open(filename, flags = O_RDONLY, mode = 0666)
1047           char * filename
1048           int flags
1049           Mode_t mode
1050           CODE:
1051 2         if (flags & (O_APPEND|O_CREAT|O_TRUNC|O_RDWR|O_WRONLY|O_EXCL))
1052 2         TAINT_PROPER("open");
1053           RETVAL = open(filename, flags, mode);
1054           OUTPUT:
1055           RETVAL
1056            
1057            
1058           HV *
1059           localeconv()
1060           CODE:
1061           #ifdef HAS_LOCALECONV
1062           struct lconv *lcbuf;
1063 336         RETVAL = newHV();
1064 336         sv_2mortal((SV*)RETVAL);
1065 336         if ((lcbuf = localeconv())) {
1066           const struct lconv_offset *strings = lconv_strings;
1067           const struct lconv_offset *integers = lconv_integers;
1068           const char *ptr = (const char *) lcbuf;
1069            
1070           do {
1071 3360         const char *value = *((const char **)(ptr + strings->offset));
1072            
1073 3360         if (value && *value)
1074 2352         (void) hv_store(RETVAL, strings->name, strlen(strings->name),
1075           newSVpv(value, 0), 0);
1076 3360         } while ((++strings)->name);
1077            
1078           do {
1079 2688         const char value = *((const char *)(ptr + integers->offset));
1080            
1081 2688         if (value != CHAR_MAX)
1082 2688         (void) hv_store(RETVAL, integers->name,
1083           strlen(integers->name), newSViv(value), 0);
1084 2688         } while ((++integers)->name);
1085           }
1086           #else
1087           localeconv(); /* A stub to call not_here(). */
1088           #endif
1089           OUTPUT:
1090           RETVAL
1091            
1092           char *
1093           setlocale(category, locale = 0)
1094           int category
1095           char * locale
1096           PREINIT:
1097           char * retval;
1098           CODE:
1099 484         retval = setlocale(category, locale);
1100 484         if (! retval) {
1101 378         XSRETURN_UNDEF;
1102           }
1103           else {
1104           /* Save retval since subsequent setlocale() calls
1105           * may overwrite it. */
1106 106         RETVAL = savepv(retval);
1107           #ifdef USE_LOCALE_CTYPE
1108 212         if (category == LC_CTYPE
1109           #ifdef LC_ALL
1110 106         || category == LC_ALL
1111           #endif
1112           )
1113           {
1114           char *newctype;
1115           #ifdef LC_ALL
1116 66         if (category == LC_ALL)
1117 64         newctype = setlocale(LC_CTYPE, NULL);
1118           else
1119           #endif
1120           newctype = RETVAL;
1121 66         new_ctype(newctype);
1122           }
1123           #endif /* USE_LOCALE_CTYPE */
1124           #ifdef USE_LOCALE_COLLATE
1125 212         if (category == LC_COLLATE
1126           #ifdef LC_ALL
1127 106         || category == LC_ALL
1128           #endif
1129           )
1130           {
1131           char *newcoll;
1132           #ifdef LC_ALL
1133 64         if (category == LC_ALL)
1134 64         newcoll = setlocale(LC_COLLATE, NULL);
1135           else
1136           #endif
1137           newcoll = RETVAL;
1138 64         new_collate(newcoll);
1139           }
1140           #endif /* USE_LOCALE_COLLATE */
1141           #ifdef USE_LOCALE_NUMERIC
1142 212         if (category == LC_NUMERIC
1143           #ifdef LC_ALL
1144 106         || category == LC_ALL
1145           #endif
1146           )
1147           {
1148           char *newnum;
1149           #ifdef LC_ALL
1150 100         if (category == LC_ALL)
1151 64         newnum = setlocale(LC_NUMERIC, NULL);
1152           else
1153           #endif
1154           newnum = RETVAL;
1155 100         new_numeric(newnum);
1156           }
1157           #endif /* USE_LOCALE_NUMERIC */
1158           }
1159           OUTPUT:
1160           RETVAL
1161           CLEANUP:
1162 106         Safefree(RETVAL);
1163            
1164           NV
1165           acos(x)
1166           NV x
1167           ALIAS:
1168           asin = 1
1169           atan = 2
1170           ceil = 3
1171           cosh = 4
1172           floor = 5
1173           log10 = 6
1174           sinh = 7
1175           tan = 8
1176           tanh = 9
1177           CODE:
1178 72         switch (ix) {
1179           case 0:
1180 6         RETVAL = acos(x);
1181 6         break;
1182           case 1:
1183 10         RETVAL = asin(x);
1184 10         break;
1185           case 2:
1186 10         RETVAL = atan(x);
1187 10         break;
1188           case 3:
1189 2         RETVAL = ceil(x);
1190 2         break;
1191           case 4:
1192 10         RETVAL = cosh(x);
1193 10         break;
1194           case 5:
1195 4         RETVAL = floor(x);
1196 4         break;
1197           case 6:
1198 4         RETVAL = log10(x);
1199 4         break;
1200           case 7:
1201 6         RETVAL = sinh(x);
1202 6         break;
1203           case 8:
1204 10         RETVAL = tan(x);
1205 10         break;
1206           default:
1207 10         RETVAL = tanh(x);
1208           }
1209           OUTPUT:
1210           RETVAL
1211            
1212           NV
1213           fmod(x,y)
1214           NV x
1215           NV y
1216            
1217           void
1218           frexp(x)
1219           NV x
1220           PPCODE:
1221           int expvar;
1222           /* (We already know stack is long enough.) */
1223 2         PUSHs(sv_2mortal(newSVnv(frexp(x,&expvar))));
1224 2         PUSHs(sv_2mortal(newSViv(expvar)));
1225            
1226           NV
1227           ldexp(x,exp)
1228           NV x
1229           int exp
1230            
1231           void
1232           modf(x)
1233           NV x
1234           PPCODE:
1235           NV intvar;
1236           /* (We already know stack is long enough.) */
1237 2         PUSHs(sv_2mortal(newSVnv(Perl_modf(x,&intvar))));
1238 2         PUSHs(sv_2mortal(newSVnv(intvar)));
1239            
1240           SysRet
1241           sigaction(sig, optaction, oldaction = 0)
1242           int sig
1243           SV * optaction
1244           POSIX::SigAction oldaction
1245           CODE:
1246           #if defined(WIN32) || defined(NETWARE)
1247           RETVAL = not_here("sigaction");
1248           #else
1249           # This code is really grody because we're trying to make the signal
1250           # interface look beautiful, which is hard.
1251            
1252           {
1253 58         dVAR;
1254           POSIX__SigAction action;
1255           GV *siggv = gv_fetchpvs("SIG", GV_ADD, SVt_PVHV);
1256           struct sigaction act;
1257           struct sigaction oact;
1258           sigset_t sset;
1259           SV *osset_sv;
1260           sigset_t osset;
1261           POSIX__SigSet sigset;
1262           SV** svp;
1263 58         SV** sigsvp;
1264 2          
1265           if (sig < 0) {
1266           croak("Negative signals are not allowed");
1267 56         }
1268 6          
1269 6         if (sig == 0 && SvPOK(ST(0))) {
1270           const char *s = SvPVX_const(ST(0));
1271 6         int i = whichsig(s);
1272 2          
1273 6         if (i < 0 && memEQ(s, "SIG", 3))
1274 2         i = whichsig(s + 3);
1275 2         if (i < 0) {
1276           if (ckWARN(WARN_SIGNAL))
1277 2         Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1278           "No such signal: SIG%s", s);
1279           XSRETURN_UNDEF;
1280           }
1281           else
1282           sig = i;
1283 54         }
1284 0         #ifdef NSIG
1285           if (sig > NSIG) { /* NSIG - 1 is still okay. */
1286 0         Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1287           "No such signal: %d", sig);
1288           XSRETURN_UNDEF;
1289 54         }
1290           #endif
1291           sigsvp = hv_fetch(GvHVn(siggv),
1292           PL_sig_name[sig],
1293           strlen(PL_sig_name[sig]),
1294           TRUE);
1295 54          
1296 82         /* Check optaction and set action */
1297 40         if(SvTRUE(optaction)) {
1298           if(sv_isa(optaction, "POSIX::SigAction"))
1299 2         action = (HV*)SvRV(optaction);
1300           else
1301           croak("action is not of type POSIX::SigAction");
1302           }
1303           else {
1304           action=0;
1305           }
1306            
1307           /* sigaction() is supposed to look atomic. In particular, any
1308           * signal handler invoked during a sigaction() call should
1309           * see either the old or the new disposition, and not something
1310 52         * in between. We use sigprocmask() to make it so.
1311 52         */
1312 52         sigfillset(&sset);
1313 0         RETVAL=sigprocmask(SIG_BLOCK, &sset, &osset);
1314 52         if(RETVAL == -1)
1315           XSRETURN_UNDEF;
1316 52         ENTER;
1317 52         /* Restore signal mask no matter how we exit this block. */
1318 52         osset_sv = newSVpvn((char *)(&osset), sizeof(sigset_t));
1319           SAVEFREESV( osset_sv );
1320           SAVEDESTRUCTOR_X(restore_sigmask, osset_sv);
1321            
1322           RETVAL=-1; /* In case both oldaction and action are 0. */
1323 52          
1324 22         /* Remember old disposition if desired. */
1325 22         if (oldaction) {
1326 0         svp = hv_fetchs(oldaction, "HANDLER", TRUE);
1327 22         if(!svp)
1328 16         croak("Can't supply an oldaction without a HANDLER");
1329           if(SvTRUE(*sigsvp)) { /* TBD: what if "0"? */
1330           sv_setsv(*svp, *sigsvp);
1331 6         }
1332           else {
1333 22         sv_setpvs(*svp, "DEFAULT");
1334 22         }
1335 0         RETVAL = sigaction(sig, (struct sigaction *)0, & oact);
1336 0         if(RETVAL == -1) {
1337           LEAVE;
1338           XSRETURN_UNDEF;
1339 22         }
1340 22         /* Get back the mask. */
1341 16         svp = hv_fetchs(oldaction, "MASK", TRUE);
1342           if (sv_isa(*svp, "POSIX::SigSet")) {
1343           sigset = (sigset_t *) SvPV_nolen(SvRV(*svp));
1344 6         }
1345           else {
1346           sigset = (sigset_t *) allocate_struct(aTHX_ *svp,
1347           sizeof(sigset_t),
1348 22         "POSIX::SigSet");
1349           }
1350           *sigset = oact.sa_mask;
1351 22          
1352 22         /* Get back the flags. */
1353           svp = hv_fetchs(oldaction, "FLAGS", TRUE);
1354           sv_setiv(*svp, oact.sa_flags);
1355 22          
1356 22         /* Get back whether the old handler used safe signals. */
1357           svp = hv_fetchs(oldaction, "SAFE", TRUE);
1358           sv_setiv(*svp,
1359           /* compare incompatible pointers by casting to integer */
1360           PTR2nat(oact.sa_handler) == PTR2nat(PL_csighandlerp));
1361 52         }
1362            
1363           if (action) {
1364           /* Safe signals use "csighandler", which vectors through the
1365 40         PL_sighandlerp pointer when it's safe to do so.
1366 40         (BTW, "csighandler" is very different from "sighandler".) */
1367 40         svp = hv_fetchs(action, "SAFE", FALSE);
1368           act.sa_handler =
1369           DPTR2FPTR(
1370           void (*)(int),
1371           (*svp && SvTRUE(*svp))
1372           ? PL_csighandlerp : PL_sighandlerp
1373           );
1374            
1375 40         /* Vector new Perl handler through %SIG.
1376 40         (The core signal handlers read %SIG to dispatch.) */
1377 2         svp = hv_fetchs(action, "HANDLER", FALSE);
1378 38         if (!svp)
1379           croak("Can't supply an action without a HANDLER");
1380           sv_setsv(*sigsvp, *svp);
1381            
1382           /* This call actually calls sigaction() with almost the
1383           right settings, including appropriate interpretation
1384 38         of DEFAULT and IGNORE. However, why are we doing
1385           this when we're about to do it again just below? XXX */
1386           SvSETMAGIC(*sigsvp);
1387 38          
1388 22         /* And here again we duplicate -- DEFAULT/IGNORE checking. */
1389 22         if(SvPOK(*svp)) {
1390 2         const char *s=SvPVX_const(*svp);
1391           if(strEQ(s,"IGNORE")) {
1392 20         act.sa_handler = SIG_IGN;
1393 6         }
1394           else if(strEQ(s,"DEFAULT")) {
1395           act.sa_handler = SIG_DFL;
1396           }
1397           }
1398 38          
1399 38         /* Set up any desired mask. */
1400 10         svp = hv_fetchs(action, "MASK", FALSE);
1401 10         if (svp && sv_isa(*svp, "POSIX::SigSet")) {
1402           sigset = (sigset_t *) SvPV_nolen(SvRV(*svp));
1403           act.sa_mask = *sigset;
1404 28         }
1405           else
1406           sigemptyset(& act.sa_mask);
1407 38          
1408 38         /* Set up any desired flags. */
1409           svp = hv_fetchs(action, "FLAGS", FALSE);
1410           act.sa_flags = svp ? SvIV(*svp) : 0;
1411            
1412           /* Don't worry about cleaning up *sigsvp if this fails,
1413           * because that means we tried to disposition a
1414           * nonblockable signal, in which case *sigsvp is
1415 38         * essentially meaningless anyway.
1416 38         */
1417 2         RETVAL = sigaction(sig, & act, (struct sigaction *)0);
1418 2         if(RETVAL == -1) {
1419           LEAVE;
1420           XSRETURN_UNDEF;
1421           }
1422 48         }
1423            
1424           LEAVE;
1425           }
1426           #endif
1427           OUTPUT:
1428           RETVAL
1429            
1430           SysRet
1431           sigpending(sigset)
1432           POSIX::SigSet sigset
1433           ALIAS:
1434           sigsuspend = 1
1435           CODE:
1436 22         RETVAL = ix ? sigsuspend(sigset) : sigpending(sigset);
1437           OUTPUT:
1438           RETVAL
1439           CLEANUP:
1440 10         PERL_ASYNC_CHECK();
1441            
1442           SysRet
1443           sigprocmask(how, sigset, oldsigset = 0)
1444           int how
1445           POSIX::SigSet sigset = NO_INIT
1446           POSIX::SigSet oldsigset = NO_INIT
1447           INIT:
1448 14         if (! SvOK(ST(1))) {
1449           sigset = NULL;
1450 6         } else if (sv_isa(ST(1), "POSIX::SigSet")) {
1451 6         sigset = (sigset_t *) SvPV_nolen(SvRV(ST(1)));
1452           } else {
1453 0         croak("sigset is not of type POSIX::SigSet");
1454           }
1455            
1456 14         if (items < 3 || ! SvOK(ST(2))) {
1457           oldsigset = NULL;
1458 10         } else if (sv_isa(ST(2), "POSIX::SigSet")) {
1459 10         oldsigset = (sigset_t *) SvPV_nolen(SvRV(ST(2)));
1460           } else {
1461 0         croak("oldsigset is not of type POSIX::SigSet");
1462           }
1463            
1464           void
1465           _exit(status)
1466           int status
1467            
1468           SysRet
1469           dup2(fd1, fd2)
1470           int fd1
1471           int fd2
1472           CODE:
1473           #ifdef WIN32
1474           /* RT #98912 - More Microsoft muppetry - failing to actually implemented
1475           the well known documented POSIX behaviour for a POSIX API.
1476           http://msdn.microsoft.com/en-us/library/8syseb29.aspx */
1477           RETVAL = dup2(fd1, fd2) == -1 ? -1 : fd2;
1478           #else
1479 0         RETVAL = dup2(fd1, fd2);
1480           #endif
1481           OUTPUT:
1482           RETVAL
1483            
1484           SV *
1485           lseek(fd, offset, whence)
1486           int fd
1487           Off_t offset
1488           int whence
1489           CODE:
1490 0         Off_t pos = PerlLIO_lseek(fd, offset, whence);
1491 0         RETVAL = sizeof(Off_t) > sizeof(IV)
1492           ? newSVnv((NV)pos) : newSViv((IV)pos);
1493           OUTPUT:
1494           RETVAL
1495            
1496           void
1497           nice(incr)
1498           int incr
1499           PPCODE:
1500 0         errno = 0;
1501 0         if ((incr = nice(incr)) != -1 || errno == 0) {
1502 0         if (incr == 0)
1503 0         XPUSHs(newSVpvs_flags("0 but true", SVs_TEMP));
1504           else
1505 0         XPUSHs(sv_2mortal(newSViv(incr)));
1506           }
1507            
1508           void
1509           pipe()
1510           PPCODE:
1511           int fds[2];
1512 0         if (pipe(fds) != -1) {
1513 0         EXTEND(SP,2);
1514 0         PUSHs(sv_2mortal(newSViv(fds[0])));
1515 0         PUSHs(sv_2mortal(newSViv(fds[1])));
1516           }
1517            
1518           SysRet
1519           read(fd, buffer, nbytes)
1520           PREINIT:
1521 0         SV *sv_buffer = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
1522           INPUT:
1523           int fd
1524           size_t nbytes
1525           char * buffer = sv_grow( sv_buffer, nbytes+1 );
1526           CLEANUP:
1527 0         if (RETVAL >= 0) {
1528 0         SvCUR_set(sv_buffer, RETVAL);
1529 0         SvPOK_only(sv_buffer);
1530 0         *SvEND(sv_buffer) = '\0';
1531 0         SvTAINTED_on(sv_buffer);
1532           }
1533            
1534           SysRet
1535           setpgid(pid, pgid)
1536           pid_t pid
1537           pid_t pgid
1538            
1539           pid_t
1540           setsid()
1541            
1542           pid_t
1543           tcgetpgrp(fd)
1544           int fd
1545            
1546           SysRet
1547           tcsetpgrp(fd, pgrp_id)
1548           int fd
1549           pid_t pgrp_id
1550            
1551           void
1552           uname()
1553           PPCODE:
1554           #ifdef HAS_UNAME
1555           struct utsname buf;
1556 4         if (uname(&buf) >= 0) {
1557 2         EXTEND(SP, 5);
1558 2         PUSHs(newSVpvn_flags(buf.sysname, strlen(buf.sysname), SVs_TEMP));
1559 2         PUSHs(newSVpvn_flags(buf.nodename, strlen(buf.nodename), SVs_TEMP));
1560 2         PUSHs(newSVpvn_flags(buf.release, strlen(buf.release), SVs_TEMP));
1561 2         PUSHs(newSVpvn_flags(buf.version, strlen(buf.version), SVs_TEMP));
1562 2         PUSHs(newSVpvn_flags(buf.machine, strlen(buf.machine), SVs_TEMP));
1563           }
1564           #else
1565           uname((char *) 0); /* A stub to call not_here(). */
1566           #endif
1567            
1568           SysRet
1569           write(fd, buffer, nbytes)
1570           int fd
1571           char * buffer
1572           size_t nbytes
1573            
1574           SV *
1575           tmpnam()
1576           PREINIT:
1577           STRLEN i;
1578           int len;
1579           CODE:
1580 0         RETVAL = newSVpvn("", 0);
1581 0         SvGROW(RETVAL, L_tmpnam);
1582 0         len = strlen(tmpnam(SvPV(RETVAL, i)));
1583 0         SvCUR_set(RETVAL, len);
1584           OUTPUT:
1585           RETVAL
1586            
1587           void
1588           abort()
1589            
1590           int
1591           mblen(s, n)
1592           char * s
1593           size_t n
1594            
1595           size_t
1596           mbstowcs(s, pwcs, n)
1597           wchar_t * s
1598           char * pwcs
1599           size_t n
1600            
1601           int
1602           mbtowc(pwc, s, n)
1603           wchar_t * pwc
1604           char * s
1605           size_t n
1606            
1607           int
1608           wcstombs(s, pwcs, n)
1609           char * s
1610           wchar_t * pwcs
1611           size_t n
1612            
1613           int
1614           wctomb(s, wchar)
1615           char * s
1616           wchar_t wchar
1617            
1618           int
1619           strcoll(s1, s2)
1620           char * s1
1621           char * s2
1622            
1623           void
1624           strtod(str)
1625           char * str
1626           PREINIT:
1627           double num;
1628           char *unparsed;
1629           PPCODE:
1630 0         SET_NUMERIC_LOCAL();
1631 0         num = strtod(str, &unparsed);
1632 0         PUSHs(sv_2mortal(newSVnv(num)));
1633 0         if (GIMME == G_ARRAY) {
1634 0         EXTEND(SP, 1);
1635 0         if (unparsed)
1636 0         PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
1637           else
1638 0         PUSHs(&PL_sv_undef);
1639           }
1640            
1641           void
1642           strtol(str, base = 0)
1643           char * str
1644           int base
1645           PREINIT:
1646           long num;
1647           char *unparsed;
1648           PPCODE:
1649 0         num = strtol(str, &unparsed, base);
1650           #if IVSIZE <= LONGSIZE
1651           if (num < IV_MIN || num > IV_MAX)
1652           PUSHs(sv_2mortal(newSVnv((double)num)));
1653           else
1654           #endif
1655 0         PUSHs(sv_2mortal(newSViv((IV)num)));
1656 0         if (GIMME == G_ARRAY) {
1657 0         EXTEND(SP, 1);
1658 0         if (unparsed)
1659 0         PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
1660           else
1661 0         PUSHs(&PL_sv_undef);
1662           }
1663            
1664           void
1665           strtoul(str, base = 0)
1666           const char * str
1667           int base
1668           PREINIT:
1669           unsigned long num;
1670           char *unparsed;
1671           PPCODE:
1672 0         num = strtoul(str, &unparsed, base);
1673           #if IVSIZE <= LONGSIZE
1674 0         if (num > IV_MAX)
1675 0         PUSHs(sv_2mortal(newSVnv((double)num)));
1676           else
1677           #endif
1678 0         PUSHs(sv_2mortal(newSViv((IV)num)));
1679 0         if (GIMME == G_ARRAY) {
1680 0         EXTEND(SP, 1);
1681 0         if (unparsed)
1682 0         PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
1683           else
1684 0         PUSHs(&PL_sv_undef);
1685           }
1686            
1687           void
1688           strxfrm(src)
1689           SV * src
1690           CODE:
1691           {
1692           STRLEN srclen;
1693           STRLEN dstlen;
1694 4         char *p = SvPV(src,srclen);
1695 4         srclen++;
1696 4         ST(0) = sv_2mortal(newSV(srclen*4+1));
1697 4         dstlen = strxfrm(SvPVX(ST(0)), p, (size_t)srclen);
1698 4         if (dstlen > srclen) {
1699 4         dstlen++;
1700 4         SvGROW(ST(0), dstlen);
1701 4         strxfrm(SvPVX(ST(0)), p, (size_t)dstlen);
1702           dstlen--;
1703           }
1704 4         SvCUR_set(ST(0), dstlen);
1705 4         SvPOK_only(ST(0));
1706           }
1707            
1708           SysRet
1709           mkfifo(filename, mode)
1710           char * filename
1711           Mode_t mode
1712           ALIAS:
1713           access = 1
1714           CODE:
1715 672         if(ix) {
1716 672         RETVAL = access(filename, mode);
1717           } else {
1718 0         TAINT_PROPER("mkfifo");
1719 0         RETVAL = mkfifo(filename, mode);
1720           }
1721           OUTPUT:
1722           RETVAL
1723            
1724           SysRet
1725           tcdrain(fd)
1726           int fd
1727           ALIAS:
1728           close = 1
1729           dup = 2
1730           CODE:
1731           RETVAL = ix == 1 ? close(fd)
1732 0         : (ix < 1 ? tcdrain(fd) : dup(fd));
1733           OUTPUT:
1734           RETVAL
1735            
1736            
1737           SysRet
1738           tcflow(fd, action)
1739           int fd
1740           int action
1741           ALIAS:
1742           tcflush = 1
1743           tcsendbreak = 2
1744           CODE:
1745           RETVAL = ix == 1 ? tcflush(fd, action)
1746 0         : (ix < 1 ? tcflow(fd, action) : tcsendbreak(fd, action));
1747           OUTPUT:
1748           RETVAL
1749            
1750           void
1751           asctime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1)
1752           int sec
1753           int min
1754           int hour
1755           int mday
1756           int mon
1757           int year
1758           int wday
1759           int yday
1760           int isdst
1761           ALIAS:
1762           mktime = 1
1763           PPCODE:
1764           {
1765 8752         dXSTARG;
1766           struct tm mytm;
1767 8752         init_tm(&mytm); /* XXX workaround - see init_tm() in core util.c */
1768 8752         mytm.tm_sec = sec;
1769 8752         mytm.tm_min = min;
1770 8752         mytm.tm_hour = hour;
1771 8752         mytm.tm_mday = mday;
1772 8752         mytm.tm_mon = mon;
1773 8752         mytm.tm_year = year;
1774 8752         mytm.tm_wday = wday;
1775 8752         mytm.tm_yday = yday;
1776 8752         mytm.tm_isdst = isdst;
1777 8752         if (ix) {
1778 8744         const time_t result = mktime(&mytm);
1779 8744         if (result == (time_t)-1)
1780 0         SvOK_off(TARG);
1781 8744         else if (result == 0)
1782 0         sv_setpvn(TARG, "0 but true", 10);
1783           else
1784 8744         sv_setiv(TARG, (IV)result);
1785           } else {
1786 8         sv_setpv(TARG, asctime(&mytm));
1787           }
1788 8752         ST(0) = TARG;
1789 8752         XSRETURN(1);
1790           }
1791            
1792           long
1793           clock()
1794            
1795           char *
1796           ctime(time)
1797           Time_t &time
1798            
1799           void
1800           times()
1801           PPCODE:
1802           struct tms tms;
1803           clock_t realtime;
1804 0         realtime = times( &tms );
1805 0         EXTEND(SP,5);
1806 0         PUSHs( sv_2mortal( newSViv( (IV) realtime ) ) );
1807 0         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_utime ) ) );
1808 0         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_stime ) ) );
1809 0         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cutime ) ) );
1810 0         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cstime ) ) );
1811            
1812           double
1813           difftime(time1, time2)
1814           Time_t time1
1815           Time_t time2
1816            
1817           #XXX: if $xsubpp::WantOptimize is always the default
1818           # sv_setpv(TARG, ...) could be used rather than
1819           # ST(0) = sv_2mortal(newSVpv(...))
1820           void
1821           strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1)
1822           SV * fmt
1823           int sec
1824           int min
1825           int hour
1826           int mday
1827           int mon
1828           int year
1829           int wday
1830           int yday
1831           int isdst
1832           CODE:
1833           {
1834 72         char *buf = my_strftime(SvPV_nolen(fmt), sec, min, hour, mday, mon, year, wday, yday, isdst);
1835 72         if (buf) {
1836 72         SV *const sv = sv_newmortal();
1837 72         sv_usepvn_flags(sv, buf, strlen(buf), SV_HAS_TRAILING_NUL);
1838 72         if (SvUTF8(fmt)) {
1839 4         SvUTF8_on(sv);
1840           }
1841 72         ST(0) = sv;
1842           }
1843           }
1844            
1845           void
1846           tzset()
1847           PPCODE:
1848           my_tzset(aTHX);
1849            
1850           void
1851           tzname()
1852           PPCODE:
1853 2         EXTEND(SP,2);
1854 2         PUSHs(newSVpvn_flags(tzname[0], strlen(tzname[0]), SVs_TEMP));
1855 2         PUSHs(newSVpvn_flags(tzname[1], strlen(tzname[1]), SVs_TEMP));
1856            
1857           char *
1858           ctermid(s = 0)
1859           char * s = 0;
1860           CODE:
1861           #ifdef HAS_CTERMID_R
1862           s = (char *) safemalloc((size_t) L_ctermid);
1863           #endif
1864 0         RETVAL = ctermid(s);
1865           OUTPUT:
1866           RETVAL
1867           CLEANUP:
1868           #ifdef HAS_CTERMID_R
1869           Safefree(s);
1870           #endif
1871            
1872           char *
1873           cuserid(s = 0)
1874           char * s = 0;
1875           CODE:
1876           #ifdef HAS_CUSERID
1877 0         RETVAL = cuserid(s);
1878           #else
1879           RETVAL = 0;
1880           not_here("cuserid");
1881           #endif
1882           OUTPUT:
1883           RETVAL
1884            
1885           SysRetLong
1886           fpathconf(fd, name)
1887           int fd
1888           int name
1889            
1890           SysRetLong
1891           pathconf(filename, name)
1892           char * filename
1893           int name
1894            
1895           SysRet
1896           pause()
1897           CLEANUP:
1898 0         PERL_ASYNC_CHECK();
1899            
1900           unsigned int
1901           sleep(seconds)
1902           unsigned int seconds
1903           CODE:
1904 2         RETVAL = PerlProc_sleep(seconds);
1905           OUTPUT:
1906           RETVAL
1907            
1908           SysRet
1909           setgid(gid)
1910           Gid_t gid
1911            
1912           SysRet
1913           setuid(uid)
1914           Uid_t uid
1915            
1916           SysRetLong
1917           sysconf(name)
1918           int name
1919            
1920           char *
1921           ttyname(fd)
1922           int fd
1923            
1924           void
1925           getcwd()
1926           PPCODE:
1927           {
1928 0         dXSTARG;
1929 0         getcwd_sv(TARG);
1930 0         XSprePUSH; PUSHTARG;
1931           }
1932            
1933           SysRet
1934           lchown(uid, gid, path)
1935           Uid_t uid
1936           Gid_t gid
1937           char * path
1938           CODE:
1939           #ifdef HAS_LCHOWN
1940           /* yes, the order of arguments is different,
1941           * but consistent with CORE::chown() */
1942 0         RETVAL = lchown(path, uid, gid);
1943           #else
1944           RETVAL = not_here("lchown");
1945           #endif
1946           OUTPUT:
1947           RETVAL