}
#ifdef USE_LONG_DOUBLE
# if LONG_DOUBLEKIND == 3 || LONG_DOUBLEKIND == 4
+# if LONG_DOUBLESIZE > 10
memset((char *)nvp + 10, '\0', LONG_DOUBLESIZE - 10); /* x86 long double */
+# endif
# endif
#endif
for (i = 0; i < (int)C_ARRAY_LENGTH(a); i++) {
#else
# ifndef HAS_MKFIFO
-# if defined(OS2)
+# if defined(OS2) || defined(__amigaos4__)
# define mkfifo(a,b) not_here("mkfifo")
# else /* !( defined OS2 ) */
# ifndef mkfifo
# ifdef HAS_UNAME
# include <sys/utsname.h>
# endif
-# include <sys/wait.h>
+# ifndef __amigaos4__
+# include <sys/wait.h>
+# endif
# ifdef I_UTIME
# include <utime.h>
# endif
typedef long SysRetLong;
typedef sigset_t* POSIX__SigSet;
typedef HV* POSIX__SigAction;
+typedef int POSIX__SigNo;
+typedef int POSIX__Fd;
#ifdef I_TERMIOS
typedef struct termios* POSIX__Termios;
#else /* Define termios types to int, and call not_here for the functions.*/
size_t offset;
};
-const struct lconv_offset lconv_strings[] = {
+static const struct lconv_offset lconv_strings[] = {
#ifdef USE_LOCALE_NUMERIC
{"decimal_point", STRUCT_OFFSET(struct lconv, decimal_point)},
{"thousands_sep", STRUCT_OFFSET(struct lconv, thousands_sep)},
/* The Linux man pages say these are the field names for the structure
* components that are LC_NUMERIC; the rest being LC_MONETARY */
-# define isLC_NUMERIC_STRING(name) (strcmp(name, "decimal_point") \
- || strcmp(name, "thousands_sep") \
+# define isLC_NUMERIC_STRING(name) (strEQ(name, "decimal_point") \
+ || strEQ(name, "thousands_sep") \
\
/* There should be no harm done \
* checking for this, even if \
* NO_LOCALECONV_GROUPING */ \
- || strcmp(name, "grouping"))
+ || strEQ(name, "grouping"))
#else
# define isLC_NUMERIC_STRING(name) (0)
#endif
-const struct lconv_offset lconv_integers[] = {
+static const struct lconv_offset lconv_integers[] = {
#ifdef USE_LOCALE_MONETARY
{"int_frac_digits", STRUCT_OFFSET(struct lconv, int_frac_digits)},
{"frac_digits", STRUCT_OFFSET(struct lconv, frac_digits)},
* supposed to return -1 from sigaction unless the disposition
* was unaffected.
*/
+#if !(defined(__amigaos4__) && defined(__NEWLIB__))
sigset_t *ossetp = (sigset_t *) SvPV_nolen( osset_sv );
(void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
+#endif
}
static void *
SysRet
addset(sigset, sig)
POSIX::SigSet sigset
- int sig
+ POSIX::SigNo sig
ALIAS:
delset = 1
CODE:
int
sigismember(sigset, sig)
POSIX::SigSet sigset
- int sig
+ POSIX::SigNo sig
MODULE = Termios PACKAGE = POSIX::Termios PREFIX = cf
SysRet
getattr(termios_ref, fd = 0)
POSIX::Termios termios_ref
- int fd
+ POSIX::Fd fd
CODE:
RETVAL = tcgetattr(fd, termios_ref);
OUTPUT:
SysRet
setattr(termios_ref, fd = 0, optional_actions = DEF_SETATTR_ACTION)
POSIX::Termios termios_ref
- int fd
+ POSIX::Fd fd
int optional_actions
CODE:
/* The second argument to the call is mandatory, but we'd like to give
it a useful default. 0 isn't valid on all operating systems - on
- Solaris (at least) TCSANOW, TCSADRAIN and TCSAFLUSH have the same
- values as the equivalent ioctls, TCSETS, TCSETSW and TCSETSF. */
- RETVAL = tcsetattr(fd, optional_actions, termios_ref);
+ Solaris (at least) TCSANOW, TCSADRAIN and TCSAFLUSH have the same
+ values as the equivalent ioctls, TCSETS, TCSETSW and TCSETSF. */
+ if (optional_actions < 0) {
+ SETERRNO(EINVAL, LIB_INVARG);
+ RETVAL = -1;
+ } else {
+ RETVAL = tcsetattr(fd, optional_actions, termios_ref);
+ }
OUTPUT:
RETVAL
#else
retval = setlocale(category, locale);
#endif
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "%s:%d: %s\n", __FILE__, __LINE__,
+ _setlocale_debug_string(category, locale, retval)));
if (! retval) {
/* Should never happen that a query would return an error, but be
* sure and reset to C locale */
{
char *newctype;
#ifdef LC_ALL
- if (category == LC_ALL)
+ if (category == LC_ALL) {
newctype = setlocale(LC_CTYPE, NULL);
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log,
+ "%s:%d: %s\n", __FILE__, __LINE__,
+ _setlocale_debug_string(LC_CTYPE, NULL, newctype)));
+ }
else
#endif
newctype = RETVAL;
{
char *newcoll;
#ifdef LC_ALL
- if (category == LC_ALL)
+ if (category == LC_ALL) {
newcoll = setlocale(LC_COLLATE, NULL);
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log,
+ "%s:%d: %s\n", __FILE__, __LINE__,
+ _setlocale_debug_string(LC_COLLATE, NULL, newcoll)));
+ }
else
#endif
newcoll = RETVAL;
{
char *newnum;
#ifdef LC_ALL
- if (category == LC_ALL)
+ if (category == LC_ALL) {
newnum = setlocale(LC_NUMERIC, NULL);
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log,
+ "%s:%d: %s\n", __FILE__, __LINE__,
+ _setlocale_debug_string(LC_NUMERIC, NULL, newnum)));
+ }
else
#endif
newnum = RETVAL;
NV z
CODE:
#ifdef c99_fma
+ RETVAL = c99_fma(x, y, z);
+#else
PERL_UNUSED_VAR(x);
PERL_UNUSED_VAR(y);
PERL_UNUSED_VAR(z);
- RETVAL = c99_fma(x, y, z);
+ not_here("fma");
#endif
OUTPUT:
RETVAL
ALIAS:
yn = 1
CODE:
- PERL_UNUSED_VAR(x);
- PERL_UNUSED_VAR(y);
RETVAL = NV_NAN;
switch (ix) {
case 0:
#ifdef bessel_jn
RETVAL = bessel_jn(x, y);
#else
+ PERL_UNUSED_VAR(x);
+ PERL_UNUSED_VAR(y);
not_here("jn");
#endif
break;
#ifdef bessel_yn
RETVAL = bessel_yn(x, y);
#else
+ PERL_UNUSED_VAR(x);
+ PERL_UNUSED_VAR(y);
not_here("yn");
#endif
break;
SV * optaction
POSIX::SigAction oldaction
CODE:
-#if defined(WIN32) || defined(NETWARE)
+#if defined(WIN32) || defined(NETWARE) || (defined(__amigaos4__) && defined(__NEWLIB__))
RETVAL = not_here("sigaction");
#else
-# This code is really grody because we're trying to make the signal
+# This code is really grody because we are trying to make the signal
# interface look beautiful, which is hard.
{
ALIAS:
sigsuspend = 1
CODE:
+#ifdef __amigaos4__
+ RETVAL = not_here("sigpending");
+#else
RETVAL = ix ? sigsuspend(sigset) : sigpending(sigset);
+#endif
OUTPUT:
RETVAL
CLEANUP:
int fd1
int fd2
CODE:
+ if (fd1 >= 0 && fd2 >= 0) {
#ifdef WIN32
- /* RT #98912 - More Microsoft muppetry - failing to actually implemented
- the well known documented POSIX behaviour for a POSIX API.
- http://msdn.microsoft.com/en-us/library/8syseb29.aspx */
- RETVAL = dup2(fd1, fd2) == -1 ? -1 : fd2;
+ /* RT #98912 - More Microsoft muppetry - failing to
+ actually implemented the well known documented POSIX
+ behaviour for a POSIX API.
+ http://msdn.microsoft.com/en-us/library/8syseb29.aspx */
+ RETVAL = dup2(fd1, fd2) == -1 ? -1 : fd2;
#else
- RETVAL = dup2(fd1, fd2);
+ RETVAL = dup2(fd1, fd2);
#endif
+ } else {
+ SETERRNO(EBADF,RMS_IFI);
+ RETVAL = -1;
+ }
OUTPUT:
RETVAL
SV *
lseek(fd, offset, whence)
- int fd
+ POSIX::Fd fd
Off_t offset
int whence
CODE:
- if (fd >= 0) {
- Off_t pos = PerlLIO_lseek(fd, offset, whence);
- RETVAL = sizeof(Off_t) > sizeof(IV)
- ? newSVnv((NV)pos) : newSViv((IV)pos);
- } else {
- SETERRNO(EBADF,RMS_IFI);
- RETVAL = newSViv(-1);
+ {
+ Off_t pos = PerlLIO_lseek(fd, offset, whence);
+ RETVAL = sizeof(Off_t) > sizeof(IV)
+ ? newSVnv((NV)pos) : newSViv((IV)pos);
}
OUTPUT:
RETVAL
PREINIT:
SV *sv_buffer = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
INPUT:
- int fd
+ POSIX::Fd fd
size_t nbytes
char * buffer = sv_grow( sv_buffer, nbytes+1 );
CLEANUP:
pid_t
tcgetpgrp(fd)
- int fd
+ POSIX::Fd fd
SysRet
tcsetpgrp(fd, pgrp_id)
- int fd
+ POSIX::Fd fd
pid_t pgrp_id
void
SysRet
write(fd, buffer, nbytes)
- int fd
+ POSIX::Fd fd
char * buffer
size_t nbytes
long num;
char *unparsed;
PPCODE:
- num = strtol(str, &unparsed, base);
-#if IVSIZE <= LONGSIZE
- if (num < IV_MIN || num > IV_MAX)
- PUSHs(sv_2mortal(newSVnv((double)num)));
- else
-#endif
- PUSHs(sv_2mortal(newSViv((IV)num)));
- if (GIMME_V == G_ARRAY) {
- EXTEND(SP, 1);
- if (unparsed)
- PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
- else
- PUSHs(&PL_sv_undef);
- }
+ if (base == 0 || (base >= 2 && base <= 36)) {
+ num = strtol(str, &unparsed, base);
+#if IVSIZE < LONGSIZE
+ if (num < IV_MIN || num > IV_MAX)
+ PUSHs(sv_2mortal(newSVnv((double)num)));
+ else
+#endif
+ PUSHs(sv_2mortal(newSViv((IV)num)));
+ if (GIMME_V == G_ARRAY) {
+ EXTEND(SP, 1);
+ if (unparsed)
+ PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
+ else
+ PUSHs(&PL_sv_undef);
+ }
+ } else {
+ SETERRNO(EINVAL, LIB_INVARG);
+ PUSHs(&PL_sv_undef);
+ if (GIMME_V == G_ARRAY) {
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ }
+ }
void
strtoul(str, base = 0)
PPCODE:
PERL_UNUSED_VAR(str);
PERL_UNUSED_VAR(base);
- num = strtoul(str, &unparsed, base);
+ if (base == 0 || (base >= 2 && base <= 36)) {
+ num = strtoul(str, &unparsed, base);
#if IVSIZE <= LONGSIZE
- if (num > IV_MAX)
- PUSHs(sv_2mortal(newSVnv((double)num)));
- else
-#endif
- PUSHs(sv_2mortal(newSViv((IV)num)));
- if (GIMME_V == G_ARRAY) {
- EXTEND(SP, 1);
- if (unparsed)
- PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
- else
- PUSHs(&PL_sv_undef);
- }
+ if (num > IV_MAX)
+ PUSHs(sv_2mortal(newSVnv((double)num)));
+ else
+#endif
+ PUSHs(sv_2mortal(newSViv((IV)num)));
+ if (GIMME_V == G_ARRAY) {
+ EXTEND(SP, 1);
+ if (unparsed)
+ PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
+ else
+ PUSHs(&PL_sv_undef);
+ }
+ } else {
+ SETERRNO(EINVAL, LIB_INVARG);
+ PUSHs(&PL_sv_undef);
+ if (GIMME_V == G_ARRAY) {
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ }
+ }
void
strxfrm(src)
SysRet
tcdrain(fd)
- int fd
+ POSIX::Fd fd
ALIAS:
close = 1
dup = 2
CODE:
- RETVAL = ix == 1 ? close(fd)
- : (ix < 1 ? tcdrain(fd) : dup(fd));
+ if (fd >= 0) {
+ RETVAL = ix == 1 ? close(fd)
+ : (ix < 1 ? tcdrain(fd) : dup(fd));
+ } else {
+ SETERRNO(EBADF,RMS_IFI);
+ RETVAL = -1;
+ }
OUTPUT:
RETVAL
SysRet
tcflow(fd, action)
- int fd
+ POSIX::Fd fd
int action
ALIAS:
tcflush = 1
tcsendbreak = 2
CODE:
- if (fd >= 0 && action >= 0) {
+ if (action >= 0) {
RETVAL = ix == 1 ? tcflush(fd, action)
: (ix < 1 ? tcflow(fd, action) : tcsendbreak(fd, action));
} else {
- SETERRNO(EBADF,RMS_IFI);
+ SETERRNO(EINVAL,LIB_INVARG);
RETVAL = -1;
}
OUTPUT:
SysRetLong
fpathconf(fd, name)
- int fd
+ POSIX::Fd fd
int name
SysRetLong
char *
ttyname(fd)
- int fd
+ POSIX::Fd fd
void
getcwd()
https://perl5.git.perl.org / perl5.git / blobdiff