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