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 int
 724 do_binmode(PerlIO *fp, int iotype, int flag)
 725 {
 726     if (flag != TRUE)
 727         croak("panic: unsetting binmode"); /* Not implemented yet */
 728 #ifdef DOSISH
 729 #ifdef atarist
 730     if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN))
 731         return 1;
 732     else
 733         return 0;
 734 #else
 735     if (PerlLIO_setmode(PerlIO_fileno(fp), OP_BINARY) != -1) {
 736 #if defined(WIN32) && defined(__BORLANDC__)
 737         /* The translation mode of the stream is maintained independent
 738          * of the translation mode of the fd in the Borland RTL (heavy
 739          * digging through their runtime sources reveal).  User has to
 740          * set the mode explicitly for the stream (though they don't
 741          * document this anywhere). GSAR 97-5-24
 742          */
 743         PerlIO_seek(fp,0L,0);
 744         fp->flags |= _F_BIN;
 745 #endif
 746         return 1;
 747     }
 748     else
 749         return 0;
 750 #endif
 751 #else
 752 #if defined(USEMYBINMODE)
 753     if (my_binmode(fp,iotype) != NULL)
 754         return 1;
 755     else
 756         return 0;
 757 #else
 758     return 1;
 759 #endif
 760 #endif
 761 }
 762
 763 #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
 764         /* code courtesy of William Kucharski */
 765 #define HAS_CHSIZE
 766
 767 I32 my_chsize(fd, length)
 768 I32 fd;                 /* file descriptor */
 769 Off_t length;           /* length to set file to */
 770 {
 771     struct flock fl;
 772     struct stat filebuf;
 773
 774     if (PerlLIO_fstat(fd, &filebuf) < 0)
 775         return -1;
 776
 777     if (filebuf.st_size < length) {
 778
 779         /* extend file length */
 780
 781         if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
 782             return -1;
 783
 784         /* write a "0" byte */
 785
 786         if ((PerlLIO_write(fd, "", 1)) != 1)
 787             return -1;
 788     }
 789     else {
 790         /* truncate length */
 791
 792         fl.l_whence = 0;
 793         fl.l_len = 0;
 794         fl.l_start = length;
 795         fl.l_type = F_WRLCK;    /* write lock on file space */
 796
 797         /*
 798         * This relies on the UNDOCUMENTED F_FREESP argument to
 799         * fcntl(2), which truncates the file so that it ends at the
 800         * position indicated by fl.l_start.
 801         *
 802         * Will minor miracles never cease?
 803         */
 804
 805         if (fcntl(fd, F_FREESP, &fl) < 0)
 806             return -1;
 807
 808     }
 809
 810     return 0;
 811 }
 812 #endif /* F_FREESP */
 813
 814 bool
 815 do_print(register SV *sv, PerlIO *fp)
 816 {
 817     register char *tmps;
 818     STRLEN len;
 819
 820     /* assuming fp is checked earlier */
 821     if (!sv)
 822         return TRUE;
 823     if (ofmt) {
 824         if (SvGMAGICAL(sv))
 825             mg_get(sv);
 826         if (SvIOK(sv) && SvIVX(sv) != 0) {
 827             PerlIO_printf(fp, ofmt, (double)SvIVX(sv));
 828             return !PerlIO_error(fp);
 829         }
 830         if (  (SvNOK(sv) && SvNVX(sv) != 0.0)
 831            || (looks_like_number(sv) && sv_2nv(sv) != 0.0) ) {
 832             PerlIO_printf(fp, ofmt, SvNVX(sv));
 833             return !PerlIO_error(fp);
 834         }
 835     }
 836     switch (SvTYPE(sv)) {
 837     case SVt_NULL:
 838         if (dowarn)
 839             warn(warn_uninit);
 840         return TRUE;
 841     case SVt_IV:
 842         if (SvIOK(sv)) {
 843             if (SvGMAGICAL(sv))
 844                 mg_get(sv);
 845             PerlIO_printf(fp, "%ld", (long)SvIVX(sv));
 846             return !PerlIO_error(fp);
 847         }
 848         /* FALL THROUGH */
 849     default:
 850         tmps = SvPV(sv, len);
 851         break;
 852     }
 853     if (len && (PerlIO_write(fp,tmps,len) == 0 || PerlIO_error(fp)))
 854         return FALSE;
 855     return !PerlIO_error(fp);
 856 }
 857
 858 I32
 859 my_stat(ARGSproto)
 860 {
 861     djSP;
 862     IO *io;
 863     GV* tmpgv;
 864
 865     if (op->op_flags & OPf_REF) {
 866         EXTEND(SP,1);
 867         tmpgv = cGVOP->op_gv;
 868       do_fstat:
 869         io = GvIO(tmpgv);
 870         if (io && IoIFP(io)) {
 871             statgv = tmpgv;
 872             sv_setpv(statname,"");
 873             laststype = OP_STAT;
 874             return (laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &statcache));
 875         }
 876         else {
 877             if (tmpgv == defgv)
 878                 return laststatval;
 879             if (dowarn)
 880                 warn("Stat on unopened file <%s>",
 881                   GvENAME(tmpgv));
 882             statgv = Nullgv;
 883             sv_setpv(statname,"");
 884             return (laststatval = -1);
 885         }
 886     }
 887     else {
 888         SV* sv = POPs;
 889         char *s;
 890         PUTBACK;
 891         if (SvTYPE(sv) == SVt_PVGV) {
 892             tmpgv = (GV*)sv;
 893             goto do_fstat;
 894         }
 895         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
 896             tmpgv = (GV*)SvRV(sv);
 897             goto do_fstat;
 898         }
 899
 900         s = SvPV(sv, na);
 901         statgv = Nullgv;
 902         sv_setpv(statname, s);
 903         laststype = OP_STAT;
 904         laststatval = PerlLIO_stat(s, &statcache);
 905         if (laststatval < 0 && dowarn && strchr(s, '\n'))
 906             warn(warn_nl, "stat");
 907         return laststatval;
 908     }
 909 }
 910
 911 I32
 912 my_lstat(ARGSproto)
 913 {
 914     djSP;
 915     SV *sv;
 916     if (op->op_flags & OPf_REF) {
 917         EXTEND(SP,1);
 918         if (cGVOP->op_gv == defgv) {
 919             if (laststype != OP_LSTAT)
 920                 croak("The stat preceding -l _ wasn't an lstat");
 921             return laststatval;
 922         }
 923         croak("You can't use -l on a filehandle");
 924     }
 925
 926     laststype = OP_LSTAT;
 927     statgv = Nullgv;
 928     sv = POPs;
 929     PUTBACK;
 930     sv_setpv(statname,SvPV(sv, na));
 931 #ifdef HAS_LSTAT
 932     laststatval = PerlLIO_lstat(SvPV(sv, na),&statcache);
 933 #else
 934     laststatval = PerlLIO_stat(SvPV(sv, na),&statcache);
 935 #endif
 936     if (laststatval < 0 && dowarn && strchr(SvPV(sv, na), '\n'))
 937         warn(warn_nl, "lstat");
 938     return laststatval;
 939 }
 940
 941 bool
 942 do_aexec(SV *really, register SV **mark, register SV **sp)
 943 {
 944     register char **a;
 945     char *tmps;
 946
 947     if (sp > mark) {
 948         dTHR;
 949         New(401,Argv, sp - mark + 1, char*);
 950         a = Argv;
 951         while (++mark <= sp) {
 952             if (*mark)
 953                 *a++ = SvPVx(*mark, na);
 954             else
 955                 *a++ = "";
 956         }
 957         *a = Nullch;
 958         if (*Argv[0] != '/')    /* will execvp use PATH? */
 959             TAINT_ENV();                /* testing IFS here is overkill, probably */
 960         if (really && *(tmps = SvPV(really, na)))
 961             PerlProc_execvp(tmps,Argv);
 962         else
 963             PerlProc_execvp(Argv[0],Argv);
 964         if (dowarn)
 965             warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno));
 966     }
 967     do_execfree();
 968     return FALSE;
 969 }
 970
 971 void
 972 do_execfree(void)
 973 {
 974     if (Argv) {
 975         Safefree(Argv);
 976         Argv = Null(char **);
 977     }
 978     if (Cmd) {
 979         Safefree(Cmd);
 980         Cmd = Nullch;
 981     }
 982 }
 983
 984 #if !defined(OS2) && !defined(WIN32) && !defined(DJGPP)
 985
 986 bool
 987 do_exec(char *cmd)
 988 {
 989     register char **a;
 990     register char *s;
 991     char flags[10];
 992
 993     while (*cmd && isSPACE(*cmd))
 994         cmd++;
 995
 996     /* save an extra exec if possible */
 997
 998 #ifdef CSH
 999     if (strnEQ(cmd,cshname,cshlen) && strnEQ(cmd+cshlen," -c",3)) {
1000         strcpy(flags,"-c");
1001         s = cmd+cshlen+3;
1002         if (*s == 'f') {
1003             s++;
1004             strcat(flags,"f");
1005         }
1006         if (*s == ' ')
1007             s++;
1008         if (*s++ == '\'') {
1009             char *ncmd = s;
1010
1011             while (*s)
1012                 s++;
1013             if (s[-1] == '\n')
1014                 *--s = '\0';
1015             if (s[-1] == '\'') {
1016                 *--s = '\0';
1017                 PerlProc_execl(cshname,"csh", flags,ncmd,(char*)0);
1018                 *s = '\'';
1019                 return FALSE;
1020             }
1021         }
1022     }
1023 #endif /* CSH */
1024
1025     /* see if there are shell metacharacters in it */
1026
1027     if (*cmd == '.' && isSPACE(cmd[1]))
1028         goto doshell;
1029
1030     if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
1031         goto doshell;
1032
1033     for (s = cmd; *s && isALPHA(*s); s++) ;     /* catch VAR=val gizmo */
1034     if (*s == '=')
1035         goto doshell;
1036
1037     for (s = cmd; *s; s++) {
1038         if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
1039             if (*s == '\n' && !s[1]) {
1040                 *s = '\0';
1041                 break;
1042             }
1043           doshell:
1044             PerlProc_execl(sh_path, "sh", "-c", cmd, (char*)0);
1045             return FALSE;
1046         }
1047     }
1048
1049     New(402,Argv, (s - cmd) / 2 + 2, char*);
1050     Cmd = savepvn(cmd, s-cmd);
1051     a = Argv;
1052     for (s = Cmd; *s;) {
1053         while (*s && isSPACE(*s)) s++;
1054         if (*s)
1055             *(a++) = s;
1056         while (*s && !isSPACE(*s)) s++;
1057         if (*s)
1058             *s++ = '\0';
1059     }
1060     *a = Nullch;
1061     if (Argv[0]) {
1062         PerlProc_execvp(Argv[0],Argv);
1063         if (errno == ENOEXEC) {         /* for system V NIH syndrome */
1064             do_execfree();
1065             goto doshell;
1066         }
1067         if (dowarn)
1068             warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno));
1069     }
1070     do_execfree();
1071     return FALSE;
1072 }
1073
1074 #endif /* OS2 || WIN32 */
1075
1076 I32
1077 apply(I32 type, register SV **mark, register SV **sp)
1078 {
1079     dTHR;
1080     register I32 val;
1081     register I32 val2;
1082     register I32 tot = 0;
1083     char *what;
1084     char *s;
1085     SV **oldmark = mark;
1086
1087 #define APPLY_TAINT_PROPER() \
1088     if (!(tainting && tainted)) {} else { goto taint_proper; }
1089
1090     /* This is a first heuristic; it doesn't catch tainting magic. */
1091     if (tainting) {
1092         while (++mark <= sp) {
1093             if (SvTAINTED(*mark)) {
1094                 TAINT;
1095                 break;
1096             }
1097         }
1098         mark = oldmark;
1099     }
1100     switch (type) {
1101     case OP_CHMOD:
1102         what = "chmod";
1103         APPLY_TAINT_PROPER();
1104         if (++mark <= sp) {
1105             val = SvIVx(*mark);
1106             APPLY_TAINT_PROPER();
1107             tot = sp - mark;
1108             while (++mark <= sp) {
1109                 char *name = SvPVx(*mark, na);
1110                 APPLY_TAINT_PROPER();
1111                 if (PerlLIO_chmod(name, val))
1112                     tot--;
1113             }
1114         }
1115         break;
1116 #ifdef HAS_CHOWN
1117     case OP_CHOWN:
1118         what = "chown";
1119         APPLY_TAINT_PROPER();
1120         if (sp - mark > 2) {
1121             val = SvIVx(*++mark);
1122             val2 = SvIVx(*++mark);
1123             APPLY_TAINT_PROPER();
1124             tot = sp - mark;
1125             while (++mark <= sp) {
1126                 char *name = SvPVx(*mark, na);
1127                 APPLY_TAINT_PROPER();
1128                 if (chown(name, val, val2))
1129                     tot--;
1130             }
1131         }
1132         break;
1133 #endif
1134 /*
1135 XXX Should we make lchown() directly available from perl?
1136 For now, we'll let Configure test for HAS_LCHOWN, but do
1137 nothing in the core.
1138     --AD  5/1998
1139 */
1140 #ifdef HAS_KILL
1141     case OP_KILL:
1142         what = "kill";
1143         APPLY_TAINT_PROPER();
1144         if (mark == sp)
1145             break;
1146         s = SvPVx(*++mark, na);
1147         if (isUPPER(*s)) {
1148             if (*s == 'S' && s[1] == 'I' && s[2] == 'G')
1149                 s += 3;
1150             if (!(val = whichsig(s)))
1151                 croak("Unrecognized signal name \"%s\"",s);
1152         }
1153         else
1154             val = SvIVx(*mark);
1155         APPLY_TAINT_PROPER();
1156         tot = sp - mark;
1157 #ifdef VMS
1158         /* kill() doesn't do process groups (job trees?) under VMS */
1159         if (val < 0) val = -val;
1160         if (val == SIGKILL) {
1161 #           include <starlet.h>
1162             /* Use native sys$delprc() to insure that target process is
1163              * deleted; supervisor-mode images don't pay attention to
1164              * CRTL's emulation of Unix-style signals and kill()
1165              */
1166             while (++mark <= sp) {
1167                 I32 proc = SvIVx(*mark);
1168                 register unsigned long int __vmssts;
1169                 APPLY_TAINT_PROPER();
1170                 if (!((__vmssts = sys$delprc(&proc,0)) & 1)) {
1171                     tot--;
1172                     switch (__vmssts) {
1173                         case SS$_NONEXPR:
1174                         case SS$_NOSUCHNODE:
1175                             SETERRNO(ESRCH,__vmssts);
1176                             break;
1177                         case SS$_NOPRIV:
1178                             SETERRNO(EPERM,__vmssts);
1179                             break;
1180                         default:
1181                             SETERRNO(EVMSERR,__vmssts);
1182                     }
1183                 }
1184             }
1185             break;
1186         }
1187 #endif
1188         if (val < 0) {
1189             val = -val;
1190             while (++mark <= sp) {
1191                 I32 proc = SvIVx(*mark);
1192                 APPLY_TAINT_PROPER();
1193 #ifdef HAS_KILLPG
1194                 if (PerlProc_killpg(proc,val))  /* BSD */
1195 #else
1196                 if (PerlProc_kill(-proc,val))   /* SYSV */
1197 #endif
1198                     tot--;
1199             }
1200         }
1201         else {
1202             while (++mark <= sp) {
1203                 I32 proc = SvIVx(*mark);
1204                 APPLY_TAINT_PROPER();
1205                 if (PerlProc_kill(proc, val))
1206                     tot--;
1207             }
1208         }
1209         break;
1210 #endif
1211     case OP_UNLINK:
1212         what = "unlink";
1213         APPLY_TAINT_PROPER();
1214         tot = sp - mark;
1215         while (++mark <= sp) {
1216             s = SvPVx(*mark, na);
1217             APPLY_TAINT_PROPER();
1218             if (euid || unsafe) {
1219                 if (UNLINK(s))
1220                     tot--;
1221             }
1222             else {      /* don't let root wipe out directories without -U */
1223 #ifdef HAS_LSTAT
1224                 if (PerlLIO_lstat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
1225 #else
1226                 if (PerlLIO_stat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
1227 #endif
1228                     tot--;
1229                 else {
1230                     if (UNLINK(s))
1231                         tot--;
1232                 }
1233             }
1234         }
1235         break;
1236 #ifdef HAS_UTIME
1237     case OP_UTIME:
1238         what = "utime";
1239         APPLY_TAINT_PROPER();
1240         if (sp - mark > 2) {
1241 #if defined(I_UTIME) || defined(VMS)
1242             struct utimbuf utbuf;
1243 #else
1244             struct {
1245                 long    actime;
1246                 long    modtime;
1247             } utbuf;
1248 #endif
1249
1250             Zero(&utbuf, sizeof utbuf, char);
1251 #ifdef BIG_TIME
1252             utbuf.actime = (Time_t)SvNVx(*++mark);    /* time accessed */
1253             utbuf.modtime = (Time_t)SvNVx(*++mark);    /* time modified */
1254 #else
1255             utbuf.actime = SvIVx(*++mark);    /* time accessed */
1256             utbuf.modtime = SvIVx(*++mark);    /* time modified */
1257 #endif
1258             APPLY_TAINT_PROPER();
1259             tot = sp - mark;
1260             while (++mark <= sp) {
1261                 char *name = SvPVx(*mark, na);
1262                 APPLY_TAINT_PROPER();
1263                 if (PerlLIO_utime(name, &utbuf))
1264                     tot--;
1265             }
1266         }
1267         else
1268             tot = 0;
1269         break;
1270 #endif
1271     }
1272     return tot;
1273
1274   taint_proper:
1275     TAINT_PROPER(what);
1276     return 0;   /* this should never happen */
1277
1278 #undef APPLY_TAINT_PROPER
1279 }
1280
1281 /* Do the permissions allow some operation?  Assumes statcache already set. */
1282 #ifndef VMS /* VMS' cando is in vms.c */
1283 I32
1284 cando(I32 bit, I32 effective, register struct stat *statbufp)
1285 {
1286 #ifdef DOSISH
1287     /* [Comments and code from Len Reed]
1288      * MS-DOS "user" is similar to UNIX's "superuser," but can't write
1289      * to write-protected files.  The execute permission bit is set
1290      * by the Miscrosoft C library stat() function for the following:
1291      *          .exe files
1292      *          .com files
1293      *          .bat files
1294      *          directories
1295      * All files and directories are readable.
1296      * Directories and special files, e.g. "CON", cannot be
1297      * write-protected.
1298      * [Comment by Tom Dinger -- a directory can have the write-protect
1299      *          bit set in the file system, but DOS permits changes to
1300      *          the directory anyway.  In addition, all bets are off
1301      *          here for networked software, such as Novell and
1302      *          Sun's PC-NFS.]
1303      */
1304
1305      /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
1306       * too so it will actually look into the files for magic numbers
1307       */
1308      return (bit & statbufp->st_mode) ? TRUE : FALSE;
1309
1310 #else /* ! DOSISH */
1311     if ((effective ? euid : uid) == 0) {        /* root is special */
1312         if (bit == S_IXUSR) {
1313             if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
1314                 return TRUE;
1315         }
1316         else
1317             return TRUE;                /* root reads and writes anything */
1318         return FALSE;
1319     }
1320     if (statbufp->st_uid == (effective ? euid : uid) ) {
1321         if (statbufp->st_mode & bit)
1322             return TRUE;        /* ok as "user" */
1323     }
1324     else if (ingroup((I32)statbufp->st_gid,effective)) {
1325         if (statbufp->st_mode & bit >> 3)
1326             return TRUE;        /* ok as "group" */
1327     }
1328     else if (statbufp->st_mode & bit >> 6)
1329         return TRUE;    /* ok as "other" */
1330     return FALSE;
1331 #endif /* ! DOSISH */
1332 }
1333 #endif /* ! VMS */
1334
1335 I32
1336 ingroup(I32 testgid, I32 effective)
1337 {
1338     if (testgid == (effective ? egid : gid))
1339         return TRUE;
1340 #ifdef HAS_GETGROUPS
1341 #ifndef NGROUPS
1342 #define NGROUPS 32
1343 #endif
1344     {
1345         Groups_t gary[NGROUPS];
1346         I32 anum;
1347
1348         anum = getgroups(NGROUPS,gary);
1349         while (--anum >= 0)
1350             if (gary[anum] == testgid)
1351                 return TRUE;
1352     }
1353 #endif
1354     return FALSE;
1355 }
1356
1357 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
1358
1359 I32
1360 do_ipcget(I32 optype, SV **mark, SV **sp)
1361 {
1362     dTHR;
1363     key_t key;
1364     I32 n, flags;
1365
1366     key = (key_t)SvNVx(*++mark);
1367     n = (optype == OP_MSGGET) ? 0 : SvIVx(*++mark);
1368     flags = SvIVx(*++mark);
1369     SETERRNO(0,0);
1370     switch (optype)
1371     {
1372 #ifdef HAS_MSG
1373     case OP_MSGGET:
1374         return msgget(key, flags);
1375 #endif
1376 #ifdef HAS_SEM
1377     case OP_SEMGET:
1378         return semget(key, n, flags);
1379 #endif
1380 #ifdef HAS_SHM
1381     case OP_SHMGET:
1382         return shmget(key, n, flags);
1383 #endif
1384 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
1385     default:
1386         croak("%s not implemented", op_desc[optype]);
1387 #endif
1388     }
1389     return -1;                  /* should never happen */
1390 }
1391
1392 #if defined(__sun) && defined(__svr4__) /* XXX Need metaconfig test */
1393 /* Solaris manpage says that it uses (like linux)
1394    int semctl (int semid, int semnum, int cmd, union semun arg)
1395    but the system include files do not define union semun !!!!
1396    Note: Linux/glibc *does* declare union semun in <sys/sem_buf.h>
1397    but, unlike the older Linux libc and Solaris, it has an extra
1398    struct seminfo * on the end.
1399 */
1400 union semun {
1401      int val;
1402      struct semid_ds *buf;
1403      ushort *array;
1404 };
1405 #endif
1406
1407 I32
1408 do_ipcctl(I32 optype, SV **mark, SV **sp)
1409 {
1410     dTHR;
1411     SV *astr;
1412     char *a;
1413     I32 id, n, cmd, infosize, getinfo;
1414     I32 ret = -1;
1415 /* XXX REALLY need metaconfig test */
1416 /* linux and Solaris2 use:
1417    int semctl (int semid, int semnum, int cmd, union semun arg)
1418    instead of:
1419    int semctl (int semid, int semnum, int cmd, struct semid_ds *arg);
1420    Solaris and Linux (pre-glibc) use
1421        union semun {
1422             int val;
1423             struct semid_ds *buf;
1424             ushort *array;
1425        };
1426    but Solaris doesn't declare it in a header file (we declared it
1427    explicitly earlier). Linux/glibc declares a *different* union semun
1428    so we just refer to "union semun" here.
1429
1430 */
1431 #if defined(__linux__) || (defined(__sun__) && defined(__svr4__))
1432 #   define SEMCTL_SEMUN
1433     union semun unsemds, semun;
1434 #endif
1435
1436     id = SvIVx(*++mark);
1437     n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
1438     cmd = SvIVx(*++mark);
1439     astr = *++mark;
1440     infosize = 0;
1441     getinfo = (cmd == IPC_STAT);
1442
1443     switch (optype)
1444     {
1445 #ifdef HAS_MSG
1446     case OP_MSGCTL:
1447         if (cmd == IPC_STAT || cmd == IPC_SET)
1448             infosize = sizeof(struct msqid_ds);
1449         break;
1450 #endif
1451 #ifdef HAS_SHM
1452     case OP_SHMCTL:
1453         if (cmd == IPC_STAT || cmd == IPC_SET)
1454             infosize = sizeof(struct shmid_ds);
1455         break;
1456 #endif
1457 #ifdef HAS_SEM
1458     case OP_SEMCTL:
1459         if (cmd == IPC_STAT || cmd == IPC_SET)
1460             infosize = sizeof(struct semid_ds);
1461         else if (cmd == GETALL || cmd == SETALL)
1462         {
1463             struct semid_ds semds;
1464 #ifdef SEMCTL_SEMUN
1465             semun.buf = &semds;
1466             if (semctl(id, 0, IPC_STAT, semun) == -1)
1467 #else
1468             if (semctl(id, 0, IPC_STAT, &semds) == -1)
1469 #endif
1470                 return -1;
1471             getinfo = (cmd == GETALL);
1472             infosize = semds.sem_nsems * sizeof(short);
1473                 /* "short" is technically wrong but much more portable
1474                    than guessing about u_?short(_t)? */
1475         }
1476         break;
1477 #endif
1478 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
1479     default:
1480         croak("%s not implemented", op_desc[optype]);
1481 #endif
1482     }
1483
1484     if (infosize)
1485     {
1486         STRLEN len;
1487         if (getinfo)
1488         {
1489             SvPV_force(astr, len);
1490             a = SvGROW(astr, infosize+1);
1491         }
1492         else
1493         {
1494             a = SvPV(astr, len);
1495             if (len != infosize)
1496                 croak("Bad arg length for %s, is %lu, should be %ld",
1497                         op_desc[optype], (unsigned long)len, (long)infosize);
1498         }
1499     }
1500     else
1501     {
1502         IV i = SvIV(astr);
1503         a = (char *)i;          /* ouch */
1504     }
1505     SETERRNO(0,0);
1506     switch (optype)
1507     {
1508 #ifdef HAS_MSG
1509     case OP_MSGCTL:
1510         ret = msgctl(id, cmd, (struct msqid_ds *)a);
1511         break;
1512 #endif
1513 #ifdef HAS_SEM
1514     case OP_SEMCTL:
1515 #ifdef SEMCTL_SEMUN
1516         /* XXX Need metaconfig test */
1517         unsemds.buf = (struct semid_ds *)a;
1518         ret = semctl(id, n, cmd, unsemds);
1519 #else
1520         ret = semctl(id, n, cmd, (struct semid_ds *)a);
1521 #endif
1522         break;
1523 #endif
1524 #ifdef HAS_SHM
1525     case OP_SHMCTL:
1526         ret = shmctl(id, cmd, (struct shmid_ds *)a);
1527         break;
1528 #endif
1529     }
1530     if (getinfo && ret >= 0) {
1531         SvCUR_set(astr, infosize);
1532         *SvEND(astr) = '\0';
1533         SvSETMAGIC(astr);
1534     }
1535     return ret;
1536 }
1537
1538 I32
1539 do_msgsnd(SV **mark, SV **sp)
1540 {
1541 #ifdef HAS_MSG
1542     dTHR;
1543     SV *mstr;
1544     char *mbuf;
1545     I32 id, msize, flags;
1546     STRLEN len;
1547
1548     id = SvIVx(*++mark);
1549     mstr = *++mark;
1550     flags = SvIVx(*++mark);
1551     mbuf = SvPV(mstr, len);
1552     if ((msize = len - sizeof(long)) < 0)
1553         croak("Arg too short for msgsnd");
1554     SETERRNO(0,0);
1555     return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
1556 #else
1557     croak("msgsnd not implemented");
1558 #endif
1559 }
1560
1561 I32
1562 do_msgrcv(SV **mark, SV **sp)
1563 {
1564 #ifdef HAS_MSG
1565     dTHR;
1566     SV *mstr;
1567     char *mbuf;
1568     long mtype;
1569     I32 id, msize, flags, ret;
1570     STRLEN len;
1571
1572     id = SvIVx(*++mark);
1573     mstr = *++mark;
1574     msize = SvIVx(*++mark);
1575     mtype = (long)SvIVx(*++mark);
1576     flags = SvIVx(*++mark);
1577     if (SvTHINKFIRST(mstr)) {
1578         if (SvREADONLY(mstr))
1579             croak("Can't msgrcv to readonly var");
1580         if (SvROK(mstr))
1581             sv_unref(mstr);
1582     }
1583     SvPV_force(mstr, len);
1584     mbuf = SvGROW(mstr, sizeof(long)+msize+1);
1585
1586     SETERRNO(0,0);
1587     ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
1588     if (ret >= 0) {
1589         SvCUR_set(mstr, sizeof(long)+ret);
1590         *SvEND(mstr) = '\0';
1591     }
1592     return ret;
1593 #else
1594     croak("msgrcv not implemented");
1595 #endif
1596 }
1597
1598 I32
1599 do_semop(SV **mark, SV **sp)
1600 {
1601 #ifdef HAS_SEM
1602     dTHR;
1603     SV *opstr;
1604     char *opbuf;
1605     I32 id;
1606     STRLEN opsize;
1607
1608     id = SvIVx(*++mark);
1609     opstr = *++mark;
1610     opbuf = SvPV(opstr, opsize);
1611     if (opsize < sizeof(struct sembuf)
1612         || (opsize % sizeof(struct sembuf)) != 0) {
1613         SETERRNO(EINVAL,LIB$_INVARG);
1614         return -1;
1615     }
1616     SETERRNO(0,0);
1617     return semop(id, (struct sembuf *)opbuf, opsize/sizeof(struct sembuf));
1618 #else
1619     croak("semop not implemented");
1620 #endif
1621 }
1622
1623 I32
1624 do_shmio(I32 optype, SV **mark, SV **sp)
1625 {
1626 #ifdef HAS_SHM
1627     dTHR;
1628     SV *mstr;
1629     char *mbuf, *shm;
1630     I32 id, mpos, msize;
1631     STRLEN len;
1632     struct shmid_ds shmds;
1633
1634     id = SvIVx(*++mark);
1635     mstr = *++mark;
1636     mpos = SvIVx(*++mark);
1637     msize = SvIVx(*++mark);
1638     SETERRNO(0,0);
1639     if (shmctl(id, IPC_STAT, &shmds) == -1)
1640         return -1;
1641     if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
1642         SETERRNO(EFAULT,SS$_ACCVIO);            /* can't do as caller requested */
1643         return -1;
1644     }
1645     shm = (char *)shmat(id, (char*)NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
1646     if (shm == (char *)-1)      /* I hate System V IPC, I really do */
1647         return -1;
1648     if (optype == OP_SHMREAD) {
1649         SvPV_force(mstr, len);
1650         mbuf = SvGROW(mstr, msize+1);
1651
1652         Copy(shm + mpos, mbuf, msize, char);
1653         SvCUR_set(mstr, msize);
1654         *SvEND(mstr) = '\0';
1655         SvSETMAGIC(mstr);
1656     }
1657     else {
1658         I32 n;
1659
1660         mbuf = SvPV(mstr, len);
1661         if ((n = len) > msize)
1662             n = msize;
1663         Copy(mbuf, shm + mpos, n, char);
1664         if (n < msize)
1665             memzero(shm + mpos + n, msize - n);
1666     }
1667     return shmdt(shm);
1668 #else
1669     croak("shm I/O not implemented");
1670 #endif
1671 }
1672
1673 #endif /* SYSV IPC */
1674