This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
ensure File::Spec::canonpath() preserves taint
[perl5.git] / dist / PathTools / Cwd.xs
1 /*
2  * ex: set ts=8 sts=4 sw=4 et:
3  */
4
5 #define PERL_NO_GET_CONTEXT
6
7 #include "EXTERN.h"
8 #include "perl.h"
9 #include "XSUB.h"
10 #define NEED_my_strlcpy
11 #define NEED_my_strlcat
12 #include "ppport.h"
13
14 #ifdef I_UNISTD
15 #   include <unistd.h>
16 #endif
17
18 /* For special handling of os390 sysplexed systems */
19 #define SYSNAME "$SYSNAME"
20 #define SYSNAME_LEN (sizeof(SYSNAME) - 1)
21
22 /* The realpath() implementation from OpenBSD 3.9 to 4.2 (realpath.c 1.13)
23  * Renamed here to bsd_realpath() to avoid library conflicts.
24  */
25
26 /* See
27  * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2004-11/msg00979.html
28  * for the details of why the BSD license is compatible with the
29  * AL/GPL standard perl license.
30  */
31
32 /*
33  * Copyright (c) 2003 Constantin S. Svintsoff <kostik@iclub.nsu.ru>
34  *
35  * Redistribution and use in source and binary forms, with or without
36  * modification, are permitted provided that the following conditions
37  * are met:
38  * 1. Redistributions of source code must retain the above copyright
39  *    notice, this list of conditions and the following disclaimer.
40  * 2. Redistributions in binary form must reproduce the above copyright
41  *    notice, this list of conditions and the following disclaimer in the
42  *    documentation and/or other materials provided with the distribution.
43  * 3. The names of the authors may not be used to endorse or promote
44  *    products derived from this software without specific prior written
45  *    permission.
46  *
47  * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND
48  * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
49  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
50  * ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
51  * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
52  * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
53  * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
54  * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
55  * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
56  * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
57  * SUCH DAMAGE.
58  */
59
60 /* OpenBSD system #includes removed since the Perl ones should do. --jhi */
61
62 #ifndef MAXSYMLINKS
63 #define MAXSYMLINKS 8
64 #endif
65
66 #ifndef VMS
67 /*
68  * char *realpath(const char *path, char resolved[MAXPATHLEN]);
69  *
70  * Find the real name of path, by removing all ".", ".." and symlink
71  * components.  Returns (resolved) on success, or (NULL) on failure,
72  * in which case the path which caused trouble is left in (resolved).
73  */
74 static
75 char *
76 bsd_realpath(const char *path, char resolved[MAXPATHLEN])
77 {
78         char *p, *q, *s;
79         size_t remaining_len, resolved_len;
80         unsigned symlinks;
81         int serrno;
82         char remaining[MAXPATHLEN], next_token[MAXPATHLEN];
83
84         serrno = errno;
85         symlinks = 0;
86         if (path[0] == '/') {
87             resolved[0] = '/';
88             resolved[1] = '\0';
89             if (path[1] == '\0')
90                     return (resolved);
91             resolved_len = 1;
92             remaining_len = my_strlcpy(remaining, path + 1, sizeof(remaining));
93         } else {
94             if (getcwd(resolved, MAXPATHLEN) == NULL) {
95                 my_strlcpy(resolved, ".", MAXPATHLEN);
96                 return (NULL);
97             }
98             resolved_len = strlen(resolved);
99             remaining_len = my_strlcpy(remaining, path, sizeof(remaining));
100         }
101         if (remaining_len >= sizeof(remaining) || resolved_len >= MAXPATHLEN) {
102             errno = ENAMETOOLONG;
103             return (NULL);
104         }
105
106         /*
107          * Iterate over path components in 'remaining'.
108          */
109         while (remaining_len != 0) {
110
111             /*
112              * Extract the next path component and adjust 'remaining'
113              * and its length.
114              */
115
116             p = strchr(remaining, '/');
117             s = p ? p : remaining + remaining_len;
118             if ((STRLEN)(s - remaining) >= (STRLEN)sizeof(next_token)) {
119                 errno = ENAMETOOLONG;
120                 return (NULL);
121             }
122             memcpy(next_token, remaining, s - remaining);
123             next_token[s - remaining] = '\0';
124             remaining_len -= s - remaining;
125             if (p != NULL)
126                 memmove(remaining, s + 1, remaining_len + 1);
127             if (resolved[resolved_len - 1] != '/') {
128                 if (resolved_len + 1 >= MAXPATHLEN) {
129                     errno = ENAMETOOLONG;
130                     return (NULL);
131                 }
132                 resolved[resolved_len++] = '/';
133                 resolved[resolved_len] = '\0';
134             }
135             if (next_token[0] == '\0')
136                 continue;
137             else if (strcmp(next_token, ".") == 0)
138                 continue;
139             else if (strcmp(next_token, "..") == 0) {
140                 /*
141                  * Strip the last path component except when we have
142                  * single "/"
143                  */
144                 if (resolved_len > 1) {
145                     resolved[resolved_len - 1] = '\0';
146                     q = strrchr(resolved, '/') + 1;
147                     *q = '\0';
148                     resolved_len = q - resolved;
149                 }
150                 continue;
151             }
152
153             /*
154              * Append the next path component and lstat() it. If
155              * lstat() fails we still can return successfully if
156              * there are no more path components left.
157              */
158             resolved_len = my_strlcat(resolved, next_token, MAXPATHLEN);
159             if (resolved_len >= MAXPATHLEN) {
160                 errno = ENAMETOOLONG;
161                 return (NULL);
162             }
163 #if defined(HAS_LSTAT) && defined(HAS_READLINK) && defined(HAS_SYMLINK)
164             {
165                 struct stat sb;
166                 if (lstat(resolved, &sb) != 0) {
167                     if (errno == ENOENT && p == NULL) {
168                         errno = serrno;
169                         return (resolved);
170                     }
171                     return (NULL);
172                 }
173                 if (S_ISLNK(sb.st_mode)) {
174                     int slen;
175                     char symlink[MAXPATHLEN];
176
177                     if (symlinks++ > MAXSYMLINKS) {
178                         errno = ELOOP;
179                         return (NULL);
180                     }
181                     slen = readlink(resolved, symlink, sizeof(symlink) - 1);
182                     if (slen < 0)
183                         return (NULL);
184                     symlink[slen] = '\0';
185 #  ifdef EBCDIC /* XXX Probably this should be only os390 */
186                     /* Replace all instances of $SYSNAME/foo simply by /foo */
187                     if (slen > SYSNAME_LEN + strlen(next_token)
188                         && strnEQ(symlink, SYSNAME, SYSNAME_LEN)
189                         && *(symlink + SYSNAME_LEN) == '/'
190                         && strEQ(symlink + SYSNAME_LEN + 1, next_token))
191                     {
192                         goto not_symlink;
193                     }
194 #  endif
195                     if (symlink[0] == '/') {
196                         resolved[1] = 0;
197                         resolved_len = 1;
198                     } else if (resolved_len > 1) {
199                         /* Strip the last path component. */
200                         resolved[resolved_len - 1] = '\0';
201                         q = strrchr(resolved, '/') + 1;
202                         *q = '\0';
203                         resolved_len = q - resolved;
204                     }
205
206                     /*
207                      * If there are any path components left, then
208                      * append them to symlink. The result is placed
209                      * in 'remaining'.
210                      */
211                     if (p != NULL) {
212                         if (symlink[slen - 1] != '/') {
213                             if ((STRLEN)(slen + 1) >= (STRLEN)sizeof(symlink)) {
214                                 errno = ENAMETOOLONG;
215                                 return (NULL);
216                             }
217                             symlink[slen] = '/';
218                             symlink[slen + 1] = 0;
219                         }
220                         remaining_len = my_strlcat(symlink, remaining, sizeof(symlink));
221                         if (remaining_len >= sizeof(remaining)) {
222                             errno = ENAMETOOLONG;
223                             return (NULL);
224                         }
225                     }
226                     remaining_len = my_strlcpy(remaining, symlink, sizeof(remaining));
227                 }
228 #  ifdef EBCDIC
229               not_symlink: ;
230 #  endif
231             }
232 #endif
233         }
234
235         /*
236          * Remove trailing slash except when the resolved pathname
237          * is a single "/".
238          */
239         if (resolved_len > 1 && resolved[resolved_len - 1] == '/')
240             resolved[resolved_len - 1] = '\0';
241         return (resolved);
242 }
243 #endif
244
245 #ifndef SV_CWD_RETURN_UNDEF
246 #define SV_CWD_RETURN_UNDEF \
247 sv_setsv(sv, &PL_sv_undef); \
248 return FALSE
249 #endif
250
251 #ifndef OPpENTERSUB_HASTARG
252 #define OPpENTERSUB_HASTARG     32      /* Called from OP tree. */
253 #endif
254
255 #ifndef dXSTARG
256 #define dXSTARG SV * targ = ((PL_op->op_private & OPpENTERSUB_HASTARG) \
257                              ? PAD_SV(PL_op->op_targ) : sv_newmortal())
258 #endif
259
260 #ifndef XSprePUSH
261 #define XSprePUSH (sp = PL_stack_base + ax - 1)
262 #endif
263
264 #ifndef SV_CWD_ISDOT
265 #define SV_CWD_ISDOT(dp) \
266     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
267         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
268 #endif
269
270 #ifndef getcwd_sv
271 /* Taken from perl 5.8's util.c */
272 #define getcwd_sv(a) Perl_getcwd_sv(aTHX_ a)
273 int Perl_getcwd_sv(pTHX_ SV *sv)
274 {
275 #ifndef PERL_MICRO
276
277     SvTAINTED_on(sv);
278
279 #ifdef HAS_GETCWD
280     {
281         char buf[MAXPATHLEN];
282
283         /* Some getcwd()s automatically allocate a buffer of the given
284          * size from the heap if they are given a NULL buffer pointer.
285          * The problem is that this behaviour is not portable. */
286         if (getcwd(buf, sizeof(buf) - 1)) {
287             STRLEN len = strlen(buf);
288             sv_setpvn(sv, buf, len);
289             return TRUE;
290         }
291         else {
292             sv_setsv(sv, &PL_sv_undef);
293             return FALSE;
294         }
295     }
296
297 #else
298   {
299     Stat_t statbuf;
300     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
301     int namelen, pathlen=0;
302     DIR *dir;
303     Direntry_t *dp;
304
305     (void)SvUPGRADE(sv, SVt_PV);
306
307     if (PerlLIO_lstat(".", &statbuf) < 0) {
308         SV_CWD_RETURN_UNDEF;
309     }
310
311     orig_cdev = statbuf.st_dev;
312     orig_cino = statbuf.st_ino;
313     cdev = orig_cdev;
314     cino = orig_cino;
315
316     for (;;) {
317         odev = cdev;
318         oino = cino;
319
320         if (PerlDir_chdir("..") < 0) {
321             SV_CWD_RETURN_UNDEF;
322         }
323         if (PerlLIO_stat(".", &statbuf) < 0) {
324             SV_CWD_RETURN_UNDEF;
325         }
326
327         cdev = statbuf.st_dev;
328         cino = statbuf.st_ino;
329
330         if (odev == cdev && oino == cino) {
331             break;
332         }
333         if (!(dir = PerlDir_open("."))) {
334             SV_CWD_RETURN_UNDEF;
335         }
336
337         while ((dp = PerlDir_read(dir)) != NULL) {
338 #ifdef DIRNAMLEN
339             namelen = dp->d_namlen;
340 #else
341             namelen = strlen(dp->d_name);
342 #endif
343             /* skip . and .. */
344             if (SV_CWD_ISDOT(dp)) {
345                 continue;
346             }
347
348             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
349                 SV_CWD_RETURN_UNDEF;
350             }
351
352             tdev = statbuf.st_dev;
353             tino = statbuf.st_ino;
354             if (tino == oino && tdev == odev) {
355                 break;
356             }
357         }
358
359         if (!dp) {
360             SV_CWD_RETURN_UNDEF;
361         }
362
363         if (pathlen + namelen + 1 >= MAXPATHLEN) {
364             SV_CWD_RETURN_UNDEF;
365         }
366
367         SvGROW(sv, pathlen + namelen + 1);
368
369         if (pathlen) {
370             /* shift down */
371             Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
372         }
373
374         /* prepend current directory to the front */
375         *SvPVX(sv) = '/';
376         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
377         pathlen += (namelen + 1);
378
379 #ifdef VOID_CLOSEDIR
380         PerlDir_close(dir);
381 #else
382         if (PerlDir_close(dir) < 0) {
383             SV_CWD_RETURN_UNDEF;
384         }
385 #endif
386     }
387
388     if (pathlen) {
389         SvCUR_set(sv, pathlen);
390         *SvEND(sv) = '\0';
391         SvPOK_only(sv);
392
393         if (PerlDir_chdir(SvPVX(sv)) < 0) {
394             SV_CWD_RETURN_UNDEF;
395         }
396     }
397     if (PerlLIO_stat(".", &statbuf) < 0) {
398         SV_CWD_RETURN_UNDEF;
399     }
400
401     cdev = statbuf.st_dev;
402     cino = statbuf.st_ino;
403
404     if (cdev != orig_cdev || cino != orig_cino) {
405         Perl_croak(aTHX_ "Unstable directory path, "
406                    "current directory changed unexpectedly");
407     }
408
409     return TRUE;
410   }
411 #endif
412
413 #else
414     return FALSE;
415 #endif
416 }
417
418 #endif
419
420 #if defined(START_MY_CXT) && defined(MY_CXT_CLONE)
421 # define USE_MY_CXT 1
422 #else
423 # define USE_MY_CXT 0
424 #endif
425
426 #if USE_MY_CXT
427 # define MY_CXT_KEY "Cwd::_guts"XS_VERSION
428 typedef struct {
429     SV *empty_string_sv, *slash_string_sv;
430 } my_cxt_t;
431 START_MY_CXT
432 # define dUSE_MY_CXT dMY_CXT
433 # define EMPTY_STRING_SV MY_CXT.empty_string_sv
434 # define SLASH_STRING_SV MY_CXT.slash_string_sv
435 # define POPULATE_MY_CXT do { \
436         MY_CXT.empty_string_sv = newSVpvs(""); \
437         MY_CXT.slash_string_sv = newSVpvs("/"); \
438     } while(0)
439 #else
440 # define dUSE_MY_CXT dNOOP
441 # define EMPTY_STRING_SV sv_2mortal(newSVpvs(""))
442 # define SLASH_STRING_SV sv_2mortal(newSVpvs("/"))
443 #endif
444
445 #define invocant_is_unix(i) THX_invocant_is_unix(aTHX_ i)
446 static
447 bool
448 THX_invocant_is_unix(pTHX_ SV *invocant)
449 {
450     /*
451      * This is used to enable optimisations that avoid method calls
452      * by knowing how they would resolve.  False negatives, disabling
453      * the optimisation where it would actually behave correctly, are
454      * acceptable.
455      */
456     return SvPOK(invocant) && SvCUR(invocant) == 16 &&
457         !memcmp(SvPVX(invocant), "File::Spec::Unix", 16);
458 }
459
460 #define unix_canonpath(p) THX_unix_canonpath(aTHX_ p)
461 static
462 SV *
463 THX_unix_canonpath(pTHX_ SV *path)
464 {
465     SV *retval;
466     char const *p, *pe, *q;
467     STRLEN l;
468     char *o;
469     STRLEN plen;
470     SvGETMAGIC(path);
471     if(!SvOK(path)) return &PL_sv_undef;
472     p = SvPV_nomg(path, plen);
473     if(plen == 0) return newSVpvs("");
474     pe = p + plen;
475     retval = newSV(plen);
476 #ifdef SvUTF8
477     if(SvUTF8(path)) SvUTF8_on(retval);
478 #endif
479     o = SvPVX(retval);
480     if(DOUBLE_SLASHES_SPECIAL && p[0] == '/' && p[1] == '/' && p[2] != '/') {
481         q = (const char *) memchr(p+2, '/', pe-(p+2));
482         if(!q) q = pe;
483         l = q - p;
484         memcpy(o, p, l);
485         p = q;
486         o += l;
487     }
488     /*
489      * The transformations performed here are:
490      *   . squeeze multiple slashes
491      *   . eliminate "." segments, except one if that's all there is
492      *   . eliminate leading ".." segments
493      *   . eliminate trailing slash, unless it's all there is
494      */
495     if(p[0] == '/') {
496         *o++ = '/';
497         while(1) {
498             do { p++; } while(p[0] == '/');
499             if(p[0] == '.' && p[1] == '.' && (p+2 == pe || p[2] == '/')) {
500                 p++;
501                 /* advance past second "." next time round loop */
502             } else if(p[0] == '.' && (p+1 == pe || p[1] == '/')) {
503                 /* advance past "." next time round loop */
504             } else {
505                 break;
506             }
507         }
508     } else if(p[0] == '.' && p[1] == '/') {
509         do {
510             p++;
511             do { p++; } while(p[0] == '/');
512         } while(p[0] == '.' && p[1] == '/');
513         if(p == pe) *o++ = '.';
514     }
515     if(p == pe) goto end;
516     while(1) {
517         q = (const char *) memchr(p, '/', pe-p);
518         if(!q) q = pe;
519         l = q - p;
520         memcpy(o, p, l);
521         p = q;
522         o += l;
523         if(p == pe) goto end;
524         while(1) {
525             do { p++; } while(p[0] == '/');
526             if(p == pe) goto end;
527             if(p[0] != '.') break;
528             if(p+1 == pe) goto end;
529             if(p[1] != '/') break;
530             p++;
531         }
532         *o++ = '/';
533     }
534     end: ;
535     *o = 0;
536     SvPOK_on(retval);
537     SvCUR_set(retval, o - SvPVX(retval));
538     SvTAINT(retval);
539     return retval;
540 }
541
542 MODULE = Cwd            PACKAGE = Cwd
543
544 PROTOTYPES: DISABLE
545
546 BOOT:
547 #if USE_MY_CXT
548 {
549     MY_CXT_INIT;
550     POPULATE_MY_CXT;
551 }
552 #endif
553
554 #if USE_MY_CXT
555
556 void
557 CLONE(...)
558 CODE:
559         PERL_UNUSED_VAR(items);
560         { MY_CXT_CLONE; POPULATE_MY_CXT; }
561
562 #endif
563
564 void
565 getcwd(...)
566 ALIAS:
567     fastcwd=1
568 PPCODE:
569 {
570     dXSTARG;
571     /* fastcwd takes zero parameters:  */
572     if (ix == 1 && items != 0)
573         croak_xs_usage(cv,  "");
574     getcwd_sv(TARG);
575     XSprePUSH; PUSHTARG;
576     SvTAINTED_on(TARG);
577 }
578
579 void
580 abs_path(pathsv=Nullsv)
581     SV *pathsv
582 PPCODE:
583 {
584     dXSTARG;
585     char *const path = pathsv ? SvPV_nolen(pathsv) : (char *)".";
586     char buf[MAXPATHLEN];
587
588     if (
589 #ifdef VMS
590         Perl_rmsexpand(aTHX_ path, buf, NULL, 0)
591 #else
592         bsd_realpath(path, buf)
593 #endif
594     ) {
595         sv_setpv_mg(TARG, buf);
596         SvPOK_only(TARG);
597         SvTAINTED_on(TARG);
598     }
599     else
600         sv_setsv(TARG, &PL_sv_undef);
601
602     XSprePUSH; PUSHs(TARG);
603     SvTAINTED_on(TARG);
604 }
605
606 #if defined(WIN32) && !defined(UNDER_CE)
607
608 void
609 getdcwd(...)
610 PROTOTYPE: ENABLE
611 PPCODE:
612 {
613     dXSTARG;
614     int drive;
615     char *dir;
616
617     /* Drive 0 is the current drive, 1 is A:, 2 is B:, 3 is C: and so on. */
618     if ( items == 0 ||
619         (items == 1 && (!SvOK(ST(0)) || (SvPOK(ST(0)) && !SvCUR(ST(0))))))
620         drive = 0;
621     else if (items == 1 && SvPOK(ST(0)) && SvCUR(ST(0)) &&
622              isALPHA(SvPVX(ST(0))[0]))
623         drive = toUPPER(SvPVX(ST(0))[0]) - 'A' + 1;
624     else
625         croak("Usage: getdcwd(DRIVE)");
626
627     New(0,dir,MAXPATHLEN,char);
628     if (_getdcwd(drive, dir, MAXPATHLEN)) {
629         sv_setpv_mg(TARG, dir);
630         SvPOK_only(TARG);
631     }
632     else
633         sv_setsv(TARG, &PL_sv_undef);
634
635     Safefree(dir);
636
637     XSprePUSH; PUSHs(TARG);
638     SvTAINTED_on(TARG);
639 }
640
641 #endif
642
643 MODULE = Cwd            PACKAGE = File::Spec::Unix
644
645 SV *
646 canonpath(SV *self, SV *path = &PL_sv_undef, ...)
647 CODE:
648     PERL_UNUSED_VAR(self);
649     RETVAL = unix_canonpath(path);
650 OUTPUT:
651     RETVAL
652
653 SV *
654 _fn_canonpath(SV *path = &PL_sv_undef, ...)
655 CODE:
656     RETVAL = unix_canonpath(path);
657 OUTPUT:
658     RETVAL
659
660 SV *
661 catdir(SV *self, ...)
662 PREINIT:
663     dUSE_MY_CXT;
664     SV *joined;
665 CODE:
666     EXTEND(SP, items+1);
667     ST(items) = EMPTY_STRING_SV;
668     joined = sv_newmortal();
669     do_join(joined, SLASH_STRING_SV, &ST(0), &ST(items));
670     if(invocant_is_unix(self)) {
671         RETVAL = unix_canonpath(joined);
672     } else {
673         ENTER;
674         PUSHMARK(SP);
675         EXTEND(SP, 2);
676         PUSHs(self);
677         PUSHs(joined);
678         PUTBACK;
679         call_method("canonpath", G_SCALAR);
680         SPAGAIN;
681         RETVAL = POPs;
682         LEAVE;
683         SvREFCNT_inc(RETVAL);
684     }
685 OUTPUT:
686     RETVAL
687
688 SV *
689 _fn_catdir(...)
690 PREINIT:
691     dUSE_MY_CXT;
692     SV *joined;
693 CODE:
694     EXTEND(SP, items+1);
695     ST(items) = EMPTY_STRING_SV;
696     joined = sv_newmortal();
697     do_join(joined, SLASH_STRING_SV, &ST(-1), &ST(items));
698     RETVAL = unix_canonpath(joined);
699 OUTPUT:
700     RETVAL
701
702 SV *
703 catfile(SV *self, ...)
704 PREINIT:
705     dUSE_MY_CXT;
706 CODE:
707     if(invocant_is_unix(self)) {
708         if(items == 1) {
709             RETVAL = &PL_sv_undef;
710         } else {
711             SV *file = unix_canonpath(ST(items-1));
712             if(items == 2) {
713                 RETVAL = file;
714             } else {
715                 SV *dir = sv_newmortal();
716                 sv_2mortal(file);
717                 ST(items-1) = EMPTY_STRING_SV;
718                 do_join(dir, SLASH_STRING_SV, &ST(0), &ST(items-1));
719                 RETVAL = unix_canonpath(dir);
720                 if(SvCUR(RETVAL) == 0 || SvPVX(RETVAL)[SvCUR(RETVAL)-1] != '/')
721                     sv_catsv(RETVAL, SLASH_STRING_SV);
722                 sv_catsv(RETVAL, file);
723             }
724         }
725     } else {
726         SV *file, *dir;
727         ENTER;
728         PUSHMARK(SP);
729         EXTEND(SP, 2);
730         PUSHs(self);
731         PUSHs(items == 1 ? &PL_sv_undef : ST(items-1));
732         PUTBACK;
733         call_method("canonpath", G_SCALAR);
734         SPAGAIN;
735         file = POPs;
736         LEAVE;
737         if(items <= 2) {
738             RETVAL = SvREFCNT_inc(file);
739         } else {
740             char const *pv;
741             STRLEN len;
742             bool need_slash;
743             SP--;
744             ENTER;
745             PUSHMARK(&ST(-1));
746             PUTBACK;
747             call_method("catdir", G_SCALAR);
748             SPAGAIN;
749             dir = POPs;
750             LEAVE;
751             pv = SvPV(dir, len);
752             need_slash = len == 0 || pv[len-1] != '/';
753             RETVAL = newSVsv(dir);
754             if(need_slash) sv_catsv(RETVAL, SLASH_STRING_SV);
755             sv_catsv(RETVAL, file);
756         }
757     }
758 OUTPUT:
759     RETVAL
760
761 SV *
762 _fn_catfile(...)
763 PREINIT:
764     dUSE_MY_CXT;
765 CODE:
766     if(items == 0) {
767         RETVAL = &PL_sv_undef;
768     } else {
769         SV *file = unix_canonpath(ST(items-1));
770         if(items == 1) {
771             RETVAL = file;
772         } else {
773             SV *dir = sv_newmortal();
774             sv_2mortal(file);
775             ST(items-1) = EMPTY_STRING_SV;
776             do_join(dir, SLASH_STRING_SV, &ST(-1), &ST(items-1));
777             RETVAL = unix_canonpath(dir);
778             if(SvCUR(RETVAL) == 0 || SvPVX(RETVAL)[SvCUR(RETVAL)-1] != '/')
779                 sv_catsv(RETVAL, SLASH_STRING_SV);
780             sv_catsv(RETVAL, file);
781         }
782     }
783 OUTPUT:
784     RETVAL