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