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)PerlLIO_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         ((FILE*)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     STMT_START {                                                \
1089         if (tainting && tainted) { goto taint_proper_label; }   \
1090     } STMT_END
1091
1092     /* This is a first heuristic; it doesn't catch tainting magic. */
1093     if (tainting) {
1094         while (++mark <= sp) {
1095             if (SvTAINTED(*mark)) {
1096                 TAINT;
1097                 break;
1098             }
1099         }
1100         mark = oldmark;
1101     }
1102     switch (type) {
1103     case OP_CHMOD:
1104         what = "chmod";
1105         APPLY_TAINT_PROPER();
1106         if (++mark <= sp) {
1107             val = SvIVx(*mark);
1108             APPLY_TAINT_PROPER();
1109             tot = sp - mark;
1110             while (++mark <= sp) {
1111                 char *name = SvPVx(*mark, na);
1112                 APPLY_TAINT_PROPER();
1113                 if (PerlLIO_chmod(name, val))
1114                     tot--;
1115             }
1116         }
1117         break;
1118 #ifdef HAS_CHOWN
1119     case OP_CHOWN:
1120         what = "chown";
1121         APPLY_TAINT_PROPER();
1122         if (sp - mark > 2) {
1123             val = SvIVx(*++mark);
1124             val2 = SvIVx(*++mark);
1125             APPLY_TAINT_PROPER();
1126             tot = sp - mark;
1127             while (++mark <= sp) {
1128                 char *name = SvPVx(*mark, na);
1129                 APPLY_TAINT_PROPER();
1130                 if (PerlLIO_chown(name, val, val2))
1131                     tot--;
1132             }
1133         }
1134         break;
1135 #endif
1136 #ifdef HAS_KILL
1137     case OP_KILL:
1138         what = "kill";
1139         APPLY_TAINT_PROPER();
1140         if (mark == sp)
1141             break;
1142         s = SvPVx(*++mark, na);
1143         if (isUPPER(*s)) {
1144             if (*s == 'S' && s[1] == 'I' && s[2] == 'G')
1145                 s += 3;
1146             if (!(val = whichsig(s)))
1147                 croak("Unrecognized signal name \"%s\"",s);
1148         }
1149         else
1150             val = SvIVx(*mark);
1151         APPLY_TAINT_PROPER();
1152         tot = sp - mark;
1153 #ifdef VMS
1154         /* kill() doesn't do process groups (job trees?) under VMS */
1155         if (val < 0) val = -val;
1156         if (val == SIGKILL) {
1157 #           include <starlet.h>
1158             /* Use native sys$delprc() to insure that target process is
1159              * deleted; supervisor-mode images don't pay attention to
1160              * CRTL's emulation of Unix-style signals and kill()
1161              */
1162             while (++mark <= sp) {
1163                 I32 proc = SvIVx(*mark);
1164                 register unsigned long int __vmssts;
1165                 APPLY_TAINT_PROPER();
1166                 if (!((__vmssts = sys$delprc(&proc,0)) & 1)) {
1167                     tot--;
1168                     switch (__vmssts) {
1169                         case SS$_NONEXPR:
1170                         case SS$_NOSUCHNODE:
1171                             SETERRNO(ESRCH,__vmssts);
1172                             break;
1173                         case SS$_NOPRIV:
1174                             SETERRNO(EPERM,__vmssts);
1175                             break;
1176                         default:
1177                             SETERRNO(EVMSERR,__vmssts);
1178                     }
1179                 }
1180             }
1181             break;
1182         }
1183 #endif
1184         if (val < 0) {
1185             val = -val;
1186             while (++mark <= sp) {
1187                 I32 proc = SvIVx(*mark);
1188                 APPLY_TAINT_PROPER();
1189 #ifdef HAS_KILLPG
1190                 if (PerlProc_killpg(proc,val))  /* BSD */
1191 #else
1192                 if (PerlProc_kill(-proc,val))   /* SYSV */
1193 #endif
1194                     tot--;
1195             }
1196         }
1197         else {
1198             while (++mark <= sp) {
1199                 I32 proc = SvIVx(*mark);
1200                 APPLY_TAINT_PROPER();
1201                 if (PerlProc_kill(proc, val))
1202                     tot--;
1203             }
1204         }
1205         break;
1206 #endif
1207     case OP_UNLINK:
1208         what = "unlink";
1209         APPLY_TAINT_PROPER();
1210         tot = sp - mark;
1211         while (++mark <= sp) {
1212             s = SvPVx(*mark, na);
1213             APPLY_TAINT_PROPER();
1214             if (euid || unsafe) {
1215                 if (UNLINK(s))
1216                     tot--;
1217             }
1218             else {      /* don't let root wipe out directories without -U */
1219 #ifdef HAS_LSTAT
1220                 if (PerlLIO_lstat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
1221 #else
1222                 if (PerlLIO_stat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
1223 #endif
1224                     tot--;
1225                 else {
1226                     if (UNLINK(s))
1227                         tot--;
1228                 }
1229             }
1230         }
1231         break;
1232 #ifdef HAS_UTIME
1233     case OP_UTIME:
1234         what = "utime";
1235         APPLY_TAINT_PROPER();
1236         if (sp - mark > 2) {
1237 #if defined(I_UTIME) || defined(VMS)
1238             struct utimbuf utbuf;
1239 #else
1240             struct {
1241                 long    actime;
1242                 long    modtime;
1243             } utbuf;
1244 #endif
1245
1246             Zero(&utbuf, sizeof utbuf, char);
1247 #ifdef BIG_TIME
1248             utbuf.actime = (Time_t)SvNVx(*++mark);    /* time accessed */
1249             utbuf.modtime = (Time_t)SvNVx(*++mark);    /* time modified */
1250 #else
1251             utbuf.actime = SvIVx(*++mark);    /* time accessed */
1252             utbuf.modtime = SvIVx(*++mark);    /* time modified */
1253 #endif
1254             APPLY_TAINT_PROPER();
1255             tot = sp - mark;
1256             while (++mark <= sp) {
1257                 char *name = SvPVx(*mark, na);
1258                 APPLY_TAINT_PROPER();
1259                 if (PerlLIO_utime(name, &utbuf))
1260                     tot--;
1261             }
1262         }
1263         else
1264             tot = 0;
1265         break;
1266 #endif
1267     }
1268     return tot;
1269
1270   taint_proper_label:
1271     TAINT_PROPER(what);
1272     return 0;   /* this should never happen */
1273
1274 #undef APPLY_TAINT_PROPER
1275 }
1276
1277 /* Do the permissions allow some operation?  Assumes statcache already set. */
1278 #ifndef VMS /* VMS' cando is in vms.c */
1279 I32
1280 cando(I32 bit, I32 effective, register struct stat *statbufp)
1281 {
1282 #ifdef DOSISH
1283     /* [Comments and code from Len Reed]
1284      * MS-DOS "user" is similar to UNIX's "superuser," but can't write
1285      * to write-protected files.  The execute permission bit is set
1286      * by the Miscrosoft C library stat() function for the following:
1287      *          .exe files
1288      *          .com files
1289      *          .bat files
1290      *          directories
1291      * All files and directories are readable.
1292      * Directories and special files, e.g. "CON", cannot be
1293      * write-protected.
1294      * [Comment by Tom Dinger -- a directory can have the write-protect
1295      *          bit set in the file system, but DOS permits changes to
1296      *          the directory anyway.  In addition, all bets are off
1297      *          here for networked software, such as Novell and
1298      *          Sun's PC-NFS.]
1299      */
1300
1301      /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
1302       * too so it will actually look into the files for magic numbers
1303       */
1304      return (bit & statbufp->st_mode) ? TRUE : FALSE;
1305
1306 #else /* ! DOSISH */
1307     if ((effective ? euid : uid) == 0) {        /* root is special */
1308         if (bit == S_IXUSR) {
1309             if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
1310                 return TRUE;
1311         }
1312         else
1313             return TRUE;                /* root reads and writes anything */
1314         return FALSE;
1315     }
1316     if (statbufp->st_uid == (effective ? euid : uid) ) {
1317         if (statbufp->st_mode & bit)
1318             return TRUE;        /* ok as "user" */
1319     }
1320     else if (ingroup((I32)statbufp->st_gid,effective)) {
1321         if (statbufp->st_mode & bit >> 3)
1322             return TRUE;        /* ok as "group" */
1323     }
1324     else if (statbufp->st_mode & bit >> 6)
1325         return TRUE;    /* ok as "other" */
1326     return FALSE;
1327 #endif /* ! DOSISH */
1328 }
1329 #endif /* ! VMS */
1330
1331 I32
1332 ingroup(I32 testgid, I32 effective)
1333 {
1334     if (testgid == (effective ? egid : gid))
1335         return TRUE;
1336 #ifdef HAS_GETGROUPS
1337 #ifndef NGROUPS
1338 #define NGROUPS 32
1339 #endif
1340     {
1341         Groups_t gary[NGROUPS];
1342         I32 anum;
1343
1344         anum = getgroups(NGROUPS,gary);
1345         while (--anum >= 0)
1346             if (gary[anum] == testgid)
1347                 return TRUE;
1348     }
1349 #endif
1350     return FALSE;
1351 }
1352
1353 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
1354
1355 I32
1356 do_ipcget(I32 optype, SV **mark, SV **sp)
1357 {
1358     dTHR;
1359     key_t key;
1360     I32 n, flags;
1361
1362     key = (key_t)SvNVx(*++mark);
1363     n = (optype == OP_MSGGET) ? 0 : SvIVx(*++mark);
1364     flags = SvIVx(*++mark);
1365     SETERRNO(0,0);
1366     switch (optype)
1367     {
1368 #ifdef HAS_MSG
1369     case OP_MSGGET:
1370         return msgget(key, flags);
1371 #endif
1372 #ifdef HAS_SEM
1373     case OP_SEMGET:
1374         return semget(key, n, flags);
1375 #endif
1376 #ifdef HAS_SHM
1377     case OP_SHMGET:
1378         return shmget(key, n, flags);
1379 #endif
1380 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
1381     default:
1382         croak("%s not implemented", op_desc[optype]);
1383 #endif
1384     }
1385     return -1;                  /* should never happen */
1386 }
1387
1388 #if defined(__sun) && defined(__svr4__) /* XXX Need metaconfig test */
1389 /* Solaris manpage says that it uses (like linux)
1390    int semctl (int semid, int semnum, int cmd, union semun arg)
1391    but the system include files do not define union semun !!!!
1392    Note: Linux/glibc *does* declare union semun in <sys/sem_buf.h>
1393    but, unlike the older Linux libc and Solaris, it has an extra
1394    struct seminfo * on the end.
1395 */
1396 union semun {
1397      int val;
1398      struct semid_ds *buf;
1399      ushort *array;
1400 };
1401 #endif
1402
1403 I32
1404 do_ipcctl(I32 optype, SV **mark, SV **sp)
1405 {
1406     dTHR;
1407     SV *astr;
1408     char *a;
1409     I32 id, n, cmd, infosize, getinfo;
1410     I32 ret = -1;
1411 /* XXX REALLY need metaconfig test */
1412 /* linux and Solaris2 use:
1413    int semctl (int semid, int semnum, int cmd, union semun arg)
1414    instead of:
1415    int semctl (int semid, int semnum, int cmd, struct semid_ds *arg);
1416    Solaris and Linux (pre-glibc) use
1417        union semun {
1418             int val;
1419             struct semid_ds *buf;
1420             ushort *array;
1421        };
1422    but Solaris doesn't declare it in a header file (we declared it
1423    explicitly earlier). Linux/glibc declares a *different* union semun
1424    so we just refer to "union semun" here.
1425
1426 */
1427 #if defined(__linux__) || (defined(__sun__) && defined(__svr4__))
1428 #   define SEMCTL_SEMUN
1429     union semun unsemds, semun;
1430 #endif
1431
1432     id = SvIVx(*++mark);
1433     n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
1434     cmd = SvIVx(*++mark);
1435     astr = *++mark;
1436     infosize = 0;
1437     getinfo = (cmd == IPC_STAT);
1438
1439     switch (optype)
1440     {
1441 #ifdef HAS_MSG
1442     case OP_MSGCTL:
1443         if (cmd == IPC_STAT || cmd == IPC_SET)
1444             infosize = sizeof(struct msqid_ds);
1445         break;
1446 #endif
1447 #ifdef HAS_SHM
1448     case OP_SHMCTL:
1449         if (cmd == IPC_STAT || cmd == IPC_SET)
1450             infosize = sizeof(struct shmid_ds);
1451         break;
1452 #endif
1453 #ifdef HAS_SEM
1454     case OP_SEMCTL:
1455         if (cmd == IPC_STAT || cmd == IPC_SET)
1456             infosize = sizeof(struct semid_ds);
1457         else if (cmd == GETALL || cmd == SETALL)
1458         {
1459             struct semid_ds semds;
1460 #ifdef SEMCTL_SEMUN
1461             semun.buf = &semds;
1462             if (semctl(id, 0, IPC_STAT, semun) == -1)
1463 #else
1464             if (semctl(id, 0, IPC_STAT, &semds) == -1)
1465 #endif
1466                 return -1;
1467             getinfo = (cmd == GETALL);
1468             infosize = semds.sem_nsems * sizeof(short);
1469                 /* "short" is technically wrong but much more portable
1470                    than guessing about u_?short(_t)? */
1471         }
1472         break;
1473 #endif
1474 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
1475     default:
1476         croak("%s not implemented", op_desc[optype]);
1477 #endif
1478     }
1479
1480     if (infosize)
1481     {
1482         STRLEN len;
1483         if (getinfo)
1484         {
1485             SvPV_force(astr, len);
1486             a = SvGROW(astr, infosize+1);
1487         }
1488         else
1489         {
1490             a = SvPV(astr, len);
1491             if (len != infosize)
1492                 croak("Bad arg length for %s, is %lu, should be %ld",
1493                         op_desc[optype], (unsigned long)len, (long)infosize);
1494         }
1495     }
1496     else
1497     {
1498         IV i = SvIV(astr);
1499         a = (char *)i;          /* ouch */
1500     }
1501     SETERRNO(0,0);
1502     switch (optype)
1503     {
1504 #ifdef HAS_MSG
1505     case OP_MSGCTL:
1506         ret = msgctl(id, cmd, (struct msqid_ds *)a);
1507         break;
1508 #endif
1509 #ifdef HAS_SEM
1510     case OP_SEMCTL:
1511 #ifdef SEMCTL_SEMUN
1512         /* XXX Need metaconfig test */
1513         unsemds.buf = (struct semid_ds *)a;
1514         ret = semctl(id, n, cmd, unsemds);
1515 #else
1516         ret = semctl(id, n, cmd, (struct semid_ds *)a);
1517 #endif
1518         break;
1519 #endif
1520 #ifdef HAS_SHM
1521     case OP_SHMCTL:
1522         ret = shmctl(id, cmd, (struct shmid_ds *)a);
1523         break;
1524 #endif
1525     }
1526     if (getinfo && ret >= 0) {
1527         SvCUR_set(astr, infosize);
1528         *SvEND(astr) = '\0';
1529         SvSETMAGIC(astr);
1530     }
1531     return ret;
1532 }
1533
1534 I32
1535 do_msgsnd(SV **mark, SV **sp)
1536 {
1537 #ifdef HAS_MSG
1538     dTHR;
1539     SV *mstr;
1540     char *mbuf;
1541     I32 id, msize, flags;
1542     STRLEN len;
1543
1544     id = SvIVx(*++mark);
1545     mstr = *++mark;
1546     flags = SvIVx(*++mark);
1547     mbuf = SvPV(mstr, len);
1548     if ((msize = len - sizeof(long)) < 0)
1549         croak("Arg too short for msgsnd");
1550     SETERRNO(0,0);
1551     return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
1552 #else
1553     croak("msgsnd not implemented");
1554 #endif
1555 }
1556
1557 I32
1558 do_msgrcv(SV **mark, SV **sp)
1559 {
1560 #ifdef HAS_MSG
1561     dTHR;
1562     SV *mstr;
1563     char *mbuf;
1564     long mtype;
1565     I32 id, msize, flags, ret;
1566     STRLEN len;
1567
1568     id = SvIVx(*++mark);
1569     mstr = *++mark;
1570     msize = SvIVx(*++mark);
1571     mtype = (long)SvIVx(*++mark);
1572     flags = SvIVx(*++mark);
1573     if (SvTHINKFIRST(mstr)) {
1574         if (SvREADONLY(mstr))
1575             croak("Can't msgrcv to readonly var");
1576         if (SvROK(mstr))
1577             sv_unref(mstr);
1578     }
1579     SvPV_force(mstr, len);
1580     mbuf = SvGROW(mstr, sizeof(long)+msize+1);
1581
1582     SETERRNO(0,0);
1583     ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
1584     if (ret >= 0) {
1585         SvCUR_set(mstr, sizeof(long)+ret);
1586         *SvEND(mstr) = '\0';
1587     }
1588     return ret;
1589 #else
1590     croak("msgrcv not implemented");
1591 #endif
1592 }
1593
1594 I32
1595 do_semop(SV **mark, SV **sp)
1596 {
1597 #ifdef HAS_SEM
1598     dTHR;
1599     SV *opstr;
1600     char *opbuf;
1601     I32 id;
1602     STRLEN opsize;
1603
1604     id = SvIVx(*++mark);
1605     opstr = *++mark;
1606     opbuf = SvPV(opstr, opsize);
1607     if (opsize < sizeof(struct sembuf)
1608         || (opsize % sizeof(struct sembuf)) != 0) {
1609         SETERRNO(EINVAL,LIB$_INVARG);
1610         return -1;
1611     }
1612     SETERRNO(0,0);
1613     return semop(id, (struct sembuf *)opbuf, opsize/sizeof(struct sembuf));
1614 #else
1615     croak("semop not implemented");
1616 #endif
1617 }
1618
1619 I32
1620 do_shmio(I32 optype, SV **mark, SV **sp)
1621 {
1622 #ifdef HAS_SHM
1623     dTHR;
1624     SV *mstr;
1625     char *mbuf, *shm;
1626     I32 id, mpos, msize;
1627     STRLEN len;
1628     struct shmid_ds shmds;
1629
1630     id = SvIVx(*++mark);
1631     mstr = *++mark;
1632     mpos = SvIVx(*++mark);
1633     msize = SvIVx(*++mark);
1634     SETERRNO(0,0);
1635     if (shmctl(id, IPC_STAT, &shmds) == -1)
1636         return -1;
1637     if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
1638         SETERRNO(EFAULT,SS$_ACCVIO);            /* can't do as caller requested */
1639         return -1;
1640     }
1641     shm = (char *)shmat(id, (char*)NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
1642     if (shm == (char *)-1)      /* I hate System V IPC, I really do */
1643         return -1;
1644     if (optype == OP_SHMREAD) {
1645         SvPV_force(mstr, len);
1646         mbuf = SvGROW(mstr, msize+1);
1647
1648         Copy(shm + mpos, mbuf, msize, char);
1649         SvCUR_set(mstr, msize);
1650         *SvEND(mstr) = '\0';
1651         SvSETMAGIC(mstr);
1652     }
1653     else {
1654         I32 n;
1655
1656         mbuf = SvPV(mstr, len);
1657         if ((n = len) > msize)
1658             n = msize;
1659         Copy(mbuf, shm + mpos, n, char);
1660         if (n < msize)
1661             memzero(shm + mpos + n, msize - n);
1662     }
1663     return shmdt(shm);
1664 #else
1665     croak("shm I/O not implemented");
1666 #endif
1667 }
1668
1669 #endif /* SYSV IPC */
1670