cj-git-applypatches

#!/usr/bin/perl -w

use strict;

use Cwd 'abs_path';
my ($mydir, $myname);
BEGIN {
    my $location = (-l $0) ? abs_path($0) : $0;
    $location =~ /(.*?)([^\/]+)\z/s or die "?";
    ($mydir, $myname) = ($1, $2);
}

use lib "$mydir/lib";

use Chj::Git::Functions qw(make_xgit_do_hack git_wait_lock xgit_do);
use Chj::xperlfunc;
use Chj::xopen 'xopen_read';
use Date::Parse ();
use Chj::xperlfunc 'dirname';
use Chj::FP::lazy;
use Chj::Backtrace;
use Chj::Git::Patchtool 'git_commit_options';


(my $email='ch%christianjaeger,ch')=~ tr/%,/@./;

sub usage {
    print STDERR map{"$_\n"} @_ if @_;
    print "$myname listfile

  Apply the patches in the listfile to the current git dir; assumes
  the patches are in the same dir as listfile.

  Like with rebase -i, prefixing patches with 's' is possible. The
  ordering is as in the file.

  Options:

    --no-early   do *not* check for missing titles etc. before starting
                 the patching process.

  (Christian Jaeger <$email>)
";
exit (@_ ? 1 : 0);
}

use Getopt::Long;
our $verbose=0;
our $opt_no_early;
our $opt_dry;
GetOptions("verbose"=> \$verbose,
           "help"=> sub{usage},
           "dry-run"=> \$opt_dry,
           "no-early"=> \$opt_no_early,
           ) or exit 1;
usage unless @ARGV==1;

our ($listfile)=@ARGV;

package _Error {
    sub new {
        my $cl=shift;
        @_==1 or die "expect 1 arg";
        my ($msg)=@_;
        bless \$msg, $cl
    }
    sub string {
        my $s=shift;
        $$s
    }
}
package _NoCommitmsgError {
    our @ISA=("_Error");
}
package _MissingCommitidError {
    our @ISA=("_Error");
}


sub xgit_do_hack;
*xgit_do_hack= make_xgit_do_hack
  (sub {
       my ($base)=@_;
       xsystem "rm", "-rf", "--", "$base/rebase-apply";
       git_wait_lock ($base);
       xgit_do "reset","--hard"; # needed?
       git_wait_lock ($base);
   });

package ClusterItem {
    use Class::Array -fields=> -publica=>
      ();
    sub is_patch { 0 }
    sub is_command { 0 }
    end Class::Array;
}

