This file is indexed.

/usr/share/perl5/Alien/Package/Rpm.pm is in alien 8.86.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

  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
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
#!/usr/bin/perl -w

=head1 NAME

Alien::Package::Rpm - an object that represents a rpm package

=cut

package Alien::Package::Rpm;
use strict;
use base qw(Alien::Package);

=head1 DESCRIPTION

This is an object class that represents a rpm package. It is derived from
Alien::Package.

=head1 FIELDS

=over 4

=item prefixes

Relocatable rpm packages have a prefixes field.

=back

=head1 METHODS

=over 4

=item checkfile

Detect rpm files by their extention.

=cut

sub checkfile {
	my $this=shift;
	my $file=shift;

	return $file =~ m/.*\.rpm$/;
}

=item install

Install a rpm. If RPMINSTALLOPT is set in the environement, the options in
it are passed to rpm on its command line.

=cut

sub install {
	my $this=shift;
	my $rpm=shift;

	my $v=$Alien::Package::verbose;
	$Alien::Package::verbose=2;
	$this->do("rpm -ivh ".(exists $ENV{RPMINSTALLOPT} ? $ENV{RPMINSTALLOPT} : '').$rpm)
		or die "Unable to install";
	$Alien::Package::verbose=$v;
}

=item scan

Implement the scan method to read a rpm file.

=cut

sub scan {
	my $this=shift;
	$this->SUPER::scan(@_);
	my $file=$this->filename;

	my %fieldtrans=(
		PREIN => 'preinst',
		POSTIN => 'postinst',
		PREUN => 'prerm',
		POSTUN => 'postrm',
		LICENSE => 'copyright',
	);

	# Use --queryformat to pull out all the fields we need.
	foreach my $field (qw{NAME VERSION RELEASE ARCH CHANGELOGTEXT
		              SUMMARY DESCRIPTION PREFIXES},
	                   keys(%fieldtrans)) {
		my $value=$this->runpipe(0, "LANG=C rpm -qp --queryformat \%{$field} '$file'");
		next if $? || $value eq '(none)';
		my $key;
		if (exists $fieldtrans{$field}) {
			$key=$fieldtrans{$field};
		}
		else {
			$key=lc($field);
		}
		$this->$key($value);
	}

	# Get the conffiles list.
	$this->conffiles([map { chomp; $_ } $this->runpipe(0, "LANG=C rpm -qcp '$file'")]);
	if (defined $this->conffiles->[0] &&
	    $this->conffiles->[0] eq '(contains no files)') {
		$this->conffiles([]);
	}

	$this->binary_info(scalar $this->runpipe(0, "rpm -qpi '$file'"));

	# Get the filelist.
	$this->filelist([map { chomp; $_ } $this->runpipe(0, "LANG=C rpm -qpl '$file'")]);
	if (defined $this->filelist->[0] &&
	    $this->filelist->[0] eq '(contains no files)') {
		$this->filelist([]);
	}

	# Sanity check and sanitize fields.
	unless (defined $this->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.
		$this->summary($this->description."\n")=~m/(.*?)\n/m;

		# Fallback.
		if (! $this->summary) {
			$this->summary('Converted RPM package');
		}
	}
	unless (defined $this->description) {
		$this->description($this->summary);
	}
	unless (defined $this->copyright) {
		# Older rpms have no licence tag, but have a copyright.
		$this->copyright($this->runpipe(0, "LANG=C rpm -qp --queryformat \%{COPYRIGHT} '$file'"));

		# Fallback.
		if (! $this->copyright) {
			$this->copyright('unknown');
		}
	}
	if (! defined $this->release || ! defined $this->version || 
	    ! defined $this->name) {
		die "Error querying rpm file";
	}

	$this->distribution("Red Hat");
	$this->origformat("rpm");

	return 1;
}

=item unpack

Implement the unpack method to unpack a rpm file. This is a little nasty
because it has to handle relocatable rpms and has to do a bit of
permissions fixing as well.

