Integrate perlio:

[  8026]
Various oddities p4 diff -se showed up
Remove 'our' from warnings.pl

[  8025]
Change PerlIO_(get|set)pos to take SV *
Should fix, OS/2, VMS, (sfio??)

p4raw-link: @8026 on //depot/perlio: 0ca4541c317eb395329cac582e39db540241d553
p4raw-link: @8025 on //depot/perlio: 766a733e849204725c27391cf2992d649af4aba6

p4raw-id: //depot/perl@8029

9 files changed, 126 insertions, 82 deletions

diff --git a/ext/IO/IO.xs b/ext/IO/IO.xs
index 6da48dca15..13b198cc71 100644
--- a/ext/IO/IO.xs
+++ b/ext/IO/IO.xs
@@ -59,9 +59,9 @@ io_blocking(InputStream f, int block)
     if (RETVAL >= 0) {
 	int mode = RETVAL;
 #ifdef O_NONBLOCK
-	/* POSIX style */ 
+	/* POSIX style */
 #if defined(O_NDELAY) && O_NDELAY != O_NONBLOCK
-	/* Ooops has O_NDELAY too - make sure we don't 
+	/* Ooops has O_NDELAY too - make sure we don't
 	 * get SysV behaviour by mistake. */
 
 	/* E.g. In UNICOS and UNICOS/mk a F_GETFL returns an O_NDELAY
@@ -86,7 +86,7 @@ io_blocking(InputStream f, int block)
               }
 	}
 #else
-	/* Standard POSIX */ 
+	/* Standard POSIX */
 	RETVAL = RETVAL & O_NONBLOCK ? 0 : 1;
 
 	if ((block == 0) && !(mode & O_NONBLOCK)) {
@@ -103,11 +103,11 @@ io_blocking(InputStream f, int block)
 	    if(ret < 0)
 		RETVAL = ret;
 	 }
-#endif 
+#endif
 #else
 	/* Not POSIX - better have O_NDELAY or we can't cope.
 	 * for BSD-ish machines this is an acceptable alternative
-	 * for SysV we can't tell "would block" from EOF but that is 
+	 * for SysV we can't tell "would block" from EOF but that is
 	 * the way SysV is...
 	 */
 	RETVAL = RETVAL & O_NDELAY ? 0 : 1;
@@ -141,18 +141,18 @@ fgetpos(handle)
 	InputStream	handle
     CODE:
 	if (handle) {
-	    Fpos_t pos;
-	    if (
 #ifdef PerlIO
-		PerlIO_getpos(handle, &pos)
+	    ST(0) = sv_2mortal(newSV(0));
+	    if (PerlIO_getpos(handle, ST(0)) != 0) {
+		ST(0) = &PL_sv_undef;
+	    }
 #else
-		fgetpos(handle, &pos)
-#endif
-		) {
+	    if (fgetpos(handle, &pos)) {
 		ST(0) = &PL_sv_undef;
 	    } else {
 		ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t)));
 	    }
