doio.c

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