}
#ifndef O_ACCMODE
-#define O_ACCMODE 3 /* Assume traditional implementation */
+#define O_ACCMODE 3 /* Assume traditional implementation */
#endif
int
return NULL;
#else
#ifdef PERL_IMPLICIT_SYS
- return PerlSIO_fdupopen(f);
+ return PerlSIO_fdupopen(f);
#else
#ifdef WIN32
return win32_fdupopen(f);
return tmpfile();
}
-#else /* PERLIO_IS_STDIO */
+#else /* PERLIO_IS_STDIO */
#ifdef USE_SFIO
}
-#else /* USE_SFIO */
+#else /* USE_SFIO */
/*======================================================================================*/
/*
* Implement all the PerlIO interface ourselves.
if (!s)
s = "(none)";
sprintf(buffer, "%s:%" IVdf " ", s, (IV) CopLINE(PL_curcop));
- len = strlen(buffer);
+ len = strlen(buffer);
vsprintf(buffer+len, fmt, ap);
PerlLIO_write(dbg, buffer, strlen(buffer));
#else
PerlIO_funcs *tab = PerlIOBase(f)->tab;
PerlIO *new;
PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
- new = (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX),f,param, flags);
+ new = (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX),f,param, flags);
return new;
}
else {
MGVTBL perlio_vtab = {
perlio_mg_get,
perlio_mg_set,
- NULL, /* len */
+ NULL, /* len */
perlio_mg_clear,
perlio_mg_free
};
XSRETURN(count);
}
-#endif /* USE_ATTIBUTES_FOR_PERLIO */
+#endif /* USE_ATTIBUTES_FOR_PERLIO */
SV *
PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
*/
char q = ((*s == '\'') ? '"' : '\'');
if (ckWARN(WARN_LAYER))
- Perl_warner(aTHX_ packWARN(WARN_LAYER),
+ Perl_warner(aTHX_ packWARN(WARN_LAYER),
"perlio: invalid separator character %c%c%c in layer specification list %s",
q, *s, q, s);
return -1;
*/
case '\0':
e--;
- if (ckWARN(WARN_LAYER))
- Perl_warner(aTHX_ packWARN(WARN_LAYER),
+ if (ckWARN(WARN_LAYER))
+ Perl_warner(aTHX_ packWARN(WARN_LAYER),
"perlio: argument list not closed for layer \"%.*s\"",
(int) (e - s), s);
return -1;
&PL_sv_undef);
}
else {
- if (warn_layer)
+ if (warn_layer)
Perl_warner(aTHX_ packWARN(WARN_LAYER), "perlio: unknown layer \"%.*s\"",
(int) llen, s);
return -1;
tab = &PerlIO_crlf;
#else
if (PerlIO_stdio.Set_ptrcnt)
- tab = &PerlIO_stdio;
+ tab = &PerlIO_stdio;
#endif
PerlIO_debug("Pushing %s\n", tab->name);
PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
NULL,
NULL,
NULL,
- NULL, /* flush */
- NULL, /* fill */
+ NULL, /* flush */
+ NULL, /* fill */
NULL,
NULL,
NULL,
NULL,
- NULL, /* get_base */
- NULL, /* get_bufsiz */
- NULL, /* get_ptr */
- NULL, /* get_cnt */
- NULL, /* set_ptrcnt */
+ NULL, /* get_base */
+ NULL, /* get_bufsiz */
+ NULL, /* get_ptr */
+ NULL, /* get_cnt */
+ NULL, /* set_ptrcnt */
};
PerlIO_funcs PerlIO_byte = {
NULL,
NULL,
NULL,
- NULL, /* flush */
- NULL, /* fill */
+ NULL, /* flush */
+ NULL, /* fill */
NULL,
NULL,
NULL,
NULL,
- NULL, /* get_base */
- NULL, /* get_bufsiz */
- NULL, /* get_ptr */
- NULL, /* get_cnt */
- NULL, /* set_ptrcnt */
+ NULL, /* get_base */
+ NULL, /* get_bufsiz */
+ NULL, /* get_ptr */
+ NULL, /* get_cnt */
+ NULL, /* set_ptrcnt */
};
PerlIO *
NULL,
NULL,
NULL,
- NULL, /* flush */
- NULL, /* fill */
+ NULL, /* flush */
+ NULL, /* fill */
NULL,
NULL,
NULL,
NULL,
- NULL, /* get_base */
- NULL, /* get_bufsiz */
- NULL, /* get_ptr */
- NULL, /* get_cnt */
- NULL, /* set_ptrcnt */
+ NULL, /* get_base */
+ NULL, /* get_bufsiz */
+ NULL, /* get_ptr */
+ NULL, /* get_cnt */
+ NULL, /* set_ptrcnt */
};
/*--------------------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------------------*/
*/
typedef struct {
- struct _PerlIO base; /* The generic part */
- int fd; /* UNIX like file descriptor */
- int oflags; /* open/fcntl flags */
+ struct _PerlIO base; /* The generic part */
+ int fd; /* UNIX like file descriptor */
+ int oflags; /* open/fcntl flags */
} PerlIOUnix;
int
s->fd = fd;
s->oflags = imode;
PerlIOBase(f)->flags |= PERLIO_F_OPEN;
- PerlIOUnix_refcnt_inc(fd);
+ PerlIOUnix_refcnt_inc(fd);
return f;
}
else {
if (PerlIOUnix_refcnt_dec(fd) > 0) {
PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
return 0;
- }
+ }
}
else {
SETERRNO(EBADF,SS$_IVCHAN);
PerlIOUnix_seek,
PerlIOUnix_tell,
PerlIOUnix_close,
- PerlIOBase_noop_ok, /* flush */
- PerlIOBase_noop_fail, /* fill */
+ PerlIOBase_noop_ok, /* flush */
+ PerlIOBase_noop_fail, /* fill */
PerlIOBase_eof,
PerlIOBase_error,
PerlIOBase_clearerr,
PerlIOBase_setlinebuf,
- NULL, /* get_base */
- NULL, /* get_bufsiz */
- NULL, /* get_ptr */
- NULL, /* get_cnt */
- NULL, /* set_ptrcnt */
+ NULL, /* get_base */
+ NULL, /* get_bufsiz */
+ NULL, /* get_ptr */
+ NULL, /* get_cnt */
+ NULL, /* set_ptrcnt */
};
/*--------------------------------------------------------------------------------------*/
typedef struct {
struct _PerlIO base;
- FILE *stdio; /* The stream */
+ FILE *stdio; /* The stream */
} PerlIOStdio;
IV
return PerlIOBase_pushed(aTHX_ f, mode, arg);
}
+
PerlIO *
PerlIO_importFILE(FILE *stdio, int fl)
{
dTHX;
PerlIO *f = NULL;
if (stdio) {
- PerlIOStdio *s =
- PerlIOSelf(PerlIO_push
- (aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio,
- "r+", Nullsv), PerlIOStdio);
+ /* We need to probe to see how we can open the stream
+ so start with read/write and then try write and read
+ we dup() so that we can fclose without loosing the fd.
+ */
+ int fd = PerlLIO_dup(fileno(stdio));
+ char *mode = "r+";
+ FILE *f2 = fdopen(fd, mode);
+ PerlIOStdio *s;
+ if (!f2 && errno == EINVAL) {
+ mode = "w";
+ f2 = fdopen(fd, mode);
+ }
+ if (!f2 && errno == EINVAL) {
+ mode = "r";
+ f2 = fdopen(fd, mode);
+ }
+ if (!f2) {
+ /* Don't seem to be able to open */
+ return f;
+ }
+ fclose(f2);
+ s = PerlIOSelf(PerlIO_push
+ (aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio,
+ mode, Nullsv), PerlIOStdio);
s->stdio = stdio;
}
return f;
FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
if (PerlIOUnix_refcnt_dec(fileno(stdio)) > 0) {
/* Do not close it but do flush any buffers */
- return PerlIO_flush(f);
+ return PerlIO_flush(f);
}
return (
#ifdef SOCKS5_VERSION_NAME
FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
if (ptr != NULL) {
#ifdef STDIO_PTR_LVALUE
- PerlSIO_set_ptr(stdio, (void*)ptr); /* LHS STDCHAR* cast non-portable */
+ PerlSIO_set_ptr(stdio, (void*)ptr); /* LHS STDCHAR* cast non-portable */
#ifdef STDIO_PTR_LVAL_SETS_CNT
if (PerlSIO_get_cnt(stdio) != (cnt)) {
assert(PerlSIO_get_cnt(stdio) == (cnt));
*/
return;
#endif
-#else /* STDIO_PTR_LVALUE */
+#else /* STDIO_PTR_LVALUE */
PerlProc_abort();
-#endif /* STDIO_PTR_LVALUE */
+#endif /* STDIO_PTR_LVALUE */
}
/*
* Now (or only) set cnt
*/
#ifdef STDIO_CNT_LVALUE
PerlSIO_set_cnt(stdio, cnt);
-#else /* STDIO_CNT_LVALUE */
+#else /* STDIO_CNT_LVALUE */
#if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
PerlSIO_set_ptr(stdio,
PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
cnt));
-#else /* STDIO_PTR_LVAL_SETS_CNT */
+#else /* STDIO_PTR_LVAL_SETS_CNT */
PerlProc_abort();
-#endif /* STDIO_PTR_LVAL_SETS_CNT */
-#endif /* STDIO_CNT_LVALUE */
+#endif /* STDIO_PTR_LVAL_SETS_CNT */
+#endif /* STDIO_CNT_LVALUE */
}
#endif
PerlIOStdio_get_cnt,
#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
PerlIOStdio_set_ptrcnt
-#else /* STDIO_PTR_LVALUE */
+#else /* STDIO_PTR_LVALUE */
NULL
-#endif /* STDIO_PTR_LVALUE */
-#else /* USE_STDIO_PTR */
+#endif /* STDIO_PTR_LVALUE */
+#else /* USE_STDIO_PTR */
NULL,
NULL,
NULL
-#endif /* USE_STDIO_PTR */
+#endif /* USE_STDIO_PTR */
};
FILE *
{
dTHX;
FILE *stdio;
+ char buf[8];
PerlIO_flush(f);
- stdio = fdopen(PerlIO_fileno(f), "r+");
+ stdio = fdopen(PerlIO_fileno(f), PerlIO_modestr(f,buf));
if (stdio) {
PerlIOStdio *s =
- PerlIOSelf(PerlIO_push(aTHX_ f, &PerlIO_stdio, "r+", Nullsv),
+ PerlIOSelf(PerlIO_push(aTHX_ f, &PerlIO_stdio, buf, Nullsv),
PerlIOStdio);
s->stdio = stdio;
}
void
PerlIO_releaseFILE(PerlIO *p, FILE *f)
{
+ PerlIOl *l;
+ while ((l = *p)) {
+ if (l->tab == &PerlIO_stdio) {
+ PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
+ if (s->stdio == f) {
+ dTHX;
+ PerlIO_pop(aTHX_ p);
+ return;
+ }
+ }
+ p = PerlIONext(p);
+ }
+ return;
}
/*--------------------------------------------------------------------------------------*/
f = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
f, narg, args);
if (f) {
- if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
+ if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
/*
* if push fails during open, open fails. close will pop us.
*/
PerlIOBase_flush_linebuf(aTHX);
if (!b->buf)
- PerlIO_get_base(f); /* allocate via vtable */
+ PerlIO_get_base(f); /* allocate via vtable */
b->ptr = b->end = b->buf;
if (PerlIO_fast_gets(n)) {
*/
typedef struct {
- PerlIOBuf base; /* PerlIOBuf stuff */
- STDCHAR *nl; /* Position of crlf we "lied" about in the
+ PerlIOBuf base; /* PerlIOBuf stuff */
+ STDCHAR *nl; /* Position of crlf we "lied" about in the
* buffer */
} PerlIOCrlf;
}
else {
int code;
- b->ptr++; /* say we have read it as far as
+ b->ptr++; /* say we have read it as far as
* flush() is concerned */
- b->buf++; /* Leave space in front of buffer */
- b->bufsiz--; /* Buffer is thus smaller */
- code = PerlIO_fill(f); /* Fetch some more */
- b->bufsiz++; /* Restore size for next time */
- b->buf--; /* Point at space */
- b->ptr = nl = b->buf; /* Which is what we hand
+ b->buf++; /* Leave space in front of buffer */
+ b->bufsiz--; /* Buffer is thus smaller */
+ code = PerlIO_fill(f); /* Fetch some more */
+ b->bufsiz++; /* Restore size for next time */
+ b->buf--; /* Point at space */
+ b->ptr = nl = b->buf; /* Which is what we hand
* off */
- b->posn--; /* Buffer starts here */
- *nl = 0xd; /* Fill in the CR */
+ b->posn--; /* Buffer starts here */
+ *nl = 0xd; /* Fill in the CR */
if (code == 0)
- goto test; /* fill() call worked */
+ goto test; /* fill() call worked */
/*
* CR at EOF - just fall through
*/
if (!ptr) {
if (c->nl) {
ptr = c->nl + 1;
- if (ptr == b->end && *c->nl == 0xd) {
+ if (ptr == b->end && *c->nl == 0xd) {
/* Defered CR at end of buffer case - we lied about count */
- ptr--;
- }
- }
+ ptr--;
+ }
+ }
else {
ptr = b->end;
}
*/
IV flags = PerlIOBase(f)->flags;
STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
- if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
+ if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
/* Defered CR at end of buffer case - we lied about count */
chk--;
- }
+ }
chk -= cnt;
if (ptr != chk ) {
break;
}
else {
- *(b->ptr)++ = 0xd; /* CR */
- *(b->ptr)++ = 0xa; /* LF */
+ *(b->ptr)++ = 0xd; /* CR */
+ *(b->ptr)++ = 0xa; /* LF */
buf++;
if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
PerlIO_flush(f);
sizeof(PerlIOCrlf),
PERLIO_K_BUFFERED | PERLIO_K_CANCRLF,
PerlIOCrlf_pushed,
- PerlIOBase_noop_ok, /* popped */
+ PerlIOBase_noop_ok, /* popped */
PerlIOBuf_open,
NULL,
PerlIOBase_fileno,
PerlIOBuf_dup,
- PerlIOBuf_read, /* generic read works with ptr/cnt lies
+ PerlIOBuf_read, /* generic read works with ptr/cnt lies
* ... */
- PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
- PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
+ PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
+ PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
PerlIOBuf_seek,
PerlIOBuf_tell,
PerlIOBuf_close,
*/
typedef struct {
- PerlIOBuf base; /* PerlIOBuf stuff */
- Mmap_t mptr; /* Mapped address */
- Size_t len; /* mapped length */
- STDCHAR *bbuf; /* malloced buffer if map fails */
+ PerlIOBuf base; /* PerlIOBuf stuff */
+ Mmap_t mptr; /* Mapped address */
+ Size_t len; /* mapped length */
+ STDCHAR *bbuf; /* malloced buffer if map fails */
} PerlIOMmap;
static size_t page_size = 0;
page_size = getpagesize();
# else
# if defined(I_SYS_PARAM) && defined(PAGESIZE)
- page_size = PAGESIZE; /* compiletime, bad */
+ page_size = PAGESIZE; /* compiletime, bad */
# endif
# endif
#endif
/*
* We have a write buffer or flushed PerlIOBuf read buffer
*/
- m->bbuf = b->buf; /* save it in case we need it again */
- b->buf = NULL; /* Clear to trigger below */
+ m->bbuf = b->buf; /* save it in case we need it again */
+ b->buf = NULL; /* Clear to trigger below */
}
if (!b->buf) {
- PerlIOMmap_map(aTHX_ f); /* Try and map it */
+ PerlIOMmap_map(aTHX_ f); /* Try and map it */
if (!b->buf) {
/*
* Map did not work - recover PerlIOBuf buffer if we have one
PerlIOBuf_set_ptrcnt,
};
-#endif /* HAS_MMAP */
+#endif /* HAS_MMAP */
PerlIO *
Perl_PerlIO_stdin(pTHX)
#undef HAS_FSETPOS
#undef HAS_FGETPOS
-#endif /* USE_SFIO */
-#endif /* PERLIO_IS_STDIO */
+#endif /* USE_SFIO */
+#endif /* PERLIO_IS_STDIO */
/*======================================================================================*/
/*
vprintf(char *pat, char *args)
{
_doprnt(pat, args, stdout);
- return 0; /* wrong, but perl doesn't use the return
+ return 0; /* wrong, but perl doesn't use the return
* value */
}
vfprintf(FILE *fd, char *pat, char *args)
{
_doprnt(pat, args, fd);
- return 0; /* wrong, but perl doesn't use the return
+ return 0; /* wrong, but perl doesn't use the return
* value */
}
piece is the order of that argument relative to the others (first, second,
etc). The second is the type of argument, and consists of the type
declaration of the argument (e.g., int, char*, etc). The third piece is
-the calling convention for the argument in the call to the library function.
+the calling convention for the argument in the call to the library function.
While Perl passes arguments to functions by reference,
C passes arguments by value; to implement a C function which modifies data
=head2 Installing your Extension
Once your extension is complete and passes all its tests, installing it
-is quite simple: you simply run "make install". You will either need
+is quite simple: you simply run "make install". You will either need
to have write permission into the directories where Perl is installed,
or ask your system administrator to run the make for you.
OUTPUT:
RETVAL
-And add the following code to test.pl, while incrementing the "1..11"
+And add the following code to test.pl, while incrementing the "1..11"
string in the BEGIN block to "1..13":
$results = Mytest::multi_statfs([ '/', '/blech' ]);
Setting $!
-=head2 EXAMPLE 9 (Coming Soon)
+=head2 EXAMPLE 9 Passing open files to XSes
-Getting fd's from filehandles
+You would think passing files to an XS is difficult, with all the
+typeglobs and stuff. Well, it isn't.
+
+Suppose that for some strange reason we need a wrapper around the
+standard C library function C<fputs()>. This is all we need:
+
+ #define PERLIO_NOT_STDIO 0
+ #include "EXTERN.h"
+ #include "perl.h"
+ #include "XSUB.h"
+
+ #include <stdio.h>
+
+ int
+ fputs(s, stream)
+ char * s
+ FILE * stream
+
+The real work is done in the standard typemap.
+
+B<But> you loose all the fine stuff done by the perlio layers. This
+calls the stdio function C<fputs()>, which knows nothing about them.
+
+For PerlIO *'s, there considered to be three kinds in the
+standard typemap C<InputStream> (T_IN), C<InOutStream> (T_INOUT) and
+C<OutputStream> (T_OUT), a bare C<PerlIO *> is considered a T_INOUT.
+If it matters in your code (see below for why it might) #define or typedef
+one of the specific names and use that as the type in your XS file.
+
+For streams coming I<from> perl the main difference is that
+C<OutputStream> will get the output PerlIO * - which may make
+a difference on a socket.
+
+For streams being handed I<to> perl a new file handle is created
+(i.e. a reference to a new glob) and associated with the PerlIO *
+provided. If the read/write state of the PerlIO * is not correct then you
+may get errors or warnings from when the file handle is used.
+So if you opened the PerlIO * as "w" it should really be an
+C<OutputStream> if open as "r" it should be an C<InputStream>.
+
+Now, suppose you want to use perlio layers in your XS. We'll use the
+perlio C<PerlIO_puts()> function as an example.
+
+In the C part of the XS file (above the first MODULE line) you
+have
+
+ #define OutputStream PerlIO *
+ or
+ typedef PerlIO * OutputStream;
+
+
+And this is the XS code:
+
+ int
+ perlioputs(s, stream)
+ char * s
+ OutputStream stream
+ CODE:
+ RETVAL = PerlIO_puts(stream, s);
+ OUTPUT:
+ RETVAL
+
+We have to use a C<CODE> section because C<PerlIO_puts()> has the arguments
+reversed compared to C<fputs()>, and we want to keep the arguments the same.
+
+Wanting to explore this thoroughly, we want to use the stdio C<fputs()>
+on an explicit PerlIO *. This means we have to ask the perlio system
+for a stdio C<FILE *>:
+
+ int
+ perliofputs(s, stream)
+ char * s
+ PerlIO * stream
+ PREINIT:
+ FILE *fp = PerlIO_findFILE(stream);
+ CODE:
+ if (fp != (FILE*) 0) {
+ RETVAL = fputs(s, fp);
+ } else {
+ RETVAL = -1;
+ }
+ OUTPUT:
+ RETVAL
+
+(We also using bare PerlIO * as the type - so we get the I<input>
+PerlIO * of a socket - if this is undesirable use typedef or #define
+as above.)
+
+Note: C<PerlIO_findFILE()> will search the layers for a stdio
+layer. If it can't find one, it will call C<PerlIO_exportFILE()> to
+generate a new stdio C<FILE>. Please only call C<PerlIO_exportFILE()> if
+you want a I<new> C<FILE>. It will generate one on each call and push a
+new stdio layer. So don't call it repeatedly on the same
+file. C<PerlIO()>_findFILE will retrieve the stdio layer once it has been
+generated by C<PerlIO_exportFILE()>.
+
+This applies to the perlio system only. For versions before 5.7,
+C<PerlIO_exportFILE()> is equivalent to C<PerlIO_findFILE()>.
=head2 Troubleshooting these Examples
=item *
-This document assumes that the executable named "perl" is Perl version 5.
+This document assumes that the executable named "perl" is Perl version 5.
Some systems may have installed Perl version 5 as "perl5".
=back
Reviewed and assisted by Dean Roehrich, Ilya Zakharevich, Andreas Koenig,
and Tim Bunce.
+PerlIO material contributed by Lupe Christoph, with some clarification
+by Nick Ing-Simmons.
+
=head2 Last Changed
-1999/11/30
+2002/05/08
projects / p5sagit/p5-mst-13.2.git / commitdiff