=cut

sub unpack {
	my $this=shift;
	$this->SUPER::unpack(@_);
	my $workdir=$this->unpacked_tree;
	
	# Check if we need to use lzma to uncompress the cpio archive
	my $decomp='';
	if ($this->do("rpm2cpio ".$this->filename." | lzma -t -q > /dev/null 2>&1")) {
		$decomp = 'lzma -d -q |';
	}

	$this->do("rpm2cpio ".$this->filename." | (cd $workdir; $decomp cpio --extract --make-directories --no-absolute-filenames --preserve-modification-time) 2>&1")
		or die "Unpacking of '".$this->filename."' failed";
	
	# cpio does not necessarily store all parent directories in an
	# archive, and so some directories, if it has to make them and has
	# no permission info, will come out with some random permissions.
	# Find those directories and make them mode 755, which is more
	# reasonable.
	my %seenfiles;
	open (RPMLIST, "rpm2cpio ".$this->filename." | $decomp cpio -it --quiet |")
		or die "File list of '".$this->filename."' failed";
	while (<RPMLIST>) {
		chomp;
		$seenfiles{$_}=1;
	}
	close RPMLIST;
	foreach my $file (`cd $workdir; find ./`) {
		chomp $file;
		if (! $seenfiles{$file} && -d "$workdir/$file" && ! -l "$workdir/$file") {
			$this->do("chmod 755 $workdir/$file");
		}
	}

	# If the package is relocatable. We'd like to move it to be under
	# the $this->prefixes directory. However, it's possible that that
	# directory is in the package - it seems some rpm's are marked as
	# relocatable and unpack already in the directory they can relocate
	# to, while some are marked relocatable and the directory they can
	# relocate to is removed from all filenames in the package. I
	# suppose this is due to some change between versions of rpm, but
	# none of this is adequatly documented, so we'll just muddle
	# through.
	#
	# Test to see if the package contains the prefix directory already.
	if (defined $this->prefixes && ! -e "$workdir/".$this->prefixes) {
		my $relocate=1;

		# Get the files to move.
		my @filelist=glob("$workdir/*");
		
		# Now, make the destination directory.
		my $collect=$workdir;
		foreach (split m:/:, $this->prefixes) {
			if ($_ ne '') { # this keeps us from using anything but relative paths.
				$collect.="/$_";
				if (-d $collect) {
					# The package contains a parent
					# directory of the relocation
					# directory. Since it's impossible
					# to move a parent directory into
					# its child, bail out and do
					# nothing.
					$relocate=0;
					last;
				}
				$this->do("mkdir", $collect) || die "unable to mkdir $collect: $!";
			}
		}

		if ($relocate) {
			# Now move all files in the package to the directory we made.
			if (@filelist) {
				$this->do("mv", @filelist, "$workdir/".$this->prefixes)
					or die "error moving unpacked files into the default prefix directory: $!";
			}
	
			# Deal with relocating conffiles.
			my @cf;
			foreach my $cf (@{$this->conffiles}) {
				$cf=$this->prefixes.$cf;
				push @cf, $cf;
			}
			$this->conffiles([@cf]);
		}
	}
	
	# rpm files have two sets of permissions; the set in the cpio
	# archive, and the set in the control data; which override them.
	# The set in the control data are more correct, so let's use those.
	# Some permissions setting may have to be postponed until the
	# postinst.
	my %owninfo = ();
	my %modeinfo = ();
	open (GETPERMS, 'rpm --queryformat \'[%{FILEMODES} %{FILEUSERNAME} %{FILEGROUPNAME} %{FILENAMES}\n]\' -qp '.$this->filename.' |');
	while (<GETPERMS>) {
		chomp;
		my ($mode, $owner, $group, $file) = split(/ /, $_, 4);

		next if -l "$workdir/$file";

		$mode = $mode & 07777; # remove filetype
		my $uid = getpwnam($owner);
		if (! defined $uid || $uid != 0) {
			$owninfo{$file}=$owner;
			$uid=0;
		}
		my $gid = getgrnam($group);
		if (! defined $gid || $gid != 0) {
			if (exists $owninfo{$file}) {
				$owninfo{$file}.=":$group";
			}
			else {
				$owninfo{$file}=":$group";
			}
			$gid=0;
		}
		if (defined($owninfo{$file}) && (($mode & 07000) > 0)) {
			$modeinfo{$file} = sprintf "%lo", $mode;
		}
		# Note that ghost files exist in the metadata but not
                # in the cpio archive, so check that the file exists
		# before trying to access it
		if (-e "$workdir/$file") {
			if ($> == 0) {
				$this->do("chown", "$uid:$gid", "$workdir/$file") 
					|| die "failed chowning $file to $uid\:$gid\: $!";
			}
			$this->do("chmod", sprintf("%lo", $mode), "$workdir/$file") 
				|| die "failed changing mode of $file to $mode\: $!";
		}
	}
	$this->owninfo(\%owninfo);
	$this->modeinfo(\%modeinfo);

	return 1;
}

