ALPM
view release on metacpan or search on metacpan
#include "types.h"
#include "cb.h"
#define alpm_croak(HND)\
croak("ALPM Error: %s", alpm_strerror(alpm_errno(HND)));
MODULE = ALPM PACKAGE = ALPM
PROTOTYPES: DISABLE
# ALPM::PackageFree is a subclass of ALPM::Package.
# ALPM::DB::Sync and ALPM::DB::Local are each subclasses of ALPM::DB.
BOOT:
av_push(get_av("ALPM::PackageFree::ISA", GV_ADD), newSVpv("ALPM::Package", 0));
av_push(get_av("ALPM::DB::Sync::ISA", GV_ADD), newSVpv("ALPM::DB", 0));
av_push(get_av("ALPM::DB::Local::ISA", GV_ADD), newSVpv("ALPM::DB", 0));
MODULE = ALPM PACKAGE = ALPM::PackageFree
void
DESTROY(self)
ALPM_PackageFree self;
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',
ALPM 3.06
INTRODUCTION
This is a perl XS module which provides an interface to the libalpm C library.
libalpm is used by Archlinux (and other distributions) who use pacman as the
package managing program.
Read-only access is provided to the database. All transaction creation logic
was removed from this module. After each major pacman upgrade, and sub-
sequent libalpm API change, I would be forced to rewrite a majority of this
module. After the third or fourth time I decided it was not worth the effort
for a feature possibly no one uses in an obscure perl module no one knows
about.
If you really need transactions why not call pacman with "system" or
backticks? In contrast, complicated queries becomes ugly and convoluted
when calling pacman in shell scripts. With the aid of this module, queries
should instead be possible in the quintessential ugly and succinct perl form.
Small utility scripts, like the examples, can also be quickly drawn up. This
#ifndef ALPM_XS_H
#define ALPM_XS_H
/* Code references to use as callbacks. */
extern SV *cb_log_sub;
extern SV *cb_dl_sub;
extern SV *cb_totaldl_sub;
extern SV *cb_fetch_sub;
/* transactions */
extern SV *cb_trans_event_sub;
extern SV *cb_trans_conv_sub;
extern SV *cb_trans_progress_sub;
/* 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,
#!/bin/sh
perl -MALPM::Conf=/etc/pacman.conf -e '
print substr(sprintf("%-16s * %s", $_->name, $_->desc), 0, 78), "\n"
for($alpm->localdb->pkgs);
'
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";
lib/ALPM/DB.pod view on Meta::CPAN
=back
=head2 search
@PKGS = $DB->search($MATCH)
=over 4
=item C<$MATCH>
A substring to search for within the names of packages.
=item C<@PKGS>
A list of found packages, in the form of L<ALPM::Package> objects. This may
be empty.
=back
=head2 groups
lib/ALPM/DB/Local.pod view on Meta::CPAN
ALPM::DB::Local - Machine-local package database.
=head1 SYNOPSIS
$db = $alpm->localdb;
$pkg = $db->find('perl');
$db->set_install_reason($pkg, 'implicit') or die $alpm->strerror;
=head1 OBJECT METHODS
This is a subclass of I<ALPM::DB> and inherits all of its methods.
=head2 set_install_reason
$SUCCESS = $DB->set_install_reason($PKG, $REASON);
The installation reason records whether the package was installed
explicitly or implicitly. Packages installed as requested on the command
line are installed explicitly. Packages installed as dependencies are
installed implicitly. You can override the reason here.
PERL_MAGIC_overload|5.007002||p
PERL_MAGIC_pos|5.007002||p
PERL_MAGIC_qr|5.007002||p
PERL_MAGIC_regdata|5.007002||p
PERL_MAGIC_regdatum|5.007002||p
PERL_MAGIC_regex_global|5.007002||p
PERL_MAGIC_shared_scalar|5.007003||p
PERL_MAGIC_shared|5.007003||p
PERL_MAGIC_sigelem|5.007002||p
PERL_MAGIC_sig|5.007002||p
PERL_MAGIC_substr|5.007002||p
PERL_MAGIC_sv|5.007002||p
PERL_MAGIC_taint|5.007002||p
PERL_MAGIC_tiedelem|5.007002||p
PERL_MAGIC_tiedscalar|5.007002||p
PERL_MAGIC_tied|5.007002||p
PERL_MAGIC_utf8|5.008001||p
PERL_MAGIC_uvar_elem|5.007003||p
PERL_MAGIC_uvar|5.007002||p
PERL_MAGIC_vec|5.007002||p
PERL_MAGIC_vstring|5.008001||p
PERL_UNUSED_DECL|5.007002||p
PERL_UNUSED_VAR|5.007002||p
PERL_UQUAD_MAX|5.004000||p
PERL_UQUAD_MIN|5.004000||p
PERL_USE_GCC_BRACE_GROUPS|5.009004||p
PERL_USHORT_MAX|5.004000||p
PERL_USHORT_MIN|5.004000||p
PERL_VERSION|5.006000||p
PL_DBsignal|5.005000||p
PL_DBsingle|||pn
PL_DBsub|||pn
PL_DBtrace|||pn
PL_Sv|5.005000||p
PL_bufend|5.011000||p
PL_bufptr|5.011000||p
PL_compiling|5.004050||p
PL_copline|5.011000||p
PL_curcop|5.004050||p
PL_curstash|5.004050||p
PL_debstash|5.004050||p
PL_defgv|5.004050||p
ck_require|||
ck_return|||
ck_rfun|||
ck_rvconst|||
ck_sassign|||
ck_select|||
ck_shift|||
ck_sort|||
ck_spair|||
ck_split|||
ck_subr|||
ck_substr|||
ck_svconst|||
ck_trunc|||
ck_unpack|||
ckwarn_d||5.009003|
ckwarn||5.009003|
cl_and|||n
cl_anything|||n
cl_init_zero|||n
cl_init|||n
cl_is_anything|||n
dofindlabel|||
doform|||
doing_taint||5.008001|n
dooneliner|||
doopen_pm|||
doparseform|||
dopoptoeval|||
dopoptogiven|||
dopoptolabel|||
dopoptoloop|||
dopoptosub_at|||
dopoptowhen|||
doref||5.009003|
dounwind|||
dowantarray|||
dump_all||5.006000|
dump_eval||5.006000|
dump_exec_pos|||
dump_fds|||
dump_form||5.006000|
dump_indent||5.006000|v
dump_mstats|||
dump_packsubs||5.006000|
dump_sub||5.006000|
dump_sv_child|||
dump_trie_interim_list|||
dump_trie_interim_table|||
dump_trie|||
dump_vindent||5.006000|
dumpuntil|||
dup_attrlist|||
emulate_cop_io|||
eval_pv|5.006000||p
eval_sv|5.006000||p
expect_number|||
fbm_compile||5.005000|
fbm_instr||5.005000|
feature_is_enabled|||
fetch_cop_label||5.011000|
filter_add|||
filter_del|||
filter_gets|||
filter_read|||
find_and_forget_pmops|||
find_array_subscript|||
find_beginning|||
find_byclass|||
find_hash_subscript|||
find_in_my_stash|||
find_runcv||5.008001|
find_rundefsvoffset||5.009002|
find_script|||
find_uninit_var|||
first_symbol|||n
fold_constants|||
forbid_setid|||
force_ident|||
force_list|||
free_global_struct|||
free_tied_hv_pool|||
free_tmps|||
gen_constant_list|||
get_arena|||
get_aux_mg|||
get_av|5.006000||p
get_context||5.006000|n
get_cvn_flags||5.009005|
get_cv|5.006000||p
get_db_sub|||
get_debug_opts|||
get_hash_seed|||
get_hv|5.006000||p
get_isa_hash|||
get_mstats|||
get_no_modify|||
get_num|||
get_op_descs||5.005000|
get_op_names||5.005000|
get_opargs|||
isPRINT|5.004000||p
isPSXSPC|5.006001||p
isPUNCT|5.006000||p
isSPACE|||
isUPPER|||
isXDIGIT|5.006000||p
is_an_int|||
is_gv_magical_sv|||
is_handle_constructor|||n
is_list_assignment|||
is_lvalue_sub||5.007001|
is_uni_alnum_lc||5.006000|
is_uni_alnumc_lc||5.006000|
is_uni_alnumc||5.006000|
is_uni_alnum||5.006000|
is_uni_alpha_lc||5.006000|
is_uni_alpha||5.006000|
is_uni_ascii_lc||5.006000|
is_uni_ascii||5.006000|
is_uni_cntrl_lc||5.006000|
is_uni_cntrl||5.006000|
magic_dump||5.006000|
magic_existspack|||
magic_freearylen_p|||
magic_freeovrld|||
magic_getarylen|||
magic_getdefelem|||
magic_getnkeys|||
magic_getpack|||
magic_getpos|||
magic_getsig|||
magic_getsubstr|||
magic_gettaint|||
magic_getuvar|||
magic_getvec|||
magic_get|||
magic_killbackrefs|||
magic_len|||
magic_methcall|||
magic_methpack|||
magic_nextpack|||
magic_regdata_cnt|||
magic_setdefelem|||
magic_setenv|||
magic_sethint|||
magic_setisa|||
magic_setmglob|||
magic_setnkeys|||
magic_setpack|||
magic_setpos|||
magic_setregexp|||
magic_setsig|||
magic_setsubstr|||
magic_settaint|||
magic_setutf8|||
magic_setuvar|||
magic_setvec|||
magic_set|||
magic_sizepack|||
magic_wipepack|||
make_matcher|||
make_trie_failtable|||
make_trie|||
scan_const|||
scan_formline|||
scan_heredoc|||
scan_hex|||
scan_ident|||
scan_inputsymbol|||
scan_num||5.007001|
scan_oct|||
scan_pat|||
scan_str|||
scan_subst|||
scan_trans|||
scan_version||5.009001|
scan_vstring||5.009005|
scan_word|||
scope|||
screaminstr||5.005000|
search_const|||
seed||5.008001|
sequence_num|||
sequence_tail|||
share_hek||5.004000|
si_dup|||
sighandler|||n
simplify_sort|||
skipspace0|||
skipspace1|||
skipspace2|||
skipspace|||
softref2xv|||
sortcv_stacked|||
sortcv_xsub|||
sortcv|||
sortsv_flags||5.009003|
sortsv||5.007003|
space_join_names_mortal|||
ss_dup|||
stack_grow|||
start_force|||
start_glob|||
start_subparse||5.004000|
stashpv_hvname_match||5.011000|
stdize_locale|||
store_cop_label|||
strEQ|||
strGE|||
strGT|||
strLE|||
strLT|||
strNE|||
str_to_version||5.006000|
strip_return|||
strnEQ|||
strnNE|||
study_chunk|||
sub_crush_depth|||
sublex_done|||
sublex_push|||
sublex_start|||
sv_2bool|||
sv_2cv|||
sv_2io|||
sv_2iuv_common|||
sv_2iuv_non_preserve|||
sv_2iv_flags||5.009001|
sv_2iv|||
sv_2mortal|||
sv_2num|||
sv_2nv|||
sys_init||5.010000|n
sys_intern_clear|||
sys_intern_dup|||
sys_intern_init|||
sys_term||5.010000|n
taint_env|||
taint_proper|||
tmps_grow||5.006000|
toLOWER|||
toUPPER|||
to_byte_substr|||
to_uni_fold||5.007003|
to_uni_lower_lc||5.006000|
to_uni_lower||5.007003|
to_uni_title_lc||5.006000|
to_uni_title||5.007003|
to_uni_upper_lc||5.006000|
to_uni_upper||5.007003|
to_utf8_case||5.007003|
to_utf8_fold||5.007003|
to_utf8_lower||5.007003|
to_utf8_substr|||
to_utf8_title||5.007003|
to_utf8_upper||5.007003|
token_free|||
token_getmad|||
tokenize_use|||
tokeq|||
tokereport|||
too_few_arguments|||
too_many_arguments|||
uiv_2buf|||n
warn|||v
watch|||
whichsig|||
write_no_mem|||
write_to_stderr|||
xmldump_all|||
xmldump_attr|||
xmldump_eval|||
xmldump_form|||
xmldump_indent|||v
xmldump_packsubs|||
xmldump_sub|||
xmldump_vindent|||
yyerror|||
yylex|||
yyparse|||
yywarn|||
);
if (exists $opt{'list-unsupported'}) {
my $f;
for $f (sort { lc $a cmp lc $b } keys %API) {
}
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
imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
sv = va_arg(*args, SV*);
}
}
{
const line_t ocopline = PL_copline;
COP * const ocurcop = PL_curcop;
const int oexpect = PL_expect;
#if (PERL_BCDVERSION >= 0x5004000)
utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
veop, modname, imop);
#else
utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(),
modname, imop);
#endif
PL_expect = oexpect;
PL_copline = ocopline;
PL_curcop = ocurcop;
}
}
#endif
#endif
line_t oldline = PL_curcop->cop_line;
PL_curcop->cop_line = D_PPP_PL_copline;
PL_hints &= ~HINT_BLOCK_SCOPE;
if (stash)
PL_curstash = PL_curcop->cop_stash = stash;
newSUB(
#if (PERL_BCDVERSION < 0x5003022)
start_subparse(),
#elif (PERL_BCDVERSION == 0x5003022)
start_subparse(0),
#else /* 5.003_23 onwards */
start_subparse(FALSE, 0),
#endif
newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)),
newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
);
PL_hints = oldhints;
PL_curcop->cop_stash = old_cop_stash;
PL_curstash = old_curstash;
#endif
#ifndef PERL_MAGIC_vec
# define PERL_MAGIC_vec 'v'
#endif
#ifndef PERL_MAGIC_utf8
# define PERL_MAGIC_utf8 'w'
#endif
#ifndef PERL_MAGIC_substr
# define PERL_MAGIC_substr 'x'
#endif
#ifndef PERL_MAGIC_defelem
# define PERL_MAGIC_defelem 'y'
#endif
#ifndef PERL_MAGIC_glob
# define PERL_MAGIC_glob '*'
#endif
const char *s = start;
STRLEN len = *len_p;
UV value = 0;
NV value_nv = 0;
const UV max_div_8 = UV_MAX / 8;
bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
bool overflowed = FALSE;
for (; len-- && *s; s++) {
/* gcc 2.95 optimiser not smart enough to figure that this subtraction
out front allows slicker code. */
int digit = *s - '0';
if (digit >= 0 && digit <= 7) {
/* Write it in this wonky order with a goto to attempt to get the
compiler to make the common case integer-only loop pretty tight.
*/
redo:
if (!overflowed) {
if (value <= max_div_8) {
value = (value << 3) | digit;
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 1.709 second using v1.01-cache-2.11-cpan-88abd93f124 )