/*
 * This file was generated automatically by ExtUtils::ParseXS version 3.24 from the
 * contents of IO.xs. Do not edit this file, edit IO.xs instead.
 *
 *    ANY CHANGES MADE HERE WILL BE LOST!
 *
 */

#line 1 "IO.xs"
/*
  Copyright (c) 1995-2004 Nick Ing-Simmons. All rights reserved.
  This program is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
*/
#define PERL_NO_GET_CONTEXT
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
#include <patchlevel.h>
#include <fcntl.h>

#include "tkGlue.def"

#include "pTk/tkPort.h"
#include "pTk/tkInt.h"
#include "pTk/tkEvent.h"
#include "pTk/tkEvent_f.h"
#include "pTk/tkEvent.m"
#include "tkGlue.h"
#include "tkGlue.m"

DECLARE_EVENT;

#define InputStream PerlIO *
#define OutputStream PerlIO *


typedef struct
 {
  PerlIO *f;
  SV *buf;
  int len;
  int offset;
  int count;
  int error;
  int eof;
 } nIO_read;

static void read_handler _((ClientData clientData, int mask));
static void
read_handler(clientData, mask)
ClientData clientData;
int mask;
{
 dTHX; /* FIXME */
 if (mask & TCL_READABLE)
  {
   nIO_read *info = (nIO_read *) clientData;
   SV *buf = info->buf;
   int count;
   SvGROW(buf,(Size_t) (info->offset+info->len+1));
   count = read(PerlIO_fileno(info->f),SvPVX(buf)+info->offset,(size_t) info->len);
   if (count == 0)
    {
     info->eof = 1;
    }
   else if (count == -1)
    {
     perror("read_handler");
     if (errno == EAGAIN)
      {
       PerlIO_printf(PerlIO_stderr(),"%d would block\n",PerlIO_fileno(info->f));
      }
     else
      info->error = errno;
    }
   else
    {STRLEN len;
     SvCUR_set(buf,SvCUR(buf)+count);
     info->len    -= count;
     info->count  += count;
     info->offset += count;
    }
   SvPVX(buf)[SvCUR(buf)] = '\0';
  }
}


#if defined(__WIN32__) && !defined(__CYGWIN__)
static int
make_nonblock (pTHX_ PerlIO *f,int *mode,int *newmode)
{
 croak("Cannot make nonblocking on Win32 yet");
 return -1;
}

static int
restore_mode (pTHX_ PerlIO *f,int mode)
{
 croak("Cannot make nonblocking on Win32 yet");
 return -1;
}
#else
static int
make_nonblock (pTHX_ PerlIO *f,int *mode,int *newmode)
{
 int RETVAL = fcntl(PerlIO_fileno(f), F_GETFL, 0);
 if (RETVAL >= 0)
  {
   *newmode = *mode = RETVAL;
#ifdef O_NONBLOCK
   /* POSIX style */
#ifdef O_NDELAY
   /* Ooops has O_NDELAY too - make sure we don't
    * get SysV behaviour by mistake
    */
   if ((*mode & O_NDELAY) || !(*mode & O_NONBLOCK))
    {
     *newmode = (*mode & ~O_NDELAY) | O_NONBLOCK;
     RETVAL = fcntl(PerlIO_fileno(f),F_SETFL,*newmode);
    }
#else
   /* Standard POSIX */
   if (!(*mode & O_NONBLOCK))
    {
     *newmode = *mode | O_NONBLOCK;
     RETVAL = fcntl(PerlIO_fileno(f),F_SETFL,*newmode);
    }
#endif
#else
   /* Not POSIX - better have O_NDELAY or we can't cope.
    * for BSD-ish machines this is an acceptable alternative
    * for SysV we can't tell "would block" from EOF but that is
    * the way SysV is...
    */
   if (!(*mode & O_NDELAY))
    {
     *newmode = *mode | O_NDELAY;
     RETVAL = fcntl(PerlIO_fileno(f),F_SETFL,*newmode);
    }
#endif
  }
 return RETVAL;
}