=item prep

Prepare for package building by generating the spec file.

=cut

sub prep {
	my $this=shift;
	my $dir=$this->unpacked_tree || die "The package must be unpacked first!";

	# Place %config in front of files that are conffiles.
	my @conffiles = @{$this->conffiles};
	my $filelist;
	foreach my $fn (@{$this->filelist}) {
		# Unquote any escaped characters in filenames - needed for
		# non ascii characters. (eg. iso_8859-1 latin set)
		if ($fn =~ /\\/) {
			$fn=eval qq{"$fn"};
		}

		# Note all filenames are quoted in case they contain
		# spaces.
		if ($fn =~ m:/$:) {
			$filelist.=qq{%dir "$fn"\n};
		}
		elsif (grep(m:^\Q$fn\E$:,@conffiles)) { # it's a conffile
			$filelist.=qq{%config "$fn"\n};
		}
		else { # normal file
			$filelist.=qq{"$fn"\n};
		}
	}

	# Write out the spec file.
	my $spec="$dir/".$this->name."-".$this->version."-".$this->release.".spec";
	open (OUT, ">$spec") || die "$spec: $!";
	my $pwd=`pwd`;
	chomp $pwd;
	print OUT "Buildroot: $pwd/$dir\n"; # must be absolute dirname
	print OUT "Name: ".$this->name."\n";
	print OUT "Version: ".$this->version."\n";
	print OUT "Release: ".$this->release."\n";
	print OUT "Requires: ".$this->depends."\n"
		if defined $this->depends && length $this->depends;
	print OUT "Summary: ".$this->summary."\n";
	print OUT "License: ".$this->copyright."\n";
	print OUT "Distribution: ".$this->distribution."\n";
	print OUT "Group: Converted/".$this->group."\n";
	print OUT "\n";
	print OUT "\%define _rpmdir ../\n"; # write rpm to current directory
	print OUT "\%define _rpmfilename %%{NAME}-%%{VERSION}-%%{RELEASE}.%%{ARCH}.rpm\n";
	print OUT "\%define _unpackaged_files_terminate_build 0\n"; # work on SuSE
	print OUT "\n";
	if ($this->usescripts) {
		if ($this->preinst) {
			print OUT "\%pre\n";
			print OUT $this->preinst."\n";
			print OUT "\n";
		}
		if ($this->postinst) {
			print OUT "\%post\n";
			print OUT $this->postinst."\n";
			print OUT "\n";
		}
		if ($this->prerm) {
			print OUT "\%preun\n";
			print OUT $this->prerm."\n";
			print OUT "\n";
		}
		if ($this->postrm) {
			print OUT "\%postun\n";
			print OUT $this->postrm."\n";
			print OUT "\n";
		}
	}
	print OUT "\%description\n";
	print OUT $this->description."\n";
	print OUT "\n";
	print OUT "(Converted from a ".$this->origformat." package by alien version $Alien::Version.)\n";
	print OUT "\n";
	print OUT "%files\n";
	print OUT $filelist if defined $filelist;
	close OUT;
}

