tjh.dev
1#! @perl@ -w
2
3use strict;
4use Cwd 'abs_path';
5use IO::Handle;
6use File::Path;
7use File::Basename;
8use File::Compare;
9use JSON::PP;
10
11STDOUT->autoflush(1);
12
13$SIG{__WARN__} = sub { warn "warning: ", @_ };
14$SIG{__DIE__} = sub { die "error: ", @_ };
15
16my $out = $ENV{"out"};
17my $extraPrefix = $ENV{"extraPrefix"};
18
19my @pathsToLink = split ' ', $ENV{"pathsToLink"};
20
21sub isInPathsToLink {
22 my $path = shift;
23 $path = "/" if $path eq "";
24 foreach my $elem (@pathsToLink) {
25 return 1 if
26 $elem eq "/" ||
27 (substr($path, 0, length($elem)) eq $elem
28 && (($path eq $elem) || (substr($path, length($elem), 1) eq "/")));
29 }
30 return 0;
31}
32
33# Returns whether a path in one of the linked packages may contain
34# files in one of the elements of pathsToLink.
35sub hasPathsToLink {
36 my $path = shift;
37 foreach my $elem (@pathsToLink) {
38 return 1 if
39 $path eq "" ||
40 (substr($elem, 0, length($path)) eq $path
41 && (($path eq $elem) || (substr($elem, length($path), 1) eq "/")));
42 }
43 return 0;
44}
45
46# Similar to `lib.isStorePath`
47sub isStorePath {
48 my $path = shift;
49 my $storePath = "@storeDir@";
50
51 return substr($path, 0, 1) eq "/" && dirname($path) eq $storePath;
52}
53
54# For each activated package, determine what symlinks to create.
55
56my %symlinks;
57
58# Add all pathsToLink and all parent directories.
59#
60# For "/a/b/c" that will include
61# [ "", "/a", "/a/b", "/a/b/c" ]
62#
63# That ensures the whole directory tree needed by pathsToLink is
64# created as directories and not symlinks.
65$symlinks{""} = ["", 0];
66for my $p (@pathsToLink) {
67 my @parts = split '/', $p;
68
69 my $cur = "";
70 for my $x (@parts) {
71 $cur = $cur . "/$x";
72 $cur = "" if $cur eq "/";
73 $symlinks{$cur} = ["", 0];
74 }
75}
76
77sub findFiles;
78
79sub findFilesInDir {
80 my ($relName, $target, $ignoreCollisions, $checkCollisionContents, $priority) = @_;
81
82 opendir DIR, "$target" or die "cannot open `$target': $!";
83 my @names = readdir DIR or die;
84 closedir DIR;
85
86 foreach my $name (@names) {
87 next if $name eq "." || $name eq "..";
88 findFiles("$relName/$name", "$target/$name", $name, $ignoreCollisions, $checkCollisionContents, $priority);
89 }
90}
91
92sub checkCollision {
93 my ($path1, $path2) = @_;
94
95 if (! -e $path1 || ! -e $path2) {
96 return 0;
97 }
98
99 my $stat1 = (stat($path1))[2];
100 my $stat2 = (stat($path2))[2];
101
102 if ($stat1 != $stat2) {
103 warn "different permissions in `$path1' and `$path2': "
104 . sprintf("%04o", $stat1 & 07777) . " <-> "
105 . sprintf("%04o", $stat2 & 07777);
106 return 0;
107 }
108
109 return compare($path1, $path2) == 0;
110}
111
112sub prependDangling {
113 my $path = shift;
114 return (-l $path && ! -e $path ? "dangling symlink " : "") . "`$path'";
115}
116
117sub findFiles {
118 my ($relName, $target, $baseName, $ignoreCollisions, $checkCollisionContents, $priority) = @_;
119
120 # The store path must not be a file
121 if (-f $target && isStorePath $target) {
122 die "The store path $target is a file and can't be merged into an environment using pkgs.buildEnv!";
123 }
124
125 # Urgh, hacky...
126 return if
127 $relName eq "/propagated-build-inputs" ||
128 $relName eq "/nix-support" ||
129 $relName =~ /info\/dir/ ||
130 ( $relName =~ /^\/share\/mime\// && !( $relName =~ /^\/share\/mime\/packages/ ) ) ||
131 $baseName eq "perllocal.pod" ||
132 $baseName eq "log" ||
133 ! (hasPathsToLink($relName) || isInPathsToLink($relName));
134
135 my ($oldTarget, $oldPriority) = @{$symlinks{$relName} // [undef, undef]};
136
137 # If target doesn't exist, create it. If it already exists as a
138 # symlink to a file (not a directory) in a lower-priority package,
139 # overwrite it.
140 if (!defined $oldTarget || ($priority < $oldPriority && ($oldTarget ne "" && ! -d $oldTarget))) {
141 # If target is a dangling symlink, emit a warning.
142 if (-l $target && ! -e $target) {
143 my $link = readlink $target;
144 warn "creating dangling symlink `$out$extraPrefix/$relName' -> `$target' -> `$link'\n";
145 }
146 $symlinks{$relName} = [$target, $priority];
147 return;
148 }
149
150 # If target already exists and both targets resolves to the same path, skip
151 if (
152 defined $oldTarget && $oldTarget ne "" &&
153 defined abs_path($target) && defined abs_path($oldTarget) &&
154 abs_path($target) eq abs_path($oldTarget)
155 ) {
156 # Prefer the target that is not a symlink, if any
157 if (-l $oldTarget && ! -l $target) {
158 $symlinks{$relName} = [$target, $priority];
159 }
160 return;
161 }
162
163 # If target already exists as a symlink to a file (not a
164 # directory) in a higher-priority package, skip.
165 if (defined $oldTarget && $priority > $oldPriority && $oldTarget ne "" && ! -d $oldTarget) {
166 return;
167 }
168
169 # If target is supposed to be a directory but it isn't, die with an error message
170 # instead of attempting to recurse into it, only to fail then.
171 # This happens e.g. when pathsToLink contains a non-directory path.
172 if ($oldTarget eq "" && ! -d $target) {
173 die "not a directory: `$target'\n";
174 }
175
176 unless (-d $target && ($oldTarget eq "" || -d $oldTarget)) {
177 # Prepend "dangling symlink" to paths if applicable.
178 my $targetRef = prependDangling($target);
179 my $oldTargetRef = prependDangling($oldTarget);
180
181 if ($ignoreCollisions) {
182 warn "collision between $targetRef and $oldTargetRef\n" if $ignoreCollisions == 1;
183 return;
184 } elsif ($checkCollisionContents && checkCollision($oldTarget, $target)) {
185 return;
186 } else {
187 die "collision between $targetRef and $oldTargetRef\n";
188 }
189 }
190
191 findFilesInDir($relName, $oldTarget, $ignoreCollisions, $checkCollisionContents, $oldPriority) unless $oldTarget eq "";
192 findFilesInDir($relName, $target, $ignoreCollisions, $checkCollisionContents, $priority);
193
194 $symlinks{$relName} = ["", $priority]; # denotes directory
195}
196
197
198my %done;
199my %postponed;
200
201sub addPkg {
202 my ($pkgDir, $ignoreCollisions, $checkCollisionContents, $priority) = @_;
203
204 return if (defined $done{$pkgDir});
205 $done{$pkgDir} = 1;
206
207 findFiles("", $pkgDir, "", $ignoreCollisions, $checkCollisionContents, $priority);
208
209 my $propagatedFN = "$pkgDir/nix-support/propagated-user-env-packages";
210 if (-e $propagatedFN) {
211 open PROP, "<$propagatedFN" or die;
212 my $propagated = <PROP>;
213 close PROP;
214 my @propagated = split ' ', $propagated;
215 foreach my $p (@propagated) {
216 $postponed{$p} = 1 unless defined $done{$p};
217 }
218 }
219}
220
221# Read packages list.
222my $pkgs;
223
224if (exists $ENV{"pkgsPath"}) {
225 open FILE, $ENV{"pkgsPath"};
226 $pkgs = <FILE>;
227 close FILE;
228} else {
229 $pkgs = $ENV{"pkgs"}
230}
231
232# Symlink to the packages that have been installed explicitly by the
233# user.
234for my $pkg (@{decode_json $pkgs}) {
235 for my $path (@{$pkg->{paths}}) {
236 addPkg($path,
237 $ENV{"ignoreCollisions"} eq "1",
238 $ENV{"checkCollisionContents"} eq "1",
239 $pkg->{priority})
240 if -e $path;
241 }
242}
243
244
245# Symlink to the packages that have been "propagated" by packages
246# installed by the user (i.e., package X declares that it wants Y
247# installed as well). We do these later because they have a lower
248# priority in case of collisions.
249my $priorityCounter = 1000; # don't care about collisions
250while (scalar(keys %postponed) > 0) {
251 my @pkgDirs = keys %postponed;
252 %postponed = ();
253 foreach my $pkgDir (sort @pkgDirs) {
254 addPkg($pkgDir, 2, $ENV{"checkCollisionContents"} eq "1", $priorityCounter++);
255 }
256}
257
258
259# Create the symlinks.
260my $nrLinks = 0;
261foreach my $relName (sort keys %symlinks) {
262 my ($target, $priority) = @{$symlinks{$relName}};
263 my $abs = "$out" . "$extraPrefix" . "/$relName";
264 next unless isInPathsToLink $relName;
265 if ($target eq "") {
266 #print "creating directory $relName\n";
267 mkpath $abs or die "cannot create directory `$abs': $!";
268 } else {
269 #print "creating symlink $relName to $target\n";
270 symlink $target, $abs ||
271 die "error creating link `$abs': $!";
272 $nrLinks++;
273 }
274}
275
276
277print STDERR "created $nrLinks symlinks in user environment\n";
278
279
280my $manifest = $ENV{"manifest"};
281if ($manifest) {
282 symlink($manifest, "$out/manifest") or die "cannot create manifest";
283}