static int
restore_mode (pTHX_ PerlIO *f,int mode)
{
 return fcntl(PerlIO_fileno(f), F_SETFL, mode);
}

#endif

static int has_nl _((SV *sv));

static int has_nl(sv)
SV *sv;
{
 STRLEN n = SvCUR(sv);
 char *p = SvPVX(sv);
 while (n-- > 0)
  {
   if (*p++ == '\n')
    return 1;
  }
 return 0;
}

#line 170 "IO.c"
#ifndef PERL_UNUSED_VAR
#  define PERL_UNUSED_VAR(var) if (0) var = var
#endif

#ifndef dVAR
#  define dVAR		dNOOP
#endif


/* This stuff is not part of the API! You have been warned. */
#ifndef PERL_VERSION_DECIMAL
#  define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
#endif
#ifndef PERL_DECIMAL_VERSION
#  define PERL_DECIMAL_VERSION \
	  PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
#endif
#ifndef PERL_VERSION_GE
#  define PERL_VERSION_GE(r,v,s) \
	  (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
#endif
#ifndef PERL_VERSION_LE
#  define PERL_VERSION_LE(r,v,s) \
	  (PERL_DECIMAL_VERSION <= PERL_VERSION_DECIMAL(r,v,s))
#endif

/* XS_INTERNAL is the explicit static-linkage variant of the default
 * XS macro.
 *
 * XS_EXTERNAL is the same as XS_INTERNAL except it does not include
 * "STATIC", ie. it exports XSUB symbols. You probably don't want that
 * for anything but the BOOT XSUB.
 *
 * See XSUB.h in core!
 */


/* TODO: This might be compatible further back than 5.10.0. */
#if PERL_VERSION_GE(5, 10, 0) && PERL_VERSION_LE(5, 15, 1)
#  undef XS_EXTERNAL
#  undef XS_INTERNAL
#  if defined(__CYGWIN__) && defined(USE_DYNAMIC_LOADING)
#    define XS_EXTERNAL(name) __declspec(dllexport) XSPROTO(name)
#    define XS_INTERNAL(name) STATIC XSPROTO(name)
#  endif
#  if defined(__SYMBIAN32__)
#    define XS_EXTERNAL(name) EXPORT_C XSPROTO(name)
#    define XS_INTERNAL(name) EXPORT_C STATIC XSPROTO(name)
#  endif
#  ifndef XS_EXTERNAL
#    if defined(HASATTRIBUTE_UNUSED) && !defined(__cplusplus)
#      define XS_EXTERNAL(name) void name(pTHX_ CV* cv __attribute__unused__)
#      define XS_INTERNAL(name) STATIC void name(pTHX_ CV* cv __attribute__unused__)
#    else
#      ifdef __cplusplus
#        define XS_EXTERNAL(name) extern "C" XSPROTO(name)
#        define XS_INTERNAL(name) static XSPROTO(name)
#      else
#        define XS_EXTERNAL(name) XSPROTO(name)
#        define XS_INTERNAL(name) STATIC XSPROTO(name)
#      endif
#    endif
#  endif
#endif

/* perl >= 5.10.0 && perl <= 5.15.1 */


/* The XS_EXTERNAL macro is used for functions that must not be static
 * like the boot XSUB of a module. If perl didn't have an XS_EXTERNAL
 * macro defined, the best we can do is assume XS is the same.
 * Dito for XS_INTERNAL.
 */
#ifndef XS_EXTERNAL
#  define XS_EXTERNAL(name) XS(name)
#endif
#ifndef XS_INTERNAL
#  define XS_INTERNAL(name) XS(name)
#endif

/* Now, finally, after all this mess, we want an ExtUtils::ParseXS
 * internal macro that we're free to redefine for varying linkage due
 * to the EXPORT_XSUB_SYMBOLS XS keyword. This is internal, use
 * XS_EXTERNAL(name) or XS_INTERNAL(name) in your code if you need to!
 */

#undef XS_EUPXS
#if defined(PERL_EUPXS_ALWAYS_EXPORT)
#  define XS_EUPXS(name) XS_EXTERNAL(name)
#else
   /* default to internal */
#  define XS_EUPXS(name) XS_INTERNAL(name)
#endif

#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)

/* prototype to pass -Wmissing-prototypes */
STATIC void
S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);

