File Coverage

blib/script/makepatch

Criterion	Covered	Total	%
statement	266	602	44.1
branch	95	364	26.1
condition	29	145	20.0
subroutine	22	34	64.7
pod			n/a
total	412	1145	35.9

#!/usr/local/bin/perl -w
# makepatch.pl -- generate a patch kit from two files or directories.
# Author          : Johan Vromans
# Created On      : Tue Jul  7 20:39:39 1992
# Last Modified By: Johan Vromans
# Last Modified On: Fri Oct 26 21:46:58 2012
# Update Count    : 1196
# Status          : Released

use strict;
use Getopt::Long 2.00;
use IO qw(File);
use File::Basename;
use File::Spec;
use File::Path;

################ Common stuff ################

my $my_package = 'Sciurix';
my $my_name    = "makepatch";
my $my_version = "2.05";
my $data_version = '1.0';

################ Globals ################

## Options and defaults

my $opt_diff = 'diff -c';	# default diff command
my $opt_sort;			# sort entries. Default = 1
my $opt_follow = 0;		# follow symbolic links
my $opt_automanifest = "MANIFEST";
my $opt_oldmanifest;		# list of files of the old tree
my $opt_newmanifest;		# list of files of the new tree
my $opt_nomanifest = 0;		# suppress use of MANIFEST files
my $opt_patchlevel;		# patchlevel.h file
my $opt_prefix = '';		# prefix to be added
my $opt_filelist = 0;		# make file list
my $opt_infocmd;		# info command
my $opt_exclude_standard = 1;	# standard excludes
my $opt_exclude_rcs = 0;	# exclude RCS files
my $opt_exclude_cvs = 0;	# exclude CVS files
my $opt_exclude_sccs = 0;	# exclude SCCS files
my $opt_ignore_rcs_keywords = 0; # exclude CVS/RCS keyword data
my @opt_exclude;		# list of excludes (wildcards)
my @opt_exclude_regex;		# list of excludes (regex)
my $opt_recurse = 1;		# recurse
my @opt_descr = ();		# description
my %opt_extract = ();		# extraction rules

# Development options (not shown with -help).
my $opt_trace = 0;		# trace messages
my $opt_verbose = 0;		# verbose info
my $opt_quiet = 0;		# (almost?) no info
my $opt_debug = 0;		# debugging messages
my $opt_test = 0;		# testing

## Misc

my $exclude_pat;		# regex to exclude
my @workq = ();			# pre/post work

# Try to find a temp location.
my $TMPDIR = (File::Spec->can('tmpdir') && File::Spec->tmpdir)
  || $ENV{TMPDIR}
  || $ENV{TEMP}
  || '/usr/tmp';

my $dot_u = File::Spec::Unix->curdir; # UNIX current dir
my $dot = File::Spec->curdir;	# current dir
my $dotdot = File::Spec->updir;	# parent dir

# Try to find something home-ish.
my $HOME = $ENV{HOME}
  || ( ($^O eq 'MSWin32')
       && ( $ENV{APPDATA}
            || $ENV{USERPROFILE}
            || $ENV{HOMEDRIVE} && $ENV{HOMEPATH}
	       && $ENV{HOMEDRIVE}.$ENV{HOMEPATH}
	  )
     )
  || $dot;

# Try to find something null-ish.
my $DEVNULL = (File::Spec->can('devnull') && File::Spec->devnull)
  || '/dev/null';
my $nulpat = quotemeta($DEVNULL);	# pattern to match nul device

my $timestamp = "".localtime();	# timestamp, in string format
my $unified = 0;		# produce unified diff
my $skipped = 0;		# number of files skipped.
my $excluded = 0;		# number of files excluded.

## Subroutine prototypes

sub app_options ();
sub app_parse_rc ($$$);
sub app_usage ($);
sub app_usage_filelist ($);
sub catfile ($$);
sub check_extract ($);
sub cleanup ();
sub cvs_excludes($$$);
sub cvs_ignore($);
sub debug   (@);
sub dodiff ($$$$);
sub makepatch ();
sub extract ($$);
sub filelist ($);
sub make_filelist ($;$);
sub make_filelist_from_manifest ($);
sub message (@);
sub newfile ($$);
sub quotfn ($);
sub setup_excludes ();
sub showopts ($);
sub trace   (@);
sub verbose (@);
sub wrapup (;$);
sub yesno ($);

################ INI files, program parameters ################

app_options ();

################ Presets ################

if ( $opt_exclude_sccs ) {
    unshift (@opt_exclude, qw(p.* s.* SCCS));

}

if ( $opt_exclude_rcs ) {
    unshift (@opt_exclude, ',*', '*,v', qw(RCS RCSLOG));
}

if ( $opt_exclude_cvs ) {
    # Load common .cvsignore, if present.
    for ( catfile($HOME, ".cvsignore") ) {
	unshift (@opt_exclude, cvs_ignore($_)) if -s $_;
    }

    unshift (@opt_exclude, '.#*', '#*',
	     qw(_$* *$ CVS CVS.adm cvslog.*));

}

if ( $opt_exclude_standard ) {
    # Common excludes.
    # Mostly copied from 'Open Source Development with CVS', p. 170.
    unshift (@opt_exclude,
	     qw(*~ *.a *.bak *.BAK *.elc *.exe *.gz *.ln *.o *.obj
		*.olb *.old *.orig *.rej *.so *.Z
		.del-* .make.state .nse_depinfo core
		tags TAGS));
}

setup_excludes ();

