view release on metacpan or  search on metacpan

lib/Dist/Zilla/Plugin/Git/FilePermissions.pm  view on Meta::CPAN

sub mvp_multivalue_args { return (qw( perms )) }

has _git => (
    is      => 'ro',
    isa     => 'Git::Background',
    lazy    => 1,
    default => sub { Git::Background->new( path( shift->zilla->root )->absolute ) },
);

has default => (
    is      => 'ro',
    isa     => 'Str',
    default => '0644',
);

has perms => (
    is      => 'ro',
    isa     => 'Maybe[ArrayRef]',
    default => sub { [] },
);

sub before_build {
    my ($self) = @_;

    my @files = $self->_git_ls_files();
    return if !@files;

    my @perms = $self->_permissions;

  FILE:
    for my $file (@files) {

        # Git reports submodules as a file although they are a directory on
        # the file system. We skip them because the default permissions of
        # 0644 are suboptimal for directories.
        next FILE if !-f $file;

        # default permission
        my $perm = oct( $self->default );

      PERMS:
        for my $perm_ref (@perms) {
            my ( $regex, $p ) = @{$perm_ref};

            next PERMS if $file !~ m{$regex};

            $perm = $p;
            last PERMS;
        }

        if ( $perm eq q{-} ) {
            $self->log_debug("Ignoring permissions of file $file");
            next FILE;
        }

        my $current_perm = ( stat $file )[2] & 07777;

        if ( $current_perm != $perm ) {
            $self->log( sprintf "Setting permission of $file to %o", $perm );

            my $rc = chmod $perm, $file;
            if ( $rc != 1 ) {
                $self->log_fatal( sprintf "Unable to change permissions of file $file to %o", $perm );
            }
        }
    }

    return;
}

sub _git_ls_files {
    my ($self) = @_;

    my $git = $self->_git;

    my $files_f = $git->run('ls-files')->await;

    $self->log_fatal( scalar $files_f->failure ) if $files_f->is_failed;

    my @files = $files_f->stdout;
    return @files;
}

sub _permissions {
    my ($self) = @_;

    my @perms;

  LINE:
    for my $line ( @{ $self->perms } ) {
        my ( $regex, $perm ) = $line =~ m{ ( .+ ) \s+ ((?: 0[0-9]+ | - )) \s* $ }xsm;

        if ( !defined $perm ) {
            $self->log_fatal("Unable to parse permissions line: $line");
        }

        push @perms, [
            $regex,
            $perm eq q{-} ? q{-} : oct($perm),
        ];
    }

    return @perms;
}

__PACKAGE__->meta->make_immutable;

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Dist::Zilla::Plugin::Git::FilePermissions - fix the file permissions in your Git repository with Dist::Zilla

=head1 VERSION