source: trunk/third/perl/doio.c @ 10724

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