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
|
#!/usr/bin/perl
#
# Misc. functions used by alien.
package Alien;
use strict;
# Print out a status line.
sub Status { my $message=shift;
print "-- $message\n";
}
# Print out an error message and exit the program.
sub Error { my $message=shift;
print STDERR "alien: $message\n";
exit 1;
}
# print a warning message.
sub Warning { my $message=shift;
print STDERR "* $message\n";
}
# Run a system command, and print an error message if it fails.
# The errormessage parameter is optional.
sub SafeSystem { my ($command,$errormessage)=@_;
my $ret=system $command;
if (int($ret/256) > 0) {
$errormessage="Error running: $command" if !$errormessage;
Error($errormessage);
}
}
# Make the passed directory. Exits with error if the directory already
# exists.
sub SafeMkdir { my ($dir)=@_;
if (-e $dir) {
Error("Directory $dir already exists.\nRemove it and re-run alien.");
}
mkdir $dir,0755 || Error("Unable to make directory, \"$dir\": $!");
}
# Pass the filename of a package.
# Returns "rpm" or "tgz" or "deb" or "slp", depending on what it thinks the
# file type is, based on the filename.
# Perhaps this should call file(1), instead? (that won't work for .slp's though)
#
# Note that the file type this returns corresponds to directories in
# $libdir.
sub FileType { my $file=shift;
if ($file=~m/.*\.rpm/ ne undef) {
return 'rpm';
}
elsif ($file=~m/.*\.(tgz|tar\.gz)/ ne undef) {
return 'tgz';
}
elsif ($file=~m/.*\.deb/ ne undef) {
return 'deb';
}
elsif ($file=~m/.*\.slp/ ne undef) {
return 'slp';
}
else {
Error("Format of filename bad: $file");
}
}
# Pass this the name and version and revision of a package, it will return the
# filename of a patch file for the package or undef if there is none.
sub GetPatch { my ($name,$version,$revision)=@_;
my @patches=();
my $dir;
foreach $dir (@main::patchdirs) {
push @patches,glob("$dir/$name\_$version-$revision*.diff.gz");
}
if ($#patches < 0) {
# try not matching the revision, see if that helps.
foreach $dir (@main::patchdirs) {
push @patches,glob("$dir/$name\_$version*.diff.gz");
}
if ($#patches < 0) {
# fallback to anything that matches the name.
foreach $dir (@main::patchdirs) {
push @patches,glob("$dir/$name\_*.diff.gz");
}
}
}
# If we ended up with multiple matches, return the first.
return $patches[0];
}
# Apply the given patch file to the given subdirectory.
sub Patch { my ($patchfile,$subdir)=@_;
Status("Patching in $patchfile");
chdir $subdir;
# cd .. here in case the patchfile's name was a relative path.
# The -f passed to zcat makes it pass uncompressed files through
# without error.
SafeSystem("(cd ..;zcat -f $patchfile) | patch -p1","Patch error.\n");
# look for .rej files
if (`find . -name "*.rej"`) {
Error("Patch failed: giving up.");
}
SafeSystem('find . -name \'*.orig\' -exec rm {} \\;',"Error removing .orig files");
chdir "..";
}
# Returns the 822-date.
sub GetDate {
my $date=`822-date`;
chomp $date;
if (!$date) {
Error("822-date did not return a valid result. You probably need to install the dpkg-dev debian package.\n");
}
return $date;
}
# Returns a email address for the current user.
sub GetEmail {
if (!$ENV{EMAIL}) {
my $login = getlogin || (getpwuid($<))[0] || $ENV{USER};
open (MAILNAME,"</etc/mailname");
my $mailname=<MAILNAME>;
chomp $mailname;
close MAILNAME;
if (!$mailname) {
$mailname=`hostname -f`;
chomp $mailname;
}
return "$login\@$mailname";
}
else {
return $ENV{EMAIL};
}
}
# Returns the user name of the user who is running this.
sub GetUserName {
my $username;
my $username_in_passwd=undef;
my $login = getlogin || (getpwuid($<))[0] || $ENV{USER};
open (PASSWD,"</etc/passwd");
while (<PASSWD>) {
my (@fields)=split(/:/,$_);
if ($fields[0] eq $login) {
$username=$fields[4];
$username_in_passwd=1; # don't try NIS, no matter what.
close PASSWD;
}
}
close PASSWD;
if (!$username_in_passwd && !$username && -x "/usr/bin/ypmatch") {
# Give NIS a try.
open (YPMATCH,"ypmatch $login passwd.byname |");
my (@fields)=split(/:/,<YPMATCH>);
$username=$fields[4];
close YPMATCH;
}
# Remove GECOS(?) fields from username.
$username=~s/,.*//g;
# The ultimate fallback.
if (!$username) {
$username=$login;
}
return $username;
}
# Fill out a template, and save it to the passed location.
# The hash that is passed to this function lists the tags that can be onthe
# template, and the values to fill in for those tags.
sub FillOutTemplate { my ($fn,$destfn,%fields)=@_;
open (IN,"<$fn") || Error("$fn: $!");
open (OUT,">$destfn") || Error("$destfn: $!");
while (<IN>) {
s/#(.*?)#/$fields{$1}/g;
print OUT $_;
}
close OUT;
close IN;
}
1
|
