This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Removed the ifdefs for INCOMPLETE_TAINTS
[perl5.git] / dist / Cwd / Cwd.xs
1 #define PERL_NO_GET_CONTEXT
2
3 #include "EXTERN.h"
4 #include "perl.h"
5 #include "XSUB.h"
6 #define NEED_my_strlcpy
7 #define NEED_my_strlcat
8 #include "ppport.h"
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 #ifndef VMS
59 /*
60  * char *realpath(const char *path, char resolved[MAXPATHLEN]);
61  *
62  * Find the real name of path, by removing all ".", ".." and symlink
63  * components.  Returns (resolved) on success, or (NULL) on failure,
64  * in which case the path which caused trouble is left in (resolved).
65  */
66 static
67 char *
68 bsd_realpath(const char *path, char resolved[MAXPATHLEN])
69 {
70         char *p, *q, *s;
71         size_t left_len, resolved_len;
72         unsigned symlinks;
73         int serrno;
74         char left[MAXPATHLEN], next_token[MAXPATHLEN];
75
76         serrno = errno;
77         symlinks = 0;
78         if (path[0] == '/') {
79                 resolved[0] = '/';
80                 resolved[1] = '\0';
81                 if (path[1] == '\0')
82                         return (resolved);
83                 resolved_len = 1;
84                 left_len = my_strlcpy(left, path + 1, sizeof(left));
85         } else {
86                 if (getcwd(resolved, MAXPATHLEN) == NULL) {
87                         my_strlcpy(resolved, ".", MAXPATHLEN);
88                 return (NULL);
89         }
90                 resolved_len = strlen(resolved);
91                 left_len = my_strlcpy(left, path, sizeof(left));
92         }
93         if (left_len >= sizeof(left) || resolved_len >= MAXPATHLEN) {
94                 errno = ENAMETOOLONG;
95                 return (NULL);
96         }
97
98         /*
99          * Iterate over path components in 'left'.
100          */
101         while (left_len != 0) {
102                 /*
103                  * Extract the next path component and adjust 'left'
104                  * and its length.
105                  */
106                 p = strchr(left, '/');
107                 s = p ? p : left + left_len;
108                 if ((STRLEN)(s - left) >= (STRLEN)sizeof(next_token)) {
109                         errno = ENAMETOOLONG;
110                         return (NULL);
111                         }
112                 memcpy(next_token, left, s - left);
113                 next_token[s - left] = '\0';
114                 left_len -= s - left;
115                 if (p != NULL)
116                         memmove(left, s + 1, left_len + 1);
117                 if (resolved[resolved_len - 1] != '/') {
118                         if (resolved_len + 1 >= MAXPATHLEN) {
119                                 errno = ENAMETOOLONG;
120                                 return (NULL);
121                 }
122                         resolved[resolved_len++] = '/';
123                         resolved[resolved_len] = '\0';
124         }
125                 if (next_token[0] == '\0')
126                         continue;
127                 else if (strcmp(next_token, ".") == 0)
128                         continue;
129                 else if (strcmp(next_token, "..") == 0) {
130                         /*
131                          * Strip the last path component except when we have
132                          * single "/"
133                          */
134                         if (resolved_len > 1) {
135                                 resolved[resolved_len - 1] = '\0';
136                                 q = strrchr(resolved, '/') + 1;
137                                 *q = '\0';
138                                 resolved_len = q - resolved;
139                         }
140                         continue;
141     }
142
143         /*
144                  * Append the next path component and lstat() it. If
145                  * lstat() fails we still can return successfully if
146                  * there are no more path components left.
147          */
148                 resolved_len = my_strlcat(resolved, next_token, MAXPATHLEN);
149                 if (resolved_len >= MAXPATHLEN) {
150                         errno = ENAMETOOLONG;
151                         return (NULL);
152                 }
153 #if defined(HAS_LSTAT) && defined(HAS_READLINK) && defined(HAS_SYMLINK)
154                 {
155                         struct stat sb;
156                         if (lstat(resolved, &sb) != 0) {
157                                 if (errno == ENOENT && p == NULL) {
158                                         errno = serrno;
159                                         return (resolved);
160                                 }
161                                 return (NULL);
162                         }
163                         if (S_ISLNK(sb.st_mode)) {
164                                 int slen;
165                                 char symlink[MAXPATHLEN];
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 ((STRLEN)(slen + 1) >= (STRLEN)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 }
220 #endif
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_ SV *sv)
251 {
252 #ifndef PERL_MICRO
253
254     SvTAINTED_on(sv);
255
256 #ifdef HAS_GETCWD
257     {
258         char buf[MAXPATHLEN];
259
260         /* Some getcwd()s automatically allocate a buffer of the given
261          * size from the heap if they are given a NULL buffer pointer.
262          * The problem is that this behaviour is not portable. */
263         if (getcwd(buf, sizeof(buf) - 1)) {
264             STRLEN len = strlen(buf);
265             sv_setpvn(sv, buf, len);
266             return TRUE;
267         }
268         else {
269             sv_setsv(sv, &PL_sv_undef);
270             return FALSE;
271         }
272     }
273
274 #else
275   {
276     Stat_t statbuf;
277     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
278     int namelen, pathlen=0;
279     DIR *dir;
280     Direntry_t *dp;
281
282     (void)SvUPGRADE(sv, SVt_PV);
283
284     if (PerlLIO_lstat(".", &statbuf) < 0) {
285         SV_CWD_RETURN_UNDEF;
286     }
287
288     orig_cdev = statbuf.st_dev;
289     orig_cino = statbuf.st_ino;
290     cdev = orig_cdev;
291     cino = orig_cino;
292
293     for (;;) {
294         odev = cdev;
295         oino = cino;
296
297         if (PerlDir_chdir("..") < 0) {
298             SV_CWD_RETURN_UNDEF;
299         }
300         if (PerlLIO_stat(".", &statbuf) < 0) {
301             SV_CWD_RETURN_UNDEF;
302         }
303
304         cdev = statbuf.st_dev;
305         cino = statbuf.st_ino;
306
307         if (odev == cdev && oino == cino) {
308             break;
309         }
310         if (!(dir = PerlDir_open("."))) {
311             SV_CWD_RETURN_UNDEF;
312         }
313
314         while ((dp = PerlDir_read(dir)) != NULL) {
315 #ifdef DIRNAMLEN
316             namelen = dp->d_namlen;
317 #else
318             namelen = strlen(dp->d_name);
319 #endif
320             /* skip . and .. */
321             if (SV_CWD_ISDOT(dp)) {
322                 continue;
323             }
324
325             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
326                 SV_CWD_RETURN_UNDEF;
327             }
328
329             tdev = statbuf.st_dev;
330             tino = statbuf.st_ino;
331             if (tino == oino && tdev == odev) {
332                 break;
333             }
334         }
335
336         if (!dp) {
337             SV_CWD_RETURN_UNDEF;
338         }
339
340         if (pathlen + namelen + 1 >= MAXPATHLEN) {
341             SV_CWD_RETURN_UNDEF;
342         }
343
344         SvGROW(sv, pathlen + namelen + 1);
345
346         if (pathlen) {
347             /* shift down */
348             Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
349         }
350
351         /* prepend current directory to the front */
352         *SvPVX(sv) = '/';
353         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
354         pathlen += (namelen + 1);
355
356 #ifdef VOID_CLOSEDIR
357         PerlDir_close(dir);
358 #else
359         if (PerlDir_close(dir) < 0) {
360             SV_CWD_RETURN_UNDEF;
361         }
362 #endif
363     }
364
365     if (pathlen) {
366         SvCUR_set(sv, pathlen);
367         *SvEND(sv) = '\0';
368         SvPOK_only(sv);
369
370         if (PerlDir_chdir(SvPVX(sv)) < 0) {
371             SV_CWD_RETURN_UNDEF;
372         }
373     }
374     if (PerlLIO_stat(".", &statbuf) < 0) {
375         SV_CWD_RETURN_UNDEF;
376     }
377
378     cdev = statbuf.st_dev;
379     cino = statbuf.st_ino;
380
381     if (cdev != orig_cdev || cino != orig_cino) {
382         Perl_croak(aTHX_ "Unstable directory path, "
383                    "current directory changed unexpectedly");
384     }
385
386     return TRUE;
387   }
388 #endif
389
390 #else
391     return FALSE;
392 #endif
393 }
394
395 #endif
396
397 #if defined(START_MY_CXT) && defined(MY_CXT_CLONE)
398 # define USE_MY_CXT 1
399 #else
400 # define USE_MY_CXT 0
401 #endif
402
403 #if USE_MY_CXT
404 # define MY_CXT_KEY "Cwd::_guts"XS_VERSION
405 typedef struct {
406     SV *empty_string_sv, *slash_string_sv;
407 } my_cxt_t;
408 START_MY_CXT
409 # define dUSE_MY_CXT dMY_CXT
410 # define EMPTY_STRING_SV MY_CXT.empty_string_sv
411 # define SLASH_STRING_SV MY_CXT.slash_string_sv
412 # define POPULATE_MY_CXT do { \
413         MY_CXT.empty_string_sv = newSVpvs(""); \
414         MY_CXT.slash_string_sv = newSVpvs("/"); \
415     } while(0)
416 #else
417 # define dUSE_MY_CXT dNOOP
418 # define EMPTY_STRING_SV sv_2mortal(newSVpvs(""))
419 # define SLASH_STRING_SV sv_2mortal(newSVpvs("/"))
420 #endif
421
422 #define invocant_is_unix(i) THX_invocant_is_unix(aTHX_ i)
423 static
424 bool
425 THX_invocant_is_unix(pTHX_ SV *invocant)
426 {
427     /*
428      * This is used to enable optimisations that avoid method calls
429      * by knowing how they would resolve.  False negatives, disabling
430      * the optimisation where it would actually behave correctly, are
431      * acceptable.
432      */
433     return SvPOK(invocant) && SvCUR(invocant) == 16 &&
434         !memcmp(SvPVX(invocant), "File::Spec::Unix", 16);
435 }
436
437 #define unix_canonpath(p) THX_unix_canonpath(aTHX_ p)
438 static
439 SV *
440 THX_unix_canonpath(pTHX_ SV *path)
441 {
442     SV *retval;
443     char const *p, *pe, *q;
444     STRLEN l;
445     char *o;
446     STRLEN plen;
447     SvGETMAGIC(path);
448     if(!SvOK(path)) return &PL_sv_undef;
449     p = SvPV_nomg(path, plen);
450     if(plen == 0) return newSVpvs("");
451     pe = p + plen;
452     retval = newSV(plen);
453 #ifdef SvUTF8
454     if(SvUTF8(path)) SvUTF8_on(retval);
455 #endif
456     o = SvPVX(retval);
457     if(DOUBLE_SLASHES_SPECIAL && p[0] == '/' && p[1] == '/' && p[2] != '/') {
458         q = (const char *) memchr(p+2, '/', pe-(p+2));
459         if(!q) q = pe;
460         l = q - p;
461         memcpy(o, p, l);
462         p = q;
463         o += l;
464     }
465     /*
466      * The transformations performed here are:
467      *   . squeeze multiple slashes
468      *   . eliminate "." segments, except one if that's all there is
469      *   . eliminate leading ".." segments
470      *   . eliminate trailing slash, unless it's all there is
471      */
472     if(p[0] == '/') {
473         *o++ = '/';
474         while(1) {
475             do { p++; } while(p[0] == '/');
476             if(p[0] == '.' && p[1] == '.' && (p+2 == pe || p[2] == '/')) {
477                 p++;
478                 /* advance past second "." next time round loop */
479             } else if(p[0] == '.' && (p+1 == pe || p[1] == '/')) {
480                 /* advance past "." next time round loop */
481             } else {
482                 break;
483             }
484         }
485     } else if(p[0] == '.' && p[1] == '/') {
486         do {
487             p++;
488             do { p++; } while(p[0] == '/');
489         } while(p[0] == '.' && p[1] == '/');
490         if(p == pe) *o++ = '.';
491     }
492     if(p == pe) goto end;
493     while(1) {
494         q = (const char *) memchr(p, '/', pe-p);
495         if(!q) q = pe;
496         l = q - p;
497         memcpy(o, p, l);
498         p = q;
499         o += l;
500         if(p == pe) goto end;
501         while(1) {
502             do { p++; } while(p[0] == '/');
503             if(p == pe) goto end;
504             if(p[0] != '.') break;
505             if(p+1 == pe) goto end;
506             if(p[1] != '/') break;
507             p++;
508         }
509         *o++ = '/';
510     }
511     end: ;
512     *o = 0;
513     SvPOK_on(retval);
514     SvCUR_set(retval, o - SvPVX(retval));
515     return retval;
516 }
517
518 MODULE = Cwd            PACKAGE = Cwd
519
520 PROTOTYPES: DISABLE
521
522 BOOT:
523 #if USE_MY_CXT
524 {
525     MY_CXT_INIT;
526     POPULATE_MY_CXT;
527 }
528 #endif
529
530 #if USE_MY_CXT
531
532 void
533 CLONE(...)
534 CODE:
535         PERL_UNUSED_VAR(items);
536         { MY_CXT_CLONE; POPULATE_MY_CXT; }
537
538 #endif
539
540 void
541 getcwd(...)
542 ALIAS:
543     fastcwd=1
544 PPCODE:
545 {
546     dXSTARG;
547     /* fastcwd takes zero parameters:  */
548     if (ix == 1 && items != 0)
549         croak_xs_usage(cv,  "");
550     getcwd_sv(TARG);
551     XSprePUSH; PUSHTARG;
552     SvTAINTED_on(TARG);
553 }
554
555 void
556 abs_path(pathsv=Nullsv)
557     SV *pathsv
558 PPCODE:
559 {
560     dXSTARG;
561     char *const path = pathsv ? SvPV_nolen(pathsv) : (char *)".";
562     char buf[MAXPATHLEN];
563
564     if (
565 #ifdef VMS
566         Perl_rmsexpand(aTHX_ path, buf, NULL, 0)
567 #else
568         bsd_realpath(path, buf)
569 #endif
570     ) {
571         sv_setpv_mg(TARG, buf);
572         SvPOK_only(TARG);
573         SvTAINTED_on(TARG);
574     }
575     else
576         sv_setsv(TARG, &PL_sv_undef);
577
578     XSprePUSH; PUSHs(TARG);
579     SvTAINTED_on(TARG);
580 }
581
582 #if defined(WIN32) && !defined(UNDER_CE)
583
584 void
585 getdcwd(...)
586 PROTOTYPE: ENABLE
587 PPCODE:
588 {
589     dXSTARG;
590     int drive;
591     char *dir;
592
593     /* Drive 0 is the current drive, 1 is A:, 2 is B:, 3 is C: and so on. */
594     if ( items == 0 ||
595         (items == 1 && (!SvOK(ST(0)) || (SvPOK(ST(0)) && !SvCUR(ST(0))))))
596         drive = 0;
597     else if (items == 1 && SvPOK(ST(0)) && SvCUR(ST(0)) &&
598              isALPHA(SvPVX(ST(0))[0]))
599         drive = toUPPER(SvPVX(ST(0))[0]) - 'A' + 1;
600     else
601         croak("Usage: getdcwd(DRIVE)");
602
603     New(0,dir,MAXPATHLEN,char);
604     if (_getdcwd(drive, dir, MAXPATHLEN)) {
605         sv_setpv_mg(TARG, dir);
606         SvPOK_only(TARG);
607     }
608     else
609         sv_setsv(TARG, &PL_sv_undef);
610
611     Safefree(dir);
612
613     XSprePUSH; PUSHs(TARG);
614     SvTAINTED_on(TARG);
615 }
616
617 #endif
618
619 MODULE = Cwd            PACKAGE = File::Spec::Unix
620
621 SV *
622 canonpath(SV *self, SV *path = &PL_sv_undef, ...)
623 CODE:
624     PERL_UNUSED_VAR(self);
625     RETVAL = unix_canonpath(path);
626 OUTPUT:
627     RETVAL
628
629 SV *
630 _fn_canonpath(SV *path = &PL_sv_undef, ...)
631 CODE:
632     RETVAL = unix_canonpath(path);
633 OUTPUT:
634     RETVAL
635
636 SV *
637 catdir(SV *self, ...)
638 PREINIT:
639     dUSE_MY_CXT;
640     SV *joined;
641 CODE:
642     EXTEND(SP, items+1);
643     ST(items) = EMPTY_STRING_SV;
644     joined = sv_newmortal();
645     do_join(joined, SLASH_STRING_SV, &ST(0), &ST(items));
646     if(invocant_is_unix(self)) {
647         RETVAL = unix_canonpath(joined);
648     } else {
649         ENTER;
650         PUSHMARK(SP);
651         EXTEND(SP, 2);
652         PUSHs(self);
653         PUSHs(joined);
654         PUTBACK;
655         call_method("canonpath", G_SCALAR);
656         SPAGAIN;
657         RETVAL = POPs;
658         LEAVE;
659         SvREFCNT_inc(RETVAL);
660     }
661 OUTPUT:
662     RETVAL
663
664 SV *
665 _fn_catdir(...)
666 PREINIT:
667     dUSE_MY_CXT;
668     SV *joined;
669 CODE:
670     EXTEND(SP, items+1);
671     ST(items) = EMPTY_STRING_SV;
672     joined = sv_newmortal();
673     do_join(joined, SLASH_STRING_SV, &ST(-1), &ST(items));
674     RETVAL = unix_canonpath(joined);
675 OUTPUT:
676     RETVAL
677
678 SV *
679 catfile(SV *self, ...)
680 PREINIT:
681     dUSE_MY_CXT;
682 CODE:
683     if(invocant_is_unix(self)) {
684         if(items == 1) {
685             RETVAL = &PL_sv_undef;
686         } else {
687             SV *file = unix_canonpath(ST(items-1));
688             if(items == 2) {
689                 RETVAL = file;
690             } else {
691                 SV *dir = sv_newmortal();
692                 sv_2mortal(file);
693                 ST(items-1) = EMPTY_STRING_SV;
694                 do_join(dir, SLASH_STRING_SV, &ST(0), &ST(items-1));
695                 RETVAL = unix_canonpath(dir);
696                 if(SvCUR(RETVAL) == 0 || SvPVX(RETVAL)[SvCUR(RETVAL)-1] != '/')
697                     sv_catsv(RETVAL, SLASH_STRING_SV);
698                 sv_catsv(RETVAL, file);
699             }
700         }
701     } else {
702         SV *file, *dir;
703         ENTER;
704         PUSHMARK(SP);
705         EXTEND(SP, 2);
706         PUSHs(self);
707         PUSHs(items == 1 ? &PL_sv_undef : ST(items-1));
708         PUTBACK;
709         call_method("canonpath", G_SCALAR);
710         SPAGAIN;
711         file = POPs;
712         LEAVE;
713         if(items <= 2) {
714             RETVAL = SvREFCNT_inc(file);
715         } else {
716             char const *pv;
717             STRLEN len;
718             bool need_slash;
719             SP--;
720             ENTER;
721             PUSHMARK(&ST(-1));
722             PUTBACK;
723             call_method("catdir", G_SCALAR);
724             SPAGAIN;
725             dir = POPs;
726             LEAVE;
727             pv = SvPV(dir, len);
728             need_slash = len == 0 || pv[len-1] != '/';
729             RETVAL = newSVsv(dir);
730             if(need_slash) sv_catsv(RETVAL, SLASH_STRING_SV);
731             sv_catsv(RETVAL, file);
732         }
733     }
734 OUTPUT:
735     RETVAL
736
737 SV *
738 _fn_catfile(...)
739 PREINIT:
740     dUSE_MY_CXT;
741 CODE:
742     if(items == 0) {
743         RETVAL = &PL_sv_undef;
744     } else {
745         SV *file = unix_canonpath(ST(items-1));
746         if(items == 1) {
747             RETVAL = file;
748         } else {
749             SV *dir = sv_newmortal();
750             sv_2mortal(file);
751             ST(items-1) = EMPTY_STRING_SV;
752             do_join(dir, SLASH_STRING_SV, &ST(-1), &ST(items-1));
753             RETVAL = unix_canonpath(dir);
754             if(SvCUR(RETVAL) == 0 || SvPVX(RETVAL)[SvCUR(RETVAL)-1] != '/')
755                 sv_catsv(RETVAL, SLASH_STRING_SV);
756             sv_catsv(RETVAL, file);
757         }
758     }
759 OUTPUT:
760     RETVAL