File Coverage

blib/lib/RPM/Header/PurePerl.pm

Criterion	Covered	Total	%
statement	81	136	59.5
branch	32	56	57.1
condition	13	27	48.1
subroutine	5	12	41.6
pod			n/a
total	131	231	56.7

# Copyright (C) 2001,2002,2006 Troels Liebe Bentsen
# This library is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.

package RPM::Header::PurePerl;
use vars '$VERSION';
$VERSION = q{1.0.2};

use strict;
use RPM::Header::PurePerl::Tagtable;

sub TIEHASH   # during tie()
{
    my $RPM_HEADER_MAGIC = chr(0x8e).chr(0xad).chr(0xe8);
    my $RPM_FILE_MAGIC   = chr(0xed).chr(0xab).chr(0xee).chr(0xdb);
    my $buff;

    my ($class_name, $filename, $readtype) = @_;
    my $self = bless { hash => {}, }, $class_name;

    if (!defined($filename) or !open(RPMFILE, "<$filename")) { return undef; }

    binmode(RPMFILE);

    # Read rpm lead
    read(RPMFILE, $buff, 96);
    ( $self->{'hash'}->{'LEAD_MAGIC'},          # unsigned char[4], í«îÛ == rpm
      $self->{'hash'}->{'LEAD_MAJOR'},          # unsigned char, 3 == rpm version 3.x
      $self->{'hash'}->{'LEAD_MINOR'},          # unsigned char, 0 == rpm version x.0
      $self->{'hash'}->{'LEAD_TYPE'},           # short(int16), 0 == binary, 1 == source
      $self->{'hash'}->{'LEAD_ARCHNUM'},        # short(int16), 1 == i386
      $self->{'hash'}->{'LEAD_NAME'},           # char[66], rpm name
      $self->{'hash'}->{'LEAD_OSNUM'},          # short(int16), 1 == Linux
      $self->{'hash'}->{'LEAD_SIGNATURETYPE'},  # short(int16), 1280 == rpm 4.0
      $self->{'hash'}->{'LEAD_RESERVED'}        # char[16] future expansion
    ) = unpack("a4CCssA66ssA16", $buff);
    # DEBUG:
    # foreach my $var (keys %{$self->{'hash'}}) { print "$self->{'hash'}->{$var}\n"; } exit;

    if (!$self->{'hash'}->{'LEAD_MAGIC'} eq $RPM_FILE_MAGIC) { return 0; }

    # Quick read option.
    if (defined($readtype) and ($readtype eq 'onlylead')) { return $self; }

    for (my $header_num=1; $header_num < 3; $header_num++) {
        # DEBUG:
        # print "hlead:".tell(RPMFILE)."\n";

        # Read lead of the headers
        read(RPMFILE, $buff, 16);

        # DEBUG:
        # print "hlead:".tell(RPMFILE)."\n";

        my ($header_magic, $header_version, $header_reserved, $header_entries,
            $header_size) = unpack("a3CNNN", $buff);

        # DEBUG:
        #print "$header_magic, $header_version, $header_reserved, $header_entries, $header_size\n"; next;
        #read(RPMFILE, $buff, 2200, 0); print "header magic:".index($buff, $RPM_HEADER_MAGIC, 256)."\n"; exit;

        if ($header_magic eq $RPM_HEADER_MAGIC) { # RPM_HEADER_MAGIC
            # Read the record structure.
            my $record;
            read(RPMFILE, $record, 16*$header_entries);

            # Read the tag structure, pad to a multiplyer of 8 if it's the first header.
            if ($header_num == 1) {
                # DEBUG:
                #print "Offset 1: $header_size, ".tell(RPMFILE)."\n";
                if (($header_size % 8) == 0) {
                    read(RPMFILE, $buff, $header_size);
                }
                else {
                    read(RPMFILE, $buff, $header_size+(8-($header_size % 8)));
                }
            }
            else {
                # DEBUG:
                #print "Offset 2:".tell(RPMFILE)."\n";
                read(RPMFILE, $buff, $header_size);
            }

            for (my $record_num=0; $record_num < $header_entries;
                $record_num++) { # RECORD LOOP
                my ($tag, $type, $offset, $count) =
                    unpack("NNNN", substr($record, $record_num*16, 16));

                my @value;

                # 10x if signature header.
                if ($header_num == 1) { $tag = $tag*10; }

                # Unknown tag
                if (!defined($hdr_tags{$tag})) {
                    print "Unknown $tag, $type\n"; next;
                }
                # Null type
                elsif ($type == 0) {
                    @value = ('');
                }
                # Char type
                elsif ($type == 1) {
                    print "Char $count $hdr_tags{$tag}{'TAGNAME'}\n";
                    #for (my $i=0; $i < $count; $i++) {
                    #push(@value, substr($buff, $offset, $count));
                    #   $header_info{$record}{'offset'} += $count;
                    #}
                }
                # int8
                elsif ($type == 2) {
                    @value = unpack("C*", substr($buff, $offset, 1*$count));
                    $offset = 1*$count;
                }
                # int16
                elsif ($type == 3) {
                    @value = unpack("n*", substr($buff, $offset, 2*$count));
                    $offset = 2*$count;
                }
                    # int32
                elsif ($type == 4) {
                    @value = unpack("N*", substr($buff, $offset, 4*$count));
                    $offset = 4*$count;
                }
                # int64
                elsif ($type == 5) {
                    print "Int64(Not supported): ".
                        "$count $hdr_tags{$tag}{'TAGNAME'}\n";
                    #@value = unpack("N*", substr($buff, $offset, 4*$count));
                    #$offset = 4*$count;
                }
                # String, String array, I18N string array
                if ($type == 6 or $type == 8 or $type == 9) {
                    for(my $i=0;$i<$count;$i++) {
                        my $length = index($buff, "\0", $offset)-$offset;
                        # unpack istedet for substr.
                        push(@value, substr($buff, $offset, $length));
                        $offset += $length+1;
                    }
                }
                # bin
                elsif ($type == 7) {
                    #print "Bin $count $tags{$tag}{'TAGNAME'}\n";
                    $value[0] = substr($buff, $offset, $count);
                }
                # Find out if it's an array type or not.
                if (defined($hdr_tags{$tag}{'TYPE'})
                        and $hdr_tags{$tag}{'TYPE'} == 1) {
                    @{$self->{'hash'}->{$hdr_tags{$tag}{'TAGNAME'}}} = @value;
                }
                else {
                    $self->{'hash'}->{$hdr_tags{$tag}{'TAGNAME'}} = $value[0];
                }
            } # RECORD LOOP
        } # HEADER LOOP
    }

    # Save package(cpio.gz) location.
    $self->{'hash'}->{'PACKAGE_OFFSET'} = tell(RPMFILE);
    close(RPMFILE);

    # Make old packages look like new ones.
    if (defined($self->{'hash'}->{'FILENAMES'})) {
        my $count = 0;
        my %quick_dirnames;
        foreach my $filename (@{$self->{'hash'}->{'FILENAMES'}}) {
            my $file = ''; my $dir = '/';

            if($filename =~ /(.*\/)(.*$)/) {
                $file = $1; $dir = $2;
            } else {
                $file = $filename;
            }

            if (!defined($quick_dirnames{$dir})) {
                push(@{$self->{'hash'}->{'DIRNAMES'}}, $dir);
                $quick_dirnames{$dir} = $count++;
            }
            push(@{$self->{'hash'}->{'BASENAMES'}}, $file);
            push(@{$self->{'hash'}->{'DIRINDEXES'}}, $quick_dirnames{$dir});
        }
        delete($self->{'hash'}->{'FILENAMES'});
    }

    # Wait I can beat it, a package sould also provide is's own name, sish (and only once).
    my %quick_provides = map {$_ => 1} @{$self->{'hash'}->{'PROVIDENAME'}};
    my %quick_provideflags = map {$_ => 1} @{$self->{'hash'}->{'PROVIDEFLAGS'}};
    my %quick_provideversion
        = map {$_ => 1} @{$self->{'hash'}->{'PROVIDEVERSION'}};

    if (!defined($quick_provides{$self->{'hash'}->{'NAME'}}) and
        !defined($quick_provideflags{8}) and
        !defined($quick_provideversion{$self->{'hash'}->{'VERSION'}})) {
        push(@{$self->{'hash'}->{'PROVIDENAME'}}, $self->{'hash'}->{'NAME'});
        push(@{$self->{'hash'}->{'PROVIDEFLAGS'}}, 8);
        push(@{$self->{'hash'}->{'PROVIDEVERSION'}},
            $self->{'hash'}->{'VERSION'}.'-'.$self->{'hash'}->{'RELEASE'});
    }

    # FILEVERIFYFLAGS is signed
    if ($self->{'hash'}->{'FILEVERIFYFLAGS'}) {
        for(my $i=0;$i{'hash'}->{'FILEVERIFYFLAGS'}}); $i++) {
            my $val = @{$self->{'hash'}->{'FILEVERIFYFLAGS'}}[$i];
            if (int($val) == $val && $val >= 2147483648 &&
                $val <= 4294967295) {
                @{$self->{'hash'}->{'FILEVERIFYFLAGS'}}[$i] -= 4294967296;
            }
        }
    }

    # Lets handel the SIGNATURE, this does not work, fix it please.
    if (defined($self->{'hash'}->{'SIGNATURE_MD5'})) {
        $self->{'hash'}->{'SIGNATURE_MD5'} =
            unpack("H*", $self->{'hash'}->{'SIGNATURE_MD5'});
    }

    # Old stuff, so it can be a drop in replacement for RPM::HEADERS.
    if (defined($self->{'hash'}->{'EPOCH'})) {
        $self->{'hash'}->{'SERIAL'} = $self->{'hash'}->{'EPOCH'};
    }

    if (defined($self->{'hash'}->{'LICENSE'})) {
        $self->{'hash'}->{'COPYRIGHT'} = $self->{'hash'}->{'LICENSE'};
    }

    if (defined($self->{'hash'}->{'PROVIDENAME'})) {
        $self->{'hash'}->{'PROVIDES'} = $self->{'hash'}->{'PROVIDENAME'};
    }

    if (defined($self->{'hash'}->{'OBSOLETENAME'})) {
        $self->{'hash'}->{'OBSOLETES'} = $self->{'hash'}->{'OBSOLETENAME'};
    }

    return $self;
}

