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