diff options
49 files changed, 1120 insertions, 293 deletions
@@ -31,6 +31,223 @@ or any other branch. Version v5.7.2 Development release working toward v5.8 -------------- ____________________________________________________________________________ +[ 14225] By: jhi on 2002/01/12 20:28:05 + Log: Subject: [PATCH 2] Re: [PATCH Configure ext/NDBM_File/hints/linux.pl] Support for linux systems with gdbm + From: Jonathan Stowe <gellyfish@gellyfish.com> + Date: Sat, 12 Jan 2002 11:13:02 +0000 (GMT) + Message-ID: <Pine.LNX.4.44.0201121107400.26602-100000@orpheus.gellyfish.com> + Branch: perl + ! Configure config_h.SH +____________________________________________________________________________ +[ 14224] By: jhi on 2002/01/12 20:18:02 + Log: Quick reformat using indent -kr -nce, as requested + by Dan Kogai and suggest by NI-S. + Branch: perl + ! ext/Encode/encengine.c +____________________________________________________________________________ +[ 14223] By: jhi on 2002/01/12 20:08:54 + Log: Couple more Unicode lookbehind tests. + Branch: perl + ! t/op/pat.t +____________________________________________________________________________ +[ 14222] By: jhi on 2002/01/12 20:05:29 + Log: Sharp S as a special treat for our German UTF-8 testers :-) + Branch: perl + ! pod/perlunicode.pod regexec.c t/op/pat.t utf8.h +____________________________________________________________________________ +[ 14221] By: jhi on 2002/01/12 18:38:54 + Log: Subject: {PATCH] Fix: Re: [PATCH] B::C, perlcc.PL, B.xs, B.pm, t/TEST, C.xs + From: "Mattia Barbon" <mbarbon@dsi.unive.it> + Date: Sat, 12 Jan 2002 20:37:32 +0100 + Message-ID: <3C409E8C.16203.196C2D3@localhost> + Branch: perl + ! ext/B/B/Deparse.pm +____________________________________________________________________________ +[ 14220] By: jhi on 2002/01/12 18:27:32 + Log: Hrmph. Is having a test for an exact version of MM_Unix.pm + really worth the bits it's printed on? + Branch: perl + ! lib/ExtUtils/t/MM_Unix.t +____________________________________________________________________________ +[ 14219] By: jhi on 2002/01/12 18:06:49 + Log: Special treatment for U+03B0 and U+0390 in //i, + this means that we can remove the minlen pessimisations + introduced by the #14096. + Branch: perl + ! pp_hot.c regcomp.c regexec.c +____________________________________________________________________________ +[ 14218] By: jhi on 2002/01/12 16:14:52 + Log: Integrate perlio; + + Abstract out the cloning of SvPVX and handle shared pv in a + safe (if suboptimal) manner. Does not fix op/fork.t :-( + + Win32-ize socketpair test + - Win32 can fork even though $Config{d_fork} is undef + - SOCK_DGRAM does not work - skip those tests. + Branch: perl + !> ext/Socket/socketpair.t sv.c +____________________________________________________________________________ +[ 14217] By: jhi on 2002/01/12 16:09:59 + Log: One should first drop the real uid, not the effective uid. + [ID 20020110.003] + Branch: perl + ! utils/perldoc.PL +____________________________________________________________________________ +[ 14216] By: jhi on 2002/01/12 15:50:38 + Log: Subject: [PATCH] B::C, perlcc.PL, B.xs, B.pm, t/TEST, C.xs + From: "Mattia Barbon" <mbarbon@dsi.unive.it> + Date: Fri, 11 Jan 2002 23:29:48 +0100 + Message-ID: <3C3F756C.4581.2E2A938@localhost> + Branch: perl + + ext/B/C/C.xs ext/B/C/Makefile.PL + ! MANIFEST ext/B/B.pm ext/B/B.xs ext/B/B/C.pm t/TEST + ! utils/perlcc.PL +____________________________________________________________________________ +[ 14215] By: jhi on 2002/01/12 15:22:01 + Log: Subject: [PATCH] Re: Magic numbers in B::Concise + From: Stephen McCamant <smcc@CSUA.Berkeley.EDU> + Date: Fri, 11 Jan 2002 14:29:30 -0800 + Message-ID: <15423.26442.891378.802062@soda.csua.berkeley.edu> + Branch: perl + ! ext/B/t/concise.t +____________________________________________________________________________ +[ 14212] By: ams on 2002/01/12 06:10:52 + Log: Subject: [PATCH] More fixes for Stratus VOS + From: "Green, Paul" <Paul.Green@stratus.com> + Date: Fri, 11 Jan 2002 17:30:37 -0500 + Message-Id: <95AE3CDB3543D511883A0020485B38B9023534D3@exna3.stratus.com> + Branch: perl + ! hints/vos.sh lib/ExtUtils/MM_Unix.pm +____________________________________________________________________________ +[ 14211] By: jhi on 2002/01/12 06:01:29 + Log: Upgrade to CGI.pm 2.80. + Branch: perl + ! lib/CGI.pm lib/CGI/Carp.pm lib/CGI/t/form.t +____________________________________________________________________________ +[ 14210] By: jhi on 2002/01/12 05:57:36 + Log: FAQ sync. + Branch: perl + ! pod/perlfaq.pod pod/perlfaq1.pod pod/perlfaq2.pod + ! pod/perlfaq3.pod pod/perlfaq4.pod pod/perlfaq5.pod + ! pod/perlfaq8.pod +____________________________________________________________________________ +[ 14209] By: jhi on 2002/01/12 05:54:24 + Log: This is getting embarrassing. + Branch: perl + ! t/op/pat.t +____________________________________________________________________________ +[ 14208] By: jhi on 2002/01/12 05:30:03 + Log: Doc tweaks. + Branch: perl + ! pod/perlunicode.pod +____________________________________________________________________________ +[ 14207] By: jhi on 2002/01/12 05:16:55 + Log: Updating the test count is good; also rephrasing + so that there is no ok output containing "not". + Branch: perl + ! t/op/pat.t +____________________________________________________________________________ +[ 14206] By: jhi on 2002/01/12 05:11:20 + Log: Andreas is busy :-) + Branch: perl + ! doop.c t/op/unisprintf.t +____________________________________________________________________________ +[ 14205] By: jhi on 2002/01/12 04:55:20 + Log: Unicode lookbehind looked bad. + Branch: perl + ! regexec.c t/op/pat.t +____________________________________________________________________________ +[ 14204] By: jhi on 2002/01/12 01:43:48 + Log: Garbage collection. + Branch: perl + ! t/run/kill_perl.t +____________________________________________________________________________ +[ 14203] By: jhi on 2002/01/12 00:10:51 + Log: Subject: [PATCH] export win32_async_check or Perl_despatch_signals + From: "Mattia Barbon" <mbarbon@dsi.unive.it> + Date: Fri, 11 Jan 2002 23:29:48 +0100 + Message-ID: <3C3F756C.21561.2E2A9CE@localhost> + Branch: perl + ! embed.fnc global.sym makedef.pl +____________________________________________________________________________ +[ 14202] By: jhi on 2002/01/12 00:07:41 + Log: Subject: [PATCH] perldelta nit? + From: Robert Spier <rspier@pobox.com> + Date: Fri, 11 Jan 2002 15:19:16 -0800 + Message-ID: <15423.29428.164185.251700@rls.cx> + Branch: perl + ! pod/perldelta.pod +____________________________________________________________________________ +[ 14201] By: jhi on 2002/01/12 00:06:02 + Log: Subject: Re: [PATCH lib/AnyDBM_File.t] Convert to Test::More + From: Michael G Schwern <schwern@pobox.com> + Date: Fri, 11 Jan 2002 17:08:17 -0500 + Message-ID: <20020111220817.GG2838@blackrider> + Branch: perl + ! t/run/kill_perl.t t/test.pl +____________________________________________________________________________ +[ 14200] By: jhi on 2002/01/12 00:02:05 + Log: Subject: [PATCH] Correct misleading error message + From: Mike Guy <mjtg@cam.ac.uk> + Date: Fri, 11 Jan 2002 18:36:33 +0000 + Message-Id: <E16P6XZ-0005kA-00@draco.cus.cam.ac.uk> + + hash assignment -> anonymous hash + Branch: perl + ! pod/perldiag.pod pp.c t/lib/warnings/pp t/op/hashwarn.t +____________________________________________________________________________ +[ 14199] By: jhi on 2002/01/11 23:58:00 + Log: Subject: [PATCH bleadperl] Shut down warnings in Normalize.c + From: Nikola Knezevic <indy@tesla.rcub.bg.ac.yu> + Date: Fri, 11 Jan 2002 16:58:14 +0100 + Message-ID: <543058204.20020111165814@tesla.rcub.bg.ac.yu> + Branch: perl + ! ext/Unicode/Normalize/mkheader +____________________________________________________________________________ +[ 14198] By: jhi on 2002/01/11 23:53:05 + Log: Add a new test for is-sprintf-preserving Unicodeness: + #14194 and an old one from kill_perl.t (I could have used + sprintf.t, but it's format was quite fixed, and I didn't + feel like breaking the format) + Branch: perl + + t/op/unisprintf.t + ! MANIFEST t/run/kill_perl.t +____________________________________________________________________________ +[ 14197] By: jhi on 2002/01/11 21:48:49 + Log: Integrate perlio; + Install dummy signal() handlers for Win32's SIGINT and SIGBREAK + Branch: perl + !> win32/win32.c +____________________________________________________________________________ +[ 14195] By: jhi on 2002/01/11 20:07:35 + Log: Integrate perlio; + A mostly-stable version of "new" Win32 signal/kill support. + Branch: perl + !> MANIFEST XSUB.h mg.c t/run/kill_perl.t toke.c win32/config.bc + !> win32/config.gc win32/config.vc win32/config_H.bc + !> win32/config_H.gc win32/config_H.vc win32/config_h.PL + !> win32/makefile.mk win32/win32.c win32/win32.h +____________________________________________________________________________ +[ 14194] By: jhi on 2002/01/11 20:04:26 + Log: Fix for + + Subject: UTF-8 sprintf bug in bleadperl + From: andreas.koenig@anima.de (Andreas J. Koenig) + Date: 11 Jan 2002 15:47:15 +0100 + Message-ID: <m3vge99c7g.fsf@anima.de> + + I have tests, have just to figure out where to put them + since op/sprintf looks a bit unfriendly for tests of + somewhat freer form. + Branch: perl + ! doop.c sv.c +____________________________________________________________________________ +[ 14191] By: jhi on 2002/01/11 15:34:53 + Log: Update Changes. + Branch: perl + ! Changes patchlevel.h +____________________________________________________________________________ [ 14190] By: jhi on 2002/01/11 14:52:51 Log: Subject: [PATCH] Re: Magic numbers in B::Concise From: Stephen McCamant <smcc@CSUA.Berkeley.EDU> @@ -20,7 +20,7 @@ # $Id: Head.U,v 3.0.1.9 1997/02/28 15:02:09 ram Exp $ # -# Generated on Sun Dec 30 19:31:52 EET 2001 [metaconfig 3.0 PL70] +# Generated on Sat Jan 12 23:16:55 EET 2002 [metaconfig 3.0 PL70] # (with additional metaconfig patches by perlbug@perl.org) cat >c1$$ <<EOF @@ -16051,6 +16051,19 @@ eval $inhdr : see if ndbm.h is available set ndbm.h t_ndbm eval $inhdr + +case "$t_ndbm" in +$undef) + # Some Linux distributions such as RedHat 7.1 put the + # ndbm.h header in /usr/include/gdbm/ndbm.h. + if $test -f /usr/include/gdbm/ndbm.h; then + ccflags="$ccflags -I/usr/include/gdbm" + cppflags="$cppflags -I/usr/include/gdbm" + t_ndbm=$define + fi + ;; +esac + case "$t_ndbm" in $define) : see if dbm_open exists @@ -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/config_h.SH b/config_h.SH index 37ad71aaec..b860075fd8 100644 --- a/config_h.SH +++ b/config_h.SH @@ -757,12 +757,6 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$i_memory I_MEMORY /**/ -/* I_NDBM: - * This symbol, if defined, indicates that <ndbm.h> exists and should - * be included. - */ -#$i_ndbm I_NDBM /**/ - /* I_NET_ERRNO: * This symbol, if defined, indicates that <net/errno.h> exists and * should be included. @@ -3444,6 +3438,12 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un #$d_suidsafe SETUID_SCRIPTS_ARE_SECURE_NOW /**/ #$d_dosuid DOSUID /**/ +/* I_NDBM: + * This symbol, if defined, indicates that <ndbm.h> exists and should + * be included. + */ +#$i_ndbm I_NDBM /**/ + /* I_STDARG: * This symbol, if defined, indicates that <stdarg.h> exists and should * be included. @@ -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) @@ -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 -p |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 diff --git a/ext/B/B.pm b/ext/B/B.pm index 90d3ff50db..46c834a2c4 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -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>. diff --git a/ext/B/B.xs b/ext/B/B.xs index f18efce96d..c9ca8b1962 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -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 diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm index fd7c1a9c93..f1019f043f 100644 --- a/ext/B/B/C.pm +++ b/ext/B/B/C.pm @@ -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/B/Deparse.pm b/ext/B/B/Deparse.pm index a6644fbe15..a0f0e78020 100644 --- a/ext/B/B/Deparse.pm +++ b/ext/B/B/Deparse.pm @@ -3627,7 +3627,10 @@ sub pp_split { my($op, $cx) = @_; my($kid, @exprs, $ary, $expr); $kid = $op->first; - if ($ {$kid->pmreplroot}) { + # under ithreads pmreplroot is an integer, not an SV + my $replroot = $kid->pmreplroot; + if ( ( ref($replroot) && $$replroot ) || + ( !ref($replroot) && $replroot ) ) { $ary = $self->stash_variable('@', $self->gv_name($kid->pmreplroot)); } for (; !null($kid); $kid = $kid->sibling) { diff --git a/ext/B/C/C.xs b/ext/B/C/C.xs new file mode 100644 index 0000000000..15c9c5c6fd --- /dev/null +++ b/ext/B/C/C.xs @@ -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 index 0000000000..7291b33a6d --- /dev/null +++ b/ext/B/C/Makefile.PL @@ -0,0 +1,8 @@ +#!perl + +use ExtUtils::MakeMaker; + +WriteMakefile( NAME => 'B::C', + VERSION_FROM => '../B/C.pm' + ); + diff --git a/ext/B/t/concise.t b/ext/B/t/concise.t index ad29c20329..a567a73202 100644 --- a/ext/B/t/concise.t +++ b/ext/B/t/concise.t @@ -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"); diff --git a/ext/Encode/encengine.c b/ext/Encode/encengine.c index 513ef9ac5b..4c2a7cf65a 100644 --- a/ext/Encode/encengine.c +++ b/ext/Encode/encengine.c @@ -92,73 +92,62 @@ we add a flag to re-add the removed byte to the source we could handle #include "encode.h" int -do_encode(encpage_t *enc, const U8 *src, STRLEN *slen, U8 *dst, STRLEN dlen, STRLEN *dout, int approx) +do_encode(encpage_t * enc, const U8 * src, STRLEN * slen, U8 * dst, + STRLEN dlen, STRLEN * dout, int approx) { - const U8 *s = src; - const U8 *send = s+*slen; - const U8 *last = s; - U8 *d = dst; - U8 *dend = d+dlen; - int code = 0; - while (s < send) - { - encpage_t *e = enc; - U8 byte = *s; - while (byte > e->max) - e++; - if (byte >= e->min && e->slen && (approx || !(e->slen & 0x80))) - { - const U8 *cend = s + (e->slen & 0x7f); - if (cend <= send) - { - STRLEN n; - if ((n = e->dlen)) - { - const U8 *out = e->seq+n*(byte - e->min); - U8 *oend = d+n; - if (dst) - { - if (oend <= dend) - { - while (d < oend) - *d++ = *out++; - } - else - { - /* Out of space */ - code = ENCODE_NOSPACE; - break; - } - } - else - d = oend; - } - enc = e->next; - s++; - if (s == cend) - { - if (approx && (e->slen & 0x80)) - code = ENCODE_FALLBACK; - last = s; - } - } - else - { - /* partial source character */ - code = ENCODE_PARTIAL; - break; - } + const U8 *s = src; + const U8 *send = s + *slen; + const U8 *last = s; + U8 *d = dst; + U8 *dend = d + dlen; + int code = 0; + while (s < send) { + encpage_t *e = enc; + U8 byte = *s; + while (byte > e->max) + e++; + if (byte >= e->min && e->slen && (approx || !(e->slen & 0x80))) { + const U8 *cend = s + (e->slen & 0x7f); + if (cend <= send) { + STRLEN n; + if ((n = e->dlen)) { + const U8 *out = e->seq + n * (byte - e->min); + U8 *oend = d + n; + if (dst) { + if (oend <= dend) { + while (d < oend) + *d++ = *out++; + } + else { + /* Out of space */ + code = ENCODE_NOSPACE; + break; + } + } + else + d = oend; + } + enc = e->next; + s++; + if (s == cend) { + if (approx && (e->slen & 0x80)) + code = ENCODE_FALLBACK; + last = s; + } + } + else { + /* partial source character */ + code = ENCODE_PARTIAL; + break; + } + } + else { + /* Cannot represent */ + code = ENCODE_NOREP; + break; + } } - else - { - /* Cannot represent */ - code = ENCODE_NOREP; - break; - } - } - *slen = last - src; - *dout = d - dst; - return code; + *slen = last - src; + *dout = d - dst; + return code; } - - diff --git a/ext/Unicode/Normalize/mkheader b/ext/Unicode/Normalize/mkheader index aa6a153bf1..7aef304794 100644 --- a/ext/Unicode/Normalize/mkheader +++ b/ext/Unicode/Normalize/mkheader @@ -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; } diff --git a/global.sym b/global.sym index 4710ebb225..5f0c9dec83 100644 --- a/global.sym +++ b/global.sym @@ -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 diff --git a/hints/vos.sh b/hints/vos.sh index 52523be46e..f4e97003b6 100644 --- a/hints/vos.sh +++ b/hints/vos.sh @@ -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" diff --git a/lib/CGI.pm b/lib/CGI.pm index 292e26234f..c07625df08 100644 --- a/lib/CGI.pm +++ b/lib/CGI.pm @@ -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) = @_; diff --git a/lib/CGI/Carp.pm b/lib/CGI/Carp.pm index a3b8b40678..dbb78c876f 100644 --- a/lib/CGI/Carp.pm +++ b/lib/CGI/Carp.pm @@ -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. diff --git a/lib/CGI/t/form.t b/lib/CGI/t/form.t index 612e2e1650..a6a90a6058 100755 --- a/lib/CGI/t/form.t +++ b/lib/CGI/t/form.t @@ -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 diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index 6c08d9a2c6..82b8f69dc7 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -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 diff --git a/lib/ExtUtils/t/MM_Unix.t b/lib/ExtUtils/t/MM_Unix.t index 1b918e8014..791b7581b4 100644 --- a/lib/ExtUtils/t/MM_Unix.t +++ b/lib/ExtUtils/t/MM_Unix.t @@ -34,7 +34,7 @@ my $os = ($ExtUtils::MM_Unix::Is_OS2 || 0) + ($ExtUtils::MM_Unix::Is_VMS || 0); ok ( $os <= 1, 'There can be only one (or none)'); -is ($ExtUtils::MM_Unix::VERSION, '1.12604', 'Should be that version'); +is ($ExtUtils::MM_Unix::VERSION, '1.12605', 'Should be that version'); # when the following calls like canonpath, catdir etc are replaced by # File::Spec calls, the test's become a bit pointless diff --git a/makedef.pl b/makedef.pl index 9f490e0b19..e2cc21b94e 100644 --- a/makedef.pl +++ b/makedef.pl @@ -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/patchlevel.h b/patchlevel.h index 5293ca2dd9..d924c17ad2 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -70,7 +70,7 @@ #if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT) static char *local_patches[] = { NULL - ,"DEVEL14190" + ,"DEVEL14225" ,NULL }; diff --git a/pod/perldelta.pod b/pod/perldelta.pod index b5f126c05a..f3f2a19300 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -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 diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 777b0dd80a..af78458acb 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -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, diff --git a/pod/perlfaq.pod b/pod/perlfaq.pod index 26290783c0..c3fcacd461 100644 --- a/pod/perlfaq.pod +++ b/pod/perlfaq.pod @@ -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 diff --git a/pod/perlfaq1.pod b/pod/perlfaq1.pod index 7a010a75ec..d8e4f9799d 100644 --- a/pod/perlfaq1.pod +++ b/pod/perlfaq1.pod @@ -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 diff --git a/pod/perlfaq2.pod b/pod/perlfaq2.pod index 0ad762c4fe..3ef958ffe7 100644 --- a/pod/perlfaq2.pod +++ b/pod/perlfaq2.pod @@ -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 diff --git a/pod/perlfaq3.pod b/pod/perlfaq3.pod index a592c57387..5a4e65010d 100644 --- a/pod/perlfaq3.pod +++ b/pod/perlfaq3.pod @@ -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 diff --git a/pod/perlfaq4.pod b/pod/perlfaq4.pod index abbb9a03cb..9d19337119 100644 --- a/pod/perlfaq4.pod +++ b/pod/perlfaq4.pod @@ -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 diff --git a/pod/perlfaq5.pod b/pod/perlfaq5.pod index ef7b5cb73f..fb0274ec9e 100644 --- a/pod/perlfaq5.pod +++ b/pod/perlfaq5.pod @@ -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 diff --git a/pod/perlfaq8.pod b/pod/perlfaq8.pod index 0f65a30762..1b1ab583ee 100644 --- a/pod/perlfaq8.pod +++ b/pod/perlfaq8.pod @@ -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 diff --git a/pod/perlunicode.pod b/pod/perlunicode.pod index 74b10e4f24..beb742efb1 100644 --- a/pod/perlunicode.pod +++ b/pod/perlunicode.pod @@ -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] @@ -639,11 +639,16 @@ Level 1 - Basic Unicode Support [ 5] have negation [ 6] can use look-ahead to emulate subtraction (*) [ 7] include Letters in word characters - [ 8] some cases of "ss"/"SS" matching U+00DF in a character - class are missing, but that is allowed according to the TR18. + [ 8] note that perl does Full casefolding in matching, not Simple: + for example U+1F88 is equivalent with U+1F000 U+03B9, + not with 1F80. This difference matters for certain Greek + capital letters with certain modifiers: the Full casefolding + decomposes the letter, while the Simple casefolding would map + it to a single character. [ 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 @@ -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; @@ -1235,9 +1235,7 @@ PP(pp_match) pm = PL_curpm; rx = PM_GETRE(pm); } - if (rx->minlen > len && - !PL_reg_match_utf8 /* ANYOFs can balloon to EXACTFs */ - ) + if (rx->minlen > len) goto failure; truebase = t = s; @@ -736,6 +736,50 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg n = nnext; } } + + if (UTF && OP(scan) == EXACTF && STR_LEN(scan) >= 6) { +/* + Two problematic code points in Unicode casefolding of EXACT nodes: + + U+0390 - GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS + U+03B0 - GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS + + which casefold to + + Unicode UTF-8 + + U+03B9 U+0308 U+0301 0xCE 0xB9 0xCC 0x88 0xCC 0x81 + U+03C5 U+0308 U+0301 0xCF 0x85 0xCC 0x88 0xCC 0x81 + + This means that in case-insensitive matching (or "loose matching", + as Unicode calls it), an EXACTF of length six (the UTF-8 encoded byte + length of the above casefolded versions) can match a target string + of length two (the byte length of UTF-8 encoded U+0390 or U+03B0). + This would rather mess up the minimum length computation. + + What we'll do is to look for the tail four bytes, and then peek + at the preceding two bytes to see whether we need to decrease + the minimum length by four (six minus two). + + Thanks to the design of UTF-8, there cannot be false matches: + A sequence of valid UTF-8 bytes cannot be a subsequence of + another valid sequence of UTF-8 bytes. + +*/ + char *s0 = STRING(scan), *s, *t; + char *s1 = s0 + STR_LEN(scan) - 1, *s2 = s1 - 4; + char *t0 = "\xcc\x88\xcc\x81"; + char *t1 = t0 + 3; + + for (s = s0 + 2; + s < s2 && (t = ninstr(s, s1, t0, t1)); + s = t + 4) { + if (((U8)t[-1] == 0xB9 && (U8)t[-2] == 0xCE) || + ((U8)t[-1] == 0x85 && (U8)t[-2] == 0xCF)) + min -= 4; + } + } + #ifdef DEBUGGING /* Allow dumping */ n = scan + NODE_SZ_STR(scan); @@ -111,7 +111,7 @@ #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) \ @@ -916,15 +916,19 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta switch (OP(c)) { case ANYOF: while (s < strend) { - if (reginclass(c, (U8*)s, do_utf8)) { + STRLEN skip = do_utf8 ? UTF8SKIP(s) : 1; + + if (reginclass(c, (U8*)s, do_utf8) || + (ANYOF_UNICODE_FOLD_SHARP_S(c, s, strend) && + (skip = 2))) { if (tmp && (norun || regtry(prog, s))) goto got_it; else tmp = doevery; } - else - tmp = 1; - s += do_utf8 ? UTF8SKIP(s) : 1; + else + tmp = 1; + s += skip; } break; case CANY: @@ -1012,12 +1016,12 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta c = utf8_to_uvchr((U8*)s, &len); /* Handle some of the three Greek sigmas cases. - * Note that not all the possible combinations - * are handled here: some of them are handled - * handled by the standard folding rules, and - * some of them (the character class or ANYOF - * cases) are handled during compiletime in - * regexec.c:S_regclass(). */ + * Note that not all the possible combinations + * are handled here: some of them are handled + * by the standard folding rules, and some of + * them (the character class or ANYOF cases) + * are handled during compiletime in + * regexec.c:S_regclass(). */ if (c == (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA || c == (UV)UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA) c = (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA; @@ -1554,9 +1558,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * } minlen = prog->minlen; - if (strend - startpos < minlen && - !PL_reg_match_utf8 /* ANYOFs can balloon to EXACTFs */ - ) { + if (strend - startpos < minlen) { DEBUG_r(PerlIO_printf(Perl_debug_log, "String too short [regexec_flags]...\n")); goto phooey; @@ -2110,6 +2112,7 @@ typedef union re_unwind_t { #define sayYES goto yes #define sayNO goto no +#define sayNO_ANYOF goto no_anyof #define sayYES_FINAL goto yes_final #define sayYES_LOUD goto yes_loud #define sayNO_FINAL goto no_final @@ -2370,8 +2373,20 @@ S_regmatch(pTHX_ regnode *prog) char *e = PL_regeol; if (ibcmp_utf8(s, 0, ln, do_utf8, - l, &e, 0, UTF)) - sayNO; + l, &e, 0, UTF)) { + /* One more case for the sharp s: + * pack("U0U*", 0xDF) =~ /ss/i, + * the 0xC3 0x9F are the UTF-8 + * byte sequence for the U+00DF. */ + if (!(do_utf8 && + toLOWER(s[0]) == 's' && + ln >= 2 && + toLOWER(s[1]) == 's' && + (U8)l[0] == 0xC3 && + e - l >= 2 && + (U8)l[1] == 0x9F)) + sayNO; + } locinput = e; nextchr = UCHARAT(locinput); break; @@ -2398,21 +2413,33 @@ S_regmatch(pTHX_ regnode *prog) STRLEN inclasslen = PL_regeol - locinput; if (!reginclasslen(scan, (U8*)locinput, &inclasslen, do_utf8)) - sayNO; + sayNO_ANYOF; if (locinput >= PL_regeol) sayNO; locinput += inclasslen; nextchr = UCHARAT(locinput); + break; } else { if (nextchr < 0) nextchr = UCHARAT(locinput); if (!reginclass(scan, (U8*)locinput, do_utf8)) - sayNO; + sayNO_ANYOF; if (!nextchr && locinput >= PL_regeol) sayNO; nextchr = UCHARAT(++locinput); + break; } + no_anyof: + /* If we might have the case of the German sharp s + * in a casefolding Unicode character class. */ + + if (ANYOF_UNICODE_FOLD_SHARP_S(scan, locinput, PL_regeol)) { + locinput += 2; + nextchr = UCHARAT(locinput); + } + else + sayNO; break; case ALNUML: PL_reg_flags |= RF_tainted; @@ -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); @@ -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' ) { diff --git a/t/lib/warnings/pp b/t/lib/warnings/pp index 2f4bf7b068..5ed7aa0891 100644 --- a/t/lib/warnings/pp +++ b/t/lib/warnings/pp @@ -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' ; diff --git a/t/op/hashwarn.t b/t/op/hashwarn.t index 8466a7196e..3db2b46917 100755 --- a/t/op/hashwarn.t +++ b/t/op/hashwarn.t @@ -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 ]; diff --git a/t/op/pat.t b/t/op/pat.t index 467e0a29d0..d9e8c3d43d 100755 --- a/t/op/pat.t +++ b/t/op/pat.t @@ -6,7 +6,7 @@ $| = 1; -print "1..846\n"; +print "1..854\n"; BEGIN { chdir 't' if -d 't'; @@ -2602,33 +2602,37 @@ print "# some Unicode properties\n"; print "SS" =~ /\N{LATIN SMALL LETTER SHARP S}/i ? "ok 840\n" : "not ok 840\n"; -# These are a bit tricky. Since the LATIN SMALL LETTER SHARP S is U+00DF, -# the ANYOF reduces to a byte. The Unicodeness needs to be caught earlier. -# print "ss" =~ -# /[\N{LATIN SMALL LETTER SHARP S}]/i ? "ok 841\n" : "not ok 841\n"; -# -# print "SS" =~ -# /[\N{LATIN SMALL LETTER SHARP S}]/i ? "ok 842\n" : "not ok 842\n"; + print "ss" =~ + /[\N{LATIN SMALL LETTER SHARP S}]/i ? "ok 841\n" : "not ok 841\n"; + + print "SS" =~ + /[\N{LATIN SMALL LETTER SHARP S}]/i ? "ok 842\n" : "not ok 842\n"; + + print "\N{LATIN SMALL LETTER SHARP S}" =~ /ss/i ? + "ok 843\n" : "not ok 843\n"; + + print "\N{LATIN SMALL LETTER SHARP S}" =~ /SS/i ? + "ok 844\n" : "not ok 844\n"; } { print "# more whitespace: U+0085, U+2028, U+2029\n"; # U+0085 needs to be forced to be Unicode, the \x{100} does that. - print "<\x{100}\x{0085}>" =~ /<\x{100}\s>/ ? "ok 841\n" : "not ok 841\n"; - print "<\x{2028}>" =~ /<\s>/ ? "ok 842\n" : "not ok 842\n"; - print "<\x{2029}>" =~ /<\s>/ ? "ok 843\n" : "not ok 843\n"; + print "<\x{100}\x{0085}>" =~ /<\x{100}\s>/ ? "ok 845\n" : "not ok 845\n"; + print "<\x{2028}>" =~ /<\s>/ ? "ok 846\n" : "not ok 846\n"; + print "<\x{2029}>" =~ /<\s>/ ? "ok 847\n" : "not ok 847\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}"; # This is not expected to match: the point is that # neither should we get "Malformed UTF-8" warnings. print $s =~ /\G(.+?)\n/gcs ? - "not ok 844\n" : "ok 844\n"; + "not ok 848\n" : "ok 848\n"; my @c; @@ -2636,7 +2640,7 @@ print "# some Unicode properties\n"; push @c, $1; } - print join("", @c) eq $s ? "ok 845\n" : "not ok 845\n"; + print join("", @c) eq $s ? "ok 849\n" : "not ok 849\n"; my $t1 = "Q003\n\n\x{e4}\x{f6}\n\nQ004\n\n\x{e7}"; # test only chars < 256 my $r1 = ""; @@ -2650,5 +2654,14 @@ print "# some Unicode properties\n"; $r2 .= $1 . $2; } $r2 =~ s/\x{100}//; - print $r1 eq $r2 ? "ok 846\n" : "not ok 846\n"; + print $r1 eq $r2 ? "ok 850\n" : "not ok 850\n"; +} + +{ + print "# Unicode lookbehind\n"; + + print "A\x{100}B" =~ /(?<=A.)B/ ? "ok 851\n" : "not ok 851\n"; + print "A\x{200}\x{300}B" =~ /(?<=A..)B/ ? "ok 852\n" : "not ok 852\n"; + print "\x{400}AB" =~ /(?<=\x{400}.)B/ ? "ok 853\n" : "not ok 853\n"; + print "\x{500\x{600}}B" =~ /(?<=\x{500}.)B/ ? "ok 854\n" : "not ok 854\n"; } diff --git a/t/op/unisprintf.t b/t/op/unisprintf.t new file mode 100644 index 0000000000..3c5f574b62 --- /dev/null +++ b/t/op/unisprintf.t @@ -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"); +} diff --git a/t/run/kill_perl.t b/t/run/kill_perl.t index 9d3a641407..3ee283149a 100644 --- a/t/run/kill_perl.t +++ b/t/run/kill_perl.t @@ -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"; } @@ -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) { @@ -189,6 +189,7 @@ END_EXTERN_C #define UTF8_IS_ASCII(c) UTF8_IS_INVARIANT(c) +#define UNICODE_LATIN_SMALL_LETTER_SHARP_S 0x00DF #define UNICODE_GREEK_CAPITAL_LETTER_SIGMA 0x03A3 #define UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA 0x03C2 #define UNICODE_GREEK_SMALL_LETTER_SIGMA 0x03C3 @@ -198,3 +199,10 @@ END_EXTERN_C #define UNI_DISPLAY_QQ (UNI_DISPLAY_ISPRINT|UNI_DISPLAY_BACKSLASH) #define UNI_DISPLAY_REGEX (UNI_DISPLAY_ISPRINT|UNI_DISPLAY_BACKSLASH) +#define ANYOF_UNICODE_FOLD_SHARP_S(n, s, e) \ + (ANYOF_BITMAP_TEST(n, UNICODE_LATIN_SMALL_LETTER_SHARP_S) && \ + ANYOF_FLAGS(n) & ANYOF_UNICODE && \ + ANYOF_FLAGS(n) & ANYOF_FOLD && \ + ((e) > (s) + 1) && \ + toLOWER((s)[0]) == 's' && \ + toLOWER((s)[1]) == 's') diff --git a/utils/perlcc.PL b/utils/perlcc.PL index 51f52eda5a..15a276a3cb 100644 --- a/utils/perlcc.PL +++ b/utils/perlcc.PL @@ -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"; diff --git a/utils/perldoc.PL b/utils/perldoc.PL index ea381a48b7..62a82f381f 100644 --- a/utils/perldoc.PL +++ b/utils/perldoc.PL @@ -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 !$@ && $< && $>; } |