From: Marcus Holland-Moritz Date: Thu, 25 May 2006 15:52:02 +0000 (+0000) Subject: Upgrade to Devel::PPPort 3.08_03 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0c96388fb9e802edf81ea88509a54738dad9a335;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Devel::PPPort 3.08_03 p4raw-id: //depot/perl@28307 --- diff --git a/MANIFEST b/MANIFEST index 2dd7461..b677bfb 100644 --- a/MANIFEST +++ b/MANIFEST @@ -340,9 +340,11 @@ ext/Devel/Peek/t/Peek.t See if Devel::Peek works ext/Devel/PPPort/apicheck_c.PL Devel::PPPort apicheck generator ext/Devel/PPPort/Changes Devel::PPPort changes ext/Devel/PPPort/devel/buildperl.pl Devel::PPPort perl version builder +ext/Devel/PPPort/devel/devtools.pl Devel::PPPort development utilities ext/Devel/PPPort/devel/mkapidoc.sh Devel::PPPort apidoc collector ext/Devel/PPPort/devel/mktodo Devel::PPPort baseline/todo generator ext/Devel/PPPort/devel/mktodo.pl Devel::PPPort baseline/todo generator +ext/Devel/PPPort/devel/regenerate Devel::PPPort API re-generator ext/Devel/PPPort/devel/scanprov Devel::PPPort provided API scanner ext/Devel/PPPort/HACKERS Devel::PPPort hackers documentation ext/Devel/PPPort/Makefile.PL Devel::PPPort makefile writer diff --git a/ext/Devel/PPPort/Changes b/ext/Devel/PPPort/Changes index 458bc22..115bba3 100755 --- a/ext/Devel/PPPort/Changes +++ b/ext/Devel/PPPort/Changes @@ -1,3 +1,9 @@ +3.08_03 - 2006-05-25 + + * update API info + * add devel/regenerate script to regenerate API info + * improve and speed up the development tools + 3.08_02 - 2006-05-22 * fix a POD error diff --git a/ext/Devel/PPPort/HACKERS b/ext/Devel/PPPort/HACKERS index 770ceeb..c73d372 100644 --- a/ext/Devel/PPPort/HACKERS +++ b/ext/Devel/PPPort/HACKERS @@ -134,6 +134,8 @@ Finally, add the remaining baseline information by running =back +Alternatively, you can try to use the F script. + =head2 Implementation Residing in F is the "heart" of C. Each diff --git a/ext/Devel/PPPort/PPPort.pm b/ext/Devel/PPPort/PPPort.pm index 9b56c56..fe7557a 100644 --- a/ext/Devel/PPPort/PPPort.pm +++ b/ext/Devel/PPPort/PPPort.pm @@ -8,9 +8,9 @@ # ################################################################################ # -# $Revision: 43 $ +# $Revision: 44 $ # $Author: mhx $ -# $Date: 2006/05/22 00:51:20 +0200 $ +# $Date: 2006/05/22 20:28:47 +0200 $ # ################################################################################ # @@ -45,7 +45,7 @@ C contains a single function, called C. Its only purpose is to write the F C header file. This file contains a series of macros and, if explicitly requested, functions that allow XS modules to be built using older versions of Perl. Currently, -Perl versions from 5.003 to 5.9.3 are supported. +Perl versions from 5.003 to 5.9.4 are supported. This module is used by C to write the file F. @@ -99,7 +99,7 @@ Otherwise it returns a false value. =head1 COMPATIBILITY -F supports Perl versions from 5.003 to 5.9.3 +F supports Perl versions from 5.003 to 5.9.4 in threaded and non-threaded configurations. =head2 Provided Perl compatibility API @@ -481,6 +481,7 @@ Perl below which it is unsupported: MULTICALL POP_MULTICALL PUSH_MULTICALL + PerlIO_context_layers gv_name_set my_vsnprintf newXS_flags @@ -498,6 +499,7 @@ Perl below which it is unsupported: dMULTICALL doref gv_const_sv + gv_stashpvs hv_eiter_p hv_eiter_set hv_name_set @@ -510,9 +512,11 @@ Perl below which it is unsupported: my_sprintf newGIVENOP newSVhek + newSVpvs_share newWHENOP newWHILEOP ref + savepvs sortsv_flags vverify @@ -1008,7 +1012,7 @@ require DynaLoader; use strict; use vars qw($VERSION @ISA $data); -$VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.08_02 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' }; +$VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.08_03 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' }; @ISA = qw(DynaLoader); @@ -1100,7 +1104,7 @@ SKIP |>=head1 COMPATIBILITY |> |>This version of F is designed to support operation with Perl -|>installations back to 5.003, and has been tested up to 5.9.3. +|>installations back to 5.003, and has been tested up to 5.9.4. |> |>=head1 OPTIONS |> @@ -1624,7 +1628,7 @@ PERL_UNUSED_DECL|5.007002||p PERL_UNUSED_VAR|5.007002||p PERL_UQUAD_MAX|5.004000||p PERL_UQUAD_MIN|5.004000||p -PERL_USE_GCC_BRACE_GROUPS|||p +PERL_USE_GCC_BRACE_GROUPS|5.009004||p PERL_USHORT_MAX|5.004000||p PERL_USHORT_MIN|5.004000||p PERL_VERSION|5.006000||p @@ -1689,7 +1693,7 @@ PUSHu|5.004000||p PUTBACK||| PerlIO_clearerr||5.007003| PerlIO_close||5.007003| -PerlIO_context_layers||| +PerlIO_context_layers||5.009004| PerlIO_eof||5.007003| PerlIO_error||5.007003| PerlIO_fileno||5.007003| @@ -1732,7 +1736,7 @@ STMT_END|||p STMT_START|||p STR_WITH_LEN|5.009003||p ST||| -SVf|||p +SVf|5.006000||p SVt_IV||| SVt_NV||| SVt_PVAV||| @@ -1826,7 +1830,7 @@ SvRV_set|5.009003||p SvRV||| SvSETMAGIC||| SvSHARE||5.007003| -SvSTASH_set|5.009004||p +SvSTASH_set|5.009003||p SvSTASH||| SvSetMagicSV_nosteal||5.004000| SvSetMagicSV||5.004000| @@ -1992,7 +1996,7 @@ boot_core_PerlIO||| boot_core_UNIVERSAL||| boot_core_xsutils||| bytes_from_utf8||5.007001| -bytes_to_uni||| +bytes_to_uni|||n bytes_to_utf8||5.006001| call_argv|5.006000||p call_atexit||5.006000| @@ -2010,7 +2014,7 @@ check_type_and_open||| check_uni||| checkcomma||| checkposixcc||| -ckWARN|||p +ckWARN|5.006000||p ck_anoncode||| ck_bitop||| ck_concat||| @@ -2307,6 +2311,7 @@ gv_init_sv||| gv_init||| gv_name_set||5.009004| gv_stashpvn|5.006000||p +gv_stashpvs||5.009003| gv_stashpv||| gv_stashsv||| he_dup||| @@ -2679,6 +2684,7 @@ newSVpvf_nocontext|||vn newSVpvf||5.004000|v newSVpvn_share||5.007001| newSVpvn|5.006000||p +newSVpvs_share||5.009003| newSVpvs|5.009003||p newSVpv||| newSVrv||| @@ -2910,6 +2916,7 @@ save_sptr||| save_svref||| save_vptr||5.006000| savepvn||| +savepvs||5.009003| savepv||| savesharedpv||5.007003| savestack_grow_cnt||5.008001| diff --git a/ext/Devel/PPPort/PPPort_pm.PL b/ext/Devel/PPPort/PPPort_pm.PL index cbe65b2..f0b4416 100644 --- a/ext/Devel/PPPort/PPPort_pm.PL +++ b/ext/Devel/PPPort/PPPort_pm.PL @@ -4,9 +4,9 @@ # ################################################################################ # -# $Revision: 43 $ +# $Revision: 44 $ # $Author: mhx $ -# $Date: 2006/05/22 00:51:20 +0200 $ +# $Date: 2006/05/22 20:28:47 +0200 $ # ################################################################################ # @@ -125,7 +125,7 @@ $data =~ s{^__UNSUPPORTED_API__(\s*?)^} {join "\n", @todo}gem; $data =~ s{__MIN_PERL__}{5.003}g; -$data =~ s{__MAX_PERL__}{5.9.3}g; +$data =~ s{__MAX_PERL__}{5.9.4}g; open FH, ">PPPort.pm" or die "PPPort.pm: $!\n"; print FH $data; @@ -335,9 +335,9 @@ __DATA__ # ################################################################################ # -# $Revision: 43 $ +# $Revision: 44 $ # $Author: mhx $ -# $Date: 2006/05/22 00:51:20 +0200 $ +# $Date: 2006/05/22 20:28:47 +0200 $ # ################################################################################ # @@ -499,7 +499,7 @@ require DynaLoader; use strict; use vars qw($VERSION @ISA $data); -$VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.08_02 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' }; +$VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.08_03 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' }; @ISA = qw(DynaLoader); diff --git a/ext/Devel/PPPort/TODO b/ext/Devel/PPPort/TODO index 344ef9f..0517c99 100644 --- a/ext/Devel/PPPort/TODO +++ b/ext/Devel/PPPort/TODO @@ -1,8 +1,25 @@ TODO: -* see if we can implement sv_catpvf() for < 5.004 +* figure out why many of the function for which Perl_* exists + fail the automated API check + +* use 'nm' to more efficiently find 'undefined' symbols? + +* implement snprintf with newSVpvf for >= 5.004, which is safer? + +* add support for my_vsnprintf? + +* try to perform some core consistency checks: -* add hv_stores() to blead + - check if 'd' flag in embed.fnc matches with + supplied documentation + + - check if all public API is documented + +* check (during make regen?) if MAX_PERL in PPPort_pm.PL + needs to be updated + +* see if we can implement sv_catpvf() for < 5.004 * MULTICALL ? diff --git a/ext/Devel/PPPort/apicheck_c.PL b/ext/Devel/PPPort/apicheck_c.PL index 2fbf24f..b6a6c28 100644 --- a/ext/Devel/PPPort/apicheck_c.PL +++ b/ext/Devel/PPPort/apicheck_c.PL @@ -4,9 +4,9 @@ # ################################################################################ # -# $Revision: 6 $ +# $Revision: 7 $ # $Author: mhx $ -# $Date: 2006/01/14 18:07:56 +0100 $ +# $Date: 2006/05/25 17:20:38 +0200 $ # ################################################################################ # @@ -19,7 +19,11 @@ # ################################################################################ -$out = 'apicheck.c'; -print "creating $out\n"; -system $^X, 'parts/apicheck.pl', $out +use strict; + +my $out = 'apicheck.c'; +my @api = map { /^--api=(\w+)$/ ? ($1) : () } @ARGV; +print "creating $out", (@ARGV ? " (@api)" : ''), "\n"; +system $^X, 'parts/apicheck.pl', @api, $out and die "couldn't create $out\n"; + diff --git a/ext/Devel/PPPort/devel/devtools.pl b/ext/Devel/PPPort/devel/devtools.pl new file mode 100644 index 0000000..a2b1e26 --- /dev/null +++ b/ext/Devel/PPPort/devel/devtools.pl @@ -0,0 +1,129 @@ +################################################################################ +# +# devtools.pl -- various utility functions +# +################################################################################ +# +# $Revision: 1 $ +# $Author: mhx $ +# $Date: 2006/05/25 17:19:22 +0200 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004-2006, 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. +# +################################################################################ + +use IO::File; + +eval "use Term::ANSIColor"; +$@ and eval "sub colored { pop; @_ }"; + +my @argvcopy = @ARGV; + +sub verbose +{ + if ($opt{verbose}) { + my @out = @_; + s/^(.*)/colored("($0) ", 'bold blue').colored($1, 'blue')/eg for @out; + print STDERR @out; + } +} + +sub ddverbose +{ + return $opt{verbose} ? ('--verbose') : (); +} + +sub runtool +{ + my $opt = ref $_[0] ? shift @_ : {}; + my($prog, @args) = @_; + my $sysstr = join ' ', map { "'$_'" } $prog, @args; + $sysstr .= " >$opt->{'out'}" if exists $opt->{'out'}; + $sysstr .= " 2>$opt->{'err'}" if exists $opt->{'err'}; + verbose("running $sysstr\n"); + my $rv = system $sysstr; + verbose("$prog => exit code $rv\n"); + return not $rv; +} + +sub runperl +{ + my $opt = ref $_[0] ? shift @_ : {}; + runtool($opt, $^X, @_); +} + +sub run +{ + my $prog = shift; + my @args = @_; + + runtool({ 'out' => 'tmp.out', 'err' => 'tmp.err' }, $prog, @args); + + my $out = new IO::File "tmp.out" || die "tmp.out: $!\n"; + my $err = new IO::File "tmp.err" || die "tmp.err: $!\n"; + + my %rval = ( + status => $? >> 8, + stdout => [<$out>], + stderr => [<$err>], + didnotrun => 0, + ); + + unlink "tmp.out", "tmp.err"; + + $? & 128 and $rval{core} = 1; + $? & 127 and $rval{signal} = $? & 127; + + return \%rval; +} + +sub ident_str +{ + return "$^X $0 @argvcopy"; +} + +sub identify +{ + verbose(ident_str() . "\n"); +} + +sub ask($) +{ + my $q = shift; + my $a; + local $| = 1; + print "\n$q [y/n] "; + do { $a = <>; } while ($a !~ /^\s*([yn])\s*$/i); + return lc $1 eq 'y'; +} + +sub quit_now +{ + print "\nSorry, cannot continue.\n\n"; + exit 1; +} + +sub ask_or_quit +{ + quit_now unless &ask; +} + +sub eta +{ + my($start, $i, $n) = @_; + return "--:--:--" if $i < 3; + my $elapsed = tv_interval($start); + my $h = int($elapsed*($n-$i)/$i); + my $s = $h % 60; $h /= 60; + my $m = $h % 60; $h /= 60; + return sprintf "%02d:%02d:%02d", $h, $m, $s; +} + +1; diff --git a/ext/Devel/PPPort/devel/mktodo b/ext/Devel/PPPort/devel/mktodo index d7155c8..7eaffa8 100644 --- a/ext/Devel/PPPort/devel/mktodo +++ b/ext/Devel/PPPort/devel/mktodo @@ -5,9 +5,9 @@ # ################################################################################ # -# $Revision: 10 $ +# $Revision: 12 $ # $Author: mhx $ -# $Date: 2006/01/14 23:02:12 +0100 $ +# $Date: 2006/05/25 17:22:31 +0200 $ # ################################################################################ # @@ -23,14 +23,20 @@ use strict; use Getopt::Long; -my %opt = ( - base => 0, +require 'devel/devtools.pl'; + +our %opt = ( + base => 0, + verbose => 0, ); GetOptions(\%opt, qw( base + verbose )) or die; +identify(); + # my $outdir = $opt{base} ? 'parts/base' : 'parts/todo'; my $outdir = 'parts/todo'; @@ -51,12 +57,12 @@ for (1 .. $#perls) { shift @perls; -$ENV{SKIP_PPPHTEST} = 1; - for (@perls) { my $todo = do { my $v = $_->{todo}; $v =~ s/\D+//g; $v }; -e "$outdir/$todo" and next; my @args = ('--perl', $_->{path}, '--todo', "$outdir/$todo", '--version', "$_->{todo}"); push @args, '--base' if $opt{base}; - system 'devel/mktodo.pl', @args and die "system(@args): [$!] [$?]\n"; + push @args, '--verbose' if $opt{verbose}; + runperl('devel/mktodo.pl', @args) or die "error running mktodo.pl [$!] [$?]\n"; } + diff --git a/ext/Devel/PPPort/devel/mktodo.pl b/ext/Devel/PPPort/devel/mktodo.pl index f66fc00..9d3f2c8 100644 --- a/ext/Devel/PPPort/devel/mktodo.pl +++ b/ext/Devel/PPPort/devel/mktodo.pl @@ -5,9 +5,9 @@ # ################################################################################ # -# $Revision: 8 $ +# $Revision: 11 $ # $Author: mhx $ -# $Date: 2006/01/14 22:41:14 +0100 $ +# $Date: 2006/05/25 17:22:32 +0200 $ # ################################################################################ # @@ -25,21 +25,29 @@ use Getopt::Long; use Data::Dumper; use IO::File; use IO::Select; +use Time::HiRes qw( gettimeofday tv_interval ); -my %opt = ( - debug => 0, - base => 0, -); +require 'devel/devtools.pl'; -print "\n$0 @ARGV\n\n"; +our %opt = ( + debug => 0, + base => 0, + verbose => 0, +); GetOptions(\%opt, qw( - perl=s todo=s version=s debug base + perl=s todo=s version=s debug base verbose )) or die; +identify(); + +print "\n", ident_str(), "\n\n"; + my $fullperl = `which $opt{perl}`; chomp $fullperl; +$ENV{SKIP_SLOW_TESTS} = 1; + regen_all(); my %sym; @@ -83,7 +91,6 @@ retry: unless (@new) { @new = grep !$all{$_->[0]}, @tmp; # TODO: @recheck was here, find a better way to get recheck syms - # * we definitely don't have to check (U) symbols # * try to grep out warnings before making symlist ? } unless (@new) { @@ -95,7 +102,8 @@ retry: print Dumper($r); die "no new TODO symbols found..."; } - push @recheck, map { $_->[0] } @new; + # don't recheck undefined symbols reported by the dynamic linker + push @recheck, map { $_->[0] } grep { $_->[1] !~ /^U/ } @new; for (@new) { printf "[$opt{version}] new symbol: %-30s # %s\n", @$_; $all{$_->[0]} = $_->[1]; @@ -103,13 +111,37 @@ retry: write_todo($opt{todo}, $opt{version}, \%all); } -for my $sym (@recheck) { +my $ifmt = '%' . length(scalar @recheck) . 'd'; +my $t0 = [gettimeofday]; + +RECHECK: for my $i (0 .. $#recheck) { + my $sym = $recheck[$i]; my $cur = delete $all{$sym}; - printf "[$opt{version}] chk symbol: %-30s # %s\n", $sym, $cur; + + printf "[$opt{version}] chk symbol: %-30s # %s [$ifmt/$ifmt, ETA %s]\n", + $sym, $cur, $i + 1, scalar @recheck, eta($t0, $i, scalar @recheck); + write_todo($opt{todo}, $opt{version}, \%all); + + if ($cur eq "E (Perl_$sym)") { + # we can try a shortcut here + regen_apicheck($sym); + + my $r = run(qw(make test)); + + if (!$r->{didnotrun} && $r->{status} == 0) { + printf "[$opt{version}] del symbol: %-30s # %s\n", $sym, $cur; + next RECHECK; + } + } + + # run the full test regen_all(); + my $r = run(qw(make test)); + $r->{didnotrun} and die "couldn't run make test: $!\n"; + if ($r->{status} == 0) { printf "[$opt{version}] del symbol: %-30s # %s\n", $sym, $cur; } @@ -126,7 +158,7 @@ exit 0; sub regen_all { - my @mf_arg = qw( --with-apicheck OPTIMIZE=-O0 ); + my @mf_arg = ('--with-apicheck', 'OPTIMIZE=-O0'); push @mf_arg, qw( DEFINE=-DDPPP_APICHECK_NO_PPPORT_H ) if $opt{base}; # just to be sure @@ -138,7 +170,8 @@ sub regen_all sub regen_apicheck { unlink qw(apicheck.c apicheck.o); - system "$fullperl apicheck_c.PL >/dev/null"; + runtool({ out => '/dev/null' }, $fullperl, 'apicheck_c.PL', map { "--api=$_" } @_) + or die "cannot regenerate apicheck.c\n"; } sub load_todo @@ -181,30 +214,3 @@ sub write_todo } } -sub run -{ - my $prog = shift; - my @args = @_; - - # print "[$prog @args]\n"; - - system "$prog @args >tmp.out 2>tmp.err"; - - my $out = new IO::File "tmp.out" || die "tmp.out: $!\n"; - my $err = new IO::File "tmp.err" || die "tmp.err: $!\n"; - - my %rval = ( - status => $? >> 8, - stdout => [<$out>], - stderr => [<$err>], - didnotrun => 0, - ); - - unlink "tmp.out", "tmp.err"; - - $? & 128 and $rval{core} = 1; - $? & 127 and $rval{signal} = $? & 127; - - \%rval; -} - diff --git a/ext/Devel/PPPort/devel/regenerate b/ext/Devel/PPPort/devel/regenerate new file mode 100644 index 0000000..d280f3e --- /dev/null +++ b/ext/Devel/PPPort/devel/regenerate @@ -0,0 +1,132 @@ +#!/usr/bin/perl -w +################################################################################ +# +# regenerate -- regenerate baseline and todo files +# +################################################################################ +# +# $Revision: 2 $ +# $Author: mhx $ +# $Date: 2006/05/25 17:22:32 +0200 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004-2006, 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. +# +################################################################################ + +use strict; +use File::Path; +use File::Copy; +use Getopt::Long; +use Pod::Usage; + +require 'devel/devtools.pl'; + +our %opt = ( + verbose => 0 +); + +GetOptions(\%opt, qw( verbose )) or die pod2usage(); + +identify(); + +unless (-e 'parts/embed.fnc' and -e 'parts/apidoc.fnc') { + print "\nOooops, $0 must be run from the Devel::PPPort root directory.\n"; + quit_now(); +} + +ask_or_quit("Are you sure you have updated parts/embed.fnc and parts/apidoc.fnc?"); + +my %files = map { ($_ => [glob "parts/$_/5*"]) } qw( base todo ); + +my(@notwr, @wr); +for my $f (map @$_, values %files) { + push @{-w $f ? \@wr : \@notwr}, $f; +} + +if (@notwr) { + if (@wr) { + print "\nThe following files are not writable:\n\n"; + print " $_\n" for @notwr; + print "\nAre you sure you have checked out these files?\n"; + } + else { + print "\nAll baseline / todo file are not writable.\n"; + ask_or_quit("Do you want to try to check out these files?"); + unless (runtool("wco", "-l", "-t", "locked by $0", @notwr)) { + print "\nSomething went wrong while checking out the files.\n"; + quit_now(); + } + } +} + +for my $dir (qw( base todo )) { + my $cur = "parts/$dir"; + my $old = "$cur-old"; + if (-e $old) { + ask_or_quit("Do you want me to remove the old $old directory?"); + rmtree($old); + } + mkdir $old; + print "\nBacking up $cur in $old.\n"; + for my $src (@{$files{$dir}}) { + my $dst = $src; + $dst =~ s/\E$cur/$old/ or die "Ooops!"; + move($src, $dst) or die "Moving $src to $dst failed: $!\n"; + } +} + +my $T0 = time; + +print "\nBuilding baseline files...\n\n"; + +unless (runperl('devel/mktodo', '--base', ddverbose())) { + print "\nSomething went wrong while building the baseline files.\n"; + quit_now(); +} + +print "\nMoving baseline files...\n\n"; + +for my $src (glob 'parts/todo/5*') { + my $dst = $src; + $dst =~ s/todo/base/ or die "Ooops!"; + move($src, $dst) or die "Moving $src to $dst failed: $!\n"; +} + +print "\nBuilding todo files...\n\n"; + +unless (runperl('devel/mktodo', ddverbose())) { + print "\nSomething went wrong while building the baseline files.\n"; + quit_now(); +} + +print "\nAdding remaining baseline info...\n\n"; + +unless (runperl('Makefile.PL') and + runtool('make') and + runperl('devel/scanprov', 'write')) { + print "\nSomething went wrong while adding the baseline info.\n"; + quit_now(); +} + +my($wall, $usr, $sys, $cusr, $csys) = (time - $T0, times); +my $cpu = sprintf "%.2f", $usr + $sys + $cusr + $csys; +$usr = sprintf "%.2f", $usr + $cusr; +$sys = sprintf "%.2f", $sys + $csys; + +print <$ARGV[0]" or die "$ARGV[0]: $!\n"; + my $file = pop @ARGV; + open OUT, ">$file" or die "$file: $!\n"; } else { *OUT = \*STDOUT; @@ -177,6 +178,15 @@ static double VARarg3; HEAD +if (@ARGV) { + my %want = map { ($_ => 0) } @ARGV; + @f = grep { exists $want{$_->{name}} } @f; + for (@f) { $want{$_->{name}}++ } + for (keys %want) { + die "nothing found for '$_'\n" unless $want{$_}; + } +} + my $f; for $f (@f) { $ignore{$f->{name}} and next; @@ -211,9 +221,14 @@ for $f (@f) { next; } $n = $tmap{$n} || $n; - my $v = 'arg' . $i++; - push @arg, $v; - $stack .= " static $n $p$v$d;\n"; + if ($n eq 'const char' and $p eq '*' and !$f->{flags}{f}) { + push @arg, '"foo"'; + } + else { + my $v = 'arg' . $i++; + push @arg, $v; + $stack .= " static $n $p$v$d;\n"; + } } unless ($f->{flags}{n} || $f->{flags}{'m'}) { diff --git a/ext/Devel/PPPort/parts/apidoc.fnc b/ext/Devel/PPPort/parts/apidoc.fnc index 09cde0e..d5fefdd 100644 --- a/ext/Devel/PPPort/parts/apidoc.fnc +++ b/ext/Devel/PPPort/parts/apidoc.fnc @@ -1,3 +1,6 @@ +Ama|char*|savepvs|const char* s +Ama|SV*|newSVpvs|const char* s +Ama|SV*|newSVpvs_share|const char* s Am|bool|isALNUM|char ch Am|bool|isALPHA|char ch Am|bool|isDIGIT|char ch @@ -56,6 +59,7 @@ Am|char*|SvPVx|SV* sv|STRLEN len Am|char|toLOWER|char ch Am|char|toUPPER|char ch Am|HV*|CvSTASH|CV* cv +Am|HV*|gv_stashpvs|const char* name|I32 create Am|HV*|SvSTASH|SV* sv Am|int|AvFILL|AV* av Am|IV|SvIV_nomg|SV* sv @@ -113,17 +117,21 @@ Am|SV*|HeSVKEY_force|HE* he Am|SV*|HeSVKEY|HE* he Am|SV*|HeSVKEY_set|HE* he|SV* sv Am|SV*|HeVAL|HE* he +Am|SV**|hv_fetchs|HV* tb|const char* key|I32 lval +Am|SV**|hv_stores|HV* tb|const char* key|NULLOK SV* val Am|SV*|newRV_inc|SV* sv Am|SV*|ST|int ix +Am|void|sv_catpvs|SV* sv|const char* s Am|SV*|SvREFCNT_inc_NN|SV* sv Am|SV*|SvREFCNT_inc_simple_NN|SV* sv Am|SV*|SvREFCNT_inc_simple|SV* sv -Am|SV*|SvREFCNT_inc_simple_void_NN|SV* sv -Am|SV*|SvREFCNT_inc_simple_void|SV* sv +Am|void|SvREFCNT_inc_simple_void_NN|SV* sv +Am|void|SvREFCNT_inc_simple_void|SV* sv Am|SV*|SvREFCNT_inc|SV* sv -Am|SV*|SvREFCNT_inc_void_NN|SV* sv -Am|SV*|SvREFCNT_inc_void|SV* sv +Am|void|SvREFCNT_inc_void_NN|SV* sv +Am|void|SvREFCNT_inc_void|SV* sv Am|SV*|SvRV|SV* sv +Am|void|sv_setpvs|SV* sv|const char* s Am|svtype|SvTYPE|SV* sv Ams||XCPT_RETHROW Ams||XSRETURN_EMPTY diff --git a/ext/Devel/PPPort/parts/base/5006000 b/ext/Devel/PPPort/parts/base/5006000 index 46ab41a..ea6360f 100644 --- a/ext/Devel/PPPort/parts/base/5006000 +++ b/ext/Devel/PPPort/parts/base/5006000 @@ -476,6 +476,7 @@ PTR2UV # added by devel/scanprov PTRV # added by devel/scanprov Perl_warner # added by devel/scanprov Perl_warner_nocontext # added by devel/scanprov +SVf # added by devel/scanprov UVSIZE # added by devel/scanprov UVTYPE # added by devel/scanprov UVof # added by devel/scanprov @@ -528,6 +529,7 @@ WARN_VOID # added by devel/scanprov XSprePUSH # added by devel/scanprov aTHX # added by devel/scanprov aTHX_ # added by devel/scanprov +ckWARN # added by devel/scanprov dNOOP # added by devel/scanprov dTHX # added by devel/scanprov dTHXa # added by devel/scanprov diff --git a/ext/Devel/PPPort/parts/base/5009003 b/ext/Devel/PPPort/parts/base/5009003 index e50d5f1..10191c5 100644 --- a/ext/Devel/PPPort/parts/base/5009003 +++ b/ext/Devel/PPPort/parts/base/5009003 @@ -4,6 +4,7 @@ Newxc # E Newxz # E SvMAGIC_set # U SvRV_set # U +SvSTASH_set # U SvUV_set # U av_arylen_p # E ckwarn # U @@ -13,8 +14,10 @@ dAXMARK # E dMULTICALL # E doref # E gv_const_sv # E +gv_stashpvs # E hv_eiter_p # E hv_eiter_set # U +hv_fetchs # E hv_name_set # U hv_placeholders_get # U hv_placeholders_p # E @@ -25,16 +28,17 @@ is_utf8_string_loclen # U my_sprintf # U newGIVENOP # E newSVhek # E +newSVpvs # E +newSVpvs_share # E newWHENOP # E newWHILEOP # E (Perl_newWHILEOP) ref # E (Perl_ref) +savepvs # E sortsv_flags # U +sv_catpvs # U vverify # U PERL_UNUSED_ARG # added by devel/scanprov STR_WITH_LEN # added by devel/scanprov SvPVX_const # added by devel/scanprov SvPVX_mutable # added by devel/scanprov dVAR # added by devel/scanprov -hv_fetchs # added by devel/scanprov -newSVpvs # added by devel/scanprov -sv_catpvs # added by devel/scanprov diff --git a/ext/Devel/PPPort/parts/base/5009004 b/ext/Devel/PPPort/parts/base/5009004 index 47cb53d..6d0d84b 100644 --- a/ext/Devel/PPPort/parts/base/5009004 +++ b/ext/Devel/PPPort/parts/base/5009004 @@ -2,27 +2,28 @@ MULTICALL # E POP_MULTICALL # E PUSH_MULTICALL # E +PerlIO_context_layers # E PoisonFree # E PoisonNew # E PoisonWith # E SvREFCNT_inc_NN # E SvREFCNT_inc_simple # E SvREFCNT_inc_simple_NN # E -SvREFCNT_inc_simple_void # E -SvREFCNT_inc_simple_void_NN # E -SvREFCNT_inc_void # E -SvREFCNT_inc_void_NN # E -SvSTASH_set # E +SvREFCNT_inc_simple_void # U +SvREFCNT_inc_simple_void_NN # U +SvREFCNT_inc_void # U +SvREFCNT_inc_void_NN # U gv_name_set # U +hv_stores # E my_snprintf # U my_vsnprintf # U newXS_flags # E pad_sv # U regclass_swash # E (Perl_regclass_swash) stashpv_hvname_match # U +sv_setpvs # U sv_usepvn_flags # U PERL_BCDVERSION # added by devel/scanprov PERL_UNUSED_CONTEXT # added by devel/scanprov +PERL_USE_GCC_BRACE_GROUPS # added by devel/scanprov SvVSTRING_mg # added by devel/scanprov -hv_stores # added by devel/scanprov -sv_setpvs # added by devel/scanprov diff --git a/ext/Devel/PPPort/parts/embed.fnc b/ext/Devel/PPPort/parts/embed.fnc index bc12ba1..bd4bd93 100644 --- a/ext/Devel/PPPort/parts/embed.fnc +++ b/ext/Devel/PPPort/parts/embed.fnc @@ -312,7 +312,7 @@ XEpoM |SV * |refcounted_he_fetch|NN const struct refcounted_he *chain \ |NULLOK SV *keysv|NULLOK const char *key \ |STRLEN klen, int flags, U32 hash dpoM |void |refcounted_he_free|NULLOK struct refcounted_he *he -dpoM |struct refcounted_he *|refcounted_he_new \ +XEdpoM |struct refcounted_he *|refcounted_he_new \ |NULLOK struct refcounted_he *const parent \ |NULLOK SV *const key|NULLOK SV *const value Apd |SV** |hv_store |NULLOK HV* tb|NULLOK const char* key|I32 klen|NULLOK SV* val \ @@ -1228,7 +1228,7 @@ sR |const char *|get_num |NN const char *ppat|NN I32 *lenptr ns |bool |need_utf8 |NN const char *pat|NN const char *patend ns |char |first_symbol |NN const char *pat|NN const char *patend sR |char * |sv_exp_grow |NN SV *sv|STRLEN needed -sR |char * |bytes_to_uni |NN const U8 *start|STRLEN len|NN char *dest +snR |char * |bytes_to_uni |NN const U8 *start|STRLEN len|NN char *dest #endif #if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT) @@ -1692,7 +1692,7 @@ p |void |offer_nice_chunk |NN void *chunk|U32 chunk_size Apnod |int |my_sprintf |NN char *buffer|NN const char *pat|... #endif -Apnod |int |my_snprintf |NN char *buffer|const Size_t len|NN const char *format|... +Apnodf |int |my_snprintf |NN char *buffer|const Size_t len|NN const char *format|... Apnod |int |my_vsnprintf |NN char *buffer|const Size_t len|NN const char *format|va_list ap px |void |my_clearenv diff --git a/ext/Devel/PPPort/parts/inc/podtest b/ext/Devel/PPPort/parts/inc/podtest index c4f0130..4dbb464 100644 --- a/ext/Devel/PPPort/parts/inc/podtest +++ b/ext/Devel/PPPort/parts/inc/podtest @@ -1,8 +1,8 @@ ################################################################################ ## -## $Revision: 2 $ +## $Revision: 3 $ ## $Author: mhx $ -## $Date: 2006/05/22 00:50:40 +0200 $ +## $Date: 2006/05/24 09:25:00 +0200 $ ## ################################################################################ ## @@ -19,28 +19,34 @@ my @pods = qw( HACKERS PPPort.pm ppport.h ); -# Try loading Test::Pod -eval q{ - use Test::Pod; - $Test::Pod::VERSION >= 0.95 - or die "Test::Pod version only $Test::Pod::VERSION"; - import Test::Pod tests => scalar @pods; -}; +my $reason = ''; -my $TP = $@ eq ''; +if ($ENV{'SKIP_SLOW_TESTS'}) { + $reason = 'SKIP_SLOW_TESTS'; +} +else { + # Try loading Test::Pod + eval q{ + use Test::Pod; + $Test::Pod::VERSION >= 0.95 + or die "Test::Pod version only $Test::Pod::VERSION"; + import Test::Pod tests => scalar @pods; + }; + $reason = 'Test::Pod >= 0.95 required' if $@; +} -unless ($TP) { +if ($reason) { load(); plan(tests => scalar @pods); } for (@pods) { print "# checking $_\n"; - if ($TP) { - pod_file_ok($_); + if ($reason) { + skip("skip: $reason", 0); } else { - skip("skip: Test::Pod >= 0.95 required", 0); + pod_file_ok($_); } } diff --git a/ext/Devel/PPPort/parts/inc/ppphtest b/ext/Devel/PPPort/parts/inc/ppphtest index 1607db5..41beb7a 100644 --- a/ext/Devel/PPPort/parts/inc/ppphtest +++ b/ext/Devel/PPPort/parts/inc/ppphtest @@ -1,8 +1,8 @@ ################################################################################ ## -## $Revision: 30 $ +## $Revision: 31 $ ## $Author: mhx $ -## $Date: 2006/01/19 18:34:14 +0100 $ +## $Date: 2006/05/24 09:25:00 +0200 $ ## ################################################################################ ## @@ -18,9 +18,9 @@ =tests plan => 202 BEGIN { - if ($ENV{'SKIP_PPPHTEST'}) { + if ($ENV{'SKIP_SLOW_TESTS'}) { for (1 .. 202) { - ok(1); + skip("skip: SKIP_SLOW_TESTS", 0); } exit 0; } diff --git a/ext/Devel/PPPort/parts/todo/5009003 b/ext/Devel/PPPort/parts/todo/5009003 index b3d4437..a7e2147 100644 --- a/ext/Devel/PPPort/parts/todo/5009003 +++ b/ext/Devel/PPPort/parts/todo/5009003 @@ -6,6 +6,7 @@ csighandler # E (Perl_csighandler) dMULTICALL # E doref # E gv_const_sv # E +gv_stashpvs # E hv_eiter_p # E hv_eiter_set # U hv_name_set # U @@ -18,8 +19,10 @@ is_utf8_string_loclen # U my_sprintf # U newGIVENOP # E newSVhek # E +newSVpvs_share # E newWHENOP # E newWHILEOP # E (Perl_newWHILEOP) ref # E (Perl_ref) +savepvs # E sortsv_flags # U vverify # U diff --git a/ext/Devel/PPPort/parts/todo/5009004 b/ext/Devel/PPPort/parts/todo/5009004 index 2451e81..cc78c24 100644 --- a/ext/Devel/PPPort/parts/todo/5009004 +++ b/ext/Devel/PPPort/parts/todo/5009004 @@ -2,6 +2,7 @@ MULTICALL # E POP_MULTICALL # E PUSH_MULTICALL # E +PerlIO_context_layers # E gv_name_set # U my_vsnprintf # U newXS_flags # E diff --git a/ext/Devel/PPPort/soak b/ext/Devel/PPPort/soak index b0ee503..ce7a655 100644 --- a/ext/Devel/PPPort/soak +++ b/ext/Devel/PPPort/soak @@ -7,9 +7,9 @@ # ################################################################################ # -# $Revision: 11 $ +# $Revision: 12 $ # $Author: mhx $ -# $Date: 2006/05/22 01:57:33 +0200 $ +# $Date: 2006/05/22 20:26:02 +0200 $ # ################################################################################ # @@ -33,7 +33,7 @@ use File::Find; use List::Util qw(max); use Config; -my $VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.08_02 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' }; +my $VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.08_03 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' }; $| = 1; my $verbose = 0; @@ -49,9 +49,17 @@ GetOptions(\%OPT, qw(verbose make=s min=s mmargs=s@)) or pod2usage(2); $OPT{mmargs} = [''] unless exists $OPT{mmargs}; $OPT{min} = parse_version($OPT{min}) - 1e-10; -my @GoodPerls = sort { eval { parse_version($a) <=> parse_version($b) } or $a cmp $b } - grep { my $v = eval { parse_version($_) }; $@ or $v >= $OPT{min} } +my @GoodPerls = map { $_->[0] } + sort { $a->[1] <=> $b->[1] or $a->[0] cmp $b->[0] } + grep { $_->[1] >= $OPT{min} } + map { [$_ => perl_version($_)] } @ARGV ? SearchPerls(@ARGV) : FindPerls(); + +unless (@GoodPerls) { + print "Sorry, got no Perl binaries for testing.\n\n"; + exit 0; +} + my $maxlen = max(map length, @GoodPerls) + 3; my $mmalen = max(map length, @{$OPT{mmargs}}); $maxlen += $mmalen+3 if $mmalen > 0; @@ -170,10 +178,11 @@ sub SearchPerls my @found; print "Searching for Perl binaries in '$arg'...\n"; find(sub { - if ($File::Find::name =~ m!bin/perl5\.!) { - eval { parse_version($File::Find::name) }; - $@ or push @found, $File::Find::name; - } + $File::Find::name =~ m!perl5[\w._]+$! + and -f $File::Find::name + and -x $File::Find::name + and perl_version($File::Find::name) + and push @found, $File::Find::name; }, $arg); printf "Found %d Perl binar%s in '%s'.\n\n", scalar @found, @found == 1 ? 'y' : 'ies', $arg; push @perls, @found; @@ -186,12 +195,17 @@ sub SearchPerls return @perls; } +sub perl_version +{ + my $perl = shift; + my $ver = `$perl -e 'print \$]' 2>&1`; + return $? == 0 && $ver >= 5 ? $ver : 0; +} + sub parse_version { my $ver = shift; - $ver = $1 if $ver =~ /perl(5\.[\d\._]+)/; - if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { return $1 + 1e-3*$2 + 1e-6*$3; } diff --git a/ext/Devel/PPPort/t/podtest.t b/ext/Devel/PPPort/t/podtest.t index a5b097c..f772a6a 100644 --- a/ext/Devel/PPPort/t/podtest.t +++ b/ext/Devel/PPPort/t/podtest.t @@ -38,28 +38,34 @@ $^W = 1; my @pods = qw( HACKERS PPPort.pm ppport.h ); -# Try loading Test::Pod -eval q{ - use Test::Pod; - $Test::Pod::VERSION >= 0.95 - or die "Test::Pod version only $Test::Pod::VERSION"; - import Test::Pod tests => scalar @pods; -}; +my $reason = ''; -my $TP = $@ eq ''; +if ($ENV{'SKIP_SLOW_TESTS'}) { + $reason = 'SKIP_SLOW_TESTS'; +} +else { + # Try loading Test::Pod + eval q{ + use Test::Pod; + $Test::Pod::VERSION >= 0.95 + or die "Test::Pod version only $Test::Pod::VERSION"; + import Test::Pod tests => scalar @pods; + }; + $reason = 'Test::Pod >= 0.95 required' if $@; +} -unless ($TP) { +if ($reason) { load(); plan(tests => scalar @pods); } for (@pods) { print "# checking $_\n"; - if ($TP) { - pod_file_ok($_); + if ($reason) { + skip("skip: $reason", 0); } else { - skip("skip: Test::Pod >= 0.95 required", 0); + pod_file_ok($_); } } diff --git a/ext/Devel/PPPort/t/ppphtest.t b/ext/Devel/PPPort/t/ppphtest.t index 02c0619..82ee77e 100644 --- a/ext/Devel/PPPort/t/ppphtest.t +++ b/ext/Devel/PPPort/t/ppphtest.t @@ -37,9 +37,9 @@ use strict; $^W = 1; BEGIN { - if ($ENV{'SKIP_PPPHTEST'}) { + if ($ENV{'SKIP_SLOW_TESTS'}) { for (1 .. 202) { - ok(1); + skip("skip: SKIP_SLOW_TESTS", 0); } exit 0; }