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