dist/Cwd/Cwd.xs

   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 /*
  59  * char *realpath(const char *path, char resolved[MAXPATHLEN]);
  60  *
  61  * Find the real name of path, by removing all ".", ".." and symlink
  62  * components.  Returns (resolved) on success, or (NULL) on failure,
  63  * in which case the path which caused trouble is left in (resolved).
  64  */
  65 static
  66 char *
  67 bsd_realpath(const char *path, char resolved[MAXPATHLEN])
  68 {
  69 #ifdef VMS
  70        dTHX;
  71        return Perl_rmsexpand(aTHX_ (char*)path, resolved, NULL, 0);
  72 #else
  73         char *p, *q, *s;
  74         size_t left_len, resolved_len;
  75         unsigned symlinks;
  76         int serrno;
  77         char left[MAXPATHLEN], next_token[MAXPATHLEN], symlink[MAXPATHLEN];
  78
  79         serrno = errno;
  80         symlinks = 0;
  81         if (path[0] == '/') {
  82                 resolved[0] = '/';
  83                 resolved[1] = '\0';
  84                 if (path[1] == '\0')
  85                         return (resolved);
  86                 resolved_len = 1;
  87                 left_len = my_strlcpy(left, path + 1, sizeof(left));
  88         } else {
  89                 if (getcwd(resolved, MAXPATHLEN) == NULL) {
  90                         my_strlcpy(resolved, ".", MAXPATHLEN);
  91                 return (NULL);
  92         }
  93                 resolved_len = strlen(resolved);
  94                 left_len = my_strlcpy(left, path, sizeof(left));
  95         }
  96         if (left_len >= sizeof(left) || resolved_len >= MAXPATHLEN) {
  97                 errno = ENAMETOOLONG;
  98                 return (NULL);
  99         }
 100
 101         /*
 102          * Iterate over path components in `left'.
 103          */
 104         while (left_len != 0) {
 105                 /*
 106                  * Extract the next path component and adjust `left'
 107                  * and its length.
 108                  */
 109                 p = strchr(left, '/');
 110                 s = p ? p : left + left_len;
 111                 if ((STRLEN)(s - left) >= (STRLEN)sizeof(next_token)) {
 112                         errno = ENAMETOOLONG;
 113                         return (NULL);
 114                         }
 115                 memcpy(next_token, left, s - left);
 116                 next_token[s - left] = '\0';
 117                 left_len -= s - left;
 118                 if (p != NULL)
 119                         memmove(left, s + 1, left_len + 1);
 120                 if (resolved[resolved_len - 1] != '/') {
 121                         if (resolved_len + 1 >= MAXPATHLEN) {
 122                                 errno = ENAMETOOLONG;
 123                                 return (NULL);
 124                 }
 125                         resolved[resolved_len++] = '/';
 126                         resolved[resolved_len] = '\0';
 127         }
 128                 if (next_token[0] == '\0')
 129                         continue;
 130                 else if (strcmp(next_token, ".") == 0)
 131                         continue;
 132                 else if (strcmp(next_token, "..") == 0) {
 133                         /*
 134                          * Strip the last path component except when we have
 135                          * single "/"
 136                          */
 137                         if (resolved_len > 1) {
 138                                 resolved[resolved_len - 1] = '\0';
 139                                 q = strrchr(resolved, '/') + 1;
 140                                 *q = '\0';
 141                                 resolved_len = q - resolved;
 142                         }
 143                         continue;
 144     }
 145
 146         /*
 147                  * Append the next path component and lstat() it. If
 148                  * lstat() fails we still can return successfully if
 149                  * there are no more path components left.
 150          */
 151                 resolved_len = my_strlcat(resolved, next_token, MAXPATHLEN);
 152                 if (resolved_len >= MAXPATHLEN) {
 153                         errno = ENAMETOOLONG;
 154                         return (NULL);
 155                 }
 156         #if defined(HAS_LSTAT) && defined(HAS_READLINK) && defined(HAS_SYMLINK)
 157                 {
 158                         struct stat sb;
 159                         if (lstat(resolved, &sb) != 0) {
 160                                 if (errno == ENOENT && p == NULL) {
 161                                         errno = serrno;
 162                                         return (resolved);
 163                                 }
 164                                 return (NULL);
 165                         }
 166                         if (S_ISLNK(sb.st_mode)) {
 167                                 int slen;
 168
 169                                 if (symlinks++ > MAXSYMLINKS) {
 170                                         errno = ELOOP;
 171                                         return (NULL);
 172                                 }
 173                                 slen = readlink(resolved, symlink, sizeof(symlink) - 1);
 174                                 if (slen < 0)
 175                                         return (NULL);
 176                                 symlink[slen] = '\0';
 177                                 if (symlink[0] == '/') {
 178                                         resolved[1] = 0;
 179                                         resolved_len = 1;
 180                                 } else if (resolved_len > 1) {
 181                                         /* Strip the last path component. */
 182                                         resolved[resolved_len - 1] = '\0';
 183                                         q = strrchr(resolved, '/') + 1;
 184                                         *q = '\0';
 185                                         resolved_len = q - resolved;
 186                                 }
 187
 188         /*
 189                                  * If there are any path components left, then
 190                                  * append them to symlink. The result is placed
 191                                  * in `left'.
 192          */
 193                                 if (p != NULL) {
 194                                         if (symlink[slen - 1] != '/') {
 195                                                 if ((STRLEN)(slen + 1) >= (STRLEN)sizeof(symlink)) {
 196                         errno = ENAMETOOLONG;
 197                                                         return (NULL);
 198                 }
 199                                                 symlink[slen] = '/';
 200                                                 symlink[slen + 1] = 0;
 201         }
 202                                         left_len = my_strlcat(symlink, left, sizeof(left));
 203                                         if (left_len >= sizeof(left)) {
 204                                                 errno = ENAMETOOLONG;
 205                                                 return (NULL);
 206         }
 207         }
 208                                 left_len = my_strlcpy(left, symlink, sizeof(left));
 209                         }
 210                 }
 211         #endif
 212         }
 213
 214         /*
 215          * Remove trailing slash except when the resolved pathname
 216          * is a single "/".
 217          */
 218         if (resolved_len > 1 && resolved[resolved_len - 1] == '/')
 219                 resolved[resolved_len - 1] = '\0';
 220         return (resolved);
 221 #endif
 222 }
 223
 224 #ifndef SV_CWD_RETURN_UNDEF
 225 #define SV_CWD_RETURN_UNDEF \
 226 sv_setsv(sv, &PL_sv_undef); \
 227 return FALSE
 228 #endif
 229
 230 #ifndef OPpENTERSUB_HASTARG
 231 #define OPpENTERSUB_HASTARG     32      /* Called from OP tree. */
 232 #endif
 233
 234 #ifndef dXSTARG
 235 #define dXSTARG SV * targ = ((PL_op->op_private & OPpENTERSUB_HASTARG) \
 236                              ? PAD_SV(PL_op->op_targ) : sv_newmortal())
 237 #endif
 238
 239 #ifndef XSprePUSH
 240 #define XSprePUSH (sp = PL_stack_base + ax - 1)
 241 #endif
 242
 243 #ifndef SV_CWD_ISDOT
 244 #define SV_CWD_ISDOT(dp) \
 245     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
 246         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
 247 #endif
 248
 249 #ifndef getcwd_sv
 250 /* Taken from perl 5.8's util.c */
 251 #define getcwd_sv(a) Perl_getcwd_sv(aTHX_ a)
 252 int Perl_getcwd_sv(pTHX_ register SV *sv)
 253 {
 254 #ifndef PERL_MICRO
 255
 256 #ifndef INCOMPLETE_TAINTS
 257     SvTAINTED_on(sv);
 258 #endif
 259
 260 #ifdef HAS_GETCWD
 261     {
 262         char buf[MAXPATHLEN];
 263
 264         /* Some getcwd()s automatically allocate a buffer of the given
 265          * size from the heap if they are given a NULL buffer pointer.
 266          * The problem is that this behaviour is not portable. */
 267         if (getcwd(buf, sizeof(buf) - 1)) {
 268             STRLEN len = strlen(buf);
 269             sv_setpvn(sv, buf, len);
 270             return TRUE;
 271         }
 272         else {
 273             sv_setsv(sv, &PL_sv_undef);
 274             return FALSE;
 275         }
 276     }
 277
 278 #else
 279   {
 280     Stat_t statbuf;
 281     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
 282     int namelen, pathlen=0;
 283     DIR *dir;
 284     Direntry_t *dp;
 285
 286     (void)SvUPGRADE(sv, SVt_PV);
 287
 288     if (PerlLIO_lstat(".", &statbuf) < 0) {
 289         SV_CWD_RETURN_UNDEF;
 290     }
 291
 292     orig_cdev = statbuf.st_dev;
 293     orig_cino = statbuf.st_ino;
 294     cdev = orig_cdev;
 295     cino = orig_cino;
 296
 297     for (;;) {
 298         odev = cdev;
 299         oino = cino;
 300
 301         if (PerlDir_chdir("..") < 0) {
 302             SV_CWD_RETURN_UNDEF;
 303         }
 304         if (PerlLIO_stat(".", &statbuf) < 0) {
 305             SV_CWD_RETURN_UNDEF;
 306         }
 307
 308         cdev = statbuf.st_dev;
 309         cino = statbuf.st_ino;
 310
 311         if (odev == cdev && oino == cino) {
 312             break;
 313         }
 314         if (!(dir = PerlDir_open("."))) {
 315             SV_CWD_RETURN_UNDEF;
 316         }
 317
 318         while ((dp = PerlDir_read(dir)) != NULL) {
 319 #ifdef DIRNAMLEN
 320             namelen = dp->d_namlen;
 321 #else
 322             namelen = strlen(dp->d_name);
 323 #endif
 324             /* skip . and .. */
 325             if (SV_CWD_ISDOT(dp)) {
 326                 continue;
 327             }
 328
 329             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
 330                 SV_CWD_RETURN_UNDEF;
 331             }
 332
 333             tdev = statbuf.st_dev;
 334             tino = statbuf.st_ino;
 335             if (tino == oino && tdev == odev) {
 336                 break;
 337             }
 338         }
 339
 340         if (!dp) {
 341             SV_CWD_RETURN_UNDEF;
 342         }
 343
 344         if (pathlen + namelen + 1 >= MAXPATHLEN) {
 345             SV_CWD_RETURN_UNDEF;
 346         }
 347
 348         SvGROW(sv, pathlen + namelen + 1);
 349
 350         if (pathlen) {
 351             /* shift down */
 352             Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
 353         }
 354
 355         /* prepend current directory to the front */
 356         *SvPVX(sv) = '/';
 357         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
 358         pathlen += (namelen + 1);
 359
 360 #ifdef VOID_CLOSEDIR
 361         PerlDir_close(dir);
 362 #else
 363         if (PerlDir_close(dir) < 0) {
 364             SV_CWD_RETURN_UNDEF;
 365         }
 366 #endif
 367     }
 368
 369     if (pathlen) {
 370         SvCUR_set(sv, pathlen);
 371         *SvEND(sv) = '\0';
 372         SvPOK_only(sv);
 373
 374         if (PerlDir_chdir(SvPVX(sv)) < 0) {
 375             SV_CWD_RETURN_UNDEF;
 376         }
 377     }
 378     if (PerlLIO_stat(".", &statbuf) < 0) {
 379         SV_CWD_RETURN_UNDEF;
 380     }
 381
 382     cdev = statbuf.st_dev;
 383     cino = statbuf.st_ino;
 384
 385     if (cdev != orig_cdev || cino != orig_cino) {
 386         Perl_croak(aTHX_ "Unstable directory path, "
 387                    "current directory changed unexpectedly");
 388     }
 389
 390     return TRUE;
 391   }
 392 #endif
 393
 394 #else
 395     return FALSE;
 396 #endif
 397 }
 398
 399 #endif
 400
 401
 402 MODULE = Cwd            PACKAGE = Cwd
 403
 404 PROTOTYPES: ENABLE
 405
 406 void
 407 fastcwd()
 408 PROTOTYPE: DISABLE
 409 PPCODE:
 410 {
 411     dXSTARG;
 412     getcwd_sv(TARG);
 413     XSprePUSH; PUSHTARG;
 414 #ifndef INCOMPLETE_TAINTS
 415     SvTAINTED_on(TARG);
 416 #endif
 417 }
 418
 419 void
 420 getcwd(...)
 421 PROTOTYPE: DISABLE
 422 PPCODE:
 423 {
 424     dXSTARG;
 425     getcwd_sv(TARG);
 426     XSprePUSH; PUSHTARG;
 427 #ifndef INCOMPLETE_TAINTS
 428     SvTAINTED_on(TARG);
 429 #endif
 430 }
 431
 432 void
 433 abs_path(pathsv=Nullsv)
 434     SV *pathsv
 435 PROTOTYPE: DISABLE
 436 PPCODE:
 437 {
 438     dXSTARG;
 439     char *path;
 440     char buf[MAXPATHLEN];
 441
 442     path = pathsv ? SvPV_nolen(pathsv) : (char *)".";
 443
 444     if (bsd_realpath(path, buf)) {
 445         sv_setpvn(TARG, buf, strlen(buf));
 446         SvPOK_only(TARG);
 447         SvTAINTED_on(TARG);
 448     }
 449     else
 450         sv_setsv(TARG, &PL_sv_undef);
 451
 452     XSprePUSH; PUSHTARG;
 453 #ifndef INCOMPLETE_TAINTS
 454     SvTAINTED_on(TARG);
 455 #endif
 456 }
 457
 458 #if defined(WIN32) && !defined(UNDER_CE)
 459
 460 void
 461 getdcwd(...)
 462 PPCODE:
 463 {
 464     dXSTARG;
 465     int drive;
 466     char *dir;
 467
 468     /* Drive 0 is the current drive, 1 is A:, 2 is B:, 3 is C: and so on. */
 469     if ( items == 0 ||
 470         (items == 1 && (!SvOK(ST(0)) || (SvPOK(ST(0)) && !SvCUR(ST(0))))))
 471         drive = 0;
 472     else if (items == 1 && SvPOK(ST(0)) && SvCUR(ST(0)) &&
 473              isALPHA(SvPVX(ST(0))[0]))
 474         drive = toUPPER(SvPVX(ST(0))[0]) - 'A' + 1;
 475     else
 476         croak("Usage: getdcwd(DRIVE)");
 477
 478     New(0,dir,MAXPATHLEN,char);
 479     if (_getdcwd(drive, dir, MAXPATHLEN)) {
 480         sv_setpvn(TARG, dir, strlen(dir));
 481         SvPOK_only(TARG);
 482     }
 483     else
 484         sv_setsv(TARG, &PL_sv_undef);
 485
 486     Safefree(dir);
 487
 488     XSprePUSH; PUSHTARG;
 489 #ifndef INCOMPLETE_TAINTS
 490     SvTAINTED_on(TARG);
 491 #endif
 492 }
 493
 494 #endif