Alt-App-makepatch
view release on metacpan or search on metacpan
script/makepatch view on Meta::CPAN
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);
script/makepatch view on Meta::CPAN
}
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 jima@netcom.com, 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");
script/makepatch view on Meta::CPAN
"terminated with a single '.':\n>> ");
while ( <STDIN> ) {
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 <<EOD;
# 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 <<EOD;
# 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))
}
}
}
( run in 0.574 second using v1.01-cache-2.11-cpan-39bf76dae61 )