STATIC void
S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
{
    const GV *const gv = CvGV(cv);

    PERL_ARGS_ASSERT_CROAK_XS_USAGE;

    if (gv) {
        const char *const gvname = GvNAME(gv);
        const HV *const stash = GvSTASH(gv);
        const char *const hvname = stash ? HvNAME(stash) : NULL;

        if (hvname)
            Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
        else
            Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
    } else {
        /* Pants. I don't think that it should be possible to get here. */
        Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
    }
}
#undef  PERL_ARGS_ASSERT_CROAK_XS_USAGE

#ifdef PERL_IMPLICIT_CONTEXT
#define croak_xs_usage(a,b)    S_croak_xs_usage(aTHX_ a,b)
#else
#define croak_xs_usage        S_croak_xs_usage
#endif

#endif

/* NOTE: the prototype of newXSproto() is different in versions of perls,
 * so we define a portable version of newXSproto()
 */
#ifdef newXS_flags
#define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
#else
#define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
#endif /* !defined(newXS_flags) */

#line 312 "IO.c"

XS_EUPXS(XS_Tk__IO_make_nonblock); /* prototype to pass -Wmissing-prototypes */
XS_EUPXS(XS_Tk__IO_make_nonblock)
{
    dVAR; dXSARGS;
    if (items != 3)
       croak_xs_usage(cv,  "f, mode, newmode");
    {
	InputStream	f = IoIFP(sv_2io(ST(0)))
;
	int	mode;
	int	newmode;
	int	RETVAL;
	dXSTARG;
#line 170 "IO.xs"
 {
  make_nonblock(aTHX_ f,&mode,&newmode);
 }
#line 331 "IO.c"
	sv_setiv(ST(1), (IV)mode);
	SvSETMAGIC(ST(1));
	sv_setiv(ST(2), (IV)newmode);
	SvSETMAGIC(ST(2));
    }
    XSRETURN(1);
}


XS_EUPXS(XS_Tk__IO_restore_mode); /* prototype to pass -Wmissing-prototypes */
XS_EUPXS(XS_Tk__IO_restore_mode)
{
    dVAR; dXSARGS;
    if (items != 2)
       croak_xs_usage(cv,  "f, mode");
    {
	InputStream	f = IoIFP(sv_2io(ST(0)))
;
	int	mode = (int)SvIV(ST(1))
;
	int	RETVAL;
	dXSTARG;
#line 182 "IO.xs"
 {
  restore_mode(aTHX_ f,mode);
 }
#line 358 "IO.c"
    }
    XSRETURN(1);
}


XS_EUPXS(XS_Tk__IO_read); /* prototype to pass -Wmissing-prototypes */
XS_EUPXS(XS_Tk__IO_read)
{
    dVAR; dXSARGS;
    if (items < 3 || items > 4)
       croak_xs_usage(cv,  "f, buf, len, offset = 0");
    {
	InputStream	f = IoIFP(sv_2io(ST(0)))
;
	SV *	buf = ST(1)
;
	int	len = (int)SvIV(ST(2))
;
	int	offset;
	SV *	RETVAL;

	if (items < 4)
	    offset = 0;
	else {
	    offset = (int)SvIV(ST(3))
;
	}
#line 193 "IO.xs"
  {
   int mode;
   int newmode;
   int count = make_nonblock(aTHX_ f,&mode,&newmode);
   /* Copy stuff out of PerlIO *  */
   ST(0) = &PL_sv_undef;
   if (count == 0)
    {
     int fd = PerlIO_fileno(f);
     nIO_read info;
     info.f   = f;
     info.buf = buf;
     info.len = len;
     info.offset = offset;
     info.count  = 0;
     info.error  = 0;
     info.eof    = 0;
     (void)SvUPGRADE(buf, SVt_PV);
     SvPOK_only(buf);		/* validate pointer */
     Tcl_CreateFileHandler(fd, TCL_READABLE, read_handler, (ClientData) &info);
     do
      {
       Tcl_DoOneEvent(0);
      } while (!info.eof && !info.error && info.count == 0);
     Tcl_DeleteFileHandler(fd);
     if (mode != newmode)
      {
       count = restore_mode(aTHX_ f,mode);
       if (count != 0)
        croak("Cannot make blocking");
      }
     if (!info.eof && !info.error)
      {
       ST(0) = sv_2mortal(newSViv(info.count));
      }
    }
   else
    croak("Cannot make non-blocking");
  }
#line 426 "IO.c"
    }
    XSRETURN(1);
}