if ( $opt_ignore_rcs_keywords ) {
    # Note: We ignore 'Log' since that wouldn't work anyway.
    $opt_diff .= ' ' .
      q{'--ignore-matching-lines=\\$\\(} .
	join('\\|', qw(Author Date Header Id Locker Name RCSfile
		       Revision Source State)) .
	  q{\\)[^$]*\\$'};
}

################ The Process ################

# Handle --filelist. Special but obsolete case.
if ( $opt_filelist ) {
    filelist ($ARGV[0]);
    die ("Okay\n") if $opt_test;
    exit (0);
}

# Check temp dir.
unless ( -d $TMPDIR && -w $TMPDIR ) {
print STDERR <
Please use environment variable TMPDIR or TEMP to designate a writable
directory to hold temporary files.
EOD
    die ("Cannot continue\n");
}

# Create temp dir and names for temp files.
my $tmpdir   = File::Spec->catdir ($TMPDIR, "mp$$.d");
mkdir ($tmpdir, 0777) or die ("tmpdir: $!\n");
my $thepatch = catfile ($tmpdir, ".mp$$.p");
my $tmpfile  = catfile ($tmpdir, ".mp$$.t");
my $patch    = new IO::File;

# Attach cleanup handler.
$SIG{INT} = \&cleanup;
$SIG{QUIT} = \&cleanup;

# The arguments.
my ($old, $new);
if ( $] >= 5.005 && $] < 5.008 ) {
    # Use pseudo-hashes if possible.
    my %fields = ( tag   => 1,	# old/new
		   name  => 2,	# given name on command line
		   root  => 3,	# real (physical) directory
		   base  => 4,	# basename (for archives)
		   man   => 5,	# name of manifest
		   manfn => 6,	# same, real file name
		   files => 7,	# list of files
		 );
    $old = [ \%fields, "old", shift(@ARGV) ];
    $new = [ \%fields, "new", shift(@ARGV) ];
}
else {
    $old = { tag => "old", name => shift(@ARGV) };
    $new = { tag => "new", name => shift(@ARGV) };
}

# Unpack archives, if applicable.
# $old->{root} and $new->{root} are the real locations for the source trees.
check_extract ($old);
check_extract ($new);

# The process.
makepatch ();

# Wrap up.
wrapup ();

die ("Okay\n") if $opt_test;

# In case nothing went wrong...
END { cleanup (); }

################ Subroutines ################

sub message (@) { print STDERR (@_) unless $opt_quiet; }
sub verbose (@) { print STDERR (@_) if $opt_verbose; }
sub debug   (@) { print STDERR (@_) if $opt_debug;   }
sub trace   (@) { print STDERR (@_) if $opt_trace;   }

sub makepatch () {

    # This will bail out if the directory could not be created.
    $patch->open(">$thepatch") || die ("$thepatch: $!\n");
    binmode($patch);

    if ( -f $old->{root} && -f $new->{root} ) {
	# Two files.
	verbose ("Old file = $old->{root}.\n", "New file = $new->{root}.\n");
	dodiff ($dot, $new->{root}, $dot, $old->{root}) &&
	  push (@workq, [ 'p', $old->{root}, -s $old->{root},
			  (stat($new->{root}))[9], (stat(_))[2] ]);
    }
    elsif ( -f $old->{root} && -d $new->{root} ) {
	# File and dir -> File and dir/File.
	$new->{root} = $new->{base} = catfile ($new->{root}, $old->{root});
        verbose ("Old file = $old->{root}.\n", "New file = $new->{root}.\n");
	if ( -f $new->{root} ) {
	    dodiff ($dot, $new->{root}, $dot, $old->{root}) &&
	      push (@workq, [ 'p', $old->{root}, -s $old->{root},
			      (stat($new->{root}))[9], (stat(_))[2] ]);
	}
	else {
	    unshift (@workq, [ 'r', $old->{root}, -s $old->{root}, 0 ]);
	}
    }
    elsif ( -d $old->{root} && -f $new->{root} ) {
	# Dir and file -> Dir/file and file.
	$old->{root} = $old->{base} = catfile ($old->{root}, $new->{root});
        verbose ("Old file = $old->{root}.\n", "New file = $new->{root}.\n");
	if ( -f $old->{root} ) {
	    dodiff ($dot, $new->{root}, $dot, $old->{root}) &&
	      push (@workq, [ 'p', $old->{root}, -s $old->{root},
			      (stat($new->{root}))[9], (stat(_))[2] ]);
	}
	else {
	    newfile ($new->{root}, $old->{root}) &&
	      push (@workq, [ 'c', $old->{root}, 0,
			      (stat($new->{root}))[9], (stat(_))[2] ]);
	}
    }
    elsif ( -d $old->{root} && -d $new->{root} ) {
	# Two directories.
	if ( $opt_nomanifest ) {
	    verbose ("Not using MANIFEST files.\n");
	    undef $opt_oldmanifest;
	    undef $opt_newmanifest;
	}
	elsif ( defined $opt_automanifest &&
		!(defined $opt_oldmanifest || defined $opt_newmanifest) &&
		 (-s catfile($old->{root}, $opt_automanifest) &&
		  -s catfile($new->{root}, $opt_automanifest)) ) {
	    verbose ("Using standard $opt_automanifest files.\n");
	    $opt_oldmanifest = catfile($old->{root},$opt_automanifest);
	    $opt_newmanifest = catfile($new->{root},$opt_automanifest);
	    $new->{man} = $old->{man} = $opt_automanifest;
	    $old->{manfn} = $opt_oldmanifest;
	    $new->{manfn} = $opt_newmanifest;
	}
	else {
	    $old->{man} = $old->{manfn} = $opt_oldmanifest;
	    $new->{man} = $new->{manfn} = $opt_newmanifest;
	}

	for ( $old, $new ) {
	    if ( defined ($_->{manfn}) ) {
		my $t = $_->{name} eq $dot ? "current directory" :
		  $_->{name} eq $dotdot ? "parent directory" : $_->{base};
		$_->{files} = [ make_filelist_from_manifest ($_->{manfn}) ];
		message ("Manifest $_->{man} for $t contains ",
			 scalar(@{$_->{files}}), " file",
			 scalar(@{$_->{files}}) == 1 ? "" : "s", ".\n");
	    }
	    else {
		my $t = $_->{name} eq $dot ? "current directory" :
		  $_->{name} eq $dotdot ? "parent directory" :
		    "directory $_->{base}";
		message ("Building file list for $t ...\n");
		$_->{files} = [ make_filelist ($_->{root}) ];
		message (ucfirst($t)." contains ",
			 scalar(@{$_->{files}}), " file",
			 scalar(@{$_->{files}}) == 1 ? "" : "s", ".\n");
	    }
	}

	# Handle patchlevel file first.
	$opt_patchlevel = (grep (/patchlevel\.h/, @{$new->{files}}))[0]
	    unless defined $opt_patchlevel;

	if ( defined $opt_patchlevel && $opt_patchlevel ne "" ) {
	    my $oldpl = catfile ($old->{root}, $opt_patchlevel);
	    my $newpl = catfile ($new->{root}, $opt_patchlevel);
	    if ( ! -f $newpl ) {
		die ("$newpl: $!\n");
	    }
	    if ( -f $oldpl ) {
		push (@workq, [ dodiff ($new->{root}, $opt_patchlevel,
					$old->{root}, $opt_patchlevel) ? 'p' : 'v',
				$opt_patchlevel,
				-s $oldpl,
				(stat($newpl))[9], (stat(_))[2] ]);
		# Remove patchlevel.h from the list of old files.
		$old->{files} = [ grep ($_ ne $opt_patchlevel, @{$old->{files}}) ];
	    }
	    else {
		newfile ($new->{root}, $opt_patchlevel) &&
		  push (@workq, [ 'c', $opt_patchlevel, 0,
				  (stat($newpl))[9], (stat(_))[2] ]);
	    }
	    # Remove patchlevel.h from the list of new files.
	    $new->{files} = [ grep ($_ ne $opt_patchlevel, @{$new->{files}}) ];
	}
	else {
	    undef $opt_patchlevel;
	}

        my $o;
        my $n;

	message ("Processing the filelists ...\n");
	while ( scalar(@{$old->{files}}) + scalar(@{$new->{files}}) > 0
		|| defined $o || defined $n ) {

	    $o = shift (@{$old->{files}}) unless defined $o;
	    $n = shift (@{$new->{files}}) unless defined $n;

	    debug ("* ", $o || "(undef)", " <-> ", $n || "(undef)", " ",
		   "* $old->{files}->[0] <-> $new->{files}->[0]\n") if $opt_debug;
	    if ( defined $n && (!defined $o || $o gt $n) ) {
		# New file.
		debug ("*> New file: $n\n");
		newfile ($new->{root}, $n) &&
		  push (@workq, [ 'c', $n, 0,
				  (stat(catfile($new->{root},$n)))[9],
				  (stat(_))[2] ]);
		undef $n;
	    }
	    elsif ( !defined $n || $o lt $n ) {
		# Obsolete (removed) file.
		debug ("*> Obsolete: $o\n");
		unshift (@workq, [ 'r', $o, -s catfile($old->{root},$o), 0 ]);
		undef $o;
	    }
	    elsif ( $o eq $n ) {
		# Same file.
		debug ("*> Compare: $n\n");
		dodiff ($new->{root}, $n, $old->{root}, $o) &&
		  push (@workq, [ 'p', $o, -s catfile($old->{root},$o),
				  (stat(catfile($new->{root},$n)))[9],
				  (stat(_))[2] ]);
		undef $n;
		undef $o;
	    }
	}
    }
    else {
	$patch->close;
	app_usage (1);
    }

    $patch->close;

    # For the sake of memory usage...
    undef $old->{files};
    undef $new->{files};
}

