home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / ext / IO / IO.xs < prev    next >
Text File  |  2000-02-25  |  9KB  |  462 lines
  1. /*
  2.  * Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
  3.  * This program is free software; you can redistribute it and/or
  4.  * modify it under the same terms as Perl itself.
  5.  */
  6.  
  7. #define PERL_NO_GET_CONTEXT
  8. #include "EXTERN.h"
  9. #define PERLIO_NOT_STDIO 1
  10. #include "perl.h"
  11. #include "XSUB.h"
  12. #include "poll.h"
  13. #ifdef I_UNISTD
  14. #  include <unistd.h>
  15. #endif
  16. #if defined(I_FCNTL) || defined(HAS_FCNTL)
  17. #  include <fcntl.h>
  18. #endif
  19.  
  20. #ifdef PerlIO
  21. typedef int SysRet;
  22. typedef PerlIO * InputStream;
  23. typedef PerlIO * OutputStream;
  24. #else
  25. #define PERLIO_IS_STDIO 1
  26. typedef int SysRet;
  27. typedef FILE * InputStream;
  28. typedef FILE * OutputStream;
  29. #endif
  30.  
  31. #define MY_start_subparse(fmt,flags) start_subparse(fmt,flags)
  32.  
  33. #ifndef gv_stashpvn
  34. #define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
  35. #endif
  36.  
  37. static int
  38. not_here(char *s)
  39. {
  40.     croak("%s not implemented on this architecture", s);
  41.     return -1;
  42. }
  43.  
  44.  
  45. #ifndef PerlIO
  46. #define PerlIO_fileno(f) fileno(f)
  47. #endif
  48.  
  49. static int
  50. io_blocking(InputStream f, int block)
  51. {
  52.     int RETVAL;
  53.     if(!f) {
  54.     errno = EBADF;
  55.     return -1;
  56.     }
  57. #if defined(HAS_FCNTL)
  58.     RETVAL = fcntl(PerlIO_fileno(f), F_GETFL, 0);
  59.     if (RETVAL >= 0) {
  60.     int mode = RETVAL;
  61. #ifdef O_NONBLOCK
  62.     /* POSIX style */ 
  63. #if defined(O_NDELAY) && O_NDELAY != O_NONBLOCK
  64.     /* Ooops has O_NDELAY too - make sure we don't 
  65.      * get SysV behaviour by mistake. */
  66.  
  67.     /* E.g. In UNICOS and UNICOS/mk a F_GETFL returns an O_NDELAY
  68.      * after a successful F_SETFL of an O_NONBLOCK. */
  69.     RETVAL = RETVAL & (O_NONBLOCK | O_NDELAY) ? 0 : 1;
  70.  
  71.     if (block >= 0) {
  72.         if ((mode & O_NDELAY) || ((block == 0) && !(mode & O_NONBLOCK))) {
  73.             int ret;
  74.             mode = (mode & ~O_NDELAY) | O_NONBLOCK;
  75.             ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
  76.             if(ret < 0)
  77.             RETVAL = ret;
  78.         }
  79.         else
  80.               if ((mode & O_NDELAY) || ((block > 0) && (mode & O_NONBLOCK))) {
  81.             int ret;
  82.             mode &= ~(O_NONBLOCK | O_NDELAY);
  83.             ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
  84.             if(ret < 0)
  85.             RETVAL = ret;
  86.               }
  87.     }
  88. #else
  89.     /* Standard POSIX */ 
  90.     RETVAL = RETVAL & O_NONBLOCK ? 0 : 1;
  91.  
  92.     if ((block == 0) && !(mode & O_NONBLOCK)) {
  93.         int ret;
  94.         mode |= O_NONBLOCK;
  95.         ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
  96.         if(ret < 0)
  97.         RETVAL = ret;
  98.      }
  99.     else if ((block > 0) && (mode & O_NONBLOCK)) {
  100.         int ret;
  101.         mode &= ~O_NONBLOCK;
  102.         ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
  103.         if(ret < 0)
  104.         RETVAL = ret;
  105.      }
  106. #endif 
  107. #else
  108.     /* Not POSIX - better have O_NDELAY or we can't cope.
  109.      * for BSD-ish machines this is an acceptable alternative
  110.      * for SysV we can't tell "would block" from EOF but that is 
  111.      * the way SysV is...
  112.      */
  113.     RETVAL = RETVAL & O_NDELAY ? 0 : 1;
  114.  
  115.     if ((block == 0) && !(mode & O_NDELAY)) {
  116.         int ret;
  117.         mode |= O_NDELAY;
  118.         ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
  119.         if(ret < 0)
  120.         RETVAL = ret;
  121.      }
  122.     else if ((block > 0) && (mode & O_NDELAY)) {
  123.         int ret;
  124.         mode &= ~O_NDELAY;
  125.         ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
  126.         if(ret < 0)
  127.         RETVAL = ret;
  128.      }
  129. #endif
  130.     }
  131.     return RETVAL;
  132. #else
  133.  return -1;
  134. #endif
  135. }
  136.  
  137. MODULE = IO    PACKAGE = IO::Seekable    PREFIX = f
  138.  
  139. SV *
  140. fgetpos(handle)
  141.     InputStream    handle
  142.     CODE:
  143.     if (handle) {
  144.         Fpos_t pos;
  145. #ifdef PerlIO
  146.         PerlIO_getpos(handle, &pos);
  147. #else
  148.         fgetpos(handle, &pos);
  149. #endif
  150.         ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t)));
  151.     }
  152.     else {
  153.         ST(0) = &PL_sv_undef;
  154.         errno = EINVAL;
  155.     }
  156.  
  157. SysRet
  158. fsetpos(handle, pos)
  159.     InputStream    handle
  160.     SV *        pos
  161.     CODE:
  162.         char *p;
  163.     STRLEN len;
  164.     if (handle && (p = SvPV(pos,len)) && len == sizeof(Fpos_t))
  165. #ifdef PerlIO
  166.         RETVAL = PerlIO_setpos(handle, (Fpos_t*)p);
  167. #else
  168.         RETVAL = fsetpos(handle, (Fpos_t*)p);
  169. #endif
  170.     else {
  171.         RETVAL = -1;
  172.         errno = EINVAL;
  173.     }
  174.     OUTPUT:
  175.     RETVAL
  176.  
  177. MODULE = IO    PACKAGE = IO::File    PREFIX = f
  178.  
  179. SV *
  180. new_tmpfile(packname = "IO::File")
  181.     char *        packname
  182.     PREINIT:
  183.     OutputStream fp;
  184.     GV *gv;
  185.     CODE:
  186. #ifdef PerlIO
  187.     fp = PerlIO_tmpfile();
  188. #else
  189.     fp = tmpfile();
  190. #endif
  191.     gv = (GV*)SvREFCNT_inc(newGVgen(packname));
  192.     hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD);
  193.     if (do_open(gv, "+>&", 3, FALSE, 0, 0, fp)) {
  194.         ST(0) = sv_2mortal(newRV((SV*)gv));
  195.         sv_bless(ST(0), gv_stashpv(packname, TRUE));
  196.         SvREFCNT_dec(gv);   /* undo increment in newRV() */
  197.     }
  198.     else {
  199.         ST(0) = &PL_sv_undef;
  200.         SvREFCNT_dec(gv);
  201.     }
  202.  
  203. MODULE = IO    PACKAGE = IO::Poll
  204.  
  205. void   
  206. _poll(timeout,...)
  207.     int timeout;
  208. PPCODE:
  209. {
  210. #ifdef HAS_POLL
  211.     int nfd = (items - 1) / 2;
  212.     SV *tmpsv = NEWSV(999,nfd * sizeof(struct pollfd));
  213.     struct pollfd *fds = (struct pollfd *)SvPVX(tmpsv);
  214.     int i,j,ret;
  215.     for(i=1, j=0  ; j < nfd ; j++) {
  216.     fds[j].fd = SvIV(ST(i));
  217.     i++;
  218.     fds[j].events = SvIV(ST(i));
  219.     i++;
  220.     fds[j].revents = 0;
  221.     }
  222.     if((ret = poll(fds,nfd,timeout)) >= 0) {
  223.     for(i=1, j=0 ; j < nfd ; j++) {
  224.         sv_setiv(ST(i), fds[j].fd); i++;
  225.         sv_setiv(ST(i), fds[j].revents); i++;
  226.     }
  227.     }
  228.     SvREFCNT_dec(tmpsv);
  229.     XSRETURN_IV(ret);
  230. #else
  231.     not_here("IO::Poll::poll");
  232. #endif
  233. }
  234.  
  235. MODULE = IO    PACKAGE = IO::Handle    PREFIX = io_
  236.  
  237. void
  238. io_blocking(handle,blk=-1)
  239.     InputStream    handle
  240.     int        blk
  241. PROTOTYPE: $;$
  242. CODE:
  243. {
  244.     int ret = io_blocking(handle, items == 1 ? -1 : blk ? 1 : 0);
  245.     if(ret >= 0)
  246.     XSRETURN_IV(ret);
  247.     else
  248.     XSRETURN_UNDEF;
  249. }
  250.  
  251. MODULE = IO    PACKAGE = IO::Handle    PREFIX = f
  252.  
  253.  
  254. int
  255. ungetc(handle, c)
  256.     InputStream    handle
  257.     int        c
  258.     CODE:
  259.     if (handle)
  260. #ifdef PerlIO
  261.         RETVAL = PerlIO_ungetc(handle, c);
  262. #else
  263.         RETVAL = ungetc(c, handle);
  264. #endif
  265.     else {
  266.         RETVAL = -1;
  267.         errno = EINVAL;
  268.     }
  269.     OUTPUT:
  270.     RETVAL
  271.  
  272. int
  273. ferror(handle)
  274.     InputStream    handle
  275.     CODE:
  276.     if (handle)
  277. #ifdef PerlIO
  278.         RETVAL = PerlIO_error(handle);
  279. #else
  280.         RETVAL = ferror(handle);
  281. #endif
  282.     else {
  283.         RETVAL = -1;
  284.         errno = EINVAL;
  285.     }
  286.     OUTPUT:
  287.     RETVAL
  288.  
  289. int
  290. clearerr(handle)
  291.     InputStream    handle
  292.     CODE:
  293.     if (handle) {
  294. #ifdef PerlIO
  295.         PerlIO_clearerr(handle);
  296. #else
  297.         clearerr(handle);
  298. #endif
  299.         RETVAL = 0;
  300.     }
  301.     else {
  302.         RETVAL = -1;
  303.         errno = EINVAL;
  304.     }
  305.     OUTPUT:
  306.     RETVAL
  307.  
  308. int
  309. untaint(handle)
  310.        SV *    handle
  311.     CODE:
  312. #ifdef IOf_UNTAINT
  313.     IO * io;
  314.     io = sv_2io(handle);
  315.     if (io) {
  316.         IoFLAGS(io) |= IOf_UNTAINT;
  317.         RETVAL = 0;
  318.     }
  319.         else {
  320. #endif
  321.         RETVAL = -1;
  322.         errno = EINVAL;
  323. #ifdef IOf_UNTAINT
  324.     }
  325. #endif
  326.     OUTPUT:
  327.     RETVAL
  328.  
  329. SysRet
  330. fflush(handle)
  331.     OutputStream    handle
  332.     CODE:
  333.     if (handle)
  334. #ifdef PerlIO
  335.         RETVAL = PerlIO_flush(handle);
  336. #else
  337.         RETVAL = Fflush(handle);
  338. #endif
  339.     else {
  340.         RETVAL = -1;
  341.         errno = EINVAL;
  342.     }
  343.     OUTPUT:
  344.     RETVAL
  345.  
  346. void
  347. setbuf(handle, buf)
  348.     OutputStream    handle
  349.     char *        buf = SvPOK(ST(1)) ? sv_grow(ST(1), BUFSIZ) : 0;
  350.     CODE:
  351.     if (handle)
  352. #ifdef PERLIO_IS_STDIO
  353.         setbuf(handle, buf);
  354. #else
  355.         not_here("IO::Handle::setbuf");
  356. #endif
  357.  
  358. SysRet
  359. setvbuf(handle, buf, type, size)
  360.     OutputStream    handle
  361.     char *        buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
  362.     int        type
  363.     int        size
  364.     CODE:
  365. #if defined(PERLIO_IS_STDIO) && defined(_IOFBF) && defined(HAS_SETVBUF)
  366.     if (!handle)            /* Try input stream. */
  367.         handle = IoIFP(sv_2io(ST(0)));
  368.     if (handle)
  369.         RETVAL = setvbuf(handle, buf, type, size);
  370.     else {
  371.         RETVAL = -1;
  372.         errno = EINVAL;
  373.     }
  374. #else
  375.     RETVAL = (SysRet) not_here("IO::Handle::setvbuf");
  376. #endif
  377.     OUTPUT:
  378.     RETVAL
  379.  
  380.  
  381. SysRet
  382. fsync(handle)
  383.     OutputStream handle
  384.     CODE:
  385. #ifdef HAS_FSYNC
  386.     if(handle)
  387.         RETVAL = fsync(PerlIO_fileno(handle));
  388.     else {
  389.         RETVAL = -1;
  390.         errno = EINVAL;
  391.     }
  392. #else
  393.     RETVAL = (SysRet) not_here("IO::Handle::sync");
  394. #endif
  395.     OUTPUT:
  396.     RETVAL
  397.  
  398.  
  399. BOOT:
  400. {
  401.     HV *stash;
  402.     /*
  403.      * constant subs for IO::Poll
  404.      */
  405.     stash = gv_stashpvn("IO::Poll", 8, TRUE);
  406. #ifdef    POLLIN
  407.     newCONSTSUB(stash,"POLLIN",newSViv(POLLIN));
  408. #endif
  409. #ifdef    POLLPRI
  410.         newCONSTSUB(stash,"POLLPRI", newSViv(POLLPRI));
  411. #endif
  412. #ifdef    POLLOUT
  413.         newCONSTSUB(stash,"POLLOUT", newSViv(POLLOUT));
  414. #endif
  415. #ifdef    POLLRDNORM
  416.         newCONSTSUB(stash,"POLLRDNORM", newSViv(POLLRDNORM));
  417. #endif
  418. #ifdef    POLLWRNORM
  419.         newCONSTSUB(stash,"POLLWRNORM", newSViv(POLLWRNORM));
  420. #endif
  421. #ifdef    POLLRDBAND
  422.         newCONSTSUB(stash,"POLLRDBAND", newSViv(POLLRDBAND));
  423. #endif
  424. #ifdef    POLLWRBAND
  425.         newCONSTSUB(stash,"POLLWRBAND", newSViv(POLLWRBAND));
  426. #endif
  427. #ifdef    POLLNORM
  428.         newCONSTSUB(stash,"POLLNORM", newSViv(POLLNORM));
  429. #endif
  430. #ifdef    POLLERR
  431.         newCONSTSUB(stash,"POLLERR", newSViv(POLLERR));
  432. #endif
  433. #ifdef    POLLHUP
  434.         newCONSTSUB(stash,"POLLHUP", newSViv(POLLHUP));
  435. #endif
  436. #ifdef    POLLNVAL
  437.         newCONSTSUB(stash,"POLLNVAL", newSViv(POLLNVAL));
  438. #endif
  439.     /*
  440.      * constant subs for IO::Handle
  441.      */
  442.     stash = gv_stashpvn("IO::Handle", 10, TRUE);
  443. #ifdef _IOFBF
  444.         newCONSTSUB(stash,"_IOFBF", newSViv(_IOFBF));
  445. #endif
  446. #ifdef _IOLBF
  447.         newCONSTSUB(stash,"_IOLBF", newSViv(_IOLBF));
  448. #endif
  449. #ifdef _IONBF
  450.         newCONSTSUB(stash,"_IONBF", newSViv(_IONBF));
  451. #endif
  452. #ifdef SEEK_SET
  453.         newCONSTSUB(stash,"SEEK_SET", newSViv(SEEK_SET));
  454. #endif
  455. #ifdef SEEK_CUR
  456.         newCONSTSUB(stash,"SEEK_CUR", newSViv(SEEK_CUR));
  457. #endif
  458. #ifdef SEEK_END
  459.         newCONSTSUB(stash,"SEEK_END", newSViv(SEEK_END));
  460. #endif
  461. }
  462.