$ d_setlocale="undef"
$ ENDIF
$ d_stdio_ptr_lval_sets_cnt="undef"
-$ d_stdio_ptr_lval_nochange_cnt="undef"
+$ d_stdio_ptr_lval_nochange_cnt="define"
$!
$! Sockets?
$ if Has_Socketshr .OR. Has_Dec_C_Sockets
#ifdef VMS
if (savefd != PerlIO_fileno(PerlIO_stdin())) {
char newname[FILENAME_MAX+1];
- if (fgetname(fp, newname)) {
+ if (PerlIO_getname(fp, newname)) {
if (fd == PerlIO_fileno(PerlIO_stdout())) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT", newname);
if (fd == PerlIO_fileno(PerlIO_stderr())) Perl_vmssetuserlnm(aTHX_ "SYS$ERROR", newname);
}
char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'};
char vmsspec[NAM$C_MAXRSS+1];
char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp;
- char tmpfnam[L_tmpnam] = "SYS$SCRATCH:";
$DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
PerlIO *tmpfp;
STRLEN i;
((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
but that's unsupported, so I don't want to do it now and
have it bite someone in the future. */
- strcat(tmpfnam,PerlLIO_tmpnam(NULL));
cp = SvPV(tmpglob,i);
for (; i; i--) {
if (cp[i] == ';') hasver = 1;
break;
}
}
- if ((tmpfp = PerlIO_open(tmpfnam,"w+","fop=dlt")) != NULL) {
+ if ((tmpfp = PerlIO_tmpfile()) != NULL) {
Stat_t st;
if (!PerlLIO_stat(SvPVX(tmpglob),&st) && S_ISDIR(st.st_mode))
ok = ((wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec)) != NULL);
#define PerlSIO_fputs(f,s) fputs(s,f)
#define PerlSIO_fflush(f) Fflush(f)
#define PerlSIO_fgets(s, n, fp) fgets(s,n,fp)
-#define PerlSIO_ungetc(c,f) ungetc(c,f)
+#if defined(VMS) && defined(__DECC)
+ /* Unusual definition of ungetc() here to accomodate fast_sv_gets()'
+ * belief that it can mix getc/ungetc with reads from stdio buffer */
+ int decc$ungetc(int __c, FILE *__stream);
+# define PerlSIO_ungetc(c,f) ((c) == EOF ? EOF : \
+ ((*(f) && !((*(f))->_flag & _IONBF) && \
+ ((*(f))->_ptr > (*(f))->_base)) ? \
+ ((*(f))->_cnt++, *(--(*(f))->_ptr) = (c)) : decc$ungetc(c,f)))
+#else
+# define PerlSIO_ungetc(c,f) ungetc(c,f)
+#endif
#define PerlSIO_fileno(f) fileno(f)
#define PerlSIO_fdopen(f, s) fdopen(f,s)
#define PerlSIO_freopen(p, m, f) freopen(p,m,f)
PerlIO_getname(PerlIO *f, char *buf)
{
dTHX;
+ char *name = NULL;
+#ifdef VMS
+ FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
+ if (stdio) name = fgetname(stdio, buf);
+#else
Perl_croak(aTHX_ "Don't know how to get file name");
- return NULL;
+#endif
+ return name;
}
#ifndef PerlIO_read
extern SSize_t PerlIO_read (PerlIO *,void *,Size_t);
#endif
+#ifndef PerlIO_unread
+extern SSize_t PerlIO_unread (PerlIO *,const void *,Size_t);
+#endif
#ifndef PerlIO_write
extern SSize_t PerlIO_write (PerlIO *,const void *,Size_t);
#endif
#ifndef PerlIO_binmode
extern int PerlIO_binmode (pTHX_ PerlIO *f, int iotype, int omode, const char *names);
#endif
+#ifndef PerlIO_getname
+extern char * PerlIO_getname (PerlIO *, char *);
+#endif
extern void PerlIO_destruct(pTHX);
extern IV PerlIOBase_eof (PerlIO *f);
extern IV PerlIOBase_error (PerlIO *f);
extern void PerlIOBase_clearerr (PerlIO *f);
-extern IV PerlIOBase_flush (PerlIO *f);
-extern IV PerlIOBase_fill (PerlIO *f);
extern IV PerlIOBase_close (PerlIO *f);
extern void PerlIOBase_setlinebuf(PerlIO *f);
extern void PerlIOBase_flush_linebuf(void);
#define PerlIO_stdoutf printf
#define PerlIO_vprintf(f,fmt,a) vfprintf(f,fmt,a)
#define PerlIO_write(f,buf,count) fwrite1(buf,1,count,f)
+#define PerlIO_unread(f,buf,count) (-1)
#define PerlIO_open fopen
#define PerlIO_fdopen fdopen
#define PerlIO_reopen freopen
static SV *
-newFH(FILE *fp, char type) {
+newFH(PerlIO *fp, char type) {
SV *rv;
GV **stashp, *gv = (GV *)NEWSV(0,0);
HV *stash;
PROTOTYPE: $
CODE:
IO *io = sv_2io(fh);
- FILE *fp = io ? IoOFP(io) : NULL;
+ PerlIO *fp = io ? IoOFP(io) : NULL;
char iotype = io ? IoTYPE(io) : '\0';
char filespec[NAM$C_MAXRSS], *acmode, *s, *colon, *dirend = Nullch;
int ret = 0, saverrno = errno, savevmserrno = vaxc$errno;
- fpos_t pos;
+ SV pos;
if (fp == NULL || strchr(">was+-|",iotype) == Nullch) {
set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); XSRETURN_UNDEF;
}
- if (!fgetname(fp,filespec)) XSRETURN_UNDEF;
+ if (!PerlIO_getname(fp,filespec)) XSRETURN_UNDEF;
for (s = filespec; *s; s++) {
if (*s == ':') colon = s;
else if (*s == ']' || *s == '>') dirend = s;
/* If we've got a non-file-structured device, clip off the trailing
* junk, and don't lose sleep if we can't get a stream position. */
if (dirend == Nullch) *(colon+1) = '\0';
- if (iotype != '-' && (ret = fgetpos(fp, &pos)) == -1 && dirend)
+ if (iotype != '-' && (ret = PerlIO_getpos(fp, &pos)) == -1 && dirend)
XSRETURN_UNDEF;
switch (iotype) {
case '<': case 'r': acmode = "rb"; break;
fsetpos below will take care of restoring file position */
case 'a': acmode = "ab"; break;
case '+': case 's': acmode = "rb+"; break;
- case '-': acmode = fileno(fp) ? "ab" : "rb"; break;
+ case '-': acmode = PerlIO_fileno(fp) ? "ab" : "rb"; break;
/* iotype'll be null for the SYS$INPUT:/SYS$OUTPUT:/SYS$ERROR: files */
/* since we didn't really open them and can't really */
/* reopen them */
iotype, filespec);
acmode = "rb+";
}
- if (freopen(filespec,acmode,fp) == NULL) XSRETURN_UNDEF;
- if (iotype != '-' && ret != -1 && fsetpos(fp,&pos) == -1) XSRETURN_UNDEF;
+ /* appearances to the contrary, this is an freopen substitute */
+ SV *name = sv_2mortal(newSVpvn(filespec,strlen(filespec)));
+ if (PerlIO_openn(Nullch,acmode,-1,0,0,fp,1,&name) == Nullfp) XSRETURN_UNDEF;
+ if (iotype != '-' && ret != -1 && PerlIO_setpos(fp,&pos) == -1) XSRETURN_UNDEF;
if (ret == -1) { set_errno(saverrno); set_vaxc_errno(savevmserrno); }
XSRETURN_YES;
void
flush(fp)
- FILE * fp
+ PerlIO * fp
PROTOTYPE: $
CODE:
- if (fflush(fp)) { ST(0) = &PL_sv_undef; }
- else { clearerr(fp); ST(0) = &PL_sv_yes; }
+ FILE *stdio = PerlIO_exportFILE(fp,0);
+ if (fflush(stdio)) { ST(0) = &PL_sv_undef; }
+ else { clearerr(stdio); ST(0) = &PL_sv_yes; }
+ PerlIO_releaseFILE(fp,stdio);
char *
getname(fp)
- FILE * fp
+ PerlIO * fp
PROTOTYPE: $
CODE:
char fname[NAM$C_MAXRSS+1];
ST(0) = sv_newmortal();
- if (fgetname(fp,fname) != NULL) sv_setpv(ST(0),fname);
+ if (PerlIO_getname(fp,fname) != NULL) sv_setpv(ST(0),fname);
void
rewind(fp)
- FILE * fp
+ PerlIO * fp
PROTOTYPE: $
CODE:
- ST(0) = rewind(fp) ? &PL_sv_undef : &PL_sv_yes;
+ FILE *stdio = PerlIO_exportFILE(fp,0);
+ ST(0) = rewind(stdio) ? &PL_sv_undef : &PL_sv_yes;
+ PerlIO_releaseFILE(fp,stdio);
void
remove(name)
void
sync(fp)
- FILE * fp
+ PerlIO * fp
PROTOTYPE: $
CODE:
- if (fsync(fileno(fp))) { ST(0) = &PL_sv_undef; }
- else { clearerr(fp); ST(0) = &PL_sv_yes; }
+ FILE *stdio = PerlIO_exportFILE(fp,0);
+ if (fsync(fileno(stdio))) { ST(0) = &PL_sv_undef; }
+ else { clearerr(stdio); ST(0) = &PL_sv_yes; }
+ PerlIO_releaseFILE(fp,stdio);
char *
tmpnam()
char *args[8],mode[3] = {'r','\0','\0'}, type = '<';
register int i, myargc;
FILE *fp;
+ PerlIO *pio_fp;
STRLEN n_a;
if (!spec || !*spec) {
fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
break;
}
- if (fp != Nullfp) {
- SV *fh = newFH(fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' : (mode[0] == 'a' ? 'a' : '>'))));
+ if (fp != Null(FILE*)) {
+ pio_fp = PerlIO_importFILE(fp,0);
+ SV *fh = newFH(pio_fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' : (mode[0] == 'a' ? 'a' : '>'))));
ST(0) = (fh ? sv_2mortal(fh) : &PL_sv_undef);
}
else { ST(0) = &PL_sv_undef; }
char *args[8];
int i, myargc, fd;
FILE *fp;
+ PerlIO *pio_fp;
SV *fh;
STRLEN n_a;
if (!spec || !*spec) {
}
i = mode & 3;
if (fd >= 0 &&
- ((fp = fdopen(fd, &("r\000w\000r+"[2*i]))) != Nullfp)) {
- SV *fh = newFH(fp,"<>++"[i]);
+ ((fp = fdopen(fd, &("r\000w\000r+"[2*i]))) != Null(FILE*))) {
+ pio_fp = PerlIO_importFILE(fp,0);
+ SV *fh = newFH(pio_fp,"<>++"[i]);
ST(0) = (fh ? sv_2mortal(fh) : &PL_sv_undef);
}
else { ST(0) = &PL_sv_undef; }
void
waitfh(fp)
- FILE * fp
+ PerlIO * fp
PROTOTYPE: $
CODE:
- ST(0) = fwait(fp) ? &PL_sv_undef : &PL_sv_yes;
+ FILE *stdio = PerlIO_exportFILE(fp,0);
+ ST(0) = fwait(stdio) ? &PL_sv_undef : &PL_sv_yes;
+ PerlIO_releaseFILE(fp,stdio);
void
writeof(mysv)
unsigned long int chan, iosb[2], retsts, retsts2;
struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
IO *io = sv_2io(mysv);
- FILE *fp = io ? IoOFP(io) : NULL;
+ PerlIO *fp = io ? IoOFP(io) : NULL;
if (fp == NULL || strchr(">was+-|",IoTYPE(io)) == Nullch) {
set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); XSRETURN_UNDEF;
}
- if (fgetname(fp,devnam) == Nullch) { ST(0) = &PL_sv_undef; XSRETURN(1); }
+ if (PerlIO_getname(fp,devnam) == Nullch) { ST(0) = &PL_sv_undef; XSRETURN(1); }
if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
devdsc.dsc$w_length = strlen(devnam);
retsts = sys$assign(&devdsc,&chan,0,0);
$debug = $ENV{'GEN_SHRFLS_DEBUG'};
-print "gen_shrfls.pl Rev. 14-Dec-1997\n" if $debug;
+print "gen_shrfls.pl Rev. 18-May-2001\n" if $debug;
if ($ARGV[0] eq '-f') {
open(INP,$ARGV[1]) or die "Can't read input file $ARGV[1]: $!\n";
else { die "$0: Can't find perl.h\n"; }
$use_threads = $use_mymalloc = $case_about_case = $debugging_enabled = 0;
- $hide_mymalloc = $isgcc = 0;
+ $hide_mymalloc = $isgcc = $use_perlio = 0;
# Go see what is enabled in config.sh
$config = $dir . "config.sh";
$debugging_enabled++ if /usedebugging_perl='Y'/;
$hide_mymalloc++ if /embedmymalloc='Y'/;
$isgcc++ if /gccversion='[^']/;
+ $use_perlio++ if /useperlio='define'/;
}
close CONFIG;
my($line) = @_;
print "\tchecking for global routine\n" if $debug > 1;
+ $line =~ s/\b(IV|Off_t|Size_t|SSize_t|void)\b//i;
if ( $line =~ /(\w+)\s*\(/ ) {
print "\troutine name is \\$1\\\n" if $debug > 1;
if ($1 eq 'main' || $1 eq 'perl_init_ext') {
$fcns{'Perl_mfree'}++;
}
+if ($use_perlio) {
+ $preprocess_list = "${dir}perl.h,${dir}perliol.h";
+} else {
+ $preprocess_list = "${dir}perl.h";
+}
+
$used_expectation_enum = $used_opcode_enum = 0; # avoid warnings
if ($docc) {
- open(CPP,"${cc_cmd}/NoObj/PreProc=Sys\$Output ${dir}perl.h|")
- or die "$0: Can't preprocess ${dir}perl.h: $!\n";
+ open(CPP,"${cc_cmd}/NoObj/PreProc=Sys\$Output $preprocess_list|")
+ or die "$0: Can't preprocess $preprocess_list: $!\n";
}
else {
open(CPP,"$cpp_file") or die "$0: Can't read preprocessed file $cpp_file: $!\n";
# Pull name from library module or header filespec
$spec =~ /^(\w+)$/ or $spec =~ /(\w+)\.h/i;
my $name = lc $1;
+ $name = 'perlio' if $name eq 'perliol';
$ckfunc = exists $checkh{$name} ? 1 : 0;
$scanname = $name if $ckfunc;
print "Header file transition: ckfunc = $ckfunc for $name.h\n" if $debug > 1;
# define SS$_NOSUCHOBJECT 2696
#endif
+/* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
+#define PERLIO_NOT_STDIO 0
+
/* Don't replace system definitions of vfork, getenv, and stat,
* code below needs to get to the underlying CRTL routines. */
#define DONT_MASK_RTL_CALLS
} /* end of safe_popen */
-/*{{{ FILE *my_popen(char *cmd, char *mode)*/
-FILE *
+/*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
+PerlIO *
Perl_my_popen(pTHX_ char *cmd, char *mode)
{
TAINT_ENV();
/*}}}*/
-/*{{{ I32 my_pclose(FILE *fp)*/
-I32 Perl_my_pclose(pTHX_ FILE *fp)
+/*{{{ I32 my_pclose(PerlIO *fp)*/
+I32 Perl_my_pclose(pTHX_ PerlIO *fp)
{
pInfo info, last = NULL;
unsigned long int retsts;
* the first EOF closing the pipe (and DASSGN'ing the channel)...
*/
- fsync(fileno(info->fp)); /* first, flush data */
+ PerlIO_flush(info->fp); /* first, flush data */
_ckvmssts(sys$setast(0));
info->closing = TRUE;
/* Input from a pipe, reopen it in binary mode to disable */
/* carriage control processing. */
- PerlIO_getname(stdin, mbxname);
+ fgetname(stdin, mbxname);
mbxnam.dsc$a_pointer = mbxname;
mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
if (err != NULL) {
if (strcmp(err,"&1") == 0) {
- dup2(fileno(stdout), fileno(Perl_debug_log));
+ dup2(fileno(stdout), fileno(stderr));
Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
} else {
FILE *tmperr;
exit(vaxc$errno);
}
fclose(tmperr);
- if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
+ if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
{
exit(vaxc$errno);
}
* data with nulls sprinkled in the middle but also data with no null
* byte at the end.
*/
-/*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
+/*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
int
-my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
+my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
{
register char *cp, *end, *cpd, *data;
register unsigned int fd = fileno(dest);
mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
if (SvTYPE(mysv) == SVt_PVGV) {
- if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
+ if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
ST(0) = &PL_sv_no;
XSRETURN(1);
mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
if (SvTYPE(mysv) == SVt_PVGV) {
- if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
+ if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
ST(0) = &PL_sv_no;
XSRETURN(1);
}
mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
if (SvTYPE(mysv) == SVt_PVGV) {
- if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
+ if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
ST(0) = &PL_sv_no;
XSRETURN(1);
#define _ckvmssts_noperl(call) STMT_START { register unsigned long int __ckvms_sts; \
if (!((__ckvms_sts=(call))&1)) { \
set_errno(EVMSERR); set_vaxc_errno(__ckvms_sts); \
- fprintf(Perl_debug_log,"Fatal VMS error (status=%d) at %s, line %d", \
+ fprintf(stderr,"Fatal VMS error (status=%d) at %s, line %d", \
__ckvms_sts,__FILE__,__LINE__); lib$signal(__ckvms_sts); } } STMT_END
#ifdef VMS_DO_SOCKETS
#ifndef DONT_MASK_RTL_CALLS
+# define fwrite my_fwrite /* for PerlSIO_fwrite */
# define fdopen my_fdopen
# define fclose my_fclose
#endif
unsigned long int Perl_do_spawn (pTHX_ char *);
FILE * my_fdopen (int, const char *);
int my_fclose (FILE *);
-int my_fwrite (void *, size_t, size_t, FILE *);
+int my_fwrite (const void *, size_t, size_t, FILE *);
int Perl_my_flush (pTHX_ FILE *);
struct passwd * Perl_my_getpwnam (pTHX_ char *name);
struct passwd * Perl_my_getpwuid (pTHX_ Uid_t uid);
projects / p5sagit/p5-mst-13.2.git / commitdiff