lib/App/Rgit/Policy/Interactive.pm

   1 package App::Rgit::Policy::Interactive;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Cwd ();
   7
   8 use App::Rgit::Utils qw/:codes/;
   9
  10 use base qw/App::Rgit::Policy/;
  11
  12 =head1 NAME
  13
  14 App::Rgit::Policy::Interactive - A policy that asks what to do on error.
  15
  16 =head1 VERSION
  17
  18 Version 0.07
  19
  20 =cut
  21
  22 our $VERSION = '0.07';
  23
  24 =head1 DESCRIPTION
  25
  26 When a run exited with non-zero status, this policy asks the user whether he wants to ignore and continue with the next repository, ignore all future possible errors, retry this run or open a shell in the current repository.
  27 In this last case, the user will be asked again what to do when he will close the shell.
  28
  29 =head1 METHODS
  30
  31 This class inherits from L<App::Rgit::Policy>.
  32
  33 It implements :
  34
  35 =head2 C<new>
  36
  37 The constructor will die if L<Term::ReadKey> can't be loaded.
  38
  39 =cut
  40
  41 my ($int_code, $shell);
  42
  43 sub new {
  44  my $class = shift;
  45  $class = ref $class || $class;
  46
  47  eval "require Term::ReadKey"
  48       or die "You have to install Term::ReadKey to use the interactive mode.\n";
  49
  50  unless (defined $int_code) {
  51   $int_code = { Term::ReadKey::GetControlChars() }->{INTERRUPT};
  52  }
  53
  54  unless (defined $shell) {
  55   for (grep defined, $ENV{SHELL}, '/bin/sh') {
  56    if (-x $_) {
  57     $shell = $_;
  58     last;
  59    }
  60   }
  61  }
  62
  63  $class->SUPER::new(@_);
  64 }
  65
  66 =head2 C<handle>
  67
  68 =cut
  69
  70 my %codes = (
  71  'a' => [ LAST,        'aborting' ],
  72  'i' => [ NEXT,        'ignoring' ],
  73  'I' => [ NEXT | SAVE, 'ignoring all' ],
  74  'r' => [ REDO,        'retrying' ],
  75 );
  76
  77 sub handle {
  78  my ($policy, $cmd, $conf, $repo, $status, $signal) = @_;
  79
  80  return NEXT unless $status;
  81
  82  while (1) {
  83   $conf->warn("[a]bort, [i]gnore, [I]gnore all, [r]etry, open [s]hell ?");
  84
  85   Term::ReadKey::ReadMode(4);
  86   my $key = Term::ReadKey::ReadKey(0);
  87   Term::ReadKey::ReadMode(1);
  88
  89   $conf->warn("\n");
  90
  91   next unless defined $key;
  92
  93   if ($key eq $int_code) {
  94    $conf->warn("Interrupted, aborting\n");
  95    return LAST;
  96   } elsif ($key eq 's') {
  97    if (defined $shell) {
  98     $conf->info('Opening shell in ', $repo->work, "\n");
  99     my $cwd = Cwd::cwd;
 100     $repo->chdir;
 101     system { $shell } $shell;
 102     chdir $cwd;
 103    } else {
 104     $conf->err("Couldn't find any shell\n");
 105    }
 106   } elsif (exists $codes{$key}) {
 107    my $code = $codes{$key};
 108    $conf->info('Okay, ', $code->[1], "\n");
 109    return $code->[0];
 110   }
 111  }
 112 }
 113
 114 =head1 SEE ALSO
 115
 116 L<rgit>.
 117
 118 L<App::Rgit::Policy>.
 119
 120 L<Term::ReadKey>.
 121
 122 =head1 AUTHOR
 123
 124 Vincent Pit, C<< <perl at profvince.com> >>, L<http://profvince.com>.
 125
 126 You can contact me by mail or on C<irc.perl.org> (vincent).
 127
 128 =head1 BUGS
 129
 130 Please report any bugs or feature requests to C<bug-rgit at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=rgit>.
 131 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 132
 133 =head1 SUPPORT
 134
 135 You can find documentation for this module with the perldoc command.
 136
 137     perldoc App::Rgit::Policy::Interactive
 138
 139 =head1 COPYRIGHT & LICENSE
 140
 141 Copyright 2008,2009,2010 Vincent Pit, all rights reserved.
 142
 143 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 144
 145 =cut
 146
 147 1; # End of App::Rgit::Policy::Interactive