doio.c

   1 /*    doio.c
   2  *
   3  *    Copyright (c) 1991-1997, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "Far below them they saw the white waters pour into a foaming bowl, and
  12  * then swirl darkly about a deep oval basin in the rocks, until they found
  13  * their way out again through a narrow gate, and flowed away, fuming and
  14  * chattering, into calmer and more level reaches."
  15  */
  16
  17 #include "EXTERN.h"
  18 #include "perl.h"
  19
  20 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
  21 #include <sys/ipc.h>
  22 #ifdef HAS_MSG
  23 #include <sys/msg.h>
  24 #endif
  25 #ifdef HAS_SEM
  26 #include <sys/sem.h>
  27 #endif
  28 #ifdef HAS_SHM
  29 #include <sys/shm.h>
  30 # ifndef HAS_SHMAT_PROTOTYPE
  31     extern Shmat_t shmat _((int, char *, int));
  32 # endif
  33 #endif
  34 #endif
  35
  36 #ifdef I_UTIME
  37 #  if defined(_MSC_VER) || defined(__MINGW32__)
  38 #    include <sys/utime.h>
  39 #  else
  40 #    include <utime.h>
  41 #  endif
  42 #endif
  43
  44 #ifdef I_FCNTL
  45 #include <fcntl.h>
  46 #endif
  47 #ifdef I_SYS_FILE
  48 #include <sys/file.h>
  49 #endif
  50 #ifdef O_EXCL
  51 #  define OPEN_EXCL O_EXCL
  52 #else
  53 #  define OPEN_EXCL 0
  54 #endif
  55
  56 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
  57 #include <signal.h>
  58 #endif
  59
  60 /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
  61 #ifdef I_UNISTD
  62 #  include <unistd.h>
  63 #endif
  64
  65 #if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
  66 # include <sys/socket.h>
  67 # include <netdb.h>
  68 # ifndef ENOTSOCK
  69 #  ifdef I_NET_ERRNO
  70 #   include <net/errno.h>
  71 #  endif
  72 # endif
  73 #endif
  74
  75 /* Put this after #includes because <unistd.h> defines _XOPEN_*. */
  76 #ifndef Sock_size_t
  77 #  if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__)
  78 #    define Sock_size_t Size_t
  79 #  else
  80 #    define Sock_size_t int
  81 #  endif
  82 #endif
  83
  84 bool
  85 do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp)
  86 {
  87     register IO *io = GvIOn(gv);
  88     PerlIO *saveifp = Nullfp;
  89     PerlIO *saveofp = Nullfp;
  90     char savetype = ' ';
  91     int writing = 0;
  92     PerlIO *fp;
  93     int fd;
  94     int result;
  95     bool was_fdopen = FALSE;
  96
  97     forkprocess = 1;            /* assume true if no fork */
  98
  99     if (IoIFP(io)) {
 100         fd = PerlIO_fileno(IoIFP(io));
 101         if (IoTYPE(io) == '-')
 102             result = 0;
 103         else if (fd <= maxsysfd) {
 104             saveifp = IoIFP(io);
 105             saveofp = IoOFP(io);
 106             savetype = IoTYPE(io);
 107             result = 0;
 108         }
 109         else if (IoTYPE(io) == '|')
 110             result = PerlProc_pclose(IoIFP(io));
 111         else if (IoIFP(io) != IoOFP(io)) {
 112             if (IoOFP(io)) {
 113                 result = PerlIO_close(IoOFP(io));
 114                 PerlIO_close(IoIFP(io));        /* clear stdio, fd already closed */
 115             }
 116             else
 117                 result = PerlIO_close(IoIFP(io));
 118         }
 119         else
 120             result = PerlIO_close(IoIFP(io));
 121         if (result == EOF && fd > maxsysfd)
 122             PerlIO_printf(PerlIO_stderr(), "Warning: unable to close filehandle %s properly.\n",
 123               GvENAME(gv));
 124         IoOFP(io) = IoIFP(io) = Nullfp;
 125     }
 126
 127     if (as_raw) {
 128         result = rawmode & 3;
 129         IoTYPE(io) = "<>++"[result];
 130         writing = (result > 0);
 131         fd = PerlLIO_open3(name, rawmode, rawperm);
 132         if (fd == -1)
 133             fp = NULL;
 134         else {
 135             char *fpmode;
 136             if (result == 0)
 137                 fpmode = "r";
 138 #ifdef O_APPEND
 139             else if (rawmode & O_APPEND)
 140                 fpmode = (result == 1) ? "a" : "a+";
 141 #endif
 142             else
 143                 fpmode = (result == 1) ? "w" : "r+";
 144             fp = PerlIO_fdopen(fd, fpmode);
 145             if (!fp)
 146                 PerlLIO_close(fd);
 147         }
 148     }
 149     else {
 150         char *myname;
 151         char mode[3];           /* stdio file mode ("r\0" or "r+\0") */
 152         int dodup;
 153
 154         myname = savepvn(name, len);
 155         SAVEFREEPV(myname);
 156         name = myname;
 157         while (len && isSPACE(name[len-1]))
 158             name[--len] = '\0';
 159
 160         mode[0] = mode[1] = mode[2] = '\0';
 161         IoTYPE(io) = *name;
 162         if (*name == '+' && len > 1 && name[len-1] != '|') { /* scary */
 163             mode[1] = *name++;
 164             --len;
 165             writing = 1;
 166         }
 167
 168         if (*name == '|') {
 169             /*SUPPRESS 530*/
 170             for (name++; isSPACE(*name); name++) ;
 171             if (strNE(name,"-"))
 172                 TAINT_ENV();
 173             TAINT_PROPER("piped open");
 174             if (dowarn && name[strlen(name)-1] == '|')
 175                 warn("Can't do bidirectional pipe");
 176             fp = PerlProc_popen(name,"w");
 177             writing = 1;
 178         }
 179         else if (*name == '>') {
 180             TAINT_PROPER("open");
 181             name++;
 182             if (*name == '>') {
 183                 mode[0] = IoTYPE(io) = 'a';
 184                 name++;
 185             }
 186             else
 187                 mode[0] = 'w';
 188             writing = 1;
 189
 190             if (*name == '&') {
 191               duplicity:
 192                 dodup = 1;
 193                 name++;
 194                 if (*name == '=') {
 195                     dodup = 0;
 196                     name++;
 197                 }
 198                 if (!*name && supplied_fp)
 199                     fp = supplied_fp;
 200                 else {
 201                     /*SUPPRESS 530*/
 202                     for (; isSPACE(*name); name++) ;
 203                     if (isDIGIT(*name))
 204                         fd = atoi(name);
 205                     else {
 206                         IO* thatio;
 207                         gv = gv_fetchpv(name,FALSE,SVt_PVIO);
 208                         thatio = GvIO(gv);
 209                         if (!thatio) {
 210 #ifdef EINVAL
 211                             SETERRNO(EINVAL,SS$_IVCHAN);
 212 #endif
 213                             goto say_false;
 214                         }
 215                         if (IoIFP(thatio)) {
 216                             fd = PerlIO_fileno(IoIFP(thatio));
 217                             if (IoTYPE(thatio) == 's')
 218                                 IoTYPE(io) = 's';
 219                         }
 220                         else
 221                             fd = -1;
 222                     }
 223                     if (dodup)
 224                         fd = PerlLIO_dup(fd);
 225                     else
 226                         was_fdopen = TRUE;
 227                     if (!(fp = PerlIO_fdopen(fd,mode))) {
 228                         if (dodup)
 229                             PerlLIO_close(fd);
 230                         }
 231                 }
 232             }
 233             else {
 234                 /*SUPPRESS 530*/
 235                 for (; isSPACE(*name); name++) ;
 236                 if (strEQ(name,"-")) {
 237                     fp = PerlIO_stdout();
 238                     IoTYPE(io) = '-';
 239                 }
 240                 else  {
 241                     fp = PerlIO_open(name,mode);
 242                 }
 243             }
 244         }
 245         else if (*name == '<') {
 246             /*SUPPRESS 530*/
 247             for (name++; isSPACE(*name); name++) ;
 248             mode[0] = 'r';
 249             if (*name == '&')
 250                 goto duplicity;
 251             if (strEQ(name,"-")) {
 252                 fp = PerlIO_stdin();
 253                 IoTYPE(io) = '-';
 254             }
 255             else
 256                 fp = PerlIO_open(name,mode);
 257         }
 258         else if (name[len-1] == '|') {
 259             name[--len] = '\0';
 260             while (len && isSPACE(name[len-1]))
 261                 name[--len] = '\0';
 262             /*SUPPRESS 530*/
 263             for (; isSPACE(*name); name++) ;
 264             if (strNE(name,"-"))
 265                 TAINT_ENV();
 266             TAINT_PROPER("piped open");
 267             fp = PerlProc_popen(name,"r");
 268             IoTYPE(io) = '|';
 269         }
 270         else {
 271             IoTYPE(io) = '<';
 272             /*SUPPRESS 530*/
 273             for (; isSPACE(*name); name++) ;
 274             if (strEQ(name,"-")) {
 275                 fp = PerlIO_stdin();
 276                 IoTYPE(io) = '-';
 277             }
 278             else
 279                 fp = PerlIO_open(name,"r");
 280         }
 281     }
 282     if (!fp) {
 283         if (dowarn && IoTYPE(io) == '<' && strchr(name, '\n'))
 284             warn(warn_nl, "open");
 285         goto say_false;
 286     }
 287     if (IoTYPE(io) &&
 288       IoTYPE(io) != '|' && IoTYPE(io) != '-') {
 289         dTHR;
 290         if (PerlLIO_fstat(PerlIO_fileno(fp),&statbuf) < 0) {
 291             (void)PerlIO_close(fp);
 292             goto say_false;
 293         }
 294         if (S_ISSOCK(statbuf.st_mode))
 295             IoTYPE(io) = 's';   /* in case a socket was passed in to us */
 296 #ifdef HAS_SOCKET
 297         else if (
 298 #ifdef S_IFMT
 299             !(statbuf.st_mode & S_IFMT)
 300 #else
 301             !statbuf.st_mode
 302 #endif
 303         ) {
 304             char tmpbuf[256];
 305             Sock_size_t buflen = sizeof tmpbuf;
 306             if (PerlSock_getsockname(PerlIO_fileno(fp), (struct sockaddr *)tmpbuf,
 307                             &buflen) >= 0
 308                   || errno != ENOTSOCK)
 309                 IoTYPE(io) = 's'; /* some OS's return 0 on fstat()ed socket */
 310                                 /* but some return 0 for streams too, sigh */
 311         }
 312 #endif
 313     }
 314     if (saveifp) {              /* must use old fp? */
 315         fd = PerlIO_fileno(saveifp);
 316         if (saveofp) {
 317             PerlIO_flush(saveofp);              /* emulate PerlIO_close() */
 318             if (saveofp != saveifp) {   /* was a socket? */
 319                 PerlIO_close(saveofp);
 320                 if (fd > 2)
 321                     Safefree(saveofp);
 322             }
 323         }
 324         if (fd != PerlIO_fileno(fp)) {
 325             int pid;
 326             SV *sv;
 327
 328             PerlLIO_dup2(PerlIO_fileno(fp), fd);
 329             sv = *av_fetch(fdpid,PerlIO_fileno(fp),TRUE);
 330             (void)SvUPGRADE(sv, SVt_IV);
 331             pid = SvIVX(sv);
 332             SvIVX(sv) = 0;
 333             sv = *av_fetch(fdpid,fd,TRUE);
 334             (void)SvUPGRADE(sv, SVt_IV);
 335             SvIVX(sv) = pid;
 336             if (!was_fdopen)
 337                 PerlIO_close(fp);
 338
 339         }
 340         fp = saveifp;
 341         PerlIO_clearerr(fp);
 342     }
 343 #if defined(HAS_FCNTL) && defined(F_SETFD)
 344     fd = PerlIO_fileno(fp);
 345     fcntl(fd,F_SETFD,fd > maxsysfd);
 346 #endif
 347     IoIFP(io) = fp;
 348     if (writing) {
 349         dTHR;
 350         if (IoTYPE(io) == 's'
 351           || (IoTYPE(io) == '>' && S_ISCHR(statbuf.st_mode)) ) {
 352             if (!(IoOFP(io) = PerlIO_fdopen(PerlIO_fileno(fp),"w"))) {
 353                 PerlIO_close(fp);
 354                 IoIFP(io) = Nullfp;
 355                 goto say_false;
 356             }
 357         }
 358         else
 359             IoOFP(io) = fp;
 360     }
 361     return TRUE;
 362
 363 say_false:
 364     IoIFP(io) = saveifp;
 365     IoOFP(io) = saveofp;
 366     IoTYPE(io) = savetype;
 367     return FALSE;
 368 }
 369
 370 PerlIO *
 371 nextargv(register GV *gv)
 372 {
 373     register SV *sv;
 374 #ifndef FLEXFILENAMES
 375     int filedev;
 376     int fileino;
 377 #endif
 378     int fileuid;
 379     int filegid;
 380
 381     if (!argvoutgv)
 382         argvoutgv = gv_fetchpv("ARGVOUT",TRUE,SVt_PVIO);
 383     if (filemode & (S_ISUID|S_ISGID)) {
 384         PerlIO_flush(IoIFP(GvIOn(argvoutgv)));  /* chmod must follow last write */
 385 #ifdef HAS_FCHMOD
 386         (void)fchmod(lastfd,filemode);
 387 #else
 388         (void)PerlLIO_chmod(oldname,filemode);
 389 #endif
 390     }
 391     filemode = 0;
 392     while (av_len(GvAV(gv)) >= 0) {
 393         dTHR;
 394         STRLEN oldlen;
 395         sv = av_shift(GvAV(gv));
 396         SAVEFREESV(sv);
 397         sv_setsv(GvSV(gv),sv);
 398         SvSETMAGIC(GvSV(gv));
 399         oldname = SvPVx(GvSV(gv), oldlen);
 400         if (do_open(gv,oldname,oldlen,inplace!=0,0,0,Nullfp)) {
 401             if (inplace) {
 402                 TAINT_PROPER("inplace open");
 403                 if (oldlen == 1 && *oldname == '-') {
 404                     setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
 405                     return IoIFP(GvIOp(gv));
 406                 }
 407 #ifndef FLEXFILENAMES
 408                 filedev = statbuf.st_dev;
 409                 fileino = statbuf.st_ino;
 410 #endif
 411                 filemode = statbuf.st_mode;
 412                 fileuid = statbuf.st_uid;
 413                 filegid = statbuf.st_gid;
 414                 if (!S_ISREG(filemode)) {
 415                     warn("Can't do inplace edit: %s is not a regular file",
 416                       oldname );
 417                     do_close(gv,FALSE);
 418                     continue;
 419                 }
 420                 if (*inplace) {
 421 #ifdef SUFFIX
 422                     add_suffix(sv,inplace);
 423 #else
 424                     sv_catpv(sv,inplace);
 425 #endif
 426 #ifndef FLEXFILENAMES
 427                     if (PerlLIO_stat(SvPVX(sv),&statbuf) >= 0
 428                       && statbuf.st_dev == filedev
 429                       && statbuf.st_ino == fileino
 430 #ifdef DJGPP
 431                       || (_djstat_fail_bits & _STFAIL_TRUENAME)!=0
 432 #endif
 433                       ) {
 434                         warn("Can't do inplace edit: %s would not be uniq",
 435                           SvPVX(sv) );
 436                         do_close(gv,FALSE);
 437                         continue;
 438                     }
 439 #endif
 440 #ifdef HAS_RENAME
 441 #ifndef DOSISH
 442                     if (PerlLIO_rename(oldname,SvPVX(sv)) < 0) {
 443                         warn("Can't rename %s to %s: %s, skipping file",
 444                           oldname, SvPVX(sv), Strerror(errno) );
 445                         do_close(gv,FALSE);
 446                         continue;
 447                     }
 448 #else
 449                     do_close(gv,FALSE);
 450                     (void)PerlLIO_unlink(SvPVX(sv));
 451                     (void)PerlLIO_rename(oldname,SvPVX(sv));
 452                     do_open(gv,SvPVX(sv),SvCUR(sv),inplace!=0,0,0,Nullfp);
 453 #endif /* DOSISH */
 454 #else
 455                     (void)UNLINK(SvPVX(sv));
 456                     if (link(oldname,SvPVX(sv)) < 0) {
 457                         warn("Can't rename %s to %s: %s, skipping file",
 458                           oldname, SvPVX(sv), Strerror(errno) );
 459                         do_close(gv,FALSE);
 460                         continue;
 461                     }
 462                     (void)UNLINK(oldname);
 463 #endif
 464                 }
 465                 else {
 466 #if !defined(DOSISH) && !defined(AMIGAOS)
 467 #  ifndef VMS  /* Don't delete; use automatic file versioning */
 468                     if (UNLINK(oldname) < 0) {
 469                         warn("Can't remove %s: %s, skipping file",
 470                           oldname, Strerror(errno) );
 471                         do_close(gv,FALSE);
 472                         continue;
 473                     }
 474 #  endif
 475 #else
 476                     croak("Can't do inplace edit without backup");
 477 #endif
 478                 }
 479
 480                 sv_setpvn(sv,">",!inplace);
 481                 sv_catpvn(sv,oldname,oldlen);
 482                 SETERRNO(0,0);          /* in case sprintf set errno */
 483                 if (!do_open(argvoutgv,SvPVX(sv),SvCUR(sv),inplace!=0,
 484                              O_WRONLY|O_CREAT|OPEN_EXCL,0666,Nullfp)) {
 485                     warn("Can't do inplace edit on %s: %s",
 486                       oldname, Strerror(errno) );
 487                     do_close(gv,FALSE);
 488                     continue;
 489                 }
 490                 setdefout(argvoutgv);
 491                 lastfd = PerlIO_fileno(IoIFP(GvIOp(argvoutgv)));
 492                 (void)PerlLIO_fstat(lastfd,&statbuf);
 493 #ifdef HAS_FCHMOD
 494                 (void)fchmod(lastfd,filemode);
 495 #else
 496 #  if !(defined(WIN32) && defined(__BORLANDC__))
 497                 /* Borland runtime creates a readonly file! */
 498                 (void)PerlLIO_chmod(oldname,filemode);
 499 #  endif
 500 #endif
 501                 if (fileuid != statbuf.st_uid || filegid != statbuf.st_gid) {
 502 #ifdef HAS_FCHOWN
 503                     (void)fchown(lastfd,fileuid,filegid);
 504 #else
 505 #ifdef HAS_CHOWN
 506                     (void)chown(oldname,fileuid,filegid);
 507 #endif
 508 #endif
 509                 }
 510             }
 511             return IoIFP(GvIOp(gv));
 512         }
 513         else
 514             PerlIO_printf(PerlIO_stderr(), "Can't open %s: %s\n",
 515               SvPV(sv, na), Strerror(errno));
 516     }
 517     if (inplace) {
 518         (void)do_close(argvoutgv,FALSE);
 519         setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
 520     }
 521     return Nullfp;
 522 }
 523
 524 #ifdef HAS_PIPE
 525 void
 526 do_pipe(SV *sv, GV *rgv, GV *wgv)
 527 {
 528     register IO *rstio;
 529     register IO *wstio;
 530     int fd[2];
 531
 532     if (!rgv)
 533         goto badexit;
 534     if (!wgv)
 535         goto badexit;
 536
 537     rstio = GvIOn(rgv);
 538     wstio = GvIOn(wgv);
 539
 540     if (IoIFP(rstio))
 541         do_close(rgv,FALSE);
 542     if (IoIFP(wstio))
 543         do_close(wgv,FALSE);
 544
 545     if (PerlProc_pipe(fd) < 0)
 546         goto badexit;
 547     IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
 548     IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
 549     IoIFP(wstio) = IoOFP(wstio);
 550     IoTYPE(rstio) = '<';
 551     IoTYPE(wstio) = '>';
 552     if (!IoIFP(rstio) || !IoOFP(wstio)) {
 553         if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
 554         else PerlLIO_close(fd[0]);
 555         if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
 556         else PerlLIO_close(fd[1]);
 557         goto badexit;
 558     }
 559
 560     sv_setsv(sv,&sv_yes);
 561     return;
 562
 563 badexit:
 564     sv_setsv(sv,&sv_undef);
 565     return;
 566 }
 567 #endif
 568
 569 /* explicit renamed to avoid C++ conflict    -- kja */
 570 bool
 571 do_close(GV *gv, bool not_implicit)
 572 {
 573     bool retval;
 574     IO *io;
 575
 576     if (!gv)
 577         gv = argvgv;
 578     if (!gv || SvTYPE(gv) != SVt_PVGV) {
 579         SETERRNO(EBADF,SS$_IVCHAN);
 580         return FALSE;
 581     }
 582     io = GvIO(gv);
 583     if (!io) {          /* never opened */
 584         if (dowarn && not_implicit)
 585             warn("Close on unopened file <%s>",GvENAME(gv));
 586         SETERRNO(EBADF,SS$_IVCHAN);
 587         return FALSE;
 588     }
 589     retval = io_close(io);
 590     if (not_implicit) {
 591         IoLINES(io) = 0;
 592         IoPAGE(io) = 0;
 593         IoLINES_LEFT(io) = IoPAGE_LEN(io);
 594     }
 595     IoTYPE(io) = ' ';
 596     return retval;
 597 }
 598
 599 bool
 600 io_close(IO *io)
 601 {
 602     bool retval = FALSE;
 603     int status;
 604
 605     if (IoIFP(io)) {
 606         if (IoTYPE(io) == '|') {
 607             status = PerlProc_pclose(IoIFP(io));
 608             STATUS_NATIVE_SET(status);
 609             retval = (STATUS_POSIX == 0);
 610         }
 611         else if (IoTYPE(io) == '-')
 612             retval = TRUE;
 613         else {
 614             if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {          /* a socket */
 615                 retval = (PerlIO_close(IoOFP(io)) != EOF);
 616                 PerlIO_close(IoIFP(io));        /* clear stdio, fd already closed */
 617             }
 618             else
 619                 retval = (PerlIO_close(IoIFP(io)) != EOF);
 620         }
 621         IoOFP(io) = IoIFP(io) = Nullfp;
 622     }
 623     else {
 624         SETERRNO(EBADF,SS$_IVCHAN);
 625     }
 626
 627     return retval;
 628 }
 629
 630 bool
 631 do_eof(GV *gv)
 632 {
 633     dTHR;
 634     register IO *io;
 635     int ch;
 636
 637     io = GvIO(gv);
 638
 639     if (!io)
 640         return TRUE;
 641
 642     while (IoIFP(io)) {
 643
 644         if (PerlIO_has_cntptr(IoIFP(io))) {     /* (the code works without this) */
 645             if (PerlIO_get_cnt(IoIFP(io)) > 0)  /* cheat a little, since */
 646                 return FALSE;                   /* this is the most usual case */
 647         }
 648
 649         ch = PerlIO_getc(IoIFP(io));
 650         if (ch != EOF) {
 651             (void)PerlIO_ungetc(IoIFP(io),ch);
 652             return FALSE;
 653         }
 654         if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) {
 655             if (PerlIO_get_cnt(IoIFP(io)) < -1)
 656                 PerlIO_set_cnt(IoIFP(io),-1);
 657         }
 658         if (op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */
 659             if (!nextargv(argvgv))      /* get another fp handy */
 660                 return TRUE;
 661         }
 662         else
 663             return TRUE;                /* normal fp, definitely end of file */
 664     }
 665     return TRUE;
 666 }
 667
 668 long
 669 do_tell(GV *gv)
 670 {
 671     register IO *io;
 672     register PerlIO *fp;
 673
 674     if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
 675 #ifdef ULTRIX_STDIO_BOTCH
 676         if (PerlIO_eof(fp))
 677             (void)PerlIO_seek(fp, 0L, 2);       /* ultrix 1.2 workaround */
 678 #endif
 679         return PerlIO_tell(fp);
 680     }
 681     if (dowarn)
 682         warn("tell() on unopened file");
 683     SETERRNO(EBADF,RMS$_IFI);
 684     return -1L;
 685 }
 686
 687 bool
 688 do_seek(GV *gv, long int pos, int whence)
 689 {
 690     register IO *io;
 691     register PerlIO *fp;
 692
 693     if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
 694 #ifdef ULTRIX_STDIO_BOTCH
 695         if (PerlIO_eof(fp))
 696             (void)PerlIO_seek(fp, 0L, 2);       /* ultrix 1.2 workaround */
 697 #endif
 698         return PerlIO_seek(fp, pos, whence) >= 0;
 699     }
 700     if (dowarn)
 701         warn("seek() on unopened file");
 702     SETERRNO(EBADF,RMS$_IFI);
 703     return FALSE;
 704 }
 705
 706 long
 707 do_sysseek(GV *gv, long int pos, int whence)
 708 {
 709     register IO *io;
 710     register PerlIO *fp;
 711
 712     if (gv && (io = GvIO(gv)) && (fp = IoIFP(io)))
 713         return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
 714     if (dowarn)
 715         warn("sysseek() on unopened file");
 716     SETERRNO(EBADF,RMS$_IFI);
 717     return -1L;
 718 }
 719
 720 #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
 721         /* code courtesy of William Kucharski */
 722 #define HAS_CHSIZE
 723
 724 I32 my_chsize(fd, length)
 725 I32 fd;                 /* file descriptor */
 726 Off_t length;           /* length to set file to */
 727 {
 728     struct flock fl;
 729     struct stat filebuf;
 730
 731     if (PerlLIO_fstat(fd, &filebuf) < 0)
 732         return -1;
 733
 734     if (filebuf.st_size < length) {
 735
 736         /* extend file length */
 737
 738         if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
 739             return -1;
 740
 741         /* write a "0" byte */
 742
 743         if ((PerlLIO_write(fd, "", 1)) != 1)
 744             return -1;
 745     }
 746     else {
 747         /* truncate length */
 748
 749         fl.l_whence = 0;
 750         fl.l_len = 0;
 751         fl.l_start = length;
 752         fl.l_type = F_WRLCK;    /* write lock on file space */
 753
 754         /*
 755         * This relies on the UNDOCUMENTED F_FREESP argument to
 756         * fcntl(2), which truncates the file so that it ends at the
 757         * position indicated by fl.l_start.
 758         *
 759         * Will minor miracles never cease?
 760         */
 761
 762         if (fcntl(fd, F_FREESP, &fl) < 0)
 763             return -1;
 764
 765     }
 766
 767     return 0;
 768 }
 769 #endif /* F_FREESP */
 770
 771 bool
 772 do_print(register SV *sv, PerlIO *fp)
 773 {
 774     register char *tmps;
 775     STRLEN len;
 776
 777     /* assuming fp is checked earlier */
 778     if (!sv)
 779         return TRUE;
 780     if (ofmt) {
 781         if (SvGMAGICAL(sv))
 782             mg_get(sv);
 783         if (SvIOK(sv) && SvIVX(sv) != 0) {
 784             PerlIO_printf(fp, ofmt, (double)SvIVX(sv));
 785             return !PerlIO_error(fp);
 786         }
 787         if (  (SvNOK(sv) && SvNVX(sv) != 0.0)
 788            || (looks_like_number(sv) && sv_2nv(sv) != 0.0) ) {
 789             PerlIO_printf(fp, ofmt, SvNVX(sv));
 790             return !PerlIO_error(fp);
 791         }
 792     }
 793     switch (SvTYPE(sv)) {
 794     case SVt_NULL:
 795         if (dowarn)
 796             warn(warn_uninit);
 797         return TRUE;
 798     case SVt_IV:
 799         if (SvIOK(sv)) {
 800             if (SvGMAGICAL(sv))
 801                 mg_get(sv);
 802             PerlIO_printf(fp, "%ld", (long)SvIVX(sv));
 803             return !PerlIO_error(fp);
 804         }
 805         /* FALL THROUGH */
 806     default:
 807         tmps = SvPV(sv, len);
 808         break;
 809     }
 810     if (len && (PerlIO_write(fp,tmps,len) == 0 || PerlIO_error(fp)))
 811         return FALSE;
 812     return !PerlIO_error(fp);
 813 }
 814
 815 I32
 816 my_stat(ARGSproto)
 817 {
 818     djSP;
 819     IO *io;
 820     GV* tmpgv;
 821
 822     if (op->op_flags & OPf_REF) {
 823         EXTEND(SP,1);
 824         tmpgv = cGVOP->op_gv;
 825       do_fstat:
 826         io = GvIO(tmpgv);
 827         if (io && IoIFP(io)) {
 828             statgv = tmpgv;
 829             sv_setpv(statname,"");
 830             laststype = OP_STAT;
 831             return (laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &statcache));
 832         }
 833         else {
 834             if (tmpgv == defgv)
 835                 return laststatval;
 836             if (dowarn)
 837                 warn("Stat on unopened file <%s>",
 838                   GvENAME(tmpgv));
 839             statgv = Nullgv;
 840             sv_setpv(statname,"");
 841             return (laststatval = -1);
 842         }
 843     }
 844     else {
 845         SV* sv = POPs;
 846         char *s;
 847         PUTBACK;
 848         if (SvTYPE(sv) == SVt_PVGV) {
 849             tmpgv = (GV*)sv;
 850             goto do_fstat;
 851         }
 852         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
 853             tmpgv = (GV*)SvRV(sv);
 854             goto do_fstat;
 855         }
 856
 857         s = SvPV(sv, na);
 858         statgv = Nullgv;
 859         sv_setpv(statname, s);
 860         laststype = OP_STAT;
 861         laststatval = PerlLIO_stat(s, &statcache);
 862         if (laststatval < 0 && dowarn && strchr(s, '\n'))
 863             warn(warn_nl, "stat");
 864         return laststatval;
 865     }
 866 }
 867
 868 I32
 869 my_lstat(ARGSproto)
 870 {
 871     djSP;
 872     SV *sv;
 873     if (op->op_flags & OPf_REF) {
 874         EXTEND(SP,1);
 875         if (cGVOP->op_gv == defgv) {
 876             if (laststype != OP_LSTAT)
 877                 croak("The stat preceding -l _ wasn't an lstat");
 878             return laststatval;
 879         }
 880         croak("You can't use -l on a filehandle");
 881     }
 882
 883     laststype = OP_LSTAT;
 884     statgv = Nullgv;
 885     sv = POPs;
 886     PUTBACK;
 887     sv_setpv(statname,SvPV(sv, na));
 888 #ifdef HAS_LSTAT
 889     laststatval = PerlLIO_lstat(SvPV(sv, na),&statcache);
 890 #else
 891     laststatval = PerlLIO_stat(SvPV(sv, na),&statcache);
 892 #endif
 893     if (laststatval < 0 && dowarn && strchr(SvPV(sv, na), '\n'))
 894         warn(warn_nl, "lstat");
 895     return laststatval;
 896 }
 897
 898 bool
 899 do_aexec(SV *really, register SV **mark, register SV **sp)
 900 {
 901     register char **a;
 902     char *tmps;
 903
 904     if (sp > mark) {
 905         dTHR;
 906         New(401,Argv, sp - mark + 1, char*);
 907         a = Argv;
 908         while (++mark <= sp) {
 909             if (*mark)
 910                 *a++ = SvPVx(*mark, na);
 911             else
 912                 *a++ = "";
 913         }
 914         *a = Nullch;
 915         if (*Argv[0] != '/')    /* will execvp use PATH? */
 916             TAINT_ENV();                /* testing IFS here is overkill, probably */
 917         if (really && *(tmps = SvPV(really, na)))
 918             PerlProc_execvp(tmps,Argv);
 919         else
 920             PerlProc_execvp(Argv[0],Argv);
 921         if (dowarn)
 922             warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno));
 923     }
 924     do_execfree();
 925     return FALSE;
 926 }
 927
 928 void
 929 do_execfree(void)
 930 {
 931     if (Argv) {
 932         Safefree(Argv);
 933         Argv = Null(char **);
 934     }
 935     if (Cmd) {
 936         Safefree(Cmd);
 937         Cmd = Nullch;
 938     }
 939 }
 940
 941 #if !defined(OS2) && !defined(WIN32) && !defined(DJGPP)
 942
 943 bool
 944 do_exec(char *cmd)
 945 {
 946     register char **a;
 947     register char *s;
 948     char flags[10];
 949
 950     while (*cmd && isSPACE(*cmd))
 951         cmd++;
 952
 953     /* save an extra exec if possible */
 954
 955 #ifdef CSH
 956     if (strnEQ(cmd,cshname,cshlen) && strnEQ(cmd+cshlen," -c",3)) {
 957         strcpy(flags,"-c");
 958         s = cmd+cshlen+3;
 959         if (*s == 'f') {
 960             s++;
 961             strcat(flags,"f");
 962         }
 963         if (*s == ' ')
 964             s++;
 965         if (*s++ == '\'') {
 966             char *ncmd = s;
 967
 968             while (*s)
 969                 s++;
 970             if (s[-1] == '\n')
 971                 *--s = '\0';
 972             if (s[-1] == '\'') {
 973                 *--s = '\0';
 974                 PerlProc_execl(cshname,"csh", flags,ncmd,(char*)0);
 975                 *s = '\'';
 976                 return FALSE;
 977             }
 978         }
 979     }
 980 #endif /* CSH */
 981
 982     /* see if there are shell metacharacters in it */
 983
 984     if (*cmd == '.' && isSPACE(cmd[1]))
 985         goto doshell;
 986
 987     if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
 988         goto doshell;
 989
 990     for (s = cmd; *s && isALPHA(*s); s++) ;     /* catch VAR=val gizmo */
 991     if (*s == '=')
 992         goto doshell;
 993
 994     for (s = cmd; *s; s++) {
 995         if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
 996             if (*s == '\n' && !s[1]) {
 997                 *s = '\0';
 998                 break;
 999             }
1000           doshell:
1001             PerlProc_execl(sh_path, "sh", "-c", cmd, (char*)0);
1002             return FALSE;
1003         }
1004     }
1005
1006     New(402,Argv, (s - cmd) / 2 + 2, char*);
1007     Cmd = savepvn(cmd, s-cmd);
1008     a = Argv;
1009     for (s = Cmd; *s;) {
1010         while (*s && isSPACE(*s)) s++;
1011         if (*s)
1012             *(a++) = s;
1013         while (*s && !isSPACE(*s)) s++;
1014         if (*s)
1015             *s++ = '\0';
1016     }
1017     *a = Nullch;
1018     if (Argv[0]) {
1019         PerlProc_execvp(Argv[0],Argv);
1020         if (errno == ENOEXEC) {         /* for system V NIH syndrome */
1021             do_execfree();
1022             goto doshell;
1023         }
1024         if (dowarn)
1025             warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno));
1026     }
1027     do_execfree();
1028     return FALSE;
1029 }
1030
1031 #endif /* OS2 || WIN32 */
1032
1033 I32
1034 apply(I32 type, register SV **mark, register SV **sp)
1035 {
1036     dTHR;
1037     register I32 val;
1038     register I32 val2;
1039     register I32 tot = 0;
1040     char *what;
1041     char *s;
1042     SV **oldmark = mark;
1043
1044 #define APPLY_TAINT_PROPER() \
1045     if (!(tainting && tainted)) {} else { goto taint_proper; }
1046
1047     /* This is a first heuristic; it doesn't catch tainting magic. */
1048     if (tainting) {
1049         while (++mark <= sp) {
1050             if (SvTAINTED(*mark)) {
1051                 TAINT;
1052                 break;
1053             }
1054         }
1055         mark = oldmark;
1056     }
1057     switch (type) {
1058     case OP_CHMOD:
1059         what = "chmod";
1060         APPLY_TAINT_PROPER();
1061         if (++mark <= sp) {
1062             val = SvIVx(*mark);
1063             APPLY_TAINT_PROPER();
1064             tot = sp - mark;
1065             while (++mark <= sp) {
1066                 char *name = SvPVx(*mark, na);
1067                 APPLY_TAINT_PROPER();
1068                 if (PerlLIO_chmod(name, val))
1069                     tot--;
1070             }
1071         }
1072         break;
1073 #ifdef HAS_CHOWN
1074     case OP_CHOWN:
1075         what = "chown";
1076         APPLY_TAINT_PROPER();
1077         if (sp - mark > 2) {
1078             val = SvIVx(*++mark);
1079             val2 = SvIVx(*++mark);
1080             APPLY_TAINT_PROPER();
1081             tot = sp - mark;
1082             while (++mark <= sp) {
1083                 char *name = SvPVx(*mark, na);
1084                 APPLY_TAINT_PROPER();
1085                 if (chown(name, val, val2))
1086                     tot--;
1087             }
1088         }
1089         break;
1090 #endif
1091 #ifdef HAS_KILL
1092     case OP_KILL:
1093         what = "kill";
1094         APPLY_TAINT_PROPER();
1095         if (mark == sp)
1096             break;
1097         s = SvPVx(*++mark, na);
1098         if (isUPPER(*s)) {
1099             if (*s == 'S' && s[1] == 'I' && s[2] == 'G')
1100                 s += 3;
1101             if (!(val = whichsig(s)))
1102                 croak("Unrecognized signal name \"%s\"",s);
1103         }
1104         else
1105             val = SvIVx(*mark);
1106         APPLY_TAINT_PROPER();
1107         tot = sp - mark;
1108 #ifdef VMS
1109         /* kill() doesn't do process groups (job trees?) under VMS */
1110         if (val < 0) val = -val;
1111         if (val == SIGKILL) {
1112 #           include <starlet.h>
1113             /* Use native sys$delprc() to insure that target process is
1114              * deleted; supervisor-mode images don't pay attention to
1115              * CRTL's emulation of Unix-style signals and kill()
1116              */
1117             while (++mark <= sp) {
1118                 I32 proc = SvIVx(*mark);
1119                 register unsigned long int __vmssts;
1120                 APPLY_TAINT_PROPER();
1121                 if (!((__vmssts = sys$delprc(&proc,0)) & 1)) {
1122                     tot--;
1123                     switch (__vmssts) {
1124                         case SS$_NONEXPR:
1125                         case SS$_NOSUCHNODE:
1126                             SETERRNO(ESRCH,__vmssts);
1127                             break;
1128                         case SS$_NOPRIV:
1129                             SETERRNO(EPERM,__vmssts);
1130                             break;
1131                         default:
1132                             SETERRNO(EVMSERR,__vmssts);
1133                     }
1134                 }
1135             }
1136             break;
1137         }
1138 #endif
1139         if (val < 0) {
1140             val = -val;
1141             while (++mark <= sp) {
1142                 I32 proc = SvIVx(*mark);
1143                 APPLY_TAINT_PROPER();
1144 #ifdef HAS_KILLPG
1145                 if (PerlProc_killpg(proc,val))  /* BSD */
1146 #else
1147                 if (PerlProc_kill(-proc,val))   /* SYSV */
1148 #endif
1149                     tot--;
1150             }
1151         }
1152         else {
1153             while (++mark <= sp) {
1154                 I32 proc = SvIVx(*mark);
1155                 APPLY_TAINT_PROPER();
1156                 if (PerlProc_kill(proc, val))
1157                     tot--;
1158             }
1159         }
1160         break;
1161 #endif
1162     case OP_UNLINK:
1163         what = "unlink";
1164         APPLY_TAINT_PROPER();
1165         tot = sp - mark;
1166         while (++mark <= sp) {
1167             s = SvPVx(*mark, na);
1168             APPLY_TAINT_PROPER();
1169             if (euid || unsafe) {
1170                 if (UNLINK(s))
1171                     tot--;
1172             }
1173             else {      /* don't let root wipe out directories without -U */
1174 #ifdef HAS_LSTAT
1175                 if (PerlLIO_lstat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
1176 #else
1177                 if (PerlLIO_stat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
1178 #endif
1179                     tot--;
1180                 else {
1181                     if (UNLINK(s))
1182                         tot--;
1183                 }
1184             }
1185         }
1186         break;
1187 #ifdef HAS_UTIME
1188     case OP_UTIME:
1189         what = "utime";
1190         APPLY_TAINT_PROPER();
1191         if (sp - mark > 2) {
1192 #if defined(I_UTIME) || defined(VMS)
1193             struct utimbuf utbuf;
1194 #else
1195             struct {
1196                 long    actime;
1197                 long    modtime;
1198             } utbuf;
1199 #endif
1200
1201             Zero(&utbuf, sizeof utbuf, char);
1202 #ifdef BIG_TIME
1203             utbuf.actime = (Time_t)SvNVx(*++mark);    /* time accessed */
1204             utbuf.modtime = (Time_t)SvNVx(*++mark);    /* time modified */
1205 #else
1206             utbuf.actime = SvIVx(*++mark);    /* time accessed */
1207             utbuf.modtime = SvIVx(*++mark);    /* time modified */
1208 #endif
1209             APPLY_TAINT_PROPER();
1210             tot = sp - mark;
1211             while (++mark <= sp) {
1212                 char *name = SvPVx(*mark, na);
1213                 APPLY_TAINT_PROPER();
1214                 if (PerlLIO_utime(name, &utbuf))
1215                     tot--;
1216             }
1217         }
1218         else
1219             tot = 0;
1220         break;
1221 #endif
1222     }
1223     return tot;
1224
1225   taint_proper:
1226     TAINT_PROPER(what);
1227     return 0;   /* this should never happen */
1228
1229 #undef APPLY_TAINT_PROPER
1230 }
1231
1232 /* Do the permissions allow some operation?  Assumes statcache already set. */
1233 #ifndef VMS /* VMS' cando is in vms.c */
1234 I32
1235 cando(I32 bit, I32 effective, register struct stat *statbufp)
1236 {
1237 #ifdef DOSISH
1238     /* [Comments and code from Len Reed]
1239      * MS-DOS "user" is similar to UNIX's "superuser," but can't write
1240      * to write-protected files.  The execute permission bit is set
1241      * by the Miscrosoft C library stat() function for the following:
1242      *          .exe files
1243      *          .com files
1244      *          .bat files
1245      *          directories
1246      * All files and directories are readable.
1247      * Directories and special files, e.g. "CON", cannot be
1248      * write-protected.
1249      * [Comment by Tom Dinger -- a directory can have the write-protect
1250      *          bit set in the file system, but DOS permits changes to
1251      *          the directory anyway.  In addition, all bets are off
1252      *          here for networked software, such as Novell and
1253      *          Sun's PC-NFS.]
1254      */
1255
1256      /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
1257       * too so it will actually look into the files for magic numbers
1258       */
1259      return (bit & statbufp->st_mode) ? TRUE : FALSE;
1260
1261 #else /* ! DOSISH */
1262     if ((effective ? euid : uid) == 0) {        /* root is special */
1263         if (bit == S_IXUSR) {
1264             if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
1265                 return TRUE;
1266         }
1267         else
1268             return TRUE;                /* root reads and writes anything */
1269         return FALSE;
1270     }
1271     if (statbufp->st_uid == (effective ? euid : uid) ) {
1272         if (statbufp->st_mode & bit)
1273             return TRUE;        /* ok as "user" */
1274     }
1275     else if (ingroup((I32)statbufp->st_gid,effective)) {
1276         if (statbufp->st_mode & bit >> 3)
1277             return TRUE;        /* ok as "group" */
1278     }
1279     else if (statbufp->st_mode & bit >> 6)
1280         return TRUE;    /* ok as "other" */
1281     return FALSE;
1282 #endif /* ! DOSISH */
1283 }
1284 #endif /* ! VMS */
1285
1286 I32
1287 ingroup(I32 testgid, I32 effective)
1288 {
1289     if (testgid == (effective ? egid : gid))
1290         return TRUE;
1291 #ifdef HAS_GETGROUPS
1292 #ifndef NGROUPS
1293 #define NGROUPS 32
1294 #endif
1295     {
1296         Groups_t gary[NGROUPS];
1297         I32 anum;
1298
1299         anum = getgroups(NGROUPS,gary);
1300         while (--anum >= 0)
1301             if (gary[anum] == testgid)
1302                 return TRUE;
1303     }
1304 #endif
1305     return FALSE;
1306 }
1307
1308 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
1309
1310 I32
1311 do_ipcget(I32 optype, SV **mark, SV **sp)
1312 {
1313     dTHR;
1314     key_t key;
1315     I32 n, flags;
1316
1317     key = (key_t)SvNVx(*++mark);
1318     n = (optype == OP_MSGGET) ? 0 : SvIVx(*++mark);
1319     flags = SvIVx(*++mark);
1320     SETERRNO(0,0);
1321     switch (optype)
1322     {
1323 #ifdef HAS_MSG
1324     case OP_MSGGET:
1325         return msgget(key, flags);
1326 #endif
1327 #ifdef HAS_SEM
1328     case OP_SEMGET:
1329         return semget(key, n, flags);
1330 #endif
1331 #ifdef HAS_SHM
1332     case OP_SHMGET:
1333         return shmget(key, n, flags);
1334 #endif
1335 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
1336     default:
1337         croak("%s not implemented", op_desc[optype]);
1338 #endif
1339     }
1340     return -1;                  /* should never happen */
1341 }
1342
1343 #if defined(__sun) && defined(__svr4__) /* XXX Need metaconfig test */
1344 /* Solaris manpage says that it uses (like linux)
1345    int semctl (int semid, int semnum, int cmd, union semun arg)
1346    but the system include files do not define union semun !!!!
1347 */
1348 union semun {
1349      int val;
1350      struct semid_ds *buf;
1351      ushort *array;
1352 };
1353 #endif
1354
1355 I32
1356 do_ipcctl(I32 optype, SV **mark, SV **sp)
1357 {
1358     dTHR;
1359     SV *astr;
1360     char *a;
1361     I32 id, n, cmd, infosize, getinfo;
1362     I32 ret = -1;
1363 #if defined(__linux__) || (defined(__sun) && defined(__svr4__))
1364 /* XXX Need metaconfig test */
1365     union semun unsemds;
1366 #endif
1367
1368     id = SvIVx(*++mark);
1369     n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
1370     cmd = SvIVx(*++mark);
1371     astr = *++mark;
1372     infosize = 0;
1373     getinfo = (cmd == IPC_STAT);
1374
1375     switch (optype)
1376     {
1377 #ifdef HAS_MSG
1378     case OP_MSGCTL:
1379         if (cmd == IPC_STAT || cmd == IPC_SET)
1380             infosize = sizeof(struct msqid_ds);
1381         break;
1382 #endif
1383 #ifdef HAS_SHM
1384     case OP_SHMCTL:
1385         if (cmd == IPC_STAT || cmd == IPC_SET)
1386             infosize = sizeof(struct shmid_ds);
1387         break;
1388 #endif
1389 #ifdef HAS_SEM
1390     case OP_SEMCTL:
1391         if (cmd == IPC_STAT || cmd == IPC_SET)
1392             infosize = sizeof(struct semid_ds);
1393         else if (cmd == GETALL || cmd == SETALL)
1394         {
1395             struct semid_ds semds;
1396 #if defined(__linux__) || (defined(__sun) && defined(__svr4__))
1397         /* XXX Need metaconfig test */
1398 /* linux and Solaris2 uses :
1399    int semctl (int semid, int semnum, int cmd, union semun arg)
1400        union semun {
1401             int val;
1402             struct semid_ds *buf;
1403             ushort *array;
1404        };
1405 */
1406             union semun semun;
1407             semun.buf = &semds;
1408             if (semctl(id, 0, IPC_STAT, semun) == -1)
1409 #else
1410             if (semctl(id, 0, IPC_STAT, &semds) == -1)
1411 #endif
1412                 return -1;
1413             getinfo = (cmd == GETALL);
1414             infosize = semds.sem_nsems * sizeof(short);
1415                 /* "short" is technically wrong but much more portable
1416                    than guessing about u_?short(_t)? */
1417         }
1418         break;
1419 #endif
1420 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
1421     default:
1422         croak("%s not implemented", op_desc[optype]);
1423 #endif
1424     }
1425
1426     if (infosize)
1427     {
1428         STRLEN len;
1429         if (getinfo)
1430         {
1431             SvPV_force(astr, len);
1432             a = SvGROW(astr, infosize+1);
1433         }
1434         else
1435         {
1436             a = SvPV(astr, len);
1437             if (len != infosize)
1438                 croak("Bad arg length for %s, is %lu, should be %ld",
1439                         op_desc[optype], (unsigned long)len, (long)infosize);
1440         }
1441     }
1442     else
1443     {
1444         IV i = SvIV(astr);
1445         a = (char *)i;          /* ouch */
1446     }
1447     SETERRNO(0,0);
1448     switch (optype)
1449     {
1450 #ifdef HAS_MSG
1451     case OP_MSGCTL:
1452         ret = msgctl(id, cmd, (struct msqid_ds *)a);
1453         break;
1454 #endif
1455 #ifdef HAS_SEM
1456     case OP_SEMCTL:
1457 #if defined(__linux__) || (defined(__sun) && defined(__svr4__))
1458         /* XXX Need metaconfig test */
1459         unsemds.buf = (struct semid_ds *)a;
1460         ret = semctl(id, n, cmd, unsemds);
1461 #else
1462         ret = semctl(id, n, cmd, (struct semid_ds *)a);
1463 #endif
1464         break;
1465 #endif
1466 #ifdef HAS_SHM
1467     case OP_SHMCTL:
1468         ret = shmctl(id, cmd, (struct shmid_ds *)a);
1469         break;
1470 #endif
1471     }
1472     if (getinfo && ret >= 0) {
1473         SvCUR_set(astr, infosize);
1474         *SvEND(astr) = '\0';
1475         SvSETMAGIC(astr);
1476     }
1477     return ret;
1478 }
1479
1480 I32
1481 do_msgsnd(SV **mark, SV **sp)
1482 {
1483 #ifdef HAS_MSG
1484     dTHR;
1485     SV *mstr;
1486     char *mbuf;
1487     I32 id, msize, flags;
1488     STRLEN len;
1489
1490     id = SvIVx(*++mark);
1491     mstr = *++mark;
1492     flags = SvIVx(*++mark);
1493     mbuf = SvPV(mstr, len);
1494     if ((msize = len - sizeof(long)) < 0)
1495         croak("Arg too short for msgsnd");
1496     SETERRNO(0,0);
1497     return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
1498 #else
1499     croak("msgsnd not implemented");
1500 #endif
1501 }
1502
1503 I32
1504 do_msgrcv(SV **mark, SV **sp)
1505 {
1506 #ifdef HAS_MSG
1507     dTHR;
1508     SV *mstr;
1509     char *mbuf;
1510     long mtype;
1511     I32 id, msize, flags, ret;
1512     STRLEN len;
1513
1514     id = SvIVx(*++mark);
1515     mstr = *++mark;
1516     msize = SvIVx(*++mark);
1517     mtype = (long)SvIVx(*++mark);
1518     flags = SvIVx(*++mark);
1519     if (SvTHINKFIRST(mstr)) {
1520         if (SvREADONLY(mstr))
1521             croak("Can't msgrcv to readonly var");
1522         if (SvROK(mstr))
1523             sv_unref(mstr);
1524     }
1525     SvPV_force(mstr, len);
1526     mbuf = SvGROW(mstr, sizeof(long)+msize+1);
1527
1528     SETERRNO(0,0);
1529     ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
1530     if (ret >= 0) {
1531         SvCUR_set(mstr, sizeof(long)+ret);
1532         *SvEND(mstr) = '\0';
1533     }
1534     return ret;
1535 #else
1536     croak("msgrcv not implemented");
1537 #endif
1538 }
1539
1540 I32
1541 do_semop(SV **mark, SV **sp)
1542 {
1543 #ifdef HAS_SEM
1544     dTHR;
1545     SV *opstr;
1546     char *opbuf;
1547     I32 id;
1548     STRLEN opsize;
1549
1550     id = SvIVx(*++mark);
1551     opstr = *++mark;
1552     opbuf = SvPV(opstr, opsize);
1553     if (opsize < sizeof(struct sembuf)
1554         || (opsize % sizeof(struct sembuf)) != 0) {
1555         SETERRNO(EINVAL,LIB$_INVARG);
1556         return -1;
1557     }
1558     SETERRNO(0,0);
1559     return semop(id, (struct sembuf *)opbuf, opsize/sizeof(struct sembuf));
1560 #else
1561     croak("semop not implemented");
1562 #endif
1563 }
1564
1565 I32
1566 do_shmio(I32 optype, SV **mark, SV **sp)
1567 {
1568 #ifdef HAS_SHM
1569     dTHR;
1570     SV *mstr;
1571     char *mbuf, *shm;
1572     I32 id, mpos, msize;
1573     STRLEN len;
1574     struct shmid_ds shmds;
1575
1576     id = SvIVx(*++mark);
1577     mstr = *++mark;
1578     mpos = SvIVx(*++mark);
1579     msize = SvIVx(*++mark);
1580     SETERRNO(0,0);
1581     if (shmctl(id, IPC_STAT, &shmds) == -1)
1582         return -1;
1583     if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
1584         SETERRNO(EFAULT,SS$_ACCVIO);            /* can't do as caller requested */
1585         return -1;
1586     }
1587     shm = (char *)shmat(id, (char*)NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
1588     if (shm == (char *)-1)      /* I hate System V IPC, I really do */
1589         return -1;
1590     if (optype == OP_SHMREAD) {
1591         SvPV_force(mstr, len);
1592         mbuf = SvGROW(mstr, msize+1);
1593
1594         Copy(shm + mpos, mbuf, msize, char);
1595         SvCUR_set(mstr, msize);
1596         *SvEND(mstr) = '\0';
1597         SvSETMAGIC(mstr);
1598     }
1599     else {
1600         I32 n;
1601
1602         mbuf = SvPV(mstr, len);
1603         if ((n = len) > msize)
1604             n = msize;
1605         Copy(mbuf, shm + mpos, n, char);
1606         if (n < msize)
1607             memzero(shm + mpos + n, msize - n);
1608     }
1609     return shmdt(shm);
1610 #else
1611     croak("shm I/O not implemented");
1612 #endif
1613 }
1614
1615 #endif /* SYSV IPC */
1616