sub cleanup () {
    return unless defined $tmpdir;
    return unless -d $tmpdir;
    verbose ("Cleaning up...\n");
    rmtree ($tmpdir);
    die ("Okay\n") if $opt_test;
    exit (0);
}

sub shellpat($) {
    my ($pat) = (@_);
    my @a = split (/(\[[^\]]+\]|[*.?])/, $pat);
    join ('',
	  (map { ($_ eq '*' ? '.*' :
		  ($_ eq '?' ? '.' :
		   ($_ eq '.' ? '\.' :
		    ($_ =~ /^\[/ ? $_ : quotemeta ($_)))))
	     } @a));
}

sub setup_excludes () {
    # Add --exclude wildcards to --exclude-regex list.
    if ( @opt_exclude ) {
	my $pat;
	foreach $pat ( @opt_exclude ) {
	    push (@opt_exclude_regex, '(\A|/)'.shellpat($pat).'\Z');
	}
    }

    # Build regex from --exclude-regex list.
    if ( @opt_exclude_regex ) {
	$exclude_pat = '(';
	my $re;
	foreach $re ( @opt_exclude_regex ) {
	    verbose ("  Exclude regex: ", $re, "\n");
	    eval { '' =~ /$re/ };
	    if ( $@ ) {
		$@ =~ s/ at .* line.*$//;
		die ("Invalid regex: $re $@");
	    }
	    $exclude_pat .= "($re)|";
	}
	chop ($exclude_pat);
	$exclude_pat .= ')';
	debug ("Exclude pattern: $exclude_pat\n");
    }
}

sub cvs_ignore($) {
    my ($f) = @_;
    my $fh = do { local *F; *F; };
    unless ( open($fh, $f) ) {
	warn("$f: $!\n");
	return ();
    }
    local($/) = undef;
    my $pat = <$fh>;
    close($fh);

    $pat =~ s/[\n\r]+/\n/g;
    $pat =~ s/\s+$//;
    $pat =~ s/^\s+//;
    split(/\n/, $pat);
}

sub cvs_excludes($$$) {
    my ($f, $dir, $disp) = @_;

    my @list = cvs_ignore($f);
    return "" unless @list;

    for ( $dir, $disp ) {
	$_ = "" unless defined $_;
	$_ .= '/' if $_ && $_ !~ /\/$/;
	$_ = '\A' . quotemeta($_);
    }

    my $ret = "";
    foreach my $pat ( @list ) {
	my $re = shellpat($pat);
	debug ("$f: '$pat' -> '$re'\n");
	eval { '' =~ /$re/ };
	if ( $@ ) {
	    $@ =~ s/ at .* line.*$//;
	    warn("$f: invalid pattern '$pat'");
	    next;
	}
	push(@opt_exclude_regex, $dir.$re.'\Z');
	$ret .= "($re)|";
    }
    if ( $ret ) {
	chop($ret);
	$ret = '('.$disp.'('.$ret.')\Z)';
    }
    debug ("Exclude pattern ($f): $ret\n");
    $ret;
}

