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 #ifndef NO_PPPORT_H 11 # define NEED_croak_xs_usage 12 # define NEED_sv_2pv_flags 13 # define NEED_my_strlcpy 14 # define NEED_my_strlcat 15 # include "ppport.h" 16 #endif 17 18 #if defined(HAS_READLINK) && !defined(PerlLIO_readlink) 19 #define PerlLIO_readlink readlink 20 #endif 21 22 #ifdef I_UNISTD 23 # include <unistd.h> 24 #endif 25 26 /* For special handling of os390 sysplexed systems */ 27 #define SYSNAME "$SYSNAME" 28 #define SYSNAME_LEN (sizeof(SYSNAME) - 1) 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 EBCDIC /* XXX Probably this should be only 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 EBCDIC 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 #ifndef PERL_MICRO 296 297 SvTAINTED_on(sv); 298 299 #ifdef HAS_GETCWD 300 { 301 char buf[MAXPATHLEN]; 302 303 /* Some getcwd()s automatically allocate a buffer of the given 304 * size from the heap if they are given a NULL buffer pointer. 305 * The problem is that this behaviour is not portable. */ 306 if (getcwd(buf, sizeof(buf) - 1)) { 307 STRLEN len = strlen(buf); 308 sv_setpvn(sv, buf, len); 309 return TRUE; 310 } 311 else { 312 sv_setsv(sv, &PL_sv_undef); 313 return FALSE; 314 } 315 } 316 317 #else 318 { 319 Stat_t statbuf; 320 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino; 321 int namelen, pathlen=0; 322 DIR *dir; 323 Direntry_t *dp; 324 325 (void)SvUPGRADE(sv, SVt_PV); 326 327 if (PerlLIO_lstat(".", &statbuf) < 0) { 328 SV_CWD_RETURN_UNDEF; 329 } 330 331 orig_cdev = statbuf.st_dev; 332 orig_cino = statbuf.st_ino; 333 cdev = orig_cdev; 334 cino = orig_cino; 335 336 for (;;) { 337 odev = cdev; 338 oino = cino; 339 340 if (PerlDir_chdir("..") < 0) { 341 SV_CWD_RETURN_UNDEF; 342 } 343 if (PerlLIO_stat(".", &statbuf) < 0) { 344 SV_CWD_RETURN_UNDEF; 345 } 346 347 cdev = statbuf.st_dev; 348 cino = statbuf.st_ino; 349 350 if (odev == cdev && oino == cino) { 351 break; 352 } 353 if (!(dir = PerlDir_open("."))) { 354 SV_CWD_RETURN_UNDEF; 355 } 356 357 while ((dp = PerlDir_read(dir)) != NULL) { 358 #ifdef DIRNAMLEN 359 namelen = dp->d_namlen; 360 #else 361 namelen = strlen(dp->d_name); 362 #endif 363 /* skip . and .. */ 364 if (SV_CWD_ISDOT(dp)) { 365 continue; 366 } 367 368 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) { 369 SV_CWD_RETURN_UNDEF; 370 } 371 372 tdev = statbuf.st_dev; 373 tino = statbuf.st_ino; 374 if (tino == oino && tdev == odev) { 375 break; 376 } 377 } 378 379 if (!dp) { 380 SV_CWD_RETURN_UNDEF; 381 } 382 383 if (pathlen + namelen + 1 >= MAXPATHLEN) { 384 SV_CWD_RETURN_UNDEF; 385 } 386 387 SvGROW(sv, pathlen + namelen + 1); 388 389 if (pathlen) { 390 /* shift down */ 391 Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char); 392 } 393 394 /* prepend current directory to the front */ 395 *SvPVX(sv) = '/'; 396 Move(dp->d_name, SvPVX(sv)+1, namelen, char); 397 pathlen += (namelen + 1); 398 399 #ifdef VOID_CLOSEDIR 400 PerlDir_close(dir); 401 #else 402 if (PerlDir_close(dir) < 0) { 403 SV_CWD_RETURN_UNDEF; 404 } 405 #endif 406 } 407 408 if (pathlen) { 409 SvCUR_set(sv, pathlen); 410 *SvEND(sv) = '\0'; 411 SvPOK_only(sv); 412 413 if (PerlDir_chdir(SvPVX(sv)) < 0) { 414 SV_CWD_RETURN_UNDEF; 415 } 416 } 417 if (PerlLIO_stat(".", &statbuf) < 0) { 418 SV_CWD_RETURN_UNDEF; 419 } 420 421 cdev = statbuf.st_dev; 422 cino = statbuf.st_ino; 423 424 if (cdev != orig_cdev || cino != orig_cino) { 425 Perl_croak(aTHX_ "Unstable directory path, " 426 "current directory changed unexpectedly"); 427 } 428 429 return TRUE; 430 } 431 #endif 432 433 #else 434 return FALSE; 435 #endif 436 } 437 438 #endif 439 440 #if defined(START_MY_CXT) && defined(MY_CXT_CLONE) 441 # define USE_MY_CXT 1 442 #else 443 # define USE_MY_CXT 0 444 #endif 445 446 #if USE_MY_CXT 447 # define MY_CXT_KEY "Cwd::_guts" XS_VERSION 448 typedef struct { 449 SV *empty_string_sv, *slash_string_sv; 450 } my_cxt_t; 451 START_MY_CXT 452 # define dUSE_MY_CXT dMY_CXT 453 # define EMPTY_STRING_SV MY_CXT.empty_string_sv 454 # define SLASH_STRING_SV MY_CXT.slash_string_sv 455 # define POPULATE_MY_CXT do { \ 456 MY_CXT.empty_string_sv = newSVpvs(""); \ 457 MY_CXT.slash_string_sv = newSVpvs("/"); \ 458 } while(0) 459 #else 460 # define dUSE_MY_CXT dNOOP 461 # define EMPTY_STRING_SV sv_2mortal(newSVpvs("")) 462 # define SLASH_STRING_SV sv_2mortal(newSVpvs("/")) 463 #endif 464 465 #define invocant_is_unix(i) THX_invocant_is_unix(aTHX_ i) 466 static 467 bool 468 THX_invocant_is_unix(pTHX_ SV *invocant) 469 { 470 /* 471 * This is used to enable optimisations that avoid method calls 472 * by knowing how they would resolve. False negatives, disabling 473 * the optimisation where it would actually behave correctly, are 474 * acceptable. 475 */ 476 return SvPOK(invocant) && SvCUR(invocant) == 16 && 477 !memcmp(SvPVX(invocant), "File::Spec::Unix", 16); 478 } 479 480 #define unix_canonpath(p) THX_unix_canonpath(aTHX_ p) 481 static 482 SV * 483 THX_unix_canonpath(pTHX_ SV *path) 484 { 485 SV *retval; 486 char const *p, *pe, *q; 487 STRLEN l; 488 char *o; 489 STRLEN plen; 490 SvGETMAGIC(path); 491 if(!SvOK(path)) return &PL_sv_undef; 492 p = SvPV_nomg(path, plen); 493 if(plen == 0) return newSVpvs(""); 494 pe = p + plen; 495 retval = newSV(plen); 496 #ifdef SvUTF8 497 if(SvUTF8(path)) SvUTF8_on(retval); 498 #endif 499 o = SvPVX(retval); 500 if(DOUBLE_SLASHES_SPECIAL && p[0] == '/' && p[1] == '/' && p[2] != '/') { 501 q = (const char *) memchr(p+2, '/', pe-(p+2)); 502 if(!q) q = pe; 503 l = q - p; 504 memcpy(o, p, l); 505 p = q; 506 o += l; 507 } 508 /* 509 * The transformations performed here are: 510 * . squeeze multiple slashes 511 * . eliminate "." segments, except one if that's all there is 512 * . eliminate leading ".." segments 513 * . eliminate trailing slash, unless it's all there is 514 */ 515 if(p[0] == '/') { 516 *o++ = '/'; 517 while(1) { 518 do { p++; } while(p[0] == '/'); 519 if(p[0] == '.' && p[1] == '.' && (p+2 == pe || p[2] == '/')) { 520 p++; 521 /* advance past second "." next time round loop */ 522 } else if(p[0] == '.' && (p+1 == pe || p[1] == '/')) { 523 /* advance past "." next time round loop */ 524 } else { 525 break; 526 } 527 } 528 } else if(p[0] == '.' && p[1] == '/') { 529 do { 530 p++; 531 do { p++; } while(p[0] == '/'); 532 } while(p[0] == '.' && p[1] == '/'); 533 if(p == pe) *o++ = '.'; 534 } 535 if(p == pe) goto end; 536 while(1) { 537 q = (const char *) memchr(p, '/', pe-p); 538 if(!q) q = pe; 539 l = q - p; 540 memcpy(o, p, l); 541 p = q; 542 o += l; 543 if(p == pe) goto end; 544 while(1) { 545 do { p++; } while(p[0] == '/'); 546 if(p == pe) goto end; 547 if(p[0] != '.') break; 548 if(p+1 == pe) goto end; 549 if(p[1] != '/') break; 550 p++; 551 } 552 *o++ = '/'; 553 } 554 end: ; 555 *o = 0; 556 SvPOK_on(retval); 557 SvCUR_set(retval, o - SvPVX(retval)); 558 SvTAINT(retval); 559 return retval; 560 } 561 562 MODULE = Cwd PACKAGE = Cwd 563 564 PROTOTYPES: DISABLE 565 566 BOOT: 567 #if USE_MY_CXT 568 { 569 MY_CXT_INIT; 570 POPULATE_MY_CXT; 571 } 572 #endif 573 574 #if USE_MY_CXT 575 576 void 577 CLONE(...) 578 CODE: 579 PERL_UNUSED_VAR(items); 580 { MY_CXT_CLONE; POPULATE_MY_CXT; } 581 582 #endif 583 584 void 585 getcwd(...) 586 ALIAS: 587 fastcwd=1 588 PPCODE: 589 { 590 dXSTARG; 591 /* fastcwd takes zero parameters: */ 592 if (ix == 1 && items != 0) 593 croak_xs_usage(cv, ""); 594 getcwd_sv(TARG); 595 XSprePUSH; PUSHTARG; 596 SvTAINTED_on(TARG); 597 } 598 599 void 600 abs_path(pathsv=Nullsv) 601 SV *pathsv 602 PPCODE: 603 { 604 dXSTARG; 605 char *const path = pathsv ? SvPV_nolen(pathsv) : (char *)"."; 606 char buf[MAXPATHLEN]; 607 608 if ( 609 #ifdef VMS 610 Perl_rmsexpand(aTHX_ path, buf, NULL, 0) 611 #else 612 bsd_realpath(path, buf) 613 #endif 614 ) { 615 sv_setpv_mg(TARG, buf); 616 SvPOK_only(TARG); 617 SvTAINTED_on(TARG); 618 } 619 else 620 sv_setsv(TARG, &PL_sv_undef); 621 622 XSprePUSH; PUSHs(TARG); 623 SvTAINTED_on(TARG); 624 } 625 626 #if defined(WIN32) && !defined(UNDER_CE) 627 628 void 629 getdcwd(...) 630 PROTOTYPE: ENABLE 631 PPCODE: 632 { 633 dXSTARG; 634 int drive; 635 char *dir; 636 637 /* Drive 0 is the current drive, 1 is A:, 2 is B:, 3 is C: and so on. */ 638 if ( items == 0 || 639 (items == 1 && (!SvOK(ST(0)) || (SvPOK(ST(0)) && !SvCUR(ST(0)))))) 640 drive = 0; 641 else if (items == 1 && SvPOK(ST(0)) && SvCUR(ST(0)) && 642 isALPHA(SvPVX(ST(0))[0])) 643 drive = toUPPER(SvPVX(ST(0))[0]) - 'A' + 1; 644 else 645 croak("Usage: getdcwd(DRIVE)"); 646 647 New(0,dir,MAXPATHLEN,char); 648 if (_getdcwd(drive, dir, MAXPATHLEN)) { 649 sv_setpv_mg(TARG, dir); 650 SvPOK_only(TARG); 651 } 652 else 653 sv_setsv(TARG, &PL_sv_undef); 654 655 Safefree(dir); 656 657 XSprePUSH; PUSHs(TARG); 658 SvTAINTED_on(TARG); 659 } 660 661 #endif 662 663 MODULE = Cwd PACKAGE = File::Spec::Unix 664 665 SV * 666 canonpath(SV *self, SV *path = &PL_sv_undef, ...) 667 CODE: 668 PERL_UNUSED_VAR(self); 669 RETVAL = unix_canonpath(path); 670 OUTPUT: 671 RETVAL 672 673 SV * 674 _fn_canonpath(SV *path = &PL_sv_undef, ...) 675 CODE: 676 RETVAL = unix_canonpath(path); 677 OUTPUT: 678 RETVAL 679 680 SV * 681 catdir(SV *self, ...) 682 PREINIT: 683 dUSE_MY_CXT; 684 SV *joined; 685 CODE: 686 EXTEND(SP, items+1); 687 ST(items) = EMPTY_STRING_SV; 688 joined = sv_newmortal(); 689 do_join(joined, SLASH_STRING_SV, &ST(0), &ST(items)); 690 if(invocant_is_unix(self)) { 691 RETVAL = unix_canonpath(joined); 692 } else { 693 ENTER; 694 PUSHMARK(SP); 695 EXTEND(SP, 2); 696 PUSHs(self); 697 PUSHs(joined); 698 PUTBACK; 699 call_method("canonpath", G_SCALAR); 700 SPAGAIN; 701 RETVAL = POPs; 702 LEAVE; 703 SvREFCNT_inc(RETVAL); 704 } 705 OUTPUT: 706 RETVAL 707 708 SV * 709 _fn_catdir(...) 710 PREINIT: 711 dUSE_MY_CXT; 712 SV *joined; 713 CODE: 714 EXTEND(SP, items+1); 715 ST(items) = EMPTY_STRING_SV; 716 joined = sv_newmortal(); 717 do_join(joined, SLASH_STRING_SV, &ST(-1), &ST(items)); 718 RETVAL = unix_canonpath(joined); 719 OUTPUT: 720 RETVAL 721 722 SV * 723 catfile(SV *self, ...) 724 PREINIT: 725 dUSE_MY_CXT; 726 CODE: 727 if(invocant_is_unix(self)) { 728 if(items == 1) { 729 RETVAL = &PL_sv_undef; 730 } else { 731 SV *file = unix_canonpath(ST(items-1)); 732 if(items == 2) { 733 RETVAL = file; 734 } else { 735 SV *dir = sv_newmortal(); 736 sv_2mortal(file); 737 ST(items-1) = EMPTY_STRING_SV; 738 do_join(dir, SLASH_STRING_SV, &ST(0), &ST(items-1)); 739 RETVAL = unix_canonpath(dir); 740 if(SvCUR(RETVAL) == 0 || SvPVX(RETVAL)[SvCUR(RETVAL)-1] != '/') 741 sv_catsv(RETVAL, SLASH_STRING_SV); 742 sv_catsv(RETVAL, file); 743 } 744 } 745 } else { 746 SV *file, *dir; 747 ENTER; 748 PUSHMARK(SP); 749 EXTEND(SP, 2); 750 PUSHs(self); 751 PUSHs(items == 1 ? &PL_sv_undef : ST(items-1)); 752 PUTBACK; 753 call_method("canonpath", G_SCALAR); 754 SPAGAIN; 755 file = POPs; 756 LEAVE; 757 if(items <= 2) { 758 RETVAL = SvREFCNT_inc(file); 759 } else { 760 char const *pv; 761 STRLEN len; 762 bool need_slash; 763 SP--; 764 ENTER; 765 PUSHMARK(&ST(-1)); 766 PUTBACK; 767 call_method("catdir", G_SCALAR); 768 SPAGAIN; 769 dir = POPs; 770 LEAVE; 771 pv = SvPV(dir, len); 772 need_slash = len == 0 || pv[len-1] != '/'; 773 RETVAL = newSVsv(dir); 774 if(need_slash) sv_catsv(RETVAL, SLASH_STRING_SV); 775 sv_catsv(RETVAL, file); 776 } 777 } 778 OUTPUT: 779 RETVAL 780 781 SV * 782 _fn_catfile(...) 783 PREINIT: 784 dUSE_MY_CXT; 785 CODE: 786 if(items == 0) { 787 RETVAL = &PL_sv_undef; 788 } else { 789 SV *file = unix_canonpath(ST(items-1)); 790 if(items == 1) { 791 RETVAL = file; 792 } else { 793 SV *dir = sv_newmortal(); 794 sv_2mortal(file); 795 ST(items-1) = EMPTY_STRING_SV; 796 do_join(dir, SLASH_STRING_SV, &ST(-1), &ST(items-1)); 797 RETVAL = unix_canonpath(dir); 798 if(SvCUR(RETVAL) == 0 || SvPVX(RETVAL)[SvCUR(RETVAL)-1] != '/') 799 sv_catsv(RETVAL, SLASH_STRING_SV); 800 sv_catsv(RETVAL, file); 801 } 802 } 803 OUTPUT: 804 RETVAL 805