This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
9d4dcf0acc85166096c7ec1b4ef2fafd3218f6f6
[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     return retval;
539 }
540
541 MODULE = Cwd            PACKAGE = Cwd
542
543 PROTOTYPES: DISABLE
544
545 BOOT:
546 #if USE_MY_CXT
547 {
548     MY_CXT_INIT;
549     POPULATE_MY_CXT;
550 }
551 #endif
552
553 #if USE_MY_CXT
554
555 void
556 CLONE(...)
557 CODE:
558         PERL_UNUSED_VAR(items);
559         { MY_CXT_CLONE; POPULATE_MY_CXT; }
560
561 #endif
562
563 void
564 getcwd(...)
565 ALIAS:
566     fastcwd=1
567 PPCODE:
568 {
569     dXSTARG;
570     /* fastcwd takes zero parameters:  */
571     if (ix == 1 && items != 0)
572         croak_xs_usage(cv,  "");
573     getcwd_sv(TARG);
574     XSprePUSH; PUSHTARG;
575     SvTAINTED_on(TARG);
576 }
577
578 void
579 abs_path(pathsv=Nullsv)
580     SV *pathsv
581 PPCODE:
582 {
583     dXSTARG;
584     char *const path = pathsv ? SvPV_nolen(pathsv) : (char *)".";
585     char buf[MAXPATHLEN];
586
587     if (
588 #ifdef VMS
589         Perl_rmsexpand(aTHX_ path, buf, NULL, 0)
590 #else
591         bsd_realpath(path, buf)
592 #endif
593     ) {
594         sv_setpv_mg(TARG, buf);
595         SvPOK_only(TARG);
596         SvTAINTED_on(TARG);
597     }
598     else
599         sv_setsv(TARG, &PL_sv_undef);
600
601     XSprePUSH; PUSHs(TARG);
602     SvTAINTED_on(TARG);
603 }
604
605 #if defined(WIN32) && !defined(UNDER_CE)
606
607 void
608 getdcwd(...)
609 PROTOTYPE: ENABLE
610 PPCODE:
611 {
612     dXSTARG;
613     int drive;
614     char *dir;
615
616     /* Drive 0 is the current drive, 1 is A:, 2 is B:, 3 is C: and so on. */
617     if ( items == 0 ||
618         (items == 1 && (!SvOK(ST(0)) || (SvPOK(ST(0)) && !SvCUR(ST(0))))))
619         drive = 0;
620     else if (items == 1 && SvPOK(ST(0)) && SvCUR(ST(0)) &&
621              isALPHA(SvPVX(ST(0))[0]))
622         drive = toUPPER(SvPVX(ST(0))[0]) - 'A' + 1;
623     else
624         croak("Usage: getdcwd(DRIVE)");
625
626     New(0,dir,MAXPATHLEN,char);
627     if (_getdcwd(drive, dir, MAXPATHLEN)) {
628         sv_setpv_mg(TARG, dir);
629         SvPOK_only(TARG);
630     }
631     else
632         sv_setsv(TARG, &PL_sv_undef);
633
634     Safefree(dir);
635
636     XSprePUSH; PUSHs(TARG);
637     SvTAINTED_on(TARG);
638 }
639
640 #endif
641
642 MODULE = Cwd            PACKAGE = File::Spec::Unix
643
644 SV *
645 canonpath(SV *self, SV *path = &PL_sv_undef, ...)
646 CODE:
647     PERL_UNUSED_VAR(self);
648     RETVAL = unix_canonpath(path);
649 OUTPUT:
650     RETVAL
651
652 SV *
653 _fn_canonpath(SV *path = &PL_sv_undef, ...)
654 CODE:
655     RETVAL = unix_canonpath(path);
656 OUTPUT:
657     RETVAL
658
659 SV *
660 catdir(SV *self, ...)
661 PREINIT:
662     dUSE_MY_CXT;
663     SV *joined;
664 CODE:
665     EXTEND(SP, items+1);
666     ST(items) = EMPTY_STRING_SV;
667     joined = sv_newmortal();
668     do_join(joined, SLASH_STRING_SV, &ST(0), &ST(items));
669     if(invocant_is_unix(self)) {
670         RETVAL = unix_canonpath(joined);
671     } else {
672         ENTER;
673         PUSHMARK(SP);
674         EXTEND(SP, 2);
675         PUSHs(self);
676         PUSHs(joined);
677         PUTBACK;
678         call_method("canonpath", G_SCALAR);
679         SPAGAIN;
680         RETVAL = POPs;
681         LEAVE;
682         SvREFCNT_inc(RETVAL);
683     }
684 OUTPUT:
685     RETVAL
686
687 SV *
688 _fn_catdir(...)
689 PREINIT:
690     dUSE_MY_CXT;
691     SV *joined;
692 CODE:
693     EXTEND(SP, items+1);
694     ST(items) = EMPTY_STRING_SV;
695     joined = sv_newmortal();
696     do_join(joined, SLASH_STRING_SV, &ST(-1), &ST(items));
697     RETVAL = unix_canonpath(joined);
698 OUTPUT:
699     RETVAL
700
701 SV *
702 catfile(SV *self, ...)
703 PREINIT:
704     dUSE_MY_CXT;
705 CODE:
706     if(invocant_is_unix(self)) {
707         if(items == 1) {
708             RETVAL = &PL_sv_undef;
709         } else {
710             SV *file = unix_canonpath(ST(items-1));
711             if(items == 2) {
712                 RETVAL = file;
713             } else {
714                 SV *dir = sv_newmortal();
715                 sv_2mortal(file);
716                 ST(items-1) = EMPTY_STRING_SV;
717                 do_join(dir, SLASH_STRING_SV, &ST(0), &ST(items-1));
718                 RETVAL = unix_canonpath(dir);
719                 if(SvCUR(RETVAL) == 0 || SvPVX(RETVAL)[SvCUR(RETVAL)-1] != '/')
720                     sv_catsv(RETVAL, SLASH_STRING_SV);
721                 sv_catsv(RETVAL, file);
722             }
723         }
724     } else {
725         SV *file, *dir;
726         ENTER;
727         PUSHMARK(SP);
728         EXTEND(SP, 2);
729         PUSHs(self);
730         PUSHs(items == 1 ? &PL_sv_undef : ST(items-1));
731         PUTBACK;
732         call_method("canonpath", G_SCALAR);
733         SPAGAIN;
734         file = POPs;
735         LEAVE;
736         if(items <= 2) {
737             RETVAL = SvREFCNT_inc(file);
738         } else {
739             char const *pv;
740             STRLEN len;
741             bool need_slash;
742             SP--;
743             ENTER;
744             PUSHMARK(&ST(-1));
745             PUTBACK;
746             call_method("catdir", G_SCALAR);
747             SPAGAIN;
748             dir = POPs;
749             LEAVE;
750             pv = SvPV(dir, len);
751             need_slash = len == 0 || pv[len-1] != '/';
752             RETVAL = newSVsv(dir);
753             if(need_slash) sv_catsv(RETVAL, SLASH_STRING_SV);
754             sv_catsv(RETVAL, file);
755         }
756     }
757 OUTPUT:
758     RETVAL
759
760 SV *
761 _fn_catfile(...)
762 PREINIT:
763     dUSE_MY_CXT;
764 CODE:
765     if(items == 0) {
766         RETVAL = &PL_sv_undef;
767     } else {
768         SV *file = unix_canonpath(ST(items-1));
769         if(items == 1) {
770             RETVAL = file;
771         } else {
772             SV *dir = sv_newmortal();
773             sv_2mortal(file);
774             ST(items-1) = EMPTY_STRING_SV;
775             do_join(dir, SLASH_STRING_SV, &ST(-1), &ST(items-1));
776             RETVAL = unix_canonpath(dir);
777             if(SvCUR(RETVAL) == 0 || SvPVX(RETVAL)[SvCUR(RETVAL)-1] != '/')
778                 sv_catsv(RETVAL, SLASH_STRING_SV);
779             sv_catsv(RETVAL, file);
780         }
781     }
782 OUTPUT:
783     RETVAL