# 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<int(@{$self->{'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 <tlb@rapanden.dk>

=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__