our
$VERSION
=
'0.08'
;
Readonly
my
$MKPKGCONF_FQP
=>
'/etc/makepkg.conf'
;
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
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
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
our
(
$PKGDEST
,
$PACKAGER
);
$PACKAGER
=
'Anonymous'
;
READ_CONF:
{
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: $!"
;
}
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;
my
$module
=
$self
->parent;
my
$intern
=
$module
->parent;
my
$conf
=
$intern
->configure_object;
my
$distcpan
=
$module
->status->dist_cpan;
$self
->_prepare_status;
$status
->prepared(0);
return
$self
->SUPER::prepare(
@_
);
}
sub
create
{
my
(
$self
,
%opts
) = (
shift
,
@_
);
my
$status
=
$self
->status;
my
$module
=
$self
->parent;
my
$intern
=
$module
->parent;
my
$conf
=
$intern
->configure_object;
my
$distcpan
=
$module
->status->dist_cpan;
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'
) {
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 );
}
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"
;
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);
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'
: () ),
);
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;
my
$module
=
$self
->parent;
my
$intern
=
$module
->parent;
my
$conf
=
$intern
->configure_object;
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
);
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);
}
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;
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
;
}
sub
_translate_name
{
die
"Invalid arguments to _translate_name method"
if
@_
!= 2;
my
(
$self
,
$distname
) =
@_
;
return
$PKGNAME_OVERRIDES
->{
$distname
}
if
$PKGNAME_OVERRIDES
->{
$distname
};
$distname
=
lc
$distname
;
$distname
=~
tr
/_/-/;
$distname
=~
tr
/-a-z0-9//cd;
$distname
=~
tr
/-/-/s;
$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
;
}
sub
_translate_version
{
die
"Invalid arguments to _translate_version method"
if
@_
!= 2;
my
(
$self
,
$version
) =
@_
;
$version
=~
tr
/_-/../s;
$version
=~
tr
/a-zA-Z0-9.//cd;
return
$version
;
}
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
};
if
(
$modname
eq
'perl'
) {
$pkgdeps
{perl} =
$depver
;
next
CPAN_DEP_LOOP;
}
next
CPAN_DEP_LOOP
if
(
exists
$Module::CoreList::version
{0+$]}->{
$modname
} );
my
$modobj
=
$backend
->parse_module(
module
=>
$modname
);
my
$pkgname
=
$self
->_translate_name(
$modobj
->package_name );
$pkgdeps
{
$pkgname
} =
$self
->_translate_version(
$depver
);
}
$pkgdeps
{perl} ||=
sprintf
'%vd'
,
$PERL_VERSION
;
return
%pkgdeps
if
(
wantarray
);
return
(
join
' '
,
map
{
$pkgdeps
{
$_
} ?
qq{'${_}
>=
$pkgdeps
{
$_
}'} :
qq{'$_'}
}
sort
keys
%pkgdeps
);
}
sub
_prepare_pkgdesc
{
die
'Invalid arguments to _prepare_pkgdesc method'
if
@_
!= 1;
my
(
$self
) =
@_
;
my
(
$status
,
$module
,
$pkgdesc
) = (
$self
->status,
$self
->parent);
return
$status
->pkgdesc(
$module
->description )
if
(
$module
->description );
METAYML:
{
my
$metayml
;
unless
(
open
$metayml
,
'<'
,
$module
->status->extract().
'/META.yml'
) {
last
METAYML;
}
while
( <
$metayml
> ) {
chomp
;
if
( (
$pkgdesc
) = /^abstract:\s*(.+)/) {
$pkgdesc
= $1
if
(
$pkgdesc
=~ /\A
'(.*)'
\z/ );
close
$metayml
;
return
$status
->pkgdesc(
$pkgdesc
);
}
}
close
$metayml
;
}
my
$podselect
= Pod::Select->new;
$podselect
->
select
(
'NAME'
);
my
$modname
=
$module
->name;
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
);
$name_section
=~ s{ [IBCLEFSXZ] <(.*?)> }{$1}gxms;
$name_section
=~ s{ [IBCLEFSXZ] <<(.*?)>> }{$1}gxms;
return
$status
->pkgdesc(
$pkgdesc
)
if
( (
$pkgdesc
) =
$name_section
=~ / ^ \s*
$modname
[\s-]+ (.+?) $ /xms );
}
README:
{
open
my
$readme
,
'<'
,
$module
->status->extract .
'/README'
or
last
README;
my
$modname
=
$module
->name;
while
( <
$readme
> ) {
chomp
;
if
( (/^NAME/ ... /^[A-Z]+/)
&& ( (
$pkgdesc
) = / ^ \s* ${modname} [\s\-]+ (.+) $ /oxms) ) {
close
$readme
;
return
$status
->pkgdesc(
$pkgdesc
);
}
}
close
$readme
;
}
return
$status
->pkgdesc(
q{}
);
}
sub
_prepare_status
{
die
'Invalid arguments to _prepare_status method'
if
@_
!= 1;
my
$self
=
shift
;
my
$status
=
$self
->status;
my
$module
=
$self
->parent;
my
$conf
=
$module
->parent->configure_object;
my
$our_base
= catdir(
$conf
->get_conf(
'base'
),
(
sprintf
"%vd"
,
$PERL_VERSION
),
'pacman'
);
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
;
}
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
;
}
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
;
}
sub
_calc_tarballmd5
{
my
(
$self
) =
@_
;
my
$module
=
$self
->parent;
my
$tarball_fqp
=
$module
->_status->fetch;
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;
}
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?
(.+?)
\[% \s* FI \s* %\] \n? }
{
$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;