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
CommitLineData
c30da3b5
NC
1#define PERL_NO_GET_CONTEXT
2
0d2079fa
BS
3#include "EXTERN.h"
4#include "perl.h"
5#include "XSUB.h"
9bc94e3d
SM
6#define NEED_my_strlcpy
7#define NEED_my_strlcat
8#include "ppport.h"
0d2079fa 9
c70498c1
JH
10#ifdef I_UNISTD
11# include <unistd.h>
12#endif
13
bf7c0a3d 14/* The realpath() implementation from OpenBSD 3.9 to 4.2 (realpath.c 1.13)
03d70c89 15 * Renamed here to bsd_realpath() to avoid library conflicts.
99f36a73
RGS
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 */
03d70c89
JH
23
24/*
bf7c0a3d 25 * Copyright (c) 2003 Constantin S. Svintsoff <kostik@iclub.nsu.ru>
03d70c89
JH
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.
bf7c0a3d
SP
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.
03d70c89 38 *
6dfee1ec 39 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND
03d70c89
JH
40 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
41 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
bf7c0a3d 42 * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
03d70c89
JH
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
03d70c89
JH
52/* OpenBSD system #includes removed since the Perl ones should do. --jhi */
53
54#ifndef MAXSYMLINKS
55#define MAXSYMLINKS 8
56#endif
57
66a378bd 58#ifndef VMS
03d70c89 59/*
bf7c0a3d 60 * char *realpath(const char *path, char resolved[MAXPATHLEN]);
03d70c89
JH
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 */
66static
67char *
c7304ea2 68bsd_realpath(const char *path, char resolved[MAXPATHLEN])
03d70c89 69{
c7304ea2
NC
70 char *p, *q, *s;
71 size_t left_len, resolved_len;
72 unsigned symlinks;
73 int serrno;
8304a6c4 74 char left[MAXPATHLEN], next_token[MAXPATHLEN];
03d70c89 75
c7304ea2
NC
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);
03d70c89
JH
88 return (NULL);
89 }
c7304ea2
NC
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;
e3d944f4
JH
95 return (NULL);
96 }
03d70c89
JH
97
98 /*
6dfee1ec 99 * Iterate over path components in 'left'.
03d70c89 100 */
c7304ea2
NC
101 while (left_len != 0) {
102 /*
6dfee1ec 103 * Extract the next path component and adjust 'left'
c7304ea2
NC
104 * and its length.
105 */
106 p = strchr(left, '/');
107 s = p ? p : left + left_len;
c33e8be1 108 if ((STRLEN)(s - left) >= (STRLEN)sizeof(next_token)) {
c7304ea2
NC
109 errno = ENAMETOOLONG;
110 return (NULL);
03d70c89 111 }
c7304ea2
NC
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);
03d70c89 121 }
c7304ea2
NC
122 resolved[resolved_len++] = '/';
123 resolved[resolved_len] = '\0';
03d70c89 124 }
c7304ea2
NC
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;
91f3b821 141 }
03d70c89
JH
142
143 /*
c7304ea2
NC
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.
03d70c89 147 */
c7304ea2
NC
148 resolved_len = my_strlcat(resolved, next_token, MAXPATHLEN);
149 if (resolved_len >= MAXPATHLEN) {
150 errno = ENAMETOOLONG;
151 return (NULL);
152 }
8304a6c4 153#if defined(HAS_LSTAT) && defined(HAS_READLINK) && defined(HAS_SYMLINK)
c7304ea2
NC
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;
8304a6c4 165 char symlink[MAXPATHLEN];
c7304ea2
NC
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 }
03d70c89
JH
185
186 /*
c7304ea2
NC
187 * If there are any path components left, then
188 * append them to symlink. The result is placed
6dfee1ec 189 * in 'left'.
03d70c89 190 */
c7304ea2
NC
191 if (p != NULL) {
192 if (symlink[slen - 1] != '/') {
c33e8be1 193 if ((STRLEN)(slen + 1) >= (STRLEN)sizeof(symlink)) {
8304a6c4 194 errno = ENAMETOOLONG;
c7304ea2 195 return (NULL);
8304a6c4 196 }
c7304ea2
NC
197 symlink[slen] = '/';
198 symlink[slen + 1] = 0;
8304a6c4 199 }
c7304ea2
NC
200 left_len = my_strlcat(symlink, left, sizeof(left));
201 if (left_len >= sizeof(left)) {
202 errno = ENAMETOOLONG;
203 return (NULL);
8304a6c4
NC
204 }
205 }
c7304ea2
NC
206 left_len = my_strlcpy(left, symlink, sizeof(left));
207 }
208 }
8304a6c4 209#endif
c7304ea2 210 }
03d70c89 211
c7304ea2
NC
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';
03d70c89 218 return (resolved);
03d70c89 219}
66a378bd 220#endif
03d70c89 221
99f36a73
RGS
222#ifndef SV_CWD_RETURN_UNDEF
223#define SV_CWD_RETURN_UNDEF \
224sv_setsv(sv, &PL_sv_undef); \
225return 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
a9939470 247#ifndef getcwd_sv
1955c8df 248/* Taken from perl 5.8's util.c */
09122b95 249#define getcwd_sv(a) Perl_getcwd_sv(aTHX_ a)
5aaab254 250int Perl_getcwd_sv(pTHX_ SV *sv)
a9939470
NC
251{
252#ifndef PERL_MICRO
253
a9939470 254 SvTAINTED_on(sv);
a9939470
NC
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
f6342b4b 275 {
a9939470
NC
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;
f6342b4b 387 }
a9939470
NC
388#endif
389
390#else
391 return FALSE;
392#endif
393}
394
395#endif
396
07f43755
Z
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
405typedef struct {
406 SV *empty_string_sv, *slash_string_sv;
407} my_cxt_t;
408START_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)
423static
424bool
425THX_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)
438static
439SV *
440THX_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] != '/') {
b1cb0d6f 458 q = (const char *) memchr(p+2, '/', pe-(p+2));
07f43755
Z
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) {
b1cb0d6f 494 q = (const char *) memchr(p, '/', pe-p);
07f43755
Z
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}
a9939470 517
f22d8e4b 518MODULE = Cwd PACKAGE = Cwd
0d2079fa 519
1d0561d5 520PROTOTYPES: DISABLE
0d2079fa 521
07f43755
Z
522BOOT:
523#if USE_MY_CXT
524{
525 MY_CXT_INIT;
526 POPULATE_MY_CXT;
527}
528#endif
529
530#if USE_MY_CXT
531
532void
533CLONE(...)
534CODE:
535 PERL_UNUSED_VAR(items);
536 { MY_CXT_CLONE; POPULATE_MY_CXT; }
537
538#endif
539
f22d8e4b 540void
23bb49fa 541getcwd(...)
2cdb8b94
NC
542ALIAS:
543 fastcwd=1
fa52125f
SP
544PPCODE:
545{
546 dXSTARG;
2cdb8b94
NC
547 /* fastcwd takes zero parameters: */
548 if (ix == 1 && items != 0)
549 croak_xs_usage(cv, "");
fa52125f
SP
550 getcwd_sv(TARG);
551 XSprePUSH; PUSHTARG;
fa52125f 552 SvTAINTED_on(TARG);
fa52125f
SP
553}
554
555void
03d70c89
JH
556abs_path(pathsv=Nullsv)
557 SV *pathsv
f22d8e4b 558PPCODE:
2ae52c40 559{
f22d8e4b 560 dXSTARG;
66a378bd 561 char *const path = pathsv ? SvPV_nolen(pathsv) : (char *)".";
00536bfc 562 char buf[MAXPATHLEN];
03d70c89 563
66a378bd
NC
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);
00536bfc 572 SvPOK_only(TARG);
ea715489 573 SvTAINTED_on(TARG);
2ae52c40 574 }
03d70c89 575 else
ea715489 576 sv_setsv(TARG, &PL_sv_undef);
2ae52c40 577
66a378bd 578 XSprePUSH; PUSHs(TARG);
ea715489 579 SvTAINTED_on(TARG);
2ae52c40 580}
09122b95 581
42d1cefd 582#if defined(WIN32) && !defined(UNDER_CE)
09122b95
RGS
583
584void
585getdcwd(...)
1d0561d5 586PROTOTYPE: ENABLE
09122b95
RGS
587PPCODE:
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
275e8705
RGS
603 New(0,dir,MAXPATHLEN,char);
604 if (_getdcwd(drive, dir, MAXPATHLEN)) {
66a378bd 605 sv_setpv_mg(TARG, dir);
09122b95
RGS
606 SvPOK_only(TARG);
607 }
608 else
609 sv_setsv(TARG, &PL_sv_undef);
610
99f36a73
RGS
611 Safefree(dir);
612
66a378bd 613 XSprePUSH; PUSHs(TARG);
09122b95 614 SvTAINTED_on(TARG);
09122b95
RGS
615}
616
617#endif
07f43755
Z
618
619MODULE = Cwd PACKAGE = File::Spec::Unix
620
621SV *
622canonpath(SV *self, SV *path = &PL_sv_undef, ...)
623CODE:
624 PERL_UNUSED_VAR(self);
625 RETVAL = unix_canonpath(path);
626OUTPUT:
627 RETVAL
628
629SV *
630_fn_canonpath(SV *path = &PL_sv_undef, ...)
631CODE:
632 RETVAL = unix_canonpath(path);
633OUTPUT:
634 RETVAL
635
636SV *
637catdir(SV *self, ...)
638PREINIT:
639 dUSE_MY_CXT;
640 SV *joined;
641CODE:
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 }
661OUTPUT:
662 RETVAL
663
664SV *
665_fn_catdir(...)
666PREINIT:
667 dUSE_MY_CXT;
668 SV *joined;
669CODE:
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);
675OUTPUT:
676 RETVAL
677
678SV *
679catfile(SV *self, ...)
680PREINIT:
681 dUSE_MY_CXT;
682CODE:
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 }
734OUTPUT:
735 RETVAL
736
737SV *
738_fn_catfile(...)
739PREINIT:
740 dUSE_MY_CXT;
741CODE:
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 }
759OUTPUT:
760 RETVAL