337ff285 |
1 | #!/usr/bin/env perl |
2 | |
3 | # lns -- create a symbolic link. Alternative to "ln -s". |
4 | # This program works more like "cp", in that the source path name is not |
5 | # taken literally. |
6 | # ln -s filename /tmp |
7 | # creates a link |
8 | # /tmp/filename -> filename |
9 | # whereas we would prefer |
10 | # /tmp/filename -> /home/me/filename |
11 | # or wherever the file *really* was. |
12 | # |
13 | # Usage: lns [-afF] file1 file2 |
14 | # or lns [-af] file1 [file2...] dir |
15 | # |
16 | # Where: |
17 | # -a means absolute - "symlink /usr/bin/argh /usr/local/bin/argh" produces |
18 | # a relative link "/usr/bin/argh -> ../local/bin/argh", but using the |
19 | # -a option will give a real absolute link. |
20 | # -f means forceful - overwrite the target filename if it exists *and* is |
21 | # a link. You can't accidentally overwrite real files like this. |
22 | # -q means quiet - don't complain if we fail to do the job. |
23 | # -v means verbose - say what we're doing. |
24 | # -F means FILE - forces interpretation to be the "file1 file2" syntax, |
25 | # even if file2 is a link to a directory. This option implies -f. |
26 | |
27 | use Cwd; |
53ddbe1a |
28 | use POSIX; # for opendir and friends |
337ff285 |
29 | |
30 | $usage = |
31 | "usage: lns [flags] srcfile destfile\n". |
32 | " or: lns [flags] srcfile [srcfile...] destdir\n". |
33 | "where: -a create symlinks with absolute path names\n". |
34 | " -f overwrite existing symlink at target location\n". |
35 | " -F like -f, but works even if target is link to dir\n". |
53ddbe1a |
36 | " -r recursively construct a directory tree which\n". |
37 | " mirrors the source, with symlinks to all files\n". |
337ff285 |
38 | " -v verbosely log activity (repeat for more verbosity)\n". |
39 | " -q suppress error messages on failure\n". |
40 | " also: lns --version report version number\n" . |
41 | " lns --help display this help text\n" . |
42 | " lns --licence display (MIT) licence text\n"; |
43 | |
44 | $licence = |
45 | "lns is copyright 1999,2004 Simon Tatham.\n" . |
46 | "\n" . |
47 | "Permission is hereby granted, free of charge, to any person\n" . |
48 | "obtaining a copy of this software and associated documentation files\n" . |
49 | "(the \"Software\"), to deal in the Software without restriction,\n" . |
50 | "including without limitation the rights to use, copy, modify, merge,\n" . |
51 | "publish, distribute, sublicense, and/or sell copies of the Software,\n" . |
52 | "and to permit persons to whom the Software is furnished to do so,\n" . |
53 | "subject to the following conditions:\n" . |
54 | "\n" . |
55 | "The above copyright notice and this permission notice shall be\n" . |
56 | "included in all copies or substantial portions of the Software.\n" . |
57 | "\n" . |
58 | "THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND,\n" . |
59 | "EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF\n" . |
60 | "MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND\n" . |
61 | "NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS\n" . |
62 | "BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN\n" . |
63 | "ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN\n" . |
64 | "CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE\n" . |
65 | "SOFTWARE.\n"; |
66 | |
53ddbe1a |
67 | $abs=$force=$quiet=$verbose=$recurse=$FILE=0; |
337ff285 |
68 | while ($_=shift @ARGV) { |
69 | last if /^--$/; |
70 | unshift (@ARGV, $_), last unless /^-(.*)/; |
71 | if ($1 eq "-help") { |
72 | print STDERR $usage; |
73 | exit 0; |
74 | } elsif ($1 eq "-version") { |
75 | if ('$Revision$' =~ /Revision:\s+(\d+)/) { |
76 | print "lns revision $1\n"; |
77 | } else { |
78 | print "lns: unknown revision\n"; |
79 | } |
80 | exit 0; |
81 | } elsif ($1 eq "-licence" or $1 eq "-license") { |
82 | print $licence; |
83 | exit 0; |
84 | } else { |
85 | foreach $opt (split //, $1) { |
86 | if ($opt eq "a") { $abs=1; } |
87 | elsif ($opt eq "f") { $force=1; } |
88 | elsif ($opt eq "q") { $quiet=1; } |
53ddbe1a |
89 | elsif ($opt eq "r") { $recurse=1; } |
337ff285 |
90 | elsif ($opt eq "v") { $verbose++; } |
91 | elsif ($opt eq "F") { $force=$FILE=1; } |
5a303401 |
92 | else { die "lns: unrecognised option '-$1'\n"; } |
337ff285 |
93 | } |
94 | } |
95 | } |
96 | |
97 | die $usage if $#ARGV < 1; |
98 | |
5a303401 |
99 | die "lns: multiple source files specified with -F option\n" |
337ff285 |
100 | if $#ARGV > 1 && $FILE; |
5a303401 |
101 | die "lns: -q (quiet) and -v (verbose) options both specified\n" |
337ff285 |
102 | if $quiet && $verbose; |
103 | |
104 | $target = pop @ARGV; |
5a303401 |
105 | die "lns: multiple source files specified, $target not a directory\n" |
337ff285 |
106 | if $#ARGV > 0 && !-d $target; |
107 | |
108 | $multiple = (-d $target && !$FILE); |
337ff285 |
109 | |
110 | $target =~ s/// if $target =~ /\/$/; # strip trailing slash if present |
111 | |
112 | if ($multiple) { |
113 | foreach $source (@ARGV) { |
9d63af99 |
114 | # We must path-normalise $source _before_ looking for the final |
115 | # filename component, to deal with the case of `lns . subdir' |
116 | # in which we want the link to be called subdir/<dirname> rather |
117 | # than subdir/. . |
118 | $source = &normalise($source); |
337ff285 |
119 | $source =~ /^(.*\/)?([^\/]*)$/; # find final file name component |
120 | &makelink($source, "$target/$2"); # actually make a link |
121 | } |
122 | } else { |
123 | $source = $ARGV[0]; # only one source file |
124 | &makelink($source, $target); # make the link |
125 | } |
126 | |
127 | sub makelink { |
128 | local ($source, $target) = @_; |
124cdfbe |
129 | # Calculate the absolute path names of both source and target. |
130 | $source = &normalise($source); |
131 | $target = &normalise($target); |
132 | |
133 | # If we're in Relative mode (the default), calculate the relative path |
134 | # name we will reference the source by. |
135 | $sourcename = $abs ? $source : &relname($source, $target); |
136 | |
53ddbe1a |
137 | my $donothing = 0; |
138 | my $recursing = $recurse && -d $source; |
139 | my $ok; |
337ff285 |
140 | # If the target exists... |
141 | if (-e $target || readlink $target) { |
53ddbe1a |
142 | if ($recursing && -d $target) { |
143 | # If it's a directory and we're in recursive mode, just do nothing |
144 | # and work around it. |
145 | $donothing = 1; |
146 | } elsif ($force && readlink $target) { |
147 | # If it's a symlink and we're in Force mode, remove it and carry on. |
5a303401 |
148 | unlink $target || die "lns: unable to remove link $target\n"; |
337ff285 |
149 | # Report that if in Verbose mode. |
5a303401 |
150 | warn "lns: removing existing target link $target\n" if $verbose; |
337ff285 |
151 | } else { |
152 | # Otherwise, fail. Report that fact if not in Quiet mode. |
5a303401 |
153 | warn "lns: failed to link $source to $target: target exists\n" |
337ff285 |
154 | if !$quiet; |
155 | return; |
156 | } |
157 | } |
158 | |
53ddbe1a |
159 | if ($recursing) { |
160 | # Make the directory. |
161 | if ($donothing) { |
162 | warn "lns: directory $target already exists, no need to create it\n" |
163 | if $verbose; |
164 | $ok = 1; |
165 | } else { |
166 | warn "lns: making directory $target\n" |
167 | if $verbose; |
168 | if (mkdir $target) { |
169 | $ok = 1; |
170 | } else { |
171 | warn "lns: unable to make directory '$target': $!\n"; |
172 | } |
173 | } |
174 | # Now recurse into it. |
175 | if ($ok) { |
176 | my $dh = POSIX::opendir($source); |
177 | my @files = POSIX::readdir($dh); |
178 | my $f; |
179 | POSIX::closedir($dh); |
180 | foreach $f (@files) { |
181 | next if $f eq "." or $f eq ".."; |
182 | &makelink("$source/$f", "$target/$f"); |
183 | } |
184 | } |
185 | } else { |
186 | # Make the link. |
187 | warn "lns: linking $source: $target -> $sourcename\n" if $verbose; |
188 | symlink($sourcename, $target) || die "lns: unable to make link to $target\n"; |
189 | } |
337ff285 |
190 | } |
191 | |
73bdc6aa |
192 | sub normalise { |
193 | # Normalise a path into an absolute one containing no . or .. |
194 | # segments. |
195 | local ($_) = @_; |
337ff285 |
196 | |
124cdfbe |
197 | warn "lns: path normalisation required on $_\n" if $verbose > 2; |
198 | |
73bdc6aa |
199 | # Make relative paths absolute. |
200 | $_ = getcwd() . "/" . $_ if !/^\//; |
337ff285 |
201 | |
73bdc6aa |
202 | # Remove "." segments. |
203 | 1 while s/^(.*)\/\.(\/.*)?$/$1$2/; |
337ff285 |
204 | |
73bdc6aa |
205 | # Remove redundant slashes. |
626fc36e |
206 | s/\/+/\//g; |
337ff285 |
207 | |
73bdc6aa |
208 | # Remove a trailing slash if present. |
209 | s/\/$//; |
337ff285 |
210 | |
73bdc6aa |
211 | # Remove ".." segments. This is the hard bit, because a |
212 | # directory segment that's a _symlink_ doesn't do the obvious |
213 | # thing if followed by "..". But we can't just call realpath, |
214 | # because we do want to preserve symlinks where they _don't_ |
215 | # interfere with this sort of work. So the algorithm is: |
337ff285 |
216 | # |
217 | # - Repeatedly search for the rightmost `directory/..' |
218 | # fragment. |
219 | # - When we find it, one of two cases apply. |
220 | # * If the directory before the .. is not a symlink, we can |
221 | # remove both it and the .. from the string. |
222 | # * If it _is_ a symlink, we substitute it for its link |
223 | # text, and loop round again. |
73bdc6aa |
224 | while (/^(.*)\/((\.|\.\.[^\/]+|\.?[^\/\.][^\/]*)\/\.\.)(\/.*)?$/) |
337ff285 |
225 | { |
226 | my ($pre, $dir, $frag, $post) = ($1,$2,$3,$4); |
124cdfbe |
227 | my $log = " transforming $_ -> "; |
337ff285 |
228 | if (-l "$pre/$frag") { |
229 | my $linktext = readlink "$pre/$frag"; |
230 | if ($linktext =~ /^\//) { # absolute link |
73bdc6aa |
231 | $_ = $linktext; |
337ff285 |
232 | } else { # relative link |
73bdc6aa |
233 | $_ = "$pre/$linktext"; |
337ff285 |
234 | } |
73bdc6aa |
235 | $_ .= "/.." . $post; |
337ff285 |
236 | } else { |
73bdc6aa |
237 | $_ = $pre . $post; |
337ff285 |
238 | } |
73bdc6aa |
239 | $_ = "/" if $_ eq ""; # special case |
626fc36e |
240 | s/\/+/\//g; # remove redundant slashes again in case link text had any |
124cdfbe |
241 | $log .= "$_"; |
242 | warn "lns: $log\n" if $verbose > 2; |
337ff285 |
243 | } |
244 | |
73bdc6aa |
245 | # The only place where a ".." fragment might still remain is at |
246 | # the very start of the string, and "/.." is defined to be |
247 | # equivalent to "/". |
124cdfbe |
248 | 1 while s/^\/\.\.(\/(.*))?$/\/$2/; |
249 | |
250 | warn "lns: path normalisation returned $_\n" if $verbose > 2; |
73bdc6aa |
251 | |
252 | return $_; |
253 | } |
254 | |
255 | sub relname { |
256 | local ($source, $target) = @_; |
257 | local $prefix; |
258 | |
259 | # Strip the last word off the target (the actual file name) to |
260 | # obtain the target _directory_. |
261 | $target =~ s/\/[^\/]*$//; |
262 | |
263 | # Our starting prefix is empty. We will add one "../" at a time |
264 | # until we find a match. |
265 | |
266 | while (1) { |
267 | |
124cdfbe |
268 | warn "lns: trying prefix '$prefix': looking for $target as prefix of $source\n" if $verbose > 1; |
269 | |
a6aa7104 |
270 | # If $target is _precisely_ $source, we are done. |
271 | if ($target eq $source) { |
272 | return "." if $prefix eq ""; |
273 | $prefix =~ s/\/$//; |
274 | return $prefix; |
275 | } |
276 | |
73bdc6aa |
277 | # If $target is a prefix of $source, we are done. (No matter what |
278 | # symlinks may exist on the shared common pathname, if we are |
279 | # linking `a/b/c/foo' to `foo' then a simple relative link will |
280 | # work.) |
281 | if (substr($source, 0, 1 + length $target) eq "$target/") { |
124cdfbe |
282 | warn "lns: found it\n" if $verbose > 1; |
283 | return $prefix . substr($source, 1 + length $target); # skip the slash |
284 | } elsif ($target eq "/") { |
285 | warn "lns: found it\n" if $verbose > 1; |
286 | return $prefix . substr($source, 1); # special case |
73bdc6aa |
287 | } |
288 | |
289 | # Otherwise, descend to "..". |
290 | $target = &normalise($target . "/.."); |
291 | |
337ff285 |
292 | # Now we have replaced $target with a pathname equivalent to |
293 | # `$target/..'. So add a "../" to $prefix, and try matching |
294 | # again. |
295 | $prefix .= "../"; |
296 | } |
297 | } |