pkg-perl-tools 0.42 / usr / bin / patchedit

#!/usr/bin/perl

=pod

=head1 NAME

B<patchedit> - Edit headers of a patch according to DEP3

=head1 SYNOPSIS

B<patchedit> [I<command>] F<patchfile>

=head1 DESCRIPTION

B<patchedit> is a helper script for managing patch headers according to
L<http://dep.debian.net/deps/dep3/>.

=head1 COMMANDS

=over

=item I<edit> (default)

Opens F<patchfile> in EDITOR (or VISUAL or sensible-editor) and

=over

=item * checks all headers

=item * marks problems

=item * adds missing required headers with proposals for their values

=back

If no command is given, I<edit> is chosen automatically.

=item I<check>

Does a non-interactive check if the headers conform to DEP3. Prints the
results (missing required headers, wrong values, ...) to stdout.

=back

=head1 ARGUMENTS

=over

=item F<patchfile> (required)

The patch to work on.

=back

=head1 OPTIONS

=over

=item B<-f|--fix>

Tries to fix problems in the headers when editing/checking patches.

=item B<-o|--optional>

Also add/print missing optional headers.

=item B<-h|--help>

Help output.

=back

=head1 ENVIRONMENT

B<patchedit> respects DEBEMAIL (or EMAIL) and DEBFULLNAME (for new Author or
Reviewed-by headers).

=head1 NOTE

This script is not pkg-perl specific. It should go into I<devscripts>
eventually.

=head1 TODO

 * preserve the extra fields
 * preserve the order of the fields

=head1 COPYRIGHT AND LICENSE

Copyright 2010, Jozef Kutej <jkutej@cpan.org>.

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

=cut

use strict;
use warnings;

use 5.010;

use Getopt::Long;
use Pod::Usage;
use Test::Builder;
use DateTime;
use List::MoreUtils 'none';
use User::pwent;

use open ':std', ':encoding(UTF-8)';

our @standard_fields = qw(
    Description
    Subject
    Origin
    Bug
    Forwarded
    Author
    From
    Reviewed-by
    Acked-by
    Last-Update
    Applied-Upstream
);

exit main() unless caller();

sub main {
    my $help;
    my $do_fix        = 0;
    my $also_optional = 0;
    GetOptions(
        'help|h'     => \$help,
        'optional|o' => \$also_optional,
        'fix|f'      => \$do_fix,
    ) or pod2usage;
    pod2usage if $help or !@ARGV;

    my $cmd = shift @ARGV;

    # make the edit default
    if ( $cmd !~ m{^(edit|check)$} ) {
        unshift @ARGV, $cmd;
        $cmd = 'edit';
    }

    my @patch_files = @ARGV;

    pod2usage if ( ( not $cmd ) or ( not @patch_files ) );

    foreach my $patch_file (@patch_files) {
        die 'no such file "' . $patch_file . '"'
            if not -f $patch_file;

        if ( $cmd eq 'edit' ) {
            fix_patch( $patch_file, $also_optional ) if $do_fix;
            edit_patch($patch_file);
        }
        elsif ( $cmd eq 'check' ) {
            check_patch( $patch_file, $also_optional );
            fix_patch( $patch_file, $also_optional ) if $do_fix;
        }
    }

    return 0;
}

