view release on metacpan or  search on metacpan

lib/CPANPLUS/Dist/Debora/Package.pm  view on Meta::CPAN

    my @files = map { $_->{name} } grep { $_->{type} eq $type } @{$self->files};

    return \@files;
}

sub mb_opt {
    my $self = shift;

    my $installdirs = $self->installdirs;

    return << "END_MB_OPT";
--installdirs $installdirs
END_MB_OPT
}

sub mm_opt {
    my $self = shift;

    my $installdirs = $self->installdirs;

    return << "END_MM_OPT";
INSTALLDIRS=$installdirs
END_MM_OPT
}

sub sanitize_stagingdir {
    my $self = shift;

    my $fail_count = 0;

    my $finddepth = sub {
        my $dir = shift;

        opendir my $dh, $dir
            or croak "Could not traverse '$dir': $OS_ERROR";
        ENTRY:
        while (defined(my $entry = readdir $dh)) {
            next ENTRY if $entry eq q{.} || $entry eq q{..};

            my $path = catfile($dir, $entry);

            # Skip symbolic links.
            next ENTRY if -l $path;

            # Process sub directories first.
            if (-d $path) {
                __SUB__->($path);
            }

            # Sanitize the permissions.
            my @stat = lstat $path;
            if (!@stat) {
                error("Could not stat '$path': $OS_ERROR");
                next ENTRY;
            }

            my $old_mode = $stat[2] & oct '0777';
            my $new_mode = ($old_mode & oct '0755') | oct '0200';
            if ($old_mode != $new_mode) {
                if (!chmod $new_mode, $path) {
                    error("Could not chmod '$path': $OS_ERROR");
                    ++$fail_count;
                }
            }

            # Remove empty directories and some files.
            if (-d $path) {
                rmdir $path;
            }
            else {
                if (   $entry eq 'perllocal.pod'
                    || $entry eq '.packlist'
                    || $entry =~ m{[.]la \z}xms
                    || ($entry =~ m{[.]bs \z}xms && -z $path))
                {
                    if (!unlink $path) {
                        error("Could not remove '$path': $OS_ERROR");
                        ++$fail_count;
                    }
                }
            }
        }
        closedir $dh;

        return;
    };
    $finddepth->($self->stagingdir);

    return $fail_count == 0;
}

sub remove_stagingdir {
    my $self = shift;

    my $stagingdir = $self->{stagingdir};
    if (defined $stagingdir) {
        remove_tree($stagingdir);
        delete $self->{stagingdir};
    }

    return 1;
}

sub rpm_cmd {
    my $self = shift;

    state $rpm_cmd = can_run('rpm');

    return $rpm_cmd;
}

sub rpm_eval {
    my ($self, $expr) = @_;

    my $string = q{};

    my $rpm_cmd = $self->rpm_cmd;
    if ($rpm_cmd) {
        my @eval_cmd = ($rpm_cmd, '--eval', $expr);
        my $output   = q{};
        if (run(command => \@eval_cmd, buffer => \$output)) {

lib/CPANPLUS/Dist/Debora/Package.pm  view on Meta::CPAN

        = map { $get_license->($_->spdx_expression) } values %unique_guesses;
    if (!@licenses) {
        push @licenses, $get_license->($LICENSE_FOR{$self->dist_name});
    }

    my @sorted_licenses
        = sort { $a->spdx_expression cmp $b->spdx_expression } @licenses;

    return \@sorted_licenses;
}

sub _get_license {
    my $self = shift;

    my @names   = map { $_->spdx_expression } @{$self->licenses};
    my $license = join ' AND ',
        map { @names > 1 && m{\b OR \b}xmsi ? "($_)" : $_ } @names;

    return $license;
}

sub _get_docfiles {
    my $self = shift;

    my $LICENSE = qr{ \A (?:
       COPYING(?:[.](?:LESSER|LIB))?
       | COPYRIGHT
       | LICEN[CS]E
       ) (?:[.](?:md|mkdn|pod|txt))? \z
    }xmsi;

    my $CHANGELOG = qr{ \A (?:
        Change(?:s|Log)
        ) (?:[.](?:md|mkdn|pod|txt))? \z
    }xmsi;

    my $DOC = qr{ \A (?:
        AUTHORS
        | BUGS
        | CONTRIBUTING
        | CREDITS
        | FAQ
        | NEWS
        | README
        | THANKS
        | TODO
        ) (?:[.](?:md|mkdn|pod|txt))? \z
    }xmsi;

    my %regex_for = (
        'license'   => $LICENSE,
        'changelog' => $CHANGELOG,
        'doc'       => $DOC,
    );

    my @files;

    my $fix_permissions = sub {
        my $dir = shift;

        chmod oct '0755', $dir;

        opendir my $dh, $dir
            or croak "Could not traverse '$dir': $OS_ERROR";
        ENTRY:
        while (defined(my $entry = readdir $dh)) {
            next ENTRY if $entry eq q{.} || $entry eq q{..};

            my $path = catfile($dir, $entry);

            # Skip symbolic links.
            next ENTRY if -l $path;

            if (-d $path) {
                __SUB__->($path);
            }
            else {
                chmod oct '0644', $path;
            }
        }
        closedir $dh;

        return;
    };

    my $find = sub {
        my $dir = shift;

        opendir my $dh, $dir
            or croak "Could not traverse '$dir': $OS_ERROR";
        ENTRY:
        while (defined(my $entry = readdir $dh)) {
            next ENTRY if $entry eq q{.} || $entry eq q{..};

            my $path = catfile($dir, $entry);

            # Skip symbolic links.
            next ENTRY if -l $path;

            if (-d $path) {
                if ($entry eq 'examples') {
                    $fix_permissions->($path);
                    my $file = {name => $entry, type => 'doc'};
                    push @files, $file;
                }
            }
            elsif (-s $path) {
                TYPE:
                for my $type (keys %regex_for) {
                    if ($entry =~ $regex_for{$type}) {
                        chmod oct '0644', $path;
                        my $file = {name => $entry, type => $type};
                        push @files, $file;
                        last TYPE;
                    }
                }
            }
        }
        closedir $dh;

        return;
    };
    $find->($self->builddir);

    my @sorted_files = sort { $a->{name} cmp $b->{name} } @files;

    return \@sorted_files;
}

sub _get_excludedirs {
    my $self = shift;

    # A list of directories that are provided by Perl and must not be removed
    # by packages.

    my @vars = qw(
        installsitearch
        installsitebin
        installsitelib
        installsiteman1dir
        installsiteman3dir
        installsitescript
        installvendorarch
        installvendorbin
        installvendorlib
        installvendorman1dir
        installvendorman3dir
        installvendorscript
    );

    my %excludedirs = map { $_ => 1 } qw(/etc);
    VAR:
    for my $var (@vars) {
        my $value = $Config{$var};
        next VAR if !$value;

        if ($var =~ m{arch \z}xms) {
            $value = catdir($value, 'auto');
        }

        my ($volume, $path) = File::Spec->splitpath($value, 1);

        my ($dir, @dirs) = splitdir($path);
        while (@dirs) {
            $dir = catdir($dir, shift @dirs);
            $excludedirs{$dir} = 1;
        }
    }

    return \%excludedirs;
}