Alt-App-makepatch

 view release on metacpan or  search on metacpan

script/applypatch  view on Meta::CPAN

my $dir;			# source directory
my $check = 0;			# check only
my $retain = 0;			# retain .orig files
my $patch = 'patch -p0 -N';	# patch command
my $verbose = 0;		# verbose processing
my $force = 0;			# allow continuation after trunc/corruption

# Development options (not shown with -help).
my $trace = 0;			# trace (show process)
my $test = 0;			# test (no actual processing)
my $debug = 0;			# extensive debugging info

## Misc

my $applypatch = 0;		# it's for us
my $timestamp;			# create date/time of patch kit
my @workq = ();			# work queue

## Subroutine prototypes

sub app_options ();
sub app_usage ($);
sub copy_input ();
sub execute_patch ();
sub post_patch ();
sub pre_patch ();
sub verify_files ();

################ Program parameters ################

app_options();
$trace ||= $debug;
$verbose ||= $trace;

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

$patch .= " -s" unless $verbose;
my $tmpfile = IO::File->new_tmpfile;

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

# Validate input and copy to temp file.

script/applypatch  view on Meta::CPAN

sub execute_patch () {

	my $p;

    print STDERR ("+ $patch\n") if $trace;
    if ( $applypatch ) {
	my $lines = 0;
	while ( <$tmpfile> ) {
	    chomp;
	    print STDERR ("++ ", $_, "\n") if $debug;
	    next if $_ eq "#### Patch data follows ####";
	    last if $_ eq "#### End of Patch data ####";
	    $p = _open_patch() unless $p;
	    print $p ($_, "\n");
	    $lines++;
	}
	print STDERR ("+ $lines lines sent to \"$patch\"\n") if $trace;
    }
    else {
	    while ( <$tmpfile> ) {

script/applypatch  view on Meta::CPAN

    return unless @ARGV > 0;
    my @opts = ('check'		=> \$check,
		'dir|d=s'	=> \$dir,
		'retain'	=> \$retain,
		'force'		=> \$force,
		'verbose'	=> \$verbose,
		'quiet'		=> sub { $verbose = 0; },
		'patch=s'	=> \$patch,
		'test'		=> \$test,
		'trace'		=> \$trace,
		'debug'		=> \$debug,
		'help'		=> \$help);
    
    (!GetOptions (@opts) || $help) && app_usage (2);

}

sub app_usage ($) {
    my ($exit) = @_;
    print STDERR <<EndOfUsage;
Usage: $0 [options] patch-kit

script/makepatch  view on Meta::CPAN

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}

script/makepatch  view on Meta::CPAN

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 ();

script/makepatch  view on Meta::CPAN

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.

script/makepatch  view on Meta::CPAN

        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 {

script/makepatch  view on Meta::CPAN

	    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 ();
    }

script/makepatch  view on Meta::CPAN

    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;

script/makepatch  view on Meta::CPAN

          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;
}

script/makepatch  view on Meta::CPAN

	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");

script/makepatch  view on Meta::CPAN

}

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] },

script/makepatch  view on Meta::CPAN

	    @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 ) {

script/makepatch  view on Meta::CPAN

	$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;