cpan/Cwd/Cwd.xs

   1 #include "EXTERN.h"
   2 #include "perl.h"
   3 #include "XSUB.h"
   4 #define NEED_my_strlcpy
   5 #define NEED_my_strlcat
   6 #include "ppport.h"
   7
   8 #ifdef I_UNISTD
   9 #   include <unistd.h>
  10 #endif
  11
  12 /* The realpath() implementation from OpenBSD 3.9 to 4.2 (realpath.c 1.13)
  13  * Renamed here to bsd_realpath() to avoid library conflicts.
  14  */
  15
  16 /* See
  17  * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2004-11/msg00979.html
  18  * for the details of why the BSD license is compatible with the
  19  * AL/GPL standard perl license.
  20  */
  21
  22 /*
  23  * Copyright (c) 2003 Constantin S. Svintsoff <kostik@iclub.nsu.ru>
  24  *
  25  * Redistribution and use in source and binary forms, with or without
  26  * modification, are permitted provided that the following conditions
  27  * are met:
  28  * 1. Redistributions of source code must retain the above copyright
  29  *    notice, this list of conditions and the following disclaimer.
  30  * 2. Redistributions in binary form must reproduce the above copyright
  31  *    notice, this list of conditions and the following disclaimer in the
  32  *    documentation and/or other materials provided with the distribution.
  33  * 3. The names of the authors may not be used to endorse or promote
  34  *    products derived from this software without specific prior written
  35  *    permission.
  36  *
  37  * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
  38  * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  39  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  40  * ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
  41  * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  42  * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  43  * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  44  * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  45  * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  46  * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  47  * SUCH DAMAGE.
  48  */
  49
  50 /* OpenBSD system #includes removed since the Perl ones should do. --jhi */
  51
  52 #ifndef MAXSYMLINKS
  53 #define MAXSYMLINKS 8
  54 #endif
  55
  56 /*
  57  * char *realpath(const char *path, char resolved[MAXPATHLEN]);
  58  *
  59  * Find the real name of path, by removing all ".", ".." and symlink
  60  * components.  Returns (resolved) on success, or (NULL) on failure,
  61  * in which case the path which caused trouble is left in (resolved).
  62  */
  63 static
  64 char *
  65 bsd_realpath(const char *path, char resolved[MAXPATHLEN])
  66 {
  67 #ifdef VMS
  68        dTHX;
  69        return Perl_rmsexpand(aTHX_ (char*)path, resolved, NULL, 0);
  70 #else
  71         char *p, *q, *s;
  72         size_t left_len, resolved_len;
  73         unsigned symlinks;
  74         int serrno;
  75         char left[MAXPATHLEN], next_token[MAXPATHLEN], symlink[MAXPATHLEN];
  76
  77         serrno = errno;
  78         symlinks = 0;
  79         if (path[0] == '/') {
  80                 resolved[0] = '/';
  81                 resolved[1] = '\0';
  82                 if (path[1] == '\0')
  83                         return (resolved);
  84                 resolved_len = 1;
  85                 left_len = my_strlcpy(left, path + 1, sizeof(left));
  86         } else {
  87                 if (getcwd(resolved, MAXPATHLEN) == NULL) {
  88                         my_strlcpy(resolved, ".", MAXPATHLEN);
  89                 return (NULL);
  90         }
  91                 resolved_len = strlen(resolved);
  92                 left_len = my_strlcpy(left, path, sizeof(left));
  93         }
  94         if (left_len >= sizeof(left) || resolved_len >= MAXPATHLEN) {
  95                 errno = ENAMETOOLONG;
  96                 return (NULL);
  97         }
  98
  99         /*
 100          * Iterate over path components in `left'.
 101          */
 102         while (left_len != 0) {
 103                 /*
 104                  * Extract the next path component and adjust `left'
 105                  * and its length.
 106                  */
 107                 p = strchr(left, '/');
 108                 s = p ? p : left + left_len;
 109                 if (s - left >= sizeof(next_token)) {
 110                         errno = ENAMETOOLONG;
 111                         return (NULL);
 112                         }
 113                 memcpy(next_token, left, s - left);
 114                 next_token[s - left] = '\0';
 115                 left_len -= s - left;
 116                 if (p != NULL)
 117                         memmove(left, s + 1, left_len + 1);
 118                 if (resolved[resolved_len - 1] != '/') {
 119                         if (resolved_len + 1 >= MAXPATHLEN) {
 120                                 errno = ENAMETOOLONG;
 121                                 return (NULL);
 122                 }
 123                         resolved[resolved_len++] = '/';
 124                         resolved[resolved_len] = '\0';
 125         }
 126                 if (next_token[0] == '\0')
 127                         continue;
 128                 else if (strcmp(next_token, ".") == 0)
 129                         continue;
 130                 else if (strcmp(next_token, "..") == 0) {
 131                         /*
 132                          * Strip the last path component except when we have
 133                          * single "/"
 134                          */
 135                         if (resolved_len > 1) {
 136                                 resolved[resolved_len - 1] = '\0';
 137                                 q = strrchr(resolved, '/') + 1;
 138                                 *q = '\0';
 139                                 resolved_len = q - resolved;
 140                         }
 141                         continue;
 142     }
 143
 144         /*
 145                  * Append the next path component and lstat() it. If
 146                  * lstat() fails we still can return successfully if
 147                  * there are no more path components left.
 148          */
 149                 resolved_len = my_strlcat(resolved, next_token, MAXPATHLEN);
 150                 if (resolved_len >= MAXPATHLEN) {
 151                         errno = ENAMETOOLONG;
 152                         return (NULL);
 153                 }
 154         #if defined(HAS_LSTAT) && defined(HAS_READLINK) && defined(HAS_SYMLINK)
 155                 {
 156                         struct stat sb;
 157                         if (lstat(resolved, &sb) != 0) {
 158                                 if (errno == ENOENT && p == NULL) {
 159                                         errno = serrno;
 160                                         return (resolved);
 161                                 }
 162                                 return (NULL);
 163                         }
 164                         if (S_ISLNK(sb.st_mode)) {
 165                                 int slen;
 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 (slen + 1 >= 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 #endif
 220 }
 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_ register SV *sv)
 251 {
 252 #ifndef PERL_MICRO
 253
 254 #ifndef INCOMPLETE_TAINTS
 255     SvTAINTED_on(sv);
 256 #endif
 257
 258 #ifdef HAS_GETCWD
 259     {
 260         char buf[MAXPATHLEN];
 261
 262         /* Some getcwd()s automatically allocate a buffer of the given
 263          * size from the heap if they are given a NULL buffer pointer.
 264          * The problem is that this behaviour is not portable. */
 265         if (getcwd(buf, sizeof(buf) - 1)) {
 266             STRLEN len = strlen(buf);
 267             sv_setpvn(sv, buf, len);
 268             return TRUE;
 269         }
 270         else {
 271             sv_setsv(sv, &PL_sv_undef);
 272             return FALSE;
 273         }
 274     }
 275
 276 #else
 277   {
 278     Stat_t statbuf;
 279     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
 280     int namelen, pathlen=0;
 281     DIR *dir;
 282     Direntry_t *dp;
 283
 284     (void)SvUPGRADE(sv, SVt_PV);
 285
 286     if (PerlLIO_lstat(".", &statbuf) < 0) {
 287         SV_CWD_RETURN_UNDEF;
 288     }
 289
 290     orig_cdev = statbuf.st_dev;
 291     orig_cino = statbuf.st_ino;
 292     cdev = orig_cdev;
 293     cino = orig_cino;
 294
 295     for (;;) {
 296         odev = cdev;
 297         oino = cino;
 298
 299         if (PerlDir_chdir("..") < 0) {
 300             SV_CWD_RETURN_UNDEF;
 301         }
 302         if (PerlLIO_stat(".", &statbuf) < 0) {
 303             SV_CWD_RETURN_UNDEF;
 304         }
 305
 306         cdev = statbuf.st_dev;
 307         cino = statbuf.st_ino;
 308
 309         if (odev == cdev && oino == cino) {
 310             break;
 311         }
 312         if (!(dir = PerlDir_open("."))) {
 313             SV_CWD_RETURN_UNDEF;
 314         }
 315
 316         while ((dp = PerlDir_read(dir)) != NULL) {
 317 #ifdef DIRNAMLEN
 318             namelen = dp->d_namlen;
 319 #else
 320             namelen = strlen(dp->d_name);
 321 #endif
 322             /* skip . and .. */
 323             if (SV_CWD_ISDOT(dp)) {
 324                 continue;
 325             }
 326
 327             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
 328                 SV_CWD_RETURN_UNDEF;
 329             }
 330
 331             tdev = statbuf.st_dev;
 332             tino = statbuf.st_ino;
 333             if (tino == oino && tdev == odev) {
 334                 break;
 335             }
 336         }
 337
 338         if (!dp) {
 339             SV_CWD_RETURN_UNDEF;
 340         }
 341
 342         if (pathlen + namelen + 1 >= MAXPATHLEN) {
 343             SV_CWD_RETURN_UNDEF;
 344         }
 345
 346         SvGROW(sv, pathlen + namelen + 1);
 347
 348         if (pathlen) {
 349             /* shift down */
 350             Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
 351         }
 352
 353         /* prepend current directory to the front */
 354         *SvPVX(sv) = '/';
 355         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
 356         pathlen += (namelen + 1);
 357
 358 #ifdef VOID_CLOSEDIR
 359         PerlDir_close(dir);
 360 #else
 361         if (PerlDir_close(dir) < 0) {
 362             SV_CWD_RETURN_UNDEF;
 363         }
 364 #endif
 365     }
 366
 367     if (pathlen) {
 368         SvCUR_set(sv, pathlen);
 369         *SvEND(sv) = '\0';
 370         SvPOK_only(sv);
 371
 372         if (PerlDir_chdir(SvPVX(sv)) < 0) {
 373             SV_CWD_RETURN_UNDEF;
 374         }
 375     }
 376     if (PerlLIO_stat(".", &statbuf) < 0) {
 377         SV_CWD_RETURN_UNDEF;
 378     }
 379
 380     cdev = statbuf.st_dev;
 381     cino = statbuf.st_ino;
 382
 383     if (cdev != orig_cdev || cino != orig_cino) {
 384         Perl_croak(aTHX_ "Unstable directory path, "
 385                    "current directory changed unexpectedly");
 386     }
 387
 388     return TRUE;
 389   }
 390 #endif
 391
 392 #else
 393     return FALSE;
 394 #endif
 395 }
 396
 397 #endif
 398
 399
 400 MODULE = Cwd            PACKAGE = Cwd
 401
 402 PROTOTYPES: ENABLE
 403
 404 void
 405 fastcwd()
 406 PROTOTYPE: DISABLE
 407 PPCODE:
 408 {
 409     dXSTARG;
 410     getcwd_sv(TARG);
 411     XSprePUSH; PUSHTARG;
 412 #ifndef INCOMPLETE_TAINTS
 413     SvTAINTED_on(TARG);
 414 #endif
 415 }
 416
 417 void
 418 getcwd(...)
 419 PROTOTYPE: DISABLE
 420 PPCODE:
 421 {
 422     dXSTARG;
 423     getcwd_sv(TARG);
 424     XSprePUSH; PUSHTARG;
 425 #ifndef INCOMPLETE_TAINTS
 426     SvTAINTED_on(TARG);
 427 #endif
 428 }
 429
 430 void
 431 abs_path(pathsv=Nullsv)
 432     SV *pathsv
 433 PROTOTYPE: DISABLE
 434 PPCODE:
 435 {
 436     dXSTARG;
 437     char *path;
 438     char buf[MAXPATHLEN];
 439
 440     path = pathsv ? SvPV_nolen(pathsv) : (char *)".";
 441
 442     if (bsd_realpath(path, buf)) {
 443         sv_setpvn(TARG, buf, strlen(buf));
 444         SvPOK_only(TARG);
 445         SvTAINTED_on(TARG);
 446     }
 447     else
 448         sv_setsv(TARG, &PL_sv_undef);
 449
 450     XSprePUSH; PUSHTARG;
 451 #ifndef INCOMPLETE_TAINTS
 452     SvTAINTED_on(TARG);
 453 #endif
 454 }
 455
 456 #if defined(WIN32) && !defined(UNDER_CE)
 457
 458 void
 459 getdcwd(...)
 460 PPCODE:
 461 {
 462     dXSTARG;
 463     int drive;
 464     char *dir;
 465
 466     /* Drive 0 is the current drive, 1 is A:, 2 is B:, 3 is C: and so on. */
 467     if ( items == 0 ||
 468         (items == 1 && (!SvOK(ST(0)) || (SvPOK(ST(0)) && !SvCUR(ST(0))))))
 469         drive = 0;
 470     else if (items == 1 && SvPOK(ST(0)) && SvCUR(ST(0)) &&
 471              isALPHA(SvPVX(ST(0))[0]))
 472         drive = toUPPER(SvPVX(ST(0))[0]) - 'A' + 1;
 473     else
 474         croak("Usage: getdcwd(DRIVE)");
 475
 476     New(0,dir,MAXPATHLEN,char);
 477     if (_getdcwd(drive, dir, MAXPATHLEN)) {
 478         sv_setpvn(TARG, dir, strlen(dir));
 479         SvPOK_only(TARG);
 480     }
 481     else
 482         sv_setsv(TARG, &PL_sv_undef);
 483
 484     Safefree(dir);
 485
 486     XSprePUSH; PUSHTARG;
 487 #ifndef INCOMPLETE_TAINTS
 488     SvTAINTED_on(TARG);
 489 #endif
 490 }
 491
 492 #endif