Integrate mainline

p4raw-id: //depot/perlio@16038

diff --combined ext/Encode/Encode.pm
index cd8f91a,0bf6a24..fb80200
--- 1/ext/Encode/Encode.pm
--- 2/ext/Encode/Encode.pm
+++ b/ext/Encode/Encode.pm
@@@ -1,6 -1,6 +1,6 @@@
  package Encode;
  use strict;
- our $VERSION = do { my @r = (q$Revision: 1.51 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+ our $VERSION = do { my @r = (q$Revision: 1.52 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
  our $DEBUG = 0;
  use XSLoader ();
  XSLoader::load 'Encode';
@@@ -253,24 -253,21 +253,25 @@@ sub predefine_encodings
            $_[1] = '' if $chk;
            return $octets;
        };
 -      $Encode::Encoding{utf8} = 
 +      $Encode::Encoding{utf8} =
            bless {Name => "utf8"} => "Encode::utf8";
      }
  }
  
  require Encode::Encoding;
 +@Encode::XS::ISA = qw(Encode::Encoding);
  
 -eval { 
 +# This is very dodgy - PerlIO::encoding does "use Encode" and  _BEFORE_ it gets a
 +# chance to set its VERSION we potentially delete it from %INC so it will be re-loaded
 +# NI-S
 +eval {
      require PerlIO::encoding;
      unless (PerlIO::encoding->VERSION >= 0.02){
        delete $INC{"PerlIO/encoding.pm"};
      }
  };
  # warn $@ if $@;
+ @Encode::XS::ISA = qw(Encode::Encoding);
  
  1;
  

diff --combined ext/Encode/Encode.xs
index 0d8f80e,c208af0..992fbfe
--- 1/ext/Encode/Encode.xs
--- 2/ext/Encode/Encode.xs
+++ b/ext/Encode/Encode.xs
@@@ -1,5 -1,5 +1,5 @@@
  /*
-  $Id: Encode.xs,v 1.30 2002/04/20 09:58:23 dankogai Exp dankogai $
+  $Id: Encode.xs,v 1.31 2002/04/20 23:43:47 dankogai Exp dankogai $
   */
  
  #define PERL_NO_GET_CONTEXT
@@@ -11,11 -11,11 +11,11 @@@
  
  /* set 1 or more to profile.  t/encoding.t dumps core because of
     Perl_warner and PerlIO don't work well */
 -#define ENCODE_XS_PROFILE 0 
 +#define ENCODE_XS_PROFILE 0
  
  /* set 0 to disable floating point to calculate buffer size for
     encode_method().  1 is recommended. 2 restores NI-S original */
 -#define ENCODE_XS_USEFP   1 
 +#define ENCODE_XS_USEFP   1
  
  #define UNIMPLEMENTED(x,y) y x (SV *sv, char *encoding) {dTHX;   \
                           Perl_croak(aTHX_ "panic_unimplemented"); \
@@@ -119,40 -119,40 +119,40 @@@ encode_method(pTHX_ encode_t * enc, enc
        }
        case ENCODE_NOREP:
            /* encoding */      
 -          if (dir == enc->f_utf8) { 
 +          if (dir == enc->f_utf8) {
                STRLEN clen;
                UV ch =
 -                  utf8n_to_uvuni(s+slen, (SvCUR(src)-slen), 
 +                  utf8n_to_uvuni(s+slen, (SvCUR(src)-slen),
                                   &clen, UTF8_ALLOW_ANY|UTF8_CHECK_ONLY);
                if (check & ENCODE_DIE_ON_ERR) {
                    Perl_croak(
 -                      aTHX_ "\"\\N{U+%" UVxf "}\" does not map to %s, %d", 
 +                      aTHX_ "\"\\N{U+%" UVxf "}\" does not map to %s, %d",
                        ch, enc->name[0], __LINE__);
                }else{
                    if (check & ENCODE_RETURN_ON_ERR){
                        if (check & ENCODE_WARN_ON_ERR){
                            Perl_warner(
                                aTHX_ packWARN(WARN_UTF8),
 -                              "\"\\N{U+%" UVxf "}\" does not map to %s", 
 +                              "\"\\N{U+%" UVxf "}\" does not map to %s",
                                ch,enc->name[0]);
                        }
                                goto ENCODE_SET_SRC;
                    }else if (check & ENCODE_PERLQQ){
 -                      SV* perlqq = 
 +                      SV* perlqq =
                            sv_2mortal(newSVpvf("\\x{%04x}", ch));
                        sdone += slen + clen;
                        ddone += dlen + SvCUR(perlqq);
                        sv_catsv(dst, perlqq);
 -                  } else { 
 +                  } else {
                        /* fallback char */
                        sdone += slen + clen;
 -                      ddone += dlen + enc->replen; 
 -                      sv_catpvn(dst, (char*)enc->rep, enc->replen); 
 +                      ddone += dlen + enc->replen;
 +                      sv_catpvn(dst, (char*)enc->rep, enc->replen);
                    }                   
 -              } 
 +              }
            }
            /* decoding */
 -          else {           
 +          else {
                if (check & ENCODE_DIE_ON_ERR){
                    Perl_croak(
                        aTHX_ "%s \"\\x%02X\" does not map to Unicode (%d)",
@@@ -167,22 -167,22 +167,22 @@@
                        }
                        goto ENCODE_SET_SRC;
                    }else if (check & ENCODE_PERLQQ){
 -                      SV* perlqq = 
 +                      SV* perlqq =
                            sv_2mortal(newSVpvf("\\x%02X", s[slen]));
                        sdone += slen + 1;
                        ddone += dlen + SvCUR(perlqq);
                        sv_catsv(dst, perlqq);
                    } else {
                        sdone += slen + 1;
 -                      ddone += dlen + strlen(FBCHAR_UTF8); 
 -                      sv_catpv(dst, FBCHAR_UTF8); 
 +                      ddone += dlen + strlen(FBCHAR_UTF8);
 +                      sv_catpv(dst, FBCHAR_UTF8);
                    }
                }
            }
            /* settle variables when fallback */
            d    = (U8 *)SvEND(dst);
              dlen = SvLEN(dst) - ddone - 1;
 -          s    = (U8*)SvPVX(src) + sdone; 
 +          s    = (U8*)SvPVX(src) + sdone;
            slen = tlen - sdone;
            break;
  
@@@ -205,10 -205,10 +205,10 @@@
      if (code && !(check & ENCODE_RETURN_ON_ERR)) {
        return &PL_sv_undef;
      }
 -    
 +
      SvCUR_set(dst, dlen+ddone);
      SvPOK_only(dst);
 -    
 +
  #if ENCODE_XS_PROFILE
      if (SvCUR(dst) > SvCUR(src)){
        Perl_warn(aTHX_
@@@ -217,7 -217,7 +217,7 @@@
                  (SvLEN(dst) - SvCUR(dst))*1.0/SvLEN(dst)*100.0);
      }
  #endif
 -    
 +
   ENCODE_END:
      *SvEND(dst) = '\0';
      return dst;
@@@ -273,7 -273,7 +273,7 @@@ SV *    s
  CODE:
  {
      SV * encoding = items == 2 ? ST(1) : Nullsv;
 -    
 +
      if (encoding)
      RETVAL = _encoded_bytes_to_utf8(sv, SvPV_nolen(encoding));
      else {
@@@ -310,7 -310,7 +310,7 @@@ CODE
            /* Must do things the slow way */
            U8 *dest;
              /* We need a copy to pass to check() */
 -          U8 *src  = (U8*)savepv((char *)s); 
 +          U8 *src  = (U8*)savepv((char *)s);
            U8 *send = s + len;
  
            New(83, dest, len, U8); /* I think */
@@@ -335,8 -335,8 +335,8 @@@
                
                    /* Note change to utf8.c variable naming, for variety */
                    while (ulen--) {
 -                      if ((*s & 0xc0) != 0x80){ 
 -                          goto failure; 
 +                      if ((*s & 0xc0) != 0x80){
 +                          goto failure;
                        } else {
                            uv = (uv << 6) | (*s++ & 0x3f);
                        }
@@@ -422,7 -422,7 +422,7 @@@ CODE
  OUTPUT:
      RETVAL
  
 -int 
 +int
  WARN_ON_ERR()
  CODE:
      RETVAL = ENCODE_WARN_ON_ERR;

diff --combined ext/Encode/t/perlio.t
index 671be8a,52a161b..2efd4a8
--- 1/ext/Encode/t/perlio.t
--- 2/ext/Encode/t/perlio.t
+++ b/ext/Encode/t/perlio.t
@@@ -28,6 -28,7 +28,7 @@@ use strict
  use File::Basename;
  use File::Spec;
  use File::Compare;
+ use File::Copy;
  use FileHandle;
  
  #use Test::More qw(no_plan);
@@@ -50,28 -51,29 +51,29 @@@ open my $fh, "<:utf8", $ufile or die "$
  my @uline = <$fh>;
  my $utext = join('' => @uline);
  close $fh;
+ my $seq = 0;
  
  for my $e (qw/euc-jp shiftjis 7bit-jis iso-2022-jp iso-2022-jp-1/){
      my $sfile = File::Spec->catfile($dir,"$$.sio");
      my $pfile = File::Spec->catfile($dir,"$$.pio");
  
      # first create a file without perlio
-     open $fh, ">", $sfile or die "$sfile :$!";
-     binmode $fh;
-     print $fh &encode($e, $utext, 0);
-     close $fh;
+     dump2file($sfile, &encode($e, $utext, 0));
 -    
 +
      # then create a file via perlio without autoflush
        
- # TODO:{
- #        local $TODO = "perlio broken";
- #     todo_skip "$e: !perlio_ok", 1  unless perlio_ok($e);
+  SKIP:{
+       skip "$e: !perlio_ok", 1  unless perlio_ok($e) or $DEBUG;
        open $fh, ">:encoding($e)", $pfile or die "$sfile : $!";
        $fh->autoflush(0);
        print $fh $utext;
        close $fh;
-       ok(compare($sfile, $pfile) == 0 => ">:encoding($e)");
- #    }
+       $seq++;
+       unless (is(compare($sfile, $pfile), 0 => ">:encoding($e)")){
+           copy $sfile, "$sfile.$seq";
+           copy $pfile, "$pfile.$seq";
+       }
+     }
        
      # this time print line by line.
      # works even for ISO-2022!
@@@ -81,24 -83,43 +83,43 @@@
        print $fh $l;
      }
      close $fh;
-     is(compare($sfile, $pfile), 0 => ">:encoding($e); line-by-line");
+     $seq++;
+     unless(is(compare($sfile, $pfile), 0
+             => ">:encoding($e); by lines")){
+       copy $sfile, "$sfile.$seq";
+       copy $pfile, "$pfile.$seq";
+     }
  
- # TODO:{
- #        local $TODO = "perlio broken";
- #     todo_skip "$e: !perlio_ok", 2 unless perlio_ok($e);
+  SKIP:{
+       skip "$e: !perlio_ok", 2 unless perlio_ok($e) or $DEBUG;
        open $fh, "<:encoding($e)", $pfile or die "$pfile : $!";
        $fh->autoflush(0);
        my $dtext = join('' => <$fh>);
        close $fh;
-       ok($utext eq $dtext, "<:encoding($e)");
+       $seq++;
+       unless(ok($utext eq $dtext, "<:encoding($e)")){
+           dump2file("$sfile.$seq", $utext);
+           dump2file("$pfile.$seq", $dtext);
+       }
        $dtext = '';
        open $fh, "<:encoding($e)", $pfile or die "$pfile : $!";
        while(defined(my $l = <$fh>)) {
            $dtext .= $l;
        }
        close $fh;
-       ok($utext eq $dtext, "<:encoding($e); line-by-line");
- #    }
+       $seq++;
+       unless (ok($utext eq $dtext,  "<:encoding($e); by lines")) {
+           dump2file("$sfile.$seq", $utext);
+           dump2file("$pfile.$seq", $dtext);
+       }
+     }
      $DEBUG or unlink ($sfile, $pfile);
  }
  
+ sub dump2file{
+     no warnings;
+     open my $fh, ">", $_[0] or die "$_[0]: $!";
+     binmode $fh;
+     print $fh $_[1];
+     close $fh;
+ }

diff --combined perl.h
index 98b7dfa,920bd3c..15360d1
--- 1/perl.h
--- 2/perl.h
+++ b/perl.h
@@@ -449,7 -449,7 +449,7 @@@ int usleep(unsigned int)
  #  define MYSWAP
  #endif
  
 -/* Cannot include embed.h here on Win32 as win32.h has not 
 +/* Cannot include embed.h here on Win32 as win32.h has not
     yet been included and defines some config variables e.g. HAVE_INTERP_INTERN
   */
  #if !defined(PERL_FOR_X2P) && !(defined(WIN32)||defined(VMS))
@@@ -2279,6 -2279,12 +2279,12 @@@ struct ptr_tbl 
  #  define htovs(x)    vtohs(x)
  # endif
        /* otherwise default to functions in util.c */
+ #ifndef htovs
+ short htovs(short n);
+ short vtohs(short n);
+ long htovl(long n);
+ long vtohl(long n);
+ #endif
  #endif
  
  /* *MAX Plus 1. A floating point value.
@@@ -3742,6 -3748,9 +3748,9 @@@ typedef struct am_table_short AMTS
  #    ifdef __hpux
  #        define strtoll __strtoll     /* secret handshake */
  #    endif
+ #    ifdef WIN64
+ #        define strtoll _strtoi64     /* secret handshake */
+ #    endif
  #   if !defined(Strtol) && defined(HAS_STRTOLL)
  #       define Strtol strtoll
  #   endif
@@@ -3758,6 -3767,9 +3767,9 @@@
   * (as is done for Atoul(), see below) but for backward compatibility
   * we just assume atol(). */
  #   if defined(USE_64_BIT_INT) && defined(IV_IS_QUAD) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_ATOLL)
+ #    ifdef WIN64
+ #       define atoll    _atoi64               /* secret handshake */
+ #    endif
  #       define Atol   atoll
  #   else
  #       define Atol   atol
@@@ -3768,6 -3780,9 +3780,9 @@@
  #    ifdef __hpux
  #        define strtoull __strtoull   /* secret handshake */
  #    endif
+ #    ifdef WIN64
+ #        define strtoull _strtoui64   /* secret handshake */
+ #    endif
  #    if !defined(Strtoul) && defined(HAS_STRTOULL)
  #       define Strtoul        strtoull
  #    endif