#!/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. Either a full path or the name of the file in
F<./debian/patches>.

=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 (not $cmd ~~ ['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;
		
		given ($cmd) {
			when ('edit') {
				fix_patch($patch_file, $also_optional)
					if $do_fix;
				edit_patch($patch_file);
			}
			when ('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'};
		$patch_content->{'Last-Update'} ||= DateTime->now->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;
}