=item cleantree

Delete the spec file.

=cut

sub cleantree {
	my $this=shift;
	my $dir=$this->unpacked_tree || die "The package must be unpacked first!";
	
	unlink "$dir/".$this->name."-".$this->version."-".$this->release.".spec";
}

=item build

Build a rpm. If RPMBUILDOPT is set in the environement, the options in
it are passed to rpm on its command line.

An optional parameter, if passed, can be used to specify the program to use
to build the rpm. It defaults to rpmbuild.

=cut

sub build {
	my $this=shift;
	my $buildcmd=shift || 'rpmbuild';
	my $dir=$this->unpacked_tree || die "The package must be unpacked first!";
	
	# Ask rpm how it's set up. We want to know where it will place rpms.
	my $rpmdir;
	foreach ($this->runpipe(1, "rpm --showrc")) {
		chomp;
		if (/^rpmdir\s+:\s(.*)$/) {
			$rpmdir=$1;
		}
	}

	my $rpm=$this->name."-".$this->version."-".$this->release.".".$this->arch.".rpm";
	my $opts='';
	if ($rpmdir) {
		# Old versions of rpm toss it off in the middle of nowhere.
		$rpm="$rpmdir/".$this->arch."/$rpm";

		# This is the old command line argument to set the arch.
		$opts="--buildarch ".$this->arch;
	}
	else {
		# Presumably we're dealing with rpm 3.0 or above, which
		# doesn't output rpmdir in any format I'd care to try to
		# parse. Instead, rpm is now of a late enough version to
		# notice the %define's in the spec file, that will make the
		# file end up in the directory we started in.
		# Anyway, let's assume this is version 3 or above.
		
		# This is the new command line arcgument to set the arch
		# rpms. It appeared in rpm version 3.
		$opts="--target ".$this->arch;
	}

	$opts.=" $ENV{RPMBUILDOPT}" if exists $ENV{RPMBUILDOPT};
	my $pwd=`pwd`;
	chomp $pwd;
	my $command="cd $dir; $buildcmd --buildroot='$pwd/$dir' -bb $opts '".$this->name."-".$this->version."-".$this->release.".spec'";
	my $log=$this->runpipe(1, "$command 2>&1");
	if ($?) {
		die "Package build failed. Here's the log of the command ($command):\n", $log;
	}

	return $rpm;
}

=item version

Set/get version.

When retreiving the version, remove any dashes in it.

=cut

sub version {
	my $this=shift;

	# set
	$this->{version} = shift if @_;

	# get
	return unless defined wantarray; # optimization
	$_=$this->{version};
	tr/-/_/;
	return $_;
}

=item postinst

=item postrm

=item preinst

=item prerm

Set/get script fields.

When retrieving a value, we have to do some truely sick mangling. Since
debian/slackware scripts can be anything -- perl programs or binary files
-- and rpm is limited to only shell scripts, we need to encode the files
and add a scrap of shell script to make it unextract and run on the fly.

When setting a value, we do some mangling too. Rpm maintainer scripts
are typically shell scripts, but often lack the leading shebang line.
This can confuse dpkg, so add the shebang if it looks like there
is no shebang magic already in place.

Additionally, it's not uncommon for rpm maintainer scripts to contain
bashisms, which can be triggered when they are ran on systems where /bin/sh
is not bash. To work around this, the shebang line of the scripts is
changed to use bash.

Also, if the rpm is relocatable, the script could refer to
RPM_INSTALL_PREFIX, which is set by rpm at run time. Deal with this by
adding code to the script to set RPM_INSTALL_PREFIX.

