chnGlue.c

/*
  Copyright (c) 1997-2003 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.
*/

#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>

#include "tkGlue.def"

#include "pTk/tkPort.h"
#include "pTk/tkInt.h"
#include "tkGlue.h"

static char *Lang_Utf8ToBytes(CONST char *src);

Tcl_Channel
Tcl_OpenFileChannel(interp,fileName,modeString,permissions)
Tcl_Interp *interp;
CONST char *fileName;
CONST char *modeString;
int permissions;
{PerlIO *f = PerlIO_open(Lang_Utf8ToBytes(fileName),modeString);
 /* Hopefully every fileName here should be translated back to octets ... */
 if (!f)
  {
   /* FIXME - use strerr() or perl's equivalent */
   if (interp)
    Tcl_SprintfResult(interp,"Cannot open '%s' in mode '%s'",fileName, modeString);
  }
 return (Tcl_Channel) f;
}

Tcl_Channel
Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions)
    Tcl_Interp *interp;                 /* Interpreter for error reporting;
                                         * can be NULL. */
    Tcl_Obj *pathPtr;                   /* Name of file to open. */
    CONST char *modeString;             /* A list of POSIX open modes or
                                         * a string such as "rw". */
    int permissions;                    /* If the open involves creating a
                                         * file, with what modes to create
                                         * it? */
{
 return Tcl_OpenFileChannel(interp, Tcl_GetString(pathPtr), modeString, permissions);
}



Tcl_Channel
Tcl_GetChannel (Tcl_Interp *interp,CONST char *chanName, int *modePtr)
{
 Tcl_SprintfResult(interp,"Tcl_GetChannel %s not implemeted",chanName);
 return NULL;
}


int
Tcl_Read(chan,bufPtr,toRead)
Tcl_Channel chan;
char *bufPtr;
int toRead;
{
 PerlIO *f = (PerlIO *) chan;
 return PerlIO_read(f,bufPtr,toRead);
}

int
Tcl_Write(chan, buf, count)
Tcl_Channel chan;
CONST char *buf;
int count;
{
 PerlIO *f = (PerlIO *) chan;
 if (count < 0)
  count = strlen(buf);
 return PerlIO_write(f,buf,count);
}

int
Tcl_WriteChars(Tcl_Channel chan, CONST char * src, int srcLen)
{
 return Tcl_Write(chan, (char *) src, srcLen);
}

Tcl_Channel
Tcl_GetStdChannel(int type)
{
 switch(type)
  {
   case TCL_STDIN:
    return (Tcl_Channel) PerlIO_stdin();
   case TCL_STDOUT:
    return (Tcl_Channel) PerlIO_stdout();
   case TCL_STDERR:
    return (Tcl_Channel) PerlIO_stderr();
  }
 return NULL;
}


int
Tcl_Close(interp,chan)
Tcl_Interp *interp;
Tcl_Channel chan;
{
 return PerlIO_close((PerlIO *) chan);
}

Tcl_WideInt
Tcl_Seek(Tcl_Channel chan, Tcl_WideInt offset, int mode)
{
 PerlIO_seek((PerlIO *) chan, offset, mode);
 return PerlIO_tell((PerlIO *) chan);
}

int
Tcl_Eof(Tcl_Channel chan)
{
 PerlIO *f = (PerlIO *) chan;
 return PerlIO_eof(f);
}

int
Tcl_SetChannelOption(Tcl_Interp *interp, Tcl_Channel chan,
                  CONST char *optionName, CONST char *newValue)
{
 PerlIO *f = (PerlIO *) chan;
 if (LangCmpOpt("-translation",optionName,-1) == 0 ||
     LangCmpOpt("-encoding",optionName,-1) == 0
    )
  {
   if (strcmp(newValue,"binary") == 0)
    {
     dTHX;
     PerlIO_binmode(aTHX_ f,'+',O_BINARY,Nullch);
     return TCL_OK;
    }
  }
 warn("Set option %s=%s on channel %d", optionName, newValue, PerlIO_fileno(f));
 return TCL_OK;
}

char *
Lang_Utf8ToBytes(CONST char *src)
{
 SV* sv = newSVpv(src,0);
 sv_2mortal(sv);
 sv_utf8_decode(sv);
 return SvPVbyte_nolen(sv);
}