ALPM
view release on metacpan or search on metacpan
Makefile.PL view on Meta::CPAN
use warnings;
use strict;
# Avoid useless FAIL reports from CPAN Testers...
require DynaLoader;
unless(DynaLoader::dl_findfile('-lalpm')){
print STDERR "ERROR: pacman/libalpm must be installed to compile ALPM!\n";
exit 0;
}
sub MY::postamble {
return <<'END_MAKE';
ALPM.xs: xs/DB.xs xs/Package.xs xs/Options.xs
END_MAKE
}
my %meta = ('resources' => { 'repository' => 'http://github.com/andrewgregory/perl-alpm' });
WriteMakefile(
'NAME' => 'ALPM',
'VERSION_FROM' => 'lib/ALPM.pm',
'LICENSE' => 'perl',
/* String constants to use for log levels (instead of bitflags) */
extern const char * log_lvl_error;
extern const char * log_lvl_warning;
extern const char * log_lvl_debug;
extern const char * log_lvl_function;
extern const char * log_lvl_unknown;
/* CALLBACKS ****************************************************************/
#define DEF_SET_CALLBACK( CBTYPE ) \
if ( ! SvOK(callback) && cb_ ## CBTYPE ## _sub != NULL ) { \
SvREFCNT_dec( cb_ ## CBTYPE ## _sub ); \
alpm_option_set_ ## CBTYPE ## cb( NULL ); \
cb_ ## CBTYPE ## _sub = NULL; \
} \
else { \
if ( !SvROK(callback) \
|| SvTYPE( SvRV(callback) ) != SVt_PVCV ) { \
croak( "value for %scb option must be a code reference", \
#CBTYPE ); \
} \
if ( cb_ ## CBTYPE ## _sub ) { \
sv_setsv( cb_ ## CBTYPE ## _sub, callback ); \
} \
else { \
cb_ ## CBTYPE ## _sub = newSVsv(callback); \
alpm_option_set_ ## CBTYPE ## cb \
( cb_ ## CBTYPE ## _wrapper ); \
} \
}
#define DEF_GET_CALLBACK( CBTYPE ) \
RETVAL = ( cb_ ## CBTYPE ## _sub == NULL \
? &PL_sv_undef : cb_ ## CBTYPE ## _sub );
void cb_log_wrapper ( alpm_loglevel_t level, const char * format, va_list args );
void cb_dl_wrapper ( const char *filename, off_t xfered, off_t total );
void cb_totaldl_wrapper ( off_t total );
int cb_fetch_wrapper ( const char *url, const char *localpath, int force );
/* TRANSACTIONS ************************************************************/
/* This macro is used inside alpm_trans_init.
CB_NAME is one of the transaction callback types (event, conv, progress).
* [CB_NAME]_sub is the argument to the trans_init XSUB.
* [CB_NAME]_func is a variable to hold the function pointer to pass
to the real C ALPM function.
* cb_trans_[CB_NAME]_wrapper is the name of the C wrapper function which
calls the perl sub stored in the global variable:
* cb_trans_[CB_NAME]_sub.
*/
#define UPDATE_TRANS_CALLBACK( CB_NAME ) \
if ( SvOK( CB_NAME ## _sub ) ) { \
if ( SvTYPE( SvRV( CB_NAME ## _sub ) ) != SVt_PVCV ) { \
croak( "Callback arguments must be code references" ); \
} \
if ( cb_trans_ ## CB_NAME ## _sub ) { \
sv_setsv( cb_trans_ ## CB_NAME ## _sub, CB_NAME ## _sub ); \
} \
else { \
cb_trans_ ## CB_NAME ## _sub = newSVsv( CB_NAME ## _sub ); \
} \
CB_NAME ## _func = cb_trans_ ## CB_NAME ## _wrapper; \
} \
else if ( cb_trans_ ## CB_NAME ## _sub != NULL ) { \
/* If no event callback was provided for this new transaction, \
and an event callback is active, then remove the old callback. */ \
SvREFCNT_dec( cb_trans_ ## CB_NAME ## _sub ); \
cb_trans_ ## CB_NAME ## _sub = NULL; \
}
void cb_trans_event_wrapper ( alpm_transevt_t event,
void *arg_one, void *arg_two );
void cb_trans_conv_wrapper ( alpm_transconv_t type,
void *arg_one, void *arg_two, void *arg_three,
int *result );
void cb_trans_progress_wrapper ( alpm_transprog_t type,
const char * desc,
int item_progress,
lib/ALPM.pm view on Meta::CPAN
our $VERSION;
BEGIN {
$VERSION = '3.06';
require XSLoader;
XSLoader::load(__PACKAGE__, $VERSION);
}
## PUBLIC METHODS ##
sub dbs
{
my($self) = @_;
return ($self->localdb, $self->syncdbs);
}
sub db
{
my($self, $name) = @_;
for my $db ($self->dbs){
return $db if($db->name eq $name);
}
return undef;
}
sub search
{
my($self, @qry) = @_;
return map { $_->search(@qry) } $self->dbs;
}
1;
lib/ALPM/Conf.pm view on Meta::CPAN
require Carp;
require ALPM;
}
## Private functions.
# These options are implemented in pacman, not libalpm, and are ignored.
my @NULL_OPTS = qw{HoldPkg SyncFirst CleanMethod XferCommand
TotalDownload VerbosePkgLists};
sub _null
{
1;
}
my $COMMENT_MATCH = qr/ \A \s* [#] /xms;
my $SECTION_MATCH = qr/ \A \s* \[ ([^\]]+) \] \s* \z /xms;
my $FIELD_MATCH = qr/ \A \s* ([^=\s]+) (?: \s* = \s* ([^\n]*))? /xms;
sub _mkparser
{
my($path, $hooks) = @_;
sub {
local $_ = shift;
s/^\s+//; s/\s+$//; # trim whitespace
return unless(length);
# Call the appropriate hook for each type of token...
if(/$COMMENT_MATCH/){
;
}elsif(/$SECTION_MATCH/){
$hooks->{'section'}->($1);
}elsif(/$FIELD_MATCH/){
lib/ALPM/Conf.pm view on Meta::CPAN
if(length $val){
my $apply = $hooks->{'field'}{$name};
$apply->($val) if($apply);
}
}else{
die "Invalid line in config file, not a comment, section, or field\n";
}
};
}
sub _parse
{
my($path, $hooks) = @_;
my $parser = _mkparser($path, $hooks);
my $line;
open my $if, '<', $path or die "open $path: $!\n";
eval {
while(<$if>){
chomp;
$line = $_;
lib/ALPM/Conf.pm view on Meta::CPAN
if($err){
# Print the offending file and line number along with any errors...
# (This is why we use dies with newlines, for cascading error msgs)
die "$@$path:$. $line\n"
}
return;
}
## Public methods.
sub new
{
my($class, $path) = @_;
bless { 'path' => $path }, $class;
}
sub custom_fields
{
my($self, %cfields) = @_;
if(grep { ref $_ ne 'CODE' } values %cfields){
Carp::croak('Hash argument must have coderefs as values' )
}
$self->{'cfields'} = \%cfields;
return;
}
sub _mlisthooks
{
my($dbsref, $sectref) = @_;
# Setup hooks for 'Include'ed file parsers...
return {
'section' => sub {
my $file = shift;
die q{Section declaration is not allowed in Include-ed file\n($file)\n};
},
'field' => {
'Server' => sub { _addmirror($dbsref, shift, $$sectref) }
},
};
}
my %CFGOPTS = (
'RootDir' => 'root',
'DBPath' => 'dbpath',
'CacheDir' => 'cachedirs',
'GPGDir' => 'gpgdir',
'LogFile' => 'logfile',
lib/ALPM/Conf.pm view on Meta::CPAN
'UseDelta' => 'usedelta',
'CheckSpace' => 'checkspace',
'IgnorePkg' => 'ignorepkgs',
'IgnoreGroup' => 'ignoregrps',
'NoUpgrade' => 'noupgrades',
'NoExtract' => 'noextracts',
'NoPassiveFtp' => 'nopassiveftp',
'Architecture' => 'arch',
);
sub _confhooks
{
my($optsref, $sectref) = @_;
my %hooks;
while(my($fld, $opt) = each %CFGOPTS){
$hooks{$fld} = sub {
my $val = shift;
die qq{$fld can only be set in the [options] section\n}
unless($$sectref eq 'options');
$optsref->{$opt} = $val;
};
}
return %hooks;
}
sub _nullhooks
{
map { ($_ => \&_null) } @_
}
sub _getdb
{
my($dbs, $name) = @_;
# The order databases are added must be preserved as must the order of URLs.
for my $db (@$dbs){
return $db if($db->{'name'} eq $name);
}
my $new = { 'name' => $name };
push @$dbs, $new;
return $new;
}
sub _setsiglvl
{
my($dbs, $sect, $siglvl) = @_;
my $db = _getdb($dbs, $sect);
$db->{'siglvl'} = $siglvl;
return;
}
sub _parse_siglvl
{
my($str) = @_;
my $siglvl;
my $opt;
for(split /\s+/, $str){
my @types = qw/pkg db/;
if(s/^Package//){
@types = qw/pkg/;
lib/ALPM/Conf.pm view on Meta::CPAN
}
}
# Check for a blank SigLevel
unless(defined $opt){
die "SigLevel was empty\n";
}
return $opt;
}
sub _addmirror
{
my($dbs, $url, $sect) = @_;
die "Section has not previously been declared, cannot set URL\n" unless($sect);
my $db = _getdb($dbs, $sect);
push @{$db->{'mirrors'}}, $url;
return;
}
sub _setopt
{
my($alpm, $opt, $valstr) = @_;
no strict 'refs';
my $meth = *{"ALPM::set_$opt"}{'CODE'};
die "The ALPM::set_$opt method is missing" unless($meth);
my @val = ($opt =~ /s$/ ? map { split } $valstr : $valstr);
return $meth->($alpm, @val);
}
sub _setarch
{
my($opts) = @_;
if(!$opts->{'arch'} || $opts->{'arch'} eq 'auto'){
chomp ($opts->{'arch'} = `uname -m`);
}
}
sub _expurls
{
my($urls, $arch, $repo) = @_;
for(@$urls){
s/\$arch/$arch/g;
s/\$repo/$repo/g;
}
}
sub _applyopts
{
my($opts, $dbs) = @_;
my($root, $dbpath) = delete @{$opts}{'root', 'dbpath'};
unless($root){
$root = '/';
unless($dbpath){
$dbpath = "$root/var/lib/pacman";
$dbpath =~ tr{/}{/}s;
}
lib/ALPM/Conf.pm view on Meta::CPAN
_expurls($mirs, $opts->{'arch'}, $r);
$sl = 'default' if(!$usesl);
my $x = $alpm->register($r, $sl)
or die "Failed to register $r database: " . $alpm->strerror;
$x->add_server($_) for(@$mirs);
}
return $alpm;
}
sub parse
{
my($self) = @_;
my (%opts, @dbs, $currsect, $defsiglvl);
my %fldhooks = (
_confhooks(\%opts, \$currsect),
_nullhooks(@NULL_OPTS),
'Server' => sub { _addmirror(\@dbs, shift, $currsect) },
'Include' => sub {
die "Cannot have an Include directive in the [options] section\n"
if($currsect eq 'options');
# An include directive spawns its own little parser...
_parse(shift, _mlisthooks(\@dbs, \$currsect));
},
'SigLevel' => sub {
if($currsect eq 'options'){
$defsiglvl = _parse_siglvl(shift);
}else{
_setsiglvl(\@dbs, $currsect, _parse_siglvl(shift));
}
},
($self->{'cfields'} ? %{$self->{'cfields'}} : ()),
);
my %hooks = (
'field' => \%fldhooks,
'section' => sub { $currsect = shift; }
);
_parse($self->{'path'}, \%hooks);
return _applyopts(\%opts, \@dbs);
}
## Import magic used for quick scripting.
# e.g: perl -MALPM::Conf=/etc/pacman.conf -le 'print $alpm->root'
sub import
{
my($pkg, $path) = @_;
my($dest) = caller;
return unless($path);
my $conf = $pkg->new($path);
my $alpm = $conf->parse;
no strict 'refs';
*{"${dest}::alpm"} = \$alpm;
return;
lib/ALPM/Conf.pod view on Meta::CPAN
ALPM::Conf - pacman.conf config file parser and ALPM loader
=head1 SYNOPSIS
use ALPM::Conf;
my $conf = ALPM::Conf->new('/etc/pacman.conf');
my $alpm = $conf->parse;
# Try again with custom fields:
my $value;
my %fields = ('CustomField' => sub { $value = shift });
$conf->custom_fields(%fields);
$alpm = $conf->parse();
print "$value\n";
# When imported with an argument, a conf file is loaded and
# an alpm instance (named $alpm) is imported into the caller's
# namespace.
use ALPM::Conf '/etc/pacman.conf';
print $alpm->get_arch, "\n";
}
exit 0;
}
# Scan for possible replacement candidates
my(%replace, %need, %hints, %warnings, %depends);
my $replace = 0;
my($hint, $define, $function);
sub find_api
{
my $code = shift;
$code =~ s{
/ (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*)
| "[^"\\]*(?:\\.[^"\\]*)*"
| '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx;
grep { exists $API{$_} } $code =~ /(\w+)/mg;
}
while (<DATA>) {
else {
my @new = grep { -f } glob $_
or warn "'$_' does not exist.\n";
push @files, grep { !$seen{$_}++ } @new;
}
}
}
else {
eval {
require File::Find;
File::Find::find(sub {
$File::Find::name =~ /($srcext)$/i
and push @files, $File::Find::name;
}, '.');
};
if ($@) {
@files = map { glob "*$_" } @srcext;
}
}
if (!@ARGV || $opt{filter}) {
else {
info("Looks good");
}
}
close PATCH if $patch_opened;
exit 0;
sub try_use { eval "use @_;"; return $@ eq '' }
sub mydiff
{
local *F = shift;
my($file, $str) = @_;
my $diff;
if (exists $opt{diff}) {
$diff = run_diff($opt{diff}, $file, $str);
}
if (!defined $diff and try_use('Text::Diff')) {
}
if (!defined $diff) {
error("Cannot generate a diff. Please install Text::Diff or use --copy.");
return;
}
print F $diff;
}
sub run_diff
{
my($prog, $file, $str) = @_;
my $tmp = 'dppptemp';
my $suf = 'aaa';
my $diff = '';
local *F;
while (-e "$tmp.$suf") { $suf++ }
$tmp = "$tmp.$suf";
unlink $tmp;
}
else {
error("Cannot open '$tmp' for writing: $!");
}
return undef;
}
sub rec_depend
{
my($func, $seen) = @_;
return () unless exists $depends{$func};
$seen = {%{$seen||{}}};
return () if $seen->{$func}++;
my %s;
grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}};
}
sub parse_version
{
my $ver = shift;
if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
return ($1, $2, $3);
}
elsif ($ver !~ /^\d+\.[\d_]+$/) {
die "cannot parse version '$ver'\n";
}
if ($r < 5 || ($r == 5 && $v < 6)) {
if ($s % 10) {
die "cannot parse version '$ver'\n";
}
}
return ($r, $v, $s);
}
sub format_version
{
my $ver = shift;
$ver =~ s/$/000000/;
my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
$v = int $v;
$s = int $s;
if ($r < 5 || ($r == 5 && $v < 6)) {
$ver = sprintf "%d.%03d", $r, $v;
$s > 0 and $ver .= sprintf "_%02d", $s;
return $ver;
}
return sprintf "%d.%d.%d", $r, $v, $s;
}
sub info
{
$opt{quiet} and return;
print @_, "\n";
}
sub diag
{
$opt{quiet} and return;
$opt{diag} and print @_, "\n";
}
sub warning
{
$opt{quiet} and return;
print "*** ", @_, "\n";
}
sub error
{
print "*** ERROR: ", @_, "\n";
}
my %given_hints;
my %given_warnings;
sub hint
{
$opt{quiet} and return;
my $func = shift;
my $rv = 0;
if (exists $warnings{$func} && !$given_warnings{$func}++) {
my $warn = $warnings{$func};
$warn =~ s!^!*** !mg;
print "*** WARNING: $func\n", $warn;
$rv++;
}
if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) {
my $hint = $hints{$func};
$hint =~ s/^/ /mg;
print " --- hint for $func ---\n", $hint;
}
$rv;
}
sub usage
{
my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms;
my %M = ( 'I' => '*' );
$usage =~ s/^\s*perl\s+\S+/$^X $0/;
$usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g;
print <<ENDUSAGE;
Usage: $usage
See perldoc $0 for details.
ENDUSAGE
exit 2;
}
sub strip
{
my $self = do { local(@ARGV,$/)=($0); <> };
my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms;
$copy =~ s/^(?=\S+)/ /gms;
$self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms;
$self =~ s/^SKIP.*(?=^__DATA__)/SKIP
if (\@ARGV && \$ARGV[0] eq '--unstrip') {
eval { require Devel::PPPort };
\$@ and die "Cannot require Devel::PPPort, please install.\\n";
if (eval \$Devel::PPPort::VERSION < $VERSION) {
/* Replace: 1 */
# define PL_ppaddr ppaddr
# define PL_no_modify no_modify
/* Replace: 0 */
#endif
#if (PERL_BCDVERSION <= 0x5004005)
/* Replace: 1 */
# define PL_DBsignal DBsignal
# define PL_DBsingle DBsingle
# define PL_DBsub DBsub
# define PL_DBtrace DBtrace
# define PL_Sv Sv
# define PL_bufend bufend
# define PL_bufptr bufptr
# define PL_compiling compiling
# define PL_copline copline
# define PL_curcop curcop
# define PL_curstash curstash
# define PL_debstash debstash
# define PL_defgv defgv
t/00-ALPM.t view on Meta::CPAN
'cachedirs' => [ "$r/cache/" ], # needs trailing slash
'noupgrades' => [ 'foo' ],
'noextracts' => [ 'bar' ],
'ignorepkgs' => [ 'baz' ],
'ignoregroups' => [ 'core' ],
'usesyslog' => 0,
'deltaratio' => 0.5,
'checkspace' => 1,
);
sub meth
{
my $name = shift;
my $m = *{"ALPM::$name"}{CODE} or die "missing $name method";
my @ret = eval { $m->($alpm, @_) };
if($@){ die "method call to $name failed: $@" }
return (wantarray ? @ret : $ret[0]);
}
for $k (sort keys %opts){
$v = $opts{$k};
use Test::More;
use ALPM::Conf 't/test.conf';
ok $alpm;
sub checkpkgs
{
my $db = shift;
my $dbname = $db->name;
my %set = map { ($_ => 1) } @_;
for my $p ($db->pkgs){
my $n = $p->name;
unless(exists $set{$n}){
fail "unexpected $n package exists in $dbname";
return;
}
delete $set{$n};
}
if(keys %set){
fail "missing packages in $dbname: " . join q{ }, keys %set;
}else{
pass "all expected packages exist in $dbname";
}
}
sub checkdb
{
my $dbname = shift;
my $db = $alpm->db($dbname);
is $db->name, $dbname, 'dbname matches db() arg';
checkpkgs($db, @_);
}
$db = $alpm->localdb;
is $db->name, 'local';
t/03-Package.t view on Meta::CPAN
use Test::More;
use ALPM::Conf 't/test.conf';
sub pkgpath
{
my($dbname, $pkgname) = @_;
$db = $alpm->db($dbname);
$db->update or die $alpm->err;
my($url) = $db->get_servers;
$pkg = $db->find($pkgname) or die "$dbname/$pkgname package is missing";
$url .= q{/} . $pkg->filename;
print "$url\n";
if(($url =~ s{^file://}{}) != 1){
die 'package files are not locally hosted as expected';
t/05-Callbacks.t view on Meta::CPAN
use Test::More;
use ALPM::Conf 't/test.conf';
ok !defined $alpm->get_logcb;
$cb = sub { print "LOG: @_" };
die 'internal error' unless(ref($cb) eq 'CODE');
$alpm->set_logcb($cb);
$tmp = $alpm->get_logcb($cb);
is ref($tmp), 'CODE';
ok $tmp eq $cb;
$alpm->set_logcb(undef);
ok !defined $alpm->get_logcb;
t/preptests.pl view on Meta::CPAN
use File::Spec::Functions qw(rel2abs catfile);
use File::Basename qw(dirname);
my $PROG = 'preptests';
my $REPODIR = 'repos';
## Variables inside the test.conf need absolute paths, assigned later.
my ($REPOSHARE, $TESTROOT);
my $TESTCONF = 'test.conf';
sub createconf
{
my($path, $root, $repos) = @_;
open my $of, '>', $path
or die "failed to open t/test.conf file: $!";
print $of <<"END_CONF";
[options]
RootDir = $root
DBPath = $root/db
CacheDir = $root/cache
LogFile = $root/test.log
t/preptests.pl view on Meta::CPAN
[$repo]
SigLevel = Optional TrustAll
Server = file://$path
END_CONF
}
close $of;
}
sub buildpkgs
{
chdir 'repos' or die "chdir: $!";
my @lines = `perl package.pl`;
chdir '..' or die "chdir: $!";
if(@?){
printf STDERR "$PROG: package.pl script failed: code %d\n", $? >> 8;
exit 1;
}
my %repos;
for (@lines){
chomp;
my($r, @rest) = split /\t/;
push @{$repos{$r}}, join "\t", @rest;
}
return \%repos;
}
sub remkdir
{
my($dir) = @_;
die "WTF?" if($dir eq '/');
remove_tree($dir);
mkdir($dir);
return;
}
sub mkroot
{
remkdir($TESTROOT);
my @dirs = glob("$TESTROOT/{gnupg,cache,{db/{local,cache}}}");
make_path(@dirs, { mode => 0755 });
}
sub corruptpkg
{
my $fqp = "$REPOSHARE/simpletest/corruptme-1.0-1-any.pkg.tar.xz";
unlink $fqp or die "unlink: $!";
open my $fh, '>', $fqp or die "open: $!";
print $fh "HAHA PWNED!\n";
close $fh or die "close: $!";
return;
}
sub buildrepos
{
my($sharedir) = @_;
my $repos = buildpkgs();
my $wd = getcwd();
chdir($REPODIR) or die "chdir: $!";
my %paths;
for my $r (sort keys %$repos){
my $rd = "$sharedir/$r";
make_path("$rd/contents");
t/preptests.pl view on Meta::CPAN
exit 1;
}
$paths{$r} = $rd;
}
chdir $wd or die "chdir: $!";
return \%paths;
}
sub main
{
chdir(dirname($0)) or die "chdir: $!";
$REPOSHARE = rel2abs('repos/share');
$TESTROOT = rel2abs('root');
unless(-d $REPOSHARE){
my $repos = buildrepos($REPOSHARE);
createconf($TESTCONF, $TESTROOT, $repos);
}
t/repos/package.pl view on Meta::CPAN
use File::Find qw(find);
use File::Copy qw(copy);
use Cwd qw(getcwd);
use File::stat;
use warnings;
use strict;
our $PROG='t/package.pl';
sub sumfiles
{
my($pd) = @_;
my $sum;
find(sub { $sum += -s $_ if(-f $_ && !/.PKGINFO/); }, $pd);
return $sum;
}
sub readpi
{
my($ipath) = @_;
unless(-f $ipath && -r $ipath){
print STDERR "$PROG: $ipath is missing.\n";
exit 1;
}
my %pinfo;
open my $if, '<', $ipath or die "open: $!";
while(<$if>){
my ($name, $val) = split / = /;
my @vals = split /\s+/, $val;
$pinfo{$name} = \@vals;
}
close $if or die "close: $!";
return \%pinfo;
}
sub writepi
{
my($pinfo, $ipath) = @_;
open my $of, '>', $ipath or die "open: $!";
while(my($k, $v) = each %$pinfo){
print $of "$k = @$v\n";
}
close $of or die "close: $!";
return;
}
sub updatepi
{
my($pi, $pd) = @_;
$pi->{'builddate'} = [ time ];
$pi->{'size'} = [ sumfiles($pd) ];
$pi->{'packager'} = [ 'ALPM Module' ];
return;
}
sub remkdir
{
my($d) = @_;
if(-d $d){
system 'rm' => ('-r', $d);
if($?){
printf STDERR "$PROG: rm -r $d failed: error code %d\n", $? >> 8;
exit 1;
}
}
unless(mkdir $d){
print STDERR "$PROG: mkdir $d failed: $!\n";
exit 1;
}
return;
}
sub mktmpdir
{
my($base) = @_;
remkdir("$base/tmp");
return "$base/tmp";
}
sub pkgfname
{
my($pi) = @_;
return sprintf '%s-%s-%s.pkg.tar.xz',
map { $_->[0] } @{$pi}{qw/pkgname pkgver arch/};
}
sub buildpkg
{
my($pi, $pd, $td) = @_;
my $parentd = dirname($td);
remkdir($td);
system 'cp' => ('-R', $pd, $parentd);
if($?){
print STDERR "$PROG: failed to cp $pd to $parentd\n";
exit 1;
}
t/repos/package.pl view on Meta::CPAN
system qq{bsdtar -cf - .PKGINFO * | xz -z > ../$fname};
if($?){
printf STDERR "$PROG: xz returned %d\n", $? >> 8;
exit 1;
}
chdir $oldwd or die "chdir: $!";
return "$parentd/$fname";
}
sub dirsin
{
my($p) = @_;
opendir my $dh, $p or die "opendir $p: $!";
my @dirs = grep { !/^[.]/ && -d "$p/$_" } readdir $dh;
closedir $dh;
return @dirs;
}
sub readrepos
{
my($based) = @_;
my %rpkgs;
for my $r (dirsin($based)){
next if($r eq 'tmp');
push @{$rpkgs{$r}}, dirsin("$based/$r");
}
return \%rpkgs;
}
sub findbuilt
{
my($pi, $pd, $td) = @_;
unless(-f "$pd/.PKGINFO"){
print STDERR "$PROG: $pd/.PKGINFO is missing\n";
exit 1;
}
return undef unless(-d $td);
my $fname = pkgfname($pi);
t/repos/repoadd.pl view on Meta::CPAN
#!/usr/bin/env perl
use warnings;
use strict;
my $PROG = 'repoadd.pl';
package PkgFile;
sub fromPath { my $self = bless {}, shift; $self->{'path'} = shift; $self; }
sub info
{
my($self) = @_;
return $self->{'info'} if($self->{'info'});
if(-e '.PKGINFO'){
print STDERR "PROG: .PKGINFO already exists in current dir, please delete it.\n";
exit 1;
}
my $path = $self->{'path'};
t/repos/repoadd.pl view on Meta::CPAN
$name =~ s/^pkg//;
push @{$pi{$name}}, $val;
}
close $if;
unlink '.PKGINFO';
$pi{'version'} = delete $pi{'ver'};
return $self->{'info'} = \%pi;
}
sub fileName
{
my($self) = @_;
my $fn = $self->{'path'};
$fn =~ s{.*/}{};
return $fn;
}
package DBDir;
our @DescFields = qw{filename name base version desc groups
csize isize url license arch builddate packager replaces};
our @DepFields = qw/depends provides conflicts optdepends/;
sub fromPath
{
my $self = bless {}, shift;
$self->{'dir'} = shift;
$self;
}
sub writeFile
{
my($self, $path, $data) = @_;
open my $of, '>', $path or die "open: $!";
while(my($k, $v) = each %$data){
my $str = join "\n", @$v;
my $uck = uc $k;
print $of "%$uck%\n$str\n\n";
}
close $of or die "close: $!";
$self;
}
sub addEntry
{
my($self, $pkg) = @_;
my $pi = $pkg->info;
my $name = join q{-}, map { $_->[0] } @{$pi}{qw/name version/};
my $dir = "$self->{'dir'}/$name";
if(-d $dir){
system 'rm' => '-r', "$dir";
if($?){
t/repos/repoadd.pl view on Meta::CPAN
$pi->{'filename'} = [ $pkg->fileName ];
for my $fld (@DescFields){
$pi->{$fld} = [] unless($pi->{$fld});
}
$self->writeFile("$dir/desc", $pi);
}
package main;
sub usage
{
print STDERR "usage: $PROG [repo dir path] [package path]\n";
exit 2;
}
sub main
{
usage() if(@_ != 2);
my($dbname, $pkgpath) = @_;
my $dbdir = "$dbname/contents";
unless(-d $dbdir){
print STDERR "$PROG: dir named $dbname must exist in current directory\n";
exit 1;
}
unless(-f $pkgpath){
( run in 0.372 second using v1.01-cache-2.11-cpan-4d50c553e7e )