#!/usr/bin/perl -w

use strict;
use File::Spec;
use Cwd;
use Getopt::Long;
use vars qw(%Opt $VERSION);

$VERSION = sprintf "%.3f", (sprintf "%d.%03d", q$Revision: 1.19 $ =~ /(\d+)\.(\d+)/) - 1;
# $Id: patchaperlup,v 1.19 2001/09/24 09:11:59 k Exp k $

%Opt = ();

# options get and build are undocumented as they might be considered bloatware
GetOptions( \%Opt, qw( start=i upto=i perldir=s diffdir=s nounlink! quiet! version+ verbose+) );

sub verbose {
  return if $Opt{quiet};
  printf STDERR @_;
}

print "Version: $VERSION\n";
if ($Opt{version}) {
  exit;
}

sub usage () {
  "Usage $0
    --perldir  perldirectory-to-alter
    --diffdir  patchdirectory
    [--start   number-of-first-patch]
    [--upto    number-of-last-patch]
    [--quiet]
    [--verbose]
    [--nounlink]
    [--version]";
}

my $perldir = $Opt{perldir} or die usage;
my $diffdir = $Opt{diffdir} or die usage;
$Opt{verbose} ||= 0;

die "perldir[$perldir] not found" unless -d $perldir;
print "Perldir: $perldir\n";
open F, "$perldir/Changes" or die "Couldn't open $perldir/Changes: $!";
my $already_patched;
while (<F>) {
  next unless /^\[\s*(\d+)\]\sBy:\s/;
  $already_patched = $1;
  last;
}
$|=1;

die "diffdir[$diffdir] not found" unless -d $diffdir;
print "Diffdir: $diffdir\n";
my $diffdir_abs = File::Spec->file_name_is_absolute($diffdir) ?
    $diffdir : File::Spec->catdir(Cwd::cwd,$diffdir);
opendir DIR, $diffdir_abs or die "Couldnt opendir";
my @diffs = sort { $a <=> $b } grep s/^(\d+)\.gz/$1/, readdir DIR;
if ($already_patched > $diffs[0]) {
  verbose "Your patchdirectory starts with patch %d, but your perldir
has the patches up to %d already applied. Skipping those not needed.
", $diffs[0], $already_patched;
  shift @diffs while $diffs[0] <= $already_patched;
}

# Now it is possible that the first patch we have here is only
# patching the Changes file and that this patch has already been
# applied during the release. We need to be more tolerant on the first
# patch.

my $latest = $diffs[-1];
$latest =~ s/\D.*//;
for my $arg (qw(upto start)) {
  if ($Opt{$arg}) {
    if ($Opt{$arg} > $latest) {
      warn "Option for $arg\[$Opt{$arg}] bigger than
 latest[$latest]. Won't apply any patch.\a\n";
      sleep 5;
    }
    if ($Opt{$arg}<$diffs[0]) {
      die "Invalid option for $arg\[$Opt{$arg}].
First patch in your diffdir is $diffs[0]\n";
    } else {
      if ($arg eq "upto") {
        pop @diffs while @diffs && $diffs[-1] > $Opt{$arg};
        $latest = $Opt{$arg};
      } else {
        shift @diffs while @diffs && $diffs[0] < $Opt{$arg};
      }
    }
  }
}
chdir $perldir or die "Couldn't chdir to $perldir: $!";
my @fails;
verbose "Prescanning all patch files for contents\n";
my $tmpfile = "tmp.patchls.$$";
open F, "| perl Porting/patchls - > $tmpfile";
for my $d ( @diffs ){
  verbose "\r%10s of %10s to %10s", $d, $diffs[0], $diffs[-1];
  my $pathdiff = "$diffdir_abs/$d.gz";
  die "Couldn't find pathdiff[$pathdiff]" unless -f $pathdiff;
  open G, "zcat $pathdiff|";
  local $/;
  print F <G>;
  close G;
}
close F;
verbose "\n";

open F, $tmpfile or die "Couldn't open $tmpfile: $!";
my %pfiles;
while (<F>) {
  s/^-:\s//;
  chomp $_;
  my @pfiles = grep { -f $_ } split m{ }, $_;
  @pfiles{@pfiles} = ();
}
close F;
unlink $tmpfile;