sub make_filelist ($;$) {
    my ($dir, $disp) = @_;

    # Return a list of files, sorted, for this directory.
    # Recurses if $opt_recurse.

    my $dh = new IO::File;
    trace ("+ recurse $dir\n");
    opendir ($dh, $dir) || die ("$dir: $!\n");
    my @tmp = readdir ($dh);
    closedir ($dh);
    debug ("Dir $dir: ", scalar(@tmp), " entries\n");

    my @ret = ();
    my $file;
    my $excl = $exclude_pat;
    for ( catfile($dir, ".cvsignore") ) {
	$excl = '('.$excl.'|'.cvs_excludes($_,$dir,$disp).')' if -s $_;
	debug("Exclude pattern: $excl\n");
    }
    foreach $file ( @tmp ) {

	# Skip unwanted files.
	next if $file =~ /^\.\.?$/; # dot and dotdot
	next if $file =~ /~$/;	# editor backup files

        my $realname = catfile ($dir, $file);
        my $display_name = defined $disp ? catfile($disp,$file) : $file;

        # Skip exclusions.
        if ( defined $excl && $display_name =~ /$excl/mso ) {
          verbose ("Excluding $display_name\n");
	  $excluded++;
          next;
        }

	# Push on the list.
	if ( -d $realname && ( $opt_follow || ! -l $realname ) ) {
	    next unless $opt_recurse;
	    # Recurse.
	    push (@ret, make_filelist ($realname, $display_name));
	}
	elsif ( -f _ ) {
	    debug("+ file $display_name\n");
	    push (@ret, $display_name);
	}
	else {
	    verbose ("WARNING: Not a file: $realname -- skipped\n");
	    $skipped++;
	}
    }
    @ret = sort @ret if $opt_sort;
    @ret;
}

sub make_filelist_from_manifest ($) {

    # Return a list of files, optionally sorted, from a manifest file.

    my ($man) = @_;
    my $fh = new IO::File;
    my @ret = ();
    local ($_);

    $fh->open($man) || die ("$man: $!\n");
    binmode($fh);
    while ( <$fh> ) {
	if ( $. == 2 && /^[-=_\s]*$/ ) {
	    @ret = ();
	    next;
	}
	next if /^#/;
	next unless /\S/;
	$_ = $1 if /^(\S+)\s/;
        if ( defined $exclude_pat && /$exclude_pat/mso ) {
	    verbose ("Excluding $_\n");
	    $excluded++;
	    next;
        }
	push (@ret, $_);
    }
    $fh->close;
    @ret = sort @ret if $opt_sort;
    @ret;
}

sub check_extract ($) {
    my ($arg) = @_;

    my @exctrl = ('.+\.(tar\.gz|tgz)' => "gzip -d | tar xpf -",
		  '.+\.(tar\.bz2)'    => "bzip2 -d | tar xpf -",
		  '.+\.(tar)'         => "tar xf -",
		  '.+\.(zip)'         => "unzip -",
		 );

    # Plug in user defined rules.
    if ( %opt_extract ) {
	my ($k, $v);
	while ( ($k,$v) = each (%opt_extract) ) {
	    unshift (@exctrl, $v);
	    unshift (@exctrl, $k);
	}
    }

    $arg->{root} = File::Spec->canonpath ($arg->{name});
    my $base = basename ($arg->{root});

    while ( @exctrl > 0 ) {
	my $pat = shift (@exctrl);
	my $cmd = shift (@exctrl);
	if ( $base =~ /^$pat$/is ) {
	    extract ($arg, $cmd);
	    verbose ("Using $arg->{root} for $arg->{name}\n")
	      unless $arg->{root} eq $arg->{name};
	    return;
	}
    }
    $arg->{root} = $arg->{base} = $arg->{name};
}

sub extract ($$) {
    my ($arg, $cmd) = @_;

    my $tmp = catfile ($tmpdir, $arg->{tag});
    message ("Extracting $arg->{name} to $tmp...\n");

    # Create a temp directory.
    mkdir ($tmp, 0777) || die ("Cannot mkdir $tmp [$!]\n");

    # Extract the kit.
    $cmd = "( cd $tmp; $cmd ) < $arg->{name}";
    trace ("+ $cmd\n");
    my $ret = system ("$cmd 1>&2");
    if ( $ret || ($? & 127) ) {
	die ("Not okay 1\n") if $opt_test;
	exit (1);
    }

    # Inspect the directory.
    my $dir = new IO::File;
    opendir ($dir, $tmp) || die ("Cannot read $tmp [$!]\n");
    my @files = grep ($_ !~ /^\.+$/, readdir ($dir));
    closedir ($dir);

    # If we have only one directory, assume it is the root.
    if ( @files == 1 && -d catfile($tmp,$files[0]) ) {
	$arg->{base} = $files[0];
	$arg->{root} = catfile($tmp,$files[0]);
	return;
    }
    # Else, take the temp dir as root.
    $arg->{root} = $tmp;
    $arg->{base} = $arg->{name};
}

sub catfile ($$) {
    File::Spec->canonpath(File::Spec->catfile(@_));
}

sub dot_file_u ($) {
   $_[0] =~ s,\\,/,g if $^O =~ /^MSWin/i;
   File::Spec::Unix->catfile($dot_u, File::Spec::Unix->canonpath(@_));
}