+#endif
 	}
 	else {
 	    ST(0) = &PL_sv_undef;
@@ -164,14 +164,21 @@ fsetpos(handle, pos)
 	InputStream	handle
 	SV *		pos
     CODE:
-        char *p;
-	STRLEN len;
-	if (handle && (p = SvPV(pos,len)) && len == sizeof(Fpos_t))
+	if (handle) {
 #ifdef PerlIO
-	    RETVAL = PerlIO_setpos(handle, (Fpos_t*)p);
+	    RETVAL = PerlIO_setpos(handle, pos);
 #else
-	    RETVAL = fsetpos(handle, (Fpos_t*)p);
+	    char *p;
+	    STRLEN len;
+	    if ((p = SvPV(pos,len)) && len == sizeof(Fpos_t)) {
+		RETVAL = fsetpos(handle, (Fpos_t*)p);
+	    }
+	    else {
+		RETVAL = -1;
+		errno = EINVAL;
+	    }
 #endif
+	}
 	else {
 	    RETVAL = -1;
 	    errno = EINVAL;
@@ -207,7 +214,7 @@ new_tmpfile(packname = "IO::File")
 
 MODULE = IO	PACKAGE = IO::Poll
 
-void   
+void
 _poll(timeout,...)
 	int timeout;
 PPCODE:
diff --git a/fakesdio.h b/fakesdio.h
index 374087f5a8..479123242f 100644
--- a/fakesdio.h
+++ b/fakesdio.h
@@ -71,9 +71,7 @@
 #define fread(b,s,c,f)		_CANNOT fread
 #define fwrite(b,s,c,f)		_CANNOT fwrite
 #endif
-#define fgetpos(f,p)		PerlIO_getpos(f,p)
 #define fseek(f,o,w)		PerlIO_seek(f,o,w)
-#define fsetpos(f,p)		PerlIO_setpos(f,p)
 #define ftell(f)		PerlIO_tell(f)
 #define rewind(f)		PerlIO_rewind(f)
 #define clearerr(f)		PerlIO_clearerr(f)
@@ -84,6 +82,9 @@
 #define popen(c,m)		my_popen(c,m)
 #define pclose(f)		my_pclose(f)
 
+#define fsetpos(f,p)		_CANNOT _fsetpos_
+#define fgetpos(f,p)		_CANNOT _fgetpos_
+
 #define __filbuf(f)		_CANNOT __filbuf_
 #define _filbuf(f)		_CANNOT _filbuf_
 #define __flsbuf(c,f)		_CANNOT __flsbuf_
diff --git a/global.sym b/global.sym
index b5c367d651..7ca196bc1e 100644
--- a/global.sym
+++ b/global.sym
@@ -444,6 +444,7 @@ Perl_sv_taint
 Perl_sv_tainted
 Perl_sv_unmagic
 Perl_sv_unref
+Perl_sv_unref_flags
 Perl_sv_untaint
 Perl_sv_upgrade
 Perl_sv_usepvn
@@ -529,6 +530,7 @@ Perl_sv_utf8_downgrade
 Perl_sv_utf8_encode
 Perl_sv_utf8_decode
 Perl_sv_force_normal
+Perl_sv_force_normal_flags
 Perl_tmps_grow
 Perl_sv_rvweaken
 Perl_newANONATTRSUB
diff --git a/lib/warnings.pm b/lib/warnings.pm
index 2517239365..e3416419fd 100644
--- a/lib/warnings.pm
+++ b/lib/warnings.pm
@@ -5,6 +5,8 @@
 
 package warnings;
 
+our $VERSION = '1.00';
+
 =head1 NAME
 
 warnings - Perl pragma to control optional warnings
@@ -39,7 +41,7 @@ warnings - Perl pragma to control optional warnings
 If no import list is supplied, all possible warnings are either enabled
 or disabled.
 
-A number of functions are provided to assist module authors. 
+A number of functions are provided to assist module authors.
 
 =over 4
 
@@ -295,7 +297,7 @@ sub bits {
 	    $mask |= $DeadBits{$word} if $fatal ;
 	}
 	else
-          { croak("unknown warnings category '$word'")}  
+          { croak("unknown warnings category '$word'")}
     }
 
     return $mask ;
@@ -341,13 +343,13 @@ sub __chk
 	    unless defined $offset;
     }
     else {
-        $category = (caller(1))[0] ; 
+        $category = (caller(1))[0] ;
         $offset = $Offsets{$category};
         croak("package '$category' not registered for warnings")
 	    unless defined $offset ;
     }
 
-    my $this_pkg = (caller(1))[0] ; 
+    my $this_pkg = (caller(1))[0] ;
     my $i = 2 ;
     my $pkg ;
 
@@ -361,11 +363,11 @@ sub __chk
         for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
             last if $pkg ne $this_pkg ;
         }
-        $i = 2 
+        $i = 2
             if !$pkg || $pkg eq $this_pkg ;
     }
 
-    my $callers_bitmask = (caller($i))[9] ; 
+    my $callers_bitmask = (caller($i))[9] ;
     return ($callers_bitmask, $offset, $i) ;
 }
 
@@ -390,7 +392,7 @@ sub warn
     my $message = pop ;
     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
     local $Carp::CarpLevel = $i ;
