typedef Signal_t (*Sighandler_t) (int);
#endif
+#ifndef Fpos_t
+#define Fpos_t Off_t
+#endif
+
#if defined(PERL_IMPLICIT_SYS)
#ifndef PerlIO
typedef struct _PerlIO PerlIOl;
typedef PerlIOl *PerlIO;
#define PerlIO PerlIO
-#endif
+#endif /* No PerlIO */
/* IPerlStdIO */
struct IPerlStdIO;
typedef void (*LPInit)(struct IPerlStdIO*);
typedef void (*LPInitOSExtras)(struct IPerlStdIO*);
typedef PerlIO* (*LPFdupopen)(struct IPerlStdIO*, PerlIO*);
+typedef int (*LPIsUtf8)(struct IPerlStdIO*, PerlIO*);
struct IPerlStdIO
{
LPInit pInit;
LPInitOSExtras pInitOSExtras;
LPFdupopen pFdupopen;
+ LPIsUtf8 pIsUtf8;
};
struct IPerlStdIOInfo
(*PL_StdIO->pInitOSExtras)(PL_StdIO)
#define PerlIO_fdupopen(f) \
(*PL_StdIO->pFdupopen)(PL_StdIO, (f))
+#define PerlIO_isutf8(f) \
+ (*PL_StdIO->pIsUtf8)(PL_StdIO, (f))
#else /* PERL_IMPLICIT_SYS */
#include "perlsdio.h"
#include "perl.h"
#define PerlIO_fdupopen(f) (f)
+#define PerlIO_isutf8(f) 0
#endif /* PERL_IMPLICIT_SYS */
#ifndef PERLIO_IS_STDIO
#ifdef USE_SFIO
#include "perlsfio.h"
+#define PerlIO_isutf8(f) 0
#endif /* USE_SFIO */
#endif /* PERLIO_IS_STDIO */
#define PerlIO PerlIO
#endif /* No PerlIO */
-#ifndef Fpos_t
-#define Fpos_t long
-#endif
-
#ifndef NEXT30_NO_ATTRIBUTE
#ifndef HASATTRIBUTE /* disable GNU-cc attribute checking? */
#ifdef __attribute__ /* Avoid possible redefinition errors */
#ifndef PerlIO_fdupopen
extern PerlIO * PerlIO_fdupopen (PerlIO *);
#endif
-
+#ifndef PerlIO_isutf8
+extern int PerlIO_isutf8 (PerlIO *);
+#endif
/*
* Interface for directory functions
--- /dev/null
+package perlio;
+1;
+__END__
+
+=head1 NAME
+
+perlio - perl pragma to configure C level IO
+
+=head1 SYNOPSIS
+
+ Shell:
+ PERLIO=perlio perl ....
+
+ print "Have ",join(',',keys %perlio::layers),"\n";
+ print "Using ",join(',',@perlio::layers),"\n";
+
+
+=head1 DESCRIPTION
+
+Mainly a Place holder for now.
+
+The C<%perlio::layers> hash is a record of the available "layers" that may be pushed
+onto a C<PerlIO> stream.
+
+The C<@perlio::layers> array is the current set of layers that are used when
+a new C<PerlIO> stream is opened. The C code looks are the array each time
+a stream is opened so the "stack" can be manipulated by messing with the array :
+
+ pop(@perlio::layers);
+ push(@perlio::layers,$perlio::layers{'stdio'});
+
+The values if both the hash and the array are perl objects, of class C<perlio::Layer>
+which are created by the C code in C<perlio.c>. As yet there is nothing useful you
+can do with the objects at the perl level.
+
+There are three layers currently defined:
+
+=over 4
+
+=item unix
+
+Low level layer which calls C<read>, C<write> and C<lseek> etc.
+
+=item stdio
+
+Layer which calls C<fread>, C<fwrite> and C<fseek>/C<ftell> etc.
+Note that as this is "real" stdio it will ignore any layers beneath it and
+got straight to the operating system via the C library as usual.
+
+=item perlio
+
+This is a re-implementation of "stdio-like" buffering written as a PerlIO "layer".
+As such it will call whatever layer is below it for its operations.
+
+=back
+
+=head2 Defaults and how to override them
+
+If C<Configure> found out how to do "fast" IO using system's stdio, then
+the default layers are :
+
+ unix stdio
+
+Otherwise the default layers are
+
+ unix perlio
+
+(STDERR will have just unix in this case as that is optimal way to make it
+"unbuffered" - do not add a buffering layer!)
+
+The default may change once perlio has been better tested and tuned.
+
+The default can be overridden by setting the environment variable PERLIO
+to a space separated list of layers (unix is always pushed first).
+This can be used to see the effect of/bugs in the various layers e.g.
+
+ cd .../perl/t
+ PERLIO=stdio ./perl harness
+ PERLIO=perlio ./perl harness
+
+=head1 AUTHOR
+
+Nick Ing-Simmons E<lt>nick@ing-simmons.netE<gt>
+
+=cut
+
+
#ifdef I_UNISTD
#include <unistd.h>
#endif
+#include "XSUB.h"
#undef printf
void PerlIO_debug(char *fmt,...) __attribute__((format(printf,1,2)));
/*--------------------------------------------------------------------------------------*/
/* Flag values */
-#define PERLIO_F_EOF 0x0010000
-#define PERLIO_F_CANWRITE 0x0020000
-#define PERLIO_F_CANREAD 0x0040000
-#define PERLIO_F_ERROR 0x0080000
-#define PERLIO_F_TRUNCATE 0x0100000
-#define PERLIO_F_APPEND 0x0200000
-#define PERLIO_F_BINARY 0x0400000
-#define PERLIO_F_TEMP 0x0800000
-#define PERLIO_F_LINEBUF 0x0100000
-#define PERLIO_F_WRBUF 0x2000000
-#define PERLIO_F_RDBUF 0x4000000
-#define PERLIO_F_OPEN 0x8000000
+#define PERLIO_F_EOF 0x00010000
+#define PERLIO_F_CANWRITE 0x00020000
+#define PERLIO_F_CANREAD 0x00040000
+#define PERLIO_F_ERROR 0x00080000
+#define PERLIO_F_TRUNCATE 0x00100000
+#define PERLIO_F_APPEND 0x00200000
+#define PERLIO_F_BINARY 0x00400000
+#define PERLIO_F_UTF8 0x00800000
+#define PERLIO_F_LINEBUF 0x01000000
+#define PERLIO_F_WRBUF 0x02000000
+#define PERLIO_F_RDBUF 0x04000000
+#define PERLIO_F_TEMP 0x08000000
+#define PERLIO_F_OPEN 0x10000000
#define PerlIOBase(f) (*(f))
#define PerlIOSelf(f,type) ((type *)PerlIOBase(f))
PerlIO *
PerlIO_allocate(void)
{
- /* Find a free slot in the table, growing table as necessary */
+ /* Find a free slot in the table, allocating new table as necessary */
PerlIO **last = &_perlio;
PerlIO *f;
while ((f = *last))
return (*PerlIOBase(f)->tab->Fileno)(f);
}
+
extern PerlIO_funcs PerlIO_unix;
-extern PerlIO_funcs PerlIO_stdio;
extern PerlIO_funcs PerlIO_perlio;
+extern PerlIO_funcs PerlIO_stdio;
+
+XS(XS_perlio_import)
+{
+ dXSARGS;
+ GV *gv = CvGV(cv);
+ char *s = GvNAME(gv);
+ STRLEN l = GvNAMELEN(gv);
+ PerlIO_debug("%.*s\n",(int) l,s);
+ XSRETURN_EMPTY;
+}
+
+XS(XS_perlio_unimport)
+{
+ dXSARGS;
+ GV *gv = CvGV(cv);
+ char *s = GvNAME(gv);
+ STRLEN l = GvNAMELEN(gv);
+ PerlIO_debug("%.*s\n",(int) l,s);
+ XSRETURN_EMPTY;
+}
+
+HV *PerlIO_layer_hv;
+AV *PerlIO_layer_av;
-#define PerlIO_default_top() &PerlIO_stdio
-#define PerlIO_default_btm() &PerlIO_unix
+SV *
+PerlIO_find_layer(char *name, STRLEN len)
+{
+ dTHX;
+ SV **svp;
+ SV *sv;
+ if (len <= 0)
+ len = strlen(name);
+ svp = hv_fetch(PerlIO_layer_hv,name,len,0);
+ if (svp && (sv = *svp) && SvROK(sv))
+ return *svp;
+ return NULL;
+}
+
+void
+PerlIO_define_layer(PerlIO_funcs *tab)
+{
+ dTHX;
+ HV *stash = gv_stashpv("perlio::Layer", TRUE);
+ SV *sv = sv_bless(newRV_noinc(newSViv((IV) tab)),stash);
+ hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
+}
+
+PerlIO_funcs *
+PerlIO_default_layer(I32 n)
+{
+ dTHX;
+ SV **svp;
+ SV *layer;
+ PerlIO_funcs *tab = &PerlIO_stdio;
+ int len;
+ if (!PerlIO_layer_hv)
+ {
+ char *s = getenv("PERLIO");
+ newXS("perlio::import",XS_perlio_import,__FILE__);
+ newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
+ PerlIO_layer_hv = get_hv("perlio::layers",GV_ADD|GV_ADDMULTI);
+ PerlIO_layer_av = get_av("perlio::layers",GV_ADD|GV_ADDMULTI);
+ PerlIO_define_layer(&PerlIO_unix);
+ PerlIO_define_layer(&PerlIO_unix);
+ PerlIO_define_layer(&PerlIO_perlio);
+ PerlIO_define_layer(&PerlIO_stdio);
+ av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
+ if (s)
+ {
+ while (*s)
+ {
+ while (*s && isspace((unsigned char)*s))
+ s++;
+ if (*s)
+ {
+ char *e = s;
+ SV *layer;
+ while (*e && !isspace((unsigned char)*e))
+ e++;
+ layer = PerlIO_find_layer(s,e-s);
+ if (layer)
+ {
+ PerlIO_debug("Pushing %.*s\n",(e-s),s);
+ av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
+ }
+ else
+ Perl_croak(aTHX_ "Unknown layer %.*s",(e-s),s);
+ s = e;
+ }
+ }
+ }
+ }
+ len = av_len(PerlIO_layer_av);
+ if (len < 1)
+ {
+ if (PerlIO_stdio.Set_ptrcnt)
+ {
+ av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
+ }
+ else
+ {
+ av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
+ }
+ len = av_len(PerlIO_layer_av);
+ }
+ if (n < 0)
+ n += len+1;
+ svp = av_fetch(PerlIO_layer_av,n,0);
+ if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
+ {
+ tab = (PerlIO_funcs *) SvIV(layer);
+ }
+ /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
+ return tab;
+}
+
+#define PerlIO_default_top() PerlIO_default_layer(-1)
+#define PerlIO_default_btm() PerlIO_default_layer(0)
+
+void
+PerlIO_stdstreams()
+{
+ if (!_perlio)
+ {
+ PerlIO_allocate();
+ PerlIO_fdopen(0,"Ir");
+ PerlIO_fdopen(1,"Iw");
+ PerlIO_fdopen(2,"Iw");
+ }
+}
#undef PerlIO_fdopen
PerlIO *
PerlIO_fdopen(int fd, const char *mode)
{
PerlIO_funcs *tab = PerlIO_default_top();
+ if (!_perlio)
+ PerlIO_stdstreams();
return (*tab->Fdopen)(fd,mode);
}
PerlIO_open(const char *path, const char *mode)
{
PerlIO_funcs *tab = PerlIO_default_top();
+ if (!_perlio)
+ PerlIO_stdstreams();
return (*tab->Open)(path,mode);
}
}
}
+#undef PerlIO_isutf8
+int
+PerlIO_isutf8(PerlIO *f)
+{
+ return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
+}
+
#undef PerlIO_eof
int
PerlIO_eof(PerlIO *f)
void
PerlIO_set_cnt(PerlIO *f,int cnt)
{
- return (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
+ (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
}
#undef PerlIO_set_ptrcnt
void
PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
{
- return (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
+ (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
}
/*--------------------------------------------------------------------------------------*/
if (!_perlio)
{
atexit(&PerlIO_cleanup);
- PerlIO_fdopen(0,"Ir");
- PerlIO_fdopen(1,"Iw");
- PerlIO_fdopen(2,"Iw");
}
}
PerlIO_stdin(void)
{
if (!_perlio)
- PerlIO_init();
+ PerlIO_stdstreams();
return &_perlio[1];
}
PerlIO_stdout(void)
{
if (!_perlio)
- PerlIO_init();
+ PerlIO_stdstreams();
return &_perlio[2];
}
PerlIO_stderr(void)
{
if (!_perlio)
- PerlIO_init();
+ PerlIO_stdstreams();
return &_perlio[3];
}
projects / p5sagit/p5-mst-13.2.git / commitdiff