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 SvTAINTED_on(sv); 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 275 { 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; 387 } 388 #endif 389 390 #else 391 return FALSE; 392 #endif 393 } 394 395 #endif 396 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 405 typedef struct { 406 SV *empty_string_sv, *slash_string_sv; 407 } my_cxt_t; 408 START_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) 423 static 424 bool 425 THX_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) 438 static 439 SV * 440 THX_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] != '/') { 458 q = (const char *) memchr(p+2, '/', pe-(p+2)); 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) { 494 q = (const char *) memchr(p, '/', pe-p); 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 } 517 518 MODULE = Cwd PACKAGE = Cwd 519 520 PROTOTYPES: DISABLE 521 522 BOOT: 523 #if USE_MY_CXT 524 { 525 MY_CXT_INIT; 526 POPULATE_MY_CXT; 527 } 528 #endif 529 530 #if USE_MY_CXT 531 532 void 533 CLONE(...) 534 CODE: 535 PERL_UNUSED_VAR(items); 536 { MY_CXT_CLONE; POPULATE_MY_CXT; } 537 538 #endif 539 540 void 541 getcwd(...) 542 ALIAS: 543 fastcwd=1 544 PPCODE: 545 { 546 dXSTARG; 547 /* fastcwd takes zero parameters: */ 548 if (ix == 1 && items != 0) 549 croak_xs_usage(cv, ""); 550 getcwd_sv(TARG); 551 XSprePUSH; PUSHTARG; 552 SvTAINTED_on(TARG); 553 } 554 555 void 556 abs_path(pathsv=Nullsv) 557 SV *pathsv 558 PPCODE: 559 { 560 dXSTARG; 561 char *const path = pathsv ? SvPV_nolen(pathsv) : (char *)"."; 562 char buf[MAXPATHLEN]; 563 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); 572 SvPOK_only(TARG); 573 SvTAINTED_on(TARG); 574 } 575 else 576 sv_setsv(TARG, &PL_sv_undef); 577 578 XSprePUSH; PUSHs(TARG); 579 SvTAINTED_on(TARG); 580 } 581 582 #if defined(WIN32) && !defined(UNDER_CE) 583 584 void 585 getdcwd(...) 586 PROTOTYPE: ENABLE 587 PPCODE: 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 603 New(0,dir,MAXPATHLEN,char); 604 if (_getdcwd(drive, dir, MAXPATHLEN)) { 605 sv_setpv_mg(TARG, dir); 606 SvPOK_only(TARG); 607 } 608 else 609 sv_setsv(TARG, &PL_sv_undef); 610 611 Safefree(dir); 612 613 XSprePUSH; PUSHs(TARG); 614 SvTAINTED_on(TARG); 615 } 616 617 #endif 618 619 MODULE = Cwd PACKAGE = File::Spec::Unix 620 621 SV * 622 canonpath(SV *self, SV *path = &PL_sv_undef, ...) 623 CODE: 624 PERL_UNUSED_VAR(self); 625 RETVAL = unix_canonpath(path); 626 OUTPUT: 627 RETVAL 628 629 SV * 630 _fn_canonpath(SV *path = &PL_sv_undef, ...) 631 CODE: 632 RETVAL = unix_canonpath(path); 633 OUTPUT: 634 RETVAL 635 636 SV * 637 catdir(SV *self, ...) 638 PREINIT: 639 dUSE_MY_CXT; 640 SV *joined; 641 CODE: 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 } 661 OUTPUT: 662 RETVAL 663 664 SV * 665 _fn_catdir(...) 666 PREINIT: 667 dUSE_MY_CXT; 668 SV *joined; 669 CODE: 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); 675 OUTPUT: 676 RETVAL 677 678 SV * 679 catfile(SV *self, ...) 680 PREINIT: 681 dUSE_MY_CXT; 682 CODE: 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 } 734 OUTPUT: 735 RETVAL 736 737 SV * 738 _fn_catfile(...) 739 PREINIT: 740 dUSE_MY_CXT; 741 CODE: 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 } 759 OUTPUT: 760 RETVAL 761