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