package Patch {
    use Chj::xperlfunc qw(xsymlink xunlink);
    
    use Class::Array -class=> 'ClusterItem', -extend=> -publica=>
      (
       'basedir',
       'filename',
       'is_message_leader', # provides the message.
       'is_time_leader', # provides the author time.
       'is_author_leader', # provides the author name/email.
       'commitid', # set-once.
       'headers', # cache
      );
    sub is_patch { 1 }

    sub new {
        my $cl=shift;
        bless [@_],$cl
    }

    sub desc {
        my $s=shift;
        $s->filename
    }

    sub path {
        my $s=shift;
        "$$s[Basedir]/$$s[Filename]"
    }

    sub set_commitid {
        my $s=shift;
        my ($commitid)=@_;
        die "commitid already set"
          if $$s[Commitid];
        $$s[Commitid]=$commitid
    }

    use Chj::FP::lazy;
    sub message {
        my $s=shift;
        Delay {
            if ($$s[Commitid]) {
                # to be added to git commit for the cluster
                [ "-C",$$s[Commitid] ]
            } else {
                my $msg= "missing commitid for patchfile $$s[Filename]";
                if ($opt_dry) {
                    _MissingCommitidError->new($msg)
                } else {
                    # would fail too but only after giving the
                    # stringified representation to git
                    die $msg
                }
            }
        }
    }

    sub get_orig_message {
        my $s=shift;
        # read message from original commit
        if (my $id= $$s[Commitid]) {
            my $rf= Chj::Git::Functions::maybe_cat_file("commit",$id)
              or die "could not get commit message for '$id'";
            $$rf=~ s/.*?\n\n//s
              or die "cannot match to strip headers from '$$rf'";
            $$rf
        } else {
            my $msg= "missing commitid for patchfile $$s[Filename]";
            if ($opt_dry) {
                _MissingCommitidError->new($msg)
            } else {
                # would fail too but only after giving the stringified
                # representation to git
                die $msg
            }
        }
    }

    sub headers {
        my $s=shift;
        $$s[Headers] ||= do {
            my $headers={};
            my $lastkey;
            {
                my $f= Chj::xopen::xopen_read $s->path;
                local $_; # !!!!!!
                while (<$f>) {
                    chomp;
                    last if /^$/;
                    next if /^From /;
                    if (/^\s+(.*)/) {
                        $$headers{$lastkey}[-1] .= "\n".$1;
                    } elsif (my ($key,$val)= /^([\w-]+):\s*(.*)/) {
                        $lastkey=lc $key;
                        push @{$$headers{$lastkey}},$val;
                    } else {
                        die "invalid header in file: '$_' ".$s->path;
                    }
                }
                $f->xclose;
            }
            $headers
        }
    }

    my $get_single_header_named= sub {
        my ($name)= @_;
        sub {
            my $s=shift;
            my $headers= $s->headers;
            my @res= @{$$headers{$name}||[]};
            @res == 1 ? $res[0] : do {
                my $msg= @res ? "more than one" : "no";
                die "contains $msg '$name' header: ".$s->path;
            }
        }
    };

    sub author_date; *author_date= $get_single_header_named->("date");
    sub author; *author= $get_single_header_named->("from");
    sub author_name_and_email {
        my $s=shift;
        my $author= $s->author;
        my ($name, $mail)= $author=~ m/^\s*(.*?)\s*<([^<>]+)>\s*$/
          or die "no match on author '$author'";
        ($name, $mail)
    }

    sub apply {
        my $s=shift;
        my $applying_path = $$s[Basedir] . "/_applying";
        unlink $applying_path;
        xsymlink $s->path, $applying_path;
        main::xgit_do_hack "am", "-3", "--ignore-whitespace", $s->path;
        # ^ does not output the new commitid in a clear way, thus:
        xunlink $applying_path;
        my $commitid= Chj::Git::Functions::xgit_rev_parse "HEAD";
        $s->set_commitid ($commitid);
    }
    end Class::Array;
}

package Command {
    use Chj::xperlfunc 'xxsystem';

    use Class::Array -class=> 'ClusterItem', -extend=> -publica=>
      ('commandline');

    sub is_command { 1 }

    sub new {
        my $cl=shift;
        @_==1 or die "wrong number of arguments";
        bless [@_],$cl
    }

    sub desc {
        my $s=shift;
        '% ' . $s->commandline
    }

    sub apply {
        my $s=shift;
        xxsystem $s->commandline;
    }

    end Class::Array;
}


