dslinux/user/perl/ext/Devel/PPPort/devel buildperl.pl mkapidoc.sh mktodo mktodo.pl scanprov
cayenne
dslinux_cayenne at user.in-berlin.de
Mon Dec 4 17:59:16 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/ext/Devel/PPPort/devel
In directory antilope:/tmp/cvs-serv17422/ext/Devel/PPPort/devel
Added Files:
buildperl.pl mkapidoc.sh mktodo mktodo.pl scanprov
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: scanprov ---
#!/usr/bin/perl -w
################################################################################
#
# scanprov -- scan Perl headers for provided macros
#
################################################################################
#
# $Revision: 1.1 $
# $Author: dslinux_cayenne $
# $Date: 2006-12-04 16:59:14 $
#
################################################################################
#
# Version 3.x, Copyright (C) 2004-2005, 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;
require 'parts/ppptools.pl';
die "Usage: $0 [check|write]\n" unless @ARGV && $ARGV[0] =~ /^(check|write)$/;
my $mode = $1;
my %embed = map { ( $_->{name} => 1 ) }
parse_embed(qw(parts/embed.fnc parts/apidoc.fnc));
my @provided = grep { !exists $embed{$_} }
map { /^(\w+)/ ? $1 : () }
`$^X ppport.h --list-provided`;
my $install = '/tmp/perl/install/default';
my @perls = sort { $b->{version} <=> $a->{version} }
map { { version => `$_ -e 'printf "%.6f", \$]'`, path => $_ } }
('bleadperl', glob "$install/*/bin/perl5.*");
for (1 .. $#perls) {
$perls[$_]{todo} = $perls[$_-1]{version};
}
shift @perls;
my %v;
for my $p (@perls) {
print "checking perl $p->{version}...\n";
my $archlib = `$p->{path} -MConfig -l -e 'print \$Config{archlib}'`;
chomp $archlib;
local @ARGV = glob "$archlib/CORE/*.h";
my %sym;
while (<>) { $sym{$_}++ for /(\w+)/g; }
@provided = map { $sym{$_} or $v{$p->{todo}}{$_}++; $sym{$_} ? $_ : () } @provided;
}
my $out = 'parts/base';
my $todo = parse_todo($out);
for my $v (keys %v) {
my @new = sort grep { !exists $todo->{$_} } keys %{$v{$v}};
@new or next;
my $file = $v;
$file =~ s/\.//g;
$file = "$out/$file";
-e $file or die "non-existent: $file\n";
print "-- $file --\n";
$mode eq 'write' and (open F, ">>$file" or die "$file: $!\n");
for (@new) {
print "adding $_\n";
$mode eq 'write' and printf F "%-30s # added by $0\n", $_;
}
$mode eq 'write' and close F;
}
--- NEW FILE: buildperl.pl ---
#!/usr/bin/perl -w
################################################################################
#
# buildperl.pl -- build various versions of perl automatically
#
################################################################################
#
# $Revision: 1.1 $
# $Author: dslinux_cayenne $
# $Date: 2006-12-04 16:59:13 $
#
################################################################################
#
# Version 3.x, Copyright (C) 2004-2005, 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 Getopt::Long;
use Pod::Usage;
use File::Find;
use File::Path;
use Data::Dumper;
use IO::File;
use Cwd;
my %opt = (
prefix => '/tmp/perl/install/<config>/<perl>',
build => '/tmp/perl/build/<config>',
source => '/tmp/perl/source',
force => 0,
);
my %config = (
default => {
config_args => '-des',
},
thread => {
config_args => '-des -Dusethreads',
masked_versions => [ qr/^perl5\.00[01234]/ ],
},
thread5005 => {
config_args => '-des -Duse5005threads',
masked_versions => [ qr/^perl5\.00[012345]|^perl-5.(9|\d\d)/ ],
},
debug => {
config_args => '-des -Doptimize=-g',
},
);
my @patch = (
{
perl => [
qr/^perl5\.00[01234]/,
qw/
perl5.005
perl5.005_01
perl5.005_02
perl5.005_03
/,
],
subs => [
[ \&patch_db, 1 ],
],
},
{
perl => [
qw/
perl-5.6.0
perl-5.6.1
perl-5.7.0
perl-5.7.1
perl-5.7.2
perl-5.7.3
perl-5.8.0
/,
],
subs => [
[ \&patch_db, 3 ],
],
},
{
perl => [
qr/^perl5\.004_0[1234]/,
],
subs => [
[ \&patch_doio ],
],
},
);
my(%perl, @perls);
GetOptions(\%opt, qw(
config=s@
prefix=s
source=s
perl=s@
force
)) or pod2usage(2);
if (exists $opt{config}) {
for my $cfg (@{$opt{config}}) {
exists $config{$cfg} or die "Unknown configuration: $cfg\n";
}
}
else {
$opt{config} = [sort keys %config];
}
find(sub {
/^(perl-?(5\..*))\.tar.gz$/ or return;
$perl{$1} = { version => $2, source => $File::Find::name };
}, $opt{source});
if (exists $opt{perl}) {
for my $perl (@{$opt{perl}}) {
my $p = $perl;
exists $perl{$p} or $p = "perl$perl";
exists $perl{$p} or $p = "perl-$perl";
exists $perl{$p} or die "Cannot find perl: $perl\n";
push @perls, $p;
}
}
else {
@perls = sort keys %perl;
}
$ENV{PATH} = "~/bin:$ENV{PATH}"; # use ccache
my %current;
for my $cfg (@{$opt{config}}) {
for my $perl (@perls) {
my $config = $config{$cfg};
%current = (config => $cfg, perl => $perl);
if (is($config->{masked_versions}, $perl)) {
print STDERR "skipping $perl for configuration $cfg (masked)\n";
next;
}
if (-d expand($opt{prefix}) and !$opt{force}) {
print STDERR "skipping $perl for configuration $cfg (already installed)\n";
next;
}
my $cwd = cwd;
my $build = expand($opt{build});
-d $build or mkpath($build);
chdir $build or die "chdir $build: $!\n";
print STDERR "building $perl with configuration $cfg\n";
buildperl($perl, $config);
chdir $cwd or die "chdir $cwd: $!\n";
}
}
sub expand
{
my $in = shift;
$in =~ s/(<(\w+)>)/exists $current{$2} ? $current{$2} : $1/eg;
return $in;
}
sub is
{
my($s1, $s2) = @_;
defined $s1 != defined $s2 and return 0;
ref $s2 and ($s1, $s2) = ($s2, $s1);
if (ref $s1) {
if (ref $s1 eq 'ARRAY') {
is($_, $s2) and return 1 for @$s1;
return 0;
}
return $s2 =~ $s1;
}
return $s1 eq $s2;
}
sub buildperl
{
my($perl, $cfg) = @_;
my $d = extract_source($perl{$perl});
chdir $d or die "chdir $d: $!\n";
patch_source($perl);
build_and_install($perl{$perl});
}
sub extract_source
{
my $perl = shift;
my $target = "perl-$perl->{version}";
for my $dir ("perl$perl->{version}", "perl-$perl->{version}") {
if (-d $dir) {
print "removing old build directory $dir\n";
rmtree($dir);
}
}
print "extracting $perl->{source}\n";
run_or_die("tar xzf $perl->{source}");
if ($perl->{version} !~ /^\d+\.\d+\.\d+/ && -d "perl-$perl->{version}") {
$target = "perl$perl->{version}";
rename "perl-$perl->{version}", $target or die "rename: $!\n";
}
-d $target or die "$target not found\n";
return $target;
}
sub patch_source
{
my $perl = shift;
for my $p (@patch) {
if (is($p->{perl}, $perl)) {
for my $s (@{$p->{subs}}) {
my($sub, @args) = @$s;
$sub->(@args);
}
}
}
}
sub build_and_install
{
my $perl = shift;
my $prefix = expand($opt{prefix});
print "building perl $perl->{version} ($current{config})\n";
run_or_die("./Configure $config{$current{config}}{config_args} -Dusedevel -Uinstallusrbinperl -Dprefix=$prefix");
run_or_die("sed -i -e '/^.*<built-in>/d' -e '/^.*<command line>/d' makefile x2p/makefile");
run_or_die("make all");
# run("make test");
run_or_die("make install");
}
sub patch_db
{
my $ver = shift;
print "patching DB_File\n";
run_or_die("sed -i -e 's/<db.h>/<db$ver\\/db.h>/' ext/DB_File/DB_File.xs");
}
sub patch_doio
{
patch('doio.c', <<'END');
--- doio.c.org 2004-06-07 23:14:45.000000000 +0200
+++ doio.c 2003-11-04 08:03:03.000000000 +0100
@@ -75,6 +75,16 @@
# endif
#endif
+#if _SEM_SEMUN_UNDEFINED
+union semun
+{
+ int val;
+ struct semid_ds *buf;
+ unsigned short int *array;
+ struct seminfo *__buf;
+};
+#endif
+
bool
do_open(gv,name,len,as_raw,rawmode,rawperm,supplied_fp)
GV *gv;
END
}
sub patch
{
my($file, $patch) = @_;
print "patching $file\n";
my $diff = "$file.diff";
write_or_die($diff, $patch);
run_or_die("patch -s -p0 <$diff");
unlink $diff or die "unlink $diff: $!\n";
}
sub write_or_die
{
my($file, $data) = @_;
my $fh = new IO::File ">$file" or die "$file: $!\n";
$fh->print($data);
}
sub run_or_die
{
# print "[running @_]\n";
system "@_" and die "@_: $?\n";
}
sub run
{
# print "[running @_]\n";
system "@_" and warn "@_: $?\n";
}
--- NEW FILE: mktodo ---
#!/usr/bin/perl -w
################################################################################
#
# mktodo -- generate baseline and todo files by running mktodo.pl
#
################################################################################
#
# $Revision: 1.1 $
# $Author: dslinux_cayenne $
# $Date: 2006-12-04 16:59:14 $
#
################################################################################
#
# Version 3.x, Copyright (C) 2004-2005, 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 Getopt::Long;
my %opt = (
base => 0,
);
GetOptions(\%opt, qw(
base
)) or die;
# my $outdir = $opt{base} ? 'parts/base' : 'parts/todo';
my $outdir = 'parts/todo';
# for (glob "$outdir/*") {
# unlink or die "$_: $!\n";
# }
my $install = '/tmp/perl/install/default';
# my $install = '/tmp/perl/install/thread';
my @perls = sort { $b->{version} <=> $a->{version} }
map { { version => `$_ -e 'printf "%.6f", \$]'`, path => $_ } }
('bleadperl', glob "$install/*/bin/perl5.*");
for (1 .. $#perls) {
$perls[$_]{todo} = $perls[$_-1]{version};
}
shift @perls;
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";
}
--- NEW FILE: mkapidoc.sh ---
#!/bin/bash
################################################################################
#
# mkapidoc.sh -- generate apidoc.fnc from scanning the Perl source
#
################################################################################
#
# $Revision: 1.1 $
# $Author: dslinux_cayenne $
# $Date: 2006-12-04 16:59:14 $
#
################################################################################
#
# Version 3.x, Copyright (C) 2004-2005, 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.
#
################################################################################
function isperlroot
{
[ -f "$1/embed.fnc" ] && [ -f "$1/perl.h" ]
}
function usage
{
echo "USAGE: $0 [perlroot] [output-file] [embed.fnc]"
exit 0
}
if [ -z "$1" ]; then
if isperlroot "../../.."; then
PERLROOT=../../..
else
PERLROOT=.
fi
else
PERLROOT=$1
fi
if [ -z "$2" ]; then
if [ -f "parts/apidoc.fnc" ]; then
OUTPUT="parts/apidoc.fnc"
else
usage
fi
else
OUTPUT=$2
fi
if [ -z "$3" ]; then
if [ -f "parts/embed.fnc" ]; then
EMBED="parts/embed.fnc"
else
usage
fi
else
EMBED=$3
fi
if isperlroot $PERLROOT; then
grep -hr '^=for apidoc' $PERLROOT | sed -e 's/=for apidoc //' | grep '|' | sort | uniq \
| perl -e'$f=pop;open(F,$f)||die"$f:$!";while(<F>){(split/\|/)[2]=~/(\w+)/;$h{$1}++}
while(<>){s/[ \t]+$//;(split/\|/)[2]=~/(\w+)/;$h{$1}||print}' $EMBED >$OUTPUT
else
usage
fi
--- NEW FILE: mktodo.pl ---
#!/usr/bin/perl -w
################################################################################
#
# mktodo.pl -- generate baseline and todo files
#
################################################################################
#
# $Revision: 1.1 $
# $Author: dslinux_cayenne $
# $Date: 2006-12-04 16:59:14 $
#
################################################################################
#
# Version 3.x, Copyright (C) 2004-2005, 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 Getopt::Long;
use Data::Dumper;
use IO::File;
use IO::Select;
my %opt = (
debug => 0,
base => 0,
);
print "\n$0 @ARGV\n\n";
GetOptions(\%opt, qw(
perl=s todo=s version=s debug base
)) or die;
my $fullperl = `which $opt{perl}`;
chomp $fullperl;
regen_all();
my %sym;
for (`nm $fullperl`) {
chomp;
/\s+T\s+(\w+)\s*$/ and $sym{$1}++;
}
keys %sym >= 50 or die "less than 50 symbols found in $fullperl\n";
my %all = %{load_todo($opt{todo}, $opt{version})};
my @recheck;
for (;;) {
my $retry = 1;
regen_apicheck();
retry:
my $r = run(qw(make test));
$r->{didnotrun} and die "couldn't run make test: $!\n";
$r->{status} == 0 and last;
my(@new, @tmp, %seen);
for my $l (@{$r->{stderr}}) {
if ($l =~ /_DPPP_test_(\w+)/) {
if (!$seen{$1}++) {
my @s = grep { exists $sym{$_} } $1, "Perl_$1", "perl_$1";
if (@s) {
push @tmp, [$1, "E (@s)"];
}
else {
push @new, [$1, "E"];
}
}
}
if ($l =~ /undefined symbol: (?:[Pp]erl_)?(\w+)/) {
if (!$seen{$1}++) {
my @s = grep { exists $sym{$_} } $1, "Perl_$1", "perl_$1";
push @new, [$1, @s ? "U (@s)" : "U"];
}
}
}
@new = grep !$all{$_->[0]}, @new;
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) {
if ($retry > 0) {
$retry--;
regen_all();
goto retry;
}
print Dumper($r);
die "no new TODO symbols found...";
}
push @recheck, map { $_->[0] } @new;
for (@new) {
printf "[$opt{version}] new symbol: %-30s # %s\n", @$_;
$all{$_->[0]} = $_->[1];
}
write_todo($opt{todo}, $opt{version}, \%all);
}
for my $sym (@recheck) {
my $cur = delete $all{$sym};
printf "[$opt{version}] chk symbol: %-30s # %s\n", $sym, $cur;
write_todo($opt{todo}, $opt{version}, \%all);
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;
}
else {
$all{$sym} = $cur;
}
}
write_todo($opt{todo}, $opt{version}, \%all);
run(qw(make realclean));
exit 0;
sub regen_all
{
my @mf_arg = qw( --with-apicheck OPTIMIZE=-O0 );
push @mf_arg, qw( DEFINE=-DDPPP_APICHECK_NO_PPPORT_H ) if $opt{base};
# just to be sure
run(qw(make realclean));
run($fullperl, "Makefile.PL", @mf_arg)->{status} == 0
or die "cannot run Makefile.PL: $!\n";
}
sub regen_apicheck
{
unlink qw(apicheck.c apicheck.o);
system "$fullperl apicheck_c.PL >/dev/null";
}
sub load_todo
{
my($file, $expver) = @_;
if (-e $file) {
my $f = new IO::File $file or die "cannot open $file: $!\n";
my $ver = <$f>;
chomp $ver;
if ($ver eq $expver) {
my %sym;
while (<$f>) {
chomp;
/^(\w+)\s+#\s+(.*)/ or goto nuke_file;
exists $sym{$1} and goto nuke_file;
$sym{$1} = $2;
}
return \%sym;
}
nuke_file:
undef $f;
unlink $file or die "cannot remove $file: $!\n";
}
return {};
}
sub write_todo
{
my($file, $ver, $sym) = @_;
my $f;
$f = new IO::File ">$file" or die "cannot open $file: $!\n";
$f->print("$ver\n");
for (sort keys %$sym) {
$f->print(sprintf "%-30s # %s\n", $_, $sym->{$_});
}
}
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;
}
More information about the dslinux-commit
mailing list