Alt-App-makepatch
view release on metacpan or search on metacpan
script/makepatch view on Meta::CPAN
#!/usr/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)) .
script/makepatch view on Meta::CPAN
# Check temp dir.
unless ( -d $TMPDIR && -w $TMPDIR ) {
print STDERR <<EOD;
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;
script/makepatch view on Meta::CPAN
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);
}
}
script/makepatch view on Meta::CPAN
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 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",
script/makepatch view on Meta::CPAN
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 <<EoU;
This is $my_name version $my_version
Usage: $0 [options] old-src new-src
Makepatch options:
( run in 0.792 second using v1.01-cache-2.11-cpan-02777c243ea )