package Cluster {
    use Chj::FP::lazy;

    use Class::Array -fields=> -publica=>
      (
       'line', #of the start, in source file.
       'message', # string
       'items', # array_of ClusterItem
       'maybe_prefix', # undef or string to be prepended to commit message
       'maybe_postfix_subject', # undef or string to be appended to subject line
       'maybe_postfix', # undef or string to be appended to commit message
       '_patches', # cache of items that are patches (premature opt?)
       '_commands', # dito
      );

    sub new {
        my $cl=shift;
        my ($line)=@_;
        my $s=$cl->SUPER::new;
        $$s[Line]=$line;
        $$s[Items]=[];
        $s
    }

    sub add_item {
        my $s=shift;
        undef $$s[_Patches];
        undef $$s[_Commands];
        push @{$$s[Items]},@_
    }

    sub patches {
        my $s=shift;
        $$s[_Patches] ||=
          [ grep { $_->is_patch } @{$$s[Items]} ];
    }

    sub has_patches {
        my $s=shift;
        @{ $s->patches } > 0
    }

    sub commands {
        my $s=shift;
        $$s[_Commands] ||=
          [ grep { $_->is_command } @{$$s[Items]} ];
    }

    sub has_commands {
        my $s=shift;
        @{ $s->commands } > 0
    }

    sub perhaps_singlepatch {
        my $s=shift;
        my $ps= $s->patches;
        @$ps == 1 ? $$ps[0] : ()
    }

    sub is_empty { # really empty (nothing to apply to history),
                   # regardless of kind of item
        my $s=shift;
        not @{$$s[Items]}
    }

    sub perhaps_the_patch_that {
        # incl. sanitation, i.e. throws exception if more than one
        # leader is present
        my $s=shift;
        my ($method)=@_;
        my @leaders= grep { $_->$method } @{$s->patches};
        @leaders==1 ? $leaders[0]
          : @leaders ?
            die "more than one $method patch selected"
              : ();
    }

    sub perhaps_author_date { # -> perhaps (git time format)
        my $s=shift;
        return ()
          unless $s->has_patches;
        if (my ($leader)= $s->perhaps_the_patch_that ("is_time_leader")) {
            $leader->author_date
        } else {
            # select the *latest* author_date of all patches.
            my @p= map {
                [
                 ((scalar Date::Parse::str2time($_))
                  || die "invalid time?: '$_'"),
                 $_
                ]
            } map {
                $_->author_date
            } @{$s->patches};

            (sort {
                $$a[0] cmp $$b[0]
            } @p)[-1][1]
        }
    }

    sub perhaps_author {
        my $s=shift;
        return ()
            unless $s->has_patches;
        if (my ($leader)= $s->perhaps_the_patch_that ("is_author_leader")) {
            $leader->author
        } else {
            my @_authors= map {
                $_->author
            } @{$s->patches};
            my %authors= map {
                $_ => 1
            } @_authors;
            my @authors= keys %authors;
            if (@authors==1) {
                $authors[0]
            } else {
                warn "**NOTE**: more than one author in cluster on line "
                    .($s->line).", maybe specify 'a' on a patch:\n"
                    .join("", sort map { "          $_\n" } @authors);
                ()
            }
        }
    }

    sub maybe_msgoptions_promise {
        # either false if message does not need to be changed,
        # or a promise of an array of options to be fed to git.
        my $s=shift;
        my $prefix= $$s[Maybe_prefix] // "";
        my $postfix= $$s[Maybe_postfix] // "";
        my $fix_message = sub {
            my ($message) = @_;
            my $subjected_message = do {
                if (defined (my $str = $$s[Maybe_postfix_subject])) {
                    my ($subject, @rest) = split /\n/, $message;
                    join("\n", ($subject.$str, @rest))
                } else {
                    $message
                }
            };
            #warn "subjected_message= '$subjected_message'";
            $prefix . $subjected_message . $postfix
        };
        if ($$s[Message]) {
            # Explicit message in `[ ]` was given.
            # (Delay just for consistency, so that I can Force
            # it. Should use FP::Lazy instead or so.)
            Delay {
                ["-m", $fix_message->($$s[Message]) ]
            }
        } else {
            if (my ($leader)= $s->perhaps_the_patch_that ("is_message_leader")) {
                Delay {
                    [
                     "-m",
                     $fix_message->($leader->get_orig_message)
                    ]
                }
            } else {
                if (my ($thepatch)= $s->perhaps_singlepatch) {
                    if (length $prefix or length $postfix
                        or defined($$s[Maybe_postfix_subject]))
                    {
                        Delay {
                            [
                             "-m",
                             $fix_message->($thepatch->get_orig_message)
                            ]
                        }
                    } else {
                        if (@{$s->items} == 1) {
                            # optimization: no need to reset --soft
                            # and re-commit
                            undef
                        } else {
                            # single patch, but also shell commands
                            Delay {
                                [
                                 "-m",
                                 $fix_message->($thepatch->get_orig_message)
                                ]
                            }
                        }
                    }
                } elsif (not $s->has_patches) {
                    undef
                } else {
                    my $msg="Cluster starting at line $$s[Line]: ".
                      "neither leader patch indication nor ".
                        "explicit message given";
                    #new _NoCommitmsgError ;
                    # XX find something better. right now it's broken
                    # as it is not checked in "check" anymore, and on
                    # "patch" it will feed that to Force and break
                    # this way. !

                    die $msg
                }
            }
        }
    }

    end Class::Array;
}


our $basedir= dirname $listfile;

our $listfh= xopen_read $listfile;

our @clusters;
my $line=1;
our $curcluster= new Cluster ($line);
my $curcluster_add_string = sub {
    my ($fieldname, $str)= @_;
    my $old = $curcluster->$fieldname // "";
    my $setmethod = "set_$fieldname";
    $curcluster->$setmethod($old.$str);
};

