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