This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate perlio:
authorJarkko Hietaniemi <jhi@iki.fi>
Sat, 12 Jan 2002 16:14:52 +0000 (16:14 +0000)
committerJarkko Hietaniemi <jhi@iki.fi>
Sat, 12 Jan 2002 16:14:52 +0000 (16:14 +0000)
[ 14214]
Win32-ize socketpair test
- Win32 can fork even though $Config{d_fork} is undef
- SOCK_DGRAM does not work - skip those tests.

[ 14213]
Abstract out the cloning of SvPVX and handle shared pv in a
safe (if suboptimal) manner. Does not fix op/fork.t :-(

p4raw-link: @14214 on //depot/perlio: 26bf1728b5f258bdc26021f9eb583c46488b8859
p4raw-link: @14213 on //depot/perlio: 83841fad1c8ce4928a4239052849bad556adb3d3

p4raw-id: //depot/perl@14218

41 files changed:
MANIFEST
doop.c
embed.fnc
ext/B/B.pm
ext/B/B.xs
ext/B/B/C.pm
ext/B/C/C.xs [new file with mode: 0644]
ext/B/C/Makefile.PL [new file with mode: 0644]
ext/B/t/concise.t
ext/Unicode/Normalize/mkheader
global.sym
hints/vos.sh
lib/CGI.pm
lib/CGI/Carp.pm
lib/CGI/t/form.t
lib/ExtUtils/MM_Unix.pm
makedef.pl
perl.h
pod/perldelta.pod
pod/perldiag.pod
pod/perlfaq.pod
pod/perlfaq1.pod
pod/perlfaq2.pod
pod/perlfaq3.pod
pod/perlfaq4.pod
pod/perlfaq5.pod
pod/perlfaq8.pod
pod/perlunicode.pod
pp.c
regexec.c
sv.c
t/TEST
t/lib/warnings/pp
t/op/hashwarn.t
t/op/pat.t
t/op/unisprintf.t [new file with mode: 0644]
t/op/utf8decode.t [changed mode: 0755->0644]
t/run/kill_perl.t
t/test.pl
utils/perlcc.PL
utils/perldoc.PL

index 5d4fa34..66a265b 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -82,6 +82,8 @@ ext/B/B/Stackobj.pm   Compiler stack objects support functions
 ext/B/B/Stash.pm       Compiler module to identify stashes
 ext/B/B/Terse.pm       Compiler Terse backend
 ext/B/B/Xref.pm                Compiler Xref backend
+ext/B/C/C.xs           Compiler C backend external subroutines
+ext/B/C/Makefile.PL    Compiler C backend makefile writer
 ext/B/defsubs_h.PL     Generator for constant subroutines
 ext/B/Makefile.PL      Compiler backend makefile writer
 ext/B/NOTES            Compiler backend notes
@@ -2332,6 +2334,7 @@ t/op/time.t                       See if time functions work
 t/op/tr.t                      See if tr works
 t/op/undef.t                   See if undef works
 t/op/unifold.t                 See if Unicode folding works
+t/op/unisprintf.t              See if Unicode sprintf works
 t/op/universal.t               See if UNIVERSAL class works
 t/op/unshift.t                 See if unshift works
 t/op/utf8decode.t              See if UTF-8 decoding works
diff --git a/doop.c b/doop.c
index 9f0fa64..8b02034 100644 (file)
--- a/doop.c
+++ b/doop.c
@@ -697,6 +697,9 @@ Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg)
     char *pat = SvPV(*sarg, patlen);
     bool do_taint = FALSE;
 
+    SvUTF8_off(sv);
+    if (DO_UTF8(*sarg))
+        SvUTF8_on(sv);
     sv_vsetpvfn(sv, pat, patlen, Null(va_list*), sarg + 1, len - 1, &do_taint);
     SvSETMAGIC(sv);
     if (do_taint)
index e534f52..729f914 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -556,7 +556,7 @@ Apd |I32    |call_argv      |const char* sub_name|I32 flags|char** argv
 Apd    |I32    |call_method    |const char* methname|I32 flags
 Apd    |I32    |call_pv        |const char* sub_name|I32 flags
 Apd    |I32    |call_sv        |SV* sv|I32 flags
-     |void   |despatch_signals
+Ap     |void   |despatch_signals
 Apd    |SV*    |eval_pv        |const char* p|I32 croak_on_error
 Apd    |I32    |eval_sv        |SV* sv|I32 flags
 Apd    |SV*    |get_sv         |const char* name|I32 create
index 90d3ff5..46c834a 100644 (file)
@@ -21,7 +21,7 @@ require Exporter;
                amagic_generation
                walkoptree_slow walkoptree walkoptree_exec walksymtable
                parents comppadlist sv_undef compile_stats timing_info
-               begin_av init_av end_av);
+               begin_av init_av end_av regex_padav);
 
 sub OPf_KIDS ();
 use strict;
@@ -411,6 +411,11 @@ string using the length and offset information in the struct:
 for ordinary scalars it will return the string that you'd see
 from Perl, even if it contains null characters.
 
+=item RV
+
+Same as B::RV::RV, except that it will die() if the PV isn't
+a reference.
+
 =item PVX
 
 This method is less often useful. It assumes that the string
@@ -440,6 +445,10 @@ are always stored with a null terminator, and the length field
 
 =item MOREMAGIC
 
+=item precomp
+
+Only valid on r-magic, returns the string that generated the regexp.
+
 =item PRIVATE
 
 =item TYPE
@@ -448,8 +457,15 @@ are always stored with a null terminator, and the length field
 
 =item OBJ
 
+Will die() if called on r-magic.
+
 =item PTR
 
+=item REGEX
+
+Only valid on r-magic, returns the integer value of the REGEX stored
+in the MAGIC.
+
 =back
 
 =head2 B::PVLV METHODS
@@ -565,6 +581,13 @@ If you're working with globs at runtime, and need to disambiguate
 
 =item IoFLAGS
 
+=item IsSTD
+
+Takes one arguments ( 'stdin' | 'stdout' | 'stderr' ) and returns true
+if the IoIFP of the object is equal to the handle whose name was
+passed as argument ( i.e. $io->IsSTD('stderr') is true if
+IoIFP($io) == PerlIO_stdin() ).
+
 =back
 
 =head2 B::AV METHODS
@@ -607,6 +630,8 @@ If you're working with globs at runtime, and need to disambiguate
 
 =item XSUBANY
 
+For constant subroutines, returns the constant SV returned by the subroutine.
+
 =item CvFLAGS
 
 =item const_sv
@@ -723,10 +748,16 @@ This returns the op description from the global C PL_op_desc array
 
 =item pmflags
 
+=item pmdynflags
+
 =item pmpermflags
 
 =item precomp
 
+=item pmoffet
+
+Only when perl was compiled with ithreads.
+
 =back
 
 =head2 B::SVOP METHOD
@@ -802,6 +833,14 @@ program.
 
 Returns the AV object (i.e. in class B::AV) representing INIT blocks.
 
+=item begin_av
+
+Returns the AV object (i.e. in class B::AV) representing BEGIN blocks.
+
+=item end_av
+
+Returns the AV object (i.e. in class B::AV) representing END blocks.
+
 =item main_root
 
 Returns the root op (i.e. an object in the appropriate B::OP-derived
@@ -815,6 +854,10 @@ Returns the starting op of the main part of the Perl program.
 
 Returns the AV object (i.e. in class B::AV) of the global comppadlist.
 
+=item regex_padav
+
+Only when perl was compiled with ithreads.
+
 =item sv_undef
 
 Returns the SV object corresponding to the C variable C<sv_undef>.
index f18efce..c9ca8b1 100644 (file)
@@ -410,6 +410,9 @@ BOOT:
 #define B_sv_undef()   &PL_sv_undef
 #define B_sv_yes()     &PL_sv_yes
 #define B_sv_no()      &PL_sv_no
+#ifdef USE_ITHREADS
+#define B_regex_padav()        PL_regex_padav
+#endif
 
 B::AV
 B_init_av()
@@ -420,6 +423,13 @@ B_begin_av()
 B::AV
 B_end_av()
 
+#ifdef USE_ITHREADS
+
+B::AV
+B_regex_padav()
+
+#endif
+
 B::CV
 B_main_cv()
 
@@ -677,8 +687,12 @@ LISTOP_children(o)
 #define PMOP_pmreplstart(o)    o->op_pmreplstart
 #define PMOP_pmnext(o)         o->op_pmnext
 #define PMOP_pmregexp(o)       PM_GETRE(o)
+#ifdef USE_ITHREADS
+#define PMOP_pmoffset(o)       o->op_pmoffset
+#endif
 #define PMOP_pmflags(o)                o->op_pmflags
 #define PMOP_pmpermflags(o)    o->op_pmpermflags
+#define PMOP_pmdynflags(o)      o->op_pmdynflags
 
 MODULE = B     PACKAGE = B::PMOP               PREFIX = PMOP_
 
@@ -691,9 +705,13 @@ PMOP_pmreplroot(o)
        root = o->op_pmreplroot;
        /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
        if (o->op_type == OP_PUSHRE) {
+#ifdef USE_ITHREADS
+            sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
+#else
            sv_setiv(newSVrv(ST(0), root ?
                             svclassnames[SvTYPE((SV*)root)] : "B::SV"),
                     PTR2IV(root));
+#endif
        }
        else {
            sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root));
