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

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