RPM4 - perl module to access and manipulate RPM files

    readconfig(); # Reread default configuration
    readconfig(undef, "i386-mandrake-linux"); # Read configuration for i386

  - EMERG    (0)
  - ALERT    (1)
  - CRIT     (2)
  - ERR      (3)
  - WARNING  (4)
  - NOTICE   (5)
  - INFO     (6)
  - DEBUG    (7)

    tagName(1000); return "NAME".

    tagValue("NAME"); return 1000.

    expand("%_var") return "/var".

##- Nanar <nanardon@zarb.org>
##-
##- This program is free software; you can redistribute it and/or modify
##- it under the terms of the GNU General Public License as published by
##- the Free Software Foundation; either version 2, or (at your option)
##- any later version.
##-
##- This program is distributed in the hope that it will be useful,
##- but WITHOUT ANY WARRANTY; without even the implied warranty of
##- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##- GNU General Public License for more details.
##-
##- You should have received a copy of the GNU General Public License
##- along with this program; if not, write to the Free Software
##- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
#
# $Id: RPM4.pm 132 2007-07-19 22:11:23Z nanardon $

package RPM4;

use strict;
use warnings;

use DynaLoader;
use Exporter;

use RPM4::Header;
use RPM4::Transaction;
use RPM4::Header::Dependencies;
use RPM4::Header::Files;
use RPM4::Spec;

our $VERSION = '0.23';
our @ISA = qw(DynaLoader Exporter);
our @EXPORT = qw(moduleinfo
                 readconfig querytag tagName tagValue expand rpmvercmp
                 stream2header rpm2header
                 installsrpm
                 setverbosity setlogcallback format_rpmpb
                 rpmresign dumpmacros dumprc
                 newdb parserpms);
our %EXPORT_TAGS = (
    rpmlib => [qw(getosname getarchname dumprc dumpmacros rpmvercmp setverbosity setlogcallback
                  rpmlog)],
    macros => [qw(add_macros del_macros loadmacrosfile resetmacros)],
    build => [qw(headernew)],
    rpmdb => [qw(rpmdbverify rpmdbrebuild)],
);

bootstrap RPM4;

# I18N:
sub N {
    my ($msg, @args) = @_;
    sprintf($msg, @args)
}

sub compare_evr {
    my ($ae, $av, $ar) = $_[0] =~ /^(?:([^:]*):)?([^-]*)(?:-(.*))?$/;
    my ($be, $bv, $br) = $_[1] =~ /^(?:([^:]*):)?([^-]*)(?:-(.*))?$/;

    my $rc = 0;
    if(defined($ae) && ! defined($be)) {
        return 1;
    } elsif(!defined($ae) && defined($be)) {
        return -1;
    } else {
        $rc = RPM4::rpmvercmp($ae, $be) if (defined($ae) && defined($be));
        if ($rc == 0) {
            $rc = RPM4::rpmvercmp($av, $bv);
            if ($rc == 0) {
                if(defined($ar) && !defined($br)) {
                    return 1;
                } elsif(!defined($ar) && defined($br)) {
                    return -1;
                } elsif (!defined($ar) &&  !defined($br)) {
                    return 0;
                } else {
                    return RPM4::rpmvercmp($ar, $br);
                }
            } else {
                return $rc;
            }
        } else {
            return $rc;
        }
    }
}

# parse* function
# callback => function
#   (
#       header => the header (undef on error)
#       file => actual source
#   )
# files => []
# flags => ??

sub parserpms {
    my (%options) = @_;
    my $db = newdb();
    $db->vsflags($options{checkrpms} ? [ "NOSIGNATURES" ] : [ qw(NOSIGNATURES NOPAYLOAD NODIGESTS) ]);
    foreach my $rpm (@{$options{rpms} || []}) {
        my $header = $db->rpm2header($options{path} ? "$options{path}/$rpm" : $rpm);
        defined($options{callback}) and
            $options{callback}->(
                header => $header,
                dir => $options{path} ? "$options{path}/" : "",
                rpm => $rpm,
            );
    }
}

sub format_rpmpb {
    my (@msgs) = @_;
    my @ret;
    foreach my $p (@msgs) {
        $p->{pb} eq "BADARCH" and do {
            push @ret, N('package %s is intended for a different architecture', $p->{pkg});
            next;
        };
        $p->{pb} eq "BADOS" and do {
            push @ret, N('package %s is intended for a different operating system', $p->{pkg});
            next;
        };
        $p->{pb} eq "PKG_INSTALLED" and do {
            push @ret, N('package %s is allready installed', $p->{pkg});
            next;
        };
        $p->{pb} eq "BADRELOCATE" and do {
            push @ret, N('path %s in package %s is not relocatable', $p->{path}, $p->{pkg});
            next;
        };
        $p->{pb} eq "NEW_FILE_CONFLICT" and do {
            push @ret, N('file %s conflicts between attempted installs of %s and %s', $p->{file}, $p->{pkg}, $p->{pkg2});
            next;
        };
        $p->{pb} eq "FILE_CONFLICT" and do {
            push @ret, N('file %s from install of %s conflicts with file from package %s', $p->{file}, $p->{pkg}, $p->{pkg2});
            next;
        };
        $p->{pb} eq "OLDPACKAGE" and do {
            push @ret, N('package %s (which is newer than %s) is already installed', $p->{pkg2}, $p->{pkg});
            next;
        };
        $p->{pb} eq "DISKSPACE" and do {
            push @ret, N('installing package %s needs %sB on the %s filesystem', $p->{pkg},
                ($p->{size} > 1024 * 1024
                    ? ($p->{size} + 1024 * 1024 - 1) / (1024 * 1024)
                    : ($p->{size} + 1023) / 1024 ) . 
                ($p->{size} > 1024 * 1024 ? 'M' : 'K'),
                $p->{filesystem});
            next;
        };
        $p->{pb} eq "DISKNODES" and do {
            push @ret, N('installing package %s needs %ld inodes on the %s filesystem', $p->{pkg}, $p->{nodes}, $p->{filesystem});
            next;
        };
        $p->{pb} eq "BADPRETRANS" and do {
            push @ret, N('package %s pre-transaction syscall(s): %s failed: %s', $p->{pkg}, $p->{'syscall'}, $p->{error});
            next;
        };
        $p->{pb} eq "REQUIRES" and do {
            push @ret, N('%s is needed by %s%s', $p->{pkg2},
                defined($p->{installed}) ? N("(installed) ") : "",
                $p->{pkg});
            next;
        };
        $p->{pb} eq "CONFLICT" and do {
            push @ret, N('%s conflicts with %s%s', $p->{pkg2},
                defined($p->{val2}) ? N("(installed) ") : "",
                $p->{pkg});
            next;
        };
    };
    @ret
}

##########################
# Alias for compatiblity #
##########################

sub specnew { newspec(@_) }

sub add_macro { addmacro(@_) }

sub del_macro { delmacro(@_) }

1;

__END__