Alt-App-makepatch
view release on metacpan or search on metacpan
script/makepatch view on Meta::CPAN
}
# 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 ) {
script/makepatch view on Meta::CPAN
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");
script/makepatch view on Meta::CPAN
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 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;
}
script/makepatch view on Meta::CPAN
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))
}
}
}
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 <<EOD;
#
# This command terminates the shell and need not be executed manually.
exit
#
EOD
}
else {
print $fh <<EOD;
# STEP 2: Run the 'patch' program with this file as input.
#
EOD
}
print $fh <<EOD;
#### 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;
( run in 0.577 second using v1.01-cache-2.11-cpan-cdf2f3d4e48 )