From: Marcus Holland-Moritz Date: Tue, 17 Aug 2004 21:33:41 +0000 (+0000) Subject: Upgrade to Devel::PPPort 3.00_01. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=96ad942f8d2c927db846bf31c9b14b2779e6f99f;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Devel::PPPort 3.00_01. p4raw-id: //depot/perl@23223 --- diff --git a/MANIFEST b/MANIFEST index 832ec79..a78ee0b 100644 --- a/MANIFEST +++ b/MANIFEST @@ -238,6 +238,7 @@ ext/Devel/PPPort/parts/inc/newRV Devel::PPPort include ext/Devel/PPPort/parts/inc/ppphbin Devel::PPPort include ext/Devel/PPPort/parts/inc/ppphdoc Devel::PPPort include ext/Devel/PPPort/parts/inc/ppphtest Devel::PPPort include +ext/Devel/PPPort/parts/inc/sv_xpvf Devel::PPPort include ext/Devel/PPPort/parts/inc/SvPV Devel::PPPort include ext/Devel/PPPort/parts/inc/threads Devel::PPPort include ext/Devel/PPPort/parts/inc/uv Devel::PPPort include @@ -278,6 +279,7 @@ ext/Devel/PPPort/PPPort_xs.PL Devel::PPPort PPPort.xs writer ext/Devel/PPPort/README Devel::PPPort Readme ext/Devel/PPPort/soak Devel::PPPort Test Harness to run under various Perls ext/Devel/PPPort/t/call.t Devel::PPPort test file +ext/Devel/PPPort/t/cop.t Devel::PPPort test file ext/Devel/PPPort/t/grok.t Devel::PPPort test file ext/Devel/PPPort/t/limits.t Devel::PPPort test file ext/Devel/PPPort/t/magic.t Devel::PPPort test file @@ -287,10 +289,11 @@ ext/Devel/PPPort/t/MY_CXT.t Devel::PPPort test file ext/Devel/PPPort/t/newCONSTSUB.t Devel::PPPort test file ext/Devel/PPPort/t/newRV.t Devel::PPPort test file ext/Devel/PPPort/t/ppphtest.t Devel::PPPort test file +ext/Devel/PPPort/t/sv_xpvf.t Devel::PPPort test file ext/Devel/PPPort/t/SvPV.t Devel::PPPort test file ext/Devel/PPPort/t/testutil.pl Devel::PPPort test utilities ext/Devel/PPPort/t/threads.t Devel::PPPort test file -ext/Devel/PPPort/t/uv.t Devel::PPPort test file +ext/Devel/PPPort/t/uv.t Devel::PPPort test file ext/Devel/PPPort/TODO Devel::PPPort Todo ext/Devel/PPPort/typemap Devel::PPPort Typemap ext/Digest/MD5/Changes Digest::MD5 extension changes diff --git a/ext/Devel/PPPort/Changes b/ext/Devel/PPPort/Changes index 091ee80..bc62894 100755 --- a/ext/Devel/PPPort/Changes +++ b/ext/Devel/PPPort/Changes @@ -1,3 +1,34 @@ +3.00_01 - 2004-08-17 + + * fixed problems with $^X in t/ppphtest.t when building in + the core on OpenBSD + * fixed a "duplicate dependencies" bug that could lead to + global NEED_'s where static NEED_'s are sufficient + * added support for the following API: + PL_DBsingle + PL_DBsub + PL_debstash + PL_diehook + PL_errgv + PL_no_modify + PL_perl_destruct_level + PL_ppaddr + PL_stack_sp + PL_sv_arenaroot + PL_tainted + PL_tainting + PUSHu + sv_catpvf_mg + sv_catpvf_mg_nocontext + sv_setpvf_mg + sv_setpvf_mg_nocontext + sv_vcatpvf + sv_vcatpvf_mg + sv_vsetpvf + sv_vsetpvf_mg + vnewSVpvf + XPUSHu + 3.00 - 2004-08-16 * added support for dAX and dITEMS, which got lost while diff --git a/ext/Devel/PPPort/MANIFEST b/ext/Devel/PPPort/MANIFEST index 3f6da6b..d05e8ae 100644 --- a/ext/Devel/PPPort/MANIFEST +++ b/ext/Devel/PPPort/MANIFEST @@ -57,6 +57,7 @@ parts/inc/newRV parts/inc/ppphbin parts/inc/ppphdoc parts/inc/ppphtest +parts/inc/sv_xpvf parts/inc/SvPV parts/inc/threads parts/inc/uv @@ -97,6 +98,7 @@ PPPort_xs.PL README soak t/call.t +t/cop.t t/grok.t t/limits.t t/magic.t @@ -106,6 +108,7 @@ t/MY_CXT.t t/newCONSTSUB.t t/newRV.t t/ppphtest.t +t/sv_xpvf.t t/SvPV.t t/testutil.pl t/threads.t diff --git a/ext/Devel/PPPort/META.yml b/ext/Devel/PPPort/META.yml index bb728d7..d850858 100644 --- a/ext/Devel/PPPort/META.yml +++ b/ext/Devel/PPPort/META.yml @@ -1,7 +1,7 @@ # http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Devel-PPPort -version: 3.00 +version: 3.00_01 version_from: PPPort_pm.PL installdirs: perl requires: diff --git a/ext/Devel/PPPort/PPPort.pm b/ext/Devel/PPPort/PPPort.pm index a6ab618..5ea849b 100644 --- a/ext/Devel/PPPort/PPPort.pm +++ b/ext/Devel/PPPort/PPPort.pm @@ -8,9 +8,9 @@ # ################################################################################ # -# $Revision: 28 $ +# $Revision: 30 $ # $Author: mhx $ -# $Date: 2004/08/13 12:49:22 +0200 $ +# $Date: 2004/08/17 20:01:49 +0200 $ # ################################################################################ # @@ -265,21 +265,33 @@ in older Perl releases: PL_copline PL_curcop PL_curstash + PL_DBsingle + PL_DBsub + PL_debstash PL_defgv + PL_diehook PL_dirty PL_dowarn + PL_errgv PL_hexdigit PL_hints PL_na + PL_no_modify + PL_perl_destruct_level PL_perldb + PL_ppaddr PL_rsfp PL_rsfp_filters PL_stack_base + PL_stack_sp PL_stdingv PL_Sv + PL_sv_arenaroot PL_sv_no PL_sv_undef PL_sv_yes + PL_tainted + PL_tainting pMY_CXT pMY_CXT_ Poison @@ -291,12 +303,15 @@ in older Perl releases: PTR2UV PTRV PUSHmortal + PUSHu SAVE_DEFSV START_MY_CXT sv_2pv_nolen sv_2pvbyte sv_2uv sv_catpv_mg + sv_catpvf_mg + sv_catpvf_mg_nocontext sv_catpvn_mg sv_catpvn_nomg sv_catsv_mg @@ -307,6 +322,8 @@ in older Perl releases: sv_setiv_mg sv_setnv_mg sv_setpv_mg + sv_setpvf_mg + sv_setpvf_mg_nocontext sv_setpvn_mg sv_setsv_mg sv_setsv_nomg @@ -314,6 +331,10 @@ in older Perl releases: sv_setuv_mg sv_usepvn_mg sv_uv + sv_vcatpvf + sv_vcatpvf_mg + sv_vsetpvf + sv_vsetpvf_mg SvGETMAGIC SvIV_nomg SvPV_force_nomg @@ -332,7 +353,9 @@ in older Perl releases: UVuf UVXf UVxf + vnewSVpvf XPUSHmortal + XPUSHu XSRETURN_UV XST_mUV ZeroD @@ -667,10 +690,6 @@ Perl below which it is unsupported: sv_utf8_decode sv_utf8_downgrade sv_utf8_encode - sv_vcatpvf - sv_vcatpvf_mg - sv_vsetpvf - sv_vsetpvf_mg swash_init tmps_grow to_uni_lower_lc @@ -682,7 +701,6 @@ Perl below which it is unsupported: vform vload_module vmess - vnewSVpvf vwarn vwarner warner @@ -727,8 +745,6 @@ Perl below which it is unsupported: do_binmode save_aelem save_helem - sv_catpvf_mg - sv_setpvf_mg =item perl 5.004_04 @@ -747,14 +763,12 @@ Perl below which it is unsupported: HeSVKEY_force HeSVKEY_set HeVAL - PUSHu SvSetMagicSV SvSetMagicSV_nosteal SvSetSV_nosteal SvTAINTED SvTAINTED_off SvTAINTED_on - XPUSHu block_gimme call_list cv_const_sv @@ -785,16 +799,23 @@ Perl below which it is unsupported: save_gp start_subparse sv_catpvf + sv_catpvf_mg sv_cmp_locale sv_derived_from sv_gets sv_setpvf + sv_setpvf_mg sv_taint sv_tainted sv_untaint + sv_vcatpvf + sv_vcatpvf_mg sv_vcatpvfn + sv_vsetpvf + sv_vsetpvf_mg sv_vsetpvfn unsharepvn + vnewSVpvf =back @@ -845,7 +866,7 @@ require DynaLoader; use strict; use vars qw($VERSION @ISA $data); -$VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.00 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' }; +$VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.00_01 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' }; @ISA = qw(DynaLoader); @@ -1053,18 +1074,23 @@ POD POD Note that you mustn't have more than one global request for one POD function in your project. POD -POD Function Static Request Global Request -POD ----------------------------------------------------------------------------- -POD eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL -POD grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL -POD grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL -POD grok_number() NEED_grok_number NEED_grok_number_GLOBAL -POD grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL -POD grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL -POD newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL -POD newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL -POD sv_2pv_nolen() NEED_sv_2pv_nolen NEED_sv_2pv_nolen_GLOBAL -POD sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL +POD Function Static Request Global Request +POD ----------------------------------------------------------------------------------------- +POD eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL +POD grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL +POD grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL +POD grok_number() NEED_grok_number NEED_grok_number_GLOBAL +POD grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL +POD grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL +POD newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL +POD newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL +POD sv_2pv_nolen() NEED_sv_2pv_nolen NEED_sv_2pv_nolen_GLOBAL +POD sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL +POD sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL +POD sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL +POD sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL +POD sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL +POD vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL POD POD To avoid namespace conflicts, you can change the namespace of the POD explicitly exported functions using the C macro. @@ -1418,32 +1444,42 @@ PERL_UQUAD_MIN|5.004000||p PERL_USHORT_MAX|5.004000||p PERL_USHORT_MIN|5.004000||p PERL_VERSION|5.006000||p -PL_DBsingle|||n -PL_DBsub|||n +PL_DBsingle|||pn +PL_DBsub|||pn PL_DBtrace|||n PL_Sv|5.005000||p PL_compiling|5.004050||p PL_copline|5.005000||p PL_curcop|5.004050||p PL_curstash|5.004050||p +PL_debstash|||p PL_defgv|5.004050||p +PL_diehook|||p PL_dirty|5.004050||p PL_dowarn|||pn +PL_errgv|||p PL_hexdigit|5.005000||p PL_hints|5.005000||p PL_last_in_gv|||n PL_modglobal||5.005000|n PL_na|5.004050||pn +PL_no_modify|||p PL_ofs_sv|||n +PL_perl_destruct_level|||p PL_perldb|5.004050||p +PL_ppaddr|||p PL_rsfp_filters|5.004050||p PL_rsfp|5.004050||p PL_rs|||n PL_stack_base|||p +PL_stack_sp|||p PL_stdingv|5.004050||p +PL_sv_arenaroot|||p PL_sv_no|5.004050||pn PL_sv_undef|5.004050||pn PL_sv_yes|5.004050||pn +PL_tainted|||p +PL_tainting|||p POPi|||n POPl|||n POPn|||n @@ -1462,7 +1498,7 @@ PUSHmortal|5.009002||p PUSHn||| PUSHp||| PUSHs||| -PUSHu||5.004000| +PUSHu|5.004000||p PUTBACK||| PerlIO_clearerr||5.007003| PerlIO_close||5.007003| @@ -1612,7 +1648,7 @@ XPUSHmortal|5.009002||p XPUSHn||| XPUSHp||| XPUSHs||| -XPUSHu||5.004000| +XPUSHu|5.004000||p XSRETURN_EMPTY||| XSRETURN_IV||| XSRETURN_NO||| @@ -2586,8 +2622,8 @@ sv_backoff||| sv_bless||| sv_cat_decode||5.008001| sv_catpv_mg|5.006000||p -sv_catpvf_mg_nocontext|||vn -sv_catpvf_mg||5.004050|v +sv_catpvf_mg_nocontext|||pvn +sv_catpvf_mg|5.006000|5.004000|pv sv_catpvf_nocontext|||vn sv_catpvf||5.004000|v sv_catpvn_flags||5.007002| @@ -2664,8 +2700,8 @@ sv_setiv||| sv_setnv_mg|5.006000||p sv_setnv||| sv_setpv_mg|5.006000||p -sv_setpvf_mg_nocontext|||vn -sv_setpvf_mg||5.004050|v +sv_setpvf_mg_nocontext|||pvn +sv_setpvf_mg|5.006000|5.004000|pv sv_setpvf_nocontext|||vn sv_setpvf||5.004000|v sv_setpviv_mg||5.008001| @@ -2703,12 +2739,12 @@ sv_utf8_encode||5.006000| sv_utf8_upgrade_flags||5.007002| sv_utf8_upgrade||5.007001| sv_uv|5.006000||p -sv_vcatpvf_mg||5.006000| +sv_vcatpvf_mg|5.006000|5.004000|p sv_vcatpvfn||5.004000| -sv_vcatpvf||5.006000| -sv_vsetpvf_mg||5.006000| +sv_vcatpvf|5.006000|5.004000|p +sv_vsetpvf_mg|5.006000|5.004000|p sv_vsetpvfn||5.004000| -sv_vsetpvf||5.006000| +sv_vsetpvf|5.006000|5.004000|p svtype||| swallow_bom||| swash_fetch||5.007002| @@ -2782,7 +2818,7 @@ vivify_defelem||| vivify_ref||| vload_module||5.006000| vmess||5.006000| -vnewSVpvf||5.006000| +vnewSVpvf|5.006000|5.004000|p vnormal||5.009002| vnumify||5.009000| vparse_body||| @@ -2911,19 +2947,16 @@ for $filename (@files) { if (exists $API{$func}{provided}) { if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { $file{uses}{$func}++; - push @{$global{uses}{$func}}, $filename; my @deps = rec_depend($func); if (@deps) { $file{uses_deps}{$func} = \@deps; for (@deps) { $file{uses}{$_} = 0 unless exists $file{uses}{$_}; - push @{$global{uses}{$_}}, $filename; } } for ($func, @deps) { if (exists $need{$_}) { $file{needs}{$_} = 'static'; - push @{$global{needs}{$_}}, $filename; } } } @@ -2931,7 +2964,6 @@ for $filename (@files) { if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { if ($c =~ /\b$func\b/) { $file{uses_todo}{$func}++; - push @{$global{uses_todo}{$func}}, $filename; } } } @@ -2940,13 +2972,18 @@ for $filename (@files) { while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { if (exists $need{$2}) { $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; - push @{$global{defined $3 ? 'needed_global' : 'needed_static'}{$2}}, $filename; } else { warning("Possibly wrong #define $1 in $filename"); } } + for (qw(uses needs uses_todo needed_global needed_static)) { + for $func (keys %{$file{$_}}) { + push @{$global{$_}{$func}}, $filename; + } + } + $files{$filename} = \%file; } @@ -3245,8 +3282,9 @@ sub can_use sub rec_depend { my $func = shift; + my %seen; return () unless exists $depends{$func}; - map { ($_, rec_depend($_)) } @{$depends{$func}}; + grep !$seen{$_}++, map { ($_, rec_depend($_)) } @{$depends{$func}}; } sub parse_version @@ -3781,27 +3819,47 @@ __DATA__ #ifndef XSRETURN_UV # define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END #endif +#ifndef PUSHu +# define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END +#endif + +#ifndef XPUSHu +# define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END +#endif #if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5)) /* Replace: 1 */ -# define PL_Sv Sv -# define PL_compiling compiling -# define PL_copline copline -# define PL_curcop curcop -# define PL_curstash curstash -# define PL_defgv defgv -# define PL_dirty dirty -# define PL_dowarn dowarn -# define PL_hints hints -# define PL_na na -# define PL_perldb perldb -# define PL_rsfp_filters rsfp_filters -# define PL_rsfp rsfp -# define PL_stdingv stdingv -# define PL_sv_no sv_no -# define PL_sv_undef sv_undef -# define PL_sv_yes sv_yes -# define PL_hexdigit hexdigit +# define PL_DBsingle DBsingle +# define PL_DBsub DBsub +# define PL_Sv Sv +# define PL_compiling compiling +# define PL_copline copline +# define PL_curcop curcop +# define PL_curstash curstash +# define PL_debstash debstash +# define PL_defgv defgv +# define PL_diehook diehook +# define PL_dirty dirty +# define PL_dowarn dowarn +# define PL_errgv errgv +# define PL_hexdigit hexdigit +# define PL_hints hints +# define PL_na na +# define PL_no_modify no_modify +# define PL_perl_destruct_level perl_destruct_level +# define PL_perldb perldb +# define PL_ppaddr ppaddr +# define PL_rsfp_filters rsfp_filters +# define PL_rsfp rsfp +# define PL_stack_base stack_base +# define PL_stack_sp stack_sp +# define PL_stdingv stdingv +# define PL_sv_arenaroot sv_arenaroot +# define PL_sv_no sv_no +# define PL_sv_undef sv_undef +# define PL_sv_yes sv_yes +# define PL_tainted tainted +# define PL_tainting tainting /* Replace: 0 */ #endif @@ -4061,22 +4119,22 @@ typedef NVTYPE NV; #ifndef eval_pv #if defined(NEED_eval_pv) -static SV* DPPP_(eval_pv)(char *p, I32 croak_on_error); +static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); static #else -extern SV* DPPP_(eval_pv)(char *p, I32 croak_on_error); +extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); #endif #ifdef eval_pv # undef eval_pv #endif -#define eval_pv(a,b) DPPP_(eval_pv)(aTHX_ a,b) -#define Perl_eval_pv DPPP_(eval_pv) +#define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) +#define Perl_eval_pv DPPP_(my_eval_pv) #if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) SV* -DPPP_(eval_pv)(char *p, I32 croak_on_error) +DPPP_(my_eval_pv)(char *p, I32 croak_on_error) { dSP; SV* sv = newSVpv(p, 0); @@ -4103,21 +4161,21 @@ DPPP_(eval_pv)(char *p, I32 croak_on_error) #ifndef newRV_noinc #if defined(NEED_newRV_noinc) -static SV * DPPP_(newRV_noinc)(SV *sv); +static SV * DPPP_(my_newRV_noinc)(SV *sv); static #else -extern SV * DPPP_(newRV_noinc)(SV *sv); +extern SV * DPPP_(my_newRV_noinc)(SV *sv); #endif #ifdef newRV_noinc # undef newRV_noinc #endif -#define newRV_noinc(a) DPPP_(newRV_noinc)(aTHX_ a) -#define Perl_newRV_noinc DPPP_(newRV_noinc) +#define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) +#define Perl_newRV_noinc DPPP_(my_newRV_noinc) #if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) SV * -DPPP_(newRV_noinc)(SV *sv) +DPPP_(my_newRV_noinc)(SV *sv) { SV *rv = (SV *)newRV(sv); SvREFCNT_dec(sv); @@ -4134,22 +4192,22 @@ DPPP_(newRV_noinc)(SV *sv) /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ #if ((PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))) && ((PERL_VERSION != 4) || (PERL_SUBVERSION != 5)) #if defined(NEED_newCONSTSUB) -static void DPPP_(newCONSTSUB)(HV *stash, char *name, SV *sv); +static void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv); static #else -extern void DPPP_(newCONSTSUB)(HV *stash, char *name, SV *sv); +extern void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv); #endif #ifdef newCONSTSUB # undef newCONSTSUB #endif -#define newCONSTSUB(a,b,c) DPPP_(newCONSTSUB)(aTHX_ a,b,c) -#define Perl_newCONSTSUB DPPP_(newCONSTSUB) +#define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) +#define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) void -DPPP_(newCONSTSUB)(HV *stash, char *name, SV *sv) +DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv) { U32 oldhints = PL_hints; HV *old_cop_stash = PL_curcop->cop_stash; @@ -4305,22 +4363,22 @@ DPPP_(newCONSTSUB)(HV *stash, char *name, SV *sv) #ifndef SvPV_nolen #if defined(NEED_sv_2pv_nolen) -static char * DPPP_(sv_2pv_nolen)(pTHX_ register SV *sv); +static char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv); static #else -extern char * DPPP_(sv_2pv_nolen)(pTHX_ register SV *sv); +extern char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv); #endif #ifdef sv_2pv_nolen # undef sv_2pv_nolen #endif -#define sv_2pv_nolen(a) DPPP_(sv_2pv_nolen)(aTHX_ a) -#define Perl_sv_2pv_nolen DPPP_(sv_2pv_nolen) +#define sv_2pv_nolen(a) DPPP_(my_sv_2pv_nolen)(aTHX_ a) +#define Perl_sv_2pv_nolen DPPP_(my_sv_2pv_nolen) #if defined(NEED_sv_2pv_nolen) || defined(NEED_sv_2pv_nolen_GLOBAL) char * -DPPP_(sv_2pv_nolen)(pTHX_ register SV *sv) +DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv) { STRLEN n_a; return sv_2pv(sv, &n_a); @@ -4349,22 +4407,22 @@ DPPP_(sv_2pv_nolen)(pTHX_ register SV *sv) #if ((PERL_VERSION < 7) || ((PERL_VERSION == 7) && (PERL_SUBVERSION < 0))) #if defined(NEED_sv_2pvbyte) -static char * DPPP_(sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp); +static char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp); static #else -extern char * DPPP_(sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp); +extern char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp); #endif #ifdef sv_2pvbyte # undef sv_2pvbyte #endif -#define sv_2pvbyte(a,b) DPPP_(sv_2pvbyte)(aTHX_ a,b) -#define Perl_sv_2pvbyte DPPP_(sv_2pvbyte) +#define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) +#define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) #if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) char * -DPPP_(sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp) +DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp) { sv_utf8_downgrade(sv,0); return SvPV(sv,*lp); @@ -4410,6 +4468,189 @@ DPPP_(sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp) #ifndef sv_pvn_force # define sv_pvn_force(sv, len) SvPV_force(sv, len) #endif + +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(vnewSVpvf) +#if defined(NEED_vnewSVpvf) +static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args); +static +#else +extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args); +#endif + +#ifdef vnewSVpvf +# undef vnewSVpvf +#endif +#define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) +#define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) + +#if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) + +SV * +DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) +{ + register SV *sv = newSV(0); + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + return sv; +} + +#endif +#endif + +/* sv_vcatpvf depends on sv_vcatpvfn */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf) +# define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +/* sv_vsetpvf depends on sv_vsetpvfn */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf) +# define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +/* sv_catpvf_mg depends on sv_vcatpvfn, sv_catpvf_mg_nocontext */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg) +#if defined(NEED_sv_catpvf_mg) +static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...); +#endif + +#define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) + +#if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +/* sv_catpvf_mg_nocontext depends on sv_vcatpvfn */ +#ifdef PERL_IMPLICIT_CONTEXT +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg_nocontext) +#if defined(NEED_sv_catpvf_mg_nocontext) +static void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...); +#endif + +#define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) +#define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) + +#if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +#ifndef sv_catpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext +# else +# define sv_catpvf_mg Perl_sv_catpvf_mg +# endif +#endif + +/* sv_vcatpvf_mg depends on sv_vcatpvfn */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf_mg) +# define sv_vcatpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +/* sv_setpvf_mg depends on sv_vsetpvfn, sv_setpvf_mg_nocontext */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg) +#if defined(NEED_sv_setpvf_mg) +static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...); +#endif + +#define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) + +#if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +/* sv_setpvf_mg_nocontext depends on sv_vsetpvfn */ +#ifdef PERL_IMPLICIT_CONTEXT +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg_nocontext) +#if defined(NEED_sv_setpvf_mg_nocontext) +static void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...); +#endif + +#define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) +#define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) + +#if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +#ifndef sv_setpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext +# else +# define sv_setpvf_mg Perl_sv_setpvf_mg +# endif +#endif + +/* sv_vsetpvf_mg depends on sv_vsetpvfn */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf_mg) +# define sv_vsetpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif #ifndef SvGETMAGIC # define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END #endif @@ -4842,21 +5083,21 @@ DPPP_(sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp) #ifndef grok_numeric_radix #if defined(NEED_grok_numeric_radix) -static bool DPPP_(grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); static #else -extern bool DPPP_(grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); #endif #ifdef grok_numeric_radix # undef grok_numeric_radix #endif -#define grok_numeric_radix(a,b) DPPP_(grok_numeric_radix)(aTHX_ a,b) -#define Perl_grok_numeric_radix DPPP_(grok_numeric_radix) +#define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) +#define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) #if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) bool -DPPP_(grok_numeric_radix)(pTHX_ const char **sp, const char *send) +DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) { #ifdef USE_LOCALE_NUMERIC #ifdef PL_numeric_radix_sv @@ -4900,21 +5141,21 @@ DPPP_(grok_numeric_radix)(pTHX_ const char **sp, const char *send) #ifndef grok_number #if defined(NEED_grok_number) -static int DPPP_(grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); static #else -extern int DPPP_(grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); #endif #ifdef grok_number # undef grok_number #endif -#define grok_number(a,b,c) DPPP_(grok_number)(aTHX_ a,b,c) -#define Perl_grok_number DPPP_(grok_number) +#define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) +#define Perl_grok_number DPPP_(my_grok_number) #if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) int -DPPP_(grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) +DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) { const char *s = pv; const char *send = pv + len; @@ -5114,21 +5355,21 @@ DPPP_(grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) #ifndef grok_bin #if defined(NEED_grok_bin) -static UV DPPP_(grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +static UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); static #else -extern UV DPPP_(grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +extern UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); #endif #ifdef grok_bin # undef grok_bin #endif -#define grok_bin(a,b,c,d) DPPP_(grok_bin)(aTHX_ a,b,c,d) -#define Perl_grok_bin DPPP_(grok_bin) +#define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) +#define Perl_grok_bin DPPP_(my_grok_bin) #if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) UV -DPPP_(grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) +DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; @@ -5216,21 +5457,21 @@ DPPP_(grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) #ifndef grok_hex #if defined(NEED_grok_hex) -static UV DPPP_(grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +static UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); static #else -extern UV DPPP_(grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +extern UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); #endif #ifdef grok_hex # undef grok_hex #endif -#define grok_hex(a,b,c,d) DPPP_(grok_hex)(aTHX_ a,b,c,d) -#define Perl_grok_hex DPPP_(grok_hex) +#define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) +#define Perl_grok_hex DPPP_(my_grok_hex) #if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) UV -DPPP_(grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) +DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; @@ -5318,21 +5559,21 @@ DPPP_(grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) #ifndef grok_oct #if defined(NEED_grok_oct) -static UV DPPP_(grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +static UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); static #else -extern UV DPPP_(grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +extern UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); #endif #ifdef grok_oct # undef grok_oct #endif -#define grok_oct(a,b,c,d) DPPP_(grok_oct)(aTHX_ a,b,c,d) -#define Perl_grok_oct DPPP_(grok_oct) +#define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) +#define Perl_grok_oct DPPP_(my_grok_oct) #if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) UV -DPPP_(grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) +DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; diff --git a/ext/Devel/PPPort/PPPort.xs b/ext/Devel/PPPort/PPPort.xs index 4c30b35..4cee9d0 100644 --- a/ext/Devel/PPPort/PPPort.xs +++ b/ext/Devel/PPPort/PPPort.xs @@ -51,6 +51,13 @@ /* ---- from parts/inc/newRV ---- */ #define NEED_newRV_noinc +/* ---- from parts/inc/sv_xpvf ---- */ +#define NEED_vnewSVpvf +#define NEED_sv_catpvf_mg +#define NEED_sv_catpvf_mg_nocontext +#define NEED_sv_setpvf_mg +#define NEED_sv_setpvf_mg_nocontext + /* ---- from parts/inc/SvPV ---- */ #define NEED_sv_2pv_nolen #define NEED_sv_2pvbyte @@ -83,6 +90,45 @@ void call_newCONSTSUB_1(void) extern void call_newCONSTSUB_2(void); extern void call_newCONSTSUB_3(void); +/* ---- from parts/inc/sv_xpvf ---- */ +static SV * test_vnewSVpvf(pTHX_ const char *pat, ...) +{ + SV *sv; + va_list args; + va_start(args, pat); +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) + sv = vnewSVpvf(pat, &args); +#else + sv = newSVpv(pat, 0); +#endif + va_end(args); + return sv; +} + +static void test_sv_vcatpvf(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) + sv_vcatpvf(sv, pat, &args); +#else + sv_catpv(sv, pat); +#endif + va_end(args); +} + +static void test_sv_vsetpvf(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) + sv_vsetpvf(sv, pat, &args); +#else + sv_setpv(sv, pat); +#endif + va_end(args); +} + /* =========== END XSMISC =================================================== */ MODULE = Devel::PPPort PACKAGE = Devel::PPPort @@ -718,6 +764,91 @@ newRV_noinc_REFCNT() RETVAL ##---------------------------------------------------------------------- +## XSUBs from parts/inc/sv_xpvf +##---------------------------------------------------------------------- + +SV * +vnewSVpvf() + CODE: + RETVAL = test_vnewSVpvf(aTHX_ "%s-%d", "Perl", 42); + OUTPUT: + RETVAL + +SV * +sv_vcatpvf(sv) + SV *sv + CODE: + RETVAL = newSVsv(sv); + test_sv_vcatpvf(aTHX_ RETVAL, "%s-%d", "Perl", 42); + OUTPUT: + RETVAL + +SV * +sv_vsetpvf(sv) + SV *sv + CODE: + RETVAL = newSVsv(sv); + test_sv_vsetpvf(aTHX_ RETVAL, "%s-%d", "Perl", 42); + OUTPUT: + RETVAL + +void +sv_catpvf_mg(sv) + SV *sv + CODE: +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) + sv_catpvf_mg(sv, "%s-%d", "Perl", 42); +#endif + +void +Perl_sv_catpvf_mg(sv) + SV *sv + CODE: +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) + Perl_sv_catpvf_mg(aTHX_ sv, "%s-%d", "-Perl", 43); +#endif + +void +sv_catpvf_mg_nocontext(sv) + SV *sv + CODE: +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) +#ifdef PERL_IMPLICIT_CONTEXT + sv_catpvf_mg_nocontext(sv, "%s-%d", "-Perl", 44); +#else + sv_catpvf_mg(sv, "%s-%d", "-Perl", 44); +#endif +#endif + +void +sv_setpvf_mg(sv) + SV *sv + CODE: +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) + sv_setpvf_mg(sv, "%s-%d", "mhx", 42); +#endif + +void +Perl_sv_setpvf_mg(sv) + SV *sv + CODE: +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) + Perl_sv_setpvf_mg(aTHX_ sv, "%s-%d", "foo", 43); +#endif + +void +sv_setpvf_mg_nocontext(sv) + SV *sv + CODE: +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) +#ifdef PERL_IMPLICIT_CONTEXT + sv_setpvf_mg_nocontext(sv, "%s-%d", "bar", 44); +#else + sv_setpvf_mg(sv, "%s-%d", "bar", 44); +#endif +#endif + +##---------------------------------------------------------------------- ## XSUBs from parts/inc/SvPV ##---------------------------------------------------------------------- @@ -804,3 +935,22 @@ void XSRETURN_UV() PPCODE: XSRETURN_UV(42); + +void +PUSHu() + PREINIT: + dTARG; + PPCODE: + TARG = sv_newmortal(); + EXTEND(SP, 1); + PUSHu(42); + XSRETURN(1); + +void +XPUSHu() + PREINIT: + dTARG; + PPCODE: + TARG = sv_newmortal(); + XPUSHu(43); + XSRETURN(1); diff --git a/ext/Devel/PPPort/PPPort_pm.PL b/ext/Devel/PPPort/PPPort_pm.PL index 269895b..baa6d9f 100644 --- a/ext/Devel/PPPort/PPPort_pm.PL +++ b/ext/Devel/PPPort/PPPort_pm.PL @@ -4,9 +4,9 @@ # ################################################################################ # -# $Revision: 28 $ +# $Revision: 30 $ # $Author: mhx $ -# $Date: 2004/08/13 12:49:22 +0200 $ +# $Date: 2004/08/17 20:01:49 +0200 $ # ################################################################################ # @@ -69,8 +69,14 @@ for (keys %raw_todo) { # check consistency for (@api) { if (exists $raw_todo{$_}) { - warn "$INCLUDE/$provides{$_} provides $_, which is still marked " - . "todo for " . format_version($raw_todo{$_}) . "\n"; + if ($raw_base{$_} eq $raw_todo{$_}) { + warn "$INCLUDE/$provides{$_} provides $_, which is still marked " + . "todo for " . format_version($raw_todo{$_}) . "\n"; + } + else { + check(2, "$_ was ported back to " . format_version($raw_todo{$_}) . + " (baseline revision: " . format_version($raw_base{$_}) . ")."); + } } } @@ -148,7 +154,7 @@ sub include for (keys %{$data->{prototypes}}) { $prototypes{$_} = $data->{prototypes}{$_}; - $data->{implementation} =~ s/^$_(?=\s*\()/$DPPP($_)/g; + $data->{implementation} =~ s/^$_(?=\s*\()/$DPPP(my_$_)/mg; } my $out = $data->{implementation}; @@ -213,15 +219,6 @@ sub expand_pp_expr { my $expr = shift; - if ($expr =~ /^\s*version\s*(<|>|==|!=|>=|<=)\s*([\d._]+)\s*$/i) { - my($op, $ver) = ($1, $2); - my($r, $v, $s) = parse_version($ver); - $r == 5 or die "only Perl revision 5 is supported\n"; - $op eq '==' and return "((PERL_VERSION == $v) && (PERL_SUBVERSION == $s))"; - $op eq '!=' and return "((PERL_VERSION != $v) || (PERL_SUBVERSION != $s))"; - $op =~ /([<>])/ and return "((PERL_VERSION $1 $v) || ((PERL_VERSION == $v) && (PERL_SUBVERSION $op $s)))"; - } - if ($expr =~ /^\s*need\s*(\w+)\s*$/i) { my $func = $1; my $e = $embed{$func} or die "unknown API function '$func' in NEED\n"; @@ -238,7 +235,7 @@ sub expand_pp_expr $explicit{$func} = 1; - $proto =~ s/\b$func(?=\s*\()/$DPPP($func)/; + $proto =~ s/\b$func(?=\s*\()/$DPPP(my_$func)/; my $embed = make_embed($e); return "defined(NEED_$func)\n" @@ -250,10 +247,9 @@ sub expand_pp_expr . "\n" . "$embed\n" . "\n" - . "#if defined(NEED_$func) || defined(NEED_${func}_GLOBAL)" + . "#if defined(NEED_$func) || defined(NEED_${func}_GLOBAL)"; } - die "cannot expand preprocessor expression '$expr'\n"; } @@ -265,11 +261,11 @@ sub make_embed if ($f->{flags}{n}) { if ($f->{flags}{p}) { - return "#define $n $DPPP($n)\n" . - "#define Perl_$n $DPPP($n)"; + return "#define $n $DPPP(my_$n)\n" . + "#define Perl_$n $DPPP(my_$n)"; } else { - return "#define $n $DPPP($n)"; + return "#define $n $DPPP(my_$n)"; } } else { @@ -279,11 +275,16 @@ sub make_embed #endif UNDEF if ($f->{flags}{p}) { - return $undef . "#define $n($a) $DPPP($n)(aTHX_ $a)\n" . - "#define Perl_$n $DPPP($n)"; + if ($f->{flags}{f}) { + return "#define Perl_$n $DPPP(my_$n)"; + } + else { + return $undef . "#define $n($a) $DPPP(my_$n)(aTHX_ $a)\n" . + "#define Perl_$n $DPPP(my_$n)"; + } } else { - return $undef . "#define $n($a) $DPPP($n)(aTHX_ $a)"; + return $undef . "#define $n($a) $DPPP(my_$n)(aTHX_ $a)"; } } } @@ -308,9 +309,9 @@ __DATA__ # ################################################################################ # -# $Revision: 28 $ +# $Revision: 30 $ # $Author: mhx $ -# $Date: 2004/08/13 12:49:22 +0200 $ +# $Date: 2004/08/17 20:01:49 +0200 $ # ################################################################################ # @@ -472,7 +473,7 @@ require DynaLoader; use strict; use vars qw($VERSION @ISA $data); -$VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.00 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' }; +$VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.00_01 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' }; @ISA = qw(DynaLoader); @@ -566,6 +567,8 @@ __DATA__ %include SvPV +%include sv_xpvf + %include magic %include cop diff --git a/ext/Devel/PPPort/TODO b/ext/Devel/PPPort/TODO index e5d3eaa..8af9477 100644 --- a/ext/Devel/PPPort/TODO +++ b/ext/Devel/PPPort/TODO @@ -1,7 +1,5 @@ TODO: -* add support for sv_vcatpvf / sv_vsetpvf / ... - * more documentation, more tests * Resolve dependencies in Makefile.PL and remind of diff --git a/ext/Devel/PPPort/parts/apicheck.pl b/ext/Devel/PPPort/parts/apicheck.pl index 7ed00d2..b49c53a 100644 --- a/ext/Devel/PPPort/parts/apicheck.pl +++ b/ext/Devel/PPPort/parts/apicheck.pl @@ -5,9 +5,9 @@ # ################################################################################ # -# $Revision: 9 $ +# $Revision: 10 $ # $Author: mhx $ -# $Date: 2004/08/13 12:49:50 +0200 $ +# $Date: 2004/08/17 20:56:15 +0200 $ # ################################################################################ # @@ -150,6 +150,12 @@ print OUT < $opt{'compat-version'}) { $file{uses}{$func}++; - push @{$global{uses}{$func}}, $filename; my @deps = rec_depend($func); if (@deps) { $file{uses_deps}{$func} = \@deps; for (@deps) { $file{uses}{$_} = 0 unless exists $file{uses}{$_}; - push @{$global{uses}{$_}}, $filename; } } for ($func, @deps) { if (exists $need{$_}) { $file{needs}{$_} = 'static'; - push @{$global{needs}{$_}}, $filename; } } } @@ -233,7 +230,6 @@ for $filename (@files) { if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { if ($c =~ /\b$func\b/) { $file{uses_todo}{$func}++; - push @{$global{uses_todo}{$func}}, $filename; } } } @@ -242,13 +238,18 @@ for $filename (@files) { while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { if (exists $need{$2}) { $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; - push @{$global{defined $3 ? 'needed_global' : 'needed_static'}{$2}}, $filename; } else { warning("Possibly wrong #define $1 in $filename"); } } + for (qw(uses needs uses_todo needed_global needed_static)) { + for $func (keys %{$file{$_}}) { + push @{$global{$_}{$func}}, $filename; + } + } + $files{$filename} = \%file; } @@ -548,8 +549,9 @@ sub can_use sub rec_depend { my $func = shift; + my %seen; return () unless exists $depends{$func}; - map { ($_, rec_depend($_)) } @{$depends{$func}}; + grep !$seen{$_}++, map { ($_, rec_depend($_)) } @{$depends{$func}}; } sub parse_version diff --git a/ext/Devel/PPPort/parts/inc/ppphtest b/ext/Devel/PPPort/parts/inc/ppphtest index 8b8c37e..f672dff 100644 --- a/ext/Devel/PPPort/parts/inc/ppphtest +++ b/ext/Devel/PPPort/parts/inc/ppphtest @@ -1,8 +1,8 @@ ################################################################################ ## -## $Revision: 16 $ +## $Revision: 19 $ ## $Author: mhx $ -## $Date: 2004/08/13 12:45:56 +0200 $ +## $Date: 2004/08/17 22:04:17 +0200 $ ## ################################################################################ ## @@ -15,20 +15,25 @@ ## ################################################################################ -=tests plan => 131 +=tests plan => 134 use File::Path qw/rmtree mkpath/; +use Config; my $tmp = 'ppptmp'; +my $inc = ''; +my $perl = find_perl(); rmtree($tmp) if -d $tmp; mkpath($tmp) or die "mkpath $tmp: $!\n"; chdir($tmp) or die "chdir $tmp: $!\n"; -my $inc = ''; if ($ENV{'PERL_CORE'}) { $inc = '-I../../lib' if -d '../../lib'; } +if ($perl =~ m!^\./!) { + $perl = ".$perl"; +} END { chdir("..") if !-d $tmp && -d "../$tmp"; @@ -40,8 +45,8 @@ ok(&Devel::PPPort::WriteFile("ppport.h")); sub ppport { my @args = @_; - print "# *** running $^X $inc ppport.h @args ***\n"; - my $out = join '', `$^X $inc ppport.h @args`; + print "# *** running $perl $inc ppport.h @args ***\n"; + my $out = join '', `$perl $inc ppport.h @args`; my $copy = $out; $copy =~ s/^/# | /mg; print "$copy\n"; @@ -122,6 +127,33 @@ for $t (@tests) { } } +sub find_perl +{ + my $perl = $^X; + + return $perl if $^O eq 'VMS'; + + my $exe = $Config{'_exe'} || ''; + + if ($perl =~ /^perl\Q$exe\E$/i) { + $perl = "perl$exe"; + eval "require File::Spec"; + if ($@) { + $perl = "./$perl"; + } else { + $perl = File::Spec->catfile(File::Spec->curdir(), $perl); + } + } + + if ($perl !~ /\Q$exe\E$/i) { + $perl .= $exe; + } + + warn "find_perl: cannot find $perl from $^X" unless -f $perl; + + return $perl; +} + __DATA__ my $o = ppport(qw(--help)); @@ -518,3 +550,24 @@ ok($o !~ /Uses SvPVutf8_force/m); SvPVutf8_force(); +=============================================================================== + +my $o = ppport(qw(--nochanges)); +ok($o !~ /potentially required change/); +ok(matches($o, '^Looks good', 'mi'), 2); + +---------------------------- FooBar.xs ---------------------------------------- + +#define NEED_grok_numeric_radix +#define NEED_grok_number +#include "ppport.h" + +GROK_NUMERIC_RADIX(); +grok_number(); + +---------------------------- foo.c -------------------------------------------- + +#include "ppport.h" + +call_pv(); + diff --git a/ext/Devel/PPPort/parts/inc/sv_xpvf b/ext/Devel/PPPort/parts/inc/sv_xpvf new file mode 100644 index 0000000..1083ecd --- /dev/null +++ b/ext/Devel/PPPort/parts/inc/sv_xpvf @@ -0,0 +1,327 @@ +################################################################################ +## +## $Revision: 2 $ +## $Author: mhx $ +## $Date: 2004/08/17 20:02:25 +0200 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +vnewSVpvf +sv_vcatpvf +sv_vsetpvf + +sv_catpvf_mg +sv_catpvf_mg_nocontext +sv_vcatpvf_mg + +sv_setpvf_mg +sv_setpvf_mg_nocontext +sv_vsetpvf_mg + +=implementation + +#if { VERSION >= 5.004 } && !defined(vnewSVpvf) +#if { NEED vnewSVpvf } + +SV * +vnewSVpvf(pTHX_ const char *pat, va_list *args) +{ + register SV *sv = newSV(0); + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + return sv; +} + +#endif +#endif + +/* sv_vcatpvf depends on sv_vcatpvfn */ +#if { VERSION >= 5.004 } && !defined(sv_vcatpvf) +# define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +/* sv_vsetpvf depends on sv_vsetpvfn */ +#if { VERSION >= 5.004 } && !defined(sv_vsetpvf) +# define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +/* sv_catpvf_mg depends on sv_vcatpvfn, sv_catpvf_mg_nocontext */ +#if { VERSION >= 5.004 } && !defined(sv_catpvf_mg) +#if { NEED sv_catpvf_mg } + +void +sv_catpvf_mg(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +/* sv_catpvf_mg_nocontext depends on sv_vcatpvfn */ +#ifdef PERL_IMPLICIT_CONTEXT +#if { VERSION >= 5.004 } && !defined(sv_catpvf_mg_nocontext) +#if { NEED sv_catpvf_mg_nocontext } + +void +sv_catpvf_mg_nocontext(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +#ifndef sv_catpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext +# else +# define sv_catpvf_mg Perl_sv_catpvf_mg +# endif +#endif + +/* sv_vcatpvf_mg depends on sv_vcatpvfn */ +#if { VERSION >= 5.004 } && !defined(sv_vcatpvf_mg) +# define sv_vcatpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +/* sv_setpvf_mg depends on sv_vsetpvfn, sv_setpvf_mg_nocontext */ +#if { VERSION >= 5.004 } && !defined(sv_setpvf_mg) +#if { NEED sv_setpvf_mg } + +void +sv_setpvf_mg(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +/* sv_setpvf_mg_nocontext depends on sv_vsetpvfn */ +#ifdef PERL_IMPLICIT_CONTEXT +#if { VERSION >= 5.004 } && !defined(sv_setpvf_mg_nocontext) +#if { NEED sv_setpvf_mg_nocontext } + +void +sv_setpvf_mg_nocontext(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +#ifndef sv_setpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext +# else +# define sv_setpvf_mg Perl_sv_setpvf_mg +# endif +#endif + +/* sv_vsetpvf_mg depends on sv_vsetpvfn */ +#if { VERSION >= 5.004 } && !defined(sv_vsetpvf_mg) +# define sv_vsetpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +=xsinit + +#define NEED_vnewSVpvf +#define NEED_sv_catpvf_mg +#define NEED_sv_catpvf_mg_nocontext +#define NEED_sv_setpvf_mg +#define NEED_sv_setpvf_mg_nocontext + +=xsmisc + +static SV * test_vnewSVpvf(pTHX_ const char *pat, ...) +{ + SV *sv; + va_list args; + va_start(args, pat); +#if { VERSION >= 5.004 } + sv = vnewSVpvf(pat, &args); +#else + sv = newSVpv(pat, 0); +#endif + va_end(args); + return sv; +} + +static void test_sv_vcatpvf(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); +#if { VERSION >= 5.004 } + sv_vcatpvf(sv, pat, &args); +#else + sv_catpv(sv, pat); +#endif + va_end(args); +} + +static void test_sv_vsetpvf(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); +#if { VERSION >= 5.004 } + sv_vsetpvf(sv, pat, &args); +#else + sv_setpv(sv, pat); +#endif + va_end(args); +} + +=xsubs + +SV * +vnewSVpvf() + CODE: + RETVAL = test_vnewSVpvf(aTHX_ "%s-%d", "Perl", 42); + OUTPUT: + RETVAL + +SV * +sv_vcatpvf(sv) + SV *sv + CODE: + RETVAL = newSVsv(sv); + test_sv_vcatpvf(aTHX_ RETVAL, "%s-%d", "Perl", 42); + OUTPUT: + RETVAL + +SV * +sv_vsetpvf(sv) + SV *sv + CODE: + RETVAL = newSVsv(sv); + test_sv_vsetpvf(aTHX_ RETVAL, "%s-%d", "Perl", 42); + OUTPUT: + RETVAL + +void +sv_catpvf_mg(sv) + SV *sv + CODE: +#if { VERSION >= 5.004 } + sv_catpvf_mg(sv, "%s-%d", "Perl", 42); +#endif + +void +Perl_sv_catpvf_mg(sv) + SV *sv + CODE: +#if { VERSION >= 5.004 } + Perl_sv_catpvf_mg(aTHX_ sv, "%s-%d", "-Perl", 43); +#endif + +void +sv_catpvf_mg_nocontext(sv) + SV *sv + CODE: +#if { VERSION >= 5.004 } +#ifdef PERL_IMPLICIT_CONTEXT + sv_catpvf_mg_nocontext(sv, "%s-%d", "-Perl", 44); +#else + sv_catpvf_mg(sv, "%s-%d", "-Perl", 44); +#endif +#endif + +void +sv_setpvf_mg(sv) + SV *sv + CODE: +#if { VERSION >= 5.004 } + sv_setpvf_mg(sv, "%s-%d", "mhx", 42); +#endif + +void +Perl_sv_setpvf_mg(sv) + SV *sv + CODE: +#if { VERSION >= 5.004 } + Perl_sv_setpvf_mg(aTHX_ sv, "%s-%d", "foo", 43); +#endif + +void +sv_setpvf_mg_nocontext(sv) + SV *sv + CODE: +#if { VERSION >= 5.004 } +#ifdef PERL_IMPLICIT_CONTEXT + sv_setpvf_mg_nocontext(sv, "%s-%d", "bar", 44); +#else + sv_setpvf_mg(sv, "%s-%d", "bar", 44); +#endif +#endif + +=tests plan => 9 + +use Tie::Hash; +my %h; +tie %h, 'Tie::StdHash'; +$h{foo} = 'foo-'; +$h{bar} = ''; + +ok(&Devel::PPPort::vnewSVpvf(), $] >= 5.004 ? 'Perl-42' : '%s-%d'); +ok(&Devel::PPPort::sv_vcatpvf('1-2-3-'), $] >= 5.004 ? '1-2-3-Perl-42' : '1-2-3-%s-%d'); +ok(&Devel::PPPort::sv_vsetpvf('1-2-3-'), $] >= 5.004 ? 'Perl-42' : '%s-%d'); + +&Devel::PPPort::sv_catpvf_mg($h{foo}); +ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42' : 'foo-'); + +&Devel::PPPort::Perl_sv_catpvf_mg($h{foo}); +ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42-Perl-43' : 'foo-'); + +&Devel::PPPort::sv_catpvf_mg_nocontext($h{foo}); +ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42-Perl-43-Perl-44' : 'foo-'); + +&Devel::PPPort::sv_setpvf_mg($h{bar}); +ok($h{bar}, $] >= 5.004 ? 'mhx-42' : ''); + +&Devel::PPPort::Perl_sv_setpvf_mg($h{bar}); +ok($h{bar}, $] >= 5.004 ? 'foo-43' : ''); + +&Devel::PPPort::sv_setpvf_mg_nocontext($h{bar}); +ok($h{bar}, $] >= 5.004 ? 'bar-44' : ''); + + diff --git a/ext/Devel/PPPort/parts/inc/uv b/ext/Devel/PPPort/parts/inc/uv index 3384eb8..b9d3a49 100644 --- a/ext/Devel/PPPort/parts/inc/uv +++ b/ext/Devel/PPPort/parts/inc/uv @@ -1,8 +1,8 @@ ################################################################################ ## -## $Revision: 8 $ +## $Revision: 9 $ ## $Author: mhx $ -## $Date: 2004/08/13 12:47:17 +0200 $ +## $Date: 2004/08/17 23:13:18 +0200 $ ## ################################################################################ ## @@ -52,6 +52,9 @@ __UNDEFINED__ sv_uv(sv) SvUVx(sv) __UNDEFINED__ XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) __UNDEFINED__ XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END +__UNDEFINED__ PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END +__UNDEFINED__ XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END + =xsubs SV * @@ -93,7 +96,26 @@ XSRETURN_UV() PPCODE: XSRETURN_UV(42); -=tests plan => 8 +void +PUSHu() + PREINIT: + dTARG; + PPCODE: + TARG = sv_newmortal(); + EXTEND(SP, 1); + PUSHu(42); + XSRETURN(1); + +void +XPUSHu() + PREINIT: + dTARG; + PPCODE: + TARG = sv_newmortal(); + XPUSHu(43); + XSRETURN(1); + +=tests plan => 10 ok(&Devel::PPPort::sv_setuv(42), 42); ok(&Devel::PPPort::newSVuv(123), 123); @@ -103,4 +125,6 @@ ok(&Devel::PPPort::SvUVx("1735928559"), 1735928559); ok(&Devel::PPPort::SvUVx(1735928559), 1735928559); ok(&Devel::PPPort::SvUVx(0xdeadbeef), 0xdeadbeef); ok(&Devel::PPPort::XSRETURN_UV(), 42); +ok(&Devel::PPPort::PUSHu(), 42); +ok(&Devel::PPPort::XPUSHu(), 43); diff --git a/ext/Devel/PPPort/parts/ppptools.pl b/ext/Devel/PPPort/parts/ppptools.pl index 7ef1700..2953f3b 100644 --- a/ext/Devel/PPPort/parts/ppptools.pl +++ b/ext/Devel/PPPort/parts/ppptools.pl @@ -4,9 +4,9 @@ # ################################################################################ # -# $Revision: 11 $ +# $Revision: 12 $ # $Author: mhx $ -# $Date: 2004/08/13 12:50:05 +0200 $ +# $Date: 2004/08/17 14:00:34 +0200 $ # ################################################################################ # @@ -45,6 +45,17 @@ sub parse_todo return \%todo; } +sub expand_version +{ + my($op, $ver) = @_; + my($r, $v, $s) = parse_version($ver); + $r == 5 or die "only Perl revision 5 is supported\n"; + $op eq '==' and return "((PERL_VERSION == $v) && (PERL_SUBVERSION == $s))"; + $op eq '!=' and return "((PERL_VERSION != $v) || (PERL_SUBVERSION != $s))"; + $op =~ /([<>])/ and return "((PERL_VERSION $1 $v) || ((PERL_VERSION == $v) && (PERL_SUBVERSION $op $s)))"; + die "cannot expand version expression ($op $ver)\n"; +} + sub parse_partspec { my $file = shift; @@ -139,6 +150,12 @@ sub parse_partspec } } + for $section (qw( implementation xsubs xsinit xsmisc xshead xsboot )) { + if (exists $data{$section}) { + $data{$section} =~ s/\{\s*version\s*(<|>|==|!=|>=|<=)\s*([\d._]+)\s*\}/expand_version($1, $2)/gei; + } + } + $data{provides} = \@prov; $data{prototypes} = \%proto; $data{OPTIONS} = \%options; diff --git a/ext/Devel/PPPort/parts/todo/5004000 b/ext/Devel/PPPort/parts/todo/5004000 index 4805705..58f01f5 100644 --- a/ext/Devel/PPPort/parts/todo/5004000 +++ b/ext/Devel/PPPort/parts/todo/5004000 @@ -10,14 +10,12 @@ HeSVKEY # E HeSVKEY_force # E HeSVKEY_set # E HeVAL # E -PUSHu # U SvSetMagicSV # U SvSetMagicSV_nosteal # U SvSetSV_nosteal # U SvTAINTED # U SvTAINTED_off # U SvTAINTED_on # U -XPUSHu # U block_gimme # U call_list # U cv_const_sv # E @@ -48,13 +46,20 @@ save_I16 # U save_gp # U start_subparse # E (Perl_start_subparse) sv_catpvf # U +sv_catpvf_mg # U sv_cmp_locale # U sv_derived_from # U sv_gets # E (Perl_sv_gets) sv_setpvf # U +sv_setpvf_mg # U sv_taint # U sv_tainted # U sv_untaint # U +sv_vcatpvf # U +sv_vcatpvf_mg # U sv_vcatpvfn # U +sv_vsetpvf # U +sv_vsetpvf_mg # U sv_vsetpvfn # U unsharepvn # U +vnewSVpvf # E diff --git a/ext/Devel/PPPort/parts/todo/5004050 b/ext/Devel/PPPort/parts/todo/5004050 index e367a73..f1c9f89 100644 --- a/ext/Devel/PPPort/parts/todo/5004050 +++ b/ext/Devel/PPPort/parts/todo/5004050 @@ -2,5 +2,3 @@ do_binmode # U save_aelem # U save_helem # U -sv_catpvf_mg # U -sv_setpvf_mg # U diff --git a/ext/Devel/PPPort/parts/todo/5006000 b/ext/Devel/PPPort/parts/todo/5006000 index 59f2716..b1e9b26 100644 --- a/ext/Devel/PPPort/parts/todo/5006000 +++ b/ext/Devel/PPPort/parts/todo/5006000 @@ -140,10 +140,6 @@ sv_rvweaken # E sv_utf8_decode # U sv_utf8_downgrade # U sv_utf8_encode # U -sv_vcatpvf # U -sv_vcatpvf_mg # U -sv_vsetpvf # U -sv_vsetpvf_mg # U swash_init # E tmps_grow # U to_uni_lower_lc # U @@ -155,7 +151,6 @@ vcroak # U vform # E vload_module # U vmess # E -vnewSVpvf # E vwarn # U vwarner # U warner # U diff --git a/ext/Devel/PPPort/t/cop.t b/ext/Devel/PPPort/t/cop.t new file mode 100644 index 0000000..00d9746 --- /dev/null +++ b/ext/Devel/PPPort/t/cop.t @@ -0,0 +1,49 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/cop instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ] ) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..2\n"; + } + else { + plan(tests => 2); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +my $package; +{ + package MyPackage; + $package = &Devel::PPPort::CopSTASHPV(); +} +print "# $package\n"; +ok($package, "MyPackage"); + +my $file = &Devel::PPPort::CopFILE(); +print "# $file\n"; +ok($file =~ /cop/i); + diff --git a/ext/Devel/PPPort/t/ppphtest.t b/ext/Devel/PPPort/t/ppphtest.t index 5709da9..529bf3b 100644 --- a/ext/Devel/PPPort/t/ppphtest.t +++ b/ext/Devel/PPPort/t/ppphtest.t @@ -24,10 +24,10 @@ BEGIN { eval "use Test"; if ($@) { require 'testutil.pl'; - print "1..131\n"; + print "1..134\n"; } else { - plan(tests => 131); + plan(tests => 134); } } @@ -36,17 +36,22 @@ use strict; $^W = 1; use File::Path qw/rmtree mkpath/; +use Config; my $tmp = 'ppptmp'; +my $inc = ''; +my $perl = find_perl(); rmtree($tmp) if -d $tmp; mkpath($tmp) or die "mkpath $tmp: $!\n"; chdir($tmp) or die "chdir $tmp: $!\n"; -my $inc = ''; if ($ENV{'PERL_CORE'}) { $inc = '-I../../lib' if -d '../../lib'; } +if ($perl =~ m!^\./!) { + $perl = ".$perl"; +} END { chdir("..") if !-d $tmp && -d "../$tmp"; @@ -58,8 +63,8 @@ ok(&Devel::PPPort::WriteFile("ppport.h")); sub ppport { my @args = @_; - print "# *** running $^X $inc ppport.h @args ***\n"; - my $out = join '', `$^X $inc ppport.h @args`; + print "# *** running $perl $inc ppport.h @args ***\n"; + my $out = join '', `$perl $inc ppport.h @args`; my $copy = $out; $copy =~ s/^/# | /mg; print "$copy\n"; @@ -140,6 +145,33 @@ for $t (@tests) { } } +sub find_perl +{ + my $perl = $^X; + + return $perl if $^O eq 'VMS'; + + my $exe = $Config{'_exe'} || ''; + + if ($perl =~ /^perl\Q$exe\E$/i) { + $perl = "perl$exe"; + eval "require File::Spec"; + if ($@) { + $perl = "./$perl"; + } else { + $perl = File::Spec->catfile(File::Spec->curdir(), $perl); + } + } + + if ($perl !~ /\Q$exe\E$/i) { + $perl .= $exe; + } + + warn "find_perl: cannot find $perl from $^X" unless -f $perl; + + return $perl; +} + __DATA__ my $o = ppport(qw(--help)); @@ -536,3 +568,24 @@ ok($o !~ /Uses SvPVutf8_force/m); SvPVutf8_force(); +=============================================================================== + +my $o = ppport(qw(--nochanges)); +ok($o !~ /potentially required change/); +ok(matches($o, '^Looks good', 'mi'), 2); + +---------------------------- FooBar.xs ---------------------------------------- + +#define NEED_grok_numeric_radix +#define NEED_grok_number +#include "ppport.h" + +GROK_NUMERIC_RADIX(); +grok_number(); + +---------------------------- foo.c -------------------------------------------- + +#include "ppport.h" + +call_pv(); + diff --git a/ext/Devel/PPPort/t/sv_xpvf.t b/ext/Devel/PPPort/t/sv_xpvf.t new file mode 100644 index 0000000..13c9182 --- /dev/null +++ b/ext/Devel/PPPort/t/sv_xpvf.t @@ -0,0 +1,65 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/sv_xpvf instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ] ) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..9\n"; + } + else { + plan(tests => 9); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +use Tie::Hash; +my %h; +tie %h, 'Tie::StdHash'; +$h{foo} = 'foo-'; +$h{bar} = ''; + +ok(&Devel::PPPort::vnewSVpvf(), $] >= 5.004 ? 'Perl-42' : '%s-%d'); +ok(&Devel::PPPort::sv_vcatpvf('1-2-3-'), $] >= 5.004 ? '1-2-3-Perl-42' : '1-2-3-%s-%d'); +ok(&Devel::PPPort::sv_vsetpvf('1-2-3-'), $] >= 5.004 ? 'Perl-42' : '%s-%d'); + +&Devel::PPPort::sv_catpvf_mg($h{foo}); +ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42' : 'foo-'); + +&Devel::PPPort::Perl_sv_catpvf_mg($h{foo}); +ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42-Perl-43' : 'foo-'); + +&Devel::PPPort::sv_catpvf_mg_nocontext($h{foo}); +ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42-Perl-43-Perl-44' : 'foo-'); + +&Devel::PPPort::sv_setpvf_mg($h{bar}); +ok($h{bar}, $] >= 5.004 ? 'mhx-42' : ''); + +&Devel::PPPort::Perl_sv_setpvf_mg($h{bar}); +ok($h{bar}, $] >= 5.004 ? 'foo-43' : ''); + +&Devel::PPPort::sv_setpvf_mg_nocontext($h{bar}); +ok($h{bar}, $] >= 5.004 ? 'bar-44' : ''); + diff --git a/ext/Devel/PPPort/t/uv.t b/ext/Devel/PPPort/t/uv.t index d1c5592..6b10ddd 100644 --- a/ext/Devel/PPPort/t/uv.t +++ b/ext/Devel/PPPort/t/uv.t @@ -24,10 +24,10 @@ BEGIN { eval "use Test"; if ($@) { require 'testutil.pl'; - print "1..8\n"; + print "1..10\n"; } else { - plan(tests => 8); + plan(tests => 10); } } @@ -43,4 +43,6 @@ ok(&Devel::PPPort::SvUVx("1735928559"), 1735928559); ok(&Devel::PPPort::SvUVx(1735928559), 1735928559); ok(&Devel::PPPort::SvUVx(0xdeadbeef), 0xdeadbeef); ok(&Devel::PPPort::XSRETURN_UV(), 42); +ok(&Devel::PPPort::PUSHu(), 42); +ok(&Devel::PPPort::XPUSHu(), 43);