git.notmuchmail.org Git - notmuch/blob - devel/nmbug/nmbug

   1 #!/usr/bin/env perl
   2 # Copyright (c) 2011 David Bremner
   3 # License: same as notmuch
   4
   5 use strict;
   6 use warnings;
   7 use File::Temp qw(tempdir);
   8 use Pod::Usage;
   9
  10 no encoding;
  11
  12 my $NMBGIT = $ENV{NMBGIT} || $ENV{HOME}.'/.nmbug';
  13
  14 $NMBGIT .= '/.git' if (-d $NMBGIT.'/.git');
  15
  16 my $TAGPREFIX = defined($ENV{NMBPREFIX}) ? $ENV{NMBPREFIX} : 'notmuch::';
  17
  18 # for encoding
  19
  20 my $ESCAPE_CHAR =       '%';
  21 my $NO_ESCAPE =         'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'.
  22                         '0123456789+-_@=.:,';
  23 my $MUST_ENCODE =       qr{[^\Q$NO_ESCAPE\E]};
  24 my $ESCAPED_RX =        qr{$ESCAPE_CHAR([A-Fa-f0-9]{2})};
  25
  26 my %command = (
  27              archive    => \&do_archive,
  28              checkout   => \&do_checkout,
  29              clone      => \&do_clone,
  30              commit     => \&do_commit,
  31              fetch      => \&do_fetch,
  32              help       => \&do_help,
  33              log        => \&do_log,
  34              merge      => \&do_merge,
  35              pull       => \&do_pull,
  36              push       => \&do_push,
  37              status     => \&do_status,
  38              );
  39
  40 # Convert prefix into form suitable for literal matching against
  41 # notmuch dump --format=batch-tag output.
  42 my $ENCPREFIX = encode_for_fs ($TAGPREFIX);
  43 $ENCPREFIX =~ s/:/%3a/g;
  44
  45 my $subcommand = shift || usage ();
  46
  47 if (!exists $command{$subcommand}) {
  48   usage ();
  49 }
  50
  51 # magic hash for git
  52 my $EMPTYBLOB = git (qw{hash-object -t blob /dev/null});
  53
  54 &{$command{$subcommand}}(@ARGV);
  55
  56 sub git_pipe {
  57   my $envref = (ref $_[0] eq 'HASH') ? shift : {};
  58   my $ioref  = (ref $_[0] eq 'ARRAY') ? shift : undef;
  59   my $dir = ($_[0] eq '-|' or $_[0] eq '|-') ? shift : undef;
  60
  61   unshift @_, 'git';
  62   $envref->{GIT_DIR} ||= $NMBGIT;
  63   spawn ($envref, defined $ioref ? $ioref : (), defined $dir ? $dir : (), @_);
  64 }
  65
  66 sub git_with_status {
  67   my $fh = git_pipe (@_);
  68   my $str = join ('', <$fh>);
  69   close $fh;
  70   my $status = $?;
  71   chomp($str);
  72   return ($str, $status);
  73 }
  74
  75 sub git {
  76   my ($str, $status) = git_with_status (@_);
  77   if ($status) {
  78     die "'git @_' exited with nonzero value\n";
  79   }
  80   return $str;
  81 }
  82
  83 sub spawn {
  84   my $envref = (ref $_[0] eq 'HASH') ? shift : {};
  85   my $ioref  = (ref $_[0] eq 'ARRAY') ? shift : undef;
  86   my $dir = ($_[0] eq '-|' or $_[0] eq '|-') ? shift : '-|';
  87
  88   die unless @_;
  89
  90   if (open my $child, $dir) {
  91     return $child;
  92   }
  93   # child
  94   while (my ($key, $value) = each %{$envref}) {
  95     $ENV{$key} = $value;
  96   }
  97
  98   if (defined $ioref && $dir eq '-|') {
  99       open my $fh, '|-', @_ or die "open |- @_: $!";
 100       foreach my $line (@{$ioref}) {
 101         print $fh $line, "\n";
 102       }
 103       exit ! close $fh;
 104     } else {
 105       if ($dir ne '|-') {
 106         open STDIN, '<', '/dev/null' or die "reopening stdin: $!"
 107       }
 108       exec @_;
 109       die "exec @_: $!";
 110     }
 111 }
 112
 113
 114 sub get_tags {
 115   my $prefix = shift;
 116   my @tags;
 117
 118   my $fh = spawn ('-|', qw/notmuch search --output=tags/, "*")
 119     or die 'error dumping tags';
 120
 121   while (<$fh>) {
 122     chomp ();
 123     push @tags, $_ if (m/^$prefix/);
 124   }
 125   unless (close $fh) {
 126     die "'notmuch search --output=tags *' exited with nonzero value\n";
 127   }
 128   return @tags;
 129 }
 130
 131
 132 sub do_archive {
 133   system ('git', "--git-dir=$NMBGIT", 'archive', 'HEAD');
 134 }
 135
 136 sub do_clone {
 137   my $repository = shift;
 138
 139   my $tempwork = tempdir ('/tmp/nmbug-clone.XXXXXX', CLEANUP => 1);
 140   system ('git', 'clone', '--no-checkout', '--separate-git-dir', $NMBGIT,
 141           $repository, $tempwork) == 0
 142     or die "'git clone' exited with nonzero value\n";
 143   git ('config', '--unset', 'core.worktree');
 144   git ('config', 'core.bare', 'true');
 145 }
 146
 147 sub is_committed {
 148   my $status = shift;
 149   return scalar (@{$status->{added}} ) + scalar (@{$status->{deleted}} ) == 0;
 150 }
 151
 152
 153 sub do_commit {
 154   my @args = @_;
 155
 156   my $status = compute_status ();
 157
 158   if ( is_committed ($status) ) {
 159     print "Nothing to commit\n";
 160     return;
 161   }
 162
 163   my $index = read_tree ('HEAD');
 164
 165   update_index ($index, $status);
 166
 167   my $tree = git ( { GIT_INDEX_FILE => $index }, 'write-tree')
 168     or die 'no output from write-tree';
 169
 170   my $parent = git ( 'rev-parse', 'HEAD'  )
 171     or die 'no output from rev-parse';
 172
 173   my $commit = git ([ @args ], 'commit-tree', $tree, '-p', $parent)
 174     or die 'commit-tree';
 175
 176   git ('update-ref', 'HEAD', $commit);
 177
 178   unlink $index || die "unlink: $!";
 179
 180 }
 181
 182 sub read_tree {
 183   my $treeish = shift;
 184   my $index = $NMBGIT.'/nmbug.index';
 185   git ({ GIT_INDEX_FILE => $index }, 'read-tree', '--empty');
 186   git ({ GIT_INDEX_FILE => $index }, 'read-tree', $treeish);
 187   return $index;
 188 }
 189
 190 sub update_index {
 191   my $index = shift;
 192   my $status = shift;
 193
 194   my $git = spawn ({ GIT_DIR => $NMBGIT, GIT_INDEX_FILE => $index },
 195                      '|-', qw/git update-index --index-info/)
 196     or die 'git update-index';
 197
 198   foreach my $pair (@{$status->{deleted}}) {
 199     index_tags_for_msg ($git, $pair->{id}, 'D', $pair->{tag});
 200   }
 201
 202   foreach my $pair (@{$status->{added}}) {
 203     index_tags_for_msg ($git, $pair->{id}, 'A', $pair->{tag});
 204   }
 205   unless (close $git) {
 206     die "'git update-index --index-info' exited with nonzero value\n";
 207   }
 208
 209 }
 210
 211
 212 sub do_fetch {
 213   my $remote = shift || 'origin';
 214
 215   git ('fetch', $remote);
 216 }
 217
 218
 219 sub notmuch {
 220   my @args = @_;
 221   system ('notmuch', @args) == 0 or die  "notmuch @args failed: $?";
 222 }
 223
 224
 225 sub index_tags {
 226
 227   my $index = $NMBGIT.'/nmbug.index';
 228
 229   my $query = join ' ', map ("tag:\"$_\"", get_tags ($TAGPREFIX));
 230
 231   my $fh = spawn ('-|', qw/notmuch dump --format=batch-tag --/, $query)
 232     or die "notmuch dump: $!";
 233
 234   git ('read-tree', '--empty');
 235   my $git = spawn ({ GIT_DIR => $NMBGIT, GIT_INDEX_FILE => $index },
 236                      '|-', qw/git update-index --index-info/)
 237     or die 'git update-index';
 238
 239   while (<$fh>) {
 240
 241     chomp();
 242     my ($rest,$id) = split(/ -- id:/);
 243
 244     if ($id =~ s/^"(.*)"\s*$/$1/) {
 245       # xapian quoted string, dequote.
 246       $id =~ s/""/"/g;
 247     }
 248
 249     #strip prefixes from tags before writing
 250     my @tags = grep { s/^[+]$ENCPREFIX//; } split (' ', $rest);
 251     index_tags_for_msg ($git,$id, 'A', @tags);
 252   }
 253   unless (close $git) {
 254     die "'git update-index --index-info' exited with nonzero value\n";
 255   }
 256   unless (close $fh) {
 257     die "'notmuch dump --format=batch-tag -- $query' exited with nonzero value\n";
 258   }
 259   return $index;
 260 }
 261
 262 # update the git index to either create or delete an empty file.
 263 # Neither argument should be encoded/escaped.
 264 sub index_tags_for_msg {
 265   my $fh = shift;
 266   my $msgid = shift;
 267   my $mode = shift;
 268
 269   my $hash = $EMPTYBLOB;
 270   my $blobmode = '100644';
 271
 272   if ($mode eq 'D') {
 273     $blobmode = '0';
 274     $hash = '0000000000000000000000000000000000000000';
 275   }
 276
 277   foreach my $tag (@_) {
 278     my $tagpath = 'tags/' . encode_for_fs ($msgid) . '/' . encode_for_fs ($tag);
 279     print $fh "$blobmode $hash\t$tagpath\n";
 280   }
 281 }
 282
 283
 284 sub do_checkout {
 285   do_sync (action => 'checkout');
 286 }
 287
 288 sub quote_for_xapian {
 289   my $str = shift;
 290   $str =~ s/"/""/g;
 291   return '"' . $str . '"';
 292 }
 293
 294 sub pair_to_batch_line {
 295   my ($action, $pair) = @_;
 296
 297   # the tag should already be suitably encoded
 298
 299   return $action . $ENCPREFIX . $pair->{tag} .
 300     ' -- id:' . quote_for_xapian ($pair->{id})."\n";
 301 }
 302
 303 sub do_sync {
 304
 305   my %args = @_;
 306
 307   my $status = compute_status ();
 308   my ($A_action, $D_action);
 309
 310   if ($args{action} eq 'checkout') {
 311     $A_action = '-';
 312     $D_action = '+';
 313   } else {
 314     $A_action = '+';
 315     $D_action = '-';
 316   }
 317
 318   my $notmuch = spawn ({}, '|-', qw/notmuch tag --batch/)
 319     or die 'notmuch tag --batch';
 320
 321   foreach my $pair (@{$status->{added}}) {
 322     print $notmuch pair_to_batch_line ($A_action, $pair);
 323   }
 324
 325   foreach my $pair (@{$status->{deleted}}) {
 326     print $notmuch pair_to_batch_line ($D_action, $pair);
 327   }
 328
 329   unless (close $notmuch) {
 330     die "'notmuch tag --batch' exited with nonzero value\n";
 331   }
 332 }
 333
 334
 335 sub insist_committed {
 336
 337   my $status=compute_status();
 338   if ( !is_committed ($status) ) {
 339     print "Uncommitted changes to $TAGPREFIX* tags in notmuch
 340
 341 For a summary of changes, run 'nmbug status'
 342 To save your changes,     run 'nmbug commit' before merging/pull
 343 To discard your changes,  run 'nmbug checkout'
 344 ";
 345     exit (1);
 346   }
 347
 348 }
 349
 350
 351 sub do_pull {
 352   my $remote = shift || 'origin';
 353   my $branch = shift || 'master';
 354
 355   git ( 'fetch', $remote);
 356
 357   do_merge ("$remote/$branch");
 358 }
 359
 360
 361 sub do_merge {
 362   my $commit = shift || '@{upstream}';
 363
 364   insist_committed ();
 365
 366   my $tempwork = tempdir ('/tmp/nmbug-merge.XXXXXX', CLEANUP => 1);
 367
 368   git ( { GIT_WORK_TREE => $tempwork }, 'checkout', '-f', 'HEAD');
 369
 370   git ( { GIT_WORK_TREE => $tempwork }, 'merge', $commit);
 371
 372   do_checkout ();
 373 }
 374
 375
 376 sub do_log {
 377   # we don't want output trapping here, because we want the pager.
 378   system ( 'git', "--git-dir=$NMBGIT", 'log', '--name-status', @_);
 379 }
 380
 381
 382 sub do_push {
 383   my $remote = shift || 'origin';
 384
 385   git ('push', $remote, 'master');
 386 }
 387
 388
 389 sub do_status {
 390   my $status = compute_status ();
 391
 392   my %output = ();
 393   foreach my $pair (@{$status->{added}}) {
 394     $output{$pair->{id}} ||= {};
 395     $output{$pair->{id}}{$pair->{tag}} = 'A'
 396   }
 397
 398   foreach my $pair (@{$status->{deleted}}) {
 399     $output{$pair->{id}} ||= {};
 400     $output{$pair->{id}}{$pair->{tag}} = 'D'
 401   }
 402
 403   foreach my $pair (@{$status->{missing}}) {
 404     $output{$pair->{id}} ||= {};
 405     $output{$pair->{id}}{$pair->{tag}} = 'U'
 406   }
 407
 408   if (is_unmerged ()) {
 409     foreach my $pair (diff_refs ('A')) {
 410       $output{$pair->{id}} ||= {};
 411       $output{$pair->{id}}{$pair->{tag}} ||= ' ';
 412       $output{$pair->{id}}{$pair->{tag}} .= 'a';
 413     }
 414
 415     foreach my $pair (diff_refs ('D')) {
 416       $output{$pair->{id}} ||= {};
 417       $output{$pair->{id}}{$pair->{tag}} ||= ' ';
 418       $output{$pair->{id}}{$pair->{tag}} .= 'd';
 419     }
 420   }
 421
 422   foreach my $id (sort keys %output) {
 423     foreach my $tag (sort keys %{$output{$id}}) {
 424       printf "%s\t%s\t%s\n", $output{$id}{$tag}, $id, $tag;
 425     }
 426   }
 427 }
 428
 429
 430 sub is_unmerged {
 431   my $commit = shift || '@{upstream}';
 432
 433   my ($fetch_head, $status) = git_with_status ('rev-parse', $commit);
 434   if ($status) {
 435     return 0;
 436   }
 437   my $base = git ( 'merge-base', 'HEAD', $commit);
 438
 439   return ($base ne $fetch_head);
 440
 441 }
 442
 443 sub compute_status {
 444   my %args = @_;
 445
 446   my @added;
 447   my @deleted;
 448   my @missing;
 449
 450   my $index = index_tags ();
 451
 452   my @maybe_deleted = diff_index ($index, 'D');
 453
 454   foreach my $pair (@maybe_deleted) {
 455
 456     my $id = $pair->{id};
 457
 458     my $fh = spawn ('-|', qw/notmuch search --output=files/,"id:$id")
 459       or die "searching for $id";
 460     if (!<$fh>) {
 461       push @missing, $pair;
 462     } else {
 463       push @deleted, $pair;
 464     }
 465     unless (close $fh) {
 466       die "'notmuch search --output=files id:$id' exited with nonzero value\n";
 467     }
 468   }
 469
 470
 471   @added = diff_index ($index, 'A');
 472
 473   unlink $index || die "unlink $index: $!";
 474
 475   return { added => [@added], deleted => [@deleted], missing => [@missing] };
 476 }
 477
 478
 479 sub diff_index {
 480   my $index = shift;
 481   my $filter = shift;
 482
 483   my $fh = git_pipe ({ GIT_INDEX_FILE => $index },
 484                   qw/diff-index --cached/,
 485                  "--diff-filter=$filter", qw/--name-only HEAD/ );
 486
 487   my @lines = unpack_diff_lines ($fh);
 488   unless (close $fh) {
 489     die "'git diff-index --cached --diff-filter=$filter --name-only HEAD' ",
 490         "exited with nonzero value\n";
 491   }
 492   return @lines;
 493 }
 494
 495
 496 sub diff_refs {
 497   my $filter = shift;
 498   my $ref1 = shift || 'HEAD';
 499   my $ref2 = shift || '@{upstream}';
 500
 501   my $fh= git_pipe ( 'diff', "--diff-filter=$filter", '--name-only',
 502                  $ref1, $ref2);
 503
 504   my @lines = unpack_diff_lines ($fh);
 505   unless (close $fh) {
 506     die "'git diff --diff-filter=$filter --name-only $ref1 $ref2' ",
 507         "exited with nonzero value\n";
 508   }
 509   return @lines;
 510 }
 511
 512
 513 sub unpack_diff_lines {
 514   my $fh = shift;
 515
 516   my @found;
 517   while(<$fh>) {
 518     chomp ();
 519     my ($id,$tag) = m|tags/ ([^/]+) / ([^/]+) |x;
 520
 521     $id = decode_from_fs ($id);
 522     $tag = decode_from_fs ($tag);
 523
 524     push @found, { id => $id, tag => $tag };
 525   }
 526
 527   return @found;
 528 }
 529
 530
 531 sub encode_for_fs {
 532   my $str = shift;
 533
 534   $str =~ s/($MUST_ENCODE)/"$ESCAPE_CHAR".sprintf ("%02x",ord ($1))/ge;
 535   return $str;
 536 }
 537
 538
 539 sub decode_from_fs {
 540   my $str = shift;
 541
 542   $str =~ s/$ESCAPED_RX/ chr (hex ($1))/eg;
 543
 544   return $str;
 545
 546 }
 547
 548
 549 sub usage {
 550   pod2usage ();
 551   exit (1);
 552 }
 553
 554
 555 sub do_help {
 556   pod2usage ( -verbose => 2 );
 557   exit (0);
 558 }
 559
 560 __END__
 561
 562 =head1 NAME
 563
 564 nmbug - manage notmuch tags about notmuch
 565
 566 =head1 SYNOPSIS
 567
 568 nmbug subcommand [options]
 569
 570 B<nmbug help> for more help
 571
 572 =head1 OPTIONS
 573
 574 =head2 Most common commands
 575
 576 =over 8
 577
 578 =item B<commit> [message]
 579
 580 Commit appropriately prefixed tags from the notmuch database to
 581 git. Any extra arguments are used (one per line) as a commit message.
 582
 583 =item  B<push> [remote]
 584
 585 push local nmbug git state to remote repo
 586
 587 =item  B<pull> [remote] [branch]
 588
 589 pull (merge) remote repo changes to notmuch. B<pull> is equivalent to
 590 B<fetch> followed by B<merge>.  The default remote is C<origin>, and
 591 the default branch is C<master>.
 592
 593 =back
 594
 595 =head2 Other Useful Commands
 596
 597 =over 8
 598
 599 =item B<clone> repository
 600
 601 Create a local nmbug repository from a remote source.  This wraps
 602 C<git clone>, adding some options to avoid creating a working tree
 603 while preserving remote-tracking branches and upstreams.
 604
 605 =item B<checkout>
 606
 607 Update the notmuch database from git. This is mainly useful to discard
 608 your changes in notmuch relative to git.
 609
 610 =item B<fetch> [remote]
 611
 612 Fetch changes from the remote repo (see merge to bring those changes
 613 into notmuch).
 614
 615 =item B<help> [subcommand]
 616
 617 print help [for subcommand]
 618
 619 =item B<log> [parameters]
 620
 621 A simple wrapper for git log. After running C<nmbug fetch>, you can
 622 inspect the changes with C<nmbug log HEAD..@{upstream}>
 623
 624 =item B<merge> [commit]
 625
 626 Merge changes from C<commit> into HEAD, and load the result into
 627 notmuch.  The default commit is C<@{upstream}>.
 628
 629 =item  B<status>
 630
 631 Show pending updates in notmuch or git repo. See below for more
 632 information about the output format.
 633
 634 =back
 635
 636 =head2 Less common commands
 637
 638 =over 8
 639
 640 =item B<archive>
 641
 642 Dump a tar archive (using git archive) of the current nmbug tag set.
 643
 644 =back
 645
 646 =head1 STATUS FORMAT
 647
 648 B<nmbug status> prints lines of the form
 649
 650    ng Message-Id tag
 651
 652 where n is a single character representing notmuch database status
 653
 654 =over 8
 655
 656 =item B<A>
 657
 658 Tag is present in notmuch database, but not committed to nmbug
 659 (equivalently, tag has been deleted in nmbug repo, e.g. by a pull, but
 660 not restored to notmuch database).
 661
 662 =item B<D>
 663
 664 Tag is present in nmbug repo, but not restored to notmuch database
 665 (equivalently, tag has been deleted in notmuch)
 666
 667 =item B<U>
 668
 669 Message is unknown (missing from local notmuch database)
 670
 671 =back
 672
 673 The second character (if present) represents a difference between remote
 674 git and local. Typically C<nmbug fetch> needs to be run to update this.
 675
 676 =over 8
 677
 678
 679 =item B<a>
 680
 681 Tag is present in remote, but not in local git.
 682
 683
 684 =item B<d>
 685
 686 Tag is present in local git, but not in remote git.
 687
 688
 689 =back
 690
 691 =head1 DUMP FORMAT
 692
 693 Each tag $tag for message with Message-Id $id is written to
 694 an empty file
 695
 696         tags/encode($id)/encode($tag)
 697
 698 The encoding preserves alphanumerics, and the characters "+-_@=.:,"
 699 (not the quotes).  All other octets are replaced with '%' followed by
 700 a two digit hex number.
 701
 702 =head1 ENVIRONMENT
 703
 704 B<NMBGIT> specifies the location of the git repository used by nmbug.
 705 If not specified $HOME/.nmbug is used.
 706
 707 B<NMBPREFIX> specifies the prefix in the notmuch database for tags of
 708 interest to nmbug. If not specified 'notmuch::' is used.