sub dodiff ($$$$) {
    my ($newdir, $new, $olddir, $old) = @_;
    my $fh = new IO::File;
    my $oldfn = catfile ($olddir, $old);
    my $newfn = catfile ($newdir, $new);

    # Check for binary files.
    if ( -s $oldfn && -B _ ) {
	verbose ("WARNING: Binary file $oldfn -- skipped\n");
	$skipped++;
	return 0;
    }
    if ( -s $newfn && -B _ ) {
	verbose ("WARNING: Binary file $newfn -- skipped\n");
	$skipped++;
	return 0;
    }

    # Produce a patch hunk.
    my $cmd = $opt_diff . ' ' . quotfn($oldfn) . ' ' . quotfn($newfn);
    trace ("+ ", $cmd, "\n");

    my $result = system ("$cmd > $tmpfile");
    debug  (sprintf ("+> result = 0x%x\n", $result)) if $result;

    if ( $result && $result < 128 ) {
	wrapup (($result == 2 || $result == 3)
		? "User request" : "System error");
	die ("Not okay 2\n") if $opt_test;
	exit (1);
    }
    return 0 unless $result == 0x100;	# no diffs
    print $patch ($cmd, "\n");

    # Add output from user defined file information command.
    if ( defined $opt_infocmd ) {
	my $cmd = $opt_infocmd;
	$cmd =~ s/\002P/$oldfn/eg;
	$cmd =~ s/\003P/$newfn/eg;
	print $patch (`$cmd`);
    }

    # By prepending $dot to the names, we can use 'patch -p0' as well
    # as 'patch -p1'.
    print $patch ("Index: ", dot_file_u($old), "\n");

    # Try to find a prereq.
    # The RCS code is based on a suggestion by [e-mail], who also
    # pointed out that patch requires blanks around the prereq string.
    if ( $fh->open($oldfn) ) {
	binmode($fh);
	while ( <$fh> ) {
	    next unless (/(\@\(\#\)\@?|\$Header\:|\$Id\:)(.*)$/);
	    next unless $+ =~ /(\s\d+(\.\d+)*\s)/; # e.g. 5.4
	    print $patch ("Prereq: $1\n");
	    last;
	}
	$fh->close;
    }
    else {
	warn ("$oldfn: $!\n");
    }

    # Copy patch.
    $fh->open($tmpfile) || die ("$tmpfile: $!\n");
    binmode($fh);

    # Skip to beginning of patch. Adjust $unified if needed.
    my $found = 0;
    while ( <$fh> ) {
	if ( /^\@\@/ ) {
	    $unified = 1;
	    $found = 1;
	    last;
	}
	elsif ( /^\*{15}/ ) {
	    $unified = 0;
	    $found = 1;
	    last;
	}
    }
    unless ( $found ) {
	die ("ALARM: No patch data found for $old\n",
	     "Something is wrong with your diff command \"$opt_diff\".\n",
	     "It should produce context or unified diff output.\n");
    }

    # Replace patch header.
    if ( $unified ) {
	print $patch ("--- ", dot_file_u($old),
		      "\t" . localtime((stat($oldfn))[9]), "\n",
		      "+++ ", dot_file_u($new),
		      "\t" . localtime((stat($newfn))[9]), "\n",
		      $_);
    }
    else {
	print $patch ("*** ", dot_file_u($old),
		      "\t" . localtime((stat($oldfn))[9]), "\n",
		      "--- ", dot_file_u($new),
		      "\t" . localtime((stat($newfn))[9]), "\n",
		      $_);
    }

    # Copy rest.
    print $patch ($_) while <$fh>;
    print "\n";			# just in case
    $fh->close;

    return 1;
}

sub newfile ($$) {

    # In-line production of what diff would have produced.

    my ($newdir, $new) = @_;
    my $fh = new IO::File;
    my $newfn = catfile ($newdir, $new);

    my $lines = 0;
    unless ( $fh->open($newfn) ) {
	warn ("$newfn: $!\n");
	$skipped++;
	return 0;
    }
    binmode($fh);
    # We cannot trust stdio here.
    if ( -s $newfn && -B _ ) {
	verbose ("WARNING: Binary file $new -- skipped\n");
	$skipped++;
	return 0;
    }

    my $pos = $fh->getpos;
    while ( <$fh> ) {
	$lines++;
    }
    $fh->setpos($pos);

    # Avoid creating a patch if the new file is empty.
    if ($lines == 0) {
      return 1;
    }

    my $cmd = $opt_diff . " " . $DEVNULL . " " . quotfn($newfn);
    trace ("+ $cmd (inlined)\n");
    print $patch ($cmd, "\n");

    # Add output from user defined file information command.
    if ( defined $opt_infocmd ) {
	my $cmd = $opt_infocmd;
	$cmd =~ s/\002P/$newfn/eg;
	$cmd =~ s/\003P/$newfn/eg;
	print $patch (`$cmd`);
    }

    # Prepending $dot, so we can use 'patch -p0' as well as 'patch -p1'.
    $new = dot_file_u($new);

    print $patch ("Index: $new\n");

    $lines = "1,$lines" unless $lines == 1;

    if ( $unified ) {
	print $patch ("--- ", $new, "\t" . localtime(0), "\n",
		      "+++ ", $new, "\t" . localtime((stat($fh))[9]), "\n",
		      "\@\@ -0,0 +", $lines, " \@\@\n");
	while ( <$fh> ) {
	    print $patch ("+$_");
	}
    }
    else {
	print $patch ("*** ", $new, "\t" . localtime(0), "\n",
		      "--- ", $new, "\t" . localtime((stat($fh))[9]), "\n",
		      "***************\n",
		      "*** 0 ****\n",
		      "--- ", $lines, " ----\n");
	while ( <$fh> ) {
	    print $patch ("+ $_");
	}
    }

    $fh->close;
    return 1;
}

sub remove_file ($$) {
    #  diff -c -N -r t1/f2 t2/f2
    #  *** t1/f2       Tue Jul  7 21:28:45 1992
    #  --- t2/f2       Thu Jan  1 01:00:00 1970
    #  ***************
    #  *** 1,1 ****
    #  - foo
    #  - bar
    #  --- 0 ----

    #  diff -u -N -r t1/f2 t2/f2
    #  --- t1/f2       Tue Jul  7 21:28:45 1992
    #  +++ t2/f2       Thu Jan  1 01:00:00 1970
    #  @@ -1,1 +0,0 @@
    #  -foo
    #  -bar
}

sub quotfn ($) {
    my ($file) = @_;
    # Protect file name.
    $file =~ s/`/\\`/g;
    ($^O =~ /^MSWin/i) ? "\"$file\"" : "'$file'";
}

sub wrapup (;$) {
    my ($reason) = @_;

    if ( defined $reason ) {
	warn ("*** Aborted: $reason ***\n");
	return;
    }

    warn ("WARNING: $skipped file",
	  $skipped == 1 ? " was" : "s were", " skipped!",
	  $opt_verbose ? "" : " Use \"--verbose\" for more details.",
	  "\n") if $skipped;

    # Construct a description, if possible.
    if ( @opt_descr == 0 ) {
	my $old = $old->{base};
	my $new = $new->{base};
	# We can infer a name if the file name does not contain a
	# directory part, and is not equal to . or ..
	if ( $old ne $dot && $old ne $dotdot && basename($old) eq $old &&
	     $new ne $dot && $new ne $dotdot && basename($new) eq $new
	   ) {
	    @opt_descr = ("This is a patch for $old to update it to $new");
	}
    }

    # Get a description, unless provided.
    if ( @opt_descr == 0 ) {
	print STDERR ("Enter patch description, ",
		      "terminated with a single '.':\n>> ");
	while (  ) {
	    chomp;
	    last if $_ eq ".";
	    push (@opt_descr, $_);
	    print STDERR (">> ");
	}
	print STDERR ("\n") unless $_ eq ".";
    }
    push (@opt_descr, "");

    message ("Collecting patches ...\n");

    my $removed = 0;		# files removed
    my $created = 0;		# files added
    my $patched = 0;		# files patched
    my $dremoved = 0;		# directories removed
    my $dcreated = 0;		# directories created

    {	my @goners = ();
	my %dir_gone = ();
	my @newcomers = ();
	my %dir_ok = ();
	foreach ( @workq ) {
	    my ($op, $fn) = @$_;
	    push (@newcomers, $fn) if $op eq 'c';
	    push (@goners, $fn) if $op eq 'r';
	    $patched++ if $op eq 'p';
	}
	$created = @newcomers;
	$removed = @goners;
	foreach ( sort @goners ) {
	    # WARNING: This code assumes you are running some Unix.
	    my @p = split (/\//, $_);
	    pop (@p);
	    foreach my $i ( (1-@p)..0 ) {
		my $dir = join('/',@p[0..-$i]);
		unless ( defined $dir_gone{$dir} ) {
		    unless ( -d catfile($new->{root},$dir) ) {
			$dremoved++;
			$dir_gone{$dir} = 1;
		    }
		}
	    }
	}
	foreach ( reverse sort keys %dir_gone ) {
	    push (@workq, [ 'R', $_ ]);
	}
	foreach ( sort @newcomers ) {
	    # Explicitly create the new files since not all patch versions
	    # can handle creating new files.
	    # Create intermediate directories first.
	    # WARNING: This code assumes you are running some Unix.
	    my @p = split (/\//, $_);
	    pop (@p);
	    foreach my $i ( 0..(@p-1) ) {
		my $dir = join('/',@p[0..$i]);
		unless ( defined $dir_ok{$dir} ) {
		    unless ( -d catfile($old->{root},$dir) ) {
			push (@workq, [ 'C', $dir, 0,
					(stat(catfile($new->{root},$dir)))[9],
					(stat(_))[2] ]);
			$dcreated++;
		    }
		    $dir_ok{$dir} = 1;
		}
	    }
	}
    }

    my $fh = new IO::File;
    $fh->open(">$tmpfile") || die ("$tmpfile: $!\n");
    binmode($fh);

    foreach ( @opt_descr ) {
	print $fh ("# ", $_, "\n");
    }
    print $fh <
# To apply this patch:
# STEP 1: Chdir to the source directory.
# STEP 2: Run the 'applypatch' program with this patch file as input.
#
# If you do not have 'applypatch', it is part of the 'makepatch' package
# that you can fetch from the Comprehensive Perl Archive Network:
# http://www.perl.com/CPAN/authors/Johan_Vromans/makepatch-x.y.tar.gz
# In the above URL, 'x' should be 2 or higher.
#
# To apply this patch without the use of 'applypatch':
# STEP 1: Chdir to the source directory.
EOD
    if ( $removed || $created ) {
	my $cd = "";
	my $fd = "";
	$cd = "create" if $created;
	if ( $removed ) {
	    $cd .= "/" if $cd;
	    $cd .= "delete";
	}
	$fd = "files";
	if ( $dcreated || $dremoved ) {
	    $fd .= "/" if $fd;
	    $fd .= "directories";
	}
	print $fh <
# If you have a decent Bourne-type shell:
# STEP 2: Run the shell with this file as input.
# If you don't have such a shell, you may need to manually $cd
# the $fd as shown below.
# STEP 3: Run the 'patch' program with this file as input.
#
# These are the commands needed to create/delete files/directories:
#
EOD
	foreach ( @workq ) {
	    my ($op, $file, @args) = @$_;
	    if ( $op eq 'C' ) {
		print $fh ("mkdir ", quotfn($file), "\n");
		if ( defined $args[2] && ($args[2] &= 0777) ) {
		    printf $fh ("chmod 0%o %s\n", $args[2], quotfn($file))
		}
	    }
	}
	foreach ( @workq ) {
	    my ($op, $file, @args) = @$_;
	    if ( $op eq 'r' ) {
		print $fh ("rm -f ", quotfn($file), "\n");
	    }
	    elsif ( $op eq 'R' ) {
		print $fh ("rmdir ", quotfn($file), "\n");
	    }
	    elsif ( $op eq 'c' ) {
		print $fh ("touch ", quotfn($file), "\n");
		if ( defined $args[2] && ($args[2] &= 0777) ) {
		    printf $fh ("chmod 0%o %s\n", $args[2], quotfn($file))
		}
	    }
	}
	print $fh <
#
# This command terminates the shell and need not be executed manually.
exit
#
EOD
    }
    else {
	print $fh <
# STEP 2: Run the 'patch' program with this file as input.
#
EOD
    }
    print $fh <
#### End of Preamble ####

#### Patch data follows ####
EOD
    # Copy patch.
    $patch->open($thepatch);
    binmode($patch);
    while ( <$patch> ) {
	print $fh $_;
    }
    $patch->close;

    # Print a reassuring "End of Patch" note so people won't
    # wonder if their mailer truncated patches.
    print $fh ("#### End of Patch data ####\n\n",
	       "#### ApplyPatch data follows ####\n",
	       "# Data version        : $data_version\n",
	       "# Date generated      : $timestamp\n",
	       "# Generated by        : $my_name $my_version\n");
    print $fh ("# Recurse directories : Yes\n") if $opt_recurse;
    print $fh ("# Excluded files      : ",
	       join("\n#                       ", @opt_exclude_regex), "\n")
      if @opt_exclude_regex;

    foreach ( @workq ) {
	my ($op, $file, @args) = @$_;
	$file = quotfn ($file);
	print $fh ("# ", $op, " ", $file);
	if ( defined ($args[2]) && ($op eq 'c' || $op eq 'C' || $op eq 'p') ) {
	    $args[2] = sprintf ("0%o", $args[2]);
	}
	print $fh (" ", join(" ", @args)) if @args;
	print $fh ("\n");
    }

    print $fh ("#### End of ApplyPatch data ####\n");
    print $fh ("\n#### End of Patch kit [created: $timestamp] ####\n");
    $fh->close;

    # Checksum calculation.
    # Two checksums are calculated: one for the whole file (for compatibilty),
    # and one for just the patch data (so the preamble can be modified).
    my $lines = 0;
    my $bytes = 0;
    my $sum = 0;
    my $all_lines = 0;
    my $all_bytes = 0;
    my $all_sum = 0;
    $fh->open ($tmpfile) || die ("$tmpfile: $!\n");
    binmode($fh);
    binmode(STDOUT);
    while ( <$fh> ) {
	$lines = $bytes = $sum = 0
	  if /^#### Patch data follows ####/;
	chomp;
	$_ .= "\n";
	$lines++;
	$all_lines++;
	$bytes += length ($_);
	$all_bytes += length ($_);
	# System V 'sum' checksum
	$sum = ($sum + unpack ("%16C*", $_)) % 65535;
	$all_sum = ($all_sum + unpack ("%16C*", $_)) % 65535;
	print STDOUT ($_);
    }
    $fh->close;

    # Checksum info for the patch data.
    $_ = "#### Patch checksum: $lines $bytes $sum ####\n";
    print STDOUT ($_);
    $all_lines++;
    $all_bytes += length ($_);
    $all_sum = ($all_sum + unpack ("%16C*", $_)) % 65535;

    # Overall checksum info.
    print STDOUT ("#### Checksum: $all_lines $all_bytes $all_sum ####\n");

    message ("  $patched file",
	     $patched == 1 ? "" : "s", " need to be patched.\n");
    if ( $created ) {
	message ("  $created file", $created == 1 ? "" : "s");
	message (" and $dcreated director",
		 $dcreated == 1 ? "y" : "ies") if $dcreated;
	message (" need", ($created+$dcreated != 1) ? "" : "s",
		 " to be created.\n");
    }
    if ( $removed ) {
	message ("  $removed file", $removed == 1 ? "" : "s");
	message (" and $dremoved director",
		 $dremoved == 1 ? "y" : "ies") if $dremoved;
	message (" need", ($removed+$dremoved != 1) ? "" : "s",
		 " to be removed.\n");
    }
    message ("  $excluded file",
	  $excluded == 1 ? " was" : "s were", " excluded.\n") if $excluded;
}

sub filelist ($) {
    my ($man) = @_;
    my @new = make_filelist_from_manifest ($man);
    foreach ( @new ) {
	print STDOUT ($opt_prefix, $_, "\n");
    }
}

sub app_options () {
    my $opt_manifest;
    my $opt_help = 0;
    my $opt_ident = 0;
    my $opt_rcfile;

    my @o = (
	     "automanifest=s"		=> \$opt_automanifest,
	     "debug!"			=> \$opt_debug,
	     "description=s@"		=> \@opt_descr,
	     "diff=s"			=> \$opt_diff,
	     "exclude-regex=s@"     	=> \@opt_exclude_regex,
	     "exclude-standard!"	=> \$opt_exclude_standard,
	     "exclude-rcs!"		=> \$opt_exclude_rcs,
	     "exclude-sccs!"		=> \$opt_exclude_sccs,
	     "exclude-cvs!"		=> \$opt_exclude_cvs,
	     "exclude-vc!"		=> sub { $opt_exclude_rcs =
						 $opt_exclude_cvs =
						 $opt_exclude_sccs = $_[1] },
	     "exclude=s@"	     	=> \@opt_exclude,
	     "extract=s%"		=> \%opt_extract,
	     "filelist|list!"		=> \$opt_filelist,
	     "follow!"			=> \$opt_follow,
	     "help"                 	=> \$opt_help,
	     "ident!"			=> \$opt_ident,
	     "ignore-cvs-keywords|ignore-rcs-keywords!"
					=> \$opt_ignore_rcs_keywords,
	     "infocmd=s"		=> \$opt_infocmd,
	     "manifest=s"		=> \$opt_manifest,
	     "newmanifest=s"		=> \$opt_newmanifest,
	     "nomanifest!"		=> \$opt_nomanifest,
	     "oldmanifest=s"		=> \$opt_oldmanifest,
	     "patchlevel=s"		=> \$opt_patchlevel,
	     "prefix=s"			=> \$opt_prefix,
	     "quiet!"			=> \$opt_quiet,
	     "sort!"			=> \$opt_sort,
	     "recurse!"			=> \$opt_recurse,
	     "test"			=> \$opt_test,
	     "trace!"			=> \$opt_trace,
	     "verbose!"			=> \$opt_verbose,
	    );

    my $init;

    # Process ENV options.
    if ( defined ($init = $ENV{MAKEPATCHINIT}) ) {
	require Text::ParseWords;
	local (@ARGV) = Text::ParseWords::shellwords ($init);
	unless ( GetOptions (@o, "rcfile=s" => \$opt_rcfile) &&
		 @ARGV == 0 ) {
	    warn ("Error in MAKEPATCHINIT\n");
	    app_usage (1);
	}
	else {
	    trace ("+ INIT: $init\n");
	}
    }

    unless ( $opt_test ) {
	# Process ini file options.
	# First, try system wide file. Unix specific.
	app_parse_rc ("/etc/makepatchrc", 1, \@o);
	my $rcname = ".".$my_name."rc";
	# Then, try HOME .rc.
	app_parse_rc (catfile ($HOME, $rcname), 1, \@o);
	# Then try --rcfile, defaulting to .rc in current dir.
	if ( defined $opt_rcfile ) {
	    app_parse_rc ($opt_rcfile, 0, \@o);
	}
	else {
	    app_parse_rc (catfile ($dot, $rcname), 1, \@o);
	}
    }

    # Process command line options
    if ( !GetOptions (@o) || $opt_help ) {
	app_usage (1);
    }

    # Argument check.
    if ( $opt_filelist ) {
	if ( defined $opt_manifest ) {
	    app_usage (1) if @ARGV;
	    @ARGV = ( $opt_manifest );
	}
	else {
	    app_usage (1) unless @ARGV == 1;
	}
    }
    else {
	app_usage (1) unless @ARGV == 2;
    }

    $opt_trace = 1 if $opt_debug;

    print STDERR ("This is $my_name version $my_version\n")
      if $opt_verbose || $opt_ident;

    if ( $opt_prefix ne '' ) {
	die ("$0: option \"-prefix\" requires \"-filelist\"\n")
	  unless $opt_filelist;
    }

    if ( defined $opt_sort ) {
	die ("$0: option \"-[no]sort\" requires \"-filelist\"\n")
	  unless $opt_filelist;
    }
    else {
	$opt_sort = 1;
    }

    if ( $opt_filelist ) {
	die ("$0: option \"-filelist\" only uses \"-manifest\"\n")
	  if defined $opt_oldmanifest || defined $opt_newmanifest;
    }

    if ( defined $opt_manifest ) {
	die ("$0: do not use \"-manifest\" with \"-oldmanifest\"".
	     " or \"-newmanifest\"\n")
	  if defined $opt_newmanifest || defined $opt_oldmanifest;
	$opt_newmanifest = $opt_oldmanifest = $opt_manifest;
    }

    if ( defined $opt_infocmd ) {
	die ("$0: \"-infocmd\" can not be used with \"-filelist\"\n")
	  if $opt_filelist;
	# Protect %% sequences.
	$opt_infocmd =~ s/\%\%/\001/g;
	# Encode %o and %n sequences.
	$opt_infocmd =~ s/\%o([P])/\002$1/g;
	$opt_infocmd =~ s/\%n([P])/\003$1/g;
	# Restore %% sequences.
	$opt_infocmd =~ s/\001/%%/g;
	while ( $opt_infocmd =~ /(\%[on]\S)/g ) {
	    warn ("Warning: $1 in info command may become ",
		  "special in the future\n");
	}
    }

    $opt_verbose = 0 if $opt_quiet;
    $opt_trace ||= $opt_debug;
    $opt_verbose ||= $opt_trace;
}

sub app_parse_rc ($$$) {
    my ($file, $opt, $optref) = @_;

    my $rcfile = new IO::File;
    unless ( $rcfile->open($file) ) {
	die ("$file: $!\n") unless $opt;
	return;
    }

    require Text::ParseWords;

    local (@ARGV);
    my $ok = 1;

    # Intercept Getopt::Long warning messages.
    my $warn;
    $SIG{__WARN__} = sub { $warn = "@_"; };

    # Process the file.
    while ( <$rcfile> ) {
	# Skip blank and comment lines.
	next if /^\s*[;#]/;
	next unless /\S/;

	# Split.
	my @a = Text::ParseWords::shellwords ($_);
	$warn = '';
	trace ("+ RC: @a\n");
	# Handle.
	@ARGV = @a;
	unless ( GetOptions (@$optref) ) {
	    chomp ($warn);
	    print STDERR ("$warn -- at line $. in $file\n");
	    $ok = 0;
	}
	if ( @ARGV > 0 ) {
	    print STDERR ("Garbage \"@ARGV\"",
			  " -- at line $. in $file\n");
	    $ok = 0;
	}
    }
    $rcfile->close;
    $SIG{__WARN__} = 'DEFAULT';
    unless ( $ok ) {
	app_usage (1);
    }
    $ok;
}

sub app_usage ($) {
    my ($exit) = @_;
    print STDERR <
This is $my_name version $my_version

Usage: $0 [options] old-src new-src

Makepatch options:
   -description XXX	descriptive message about this patch
   -diff cmd		diff command to use, default \"$opt_diff\"
   -patchlevel file	file to use as patchlevel.h
   -man[ifest] file	list of files for old and new dir, defaults to $opt_automanifest
   -nomanifest		suppress use of MANIFEST files
   -automan[ifest] XXX	assumend name for MANIFEST files
   -newman[ifest] file	list of files for new dir
   -oldman[ifest] file	list of files for old dir
   -follow		follow symbolic links
   -infocmd cmd		add output of cmd to each patch chunk
   -exclude pat         exclude files according to wildcard pattern
   -exclude-regex pat   exclude files and dirs matching regex pattern
   -exclude-vc          exclude version control files (RCS, CVS, SCCS)
   -exclude-rcs         exclude version control files for RCS
   -exclude-cvs         exclude version control files for CVS
   -exclude-sccs        exclude version control files for SCCS
   -ignore-cvs-keywords ignore diffs in CVS keyword data (same as RCS)
   -ignore-rcs-keywords ignore diffs in RCS keyword data (same as CVS)
   -extract PAT=RULE	define an archive extraction rule
   -[no]recurse         recurse through directories (default)
   -verbose		verbose progress information
   -quiet		no progress information
   -help		this message
EoU
    die ("Not okay 99\n") if $opt_test;
    exit $exit if defined $exit && $exit != 0;
}

sub app_usage_filelist ($) {
    my ($exit) = @_;
    print STDERR <
This is $my_name version $my_version

Usage: $0 -filelist [ options ] [ -manifest ] file

Filelist options:
   -[file]list		extract filenames from manifest file
   -prefix XXX		add a prefix to these filenames
   -nosort		do not sort manifest entries
   -man[ifest] file	list of files
   -exclude pat         exclude files according to wildcard pattern
   -exclude-regex pat   exclude files and dirs matching regex pattern
   -exclude-vc          exclude version control files (RCS, CVS, SCCS)
   -exclude-rcs         exclude version control files for RCS
   -exclude-cvs         exclude version control files for CVS
   -exclude-sccs        exclude version control files for SCCS
   -verbose		verbose output (default)
   -quiet		no verbose output
   -help		this message
EoU
    die ("Not okay 99\n") if $opt_test;
    exit $exit if defined $exit && $exit != 0;
}

1;

__END__