This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add PERL_NO_GET_CONTEXT to Cwd.
[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
58/*
bf7c0a3d 59 * char *realpath(const char *path, char resolved[MAXPATHLEN]);
03d70c89
JH
60 *
61 * Find the real name of path, by removing all ".", ".." and symlink
62 * components. Returns (resolved) on success, or (NULL) on failure,
63 * in which case the path which caused trouble is left in (resolved).
64 */
65static
66char *
c7304ea2 67bsd_realpath(const char *path, char resolved[MAXPATHLEN])
03d70c89 68{
e3d944f4 69#ifdef VMS
32af7c23
CL
70 dTHX;
71 return Perl_rmsexpand(aTHX_ (char*)path, resolved, NULL, 0);
e3d944f4 72#else
c7304ea2
NC
73 char *p, *q, *s;
74 size_t left_len, resolved_len;
75 unsigned symlinks;
76 int serrno;
77 char left[MAXPATHLEN], next_token[MAXPATHLEN], symlink[MAXPATHLEN];
03d70c89 78
c7304ea2
NC
79 serrno = errno;
80 symlinks = 0;
81 if (path[0] == '/') {
82 resolved[0] = '/';
83 resolved[1] = '\0';
84 if (path[1] == '\0')
85 return (resolved);
86 resolved_len = 1;
87 left_len = my_strlcpy(left, path + 1, sizeof(left));
88 } else {
89 if (getcwd(resolved, MAXPATHLEN) == NULL) {
90 my_strlcpy(resolved, ".", MAXPATHLEN);
03d70c89
JH
91 return (NULL);
92 }
c7304ea2
NC
93 resolved_len = strlen(resolved);
94 left_len = my_strlcpy(left, path, sizeof(left));
95 }
96 if (left_len >= sizeof(left) || resolved_len >= MAXPATHLEN) {
97 errno = ENAMETOOLONG;
e3d944f4
JH
98 return (NULL);
99 }
03d70c89
JH
100
101 /*
c7304ea2 102 * Iterate over path components in `left'.
03d70c89 103 */
c7304ea2
NC
104 while (left_len != 0) {
105 /*
106 * Extract the next path component and adjust `left'
107 * and its length.
108 */
109 p = strchr(left, '/');
110 s = p ? p : left + left_len;
c33e8be1 111 if ((STRLEN)(s - left) >= (STRLEN)sizeof(next_token)) {
c7304ea2
NC
112 errno = ENAMETOOLONG;
113 return (NULL);
03d70c89 114 }
c7304ea2
NC
115 memcpy(next_token, left, s - left);
116 next_token[s - left] = '\0';
117 left_len -= s - left;
118 if (p != NULL)
119 memmove(left, s + 1, left_len + 1);
120 if (resolved[resolved_len - 1] != '/') {
121 if (resolved_len + 1 >= MAXPATHLEN) {
122 errno = ENAMETOOLONG;
123 return (NULL);
03d70c89 124 }
c7304ea2
NC
125 resolved[resolved_len++] = '/';
126 resolved[resolved_len] = '\0';
03d70c89 127 }
c7304ea2
NC
128 if (next_token[0] == '\0')
129 continue;
130 else if (strcmp(next_token, ".") == 0)
131 continue;
132 else if (strcmp(next_token, "..") == 0) {
133 /*
134 * Strip the last path component except when we have
135 * single "/"
136 */
137 if (resolved_len > 1) {
138 resolved[resolved_len - 1] = '\0';
139 q = strrchr(resolved, '/') + 1;
140 *q = '\0';
141 resolved_len = q - resolved;
142 }
143 continue;
91f3b821 144 }
03d70c89
JH
145
146 /*
c7304ea2
NC
147 * Append the next path component and lstat() it. If
148 * lstat() fails we still can return successfully if
149 * there are no more path components left.
03d70c89 150 */
c7304ea2
NC
151 resolved_len = my_strlcat(resolved, next_token, MAXPATHLEN);
152 if (resolved_len >= MAXPATHLEN) {
153 errno = ENAMETOOLONG;
154 return (NULL);
155 }
156 #if defined(HAS_LSTAT) && defined(HAS_READLINK) && defined(HAS_SYMLINK)
157 {
158 struct stat sb;
159 if (lstat(resolved, &sb) != 0) {
160 if (errno == ENOENT && p == NULL) {
161 errno = serrno;
162 return (resolved);
163 }
164 return (NULL);
165 }
166 if (S_ISLNK(sb.st_mode)) {
167 int slen;
168
169 if (symlinks++ > MAXSYMLINKS) {
170 errno = ELOOP;
171 return (NULL);
172 }
173 slen = readlink(resolved, symlink, sizeof(symlink) - 1);
174 if (slen < 0)
175 return (NULL);
176 symlink[slen] = '\0';
177 if (symlink[0] == '/') {
178 resolved[1] = 0;
179 resolved_len = 1;
180 } else if (resolved_len > 1) {
181 /* Strip the last path component. */
182 resolved[resolved_len - 1] = '\0';
183 q = strrchr(resolved, '/') + 1;
184 *q = '\0';
185 resolved_len = q - resolved;
186 }
03d70c89
JH
187
188 /*
c7304ea2
NC
189 * If there are any path components left, then
190 * append them to symlink. The result is placed
191 * in `left'.
03d70c89 192 */
c7304ea2
NC
193 if (p != NULL) {
194 if (symlink[slen - 1] != '/') {
c33e8be1 195 if ((STRLEN)(slen + 1) >= (STRLEN)sizeof(symlink)) {
03d70c89 196 errno = ENAMETOOLONG;
c7304ea2 197 return (NULL);
03d70c89 198 }
c7304ea2
NC
199 symlink[slen] = '/';
200 symlink[slen + 1] = 0;
03d70c89 201 }
c7304ea2
NC
202 left_len = my_strlcat(symlink, left, sizeof(left));
203 if (left_len >= sizeof(left)) {
204 errno = ENAMETOOLONG;
205 return (NULL);
03d70c89 206 }
e3d944f4 207 }
c7304ea2
NC
208 left_len = my_strlcpy(left, symlink, sizeof(left));
209 }
210 }
211 #endif
212 }
03d70c89 213
c7304ea2
NC
214 /*
215 * Remove trailing slash except when the resolved pathname
216 * is a single "/".
217 */
218 if (resolved_len > 1 && resolved[resolved_len - 1] == '/')
219 resolved[resolved_len - 1] = '\0';
03d70c89 220 return (resolved);
e3d944f4 221#endif
03d70c89
JH
222}
223
99f36a73
RGS
224#ifndef SV_CWD_RETURN_UNDEF
225#define SV_CWD_RETURN_UNDEF \
226sv_setsv(sv, &PL_sv_undef); \
227return FALSE
228#endif
229
230#ifndef OPpENTERSUB_HASTARG
231#define OPpENTERSUB_HASTARG 32 /* Called from OP tree. */
232#endif
233
234#ifndef dXSTARG
235#define dXSTARG SV * targ = ((PL_op->op_private & OPpENTERSUB_HASTARG) \
236 ? PAD_SV(PL_op->op_targ) : sv_newmortal())
237#endif
238
239#ifndef XSprePUSH
240#define XSprePUSH (sp = PL_stack_base + ax - 1)
241#endif
242
243#ifndef SV_CWD_ISDOT
244#define SV_CWD_ISDOT(dp) \
245 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
246 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
247#endif
248
a9939470 249#ifndef getcwd_sv
1955c8df 250/* Taken from perl 5.8's util.c */
09122b95
RGS
251#define getcwd_sv(a) Perl_getcwd_sv(aTHX_ a)
252int Perl_getcwd_sv(pTHX_ register SV *sv)
a9939470
NC
253{
254#ifndef PERL_MICRO
255
256#ifndef INCOMPLETE_TAINTS
257 SvTAINTED_on(sv);
258#endif
259
260#ifdef HAS_GETCWD
261 {
262 char buf[MAXPATHLEN];
263
264 /* Some getcwd()s automatically allocate a buffer of the given
265 * size from the heap if they are given a NULL buffer pointer.
266 * The problem is that this behaviour is not portable. */
267 if (getcwd(buf, sizeof(buf) - 1)) {
268 STRLEN len = strlen(buf);
269 sv_setpvn(sv, buf, len);
270 return TRUE;
271 }
272 else {
273 sv_setsv(sv, &PL_sv_undef);
274 return FALSE;
275 }
276 }
277
278#else
f6342b4b 279 {
a9939470
NC
280 Stat_t statbuf;
281 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
282 int namelen, pathlen=0;
283 DIR *dir;
284 Direntry_t *dp;
285
286 (void)SvUPGRADE(sv, SVt_PV);
287
288 if (PerlLIO_lstat(".", &statbuf) < 0) {
289 SV_CWD_RETURN_UNDEF;
290 }
291
292 orig_cdev = statbuf.st_dev;
293 orig_cino = statbuf.st_ino;
294 cdev = orig_cdev;
295 cino = orig_cino;
296
297 for (;;) {
298 odev = cdev;
299 oino = cino;
300
301 if (PerlDir_chdir("..") < 0) {
302 SV_CWD_RETURN_UNDEF;
303 }
304 if (PerlLIO_stat(".", &statbuf) < 0) {
305 SV_CWD_RETURN_UNDEF;
306 }
307
308 cdev = statbuf.st_dev;
309 cino = statbuf.st_ino;
310
311 if (odev == cdev && oino == cino) {
312 break;
313 }
314 if (!(dir = PerlDir_open("."))) {
315 SV_CWD_RETURN_UNDEF;
316 }
317
318 while ((dp = PerlDir_read(dir)) != NULL) {
319#ifdef DIRNAMLEN
320 namelen = dp->d_namlen;
321#else
322 namelen = strlen(dp->d_name);
323#endif
324 /* skip . and .. */
325 if (SV_CWD_ISDOT(dp)) {
326 continue;
327 }
328
329 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
330 SV_CWD_RETURN_UNDEF;
331 }
332
333 tdev = statbuf.st_dev;
334 tino = statbuf.st_ino;
335 if (tino == oino && tdev == odev) {
336 break;
337 }
338 }
339
340 if (!dp) {
341 SV_CWD_RETURN_UNDEF;
342 }
343
344 if (pathlen + namelen + 1 >= MAXPATHLEN) {
345 SV_CWD_RETURN_UNDEF;
346 }
347
348 SvGROW(sv, pathlen + namelen + 1);
349
350 if (pathlen) {
351 /* shift down */
352 Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
353 }
354
355 /* prepend current directory to the front */
356 *SvPVX(sv) = '/';
357 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
358 pathlen += (namelen + 1);
359
360#ifdef VOID_CLOSEDIR
361 PerlDir_close(dir);
362#else
363 if (PerlDir_close(dir) < 0) {
364 SV_CWD_RETURN_UNDEF;
365 }
366#endif
367 }
368
369 if (pathlen) {
370 SvCUR_set(sv, pathlen);
371 *SvEND(sv) = '\0';
372 SvPOK_only(sv);
373
374 if (PerlDir_chdir(SvPVX(sv)) < 0) {
375 SV_CWD_RETURN_UNDEF;
376 }
377 }
378 if (PerlLIO_stat(".", &statbuf) < 0) {
379 SV_CWD_RETURN_UNDEF;
380 }
381
382 cdev = statbuf.st_dev;
383 cino = statbuf.st_ino;
384
385 if (cdev != orig_cdev || cino != orig_cino) {
386 Perl_croak(aTHX_ "Unstable directory path, "
387 "current directory changed unexpectedly");
388 }
389
390 return TRUE;
f6342b4b 391 }
a9939470
NC
392#endif
393
394#else
395 return FALSE;
396#endif
397}
398
399#endif
400
401
f22d8e4b 402MODULE = Cwd PACKAGE = Cwd
0d2079fa 403
f22d8e4b 404PROTOTYPES: ENABLE
0d2079fa 405
f22d8e4b
DM
406void
407fastcwd()
7ddb28a3 408PROTOTYPE: DISABLE
f22d8e4b
DM
409PPCODE:
410{
411 dXSTARG;
89423764 412 getcwd_sv(TARG);
f22d8e4b 413 XSprePUSH; PUSHTARG;
248785eb
RGS
414#ifndef INCOMPLETE_TAINTS
415 SvTAINTED_on(TARG);
416#endif
0d2079fa
BS
417}
418
f22d8e4b 419void
23bb49fa 420getcwd(...)
fa52125f
SP
421PROTOTYPE: DISABLE
422PPCODE:
423{
424 dXSTARG;
425 getcwd_sv(TARG);
426 XSprePUSH; PUSHTARG;
427#ifndef INCOMPLETE_TAINTS
428 SvTAINTED_on(TARG);
429#endif
430}
431
432void
03d70c89
JH
433abs_path(pathsv=Nullsv)
434 SV *pathsv
99f36a73 435PROTOTYPE: DISABLE
f22d8e4b 436PPCODE:
2ae52c40 437{
f22d8e4b
DM
438 dXSTARG;
439 char *path;
00536bfc 440 char buf[MAXPATHLEN];
03d70c89 441
07409e01 442 path = pathsv ? SvPV_nolen(pathsv) : (char *)".";
03d70c89 443
00536bfc
JH
444 if (bsd_realpath(path, buf)) {
445 sv_setpvn(TARG, buf, strlen(buf));
446 SvPOK_only(TARG);
ea715489 447 SvTAINTED_on(TARG);
2ae52c40 448 }
03d70c89 449 else
ea715489 450 sv_setsv(TARG, &PL_sv_undef);
2ae52c40 451
f22d8e4b 452 XSprePUSH; PUSHTARG;
ea715489
JH
453#ifndef INCOMPLETE_TAINTS
454 SvTAINTED_on(TARG);
455#endif
2ae52c40 456}
09122b95 457
42d1cefd 458#if defined(WIN32) && !defined(UNDER_CE)
09122b95
RGS
459
460void
461getdcwd(...)
462PPCODE:
463{
464 dXSTARG;
465 int drive;
466 char *dir;
467
468 /* Drive 0 is the current drive, 1 is A:, 2 is B:, 3 is C: and so on. */
469 if ( items == 0 ||
470 (items == 1 && (!SvOK(ST(0)) || (SvPOK(ST(0)) && !SvCUR(ST(0))))))
471 drive = 0;
472 else if (items == 1 && SvPOK(ST(0)) && SvCUR(ST(0)) &&
473 isALPHA(SvPVX(ST(0))[0]))
474 drive = toUPPER(SvPVX(ST(0))[0]) - 'A' + 1;
475 else
476 croak("Usage: getdcwd(DRIVE)");
477
275e8705
RGS
478 New(0,dir,MAXPATHLEN,char);
479 if (_getdcwd(drive, dir, MAXPATHLEN)) {
09122b95 480 sv_setpvn(TARG, dir, strlen(dir));
09122b95
RGS
481 SvPOK_only(TARG);
482 }
483 else
484 sv_setsv(TARG, &PL_sv_undef);
485
99f36a73
RGS
486 Safefree(dir);
487
09122b95
RGS
488 XSprePUSH; PUSHTARG;
489#ifndef INCOMPLETE_TAINTS
490 SvTAINTED_on(TARG);
491#endif
492}
493
494#endif