This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
dc3da184f6de08dffaaeb63d095d1fc2cc02d258
[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 #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 #if defined(START_MY_CXT) && defined(MY_CXT_CLONE)
400 # define USE_MY_CXT 1
401 #else
402 # define USE_MY_CXT 0
403 #endif
404
405 #if USE_MY_CXT
406 # define MY_CXT_KEY "Cwd::_guts"XS_VERSION
407 typedef struct {
408     SV *empty_string_sv, *slash_string_sv;
409 } my_cxt_t;
410 START_MY_CXT
411 # define dUSE_MY_CXT dMY_CXT
412 # define EMPTY_STRING_SV MY_CXT.empty_string_sv
413 # define SLASH_STRING_SV MY_CXT.slash_string_sv
414 # define POPULATE_MY_CXT do { \
415         MY_CXT.empty_string_sv = newSVpvs(""); \
416         MY_CXT.slash_string_sv = newSVpvs("/"); \
417     } while(0)
418 #else
419 # define dUSE_MY_CXT dNOOP
420 # define EMPTY_STRING_SV sv_2mortal(newSVpvs(""))
421 # define SLASH_STRING_SV sv_2mortal(newSVpvs("/"))
422 #endif
423
424 #define invocant_is_unix(i) THX_invocant_is_unix(aTHX_ i)
425 static
426 bool
427 THX_invocant_is_unix(pTHX_ SV *invocant)
428 {
429     /*
430      * This is used to enable optimisations that avoid method calls
431      * by knowing how they would resolve.  False negatives, disabling
432      * the optimisation where it would actually behave correctly, are
433      * acceptable.
434      */
435     return SvPOK(invocant) && SvCUR(invocant) == 16 &&
436         !memcmp(SvPVX(invocant), "File::Spec::Unix", 16);
437 }
438
439 #define unix_canonpath(p) THX_unix_canonpath(aTHX_ p)
440 static
441 SV *
442 THX_unix_canonpath(pTHX_ SV *path)
443 {
444     SV *retval;
445     char const *p, *pe, *q;
446     STRLEN l;
447     char *o;
448     STRLEN plen;
449     SvGETMAGIC(path);
450     if(!SvOK(path)) return &PL_sv_undef;
451     p = SvPV_nomg(path, plen);
452     if(plen == 0) return newSVpvs("");
453     pe = p + plen;
454     retval = newSV(plen);
455 #ifdef SvUTF8
456     if(SvUTF8(path)) SvUTF8_on(retval);
457 #endif
458     o = SvPVX(retval);
459     if(DOUBLE_SLASHES_SPECIAL && p[0] == '/' && p[1] == '/' && p[2] != '/') {
460         q = (const char *) memchr(p+2, '/', pe-(p+2));
461         if(!q) q = pe;
462         l = q - p;
463         memcpy(o, p, l);
464         p = q;
465         o += l;
466     }
467     /*
468      * The transformations performed here are:
469      *   . squeeze multiple slashes
470      *   . eliminate "." segments, except one if that's all there is
471      *   . eliminate leading ".." segments
472      *   . eliminate trailing slash, unless it's all there is
473      */
474     if(p[0] == '/') {
475         *o++ = '/';
476         while(1) {
477             do { p++; } while(p[0] == '/');
478             if(p[0] == '.' && p[1] == '.' && (p+2 == pe || p[2] == '/')) {
479                 p++;
480                 /* advance past second "." next time round loop */
481             } else if(p[0] == '.' && (p+1 == pe || p[1] == '/')) {
482                 /* advance past "." next time round loop */
483             } else {
484                 break;
485             }
486         }
487     } else if(p[0] == '.' && p[1] == '/') {
488         do {
489             p++;
490             do { p++; } while(p[0] == '/');
491         } while(p[0] == '.' && p[1] == '/');
492         if(p == pe) *o++ = '.';
493     }
494     if(p == pe) goto end;
495     while(1) {
496         q = (const char *) memchr(p, '/', pe-p);
497         if(!q) q = pe;
498         l = q - p;
499         memcpy(o, p, l);
500         p = q;
501         o += l;
502         if(p == pe) goto end;
503         while(1) {
504             do { p++; } while(p[0] == '/');
505             if(p == pe) goto end;
506             if(p[0] != '.') break;
507             if(p+1 == pe) goto end;
508             if(p[1] != '/') break;
509             p++;
510         }
511         *o++ = '/';
512     }
513     end: ;
514     *o = 0;
515     SvPOK_on(retval);
516     SvCUR_set(retval, o - SvPVX(retval));
517     return retval;
518 }
519
520 MODULE = Cwd            PACKAGE = Cwd
521
522 PROTOTYPES: DISABLE
523
524 BOOT:
525 #if USE_MY_CXT
526 {
527     MY_CXT_INIT;
528     POPULATE_MY_CXT;
529 }
530 #endif
531
532 #if USE_MY_CXT
533
534 void
535 CLONE(...)
536 CODE:
537         PERL_UNUSED_VAR(items);
538         { MY_CXT_CLONE; POPULATE_MY_CXT; }
539
540 #endif
541
542 void
543 getcwd(...)
544 ALIAS:
545     fastcwd=1
546 PPCODE:
547 {
548     dXSTARG;
549     /* fastcwd takes zero parameters:  */
550     if (ix == 1 && items != 0)
551         croak_xs_usage(cv,  "");
552     getcwd_sv(TARG);
553     XSprePUSH; PUSHTARG;
554 #ifndef INCOMPLETE_TAINTS
555     SvTAINTED_on(TARG);
556 #endif
557 }
558
559 void
560 abs_path(pathsv=Nullsv)
561     SV *pathsv
562 PPCODE:
563 {
564     dXSTARG;
565     char *const path = pathsv ? SvPV_nolen(pathsv) : (char *)".";
566     char buf[MAXPATHLEN];
567
568     if (
569 #ifdef VMS
570         Perl_rmsexpand(aTHX_ path, buf, NULL, 0)
571 #else
572         bsd_realpath(path, buf)
573 #endif
574     ) {
575         sv_setpv_mg(TARG, buf);
576         SvPOK_only(TARG);
577         SvTAINTED_on(TARG);
578     }
579     else
580         sv_setsv(TARG, &PL_sv_undef);
581
582     XSprePUSH; PUSHs(TARG);
583 #ifndef INCOMPLETE_TAINTS
584     SvTAINTED_on(TARG);
585 #endif
586 }
587
588 #if defined(WIN32) && !defined(UNDER_CE)
589
590 void
591 getdcwd(...)
592 PROTOTYPE: ENABLE
593 PPCODE:
594 {
595     dXSTARG;
596     int drive;
597     char *dir;
598
599     /* Drive 0 is the current drive, 1 is A:, 2 is B:, 3 is C: and so on. */
600     if ( items == 0 ||
601         (items == 1 && (!SvOK(ST(0)) || (SvPOK(ST(0)) && !SvCUR(ST(0))))))
602         drive = 0;
603     else if (items == 1 && SvPOK(ST(0)) && SvCUR(ST(0)) &&
604              isALPHA(SvPVX(ST(0))[0]))
605         drive = toUPPER(SvPVX(ST(0))[0]) - 'A' + 1;
606     else
607         croak("Usage: getdcwd(DRIVE)");
608
609     New(0,dir,MAXPATHLEN,char);
610     if (_getdcwd(drive, dir, MAXPATHLEN)) {
611         sv_setpv_mg(TARG, dir);
612         SvPOK_only(TARG);
613     }
614     else
615         sv_setsv(TARG, &PL_sv_undef);
616
617     Safefree(dir);
618
619     XSprePUSH; PUSHs(TARG);
620 #ifndef INCOMPLETE_TAINTS
621     SvTAINTED_on(TARG);
622 #endif
623 }
624
625 #endif
626
627 MODULE = Cwd            PACKAGE = File::Spec::Unix
628
629 SV *
630 canonpath(SV *self, SV *path = &PL_sv_undef, ...)
631 CODE:
632     PERL_UNUSED_VAR(self);
633     RETVAL = unix_canonpath(path);
634 OUTPUT:
635     RETVAL
636
637 SV *
638 _fn_canonpath(SV *path = &PL_sv_undef, ...)
639 CODE:
640     RETVAL = unix_canonpath(path);
641 OUTPUT:
642     RETVAL
643
644 SV *
645 catdir(SV *self, ...)
646 PREINIT:
647     dUSE_MY_CXT;
648     SV *joined;
649 CODE:
650     EXTEND(SP, items+1);
651     ST(items) = EMPTY_STRING_SV;
652     joined = sv_newmortal();
653     do_join(joined, SLASH_STRING_SV, &ST(0), &ST(items));
654     if(invocant_is_unix(self)) {
655         RETVAL = unix_canonpath(joined);
656     } else {
657         ENTER;
658         PUSHMARK(SP);
659         EXTEND(SP, 2);
660         PUSHs(self);
661         PUSHs(joined);
662         PUTBACK;
663         call_method("canonpath", G_SCALAR);
664         SPAGAIN;
665         RETVAL = POPs;
666         LEAVE;
667         SvREFCNT_inc(RETVAL);
668     }
669 OUTPUT:
670     RETVAL
671
672 SV *
673 _fn_catdir(...)
674 PREINIT:
675     dUSE_MY_CXT;
676     SV *joined;
677 CODE:
678     EXTEND(SP, items+1);
679     ST(items) = EMPTY_STRING_SV;
680     joined = sv_newmortal();
681     do_join(joined, SLASH_STRING_SV, &ST(-1), &ST(items));
682     RETVAL = unix_canonpath(joined);
683 OUTPUT:
684     RETVAL
685
686 SV *
687 catfile(SV *self, ...)
688 PREINIT:
689     dUSE_MY_CXT;
690 CODE:
691     if(invocant_is_unix(self)) {
692         if(items == 1) {
693             RETVAL = &PL_sv_undef;
694         } else {
695             SV *file = unix_canonpath(ST(items-1));
696             if(items == 2) {
697                 RETVAL = file;
698             } else {
699                 SV *dir = sv_newmortal();
700                 sv_2mortal(file);
701                 ST(items-1) = EMPTY_STRING_SV;
702                 do_join(dir, SLASH_STRING_SV, &ST(0), &ST(items-1));
703                 RETVAL = unix_canonpath(dir);
704                 if(SvCUR(RETVAL) == 0 || SvPVX(RETVAL)[SvCUR(RETVAL)-1] != '/')
705                     sv_catsv(RETVAL, SLASH_STRING_SV);
706                 sv_catsv(RETVAL, file);
707             }
708         }
709     } else {
710         SV *file, *dir;
711         ENTER;
712         PUSHMARK(SP);
713         EXTEND(SP, 2);
714         PUSHs(self);
715         PUSHs(items == 1 ? &PL_sv_undef : ST(items-1));
716         PUTBACK;
717         call_method("canonpath", G_SCALAR);
718         SPAGAIN;
719         file = POPs;
720         LEAVE;
721         if(items <= 2) {
722             RETVAL = SvREFCNT_inc(file);
723         } else {
724             char const *pv;
725             STRLEN len;
726             bool need_slash;
727             SP--;
728             ENTER;
729             PUSHMARK(&ST(-1));
730             PUTBACK;
731             call_method("catdir", G_SCALAR);
732             SPAGAIN;
733             dir = POPs;
734             LEAVE;
735             pv = SvPV(dir, len);
736             need_slash = len == 0 || pv[len-1] != '/';
737             RETVAL = newSVsv(dir);
738             if(need_slash) sv_catsv(RETVAL, SLASH_STRING_SV);
739             sv_catsv(RETVAL, file);
740         }
741     }
742 OUTPUT:
743     RETVAL
744
745 SV *
746 _fn_catfile(...)
747 PREINIT:
748     dUSE_MY_CXT;
749 CODE:
750     if(items == 0) {
751         RETVAL = &PL_sv_undef;
752     } else {
753         SV *file = unix_canonpath(ST(items-1));
754         if(items == 1) {
755             RETVAL = file;
756         } else {
757             SV *dir = sv_newmortal();
758             sv_2mortal(file);
759             ST(items-1) = EMPTY_STRING_SV;
760             do_join(dir, SLASH_STRING_SV, &ST(-1), &ST(items-1));
761             RETVAL = unix_canonpath(dir);
762             if(SvCUR(RETVAL) == 0 || SvPVX(RETVAL)[SvCUR(RETVAL)-1] != '/')
763                 sv_catsv(RETVAL, SLASH_STRING_SV);
764             sv_catsv(RETVAL, file);
765         }
766     }
767 OUTPUT:
768     RETVAL