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