dslinux/user/perl/Porting Contract Glossary Maintainers Maintainers.pl Maintainers.pm apply check83.pl checkAUTHORS.pl checkURL.pl checkVERSION.pl checkcase.pl checkcfgvar.pl cmpVERSION.pl config.sh config_H config_h.pl corecpan.pl curliff.pl findrfuncs findvars fixCORE fixvars genlog makemeta makerel manicheck p4d2p p4genpatch patching.pod patchls pumpkin.pod repository.pod sort_perldiag.pl testall.atom thirdclean valgrindpp.pl
cayenne
dslinux_cayenne at user.in-berlin.de
Mon Dec 4 17:59:04 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/Porting
In directory antilope:/tmp/cvs-serv17422/Porting
Added Files:
Contract Glossary Maintainers Maintainers.pl Maintainers.pm
apply check83.pl checkAUTHORS.pl checkURL.pl checkVERSION.pl
checkcase.pl checkcfgvar.pl cmpVERSION.pl config.sh config_H
config_h.pl corecpan.pl curliff.pl findrfuncs findvars fixCORE
fixvars genlog makemeta makerel manicheck p4d2p p4genpatch
patching.pod patchls pumpkin.pod repository.pod
sort_perldiag.pl testall.atom thirdclean valgrindpp.pl
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: curliff.pl ---
#!/usr/bin/perl -ws
# curliff.pl - convert certain files in the Perl distribution that
# need to be in CR-LF format to CR-LF, or back to LF format (with the
# -r option). The CR-LF format is NOT to be used for checking in
# files to the Perforce repository, but it IS to be used when making
# Perl snapshots or releases.
use strict;
use vars qw($r);
my @FILES = qw(
djgpp/configure.bat
README.ce
README.dos
README.win32
win32/Makefile
win32/makefile.mk
wince/compile-all.bat
wince/README.perlce
wince/registry.bat
);
{
local($^I, @ARGV) = ('.orig', @FILES);
while (<>) {
if ($r) {
s/\015\012/\012/; # Curliffs to liffs.
} else {
s/\015?\012/\015\012/; # Curliffs and liffs to curliffs.
}
print;
close ARGV if eof; # Reset $.
}
}
--- NEW FILE: patchls ---
#!/usr/bin/perl -w
#
# patchls - patch listing utility
#
# Input is one or more patchfiles, output is a list of files to be patched.
#
# Copyright (c) 1997 Tim Bunce. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# With thanks to Tom Horsley for the seed code.
use Getopt::Std;
use Text::Wrap qw(wrap $columns);
use Text::Tabs qw(expand unexpand);
use strict;
use vars qw($VERSION);
$VERSION = 2.11;
sub usage {
die qq{
patchls [options] patchfile [ ... ]
-h no filename headers (like grep), only the listing.
-l no listing (like grep), only the filename headers.
-i Invert: for each patched file list which patch files patch it.
-c Categorise the patch and sort by category (perl specific).
-m print formatted Meta-information (Subject,From,Msg-ID etc).
-p N strip N levels of directory Prefix (like patch), else automatic.
-v more verbose (-d for noisy debugging).
-n give a count of the number of patches applied to a file if >1.
-f F only list patches which patch files matching regexp F
(F has \$ appended unless it contains a /).
-e Expect patched files to Exist (relative to current directory)
Will print warnings for files which don't. Also affects -4 option.
- Read patch from STDIN
other options for special uses:
-I just gather and display summary Information about the patches.
-4 write to stdout the PerForce commands to prepare for patching.
-5 like -4 but add "|| exit 1" after each command
-M T Like -m but only output listed meta tags (eg -M 'Title From')
-W N set wrap width to N (defaults to 70, use 0 for no wrap)
-X list patchfiles that may clash (i.e. patch the same file)
patchls version $VERSION by Tim Bunce
}
}
$::opt_p = undef; # undef != 0
$::opt_d = 0;
$::opt_v = 0;
$::opt_m = 0;
$::opt_n = 0;
$::opt_i = 0;
$::opt_h = 0;
$::opt_l = 0;
$::opt_c = 0;
$::opt_f = '';
$::opt_e = 0;
# special purpose options
$::opt_I = 0;
$::opt_4 = 0; # output PerForce commands to prepare for patching
$::opt_5 = 0;
$::opt_M = ''; # like -m but only output these meta items (-M Title)
$::opt_W = 70; # set wrap width columns (see Text::Wrap module)
$::opt_C = 0; # 'Chip' mode (handle from/tags/article/bug files) undocumented
$::opt_X = 0; # list patchfiles that patch the same file
usage unless @ARGV;
getopts("dmnihlvecC45Xp:f:IM:W:") or usage;
$columns = $::opt_W || 9999999;
$::opt_m = 1 if $::opt_M;
$::opt_4 = 1 if $::opt_5;
$::opt_i = 1 if $::opt_X;
# see get_meta_info()
my @show_meta = split(' ', $::opt_M || 'Title From Msg-ID Files');
my %show_meta = map { ($_,1) } @show_meta;
my %cat_title = (
'BUILD' => 'BUILD PROCESS',
'CORE' => 'CORE LANGUAGE',
'DOC' => 'DOCUMENTATION',
'LIB' => 'LIBRARY',
'PORT1' => 'PORTABILITY - WIN32',
'PORT2' => 'PORTABILITY - GENERAL',
'TEST' => 'TESTS',
'UTIL' => 'UTILITIES',
'OTHER' => 'OTHER CHANGES',
'EXT' => 'EXTENSIONS',
'UNKNOWN' => 'UNKNOWN - NO FILES PATCHED',
);
sub get_meta_info {
my $ls = shift;
local($_) = shift;
if (/^From:\s+(.*\S)/i) {;
my $from = $1; # temporary measure for Chip Salzenberg
$from =~ s/chip\@(atlantic\.net|perlsupport\.com)/chip\@pobox.com/;
$from =~ s/\(Tim Bunce\) \(Tim Bunce\)/(Tim Bunce)/;
$ls->{From}{$from} = 1
}
if (/^Subject:\s+(?:Re: )?(.*\S)/i) {
my $title = $1;
$title =~ s/\[(PATCH|PERL)[\w\. ]*\]:?//g;
$title =~ s/\b(PATCH|PERL)[\w\.]*://g;
$title =~ s/\bRe:\s+/ /g;
$title =~ s/\s+/ /g;
$title =~ s/^\s*(.*?)\s*$/$1/g;
$ls->{Title}{$title} = 1;
}
$ls->{'Msg-ID'}{$1}=1 if /^Message-Id:\s+(.*\S)/i;
$ls->{Date}{$1}=1 if /^Date:\s+(.*\S)/i;
$ls->{$1}{$2}=1 if $::opt_M && /^([-\w]+):\s+(.*\S)/;
}
# Style 1:
# *** perl-5.004/embed.h Sat May 10 03:39:32 1997
# --- perl-5.004.fixed/embed.h Thu May 29 19:48:46 1997
# ***************
# *** 308,313 ****
# --- 308,314 ----
#
# Style 2:
# --- perl5.004001/mg.c Sun Jun 08 12:26:24 1997
# +++ perl5.004-bc/mg.c Sun Jun 08 11:56:08 1997
# @@ .. @@
# or for deletions
# --- perl5.004001/mg.c Sun Jun 08 12:26:24 1997
# +++ /dev/null Sun Jun 08 11:56:08 1997
# @@ ... @@
# or (rcs, note the different date format)
# --- 1.18 1997/05/23 19:22:04
# +++ ./pod/perlembed.pod 1997/06/03 21:41:38
#
# Variation:
# Index: embed.h
my %ls;
my $in;
my $ls;
my $prevline = '';
my $prevtype = '';
my (%removed, %added);
my $prologue = 1; # assume prologue till patch or /^exit\b/ seen
foreach my $argv (@ARGV) {
$in = $argv;
if (-d $in) {
warn "Ignored directory $in\n";
next;
}
if ($in eq "-") {
*F = \*STDIN;
} elsif (not open F, "<$in") {
warn "Unable to open $in: $!\n";
next;
}
print "Reading $in...\n" if $::opt_v and @ARGV > 1;
$ls = $ls{$in} ||= { is_in => 1, in => $in };
my $type;
while (<F>) {
unless (/^([-+*]{3}) / || /^(Index):/) {
# not an interesting patch line
# but possibly meta-information or prologue
if ($prologue) {
$added{$1} = 1 if /^touch\s+(\S+)/;
$removed{$1} = 1 if /^rm\s+(?:-f)?\s*(\S+)/;
$prologue = 0 if /^exit\b/;
}
get_meta_info($ls, $_) if $::opt_m;
next;
}
$type = $1;
next if /^--- [0-9,]+ ----$/ || /^\*\*\* [0-9,]+ \*\*\*\*$/;
$prologue = 0;
print "Last: $prevline","This: ${_}Got: $type\n\n" if $::opt_d;
# Some patches have Index lines but not diff headers
# Patch copes with this, so must we. It's also handy for
# documenting manual changes by simply adding Index: lines
# to the file which describes the problem being fixed.
if (/^Index:\s+(.*)/) {
my $f;
foreach $f (split(/ /, $1)) { add_patched_file($ls, $f) }
next;
}
if ( ($type eq '---' and $prevtype eq '***') # Style 1
or ($type eq '+++' and $prevtype eq '---') # Style 2
) {
if (/^[-+*]{3} (\S+)\s*(.*?\d\d:\d\d:\d\d)?/) { # double check
if ($1 eq "/dev/null") {
$prevline =~ /^[-+*]{3} (\S+)\s*/;
add_deleted_file($ls, $1);
}
else {
add_patched_file($ls, $1);
}
}
else {
warn "$in $.: parse error (prev $prevtype, type $type)\n$prevline$_";
}
}
}
continue {
$prevline = $_;
$prevtype = $type || '';
$type = '';
}
# special mode for patch sets from Chip
if ($in =~ m:[\\/]patch$:) {
my $is_chip;
my $chip;
my $dir; ($dir = $in) =~ s:[\\/]patch$::;
if (!$ls->{From} && (open(CHIP,"$dir/article") || open(CHIP,"$dir/bug"))) {
get_meta_info($ls, $_) while (<CHIP>);
$is_chip = 1;
}
if (open CHIP,"<$dir/from") {
chop($chip = <CHIP>);
$ls->{From} = { $chip => 1 };
$is_chip = 1;
}
if (open CHIP,"<$dir/tag") {
chop($chip = <CHIP>);
$ls->{Title} = { $chip => 1 };
$is_chip = 1;
}
$ls->{From} = { "Chip Salzenberg" => 1 } if $is_chip && !$ls->{From};
}
# if we don't have a title for -m then use the file name
$ls->{Title}{"Untitled: $in"}=1 if $::opt_m
and !$ls->{Title} and $ls->{out};
$ls->{category} = $::opt_c
? categorize_files([keys %{ $ls->{out} }], $::opt_v) : '';
}
print scalar(@ARGV)." files read.\n" if $::opt_v and @ARGV > 1;
# --- Firstly we filter and sort as needed ---
my @ls = values %ls;
if ($::opt_f) { # filter out patches based on -f <regexp>
$::opt_f .= '$' unless $::opt_f =~ m:/:;
@ls = grep {
my $match = 0;
if ($_->{is_in}) {
my @out = keys %{ $_->{out} };
$match=1 if grep { m/$::opt_f/o } @out;
}
else {
$match=1 if $_->{in} =~ m/$::opt_f/o;
}
$match;
} @ls;
}
@ls = sort {
$a->{category} cmp $b->{category} || $a->{in} cmp $b->{in}
} @ls;
# --- Handle special modes ---
if ($::opt_4) {
my $tail = ($::opt_5) ? "|| exit 1" : "";
print map { "p4 delete $_$tail\n" } sort keys %removed if %removed;
print map { "p4 add $_$tail\n" } sort keys %added if %added;
my @patches = sort grep { $_->{is_in} } @ls;
my @no_outs = grep { keys %{$_->{out}} == 0 } @patches;
warn "Warning: Some files contain no patches:",
join("\n\t", '', map { $_->{in} } @no_outs), "\n" if @no_outs;
my %patched = map { ($_, 1) } map { keys %{$_->{out}} } @patches;
delete @patched{keys %added};
my @patched = sort keys %patched;
foreach(@patched) {
next if $removed{$_};
my $edit = ($::opt_e && !-f $_) ? "add " : "edit";
print "p4 $edit $_$tail\n";
}
exit 0 unless $::opt_C;
}
if ($::opt_I) {
my $n_patches = 0;
my($in,$out);
my %all_out;
my @no_outs;
foreach $in (@ls) {
next unless $in->{is_in};
++$n_patches;
my @outs = keys %{$in->{out}};
push @no_outs, $in unless @outs;
@all_out{@outs} = ($in->{in}) x @outs;
}
my @all_out = sort keys %all_out;
my @missing = grep { ! -f $_ } @all_out;
print "$n_patches patch files patch ". at all_out." files (". at missing." missing)\n";
print @no_outs." patch files don't contain patches.\n" if @no_outs;
print "(use -v to list patches which patch 'missing' files)\n"
if (@missing || @no_outs) && !$::opt_v;
if ($::opt_v and @no_outs) {
print "Patch files which don't contain patches:\n";
foreach $out (@no_outs) {
printf " %-20s\n", $out->{in};
}
}
if ($::opt_v and @missing) {
print "Missing files:\n";
foreach $out (@missing) {
printf " %-20s\t", $out unless $::opt_h;
print $all_out{$out} unless $::opt_l;
print "\n";
}
}
print "Added files: ".join(" ",sort keys %added )."\n" if %added;
print "Removed files: ".join(" ",sort keys %removed)."\n" if %removed;
exit 0+ at missing;
}
unless ($::opt_c and $::opt_m) {
foreach $ls (@ls) {
next unless ($::opt_i) ? $ls->{is_out} : $ls->{is_in};
next if $::opt_X and keys %{$ls->{out}} <= 1;
list_files_by_patch($ls);
}
}
else {
my $c = '';
foreach $ls (@ls) {
next unless ($::opt_i) ? $ls->{is_out} : $ls->{is_in};
print "\n ------ $cat_title{$ls->{category}} ------\n"
if $ls->{category} ne $c;
$c = $ls->{category};
unless ($::opt_i) {
list_files_by_patch($ls);
}
else {
my $out = $ls->{in};
print "\n$out patched by:\n";
# find all the patches which patch $out and list them
my @p = grep { $_->{out}->{$out} } values %ls;
foreach $ls (@p) {
list_files_by_patch($ls, '');
}
}
}
print "\n";
}
exit 0;
# ---
sub add_patched_file {
my $ls = shift;
my $raw_name = shift;
my $action = shift || 1; # 1==patched, 2==deleted
my $out = trim_name($raw_name);
print "add_patched_file '$out' ($raw_name, $action)\n" if $::opt_d;
$ls->{out}->{$out} = $action;
warn "$out patched but not present\n" if $::opt_e && !-f $out;
# do the -i inverse as well, even if we're not doing -i
my $i = $ls{$out} ||= {
is_out => 1,
in => $out,
category => $::opt_c ? categorize_files([ $out ], $::opt_v) : '',
};
$i->{out}->{$in} = 1;
}
sub add_deleted_file {
my $ls = shift;
my $raw_name = shift;
my $out = trim_name($raw_name);
print "add_deleted_file '$out' ($raw_name)\n" if $::opt_d;
$removed{$out} = 1;
#add_patched_file(@_[0,1], 2);
}
sub trim_name { # reduce/tidy file paths from diff lines
my $name = shift;
$name =~ s:\\:/:g; # adjust windows paths
$name =~ s://:/:g; # simplify (and make win \\share into absolute path)
if ($name eq "/dev/null") {
# do nothing (XXX but we need a way to record deletions)
}
elsif (defined $::opt_p) {
# strip on -p levels of directory prefix
my $dc = $::opt_p;
$name =~ s:^[^/]+/(.+)$:$1: while $dc-- > 0;
}
else { # try to strip off leading path to perl directory
# if absolute path, strip down to any *perl* directory first
$name =~ s:^/.*?perl.*?/::i;
$name =~ s:.*(perl|maint)[-_]?5?[._]?[-_a-z0-9.+]*/::i;
$name =~ s:^\./::;
}
return $name;
}
sub list_files_by_patch {
my($ls, $name) = @_;
$name = $ls->{in} unless defined $name;
my @meta;
if ($::opt_m) {
my $meta;
foreach $meta (@show_meta) {
next unless $ls->{$meta};
my @list = sort keys %{$ls->{$meta}};
push @meta, sprintf "%7s: ", $meta;
if ($meta eq 'Title') {
@list = map { "\"$_\""; } @list;
push @list, "#$1" if $::opt_C && $ls->{in} =~ m:\b(\w\d+)/patch$:;
}
elsif ($meta eq 'From') {
# fix-up bizzare addresses from japan and ibm :-)
foreach(@list) {
s:\W+=?iso.*?<: <:;
s/\d\d-\w\w\w-\d{4}\s+\d\d:\S+\s*//;
}
}
elsif ($meta eq 'Msg-ID') {
my %from; # limit long threads to one msg-id per site
@list = map {
$from{(/@(.*?)>/ ? $1 : $_)}++ ? () : ($_);
} @list;
}
push @meta, my_wrap(""," ", join(", ", at list)."\n");
}
$name = "\n$name" if @meta and $name;
}
# don't print the header unless the file contains something interesting
return if !@meta and !$ls->{out} and !$::opt_v;
if ($::opt_l) { # -l = no listing, just names
print "$ls->{in}";
my $n = keys %{ $ls->{out} };
print " ($n patches)" if $::opt_n and $n>1;
print "\n";
return;
}
# a twisty maze of little options
my $cat = ($ls->{category} and !$::opt_m) ? "\t$ls->{category}" : "";
print "$name$cat: " unless ($::opt_h and !$::opt_v) or !"$name$cat";
my $sep = "\n";
$sep = "" if @show_meta==1 && $::opt_c && $::opt_h;
print join('', $sep, @meta) if @meta;
return if $::opt_m && !$show_meta{Files};
my @v = sort PATORDER keys %{ $ls->{out} };
my $n = @v;
my $v = "@v";
print $::opt_m ? " Files: ".my_wrap(""," ",$v) : $v;
print " ($n patches)" if $::opt_n and $n>1;
print "\n";
}
sub my_wrap {
my $txt = eval { expand(wrap(@_)) }; # die's on long lines!
return $txt unless $@;
return expand("@_");
}
sub categorize_files {
my($files, $verb) = @_;
my(%c, $refine);
foreach (@$files) { # assign a score to a file path
# the order of some of the tests is important
$c{TEST} += 5,next if m:^t/:;
$c{DOC} += 5,next if m:^pod/:;
$c{UTIL} += 10,next if m:^(utils|x2p|h2pl)/:;
$c{PORT1}+= 15,next if m:^win32:;
$c{PORT2} += 15,next
if m:^(cygwin|os2|plan9|qnx|vms)/:
or m:^(hints|Porting|ext/DynaLoader)/:
or m:^README\.:;
$c{EXT} += 10,next
if m:^(ext|lib/ExtUtils)/:;
$c{LIB} += 10,next
if m:^(lib)/:;
$c{'CORE'} += 15,next
if m:^[^/]+[\._]([chH]|sym|pl)$:;
$c{BUILD} += 10,next
if m:^[A-Z]+$: or m:^[^/]+\.SH$:
or m:^(install|configure|configpm):i;
print "Couldn't categorise $_\n" if $::opt_v;
$c{OTHER} += 1;
}
if (keys %c > 1) { # sort to find category with highest score
refine:
++$refine;
my @c = sort { $c{$b} <=> $c{$a} || $a cmp $b } keys %c;
my @v = map { $c{$_} } @c;
if (@v > 1 and $refine <= 1 and "@v" =~ /^(\d) \1/
and $c[0] =~ m/^(DOC|TESTS|OTHER)/) { # rare
print "Tie, promoting $c[1] over $c[0]\n" if $::opt_d;
++$c{$c[1]};
goto refine;
}
print " ".@$files." patches: ", join(", ", map { "$_: $c{$_}" } @c),".\n"
if $verb;
return $c[0] || 'OTHER';
}
else {
my($c, $v) = %c;
$c ||= 'UNKNOWN'; $v ||= 0;
print " ".@$files." patches: $c: $v\n" if $verb;
return $c;
}
}
sub PATORDER { # PATORDER sort by Chip Salzenberg
my ($i, $j);
$i = ($a =~ m#^[A-Z]+$#);
$j = ($b =~ m#^[A-Z]+$#);
return $j - $i if $i != $j;
$i = ($a =~ m#configure|hint#i) || ($a =~ m#[S_]H$#);
$j = ($b =~ m#configure|hint#i) || ($b =~ m#[S_]H$#);
return $j - $i if $i != $j;
$i = ($a =~ m#\.pod$#);
$j = ($b =~ m#\.pod$#);
return $j - $i if $i != $j;
$i = ($a =~ m#include/#);
$j = ($b =~ m#include/#);
return $j - $i if $i != $j;
if ((($i = $a) =~ s#/+[^/]*$##)
&& (($j = $b) =~ s#/+[^/]*$##)) {
return $i cmp $j if $i ne $j;
}
$i = ($a =~ m#\.h$#);
$j = ($b =~ m#\.h$#);
return $j - $i if $i != $j;
return $a cmp $b;
}
--- NEW FILE: repository.pod ---
=head1 NAME
repository - Using the Perl repository
=head1 Synopsis
First, we assume here that you have already decided that you will
need B<write> access to the repository. If all you need is B<read>
access, there are much better ways to access the most current state of
the perl repository, or explore individual files and patches therein.
See L<perlhack> for details.
This document describes what a Perl Porter needs to do to start using
the Perl repository.
=head1 Prerequisites
You'll need to get hold of the following software.
=over 4
=item Perforce
Download a perforce client from:
http://www.perforce.com/perforce/loadprog.html
You'll probably also want to look at:
http://www.perforce.com/perforce/technical.html
where you can look at or download its documentation.
=item ssh
If you don't already have access to an ssh client, then look at its
home site C<http://www.cs.hut.fi/ssh> which mentions ftp sites from
which it's available. You only need to build the client parts (ssh
and ssh-keygen should suffice).
If you're on Windows then you might like to obtain Cygwin from:
http://cygwin.com/
which contains an ssh client. (MSYS also contains an ssh client
but it seems to time-out and disconnect from the server and doesn't
understand the ServerAliveInterval setting described later that can
be used to stop Cygwin's ssh client from doing this.)
Alternatively, the "plink" program, part of PuTTY:
http://www.chiark.greenend.org.uk/~sgtatham/putty/
should also work fine for Windows users.
=back
=head1 Creating an SSH Key Pair
If you already use ssh and want to use the same key pair for perl
repository access then you can skip the rest of this section.
Otherwise, generate an ssh key pair for use with the repository
by typing the command
ssh-keygen
After generating a key pair and testing it, ssh-keygen will ask you
to enter a filename in which to save the key. The default it offers
will be the file F<~/.ssh/identity> which is suitable unless you
particularly want to keep separate ssh identities for some reason.
If so, you could save the perl repository private key in the file
F<~/.ssh/perl>, for example, but I will use the standard filename
in the remainder of the examples of this document.
After typing in the filename, it will prompt you to type in a
passphrase. The private key will itself be encrypted so that it is
usable only when that passphrase is typed. (When using ssh, you will
be prompted when it requires a pass phrase to unlock a private key.)
If you provide a blank passphrase then no passphrase will be needed
to unlock the key and, as a consequence, anyone who gains access to
the key file gains access to accounts protected with that key
(barring additional configuration to restrict access by IP address).
When you have typed the passphrase in twice, ssh-keygen will confirm
where it has saved the private key (in the filename you gave and
with permissions set to be only readable by you), what your public
key is (don't worry: you don't need to memorise it) and where it
has saved the corresponding public key. The public key is saved in
a filename corresponding to your private key's filename but with
".pub" appended, usually F<~/.ssh/identity.pub>. That public key
can be (but need not be) world readable. It is not used by your
own system at all.
Note that the above process creates a key pair for ssh protocol 1.
You can request ssh protocol 2 (RSA) instead if you prefer (if your
particular ssh client supports it), via the command
ssh-keygen -t rsa
This will create private/public identity files called F<~/.ssh/id_rsa>
and F<~/.ssh/id_rsa.pub> respectively. Protocol 2 offers a higher
level of security than protocol 1. This is not required for access to
the Perl repository -- ssh is used for authentication rather than
encryption (the Perl sources are open anyway) -- but either protocol
is supported by the server.
B<IMPORTANT NOTE FOR CYGWIN USERS:> In order to make the private key
files only readable by you you must include the string "ntea" in the
"CYGWIN" environment variable in the shell used to run C<chmod(1)>,
and in the shell used to run the ssh client itself later. If "CYGWIN"
doesn't contain "ntea" then it will appear to the ssh client that the
file permissions are not set correctly, in which case the files will be
ignored and you won't be able to connect.
=head1 Notifying the Repository Keeper
Mail the contents of that public key file to the keeper of the perl
repository (see L</Contact Information> below).
When the key is added to the repository host's configuration file,
you will be able to connect to it with ssh by using the corresponding
private key file (after unlocking it with your chosen passphrase).
There is no harm in creating both protocol 1 and protocol 2 keys and
mailing them both in. That way you'll be able to connect using either
protocol, which may be useful if you later find yourself using a client
that only supports one or the other protocol.
=head1 Connecting to the Repository
Connections to the repository are made by using ssh to provide a
TCP "tunnel" rather than by using ssh to login to or invoke any
ordinary commands on the repository.
The ssh (secure shell) protocol runs over port number 22, so if you
have a firewall installed at the client end then you must ensure that
it is configured to allow you to make an outgoing connection to port 22
on sickle.activestate.com.
When you want to start a session using the repository, use the command:
ssh -l perlrep -f -q -x -L 1666:127.0.0.1:1666 sickle.activestate.com foo
If you are not using the default filename of F<~/.ssh/identity> or
F<~/.ssh/id_rsa> to hold your perl repository private key then you'll
need to add the option B<-i filename> to tell ssh where it is. Unless
you chose a blank passphrase for that private key, ssh will prompt you
for the passphrase to unlock that key. Then ssh will fork and put itself
in the background, returning you (silently) to your shell prompt.
Note that the first time you connect you may see a message like
"The authenticity of host 'sickle.activestate.com' can't be established,"
and asking you if you want to continue. Just answer yes and sickle's
details will be cached in a F<known_hosts> or F<known_hosts2> file. You
will not see that message again unless you delete the cache file.
The tunnel for repository access is now ready for use.
For the sake of completeness (and for the case where the chosen
port of 1666 is already in use on your machine), I'll briefly
describe what all those ssh arguments are for.
=over 4
=item B<-l perlrep>
Use a remote username of perlrep. (The account on the repository which
provides the end-point of the ssh tunnel is named "perlrep".)
=item B<-f>
Tells ssh to fork and remain running in the background. Since ssh
is only being used for its tunnelling capabilities, the command
that ssh runs never does any I/O and can sit silently in the
background.
=item B<-q>
Tells ssh to be quiet. Without this option, ssh will output a
message each time you use a p4 command (since each p4 command
tunnels over the ssh connection to reach the repository).
=item B<-x>
Tells ssh not to bother to set up a tunnel for X11 connections.
The repository doesn't allow this anyway.
=item B<-L 1666:127.0.0.1:1666>
This is the important option. It tells ssh to listen out for
connections made to port 1666 on your local machine. When such
a connection is made, the ssh client tells the remote side
(the corresponding ssh daemon on the repository) to make a
connection to IP address 127.0.0.1, port 1666. Data flowing
along that connection is tunnelled over the ssh connection
(encrypted). The perforce daemon running on the repository
only accepts connections from localhost and that is exactly
where ssh-tunnelled connections appear to come from.
If port 1666 is already in use on your machine then you can
choose any non-privileged port (a number between 1024 and 65535)
which happens to be free on your machine. It's the first of the
three colon separated values that you should change. Picking
port 2345 would mean changing the option to
B<-L 2345:127.0.0.1:1666>. Whatever port number you choose should
be used for the value of the P4PORT environment variable (q.v.).
=item sickle.activestate.com
This is the canonical name of the host on which the perl repository
resides.
=item foo
This is a dummy place holder argument. Without an argument
here, ssh will try to perform an interactive login to the
repository which is not allowed. Ordinarily, this argument
is for the one-off command which is to be executed on the
remote host. However, the repository's ssh configuration
file uses the "command=" option to force a particular
command to run so the actual value of the argument is
ignored. The command that's actually run merely pauses and
waits for the ssh connection to drop, then exits.
=back
=head1 Problems
You should normally get a prompt that asks for the passphrase
for your RSA key when you connect with the ssh command shown
above. If you see a prompt that looks like:
perlrep at sickle.activestate.com's password:
Then you either don't have a F<~/.ssh/identity> or F<~/.ssh/id_rsa>
file corresponding to your public key, or that file is not readable.
Fix the problem and try again.
If you only had the public key file for one protocol installed at the
server end then make sure your client is using the corresponding
protocol. An ssh client that supports protocol 2 will probably choose
that by default, which will fail if the server end only has your public
key file for protocol 1. Some ssh clients have "-1" and "-2" arguments
to force which protocol to use.
The "-v" (verbose) flag can be useful for seeing what protocol your
client is actually trying to connect with, and for spotting any other
problems. The flag can be specified multiple times to increase
verbosity. Note that specifying the "-q" flag as well might override
your request for verbose output, so drop the "-q" flag when trying this.
If you're using the Cygwin ssh client on Windows then you will probably
find that the connection times out after a short period of inactivity.
You will have to keep re-entering your passphrase to reconnect, which
gets annoying after a while. In order to prevent these time-outs from
happening place the following two lines in the file F<~/.ssh/config>:
Host sickle.activestate.com
ServerAliveInterval 120
This causes the ssh client to send a message to the server every 120
seconds to check that the server is still alive. The client will not
disconnect unless "ServerAliveCountMax" many of these messages go
unanswered. Run C<man ssh_config> for more details. Note also that
this option applies to protocol version 2 only.
=head1 Using the Perforce Client
Remember to read the documentation for Perforce. You need
to make sure that three environment variable are set
correctly before using the p4 client with the perl repository.
=over 4
=item P4PORT
Set this to localhost:1666 (the port for your ssh client to listen on)
unless that port is already in use on your host. If it is, see
the section above on the B<-L 1666:127.0.0.1:1666> option to ssh.
=item P4CLIENT
The value of this is the name by which Perforce knows your
host's workspace. You need to pick a name (normally, your
Perforce username, a dash, and your host's short name)
when you first start using the perl repository and then
stick with it.
Perforce keeps track of the files you have on your machine. It
does this through your client. When you first sync a version of a
file, the file comes from the server to your machine. If you sync
the same file again the server does nothing because it
knows you already have the file.
You should NOT use the same client on different machines. If you do
you probably won't get the files you expect, and may end up with
nasty corruption. Perforce allows you to have as many clients as
you want. For example, sally-home, sally-openbsd, sally-laptop.
Also, never change the client's root and view at the same time.
See C<http://www.perforce.com/perforce/doc.002/manuals/p4guide/04_details.html#1048341>
If you have multiple hosts sharing the same directory structure
via NFS then you may be able to get away with only one client name,
but be careful.
The C<p4 clients> command lists all currently known clients.
=item P4USER
This is the username by which perforce knows you. Use your
username if you have a well known or obvious one or else pick
a new one which other perl5-porters will recognise. There is
a licence limit on the number of these usernames, so be sure not
to use more than one.
It is very important to set a password for your Perforce username,
or else anyone can impersonate you. Use the C<p4 passwd> command
to do this. Once a password is set for your account, you'll need
to tell Perforce what it is. You can do this by setting the
environment variable P4PASSWD, or you can use the C<-P> flag
with the C<p4> command.
There are a few techniques you can use to avoid having to either
set an environment variable or type the password on every command.
One is to create a shell alias, for example, in bash, add something like
alias p4='p4 -P secret'
to your F<.bash_profile> file. Another way is to create a small shell
script, for example
#!/bin/bash
p4 -P secret $@
And use this instead of running C<p4> directly.
With either of these, be sure the file containing your password
(the F<.bash_profile> or shell script file) is only readable by you.
The C<p4 users> command lists all currently known users.
=back
Note that on Windows P4PORT and P4USER are requested when installing
Perforce. They are stored in the registry, so they do not need to be
set in the environment.
Once these three environment variables are set, you can use the
perforce p4 client exactly as described in its documentation.
After setting these variables and connecting to the repository
for the first time, you should use the C<p4 user> command to
set a valid email address for yourself. Messages to the commit list
are sent (faked) from whatever email address you set here.
Also use the C<p4 client> command to specify your workspace
specifications for each individual client from which you will interact
with the repository. The P4CLIENT environment variable, of course,
needs to be set to one of these client workspace names.
=head1 Ending a Repository Session
When you have finished a session using the repository, you
should kill off the ssh client process to break the tunnel.
Since ssh forked itself into the background, you'll need to use
something like ps with the appropriate options to find the ssh
process and then kill it manually. The default signal of
SIGTERM is fine.
=head1 Overview of the Repository
Please read at least the introductory sections of the Perforce
User Guide (and perhaps the Quick Start Guide as well) before
reading this section.
Every repository user typically "owns" a "branch" of the mainline
code in the repository. They hold the "pumpkin" for things in this
area, and are usually the only user who will modify files there.
This is not strictly enforced in order to allow the flexibility
of other users stealing the pumpkin for short periods with the
owner's permission.
Here is (part of) the current structure of the repository:
/----+-----perl - Mainline development (bleadperl)
+-----perlio - PerlIO Pumpkin's Perl
+-----vmsperl - VMS Pumpkin's Perl
+-----maint-5.004------perl - Maintenance branches
+-----maint-5.005------perl
+-----maint-5.6--------perl
+-----maint-5.8--------perl
+-----pureperl---------pureperl
Perforce uses a branching model that simply tracks relationships
between files. It does not care about directories at all, so
any file can be a branch of any other file--the fully qualified
depot path name (of the form //depot/foo/bar.c) uniquely determines
a file for the purpose of establishing branching relationships.
Since a branch usually involves hundreds of files, such relationships
are typically specified en masse using a branch map (try `p4 help branch`).
`p4 branches` lists the existing branches that have been set up.
`p4 branch -o branchname` can be used to view the map for a particular
branch, if you want to determine the ancestor for a particular set of
files.
The mainline (aka "trunk") code in the Perl repository is under
"//depot/perl/...". Most branches typically map its entire
contents under a directory that goes by the same name as the branch
name. Thus the contents of the perlio branch are to be found
in //depot/perlio.
Run `p4 client` to specify how the repository contents should map to
your local disk. Most users will typically have a client map that
includes at least their entire branch and the contents of the mainline.
Run `p4 changes -l -m10` to check on the activity in the repository.
//depot/perl/Porting/genlog is useful to get an annotated changelog
that shows files and branches. You can use this listing to determine
if there are any changes in the mainline that you need to merge into
your own branch. A typical merging session looks like this:
% cd ~/p4view/perlio
% p4 integrate -b perlio # to bring parent changes into perlio
% p4 resolve -am ./... # auto merge the changes
% p4 resolve ./... # manual merge conflicting changes
% p4 submit ./... # check in
If the owner of the mainline wants to bring the changes in perlio
back into the mainline, they do:
% p4 integrate -r -b perlio
...
Generating a patch for change#42 is done as follows:
% p4genpatch 42 > change-42.patch
F<p4genpatch> is to be found in //depot/perl/Porting/.
The usual routine to apply a patch is
% p4 edit file.c file.h
% patch < patch.txt
(any necessary, re-Configure, make regen_headers, make clean, etc, here)
% make all test
(preferably make all test in several platforms and under several
different Configurations)
% while unhappy
do
$EDITOR
make all test
done
% p4 submit
Other useful Perforce commands
% p4 describe -du 12345 # show change 12345
Note: the output of "p4 describe" is not in proper diff format, use
the F<Porting/p4genpatch> to get a diff-compatible format.
(Note that it may be easier to get one already prepared: grep
L<perlhack> for APC, and append eg "/diffs/12345.gz" to one of the
URLs to get a usable patch.)
% p4 diff -se ./... # have I modified something but forgotten
# to "p4 edit", easy faux pas with autogenerated
# files like proto.h, or if one forgets to
# look carefully which files a patch modifies
% p4 sync file.h # if someone else has modified file.h
% p4 opened # which files are opened (p4 edit) by me
% p4 opened -a # which files are opened by anybody
% p4 diff -du file.c # what changes have I done
% p4 revert file.h # never mind my changes
% p4 sync -f argh.c # forcibly synchronize your file
# from the repository
% p4 diff -sr | p4 -x - revert
# throw away (opened but) unchanged files
# (in Perforce it's a little bit too easy
# to checkin unchanged files)
Integrate patch 12345 from the mainline to the maint-5.6 branch:
(you have to in the directory that has both the mainline and
the maint-5.6/perl as subdirectories)
% p4 integrate -d perl/... at 12345,12345 maint-5.6/perl/...
Integrate patches 12347-12350 from the perlio branch to the mainline:
% p4 integrate -d perlio/... at 12347,12350 perl/...
=head1 Contact Information
The mail alias E<lt>perl-repository-keepers at perl.orgE<gt> can be used to reach
all current users of the repository.
The repository keeper is currently Gurusamy Sarathy
E<lt>gsar at activestate.comE<gt>.
=head1 AUTHORS
Malcolm Beattie, E<lt>mbeattie at sable.ox.ac.ukE<gt>, 24 June 1997.
Gurusamy Sarathy, E<lt>gsar at activestate.comE<gt>, 8 May 1999.
Slightly updated by Simon Cozens, E<lt>simon at brecon.co.ukE<gt>, 3 July 2000.
More updates by Jarkko Hietaniemi, E<lt>jhi at iki.fiE<gt>, 28 June 2001.
Perforce clarifications by Randall Gellens, E<lt>rcg at users.sourceforge.netE<gt>, 12 July 2001.
Windows-related updates by Steve Hay E<lt>shay at cpan.orgE<gt>, 23 July 2004
and 08 Aug 2005.
=cut
--- NEW FILE: genlog ---
#!/usr/bin/perl -w
#
# Generate a nice changelist by querying perforce.
#
# Each change is described with the change number, description,
# which branch the change happened in, files modified,
# and who was responsible for entering the change.
#
# Can be called with a list of change numbers or a range of the
# form "12..42". Changelog will be printed from highest number
# to lowest.
#
# Outputs the changelist to stdout.
#
# Gurusamy Sarathy <gsar at activestate.com>
#
use Text::Wrap;
$0 =~ s|^.*/||;
unless (@ARGV) {
die <<USAGE;
$0 [-p \$P4PORT] [-bi branch_include] [-be branch_exclude] <change numbers or from..to>
USAGE
}
my @changes;
my %editkind;
@editkind{ qw( add edit delete integrate branch )}
= qw( + ! - !> +> );
my $p4port = $ENV{P4PORT} || 'localhost:1666';
my @branch_include;
my @branch_exclude;
my %branch_include;
my %branch_exclude;
while (@ARGV) {
$_ = shift;
if (/^(\d+)\.\.(\d+)?$/) {
push @changes, $1 .. ($2 || (split(' ', `p4 changes -m 1`))[1]);
}
elsif (/^\d+$/) {
push @changes, $_;
}
elsif (/^-p(.*)$/) {
$p4port = $1 || shift;
}
elsif (/^-bi(.*)$/) {
push @branch_include, $1 || shift;
}
elsif (/^-be(.*)$/) {
push @branch_exclude, $1 || shift;
}
else {
warn "Arguments must be change numbers, ignoring `$_'\n";
}
}
@changes = sort { $b <=> $a } @changes;
@branch_include{@branch_include} = @branch_include if @branch_include;
@branch_exclude{@branch_exclude} = @branch_exclude if @branch_exclude;
my @desc = `p4 -p $p4port describe -s @changes`;
if ($?) {
die "$0: `p4 -p $p4port describe -s @changes` failed, status[$?]\n";
}
else {
tr/\r/\n/ foreach @desc;
chomp @desc;
while (@desc) {
my ($change,$who,$date,$time, at log,$branch,$file,$type,%files);
my $skip = 0;
my $nbranch = 0;
$_ = shift @desc;
if (/^Change (\d+) by (\w+)\@.+ on (\S+) (\S+)\s*$/) {
($change, $who, $date, $time) = ($1,$2,$3,$4);
$_ = shift @desc; # get rid of empty line
while (@desc) {
$_ = shift @desc;
last if /^Affected/;
push @log, $_;
}
if (/^Affected/) {
$_ = shift @desc; # get rid of empty line
while ($_ = shift @desc) {
last unless /^\.\.\./;
if (m{^\.\.\. //depot/(.*?perl|[^/]*)/([^#]+)#\d+ (\w+)\s*$}) {
($branch,$file,$type) = ($1,$2,$3);
$nbranch++;
if (exists $branch_exclude{$branch} or
@branch_include and
not exists $branch_include{$branch}) {
$skip++;
}
$files{$branch} = {} unless exists $files{$branch};
$files{$branch}{$type} = [] unless exists $files{$branch}{$type};
push @{$files{$branch}{$type}}, $file;
}
else {
warn "Unknown line [$_], ignoring\n";
}
}
}
}
next if ((not $change) or $skip);
print "_" x 76, "\n";
printf <<EOT, $change, $who, $date, $time;
[%6s] By: %-25s on %9s %9s
EOT
print " Log: ";
my $i = 0;
while (@log) {
$_ = shift @log;
s/^\s*//;
s/^\[.*\]\s*// unless $i ;
# don't print last empty line
if ($_ or @log) {
print " " if $i++;
print "$_\n";
}
}
for my $branch (sort keys %files) {
printf "%11s: $branch\n", 'Branch';
for my $kind (sort keys %{$files{$branch}}) {
warn("### $kind ###\n"), next unless exists $editkind{$kind};
my $files = $files{$branch}{$kind};
# don't show large branches and integrations
$files = ["($kind " . scalar(@$files) . ' files)']
if (@$files > 25 && ($kind eq 'integrate'
|| $kind eq 'branch'))
|| @$files > 100;
print wrap(sprintf("%12s ", $editkind{$kind}),
sprintf("%12s ", $editkind{$kind}),
"@$files\n");
}
}
}
}
--- NEW FILE: check83.pl ---
#!/usr/bin/perl -w
use strict;
# Check whether there are naming conflicts when names are truncated to
# the DOSish case-ignoring 8.3 format, plus other portability no-nos.
# The "8.3 rule" is loose: "if reducing the directory entry names
# within one directory to lowercase and 8.3-truncated causes
# conflicts, that's a bad thing". So the rule is NOT the strict
# "no filename shall be longer than eight and a suffix if present
# not longer than three".
my %seen;
my $maxl = 30; # make up a limit for a maximum filename length
sub eight_dot_three {
return () if $seen{$_[0]}++;
my ($dir, $base, $ext) = ($_[0] =~ m{^(?:(.+)/)?([^/.]+)(?:\.([^/.]+))?$});
my $file = $base . ( defined $ext ? ".$ext" : "" );
$base = substr($base, 0, 8);
$ext = substr($ext, 0, 3) if defined $ext;
if (defined $dir && $dir =~ /\./) {
print "directory name contains '.': $dir\n";
}
if ($file =~ /[^A-Za-z0-9\._-]/) {
print "filename contains non-portable characters: $_[0]\n";
}
if (length $file > $maxl) {
print "filename longer than $maxl characters: $file\n";
}
if (defined $dir) {
return ($dir, defined $ext ? "$dir/$base.$ext" : "$dir/$base");
} else {
return ('.', defined $ext ? "$base.$ext" : $base);
}
}
my %dir;
if (open(MANIFEST, "MANIFEST")) {
while (<MANIFEST>) {
chomp;
s/\s.+//;
unless (-f) {
print "missing: $_\n";
next;
}
if (tr/././ > 1) {
print "more than one dot: $_\n";
next;
}
while (m!/|\z!g) {
my ($dir, $edt) = eight_dot_three($`);
next unless defined $dir;
($dir, $edt) = map { lc } ($dir, $edt);
push @{$dir{$dir}->{$edt}}, $_;
}
}
} else {
die "$0: MANIFEST: $!\n";
}
for my $dir (sort keys %dir) {
for my $edt (keys %{$dir{$dir}}) {
my @files = @{$dir{$dir}->{$edt}};
if (@files > 1) {
print "directory $dir conflict $edt: @files\n";
}
}
}
--- NEW FILE: makerel ---
#!/usr/bin/perl -w
# A first attempt at some automated support for making a perl release.
# Very basic but functional - if you're on a unix system.
#
# No matter how automated this gets, you'll always need to read
# and re-read pumpkin.pod checking for things to be done at various
# stages of the process.
#
# Tim Bunce, June 1997
use ExtUtils::Manifest qw(fullcheck);
$|=1;
$relroot = ".."; # XXX make an option
die "Must be in root of the perl source tree.\n"
unless -f "./MANIFEST" and -f "patchlevel.h";
open PATCHLEVEL,"<patchlevel.h" or die;
my @patchlevel_h = <PATCHLEVEL>;
close PATCHLEVEL;
my $patchlevel_h = join "", grep { /^#\s*define/ } @patchlevel_h;
print $patchlevel_h;
$revision = $1 if $patchlevel_h =~ /PERL_REVISION\s+(\d+)/;
$patchlevel = $1 if $patchlevel_h =~ /PERL_VERSION\s+(\d+)/;
$subversion = $1 if $patchlevel_h =~ /PERL_SUBVERSION\s+(\d+)/;
die "Unable to parse patchlevel.h" unless $subversion >= 0;
$vers = sprintf("%d.%d.%d", $revision, $patchlevel, $subversion);
$vms_vers = sprintf("%d_%d_%d", $revision, $patchlevel, $subversion);
# fetch list of local patches
my (@local_patches, @lpatch_tags, $lpatch_tags);
@local_patches = grep { /^static.*local_patches/../^};/ } @patchlevel_h;
@local_patches = grep { !/^\s*,?NULL/ } @local_patches;
@lpatch_tags = map { /^\s*,"(\w+)/ } @local_patches;
$lpatch_tags = join "-", @lpatch_tags;
$perl = "perl-$vers";
$reldir = "$perl";
$reldir .= "-$lpatch_tags" if $lpatch_tags;
print "\nMaking a release for $perl in $relroot/$reldir\n\n";
print "Cross-checking the MANIFEST...\n";
($missfile, $missentry) = fullcheck();
warn "Can't make a release with MANIFEST files missing.\n" if @$missfile;
warn "Can't make a release with files not listed in MANIFEST.\n" if @$missentry;
if ("@$missentry" =~ m/\.orig\b/) {
# Handy listing of find command and .orig files from patching work.
# I tend to run 'xargs rm' and copy and paste the file list.
my $cmd = "find . -name '*.orig' -print";
print "$cmd\n";
system($cmd);
}
die "Aborted.\n" if @$missentry or @$missfile;
print "\n";
# VMS no longer has hardcoded version numbers descrip.mms
#print "Updating VMS version specific files with $vms_vers...\n";
#system("perl -pi -e 's/^\QPERL_VERSION = \E\d\_\d+(\s*\#)/PERL_VERSION = $vms_vers$1/' vms/descrip.mms");
print "Creating $relroot/$reldir release directory...\n";
die "$relroot/$reldir release directory already exists\n" if -e "$relroot/$reldir";
die "$relroot/$reldir.tar.gz release file already exists\n" if -e "$relroot/$reldir.tar.gz";
mkdir("$relroot/$reldir", 0755) or die "mkdir $relroot/$reldir: $!\n";
print "\n";
print "Copying files to release directory...\n";
# ExtUtils::Manifest maniread does not preserve the order
$cmd = "awk '{print \$1}' MANIFEST | cpio -pdm $relroot/$reldir";
system($cmd) == 0
or die "$cmd failed";
print "\n";
chdir "$relroot/$reldir" or die $!;
print "Setting file permissions...\n";
system("find . -type f -print | xargs chmod 0444");
system("find . -type d -print | xargs chmod 0755");
system("find t ext lib -name '*.t' -print | xargs chmod +x");
system("find t ext lib -name 'test.pl' -print | xargs chmod +x");
my @exe = qw(
Configure
configpm
configure.gnu
embed.pl
installperl
installman
keywords.pl
opcode.pl
perly.fixer
t/TEST
*.SH
vms/ext/Stdio/test.pl
vms/ext/filespec.t
x2p/*.SH
Porting/findrfuncs
Porting/genlog
Porting/makerel
Porting/p4genpatch
Porting/patchls
Porting/*.pl
mpeix/nm
mpeix/relink
Cross/generate_config_sh
Cross/warp
);
system("chmod +x @exe") == 0
or die "system: $!";
my @writables = qw(
NetWare/config_H.wc
NetWare/Makefile
keywords.h
opcode.h
opnames.h
pp_proto.h
pp.sym
proto.h
embed.h
embedvar.h
global.sym
pod/perlintern.pod
pod/perlapi.pod
perlapi.h
perlapi.c
ext/ByteLoader/byterun.h
ext/ByteLoader/byterun.c
ext/B/B/Asmdata.pm
ext/Devel/PPPort/PPPort.xs
ext/Devel/PPPort/module2.c
ext/Devel/PPPort/module3.c
regnodes.h
warnings.h
lib/warnings.pm
vms/perly_c.vms
vms/perly_h.vms
win32/Makefile
win32/makefile.mk
win32/config_H.bc
win32/config_H.gc
win32/config_H.vc
wince/config_H.ce
wince/Makefile.ce
);
system("chmod +w @writables") == 0
or die "system: $!";
print "Adding CRs to DOSish files...\n";
my @crlf = qw(
djgpp/configure.bat
README.ce
README.dos
README.win32
win32/Makefile
win32/makefile.mk
wince/Makefile.ce
wince/compile-all.bat
wince/README.perlce
wince/registry.bat
);
system("perl -pi -e 's/\\015*\\012/\\015\\012/' @crlf") == 0
or die "system: $!";
print "\n";
chdir ".." or die $!;
print "Creating and compressing the tar file...\n";
my $src = (-e $perl) ? $perl : 'perl'; # 'perl' in maint branch
$cmd = "tar cf - $reldir | gzip --best > $reldir.tar.gz";
system($cmd) == 0
or die "$cmd failed";
print "\n";
system("ls -ld $perl*");
--- NEW FILE: fixvars ---
#!/usr/bin/perl -w
use Data::Dumper;
my $targ = (@ARGV) ? join(' ', at ARGV) : 'miniperl' ;
my $work = 1;
while ($work)
{
open(PIPE,"make $targ 2>&1 |") || die "Cannot open pipe to make:$!";
my %fix;
while (<PIPE>)
{
if (/^(.*):(\d+):\s+\`(\w+)'\s+undeclared/ && -f $1 )
{
my ($file,$line,$var) = ($1,$2,$3);
$fix{$file} = [] unless exists $fix{$file};
push(@{$fix{$file}},[$line => $var]) unless ($var =~ /^PL_/ || $file =~ /\.h$/);
}
print;
}
close(PIPE);
warn "Make retured $?\n";
last unless $?;
my $changed = 0;
foreach my $file (keys %fix)
{
my @ar = sort( { $a->[0] <=> $b->[0] } @{delete $fix{$file}});
my @miss;
my $fixed = 0;
unless (-w $file)
{
system("d4","edit",$file);
}
@ARGV = ($file);
$. = 0;
local $^I = '.sav';
while (<>)
{
while (@ar && $. == $ar[0][0])
{
my ($line,$var) = @{shift(@ar)};
if (s/\b$var\b/PL_$var/)
{
warn "$file:$line: FIX $var\n";
$fixed++;
$changed++;
}
else
{
push(@miss,[$line,$var,$_]);
}
}
print;
}
unless ($fixed)
{
rename("$file$^I",$file);
if (@miss)
{
while (@miss)
{
my ($line,$var,$txt) = @{shift(@miss)};
warn "$file:$line:$var | $txt";
}
}
}
}
last unless $changed;
}
--- NEW FILE: cmpVERSION.pl ---
#!/usr/bin/perl -w
#
# cmpVERSION - compare two Perl source trees for modules
# that have identical version numbers but different contents.
#
# Original by slaven at rezic.de, modified by jhi.
#
use strict;
use ExtUtils::MakeMaker;
use File::Compare;
use File::Find;
use File::Spec::Functions qw(rel2abs abs2rel catfile catdir curdir);
for (@ARGV[0, 1]) {
die "$0: '$_' does not look like Perl directory\n"
unless -f catfile($_, "perl.h") && -d catdir($_, "Porting");
}
my $dir2 = rel2abs($ARGV[1]);
chdir $ARGV[0] or die "$0: chdir '$ARGV[0]' failed: $!\n";
# Files to skip from the check for one reason or another,
# usually because they pull in their version from some other file.
my %skip;
@skip{'./lib/Exporter/Heavy.pm'} = ();
my @wanted;
find(
sub { /\.pm$/ &&
! exists $skip{$File::Find::name}
&&
do { my $file2 =
catfile(catdir($dir2, $File::Find::dir), $_);
(my $xs_file1 = $_) =~ s/\.pm$/.xs/;
(my $xs_file2 = $file2) =~ s/\.pm$/.xs/;
if (-e $xs_file1 && -e $xs_file2) {
return if compare($_, $file2) == 0 &&
compare($xs_file1, $xs_file2) == 0;
} else {
return if compare($_, $file2) == 0;
}
my $version1 = eval {MM->parse_version($_)};
my $version2 = eval {MM->parse_version($file2)};
push @wanted, $File::Find::name
if defined $version1 &&
defined $version2 &&
$version1 eq $version2
} }, curdir);
print map { $_, "\n" } sort @wanted;
--- NEW FILE: apply ---
#!/usr/bin/perl -w
my $file = pop(@ARGV);
my %meta;
$ENV{'P4PORT'} ||= 'bactrian:1667';
$ENV{'P4CLIENT'} ||= 'ni-s';
open(FILE,$file) || die "Cannot open $file:$!";
while (<FILE>)
{
if (/^(From|Subject|Date|Message-ID):(.*)$/i)
{
$meta{lc($1)} = $2;
}
}
my @results = `patch @ARGV <$file 2>&1`;
warn @results;
my $code = $?;
warn "$code from patch\n";
foreach (@results)
{
if (/[Pp]atching\s+file\s*(\S+)/)
{
push(@edit,$1);
}
}
my @have = `p4 have @edit`;
if ($code == 0)
{
System("p4 edit @edit");
open(PIPE,"|p4 change -i") || die "Cannot open pipe to p4:$!";
print PIPE "Change: new\n";
print PIPE "Description:\n";
foreach my $key (qw(Subject From Date Message-Id))
{
if (exists $meta{lc($key)})
{
print PIPE "\t$key: ",$meta{lc($key)},"\n";
print "$key: ",$meta{lc($key)},"\n";
}
}
print PIPE "Files:\n";
foreach (@have)
{
if (m,^(.*)#,)
{
print PIPE "\t$1\n"
}
}
close(PIPE);
}
else
{
if (@edit)
{
System("p4 refresh @edit");
}
}
sub System
{
my $cmd = join(' ', at _);
warn "$cmd\n";
if (fork)
{
wait;
}
else
{
_exit(exec $cmd);
}
}
--- NEW FILE: manicheck ---
#!/usr/bin/perl -ws
#
# manicheck - check files against the MANIFEST
#
# Without options prints out (possibly) two lines:
#
# extra: a b c
# missing: d
#
# With option -x prints out only the missing files (and without the "extra: ")
# With option -m prints out only the extra files (and without the "missing: ")
#
BEGIN {
$SIG{__WARN__} = sub {
help() if $_[0] =~ /"main::\w" used only once: possible typo at /;
};
}
use strict;
sub help {
die <<EOF;
$0: Usage: $0 [-x|-m|-l|-h]
-x show only the extra files
-m show only the missing files
-l show the files one per line instead of one line
-h show only this help
EOF
}
use vars qw($x $m $l $h);
help() if $h;
open(MANIFEST, "MANIFEST") or die "MANIFEST: $!";
my %mani;
my %mand = qw(. 1);
use File::Basename qw(dirname);
while (<MANIFEST>) {
if (/^(\S+)\t+(.+)$/) {
$mani{$1}++;
my $d = dirname($1);
while($d ne '.') {
$mand{$d}++;
$d = dirname($d);
}
} else {
warn "MANIFEST:$.:$_";
}
}
close(MANIFEST);
my %find;
use File::Find;
find(sub {
my $n = $File::Find::name;
$n =~ s:^\./::;
$find{$n}++;
}, '.' );
my @xtra;
my @miss;
for (sort keys %find) {
push @xtra, $_ unless $mani{$_} || $mand{$_};
}
for (sort keys %mani) {
push @miss, $_ unless $find{$_};
}
$" = "\n" if $l;
unshift @xtra, "extra:" if @xtra;
unshift @miss, "missing:" if @miss;
print "@xtra\n", if @xtra && !$m;
print "@miss\n" if @miss && !$x;
exit 0;
--- NEW FILE: makemeta ---
#!./perl -w
# this script must be run by the current perl to get perl's version right
use strict;
use warnings;
use lib "Porting";
use File::Basename qw( dirname );
my $file = "META.yml";
die "$0: will not override $file, delete it first.\n" if -e $file;
use Maintainers qw(%Modules get_module_files get_module_pat);
my @CPAN = grep { $Modules{$_}{CPAN} } keys %Modules;
my @files = map { get_module_files($_) } @CPAN;
my @dirs = grep { -d $_ } map { get_module_pat($_) } @CPAN;
my %dirs;
@dirs{@dirs} = ();
my $files = join '', map { " - $_\n" }
grep {
my $d = $_;
while(($d = dirname($d)) ne "."){
last if exists $dirs{$d};
}
# if $d is "." it means we tried every parent dir of the file and none
# of them were in the private list
$d eq ".";
}
sort { lc $a cmp lc $b } @files;
my $dirs = join '', map { " - $_\n" } sort { lc $a cmp lc $b } @dirs;
open my $fh, ">$file" or die "Can't open $file: $!";
print $fh <<"EOI";
name: perl
version: $]
abstract: Practical Extraction and Reporting Language
author: perl5-porters\@perl.org
license: perl
distribution_type: core
private:
directory:
$dirs
file:
$files
EOI
close $fh;
--- NEW FILE: checkVERSION.pl ---
#!/usr/bin/perl -w
#
# Check the tree against missing VERSIONs.
#
# Originally by Larry Shatzer
#
use strict;
use File::Find;
find(
sub {
return unless -f;
if (/\.pm$/ && $File::Find::name !~ m:/t/:) { # pm but not in a test
unless (parse_file($_)) {
print "$File::Find::name\n";
}
}
}, @ARGV ? shift : ".");
sub parse_file {
my $parsefile = shift;
my $result;
open(FH,$parsefile) or warn "Could not open '$parsefile': $!";
my $inpod = 0;
while (<FH>) {
$inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
next if $inpod || /^\s*\#/;
chomp;
next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/;
my $eval = qq{
package ExtUtils::MakeMaker::_version;
no strict;
local $1$2;
\$$2=undef; do {
$_
}; \$$2
};
no warnings;
$result = eval($eval);
warn "Could not eval '$eval' in $parsefile: $@" if $@;
$result = "undef" unless defined $result;
last;
}
close FH;
return $result;
}
--- NEW FILE: findvars ---
#!/usr/bin/perl -w
$pat = '';
# construct word list
while (<DATA>) {
chomp;
next unless $_;
$pat .= "$_|";
}
chop $pat if $pat =~ /\|$/;
# grep
while (<>) {
print "$ARGV\:$.\:$_" if s/\b($pat)\b/#$1#/og;
# this variant might useful if the transformation is more complicated
# if (/^(.*?)\b($pat)\b(.*)$/o) {
# my $head = "$1#$2#";
# $_ = $3;
# while (/^(.*?)\b($pat)\b(.*)$/o) {
# $head .= "$1#$2#";
# $_ = $3;
# }
# print "$ARGV\:$.\:$head$_\n";
# }
}
continue {
close ARGV if eof;
}
__END__
Argv
Cmd
DBcv
DBgv
DBline
DBsignal
DBsingle
DBsub
DBtrace
No
Sv
Xpv
Yes
amagic_generation
ampergv
an
archpat_auto
argvgv
argvoutgv
av_fetch_sv
basetime
beginav
bodytarget
bostr
bufend
bufptr
cddir
chopset
collation_ix
collation_name
collation_standard
collxfrm_base
collxfrm_mult
colors
colorset
compcv
compiling
comppad
comppad_name
comppad_name_fill
comppad_name_floor
cop_seqmax
copline
cryptseen
cshlen
cshname
curcop
curcopdb
curinterp
curpad
curpm
curstack
curstackinfo
curstash
curstname
curthr
dbargs
debdelim
debname
debstash
debug
defgv
defoutgv
defstash
delaymagic
diehook
dirty
dlevel
dlmax
do_undump
doextract
doswitches
dowarn
dumplvl
e_script
egid
endav
envgv
errgv
error_count
euid
eval_cond
eval_mutex
eval_owner
eval_root
eval_start
evalseq
exitlist
exitlistlen
expect
extralen
fdpid
filemode
firstgv
forkprocess
formfeed
formtarget
generation
gensym
gid
globalstash
he_root
hexdigit
hintgv
hints
hv_fetch_ent_mh
hv_fetch_sv
in_clean_all
in_clean_objs
in_eval
in_my
in_my_stash
incgv
initav
inplace
last_in_gv
last_lop
last_lop_op
last_proto
last_uni
lastfd
lastgotoprobe
lastscream
lastsize
lastspbase
laststatval
laststype
leftgv
lex_brackets
lex_brackstack
lex_casemods
lex_casestack
lex_defer
lex_dojoin
lex_expect
lex_fakebrack
lex_formbrack
lex_inpat
lex_inwhat
lex_op
lex_repl
lex_starts
lex_state
lex_stuff
lineary
linestart
linestr
localizing
localpatches
main_cv
main_root
main_start
mainstack
malloc_mutex
markstack
markstack_max
markstack_ptr
max_intro_pending
maxo
maxscream
maxsysfd
mess_sv
min_intro_pending
minus_F
minus_a
minus_c
minus_l
minus_n
minus_p
modcount
modglobal
multi_close
multi_end
multi_open
multi_start
multiline
mystrk
na
nexttoke
nexttype
nextval
nice_chunk
nice_chunk_size
ninterps
nomemok
nthreads
nthreads_cond
numeric_local
numeric_name
numeric_standard
ofmt
ofs
ofslen
oldbufptr
oldlastpm
oldname
oldoldbufptr
op
op_mask
op_seqmax
opsave
origalen
origargc
origargv
origenviron
origfilename
ors
orslen
osname
pad_reset_pending
padix
padix_floor
patchlevel
patleave
pending_ident
perl_destruct_level
perldb
pidstatus
preambleav
preambled
preprocess
profiledata
reg_eval_set
reg_flags
reg_start_tmp
reg_start_tmpl
regbol
regcc
regcode
regcomp_parse
regcomp_rx
regcompp
regdata
regdummy
regendp
regeol
regexecp
regflags
regindent
reginput
reginterp_cnt
reglastparen
regnarrate
regnaughty
regnpar
regprecomp
regprev
regprogram
regsawback
regseen
regsize
regstartp
regtill
regxend
replgv
restartop
retstack
retstack_ix
retstack_max
rightgv
rs
rsfp
rsfp_filters
runops
savestack
savestack_ix
savestack_max
sawampersand
sawstudy
sawvec
scopestack
scopestack_ix
scopestack_max
screamfirst
screamnext
secondgv
seen_evals
seen_zerolen
sh_path
siggv
sighandlerp
sortcop
sortcxix
sortstash
specialsv_list
splitstr
stack_base
stack_max
stack_sp
start_env
statbuf
statcache
statgv
statname
statusvalue
statusvalue_vms
stdingv
strchop
strtab
sub_generation
sublex_info
subline
subname
sv_arenaroot
sv_count
sv_mutex
sv_no
sv_objcount
sv_root
sv_undef
sv_yes
svref_mutex
sys_intern
tainted
tainting
thisexpr
thr_key
threadnum
threads_mutex
threadsv_names
thrsv
timesbuf
tmps_floor
tmps_ix
tmps_max
tmps_stack
tokenbuf
top_env
toptarget
uid
unsafe
warnhook
xiv_arenaroot
xiv_root
xnv_root
xpv_root
xrv_root
piMem
piENV
piStdIO
piLIO
piDir
piSock
piProc
--- NEW FILE: Maintainers ---
#!/usr/bin/perl -w
#
# Maintainers - show information about maintainers
#
use strict;
use lib "Porting";
use Maintainers qw(show_results process_options);
show_results(process_options());
--- NEW FILE: fixCORE ---
#!/usr/bin/perl -w
use Data::Dumper;
my $targ = shift;
my $inc = join(' ',map("-I$_", at INC));
my $work = 1;
while ($work)
{
open(PIPE,"$^X -w $inc -M$targ -e '' 2>&1 |") || die "Cannot open pipe to child:$!";
my %fix;
while (<PIPE>)
{
if (/^Ambiguous call resolved as CORE::(\w+)\(\), qualify as such or use \& at (\S+) line (\d+)/
&& -f $2 )
{
my ($var,$file,$line) = ($1,$2,$3);
$fix{$file} = [] unless exists $fix{$file};
push(@{$fix{$file}},[$line => $var]) unless ($var =~ /^PL_/ || $file =~ /\.h$/);
}
print;
}
close(PIPE);
# warn "Make retured $?\n";
# last unless $?;
my $changed = 0;
foreach my $file (keys %fix)
{
my @ar = sort( { $a->[0] <=> $b->[0] } @{delete $fix{$file}});
my @miss;
my $fixed = 0;
@ARGV = ($file);
$. = 0;
local $^I = '.sav';
while (<>)
{
while (@ar && $. == $ar[0][0])
{
my ($line,$var) = @{shift(@ar)};
if (s/(?<!CORE::)\b$var\b(?=\s*\()/CORE::$var/)
{
warn "$file:$line: FIX $var\n";
$fixed++;
$changed++;
}
else
{
push(@miss,[$line,$var,$_]);
}
}
print;
}
unless ($fixed)
{
rename("$file$^I",$file);
if (@miss)
{
while (@miss)
{
my ($line,$var,$txt) = @{shift(@miss)};
warn "$file:$line:$var | $txt";
}
}
}
}
last unless $changed;
}
--- NEW FILE: findrfuncs ---
#!/usr/bin/perl -ws
#
# findrfuncs: find reentrant variants of functions used in an executable.
#
# Requires a functional "nm -u". Searches headers in /usr/include
# to find available *_r functions and looks for non-reentrant
# variants used in the supplied executable.
#
# Requires debug info in the shared libraries/executables.
#
# Gurusamy Sarathy
# gsar at ActiveState.com
#
# Hacked to automatically find the executable and shared objects.
# --jhi
use strict;
use File::Find;
my @EXES;
my $NMU = 'nm -u';
my @INCDIRS = qw(/usr/include);
my $SO = 'so';
my $EXE = '';
if (open(CONFIG, "config.sh")) {
local $/;
my $CONFIG = <CONFIG>;
$SO = $1 if $CONFIG =~ /^so='(\w+)'/m;
$EXE = $1 if $CONFIG =~ /^_exe='\.(\w+)'/m;
close(CONFIG);
}
push @EXES, "perl$EXE";
find(sub {push @EXES, $File::Find::name if /\.$SO$/}, '.' );
push @EXES, @ARGV;
if ($^O eq 'dec_osf') {
$NMU = 'nm -Bu';
} elsif ($^O eq 'irix') {
$NMU = 'nm -pu';
}
my %rfuncs;
my @syms;
find(sub {
return unless -f $File::Find::name;
local *F;
open F, "<$File::Find::name"
or die "Can't open $File::Find::name: $!";
my $line;
while (defined ($line = <F>)) {
if ($line =~ /\b(\w+_r)\b/) {
#warn "$1 => $File::Find::name\n";
$rfuncs{$1}->{$File::Find::name}++;
}
}
close F;
}, @INCDIRS);
# delete bogus symbols grepped out of comments and such
delete $rfuncs{setlocale_r} if $^O eq 'linux';
# delete obsolete (as promised by man pages) symbols
my $netdb_r_obsolete;
if ($^O eq 'hpux') {
delete $rfuncs{crypt_r};
delete $rfuncs{drand48_r};
delete $rfuncs{endgrent_r};
delete $rfuncs{endpwent_r};
delete $rfuncs{getgrent_r};
delete $rfuncs{getpwent_r};
delete $rfuncs{setlocale_r};
delete $rfuncs{srand48_r};
delete $rfuncs{strerror_r};
$netdb_r_obsolete = 1;
} elsif ($^O eq 'dec_osf') {
delete $rfuncs{crypt_r};
delete $rfuncs{strerror_r};
$netdb_r_obsolete = 1;
}
if ($netdb_r_obsolete) {
delete @rfuncs{qw(endhostent_r
endnetent_r
endprotoent_r
endservent_r
gethostbyaddr_r
gethostbyname_r
gethostent_r
getnetbyaddr_r
getnetbyname_r
getnetent_r
getprotobyname_r
getprotobynumber_r
getprotoent_r
getservbyname_r
getservbyport_r
getservent_r
sethostent_r
setnetent_r
setprotoent_r
setservent_r)};
}
my %syms;
for my $exe (@EXES) {
# warn "#--- $exe\n";
for my $sym (`$NMU $exe 2>/dev/null`) {
chomp $sym;
$sym =~ s/^\s+//;
$sym =~ s/^([0-9A-Fa-f]+\s+)?[Uu]\s+//;
$sym =~ s/\s+[Uu]\s+-$//;
next if $sym =~ /\s/;
$sym =~ s/\@.*\z//; # remove @@GLIBC_2.0 etc
# warn "#### $sym\n";
if (exists $rfuncs{"${sym}_r"} && ! $syms{"$sym:$exe"}++) {
push @syms, $sym;
}
}
if (@syms) {
print "\nFollowing symbols in $exe have reentrant versions:\n";
for my $sym (@syms) {
my @f = sort keys %{$rfuncs{$sym . '_r'}};
print "$sym => $sym" . "_r (@f)\n";
}
}
@syms = ();
}
--- NEW FILE: checkcase.pl ---
#!/usr/bin/perl
# Finds the files that have the same name, case insensitively,
# in the current directory and its subdirectories
use warnings;
use strict;
use File::Find;
my %files;
find(sub {
my $name = $File::Find::name;
# Assumes that the path separator is exactly one character.
$name =~ s/^\.\..//;
push @{$files{lc $name}}, $name;
}, '.');
my $failed;
foreach (values %files) {
if (@$_ > 1) {
print join(", ", @$_), "\n";
$failed++;
}
}
print "no similarly named files found\n" unless $failed;
--- NEW FILE: valgrindpp.pl ---
#!/usr/bin/perl
use IO::File ();
use File::Find qw(find);
use Text::Wrap qw(wrap);
use Getopt::Long qw(GetOptions);
use Pod::Usage qw(pod2usage);
use Cwd qw(cwd);
use File::Spec;
use strict;
my %opt = (
frames => 3,
lines => 0,
tests => 0,
top => 0,
verbose => 0,
);
GetOptions(\%opt, qw(
dir=s
frames=i
hide=s@
lines!
output-file=s
tests!
top=i
verbose+
)) or pod2usage(2);
# Setup the directory to process
if (exists $opt{dir}) {
$opt{dir} = File::Spec->canonpath($opt{dir});
}
else {
# Check if we're in 't'
$opt{dir} = cwd =~ /\/t$/ ? '..' : '.';
# Check if we're in the right directory
-d "$opt{dir}/$_" or die "$0: must be run from the perl source directory"
. " when --dir is not given\n"
for qw(t lib ext);
}
# Assemble regex for functions whose leaks should be hidden
# (no, a hash won't be significantly faster)
my $hidden = do { local $"='|'; $opt{hide} ? qr/^(?:@{$opt{hide}})$/o : '' };
# Setup our output file handle
# (do it early, as it may fail)
my $fh = \*STDOUT;
if (exists $opt{'output-file'}) {
$fh = new IO::File ">$opt{'output-file'}"
or die "$0: cannot open $opt{'output-file'} ($!)\n";
}
# These hashes will receive the error and leak summary data:
#
# %error = (
# error_name => {
# stack_frame => {
# test_script => occurences
# }
# }
# );
#
# %leak = (
# leak_type => {
# stack_frames => {
# test_script => occurences
# }
# } # stack frames are separated by '<'s
# );
my(%error, %leak);
# Collect summary data
find({wanted => \&filter, no_chdir => 1}, $opt{dir});
# Format the output nicely
$Text::Wrap::columns = 80;
$Text::Wrap::unexpand = 0;
# Write summary
summary($fh, \%error, \%leak);
exit 0;
sub summary {
my($fh, $error, $leak) = @_;
my(%ne, %nl, %top);
# Prepare the data
for my $e (keys %$error) {
for my $f (keys %{$error->{$e}}) {
my($func, $file, $line) = split /:/, $f;
my $nf = $opt{lines} ? "$func ($file:$line)" : "$func ($file)";
$ne{$e}{$nf}{count}++;
while (my($k,$v) = each %{$error->{$e}{$f}}) {
$ne{$e}{$nf}{tests}{$k} += $v;
$top{$k}{error}++;
}
}
}
for my $l (keys %$leak) {
for my $s (keys %{$leak->{$l}}) {
my $ns = join '<', map {
my($func, $file, $line) = split /:/;
/:/ ? $opt{lines}
? "$func ($file:$line)" : "$func ($file)"
: $_
} split /</, $s;
$nl{$l}{$ns}{count}++;
while (my($k,$v) = each %{$leak->{$l}{$s}}) {
$nl{$l}{$ns}{tests}{$k} += $v;
$top{$k}{leak}++;
}
}
}
# Print the Top N
if ($opt{top}) {
for my $what (qw(error leak)) {
my @t = sort { $top{$b}{$what} <=> $top{$a}{$what} or $a cmp $b }
grep $top{$_}{$what}, keys %top;
@t > $opt{top} and splice @t, $opt{top};
my $n = @t;
my $s = $n > 1 ? 's' : '';
my $prev = 0;
print $fh "Top $n test scripts for ${what}s:\n\n";
for my $i (1 .. $n) {
$n = $top{$t[$i-1]}{$what};
$s = $n > 1 ? 's' : '';
printf $fh " %3s %-40s %3d $what$s\n",
$n != $prev ? "$i." : '', $t[$i-1], $n;
$prev = $n;
}
print $fh "\n";
}
}
# Print the real summary
print $fh "MEMORY ACCESS ERRORS\n\n";
for my $e (sort keys %ne) {
print $fh qq("$e"\n);
for my $frame (sort keys %{$ne{$e}}) {
my $data = $ne{$e}{$frame};
my $count = $data->{count} > 1 ? " [$data->{count} paths]" : '';
print $fh ' 'x4, "$frame$count\n",
format_tests($data->{tests}), "\n";
}
print $fh "\n";
}
print $fh "\nMEMORY LEAKS\n\n";
for my $l (sort keys %nl) {
print $fh qq("$l"\n);
for my $frames (sort keys %{$nl{$l}}) {
my $data = $nl{$l}{$frames};
my @stack = split /</, $frames;
$data->{count} > 1 and $stack[-1] .= " [$data->{count} paths]";
print $fh join('', map { ' 'x4 . "$_:$stack[$_]\n" } 0 .. $#stack ),
format_tests($data->{tests}), "\n\n";
}
}
}
sub format_tests {
my $tests = shift;
my $indent = ' 'x8;
if ($opt{tests}) {
return wrap($indent, $indent, join ', ', sort keys %$tests);
}
else {
my $count = keys %$tests;
my $s = $count > 1 ? 's' : '';
return $indent . "triggered by $count test$s";
}
}
sub filter {
debug(2, "$File::Find::name\n");
# Only process '*.t.valgrind' files
/(.*)\.t\.valgrind$/ or return;
# Strip all unnecessary stuff from the test name
my $test = $1;
$test =~ s/^(?:(?:\Q$opt{dir}\E|[.t])\/)+//;
debug(1, "processing $test ($_)\n");
# Get all the valgrind output lines
my @l = do {
my $fh = new IO::File $_ or die "$0: cannot open $_ ($!)\n";
# Process outputs can interrupt each other, so sort by pid first
my %pid; local $_;
while (<$fh>) {
chomp;
s/^==(\d+)==\s?// and push @{$pid{$1}}, $_;
}
map @$_, values %pid;
};
# Setup some useful regexes
my $hexaddr = '0x[[:xdigit:]]+';
my $topframe = qr/^\s+at $hexaddr:\s+/;
my $address = qr/^\s+Address $hexaddr is \d+ bytes (?:before|inside|after) a block of size \d+/;
my $leak = qr/^\s*\d+ bytes in \d+ blocks are (still reachable|(?:definite|possib)ly lost)/;
for my $i (0 .. $#l) {
$l[$i] =~ $topframe or next; # Match on any topmost frame...
$l[$i-1] =~ $address and next; # ...but not if it's only address details
my $line = $l[$i-1]; # The error / leak description line
my $j = $i;
if ($line =~ $leak) {
debug(2, "LEAK: $line\n");
my $type = $1; # Type of leak (still reachable, ...)
my $inperl = 0; # Are we inside the perl source? (And how deep?)
my @stack; # Call stack
while ($l[$j++] =~ /^\s+(?:at|by) $hexaddr:\s+(\w+)\s+\((?:([^:]+):(\d+)|[^)]+)\)/o) {
my($func, $file, $lineno) = ($1, $2, $3);
# If the stack frame is inside perl => increment $inperl
# If we've already been inside perl, but are no longer => leave
defined $file && ++$inperl or $inperl && last;
# A function that should be hidden? => clear stack and leave
$hidden && $func =~ $hidden and @stack = (), last;
# Add stack frame if it's within our threshold
if ($inperl <= $opt{frames}) {
push @stack, $inperl ? "$func:$file:$lineno" : $func;
}
}
# If there's something on the stack and we've seen perl code,
# add this memory leak to the summary data
@stack and $inperl and $leak{$type}{join '<', @stack}{$test}++;
} else {
debug(1, "ERROR: $line\n");
# Simply find the topmost frame in the call stack within
# the perl source code
while ($l[$j++] =~ /^\s+(?:at|by) $hexaddr:\s+(?:(\w+)\s+\(([^:]+):(\d+)\))?/o) {
if (defined $1) {
$error{$line}{"$1:$2:$3"}{$test}++;
last;
}
}
}
}
}
sub debug {
my $level = shift;
$opt{verbose} >= $level and print STDERR @_;
}
__END__
=head1 NAME
valgrindpp.pl - A post processor for make test.valgrind
=head1 SYNOPSIS
valgrindpp.pl [B<--dir>=I<dir>] [B<--frames>=I<number>]
[B<--hide>=I<identifier>] [B<--lines>]
[B<--output-file>=I<file>] [B<--tests>]
[B<--top>=I<number>] [B<--verbose>]
=head1 DESCRIPTION
B<valgrindpp.pl> is a post processor for I<.valgrind> files
created during I<make test.valgrind>. It collects all these
files, extracts most of the information and produces a
significantly shorter summary of all detected memory access
errors and memory leaks.
=head1 OPTIONS
=over 4
=item B<--dir>=I<dir>
Recursively process I<.valgrind> files in I<dir>. If this
options is not given, B<valgrindpp.pl> must be run from
either the perl source or the I<t> directory and will process
all I<.valgrind> files within the distribution.
=item B<--frames>=I<number>
Number of stack frames within the perl source code to
consider when distinguishing between memory leak sources.
Increasing this value will give you a longer backtrace,
while decreasing the number will show you fewer sources
for memory leaks. The default is 3 frames.
=item B<--hide>=I<identifier>
Hide all memory leaks that have I<identifier> in their backtrace.
Useful if you want to hide leaks from functions that are known to
have lots of memory leaks. I<identifier> can also be a regular
expression, in which case all leaks with symbols matching the
expression are hidden. Can be given multiple times.
=item B<--lines>
Show line numbers for stack frames. This is useful for further
increasing the error/leak resolution, but makes it harder to
compare different reports using I<diff>.
=item B<--output-file>=I<file>
Redirect the output into I<file>. If this option is not
given, the output goes to I<stdout>.
=item B<--tests>
List all tests that trigger memory access errors or memory
leaks explicitly instead of only printing a count.
=item B<--top>=I<number>
List the top I<number> test scripts for memory access errors
and memory leaks. Set to C<0> for no top-I<n> statistics.
=item B<--verbose>
Increase verbosity level. Can be given multiple times.
=back
=head1 COPYRIGHT
Copyright 2003 by Marcus Holland-Moritz <mhx at cpan.org>.
This program is free software; you may redistribute it
and/or modify it under the same terms as Perl itself.
=cut
--- NEW FILE: Glossary ---
!!!!!!! DO NOT EDIT THIS FILE !!!!!!!
This file is built by metaconfig.
This file contains a description of all the shell variables whose value is
determined by the Configure script. Variables intended for use in C
programs (e.g. I_UNISTD) are already described in config_h.SH. [`configpm'
generates pod documentation for Config.pm from this file--please try to keep
the formatting regular.]
_a (Unix.U):
This variable defines the extension used for ordinary library files.
For unix, it is '.a'. The '.' is included. Other possible
values include '.lib'.
_exe (Unix.U):
This variable defines the extension used for executable files.
DJGPP, Cygwin and OS/2 use '.exe'. Stratus VOS uses '.pm'.
On operating systems which do not require a specific extension
[...4921 lines suppressed...]
libraries on this platform, for example CPU-specific libraries
(on multi-CPU platforms) may be listed here.
yacc (yacc.U):
This variable holds the name of the compiler compiler we
want to use in the Makefile. It can be yacc, byacc, or bison -y.
yaccflags (yacc.U):
This variable contains any additional yacc flags desired by the
user. It is up to the Makefile to use this.
zcat (Loc.U):
This variable is defined but not used by Configure.
The value is a plain '' and is not useful.
zip (Loc.U):
This variable is used internally by Configure to determine the
full pathname (if any) of the zip program. After Configure runs,
the value is reset to a plain "zip" and is not useful.
--- NEW FILE: p4d2p ---
#!/usr/bin/perl -wspi~
#
# reads a perforce style diff on stdin and outputs appropriate headers
# so the diff can be applied with the patch program
#
# Gurusamy Sarathy <gsar at activestate.com>
#
BEGIN {
$0 =~ s|.*/||;
if ($h or $help) {
print STDERR <<USAGE;
Usage: $0 [-v] [-h] files
-h print this help
-v output progress messages
Does inplace edit of diff files output by the perforce commands
"p4 describe", "p4 diff", and "p4 diff2". The result is suitable
for feeding to the "patch" program.
If no files are specified, reads from stdin and writes to stdout.
WARNING: It only handles context or unified diffs.
Example: p4 describe -du 123 | $0 > change-123.patch
USAGE
exit(0);
}
unless (@ARGV) { @ARGV = '-'; undef $^I; }
use vars qw($thisfile $time $file $fnum $v $h $help);
$thisfile = "";
$time = localtime(time);
}
my ($cur, $match);
$cur = m<^==== //depot/(.+?)\#\d+.* ====( \w+)?$> ... m<^(\@\@.+\@\@|\*+)$>;
$match = $1;
if ($ARGV ne $thisfile) {
warn "processing patchfile [$ARGV]\n" unless $ARGV eq '-';
$thisfile = $ARGV;
}
# while we are within range
if ($cur) {
# set the file name after first line
if ($cur == 1) {
$file = $match;
$fnum++;
}
# emit the diff header when we hit last line
elsif ($cur =~ /E0$/) {
my $f = $file;
# special hack for perl so we can always use "patch -p1"
$f =~ s<^.*?(perl.*?/)><$1>;
# unified diff
if ($match =~ /^\@/) {
warn "emitting udiff header\n" if $v;
$_ = "Index: $f\n--- $f.~1~\t$time\n+++ $f\t$time\n$_";
}
# context diff
elsif ($match =~ /^\*/) {
warn "emitting cdiff header\n" if $v;
$_ = "Index: $f\n*** $f.~1~\t$time\n--- $f\t$time\n$_";
}
}
# see if we hit another patch (i.e. previous patch was empty)
elsif (m<^==== //depot/(.+?)\#\d+.* ====( \w+)?$>) {
$file = $match = $1;
}
# suppress all other lines in the header
else {
$_ = "";
}
warn "file [$file] line [$cur] file# [$fnum]\n" if $v;
}
$_ .= "End of Patch.\n" if eof;
--- NEW FILE: thirdclean ---
local $/;
$_ = <ARGV>;
my @accv = /(^-+ \w+ -- \d+ --(?:.(?!^-))+)/msg;
my @leak = /(\d+ bytes? in \d+ leaks? .+? created at:(?:.(?!^[\d-]))+)/msg;
$leak[ 0] =~ s/.* were found:\n\n//m; # Snip off totals.
# Weed out the known access violations.
@accv = grep { ! /-- ru[hs] --.+setlocale.+Perl_init_i18nl10n/s } @accv;
@accv = grep { ! /-- [rw][ui]s --.+_doprnt_dis/s } @accv;
@accv = grep { ! /-- (?:fon|ris) --.+__strxfrm/s } @accv;
@accv = grep { ! /-- rus --.+__catgets/s } @accv;
@accv = grep { ! /-- rus --.+__execvp/s } @accv;
@accv = grep { ! /-- rus --.+tmpnam.+tmpfile/s } @accv;
@accv = grep { ! /-- rus --.+__gethostbyname/s } @accv;
@accv = grep { ! /-- ris --.+__actual_atof/s } @accv;
@accv = grep { ! /-- ris --.+__strftime/s } @accv;
# Weed out untraceable access violations.
@accv = grep { ! / ----- /s } @accv;
@accv = grep { ! /-- r[ui][hs] --.+proc_at_/s } @accv;
@accv = grep { ! /-- r[ui][hs] --.+pc = 0x/s } @accv;
# The following look like being caused by the intrinsic inlined
# string handling functions reading one or few bytes beyond the
# actual length.
@accv = grep { ! /-- rih --.+(?:memmove|strcpy).+moreswitches/s } @accv;
@accv = grep { ! /-- (?:rih|rus) --.+strcpy.+gv_fetchfile/s } @accv;
@accv = grep { ! /-- rih --.+strcmp.+doopen_pm/s } @accv;
@accv = grep { ! /-- rih --.+strcmp.+gv_fetchpv/s } @accv;
@accv = grep { ! /-- r[ui]h --.+strcmp.+gv_fetchmeth/s } @accv;
@accv = grep { ! /-- rih --.+memmove.+my_setenv/s } @accv;
@accv = grep { ! /-- rih --.+memmove.+catpvn_flags/s } @accv;
# yyparse.
@accv = grep { ! /Perl_yyparse/s } @accv;
# Weed out the known memory leaks.
@leak = grep { ! /setlocale.+Perl_init_i18nl10n/s } @leak;
@leak = grep { ! /setlocale.+set_numeric_standard/s } @leak;
@leak = grep { ! /_findiop.+fopen/s } @leak;
@leak = grep { ! /_findiop.+__fdopen/s } @leak;
@leak = grep { ! /__localtime/s } @leak;
@leak = grep { ! /__get_libc_context/s } @leak;
@leak = grep { ! /__sia_init/s } @leak;
# Weed out untraceable memory leaks.
@leak = grep { ! / ----- /s } @leak;
@leak = grep { ! /pc = 0x/s } @leak;
@leak = grep { ! /_pc_range_table/s } @leak;
@leak = grep { ! /_add_gp_range/s } @leak;
# yyparse.
@leak = grep { ! /Perl_yyparse/s } @leak;
# Output the cleaned up report.
# Access violations.
for (my $i = 0; $i < @accv; $i++) {
$_ = $accv[$i];
s/\d+/$i/;
print;
}
# Memory leaks.
my ($leakb, $leakn, $leaks);
for (my $i = 0; $i < @leak; $i++) {
$_ = $leak[$i];
print $_, "\n";
/^(\d+) bytes? in (\d+) leak/;
$leakb += $1;
$leakn += $2;
$leaks += $1 if /including (\d+) super/;
}
print "Bytes $leakb Leaks $leakn Super $leaks\n" if $leakb;
--- NEW FILE: Contract ---
Contributed Modules in Perl Core
A Social Contract about Artistic Control
What follows is a statement about artistic control, defined as the ability
of authors of packages to guide the future of their code and maintain
control over their work. It is a recognition that authors should have
control over their work, and that it is a responsibility of the rest of
the Perl community to ensure that they retain this control. It is an
attempt to document the standards to which we, as Perl developers, intend
to hold ourselves. It is an attempt to write down rough guidelines about
the respect we owe each other as Perl developers.
This statement is not a legal contract. This statement is not a legal
document in any way, shape, or form. Perl is distributed under the GNU
Public License and under the Artistic License; those are the precise legal
terms. This statement isn't about the law or licenses. It's about
community, mutual respect, trust, and good-faith cooperation.
We recognize that the Perl core, defined as the software distributed with
the heart of Perl itself, is a joint project on the part of all of us.
>From time to time, a script, module, or set of modules (hereafter referred
to simply as a "module") will prove so widely useful and/or so integral to
the correct functioning of Perl itself that it should be distributed with
Perl core. This should never be done without the author's explicit
consent, and a clear recognition on all parts that this means the module
is being distributed under the same terms as Perl itself. A module author
should realize that inclusion of a module into the Perl core will
necessarily mean some loss of control over it, since changes may
occasionally have to be made on short notice or for consistency with the
rest of Perl.
Once a module has been included in the Perl core, however, everyone
involved in maintaining Perl should be aware that the module is still the
property of the original author unless the original author explicitly
gives up their ownership of it. In particular:
1) The version of the module in the core should still be considered the
work of the original author. All patches, bug reports, and so forth
should be fed back to them. Their development directions should be
respected whenever possible.
2) Patches may be applied by the pumpkin holder without the explicit
cooperation of the module author if and only if they are very minor,
time-critical in some fashion (such as urgent security fixes), or if
the module author cannot be reached. Those patches must still be
given back to the author when possible, and if the author decides on
an alternate fix in their version, that fix should be strongly
preferred unless there is a serious problem with it. Any changes not
endorsed by the author should be marked as such, and the contributor
of the change acknowledged.
3) The version of the module distributed with Perl should, whenever
possible, be the latest version of the module as distributed by the
author (the latest non-beta version in the case of public Perl
releases), although the pumpkin holder may hold off on upgrading the
version of the module distributed with Perl to the latest version
until the latest version has had sufficient testing.
In other words, the author of a module should be considered to have final
say on modifications to their module whenever possible (bearing in mind
that it's expected that everyone involved will work together and arrive at
reasonable compromises when there are disagreements).
As a last resort, however:
4) If the author's vision of the future of their module is sufficiently
different from the vision of the pumpkin holder and perl5-porters as a
whole so as to cause serious problems for Perl, the pumpkin holder may
choose to formally fork the version of the module in the core from the
one maintained by the author. This should not be done lightly and
should *always* if at all possible be done only after direct input
from Larry. If this is done, it must then be made explicit in the
module as distributed with Perl core that it is a forked version and
that while it is based on the original author's work, it is no longer
maintained by them. This must be noted in both the documentation and
in the comments in the source of the module.
Again, this should be a last resort only. Ideally, this should never
happen, and every possible effort at cooperation and compromise should be
made before doing this. If it does prove necessary to fork a module for
the overall health of Perl, proper credit must be given to the original
author in perpetuity and the decision should be constantly re-evaluated to
see if a remerging of the two branches is possible down the road.
In all dealings with contributed modules, everyone maintaining Perl should
keep in mind that the code belongs to the original author, that they may
not be on perl5-porters at any given time, and that a patch is not
official unless it has been integrated into the author's copy of the
module. To aid with this, and with points #1, #2, and #3 above, contact
information for the authors of all contributed modules should be kept with
the Perl distribution.
Finally, the Perl community as a whole recognizes that respect for
ownership of code, respect for artistic control, proper credit, and active
effort to prevent unintentional code skew or communication gaps is vital
to the health of the community and Perl itself. Members of a community
should not normally have to resort to rules and laws to deal with each
other, and this document, although it contains rules so as to be clear, is
about an attitude and general approach. The first step in any dispute
should be open communication, respect for opposing views, and an attempt
at a compromise. In nearly every circumstance nothing more will be
necessary, and certainly no more drastic measure should be used until
every avenue of communication and discussion has failed.
--
Version 1.2. By Russ Allbery (rra at stanford.edu) and the perl5-porters.
--- NEW FILE: config_H ---
/*
* This file was produced by running the config_h.SH script, which
* gets its values from config.sh, which is generally produced by
* running Configure.
*
* Feel free to modify any of this as the need arises. Note, however,
* that running config_h.SH again will wipe out any changes you've made.
* For a more permanent change edit config.sh and rerun config_h.SH.
*
* $Id: config_H,v 1.2 2006-12-04 16:59:01 dslinux_cayenne Exp $
*/
/*
* Package name : perl5
* Source directory : .
* Configuration time: Fri Jul 16 20:59:18 BST 2004
* Configured by : yourname
* Target system : linux bagpuss.unfortu.net 2.4.19-rmk4 #3 fri oct 25 21:57:55 bst 2002 armv4l unknown
*/
[...4260 lines suppressed...]
/* Uid_t_sign:
* This symbol holds the signedess of a Uid_t.
* 1 for unsigned, -1 for signed.
*/
#define Uid_t_sign 1 /* UID sign */
/* Uid_t_size:
* This symbol holds the size of a Uid_t in bytes.
*/
#define Uid_t_size 4 /* UID size */
/* Uid_t:
* This symbol holds the type used to declare user ids in the kernel.
* It can be int, ushort, uid_t, etc... It may be necessary to include
* <sys/types.h> to get any typedef'ed information.
*/
#define Uid_t uid_t /* UID type */
#endif
--- NEW FILE: checkcfgvar.pl ---
#!/usr/bin/perl -w
#
# Check that the various config.sh-clones have (at least) all the
# same symbols as the top-level config_h.SH so that the (potentially)
# needed symbols are not lagging after how Configure thinks the world
# is laid out.
#
# VMS is not handled here, due to their own rather elaborate DCL scripting.
#
use strict;
my $MASTER_CFG = "config_h.SH";
my %MASTER_CFG;
my @CFG = (
# This list contains both 5.8.x and 5.9.x files,
# we check from MANIFEST whether they are expected to be present.
"Cross/config.sh-arm-linux",
"epoc/config.sh",
"NetWare/config.wc",
"symbian/config.sh",
"uconfig.sh",
"plan9/config_sh.sample",
"vos/config.alpha.def",
"vos/config.ga.def",
"win32/config.bc",
"win32/config.gc",
"win32/config.vc",
"win32/config.vc64",
"wince/config.ce",
);
sub read_file {
my ($fn, $sub) = @_;
if (open(my $fh, $fn)) {
local $_;
while (<$fh>) {
&$sub;
}
} else {
die "$0: Failed to open '$fn' for reading: $!\n";
}
}
sub config_h_SH_reader {
my $cfg = shift;
return sub {
return if 1../^echo \"Extracting \$CONFIG_H/;
while (/[^\\]\$(\w+)/g) {
my $v = $1;
next if $v =~ /^(CONFIG_H|CONFIG_SH)$/;
$cfg->{$v}++;
}
}
}
read_file($MASTER_CFG,
config_h_SH_reader(\%MASTER_CFG));
my %MANIFEST;
read_file("MANIFEST",
sub {
$MANIFEST{$1}++ if /^(.+?)\t/;
});
my @MASTER_CFG = sort keys %MASTER_CFG;
sub check_cfg {
my ($fn, $cfg) = @_;
for my $v (@MASTER_CFG) {
print "$fn: missing '$v'\n" unless exists $cfg->{$v};
}
}
for my $cfg (@CFG) {
unless (exists $MANIFEST{$cfg}) {
print "[skipping not-expected '$cfg']\n";
next;
}
my %cfg;
read_file($cfg,
sub {
return if /^\#/ || /^\s*$/;
# foo='bar'
# foo=bar
# $foo='bar' # VOS 5.8.x specialty
# $foo=bar # VOS 5.8.x specialty
if (/^\$?(\w+)='(.*)'$/) {
$cfg{$1}++;
}
elsif (/^\$?(\w+)=(.*)$/) {
$cfg{$1}++;
} else {
warn "$cfg:$.:$_";
}
});
check_cfg($cfg, \%cfg);
}
--- NEW FILE: sort_perldiag.pl ---
#!/usr/bin/perl -w
use strict;
no locale;
my %items;
my $item_key;
$/ = '';
while (<>) {
if (/^=item\s+(.+)/) {
# new item
$item_key = get_item_key($1);
$items{$item_key} .= $_;
} elsif (/^=back\b/) {
# no more items in this group
foreach my $item_key (sort keys %items) {
print $items{$item_key};
}
$item_key = undef;
%items = ();
print;
} elsif (defined $item_key) {
# part of the current item
$items{$item_key} .= $_;
} else {
# not part of an item
print;
}
}
if (keys %items) {
warn "Missing =back after final =item.\n";
foreach my $item_key (sort keys %items) {
print $items{$item_key};
}
}
# get the sortable key for an item
sub get_item_key {
my($item) = @_;
# remove POD formatting
$item =~ s/[A-Z]<(.*?)>/$1/g;
# remove printf-style escapes
# note: be careful not to remove things like %hash
$item =~ s/%(?:[scg]|lx|#o)//g;
# remove all non-letter characters
$item =~ tr/A-Za-z//cd;
return lc $item;
}
__END__
=pod
=head1 NAME
sort_perldiag.pl - Sort warning and error messages in perldiag.pod
=head1 SYNOPSIS
B<sort_perldiag.pl> I<file>
=head1 DESCRIPTION
B<sort_perldiag.pl> is a script for sorting the warning and error
messages in F<perldiag.pod>. POD formatting, printf-style escapes,
non-letter characters, and case are ignored, as explained in L<perldiag>.
=cut
--- NEW FILE: testall.atom ---
#!/bin/sh
#
# testall.atom
#
# This script creates all.Counts file that can be fed to prof(1)
# to produce various basic block counting profiles.
#
# This script needs to be run at the top level of the Perl build
# directory after the "make all" and "make test" targets have been run.
#
# You will also need to have perl.pixie built,
# which means that you will also have Configured with -Doptimize=-g.
#
# After the script has been run (this will take several minutes)
# you will have a file called all.Counts, which contains the cumulative
# basic block counting results over the whole Perl test suite.
# You can produce various reports using prof(1);
#
# prof -pixie -all -L. perl all.Counts
# prof -pixie -heavy -all -L. perl all.Counts
# prof -pixie -invocations -all -L. perl all.Counts
# prof -pixie -lines -all -L. perl all.Counts
# prof -pixie -testcoverage -all -L. perl all.Counts
# prof -pixie -zero -all -L. perl all.Counts
#
# io/openpid and op/fork core on me, I don't know why and haven't
# taken a look yet.
#
# jhi at iki.fi
#
if test ! -f /usr/bin/atom
then
echo "$0: no /usr/bin/atom"
exit 1
fi
if test ! -f perl; then echo "$0: no perl"; exit 1; fi
if test ! -f perl.pixie; then echo "$0: no perl.pixie; exit 1; fi
if test ! -f t/perl; then echo "$0: no t/perl; exit 1; fi
LD_LIBRARY_PATH=`pwd`
export LD_LIBRARY_PATH
cd t || exit 1
ln -sf ../perl.pixie .
if test $# = 0; then
the_t=`echo base/*.t comp/*.t cmd/*.t run/*.t io/*.t; echo op/*.t uni/*.t pod/*.t x2p/*.t; find ../ext ../lib -name '*.t' -print`
else
the_t=$@
fi
PERL_DESTRUCT_LEVEL=2
export PERL_DESTRUCT_LEVEL
PERL_CORE=1
export PERL_CORE
rm -f all.Counts
for t in $the_t
do
case "$t" in
ext/*|lib/*) t=../$t ;;
t/*) t=`echo $t|sed 's:^t/::'` ;;
esac
echo $t|sed 's:\.t$::'
sw=''
case "`head -1 $t|egrep -e '^#.* -.*T'`" in
*-*T*) sw="$sw -T" ;;
esac
case "`head -1 $t|egrep -e '^#.* -.*t'`" in
*-*t*) sw="$sw -t" ;;
esac
./perl.pixie -I../lib $sw $t > /dev/null
if cd ..
then
if test -f all.Counts
then
prof -pixie -merge new.Counts -L. -incobj libperl.so perl t/perl.Counts all.Counts
mv new.Counts all.Counts
else
mv t/perl.Counts all.Counts
fi
cd t
fi
done
exit 0
--- NEW FILE: Maintainers.pm ---
#
# Maintainers.pm - show information about maintainers
#
package Maintainers;
use strict;
use lib "Porting";
require "Maintainers.pl";
use vars qw(%Modules %Maintainers);
use vars qw(@ISA @EXPORT_OK);
@ISA = qw(Exporter);
@EXPORT_OK = qw(%Modules %Maintainers
get_module_files get_module_pat
show_results process_options);
require Exporter;
use File::Find;
use Getopt::Long;
my %MANIFEST;
if (open(MANIFEST, "MANIFEST")) {
while (<MANIFEST>) {
if (/^(\S+)\t+(.+)$/) {
$MANIFEST{$1}++;
}
}
close MANIFEST;
} else {
die "$0: Failed to open MANIFEST for reading: $!\n";
}
sub get_module_pat {
my $m = shift;
split ' ', $Modules{$m}{FILES};
}
sub get_module_files {
my $m = shift;
sort { lc $a cmp lc $b }
map {
-f $_ ? # Files as-is.
$_ :
-d _ ? # Recurse into directories.
do {
my @files;
find(
sub {
push @files, $File::Find::name
if -f $_ && exists $MANIFEST{$File::Find::name};
}, $_);
@files;
}
: glob($_) # The rest are globbable patterns.
} get_module_pat($m);
}
sub get_maintainer_modules {
my $m = shift;
sort { lc $a cmp lc $b }
grep { $Modules{$_}{MAINTAINER} eq $m }
keys %Modules;
}
sub usage {
print <<__EOF__;
$0: Usage: $0 [[--maintainer M --module M --files --check]|file ...]
--maintainer M list all maintainers matching M
--module M list all modules matching M
--files list all files
--check check consistency of Maintainers.pl
--opened list all modules of files opened by perforce
Matching is case-ignoring regexp, author matching is both by
the short id and by the full name and email. A "module" may
not be just a module, it may be a file or files or a subdirectory.
The options may be abbreviated to their unique prefixes
__EOF__
exit(0);
}
my $Maintainer;
my $Module;
my $Files;
my $Check;
my $Opened;
sub process_options {
usage()
unless
GetOptions(
'maintainer=s' => \$Maintainer,
'module=s' => \$Module,
'files' => \$Files,
'check' => \$Check,
'opened' => \$Opened,
);
my @Files;
if ($Opened) {
my @raw = `p4 opened`;
die if $?;
@Files = map {s!#.*!!s; s!^//depot/.*?/perl/!!; $_} @raw;
} else {
@Files = @ARGV;
}
usage() if @Files && ($Maintainer || $Module || $Files);
for my $mean ($Maintainer, $Module) {
warn "$0: Did you mean '$0 $mean'?\n"
if $mean && -e $mean && $mean ne '.' && !$Files;
}
warn "$0: Did you mean '$0 -mo $Maintainer'?\n"
if defined $Maintainer && exists $Modules{$Maintainer};
warn "$0: Did you mean '$0 -ma $Module'?\n"
if defined $Module && exists $Maintainers{$Module};
return ($Maintainer, $Module, $Files, @Files);
}
sub show_results {
my ($Maintainer, $Module, $Files, @Files) = @_;
if ($Maintainer) {
for my $m (sort keys %Maintainers) {
if ($m =~ /$Maintainer/io || $Maintainers{$m} =~ /$Maintainer/io) {
my @modules = get_maintainer_modules($m);
if ($Module) {
@modules = grep { /$Module/io } @modules;
}
if ($Files) {
my @files;
for my $module (@modules) {
push @files, get_module_files($module);
}
printf "%-15s @files\n", $m;
} else {
if ($Module) {
printf "%-15s @modules\n", $m;
} else {
printf "%-15s $Maintainers{$m}\n", $m;
}
}
}
}
} elsif ($Module) {
for my $m (sort { lc $a cmp lc $b } keys %Modules) {
if ($m =~ /$Module/io) {
if ($Files) {
my @files = get_module_files($m);
printf "%-15s @files\n", $m;
} else {
printf "%-15s $Modules{$m}{MAINTAINER}\n", $m;
}
}
}
} elsif (@Files) {
my %ModuleByFile;
for (@Files) { s:^\./:: }
@ModuleByFile{@Files} = ();
# First try fast match.
my %ModuleByPat;
for my $module (keys %Modules) {
for my $pat (get_module_pat($module)) {
$ModuleByPat{$pat} = $module;
}
}
# Expand any globs.
my %ExpModuleByPat;
for my $pat (keys %ModuleByPat) {
if (-e $pat) {
$ExpModuleByPat{$pat} = $ModuleByPat{$pat};
} else {
for my $exp (glob($pat)) {
$ExpModuleByPat{$exp} = $ModuleByPat{$pat};
}
}
}
%ModuleByPat = %ExpModuleByPat;
for my $file (@Files) {
$ModuleByFile{$file} = $ModuleByPat{$file}
if exists $ModuleByPat{$file};
}
# If still unresolved files...
if (my @ToDo = grep { !defined $ModuleByFile{$_} } keys %ModuleByFile) {
# Cannot match what isn't there.
@ToDo = grep { -e $_ } @ToDo;
if (@ToDo) {
# Try prefix matching.
# Remove trailing slashes.
for (@ToDo) { s|/$|| }
my %ToDo;
@ToDo{@ToDo} = ();
for my $pat (keys %ModuleByPat) {
last unless keys %ToDo;
if (-d $pat) {
my @Done;
for my $file (keys %ToDo) {
if ($file =~ m|^$pat|i) {
$ModuleByFile{$file} = $ModuleByPat{$pat};
push @Done, $file;
}
}
delete @ToDo{@Done};
}
}
}
}
for my $file (@Files) {
if (defined $ModuleByFile{$file}) {
my $module = $ModuleByFile{$file};
my $maintainer = $Modules{$ModuleByFile{$file}}{MAINTAINER};
printf "%-15s $module $maintainer $Maintainers{$maintainer}\n", $file;
} else {
printf "%-15s ?\n", $file;
}
}
}
elsif ($Check) {
duplicated_maintainers();
}
else {
usage();
}
}
sub duplicated_maintainers {
my %files;
for my $k (keys %Modules) {
for my $f (get_module_files($k)) {
++$files{$f};
}
}
for my $f (keys %files) {
if ($files{$f} > 1) {
warn "File $f appears $files{$f} times in Maintainers.pl\n";
}
}
}
1;
--- NEW FILE: Maintainers.pl ---
# A simple listing of core files that have specific maintainers,
# or at least someone that can be called an "interested party".
# Also, a "module" does not necessarily mean a CPAN module, it
# might mean a file or files or a subdirectory.
# Most (but not all) of the modules have dual lives in the core
# and in CPAN. Those that have a CPAN existence, have the CPAN
# attribute set to true.
package Maintainers;
%Maintainers =
(
'abergman' => 'Arthur Bergman <abergman at cpan.org>',
'ams' => 'Abhijit Menon-Sen <ams at cpan.org>',
'andk' => 'Andreas J. Koenig <andk at cpan.org>',
'arandal' => 'Allison Randal <allison at perl.org>',
'autrijus' => 'Audrey Tang <autrijus at cpan.org>',
'bbb' => 'Rob Brown <bbb at cpan.org>',
'craig' => 'Craig Berry <craigberry at mac.com>',
'dankogai' => 'Dan Kogai <dankogai at cpan.org>',
'dconway' => 'Damian Conway <dconway at cpan.org>',
'dmanura' => 'David Manura <dmanura at cpan.org>',
'drolsky' => 'Dave Rolsky <drolsky at cpan.org>',
'elizabeth' => 'Elizabeth Mattijsen <liz at dijkmat.nl>',
'gbarr' => 'Graham Barr <gbarr at cpan.org>',
'gaas' => 'Gisle Aas <gaas at cpan.org>',
'gsar' => 'Gurusamy Sarathy <gsar at activestate.com>',
'ilyam' => 'Ilya Martynov <ilyam at cpan.org>',
'ilyaz' => 'Ilya Zakharevich <ilyaz at cpan.org>',
'jand' => 'Jan Dubois <jand at activestate.com>',
'jhi' => 'Jarkko Hietaniemi <jhi at cpan.org>',
'jstowe' => 'Jonathan Stowe <jstowe at cpan.org>',
'jv' => 'Johan Vromans <jv at cpan.org>',
'kane' => 'Jos Boumans <kane at cpan.org>',
'kwilliams' => 'Ken Williams <kwilliams at cpan.org>',
'laun' => 'Wolfgang Laun <Wolfgang.Laun at alcatel.at>',
'lstein' => 'Lincoln D. Stein <lds at cpan.org>',
'marekr' => 'Marek Rouchal <marekr at cpan.org>',
'mhx' => 'Marcus Holland-Moritz <mhx at cpan.org>',
'mjd' => 'Mark-Jason Dominus <mjd at plover.com>',
'muir' => 'David Muir Sharnoff <muir at cpan.org>',
'neilb' => 'Neil Bowers <neilb at cpan.org>',
'ni-s' => 'Nick Ing-Simmons <nick at ing-simmons.net>',
'p5p' => 'perl5-porters <perl5-porters at perl.org>',
'perlfaq' => 'perlfaq-workers <perlfaq-workers at perl.org>',
'petdance' => 'Andy Lester <andy at petdance.com>',
'pmqs' => 'Paul Marquess <pmqs at cpan.org>',
'pvhp' => 'Peter Prymmer <pvhp at best.com>',
'rclamp' => 'Richard Clamp <rclamp at cpan.org>',
'rgarcia' => 'Rafael Garcia-Suarez <rgarcia at cpan.org>',
'rmbarker' => 'Robin Barker <rmbarker at cpan.org>',
'rra' => 'Russ Allbery <rra at cpan.org>',
'sadahiro' => 'SADAHIRO Tomoyuki <SADAHIRO at cpan.org>',
'salva' => 'Salvador Fandiño García <salva at cpan.org>',
'saper' => 'Sébastien Aperghis-Tramoni <saper at cpan.org>',
'sburke' => 'Sean Burke <sburke at cpan.org>',
'mschwern' => 'Michael Schwern <mschwern at cpan.org>',
'smccam' => 'Stephen McCamant <smccam at cpan.org>',
'tels' => 'perl_dummy a-t bloodgate.com',
'tomhughes' => 'Tom Hughes <tomhughes at cpan.org>',
'tjenness' => 'Tim Jenness <tjenness at cpan.org>'
);
# The FILES is either filenames, or glob patterns, or directory
# names to be recursed down. The CPAN can be either 1 (get the
# latest one from CPAN) or 0 (there is no valid CPAN release).
%Modules = (
'Archive::Tar' =>
{
'MAINTAINER' => 'kane',
'FILES' => q[lib/Archive/Tar.pm lib/Archive/Tar],
'CPAN' => 1,
},
'assertions' =>
{
'MAINTAINER' => 'salva',
'FILES' => q[lib/assertions.pm lib/assertions t/comp/assertions.t t/comp/asstcompat.t],
'CPAN' => 1,
},
'Attribute::Handlers' =>
{
'MAINTAINER' => 'abergman',
'FILES' => q[lib/Attribute/Handlers.pm
lib/Attribute/Handlers],
'CPAN' => 1,
},
'B::Concise' =>
{
'MAINTAINER' => 'smccam',
'FILES' => q[ext/B/B/Concise.pm ext/B/t/concise.t],
'CPAN' => 0,
},
'B::Deparse' =>
{
'MAINTAINER' => 'smccam',
'FILES' => q[ext/B/B/Deparse.pm ext/B/t/deparse.t],
'CPAN' => 0,
},
'base' =>
{
'MAINTAINER' => 'mschwern',
'FILES' => q[lib/base.pm lib/fields.pm lib/base],
'CPAN' => 1,
},
'bignum' =>
{
'MAINTAINER' => 'tels',
'FILES' => q[lib/big{int,num,rat}.pm lib/bignum],
'CPAN' => 1,
},
'Compress::Zlib' =>
{
'MAINTAINER' => 'pmqs',
'FILES' => q[ext/Compress/Zlib t/lib/ZlibTestUtils.pm],
'CPAN' => 1,
},
'CGI' =>
{
'MAINTAINER' => 'lstein',
'FILES' => q[lib/CGI.pm lib/CGI],
'CPAN' => 1,
},
'Class::ISA' =>
{
'MAINTAINER' => 'sburke',
'FILES' => q[lib/Class/ISA.pm lib/Class/ISA],
'CPAN' => 1,
},
'CPAN' =>
{
'MAINTAINER' => 'andk',
'FILES' => q[lib/CPAN.pm lib/CPAN],
'CPAN' => 1,
},
'Cwd' =>
{
'MAINTAINER' => 'kwilliams',
'FILES' => q[ext/Cwd lib/Cwd.pm],
'CPAN' => 1,
},
'Data::Dumper' =>
{
'MAINTAINER' => 'ilyam', # Not gsar.
'FILES' => q[ext/Data/Dumper],
'CPAN' => 1,
},
'DB::File' =>
{
'MAINTAINER' => 'pmqs',
'FILES' => q[ext/DB_File],
'CPAN' => 1,
},
'Devel::PPPort' =>
{
'MAINTAINER' => 'mhx',
'FILES' => q[ext/Devel/PPPort],
'CPAN' => 1,
},
'Digest' =>
{
'MAINTAINER' => 'gaas',
'FILES' => q[lib/Digest.pm lib/Digest],
'CPAN' => 1,
},
'Digest::MD5' =>
{
'MAINTAINER' => 'gaas',
'FILES' => q[ext/Digest/MD5],
'CPAN' => 1,
},
'Encode' =>
{
'MAINTAINER' => 'dankogai',
'FILES' => q[ext/Encode],
'CPAN' => 1,
},
'encoding::warnings' =>
{
'MAINTAINER' => 'autrijus',
'FILES' => q[lib/encoding/warnings.pm lib/encoding/warnings],
'CPAN' => 1,
},
'Errno' =>
{
'MAINTAINER' => 'p5p', # Not gbarr.
'FILES' => q[ext/Errno],
'CPAN' => 0,
},
'ExtUtils::CBuilder' =>
{
'MAINTAINER' => 'kwilliams',
'FILES' => q[lib/ExtUtils/CBuilder.pm lib/ExtUtils/CBuilder],
'CPAN' => 1,
},
'ExtUtils::MakeMaker' =>
{
'MAINTAINER' => 'mschwern',
'FILES' => q[lib/ExtUtils/{Command,Install,Installed,Liblist,MakeMaker,Manifest,Mkbootstrap,Mksymlists,MM*,MY,Packlist,testlib}.pm lib/ExtUtils/{Command,Liblist,MakeMaker,MANIFEST.SKIP}
lib/ExtUtils/t t/lib/MakeMaker t/lib/TieIn.pm t/lib/TieOut.pm],
'CPAN' => 1,
},
'ExtUtils::ParseXS' =>
{
'MAINTAINER' => 'kwilliams',
'FILES' => q[lib/ExtUtils/ParseXS.pm lib/ExtUtils/ParseXS],
'CPAN' => 1,
},
'faq' =>
{
'MAINTAINER' => 'perlfaq',
'FILES' => q[pod/perlfaq*],
'CPAN' => 0,
},
'File::Spec' =>
{
'MAINTAINER' => 'kwilliams',
'FILES' => q[lib/File/Spec.pm lib/File/Spec],
'CPAN' => 1,
},
'File::Temp' =>
{
'MAINTAINER' => 'tjenness',
'FILES' => q[lib/File/Temp.pm lib/File/Temp],
'CPAN' => 1,
},
'Filter::Simple' =>
{
'MAINTAINER' => 'dconway',
'FILES' => q[lib/Filter/Simple.pm lib/Filter/Simple
t/lib/Filter/Simple],
'CPAN' => 1,
},
'Filter::Util::Call' =>
{
'MAINTAINER' => 'pmqs',
'FILES' => q[ext/Filter/Util/Call ext/Filter/t/call.t
t/lib/filter-util.pl],
'CPAN' => 1,
},
'Getopt::Long' =>
{
'MAINTAINER' => 'jv',
'FILES' => q[lib/Getopt/Long.pm lib/Getopt/Long],
'CPAN' => 1,
},
'I18N::LangTags' =>
{
'MAINTAINER' => 'sburke',
'FILES' => q[lib/I18N/LangTags.pm lib/I18N/LangTags],
'CPAN' => 1,
},
'if' =>
{
'MAINTAINER' => 'ilyaz',
'FILES' => q[lib/if.{pm,t}],
'CPAN' => 1,
},
'IO' =>
{
'MAINTAINER' => 'gbarr',
'FILES' => q[ext/IO],
'CPAN' => 1,
},
'IO::Zlib' =>
{
'MAINTAINER' => 'tomhughes',
'FILES' => q[lib/IO/Zlib.pm lib/IO/Zlib],
'CPAN' => 1,
},
'libnet' =>
{
'MAINTAINER' => 'gbarr',
'FILES' =>
q[lib/Net/{Cmd,Config,Domain,FTP,Netrc,NNTP,POP3,SMTP,Time}.pm lib/Net/ChangeLog.libnet lib/Net/FTP lib/Net/*.eg lib/Net/libnetFAQ.pod lib/Net/README.libnet lib/Net/t],
'CPAN' => 1,
},
'Scalar-List-Utils' =>
{
'MAINTAINER' => 'gbarr',
'FILES' => q[ext/List/Util],
'CPAN' => 1,
},
'Locale::Codes' =>
{
'MAINTAINER' => 'neilb',
'FILES' => q[lib/Locale/{Codes,Constants,Country,Currency,Language,Script}*],
'CPAN' => 1,
},
'Locale::Maketext' =>
{
'MAINTAINER' => 'petdance',
'FILES' => q[lib/Locale/Maketext.pm lib/Locale/Maketext],
'CPAN' => 1,
},
'Math::BigFloat' =>
{
'MAINTAINER' => 'tels',
'FILES' => q[lib/Math/BigFloat.pm lib/Math/BigFloat],
'CPAN' => 1,
},
'Math::BigInt' =>
{
'MAINTAINER' => 'tels',
'FILES' => q[lib/Math/BigInt.pm lib/Math/BigInt
t/lib/Math],
'CPAN' => 1,
},
'Math::BigInt::FastCalc' =>
{
'MAINTAINER' => 'tels',
'FILES' => q[ext/Math/BigInt/FastCalc],
'CPAN' => 1,
},
'Math::BigRat' =>
{
'MAINTAINER' => 'tels',
'FILES' => q[lib/Math/BigRat.pm lib/Math/BigRat],
'CPAN' => 1,
},
'Memoize' =>
{
'MAINTAINER' => 'mjd',
'FILES' => q[lib/Memoize.pm lib/Memoize],
'CPAN' => 1,
},
'MIME::Base64' =>
{
'MAINTAINER' => 'gaas',
'FILES' => q[ext/MIME/Base64],
'CPAN' => 1,
},
'Module::CoreList' =>
{
'MAINTAINER' => 'rclamp',
'FILES' => q[lib/Module/CoreList lib/Module/CoreList.pm],
'CPAN' => 1,
},
'Net::Ping' =>
{
'MAINTAINER' => 'bbb',
'FILES' => q[lib/Net/Ping.pm lib/Net/Ping],
'CPAN' => 1,
},
'NEXT' =>
{
'MAINTAINER' => 'dconway',
'FILES' => q[lib/NEXT.pm lib/NEXT],
'CPAN' => 1,
},
'perlebcdic' =>
{
'MAINTAINER' => 'pvhp',
'FILES' => q[pod/perlebcdic.pod],
'CPAN' => 0,
},
'PerlIO' =>
{
'MAINTAINER' => 'p5p',
'FILES' => q[ext/PerlIO],
'CPAN' => 0,
},
'perlio-doc' =>
{
'MAINTAINER' => 'ni-s',
'FILES' => q[pod/perlapio.pod
pod/perliol.pod
lib/PerlIO.pm],
'CPAN' => 0,
},
'PerlIO::via::QuotedPrint' =>
{
'MAINTAINER' => 'elizabeth',
'FILES' => q[lib/PerlIO/via/QuotedPrint.pm
lib/PerlIO/via/t/QuotedPrint.t],
'CPAN' => 1,
},
'perlreftut' =>
{
'MAINTAINER' => 'mjd',
'FILES' => q[pod/perlreftut.pod],
'CPAN' => 0,
},
'perlpacktut' =>
{
'MAINTAINER' => 'laun',
'FILES' => q[pod/perlpacktut.pod],
'CPAN' => 0,
},
'perlpodspec' =>
{
'MAINTAINER' => 'sburke',
'FILES' => q[pod/perlpodspec.pod],
'CPAN' => 0,
},
'perlthrtut' =>
{
'MAINTAINER' => 'elizabeth',
'FILES' => q[pod/perlthrtut.pod],
'CPAN' => 0,
},
'Pod::Escapes' =>
{
'MAINTAINER' => 'sburke',
'FILES' => q[lib/Pod/Escapes.pm lib/Pod/Escapes],
'CPAN' => 1,
},
'Pod::Parser' => {
'MAINTAINER' => 'marekr',
'FILES' => q[lib/Pod/{InputObjects,Parser,ParseUtils,Select,PlainText,Usage,Checker,Find}.pm pod/pod{select,2usage,checker}.PL t/pod/testcmp.pl t/pod/testp2pt.pl t/pod/testpchk.pl t/pod/emptycmd.* t/pod/find.t t/pod/for.* t/pod/headings.* t/pod/include.* t/pod/included.* t/pod/lref.* t/pod/multiline_items.* t/pod/nested_items.* t/pod/nested_seqs.* t/pod/oneline_cmds.* t/pod/poderrs.* t/pod/pod2usage.* t/pod/podselect.* t/pod/special_seqs.*],
'CPAN' => 1,
},
'Pod::Simple' =>
{
'MAINTAINER' => 'arandal',
'FILES' => q[lib/Pod/Simple.pm lib/Pod/Simple.pod lib/Pod/Simple],
'CPAN' => 1,
},
'Pod::LaTeX' =>
{
'MAINTAINER' => 'tjenness',
'FILES' => q[lib/Pod/LaTeX.pm lib/Pod/t/pod2latex.t],
'CPAN' => 1,
},
'podlators' =>
{
'MAINTAINER' => 'rra',
'FILES' => q[lib/Pod/{Man,ParseLink,Text,Text/{Color,Overstrike,Termcap}}.pm pod/pod2man.PL pod/pod2text.PL lib/Pod/t/{basic.*,{man,parselink,text*}.t}],
'CPAN' => 1,
},
'Pod::Perldoc' =>
{
'MAINTAINER' => 'sburke',
'FILES' => q[lib/Pod/Perldoc.pm lib/Pod/Perldoc],
'CPAN' => 1,
},
'Pod::Plainer' =>
{
'MAINTAINER' => 'rmbarker',
'FILES' => q[lib/Pod/Plainer.pm t/pod/plainer.t],
'CPAN' => 0,
},
'Safe' =>
{
'MAINTAINER' => 'rgarcia',
'FILES' => q[ext/Safe],
'CPAN' => 1,
},
'Storable' =>
{
'MAINTAINER' => 'ams',
'FILES' => q[ext/Storable],
'CPAN' => 1,
},
'Switch' =>
{
'MAINTAINER' => 'rgarcia',
'FILES' => q[lib/Switch.pm lib/Switch],
'CPAN' => 1,
},
'TabsWrap' =>
{
'MAINTAINER' => 'muir',
'FILES' =>
q[lib/Text/{Tabs,Wrap}.pm lib/Text/TabsWrap],
'CPAN' => 1,
},
'Text::Balanced' =>
{
'MAINTAINER' => 'dmanura',
'FILES' => q[lib/Text/Balanced.pm lib/Text/Balanced],
'CPAN' => 1,
},
'Term::ANSIColor' =>
{
'MAINTAINER' => 'rra',
'FILES' => q[lib/Term/ANSIColor.pm lib/Term/ANSIColor],
'CPAN' => 1,
},
'Test' =>
{
'MAINTAINER' => 'sburke',
'FILES' => q[lib/Test.pm lib/Test/t],
'CPAN' => 1,
},
'Test::Builder' =>
{
'MAINTAINER' => 'mschwern',
'FILES' => q[lib/Test/Builder.pm],
'CPAN' => 1,
},
'Test::Harness' =>
{
'MAINTAINER' => 'petdance',
'FILES' => q[lib/Test/Harness.pm lib/Test/Harness
t/lib/sample-tests],
'CPAN' => 1,
},
'Test::More' =>
{
'MAINTAINER' => 'mschwern',
'FILES' => q[lib/Test/More.pm],
'CPAN' => 1,
},
'Test::Simple' =>
{
'MAINTAINER' => 'mschwern',
'FILES' => q[lib/Test/Simple.pm lib/Test/Simple
t/lib/Test/Simple],
'CPAN' => 1,
},
'Term::Cap' =>
{
'MAINTAINER' => 'jstowe',
'FILES' => q[lib/Term/Cap.{pm,t}],
'CPAN' => 1,
},
'threads' =>
{
'MAINTAINER' => 'abergman',
'FILES' => q[ext/threads],
'CPAN' => 0,
},
'Tie::File' =>
{
'MAINTAINER' => 'mjd',
'FILES' => q[lib/Tie/File.pm lib/Tie/File],
'CPAN' => 1,
},
'Time::HiRes' =>
{
'MAINTAINER' => 'jhi',
'FILES' => q[ext/Time/HiRes],
'CPAN' => 1,
},
'Time::Local' =>
{
'MAINTAINER' => 'drolsky',
'FILES' => q[lib/Time/Local.{pm,t}],
'CPAN' => 1,
},
'Unicode::Collate' =>
{
'MAINTAINER' => 'sadahiro',
'FILES' => q[lib/Unicode/Collate.pm
lib/Unicode/Collate],
'CPAN' => 1,
},
'Unicode::Normalize' =>
{
'MAINTAINER' => 'sadahiro',
'FILES' => q[ext/Unicode/Normalize],
'CPAN' => 1,
},
'vms' =>
{
'MAINTAINER' => 'craig',
'FILES' => q[vms configure.com README.vms],
'CPAN' => 0,
},
'warnings' =>
{
'MAINTAINER' => 'pmqs',
'FILES' => q[warnings.pl lib/warnings.{pm,t}
lib/warnings t/lib/warnings],
'CPAN' => 0,
},
'win32' =>
{
'MAINTAINER' => 'jand',
'FILES' => q[win32 README.win32 t/win32],
'CPAN' => 0,
},
'XSLoader' =>
{
'MAINTAINER' => 'saper',
'FILES' => q[ext/DynaLoader/t/XSLoader.t ext/DynaLoader/XSLoader_pm.PL],
'CPAN' => 1,
},
's2p' =>
{
'MAINTAINER' => 'laun',
'FILES' => q[x2p/s2p.PL],
'CPAN' => 0,
},
);
1;
--- NEW FILE: config_h.pl ---
#!/usr/bin/perl
# This script reorders config_h.SH after metaconfig
# Changing metaconfig is too complicated
#
# Copyright (C) 2005-2005 by H.Merijn Brand (m)'05 [25-05-2005]
#
# You may distribute under the terms of either the GNU General Public
# License or the Artistic License, as specified in the README file.
use strict;
use warnings;
my ($cSH, $ch, @ch, %ch) = ("config_h.SH");
open $ch, "<$cSH" or die "Cannot open $cSH: $!\n";
{ local $/ = "\n\n";
@ch = <$ch>;
close $ch;
}
sub ch_index ()
{
%ch = ();
foreach my $ch (0 .. $#ch) {
while ($ch[$ch] =~ m{^/\* ([A-Z]\w+)}gm) {
$ch{$1} = $ch;
}
}
} # ch_index
my %dep = (
# This symbol must be defined BEFORE ...
BYTEORDER => [ qw( UVSIZE ) ],
LONGSIZE => [ qw( BYTEORDER ) ],
MULTIARCH => [ qw( BYTEORDER MEM_ALIGNBYTES ) ],
USE_CROSS_COMPILE => [ qw( BYTEORDER MEM_ALIGNBYTES ) ],
HAS_QUAD => [ qw( I64TYPE ) ],
HAS_GETGROUPS => [ qw( Groups_t ) ],
HAS_SETGROUPS => [ qw( Groups_t ) ],
);
my $changed;
do {
$changed = 0;
foreach my $sym (keys %dep) {
ch_index;
foreach my $dep (@{$dep{$sym}}) {
print STDERR "Check if $sym\t($ch{$sym}) precedes $dep\t($ch{$dep})\n";
$ch{$sym} < $ch{$dep} and next;
my $ch = splice @ch, $ch{$sym}, 1;
splice @ch, $ch{$dep}, 0, $ch;
$changed++;
ch_index;
}
}
} while ($changed);
open $ch, "> $cSH" or die "Cannot write $cSH: $!\n";
print $ch @ch;
close $ch;
--- NEW FILE: patching.pod ---
=head1 Name
patching.pod - Appropriate format for patches to the perl source tree
=head2 Where to get this document
The latest version of this document is available from
http://perrin.dimensional.com/perl/perlpatch.html
=head2 How to contribute to this document
You may mail corrections, additions, and suggestions to me
at dgris at dimensional.com but the preferred method would be
to follow the instructions set forth in this document and
submit a patch 8-).
=head1 Description
=head2 Why this document exists
As an open source project Perl relies on patches and contributions from
its users to continue functioning properly and to root out the inevitable
bugs. But, some users are unsure as to the I<right> way to prepare a patch
and end up submitting seriously malformed patches. This makes it very
difficult for the current maintainer to integrate said patches into their
distribution. This document sets out usage guidelines for patches in an
attempt to make everybody's life easier.
=head2 Common problems
The most common problems appear to be patches being mangled by certain
mailers (I won't name names, but most of these seem to be originating on
boxes running a certain popular commercial operating system). Other problems
include patches not rooted in the appropriate place in the directory structure,
and patches not produced using standard utilities (such as diff).
=head1 Proper Patch Guidelines
=head2 What to patch
Generally speaking you should patch the latest development release
of perl. The maintainers of the individual branches will see to it
that patches are picked up and applied as appropriate.
=head2 How to prepare your patch
=over 4
=item Creating your patch
First, back up the original files. This can't be stressed enough,
back everything up _first_.
Also, please create patches against a clean distribution of the perl source.
This ensures that everyone else can apply your patch without clobbering their
source tree.
=item diff
While individual tastes vary (and are not the point here) patches should
be created using either C<-u> or C<-c> arguments to diff. These produce,
respectively, unified diffs (where the changed line appears immediately next
to the original) and context diffs (where several lines surrounding the changes
are included). See the manpage for diff for more details.
When GNU diff is available, the pumpkins would prefer you use C<-u -p>
(--unified --show-c-function) as arguments for optimal control. The
examples below will only use -u.
The preferred method for creating a unified diff suitable for feeding
to the patch program is:
diff -u old-file new-file > patch-file
Note the order of files. See below for how to create a patch from
two directory trees.
If your patch is for wider consumption, it may be better to create it as
a context diff as some machines have broken patch utilities that choke on
unified diffs. A context diff is made using C<diff -c> rather than
C<diff -u>.
GNU diff has many desirable features not provided by most vendor-supplied
diffs. Some examples using GNU diff:
# generate a patch for a newly added file
% diff -u /dev/null new/file
# generate a patch to remove a file (patch > v2.4 will remove it cleanly)
% diff -u old/goner /dev/null
# get additions, deletions along with everything else, recursively
% diff -ruN olddir newdir
# ignore whitespace
% diff -bu a/file b/file
# show function name in every hunk (safer, more informative)
% diff -u -p old/file new/file
% diff -u -F '^[_a-zA-Z0-9]+ *(' old/file new/file
# show sub name in perl files and modules
% diff -u -F '^sub' old/file.pm new/file.pm
# show header in doc patches
% diff -u -F '^=head' old/file.pod new/file.pod
=item Derived Files
Many files in the distribution are derivative--avoid patching them.
Patch the originals instead. Most utilities (like perldoc) are in
this category, i.e. patch utils/perldoc.PL rather than utils/perldoc.
Similarly, don't create patches for files under $src_root/ext from
their copies found in $install_root/lib. If you are unsure about the
proper location of a file that may have gotten copied while building
the source distribution, consult the C<MANIFEST>.
=item Filenames
The most usual convention when submitting patches for a single file is to make
your changes to a copy of the file with the same name as the original. Rename
the original file in such a way that it is obvious what is being patched
($file.dist or $file.old seem to be popular).
If you are submitting patches that affect multiple files then you should
backup the entire directory tree (to $source_root.old/ for example). This
will allow C<diff -ruN old-dir new-dir> to create all the patches at once.
=item Directories
IMPORTANT: Patches should be generated from the source root directory, not
from the directory that the patched file resides in. This ensures that the
maintainer patches the proper file.
For larger patches that are dealing with multiple files or
directories, Johan Vromans has written a powerful utility: makepatch.
See the JV directory on CPAN for the current version. If you have this
program available, it is recommended to create a duplicate of the perl
directory tree against which you are intending to provide a patch and
let makepatch figure out all the changes you made to your copy of the
sources. As perl comes with a MANIFEST file, you need not delete
object files and other derivative files from the two directory trees,
makepatch is smart about them.
Say, you have created a directory perl-5.7.1 at 8685/ for the perl you
are taking as the base and a directory perl-5.7.1 at 8685-withfoo/ where
you have your changes, you would run makepatch as follows:
makepatch -oldman perl-5.7.1 at 8685/MANIFEST \
-newman perl-5.7.1 at 8685-withfoo/MANIFEST \
-diff "diff -u" \
perl-5.7.1 at 8685 perl-5.7.1 at 8685-withfoo
=item Try it yourself
Just to make sure your patch "works", be sure to apply it to the Perl
distribution, rebuild everything, and make sure the testsuite runs
without incident.
=back
=head2 What to include in your patch
=over 4
=item Description of problem
The first thing you should include is a description of the problem that
the patch corrects. If it is a code patch (rather than a documentation
patch) you should also include a small test case that illustrates the
bug.
=item Directions for application
You should include instructions on how to properly apply your patch.
These should include the files affected, any shell scripts or commands
that need to be run before or after application of the patch, and
the command line necessary for application.
=item If you have a code patch
If you are submitting a code patch there are several other things that
you need to do.
=over 4
=item Comments, Comments, Comments
Be sure to adequately comment your code. While commenting every
line is unnecessary, anything that takes advantage of side effects of
operators, that creates changes that will be felt outside of the
function being patched, or that others may find confusing should
be documented. If you are going to err, it is better to err on the
side of adding too many comments than too few.
=item Style
In general, please follow the particular style of the code you are patching.
In particular, follow these general guidelines for patching Perl sources:
8-wide tabs (no exceptions!)
4-wide indents for code, 2-wide indents for nested CPP #defines
try hard not to exceed 79-columns
ANSI C prototypes
uncuddled elses and "K&R" style for indenting control constructs
no C++ style (//) comments, most C compilers will choke on them
mark places that need to be revisited with XXX (and revisit often!)
opening brace lines up with "if" when conditional spans multiple
lines; should be at end-of-line otherwise
in function definitions, name starts in column 0 (return value is on
previous line)
single space after keywords that are followed by parens, no space
between function name and following paren
avoid assignments in conditionals, but if they're unavoidable, use
extra paren, e.g. "if (a && (b = c)) ..."
"return foo;" rather than "return(foo);"
"if (!foo) ..." rather than "if (foo == FALSE) ..." etc.
=item Testsuite
When submitting a patch you should make every effort to also include
an addition to perl's regression tests to properly exercise your
patch. Your testsuite additions should generally follow these
guidelines (courtesy of Gurusamy Sarathy <gsar at activestate.com>):
Know what you're testing. Read the docs, and the source.
Tend to fail, not succeed.
Interpret results strictly.
Use unrelated features (this will flush out bizarre interactions).
Use non-standard idioms (otherwise you are not testing TIMTOWTDI).
Avoid using hardcoded test numbers whenever possible (the
EXPECTED/GOT found in t/op/tie.t is much more maintainable,
and gives better failure reports).
Give meaningful error messages when a test fails.
Avoid using qx// and system() unless you are testing for them. If you
do use them, make sure that you cover _all_ perl platforms.
Unlink any temporary files you create.
Promote unforeseen warnings to errors with $SIG{__WARN__}.
Be sure to use the libraries and modules shipped with the version
being tested, not those that were already installed.
Add comments to the code explaining what you are testing for.
Make updating the '1..42' string unnecessary. Or make sure that
you update it.
Test _all_ behaviors of a given operator, library, or function:
- All optional arguments
- Return values in various contexts (boolean, scalar, list, lvalue)
- Use both global and lexical variables
- Don't forget the exceptional, pathological cases.
=back
=item Test your patch
Apply your patch to a clean distribution, compile, and run the
regression test suite (you did remember to add one for your
patch, didn't you).
=back
=head2 An example patch creation
This should work for most patches:
cp MANIFEST MANIFEST.old
emacs MANIFEST
(make changes)
cd ..
diff -c perl5.7.42/MANIFEST.old perl5.7.42/MANIFEST > mypatch
(testing the patch:)
mv perl5.7.42/MANIFEST perl5.7.42/MANIFEST.new
cp perl5.7.42/MANIFEST.old perl5.7.42/MANIFEST
patch -p < mypatch
(should succeed)
diff perl5.7.42/MANIFEST perl5.7.42/MANIFEST.new
(should produce no output)
=head2 Submitting your patch
=over 4
=item Mailers
Please, please, please (get the point? 8-) don't use a mailer that
word wraps your patch. This leaves the patch essentially worthless
to the maintainers.
Unfortunately many mailers word wrap the main text of messages, but
luckily you can usually send your patches as email attachments without
them getting "helpfully" word wrapped.
If you have no choice in mailers and no way to get your hands on
a better one, there is, of course, a Perl solution. Just do this:
perl -ne 'print pack("u*",$_)' patch > patch.uue
and post patch.uue with a note saying to unpack it using
perl -ne 'print unpack("u*",$_)' patch.uue > patch
=item Subject lines for patches
The subject line on your patch should read
[PATCH 5.x.x AREA] Description
where the x's are replaced by the appropriate version number.
The description should be a very brief but accurate summary of the
problem (don't forget this is an email header).
Examples:
[PATCH 5.6.4 DOC] fix minor typos
[PATCH 5.7.9 CORE] New warning for foo() when frobbing
[PATCH 5.7.16 CONFIG] Added support for fribnatz 1.5
The name of the file being patched makes for a poor subject line if
no other descriptive text accompanies it.
=item Where to send your patch
If your patch is for a specific bug in the Perl core, it should be sent
using the perlbug utility. Don't forget to describe the problem and the
fix adequately.
If it is a patch to a module that you downloaded from CPAN you should
submit your patch to that module's author.
If your patch addresses one of the items described in perltodo.pod,
please discuss your approach B<before> you make the patch at
<perl5-porters at perl.org>. Be sure to browse the archives of past
discussions (see perltodo.pod for archive locations).
=back
=head2 Applying a patch
=over 4
=item General notes on applying patches
The following are some general notes on applying a patch
to your perl distribution.
=over 4
=item patch C<-p>
It is generally easier to apply patches with the C<-p N> argument to
patch (where N is the number of path components to skip in the files
found in the headers). This helps reconcile differing paths between
the machine the patch was created on and the machine on which it is
being applied.
Be sure to use the Larry Wall version of patch. Some Operating Systems
(HP-UX amongst those) have a patch command that does something completely
different. The correct version of patch will show Larry's name several
times when invoked as patch --version.
=item Cut and paste
B<Never> cut and paste a patch into your editor. This usually clobbers
the tabs and confuses patch.
=item Hand editing patches
Avoid hand editing patches as this almost always screws up the line
numbers and offsets in the patch, making it useless.
=back
=back
=head2 Final notes
If you follow these guidelines it will make everybody's life a little
easier. You'll have the satisfaction of having contributed to perl,
others will have an easy time using your work, and it should be easier
for the maintainers to coordinate the occasionally large numbers of
patches received.
Also, just because you're not a brilliant coder doesn't mean that you
can't contribute. As valuable as code patches are there is always a
need for better documentation (especially considering the general
level of joy that most programmers feel when forced to sit down and
write docs). If all you do is patch the documentation you have still
contributed more than the person who sent in an amazing new feature
that no one can use because no one understands the code (what I'm
getting at is that documentation is both the hardest part to do
(because everyone hates doing it) and the most valuable).
Mostly, when contributing patches, imagine that it is B<you> receiving
hundreds of patches and that it is B<your> responsibility to integrate
them into the source. Obviously you'd want the patches to be as easy
to apply as possible. Keep that in mind. 8-)
=head1 Last Modified
Last modified 22 August 2002
H.Merijn Brand <h.m.brand at xs4all.nl>
Prev modified 21 January 1999
Daniel Grisinger <dgris at dimensional.com>
=head1 Author and Copyright Information
Copyright (c) 1998-2002 Daniel Grisinger
Adapted from a posting to perl5-porters by Tim Bunce (Tim.Bunce at ig.co.uk).
I'd like to thank the perl5-porters for their suggestions.
--- NEW FILE: checkAUTHORS.pl ---
#!/usr/bin/perl -w
use strict;
use Text::Wrap;
$Text::Wrap::columns = 80;
my ($committer, $patch, $log);
use Getopt::Long;
my ($rank, $ta, @authors, %authors, %untraced, %patchers, %committers);
my $result = GetOptions ("rank" => \$rank, # rank authors
"thanks-applied" => \$ta, # ranks committers
"acknowledged=s" => \@authors); # authors files
if (!$result or (($rank||0) + ($ta||0) + (@authors ? 1 : 0) != 1) or !@ARGV) {
die <<"EOS";
$0 --rank Changelogs # rank authors by patches
$0 --acknowledged <authors file> Changelogs # Display unacknowledged authors
$0 --thanks-applied Changelogs # ranks committers
Specify stdin as - if needs be. Remember that option names can be abbreviated.
EOS
}
my %map = reverse (
# "Correct" => "Alias"
adi => "enache\100rdslink.ro",
alanbur => "alan.burlison\100sun.com",
ams => "ams\100wiw.org",
chip => "chip\100pobox.com",
davem => "davem\100fdgroup.com",
doughera => " doughera\100lafayette.edu",
gbarr => "gbarr\100pobox.com",
gsar => "gsar\100activestate.com",
hv => "hv\100crypt.compulink.co.uk",
jhi => "jhi\100iki.fi",
merijn => "h.m.brand\100xs4all.nl",
mhx => "mhx-perl\100gmx.net",
nicholas => "nick\100unfortu.net",
nick => "nick\100ing-simmons.net",
pudge => "pudge\100pobox.com",
rgs => "rgarciasuarez\100free.fr",
sky => "sky\100nanisky.com",
steveh => "steve.hay\100uk.radan.com",
stevep => "steve\100fisharerojo.org",
gisle => "gisle\100activestate.com",
"abigail\100abigail.nl"=> "abigail\100foad.org",
"chromatic\100wgz.org" => "chromatic\100rmci.net",
"slaven\100rezic.de" => "slaven.rezic\100berlin.de",
"mjtg\100cam.ac.uk" => "mjtg\100cus.cam.ac.uk",
"robin.barker\100npl.co.uk" => "rmb1\100cise.npl.co.uk",
"paul.marquess\100btinternet.com"
=> "paul_marquess\100yahoo.co.uk",
"wolfgang.laun\100chello.at" =>
"wolfgang.laun\100alcatel.at",
"t.jenness\100jach.hawaii.edu" => "timj\100jach.hawaii.edu",
"abe\100ztreet.demon.nl" => "abeltje\100cpan.org",
"nospam-abuse\100bloodgate.com" => "tels\100bloodgate.com",
"jfriedl\100yahoo.com" => "jfriedl\100yahoo-inc.com",
"japhy\100pobox.com" => "japhy\100pobox.org",
"gellyfish\100gellyfish.com" => "jns\100gellyfish.com",
"jcromie\100divsol.com" => "jcromie\100cpan.org",
"demerphq\100gmail.com" => "demerphq\100hotmail.com",
"rick\100consumercontact.com" => "rick\100bort.ca",
"vkonovalov\100spb.lucent.com"
=> "vkonovalov\100peterstar.ru",
"rjk\100linguist.dartmouth.edu"
=> "rjk\100linguist.thayer.dartmouth.edu",
"domo\100computer.org" => "shouldbedomo\100mac.com",
"kane\100dwim.org" => "kane\100xs4all.net",
"allens\100cpan.org" => "easmith\100beatrice.rutgers.edu",
"spoon\100cpan.org" => "spoon\100dellah.org",
"ben_tilly\100operamail.com" => "btilly\100gmail.com",
"mbarbon\100dsi.unive.it" => "mattia.barbon\100libero.it",
"tassilo.parseval\100post.rwth-aachen.de" =>
"tassilo.von.parseval\100rwth-aachen.de",
"dcd\100tc.fluke.com" => "david.dyck\100fluke.com",
"kroepke\100dolphin-services.de"
=> "kay\100dolphin-services.de",
"sebastien\100aperghis.net" => "maddingue\100free.fr",
"radu\100netsoft.ro" => "rgreab\100fx.ro",
"rick\100consumercontact.com"
=> "rick.delaney\100rogers.com",
"p5-authors\100crystalflame.net"
=> "perl\100crystalflame.net",
"stef\100mongueurs.net" => "stef\100payrard.net",
"kstar\100wolfetech.com" => "kstar\100cpan.org",
"7k8lrvf02\100sneakemail.com" =>
"kjx9zthh3001\100sneakemail.com",
"mgjv\100comdyn.com.au" => "mgjv\100tradingpost.com.au",
"thomas.dorner\100start.de" => "tdorner\100amadeus.net",
"ajohnson\100nvidia.com" => "ajohnson\100wischip.com",
"phil\100perkpartners.com" => "phil\100finchcomputer.com",
"tom.horsley\100mail.ccur.com" => "tom.horsley\100ccur.com",
"rootbeer\100teleport.com" => "rootbeer\100redcat.com",
"cp\100onsitetech.com" => "publiustemp-p5p\100yahoo.com",
"epeschko\100den-mdev1" => "esp5\100pge.com",
"pimlott\100idiomtech.com" => "andrew\100pimlott.net",
"fugazi\100zyx.net" => "larrysh\100cpan.org",
"merijnb\100iloquent.nl" => "merijnb\100iloquent.com",
"whatever\100davidnicol.com" => "davidnicol\100gmail.com",
"rmgiroux\100acm.org" => "rmgiroux\100hotmail.com",
"smcc\100mit.edu" => "smcc\100ocf.berkeley.edu",
"schubiger\100cpan.org" => "steven\100accognoscere.org",
"richard.foley\100ubsw.com"
=> "richard.foley\100t-online.de",
"damian\100cs.monash.edu.au" => "damian\100conway.org",
"gp\100familiehaase.de" => "gerrit\100familiehaase.de",
"juerd\100cpan.org" => "juerd\100convolution.nl",
"paul.green\100stratus.com"
=> "paul_greenvos\100vos.stratus.com",
"alian\100cpan.org" => "alian\100alianwebserver.com",
# Maybe we should special case this to get real names out?
"perlbug\100perl.org" => "perlbug-followup\100perl.org",
);
# Make sure these are all lower case.
$map{"autrijus\100egb.elixus.org"} = $map{"autrijus\100geb.elixus.org"}
= $map{"autrijus\100gmail.com"} = $map{"autrijus\100ossf.iis.sinica.edu.tw"}
= "autrijus\100autrijus.org";
$map{"ilya\100math.ohio-state.edu"} = $map{"ilya\100math.berkeley.edu"}
= $map{"ilya\100math.berkeley.edu"} = "nospam-abuse\100ilyaz.org";
$map{"philip.newton\100gmx.net"} = $map{"philip.newton\100datenrevision.de"}
= $map{"pnewton\100gmx.de"} = "pne\100cpan.org",
$map{"simon\100pembro4.pmb.ox.ac.uk"} = $map{"simon\100brecon.co.uk"}
= $map{"simon\100othersideofthe.earth.li"} = $map{"simon\100cozens.net"}
= $map{"simon\100netthink.co.uk"} = "simon\100simon-cozens.org";
$map{"spider\100web.zk3.dec.com"} = $map{"spider\100leggy.zk3.dec.com"}
= $map{"spider-perl\100orb.nashua.nh.us"}
= $map{"spider\100peano.zk3.dec.com"}
= "spider\100orb.nashua.nh.us";
$map{"andreas.koenig.gmwojprw\100franz.ak.mind.de"}
= $map{"a.koenig\100mind.de"} = "andreas.koenig\100anima.de";
$map{"japhy\100perlmonk.org"} = $map{"japhy\100cpan.org"}
= "japhy\100pobox.com";
$map{"rmbarker\100cpan.org"} = "robin.barker\100npl.co.uk";
$map{"yves.orton\100de.mci.com"} = $map{"yves.orton\100mciworldcom.de"}
= "demerphq\100gmail.com";
$map{"jim.cromie\100gmail.com"} = "jcromie\100divsol.com";
$map{"perl_dummy\100bloodgate.com"} = "nospam-abuse\100bloodgate.com";
$map{"paul.marquess\100ntlworld.com"} = "paul.marquess\100btinternet.com";
$map{"konovalo\100mail.wplus.net"} = $map{"vadim\100vkonovalov.ru"}
= "vkonovalov\100spb.lucent.com";
$map{"kane\100cpan.org"} = "kane\100dwim.org";
$map{"rs\100crystalflame.net"} = "p5-authors\100crystalflame.net";
$map{"(srezic\100iconmobile.com)"} = "slaven\100rezic.de";
$map{"perl\100dellah.anu.edu.au"} = "spoon\100cpan.org";
$map{"rjk-perl-p5p\100tamias.net"} = "rjk\100linguist.dartmouth.edu";
$map{"sts\100accognoscere.org"} = "schubiger\100cpan.org";
$map{"s.payrard\100wanadoo.fr"} = "stef\100mongueurs.net";
$map{"richard.foley\100ubs.com"} = "richard.foley\100ubsw.com";
# I assume that Ton Hopsel's lack of e-mail address in AUTHORS is deliberate
$map{"me-02\100ton.iguana.be"} = $map{"perl-5.8.0\100ton.iguana.be"}
= $map{"perl5-porters\100ton.iguana.be"} = "!";
# No real name for these address
$map{$_} = "?" foreach ("grommel\100sears.com", "pxm\100nubz.org",
"padre\100elte.hu", "jdhedden\100" . "1979.usna.com",
"nothingmuch\100woobling.org", "bob\100starlabs.net",
"bbucklan\100jpl-devvax.jpl.nasa.gov",
"bilbo\100ua.fm", "mats\100sm5sxl.net",
"chris\100ex-parrot.com",
"kaminsky\100math.huji.ac.il",
"bonefish\100cs.tu-berlin.de",
"bstrand\100switchmanagement.com",
"glasser\100tang-eleven-seventy-nine.mit.edu",
"raf\100tradingpost.com.au", "erik\100cs.uni-jena.de",
"jms\100mathras.comcast.net", "kvr\100centrum.cz",
"perlbug\100veggiechinese.net",
"scott\100perlcode.org",
);
# We don't have an e-mail address for Beau Cox
$map{"beau\100beaucox.com"} = "?";
$map{"rgarciasuarez\100mandrakesoft.com"}
= $map{"rgarciasuarez\100mandriva.com"}
= $map{"raphel.garcia-suarez\100hexaflux.com"} = "rgs";
$map{"jhietaniemi\100gmail.com"} = $map{"jhi\100kosh.hut.fi"}
= $map{"jhi\100cc.hut.fi"} = $map{"jarkko.hietaniemi\100nokia.com"} = "jhi";
$map{"nick\100ccl4.org"} = $map{"nick\100talking.bollo.cx"}
= $map{"nick\100plum.flirble.org"} = $map{"nick\100babyhippo.co.uk"}
= $map{"nick\100bagpuss.unfortu.net"} = "nicholas";
$map{"craig.berry\100psinetcs.com"} = $map{"craig.berry\100metamorgs.com"}
= $map{"craig.berry\100signaltreesolutions.com"}
= $map{"craigberry\100mac.com"} = "craigb";
$map{"davem\100iabyn.nospamdeletethisbit.com" }
= $map{"davem\100fdgroup.co.uk"} = $map{"davem\100fdisolutions.com"}
= "davem";
$map{"alan.burlison\100uk.sun.com"} = "alanbur";
$map{"artur\100contiller.se"} = $map{"arthur\100contiller.se"} = "sky";
$map{"h.m.brand\100hccnet.nl"} = $map{"merijn\100l1.procura.nl"} = "merijn";
$map{"nik\100tiuk.ti.com"} = $map{"nick.ing-simmons\100elixent.com"} = "nick";
$map{"hv\100crypt.org"} = "hv";
$map{"gisle\100aas.no"} = "gisle";
if (@authors) {
my %raw;
foreach my $filename (@authors) {
open FH, "<$filename" or die "Can't open $filename: $!";
while (<FH>) {
next if /^\#/;
next if /^-- /;
if (/<([^>]+)>/) {
# Easy line.
$raw{$1}++;
} elsif (/^([-A-Za-z0-9 .\'À-ÖØöø-ÿ]+)[\t\n]/) {
# Name only
$untraced{$1}++;
} else {
chomp;
warn "Can't parse line '$_'";
}
}
}
foreach (keys %raw) {
print "E-mail $_ occurs $raw{$_} times\n" if $raw{$_} > 1;
$_ = lc $_;
$authors{$map{$_} || $_}++;
}
++$authors{'!'};
++$authors{'?'};
}
while (<>) {
next if /^-+/;
if (m!^\[\s+(\d+)\]\s+By:\s+(\S+)\s+on!) {
# new patch
my @new = ($1, $2);
&process ($committer, $patch, $log);
($patch, $committer) = @new;
undef $log;
} elsif (s/^(\s+Log: )//) {
die "Duplicate Log:" if $log;
$log = $_;
my $prefix = " " x length $1;
LOG: while (<>) {
next if /^$/;
if (s/^$prefix//) {
$log .= $_;
} elsif (/^\s+Branch:/) {
last LOG;
} else {
chomp;
die "Malformed log end with '$_'";
}
}
}
}
&process ($committer, $patch, $log);
if ($rank) {
&display_ordered(\%patchers);
} elsif ($ta) {
&display_ordered(\%committers);
} elsif (%authors) {
my %missing;
foreach (sort keys %patchers) {
next if $authors{$_};
# Sort by number of patches, then name.
$missing{$patchers{$_}}->{$_}++;
}
foreach my $patches (sort {$b <=> $a} keys %missing) {
print "$patches patch(es)\n";
foreach my $author (sort keys %{$missing{$patches}}) {
print " $author\n";
}
}
}
sub display_ordered {
my $what = shift;
my @sorted;
while (my ($name, $count) = each %$what) {
push @{$sorted[$count]}, $name;
}
my $i = @sorted;
return unless $i;
while (--$i) {
next unless $sorted[$i];
print wrap ("$i:\t", "\t", join (" ", sort @{$sorted[$i]}), "\n");
}
}
sub process {
my ($committer, $patch, $log) = @_;
return unless $committer;
my @authors = $log =~ /From:\s+.*?([^"\@ \t\n<>]+\@[^"\@ \t\n<>]+)/gm;
if (@authors) {
foreach (@authors) {
s/^<//;
s/>$//;
$_ = lc $_;
$patchers{$map{$_} || $_}++;
}
# print "$patch: @authors\n";
++$committers{$committer};
} else {
# print "$patch: $committer\n";
# Not entirely fair as this means that the maint pumpking scores for
# everything intergrated that wasn't a third party patch in blead
$patchers{$committer}++;
}
}
--- NEW FILE: checkURL.pl ---
#!/usr/bin/perl
use strict;
use warnings 'all';
use LWP::Simple qw /$ua getstore/;
my %urls;
my @dummy = qw(
http://something.here
http://www.pvhp.com
);
my %dummy;
@dummy{@dummy} = ();
foreach my $file (<*/*.pod */*/*.pod */*/*/*.pod README README.* INSTALL>) {
open my $fh => $file or die "Failed to open $file: $!\n";
while (<$fh>) {
if (m{(?:http|ftp)://(?:(?!\w<)[-\w~?@=.])+} && !exists $dummy{$&}) {
my $url = $&;
$url =~ s/\.$//;
$urls {$url} ||= { };
$urls {$url} {$file} = 1;
}
}
close $fh;
}
sub fisher_yates_shuffle {
my $deck = shift; # $deck is a reference to an array
my $i = @$deck;
while (--$i) {
my $j = int rand ($i+1);
@$deck[$i,$j] = @$deck[$j,$i];
}
}
my @urls = keys %urls;
fisher_yates_shuffle(\@urls);
sub todo {
warn "(", scalar @urls, " URLs)\n";
}
my $MAXPROC = 40;
my $MAXURL = 10;
my $MAXFORK = $MAXPROC < $MAXURL ? 1 : $MAXPROC / $MAXURL;
select(STDERR); $| = 1;
select(STDOUT); $| = 1;
while (@urls) {
my @list;
my $pid;
my $i;
todo();
for ($i = 0; $i < $MAXFORK; $i++) {
$list[$i] = [ splice @urls, 0, $MAXURL ];
$pid = fork;
die "Failed to fork: $!\n" unless defined $pid;
last unless $pid; # Child.
}
if ($pid) {
# Parent.
warn "(waiting)\n";
1 until -1 == wait; # Reap.
} else {
# Child.
foreach my $url (@{$list[$i]}) {
my $code = getstore $url, "/dev/null";
next if $code == 200;
my $f = join ", " => keys %{$urls {$url}};
printf "%03d %s: %s\n" => $code, $url, $f;
}
exit;
}
}
__END__
--- NEW FILE: pumpkin.pod ---
=head1 NAME
Pumpkin - Notes on handling the Perl Patch Pumpkin And Porting Perl
=head1 SYNOPSIS
There is no simple synopsis, yet.
=head1 DESCRIPTION
This document attempts to begin to describe some of the considerations
involved in patching, porting, and maintaining perl.
This document is still under construction, and still subject to
significant changes. Still, I hope parts of it will be useful,
so I'm releasing it even though it's not done.
For the most part, it's a collection of anecdotal information that
already assumes some familiarity with the Perl sources. I really need
[...1575 lines suppressed...]
The files of Perl source code distribution do carry a lot of
copyrights, by various people. (There are many copyrights embedded in
perl.c, for example.) The most straightforward thing for pumpkings to
do is to simply update Larry's copyrights at the beginning of the
*.[hcy], x2p/*.[hcy], *.pl, and README files, and leave all other
copyrights alone. Doing more than that requires quite a bit of tracking.
=back
=head1 AUTHORS
Original author: Andy Dougherty doughera at lafayette.edu .
Additions by Chip Salzenberg chip at perl.com and
Tim Bunce Tim.Bunce at ig.co.uk .
All opinions expressed herein are those of the authorZ<>(s).
=head1 LAST MODIFIED
$Id: pumpkin.pod,v 1.2 2006-12-04 16:59:01 dslinux_cayenne Exp $
--- NEW FILE: config.sh ---
#!/bin/sh
#
# This file was produced by running the Configure script. It holds all the
# definitions figured out by Configure. Should you modify one of these values,
# do not forget to propagate your changes by running "Configure -der". You may
# instead choose to run each of the .SH files by yourself, or "Configure -S".
#
# Package name : perl5
# Source directory : .
# Configuration time: Thu Jan 19 14:41:48 GMT 2006
# Configured by : yourname
# Target system : linux bagpuss.unfortu.net 2.4.19-rmk4 #3 fri oct 25 21:57:55 bst 2002 armv4l unknown
Author=''
Date='$Date'
Header=''
Id='$Id'
Locker=''
[...1009 lines suppressed...]
zip='zip'
# Configure command line arguments.
config_arg0='./Configure'
config_args='-Dprefix=/opt/perl -Dcf_by=yourname -Dcf_email=yourname at yourhost.yourplace.com -Dperladmin=yourname at yourhost.yourplace.com -Dmydomain=.yourplace.com -Dmyhostname=yourhost -dE'
config_argc=7
config_arg1='-Dprefix=/opt/perl'
config_arg2='-Dcf_by=yourname'
config_arg3='-Dcf_email=yourname at yourhost.yourplace.com'
config_arg4='-Dperladmin=yourname at yourhost.yourplace.com'
config_arg5='-Dmydomain=.yourplace.com'
config_arg6='-Dmyhostname=yourhost'
config_arg7='-dE'
PERL_REVISION=5
PERL_VERSION=8
PERL_SUBVERSION=8
PERL_API_REVISION=5
PERL_API_VERSION=8
PERL_API_SUBVERSION=0
PERL_PATCHLEVEL=
PERL_CONFIG_SH=true
--- NEW FILE: corecpan.pl ---
#!perl
# Reports, in a perl source tree, which dual-lived core modules have not the
# same version than the corresponding module on CPAN.
use 5.9.0;
use strict;
use Getopt::Std;
use ExtUtils::MM_Unix;
use lib 'Porting';
use Maintainers qw(get_module_files %Modules);
our $packagefile = '02packages.details.txt';
sub usage () {
die <<USAGE;
$0 - report which core modules are outdated.
To be run at the root of a perl source tree.
Options :
-h : help
-v : verbose (print all versions of all files, not only those which differ)
-f : force download of $packagefile from CPAN
(it's expected to be found in the current directory)
USAGE
}
sub get_package_details () {
my $url = 'http://www.cpan.org/modules/02packages.details.txt.gz';
unlink $packagefile;
system("wget $url && gunzip $packagefile.gz") == 0
or die "Failed to get package details\n";
}
getopts('fhv');
our $opt_h and usage;
our $opt_f or !-f $packagefile and get_package_details;
# Load the package details. All of them.
my %cpanversions;
open my $fh, $packagefile or die $!;
while (<$fh>) {
my ($p, $v) = split ' ';
$cpanversions{$p} = $v;
}
close $fh;
for my $dist (sort keys %Modules) {
next unless $Modules{$dist}{CPAN};
print "Module $dist...\n";
for my $file (get_module_files($dist)) {
next if $file !~ /\.pm\z/ or $file =~ m{^t/} or $file =~ m{/t/};
my $vcore = MM->parse_version($file) // 'undef';
my $module = $file;
$module =~ s/\.pm\z//;
# some heuristics to figure out the module name from the file name
$module =~ s{^(lib|ext)/}{}
and $1 eq 'ext'
and ( $module =~ s{^(.*)/lib/\1\b}{$1},
$module =~ s{(\w+)/\1\b}{$1},
$module =~ s{^Encode/encoding}{encoding},
$module =~ s{^MIME/Base64/QuotedPrint}{MIME/QuotedPrint},
$module =~ s{^List/Util/lib/Scalar}{Scalar},
);
$module =~ s{/}{::}g;
my $vcpan = $cpanversions{$module} // 'not found';
if (our $opt_v or $vcore ne $vcpan) {
print " $file: core=$vcore, cpan=$vcpan\n";
}
}
}
--- NEW FILE: p4genpatch ---
#!/usr/bin/perl -w
# p4genpatch - Generate a perl patch from the repository
# Usage: $0 -h
# andreas.koenig at anima.de
use strict;
use File::Temp qw(tempdir);
use File::Compare;
use File::Spec;
use File::Spec::Unix;
use Time::Local;
use Getopt::Long;
use Cwd qw(cwd);
sub correctmtime ($$$);
sub Usage ();
$0 =~ s|^.*[\\/]||;
my $VERSION = '0.05';
my $TOPDIR = cwd();
my @P4opt;
our %OPT = ( "d" => "u", b => "//depot/perl/", "D" => "diff" );
Getopt::Long::Configure("no_ignore_case");
GetOptions(\%OPT, "b=s", "p=s", "d=s", "D=s", "h", "v", "V") or die Usage;
print Usage and exit if $OPT{h};
print "$VERSION\n" and exit if $OPT{V};
die Usage unless @ARGV == 1 && $ARGV[0] =~ /^\d+$/;
my $CHANGE = shift;
for my $p4opt (qw(p)) {
push @P4opt, "-$p4opt $OPT{$p4opt}" if $OPT{$p4opt};
}
my $system = "p4 @P4opt describe -s $CHANGE |";
open my $p4, $system or die "Could not run $system";
my @action;
while (<$p4>) {
print;
next unless m|($OPT{b})|;
my($prefix) = $1;
$prefix =~ s|/$||;
$prefix =~ s|/[^/]+$||; # up to the last "/" in the match is to be stripped
if (my($file,$action) = m|^\.\.\. (//depot.*)\s(\w+)$|) {
next if $action eq "delete";
push @action, [$action, $file, $prefix];
}
}
close $p4;
my $tempdir;
my @unlink;
print "Differences ...\n";
for my $a (@action) {
$tempdir ||= tempdir( "tmp-XXXX", CLEANUP => 1, TMPDIR => 1 );
@unlink = ();
my($action,$file,$prefix) = @$a;
my($path,$basename,$number) = $file =~ m|\Q$prefix\E/(.+/)?([^/]+)#(\d+)|;
my @splitdir = File::Spec::Unix->splitdir($path);
$path = File::Spec->catdir(@splitdir);
my($depotfile) = $file =~ m|^(.+)#\d+\z|;
die "Panic: Could not parse file[$file]" unless $number;
$path = "" unless defined $path;
my($d1,$d2,$prev,$prevchange,$prevfile,$doadd,$t1,$t2);
$prev = $number-1;
$prevchange = $CHANGE-1;
# can't assume previous rev == $number-1 due to obliterated revisions
$prevfile = "$depotfile\@$prevchange";
if ($number == 1 or $action =~ /^(add|branch)$/) {
$d1 = $^O eq 'MacOS' ? File::Spec->devnull : "/dev/null";
$t1 = $d1;
++$doadd;
} elsif ($action =~ /^(edit|integrate)$/) {
$d1 = File::Spec->catfile($path, "$basename-$prevchange");
$t1 = File::Spec->catfile($tempdir, $d1);
warn "==> $d1 <==\n" if $OPT{v};
my $system = qq[p4 @P4opt print -o "$t1" "$prevfile"];
my $status = `$system`;
if ($?) {
warn "$0: system[$system] failed, status[$?]\n";
next;
}
chmod 0644, $t1;
if ($status =~ /\#(\d+) \s - \s \w+ \s change \s (\d+) \s /x) {
($prev,$prevchange) = ($1,$2);
$prevfile = "$depotfile#$prev";
my $oldd1 = $d1;
$d1 =~ s/-\d+$/#$prev~$prevchange~/;
my $oldt1 = $t1;
$t1 = File::Spec->catfile($tempdir, $d1);
rename $oldt1, $t1;
}
push @unlink, $t1;
} else {
die "Unknown action[$action]";
}
$d2 = File::Spec->catfile($path, $basename);
$t2 = File::Spec->catfile($tempdir, $d2);
push @unlink, $t2;
warn "==> $d2#$number <==\n" if $OPT{v};
my $system = qq[p4 @P4opt print -o "$t2" "$file"];
# warn "system[$system]";
my $type = `$system`;
if ($?) {
warn "$0: `$system` failed, status[$?]\n";
next;
}
chmod 0644, $t2;
$type =~ m|^//.*\((.+)\)$| or next;
$type = $1;
if ($doadd or File::Compare::compare($t1, $t2)) {
print "\n==== $file ($type) ====\n";
unless ($type =~ /text/) {
next;
}
unless ($^O eq 'MacOS') {
$d1 =~ s,\\,/,g;
$d2 =~ s,\\,/,g;
}
print "Index: $d2\n";
correctmtime($prevfile,$prev,$t1) unless $doadd;
correctmtime($file,$number,$t2);
chdir $tempdir or warn "Could not chdir '$tempdir': $!";
$system = qq[$OPT{D} -$OPT{d} "$d1" "$d2"];
system($system); # no return check because diff doesn't always return 0
chdir $TOPDIR or warn "Could not chdir '$TOPDIR': $!";
}
}
continue {
for (@unlink) {
unlink or warn "Could not unlink $_: $!" if -f;
}
}
print "End of Patch.\n";
my($tz_offset);
sub correctmtime ($$$) {
my($depotfile,$nr,$localfile) = @_;
my %fstat = map { /^\.\.\. (\w+) (.*)$/ } `p4 @P4opt fstat -s "$depotfile"`;
return unless exists($fstat{headRev}) and $fstat{headRev} == $nr;
if ($^O eq 'MacOS') { # fix epoch ... still off by three hours (EDT->PDT)
require Time::Local;
$tz_offset ||= sprintf "%+0.4d\n", (
Time::Local::timelocal(localtime) - Time::Local::timelocal(gmtime)
);
$fstat{headTime} += 2082844801 + $tz_offset;
}
utime $fstat{headTime}, $fstat{headTime}, $localfile;
}
sub Usage () {
qq{Usage: $0 [OPTIONS] patchnumber
-p host:port p4 port (e.g. myhost:1666)
-d diffopt option to pass to diff(1)
-D diff diff(1) to use
-b branch(es) which branches to include (regex); the last
directory within the matched part will be
preserved on the local copy, so that patch -p1
will work (default: "//depot/perl/")
-v verbose
-h print this help and exit
-V print version number and exit
Fetches all required files from the repository, puts them into a
temporary directory with sensible names and sensible modification
times and composes a patch to STDOUT using external diff command.
Requires repository access.
Examples:
perl $0 12345 | gzip -c > 12345.gz
perl $0 -dc 12345 > change-12345.patch
perl $0 -b //depot/maint-5.6/perl -v 8571 > 8571
};
}
More information about the dslinux-commit
mailing list