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