File: Fromrpm.pm

package info (click to toggle)
alien 6.18
  • links: PTS
  • area: main
  • in suites: slink
  • size: 256 kB
  • ctags: 61
  • sloc: perl: 923; makefile: 118
file content (166 lines) | stat: -rw-r--r-- 5,011 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
#!/usr/bin/perl
#
# Package for converting from a .rpm file.

package From::rpm;

use strict;

# Query a rpm file for fields, and return a hash of the fields found.
# Pass the filename of the rpm file to query.
sub GetFields { my ($self,$file)=@_;
	my %fields;

	# This maps rpm fields (the keys) to the name we want
	# for each field (the values).
	my %fieldtrans;

	# Get the scripts fields too?
	if ($main::scripts) {
		%fieldtrans=(
			'PREIN' => 'PREINST',
			'POSTIN' => 'POSTINST',
			'PREUN' => 'PRERM',
			'POSTUN' => 'POSTRM',
		);
	}

	# These fields need no translation.
	my $field;
	foreach $field ('NAME','VERSION','RELEASE','ARCH','CHANGELOGTEXT','SUMMARY',
	         'DESCRIPTION', 'COPYRIGHT') {
		$fieldtrans{$field}=$field;
	}

	# Use --queryformat to pull out all the fields we need.
	foreach $field (keys(%fieldtrans)) {
		$_=`rpm -qp $file --queryformat \%{$field}`;
		$fields{$fieldtrans{$field}}=$_ if $_ ne '(none)';
	}

	# DEFAULTPREFIX is special because it only exists in old versions of rpm.
	$_=`rpm -qp $file --queryformat \%{DEFAULTPREFIX} 2>/dev/null`;
	$fields{DEFAULTPREFIX}=$_ if $_ ne '(none)';

	if ($main::scripts) {
		# Fix up the scripts - they are always shell scripts, so make them so.
		foreach $field ('PREINST','POSTINST','PRERM','POSTRM') {
			$fields{$field}="#!/bin/sh\n$fields{$field}" if $fields{$field};
		}
	}

	# Get the conffiles list.
	# TOCHECK: if this is a relocatable package and DEFAULTPREFIX is set,
	# do we need to prepend DEFAULTPREFIX to each of these filenames?
	$fields{CONFFILES}=`rpm -qcp $file`;

	# Include the output of rpm -qi in the copyright file.
	$fields{COPYRIGHT_EXTRA}=`rpm -qpi $file`;

	# Get the filelist, it's used in the parent directory check in Unpack().
	$fields{FILELIST}=`rpm -qpl $file`;

	# Sanity check fields.
	if (!$fields{SUMMARY}) {
		# Older rpms will have no summary, but will have a 
		# description. We'll take the 1st line out of the 
		# description, and use it for the summary.
		($fields{SUMMARY})=($fields{DESCRIPTION}."\n")=~m/(.*?)\n/m;

		# Fallback.
		if (!$fields{SUMMARY}) {
			$fields{SUMMARY}="Converted RPM package";
		}
	}
	if (!$fields{COPYRIGHT}) {
		$fields{COPYRIGHT}="unknown";
	}
	if (!$fields{DESCRIPTION}) {
		$fields{DESCRIPTION}=$fields{SUMMARY};
	}

	# Convert ARCH into string, if it isn't already a string.
	if ($fields{ARCH} eq 1) {
		$fields{ARCH}='i386';
	}
	elsif ($fields{ARCH} eq 2) {
		$fields{ARCH}='alpha';
	}
	elsif ($fields{ARCH} eq 3) {
		$fields{ARCH}='sparc';
	}
	elsif ($fields{ARCH} eq 6) {
		$fields{ARCH}='m68k';
	}
	elsif ($fields{ARCH} eq "noarch") { # noarch = all
		$fields{ARCH}='all';
	}

	if ($fields{RELEASE} eq undef || $fields{VERSION} eq undef|| !$fields{NAME}) {
		Alien::Error("Error querying rpm file.");
	}

	$fields{RELEASE}++ unless $main::keep_version;
	$fields{DISTRIBUTION}="Red Hat";

	return %fields;
}

# Unpack a rpm file.
sub Unpack { my ($self,$file,%fields)=@_;
	Alien::SafeSystem("(cd ..;rpm2cpio $file) | cpio --extract --make-directories --no-absolute-filenames --preserve-modification-time",
  	"Error unpacking $file\n");

	# This whole block is just in for backwards compatability with old versions 
	# of rpm.
	if ($fields{DEFAULTPREFIX} ne undef) {
		print "Moving unpacked files into $fields{DEFAULTPREFIX}\n";

		# We have extracted the package, but it's in the wrong place. Move it
		# to be under the DEFAULTPREFIX directory.
		# First, get a list of files to move.
		my $filelist=join ' ',glob('*');

		# Now, make the destination directory.
		my $collect=undef;
		foreach (split(m:/:,$fields{DEFAULTPREFIX})) {
			if ($_ ne undef) { # this keeps us from using anything but relative paths.
				$collect.="$_/";
				mkdir $collect,0755 || Alien::Error("Unable to make directory: $collect: $!");
			}
		}
		# Now move all files in the package to the directory we made.
		Alien::SafeSystem("mv $filelist ./$fields{DEFAULTPREFIX}",
			"Error moving unpacked files into the default prefix directory\n");
	}

	# When cpio extracts the file, any child directories that are present, but
	# whose parent directories are not, end up mode 700. This next block corrects
	# that to 755, which is more reasonable.
	#
	# Of course, this whole thing assumes we get the filelist in sorted order.
	my $lastdir=undef;
	foreach $file (split(/\n/,$fields{FILELIST})) {
		$file=~s/^\///;
		if (($lastdir && $file=~m:^\Q$lastdir\E/[^/]*$: eq undef) || !$lastdir) {
			# We've found one of the nasty directories. Fix it up.
			#
			# Note that I strip the trailing filename off $file here, for two 
			# reasons. First, it makes the loop easier, we don't need to fix the
			# perms on the last file, after all! Second, it makes the -d test below
			# fire, which saves us from trying to fix a parent directory twice.
			($file)=$file=~m:(.*)/.*?:;
			my $dircollect=undef;
			my $dir;
			foreach $dir (split(/\//,$file)) {
				$dircollect.="$dir/";
				chmod 0755,$dircollect; # TADA!
			}
		}
		if (-d "./$file") {
			$lastdir=$file;
		}
	}
}

1