view release on metacpan or  search on metacpan

lib/App/Sqitch/Command/rework.pm  view on Meta::CPAN

sub execute {
    my $self = shift;
    my ($name, $targets, $changes) = $self->parse_args(
        names      => [$self->change_name],
        all        => $self->all,
        args       => \@_,
        no_changes => 1,
    );

    # Check if the name is identified as a change.
    $name ||= shift @{ $changes } || $self->usage;

    my $note = join "\n\n", => @{ $self->note };
    my ($first_change, %reworked, @files, %seen);

    for my $target (@{ $targets }) {
        my $plan   = $target->plan;
        my $file = $plan->file;
        my $spec = $reworked{$file} ||= { scripts => [] };
        my ($prev, $reworked);
        if ($prev = $spec->{prev}) {
            # Need a dupe for *this* target so script names are right.
            $reworked = ref($prev)->new(
                plan => $plan,
                name => $name,
            );

            # Copy the rework tags to the previous instance in this plan.
            my $new_prev = $spec->{prev} = $plan->get(
                $name . [$plan->last_tagged_change->tags]->[-1]->format_name
            );
            $new_prev->add_rework_tags($prev->rework_tags);
            $prev = $new_prev;

        } else {
            # Rework it.
            $reworked = $spec->{change} = $plan->rework(
                name      => $name,
                requires  => $self->requires,
                conflicts => $self->conflicts,
                note      => $note,
            );
            $first_change ||= $reworked;

            # Get the latest instance of the change.
            $prev = $spec->{prev} = $plan->get(
                $name . [$plan->last_tagged_change->tags]->[-1]->format_name
            );
        }

        # Record the files to be copied to the previous change name.
        push @{ $spec->{scripts} } => map {
            push @files => $_->[0] if -e $_->[0];
            $_;
        } grep {
            !$seen{ $_->[0] }++;
        } (
            [ $reworked->deploy_file, $prev->deploy_file ],
            [ $reworked->revert_file, $prev->revert_file ],
            [ $reworked->verify_file, $prev->verify_file ],
        );

        # Replace the revert file with the previous deploy file.
        push @{ $spec->{scripts} } => [
            $reworked->deploy_file,
            $reworked->revert_file,
            $prev->revert_file,
        ] unless $seen{$prev->revert_file}++;
    }

    # Make sure we have a note.
    $note = $first_change->request_note(
        for     => __ 'rework',
        scripts => \@files,
    );

    # Time to write everything out.
    for my $target (@{ $targets }) {
        my $plan = $target->plan;
        my $file = $plan->file;
        my $spec = delete $reworked{$file} or next;

        # Copy the files for this spec.
        $self->_copy(@{ $_ }) for @{ $spec->{scripts } };

        # We good, write the plan file back out.
        $plan->write_to( $plan->file );

        # Let the user know.
        $self->info(__x(
            'Added "{change}" to {file}.',
            change => $spec->{change}->format_op_name_dependencies,
            file   => $plan->file,
        ));
    }

    # Now tell them what to do.
    $self->info(__n(
        'Modify this file as appropriate:',
        'Modify these files as appropriate:',
        scalar @files,
    ));
    $self->info("  * $_") for @files;

    # Let 'em at it.
    if ($self->open_editor) {
        my $sqitch = $self->sqitch;
        $sqitch->shell( $sqitch->editor . ' ' . $sqitch->quote_shell(@files) );
    }

    return $self;
}

sub _copy {
    my ( $self, $src, $dest, $orig ) = @_;
    $orig ||= $src;
    if (!-e $orig) {
        $self->debug(__x(
            'Skipped {dest}: {src} does not exist',
            dest => $dest,
            src  => $orig,
        ));
        return;
    }

    # Create the directory for the file, if it does not exist.
    $self->_mkpath($dest->dir->stringify);

    # Stringify to work around bug in File::Copy warning on 5.10.0.
    File::Copy::syscopy "$src", "$dest" or hurl rework => __x(
        'Cannot copy {src} to {dest}: {error}',
        src   => $src,
        dest  => $dest,
        error => $!,
    );

    $self->debug(__x(
        'Copied {src} to {dest}',
        dest => $dest,
        src  => $src,
    ));
    return $orig;
}

1;

__END__

=head1 Name

App::Sqitch::Command::rework - Rework a Sqitch change

=head1 Synopsis

  my $cmd = App::Sqitch::Command::rework->new(%params);
  $cmd->execute;

=head1 Description

Reworks a change. This will result in the copying of the existing deploy,
revert, and verify scripts for the change to preserve the earlier instances of
the change.

=head1 Interface

=head2 Class Methods

=head3 C<options>

  my @opts = App::Sqitch::Command::rework->options;

Returns a list of L<Getopt::Long> option specifications for the command-line
options for the C<rework> command.

=head3 C<configure>

  my $params = App::Sqitch::Command::rework->configure(
      $config,
      $options,
  );

Processes the configuration and command options and returns a hash suitable
for the constructor.

=head2 Attributes

=head3 C<change_name>

The name of the change to be reworked.

=head3 C<note>

Text of the change note.

=head3 C<requires>

List of required changes.

=head3 C<conflicts>

List of conflicting changes.

=head3 C<all>

Boolean indicating whether or not to run the command against all plans in the
project.

=head2 Instance Methods

=head3 C<execute>

  $rework->execute($command);

Executes the C<rework> command.

=head1 See Also

=over

=item L<sqitch-rework>