From Code to Community: Sponsoring The Perl and Raku Conference 2025 Learn more

use strict;
use File::Spec::Functions qw(catfile catdir);
use CPANPLUS::Error qw(error msg);
use Digest::MD5 qw();
use Pod::Select qw();
use File::Path qw(mkpath);
use File::Copy qw(copy);
use File::stat qw(stat);
use IPC::Cmd qw(run can_run);
use Readonly qw(Readonly);
use English qw(-no_match_vars);
our $VERSION = '0.08';
####
#### CLASS CONSTANTS
####
Readonly my $MKPKGCONF_FQP => '/etc/makepkg.conf';
Readonly my $CPANURL => 'http://search.cpan.org';
Readonly my $ROOT_USER_ID => 0;
Readonly my $NONROOT_WARNING => <<'END_MSG';
In order to install packages as a non-root user (highly recommended)
you must have a sudo-like command specified in your CPANPLUS
configuration.
END_MSG
# Override a package's name to conform to packaging guidelines.
# Copied entries from CPANPLUS::Dist::Pacman.
Readonly my $PKGNAME_OVERRIDES =>
{ map { split /[\s=]+/ } split /\s*\n+\s*/, <<'END_OVERRIDES' };
libwww-perl = perl-libwww
mod_perl = perl-modperl
glade-perl-two = perl-glade-two
aceperl = perl-ace
END_OVERRIDES
=for Mini-Template Format
The template format is very simple, to insert a template variable
use [% var_name %] this will insert the template variable's value.
The print_template() sub will throw: 'Template variable ... was
not provided' if the variable given by var_name is not defined.
[% IF var_name %] ... [% FI %] will remove the ... stuff if the
variable named var_name is not set to a true value.
WARNING: IF blocks cannot be nested!
See the _process_template method below.
=cut
# Crude template for our PKGBUILD script
Readonly my $PKGBUILD_TEMPL => <<'END_TEMPL';
# Contributor: [% packager %]
# Generator : CPANPLUS::Dist::Arch [% version %]
pkgname='[% pkgname %]'
pkgver='[% pkgver %]'
pkgrel='1'
pkgdesc="[% pkgdesc %]"
arch=('i686' 'x86_64')
license=('PerlArtistic' 'GPL')
options=('!emptydirs')
depends=([% pkgdeps %])
url='[% disturl %]'
source=('[% srcurl %]')
md5sums=('[% md5sum %]')
build() {
export PERL_MM_USE_DEFAULT=1
( cd "${srcdir}/[% distdir %]" &&
[% IF is_makemaker %]
perl Makefile.PL INSTALLDIRS=vendor &&
make &&
[% skiptest_comment %] make test &&
make DESTDIR="${pkgdir}/" install
) || return 1;
[% FI %]
[% IF is_modulebuild %]
perl Build.PL --installdirs=vendor --destdir="$pkgdir" &&
./Build &&
[% skiptest_comment %] ./Build test &&
./Build install
) || return 1;
[% FI %]
find "$pkgdir" -name .packlist -delete
find "$pkgdir" -name perllocal.pod -delete
}
END_TEMPL
####
#### CLASS GLOBALS
####
our ($PKGDEST, $PACKAGER);
$PACKAGER = 'Anonymous';
READ_CONF:
{
# Read makepkg.conf to see if there are system-wide settings
my $mkpkgconf;
if ( ! open $mkpkgconf, '<', $MKPKGCONF_FQP ) {
error "Could not read $MKPKGCONF_FQP: $!";
last READ_CONF;
}
my %cfg_vars = ( 'PKGDEST' => \$PKGDEST,
'PACKAGER' => \$PACKAGER );
my $cfg_var_match = '(' . join( '|', keys %cfg_vars ) . ')';
while (<$mkpkgconf>) {
if (/ ^ $cfg_var_match = "? (.*?) "? $ /xmso) {
${$cfg_vars{$1}} = $2;
}
}
close $mkpkgconf or error "close on makepkg.conf: $!";
}
####
#### PUBLIC CPANPLUS::Dist::Base Interface
####
sub format_available
{
for my $prog ( qw/ makepkg pacman / ) {
if ( ! can_run($prog) ) {
error "CPANPLUS::Dist::Arch needs to run $prog, to work properly";
return 0;
}
}
return 1;
}
sub init
{
my $self = shift;
$self->status->mk_accessors( qw{ pkgname pkgver pkgbase pkgdesc
pkgurl pkgsize pkgarch
builddir destdir } );
return 1;
}
sub prepare
{
my $self = shift;
my $status = $self->status; # Private hash
my $module = $self->parent; # CPANPLUS::Module
my $intern = $module->parent; # CPANPLUS::Internals
my $conf = $intern->configure_object; # CPANPLUS::Configure
my $distcpan = $module->status->dist_cpan; # CPANPLUS::Dist::MM or
# CPANPLUS::Dist::Build
$self->_prepare_status;
$status->prepared(0);
# Call CPANPLUS::Dist::Base's prepare to resolve our pre-reqs.
return $self->SUPER::prepare(@_);
}
sub create
{
my ($self, %opts) = (shift, @_);
my $status = $self->status; # Private hash
my $module = $self->parent; # CPANPLUS::Module
my $intern = $module->parent; # CPANPLUS::Internals
my $conf = $intern->configure_object; # CPANPLUS::Configure
my $distcpan = $module->status->dist_cpan; # CPANPLUS::Dist::MM or
# CPANPLUS::Dist::Build
# Create directories for building and delivering the new package.
for my $dir ( $status->pkgbase, $status->destdir ) {
if ( -e $dir ) {
die "$dir exists but is not a directory!" if ( ! -d _ );
die "$dir exists but is read-only!" if ( ! -w _ );
}
else {
mkpath $dir
or die qq{failed to create directory '$dir': $OS_ERROR};
if ( $opts{verbose} ) { msg "Created directory $dir" }
}
}
my $pkg_type = $opts{pkg} || $opts{pkgtype} || 'bin';
$pkg_type = lc $pkg_type;
die qq{Invalid package type requested: "$pkg_type"
Package type must be 'bin' or 'src'}
unless ( $pkg_type =~ /^(?:bin|src)$/ );
if ( $opts{verbose} ) {
my %fullname = ( bin => 'binary', src => 'source' );
msg "Creating a $fullname{$pkg_type} pacman package";
}
if ( $pkg_type eq 'bin' ) {
# Use CPANPLUS::Dist::Base to make packages for pre-requisites...
# (starts the packaging process for any missing ones)
my @ok_resolve_args = qw/ verbose target force prereq_build /;
my %resolve_args = map { ( exists $opts{$_} ?
($_ => $opts{$_}) : () ) } @ok_resolve_args;
$distcpan->_resolve_prereqs( %resolve_args,
'format' => ref $self,
'prereqs' => $module->status->prereqs );
}
# Prepare our file name paths for pkgfile and source tarball...
my $pkgfile = join '-', ( qq{${\$status->pkgname}},
qq{${\$status->pkgver}},
( $pkg_type eq q{bin}
? ( q{1}, qq{${\$status->pkgarch}.pkg.tar.gz} )
: q{1.src.tar.gz} )
);
my $srcfile_fqp = $status->pkgbase . '/' . $module->package;
my $pkgfile_fqp = $status->pkgbase . "/$pkgfile";
# Prepare our 'makepkg' package building directory,
# namely the PKGBUILD and source tarball files...
if ( ! -e $srcfile_fqp ) {
my $tarball_fqp = $module->_status->fetch;
link $tarball_fqp, $srcfile_fqp
or error "Failed to create link to $tarball_fqp: $OS_ERROR";
}
$self->create_pkgbuild($self->status->pkgbase);
# Wrap it up!
chdir $status->pkgbase or die "chdir: $OS_ERROR";
my $makepkg_cmd = join ' ', ( 'makepkg',
( $EUID == 0 ? '--asroot' : () ),
( $pkg_type eq 'src' ? '--source' : () ),
( !$opts{verbose} ? '>/dev/null' : () ),
);
# I tried to use IPC::Cmd here, but colors didn't work...
system $makepkg_cmd;
if ($CHILD_ERROR) {
error ( $CHILD_ERROR & 127
? sprintf "makepkg failed with signal %d", $CHILD_ERROR & 127
: sprintf "makepkg returned abnormal status: %d", $CHILD_ERROR >> 8
);
return 0;
}
my $destdir = $opts{destdir} || $status->destdir;
my $destfile_fqp = catfile( $destdir, $pkgfile );
if ( ! rename $pkgfile_fqp, $destfile_fqp ) {
error "failed to move $pkgfile to $destfile_fqp: $OS_ERROR";
return 0;
}
$status->dist($destfile_fqp);
return $status->created(1);
}
sub install
{
my ($self, %opts) = (shift, @_);
my $status = $self->status; # Private hash
my $module = $self->parent; # CPANPLUS::Module
my $intern = $module->parent; # CPANPLUS::Internals
my $conf = $intern->configure_object; # CPANPLUS::Configure
my $pkgfile_fpq = $status->dist
or die << 'END_ERROR';
Path to package file has not been set.
Someone is using CPANPLUS::Dist::Arch incorrectly.
Tell them to call create() before install().
END_ERROR
die "Package file $pkgfile_fpq was not found" if ( ! -f $pkgfile_fpq );
# Make sure the user has access to install a package...
my $sudocmd = $conf->get_program('sudo');
if ( $EFFECTIVE_USER_ID != $ROOT_USER_ID ) {
if ( $sudocmd ) {
system "$sudocmd pacman -U $pkgfile_fpq";
}
else {
error $NONROOT_WARNING;
return 0;
}
}
else { system "pacman -U $pkgfile_fpq"; }
if ($CHILD_ERROR) {
error ( $CHILD_ERROR & 127
? sprintf "pacman failed with signal %d", $CHILD_ERROR & 127
: sprintf "pacman returned abnormal status: %d", $CHILD_ERROR >> 8
);
return 0;
}
return $status->installed(1);
}
####
#### PUBLIC METHODS
####
sub set_destdir
{
die 'Invalid arguments to set_destdir' if ( @_ != 2 );
my ($self, $destdir) = @_;
$self->status->destdir($destdir);
return $destdir;
}
sub get_destdir
{
my $self = shift;
return $self->status->destdir;
}
sub get_pkgvars
{
die 'Invalid arguments to get_pkgvars' if ( @_ != 1 );
my $self = shift;
my $status = $self->status;
die 'prepare() must be called before get_pkgvars()'
unless ( $status->prepared );
return ( pkgname => $status->pkgname,
pkgver => $status->pkgname,
pkgdesc => $status->pkgdesc,
depends => scalar $self->_translate_cpan_deps,
url => $self->_get_disturl,
source => $self->_get_srcurl,
md5sums => $self->_calc_tarballmd5,
depshash => { $self->_translate_cpan_deps },
);
}
sub get_pkgvars_ref
{
die 'Invalid arguments to get_pkgvars_ref' if ( @_ != 1 );
my $self = shift;
return { $self->get_pkgvars };
}
sub get_pkgbuild
{
my ($self) = @_;
my $status = $self->status;
my $module = $self->parent;
my $conf = $module->parent->configure_object;
die 'prepare() must be called before get_pkgbuild()'
unless $status->prepared;
my $pkgdeps = $self->_translate_cpan_deps;
my $pkgdesc = $status->pkgdesc;
my $extdir = $module->package;
$extdir =~ s/ [.] ${\$module->package_extension} \z //xms;
$pkgdesc =~ s/ " / \\" /gxms; # Quote our package desc for bash.
my $templ_vars = { packager => $PACKAGER,
version => $VERSION,
pkgname => $status->pkgname,
pkgver => $status->pkgver,
pkgdesc => $pkgdesc,
pkgdeps => $pkgdeps,
disturl => $self->_get_disturl(),
srcurl => $self->_get_srcurl(),
md5sum => $self->_calc_tarballmd5(),
distdir => $extdir,
skiptest_comment => ( $conf->get_conf('skiptest')
? '#' : ' ' )
};
my $dist_type = $module->status->installer_type;
@{$templ_vars}{'is_makemaker', 'is_modulebuild'} =
( $dist_type eq 'CPANPLUS::Dist::MM' ? (1, 0) :
$dist_type eq 'CPANPLUS::Dist::Build' ? (0, 1) :
die "unknown Perl module installer type: '$dist_type'" );
return scalar $self->_process_template( $PKGBUILD_TEMPL,
$templ_vars );
}
sub create_pkgbuild
{
die 'Invalid arguments to create_pkgbuild' if ( @_ != 2 );
my ($self, $destdir) = @_;
die qq{Invalid directory passed to create_pkgbuild: "$destdir" ...
Directory does not exist or is not writeable}
unless ( -d $destdir && -w _ );
my $pkgbuild_text = $self->get_pkgbuild;
my $fqpath = catfile( $destdir, 'PKGBUILD' );
open my $pkgbuild_file, '>', $fqpath
or die "failed to open new PKGBUILD: $OS_ERROR";
print $pkgbuild_file $pkgbuild_text;
close $pkgbuild_file
or die "failed to close new PKGBUILD: $OS_ERROR";
return;
}
####
#### PRIVATE INSTANCE METHODS
####
#---INSTANCE METHOD---
# Usage : my $pkgname = $self->_translate_pkgname($dist_name);
# Purpose : Converts a module's dist[ribution tarball] name to an
# Archlinux style perl package name.
# Params : $dist_name - The name of the distribution (ex: Acme-Drunk)
# Returns : The Archlinux perl package name (ex: perl-acme-drunk).
#---------------------
sub _translate_name
{
die "Invalid arguments to _translate_name method" if @_ != 2;
my ($self, $distname) = @_;
# Override this package name if there is one specified...
return $PKGNAME_OVERRIDES->{$distname}
if $PKGNAME_OVERRIDES->{$distname};
# Package names should be lowercase and consist of alphanumeric
# characters only (and hyphens!)...
$distname = lc $distname;
$distname =~ tr/_/-/;
$distname =~ tr/-a-z0-9//cd;
$distname =~ tr/-/-/s;
# Delete leading or trailing hyphens...
$distname =~ s/\A-//;
$distname =~ s/-\z//;
die qq{Dist name '$distname' completely violates packaging standards}
if ( ! $distname );
if ( $distname !~ / (?: \A perl ) | (?: -perl \z ) /xms ) {
$distname = "perl-$distname";
}
return $distname;
}
#---INSTANCE METHOD---
# Purpose : Convert a module's CPAN distribution version into our more
# restrictive pacman package version number.
#---------------------
sub _translate_version
{
die "Invalid arguments to _translate_version method" if @_ != 2;
my ($self, $version) = @_;
# Package versions should be letters, numbers and decimal points only...
$version =~ tr/_-/../s;
$version =~ tr/a-zA-Z0-9.//cd;
return $version;
}
#---INSTANCE METHOD---
# Usage : my $deps_str = $self->_translate_cpan_deps()
# Purpose : Convert CPAN prerequisites into pacman package dependencies
# Returns : String to be appended after 'depends=' in PKGBUILD file,
# without parenthesis.
#---------------------
sub _translate_cpan_deps
{
die 'Invalid arguments to _translate_cpan_deps method'
if @_ != 1;
my ($self) = @_;
my %pkgdeps;
my $module = $self->parent;
my $backend = $module->parent;
my $prereqs = $module->status->prereqs;
CPAN_DEP_LOOP:
for my $modname ( keys %{$prereqs} ) {
my $depver = $prereqs->{$modname};
# Sometimes a perl version is given as a prerequisite
if ( $modname eq 'perl' ) {
$pkgdeps{perl} = $depver;
next CPAN_DEP_LOOP;
}
# Ignore modules included with this version of perl...
next CPAN_DEP_LOOP
if ( exists $Module::CoreList::version{0+$]}->{$modname} );
# Translate the module's distribution name into a package name...
my $modobj = $backend->parse_module( module => $modname );
my $pkgname = $self->_translate_name( $modobj->package_name );
$pkgdeps{$pkgname} = $self->_translate_version( $depver );
}
# Default to requiring the current perl version used to compile
# the module if there is no explicit perl version required...
$pkgdeps{perl} ||= sprintf '%vd', $PERL_VERSION;
return %pkgdeps if ( wantarray );
return ( join ' ',
map { $pkgdeps{$_} ? qq{'${_}>=$pkgdeps{$_}'} : qq{'$_'} }
sort keys %pkgdeps );
}
#---INSTANCE METHOD---
# Usage : $pkgdesc = $self->_prepare_pkgdesc();
# Purpose : Tries to find a module's "abstract" short description for
# use as a package description.
# Postcond : Sets the $self->status->pkgdesc accessor to the found
# package description.
# Returns : The package short description.
# Comments : We search through the META.yml file, the main module's .pm file,
# .pod file, and then the README file.
#---------------------
sub _prepare_pkgdesc
{
die 'Invalid arguments to _prepare_pkgdesc method' if @_ != 1;
my ($self) = @_;
my ($status, $module, $pkgdesc) = ($self->status, $self->parent);
# Registered modules have their description stored in the object.
return $status->pkgdesc( $module->description )
if ( $module->description );
# First, try to find the short description in the META.yml file.
METAYML:
{
my $metayml;
unless ( open $metayml, '<', $module->status->extract().'/META.yml' ) {
#error "Could not open META.yml to get pkgdesc: $!";
last METAYML;
}
while ( <$metayml> ) {
chomp;
if ( ($pkgdesc) = /^abstract:\s*(.+)/) {
$pkgdesc = $1 if ( $pkgdesc =~ /\A'(.*)'\z/ );
close $metayml;
return $status->pkgdesc($pkgdesc);
}
}
close $metayml;
}
# Next, parse the source file or pod file for a NAME section...
my $podselect = Pod::Select->new;
$podselect->select('NAME');
my $modname = $module->name;
# We use the package name because there is usually a module file
# with the exact same name as the package file.
#
# We want the main module's description, just in case the user requested
# a lesser module in the same package file.
#
# Assume the main .pm or .pod file is under lib/Module/Name/Here.pm
my $mainmod_file = $module->package_name;
$mainmod_file =~ tr{-}{/}s;
$mainmod_file = catfile( $module->status->extract, 'lib', $mainmod_file );
PODSEARCH:
for my $podfile_path ( map { "$mainmod_file.$_" } qw/pm pod/ ) {
my $name_section = '';
next PODSEARCH unless ( -e $podfile_path );
open my $podfile, '<', $podfile_path
or next PODSEARCH;
open my $podout, '>', \$name_section
or die "failed open on filehandle to string: $!";
$podselect->parse_from_filehandle( $podfile, $podout );
close $podfile;
close $podout
or die "failed close on filehandle to string: $!";
next PODSEARCH unless ($name_section);
# Remove formatting codes.
$name_section =~ s{ [IBCLEFSXZ] <(.*?)> }{$1}gxms;
$name_section =~ s{ [IBCLEFSXZ] <<(.*?)>> }{$1}gxms;
# The short desc is on a line beginning with 'Module::Name - '
return $status->pkgdesc($pkgdesc)
if ( ($pkgdesc) = $name_section =~ / ^ \s* $modname [\s-]+ (.+?) $ /xms );
}
# Last, try to find it in in the README file
README:
{
open my $readme, '<', $module->status->extract . '/README'
or last README;
# error( "Could not open README to get pkgdesc: $!" ), return undef;
my $modname = $module->name;
while ( <$readme> ) {
chomp;
if ( (/^NAME/ ... /^[A-Z]+/) # limit ourselves to a NAME section
&& ( ($pkgdesc) = / ^ \s* ${modname} [\s\-]+ (.+) $ /oxms) ) {
close $readme;
return $status->pkgdesc($pkgdesc);
}
}
close $readme;
}
return $status->pkgdesc(q{});
}
#---INSTANCE METHOD---
# Usage : $self->_prepare_status()
# Purpose : Prepares all the package-specific accessors in our $self->status
# accessor object (of the class Object::Accessor).
# Postcond : Accessors assigned to: pkgname pkgver pkgbase pkgarch
# destdir
# Returns : The object's status accessor.
#---------------------
sub _prepare_status
{
die 'Invalid arguments to _prepare_status method' if @_ != 1;
my $self = shift;
my $status = $self->status; # Private hash
my $module = $self->parent; # CPANPLUS::Module
my $conf = $module->parent->configure_object;
my $our_base = catdir( $conf->get_conf('base'),
( sprintf "%vd", $PERL_VERSION ),
'pacman' );
# Watchout if this was set explicitly with set_destdir() method
if ( !$status->destdir ) {
$status->destdir( $PKGDEST || catdir( $our_base, 'pkg' ) );
}
my ($pkgver, $pkgname)
= ( $self->_translate_version($module->package_version),
$self->_translate_name($module->package_name) );
my $pkgbase = catdir( $our_base, 'build', "$pkgname-$pkgver" );
my $pkgarch = `uname -m`;
chomp $pkgarch;
foreach ( $pkgname, $pkgver, $pkgbase, $pkgarch ) {
die "A package variable is invalid" unless defined;
}
$status->pkgname($pkgname);
$status->pkgver ($pkgver );
$status->pkgbase($pkgbase);
$status->pkgarch($pkgarch);
$self->_prepare_pkgdesc();
return $status;
}
#---INSTANCE METHOD---
# Usage : my $pkgurl = $self->_get_disturl()
# Purpose : Creates a nice, version agnostic homepage URL for the distribution.
# Returns : URL to the distribution's web page on CPAN.
#---------------------
sub _get_disturl
{
die 'Invalid arguments to _get_disturl method' if @_ != 1;
my $self = shift;
my $module = $self->parent;
my $distname = $module->package_name;
return join '/', $CPANURL, 'dist', $distname;
}
#---INSTANCE METHOD---
# Usage : my $srcurl = $self->_get_srcurl()
# Purpose : Generates the standard cpan download link for the source tarball.
# Returns : URL to the distribution's tarball on CPAN.
#---------------------
sub _get_srcurl
{
die 'Invalid arguments to _get_srcurl method' if @_ != 1;
my ($self) = @_;
my $module = $self->parent;
return join '/', $CPANURL, 'CPAN', $module->path, $module->package;
}
#---INSTANCE METHOD---
# Usage : my $md5hex = $self->calc_tarballmd5()
# Purpose : Returns the hex md5 string for the source (dist) tarball
# of the module.
# Throws : failed to get md5 of <filename>: ...
# Returns : The MD5 sum of the .tar.gz file in hex string form.
#---------------------
sub _calc_tarballmd5
{
my ($self) = @_;
my $module = $self->parent;
my $tarball_fqp = $module->_status->fetch;
# my $tarball_fqp = $self->status->pkgbase . '/' . $module->package;
open my $distfile, '<', $tarball_fqp
or die "failed to get md5 of $tarball_fqp: $OS_ERROR";
my $md5 = Digest::MD5->new;
$md5->addfile($distfile);
close $distfile;
return $md5->hexdigest;
}
#---INSTANCE METHOD---
# Usage : $self->_process_template( $templ, $templ_vars );
# Purpose : Processes IF blocks and fills in a template with supplied variables.
# Params : templ - A scalar variable containing the template
# templ_vars - A hashref of template variables that you can refer to
# in the template to insert the variable's value.
# Throws : 'Template variable %s was not provided' is thrown if a template
# variable is used in $templ but not provided in $templ_vars, or
# it is undefined.
# Returns : String of the template with all variables filled inserted.
#---------------------
sub _process_template
{
die "Invalid arguments to _template_out" if @_ != 3;
my ($self, $templ, $templ_vars) = @_;
die 'templ_var parameter must be a hashref'
if ( ref $templ_vars ne 'HASH' );
$templ =~ s{ \[% \s* IF \s+ (\w+) \s* %\] \n? # opening IF
(.+?) # enclosed text
\[% \s* FI \s* %\] \n? } # closing IF
{$templ_vars->{$1} ? $2 : ''}xmseg;
$templ =~ s{ \[% \s* (\w+) \s* %\] }
{ ( defined $templ_vars->{$1}
? $templ_vars->{$1}
: die "Template variable $1 was not provided" )
}xmseg;
return $templ;
}
1; # End of CPANPLUS::Dist::Arch