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