The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package Dist::Maker::Command::new;
use Mouse;
use MouseX::StrictConstructor;

use Dist::Maker::Scatter;
use Dist::Maker::Name;
use Dist::Maker::Util qw(parse_options p);
use File::Spec;
use File::Basename ();
use Cwd ();

extends 'Dist::Maker::Base';

sub pass_through { 0 }

sub option_spec {
    return(
        'dry-run|n',
        'force|f',
    );
}

sub _predir {
    my($path) = @_;
    return $path =~ m{/}
        ? +(split qr{/}, $path)[0] // ''
        : '';
}

sub run {
    my $self = shift;
    my($options, $filename, $template) = $self->parse_options(@_);
    if(!$filename) {
        $self->diag("File name is not given.\n");
        return undef;
    }

    if($filename =~ /::/) {
        $filename  =~ s{::}{/}g;
        $filename .= ".pm";
    }

    my $meta = $self->get_meta();
    $template //= $meta->{template};

    my $dist = Dist::Maker::Name->new($meta->{dist});
    $self->note("running with $filename $template in $dist\n");

    my($suffix) = ($filename =~ / (\.[^.]+) \z/xms);
    if(!defined $suffix) {
        $self->diag("Cannot determin the prototype from '$filename' (no prototype)\n");
        return undef;
    }
    my $suffix_rx = qr/\Q$suffix\E \z/xms;

    $dist->module(q{<: $package :>});
    my $dms = Dist::Maker::Scatter->new(
        dist     => $dist,
        template => $template,
        config   => $self->config,
    );

    my @candidates;
    foreach my $name(keys %{$dms->content_map}) {
        if($name =~ $suffix_rx) {
            push @candidates, $name;
        }
    }

    my $dir = _predir($filename);

    if(@candidates == 0) {
        $self->diag("Cannot determin the prototype for '$filename' (no candidates)\n");
        return undef;
    }
    elsif(@candidates > 1) {
        $self->info("Candidates: @candidates\n");

        # heulistic methods

        my %p;
        foreach my $c(@candidates) {
            $p{$c} = 0;
            # if the directory is matched, it is stronger
            if(_predir($c) eq $dir) {
                $p{$c}++;
            }

            # for tests, 't/001_*' is stronger
            if($suffix eq '.t' and $c =~ m{\A t/001 }xms) {
                $p{$c}++;
            }
        }
        @candidates = sort {
            $p{$b} <=> $p{$a} # sort by strongness
            || $a cmp $b;     # ... or leave the work to the dictionary!
        } keys %p;
    }

    my $prototype      = shift @candidates;
    my $prototype_dir = _predir($prototype);
    if($prototype_dir ne $dir) {
        if($suffix eq '.pm') {
            (my $f = $prototype) =~ s{ $suffix \z} {/$filename}xms;
            $filename = $f;
        }
        else {
            $filename = "$prototype_dir/$filename";
        }
    }

    $self->note("create $filename from $prototype\n");
    if(-e $filename && !$options->{force}) {
        $self->diag("$filename already exists. Finished.\n");
        return undef;
    }
    if(!$options->{'dry-run'}) {
        my $package = $filename;
        $package =~ s{\A $prototype_dir/ }{}xms;
        $package =~ s{$suffix}{}xms;
        $package =~ s{/+}{::}xmsg;
        $package =~ s{-+}{::}xmsg;

        my $content = $dms->render_string($dms->content_map->{$prototype}, {
            package => $package,
        });
        $dms->scatter('.', { $filename => $content });
    }

    $self->note("finished.\n");
    return 1;
}

sub get_meta {
    my($self) = @_;
    my $cwd  = Cwd::getcwd();
    my $dir  = $cwd;
    while(1) {
        if(-e "$dir/.dim.pl") {
            $self->info("Readng '$dir/.dim.pl'\n");
            my $data = do "$dir/.dim.pl";
            if($data) {
                return $data;
            }
            last;
        }

        my $d = File::Basename::dirname($dir); # updir
        if($dir eq $d) {
            last;
        }
        else {
            $dir = $d;
        }
    }

    # the last resort: from the current directory
    return {
        dist     => File::Basename::basename($cwd),
        template => 'Default',
    };
}


no Mouse;
__PACKAGE__->meta->make_immutable();
__END__

=head1 NAME

Dist::Maker::Command::new - Creates a new file

=cut