=cut

# This helper function deals with all the scripts.
sub _script_helper {
	my $this=shift;
	my $script=shift;

	# set
	if (@_) {
		my $prefixcode="";
		if (defined $this->prefixes) {
			$prefixcode="RPM_INSTALL_PREFIX=".$this->prefixes."\n";
			$prefixcode.="export RPM_INSTALL_PREFIX\n";
		}

		my $value=shift;
		if (length $value and $value !~ m/^#!\s*\//) {
			$value="#!/bin/bash\n$prefixcode$value";
		}
		else {
			$value=~s@^#!\s*/bin/sh(\s)@#!/bin/bash$1@;
			$value=~s/\n/\n$prefixcode/s;
		}
		$this->{$script} = $value;
	}
	$this->{$script} = shift if @_;

	# get
	return unless defined wantarray; # optimization
	$_=$this->{$script};
	return '' unless defined $_;
	return $_ if m/^\s*$/;
	return $_ if m/^#!\s*\/bin\/sh/; # looks like a shell script already
	my $f = pack("u",$_);
	$f =~ s/%/%%/g; # Rpm expands %S, so escape such things.
	return "#!/bin/sh\n".
	       "set -e\n".
	       "mkdir /tmp/alien.\$\$\n".
	       qq{perl -pe '\$_=unpack("u",\$_)' << '__EOF__' > /tmp/alien.\$\$/script\n}.
	       $f."__EOF__\n".
	       "chmod 755 /tmp/alien.\$\$/script\n".
	       "/tmp/alien.\$\$/script \"\$@\"\n".
	       "rm -f /tmp/alien.\$\$/script\n".
	       "rmdir /tmp/alien.\$\$";
}
sub postinst {
	my $this=shift;
	$this->_script_helper('postinst', @_);
}
sub postrm {
	my $this=shift;
	$this->_script_helper('postrm', @_);
}
sub preinst {
	my $this=shift;
	$this->_script_helper('preinst', @_);
}
sub prerm {
	my $this=shift;
	$this->_script_helper('prerm', @_);
}

=item arch

Set/get arch field. When the arch field is set, some sanitizing is done
first to convert it to the debian format used internally. When it's
retreived it's converted back to rpm form from the internal form.

=cut

sub arch {
	my $this=shift;

	my $arch;
	if (@_) {
		$arch=shift;

		if ($arch eq 1) {
			$arch='i386';
		}
		elsif ($arch eq 2) {
			$arch='alpha';
		}
		elsif ($arch eq 3) {
			$arch='sparc';
		}
		elsif ($arch eq 6) {
			$arch='m68k';
		}
		elsif ($arch eq 'noarch') {
			$arch='all';
		}
		elsif ($arch eq 'ppc') {
			$arch='powerpc';
		}
		elsif ($arch eq 'x86_64') {
			$arch='amd64';
		}
		elsif ($arch eq 'em64t') {
			$arch='amd64';
		}
		elsif ($arch =~ m/i\d86/i || $arch =~ m/pentium/i) {
			# Treat 486, 586, etc, as 386.
			$arch='i386';
		}
		elsif ($arch eq 'armv4l') {
			# Treat armv4l as arm.
			$arch='arm';
		}
		elsif ($arch eq 'parisc') {
			$arch='hppa';
		}
		
		$this->{arch}=$arch;
	}

	$arch=$this->{arch};
	if ($arch eq 'amd64') {
		$arch='x86_64';
	}
	elsif ($arch eq 'powerpc') {
		# XXX is this the canonical name for powerpc on rpm
		# systems?
		$arch='ppc';
	}
	elsif ($arch eq 'hppa') {
		$arch='parisc';
	}
	elsif ($arch eq 'all') {
		$arch='noarch';
	}

	return $arch
}

=back

=head1 AUTHOR

Joey Hess <joey@kitenet.net>

=cut

1