@@ -707,6 +725,14 @@ B::PMOP
 PMOP_pmnext(o)
        B::PMOP         o
 
+#ifdef USE_ITHREADS
+
+IV
+PMOP_pmoffset(o)
+       B::PMOP         o
+
+#endif
+
 U16
 PMOP_pmflags(o)
        B::PMOP         o
@@ -715,6 +741,10 @@ U16
 PMOP_pmpermflags(o)
        B::PMOP         o
 
+U8
+PMOP_pmdynflags(o)
+        B::PMOP         o
+
 void
 PMOP_precomp(o)
        B::PMOP         o
@@ -943,7 +973,7 @@ SvPV(sv)
        B::PV   sv
     CODE:
         ST(0) = sv_newmortal();
-        if( SvPOK(sv) ) {
+        if( SvPOK(sv) ) { 
             sv_setpvn(ST(0), SvPVX(sv), SvCUR(sv));
             SvFLAGS(ST(0)) |= SvUTF8(sv);
         }
@@ -983,6 +1013,7 @@ SvSTASH(sv)
 #define MgFLAGS(mg) mg->mg_flags
 #define MgOBJ(mg) mg->mg_obj
 #define MgLENGTH(mg) mg->mg_len
+#define MgREGEX(mg) ((IV)(mg->mg_obj))
 
 MODULE = B     PACKAGE = B::MAGIC      PREFIX = Mg     
 
@@ -1015,6 +1046,19 @@ MgOBJ(mg)
     OUTPUT:
         RETVAL
 
+IV
+MgREGEX(mg)
+       B::MAGIC        mg
+    CODE:
+        if( mg->mg_type == 'r' ) {
+            RETVAL = MgREGEX(mg);
+        }
+        else {
+            croak( "REGEX is only meaningful on r-magic" );
+        }
+    OUTPUT:
+        RETVAL
+
 SV*
 precomp(mg)
         B::MAGIC        mg
index fd7c1a9..f1019f0 100644 (file)
@@ -37,26 +37,67 @@ sub output
  my ($section, $fh, $format) = @_;
  my $sym = $section->symtable || {};
  my $default = $section->default;
+ my $i;
  foreach (@{$section->[-1]{values}})
   {
    s{(s\\_[0-9a-f]+)}{ exists($sym->{$1}) ? $sym->{$1} : $default; }ge;
-   printf $fh $format, $_;
+   printf $fh $format, $_, $i;
+   ++$i;
   }
 }
 
 package B::C::InitSection;
 
-use vars qw(@ISA); @ISA = qw(B::C::Section);
+# avoid use vars
+@B::C::InitSection::ISA = qw(B::C::Section);
 
 sub new {
     my $class = shift;
+    my $max_lines = 10000; #pop;
     my $section = $class->SUPER::new( @_ );
 
     $section->[-1]{evals} = [];
+    $section->[-1]{chunks} = [];
+    $section->[-1]{nosplit} = 0;
+    $section->[-1]{current} = [];
+    $section->[-1]{count} = 0;
+    $section->[-1]{max_lines} = $max_lines;
 
     return $section;
 }
 
+sub split {
+    my $section = shift;
+    $section->[-1]{nosplit}--
+      if $section->[-1]{nosplit} > 0;
+}
+
+sub no_split {
+    shift->[-1]{nosplit}++;
+}
+
+sub inc_count {
+    my $section = shift;
+
+    $section->[-1]{count} += $_[0];
+    # this is cheating
+    $section->add();
+}
+
+sub add {
+    my $section = shift->[-1];
+    my $current = $section->{current};
+    my $nosplit = $section->{nosplit};
+
+    push @$current, @_;
+    $section->{count} += scalar(@_);
+    if( !$nosplit && $section->{count} >= $section->{max_lines} ) {
+        push @{$section->{chunks}}, $current;
+        $section->{current} = [];
+        $section->{count} = 0;
+    }
+}
+
 sub add_eval {
     my $section = shift;
     my @strings = @_;
@@ -68,24 +109,63 @@ sub add_eval {
 }
 
 sub output {
-    my $section = shift;
+    my( $section, $fh, $format, $init_name ) = @_;
+    my $sym = $section->symtable || {};
+    my $default = $section->default;
+    push @{$section->[-1]{chunks}}, $section->[-1]{current};
+
+    my $name = "aaaa";
+    foreach my $i ( @{$section->[-1]{chunks}} ) {
+        print $fh <<"EOT";
+static int perl_init_${name}()
+{
+       dTARG;
+       dSP;
+EOT
+        foreach my $j ( @$i ) {
+            $j =~ s{(s\\_[0-9a-f]+)}
+                   { exists($sym->{$1}) ? $sym->{$1} : $default; }ge;
+            print $fh "\t$j\n";
+        }
+        print $fh "\treturn 0;\n}\n";
 
+        $section->SUPER::add( "perl_init_${name}();" );
+        ++$name;
+    }
     foreach my $i ( @{$section->[-1]{evals}} ) {
-        $section->add( sprintf q{eval_pv("%s",1);}, $i );
+        $section->SUPER::add( sprintf q{eval_pv("%s",1);}, $i );
     }
-    $section->SUPER::output( @_ );
+
+    print $fh <<"EOT";
+static int ${init_name}()
+{
+       dTARG;
+       dSP;
+EOT
+    $section->SUPER::output( $fh, $format );
+    print $fh "\treturn 0;\n}\n";
 }
 
 
 package B::C;
 use Exporter ();
+our %REGEXP;
+
+{ # block necessary for caller to work
+    my $caller = caller;
+    if( $caller eq 'O' ) {
+        require XSLoader;
+        XSLoader::load( 'B::C' );
+    }
+}
+
 @ISA = qw(Exporter);
 @EXPORT_OK = qw(output_all output_boilerplate output_main mark_unused
                init_sections set_callback save_unused_subs objsym save_context);
 
 use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop
         class cstring cchar svref_2object compile_stats comppadlist hash
-        threadsv_names main_cv init_av end_av opnumber amagic_generation
+        threadsv_names main_cv init_av end_av regex_padav opnumber amagic_generation
         AVf_REAL HEf_SVKEY SVf_POK SVf_ROK CVf_CONST);
 use B::Asmdata qw(@specialsv_name);
 
@@ -118,6 +198,8 @@ my $save_sig = 0;
 my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
 my $max_string_len;
 
+my $ithreads = $Config{useithreads} eq 'define';
+
 my @threadsv_names;
 BEGIN {
     @threadsv_names = threadsv_names();
@@ -191,16 +273,23 @@ sub savere {
 }
 
 sub savepv {
-    my $pv = shift;         
-    $pv    = '' unless defined $pv;  # Is this sane ?
+    my $pv = pack "a*", shift;
     my $pvsym = 0;
     my $pvmax = 0;
-    if ($pv_copy_on_grow) { 
-       my $cstring = cstring($pv);
-       if ($cstring ne "0") { # sic
-           $pvsym = sprintf("pv%d", $pv_index++);
-           $decl->add(sprintf("static char %s[] = %s;", $pvsym, $cstring));
-       }
+    if ($pv_copy_on_grow) {
+        $pvsym = sprintf("pv%d", $pv_index++);
+
+        if( defined $max_string_len && length($pv) > $max_string_len ) {
+            my $chars = join ', ', map { cchar $_ } split //, $pv;
+            $decl->add(sprintf("static char %s[] = { %s };", $pvsym, $chars));
+        }
+        else {
+            my $cstring = cstring($pv);
+            if ($cstring ne "0") { # sic
+                $decl->add(sprintf("static char %s[] = %s;",
+                                   $pvsym, $cstring));
+           }
+        }
     } else {
        $pvmax = length(pack "a*",$pv) + 1;
     }
@@ -223,7 +312,7 @@ sub save_pv_or_rv {
 
     my $rok = $sv->FLAGS & SVf_ROK;
     my $pok = $sv->FLAGS & SVf_POK;
-    my( $pv, $len, $savesym, $pvmax );
+    my( $len, $pvmax, $savesym, $pv ) = ( 0, 0 );
     if( $rok ) {
        $savesym = '(char*)' . save_rv( $sv );
     }
@@ -383,15 +472,19 @@ sub B::SVOP::save {
     my ($op, $level) = @_;
     my $sym = objsym($op);
     return $sym if defined $sym;
-    my $svsym = $op->sv->save;
-    $svopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, Nullsv",
+    my $sv = $op->sv;
+    my $svsym = '(SV*)' . $sv->save;
+    my $is_const_addr = $svsym =~ m/Null|\&/;
+    $svopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
                           ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
                           $op->targ, $op->type, $op_seq, $op->flags,
-                          $op->private));
+                          $op->private,
+                           ( $is_const_addr ? $svsym : 'Nullsv' )));
     my $ix = $svopsect->index;
     $init->add(sprintf("svop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
         unless $optimize_ppaddr;
-    $init->add("svop_list[$ix].op_sv = (SV*)$svsym;");
+    $init->add("svop_list[$ix].op_sv = $svsym;")
+        unless $is_const_addr;
     savesym($op, "(OP*)&svop_list[$ix]");
 }
 
@@ -399,14 +492,14 @@ sub B::PADOP::save {
     my ($op, $level) = @_;
     my $sym = objsym($op);
     return $sym if defined $sym;
-    $padopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, 0",
+    $padopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %d",
                           ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
                           $op->targ, $op->type, $op_seq, $op->flags,
-                          $op->private));
+                          $op->private,$op->padix));
     my $ix = $padopsect->index;
     $init->add(sprintf("padop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
         unless $optimize_ppaddr;
-    $init->add(sprintf("padop_list[$ix].op_padix = %ld;", $op->padix));
+#    $init->add(sprintf("padop_list[$ix].op_padix = %ld;", $op->padix));
     savesym($op, "(OP*)&padop_list[$ix]");
 }
 
@@ -429,13 +522,13 @@ sub B::COP::save {
     elsif ($is_special && $$warnings == 5) {
         # no warnings 'all';
         $warn_sv = $optimize_warn_sv ?
-            'INT2PTR(SV*,1)' :
+            'INT2PTR(SV*,2)' :
             'pWARN_NONE';
     }
     elsif ($is_special) {
         # use warnings;
         $warn_sv = $optimize_warn_sv ?
-            'INT2PTR(SV*,1)' :
+            'INT2PTR(SV*,3)' :
             'pWARN_STD';
     }
     else {
@@ -466,11 +559,15 @@ sub B::PMOP::save {
     return $sym if defined $sym;
     my $replroot = $op->pmreplroot;
     my $replstart = $op->pmreplstart;
-    my $replrootfield = sprintf("s\\_%x", $$replroot);
+    my $replrootfield;
     my $replstartfield = sprintf("s\\_%x", $$replstart);
     my $gvsym;
     my $ppaddr = $op->ppaddr;
-    if ($$replroot) {
+    # under ithreads, OP_PUSHRE.op_replroot is an integer
+    $replrootfield = sprintf("s\\_%x", $$replroot) if ref $replroot;
+    if($ithreads && $op->name eq "pushre") {
+        $replrootfield = "INT2PTR(OP*,${replroot})";
+    } elsif ($$replroot) {
        # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
        # argument to a split) stores a GV in op_pmreplroot instead
        # of a substitution syntax tree. We don't want to walk that...
@@ -485,12 +582,13 @@ sub B::PMOP::save {
     # pmnext handling is broken in perl itself, I think. Bad op_pmnext
     # fields aren't noticed in perl's runtime (unless you try reset) but we
     # segfault when trying to dereference it to find op->op_pmnext->op_type
-    $pmopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %s, %s, 0, 0, 0x%x, 0x%x",
+    $pmopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %s, %s, 0, %u, 0x%x, 0x%x, 0x%x",
                           ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, $op->targ,
                           $op->type, $op_seq, $op->flags, $op->private,
                           ${$op->first}, ${$op->last}, 
                           $replrootfield, $replstartfield,
-                          $op->pmflags, $op->pmpermflags,));
+                           ( $ithreads ? $op->pmoffset : 0 ),
+                          $op->pmflags, $op->pmpermflags, $op->pmdynflags ));
     my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
     $init->add(sprintf("$pm.op_ppaddr = %s;", $ppaddr))
         unless $optimize_ppaddr;
@@ -720,12 +818,19 @@ sub B::PVMG::save_magic {
                $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);",
                           $$sv, $$obj, cchar($type),$ptrsv,$len));
         }elsif( $type eq 'r' ){
-#               can't save r-MAGIC: we need a PMOP to recompile
-#               the regexp, so die 'cleanly'
-                confess "Can't save r-MAGICAL scalars (yet)"
-#               my($resym,$relen) = savere( $sv->precomp );
-#               $init->add(sprintf("sv_magic((SV*)s\\_%x, , %s, %s, %d);",
-#                                  $$sv, $resym, cchar($type),cstring($ptr),$len));
+            my $rx = $mg->REGEX;
+            my $pmop = $REGEXP{$rx};
+
+            confess "PMOP not found for REGEXP $rx" unless $pmop;
+
+            my( $resym, $relen ) = savere( $mg->precomp );
+            my $pmsym = $pmop->save;
+            $init->add( split /\n/, sprintf <<CODE, $$sv, cchar($type), cstring($ptr) );
+{
+    REGEXP* rx = pregcomp($resym, $resym + $relen, (PMOP*)$pmsym);
+    sv_magic((SV*)s\\_%x, (SV*)rx, %s, %s, %d);
+}
+CODE
         }else{
                $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
                           $$sv, $$obj, cchar($type),cstring($ptr),$len));
