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