ALPM
view release on metacpan or search on metacpan
Makefile.PL view on Meta::CPAN
use ExtUtils::MakeMaker;
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' });
case ALPM_LOG_DEBUG: str = "debug"; break;
case ALPM_LOG_FUNCTION: str = "function"; break;
default: str = "unknown"; break;
}
ENTER;
SAVETMPS;
/* We can't use sv_vsetpvfn because it doesn't like j's: %jd or %ji, etc... */
svlvl = sv_2mortal(newSVpv(str, 0));
vsnprintf(buf, 255, fmt, args);
svmsg = sv_2mortal(newSVpv(buf, 0));
PUSHMARK(SP);
XPUSHs(svlvl);
XPUSHs(svmsg);
PUTBACK;
call_sv(logcb_ref, G_DISCARD);
FREETMPS;
#!/usr/bin/perl -s
##
# Prints local packages which are not required by any other local package.
# Pass the -i switch to only print implicitly installed packages.
# Pass the -e switch to only print explicitly installed packages.
# Pass neither to print both.
use ALPM::Conf qw(/etc/pacman.conf);
die q{You can't use both -i and -e} if $i && $e;
for my $pkg ($alpm->localdb->pkgs){
next if(@{$pkg->requiredby} > 0);
if($i || $e){
next if($pkg->reason ne ($i ? 'implicit' : 'explicit'));
}
push @dangles, $pkg->name;
}
print map { "$_\n" } sort @dangles;
#!/bin/sh
perl -MALPM::Conf=/etc/pacman.conf -e '
print substr(sprintf("%-16s * %s", $_->name, $_->desc), 0, 78), "\n"
for($alpm->localdb->pkgs);
'
#!/usr/bin/perl -s
##
# Give a list of files as command line arguments (i.e. use shell wildcards)
# The owners of each file is printed alphabetically, with owned files grouped
# by package. Files are also printed alphabetically.
# Pass the -q flag to only print the owning package names.
#
use ALPM::Conf qw(/etc/pacman.conf);
use File::Spec;
unless(@ARGV){
print STDERR "usage: ownzors [file paths]\n";
exit 2;
}
for my $pkg ($alpm->localdb->pkgs) {
$who_owns{$_->{'name'}} = $pkg->name for(@{$pkg->files});
}
push @{$results{$who_owns{$_}}}, $_
for(map { s{\A/}{}; $_ } map { File::Spec->rel2abs($_) } @ARGV);
## Happy A! \o/
if($q){
print $_, "\n" for(sort keys %results);
exit 0;
}
for my $pkgname (sort keys %results){
print $pkgname, "\n", map { "\t/$_\n" } sort @{$results{$pkgname}};
}
lib/ALPM.pod view on Meta::CPAN
$alpm->set_logfile('/var/log/pacman.log');
## Or use ALPM::Conf, a handy module for pacman.conf parsing.
use ALPM::Conf qw(/etc/pacman.conf);
## ALPM::Conf loads an object into "our" package variable.
our $alpm;
## Querying databases & packages
my $localdb = $alpm->localdb;
my $pkg = $localdb->find('perl') or die 'wtfbbq';
printf "%s %s %s %d\n", $pkg->name, $pkg->version,
$pkg->arch, $pkg->size;
my $extradb = $alpm->register('extra') or die $alpm->strerror;
$extradb->add_mirror('ftp://ftp.archlinux.org/extra/os/i686')
or die $alpm->strerror;
$extradb->update or die $alpm->strerror;
my @perlpkgs = $extradb->search('perl');
printf "%d perl packages found.\n", scalar @perlpkgs;
## libalpm's version comparison function. (a classy method)
my $cmp = ALPM->vercmp('0.01', '0.02');
if($cmp == -1){
print "less than\n";
}elsif($cmp == 0){
print "equal\n";
}elsif($cmp == 1){
print "greater than\n";
}
## $found is undef or the package object for findme.
my @syncdbs = $alpm->syncdbs;
my $found = $alpm->find_dbs_satisfier('findme', @syncdbs);
$found = $alpm->find_satisfier('findme', $extradb->pkgs);
## These are perl wrappers around localdb and syncdbs:
## Search all databases/repos (includes localdb).
printf "%10s: %s %s\n", $_->db->get_name, $_->name,
$_->version for $alpm->search('perl');
## Find a database by name of repository.
my $coredb = $alpm->db('core');
=head1 DESCRIPTION
Archlinux uses a package manager called pacman. Pacman internally
uses the alpm library for handling its database of packages. This
module creates a perlish object-oriented interface to the libalpm C library.
lib/ALPM/Conf.pm view on Meta::CPAN
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';
lib/ALPM/Conf.pod view on Meta::CPAN
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";
# This is handy for the command line or shell scripts.
% perl -MALPM::Conf=/etc/pacman.conf -e '
for $p ($alpm->localdb->pkgs){
print $p->name, " ", $p->version, "\n";
}
'
=head1 DESCRIPTION
This class is used to parse the pacman.conf files which are used by ArchLinux's
pacman for config files. The configuration fields are used to set ALPM options.
A new I<ALPM> object instance is created with corresponding options set.
=head1 CONSTRUCTOR
lib/ALPM/DB.pod view on Meta::CPAN
=head1 NAME
ALPM::DB - Database base class, inherited by local and sync databases.
=head1 SYNOPSIS
use ALPM::Conf qw(/etc/pacman.conf);
my $db = $alpm->localdb;
printf "Playing with %s database\n", $db->name;
my $perl = $db->find('perl') or die 'where is perl';
$db = $alpm->register('community') or die;
$db->add_server('ftp://ftp.archlinux.org/community/os/i686') or die;
for my $pkg ($db->search('perl')){
printf "%s\t%s\n", $pkg->name, $pkg->version;
}
for my $pkg ($db->find_group('xfce4')){
printf "xfce4:\t%s\t%s\n", $pkg->name, $pkg->version;
}
my %grps = $db->groups;
while(my($g, $pkgs) = each %grps){
printf "%s\t%s\n", $g, $_->name for(@$pkgs);
}
=head1 OBJECT METHODS
=head2 name
$NAME = $DB->name()
=over 4
lib/ALPM/Package.pod view on Meta::CPAN
ALPM::Package - libalpm packages of files, with dependencies, etc.
=head1 SYNOPSIS
use ALPM::Conf qw(/etc/pacman.conf);
my $perlpkg = $alpm->localdb->find('perl');
## All package methods are accessors.
my $name = $perlpkg->name();
print "$name rocks!\n";
## Here is an ugly trick. Please forgive me.
print "@{[$perlpkg->name]} rocks!\n";
## Dependencies are arrayrefs of hashrefs (AoH):
print "$name depends on:\n";
for my $deps (@{$perlpkg->depends}){
print "\t@{$dep}{'name', 'mod', 'version'}\n";
}
## File lists are also arrayrefs of hashrefs (AoH):
print "$name owns files:\n";
for my $f (@{$perlpkg->files}){
printf "\t%s %o %d\n", $f->{'name'}, $f->{'mode'}, $f->{'size'};
}
## Others lists are arrayrefs of scalars:
print "$name is licensed under: @{$perlpkg->licenses}";
=head1 DESCRIPTION
This class is a wrapper for all of the C<alpm_pkg_...> C library functions
of libalpm. You retrieve the package from the database and you can then
access its information.
=head1 ACCESSORS
The accessors are named almost exactly the same as the C<alpm_pkg_get...>
=head2 --copy=I<suffix>
If this option is given, a copy of each file will be saved with
the given suffix that contains the suggested changes. This does
not require any external programs. Note that this does not
automagially add a dot between the original filename and the
suffix. If you want the dot, you have to include it in the option
argument.
If neither C<--patch> or C<--copy> are given, the default is to
simply print the diffs for each file. This requires either
C<Text::Diff> or a C<diff> program to be installed.
=head2 --diff=I<program>
Manually set the diff program and options to use. The default
is to use C<Text::Diff>, when installed, and output unified
context diffs.
=head2 --compat-version=I<version>
=head2 --cplusplus
Usually, F<ppport.h> will detect C++ style comments and
replace them with C style comments for portability reasons.
Using this option instructs F<ppport.h> to leave C++
comments untouched.
=head2 --quiet
Be quiet. Don't print anything except fatal errors.
=head2 --nodiag
Don't output any diagnostic messages. Only portability
alerts will be printed.
=head2 --nohints
Don't output any hints. Hints often contain useful portability
notes. Warnings will still be displayed.
=head2 --nochanges
Don't suggest any changes. Only give diagnostic output and hints
unless these are also deactivated.
-----------------------------------------------------------------------------------------
PL_parser NEED_PL_parser NEED_PL_parser_GLOBAL
PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL
eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL
grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL
grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL
grok_number() NEED_grok_number NEED_grok_number_GLOBAL
grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL
grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL
load_module() NEED_load_module NEED_load_module_GLOBAL
my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL
my_sprintf() NEED_my_sprintf NEED_my_sprintf_GLOBAL
my_strlcat() NEED_my_strlcat NEED_my_strlcat_GLOBAL
my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL
newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL
newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL
newSVpvn_flags() NEED_newSVpvn_flags NEED_newSVpvn_flags_GLOBAL
newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL
pv_display() NEED_pv_display NEED_pv_display_GLOBAL
pv_escape() NEED_pv_escape NEED_pv_escape_GLOBAL
pv_pretty() NEED_pv_pretty NEED_pv_pretty_GLOBAL
sv_2pv_flags() NEED_sv_2pv_flags NEED_sv_2pv_flags_GLOBAL
list-provided list-unsupported api-info=s
)) or usage();
};
if ($@ and grep /^-/, @ARGV) {
usage() if "@ARGV" =~ /^--?h(?:elp)?$/;
die "Getopt::Long not found. Please don't use any options.\n";
}
if ($opt{version}) {
print "This is $0 $VERSION.\n";
exit 0;
}
usage() if $opt{help};
strip() if $opt{strip};
if (exists $opt{'compat-version'}) {
my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) };
if ($@) {
die "Invalid version number format: '$opt{'compat-version'}'\n";
}
die "Only Perl 5 is supported\n" if $r != 5;
die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000;
$opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s;
}
else {
$opt{'compat-version'} = 5;
}
my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/
? ( $1 => {
($2 ? ( base => $2 ) : ()),
($3 ? ( todo => $3 ) : ()),
(index($4, 'v') >= 0 ? ( varargs => 1 ) : ()),
do_msgrcv|||
do_msgsnd|||
do_oddball|||
do_op_dump||5.006000|
do_op_xmldump|||
do_open9||5.006000|
do_openn||5.007001|
do_open||5.004000|
do_pmop_dump||5.006000|
do_pmop_xmldump|||
do_print|||
do_readline|||
do_seek|||
do_semop|||
do_shmio|||
do_smartmatch|||
do_spawn_nowait|||
do_spawn|||
do_sprintf|||
do_sv_dump||5.006000|
do_sysseek|||
do_tell|||
do_trans_complex_utf8|||
do_trans_complex|||
do_trans_count_utf8|||
do_trans_count|||
do_trans_simple_utf8|||
do_trans_simple|||
do_trans|||
forbid_setid|||
force_ident|||
force_list|||
force_next|||
force_version|||
force_word|||
forget_pmop|||
form_nocontext|||vn
form||5.004000|v
fp_dup|||
fprintf_nocontext|||vn
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
is_uni_cntrl_lc||5.006000|
is_uni_cntrl||5.006000|
is_uni_digit_lc||5.006000|
is_uni_digit||5.006000|
is_uni_graph_lc||5.006000|
is_uni_graph||5.006000|
is_uni_idfirst_lc||5.006000|
is_uni_idfirst||5.006000|
is_uni_lower_lc||5.006000|
is_uni_lower||5.006000|
is_uni_print_lc||5.006000|
is_uni_print||5.006000|
is_uni_punct_lc||5.006000|
is_uni_punct||5.006000|
is_uni_space_lc||5.006000|
is_uni_space||5.006000|
is_uni_upper_lc||5.006000|
is_uni_upper||5.006000|
is_uni_xdigit_lc||5.006000|
is_uni_xdigit||5.006000|
is_utf8_alnumc||5.006000|
is_utf8_alnum||5.006000|
is_utf8_char_slow|||n
is_utf8_char||5.006000|
is_utf8_cntrl||5.006000|
is_utf8_common|||
is_utf8_digit||5.006000|
is_utf8_graph||5.006000|
is_utf8_idcont||5.008000|
is_utf8_idfirst||5.006000|
is_utf8_lower||5.006000|
is_utf8_mark||5.006000|
is_utf8_print||5.006000|
is_utf8_punct||5.006000|
is_utf8_space||5.006000|
is_utf8_string_loclen||5.009003|
is_utf8_string_loc||5.008001|
is_utf8_string||5.006001|
is_utf8_upper||5.006000|
is_utf8_xdigit||5.006000|
isa_lookup|||
items|||n
ix|||n
my_letohl|||n
my_letohs|||n
my_lstat|||
my_memcmp||5.004000|n
my_memset|||n
my_ntohl|||
my_pclose||5.004000|
my_popen_list||5.007001|
my_popen||5.004000|
my_setenv|||
my_snprintf|5.009004||pvn
my_socketpair||5.007003|n
my_sprintf|5.009003||pvn
my_stat|||
my_strftime||5.007002|
my_strlcat|5.009004||pn
my_strlcpy|5.009004||pn
my_swabn|||n
my_swap|||
my_unexec|||
my_vsnprintf||5.009004|n
need_utf8|||n
newANONATTRSUB||5.006000|
newANONHASH|||
newANONLIST|||
newANONSUB|||
newASSIGNOP|||
newATTRSUB||5.006000|
newAVREF|||
newAV|||
newBINOP|||
pmop_xmldump|||
pmruntime|||
pmtrans|||
pop_scope|||
pregcomp||5.009005|
pregexec|||
pregfree2||5.011000|
pregfree|||
prepend_elem|||
prepend_madprops|||
printbuf|||
printf_nocontext|||vn
process_special_blocks|||
ptr_table_clear||5.009005|
ptr_table_fetch||5.009005|
ptr_table_find|||n
ptr_table_free||5.009005|
ptr_table_new||5.009005|
ptr_table_split||5.009005|
ptr_table_store||5.009005|
push_scope|||
put_byte|||
yyerror|||
yylex|||
yyparse|||
yywarn|||
);
if (exists $opt{'list-unsupported'}) {
my $f;
for $f (sort { lc $a cmp lc $b } keys %API) {
next unless $API{$f}{todo};
print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n";
}
exit 0;
}
# Scan for possible replacement candidates
my(%replace, %need, %hints, %warnings, %depends);
my $replace = 0;
my($hint, $define, $function);
my %s;
$_ = [sort grep !$s{$_}++, @$_];
}
if (exists $opt{'api-info'}) {
my $f;
my $count = 0;
my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$";
for $f (sort { lc $a cmp lc $b } keys %API) {
next unless $f =~ /$match/;
print "\n=== $f ===\n\n";
my $info = 0;
if ($API{$f}{base} || $API{$f}{todo}) {
my $base = format_version($API{$f}{base} || $API{$f}{todo});
print "Supported at least starting from perl-$base.\n";
$info++;
}
if ($API{$f}{provided}) {
my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003";
print "Support by $ppport provided back to perl-$todo.\n";
print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f};
print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f};
print "\n$hints{$f}" if exists $hints{$f};
print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f};
$info++;
}
print "No portability information available.\n" unless $info;
$count++;
}
$count or print "Found no API matching '$opt{'api-info'}'.";
print "\n";
exit 0;
}
if (exists $opt{'list-provided'}) {
my $f;
for $f (sort { lc $a cmp lc $b } keys %API) {
next unless $API{$f}{provided};
my @flags;
push @flags, 'explicit' if exists $need{$f};
push @flags, 'depend' if exists $depends{$f};
push @flags, 'hint' if exists $hints{$f};
push @flags, 'warning' if exists $warnings{$f};
my $flags = @flags ? ' ['.join(', ', @flags).']' : '';
print "$f$flags\n";
}
exit 0;
}
my @files;
my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc );
my $srcext = join '|', map { quotemeta $_ } @srcext;
if (@ARGV) {
my %seen;
}
else {
diag("Uses $func");
}
}
$warnings += hint($func);
}
unless ($opt{quiet}) {
for $func (sort keys %{$file{uses_todo}}) {
print "*** WARNING: Uses $func, which may not be portable below perl ",
format_version($API{$func}{todo}), ", even with '$ppport'\n";
$warnings++;
}
}
for $func (sort keys %{$file{needed_static}}) {
my $message = '';
if (not exists $file{uses}{$func}) {
$message = "No need to define NEED_$func if $func is never used";
}
if ($file{changes}) {
if (exists $opt{copy}) {
my $newfile = "$filename$opt{copy}";
if (-e $newfile) {
error("'$newfile' already exists, refusing to write copy of '$filename'");
}
else {
local *F;
if (open F, ">$newfile") {
info("Writing copy of '$filename' with changes to '$newfile'");
print F $c;
close F;
}
else {
error("Cannot open '$newfile' for writing: $!");
}
}
}
elsif (exists $opt{patch} || $opt{changes}) {
if (exists $opt{patch}) {
unless ($patch_opened) {
if (!defined $diff) {
$diff = run_diff('diff', $file, $str);
}
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";
if (open F, ">$tmp") {
print F $str;
close F;
if (open F, "$prog $file $tmp |") {
while (<F>) {
s/\Q$tmp\E/$file.patched/;
$diff .= $_;
}
close F;
unlink $tmp;
return $diff;
$v = int $v;
$s = int $s;
if ($r < 5 || ($r == 5 && $v < 6)) {
if ($s % 10) {
die "invalid version '$ver'\n";
}
$s /= 10;
$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;
}
eval { require Devel::PPPort };
\$@ and die "Cannot require Devel::PPPort, please install.\\n";
if (eval \$Devel::PPPort::VERSION < $VERSION) {
die "$0 was originally generated with Devel::PPPort $VERSION.\\n"
. "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n"
. "Please install a newer version, or --unstrip will not work.\\n";
}
Devel::PPPort::WriteFile(\$0);
exit 0;
}
print <<END;
Sorry, but this is a stripped version of \$0.
To be able to use its original script and doc functionality,
please try to regenerate this file using:
\$^X \$0 --unstrip
END
/ms;
/ (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*)
| ( "[^"\\]*(?:\\.[^"\\]*)*"
| '[^'\\]*(?:\\.[^'\\]*)*' )
| ($HS+) }{ defined $2 ? ' ' : ($1 || '') }gsex;
$c =~ s!\s+$!!mg;
$c =~ s!^$LF!!mg;
$c =~ s!^\s*#\s*!#!mg;
$c =~ s!^\s+!!mg;
open OUT, ">$0" or die "cannot strip $0: $!\n";
print OUT "$pl$c\n";
exit 0;
}
__DATA__
*/
#ifndef _P_P_PORTABILITY_H_
#define _P_P_PORTABILITY_H_
#ifndef isCNTRL
# define isCNTRL(c) iscntrl(c)
#endif
#ifndef isGRAPH
# define isGRAPH(c) isgraph(c)
#endif
#ifndef isPRINT
# define isPRINT(c) isprint(c)
#endif
#ifndef isPUNCT
# define isPUNCT(c) ispunct(c)
#endif
#ifndef isXDIGIT
# define isXDIGIT(c) isxdigit(c)
#endif
return value;
}
*flags = PERL_SCAN_GREATER_THAN_UV_MAX;
if (result)
*result = value_nv;
return UV_MAX;
}
#endif
#endif
#if !defined(my_snprintf)
#if defined(NEED_my_snprintf)
static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...);
static
#else
extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...);
#endif
#define my_snprintf DPPP_(my_my_snprintf)
#define Perl_my_snprintf DPPP_(my_my_snprintf)
#if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL)
int
DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...)
{
dTHX;
int retval;
va_list ap;
va_start(ap, format);
#ifdef HAS_VSNPRINTF
retval = vsnprintf(buffer, len, format, ap);
#else
retval = vsprintf(buffer, format, ap);
#endif
va_end(ap);
if (retval < 0 || (len > 0 && (Size_t)retval >= len))
Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
return retval;
}
#endif
#endif
#if !defined(my_sprintf)
#if defined(NEED_my_sprintf)
static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...);
static
#else
extern int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...);
#endif
#define my_sprintf DPPP_(my_my_sprintf)
#define Perl_my_sprintf DPPP_(my_my_sprintf)
#if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL)
int
DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...)
{
va_list args;
va_start(args, pat);
vsprintf(buffer, pat, args);
va_end(args);
return strlen(buffer);
}
#endif
#endif
#ifdef NO_XSLOCKS
# ifdef dJMPENV
# define dXCPT dJMPENV; int rEtV = 0
for (; pv < end && (!max || wrote < max) ; pv += readsize) {
const UV u =
#if defined(is_utf8_string) && defined(utf8_to_uvchr)
isuni ? utf8_to_uvchr((U8*)pv, &readsize) :
#endif
(U8)*pv;
const U8 c = (U8)u & 0xFF;
if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) {
if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
chsize = my_snprintf(octbuf, sizeof octbuf,
"%"UVxf, u);
else
chsize = my_snprintf(octbuf, sizeof octbuf,
"%cx{%"UVxf"}", esc, u);
} else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
chsize = 1;
} else {
if (c == dq || c == esc || !isPRINT(c)) {
chsize = 2;
switch (c) {
case '\\' : /* fallthrough */
case '%' : if (c == esc)
octbuf[1] = esc;
case '\v' : octbuf[1] = 'v'; break;
case '\t' : octbuf[1] = 't'; break;
case '\r' : octbuf[1] = 'r'; break;
case '\n' : octbuf[1] = 'n'; break;
case '\f' : octbuf[1] = 'f'; break;
case '"' : if (dq == '"')
octbuf[1] = '"';
else
chsize = 1;
break;
default: chsize = my_snprintf(octbuf, sizeof octbuf,
pv < end && isDIGIT((U8)*(pv+readsize))
? "%c%03o" : "%c%o", esc, c);
}
} else {
chsize = 1;
}
}
if (max && wrote + chsize > max) {
break;
} else if (chsize > 1) {
sv_catpvn(dsv, octbuf, chsize);
wrote += chsize;
} else {
char tmp[2];
my_snprintf(tmp, sizeof tmp, "%c", c);
sv_catpvn(dsv, tmp, 1);
wrote++;
}
if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
break;
}
if (escaped != NULL)
*escaped= pv - str;
return SvPVX(dsv);
}
t/03-Package.t view on Meta::CPAN
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';
}
return $url;
}
$msg = 'load the simpletest/foo package file';
$pkg = $alpm->load_pkgfile(pkgpath('simpletest', 'foo'), 1, 'default');
if($pkg){
pass $msg;
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
## 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
#GPGDir = $root/gnupg/
HoldPkg = pacman glibc
SyncFirst = pacman
#XferCommand = /usr/bin/curl -C - -f %u > %o
#XferCommand = /usr/bin/wget --passive-ftp -c -O %o %u
t/preptests.pl view on Meta::CPAN
#TotalDownload
CheckSpace
#VerbosePkgLists
# PGP signature checking
SigLevel = Optional
END_CONF
while(my($repo, $path) = each %$repos){
print $of <<"END_CONF"
[$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;
}
t/preptests.pl view on Meta::CPAN
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");
for my $pkg (@{$repos->{$r}}){
system 'perl' => 'repoadd.pl', $rd, $pkg;
if($?){
print STDERR "$PROG: repoadd.pl failed\n";
exit 1;
}
}
system 'perl' => 'repofin.pl', $rd;
if($?){
print STDERR "$PROG: repofin.pl failed\n";
exit 1;
}
$paths{$r} = $rd;
}
chdir $wd or die "chdir: $!";
return \%paths;
}
t/repos/package.pl view on Meta::CPAN
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;
}
unlink("$td/.PKGINFO") or die "unlink: $!";
updatepi($pi, $td);
writepi($pi, "$td/.PKGINFO");
my $fname = pkgfname($pi);
my $oldwd = getcwd();
chdir $td or die "chdir: $!";
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) = @_;
t/repos/package.pl view on Meta::CPAN
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);
return undef unless(-f "$td/$fname");
my($itime, $ptime) = map { my $s = stat $_; $s->mtime }
("$pd/.PKGINFO", "$td/$fname");
return undef if($itime > $ptime);
t/repos/package.pl view on Meta::CPAN
my $rd = "$bd/$repo";
for my $p (sort @{$repos->{$repo}}){
my $srcd = "$rd/$p";
my $destd = "$td/$p";
my $pi = readpi("$srcd/.PKGINFO");
my $pkgp = findbuilt($pi, $srcd, $rd);
unless($pkgp){
my $tmpp = buildpkg($pi, $srcd, $destd);
$pkgp = "$rd/" . basename($tmpp);
unless(copy($tmpp, $pkgp)){
printf STDERR "$PROG: copy $tmpp to $pkgp failed: $!";
exit 1;
}
}
print "$repo\t$wd/$pkgp\n";
}
}
t/repos/repoadd.pl view on Meta::CPAN
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'};
system "cat $path | xz -dc | bsdtar -xf - .PKGINFO";
if(@? || !-f '.PKGINFO'){
print STDERR "$PROG: failed to extract .PKGINFO from $path\n";
exit 1;
}
open my $if, '<.PKGINFO' or die "open: $!";
my %pi;
for my $ln (<$if>){
next if($ln =~ /^\#/);
chomp $ln;
my($name, $val) = split /\s*=\s*/, $ln, 2;
t/repos/repoadd.pl view on Meta::CPAN
}
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($?){
print STDERR "$PROG: failed to unlink dir: $dir\n";
exit 1;
}
}
mkdir $dir or die "mkdir: $!";
my %deps;
for my $dkey (@DepFields){
$deps{$dkey} = delete $pi->{$dkey} if($pi->{$dkey});
}
$self->writeFile("$dir/depends", \%deps);
t/repos/repoadd.pl view on Meta::CPAN
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){
print STDERR "$PROG: $pkgpath is not a valid path\n";
exit 1;
}
my $db = DBDir->fromPath($dbdir);
my $pkg = PkgFile->fromPath($pkgpath);
$db->addEntry($pkg);
my $dest = "$dbname/" . $pkg->fileName;
rename $pkgpath, $dest or die "rename: $!";
return 0;
t/repos/repofin.pl view on Meta::CPAN
#!/usr/bin/env perl
use File::Basename;
unless(@ARGV == 1){
print STDERR "usage: $0 [repo dir path]\n";
exit 2;
}
$dir = shift;
unless(-d $dir){
print STDERR "$0: repo dir $dir does not exist\n";
exit 1;
}
$name = basename($dir);
$dir = "$dir/contents";
unless(-d $dir){
print STDERR "$0: the specified repo dir must contain a 'contents' dir\n";
exit 1;
}
chdir $dir or die "chdir: $!";
system "bsdtar -cf - * | gzip -c > ../$name.db";
if($? || !-f "../$name.db"){
print STDERR "$0: failed to create tarball\n";
exit 1;
}
chdir '..' or die "chdir: $!";
system 'rm -r contents';
exit 0;
xs/Package.xs view on Meta::CPAN
SV *changelog_txt;
CODE:
changelog_txt = newSVpv("", 0);
RETVAL = changelog_txt;
fp = alpm_pkg_changelog_open(pkg);
if(fp){
while(1){
bytes_read = alpm_pkg_changelog_read((void *)buffer, 128,
pkg, fp);
/*fprintf(stderr,"DEBUG: read %d bytes of changelog\n", */
/* bytes_read); */
if(bytes_read == 0) break;
sv_catpvn(changelog_txt, buffer, bytes_read);
}
alpm_pkg_changelog_close(pkg, fp);
}
OUTPUT:
RETVAL
MODULE=ALPM PACKAGE=ALPM::Package PREFIX=alpm_pkg_compute_
( run in 1.638 second using v1.01-cache-2.11-cpan-de7293f3b23 )