File: Committable.pm

package info (click to toggle)
pinto 0.97%2Bdfsg-4
  • links: PTS, VCS
  • area: main
  • in suites: stretch
  • size: 1,380 kB
  • ctags: 620
  • sloc: perl: 9,933; sh: 230; makefile: 4
file content (207 lines) | stat: -rw-r--r-- 5,194 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
# ABSTRACT: Role for actions that commit changes to the repository

package Pinto::Role::Committable;

use Moose::Role;
use MooseX::Types::Moose qw(Bool Str);
use MooseX::MarkAsMethods ( autoclean => 1 );

use Try::Tiny;
use List::MoreUtils qw(uniq);

use Pinto::Constants qw($PINTO_LOCK_TYPE_EXCLUSIVE);
use Pinto::Types qw(StackName StackDefault StackObject);
use Pinto::Util qw(is_interactive throw is_blank is_not_blank);

#------------------------------------------------------------------------------

our $VERSION = '0.097'; # VERSION

#------------------------------------------------------------------------------

with qw(Pinto::Role::Plated);

#------------------------------------------------------------------------------

has stack => (
    is      => 'ro',
    isa     => StackName | StackDefault | StackObject,
    writer  => '_set_stack',
    default => undef,
);

has dry_run => (
    is      => 'ro',
    isa     => Bool,
    default => 0,
);

has message => (
    is        => 'ro',
    isa       => Str,
    predicate => 'has_message',
);

has use_default_message => (
    is      => 'ro',
    isa     => Bool,
    default => 0,
);

has lock_type => (
    is       => 'ro',
    isa      => Str,
    default  => $PINTO_LOCK_TYPE_EXCLUSIVE,
    init_arg => undef,
);

#------------------------------------------------------------------------------

requires qw( execute repo );

#------------------------------------------------------------------------------

around BUILD => sub {
    my ( $orig, $self ) = @_;

    # Inflate the stack into a real object.  As a side
    # effect, this also verifies that the stack exists.

    my $stack = $self->repo->get_stack( $self->stack );
    $self->_set_stack($stack);

    return $self->$orig;
};

#------------------------------------------------------------------------------

around execute => sub {
    my ( $orig, $self, @args ) = @_;

    $self->repo->txn_begin;
    my $stack = $self->stack->start_revision;

    my @ok = try { $self->$orig(@args) } catch { $self->repo->txn_rollback; throw $_ };

    if ( $self->dry_run ) {
        $self->notice('Dry run -- rolling back database');
        $self->repo->txn_rollback;
        $self->repo->clean_files;
    }
    elsif ( $stack->refresh->has_not_changed ) {
        $self->warning('No index changes were made');
        $self->repo->txn_rollback;
    }
    else {
        my $msg_title = $self->generate_message_title(@ok);
        my $msg = $self->compose_message( title => $msg_title, stack => $stack );
        $stack->commit_revision( message => $msg );

        $self->result->changed;
        $self->repo->txn_commit;
    }

    return $self->result;
};

#------------------------------------------------------------------------------

sub compose_message {
    my ( $self, %args ) = @_;

    my $title = $args{title} || '';
    my $stack = $args{stack} || throw 'Must specify a stack';
    my $diff  = $args{diff}  || $stack->diff;

    return $self->message
        if $self->has_message and is_not_blank( $self->message );

    return $title
        if $self->has_message and is_blank( $self->message );

    return $title
        if $self->use_default_message;

    return $title
        if not is_interactive;

    my $cm = $self->generate_message_template($title, $stack, $diff);
    my $message = $self->chrome->edit( $cm );
    $message =~ s/^ [#] .* $//gmsx; # Strip comments

    throw 'Aborting due to empty commit message' if is_blank($message);

    return $message;
}

#------------------------------------------------------------------------------

sub generate_message_title {
    my ( $self, @items, $extra ) = @_;

    my $class    = ref $self;
    my ($action) = $class =~ m/ ( [^:]* ) $/x;
    my $title    = "$action " . join( ', ', uniq(sort @items) ) . ( $extra ? " $extra" : '' );

    return $title;
}

#------------------------------------------------------------------------------

sub generate_message_template {
    my ( $self, $title, $stack, $diff ) = @_;

    # Prepend "#" to each line of the diff,
    # so they are treated as comments.
    $diff =~ s/^/# /gm;

    my $msg = <<"END_MESSAGE";
$title


#-------------------------------------------------------------------------------
# Please edit or amend the message above as you see fit.  The first line of the 
# message will be used as the title.  Any line that starts with a "#" will be 
# ignored.  To abort the commit, delete the entire message above, save the file, 
# and close the editor. 
#
# Changes to be committed to stack $stack:
#
$diff
END_MESSAGE

    chomp $msg;
    return $msg;
}

#------------------------------------------------------------------------------
1;

__END__

=pod

=encoding UTF-8

=for :stopwords Jeffrey Ryan Thalhammer

=head1 NAME

Pinto::Role::Committable - Role for actions that commit changes to the repository

=head1 VERSION

version 0.097

=head1 AUTHOR

Jeffrey Ryan Thalhammer <jeff@stratopan.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2013 by Jeffrey Ryan Thalhammer.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut