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