-    croak($message) 
+    croak($message)
 	if vec($callers_bitmask, $offset+1, 1) ||
 	   vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
     carp($message) ;
@@ -405,12 +407,12 @@ sub warnif
     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
     local $Carp::CarpLevel = $i ;
 
-    return 
+    return
         unless defined $callers_bitmask &&
             	(vec($callers_bitmask, $offset, 1) ||
             	vec($callers_bitmask, $Offsets{'all'}, 1)) ;
 
-    croak($message) 
+    croak($message)
 	if vec($callers_bitmask, $offset+1, 1) ||
 	   vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 
diff --git a/perlapi.c b/perlapi.c
index 4f3497e4fd..e2df18e1ff 100644
--- a/perlapi.c
+++ b/perlapi.c
@@ -3227,6 +3227,13 @@ Perl_sv_unref(pTHXo_ SV* sv)
     ((CPerlObj*)pPerl)->Perl_sv_unref(sv);
 }
 
+#undef  Perl_sv_unref_flags
+void
+Perl_sv_unref_flags(pTHXo_ SV* sv, U32 flags)
+{
+    ((CPerlObj*)pPerl)->Perl_sv_unref_flags(sv, flags);
+}
+
 #undef  Perl_sv_untaint
 void
 Perl_sv_untaint(pTHXo_ SV* sv)
@@ -3868,6 +3875,13 @@ Perl_sv_force_normal(pTHXo_ SV *sv)
     ((CPerlObj*)pPerl)->Perl_sv_force_normal(sv);
 }
 
+#undef  Perl_sv_force_normal_flags
+void
+Perl_sv_force_normal_flags(pTHXo_ SV *sv, U32 flags)
+{
+    ((CPerlObj*)pPerl)->Perl_sv_force_normal_flags(sv, flags);
+}
+
 #undef  Perl_tmps_grow
 void
 Perl_tmps_grow(pTHXo_ I32 n)
diff --git a/perlio.c b/perlio.c
index 10989b93fa..3d7f2c18fd 100644
--- a/perlio.c
+++ b/perlio.c
@@ -233,7 +233,7 @@ PerlIO_allocate(pTHX)
  if (!f)
   {
    return NULL;
-  } 
+  }
  *last = f;
  return f+1;
 }
@@ -312,7 +312,7 @@ PerlIO_find_layer(const char *name, STRLEN len)
  dTHX;
  SV **svp;
  SV *sv;
- if (len <= 0)
+ if ((SSize_t) len <= 0)
   len = strlen(name);
  svp  = hv_fetch(PerlIO_layer_hv,name,len,0);
  if (svp && (sv = *svp) && SvROK(sv))
@@ -637,7 +637,7 @@ PerlIO_fdupopen(pTHX_ PerlIO *f)
    Off_t posn = PerlIO_tell(f);
    PerlIO_seek(new,posn,SEEK_SET);
   }
- return new; 
+ return new;
 }
 
 #undef PerlIO_close
@@ -926,7 +926,7 @@ PerlIO_modestr(PerlIO *f,char *buf)
     {
      *s++ = '+';
     }
-  } 
+  }
  else if (flags & PERLIO_F_CANREAD)
   {
    *s++ = 'r';
@@ -1292,6 +1292,7 @@ Off_t
 PerlIOUnix_tell(PerlIO *f)
 {
  dTHX;
+ Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
  return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
 }
 
@@ -1361,20 +1362,19 @@ PerlIOStdio_fileno(PerlIO *f)
  return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
 }
 
-const char *
+char *
 PerlIOStdio_mode(const char *mode,char *tmode)
 {
- const char *ret = mode;
+ char *ret = tmode;
+ while (*mode)
+  {
+   *tmode++ = *mode++;
+  }
  if (O_BINARY != O_TEXT)
   {
-   ret = (const char *) tmode;
-   while (*mode)
-    {
-     *tmode++ = *mode++;
-    }
    *tmode++ = 'b';
-   *tmode = '\0';
   }
+ *tmode = '\0';
  return ret;
 }
 
@@ -3142,47 +3142,70 @@ PerlIO_tmpfile(void)
 #ifndef HAS_FSETPOS
 #undef PerlIO_setpos
 int
-PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
+PerlIO_setpos(PerlIO *f, SV *pos)
 {
- return PerlIO_seek(f,*pos,0);
+ dTHX;
+ if (SvOK(pos))
+  {
+   STRLEN len;
+   Off_t *posn = (Off_t *) SvPV(pos,len);
+   if (f && len == sizeof(Off_t))
+    return PerlIO_seek(f,*posn,SEEK_SET);
+  }
+ errno = EINVAL;
+ return -1;
 }
 #else
-#ifndef PERLIO_IS_STDIO
 #undef PerlIO_setpos
 int
-PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
+PerlIO_setpos(PerlIO *f, SV *pos)
 {
+ dTHX;
+ if (SvOK(pos))
+  {
+   STRLEN len;
+   Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
+   if (f && len == sizeof(Fpos_t))
+    {
 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
- return fsetpos64(f, pos);
+     return fsetpos64(f, fpos);
 #else
- return fsetpos(f, pos);
+     return fsetpos(f, fpos);
 #endif
+    }
+  }
+ errno = EINVAL;
+ return -1;
 }
 #endif
-#endif
 
 #ifndef HAS_FGETPOS
 #undef PerlIO_getpos
 int
-PerlIO_getpos(PerlIO *f, Fpos_t *pos)
+PerlIO_getpos(PerlIO *f, SV *pos)
 {
- *pos = PerlIO_tell(f);
- return *pos == -1 ? -1 : 0;
+ dTHX;
+ Off_t posn = PerlIO_tell(f);
+ sv_setpvn(pos,(char *)&posn,sizeof(posn));
+ return (posn == (Off_t)-1) ? -1 : 0;
 }
 #else
-#ifndef PERLIO_IS_STDIO
 #undef PerlIO_getpos
 int
-PerlIO_getpos(PerlIO *f, Fpos_t *pos)
+PerlIO_getpos(PerlIO *f, SV *pos)
 {
+ dTHX;
+ Fpos_t fpos;
+ int code;
 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
- return fgetpos64(f, pos);
+ code = fgetpos64(f, &fpos);
 #else
- return fgetpos(f, pos);
+ code = fgetpos(f, &fpos);
 #endif
+ sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
+ return code;
 }
 #endif
-#endif
 
 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
 
diff --git a/perlio.h b/perlio.h
index 574b741c79..7d4cdcd2dc 100644
--- a/perlio.h
+++ b/perlio.h
@@ -299,10 +299,10 @@ extern PerlIO *	PerlIO_stdout		(void);
 extern PerlIO *	PerlIO_stderr		(void);
 #endif
 #ifndef PerlIO_getpos
-extern int	PerlIO_getpos		(PerlIO *,Fpos_t *);
+extern int	PerlIO_getpos		(PerlIO *,SV *);
 #endif
 #ifndef PerlIO_setpos
-extern int	PerlIO_setpos		(PerlIO *,const Fpos_t *);
+extern int	PerlIO_setpos		(PerlIO *,SV *);
 #endif
 #ifndef PerlIO_fdupopen
 extern PerlIO *	PerlIO_fdupopen		(pTHX_ PerlIO *);
diff --git a/perlsdio.h b/perlsdio.h
index aaedec4541..fd990c06d8 100644
--- a/perlsdio.h
+++ b/perlsdio.h
@@ -60,12 +60,6 @@
 #else
 #  define PerlIO_seek(f,o,w)		fseek(f,o,w)
 #endif
-#ifdef HAS_FGETPOS
-#define PerlIO_getpos(f,p)		fgetpos(f,p)
-#endif
-#ifdef HAS_FSETPOS
-#define PerlIO_setpos(f,p)		fsetpos(f,p)
-#endif
 
 #define PerlIO_rewind(f)		rewind(f)
 #define PerlIO_tmpfile()		tmpfile()
diff --git a/warnings.pl b/warnings.pl
index be520ee146..3a5037d40d 100644
--- a/warnings.pl
+++ b/warnings.pl
@@ -1,6 +1,7 @@
 #!/usr/bin/perl
 