sub end_cluster {
    push @clusters, $curcluster
      unless $curcluster->is_empty;
}

while (<$listfh>) {
    chomp;
    $line++;
    next if /^\s*#/;
    if (/^([*"ta]*)(\d+(?:\w+)?-.+)/) {
        my ($is_some_leader,$path)=($1,$2);
        # a squash. extend existing cluster.
        my $p= Patch->new ($basedir,
                           $path,
                           # message leader:
                           scalar
                           ($is_some_leader
                            and $is_some_leader=~ /[*"]/),
                           # time leader:
                           scalar
                           ($is_some_leader
                            and $is_some_leader=~ /[*t]/),
                           # author leader:
                           scalar
                           ($is_some_leader
                            and $is_some_leader=~ /[*a]/));
        $curcluster->add_item ($p);
    } elsif (/^\%\s*(.*?)\s*$/s) {
        # a shell command
        $curcluster->add_item (Command->new ($1));
    } elsif (/^\s*$/) {
        # a new cluster.
        end_cluster;
        $curcluster= new Cluster ($line);
    } elsif (/^prefix: ?(.*)/) {
        # not trimming whitespace (other than that single expected space),
        # and not adding ": ". have to do that yourself, ok?
        $curcluster_add_string->("maybe_prefix", $1);
    } elsif (/^postfix-subject: ?(.*)/) {
        $curcluster_add_string->("maybe_postfix_subject", $1);
    } elsif (/^postfix-para(?:graph)?: ?(.*)/) {
        $curcluster_add_string->("maybe_postfix", "\n\n$1\n");
    } elsif (/^\[\s*$/) {
        # inline commit message
        my @c;
        while (<$listfh>) {
            chomp;
            $line++;#!
            if (/^\]\s*(?:#.*)?$/) {
                last;
            }
            if (/^#/) {
                warn "NOTE: comments inside commit message: '$_'\n";
            }
            push @c, $_
        }
        $curcluster->set_message
          (join ("\n", map { my $s=$_; $s=~ s/\s+\z//; $s } @c));
    } else {
        die "no match for '$_'";
    }
}
end_cluster;
$listfh->xclose;

sub check {
    my $errs=0;
    for my $c (@clusters) {
        # ugly COPY from apply.
        for my $p (@{$c->patches}) {
            #$p->apply($basedir);
            #now we calculate paths anyway ourselves?? ~td:
            my $path= $basedir."/".$p->filename;
            -e $path or do {
                warn "patch file '$path' missing\n";
                $errs++;
            };
        }
    }
    $errs
}

sub apply {
    my ($early)=@_; # early means, just check for errors in the source
                    # file (similar? to dry-run)

    for my $cluster (@clusters) {
        my $applypatches=sub {
            for my $p (@{$cluster->items}) {
                print "==== ".$p->desc." ====\n";
                $p->apply;
            }
        };
        if (my $msgoptions= $cluster->maybe_msgoptions_promise) {
            unless ($early) {
                my $oldhead= Chj::Git::Functions::xgit_rev_parse "HEAD";
                &$applypatches();
                main::xgit_do_hack "reset", "--soft", $oldhead;
            }
            my @moreoptions=
              (
               do {
                   if (my ($author_date)= $cluster->perhaps_author_date) {
                       ("--date", $author_date)
                   } else {
                       # '%' command only, no patches
                       ()
                   }
               },
               do {
                   if (my ($author)= $cluster->perhaps_author) {
                       ("--author", $author)
                   } else {
                       ()
                   }
               }
              );
            unless ($early) {
                main::xgit_do_hack "commit", git_commit_options, "-a",
                    @{Force $msgoptions}, @moreoptions;
            }
        } else {
            # "message does not need to be changed" (singlepatch [or
            # not has_patches])
            unless ($early) {
                &$applypatches();
            }
        }
    }
}


my $errors= check;

if ($errors) {
    print "$errors errors in input file, stopping.\n";
    exit 1;
} else {
    if ($opt_dry) {
        print "no errors in input file; ".
          "not running because in dry-run mode.\n";
        # NOTE: dry mode does not check for missing cluster titles and
        # such! Pointless?!!! Implemented new early checking behaviour
        # instead (--no-early).
    } else {
        unless ($opt_no_early) {
            apply 1;
        }
        apply 0;
        print "Ok.\n";
    }
}