@@ -923,7 +1028,12 @@ sub B::CV::save {
        warn sprintf("done saving GV 0x%x for CV 0x%x\n",
                     $$gv, $$cv) if $debug_cv;
     }
-    $init->add(sprintf("CvFILE($sym) = %s;", cstring($cv->FILE)));
+    if( $ithreads ) {
+        $init->add( savepvn( "CvFILE($sym)", $cv->FILE) );
+    }
+    else {
+        $init->add(sprintf("CvFILE($sym) = %s;", cstring($cv->FILE)));
+    }
     my $stash = $cv->STASH;
     if ($$stash) {
        $stash->save;
@@ -932,7 +1042,7 @@ sub B::CV::save {
                     $$stash, $$cv) if $debug_cv;
     }
     $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
-                         $sv_ix, $xpvcv_ix, $cv->REFCNT +1 , $cv->FLAGS));
+                         $sv_ix, $xpvcv_ix, $cv->REFCNT +1*0 , $cv->FLAGS));
     return $sym;
 }
 
@@ -962,17 +1072,20 @@ sub B::GV::save {
        }
     }
     $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
-              sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
+              sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS ),
               sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS));
     $init->add(sprintf("GvLINE($sym) = %u;", $gv->LINE)) unless $is_empty;
-
+    # XXX hack for when Perl accesses PVX of GVs
+    $init->add("SvPVX($sym) = emptystring;\n");
     # Shouldn't need to do save_magic since gv_fetchpv handles that
     #$gv->save_magic;
+    # XXX will always be > 1!!!
     my $refcnt = $gv->REFCNT + 1;
-    $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
+    $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1 )) if $refcnt > 1;
 
     return $sym if $is_empty;
 