sub contains_cr {
  my($file) = shift;
  open F, $file or die "Couldn't open $file: $!";
  local($/) = "\n";
  my $firstline = <F>;
  $firstline =~ /\cM/;
}

# at the time of patch 7632, some files in the repository were changed
# to contain no CR
if (1) {

  @ARGV = grep contains_cr($_), keys %pfiles;
  @ARGV = grep !m!lib/unicode/syllables.txt!, @ARGV;

  if (@ARGV) {
    verbose "Removing CR from %d files:\n", scalar @ARGV;
    $^I = ";";
    my $i = 0;
    my $b = 0;
    while (<>) {
      # in 5.7.1 we had files that contained 0x0d0d0a on line endings
      s/[\r\n]+\z/\n/;
      print;
      if (eof(ARGV)){
        verbose "%s\n", $ARGV;
      }
    }
    my $lines = $.;
    verbose "\n";
  }
}
my $patchcommand = sprintf(
                           "patch %s -p1 -N",
                           $Opt{verbose}>0 ? "" : "-s"
                          );

sub unCR {
  my($f) = shift;
  return unless -f $f;
  local *UNCR;
  local $/;
  open UNCR, "<$f" or die "Could not open <$f: $!";
  my $content = <UNCR>;
  close UNCR;
  $content =~ s/\015//g or return;
  my($dev,$inode,$mode) = stat $f;
  unlink $f or die "Could not unlink $f: $!";
  open UNCR, ">$f" or die "Could not open >$f: $!";
  print UNCR $content;
  close UNCR;
  chmod $mode, $f;
}

