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