summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--embed.h2
-rwxr-xr-xembed.pl18
-rw-r--r--ext/Encode/Encode.xs16
-rw-r--r--ext/PerlIO/Scalar/Scalar.xs13
-rw-r--r--ext/PerlIO/Via/Via.xs19
-rw-r--r--hv.c2
-rw-r--r--perl.h2
-rw-r--r--perlio.c365
-rw-r--r--perlio.h2
-rw-r--r--perliol.h3
-rw-r--r--pod/perlapi.pod48
-rw-r--r--proto.h18
-rw-r--r--sv.c44
-rw-r--r--sv.h10
-rw-r--r--win32/win32io.c14
15 files changed, 376 insertions, 200 deletions
diff --git a/embed.h b/embed.h
index a3f43d0ff1..341f90768f 100644
--- a/embed.h
+++ b/embed.h
@@ -2360,7 +2360,7 @@
#define any_dup(a,b) Perl_any_dup(aTHX_ a,b)
#define he_dup(a,b,c) Perl_he_dup(aTHX_ a,b,c)
#define re_dup(a,b) Perl_re_dup(aTHX_ a,b)
-#define fp_dup(a,b) Perl_fp_dup(aTHX_ a,b)
+#define fp_dup(a,b,c) Perl_fp_dup(aTHX_ a,b,c)
#define dirp_dup(a) Perl_dirp_dup(aTHX_ a)
#define gp_dup(a,b) Perl_gp_dup(aTHX_ a,b)
#define mg_dup(a,b) Perl_mg_dup(aTHX_ a,b)
diff --git a/embed.pl b/embed.pl
index cec8d7e749..92617872af 100755
--- a/embed.pl
+++ b/embed.pl
@@ -1940,17 +1940,17 @@ Ap |void |newMYSUB |I32 floor|OP *o|OP *proto|OP *attrs|OP *block
p |OP * |my_attrs |OP *o|OP *attrs
p |void |boot_core_xsutils
#if defined(USE_ITHREADS)
-Ap |PERL_CONTEXT*|cx_dup |PERL_CONTEXT* cx|I32 ix|I32 max|clone_params* param
-Ap |PERL_SI*|si_dup |PERL_SI* si|clone_params* param
-Ap |ANY* |ss_dup |PerlInterpreter* proto_perl|clone_params* param
+Ap |PERL_CONTEXT*|cx_dup |PERL_CONTEXT* cx|I32 ix|I32 max|CLONE_PARAMS* param
+Ap |PERL_SI*|si_dup |PERL_SI* si|CLONE_PARAMS* param
+Ap |ANY* |ss_dup |PerlInterpreter* proto_perl|CLONE_PARAMS* param
Ap |void* |any_dup |void* v|PerlInterpreter* proto_perl
-Ap |HE* |he_dup |HE* e|bool shared|clone_params* param
-Ap |REGEXP*|re_dup |REGEXP* r|clone_params* param
-Ap |PerlIO*|fp_dup |PerlIO* fp|char type
+Ap |HE* |he_dup |HE* e|bool shared|CLONE_PARAMS* param
+Ap |REGEXP*|re_dup |REGEXP* r|CLONE_PARAMS* param
+Ap |PerlIO*|fp_dup |PerlIO* fp|char type|CLONE_PARAMS* param
Ap |DIR* |dirp_dup |DIR* dp
-Ap |GP* |gp_dup |GP* gp|clone_params* param
-Ap |MAGIC* |mg_dup |MAGIC* mg|clone_params* param
-Ap |SV* |sv_dup |SV* sstr|clone_params* param
+Ap |GP* |gp_dup |GP* gp|CLONE_PARAMS* param
+Ap |MAGIC* |mg_dup |MAGIC* mg|CLONE_PARAMS* param
+Ap |SV* |sv_dup |SV* sstr|CLONE_PARAMS* param
#if defined(HAVE_INTERP_INTERN)
Ap |void |sys_intern_dup |struct interp_intern* src \
|struct interp_intern* dst
diff --git a/ext/Encode/Encode.xs b/ext/Encode/Encode.xs
index f3e8738836..87e8913f2f 100644
--- a/ext/Encode/Encode.xs
+++ b/ext/Encode/Encode.xs
@@ -325,6 +325,21 @@ PerlIOEncode_tell(PerlIO *f)
return b->posn;
}
+PerlIO *
+PerlIOEncode_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *params)
+{
+ if ((f = PerlIOBase_dup(aTHX_ f, o, params)))
+ {
+ PerlIOEncode *fe = PerlIOSelf(f,PerlIOEncode);
+ PerlIOEncode *oe = PerlIOSelf(o,PerlIOEncode);
+ if (oe->enc)
+ {
+ fe->enc = PerlIO_sv_dup(aTHX_ oe->enc, params);
+ }
+ }
+ return f;
+}
+
PerlIO_funcs PerlIO_encode = {
"encoding",
sizeof(PerlIOEncode),
@@ -334,6 +349,7 @@ PerlIO_funcs PerlIO_encode = {
PerlIOBuf_open,
PerlIOEncode_getarg,
PerlIOBase_fileno,
+ PerlIOEncode_dup,
PerlIOBuf_read,
PerlIOBuf_unread,
PerlIOBuf_write,
diff --git a/ext/PerlIO/Scalar/Scalar.xs b/ext/PerlIO/Scalar/Scalar.xs
index d8ee701b59..3bd37de010 100644
--- a/ext/PerlIO/Scalar/Scalar.xs
+++ b/ext/PerlIO/Scalar/Scalar.xs
@@ -236,6 +236,18 @@ PerlIOScalar_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const c
return NULL;
}
+PerlIO *
+PerlIOScalar_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
+{
+ if ((f = PerlIOBase_dup(aTHX_ f, o, param)))
+ {
+ PerlIOScalar *fs = PerlIOSelf(f,PerlIOScalar);
+ PerlIOScalar *os = PerlIOSelf(o,PerlIOScalar);
+ /* var has been set by implicit push */
+ fs->posn = os->posn;
+ }
+ return f;
+}
PerlIO_funcs PerlIO_scalar = {
"Scalar",
@@ -246,6 +258,7 @@ PerlIO_funcs PerlIO_scalar = {
PerlIOScalar_open,
NULL,
PerlIOScalar_fileno,
+ PerlIOScalar_dup,
PerlIOBase_read,
PerlIOScalar_unread,
PerlIOScalar_write,
diff --git a/ext/PerlIO/Via/Via.xs b/ext/PerlIO/Via/Via.xs
index fcf316c3fc..adf0abfd78 100644
--- a/ext/PerlIO/Via/Via.xs
+++ b/ext/PerlIO/Via/Via.xs
@@ -13,7 +13,6 @@ typedef struct
SV * obj;
SV * var;
SSize_t cnt;
- Off_t posn;
IO * io;
SV * fh;
CV *PUSHED;
@@ -54,7 +53,6 @@ PerlIOVia_fetchmethod(pTHX_ PerlIOVia *s,char *method,CV **save)
{
return *save = (CV *) -1;
}
-
}
SV *
@@ -271,7 +269,7 @@ PerlIOVia_seek(PerlIO *f, Off_t offset, int whence)
dTHX;
PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
SV *offsv = sv_2mortal(newSViv(offset));
- SV *whsv = sv_2mortal(newSViv(offset));
+ SV *whsv = sv_2mortal(newSViv(whence));
SV *result = PerlIOVia_method(aTHX_ f,MYMethod(SEEK),G_SCALAR,offsv,whsv,Nullsv);
return (result) ? SvIV(result) : -1;
}
@@ -282,7 +280,7 @@ PerlIOVia_tell(PerlIO *f)
dTHX;
PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
SV *result = PerlIOVia_method(aTHX_ f,MYMethod(TELL),G_SCALAR,Nullsv);
- return (result) ? (Off_t) SvIV(result) : s->posn;
+ return (result) ? (Off_t) SvIV(result) : (Off_t) -1;
}
SSize_t
@@ -492,6 +490,18 @@ PerlIOVia_eof(PerlIO *f)
return (result) ? SvIV(result) : PerlIOBase_eof(f);
}
+PerlIO *
+PerlIOVia_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
+{
+ if ((f = PerlIOBase_dup(aTHX_ f, o, param)))
+ {
+ /* Most of the fields will lazily set them selves up as needed
+ stash and obj have been set up by the implied push
+ */
+ }
+ return f;
+}
+
PerlIO_funcs PerlIO_object = {
"Via",
sizeof(PerlIOVia),
@@ -501,6 +511,7 @@ PerlIO_funcs PerlIO_object = {
NULL, /* PerlIOVia_open, */
PerlIOVia_getarg,
PerlIOVia_fileno,
+ PerlIOVia_dup,
PerlIOVia_read,
PerlIOVia_unread,
PerlIOVia_write,
diff --git a/hv.c b/hv.c
index d5539209bb..d3bb914653 100644
--- a/hv.c
+++ b/hv.c
@@ -99,7 +99,7 @@ Perl_unshare_hek(pTHX_ HEK *hek)
#if defined(USE_ITHREADS)
HE *
-Perl_he_dup(pTHX_ HE *e, bool shared, clone_params* param)
+Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
{
HE *ret;
diff --git a/perl.h b/perl.h
index eac97f5d3e..5e2eede467 100644
--- a/perl.h
+++ b/perl.h
@@ -1632,6 +1632,8 @@ typedef struct mgvtbl MGVTBL;
typedef union any ANY;
typedef struct ptr_tbl_ent PTR_TBL_ENT_t;
typedef struct ptr_tbl PTR_TBL_t;
+typedef struct clone_params CLONE_PARAMS;
+
#include "handy.h"
diff --git a/perlio.c b/perlio.c
index eb32a045e9..dd9f394c84 100644
--- a/perlio.c
+++ b/perlio.c
@@ -1,13 +1,13 @@
/*
- * perlio.c Copyright (c) 1996-2001, Nick Ing-Simmons You may distribute
+ * perlio.c Copyright (c) 1996-2001, Nick Ing-Simmons You may distribute
* under the terms of either the GNU General Public License or the
- * Artistic License, as specified in the README file.
+ * Artistic License, as specified in the README file.
*/
/*
- * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get
+ * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get
* at the dispatch tables, even when we do not need it for other reasons.
- * Invent a dSYS macro to abstract this out
+ * Invent a dSYS macro to abstract this out
*/
#ifdef PERL_IMPLICIT_SYS
#define dSYS dTHX
@@ -25,7 +25,7 @@
#define PERLIO_NOT_STDIO 0
#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
/*
- * #define PerlIO FILE
+ * #define PerlIO FILE
*/
#endif
/*
@@ -49,7 +49,7 @@ int
perlsio_binmode(FILE *fp, int iotype, int mode)
{
/*
- * This used to be contents of do_binmode in doio.c
+ * This used to be contents of do_binmode in doio.c
*/
#ifdef DOSISH
# if defined(atarist) || defined(__MINT__)
@@ -70,11 +70,11 @@ perlsio_binmode(FILE *fp, int iotype, int mode)
#endif
# if defined(WIN32) && defined(__BORLANDC__)
/*
- * The translation mode of the stream is maintained independent of
+ * The translation mode of the stream is maintained independent of
* the translation mode of the fd in the Borland RTL (heavy
- * digging through their runtime sources reveal). User has to set
+ * digging through their runtime sources reveal). User has to set
* the mode explicitly for the stream (though they don't document
- * this anywhere). GSAR 97-5-24
+ * this anywhere). GSAR 97-5-24
*/
fseek(fp, 0L, 0);
if (mode & O_BINARY)
@@ -108,7 +108,7 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
}
Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
/*
- * NOTREACHED
+ * NOTREACHED
*/
return -1;
}
@@ -129,7 +129,7 @@ PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
}
/*
- * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
+ * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
*/
PerlIO *
@@ -190,9 +190,9 @@ PerlIO_init(void)
{
/*
* Does nothing (yet) except force this file to be included in perl
- * binary. That allows this file to force inclusion of other functions
+ * binary. That allows this file to force inclusion of other functions
* that may be required by loadable extensions e.g. for
- * FileHandle::tmpfile
+ * FileHandle::tmpfile
*/
}
@@ -212,7 +212,7 @@ PerlIO_tmpfile(void)
/*
* This section is just to make sure these functions get pulled in from
- * libsfio.a
+ * libsfio.a
*/
#undef PerlIO_tmpfile
@@ -228,13 +228,13 @@ PerlIO_init(void)
/*
* Force this file to be included in perl binary. Which allows this
* file to force inclusion of other functions that may be required by
- * loadable extensions e.g. for FileHandle::tmpfile
+ * loadable extensions e.g. for FileHandle::tmpfile
*/
/*
- * Hack sfio does its own 'autoflush' on stdout in common cases. Flush
+ * Hack sfio does its own 'autoflush' on stdout in common cases. Flush
* results in a lot of lseek()s to regular files and lot of small
- * writes to pipes.
+ * writes to pipes.
*/
sfset(sfstdout, SF_SHARE, 0);
}
@@ -264,14 +264,14 @@ PerlIO_findFILE(PerlIO *pio)
#else /* USE_SFIO */
/*======================================================================================*/
/*
- * Implement all the PerlIO interface ourselves.
+ * Implement all the PerlIO interface ourselves.
*/
#include "perliol.h"
/*
* We _MUST_ have <unistd.h> if we are using lseek() and may have large
- * files
+ * files
*/
#ifdef I_UNISTD
#include <unistd.h>
@@ -300,6 +300,19 @@ PerlIO_debug(const char *fmt, ...)
}
if (dbg > 0) {
dTHX;
+#ifdef USE_ITHREADS
+ /* Use fixed buffer as sv_catpvf etc. needs SVs */
+ char buffer[1024];
+ char *s;
+ STRLEN len;
+ s = CopFILE(PL_curcop);
+ if (!s)
+ s = "(none)";
+ sprintf(buffer, "%s:%" IVdf " ", s, (IV) CopLINE(PL_curcop));
+ len = strlen(buffer);
+ vsprintf(buffer+len, fmt, ap);
+ PerlLIO_write(dbg, buffer, strlen(buffer));
+#else
SV *sv = newSVpvn("", 0);
char *s;
STRLEN len;
@@ -313,6 +326,7 @@ PerlIO_debug(const char *fmt, ...)
s = SvPV(sv, len);
PerlLIO_write(dbg, s, len);
SvREFCNT_dec(sv);
+#endif
}
va_end(ap);
}
@@ -320,11 +334,11 @@ PerlIO_debug(const char *fmt, ...)
/*--------------------------------------------------------------------------------------*/
/*
- * Inner level routines
+ * Inner level routines
*/
/*
- * Table of pointers to the PerlIO structs (malloc'ed)
+ * Table of pointers to the PerlIO structs (malloc'ed)
*/
PerlIO *_perlio = NULL;
#define PERLIO_TABLE_SIZE 64
@@ -335,7 +349,7 @@ PerlIO *
PerlIO_allocate(pTHX)
{
/*
- * Find a free slot in the table, allocating new table as necessary
+ * Find a free slot in the table, allocating new table as necessary
*/
PerlIO **last;
PerlIO *f;
@@ -478,7 +492,7 @@ PerlIO_pop(pTHX_ PerlIO *f)
/*
* If popped returns non-zero do not free its layer structure
* it has either done so itself, or it is shared and still in
- * use
+ * use
*/
if ((*l->tab->Popped) (f) != 0)
return;
@@ -490,7 +504,7 @@ PerlIO_pop(pTHX_ PerlIO *f)
/*--------------------------------------------------------------------------------------*/
/*
- * XS Interface for perl code
+ * XS Interface for perl code
*/
PerlIO_funcs *
@@ -512,7 +526,7 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
SV *layer = newSVpvn(name, len);
ENTER;
/*
- * The two SVs are magically freed by load_module
+ * The two SVs are magically freed by load_module
*/
Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
LEAVE;
@@ -653,7 +667,7 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
/*
* Message is consistent with how attribute lists are
* passed. Even though this means "foo : : bar" is
- * seen as an invalid separator character.
+ * seen as an invalid separator character.
*/
char q = ((*s == '\'') ? '"' : '\'');
Perl_warn(aTHX_
@@ -681,13 +695,13 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
/*
* It's a nul terminated string, not allowed
* to \ the terminating null. Anything other
- * character is passed over.
+ * character is passed over.
*/
if (*e++) {
break;
}
/*
- * Drop through
+ * Drop through
*/
case '\0':
e--;
@@ -697,7 +711,7 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
return -1;
default:
/*
- * boring.
+ * boring.
*/
break;
}
@@ -870,12 +884,12 @@ IV
PerlIORaw_pushed(PerlIO *f, const char *mode, SV *arg)
{
/*
- * Remove the dummy layer
+ * Remove the dummy layer
*/
dTHX;
PerlIO_pop(aTHX_ f);
/*
- * Pop back to bottom layer
+ * Pop back to bottom layer
*/
if (f && *f) {
PerlIO_flush(f);
@@ -885,7 +899,7 @@ PerlIORaw_pushed(PerlIO *f, const char *mode, SV *arg)
}
else {
/*
- * Nothing bellow - push unix on top then remove it
+ * Nothing bellow - push unix on top then remove it
*/
if (PerlIO_push(aTHX_ f, PerlIO_default_btm(), mode, arg)) {
PerlIO_pop(aTHX_ PerlIONext(f));
@@ -936,7 +950,7 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
/*--------------------------------------------------------------------------------------*/
/*
- * Given the abstraction above the public API functions
+ * Given the abstraction above the public API functions
*/
int
@@ -974,16 +988,13 @@ PerlIO__close(PerlIO *f)
#undef PerlIO_fdupopen
PerlIO *
-PerlIO_fdupopen(pTHX_ PerlIO *f)
+PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param)
{
if (f && *f) {
- char buf[8];
- int fd = PerlLIO_dup(PerlIO_fileno(f));
- PerlIO *new = PerlIO_fdopen(fd, PerlIO_modestr(f, buf));
- if (new) {
- Off_t posn = PerlIO_tell(f);
- PerlIO_seek(new, posn, SEEK_SET);
- }
+ PerlIO_funcs *tab = PerlIOBase(f)->tab;
+ PerlIO *new;
+ PerlIO_debug("fdupopen f=%p param=%p\n",f,param);
+ new = (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX),f,param);
return new;
}
else {
@@ -1024,7 +1035,7 @@ PerlIO_context_layers(pTHX_ const char *mode)
{
const char *type = NULL;
/*
- * Need to supply default layer info from open.pm
+ * Need to supply default layer info from open.pm
*/
if (PL_curcop) {
SV *layers = PL_curcop->cop_io;
@@ -1033,7 +1044,7 @@ PerlIO_context_layers(pTHX_ const char *mode)
type = SvPV(layers, len);
if (type && mode[0] != 'r') {
/*
- * Skip to write part
+ * Skip to write part
*/
const char *s = strchr(type, 0);
if (s && (s - type) < len) {
@@ -1049,13 +1060,13 @@ static PerlIO_funcs *
PerlIO_layer_from_ref(pTHX_ SV *sv)
{
/*
- * For any scalar type load the handler which is bundled with perl
+ * For any scalar type load the handler which is bundled with perl
*/
if (SvTYPE(sv) < SVt_PVAV)
return PerlIO_find_layer(aTHX_ "Scalar", 6, 1);
/*
- * For other types allow if layer is known but don't try and load it
+ * For other types allow if layer is known but don't try and load it
*/
switch (SvTYPE(sv)) {
case SVt_PVAV:
@@ -1081,8 +1092,8 @@ PerlIO_resolve_layers(pTHX_ const char *layers,
if (narg) {
SV *arg = *args;
/*
- * If it is a reference but not an object see if we have a handler
- * for it
+ * If it is a reference but not an object see if we have a handler
+ * for it
*/
if (SvROK(arg) && !sv_isobject(arg)) {
PerlIO_funcs *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
@@ -1092,9 +1103,9 @@ PerlIO_resolve_layers(pTHX_ const char *layers,
incdef = 0;
}
/*
- * Don't fail if handler cannot be found :Via(...) etc. may do
+ * Don't fail if handler cannot be found :Via(...) etc. may do
* something sensible else we will just stringfy and open
- * resulting string.
+ * resulting string.
*/
}
}
@@ -1141,8 +1152,8 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
PerlIO_funcs *tab = NULL;
if (f && *f) {
/*
- * This is "reopen" - it is not tested as perl does not use it
- * yet
+ * This is "reopen" - it is not tested as perl does not use it
+ * yet
*/
PerlIOl *l = *f;
layera = PerlIO_list_alloc();
@@ -1158,7 +1169,7 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
}
/*
- * Start at "top" of layer stack
+ * Start at "top" of layer stack
*/
n = layera->cur - 1;
while (n >= 0) {
@@ -1171,7 +1182,7 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
}
if (tab) {
/*
- * Found that layer 'n' can do opens - call it
+ * Found that layer 'n' can do opens - call it
*/
PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
tab->name, layers, mode, fd, imode, perm, f, narg,
@@ -1182,7 +1193,7 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
if (n + 1 < layera->cur) {
/*
* More layers above the one that we used to open -
- * apply them now
+ * apply them now
*/
if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1)
!= 0) {
@@ -1311,7 +1322,7 @@ PerlIO_flush(PerlIO *f)
* errorneous input? Maybe some magical value (PerlIO*
* PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
* things on fflush(NULL), but should we be bound by their design
- * decisions? --jhi
+ * decisions? --jhi
*/
PerlIO **table = &_perlio;
int code = 0;
@@ -1517,7 +1528,7 @@ PerlIO_set_ptrcnt(PerlIO *f, STDCHAR * ptr, int cnt)
/*--------------------------------------------------------------------------------------*/
/*
- * utf8 and raw dummy layers
+ * utf8 and raw dummy layers
*/
IV
@@ -1632,7 +1643,7 @@ PerlIO_funcs PerlIO_raw = {
/*--------------------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------------------*/
/*
- * "Methods" of the "base class"
+ * "Methods" of the "base class"
*/
IV
@@ -1744,7 +1755,7 @@ PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
{
dTHX;
/*
- * Save the position as current head considers it
+ * Save the position as current head considers it
*/
Off_t old = PerlIO_tell(f);
SSize_t done;
@@ -1848,7 +1859,7 @@ PerlIOBase_setlinebuf(PerlIO *f)
/*--------------------------------------------------------------------------------------*/
/*
- * Bottom-most level for UNIX-like case
+ * Bottom-most level for UNIX-like case
*/
typedef struct {
@@ -1903,7 +1914,7 @@ PerlIOUnix_oflags(const char *mode)
mode++;
}
/*
- * Always open in binary mode
+ * Always open in binary mode
*/
oflags |= O_BINARY;
if (*mode || oflags == -1) {
@@ -1927,9 +1938,9 @@ PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
s->fd = PerlIO_fileno(PerlIONext(f));
/*
- * XXX could (or should) we retrieve the oflags from the open file
+ * XXX could (or should) we retrieve the oflags from the open file
* handle rather than believing the "mode" we are passed in? XXX
- * Should the value on NULL mode be 0 or -1?
+ * Should the value on NULL mode be 0 or -1?
*/
s->oflags = mode ? PerlIOUnix_oflags(mode) : -1;
}
@@ -1977,13 +1988,78 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
else {
if (f) {
/*
- * FIXME: pop layers ???
+ * FIXME: pop layers ???
*/
}
return NULL;
}
}
+SV *
+PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
+{
+ if (!arg)
+ return Nullsv;
+#ifdef sv_dup
+ if (param) {
+ return sv_dup(arg, param);
+ }
+ else {
+ return newSVsv(arg);
+ }
+#else
+ return newSVsv(arg);
+#endif
+}
+
+PerlIO *
+PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
+{
+ PerlIO *nexto = PerlIONext(o);
+ if (*nexto) {
+ PerlIO_funcs *tab = PerlIOBase(nexto)->tab;
+ f = (*tab->Dup)(aTHX_ f, nexto, param);
+ }
+ if (f) {
+ PerlIO_funcs *self = PerlIOBase(o)->tab;
+ SV *arg = Nullsv;
+ char buf[8];
+ PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",self->name,f,o,param);
+ if (self->Getarg) {
+ arg = (*self->Getarg)(o);
+ if (arg) {
+ arg = PerlIO_sv_dup(aTHX_ arg, param);
+ }
+ }
+ f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
+ if (!f && arg) {
+ SvREFCNT_dec(arg);
+ }
+ }
+ return f;
+}
+
+PerlIO *
+PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
+{
+ PerlIOUnix *os = PerlIOSelf(o, PerlIOUnix);
+ int fd = PerlLIO_dup(os->fd);
+ if (fd >= 0) {
+ f = PerlIOBase_dup(aTHX_ f, o, param);
+ if (f) {
+ /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
+ PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
+ s->fd = fd;
+ return f;
+ }
+ else {
+ PerlLIO_close(fd);
+ }
+ }
+ return NULL;
+}
+
+
SSize_t
PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
{
@@ -2037,6 +2113,7 @@ PerlIOUnix_tell(PerlIO *f)
return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
}
+
IV
PerlIOUnix_close(PerlIO *f)
{
@@ -2065,6 +2142,7 @@ PerlIO_funcs PerlIO_unix = {
PerlIOUnix_open,
NULL,
PerlIOUnix_fileno,
+ PerlIOUnix_dup,
PerlIOUnix_read,
PerlIOBase_unread,
PerlIOUnix_write,
@@ -2086,7 +2164,7 @@ PerlIO_funcs PerlIO_unix = {
/*--------------------------------------------------------------------------------------*/
/*
- * stdio as a layer
+ * stdio as a layer
*/
typedef struct {
@@ -2116,7 +2194,7 @@ PerlIOStdio_mode(const char *mode, char *tmode)
}
/*
- * This isn't used yet ...
+ * This isn't used yet ...
*/
IV
PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
@@ -2237,7 +2315,7 @@ PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
STDCHAR *buf = (STDCHAR *) vbuf;
/*
* Perl is expecting PerlIO_getc() to fill the buffer Linux's
- * stdio does not do that for fread()
+ * stdio does not do that for fread()
*/
int ch = PerlSIO_fgetc(s);
if (ch != EOF) {
@@ -2325,12 +2403,12 @@ PerlIOStdio_flush(PerlIO *f)
#if 0
/*
* FIXME: This discards ungetc() and pre-read stuff which is not
- * right if this is just a "sync" from a layer above Suspect right
+ * right if this is just a "sync" from a layer above Suspect right
* design is to do _this_ but not have layer above flush this
- * layer read-to-read
+ * layer read-to-read
*/
/*
- * Not writeable - sync by attempting a seek
+ * Not writeable - sync by attempting a seek
*/
int err = errno;
if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
@@ -2347,7 +2425,7 @@ PerlIOStdio_fill(PerlIO *f)
FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
int c;
/*
- * fflush()ing read-only streams can cause trouble on some stdio-s
+ * fflush()ing read-only streams can cause trouble on some stdio-s
*/
if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
if (PerlSIO_fflush(stdio) != 0)
@@ -2442,7 +2520,7 @@ PerlIOStdio_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
#endif
#if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
/*
- * Setting ptr _does_ change cnt - we are done
+ * Setting ptr _does_ change cnt - we are done
*/
return;
#endif
@@ -2451,7 +2529,7 @@ PerlIOStdio_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
#endif /* STDIO_PTR_LVALUE */
}
/*
- * Now (or only) set cnt
+ * Now (or only) set cnt
*/
#ifdef STDIO_CNT_LVALUE
PerlSIO_set_cnt(stdio, cnt);
@@ -2468,6 +2546,32 @@ PerlIOStdio_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
#endif
+PerlIO *
+PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
+{
+ /* This assumes no layers underneath - which is what
+ happens, but is not how I remember it. NI-S 2001/10/16
+ */
+ int fd = PerlLIO_dup(PerlIO_fileno(o));
+ if (fd >= 0) {
+ char buf[8];
+ FILE *stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o, buf));
+ if (stdio) {
+ if ((f = PerlIOBase_dup(aTHX_ f, o, param))) {
+ PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
+ }
+ else {
+ PerlSIO_fclose(stdio);
+ }
+ }
+ else {
+ PerlLIO_close(fd);
+ f = NULL;
+ }
+ }
+ return f;
+}
+
PerlIO_funcs PerlIO_stdio = {
"stdio",
sizeof(PerlIOStdio),
@@ -2477,6 +2581,7 @@ PerlIO_funcs PerlIO_stdio = {
PerlIOStdio_open,
NULL,
PerlIOStdio_fileno,
+ PerlIOStdio_dup,
PerlIOStdio_read,
PerlIOStdio_unread,
PerlIOStdio_write,
@@ -2551,7 +2656,7 @@ PerlIO_releaseFILE(PerlIO *p, FILE *f)
/*--------------------------------------------------------------------------------------*/
/*
- * perlio buffer layer
+ * perlio buffer layer
*/
IV
@@ -2595,7 +2700,7 @@ PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
if (*mode == 'I') {
init = 1;
/*
- * mode++;
+ * mode++;
*/
}
f = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
@@ -2605,13 +2710,13 @@ PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
fd = PerlIO_fileno(f);
#if O_BINARY != O_TEXT
/*
- * do something about failing setmode()? --jhi
+ * do something about failing setmode()? --jhi
*/
PerlLIO_setmode(fd, O_BINARY);
#endif
if (init && fd == 2) {
/*
- * Initial stderr is unbuffered
+ * Initial stderr is unbuffered
*/
PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
}
@@ -2622,7 +2727,7 @@ PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
/*
* This "flush" is akin to sfio's sync in that it handles files in either
- * read or write state
+ * read or write state
*/
IV
PerlIOBuf_flush(PerlIO *f)
@@ -2631,7 +2736,7 @@ PerlIOBuf_flush(PerlIO *f)
int code = 0;
if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
/*
- * write() the buffer
+ * write() the buffer
*/
STDCHAR *buf = b->buf;
STDCHAR *p = buf;
@@ -2652,12 +2757,12 @@ PerlIOBuf_flush(PerlIO *f)
else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
STDCHAR *buf = PerlIO_get_base(f);
/*
- * Note position change
+ * Note position change
*/
b->posn += (b->ptr - buf);
if (b->ptr < b->end) {
/*
- * We did not consume all of it
+ * We did not consume all of it
*/
if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) == 0) {
b->posn = PerlIO_tell(PerlIONext(f));
@@ -2667,7 +2772,7 @@ PerlIOBuf_flush(PerlIO *f)
b->ptr = b->end = b->buf;
PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
/*
- * FIXME: Is this right for read case ?
+ * FIXME: Is this right for read case ?
*/
if (PerlIO_flush(PerlIONext(f)) != 0)
code = -1;
@@ -2684,7 +2789,7 @@ PerlIOBuf_fill(PerlIO *f)
* FIXME: doing the down-stream flush is a bad idea if it causes
* pre-read data in stdio buffer to be discarded but this is too
* simplistic - as it skips _our_ hosekeeping and breaks tell tests.
- * if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) { }
+ * if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) { }
*/
if (PerlIO_flush(f) != 0)
return -1;
@@ -2700,7 +2805,7 @@ PerlIOBuf_fill(PerlIO *f)
* Layer below is also buffered We do _NOT_ want to call its
* ->Read() because that will loop till it gets what we asked for
* which may hang on a pipe etc. Instead take anything it has to
- * hand, or ask it to fill _once_.
+ * hand, or ask it to fill _once_.
*/
avail = PerlIO_get_cnt(n);
if (avail <= 0) {
@@ -2763,27 +2868,27 @@ PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
/*
* Buffer is already a read buffer, we can overwrite any chars
- * which have been read back to buffer start
+ * which have been read back to buffer start
*/
avail = (b->ptr - b->buf);
}
else {
/*
* Buffer is idle, set it up so whole buffer is available for
- * unread
+ * unread
*/
avail = b->bufsiz;
b->end = b->buf + avail;
b->ptr = b->end;
PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
/*
- * Buffer extends _back_ from where we are now
+ * Buffer extends _back_ from where we are now
*/
b->posn -= b->bufsiz;
}
if (avail > (SSize_t) count) {
/*
- * If we have space for more than count, just move count
+ * If we have space for more than count, just move count
*/
avail = count;
}
@@ -2792,7 +2897,7 @@ PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
buf -= avail;
/*
* In simple stdio-like ungetc() case chars will be already
- * there
+ * there
*/
if (buf != b->ptr) {
Copy(buf, b->ptr, avail, STDCHAR);
@@ -2870,12 +2975,12 @@ PerlIOBuf_tell(PerlIO *f)
{
PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
/*
- * b->posn is file position where b->buf was read, or will be written
+ * b->posn is file position where b->buf was read, or will be written
*/
Off_t posn = b->posn;
if (b->buf) {
/*
- * If buffer is valid adjust position by amount in buffer
+ * If buffer is valid adjust position by amount in buffer
*/
posn += (b->ptr - b->buf);
}
@@ -2958,6 +3063,14 @@ PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
}
+PerlIO *
+PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
+{
+ return PerlIOBase_dup(aTHX_ f, o, param);
+}
+
+
+
PerlIO_funcs PerlIO_perlio = {
"perlio",
sizeof(PerlIOBuf),
@@ -2967,6 +3080,7 @@ PerlIO_funcs PerlIO_perlio = {
PerlIOBuf_open,
NULL,
PerlIOBase_fileno,
+ PerlIOBuf_dup,
PerlIOBuf_read,
PerlIOBuf_unread,
PerlIOBuf_write,
@@ -2988,14 +3102,14 @@ PerlIO_funcs PerlIO_perlio = {
/*--------------------------------------------------------------------------------------*/
/*
- * Temp layer to hold unread chars when cannot do it any other way
+ * Temp layer to hold unread chars when cannot do it any other way
*/
IV
PerlIOPending_fill(PerlIO *f)
{
/*
- * Should never happen
+ * Should never happen
*/
PerlIO_flush(f);
return 0;
@@ -3005,7 +3119,7 @@ IV
PerlIOPending_close(PerlIO *f)
{
/*
- * A tad tricky - flush pops us, then we close new top
+ * A tad tricky - flush pops us, then we close new top
*/
PerlIO_flush(f);
return PerlIO_close(f);
@@ -3015,7 +3129,7 @@ IV
PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
{
/*
- * A tad tricky - flush pops us, then we seek new top
+ * A tad tricky - flush pops us, then we seek new top
*/
PerlIO_flush(f);
return PerlIO_seek(f, offset, whence);
@@ -3052,8 +3166,8 @@ PerlIOPending_pushed(PerlIO *f, const char *mode, SV *arg)
IV code = PerlIOBase_pushed(f, mode, arg);
PerlIOl *l = PerlIOBase(f);
/*
- * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
- * etc. get muddled when it changes mid-string when we auto-pop.
+ * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
+ * etc. get muddled when it changes mid-string when we auto-pop.
*/
l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
(PerlIOBase(PerlIONext(f))->
@@ -3088,6 +3202,7 @@ PerlIO_funcs PerlIO_pending = {
NULL,
NULL,
PerlIOBase_fileno,
+ PerlIOBuf_dup,
PerlIOPending_read,
PerlIOBuf_unread,
PerlIOBuf_write,
@@ -3113,12 +3228,12 @@ PerlIO_funcs PerlIO_pending = {
/*
* crlf - translation On read translate CR,LF to "\n" we do this by
* overriding ptr/cnt entries to hand back a line at a time and keeping a
- * record of which nl we "lied" about. On write translate "\n" to CR,LF
+ * record of which nl we "lied" about. On write translate "\n" to CR,LF
*/
typedef struct {
PerlIOBuf base; /* PerlIOBuf stuff */
- STDCHAR *nl; /* Position of crlf we "lied" about in the
+ STDCHAR *nl; /* Position of crlf we "lied" about in the
* buffer */
} PerlIOCrlf;
@@ -3208,7 +3323,7 @@ PerlIOCrlf_get_cnt(PerlIO *f)
}
else {
/*
- * Not CR,LF but just CR
+ * Not CR,LF but just CR
*/
nl++;
goto scan;
@@ -3216,12 +3331,12 @@ PerlIOCrlf_get_cnt(PerlIO *f)
}
else {
/*
- * Blast - found CR as last char in buffer
+ * Blast - found CR as last char in buffer
*/
if (b->ptr < nl) {
/*
* They may not care, defer work as long as
- * possible
+ * possible
*/
return (nl - b->ptr);
}
@@ -3241,7 +3356,7 @@ PerlIOCrlf_get_cnt(PerlIO *f)
if (code == 0)
goto test; /* fill() call worked */
/*
- * CR at EOF - just fall through
+ * CR at EOF - just fall through
*/
}
}
@@ -3272,7 +3387,7 @@ PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
}
else {
/*
- * Test code - delete when it works ...
+ * Test code - delete when it works ...
*/
STDCHAR *chk;
if (c->nl)
@@ -3294,7 +3409,7 @@ PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
if (c->nl) {
if (ptr > c->nl) {
/*
- * They have taken what we lied about
+ * They have taken what we lied about
*/
*(c->nl) = 0xd;
c->nl = NULL;
@@ -3325,7 +3440,7 @@ PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
if (*buf == '\n') {
if ((b->ptr + 2) > eptr) {
/*
- * Not room for both
+ * Not room for both
*/
PerlIO_flush(f);
break;
@@ -3376,6 +3491,7 @@ PerlIO_funcs PerlIO_crlf = {
PerlIOBuf_open,
NULL,
PerlIOBase_fileno,
+ PerlIOBuf_dup,
PerlIOBuf_read, /* generic read works with ptr/cnt lies
* ... */
PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
@@ -3399,7 +3515,7 @@ PerlIO_funcs PerlIO_crlf = {
#ifdef HAS_MMAP
/*--------------------------------------------------------------------------------------*/
/*
- * mmap as "buffer" layer
+ * mmap as "buffer" layer
*/
typedef struct {
@@ -3469,7 +3585,7 @@ PerlIOMmap_map(PerlIO *f)
if (b->posn < 0) {
/*
* This is a hack - should never happen - open should
- * have set it !
+ * have set it !
*/
b->posn = PerlIO_tell(PerlIONext(f));
}
@@ -3534,13 +3650,13 @@ PerlIOMmap_get_base(PerlIO *f)
PerlIOBuf *b = &m->base;
if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
/*
- * Already have a readbuffer in progress
+ * Already have a readbuffer in progress
*/
return b->buf;
}
if (b->buf) {
/*
- * We have a write buffer or flushed PerlIOBuf read buffer
+ * 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 */
@@ -3549,7 +3665,7 @@ PerlIOMmap_get_base(PerlIO *f)
PerlIOMmap_map(f); /* Try and map it */
if (!b->buf) {
/*
- * Map did not work - recover PerlIOBuf buffer if we have one
+ * Map did not work - recover PerlIOBuf buffer if we have one
*/
b->buf = m->bbuf;
}
@@ -3575,11 +3691,11 @@ PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
}
if (m->len) {
/*
- * Loose the unwritable mapped buffer
+ * Loose the unwritable mapped buffer
*/
PerlIO_flush(f);
/*
- * If flush took the "buffer" see if we have one from before
+ * If flush took the "buffer" see if we have one from before
*/
if (!b->buf && m->bbuf)
b->buf = m->bbuf;
@@ -3598,14 +3714,14 @@ PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
PerlIOBuf *b = &m->base;
if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
/*
- * No, or wrong sort of, buffer
+ * No, or wrong sort of, buffer
*/
if (m->len) {
if (PerlIOMmap_unmap(f) != 0)
return 0;
}
/*
- * If unmap took the "buffer" see if we have one from before
+ * If unmap took the "buffer" see if we have one from before
*/
if (!b->buf && m->bbuf)
b->buf = m->bbuf;
@@ -3624,12 +3740,12 @@ PerlIOMmap_flush(PerlIO *f)
PerlIOBuf *b = &m->base;
IV code = PerlIOBuf_flush(f);
/*
- * Now we are "synced" at PerlIOBuf level
+ * Now we are "synced" at PerlIOBuf level
*/
if (b->buf) {
if (m->len) {
/*
- * Unmap the buffer
+ * Unmap the buffer
*/
if (PerlIOMmap_unmap(f) != 0)
code = -1;
@@ -3637,7 +3753,7 @@ PerlIOMmap_flush(PerlIO *f)
else {
/*
* We seem to have a PerlIOBuf buffer which was not mapped
- * remember it in case we need one later
+ * remember it in case we need one later
*/
m->bbuf = b->buf;
}
@@ -3675,6 +3791,12 @@ PerlIOMmap_close(PerlIO *f)
return code;
}
+PerlIO *
+PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
+{
+ return PerlIOBase_dup(aTHX_ f, o, param);
+}
+
PerlIO_funcs PerlIO_mmap = {
"mmap",
@@ -3685,6 +3807,7 @@ PerlIO_funcs PerlIO_mmap = {
PerlIOBuf_open,
NULL,
PerlIOBase_fileno,
+ PerlIOMmap_dup,
PerlIOBuf_read,
PerlIOMmap_unread,
PerlIOMmap_write,
@@ -3775,7 +3898,7 @@ PerlIO_getname(PerlIO *f, char *buf)
/*--------------------------------------------------------------------------------------*/
/*
* Functions which can be called on any kind of PerlIO implemented in
- * terms of above
+ * terms of above
*/
#undef PerlIO_getc
@@ -3877,7 +4000,7 @@ PerlIO *
PerlIO_tmpfile(void)
{
/*
- * I have no idea how portable mkstemp() is ...
+ * I have no idea how portable mkstemp() is ...
*/
#if defined(WIN32) || !defined(HAVE_MKSTEMP)
dTHX;
@@ -3916,8 +4039,8 @@ PerlIO_tmpfile(void)
/*======================================================================================*/
/*
- * Now some functions in terms of above which may be needed even if we are
- * not in true PerlIO mode
+ * Now some functions in terms of above which may be needed even if we are
+ * not in true PerlIO mode
*/
#ifndef HAS_FSETPOS
diff --git a/perlio.h b/perlio.h
index 4b7ec88752..1921a52957 100644
--- a/perlio.h
+++ b/perlio.h
@@ -324,7 +324,7 @@ extern int PerlIO_getpos(PerlIO *, SV *);
extern int PerlIO_setpos(PerlIO *, SV *);
#endif
#ifndef PerlIO_fdupopen
-extern PerlIO *PerlIO_fdupopen(pTHX_ PerlIO *);
+extern PerlIO *PerlIO_fdupopen(pTHX_ PerlIO *, CLONE_PARAMS *);
#endif
#if !defined(PerlIO_modestr) && !defined(PERLIO_IS_STDIO)
extern char *PerlIO_modestr(PerlIO *, char *buf);
diff --git a/perliol.h b/perliol.h
index eb6a415a30..8f9e0ea74d 100644
--- a/perliol.h
+++ b/perliol.h
@@ -26,6 +26,7 @@ struct _PerlIO_funcs {
PerlIO *old, int narg, SV **args);
SV *(*Getarg) (PerlIO *f);
IV (*Fileno) (PerlIO *f);
+ PerlIO *(*Dup) (pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param);
/* Unix-like functions - cf sfio line disciplines */
SSize_t(*Read) (PerlIO *f, void *vbuf, Size_t count);
SSize_t(*Unread) (PerlIO *f, const void *vbuf, Size_t count);
@@ -119,6 +120,7 @@ extern SV *PerlIO_arg_fetch(PerlIO_list_t *av, IV n);
/* Generic, or stub layer functions */
extern IV PerlIOBase_fileno(PerlIO *f);
+extern PerlIO *PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param);
extern IV PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg);
extern IV PerlIOBase_popped(PerlIO *f);
extern SSize_t PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count);
@@ -150,6 +152,7 @@ typedef struct {
IV oneword; /* Emergency buffer */
} PerlIOBuf;
+extern SV *PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param);
extern PerlIO *PerlIOBuf_open(pTHX_ PerlIO_funcs *self,
PerlIO_list_t *layers, IV n,
const char *mode, int fd, int imode,
diff --git a/pod/perlapi.pod b/pod/perlapi.pod
index a60c2c61a6..ad4d3e45b2 100644
--- a/pod/perlapi.pod
+++ b/pod/perlapi.pod
@@ -2191,7 +2191,7 @@ Found in file sv.h
Expands the character buffer in the SV so that it has room for the
indicated number of bytes (remember to reserve space for an extra trailing
-NUL character). Calls C<sv_grow> to perform the expansion if necessary.
+NUL character). Calls C<sv_grow> to perform the expansion if necessary.
Returns a pointer to the character buffer.
char * SvGROW(SV* sv, STRLEN len)
@@ -2397,22 +2397,22 @@ which guarantees to evaluate sv only once.
=for hackers
Found in file sv.h
-=item SvNVX
+=item SvNVx
-Returns the raw value in the SV's NV slot, without checks or conversions.
-Only use when you are sure SvNOK is true. See also C<SvNV()>.
+Coerces the given SV to a double and returns it. Guarantees to evaluate
+sv only once. Use the more efficent C<SvNV> otherwise.
- NV SvNVX(SV* sv)
+ NV SvNVx(SV* sv)
=for hackers
Found in file sv.h
-=item SvNVx
+=item SvNVX
-Coerces the given SV to a double and returns it. Guarantees to evaluate
-sv only once. Use the more efficent C<SvNV> otherwise.
+Returns the raw value in the SV's NV slot, without checks or conversions.
+Only use when you are sure SvNOK is true. See also C<SvNV()>.
- NV SvNVx(SV* sv)
+ NV SvNVX(SV* sv)
=for hackers
Found in file sv.h
@@ -2606,21 +2606,21 @@ Like C<SvPV_nolen>, but converts sv to uft8 first if necessary.
=for hackers
Found in file sv.h
-=item SvPVx
+=item SvPVX
-A version of C<SvPV> which guarantees to evaluate sv only once.
+Returns a pointer to the physical string in the SV. The SV must contain a
+string.
- char* SvPVx(SV* sv, STRLEN len)
+ char* SvPVX(SV* sv)
=for hackers
Found in file sv.h
-=item SvPVX
+=item SvPVx
-Returns a pointer to the physical string in the SV. The SV must contain a
-string.
+A version of C<SvPV> which guarantees to evaluate sv only once.
- char* SvPVX(SV* sv)
+ char* SvPVx(SV* sv, STRLEN len)
=for hackers
Found in file sv.h
@@ -2827,19 +2827,19 @@ false, defined or undefined. Does not handle 'get' magic.
=for hackers
Found in file sv.h
-=item SvTYPE
-
-Returns the type of the SV. See C<svtype>.
+=item svtype
- svtype SvTYPE(SV* sv)
+An enum of flags for Perl types. These are found in the file B<sv.h>
+in the C<svtype> enum. Test these flags with the C<SvTYPE> macro.
=for hackers
Found in file sv.h
-=item svtype
+=item SvTYPE
-An enum of flags for Perl types. These are found in the file B<sv.h>
-in the C<svtype> enum. Test these flags with the C<SvTYPE> macro.
+Returns the type of the SV. See C<svtype>.
+
+ svtype SvTYPE(SV* sv)
=for hackers
Found in file sv.h
@@ -2973,7 +2973,7 @@ Found in file sv.h
=item sv_2bool
This function is only called on magical items, and is only used by
-sv_true() or its macro equivalent.
+sv_true() or its macro equivalent.
bool sv_2bool(SV* sv)
diff --git a/proto.h b/proto.h
index 2e2427ac28..0e1d3b058b 100644
--- a/proto.h
+++ b/proto.h
@@ -937,17 +937,17 @@ PERL_CALLCONV void Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, O
PERL_CALLCONV OP * Perl_my_attrs(pTHX_ OP *o, OP *attrs);
PERL_CALLCONV void Perl_boot_core_xsutils(pTHX);
#if defined(USE_ITHREADS)
-PERL_CALLCONV PERL_CONTEXT* Perl_cx_dup(pTHX_ PERL_CONTEXT* cx, I32 ix, I32 max, clone_params* param);
-PERL_CALLCONV PERL_SI* Perl_si_dup(pTHX_ PERL_SI* si, clone_params* param);
-PERL_CALLCONV ANY* Perl_ss_dup(pTHX_ PerlInterpreter* proto_perl, clone_params* param);
+PERL_CALLCONV PERL_CONTEXT* Perl_cx_dup(pTHX_ PERL_CONTEXT* cx, I32 ix, I32 max, CLONE_PARAMS* param);
+PERL_CALLCONV PERL_SI* Perl_si_dup(pTHX_ PERL_SI* si, CLONE_PARAMS* param);
+PERL_CALLCONV ANY* Perl_ss_dup(pTHX_ PerlInterpreter* proto_perl, CLONE_PARAMS* param);
PERL_CALLCONV void* Perl_any_dup(pTHX_ void* v, PerlInterpreter* proto_perl);
-PERL_CALLCONV HE* Perl_he_dup(pTHX_ HE* e, bool shared, clone_params* param);
-PERL_CALLCONV REGEXP* Perl_re_dup(pTHX_ REGEXP* r, clone_params* param);
-PERL_CALLCONV PerlIO* Perl_fp_dup(pTHX_ PerlIO* fp, char type);
+PERL_CALLCONV HE* Perl_he_dup(pTHX_ HE* e, bool shared, CLONE_PARAMS* param);
+PERL_CALLCONV REGEXP* Perl_re_dup(pTHX_ REGEXP* r, CLONE_PARAMS* param);
+PERL_CALLCONV PerlIO* Perl_fp_dup(pTHX_ PerlIO* fp, char type, CLONE_PARAMS* param);
PERL_CALLCONV DIR* Perl_dirp_dup(pTHX_ DIR* dp);
-PERL_CALLCONV GP* Perl_gp_dup(pTHX_ GP* gp, clone_params* param);
-PERL_CALLCONV MAGIC* Perl_mg_dup(pTHX_ MAGIC* mg, clone_params* param);
-PERL_CALLCONV SV* Perl_sv_dup(pTHX_ SV* sstr, clone_params* param);
+PERL_CALLCONV GP* Perl_gp_dup(pTHX_ GP* gp, CLONE_PARAMS* param);
+PERL_CALLCONV MAGIC* Perl_mg_dup(pTHX_ MAGIC* mg, CLONE_PARAMS* param);
+PERL_CALLCONV SV* Perl_sv_dup(pTHX_ SV* sstr, CLONE_PARAMS* param);
#if defined(HAVE_INTERP_INTERN)
PERL_CALLCONV void Perl_sys_intern_dup(pTHX_ struct interp_intern* src, struct interp_intern* dst);
#endif
diff --git a/sv.c b/sv.c
index 48d0e2d231..3afbd564e1 100644
--- a/sv.c
+++ b/sv.c
@@ -123,7 +123,7 @@ Private API to rest of sv.c
Public API:
- sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
+ sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
=cut
@@ -3198,7 +3198,7 @@ Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
=for apidoc sv_2bool
This function is only called on magical items, and is only used by
-sv_true() or its macro equivalent.
+sv_true() or its macro equivalent.
=cut
*/
@@ -4280,8 +4280,8 @@ Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
if ((spv = SvPV(ssv, slen))) {
/* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
gcc version 2.95.2 20000220 (Debian GNU/Linux) for
- Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
- get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
+ Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
+ get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
dsv->sv_flags doesn't have that bit set.
Andy Dougherty 12 Oct 2001
*/
@@ -8376,13 +8376,13 @@ ptr_table_* functions.
#define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
#define SAVEPV(p) (p ? savepv(p) : Nullch)
#define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
-
+
/* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
regcomp.c. AMS 20010712 */
REGEXP *
-Perl_re_dup(pTHX_ REGEXP *r, clone_params *param)
+Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
{
REGEXP *ret;
int i, len, npar;
@@ -8480,7 +8480,7 @@ Perl_re_dup(pTHX_ REGEXP *r, clone_params *param)
/* duplicate a file handle */
PerlIO *
-Perl_fp_dup(pTHX_ PerlIO *fp, char type)
+Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
{
PerlIO *ret;
if (!fp)
@@ -8492,7 +8492,7 @@ Perl_fp_dup(pTHX_ PerlIO *fp, char type)
return ret;
/* create anew and remember what it is */
- ret = PerlIO_fdupopen(aTHX_ fp);
+ ret = PerlIO_fdupopen(aTHX_ fp, param);
ptr_table_store(PL_ptr_table, fp, ret);
return ret;
}
@@ -8511,7 +8511,7 @@ Perl_dirp_dup(pTHX_ DIR *dp)
/* duplicate a typeglob */
GP *
-Perl_gp_dup(pTHX_ GP *gp, clone_params* param)
+Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
{
GP *ret;
if (!gp)
@@ -8544,7 +8544,7 @@ Perl_gp_dup(pTHX_ GP *gp, clone_params* param)
/* duplicate a chain of magic */
MAGIC *
-Perl_mg_dup(pTHX_ MAGIC *mg, clone_params* param)
+Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
{
MAGIC *mgprev = (MAGIC*)NULL;
MAGIC *mgret;
@@ -8815,7 +8815,7 @@ S_gv_share(pTHX_ SV *sstr)
/* duplicate an SV of any type (including AV, HV etc) */
SV *
-Perl_sv_dup(pTHX_ SV *sstr, clone_params* param)
+Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
{
SV *dstr;
@@ -9010,11 +9010,11 @@ Perl_sv_dup(pTHX_ SV *sstr, clone_params* param)
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
- IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
+ IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
if (IoOFP(sstr) == IoIFP(sstr))
IoOFP(dstr) = IoIFP(dstr);
else
- IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
+ IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
/* PL_rsfp_filters entries have fake IoDIRP() */
if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
@@ -9167,7 +9167,7 @@ Perl_sv_dup(pTHX_ SV *sstr, clone_params* param)
/* duplicate a context */
PERL_CONTEXT *
-Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, clone_params* param)
+Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
{
PERL_CONTEXT *ncxs;
@@ -9255,7 +9255,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, clone_params* param)
/* duplicate a stack info structure */
PERL_SI *
-Perl_si_dup(pTHX_ PERL_SI *si, clone_params* param)
+Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
{
PERL_SI *nsi;
@@ -9330,7 +9330,7 @@ Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
/* duplicate the save stack */
ANY *
-Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, clone_params* param)
+Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
{
ANY *ss = proto_perl->Tsavestack;
I32 ix = proto_perl->Tsavestack_ix;
@@ -9625,7 +9625,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
* their pointers copied. */
IV i;
- clone_params* param = (clone_params*) malloc(sizeof(clone_params));
+ CLONE_PARAMS* param = (CLONE_PARAMS*) MALLOC(SIZEOF(CLONE_PARAMS));
PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
PERL_SET_THX(my_perl);
@@ -9653,7 +9653,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
PL_Proc = ipP;
#else /* !PERL_IMPLICIT_SYS */
IV i;
- clone_params* param = (clone_params*) malloc(sizeof(clone_params));
+ CLONE_PARAMS* param = (CLONE_PARAMS*) malloc(sizeof(CLONE_PARAMS));
PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
PERL_SET_THX(my_perl);
@@ -9820,10 +9820,10 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
for(i = 1; i <= len; i++) {
if(SvREPADTMP(regexen[i])) {
av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
- } else {
+ } else {
av_push(PL_regex_padav,
SvREFCNT_inc(
- newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
+ newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
SvIVX(regexen[i])), param)))
));
}
@@ -9924,7 +9924,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
PL_profiledata = NULL;
- PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
+ PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
/* PL_rsfp_filters entries have fake IoDIRP() */
PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
@@ -10308,7 +10308,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
ptr_table_free(PL_ptr_table);
PL_ptr_table = NULL;
}
-
+
/* Call the ->CLONE method, if it exists, for each of the stashes
identified by sv_dup() above.
*/
diff --git a/sv.h b/sv.h
index 0b3aba2154..4d08a90138 100644
--- a/sv.h
+++ b/sv.h
@@ -13,7 +13,7 @@
/*
=for apidoc AmU||svtype
-An enum of flags for Perl types. These are found in the file B<sv.h>
+An enum of flags for Perl types. These are found in the file B<sv.h>
in the C<svtype> enum. Test these flags with the C<SvTYPE> macro.
=for apidoc AmU||SVt_PV
@@ -646,7 +646,7 @@ and leaves the UTF8 status as it was.
#define SvAMAGIC_on(sv) (SvFLAGS(sv) |= SVf_AMAGIC)
#define SvAMAGIC_off(sv) (SvFLAGS(sv) &= ~SVf_AMAGIC)
-#define SvGAMAGIC(sv) (SvFLAGS(sv) & (SVs_GMG|SVf_AMAGIC))
+#define SvGAMAGIC(sv) (SvFLAGS(sv) & (SVs_GMG|SVf_AMAGIC))
/*
#define Gv_AMG(stash) \
@@ -1178,7 +1178,7 @@ Like C<SvSetMagicSV>, but does any set magic required afterwards.
=for apidoc Am|char *|SvGROW|SV* sv|STRLEN len
Expands the character buffer in the SV so that it has room for the
indicated number of bytes (remember to reserve space for an extra trailing
-NUL character). Calls C<sv_grow> to perform the expansion if necessary.
+NUL character). Calls C<sv_grow> to perform the expansion if necessary.
Returns a pointer to the character buffer.
=cut
@@ -1234,7 +1234,7 @@ Returns a pointer to the character buffer.
#define CLONEf_KEEP_PTR_TABLE 2
#define CLONEf_CLONE_HOST 4
-typedef struct {
+struct clone_params {
AV* stashes;
UV flags;
-} clone_params;
+};
diff --git a/win32/win32io.c b/win32/win32io.c
index b707172b6d..6152647a74 100644
--- a/win32/win32io.c
+++ b/win32/win32io.c
@@ -189,12 +189,12 @@ PerlIOWin32_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const ch
s->h = h;
s->fd = fd;
s->refcnt = 1;
- if (fd >= 0)
+ if (fd >= 0)
{
- fdtable[fd] = s;
+ fdtable[fd] = s;
if (fd > max_open_fd)
max_open_fd = fd;
- }
+ }
return f;
}
if (f)
@@ -294,6 +294,13 @@ PerlIOWin32_close(PerlIO *f)
return 0;
}
+PerlIO *
+PerlIOWin32_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *params)
+{
+ /* Almost certainly needs more work */
+ return PerlIOBase_dup(aTHX_ f, o, params);
+}
+
PerlIO_funcs PerlIO_win32 = {
"win32",
sizeof(PerlIOWin32),
@@ -303,6 +310,7 @@ PerlIO_funcs PerlIO_win32 = {
PerlIOWin32_open,
NULL, /* getarg */
PerlIOWin32_fileno,
+ PerlIOWin32_dup,
PerlIOWin32_read,
PerlIOBase_unread,
PerlIOWin32_write,
View Lorry Controller Status