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