diff options
author | Jarkko Hietaniemi <jhi@iki.fi> | 2001-03-24 16:06:01 +0000 |
---|---|---|
committer | Jarkko Hietaniemi <jhi@iki.fi> | 2001-03-24 16:06:01 +0000 |
commit | 42c30c638503866299537a96b1a414d449615fe9 (patch) | |
tree | cbe2d8f4aadb79c2f46c08cae48baf80a93591ea | |
parent | 2973cfbe08c1a80f4799b8b261fc8e722106e799 (diff) | |
parent | e009d45070febfef5a59a9468c3cb4e6ad05051f (diff) | |
download | perl-42c30c638503866299537a96b1a414d449615fe9.tar.gz |
Integrate perlio:
[ 9322]
Routine Win32 regen_config_h - no real changes.
[ 9321]
PerlIO fixups for Win32:
- provide win33_popenlist() - non-functional as yet.
- avoid need for aTHX in PerlIO_debug calls - even if not
enabled args are still evaluated so Win32 has trouble during fork().
- Add PerlIO/Scalar to list of extensions in win32/makefile.mk
- Fixup makedef.pl for latest set of symbols.
[ 9320]
POSIX::getcwd XS code to call Cwd::cwd when HAS_GETCWD not defined
was gibberish - broke it on WIn32 at least.
[ 9319]
Generated files.
[ 9318]
Implement:
1. open($fh,"+<",undef); # add test to t/io/open.t
2. open($fh,"+<",\$var); # New test t/lib/io_scalar.t
p4raw-link: @9322 on //depot/perlio: e009d45070febfef5a59a9468c3cb4e6ad05051f
p4raw-link: @9321 on //depot/perlio: 8c0134a884f927d58f584b87281e5a27133cbf8f
p4raw-link: @9320 on //depot/perlio: 5dd1177c222be3aa5f44de160a952953bc5703a5
p4raw-link: @9319 on //depot/perlio: c60e0e098045567c2313456d074b4094292b050c
p4raw-link: @9318 on //depot/perlio: f6c77cf1bf4d7cb2c7a64dd7608120b471f84062
p4raw-id: //depot/perl@9323
-rw-r--r-- | MANIFEST | 4 | ||||
-rw-r--r-- | Makefile.SH | 4 | ||||
-rw-r--r-- | doio.c | 6 | ||||
-rw-r--r-- | embed.h | 4 | ||||
-rw-r--r-- | ext/Encode/Encode.xs | 2 | ||||
-rw-r--r-- | ext/POSIX/POSIX.xs | 11 | ||||
-rw-r--r-- | ext/PerlIO/Scalar/Makefile.PL | 6 | ||||
-rw-r--r-- | ext/PerlIO/Scalar/Scalar.pm | 6 | ||||
-rw-r--r-- | ext/PerlIO/Scalar/Scalar.xs | 231 | ||||
-rw-r--r-- | global.sym | 1 | ||||
-rw-r--r-- | iperlsys.h | 3 | ||||
-rw-r--r-- | makedef.pl | 16 | ||||
-rw-r--r-- | objXSUB.h | 4 | ||||
-rw-r--r-- | perlapi.c | 7 | ||||
-rw-r--r-- | perlio.c | 279 | ||||
-rw-r--r-- | perliol.h | 4 | ||||
-rw-r--r-- | proto.h | 1 | ||||
-rwxr-xr-x | t/io/open.t | 17 | ||||
-rwxr-xr-x | t/io/utf8.t | 7 | ||||
-rw-r--r-- | t/lib/io_scalar.t | 35 | ||||
-rw-r--r-- | win32/config_H.bc | 2 | ||||
-rw-r--r-- | win32/config_H.gc | 2 | ||||
-rw-r--r-- | win32/config_H.vc | 2 | ||||
-rw-r--r-- | win32/makefile.mk | 13 | ||||
-rw-r--r-- | win32/perlhost.h | 11 | ||||
-rw-r--r-- | win32/win32.c | 8 | ||||
-rw-r--r-- | win32/win32iop.h | 1 |
27 files changed, 553 insertions, 134 deletions
@@ -400,6 +400,9 @@ ext/POSIX/hints/openbsd.pl Hint for POSIX for named architecture ext/POSIX/hints/sunos_4.pl Hint for POSIX for named architecture ext/POSIX/hints/svr4.pl Hint for POSIX for named architecture ext/POSIX/typemap POSIX extension interface types +ext/PerlIO/Scalar/Makefile.PL PerlIO layer for scalars +ext/PerlIO/Scalar/Scalar.pm PerlIO layer for scalars +ext/PerlIO/Scalar/Scalar.xs PerlIO layer for scalars ext/SDBM_File/Makefile.PL SDBM extension makefile writer ext/SDBM_File/SDBM_File.pm SDBM extension Perl module ext/SDBM_File/SDBM_File.xs SDBM extension external subroutines @@ -1480,6 +1483,7 @@ t/lib/io_linenum.t See if I/O line numbers are tracked correctly t/lib/io_multihomed.t See if INET sockets work with multi-homed hosts t/lib/io_pipe.t See if pipe()-related methods from IO work t/lib/io_poll.t See if poll()-related methods from IO work +t/lib/io_scalar.t Test of PerlIO::Scalar t/lib/io_sel.t See if select()-related methods from IO work t/lib/io_sock.t See if INET socket-related methods from IO work t/lib/io_taint.t See if the untaint method from IO works diff --git a/Makefile.SH b/Makefile.SH index 9122ea5ab1..f2ebb71044 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -581,13 +581,15 @@ lib/ExtUtils/Miniperl.pm: miniperlmain.c miniperl minimod.pl lib/Config.pm sh mv-if-diff minimod.tmp $@ lib/re.pm: ext/re/re.pm - rm -f $@ + @-rm -f $@ cat ext/re/re.pm > $@ $(plextract): miniperl lib/Config.pm + @-rm -f $@ $(LDLIBPTH) ./miniperl -Ilib $@.PL lib/lib.pm: miniperl lib/Config.pm + @-rm -f $@ $(LDLIBPTH) ./miniperl -Ilib lib/lib_pm.PL extra.pods: miniperl @@ -211,7 +211,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (num_svs) { /* New style explict name, type is just mode and discipline/layer info */ STRLEN l; - name = SvPV(*svp, l) ; + name = SvOK(*svp) ? SvPV(*svp, l) : ""; len = (I32)l; name = savepvn(name, len); SAVEFREEPV(name); @@ -512,7 +512,9 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } } - if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD) { + if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD && + /* FIXME: This next term is a hack to avoid fileno on PerlIO::Scalar */ + !(num_svs && SvROK(*svp))) { if (PerlLIO_fstat(PerlIO_fileno(fp),&PL_statbuf) < 0) { (void)PerlIO_close(fp); goto say_false; @@ -433,6 +433,7 @@ #if !defined(PERL_OBJECT) #define my_pclose Perl_my_pclose #define my_popen Perl_my_popen +#define my_popen_list Perl_my_popen_list #endif #define my_setenv Perl_my_setenv #define my_stat Perl_my_stat @@ -1924,6 +1925,7 @@ #if !defined(PERL_OBJECT) #define my_pclose(a) Perl_my_pclose(aTHX_ a) #define my_popen(a,b) Perl_my_popen(aTHX_ a,b) +#define my_popen_list(a,b,c) Perl_my_popen_list(aTHX_ a,b,c) #endif #define my_setenv(a,b) Perl_my_setenv(aTHX_ a,b) #define my_stat() Perl_my_stat(aTHX) @@ -3767,6 +3769,8 @@ #define my_pclose Perl_my_pclose #define Perl_my_popen CPerlObj::Perl_my_popen #define my_popen Perl_my_popen +#define Perl_my_popen_list CPerlObj::Perl_my_popen_list +#define my_popen_list Perl_my_popen_list #endif #define Perl_my_setenv CPerlObj::Perl_my_setenv #define my_setenv Perl_my_setenv diff --git a/ext/Encode/Encode.xs b/ext/Encode/Encode.xs index fea83aec4a..74303c9389 100644 --- a/ext/Encode/Encode.xs +++ b/ext/Encode/Encode.xs @@ -339,7 +339,7 @@ PerlIO_funcs PerlIO_encode = { PerlIOBase_eof, PerlIOBase_error, PerlIOBase_clearerr, - PerlIOBuf_setlinebuf, + PerlIOBase_setlinebuf, PerlIOEncode_get_base, PerlIOBuf_bufsiz, PerlIOBuf_get_ptr, diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index 6c5c70b77c..145dab7342 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -4048,15 +4048,10 @@ getcwd() else PUSHs(&PL_sv_undef); #else - dSP; require_pv("Cwd.pm"); - - ENTER; - SAVETMPS; + /* Module require may have grown the stack */ + SPAGAIN; PUSHMARK(sp); PUTBACK; - call_pv("Cwd::cwd", GIMME_V); - FREETMPS; - LEAVE; - XSRETURN(1); + XSRETURN(call_pv("Cwd::cwd", GIMME_V)); #endif diff --git a/ext/PerlIO/Scalar/Makefile.PL b/ext/PerlIO/Scalar/Makefile.PL new file mode 100644 index 0000000000..81fe5139e6 --- /dev/null +++ b/ext/PerlIO/Scalar/Makefile.PL @@ -0,0 +1,6 @@ +use ExtUtils::MakeMaker; +WriteMakefile( + NAME => "PerlIO::Scalar", + VERSION_FROM => 'Scalar.pm', +); + diff --git a/ext/PerlIO/Scalar/Scalar.pm b/ext/PerlIO/Scalar/Scalar.pm new file mode 100644 index 0000000000..e733a72c1b --- /dev/null +++ b/ext/PerlIO/Scalar/Scalar.pm @@ -0,0 +1,6 @@ +package PerlIO::Scalar; +our $VERSION = '0.01'; +use XSLoader (); +XSLoader::load 'PerlIO::Scalar'; +1; +__END__ diff --git a/ext/PerlIO/Scalar/Scalar.xs b/ext/PerlIO/Scalar/Scalar.xs new file mode 100644 index 0000000000..650cc5a67a --- /dev/null +++ b/ext/PerlIO/Scalar/Scalar.xs @@ -0,0 +1,231 @@ +#define PERL_NO_GET_CONTEXT +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#ifdef PERLIO_LAYERS + +#include "perliol.h" + +typedef struct +{ + struct _PerlIO base; /* Base "class" info */ + SV * var; + Off_t posn; +} PerlIOScalar; + +IV +PerlIOScalar_pushed(PerlIO *f, const char *mode, SV *arg) +{ + PerlIOScalar *b = PerlIOSelf(f,PerlIOScalar); + return PerlIOBase_pushed(f,mode,arg); +} + +IV +PerlIOScalar_popped(PerlIO *f) +{ + PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar); + if (s->var) + { + dTHX; + SvREFCNT_dec(s->var); + s->var = Nullsv; + } + return 0; +} + +IV +PerlIOScalar_close(PerlIO *f) +{ + dTHX; + IV code = PerlIOBase_close(f); + PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar); + PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF); + return code; +} + +IV +PerlIOScalar_fileno(PerlIO *f) +{ + return -1; +} + +IV +PerlIOScalar_seek(PerlIO *f, Off_t offset, int whence) +{ + PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar); + switch(whence) + { + case 0: + s->posn = offset; + break; + case 1: + s->posn = offset + s->posn; + break; + case 2: + s->posn = offset + SvCUR(s->var); + break; + } + if (s->posn > SvCUR(s->var)) + { + dTHX; + (void) SvGROW(s->var,s->posn); + } + return 0; +} + +Off_t +PerlIOScalar_tell(PerlIO *f) +{ + PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar); + return s->posn; +} + +SSize_t +PerlIOScalar_unread(PerlIO *f, const void *vbuf, Size_t count) +{ + dTHX; + PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar); + char *dst = SvGROW(s->var,s->posn+count); + Move(vbuf,dst,count,char); + s->posn += count; + SvCUR_set(s->var,s->posn); + SvPOK_on(s->var); + return count; +} + +SSize_t +PerlIOScalar_write(PerlIO *f, const void *vbuf, Size_t count) +{ + if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) + { + return PerlIOScalar_unread(f,vbuf,count); + } + return 0; +} + +IV +PerlIOScalar_fill(PerlIO *f) +{ + return -1; +} + +IV +PerlIOScalar_flush(PerlIO *f) +{ + return 0; +} + +STDCHAR * +PerlIOScalar_get_base(PerlIO *f) +{ + PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar); + if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) + { + dTHX; + return (STDCHAR *)SvPV_nolen(s->var); + } +} + +STDCHAR * +PerlIOScalar_get_ptr(PerlIO *f) +{ + if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) + { + PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar); + return PerlIOScalar_get_base(f)+s->posn; + } + return (STDCHAR *) Nullch; +} + +SSize_t +PerlIOScalar_get_cnt(PerlIO *f) +{ + if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) + { + PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar); + return SvCUR(s->var) - s->posn; + } + return 0; +} + +Size_t +PerlIOScalar_bufsiz(PerlIO *f) +{ + if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) + { + PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar); + return SvCUR(s->var); + } + return 0; +} + +void +PerlIOScalar_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt) +{ + PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar); + s->posn = SvCUR(s->var)-cnt; +} + +PerlIO * +PerlIOScalar_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args) +{ + PerlIOScalar *s; + if (narg > 0) + { + SV *ref = *args; + if (SvROK(ref)) + { + SV *var = SvRV(ref); + sv_upgrade(var,SVt_PV); + f = PerlIO_allocate(aTHX); + s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOScalar); + s->var = SvREFCNT_inc(var); + s->posn = 0; + PerlIOBase(f)->flags |= PERLIO_F_OPEN; + return f; + } + } + return NULL; +} + + +PerlIO_funcs PerlIO_scalar = { + "Scalar", + sizeof(PerlIOScalar), + PERLIO_K_BUFFERED, + PerlIOScalar_pushed, + PerlIOScalar_popped, + PerlIOScalar_open, + NULL, + PerlIOScalar_fileno, + PerlIOBase_read, + PerlIOScalar_unread, + PerlIOScalar_write, + PerlIOScalar_seek, + PerlIOScalar_tell, + PerlIOScalar_close, + PerlIOScalar_flush, + PerlIOScalar_fill, + PerlIOBase_eof, + PerlIOBase_error, + PerlIOBase_clearerr, + PerlIOBase_setlinebuf, + PerlIOScalar_get_base, + PerlIOScalar_bufsiz, + PerlIOScalar_get_ptr, + PerlIOScalar_get_cnt, + PerlIOScalar_set_ptrcnt, +}; + + +#endif /* Layers available */ + +MODULE = PerlIO::Scalar PACKAGE = PerlIO::Scalar + +BOOT: +{ +#ifdef PERLIO_LAYERS + PerlIO_define_layer(aTHX_ &PerlIO_scalar); +#endif +} + diff --git a/global.sym b/global.sym index 49d4e858d5..1895fbfb58 100644 --- a/global.sym +++ b/global.sym @@ -233,6 +233,7 @@ Perl_my_memcmp Perl_my_memset Perl_my_pclose Perl_my_popen +Perl_my_popen_list Perl_my_setenv Perl_my_stat Perl_my_swap diff --git a/iperlsys.h b/iperlsys.h index 8a628cd658..6c093dd53f 100644 --- a/iperlsys.h +++ b/iperlsys.h @@ -880,6 +880,8 @@ typedef int (*LPProcKillpg)(struct IPerlProc*, int, int); typedef int (*LPProcPauseProc)(struct IPerlProc*); typedef PerlIO* (*LPProcPopen)(struct IPerlProc*, const char*, const char*); +typedef PerlIO* (*LPProcPopenList)(struct IPerlProc*, const char*, + IV narg, SV **args); typedef int (*LPProcPclose)(struct IPerlProc*, PerlIO*); typedef int (*LPProcPipe)(struct IPerlProc*, int*); typedef int (*LPProcSetuid)(struct IPerlProc*, uid_t); @@ -942,6 +944,7 @@ struct IPerlProc LPProcASpawn pASpawn; #endif LPProcLastHost pLastHost; + LPProcPopenList pPopenList; }; struct IPerlProcInfo diff --git a/makedef.pl b/makedef.pl index f165a90b86..583eada584 100644 --- a/makedef.pl +++ b/makedef.pl @@ -547,8 +547,10 @@ my @layer_syms = qw( PerlIOBase_eof PerlIOBase_error PerlIOBase_fileno + PerlIOBase_setlinebuf + PerlIOBase_pushed + PerlIOBase_read PerlIOBuf_bufsiz - PerlIOBuf_fdopen PerlIOBuf_fill PerlIOBuf_flush PerlIOBuf_get_cnt @@ -556,15 +558,15 @@ my @layer_syms = qw( PerlIOBuf_open PerlIOBuf_pushed PerlIOBuf_read - PerlIOBuf_reopen PerlIOBuf_seek PerlIOBuf_set_ptrcnt - PerlIOBuf_setlinebuf PerlIOBuf_tell PerlIOBuf_unread PerlIOBuf_write PerlIO_define_layer + PerlIO_arg_fetch PerlIO_pending + PerlIO_allocate PerlIO_push PerlIO_unread ); @@ -924,8 +926,10 @@ PerlIOBuf_set_ptrcnt PerlIOBuf_get_cnt PerlIOBuf_get_ptr PerlIOBuf_bufsiz -PerlIOBuf_setlinebuf PerlIOBase_clearerr +PerlIOBase_setlinebuf +PerlIOBase_pushed +PerlIOBase_read PerlIOBase_error PerlIOBase_eof PerlIOBuf_tell @@ -933,9 +937,7 @@ PerlIOBuf_seek PerlIOBuf_write PerlIOBuf_unread PerlIOBuf_read -PerlIOBuf_reopen PerlIOBuf_open -PerlIOBuf_fdopen PerlIOBase_fileno PerlIOBuf_pushed PerlIOBuf_fill @@ -945,6 +947,8 @@ PerlIO_define_layer PerlIO_pending PerlIO_unread PerlIO_push +PerlIO_allocate +PerlIO_arg_fetch PerlIO_apply_layers perlsio_binmode PerlIO_binmode @@ -914,6 +914,10 @@ #define Perl_my_popen pPerl->Perl_my_popen #undef my_popen #define my_popen Perl_my_popen +#undef Perl_my_popen_list +#define Perl_my_popen_list pPerl->Perl_my_popen_list +#undef my_popen_list +#define my_popen_list Perl_my_popen_list #endif #undef Perl_my_setenv #define Perl_my_setenv pPerl->Perl_my_setenv @@ -1684,6 +1684,13 @@ Perl_my_popen(pTHXo_ char* cmd, char* mode) { return ((CPerlObj*)pPerl)->Perl_my_popen(cmd, mode); } + +#undef Perl_my_popen_list +PerlIO* +Perl_my_popen_list(pTHXo_ char* mode, int n, SV ** args) +{ + return ((CPerlObj*)pPerl)->Perl_my_popen_list(mode, n, args); +} #endif #undef Perl_my_setenv @@ -106,20 +106,25 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int { if (narg == 1) { - char *name = SvPV_nolen(*args); - if (*mode == '#') - { - fd = PerlLIO_open3(name,imode,perm); - if (fd >= 0) - return PerlIO_fdopen(fd,mode+1); - } - else if (old) - { - return PerlIO_reopen(name,mode,old); - } + if (*args == &PL_sv_undef) + return PerlIO_tmpfile(); else { - return PerlIO_open(name,mode); + char *name = SvPV_nolen(*args); + if (*mode == '#') + { + fd = PerlLIO_open3(name,imode,perm); + if (fd >= 0) + return PerlIO_fdopen(fd,mode+1); + } + else if (old) + { + return PerlIO_reopen(name,mode,old); + } + else + { + return PerlIO_open(name,mode); + } } } else @@ -584,9 +589,6 @@ PerlIO_arg_fetch(pTHX_ AV *av,IV n) return (svp) ? *svp : Nullsv; } -#define MYARG PerlIO_arg_fetch(aTHX_ layers,n+1) - - PerlIO_funcs * PerlIO_layer_fetch(pTHX_ AV *av,IV n,PerlIO_funcs *def) { @@ -598,7 +600,7 @@ PerlIO_layer_fetch(pTHX_ AV *av,IV n,PerlIO_funcs *def) return INT2PTR(PerlIO_funcs *, SvIV(layer)); } if (!def) - Perl_croak(aTHX_ "panic:layer array corrupt"); + Perl_croak(aTHX_ "panic:PerlIO layer array corrupt"); return def; } @@ -682,8 +684,8 @@ PerlIO_push(pTHX_ PerlIO *f,PerlIO_funcs *tab,const char *mode,SV *arg) l->next = *f; l->tab = tab; *f = l; - PerlIO_debug("PerlIO_push f=%p %s %s '%s'\n",f,tab->name, - (mode) ? mode : "(Null)",(arg) ? SvPV_nolen(arg) : "(Null)"); + PerlIO_debug("PerlIO_push f=%p %s %s %p\n",f,tab->name, + (mode) ? mode : "(Null)",arg); if ((*l->tab->Pushed)(f,mode,arg) != 0) { PerlIO_pop(aTHX_ f); @@ -750,9 +752,9 @@ PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, AV *layers, IV n) PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers,n,NULL); if (tab) { - if (!PerlIO_push(aTHX_ f,tab,mode,MYARG)) + if (!PerlIO_push(aTHX_ f,tab,mode,PerlIOArg)) { - code -1; + code = -1; break; } } @@ -832,10 +834,14 @@ int PerlIO_close(PerlIO *f) { dTHX; - int code = (*PerlIOBase(f)->tab->Close)(f); - while (*f) + int code = -1; + if (f && *f) { - PerlIO_pop(aTHX_ f); + code = (*PerlIOBase(f)->tab->Close)(f); + while (*f) + { + PerlIO_pop(aTHX_ f); + } } return code; } @@ -877,26 +883,70 @@ AV * PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **args) { AV *def = PerlIO_default_layers(aTHX); + int incdef = 1; if (!_perlio) PerlIO_stdstreams(aTHX); - /* FIXME !!! */ + if (narg) + { + if (SvROK(*args)) + { + if (sv_isobject(*args)) + { + SV *handler = PerlIO_find_layer(aTHX_ "object",6); + if (handler) + { + def = newAV(); + av_push(def,handler); + av_push(def,&PL_sv_undef); + incdef = 0; + } + } + else + { + if (SvTYPE(SvRV(*args)) < SVt_PVAV) + { + SV *handler = PerlIO_find_layer(aTHX_ "Scalar",6); + if (handler) + { + def = newAV(); + av_push(def,handler); + av_push(def,&PL_sv_undef); + incdef = 0; + } + } + else + { + Perl_croak(aTHX_ "Unsupported reference arg to open()"); + } + } + } + } if (!layers) layers = PerlIO_context_layers(aTHX_ mode); if (layers && *layers) { - AV *av = newAV(); - IV n = av_len(def)+1; - while (n-- > 0) + AV *av; + if (incdef) { - SV **svp = av_fetch(def,n,0); - av_store(av,n,(svp) ? SvREFCNT_inc(*svp) : &PL_sv_undef); + IV n = av_len(def)+1; + av = newAV(); + while (n-- > 0) + { + SV **svp = av_fetch(def,n,0); + av_store(av,n,(svp) ? SvREFCNT_inc(*svp) : &PL_sv_undef); + } + } + else + { + av = def; } PerlIO_parse_layers(aTHX_ av,layers); return av; } else { - SvREFCNT_inc(def); + if (incdef) + SvREFCNT_inc(def); return def; } } @@ -904,54 +954,68 @@ PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **a PerlIO * PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args) { - AV *layera; - IV n; - PerlIO_funcs *tab; - if (f && *f) + if (!f && narg == 1 && *args == &PL_sv_undef) { - PerlIOl *l = *f; - layera = newAV(); - while (l) + if ((f = PerlIO_tmpfile())) { - SV *arg = (l->tab->Getarg) ? (*l->tab->Getarg)(&l) : &PL_sv_undef; - av_unshift(layera,2); - av_store(layera,0,PerlIO_tab_sv(aTHX_ l->tab)); - av_store(layera,1,arg); - l = *PerlIONext(&l); + if (!layers) + layers = PerlIO_context_layers(aTHX_ mode); + if (layers && *layers) + PerlIO_apply_layers(aTHX_ f,mode,layers); } } else { - layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args); - } - n = av_len(layera)-1; - while (n >= 0) - { - PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera,n,NULL); - if (t && t->Open) + AV *layera; + IV n; + PerlIO_funcs *tab; + if (f && *f) { - tab = t; - break; + /* This is "reopen" - it is not tested as perl does not use it yet */ + PerlIOl *l = *f; + layera = newAV(); + while (l) + { + SV *arg = (l->tab->Getarg) ? (*l->tab->Getarg)(&l) : &PL_sv_undef; + av_unshift(layera,2); + av_store(layera,0,PerlIO_tab_sv(aTHX_ l->tab)); + av_store(layera,1,arg); + l = *PerlIONext(&l); + } } - n -= 2; - } - if (tab) - { - PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n", - tab->name,layers,mode,fd,imode,perm,f,narg,args); - f = (*tab->Open)(aTHX_ tab, layera, n, mode,fd,imode,perm,f,narg,args); - if (f) + else + { + layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args); + } + n = av_len(layera)-1; + while (n >= 0) + { + PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera,n,NULL); + if (t && t->Open) + { + tab = t; + break; + } + n -= 2; + } + if (tab) { - if (n+2 < av_len(layera)+1) + PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n", + tab->name,layers,mode,fd,imode,perm,f,narg,args); + f = (*tab->Open)(aTHX_ tab, layera, n, mode,fd,imode,perm,f,narg,args); + if (f) { - if (PerlIO_apply_layera(aTHX_ f, mode, layera, n+2) != 0) + if (n+2 < av_len(layera)+1) { - f = NULL; + if (PerlIO_apply_layera(aTHX_ f, mode, layera, n+2) != 0) + { + f = NULL; + } } } } + SvREFCNT_dec(layera); } - SvREFCNT_dec(layera); return f; } @@ -1434,6 +1498,37 @@ PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count) return done; } +SSize_t +PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count) +{ + STDCHAR *buf = (STDCHAR *) vbuf; + if (f) + { + if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) + return 0; + while (count > 0) + { + SSize_t avail = PerlIO_get_cnt(f); + SSize_t take = (count < avail) ? count : avail; + if (take > 0) + { + STDCHAR *ptr = PerlIO_get_ptr(f); + Copy(ptr,buf,take,STDCHAR); + PerlIO_set_ptrcnt(f,ptr+take,(avail -= take)); + count -= take; + buf += take; + } + if (count > 0 && avail <= 0) + { + if (PerlIO_fill(f) != 0) + break; + } + } + return (buf - (STDCHAR *) vbuf); + } + return 0; +} + IV PerlIOBase_noop_ok(PerlIO *f) { @@ -1453,7 +1548,7 @@ PerlIOBase_close(PerlIO *f) PerlIO *n = PerlIONext(f); if (PerlIO_flush(f) != 0) code = -1; - if (n && (*PerlIOBase(n)->tab->Close)(n) != 0) + if (n && *n && (*PerlIOBase(n)->tab->Close)(n) != 0) code = -1; PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN); return code; @@ -1494,7 +1589,10 @@ PerlIOBase_clearerr(PerlIO *f) void PerlIOBase_setlinebuf(PerlIO *f) { - + if (f) + { + PerlIOBase(f)->flags |= PERLIO_F_LINEBUF; + } } /*--------------------------------------------------------------------------------------*/ @@ -1617,7 +1715,7 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, in if (!f) { f = PerlIO_allocate(aTHX); - s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,MYARG),PerlIOUnix); + s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOUnix); } else s = PerlIOSelf(f,PerlIOUnix); @@ -1837,7 +1935,7 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, i if (stdio) { PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self, - (mode = PerlIOStdio_mode(mode,tmode)),MYARG), + (mode = PerlIOStdio_mode(mode,tmode)),PerlIOArg), PerlIOStdio); s->stdio = stdio; } @@ -1874,7 +1972,7 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, i } if (stdio) { - PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,MYARG),PerlIOStdio); + PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,PerlIOArg),PerlIOStdio); s->stdio = stdio; return f; } @@ -2208,6 +2306,7 @@ PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg) PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); int fd = PerlIO_fileno(f); Off_t posn; + dTHX; if (fd >= 0 && PerlLIO_isatty(fd)) { PerlIOBase(f)->flags |= PERLIO_F_LINEBUF; @@ -2228,7 +2327,7 @@ PerlIOBuf_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int PerlIO *next = PerlIONext(f); PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIOBase(next)->tab); next = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,next,narg,args); - if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,MYARG) != 0) + if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0) { return NULL; } @@ -2245,7 +2344,7 @@ PerlIOBuf_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int f = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,NULL,narg,args); if (f) { - PerlIOBuf *b = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,MYARG),PerlIOBuf); + PerlIOBuf *b = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOBuf); fd = PerlIO_fileno(f); #if O_BINARY != O_TEXT /* do something about failing setmode()? --jhi */ @@ -2384,32 +2483,11 @@ SSize_t PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count) { PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); - STDCHAR *buf = (STDCHAR *) vbuf; if (f) { if (!b->ptr) PerlIO_get_base(f); - if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) - return 0; - while (count > 0) - { - SSize_t avail = PerlIO_get_cnt(f); - SSize_t take = (count < avail) ? count : avail; - if (take > 0) - { - STDCHAR *ptr = PerlIO_get_ptr(f); - Copy(ptr,buf,take,STDCHAR); - PerlIO_set_ptrcnt(f,ptr+take,(avail -= take)); - count -= take; - buf += take; - } - if (count > 0 && avail <= 0) - { - if (PerlIO_fill(f) != 0) - break; - } - } - return (buf - (STDCHAR *) vbuf); + return PerlIOBase_read(f,vbuf,count); } return 0; } @@ -2551,15 +2629,6 @@ PerlIOBuf_close(PerlIO *f) return code; } -void -PerlIOBuf_setlinebuf(PerlIO *f) -{ - if (f) - { - PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF; - } -} - STDCHAR * PerlIOBuf_get_ptr(PerlIO *f) { @@ -2646,7 +2715,7 @@ PerlIO_funcs PerlIO_perlio = { PerlIOBase_eof, PerlIOBase_error, PerlIOBase_clearerr, - PerlIOBuf_setlinebuf, + PerlIOBase_setlinebuf, PerlIOBuf_get_base, PerlIOBuf_bufsiz, PerlIOBuf_get_ptr, @@ -2761,7 +2830,7 @@ PerlIO_funcs PerlIO_pending = { PerlIOBase_eof, PerlIOBase_error, PerlIOBase_clearerr, - PerlIOBuf_setlinebuf, + PerlIOBase_setlinebuf, PerlIOBuf_get_base, PerlIOBuf_bufsiz, PerlIOBuf_get_ptr, @@ -3067,7 +3136,7 @@ PerlIO_funcs PerlIO_crlf = { PerlIOBase_eof, PerlIOBase_error, PerlIOBase_clearerr, - PerlIOBuf_setlinebuf, + PerlIOBase_setlinebuf, PerlIOBuf_get_base, PerlIOBuf_bufsiz, PerlIOBuf_get_ptr, @@ -3372,7 +3441,7 @@ PerlIO_funcs PerlIO_mmap = { PerlIOBase_eof, PerlIOBase_error, PerlIOBase_clearerr, - PerlIOBuf_setlinebuf, + PerlIOBase_setlinebuf, PerlIOMmap_get_base, PerlIOBuf_bufsiz, PerlIOBuf_get_ptr, @@ -93,6 +93,8 @@ EXT PerlIO_funcs PerlIO_mmap; #endif extern PerlIO *PerlIO_allocate(pTHX); +extern SV *PerlIO_arg_fetch(pTHX_ AV *av,IV n); +#define PerlIOArg PerlIO_arg_fetch(aTHX_ layers,n+1) #if O_BINARY != O_TEXT #define PERLIO_STDTEXT "t" @@ -106,6 +108,7 @@ extern PerlIO *PerlIO_allocate(pTHX); extern IV PerlIOBase_fileno (PerlIO *f); 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); extern SSize_t PerlIOBase_unread (PerlIO *f, const void *vbuf, Size_t count); extern IV PerlIOBase_eof (PerlIO *f); extern IV PerlIOBase_error (PerlIO *f); @@ -145,7 +148,6 @@ extern Off_t PerlIOBuf_tell (PerlIO *f); extern IV PerlIOBuf_close (PerlIO *f); extern IV PerlIOBuf_flush (PerlIO *f); extern IV PerlIOBuf_fill (PerlIO *f); -extern void PerlIOBuf_setlinebuf (PerlIO *f); extern STDCHAR *PerlIOBuf_get_base (PerlIO *f); extern Size_t PerlIOBuf_bufsiz (PerlIO *f); extern STDCHAR *PerlIOBuf_get_ptr (PerlIO *f); @@ -499,6 +499,7 @@ PERL_CALLCONV void* Perl_my_memset(char* loc, I32 ch, I32 len); #if !defined(PERL_OBJECT) PERL_CALLCONV I32 Perl_my_pclose(pTHX_ PerlIO* ptr); PERL_CALLCONV PerlIO* Perl_my_popen(pTHX_ char* cmd, char* mode); +PERL_CALLCONV PerlIO* Perl_my_popen_list(pTHX_ char* mode, int n, SV ** args); #endif PERL_CALLCONV void Perl_my_setenv(pTHX_ char* nam, char* val); PERL_CALLCONV I32 Perl_my_stat(pTHX); diff --git a/t/io/open.t b/t/io/open.t index 635ea4c364..9b37db390c 100755 --- a/t/io/open.t +++ b/t/io/open.t @@ -11,7 +11,7 @@ use warnings; $Is_VMS = $^O eq 'VMS'; $Is_Dos = $^O eq 'dos'; -print "1..66\n"; +print "1..70\n"; my $test = 1; @@ -289,3 +289,18 @@ ok; } ok; } + +# 67..70 - magic temporary file via 3 arg open with undef +{ + open(my $x,"+<",undef) or print "not "; + ok; + print "not " unless defined(fileno($x)); + ok; + select $x; + ok; # goes to $x + select STDOUT; + seek($x,0,0); + print <$x>; + print "not " unless tell($x) > 3; + ok; +} diff --git a/t/io/utf8.t b/t/io/utf8.t index d0201aaffb..07e626f085 100755 --- a/t/io/utf8.t +++ b/t/io/utf8.t @@ -3,8 +3,7 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; - require Config; import Config; - unless ($Config{'useperlio'}) { + unless (defined &perlio::import) { print "1..0 # Skip: not perlio\n"; exit 0; } @@ -79,7 +78,7 @@ open F, ">:utf8", 'a' or die $!; binmode(F); # we write a "\n" and then tell() - avoid CRLF issues. print F $a; my $y; -{ my $x = tell(F); +{ my $x = tell(F); { use bytes; $y = length($a);} print "not " unless $x == $y; print "ok 16\n"; @@ -99,7 +98,7 @@ print "not ($y) " unless $y == 1; print "ok 18\n"; } -{ my $x = tell(F); +{ my $x = tell(F); { use bytes; $y += 3;} print "not ($x,$y) " unless $x == $y; print "ok 19\n"; diff --git a/t/lib/io_scalar.t b/t/lib/io_scalar.t new file mode 100644 index 0000000000..569abd71e1 --- /dev/null +++ b/t/lib/io_scalar.t @@ -0,0 +1,35 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + unless (defined &perlio::import) { + print "1..0 # Skip: not perlio\n"; + exit 0; + } +} + +$| = 1; +print "1..9\n"; + +my $fh; +my $var = "ok 2\n"; +open($fh,"+<",\$var) or print "not "; +print "ok 1\n"; +print <$fh>; +print "not " unless eof($fh); +print "ok 3\n"; +seek($fh,0,0) or print "not "; +print "not " if eof($fh); +print "ok 4\n"; +print "ok 5\n"; +print $fh "ok 7\n" or print "not "; +print "ok 6\n"; +print $var; +$var = "foo\nbar\n"; +seek($fh,0,0) or print "not "; +print "not " if eof($fh); +print "ok 8\n"; +print "not " unless <$fh> eq "foo\n"; +print "ok 9\n"; + diff --git a/win32/config_H.bc b/win32/config_H.bc index 04768a981a..788e2a6d11 100644 --- a/win32/config_H.bc +++ b/win32/config_H.bc @@ -13,7 +13,7 @@ /* * Package name : perl5 * Source directory : - * Configuration time: Thu Jan 18 14:54:24 2001 + * Configuration time: Sat Mar 24 14:32:42 2001 * Configured by : nick * Target system : */ diff --git a/win32/config_H.gc b/win32/config_H.gc index b86a80b8ea..6d5af937f5 100644 --- a/win32/config_H.gc +++ b/win32/config_H.gc @@ -13,7 +13,7 @@ /* * Package name : perl5 * Source directory : - * Configuration time: Thu Jan 18 14:54:41 2001 + * Configuration time: Sat Mar 24 14:32:55 2001 * Configured by : nick * Target system : */ diff --git a/win32/config_H.vc b/win32/config_H.vc index 314d98e5be..587d7ca03f 100644 --- a/win32/config_H.vc +++ b/win32/config_H.vc @@ -13,7 +13,7 @@ /* * Package name : perl5 * Source directory : - * Configuration time: Thu Jan 18 14:54:56 2001 + * Configuration time: Sat Mar 24 14:32:21 2001 * Configured by : nick * Target system : */ diff --git a/win32/makefile.mk b/win32/makefile.mk index 6e91bc2b82..21ead2feaf 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -743,7 +743,8 @@ SETARGV_OBJ = setargv$(o) DYNAMIC_EXT = Socket IO Fcntl Opcode SDBM_File POSIX attrs Thread B re \ Data/Dumper Devel/Peek ByteLoader Devel/DProf File/Glob \ - Sys/Hostname Storable Filter/Util/Call Encode Digest/MD5 + Sys/Hostname Storable Filter/Util/Call Encode \ + Digest/MD5 PerlIO/Scalar STATIC_EXT = DynaLoader NONXS_EXT = Errno @@ -759,6 +760,7 @@ THREAD = $(EXTDIR)\Thread\Thread B = $(EXTDIR)\B\B RE = $(EXTDIR)\re\re DUMPER = $(EXTDIR)\Data\Dumper\Dumper +SCALAR = $(EXTDIR)\PerlIO\Scalar\Scalar ERRNO = $(EXTDIR)\Errno\Errno PEEK = $(EXTDIR)\Devel\Peek\Peek BYTELOADER = $(EXTDIR)\ByteLoader\ByteLoader @@ -780,6 +782,7 @@ ATTRS_DLL = $(AUTODIR)\attrs\attrs.dll THREAD_DLL = $(AUTODIR)\Thread\Thread.dll B_DLL = $(AUTODIR)\B\B.dll DUMPER_DLL = $(AUTODIR)\Data\Dumper\Dumper.dll +SCALAR_DLL = $(AUTODIR)\PerlIO\Scalar\Scalar.dll PEEK_DLL = $(AUTODIR)\Devel\Peek\Peek.dll RE_DLL = $(AUTODIR)\re\re.dll BYTELOADER_DLL = $(AUTODIR)\ByteLoader\ByteLoader.dll @@ -804,6 +807,7 @@ EXTENSION_C = \ $(THREAD).c \ $(RE).c \ $(DUMPER).c \ + $(SCALARR).c \ $(PEEK).c \ $(B).c \ $(BYTELOADER).c \ @@ -824,6 +828,7 @@ EXTENSION_DLL = \ $(POSIX_DLL) \ $(ATTRS_DLL) \ $(DUMPER_DLL) \ + $(SCALAR_DLL) \ $(PEEK_DLL) \ $(B_DLL) \ $(RE_DLL) \ @@ -1144,6 +1149,11 @@ $(DUMPER_DLL): $(PERLDEP) $(DUMPER).xs ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl cd $(EXTDIR)\Data\$(*B) && $(MAKE) +$(SCALAR_DLL): $(PERLDEP) $(SCALAR).xs + cd $(EXTDIR)\PerlIO\$(*B) && \ + ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl + cd $(EXTDIR)\PerlIO\$(*B) && $(MAKE) + $(DPROF_DLL): $(PERLDEP) $(DPROF).xs cd $(EXTDIR)\Devel\$(*B) && \ ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl @@ -1284,6 +1294,7 @@ distclean: clean -del /f $(LIBDIR)\SDBM_File.pm $(LIBDIR)\Socket.pm $(LIBDIR)\POSIX.pm -del /f $(LIBDIR)\B.pm $(LIBDIR)\O.pm $(LIBDIR)\re.pm -del /f $(LIBDIR)\Data\Dumper.pm $(LIBDIR)\ByteLoader.pm + -del /f $(LIBDIR)\PerlIO\Scalar.pm -del /f $(LIBDIR)\Devel\Peek.pm $(LIBDIR)\Devel\DProf.pm -del /f $(LIBDIR)\File\Glob.pm -del /f $(LIBDIR)\Storable.pm diff --git a/win32/perlhost.h b/win32/perlhost.h index 719d82ac04..815be84b84 100644 --- a/win32/perlhost.h +++ b/win32/perlhost.h @@ -1594,6 +1594,14 @@ PerlProcPopen(struct IPerlProc* piPerl, const char *command, const char *mode) return win32_popen(command, mode); } +PerlIO* +PerlProcPopenList(struct IPerlProc* piPerl, const char *mode, IV narg, SV **args) +{ + dTHXo; + PERL_FLUSHALL_FOR_CHILD; + return win32_popenlist(mode, narg, args); +} + int PerlProcPclose(struct IPerlProc* piPerl, PerlIO *stream) { @@ -1893,7 +1901,8 @@ struct IPerlProc perlProc = PerlProcSpawn, PerlProcSpawnvp, PerlProcASpawn, - PerlProcLastHost + PerlProcLastHost, + PerlProcPopenList }; diff --git a/win32/win32.c b/win32/win32.c index 226ef9b7c0..d2d70e5506 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -2356,6 +2356,14 @@ win32_pipe(int *pfd, unsigned int size, int mode) return _pipe(pfd, size, mode); } +DllExport PerlIO* +win32_popenlist(const char *mode, IV narg, SV **args) +{ + dTHX; + Perl_croak(aTHX_ "List form of pipe open not implemented"); + return NULL; +} + /* * a popen() clone that respects PERL5SHELL * diff --git a/win32/win32iop.h b/win32/win32iop.h index 5412f5e9a3..4d78839888 100644 --- a/win32/win32iop.h +++ b/win32/win32iop.h @@ -73,6 +73,7 @@ DllExport int win32_fstat(int fd,struct stat *sbufptr); DllExport int win32_stat(const char *name,struct stat *sbufptr); DllExport int win32_pipe( int *phandles, unsigned int psize, int textmode ); DllExport PerlIO* win32_popen( const char *command, const char *mode ); +DllExport PerlIO* win32_popenlist(const char *mode, IV narg, SV **args); DllExport int win32_pclose( PerlIO *pf); DllExport int win32_rename( const char *oname, const char *newname); DllExport int win32_setmode( int fd, int mode); |