sub FETCH     # during $a = $ht{something};
{
    my ($self, $key) = @_;
    return $self->{hash}->{$key};
}

sub STORE     # during $ht{something} = $a;
{
    my ($self, $key, $val) = @_;
    $self->{hash}->{$key} = $val;
}

sub DELETE    # during delete $ht{something}
{
    my ($self, $key) = @_;
    delete $self->{hash}->{$key};
}

sub CLEAR     # during %h = ();
{
    my ($self) = @_;
    $self->{hash} = {};
    ();
}

sub EXISTS    # during if (exists $h{something}) { ... }
{
    my ($self, $key) = @_;
    return exists $self->{hash}->{$key};
}

sub FIRSTKEY  # at the beginning of foreach (keys %h) { ... }
{
    my ($self) = @_;
    each %{$self->{hash}};
}

sub NEXTKEY   # during foreach()
{
    my ($self) = @_;
    each %{$self->{hash}};
}

sub DESTROY   # well, when the hash gets destroyed
{
    # do nothing here
}

=head1 NAME

RPM::Header::PurePerl - a perl only implementation of a RPM header reader.

=head1 VERSION

Version 1.0.2

=head1 SYNOPSIS

    use RPM::Header::PurePerl;
    tie my %rpm, "RPM::Header::PurePerl", "rpm-4.0-1-i586.rpm"
        or die "Problem, could not open rpm";
    print $rpm{'NAME'};

=head1 DESCRIPTION

RPM::Header::PurePerl is a clone of RPM::Header written in only Perl, so it
provides a way to read a rpm package on systems where rpm is not installed.
RPM::Header::PurePerl can used as a drop in replacement for RPM::Header, if
needed also the other way round.

=head1 NOTES

The former name of this package was RPM::PerlOnly.

=head1 AUTHOR

Troels Liebe Bentsen

=head1 COPYRIGHT AND LICENCE

Copyright (C) 2001,2002,2006 Troels Liebe Bentsen

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

1;
__END__