This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to Pod::LaTeX 0.58
[perl5.git] / ext / Cwd / Cwd.xs
CommitLineData
0d2079fa
BS
1#include "EXTERN.h"
2#include "perl.h"
3#include "XSUB.h"
4
c70498c1
JH
5#ifdef I_UNISTD
6# include <unistd.h>
7#endif
8
03d70c89
JH
9/* The realpath() implementation from OpenBSD 2.9 (realpath.c 1.4)
10 * Renamed here to bsd_realpath() to avoid library conflicts.
11 * --jhi 2000-06-20 */
12
13/*
14 * Copyright (c) 1994
15 * The Regents of the University of California. All rights reserved.
16 *
17 * This code is derived from software contributed to Berkeley by
18 * Jan-Simon Pendry.
19 *
20 * Redistribution and use in source and binary forms, with or without
21 * modification, are permitted provided that the following conditions
22 * are met:
23 * 1. Redistributions of source code must retain the above copyright
24 * notice, this list of conditions and the following disclaimer.
25 * 2. Redistributions in binary form must reproduce the above copyright
26 * notice, this list of conditions and the following disclaimer in the
27 * documentation and/or other materials provided with the distribution.
28 * 3. All advertising materials mentioning features or use of this software
29 * must display the following acknowledgement:
30 * This product includes software developed by the University of
31 * California, Berkeley and its contributors.
32 * 4. Neither the name of the University nor the names of its contributors
33 * may be used to endorse or promote products derived from this software
34 * without specific prior written permission.
35 *
36 * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
37 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
38 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
39 * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
40 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
41 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
42 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
43 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
44 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
45 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
46 * SUCH DAMAGE.
47 */
48
49#if defined(LIBC_SCCS) && !defined(lint)
50static char *rcsid = "$OpenBSD: realpath.c,v 1.4 1998/05/18 09:55:19 deraadt Exp $";
51#endif /* LIBC_SCCS and not lint */
52
53/* OpenBSD system #includes removed since the Perl ones should do. --jhi */
54
55#ifndef MAXSYMLINKS
56#define MAXSYMLINKS 8
57#endif
58
59/*
60 * char *realpath(const char *path, char resolved_path[MAXPATHLEN]);
61 *
62 * Find the real name of path, by removing all ".", ".." and symlink
63 * components. Returns (resolved) on success, or (NULL) on failure,
64 * in which case the path which caused trouble is left in (resolved).
65 */
66static
67char *
68bsd_realpath(path, resolved)
69 const char *path;
70 char *resolved;
71{
e3d944f4 72#ifdef VMS
32af7c23
CL
73 dTHX;
74 return Perl_rmsexpand(aTHX_ (char*)path, resolved, NULL, 0);
e3d944f4 75#else
91f3b821 76 int rootd, serrno;
03d70c89
JH
77 char *p, *q, wbuf[MAXPATHLEN];
78 int symlinks = 0;
79
80 /* Save the starting point. */
e3d944f4 81#ifdef HAS_FCHDIR
bae06e14
JH
82 int fd;
83
03d70c89
JH
84 if ((fd = open(".", O_RDONLY)) < 0) {
85 (void)strcpy(resolved, ".");
86 return (NULL);
87 }
e3d944f4
JH
88#else
89 char wd[MAXPATHLEN];
90
91 if (getcwd(wd, MAXPATHLEN - 1) == NULL) {
92 (void)strcpy(resolved, ".");
93 return (NULL);
94 }
95#endif
03d70c89
JH
96
97 /*
98 * Find the dirname and basename from the path to be resolved.
99 * Change directory to the dirname component.
100 * lstat the basename part.
101 * if it is a symlink, read in the value and loop.
102 * if it is a directory, then change to that directory.
103 * get the current directory name and append the basename.
104 */
105 (void)strncpy(resolved, path, MAXPATHLEN - 1);
106 resolved[MAXPATHLEN - 1] = '\0';
107loop:
108 q = strrchr(resolved, '/');
109 if (q != NULL) {
110 p = q + 1;
111 if (q == resolved)
112 q = "/";
113 else {
114 do {
115 --q;
116 } while (q > resolved && *q == '/');
117 q[1] = '\0';
118 q = resolved;
119 }
120 if (chdir(q) < 0)
121 goto err1;
122 } else
123 p = resolved;
124
bae06e14 125#if defined(HAS_LSTAT) && defined(HAS_READLINK) && defined(HAS_SYMLINK)
91f3b821
GS
126 {
127 struct stat sb;
03d70c89
JH
128 /* Deal with the last component. */
129 if (lstat(p, &sb) == 0) {
130 if (S_ISLNK(sb.st_mode)) {
91f3b821 131 int n;
03d70c89
JH
132 if (++symlinks > MAXSYMLINKS) {
133 errno = ELOOP;
134 goto err1;
135 }
136 n = readlink(p, resolved, MAXPATHLEN-1);
137 if (n < 0)
138 goto err1;
139 resolved[n] = '\0';
140 goto loop;
141 }
142 if (S_ISDIR(sb.st_mode)) {
143 if (chdir(p) < 0)
144 goto err1;
145 p = "";
146 }
147 }
91f3b821 148 }
e3d944f4 149#endif
03d70c89
JH
150
151 /*
152 * Save the last component name and get the full pathname of
153 * the current directory.
154 */
155 (void)strcpy(wbuf, p);
156 if (getcwd(resolved, MAXPATHLEN) == 0)
157 goto err1;
158
159 /*
160 * Join the two strings together, ensuring that the right thing
161 * happens if the last component is empty, or the dirname is root.
162 */
163 if (resolved[0] == '/' && resolved[1] == '\0')
164 rootd = 1;
165 else
166 rootd = 0;
167
168 if (*wbuf) {
7f6e23a8 169 if (strlen(resolved) + strlen(wbuf) + (1 - rootd) + 1 > MAXPATHLEN) {
03d70c89
JH
170 errno = ENAMETOOLONG;
171 goto err1;
172 }
173 if (rootd == 0)
174 (void)strcat(resolved, "/");
175 (void)strcat(resolved, wbuf);
176 }
177
178 /* Go back to where we came from. */
e3d944f4 179#ifdef HAS_FCHDIR
03d70c89
JH
180 if (fchdir(fd) < 0) {
181 serrno = errno;
182 goto err2;
183 }
e3d944f4
JH
184#else
185 if (chdir(wd) < 0) {
186 serrno = errno;
187 goto err2;
188 }
189#endif
03d70c89
JH
190
191 /* It's okay if the close fails, what's an fd more or less? */
9cad6237 192#ifdef HAS_FCHDIR
03d70c89 193 (void)close(fd);
9cad6237 194#endif
03d70c89
JH
195 return (resolved);
196
197err1: serrno = errno;
29ab7413 198#ifdef HAS_FCHDIR
03d70c89 199 (void)fchdir(fd);
29ab7413
JH
200#else
201 (void)chdir(wd);
202#endif
89423764
GS
203
204err2:
205#ifdef HAS_FCHDIR
206 (void)close(fd);
207#endif
03d70c89
JH
208 errno = serrno;
209 return (NULL);
e3d944f4 210#endif
03d70c89
JH
211}
212
a9939470 213#ifndef getcwd_sv
1955c8df 214/* Taken from perl 5.8's util.c */
09122b95
RGS
215#define getcwd_sv(a) Perl_getcwd_sv(aTHX_ a)
216int Perl_getcwd_sv(pTHX_ register SV *sv)
a9939470
NC
217{
218#ifndef PERL_MICRO
219
220#ifndef INCOMPLETE_TAINTS
221 SvTAINTED_on(sv);
222#endif
223
224#ifdef HAS_GETCWD
225 {
226 char buf[MAXPATHLEN];
227
228 /* Some getcwd()s automatically allocate a buffer of the given
229 * size from the heap if they are given a NULL buffer pointer.
230 * The problem is that this behaviour is not portable. */
231 if (getcwd(buf, sizeof(buf) - 1)) {
232 STRLEN len = strlen(buf);
233 sv_setpvn(sv, buf, len);
234 return TRUE;
235 }
236 else {
237 sv_setsv(sv, &PL_sv_undef);
238 return FALSE;
239 }
240 }
241
242#else
243
244 Stat_t statbuf;
245 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
246 int namelen, pathlen=0;
247 DIR *dir;
248 Direntry_t *dp;
249
250 (void)SvUPGRADE(sv, SVt_PV);
251
252 if (PerlLIO_lstat(".", &statbuf) < 0) {
253 SV_CWD_RETURN_UNDEF;
254 }
255
256 orig_cdev = statbuf.st_dev;
257 orig_cino = statbuf.st_ino;
258 cdev = orig_cdev;
259 cino = orig_cino;
260
261 for (;;) {
262 odev = cdev;
263 oino = cino;
264
265 if (PerlDir_chdir("..") < 0) {
266 SV_CWD_RETURN_UNDEF;
267 }
268 if (PerlLIO_stat(".", &statbuf) < 0) {
269 SV_CWD_RETURN_UNDEF;
270 }
271
272 cdev = statbuf.st_dev;
273 cino = statbuf.st_ino;
274
275 if (odev == cdev && oino == cino) {
276 break;
277 }
278 if (!(dir = PerlDir_open("."))) {
279 SV_CWD_RETURN_UNDEF;
280 }
281
282 while ((dp = PerlDir_read(dir)) != NULL) {
283#ifdef DIRNAMLEN
284 namelen = dp->d_namlen;
285#else
286 namelen = strlen(dp->d_name);
287#endif
288 /* skip . and .. */
289 if (SV_CWD_ISDOT(dp)) {
290 continue;
291 }
292
293 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
294 SV_CWD_RETURN_UNDEF;
295 }
296
297 tdev = statbuf.st_dev;
298 tino = statbuf.st_ino;
299 if (tino == oino && tdev == odev) {
300 break;
301 }
302 }
303
304 if (!dp) {
305 SV_CWD_RETURN_UNDEF;
306 }
307
308 if (pathlen + namelen + 1 >= MAXPATHLEN) {
309 SV_CWD_RETURN_UNDEF;
310 }
311
312 SvGROW(sv, pathlen + namelen + 1);
313
314 if (pathlen) {
315 /* shift down */
316 Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
317 }
318
319 /* prepend current directory to the front */
320 *SvPVX(sv) = '/';
321 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
322 pathlen += (namelen + 1);
323
324#ifdef VOID_CLOSEDIR
325 PerlDir_close(dir);
326#else
327 if (PerlDir_close(dir) < 0) {
328 SV_CWD_RETURN_UNDEF;
329 }
330#endif
331 }
332
333 if (pathlen) {
334 SvCUR_set(sv, pathlen);
335 *SvEND(sv) = '\0';
336 SvPOK_only(sv);
337
338 if (PerlDir_chdir(SvPVX(sv)) < 0) {
339 SV_CWD_RETURN_UNDEF;
340 }
341 }
342 if (PerlLIO_stat(".", &statbuf) < 0) {
343 SV_CWD_RETURN_UNDEF;
344 }
345
346 cdev = statbuf.st_dev;
347 cino = statbuf.st_ino;
348
349 if (cdev != orig_cdev || cino != orig_cino) {
350 Perl_croak(aTHX_ "Unstable directory path, "
351 "current directory changed unexpectedly");
352 }
353
354 return TRUE;
355#endif
356
357#else
358 return FALSE;
359#endif
360}
361
362#endif
363
364
f22d8e4b 365MODULE = Cwd PACKAGE = Cwd
0d2079fa 366
f22d8e4b 367PROTOTYPES: ENABLE
0d2079fa 368
f22d8e4b
DM
369void
370fastcwd()
7ddb28a3 371PROTOTYPE: DISABLE
f22d8e4b
DM
372PPCODE:
373{
374 dXSTARG;
89423764 375 getcwd_sv(TARG);
f22d8e4b 376 XSprePUSH; PUSHTARG;
248785eb
RGS
377#ifndef INCOMPLETE_TAINTS
378 SvTAINTED_on(TARG);
379#endif
0d2079fa
BS
380}
381
f22d8e4b 382void
03d70c89
JH
383abs_path(pathsv=Nullsv)
384 SV *pathsv
f22d8e4b 385PPCODE:
2ae52c40 386{
f22d8e4b
DM
387 dXSTARG;
388 char *path;
00536bfc 389 char buf[MAXPATHLEN];
03d70c89 390
ea715489 391 path = pathsv ? SvPV_nolen(pathsv) : ".";
03d70c89 392
00536bfc
JH
393 if (bsd_realpath(path, buf)) {
394 sv_setpvn(TARG, buf, strlen(buf));
395 SvPOK_only(TARG);
ea715489 396 SvTAINTED_on(TARG);
2ae52c40 397 }
03d70c89 398 else
ea715489 399 sv_setsv(TARG, &PL_sv_undef);
2ae52c40 400
f22d8e4b 401 XSprePUSH; PUSHTARG;
ea715489
JH
402#ifndef INCOMPLETE_TAINTS
403 SvTAINTED_on(TARG);
404#endif
2ae52c40 405}
09122b95
RGS
406
407#ifdef WIN32
408
409void
410getdcwd(...)
411PPCODE:
412{
413 dXSTARG;
414 int drive;
415 char *dir;
416
417 /* Drive 0 is the current drive, 1 is A:, 2 is B:, 3 is C: and so on. */
418 if ( items == 0 ||
419 (items == 1 && (!SvOK(ST(0)) || (SvPOK(ST(0)) && !SvCUR(ST(0))))))
420 drive = 0;
421 else if (items == 1 && SvPOK(ST(0)) && SvCUR(ST(0)) &&
422 isALPHA(SvPVX(ST(0))[0]))
423 drive = toUPPER(SvPVX(ST(0))[0]) - 'A' + 1;
424 else
425 croak("Usage: getdcwd(DRIVE)");
426
275e8705
RGS
427 New(0,dir,MAXPATHLEN,char);
428 if (_getdcwd(drive, dir, MAXPATHLEN)) {
09122b95 429 sv_setpvn(TARG, dir, strlen(dir));
275e8705 430 Safefree(dir);
09122b95
RGS
431 SvPOK_only(TARG);
432 }
433 else
434 sv_setsv(TARG, &PL_sv_undef);
435
436 XSprePUSH; PUSHTARG;
437#ifndef INCOMPLETE_TAINTS
438 SvTAINTED_on(TARG);
439#endif
440}
441
442#endif