This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add a macro MUTABLE_PTR(p), which on (non-pedantic) gcc will not cast
[perl5.git] / ext / Cwd / Cwd.xs
CommitLineData
0d2079fa
BS
1#include "EXTERN.h"
2#include "perl.h"
3#include "XSUB.h"
dfa4e5d3 4#ifndef NO_PPPORT_H
bf7c0a3d
SP
5# define NEED_my_strlcpy
6# define NEED_my_strlcat
4ce45bab
JH
7# include "ppport.h"
8#endif
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 *
a733a8a0 67bsd_realpath(const char *path, char *resolved)
03d70c89 68{
e3d944f4 69#ifdef VMS
32af7c23
CL
70 dTHX;
71 return Perl_rmsexpand(aTHX_ (char*)path, resolved, NULL, 0);
e3d944f4 72#else
91f3b821 73 int rootd, serrno;
f5725584
RB
74 const char *p;
75 char *q, wbuf[MAXPATHLEN];
03d70c89
JH
76 int symlinks = 0;
77
78 /* Save the starting point. */
e3d944f4 79#ifdef HAS_FCHDIR
bae06e14
JH
80 int fd;
81
03d70c89
JH
82 if ((fd = open(".", O_RDONLY)) < 0) {
83 (void)strcpy(resolved, ".");
84 return (NULL);
85 }
e3d944f4
JH
86#else
87 char wd[MAXPATHLEN];
88
89 if (getcwd(wd, MAXPATHLEN - 1) == NULL) {
90 (void)strcpy(resolved, ".");
91 return (NULL);
92 }
93#endif
03d70c89
JH
94
95 /*
96 * Find the dirname and basename from the path to be resolved.
97 * Change directory to the dirname component.
98 * lstat the basename part.
99 * if it is a symlink, read in the value and loop.
100 * if it is a directory, then change to that directory.
101 * get the current directory name and append the basename.
102 */
103 (void)strncpy(resolved, path, MAXPATHLEN - 1);
104 resolved[MAXPATHLEN - 1] = '\0';
105loop:
106 q = strrchr(resolved, '/');
107 if (q != NULL) {
f5725584 108 const char *dir;
03d70c89
JH
109 p = q + 1;
110 if (q == resolved)
f5725584 111 dir = "/";
03d70c89
JH
112 else {
113 do {
114 --q;
115 } while (q > resolved && *q == '/');
116 q[1] = '\0';
f5725584 117 dir = resolved;
03d70c89 118 }
f5725584 119 if (chdir(dir) < 0)
03d70c89
JH
120 goto err1;
121 } else
122 p = resolved;
123
bae06e14 124#if defined(HAS_LSTAT) && defined(HAS_READLINK) && defined(HAS_SYMLINK)
91f3b821
GS
125 {
126 struct stat sb;
03d70c89
JH
127 /* Deal with the last component. */
128 if (lstat(p, &sb) == 0) {
129 if (S_ISLNK(sb.st_mode)) {
91f3b821 130 int n;
03d70c89
JH
131 if (++symlinks > MAXSYMLINKS) {
132 errno = ELOOP;
133 goto err1;
134 }
135 n = readlink(p, resolved, MAXPATHLEN-1);
136 if (n < 0)
137 goto err1;
138 resolved[n] = '\0';
139 goto loop;
140 }
141 if (S_ISDIR(sb.st_mode)) {
142 if (chdir(p) < 0)
143 goto err1;
144 p = "";
145 }
146 }
91f3b821 147 }
e3d944f4 148#endif
03d70c89
JH
149
150 /*
151 * Save the last component name and get the full pathname of
152 * the current directory.
153 */
154 (void)strcpy(wbuf, p);
155 if (getcwd(resolved, MAXPATHLEN) == 0)
156 goto err1;
157
158 /*
159 * Join the two strings together, ensuring that the right thing
160 * happens if the last component is empty, or the dirname is root.
161 */
162 if (resolved[0] == '/' && resolved[1] == '\0')
163 rootd = 1;
164 else
165 rootd = 0;
166
167 if (*wbuf) {
7f6e23a8 168 if (strlen(resolved) + strlen(wbuf) + (1 - rootd) + 1 > MAXPATHLEN) {
03d70c89
JH
169 errno = ENAMETOOLONG;
170 goto err1;
171 }
172 if (rootd == 0)
173 (void)strcat(resolved, "/");
174 (void)strcat(resolved, wbuf);
175 }
176
177 /* Go back to where we came from. */
e3d944f4 178#ifdef HAS_FCHDIR
03d70c89
JH
179 if (fchdir(fd) < 0) {
180 serrno = errno;
181 goto err2;
182 }
e3d944f4
JH
183#else
184 if (chdir(wd) < 0) {
185 serrno = errno;
186 goto err2;
187 }
188#endif
03d70c89
JH
189
190 /* It's okay if the close fails, what's an fd more or less? */
9cad6237 191#ifdef HAS_FCHDIR
03d70c89 192 (void)close(fd);
9cad6237 193#endif
03d70c89
JH
194 return (resolved);
195
196err1: serrno = errno;
29ab7413 197#ifdef HAS_FCHDIR
03d70c89 198 (void)fchdir(fd);
29ab7413
JH
199#else
200 (void)chdir(wd);
201#endif
89423764
GS
202
203err2:
204#ifdef HAS_FCHDIR
205 (void)close(fd);
206#endif
03d70c89
JH
207 errno = serrno;
208 return (NULL);
e3d944f4 209#endif
03d70c89
JH
210}
211
99f36a73
RGS
212#ifndef SV_CWD_RETURN_UNDEF
213#define SV_CWD_RETURN_UNDEF \
214sv_setsv(sv, &PL_sv_undef); \
215return FALSE
216#endif
217
218#ifndef OPpENTERSUB_HASTARG
219#define OPpENTERSUB_HASTARG 32 /* Called from OP tree. */
220#endif
221
222#ifndef dXSTARG
223#define dXSTARG SV * targ = ((PL_op->op_private & OPpENTERSUB_HASTARG) \
224 ? PAD_SV(PL_op->op_targ) : sv_newmortal())
225#endif
226
227#ifndef XSprePUSH
228#define XSprePUSH (sp = PL_stack_base + ax - 1)
229#endif
230
231#ifndef SV_CWD_ISDOT
232#define SV_CWD_ISDOT(dp) \
233 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
234 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
235#endif
236
a9939470 237#ifndef getcwd_sv
1955c8df 238/* Taken from perl 5.8's util.c */
09122b95
RGS
239#define getcwd_sv(a) Perl_getcwd_sv(aTHX_ a)
240int Perl_getcwd_sv(pTHX_ register SV *sv)
a9939470
NC
241{
242#ifndef PERL_MICRO
243
244#ifndef INCOMPLETE_TAINTS
245 SvTAINTED_on(sv);
246#endif
247
248#ifdef HAS_GETCWD
249 {
250 char buf[MAXPATHLEN];
251
252 /* Some getcwd()s automatically allocate a buffer of the given
253 * size from the heap if they are given a NULL buffer pointer.
254 * The problem is that this behaviour is not portable. */
255 if (getcwd(buf, sizeof(buf) - 1)) {
256 STRLEN len = strlen(buf);
257 sv_setpvn(sv, buf, len);
258 return TRUE;
259 }
260 else {
261 sv_setsv(sv, &PL_sv_undef);
262 return FALSE;
263 }
264 }
265
266#else
f6342b4b 267 {
a9939470
NC
268 Stat_t statbuf;
269 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
270 int namelen, pathlen=0;
271 DIR *dir;
272 Direntry_t *dp;
273
274 (void)SvUPGRADE(sv, SVt_PV);
275
276 if (PerlLIO_lstat(".", &statbuf) < 0) {
277 SV_CWD_RETURN_UNDEF;
278 }
279
280 orig_cdev = statbuf.st_dev;
281 orig_cino = statbuf.st_ino;
282 cdev = orig_cdev;
283 cino = orig_cino;
284
285 for (;;) {
286 odev = cdev;
287 oino = cino;
288
289 if (PerlDir_chdir("..") < 0) {
290 SV_CWD_RETURN_UNDEF;
291 }
292 if (PerlLIO_stat(".", &statbuf) < 0) {
293 SV_CWD_RETURN_UNDEF;
294 }
295
296 cdev = statbuf.st_dev;
297 cino = statbuf.st_ino;
298
299 if (odev == cdev && oino == cino) {
300 break;
301 }
302 if (!(dir = PerlDir_open("."))) {
303 SV_CWD_RETURN_UNDEF;
304 }
305
306 while ((dp = PerlDir_read(dir)) != NULL) {
307#ifdef DIRNAMLEN
308 namelen = dp->d_namlen;
309#else
310 namelen = strlen(dp->d_name);
311#endif
312 /* skip . and .. */
313 if (SV_CWD_ISDOT(dp)) {
314 continue;
315 }
316
317 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
318 SV_CWD_RETURN_UNDEF;
319 }
320
321 tdev = statbuf.st_dev;
322 tino = statbuf.st_ino;
323 if (tino == oino && tdev == odev) {
324 break;
325 }
326 }
327
328 if (!dp) {
329 SV_CWD_RETURN_UNDEF;
330 }
331
332 if (pathlen + namelen + 1 >= MAXPATHLEN) {
333 SV_CWD_RETURN_UNDEF;
334 }
335
336 SvGROW(sv, pathlen + namelen + 1);
337
338 if (pathlen) {
339 /* shift down */
340 Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
341 }
342
343 /* prepend current directory to the front */
344 *SvPVX(sv) = '/';
345 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
346 pathlen += (namelen + 1);
347
348#ifdef VOID_CLOSEDIR
349 PerlDir_close(dir);
350#else
351 if (PerlDir_close(dir) < 0) {
352 SV_CWD_RETURN_UNDEF;
353 }
354#endif
355 }
356
357 if (pathlen) {
358 SvCUR_set(sv, pathlen);
359 *SvEND(sv) = '\0';
360 SvPOK_only(sv);
361
362 if (PerlDir_chdir(SvPVX(sv)) < 0) {
363 SV_CWD_RETURN_UNDEF;
364 }
365 }
366 if (PerlLIO_stat(".", &statbuf) < 0) {
367 SV_CWD_RETURN_UNDEF;
368 }
369
370 cdev = statbuf.st_dev;
371 cino = statbuf.st_ino;
372
373 if (cdev != orig_cdev || cino != orig_cino) {
374 Perl_croak(aTHX_ "Unstable directory path, "
375 "current directory changed unexpectedly");
376 }
377
378 return TRUE;
f6342b4b 379 }
a9939470
NC
380#endif
381
382#else
383 return FALSE;
384#endif
385}
386
387#endif
388
389
f22d8e4b 390MODULE = Cwd PACKAGE = Cwd
0d2079fa 391
f22d8e4b 392PROTOTYPES: ENABLE
0d2079fa 393
f22d8e4b
DM
394void
395fastcwd()
7ddb28a3 396PROTOTYPE: DISABLE
f22d8e4b
DM
397PPCODE:
398{
399 dXSTARG;
89423764 400 getcwd_sv(TARG);
f22d8e4b 401 XSprePUSH; PUSHTARG;
248785eb
RGS
402#ifndef INCOMPLETE_TAINTS
403 SvTAINTED_on(TARG);
404#endif
0d2079fa
BS
405}
406
f22d8e4b 407void
23bb49fa 408getcwd(...)
fa52125f
SP
409PROTOTYPE: DISABLE
410PPCODE:
411{
412 dXSTARG;
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
99f36a73 423PROTOTYPE: DISABLE
f22d8e4b 424PPCODE:
2ae52c40 425{
f22d8e4b
DM
426 dXSTARG;
427 char *path;
00536bfc 428 char buf[MAXPATHLEN];
03d70c89 429
07409e01 430 path = pathsv ? SvPV_nolen(pathsv) : (char *)".";
03d70c89 431
00536bfc
JH
432 if (bsd_realpath(path, buf)) {
433 sv_setpvn(TARG, buf, strlen(buf));
434 SvPOK_only(TARG);
ea715489 435 SvTAINTED_on(TARG);
2ae52c40 436 }
03d70c89 437 else
ea715489 438 sv_setsv(TARG, &PL_sv_undef);
2ae52c40 439
f22d8e4b 440 XSprePUSH; PUSHTARG;
ea715489
JH
441#ifndef INCOMPLETE_TAINTS
442 SvTAINTED_on(TARG);
443#endif
2ae52c40 444}
09122b95 445
42d1cefd 446#if defined(WIN32) && !defined(UNDER_CE)
09122b95
RGS
447
448void
449getdcwd(...)
450PPCODE:
451{
452 dXSTARG;
453 int drive;
454 char *dir;
455
456 /* Drive 0 is the current drive, 1 is A:, 2 is B:, 3 is C: and so on. */
457 if ( items == 0 ||
458 (items == 1 && (!SvOK(ST(0)) || (SvPOK(ST(0)) && !SvCUR(ST(0))))))
459 drive = 0;
460 else if (items == 1 && SvPOK(ST(0)) && SvCUR(ST(0)) &&
461 isALPHA(SvPVX(ST(0))[0]))
462 drive = toUPPER(SvPVX(ST(0))[0]) - 'A' + 1;
463 else
464 croak("Usage: getdcwd(DRIVE)");
465
275e8705
RGS
466 New(0,dir,MAXPATHLEN,char);
467 if (_getdcwd(drive, dir, MAXPATHLEN)) {
09122b95 468 sv_setpvn(TARG, dir, strlen(dir));
09122b95
RGS
469 SvPOK_only(TARG);
470 }
471 else
472 sv_setsv(TARG, &PL_sv_undef);
473
99f36a73
RGS
474 Safefree(dir);
475
09122b95
RGS
476 XSprePUSH; PUSHTARG;
477#ifndef INCOMPLETE_TAINTS
478 SvTAINTED_on(TARG);
479#endif
480}
481
482#endif