-our $VERSION = '1.00';
+
+$VERSION = '1.00';
 
 BEGIN {
   push @INC, './lib';
@@ -106,7 +107,7 @@ sub mkRange
 
 
     for ($i = 1 ; $i < @a; ++ $i) {
-      	$out[$i] = ".." 
+      	$out[$i] = ".."
           if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
     }
 
@@ -132,9 +133,9 @@ sub printTree
 	print $prefix . "|\n" ;
 	print $prefix . "+- $k" ;
 	if (ref $v)
-	{ 
+	{
 	    print " " . "-" x ($max - length $k ) . "+\n" ;
-	    printTree ($v, $prefix . "|" , $max + $indent - 1) 
+	    printTree ($v, $prefix . "|" , $max + $indent - 1)
 	}
 	else
 	  { print "\n" }
@@ -291,9 +292,9 @@ foreach $k (sort keys  %list) {
     my $v = $list{$k} ;
     my @list = sort { $a <=> $b } @$v ;
 
-    print PM tab(4, "    '$k'"), '=> "', 
-		# mkHex($warn_size, @list), 
-		mkHex($warn_size, map $_ * 2 , @list), 
+    print PM tab(4, "    '$k'"), '=> "',
+		# mkHex($warn_size, @list),
+		mkHex($warn_size, map $_ * 2 , @list),
 		'", # [', mkRange(@list), "]\n" ;
 }
 
@@ -305,9 +306,9 @@ foreach $k (sort keys  %list) {
     my $v = $list{$k} ;
     my @list = sort { $a <=> $b } @$v ;
 
-    print PM tab(4, "    '$k'"), '=> "', 
-		# mkHex($warn_size, @list), 
-		mkHex($warn_size, map $_ * 2 + 1 , @list), 
+    print PM tab(4, "    '$k'"), '=> "',
+		# mkHex($warn_size, @list),
+		mkHex($warn_size, map $_ * 2 + 1 , @list),
 		'", # [', mkRange(@list), "]\n" ;
 }
 
@@ -365,7 +366,7 @@ warnings - Perl pragma to control optional warnings
 If no import list is supplied, all possible warnings are either enabled
 or disabled.
 
-A number of functions are provided to assist module authors. 
+A number of functions are provided to assist module authors.
 
 =over 4
 
@@ -469,7 +470,7 @@ sub bits {
 	    $mask |= $DeadBits{$word} if $fatal ;
 	}
 	else
-          { croak("unknown warnings category '$word'")}  
+          { croak("unknown warnings category '$word'")}
     }
 
     return $mask ;
@@ -515,13 +516,13 @@ sub __chk
 	    unless defined $offset;
     }
     else {
-        $category = (caller(1))[0] ; 
+        $category = (caller(1))[0] ;
         $offset = $Offsets{$category};
         croak("package '$category' not registered for warnings")
 	    unless defined $offset ;
     }
 
-    my $this_pkg = (caller(1))[0] ; 
+    my $this_pkg = (caller(1))[0] ;
     my $i = 2 ;
     my $pkg ;
 
@@ -535,11 +536,11 @@ sub __chk
         for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
             last if $pkg ne $this_pkg ;
         }
-        $i = 2 
+        $i = 2
             if !$pkg || $pkg eq $this_pkg ;
     }
 
-    my $callers_bitmask = (caller($i))[9] ; 
+    my $callers_bitmask = (caller($i))[9] ;
     return ($callers_bitmask, $offset, $i) ;
 }
 
@@ -564,7 +565,7 @@ sub warn
     my $message = pop ;
     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
     local $Carp::CarpLevel = $i ;
-    croak($message) 
+    croak($message)
 	if vec($callers_bitmask, $offset+1, 1) ||
 	   vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
     carp($message) ;
@@ -579,12 +580,12 @@ sub warnif
     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
     local $Carp::CarpLevel = $i ;
 
-    return 
+    return
         unless defined $callers_bitmask &&
             	(vec($callers_bitmask, $offset, 1) ||
             	vec($callers_bitmask, $Offsets{'all'}, 1)) ;
 
-    croak($message) 
+    croak($message)
 	if vec($callers_bitmask, $offset+1, 1) ||
 	   vec($callers_bitmask, $Offsets{'all'}+1, 1) ;