This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to Devel::PPPort 3.08_03
authorMarcus Holland-Moritz <mhx-perl@gmx.net>
Thu, 25 May 2006 15:52:02 +0000 (15:52 +0000)
committerMarcus Holland-Moritz <mhx-perl@gmx.net>
Thu, 25 May 2006 15:52:02 +0000 (15:52 +0000)
p4raw-id: //depot/perl@28307

24 files changed:
MANIFEST
ext/Devel/PPPort/Changes
ext/Devel/PPPort/HACKERS
ext/Devel/PPPort/PPPort.pm
ext/Devel/PPPort/PPPort_pm.PL
ext/Devel/PPPort/TODO
ext/Devel/PPPort/apicheck_c.PL
ext/Devel/PPPort/devel/devtools.pl [new file with mode: 0644]
ext/Devel/PPPort/devel/mktodo
ext/Devel/PPPort/devel/mktodo.pl
ext/Devel/PPPort/devel/regenerate [new file with mode: 0644]
ext/Devel/PPPort/parts/apicheck.pl
ext/Devel/PPPort/parts/apidoc.fnc
ext/Devel/PPPort/parts/base/5006000
ext/Devel/PPPort/parts/base/5009003
ext/Devel/PPPort/parts/base/5009004
ext/Devel/PPPort/parts/embed.fnc
ext/Devel/PPPort/parts/inc/podtest
ext/Devel/PPPort/parts/inc/ppphtest
ext/Devel/PPPort/parts/todo/5009003
ext/Devel/PPPort/parts/todo/5009004
ext/Devel/PPPort/soak
ext/Devel/PPPort/t/podtest.t
ext/Devel/PPPort/t/ppphtest.t

index 2dd7461..b677bfb 100644 (file)
--- 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
index 458bc22..115bba3 100755 (executable)
@@ -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
index 770ceeb..c73d372 100644 (file)
@@ -134,6 +134,8 @@ Finally, add the remaining baseline information by running
 
 =back
 
+Alternatively, you can try to use the F<devel/regenerate> script.
+
 =head2 Implementation
 
 Residing in F<parts/inc/> is the "heart" of C<Devel::PPPort>. Each
index 9b56c56..fe7557a 100644 (file)
@@ -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<Devel::PPPort> contains a single function, called C<WriteFile>. Its
 only purpose is to write the F<ppport.h> 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<h2xs> to write the file F<ppport.h>.
 
@@ -99,7 +99,7 @@ Otherwise it returns a false value.
 
 =head1 COMPATIBILITY
 
-F<ppport.h> supports Perl versions from 5.003 to 5.9.3
+F<ppport.h> 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<ppport.h> 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|
index cbe65b2..f0b4416 100644 (file)
@@ -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);
 
index 344ef9f..0517c99 100644 (file)
@@ -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 ?
 
index 2fbf24f..b6a6c28 100644 (file)
@@ -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 $
 #
 ################################################################################
 #
 #
 ################################################################################
 
-$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 (file)
index 0000000..a2b1e26
--- /dev/null
@@ -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;
index d7155c8..7eaffa8 100644 (file)
@@ -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 $
 #
 ################################################################################
 #
 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";
 }
+
index f66fc00..9d3f2c8 100644 (file)
@@ -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 (file)
index 0000000..d280f3e
--- /dev/null
@@ -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 <<END;
+
+API info regenerated successfully.
+
+Finished in $wall wallclock secs ($usr usr + $sys sys = $cpu CPU)
+
+Don't forget to check in the files in parts/base and parts/todo.
+
+END
+
index 5a43ce0..45e1006 100644 (file)
@@ -5,9 +5,9 @@
 #
 ################################################################################
 #
-#  $Revision: 16 $
+#  $Revision: 19 $
 #  $Author: mhx $
-#  $Date: 2006/05/19 16:15:51 +0200 $
+#  $Date: 2006/05/25 17:21:23 +0200 $
 #
 ################################################################################
 #
@@ -24,7 +24,8 @@ use strict;
 require 'parts/ppptools.pl';
 
 if (@ARGV) {
-  open OUT, ">$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'}) {
index 09cde0e..d5fefdd 100644 (file)
@@ -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
index 46ab41a..ea6360f 100644 (file)
@@ -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
index e50d5f1..10191c5 100644 (file)
@@ -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
index 47cb53d..6d0d84b 100644 (file)
@@ -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
index bc12ba1..bd4bd93 100644 (file)
@@ -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
-s    |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
index c4f0130..4dbb464 100644 (file)
@@ -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 $
 ##
 ################################################################################
 ##
 
 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($_);
   }
 }
 
index 1607db5..41beb7a 100644 (file)
@@ -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;
   }
index b3d4437..a7e2147 100644 (file)
@@ -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
index 2451e81..cc78c24 100644 (file)
@@ -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
index b0ee503..ce7a655 100644 (file)
@@ -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;
   }
index a5b097c..f772a6a 100644 (file)
@@ -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($_);
   }
 }
 
index 02c0619..82ee77e 100644 (file)
@@ -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;
   }