sub fix_patch {
    my $patch         = shift;
    my $also_optional = shift;

    my $patch_struct  = _read_patch($patch);
    my $patch_content = $patch_struct->{fields};
    $patch_content->{'Description'} = "*** FIXME ***\n"
        unless $patch_content->{'Description'} || $patch_content->{'Subject'};
    $patch_content->{'Origin'} = "vendor\n"
        unless $patch_content->{'Origin'} || $patch_content->{'Author'};

    if ($also_optional) {
        $patch_content->{'Bug'} = "*** FIXME ***\n"
            unless scalar( grep {m/Bug-?/} keys %{$patch_content} );

        $patch_content->{'Forwarded'} ||= "*** FIXME ***\n";

        my $gecosname = getpwuid($<)->gecos;
        $gecosname =~ s/,.*//;
        my $authorname ||= ( $ENV{DEBFULLNAME} || $gecosname );
        my $authoremail ||= ( $ENV{DEBEMAIL} || $ENV{EMAIL} );
        my $author = $authorname . ' <' . $authoremail . '>';

        $patch_content->{'Author'} ||= "$author\n"
            unless $patch_content->{'Author'} || $patch_content->{'From'};
        $patch_content->{'Reviewed-by'} ||= "$author\n"
            unless $patch_content->{'Reviewed-by'}
            || $patch_content->{'Acked-by'};
        # stat[9] = mtime
        $patch_content->{'Last-Update'}
            = DateTime->from_epoch( epoch => ( stat($patch) )[9] )
            ->set_time_zone('local')->strftime('%Y-%m-%d')
            . "\n";
        $patch_content->{'Applied-Upstream'} ||= "*** FIXME ***\n";
    }

    _write_patch( $patch, $patch_struct );
}

sub _write_patch {
    my $patch         = shift;
    my $patch_struct  = shift;
    my $patch_content = $patch_struct->{fields};

    open( my $patch_fh, '>', $patch )
        or die 'failed to open "' . $patch . '" - ' . $!;
    print $patch_fh $patch_struct->{header}{head} if $patch_struct->{header};
    foreach my $key (@standard_fields) {
        if ( $patch_content->{$key} ) {
            print $patch_fh '# '
                if $patch_struct->{header};
            print $patch_fh $key, ': ', $patch_content->{$key};
        }
        if ( $key eq 'Bug' ) {
            foreach my $key ( grep {m/Bug-/} sort keys %{$patch_content} ) {
                print $patch_fh '# '
                    if $patch_struct->{header};
                print $patch_fh $key, ': ', $patch_content->{$key};
            }
        }
    }
    print $patch_fh $patch_struct->{header}{tail} if $patch_struct->{header};
    print $patch_fh "\n";
    print $patch_fh $patch_struct->{body};
    close($patch_fh);
}

sub check_patch {
    my $patch         = shift;
    my $also_optional = shift;

    my $patch_struct  = _read_patch($patch);
    my $patch_content = $patch_struct->{fields};
    my $tb            = Test::Builder->new;
    $tb->plan( 'tests' => 9 );
    $tb->ok( $patch_content->{'Description'} || $patch_content->{'Subject'},
        'has Description or Subject' );
    $tb->ok( $patch_content->{'Origin'} || $patch_content->{'Author'},
        'has Origin or Author' );

    if ($also_optional) {
        if ( scalar( grep {m/Bug-?/} keys %{$patch_content} ) ) {
            $tb->ok( 1, 'has Bug or Bug-???' );
        }
        else {
            $tb->todo_skip('Bug or Bug-??? missing');
        }
        if ( $patch_content->{'Forwarded'} ) {
            $tb->ok( 1, 'has Forwarded' );
        }
        else {
            $tb->todo_skip('Forwarded missing');
        }
        if ( $patch_content->{'Author'} || $patch_content->{'From'} ) {
            $tb->ok( 1, 'has Author or From' );
        }
        else {
            $tb->todo_skip('Author or From missing');
        }
        if ( $patch_content->{'Reviewed-by'} || $patch_content->{'Acked-by'} )
        {
            $tb->ok( 1, 'has Reviewed-by or Acked-by' );
        }
        else {
            $tb->todo_skip('Reviewed-by or Acked-by missing');
        }
        if ( $patch_content->{'Last-Update'} ) {
            $tb->ok( $patch_content->{'Last-Update'}, 'has Last-Update' );
        }
        else {
            $tb->todo_skip('Last-Update missing');
        }
        if ( $patch_content->{'Applied-Upstream'} ) {
            $tb->ok( 1, 'has Applied-Upstream' );
        }
        else {
            $tb->todo_skip('Applied-Upstream missing');
        }
    }
    else {
        $tb->skip('skipping optional') foreach ( 1 .. 6 );
    }
    my @extra_fields
        = grep { $_ ne '_patch' }    # _patch is ok
        grep {
        my $key = $_;
        none { $_ eq $key } @standard_fields
        }                            # grep out standard fields
        grep { not m/^Bug-/ }        # different bugs are fine
        keys %{$patch_content};
    if ( @extra_fields == 0 ) {
        $tb->ok( 1, 'no extra fields' );
    }
    else {
        $tb->skip( 'some extra fields - ' . join( ', ', @extra_fields ) );
        $tb->note(
            join( "\n",
                map { $_ . ': ' . $patch_content->{$_} } @extra_fields )
        );
    }
}

