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 * 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) 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 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 * 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 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 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