XS_EUPXS(XS_Tk__IO_readline); /* prototype to pass -Wmissing-prototypes */
XS_EUPXS(XS_Tk__IO_readline)
{
    dVAR; dXSARGS;
    if (items != 1)
       croak_xs_usage(cv,  "f");
    {
	InputStream	f = IoIFP(sv_2io(ST(0)))
;
	SV *	RETVAL;
#line 237 "IO.xs"
  {
   int mode;
   int newmode;
   int count = make_nonblock(aTHX_ f,&mode,&newmode);
   /* Copy stuff out of PerlIO *  */
   ST(0) = &PL_sv_undef;
   if (count == 0)
    {
     SV *buf =  newSVpv("",0);
     int fd = PerlIO_fileno(f);
     nIO_read info;
     info.f   = f;
     info.buf = buf;
     info.len = 1;
     info.offset = 0;
     info.count  = 0;
     info.error  = 0;
     info.eof    = 0;
     Tcl_CreateFileHandler(fd, TCL_READABLE, read_handler, (ClientData) &info);
     while (!info.eof && !info.error && !has_nl(buf))
      {
       info.len = 1;
       info.count = 0;
       while (!info.eof && !info.error && !info.count)
        Tcl_DoOneEvent(0);
      }
     Tcl_DeleteFileHandler(fd);
     if (mode != newmode)
      {
       count = restore_mode(aTHX_ f,mode);
       if (count != 0)
        croak("Cannot make blocking");
      }
     if (!info.eof && !info.error)
      {
       sv_setiv(buf,1);
       SvPOK_on(buf);
       ST(0) = sv_2mortal(buf);
      }
     else if (info.error)
      {
       warn("error=%d",info.error);
      }
    }
   else
    {
     croak("Cannot make non-blocking");
    }
  }
#line 492 "IO.c"
    }
    XSRETURN(1);
}

#ifdef __cplusplus
extern "C"
#endif
XS_EXTERNAL(boot_Tk__IO); /* prototype to pass -Wmissing-prototypes */
XS_EXTERNAL(boot_Tk__IO)
{
    dVAR; dXSARGS;
#if (PERL_REVISION == 5 && PERL_VERSION < 9)
    char* file = __FILE__;
#else
    const char* file = __FILE__;
#endif

    PERL_UNUSED_VAR(cv); /* -W */
    PERL_UNUSED_VAR(items); /* -W */
#ifdef XS_APIVERSION_BOOTCHECK
    XS_APIVERSION_BOOTCHECK;
#endif
    XS_VERSION_BOOTCHECK;

        (void)newXSproto_portable("Tk::IO::make_nonblock", XS_Tk__IO_make_nonblock, file, "$$$");
        (void)newXSproto_portable("Tk::IO::restore_mode", XS_Tk__IO_restore_mode, file, "$$");
        (void)newXSproto_portable("Tk::IO::read", XS_Tk__IO_read, file, "$$$;$");
        (void)newXSproto_portable("Tk::IO::readline", XS_Tk__IO_readline, file, "$");

    /* Initialisation Section */

#line 288 "IO.xs"
 {
  IMPORT_EVENT;
 }

#line 529 "IO.c"

    /* End of Initialisation Section */

#if (PERL_REVISION == 5 && PERL_VERSION >= 9)
  if (PL_unitcheckav)
       call_list(PL_scopestack_ix, PL_unitcheckav);
#endif
    XSRETURN_YES;
}

