Upgrade to PathTools 3.30_02 (with only core reorganization fixes)
[perl.git] / cpan / Cwd / Cwd.xs
1 #include "EXTERN.h"
2 #include "perl.h"
3 #include "XSUB.h"
4 #define NEED_my_strlcpy
5 #define NEED_my_strlcat
6 #include "ppport.h"
7
8 #ifdef I_UNISTD
9 #   include <unistd.h>
10 #endif
11
12 /* The realpath() implementation from OpenBSD 3.9 to 4.2 (realpath.c 1.13)
13  * Renamed here to bsd_realpath() to avoid library conflicts.
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  */
21
22 /*
23  * Copyright (c) 2003 Constantin S. Svintsoff <kostik@iclub.nsu.ru>
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.
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.
36  *
37  * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
38  * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
39  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
40  * ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
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
50 /* OpenBSD system #includes removed since the Perl ones should do. --jhi */
51
52 #ifndef MAXSYMLINKS
53 #define MAXSYMLINKS 8
54 #endif
55
56 /*
57  * char *realpath(const char *path, char resolved[MAXPATHLEN]);
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  */
63 static
64 char *
65 bsd_realpath(const char *path, char resolved[MAXPATHLEN])
66 {
67 #ifdef VMS
68        dTHX;
69        return Perl_rmsexpand(aTHX_ (char*)path, resolved, NULL, 0);
70 #else
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];
76
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);
89                 return (NULL);
90         }
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;
96                 return (NULL);
97         }
98
99         /*
100          * Iterate over path components in `left'.
101          */
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;
109                 if (s - left >= sizeof(next_token)) {
110                         errno = ENAMETOOLONG;
111                         return (NULL);
112                         }
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);
122                 }
123                         resolved[resolved_len++] = '/';
124                         resolved[resolved_len] = '\0';
125         }
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;
142     }
143
144         /*
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.
148          */
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                                 }
185
186         /*
187                                  * If there are any path components left, then
188                                  * append them to symlink. The result is placed
189                                  * in `left'.
190          */
191                                 if (p != NULL) {
192                                         if (symlink[slen - 1] != '/') {
193                                                 if (slen + 1 >= sizeof(symlink)) {
194                         errno = ENAMETOOLONG;
195                                                         return (NULL);
196                 }
197                                                 symlink[slen] = '/';
198                                                 symlink[slen + 1] = 0;
199         }
200                                         left_len = my_strlcat(symlink, left, sizeof(left));
201                                         if (left_len >= sizeof(left)) {
202                                                 errno = ENAMETOOLONG;
203                                                 return (NULL);
204         }
205         }
206                                 left_len = my_strlcpy(left, symlink, sizeof(left));
207                         }
208                 }
209         #endif
210         }
211
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';
218         return (resolved);
219 #endif
220 }
221
222 #ifndef SV_CWD_RETURN_UNDEF
223 #define SV_CWD_RETURN_UNDEF \
224 sv_setsv(sv, &PL_sv_undef); \
225 return 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
247 #ifndef getcwd_sv
248 /* Taken from perl 5.8's util.c */
249 #define getcwd_sv(a) Perl_getcwd_sv(aTHX_ a)
250 int Perl_getcwd_sv(pTHX_ register SV *sv)
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
277   {
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;
389   }
390 #endif
391
392 #else
393     return FALSE;
394 #endif
395 }
396
397 #endif
398
399
400 MODULE = Cwd            PACKAGE = Cwd
401
402 PROTOTYPES: ENABLE
403
404 void
405 fastcwd()
406 PROTOTYPE: DISABLE
407 PPCODE:
408 {
409     dXSTARG;
410     getcwd_sv(TARG);
411     XSprePUSH; PUSHTARG;
412 #ifndef INCOMPLETE_TAINTS
413     SvTAINTED_on(TARG);
414 #endif
415 }
416
417 void
418 getcwd(...)
419 PROTOTYPE: DISABLE
420 PPCODE:
421 {
422     dXSTARG;
423     getcwd_sv(TARG);
424     XSprePUSH; PUSHTARG;
425 #ifndef INCOMPLETE_TAINTS
426     SvTAINTED_on(TARG);
427 #endif
428 }
429
430 void
431 abs_path(pathsv=Nullsv)
432     SV *pathsv
433 PROTOTYPE: DISABLE
434 PPCODE:
435 {
436     dXSTARG;
437     char *path;
438     char buf[MAXPATHLEN];
439
440     path = pathsv ? SvPV_nolen(pathsv) : (char *)".";
441
442     if (bsd_realpath(path, buf)) {
443         sv_setpvn(TARG, buf, strlen(buf));
444         SvPOK_only(TARG);
445         SvTAINTED_on(TARG);
446     }
447     else
448         sv_setsv(TARG, &PL_sv_undef);
449
450     XSprePUSH; PUSHTARG;
451 #ifndef INCOMPLETE_TAINTS
452     SvTAINTED_on(TARG);
453 #endif
454 }
455
456 #if defined(WIN32) && !defined(UNDER_CE)
457
458 void
459 getdcwd(...)
460 PPCODE:
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
476     New(0,dir,MAXPATHLEN,char);
477     if (_getdcwd(drive, dir, MAXPATHLEN)) {
478         sv_setpvn(TARG, dir, strlen(dir));
479         SvPOK_only(TARG);
480     }
481     else
482         sv_setsv(TARG, &PL_sv_undef);
483
484     Safefree(dir);
485
486     XSprePUSH; PUSHTARG;
487 #ifndef INCOMPLETE_TAINTS
488     SvTAINTED_on(TARG);
489 #endif
490 }
491
492 #endif