This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add section on circular refs to perlref
[perl5.git] / dist / Cwd / Cwd.xs
CommitLineData
c30da3b5
NC
1#define PERL_NO_GET_CONTEXT
2
0d2079fa
BS
3#include "EXTERN.h"
4#include "perl.h"
5#include "XSUB.h"
9bc94e3d
SM
6#define NEED_my_strlcpy
7#define NEED_my_strlcat
8#include "ppport.h"
0d2079fa 9
c70498c1
JH
10#ifdef I_UNISTD
11# include <unistd.h>
12#endif
13
bf7c0a3d 14/* The realpath() implementation from OpenBSD 3.9 to 4.2 (realpath.c 1.13)
03d70c89 15 * Renamed here to bsd_realpath() to avoid library conflicts.
99f36a73
RGS
16 */
17
18/* See
19 * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2004-11/msg00979.html
20 * for the details of why the BSD license is compatible with the
21 * AL/GPL standard perl license.
22 */
03d70c89
JH
23
24/*
bf7c0a3d 25 * Copyright (c) 2003 Constantin S. Svintsoff <kostik@iclub.nsu.ru>
03d70c89
JH
26 *
27 * Redistribution and use in source and binary forms, with or without
28 * modification, are permitted provided that the following conditions
29 * are met:
30 * 1. Redistributions of source code must retain the above copyright
31 * notice, this list of conditions and the following disclaimer.
32 * 2. Redistributions in binary form must reproduce the above copyright
33 * notice, this list of conditions and the following disclaimer in the
34 * documentation and/or other materials provided with the distribution.
bf7c0a3d
SP
35 * 3. The names of the authors may not be used to endorse or promote
36 * products derived from this software without specific prior written
37 * permission.
03d70c89 38 *
bf7c0a3d 39 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
03d70c89
JH
40 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
41 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
bf7c0a3d 42 * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
03d70c89
JH
43 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
44 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
45 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
46 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
47 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
48 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
49 * SUCH DAMAGE.
50 */
51
03d70c89
JH
52/* OpenBSD system #includes removed since the Perl ones should do. --jhi */
53
54#ifndef MAXSYMLINKS
55#define MAXSYMLINKS 8
56#endif
57
66a378bd 58#ifndef VMS
03d70c89 59/*
bf7c0a3d 60 * char *realpath(const char *path, char resolved[MAXPATHLEN]);
03d70c89
JH
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 *
c7304ea2 68bsd_realpath(const char *path, char resolved[MAXPATHLEN])
03d70c89 69{
c7304ea2
NC
70 char *p, *q, *s;
71 size_t left_len, resolved_len;
72 unsigned symlinks;
73 int serrno;
74 char left[MAXPATHLEN], next_token[MAXPATHLEN], symlink[MAXPATHLEN];
03d70c89 75
c7304ea2
NC
76 serrno = errno;
77 symlinks = 0;
78 if (path[0] == '/') {
79 resolved[0] = '/';
80 resolved[1] = '\0';
81 if (path[1] == '\0')
82 return (resolved);
83 resolved_len = 1;
84 left_len = my_strlcpy(left, path + 1, sizeof(left));
85 } else {
86 if (getcwd(resolved, MAXPATHLEN) == NULL) {
87 my_strlcpy(resolved, ".", MAXPATHLEN);
03d70c89
JH
88 return (NULL);
89 }
c7304ea2
NC
90 resolved_len = strlen(resolved);
91 left_len = my_strlcpy(left, path, sizeof(left));
92 }
93 if (left_len >= sizeof(left) || resolved_len >= MAXPATHLEN) {
94 errno = ENAMETOOLONG;
e3d944f4
JH
95 return (NULL);
96 }
03d70c89
JH
97
98 /*
c7304ea2 99 * Iterate over path components in `left'.
03d70c89 100 */
c7304ea2
NC
101 while (left_len != 0) {
102 /*
103 * Extract the next path component and adjust `left'
104 * and its length.
105 */
106 p = strchr(left, '/');
107 s = p ? p : left + left_len;
c33e8be1 108 if ((STRLEN)(s - left) >= (STRLEN)sizeof(next_token)) {
c7304ea2
NC
109 errno = ENAMETOOLONG;
110 return (NULL);
03d70c89 111 }
c7304ea2
NC
112 memcpy(next_token, left, s - left);
113 next_token[s - left] = '\0';
114 left_len -= s - left;
115 if (p != NULL)
116 memmove(left, s + 1, left_len + 1);
117 if (resolved[resolved_len - 1] != '/') {
118 if (resolved_len + 1 >= MAXPATHLEN) {
119 errno = ENAMETOOLONG;
120 return (NULL);
03d70c89 121 }
c7304ea2
NC
122 resolved[resolved_len++] = '/';
123 resolved[resolved_len] = '\0';
03d70c89 124 }
c7304ea2
NC
125 if (next_token[0] == '\0')
126 continue;
127 else if (strcmp(next_token, ".") == 0)
128 continue;
129 else if (strcmp(next_token, "..") == 0) {
130 /*
131 * Strip the last path component except when we have
132 * single "/"
133 */
134 if (resolved_len > 1) {
135 resolved[resolved_len - 1] = '\0';
136 q = strrchr(resolved, '/') + 1;
137 *q = '\0';
138 resolved_len = q - resolved;
139 }
140 continue;
91f3b821 141 }
03d70c89
JH
142
143 /*
c7304ea2
NC
144 * Append the next path component and lstat() it. If
145 * lstat() fails we still can return successfully if
146 * there are no more path components left.
03d70c89 147 */
c7304ea2
NC
148 resolved_len = my_strlcat(resolved, next_token, MAXPATHLEN);
149 if (resolved_len >= MAXPATHLEN) {
150 errno = ENAMETOOLONG;
151 return (NULL);
152 }
153 #if defined(HAS_LSTAT) && defined(HAS_READLINK) && defined(HAS_SYMLINK)
154 {
155 struct stat sb;
156 if (lstat(resolved, &sb) != 0) {
157 if (errno == ENOENT && p == NULL) {
158 errno = serrno;
159 return (resolved);
160 }
161 return (NULL);
162 }
163 if (S_ISLNK(sb.st_mode)) {
164 int slen;
165
166 if (symlinks++ > MAXSYMLINKS) {
167 errno = ELOOP;
168 return (NULL);
169 }
170 slen = readlink(resolved, symlink, sizeof(symlink) - 1);
171 if (slen < 0)
172 return (NULL);
173 symlink[slen] = '\0';
174 if (symlink[0] == '/') {
175 resolved[1] = 0;
176 resolved_len = 1;
177 } else if (resolved_len > 1) {
178 /* Strip the last path component. */
179 resolved[resolved_len - 1] = '\0';
180 q = strrchr(resolved, '/') + 1;
181 *q = '\0';
182 resolved_len = q - resolved;
183 }
03d70c89
JH
184
185 /*
c7304ea2
NC
186 * If there are any path components left, then
187 * append them to symlink. The result is placed
188 * in `left'.
03d70c89 189 */
c7304ea2
NC
190 if (p != NULL) {
191 if (symlink[slen - 1] != '/') {
c33e8be1 192 if ((STRLEN)(slen + 1) >= (STRLEN)sizeof(symlink)) {
03d70c89 193 errno = ENAMETOOLONG;
c7304ea2 194 return (NULL);
03d70c89 195 }
c7304ea2
NC
196 symlink[slen] = '/';
197 symlink[slen + 1] = 0;
03d70c89 198 }
c7304ea2
NC
199 left_len = my_strlcat(symlink, left, sizeof(left));
200 if (left_len >= sizeof(left)) {
201 errno = ENAMETOOLONG;
202 return (NULL);
03d70c89 203 }
e3d944f4 204 }
c7304ea2
NC
205 left_len = my_strlcpy(left, symlink, sizeof(left));
206 }
207 }
208 #endif
209 }
03d70c89 210
c7304ea2
NC
211 /*
212 * Remove trailing slash except when the resolved pathname
213 * is a single "/".
214 */
215 if (resolved_len > 1 && resolved[resolved_len - 1] == '/')
216 resolved[resolved_len - 1] = '\0';
03d70c89 217 return (resolved);
03d70c89 218}
66a378bd 219#endif
03d70c89 220
99f36a73
RGS
221#ifndef SV_CWD_RETURN_UNDEF
222#define SV_CWD_RETURN_UNDEF \
223sv_setsv(sv, &PL_sv_undef); \
224return FALSE
225#endif
226
227#ifndef OPpENTERSUB_HASTARG
228#define OPpENTERSUB_HASTARG 32 /* Called from OP tree. */
229#endif
230
231#ifndef dXSTARG
232#define dXSTARG SV * targ = ((PL_op->op_private & OPpENTERSUB_HASTARG) \
233 ? PAD_SV(PL_op->op_targ) : sv_newmortal())
234#endif
235
236#ifndef XSprePUSH
237#define XSprePUSH (sp = PL_stack_base + ax - 1)
238#endif
239
240#ifndef SV_CWD_ISDOT
241#define SV_CWD_ISDOT(dp) \
242 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
243 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
244#endif
245
a9939470 246#ifndef getcwd_sv
1955c8df 247/* Taken from perl 5.8's util.c */
09122b95
RGS
248#define getcwd_sv(a) Perl_getcwd_sv(aTHX_ a)
249int Perl_getcwd_sv(pTHX_ register SV *sv)
a9939470
NC
250{
251#ifndef PERL_MICRO
252
253#ifndef INCOMPLETE_TAINTS
254 SvTAINTED_on(sv);
255#endif
256
257#ifdef HAS_GETCWD
258 {
259 char buf[MAXPATHLEN];
260
261 /* Some getcwd()s automatically allocate a buffer of the given
262 * size from the heap if they are given a NULL buffer pointer.
263 * The problem is that this behaviour is not portable. */
264 if (getcwd(buf, sizeof(buf) - 1)) {
265 STRLEN len = strlen(buf);
266 sv_setpvn(sv, buf, len);
267 return TRUE;
268 }
269 else {
270 sv_setsv(sv, &PL_sv_undef);
271 return FALSE;
272 }
273 }
274
275#else
f6342b4b 276 {
a9939470
NC
277 Stat_t statbuf;
278 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
279 int namelen, pathlen=0;
280 DIR *dir;
281 Direntry_t *dp;
282
283 (void)SvUPGRADE(sv, SVt_PV);
284
285 if (PerlLIO_lstat(".", &statbuf) < 0) {
286 SV_CWD_RETURN_UNDEF;
287 }
288
289 orig_cdev = statbuf.st_dev;
290 orig_cino = statbuf.st_ino;
291 cdev = orig_cdev;
292 cino = orig_cino;
293
294 for (;;) {
295 odev = cdev;
296 oino = cino;
297
298 if (PerlDir_chdir("..") < 0) {
299 SV_CWD_RETURN_UNDEF;
300 }
301 if (PerlLIO_stat(".", &statbuf) < 0) {
302 SV_CWD_RETURN_UNDEF;
303 }
304
305 cdev = statbuf.st_dev;
306 cino = statbuf.st_ino;
307
308 if (odev == cdev && oino == cino) {
309 break;
310 }
311 if (!(dir = PerlDir_open("."))) {
312 SV_CWD_RETURN_UNDEF;
313 }
314
315 while ((dp = PerlDir_read(dir)) != NULL) {
316#ifdef DIRNAMLEN
317 namelen = dp->d_namlen;
318#else
319 namelen = strlen(dp->d_name);
320#endif
321 /* skip . and .. */
322 if (SV_CWD_ISDOT(dp)) {
323 continue;
324 }
325
326 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
327 SV_CWD_RETURN_UNDEF;
328 }
329
330 tdev = statbuf.st_dev;
331 tino = statbuf.st_ino;
332 if (tino == oino && tdev == odev) {
333 break;
334 }
335 }
336
337 if (!dp) {
338 SV_CWD_RETURN_UNDEF;
339 }
340
341 if (pathlen + namelen + 1 >= MAXPATHLEN) {
342 SV_CWD_RETURN_UNDEF;
343 }
344
345 SvGROW(sv, pathlen + namelen + 1);
346
347 if (pathlen) {
348 /* shift down */
349 Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
350 }
351
352 /* prepend current directory to the front */
353 *SvPVX(sv) = '/';
354 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
355 pathlen += (namelen + 1);
356
357#ifdef VOID_CLOSEDIR
358 PerlDir_close(dir);
359#else
360 if (PerlDir_close(dir) < 0) {
361 SV_CWD_RETURN_UNDEF;
362 }
363#endif
364 }
365
366 if (pathlen) {
367 SvCUR_set(sv, pathlen);
368 *SvEND(sv) = '\0';
369 SvPOK_only(sv);
370
371 if (PerlDir_chdir(SvPVX(sv)) < 0) {
372 SV_CWD_RETURN_UNDEF;
373 }
374 }
375 if (PerlLIO_stat(".", &statbuf) < 0) {
376 SV_CWD_RETURN_UNDEF;
377 }
378
379 cdev = statbuf.st_dev;
380 cino = statbuf.st_ino;
381
382 if (cdev != orig_cdev || cino != orig_cino) {
383 Perl_croak(aTHX_ "Unstable directory path, "
384 "current directory changed unexpectedly");
385 }
386
387 return TRUE;
f6342b4b 388 }
a9939470
NC
389#endif
390
391#else
392 return FALSE;
393#endif
394}
395
396#endif
397
398
f22d8e4b 399MODULE = Cwd PACKAGE = Cwd
0d2079fa 400
1d0561d5 401PROTOTYPES: DISABLE
0d2079fa 402
f22d8e4b 403void
23bb49fa 404getcwd(...)
2cdb8b94
NC
405ALIAS:
406 fastcwd=1
fa52125f
SP
407PPCODE:
408{
409 dXSTARG;
2cdb8b94
NC
410 /* fastcwd takes zero parameters: */
411 if (ix == 1 && items != 0)
412 croak_xs_usage(cv, "");
fa52125f
SP
413 getcwd_sv(TARG);
414 XSprePUSH; PUSHTARG;
415#ifndef INCOMPLETE_TAINTS
416 SvTAINTED_on(TARG);
417#endif
418}
419
420void
03d70c89
JH
421abs_path(pathsv=Nullsv)
422 SV *pathsv
f22d8e4b 423PPCODE:
2ae52c40 424{
f22d8e4b 425 dXSTARG;
66a378bd 426 char *const path = pathsv ? SvPV_nolen(pathsv) : (char *)".";
00536bfc 427 char buf[MAXPATHLEN];
03d70c89 428
66a378bd
NC
429 if (
430#ifdef VMS
431 Perl_rmsexpand(aTHX_ path, buf, NULL, 0)
432#else
433 bsd_realpath(path, buf)
434#endif
435 ) {
436 sv_setpv_mg(TARG, buf);
00536bfc 437 SvPOK_only(TARG);
ea715489 438 SvTAINTED_on(TARG);
2ae52c40 439 }
03d70c89 440 else
ea715489 441 sv_setsv(TARG, &PL_sv_undef);
2ae52c40 442
66a378bd 443 XSprePUSH; PUSHs(TARG);
ea715489
JH
444#ifndef INCOMPLETE_TAINTS
445 SvTAINTED_on(TARG);
446#endif
2ae52c40 447}
09122b95 448
42d1cefd 449#if defined(WIN32) && !defined(UNDER_CE)
09122b95
RGS
450
451void
452getdcwd(...)
1d0561d5 453PROTOTYPE: ENABLE
09122b95
RGS
454PPCODE:
455{
456 dXSTARG;
457 int drive;
458 char *dir;
459
460 /* Drive 0 is the current drive, 1 is A:, 2 is B:, 3 is C: and so on. */
461 if ( items == 0 ||
462 (items == 1 && (!SvOK(ST(0)) || (SvPOK(ST(0)) && !SvCUR(ST(0))))))
463 drive = 0;
464 else if (items == 1 && SvPOK(ST(0)) && SvCUR(ST(0)) &&
465 isALPHA(SvPVX(ST(0))[0]))
466 drive = toUPPER(SvPVX(ST(0))[0]) - 'A' + 1;
467 else
468 croak("Usage: getdcwd(DRIVE)");
469
275e8705
RGS
470 New(0,dir,MAXPATHLEN,char);
471 if (_getdcwd(drive, dir, MAXPATHLEN)) {
66a378bd 472 sv_setpv_mg(TARG, dir);
09122b95
RGS
473 SvPOK_only(TARG);
474 }
475 else
476 sv_setsv(TARG, &PL_sv_undef);
477
99f36a73
RGS
478 Safefree(dir);
479
66a378bd 480 XSprePUSH; PUSHs(TARG);
09122b95
RGS
481#ifndef INCOMPLETE_TAINTS
482 SvTAINTED_on(TARG);
483#endif
484}
485
486#endif