DhMakePerl::Command::refresh - dh-make-perl refresh implementation

package DhMakePerl::Command::refresh;

use strict; use warnings;

use base 'DhMakePerl::Command::Packaging';
use Debian::Control::FromCPAN;
use Debian::WNPP::Query ();
use File::Spec::Functions qw(catfile);
use Tie::File;

sub execute {
    my $self = shift;

    $self->main_dir( $ARGV[0] || '.' );
    print "Engaging refresh mode in " . $self->main_dir . "\n"
        if $self->cfg->verbose;

    if ( not $self->cfg->_explicitly_set->{'source-format'}
        and -e ( my $f = catfile( $self->debian_file('source'), 'format' ) ) )
    {
        open( my $fh, '<', $f ) or die "open($f): $!";
        my $present = <$fh>;
        close $fh;

        chomp($present) if $present;
        if ($present) {
            $self->cfg->source_format($present);
            print "Detected source format: $present\n"
                if $self->cfg->verbose;
        }
    }

    $self->control->read( $self->debian_file('control') );
    $self->fill_maintainer;
    $self->process_meta;
    $self->extract_basic();    # also detects arch-dep package

    $self->extract_docs     if 'docs'     ~~ $self->cfg->only;
    $self->extract_examples if 'examples' ~~ $self->cfg->only;
    print "Found docs: @{ $self->docs }\n"
        if @{ $self->docs } and $self->cfg->verbose;
    print "Found examples: @{ $self->examples }\n"
        if @{ $self->examples } and $self->cfg->verbose;

    if ( 'rules' ~~ $self->cfg->only ) {
        $self->create_rules;
        if ( !-f $self->debian_file('compat') or $self->cfg->dh == 7 ) {
            $self->create_compat( $self->debian_file('compat') );
        }
    }

    if ( 'examples' ~~ $self->cfg->only ) {
        $self->update_file_list( examples => $self->examples );
    }

    if ( 'docs' ~~ $self->cfg->only ) {
        $self->update_file_list( docs => $self->docs );
    }

    if ( 'copyright' ~~ $self->cfg->only ) {
        $self->backup_file( $self->debian_file('copyright') );
        $self->create_copyright( $self->debian_file('copyright') );
    }

    if ( 'control' ~~ $self->cfg->only ) {
        my $control = $self->control;
        if ( -e catfile( $self->debian_file('patches'), 'series' )
            and $self->cfg->source_format ne '3.0 (quilt)' )
        {
            $self->add_quilt($control);
        }
        else {
            $self->drop_quilt($control);
        }

        $self->write_source_format(
            catfile( $self->debian_dir, 'source', 'format' ) );

        $self->discover_dependencies;

        $self->discover_utility_deps($control);
        $control->prune_perl_deps();

        $self->backup_file( $self->debian_file('control') );
        $control->write( $self->debian_file('control') );
    }

    print "--- Done\n" if $self->cfg->verbose;
    return 0;
}

sub add_quilt {
    my( $self, $control ) = @_;

    $self->read_rules;

    $self->rules->add_quilt;

    # README.source
    my $quilt_mini_doc = <<EOF;
This package uses quilt for managing all modifications to the upstream
source. Changes are stored in the source package as diffs in
debian/patches and applied during the build.

See /usr/share/doc/quilt/README.source for a detailed explaination.
EOF

    my $readme = $self->debian_file('README.source');
    my $quilt_already_documented = 0;
    my $readme_source_exists = -e $readme;
    if($readme_source_exists) {
        my @readme;
        tie @readme, 'Tie::File', $readme
            or die "Unable to tie '$readme': $!";

        for( @readme ) {
            if( m{quilt/README.source} ) {
                $quilt_already_documented = 1;
                last;
            }
        }
    }

    print "README.source already documents quilt\n"
        if $quilt_already_documented and $self->cfg->verbose;

    unless($quilt_already_documented) {
        my $fh;
        open( $fh, '>>', $readme )
            or die "Unable to open '$readme' for writing: $!";

        print $fh "\n\n" if $readme_source_exists;
        print $fh $quilt_mini_doc;
        close $fh;
    }
}

sub drop_quilt {
    my( $self, $control ) = @_;

    $self->read_rules;

    $self->rules->drop_quilt;

    # README.source
    my $readme = $self->debian_file('README.source');

    if( -e $readme ) {
        my @readme;
        tie @readme, 'Tie::File', $readme
            or die "Unable to tie '$readme': $!";

        my( $start, $end );
        for( my $i = 0; defined( $_ = $readme[$i] ); $i++ ) {
            if( m{^This package uses quilt } ) {
                $start = $i;
                next;
            }

            if( defined($start)
                    and m{^See /usr/share/doc/quilt/README.source} ) {
                $end = $i;
                last;
            }
        }

        if( defined($start) and defined($end) ) {
            print "Removing references to quilt from README.source\n"
                if $self->cfg->verbose;

            splice @readme, $start, $end-$start+1;

            # file is now empty?
            if( join( '', @readme ) =~ /^\s*$/ ) {
                unlink $readme
                    or die "unlink($readme): $!";
            }
        }
    }
}

1;