for my $d ( @diffs ){
  my $pathdiff = "$diffdir_abs/$d.gz";
  verbose "\rapplying %s # for %d\n", $patchcommand, $d
        if $Opt{verbose}>0;
  print "Firstpatch: $d\n" if $d==$diffs[0];

  # First do the deletes, they are not line by line in the patches
  local *Z;
  open Z, "zcat $pathdiff |";
  while (<Z>) {
    last if /^Differences\s/;
    next unless m{^\s*\.\.\. //.+perl/(.+)#\d+ delete$};
    my $delfile = $1;
    unless (-f $delfile){
      warn "PAPU warning: Could not find $delfile for deletion, ignoring";
      next;
    }
    unlink $delfile or die "Could not unlink $delfile: $!";
  }

  # Now do the patches
  # my $pout = `zcat $pathdiff | perl -ple 's/\015//' | $patchcommand 2>&1`;
  my $pouth;
  open $pouth, "| $patchcommand  > tmp.patch.out 2>&1";
  while (<Z>) {
    if (/^Index: perl\/(\S+)/) {
      my $file = $1;
      unCR($file);
      next;
    }
    s/\015//g;
    print $pouth $_;
  }
  close $pouth;
  local $/;
  open $pouth, "tmp.patch.out" or die "Could not open tmp.patch.out: $!";
  my $pout = <$pouth>;
  close $pouth;
  warn "----tmp.patch.out---\n$pout----EOF----\n" if $pout;
  if ($? == 0) {
    verbose "\rapplied patch # %s.%s", $d, $Opt{verbose}>0 ? "\n" : " ";
  } else {
    my $ls = `zcat $pathdiff | perl Porting/patchls -`;
    chomp $ls;
    if ($ls eq "-: Changes") {
      warn "PAPU $d: Patch error on Changes file can be ignored\n";
    } elsif ($pout =~ /patch: \*\*\*\* Only garbage was found in the patch input./) {
      warn "PAPU $d: These Only Garbage patch errors can be ignored.\n";
    } elsif ($pout =~ /Reversed .* patch detected!/ && ($d - $already_patched)<4) {
      warn "PAPU $d: Reversed patches immediately after a snapshot indicate the failure is likely to be an artifact. Error ignored.\n";
    } else {
      my @rej1;
      while ($pout =~ /saving rejects to (?:file )?(\S+)\.rej/gc){
        push @rej1, $1;
      }

      my %rej;
      @rej{@rej1}=();
      for my $f (qw(Changes patchlevel.h)) {
        delete $rej{$f};
      }
      my @rej2 = keys %rej;
      if (@rej2) {
        warn "Problem with patch $d (files: @rej2)\n";
        push @fails, $d;
      } elsif (@rej1) {
        warn "PAPU $d: Rejects were only on [@rej1]: these can usually be ignored\n";
      }
    }
  }
  close Z;
}
verbose "\n";
if (@fails) {
  verbose "The following patches had errors:\n";
  verbose join "", map {"\t$_\n"} @fails;
  verbose "\n";
  die "Errors while patching\n";
} else {
  print "Lastpatch: $diffs[-1]\n";
}

# Removing files not in MANIFEST
use ExtUtils::Manifest;
my @rm = ExtUtils::Manifest::filecheck;
if ($Opt{nounlink}) {
  verbose "Keeping files not in MANIFEST: @rm\n";
} else {
  verbose "Removing files not in MANIFEST: @rm\n";
  unlink @rm or die "Could not unlink @rm: $!";
}

verbose qq{Now you can make a new perl by running e.g.:
  cd $perldir && ./Configure -des && make test
};


__END__

=head1 NAME

patchaperlup - apply a couple of patches in a perl source directory

=head1 SYNOPSIS

  patchaperlup --perldir perldir
               --diffdir diffdir
               [ --start patch-number ]
               [ --upto  patch-number ]
               [ --quiet ]
               [ --version ]

=head1 DESCRIPTION

This utility runs a batch of jobs that upgrade a recent development
perl with selected patches to produce a recent development snapshot of
perl.

The status of this script is alpha as the applicability of the
assumptions about where the current patches are, how they are named
and treated, etc. are unstable. The script is only reflecting current
practice which is subject to change without notice.

How to get at the patches is described in the perlhack manpage.

Be careful though, Sarathy posted a recommendation:

  From: Gurusamy Sarathy <gsar@ActiveState.com>
  Subject: Re: rsync'ed patches vs. rsync'ed source 
  Date: Wed, 01 Nov 2000 09:58:08 -0800

  I'd strongly recommend sticking with rsync.

  The rsync mirror is automatic and syncs with the repository every five
  minutes.

  Updating the patch area still requires manual intervention (with all
  the goofiness that implies, which you've noted) and is typically on
  a daily cycle.  Making this process automatic is on my tuit list,
  but don't ask me when.

I take it that for the real recent perl of the day, you should use
rsync to the perl-current area, but if you want to track down when a
bug was introduced or fixed, the patch repository is the natural
choice.

When you have unpacked a recent perl, patchaperlup should be run as

  perl patchaperlup --perldir perl5.5.660 --diffdir diffs

C<patchaperlup> checks which highest numbered patch has already been
applied to the perl in the C<perldir>. The --upto argument defaults to
the highest numbered patch in the directory given by the --diffdir
argument. The --start argument defaults to the last patch referenced
in the Changes file in the untarred perl sources.

The batch job is pretty verbose and explains what it is doing. The
reason for the verbosity was that it can take a while until
C<patchaperlup> is finishing. Verbosity can be turned off with the
--quiet switch and increased with the --verbose switch.

C<patchaperlup> prints a few mail-header-like lines to standard
output, namely

  Version: version of patchaperlup
  Perldir: perl directory
  Diffdir: directory containing the patches
  Firstpatch: number of the first applied patch
  Lastpatch: number of the last applied patch

The --version switch prints the version and exits.

=head1 EXAMPLE

The following shell script built today's perl and stuffed it into a
directory of its own. Please fill in your own path to DEVPERL.

  DEVPERL=perl-5.7.0
  tar xzf /path/to/devperl/$DEVPERL.tar.gz
  rsync -avz rsync://ftp.linux.activestate.com/diffs diffs
  patchaperlup --perldir $DEVPERL --diffdir diffs > patchaperlup.out
  LPATCH=`awk '$1=="Lastpatch:"{print $2}' patchaperlup.out`
  mv $DEVPERL $DEVPERL@$LPATCH
  cd $DEVPERL@$LPATCH && ./Configure -des && make test

If all patches from the APC are merged into a single diffs directory,
it is possible to run the above example with any DEVPERL from 5.005_58
upwards. At the time of writing, there were some tiny patch problems
if you do that. I'm planning to special-case them so that patchaperlup
does not report unnecessary errors.

=head1 PREREQUISITES

The programs C<zcat> and C<patch> must be in your path. Likewise
C<perl> must be available in the path to run the utility C<patchls>
which can be found in recent perl distributions.

=head1 AUTHOR

Andreas Koenig <andreas.koenig@anima.de>

=cut

