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