+    # XXX B::walksymtable creates an extra reference to the GV
     my $gvrefcnt = $gv->GvREFCNT;
     if ($gvrefcnt > 1) {
        $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
@@ -998,7 +1111,8 @@ sub B::GV::save {
     $savefields&=~Save_CV if $fullname eq 'attributes::bootstrap';
 
     # save it
-    if (defined($egvsym)) {
+    # XXX is that correct?
+    if (defined($egvsym) && $egvsym !~ m/Null/ ) {
        # Shared glob *foo = *bar
        $init->add("gp_free($sym);",
                   "GvGP($sym) = GvGP($egvsym);");
@@ -1062,6 +1176,7 @@ sub B::GV::save {
     }
     return $sym;
 }
+
 sub B::AV::save {
     my ($av) = @_;
     my $sym = objsym($av);
@@ -1088,18 +1203,38 @@ sub B::AV::save {
                             $$av, $i++, class($el), $$el);
            }
        }
-       my @names = map($_->save, @array);
+#      my @names = map($_->save, @array);
        # XXX Better ways to write loop?
        # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
        # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
+
+        # micro optimization: op/pat.t ( and other code probably )
+        # has very large pads ( 20k/30k elements ) passing them to
+        # ->add is a performance bottleneck: passing them as a
+        # single string cuts runtime from 6min20sec to 40sec
+
+        # you want to keep this out of the no_split/split
+        # map("\t*svp++ = (SV*)$_;", @names),
+        my $acc = '';
+        foreach my $i ( 0..$#array ) {
+              $acc .= "\t*svp++ = (SV*)" . $array[$i]->save . ";\n\t";
+        }
+        $acc .= "\n";
+
+        $init->no_split;
        $init->add("{",
                   "\tSV **svp;",
                   "\tAV *av = (AV*)&sv_list[$sv_list_index];",
                   "\tav_extend(av, $fill);",
-                  "\tsvp = AvARRAY(av);",
-              map("\t*svp++ = (SV*)$_;", @names),
-                  "\tAvFILLp(av) = $fill;",
+                  "\tsvp = AvARRAY(av);" );
+        $init->add($acc);
+       $init->add("\tAvFILLp(av) = $fill;",
                   "}");
+        $init->split;
+        # we really added a lot of lines ( B::C::InitSection->add
+        # should really scan for \n, but that would slow
+        # it down
+        $init->inc_count( $#array );
     } else {
        my $max = $av->MAX;
        $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
@@ -1144,6 +1279,7 @@ sub B::HV::save {
        for ($i = 1; $i < @contents; $i += 2) {
            $contents[$i] = $contents[$i]->save;
        }
+        $init->no_split;
        $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
        while (@contents) {
            my ($key, $value) = splice(@contents, 0, 2);
@@ -1154,6 +1290,7 @@ sub B::HV::save {
 #                             cstring($key),length($key),$value, 0));
        }
        $init->add("}");
+        $init->split;
     }
     $hv->save_magic();
     return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
@@ -1165,15 +1302,13 @@ sub B::IO::save_data {
 
     # XXX using $DATA might clobber it!
     my $sym = svref_2object( \\$data )->save;
-    foreach my $i ( split /\n/, <<CODE ) {
+    $init->add( split /\n/, <<CODE );
     {
         GV* gv = (GV*)gv_fetchpv( "$globname", TRUE, SVt_PV );
         SV* sv = $sym;
         GvSV( gv ) = sv;
     }
 CODE
-        $init->add( $i );
-    }
     # for PerlIO::Scalar
     $use_xsloader = 1;
     $init->add_eval( sprintf 'open(%s, "<", $%s)', $globname, $globname );
@@ -1245,6 +1380,9 @@ sub output_all {
            print "Static $typename ${name}_list[$lines];\n";
        }
     }
+    # XXX hack for when Perl accesses PVX of GVs
+    print 'Static char emptystring[] = "\0";';
+
     $decl->output(\*STDOUT, "%s\n");
     print "\n";
     foreach $section (@sections) {
@@ -1253,19 +1391,12 @@ sub output_all {
            my $name = $section->name;
            my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
            printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
-           $section->output(\*STDOUT, "\t{ %s },\n");
+           $section->output(\*STDOUT, "\t{ %s }, /* %d */\n");
            print "};\n\n";
        }
     }
 
-    print <<"EOT";
-static int $init_name()
-{
-       dTARG;
-       dSP;
-EOT
-    $init->output(\*STDOUT, "\t%s\n");
-    print "\treturn 0;\n}\n";
+    $init->output(\*STDOUT, "\t%s\n", $init_name );
     if ($verbose) {
        warn compile_stats();
        warn "NULLOP count: $nullop_count\n";
@@ -1393,6 +1524,11 @@ EOT
 
 sub output_main {
     print <<'EOT';
+/* if USE_IMPLICIT_SYS, we need a 'real' exit */
+#if defined(exit)
+#undef exit
+#endif
+
 int
 main(int argc, char **argv, char **env)
 {
@@ -1401,9 +1537,10 @@ main(int argc, char **argv, char **env)
     char **fakeargv;
     GV* tmpgv;
     SV* tmpsv;
+    int options_count;
 
     PERL_SYS_INIT3(&argc,&argv,&env);
+
     if (!PL_do_undump) {
        my_perl = perl_alloc();
        if (!my_perl)
@@ -1411,7 +1548,22 @@ main(int argc, char **argv, char **env)
        perl_construct( my_perl );
        PL_perl_destruct_level = 0;
     }
+EOT
+    if( $ithreads ) {
+        # XXX init free elems!
+        my $pad_len = regex_padav->FILL + 1 - 1; # first is an avref
 
+        print <<EOT;
+#ifdef USE_ITHREADS
+    for( i = 0; i < $pad_len; ++i ) {
+        av_push( PL_regex_padav, newSViv(0) );
+    }
+    PL_regex_pad = AvARRAY( PL_regex_padav );
+#endif
+EOT
+    }
+
+    print <<'EOT';
 #ifdef CSH
     if (!PL_cshlen) 
       PL_cshlen = strlen(PL_cshname);
@@ -1427,18 +1579,25 @@ main(int argc, char **argv, char **env)
     fakeargv[0] = argv[0];
     fakeargv[1] = "-e";
     fakeargv[2] = "";
+    options_count = 3;
 EOT
     # honour -T
-    print sprintf '    fakeargv[3] = ( %s ) ? "-T" : "" ;'."\n", ${^TAINT};
+    print <<EOT;
+    if( ${^TAINT} ) {
+        fakeargv[options_count] = "-T";
+        ++options_count;
+    }
+EOT
     print <<'EOT';
 #ifndef ALLOW_PERL_OPTIONS
-    fakeargv[4] = "--";
+    fakeargv[options_count] = "--";
+    ++options_count;
 #endif /* ALLOW_PERL_OPTIONS */
     for (i = 1; i < argc; i++)
-       fakeargv[i + EXTRA_OPTIONS] = argv[i];
-    fakeargv[argc + EXTRA_OPTIONS] = 0;
+       fakeargv[i + options_count - 1] = argv[i];
+    fakeargv[argc + options_count - 1] = 0;
 
-    exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
+    exitstatus = perl_parse(my_perl, xs_init, argc + options_count - 1,
                            fakeargv, NULL);
 
     if (exitstatus)
@@ -1554,7 +1713,7 @@ EOT
            else {
               print qq/\tperl_call_pv("XSLoader::load",G_DISCARD);\n/;
            }
-           print "\n#else\n";
+           print "#else\n";
           print "\tboot_$stashxsub(aTHX_ NULL);\n";
            print "#endif\n";
           print qq/\tSPAGAIN;\n/;
@@ -1759,9 +1918,10 @@ sub save_main {
     # save %SIG ( in case it was set in a BEGIN block )
     if( $save_sig ) {
         local $SIG{__WARN__} = $warner;
+        $init->no_split;
         $init->add("{", "\tHV* hv = get_hv(\"main::SIG\",1);" );
         foreach my $k ( keys %SIG ) {
-            next unless $SIG{$k};
+            next unless ref $SIG{$k};
             my $cv = svref_2object( \$SIG{$k} );
             my $sv = $cv->save;
             $init->add('{',sprintf 'SV* sv = (SV*)%s;', $sv );
@@ -1771,6 +1931,7 @@ sub save_main {
             $init->add('mg_set(sv);','}');
         }
         $init->add('}');
+        $init->split;
     }
     # honour -w
     $init->add( sprintf "    PL_dowarn = ( %s ) ? G_WARN_ON : G_WARN_OFF;", $^W );
@@ -1839,6 +2000,10 @@ sub compile {
                        'use-script-name' => \$use_perl_script_name,
                        'save-sig-hash' => \$save_sig,
                      );
+    my %optimization_map = ( 0 => [ qw() ], # special case
+                             1 => [ qw(-fcog) ],
+                             2 => [ qw(-fwarn-sv -fppaddr) ],
+                           );
   OPTION:
     while ($option = shift @options) {
        if ($option =~ /^-(.)(.*)/) {
@@ -1891,11 +2056,12 @@ sub compile {
             }
        } elsif ($opt eq "O") {
            $arg = 1 if $arg eq "";
-           $pv_copy_on_grow = 0;
-           if ($arg >= 1) {
-               # Optimisations for -O1
-               $pv_copy_on_grow = 1;
-           }
+            my @opt;
+            foreach my $i ( 1 .. $arg ) {
+                push @opt, @{$optimization_map{$i}}
+                    if exists $optimization_map{$i};
+            }
+            unshift @options, @opt;
         } elsif ($opt eq "e") {
             push @eval_at_startup, $arg;
        } elsif ($opt eq "l") {
@@ -2037,8 +2203,23 @@ Save compile-time modifications to the %SIG hash.
 
 =item B<-On>
 
-Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.  Currently,
-B<-O1> and higher set B<-fcog>.
+Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
+
+=over 4
+
+=item B<-O0>
+
+Disable all optimizations.
+
+=item B<-O1>
+
+Enable B<-fcog>.
+
+=item B<-O2>
+
+Enable B<-fppaddr>, B<-fwarn-sv>.
+
+=back
 
 =item B<-llimit>
 
diff --git a/ext/B/C/C.xs b/ext/B/C/C.xs
new file mode 100644 (file)
index 0000000..15c9c5c
--- /dev/null
@@ -0,0 +1,51 @@
+#include <EXTERN.h>
+#include <perl.h>
+#include <XSUB.h>
+
+int
+my_runops(pTHX)
+{
+    HV* regexp_hv = get_hv( "B::C::REGEXP", 0 );
+    SV* key = newSViv( 0 );
+
+    do {
+       PERL_ASYNC_CHECK();
+
+        if( PL_op->op_type == OP_QR ) {
+            PMOP* op;
+            REGEXP* rx = PM_GETRE( (PMOP*)PL_op );
+            SV* rv = newSViv( 0 );
+
+            New( 671, op, 1, PMOP );
+            Copy( PL_op, op, 1, PMOP );
+            /* we need just the flags */
+            op->op_next = NULL;
+            op->op_sibling = NULL;
+            op->op_first = NULL;
+            op->op_last = NULL;
+            op->op_pmreplroot = NULL;
+            op->op_pmreplstart = NULL;
+            op->op_pmnext = NULL;
+#ifdef USE_ITHREADS
+            op->op_pmoffset = 0;
+#else
+            op->op_pmregexp = 0;
+#endif
+
+            sv_setiv( key, PTR2IV( rx ) );
+            sv_setref_iv( rv, "B::PMOP", PTR2IV( op ) );
+
+            hv_store_ent( regexp_hv, key, rv, 0 );
+        }
+    } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
+
+    SvREFCNT_dec( key );
+
+    TAINT_NOT;
+    return 0;
+}
+
+MODULE=B__C PACKAGE=B::C
+
+BOOT:
+    PL_runops = my_runops;
diff --git a/ext/B/C/Makefile.PL b/ext/B/C/Makefile.PL
new file mode 100644 (file)
index 0000000..7291b33
--- /dev/null
@@ -0,0 +1,8 @@
+#!perl
+
+use ExtUtils::MakeMaker;
+
+WriteMakefile( NAME => 'B::C',
+               VERSION_FROM => '../B/C.pm'
+             );
+
index ad29c20..a567a73 100644 (file)
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 3;
+plan tests => 4;
 
 require_ok("B::Concise");
 
@@ -15,10 +15,12 @@ $out = runperl(switches => ["-MO=Concise"], prog => '$a', stderr => 1);
 # If either of the next two tests fail, it probably means you need to
 # fix the section labeled 'fragile kludge' in Concise.pm
 
-$op_base = ($out =~ /^(\d+)\s*<0>\s*enter/m);
+($op_base) = ($out =~ /^(\d+)\s*<0>\s*enter/m);
 
-is($op_base, 1, "Smallest OP sequence number", $help);
+is($op_base, 1, "Smallest OP sequence number");
 
-$cop_base = ($out =~ /nextstate\(main (\d+) /);
+($op_base_p1, $cop_base) = ($out =~ /^(\d+)\s*<;>\s*nextstate\(main (\d+) /m);
 
-is($cop_base, 1, "Smallest COP sequence number", $help);
+is($op_base_p1, 2, "Second-smallest OP sequence number");
+
+is($cop_base, 1, "Smallest COP sequence number");
index aa6a153..7aef304 100644 (file)
@@ -239,7 +239,7 @@ EOF
       next if ! $val{ $p }{ $r };
       printf "$type ${head}_%02x_%02x [256] = {\n", $p, $r;
       for(my $c = 0; $c < 256; $c++){
-        print "\t", defined $val{$p}{$r}{$c} ? $val{$p}{$r}{$c} : $null;
+        print "\t", defined $val{$p}{$r}{$c} ? "($type)".$val{$p}{$r}{$c} : $null;
         print ','  if $c != 255;
         print "\n" if $c % 8 == 7;
       }
index 4710ebb..5f0c9de 100644 (file)
@@ -318,6 +318,7 @@ Perl_call_argv
 Perl_call_method
 Perl_call_pv
 Perl_call_sv
+Perl_despatch_signals
 Perl_eval_pv
 Perl_eval_sv
 Perl_get_sv
index 52523be..f4e9700 100644 (file)
@@ -71,3 +71,6 @@ pager="/system/gnu_library/bin/cat.pm"
 # VOS has a bug that causes _exit() to flush all files.
 # This confuses the tests.  Make 'em happy here.
 fflushNULL=define
+
+# VOS has a link() function but it is a dummy.
+d_link="undef"
index 292e262..c07625d 100644 (file)
@@ -18,8 +18,8 @@ use Carp 'croak';
 # The most recent version and complete docs are available at:
 #   http://stein.cshl.org/WWW/software/CGI/
 
-$CGI::revision = '$Id: CGI.pm,v 1.56 2001/12/09 21:36:23 lstein Exp $';
-$CGI::VERSION='2.79';
+$CGI::revision = '$Id: CGI.pm,v 1.58 2002/01/12 02:44:56 lstein Exp $';
+$CGI::VERSION='2.80';
 
 # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
 # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
@@ -36,7 +36,7 @@ use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN',
 sub initialize_globals {
     # Set this to 1 to enable copious autoloader debugging messages
     $AUTOLOAD_DEBUG = 0;
-    
+
     # Set this to 1 to generate XTML-compatible output
     $XHTML = 1;
 
@@ -85,9 +85,9 @@ sub initialize_globals {
     # separate the name=value pairs by semicolons rather than ampersands
     $USE_PARAM_SEMICOLONS = 1;
 
-       # Do not include undefined params parsed from query string
-       # use CGI qw(-no_undef_params);
-       $NO_UNDEF_PARAMS = 0;
+    # Do not include undefined params parsed from query string
+    # use CGI qw(-no_undef_params);
+    $NO_UNDEF_PARAMS = 0;
 
     # Other globals that you shouldn't worry about.
     undef $Q;
@@ -662,14 +662,14 @@ sub _selected {
   my $self = shift;
   my $value = shift;
   return '' unless $value;
-  return $XHTML ? qq( selected="1") : qq( selected);
+  return $XHTML ? qq( selected="selected") : qq( selected);
 }
 
 sub _checked {
   my $self = shift;
   my $value = shift;
   return '' unless $value;
-  return $XHTML ? qq( checked="1") : qq( checked);
+  return $XHTML ? qq( checked="checked") : qq( checked);
 }
 
 sub _reset_globals { initialize_globals(); }
@@ -2057,7 +2057,7 @@ sub radio_group {
 
     my($other) = @other ? " @other" : '';
     foreach (@values) {
-       my($checkit) = $checked eq $_ ? qq/ checked="1"/ : '';
+       my($checkit) = $checked eq $_ ? qq/ checked="checked"/ : '';
        my($break);
        if ($linebreak) {
           $break = $XHTML ? "<br />" : "<br>";
@@ -2123,7 +2123,7 @@ sub popup_menu {
        $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
        my($value) = $self->escapeHTML($_);
        $label=$self->escapeHTML($label,1);
-       $result .= "<option $selectit value=\"$value\">$label</option>\n";
+       $result .= "<option$selectit value=\"$value\">$label</option>\n";
     }
 
     $result .= "</select>";
@@ -2177,7 +2177,7 @@ sub scrolling_list {
        $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
        $label=$self->escapeHTML($label);
        my($value)=$self->escapeHTML($_,1);
-       $result .= "<option $selectit value=\"$value\">$label</option>\n";
+       $result .= "<option$selectit value=\"$value\">$label</option>\n";
     }
     $result .= "</select>";
     $self->register_parameter($name);
@@ -2287,25 +2287,22 @@ sub url {
     my ($relative,$absolute,$full,$path_info,$query,$base) = 
        rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE'],@p);
     my $url;
-    $full++ if $base || !($relative || $absolute);
+    $full++      if $base || !($relative || $absolute);
 
     my $path = $self->path_info;
     my $script_name = $self->script_name;
 
-# If anybody knows why I ever wrote this please tell me!
-#    if (exists($ENV{REQUEST_URI})) {
-#        my $index;
-#      $script_name = $ENV{REQUEST_URI};
-#        # strip query string
-#        substr($script_name,$index) = '' if ($index = index($script_name,'?')) >= 0;
-#        # and path
-#        if (exists($ENV{PATH_INFO})) {
-#           (my $encoded_path = $ENV{PATH_INFO}) =~ s!([^a-zA-Z0-9_./-])!uc sprintf("%%%02x",ord($1))!eg;;
-#           substr($script_name,$index) = '' if ($index = rindex($script_name,$encoded_path)) >= 0;
-#         }
-#    } else {
-#      $script_name = $self->script_name;
-#    }
+    # for compatibility with Apache's MultiViews
+    if (exists($ENV{REQUEST_URI})) {
+        my $index;
+       $script_name = $ENV{REQUEST_URI};
+        $script_name =~ s/\?.+$//;   # strip query string
+        # and path
+        if (exists($ENV{PATH_INFO})) {
+           (my $encoded_path = $ENV{PATH_INFO}) =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg;
+           $script_name      =~ s/$encoded_path$//i;
+         }
+    }
 
     if ($full) {
        my $protocol = $self->protocol();
@@ -2331,7 +2328,7 @@ sub url {
     $url .= $path if $path_info and defined $path;
     $url .= "?" . $self->query_string if $query and $self->query_string;
     $url = '' unless defined $url;
-    $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/uc sprintf("%%%02x",ord($1))/eg;
+    $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg;
     return $url;
 }
 
@@ -3366,6 +3363,11 @@ $MAXTRIES = 5000;
 # %OVERLOAD = ('""'=>'as_string');
 *CGITempFile::AUTOLOAD = \&CGI::AUTOLOAD;
 
+sub DESTROY {
+    my($self) = @_;
+    unlink $$self;              # get rid of the file
+}
+
 ###############################################################################
 ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
 ###############################################################################
@@ -3387,13 +3389,6 @@ sub new {
 }
 END_OF_FUNC
 
-'DESTROY' => <<'END_OF_FUNC',
-sub DESTROY {
-    my($self) = @_;
-    unlink $$self;              # get rid of the file
-}
-END_OF_FUNC
-
 'as_string' => <<'END_OF_FUNC'
 sub as_string {
     my($self) = @_;
index a3b8b40..dbb78c8 100644 (file)
@@ -318,10 +318,10 @@ sub set_message {
     return $CGI::Carp::CUSTOM_MSG;
 }
 
-sub confess { CGI::Carp::die Carp::longmess \@_; }
-sub croak   { CGI::Carp::die Carp::shortmess \@_; }
-sub carp    { CGI::Carp::warn Carp::shortmess \@_; }
-sub cluck   { CGI::Carp::warn Carp::longmess \@_; }
+sub confess { CGI::Carp::die Carp::longmess @_; }
+sub croak   { CGI::Carp::die Carp::shortmess @_; }
+sub carp    { CGI::Carp::warn Carp::shortmess @_; }
+sub cluck   { CGI::Carp::warn Carp::longmess @_; }
 
 # We have to be ready to accept a filehandle as a reference
 # or a string.
index 612e2e1..a6a90a6 100755 (executable)
@@ -85,30 +85,30 @@ is(checkbox(-name     => 'weather',
            -label    => 'forecast',
            -checked  => 1,
            -override => 1),
-   qq(<input type="checkbox" name="weather" value="nice" checked="1" />forecast),
+   qq(<input type="checkbox" name="weather" value="nice" checked="checked" />forecast),
    "checkbox()");
 
 is(checkbox(-name  => 'weather',
            -value => 'dull',
            -label => 'forecast'),
-   qq(<input type="checkbox" name="weather" value="dull" checked="1" />forecast),
+   qq(<input type="checkbox" name="weather" value="dull" checked="checked" />forecast),
    "checkbox()");
 
 is(radio_group(-name => 'game'),
-   qq(<input type="radio" name="game" value="chess" checked="1" />chess ).
+   qq(<input type="radio" name="game" value="chess" checked="checked" />chess ).
    qq(<input type="radio" name="game" value="checkers" />checkers),
    'radio_group()');
 
 is(radio_group(-name   => 'game',
               -labels => {'chess' => 'ping pong'}),
-   qq(<input type="radio" name="game" value="chess" checked="1" />ping pong ).
+   qq(<input type="radio" name="game" value="chess" checked="checked" />ping pong ).
    qq(<input type="radio" name="game" value="checkers" />checkers),
    'radio_group()');
 
 is(checkbox_group(-name   => 'game',
                  -Values => [qw/checkers chess cribbage/]),
-   qq(<input type="checkbox" name="game" value="checkers" checked="1" />checkers ).
-   qq(<input type="checkbox" name="game" value="chess" checked="1" />chess ).
+   qq(<input type="checkbox" name="game" value="checkers" checked="checked" />checkers ).
+   qq(<input type="checkbox" name="game" value="chess" checked="checked" />chess ).
    qq(<input type="checkbox" name="game" value="cribbage" />cribbage),
    'checkbox_group()');
 
@@ -117,7 +117,7 @@ is(checkbox_group(-name       => 'game',
                  '-defaults' => ['cribbage'],-override=>1),
    qq(<input type="checkbox" name="game" value="checkers" />checkers ).
    qq(<input type="checkbox" name="game" value="chess" />chess ).
-   qq(<input type="checkbox" name="game" value="cribbage" checked="1" />cribbage),
+   qq(<input type="checkbox" name="game" value="cribbage" checked="checked" />cribbage),
    'checkbox_group()');
 
 is(popup_menu(-name     => 'game',
@@ -126,9 +126,9 @@ is(popup_menu(-name     => 'game',
              -override => 1)."\n",
    <<END, 'checkbox_group()');
 <select name="game">
-<option  value="checkers">checkers</option>
-<option  value="chess">chess</option>
-<option  selected="1" value="cribbage">cribbage</option>
+<option value="checkers">checkers</option>
+<option value="chess">chess</option>
+<option selected="selected" value="cribbage">cribbage</option>
 </select>
 END
 
index 6c08d9a..82b8f69 100644 (file)
@@ -11,7 +11,7 @@ use strict;
 our ($Is_Mac,$Is_OS2,$Is_VMS,$Is_Win32,$Is_Dos,
            $Verbose,%pm,%static,$Xsubpp_Version);
 
-our $VERSION = '1.12604';
+our $VERSION = '1.12605';
 
 require ExtUtils::MakeMaker;
 ExtUtils::MakeMaker->import(qw($Verbose &neatvalue));
@@ -1613,10 +1613,11 @@ sub init_dirscan {      # --- File and Directory Lists (.xs .pm .pod etc)
 
 =item init_main
 
-Initializes NAME, FULLEXT, BASEEXT, PARENT_NAME, DLBASE, PERL_SRC,
-PERL_LIB, PERL_ARCHLIB, PERL_INC, INSTALLDIRS, INST_*, INSTALL*,
-PREFIX, CONFIG, AR, AR_STATIC_ARGS, LD, OBJ_EXT, LIB_EXT, EXE_EXT, MAP_TARGET,
-LIBPERL_A, VERSION_FROM, VERSION, DISTNAME, VERSION_SYM.
+Initializes AR, AR_STATIC_ARGS, BASEEXT, CONFIG, DISTNAME, DLBASE,
+EXE_EXT, FULLEXT, FULLPERL, INST_*, INSTALL*, INSTALLDIRS, LD,
+LIB_EXT, LIBPERL_A, MAP_TARGET, NAME, OBJ_EXT, PARENT_NAME, PERL,
+PERL_ARCHLIB, PERL_INC, PERL_LIB, PERL_SRC, PERLRUN, PERLRUNINST,
+PREFIX, TEST_LIBS, VERSION, VERSION_FROM, VERSION_SYM, XS_VERSION.
 
 =cut
 
@@ -2037,6 +2038,11 @@ usually solves this kind of problem.
         push @perls, 'miniperl';
     }
 
+    # Build up a set of file names (not command names).
+    foreach $element (@perls) {
+        $element .= "$Config{exe_ext}";
+    }
+
     $self->{PERL} ||=
         $self->find_perl(5.0, \@perls, \@defpath, $Verbose );
     # don't check if perl is executable, maybe they have decided to
index 9f490e0..e2cc21b 100644 (file)
@@ -780,6 +780,7 @@ if ($PLATFORM eq 'win32') {
                            Perl_thread_create
                            Perl_win32_init
                            RunPerl
+                           win32_async_check
                            win32_errno
                            win32_environ
                            win32_abort
diff --git a/perl.h b/perl.h
index 3dcb146..7a876b5 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -425,7 +425,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))
index b5f126c..f3f2a19 100644 (file)
@@ -320,7 +320,7 @@ Perl used to be fragile in that signals arriving at inopportune moments
 could corrupt Perl's internal state.  Now Perl postpones handling of
 signals until it's safe (between opcodes).
 
-This change may have surprising side effects because signals no more
+This change may have surprising side effects because signals no longer
 interrupt Perl instantly.  Perl will now first finish whatever it was
 doing, like finishing an internal operation (like sort()) or an
 external operation (like an I/O operation), and only then look at any
index 777b0dd..af78458 100644 (file)
@@ -2370,6 +2370,11 @@ See also L<perlport> for writing portable code.
 (W) The call to overload::constant contained an odd number of arguments.
 The arguments should come in pairs.
 
+=item Odd number of elements in anonymous hash
+
+(W misc) You specified an odd number of elements to initialize a hash,
+which is odd, because hashes come in key/value pairs.
+
 =item Odd number of elements in hash assignment
 
 (W misc) You specified an odd number of elements to initialize a hash,
index 2629078..c3fcacd 100644 (file)
@@ -1,6 +1,6 @@
 =head1 NAME
 
-perlfaq - frequently asked questions about Perl ($Date: 2001/11/19 17:09:37 $)
+perlfaq - frequently asked questions about Perl ($Date: 2002/01/11 02:31:20 $)
 
 =head1 DESCRIPTION
 
index 7a010a7..d8e4f97 100644 (file)
@@ -1,6 +1,6 @@
 =head1 NAME
 
-perlfaq1 - General Questions About Perl ($Revision: 1.2 $, $Date: 2001/11/09 08:06:04 $)
+perlfaq1 - General Questions About Perl ($Revision: 1.3 $, $Date: 2002/01/11 02:31:20 $)
 
 =head1 DESCRIPTION
 
index 0ad762c..3ef958f 100644 (file)
@@ -1,6 +1,6 @@
 =head1 NAME
 
-perlfaq2 - Obtaining and Learning about Perl ($Revision: 1.3 $, $Date: 2001/11/09 08:06:04 $)
+perlfaq2 - Obtaining and Learning about Perl ($Revision: 1.4 $, $Date: 2002/01/11 02:31:20 $)
 
 =head1 DESCRIPTION
 
index a592c57..5a4e650 100644 (file)
@@ -1,6 +1,6 @@
 =head1 NAME
 
-perlfaq3 - Programming Tools ($Revision: 1.10 $, $Date: 2001/11/19 17:09:37 $)
+perlfaq3 - Programming Tools ($Revision: 1.11 $, $Date: 2002/01/11 02:31:20 $)
 
 =head1 DESCRIPTION
 
index abbb9a0..9d19337 100644 (file)
@@ -1,6 +1,6 @@
 =head1 NAME
 
-perlfaq4 - Data Manipulation ($Revision: 1.10 $, $Date: 2002/01/01 22:26:45 $)
+perlfaq4 - Data Manipulation ($Revision: 1.11 $, $Date: 2002/01/11 02:31:20 $)
 
 =head1 DESCRIPTION
 
index ef7b5cb..fb0274e 100644 (file)
@@ -1,6 +1,6 @@
 =head1 NAME
 
-perlfaq5 - Files and Formats ($Revision: 1.6 $, $Date: 2001/12/19 18:17:00 $)
+perlfaq5 - Files and Formats ($Revision: 1.7 $, $Date: 2002/01/11 02:31:20 $)
 
 =head1 DESCRIPTION
 
index 0f65a30..1b1ab58 100644 (file)
@@ -1,6 +1,6 @@
 =head1 NAME
 
-perlfaq8 - System Interaction ($Revision: 1.4 $, $Date: 2001/11/09 08:06:04 $)
+perlfaq8 - System Interaction ($Revision: 1.5 $, $Date: 2002/01/11 02:31:20 $)
 
 =head1 DESCRIPTION
 
index 74b10e4..23d6ff1 100644 (file)
@@ -625,7 +625,7 @@ Technical Report 18, "Unicode Regular Expression Guidelines".
 Level 1 - Basic Unicode Support
 
         2.1 Hex Notation                        - done          [1]
-                Named Notation                  - done          [2]
+            Named Notation                      - done          [2]
         2.2 Categories                          - done          [3][4]
         2.3 Subtraction                         - MISSING       [5][6]
         2.4 Simple Word Boundaries              - done          [7]
@@ -644,6 +644,7 @@ Level 1 - Basic Unicode Support
         [ 9] see UTR#13 Unicode Newline Guidelines
         [10] should do ^ and $ also on \x{85}, \x{2028} and \x{2029})
              (should also affect <>, $., and script line numbers)
+             (the \x{85}, \x{2028} and \x{2029} do match \s)
 
 (*) You can mimic class subtraction using lookahead.
 For example, what TR18 might write as
diff --git a/pp.c b/pp.c
index 8b58c16..319adaf 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -3848,7 +3848,7 @@ PP(pp_anonhash)
        if (MARK < SP)
            sv_setsv(val, *++MARK);
        else if (ckWARN(WARN_MISC))
-           Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
+           Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in anonymous hash");
        (void)hv_store_ent(hv,key,val,0);
     }
     SP = ORIGMARK;
index bdd7c0d..0ceff78 100644 (file)
--- a/regexec.c
+++ b/regexec.c
 #define HOPMAYBEc(pos,off) ((char*)HOPMAYBE(pos,off))
 
 #define HOPBACK(pos, off) (            \
-    (UTF && PL_reg_match_utf8)         \
+    (PL_reg_match_utf8)                        \
        ? reghopmaybe((U8*)pos, -off)   \
     : (pos - off >= PL_bostr)          \
        ? (U8*)(pos - off)              \
diff --git a/sv.c b/sv.c
index 2c12e4c..3de686f 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -7655,6 +7655,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
     I32 svix = 0;
     static char nullstr[] = "(null)";
     SV *argsv = Nullsv;
+    bool has_utf8 = FALSE; /* has the result utf8? */
 
     /* no matter what, this is a string now */
     (void)SvPV_force(sv, origlen);
@@ -7688,13 +7689,16 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
        }
     }
 
+    if (!args && svix < svmax && DO_UTF8(*svargs))
+        has_utf8 = TRUE;
+
     patend = (char*)pat + patlen;
     for (p = (char*)pat; p < patend; p = q) {
        bool alt = FALSE;
        bool left = FALSE;
        bool vectorize = FALSE;
        bool vectorarg = FALSE;
-       bool vec_utf = FALSE;
+       bool vec_utf8 = FALSE;
        char fill = ' ';
        char plus = 0;
        char intsize = 0;
@@ -7702,7 +7706,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
        STRLEN zeros = 0;
        bool has_precis = FALSE;
        STRLEN precis = 0;
-       bool is_utf = FALSE;
+       bool is_utf8 = FALSE;  /* is this item utf8?   */
        
        char esignbuf[4];
        U8 utf8buf[UTF8_MAXLEN+1];
@@ -7827,17 +7831,17 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                        svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
                dotstr = SvPVx(vecsv, dotstrlen);
                if (DO_UTF8(vecsv))
-                   is_utf = TRUE;
+                   is_utf8 = TRUE;
            }
            if (args) {
                vecsv = va_arg(*args, SV*);
                vecstr = (U8*)SvPVx(vecsv,veclen);
-               vec_utf = DO_UTF8(vecsv);
+               vec_utf8 = DO_UTF8(vecsv);
            }
            else if (efix ? efix <= svmax : svix < svmax) {
                vecsv = svargs[efix ? efix-1 : svix++];
                vecstr = (U8*)SvPVx(vecsv,veclen);
-               vec_utf = DO_UTF8(vecsv);
+               vec_utf8 = DO_UTF8(vecsv);
            }
            else {
                vecstr = (U8*)"";
@@ -7931,7 +7935,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                && !IN_BYTES) {
                eptr = (char*)utf8buf;
                elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
-               is_utf = TRUE;
+               is_utf8 = TRUE;
            }
            else {
                c = (char)uv;
@@ -7967,7 +7971,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                    if (width) { /* fudge width (can't fudge elen) */
                        width += elen - sv_len_utf8(argsv);
                    }
-                   is_utf = TRUE;
+                   is_utf8 = TRUE;
                }
            }
            goto string;
@@ -7983,7 +7987,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            argsv = va_arg(*args, SV*);
            eptr = SvPVx(argsv, elen);
            if (DO_UTF8(argsv))
-               is_utf = TRUE;
+               is_utf8 = TRUE;
 
        string:
            vectorize = FALSE;
@@ -8013,8 +8017,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                STRLEN ulen;
                if (!veclen)
                    continue;
-               if (vec_utf)
-                   uv = utf8n_to_uvchr(vecstr, veclen, &ulen, UTF8_ALLOW_ANYUV);
+               if (vec_utf8)
+                   uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
+                                       UTF8_ALLOW_ANYUV);
                else {
                    uv = *vecstr;
                    ulen = 1;
@@ -8098,8 +8103,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
        vector:
                if (!veclen)
                    continue;
-               if (vec_utf)
-                   uv = utf8n_to_uvchr(vecstr, veclen, &ulen, UTF8_ALLOW_ANYUV);
+               if (vec_utf8)
+                   uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
+                                       UTF8_ALLOW_ANYUV);
                else {
                    uv = *vecstr;
                    ulen = 1;
@@ -8354,6 +8360,20 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                *p++ = '0';
        }
        if (elen) {
+           if (is_utf8 != has_utf8) {
+               if (is_utf8) {
+                   if (SvCUR(sv)) {
+                       sv_utf8_upgrade(sv);
+                       p = SvEND(sv);
+                   }
+               }
+               else {
+                   SV *nsv = sv_2mortal(newSVpvn(eptr, elen));
+                   sv_utf8_upgrade(nsv);
+                   eptr = SvPVX(nsv);
+                   elen = SvCUR(nsv);
+               }
+           }
            Copy(eptr, p, elen, char);
            p += elen;
        }
@@ -8369,7 +8389,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            else
                vectorize = FALSE;              /* done iterating over vecstr */
        }
-       if (is_utf)
+       if (is_utf8)
+           has_utf8 = TRUE;
+       if (has_utf8)
            SvUTF8_on(sv);
        *p = '\0';
        SvCUR(sv) = p - SvPVX(sv);
diff --git a/t/TEST b/t/TEST
index 34f15bf..9f2081a 100755 (executable)
--- a/t/TEST
+++ b/t/TEST
@@ -212,7 +212,8 @@ EOT
        else {
            my $compile;
             my $pl2c = "$testswitch -I../lib ../utils/perlcc --testsuite " .
-                       "$switch -L .. " .
+              # -O9 for good measure, -fcog is broken ATM
+                       "$switch -Wb=-O9,-fno-cog -L .. " .
                        "-I \".. ../lib/CORE\" $args $utf $test -o ";
 
             if( $^O eq 'MSWin32' ) {
index 2f4bf7b..5ed7aa0 100644 (file)
@@ -67,7 +67,7 @@ my $a = { 1,2,3};
 no warnings 'misc' ;
 my $b = { 1,2,3};
 EXPECT
-Odd number of elements in hash assignment at - line 3.
+Odd number of elements in anonymous hash at - line 3.
 ########
 # pp.c
 use warnings 'misc' ;
index 8466a71..3db2b46 100755 (executable)
@@ -45,7 +45,8 @@ sub test_warning ($$$) {
 #   print "# $num: $got\n";
 }
 
-my $odd_msg = '/^Odd number of elements in hash/';
+my $odd_msg = '/^Odd number of elements in hash assignment/';
+my $odd_msg2 = '/^Odd number of elements in anonymous hash/';
 my $ref_msg = '/^Reference found where even-sized list expected/';
 
 {
@@ -56,7 +57,7 @@ my $ref_msg = '/^Reference found where even-sized list expected/';
     test_warning 2, shift @warnings, $odd_msg;
 
     %hash = { 1..3 };
-    test_warning 3, shift @warnings, $odd_msg;
+    test_warning 3, shift @warnings, $odd_msg2;
     test_warning 4, shift @warnings, $ref_msg;
 
     %hash = [ 1..3 ];
index 467e0a2..19ec634 100755 (executable)
@@ -6,7 +6,7 @@
 
 $| = 1;
 
-print "1..846\n";
+print "1..848\n";
 
 BEGIN {
     chdir 't' if -d 't';
@@ -2621,7 +2621,7 @@ print "# some Unicode properties\n";
 }
 
 {
-    print "# . with /s should work on characters, not bytes\n";
+    print "# . with /s should work on characters, as opposed to bytes\n";
 
     my $s = "\x{e4}\x{100}";
 
@@ -2652,3 +2652,10 @@ print "# some Unicode properties\n";
     $r2 =~ s/\x{100}//;
     print $r1 eq $r2 ? "ok 846\n" : "not ok 846\n";
 }
+
+{
+    print "# Unicode lookbehind\n";
+
+    print "A\x{100}B"        =~ /(?<=A.)B/  ? "ok 847\n" : "not ok 847\n";
+    print "A\x{200}\x{300}B" =~ /(?<=A..)B/ ? "ok 848\n" : "not ok 848\n";
+}
diff --git a/t/op/unisprintf.t b/t/op/unisprintf.t
new file mode 100644 (file)
index 0000000..3c5f574
--- /dev/null
@@ -0,0 +1,139 @@
+#!./perl -w
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = qw(../lib .);
+    require "test.pl";
+}
+
+plan tests => 25;
+
+$a = "B\x{fc}f";
+$b = "G\x{100}r";
+$c = 0x200;
+
+{
+    my $s = sprintf "%s", $a;
+    is($s, $a, "%s a");
+}
+
+{
+    my $s = sprintf "%s", $b;
+    is($s, $b, "%s b");
+}
+
+{
+    my $s = sprintf "%s%s", $a, $b;
+    is($s, $a.$b, "%s%s a b");
+}
+
+{
+    my $s = sprintf "%s%s", $b, $a;
+    is($s, $b.$a, "%s%s b a");
+}
+
+{
+    my $s = sprintf "%s%s", $b, $b;
+    is($s, $b.$b, "%s%s b b");
+}
+
+{
+    my $s = sprintf "%s$b", $a;
+    is($s, $a.$b, "%sb a");
+}
+
+{
+    my $s = sprintf "$b%s", $a;
+    is($s, $b.$a, "b%s a");
+}
+
+{
+    my $s = sprintf "%s$a", $b;
+    is($s, $b.$a, "%sa b");
+}
+
+{
+    my $s = sprintf "$a%s", $b;
+    is($s, $a.$b, "a%s b");
+}
+
+{
+    my $s = sprintf "$a%s", $a;
+    is($s, $a.$a, "a%s a");
+}
+
+{
+    my $s = sprintf "$b%s", $b;
+    is($s, $b.$b, "a%s b");
+}
+
+{
+    my $s = sprintf "%c", $c;
+    is($s, chr($c), "%c c");
+}
+
+{
+    my $s = sprintf "%s%c", $a, $c;
+    is($s, $a.chr($c), "%s%c a c");
+}
+
+{
+    my $s = sprintf "%c%s", $c, $a;
+    is($s, chr($c).$a, "%c%s c a");
+}
+
+{
+    my $s = sprintf "%c$b", $c;
+    is($s, chr($c).$b, "%cb c");
+}
+
+{
+    my $s = sprintf "%s%c$b", $a, $c;
+    is($s, $a.chr($c).$b, "%s%cb a c");
+}
+
+{
+    my $s = sprintf "%c%s$b", $c, $a;
+    is($s, chr($c).$a.$b, "%c%sb c a");
+}
+
+{
+    my $s = sprintf "$b%c", $c;
+    is($s, $b.chr($c), "b%c c");
+}
+
+{
+    my $s = sprintf "$b%s%c", $a, $c;
+    is($s, $b.$a.chr($c), "b%s%c a c");
+}
+
+{
+    my $s = sprintf "$b%c%s", $c, $a;
+    is($s, $b.chr($c).$a, "b%c%s c a");
+}
+
+{
+    # 20010407.008 sprintf removes utf8-ness
+    $a = sprintf "\x{1234}";
+    is((sprintf "%x %d", unpack("U*", $a), length($a)),    "1234 1",
+       '\x{1234}');
+    $a = sprintf "%s", "\x{5678}";
+    is((sprintf "%x %d", unpack("U*", $a), length($a)),    "5678 1",
+       '%s \x{5678}');
+    $a = sprintf "\x{1234}%s", "\x{5678}";
+    is((sprintf "%x %x %d", unpack("U*", $a), length($a)), "1234 5678 2",
+       '\x{1234}%s \x{5678}');
+}
+
+{
+    # check that utf8ness doesn't "accumulate"
+
+    my $w = "w\x{fc}";
+    my $sprintf;
+
+    $sprintf = sprintf "%s%s", $w, "$w\x{100}";
+    is(substr($sprintf,0,2), $w, "utf8 echo");
+
+    $sprintf = sprintf "%s%s", $w, "$w\x{100}";    
+    is(substr($sprintf,0,2), $w, "utf8 echo echo");
+}
old mode 100755 (executable)
new mode 100644 (file)
index 9d3a641..3ee2831 100644 (file)
@@ -52,7 +52,7 @@ foreach my $prog (@prgs) {
 
     my($prog,$expected) = split(/\nEXPECT\n/, $raw_prog);
 
-    kill_perl($prog, $expected, { switches => $switch }, $name);
+    kill_perl($prog, $expected, { switches => [$switch] }, $name);
 }
 
 __END__
@@ -707,17 +707,6 @@ sub DESTROY {
 EXPECT
 Bar=ARRAY(0x...)
 ########
-# 20010407.008 sprintf removes utf8-ness
-$a = sprintf "\x{1234}";
-printf "%x %d\n", unpack("U*", $a), length($a);
-$a = sprintf "%s", "\x{5678}";
-printf "%x %d\n", unpack("U*", $a), length($a);
-$a = sprintf "\x{1234}%s", "\x{5678}";
-printf "%x %x %d\n", unpack("U*", $a), length($a);
-EXPECT
-1234 1
-5678 1
-1234 5678 2
 ######## found by Markov chain stress testing
 eval "a.b.c.d.e.f;sub"
 EXPECT
@@ -807,6 +796,7 @@ package main;
 $test = Foo->new(); # must be package var
 END
 {
+       1 while unlink 'dbmtest';
        1 while unlink <dbmtest.*>;
        print "ok\n";
 }
index 5f358b9..379e136 100644 (file)
--- a/t/test.pl
+++ b/t/test.pl
@@ -280,8 +280,7 @@ sub runperl {
     my %args = @_;
     my $runperl = $^X;
     if ($args{switches}) {
-       _quote_args(\$runperl,
-                   ref $args{switches} ? $args{switches} : [$args{switches}]);
+       _quote_args(\$runperl, $args{switches});
     }
     unless ($args{nolib}) {
        if ($is_macos) {
index 51f52ed..15a276a 100644 (file)
@@ -178,6 +178,7 @@ sub parse_argv {
         'static',       # Dirty hack to enable -shared/-static
         'shared',       # Create a shared library (--shared for compat.)
        'log:s',        # where to log compilation process information
+        'Wb:s',         # pass (comma-sepearated) options to backend
         'testsuite',    # try to be nice to testsuite
     );
 
@@ -284,6 +285,11 @@ sub compile_cstyle {
     my $lose = 0;
     my ($cfh);
     my $testsuite = '';
+    my $addoptions = opt(Wb);
+
+    if( $addoptions ) {
+        $addoptions .= ',' if $addoptions !~ m/,$/;
+    }
 
     if (opt(testsuite)) {
         my $bo = join '', @begin_output;
@@ -324,7 +330,7 @@ sub compile_cstyle {
 
     # This has to do the write itself, so we can't keep a lock. Life
     # sucks.
-    my $command = "$BinPerl $taint -MO=$Backend,$testsuite$max_line_len$stash,-o$cfile $Input";
+    my $command = "$BinPerl $taint -MO=$Backend,$addoptions$testsuite$max_line_len$stash,-o$cfile $Input";
     vprint 1, "Compiling...";
     vprint 1, "Calling $command";
 
@@ -356,7 +362,7 @@ sub cc_harness_msvc {
     $link .= " -libpath:".$_ for split /\s+/, opt(L);
     my @mods = split /-?u /, $stash;
     $link .= " ".ExtUtils::Embed::ldopts("-std", \@mods);
-    $link .= " perl57.lib msvcrt.lib";
+    $link .= " perl57.lib kernel32.lib msvcrt.lib";
     vprint 3, "running $Config{cc} $compile";
     system("$Config{cc} $compile");
     vprint 3, "running $Config{ld} $link";
index ea381a4..62a82f3 100644 (file)
@@ -170,8 +170,14 @@ if (!($Is_VMS || $Is_MSWin32 || $Is_Dos || $Is_OS2) && ($> == 0 || $< == 0)
            $id = eval { getpwnam("nouser") } unless defined $id;
            $id = -2 unless defined $id;
         eval {
-            $> = $id;  # must do this one first!
-            $< = $id;
+           # According to Stevens' APUE and various
+           # (BSD, Solaris, HP-UX) man pages setting
+           # the real uid first and effective uid second
+           # is the way to go if one wants to drop privileges,
+           # because if one changes into an effective uid of
+           # non-zero, one cannot change the real uid any more.
+            $< = $id; # real uid
+            $> = $id; # effective uid
         };
         last if !$@ && $< && $>;
     }