sub edit_patch {
    my $patch = shift;

    my $editor = $ENV{'EDITOR'} || $ENV{'VISUAL'} || '/usr/bin/editor';
    system( "$editor $patch" );
}

sub _read_patch {
    my $patch = shift;
    my %patch_content;

    open( my $patch_fh, '<', $patch )
        or die 'failed to open "' . $patch . '" - ' . $!;

# Peek at the first line and see if we are dealing with a normal patch or with
# dpatch. We assume that if the file starts with a shebang (#!) that we are
# dealing with dpatch.
    my $use_classic = 1;
    my $line        = <$patch_fh>;
    if ( $line =~ /^#!/ ) {
        $use_classic = 0;
    }

    # Rewind the file handle back to the beeking.
    seek $patch_fh, 0, 0;

    my $patch_content;
    if ($use_classic) {
        $patch_content = _read_patch_classic($patch_fh);
    }
    else {
        $patch_content = _read_patch_dpatch($patch_fh);

    }
    close($patch_fh);

    return $patch_content;
}

sub _read_patch_classic {
    my ($patch_fh) = @_;

    my %patch_content = (
        header => undef,
        body   => '',
        fields => {},
    );
    my $key        = '';
    my $header_end = 0;
    while ( my $line = <$patch_fh> ) {
        if ( !$header_end and $line =~ /^--- / ) {

            # Start of the patch body
            $header_end = 1;
        }

        if ($header_end) {

            # Slurping the patch
            $patch_content{body} .= $line;
            next;
        }

        if ( $line =~ m/^ (\S+) : \s+ (.+) $/xms ) {

            # Starting a new field
            my $value;
            ( $key, $value ) = ( $1, $2 );
            $patch_content{fields}{$key} = $value;
            next;
        }

        if ( $line =~ m/^ / or $key eq 'Subject' ) {

            # Previous field not over
            $patch_content{fields}{$key} .= $line;
            next;
        }

        # End of header but not yet the start of patch (before ---)
        $header_end = 1;
        $patch_content{body} .= $line;
    }

    # remove the first empty line (will be added automaticaly)
    $patch_content{body} =~ s/\A\s+//xms;

    return \%patch_content;
}

sub _read_patch_dpatch {
    my ($patch_fh) = @_;

    my %patch_content = (
        header => {
            head => scalar <$patch_fh>,
            tail => '',
        },
        body   => '',
        fields => {},
    );

    my $key        = '';
    my $header_end = 0;
    my $spaces     = '--- ';
    while ( my $line = <$patch_fh> ) {

        if ( !$header_end and $line =~ /^--- / ) {

            # Start of the patch body
            $header_end = 1;
        }

        if ($header_end) {

            # Slurping the patch
            $patch_content{body} .= $line;
            next;
        }

        if ( $line =~ m/^ \# (\s+) (\S+) : \s+ (.+) $/xms ) {

            # Starting a new field
            my $value;
            ( $spaces, $key, $value ) = ( $1, $2, $3 );
            die $line if not $key;
            $patch_content{fields}{$key} = $value;
            next;
        }

        if ( $line =~ m/^ \# $spaces \s+ /xms or $key eq 'Subject' ) {

            # Previous field not over
            $patch_content{fields}{$key} .= $line;
            next;
        }

        if ( $line =~ m/^ \# /xms ) {

            # Still in the header
            $patch_content{header}{ $key ? 'tail' : 'head' } .= $line;
            next;
        }

        # End of header but not yet the start of patch (before ---)
        $header_end = 1;
        $patch_content{body} .= $line;
    }

    # remove the first empty line (will be added automaticaly)
    $patch_content{body} =~ s/\A\s+//xms;

    return \%patch_content;
}