home *** CD-ROM | disk | FTP | other *** search
/ Crawly Crypt Collection 1 / crawlyvol1.bin / program / compiler / m2posx14 / src / file.ipp < prev    next >
Encoding:
Modula Implementation  |  1994-04-18  |  38.4 KB  |  1,397 lines
  1. IMPLEMENTATION MODULE file;
  2. __IMP_SWITCHES__
  3. __DEBUG__
  4. #ifdef HM2
  5. #ifdef __LONG_WHOLE__
  6. (*$!i+: Modul muss mit $i- uebersetzt werden! *)
  7. (*$!w+: Modul muss mit $w- uebersetzt werden! *)
  8. #else
  9. (*$!i-: Modul muss mit $i+ uebersetzt werden! *)
  10. (*$!w-: Modul muss mit $w+ uebersetzt werden! *)
  11. #endif
  12. #endif
  13. (*****************************************************************************)
  14. (* Basiert auf der MiNTLIB von Eric R. Smith und anderen                     *)
  15. (* --------------------------------------------------------------------------*)
  16. (* 18-Apr-94, Holger Kleinschmidt                                            *)
  17. (*****************************************************************************)
  18.  
  19. VAL_INTRINSIC
  20. CAST_IMPORT
  21. PTR_ARITH_IMPORT
  22.  
  23. FROM SYSTEM IMPORT
  24. (* TYPE *) ADDRESS,
  25. (* PROC *) ADR;
  26. #ifdef MM2
  27. FROM SYSTEM IMPORT CADR;
  28. #endif
  29.  
  30. FROM PORTAB IMPORT
  31. (* CONST*) NULL,
  32. (* TYPE *) SIGNEDWORD, UNSIGNEDWORD, SIGNEDLONG, UNSIGNEDLONG, WORDSET;
  33.  
  34. FROM MEMBLK IMPORT
  35. (* PROC *) memalloc, memdealloc;
  36.  
  37. FROM OSCALLS IMPORT
  38. (* PROC *) Fcreate, Fopen, Fclose, Fdelete, Fread, Fwrite, Fseek, Flock,
  39.            Fcntl, Fdup, Fforce, Pumask, Fchmod, Fattrib, Fchown, Fdatime,
  40.            Fpipe, Fxattr, Dgetdrv, Pgetuid, Pgetgid, Tgettime, Tgetdate,
  41.            Freadlink, Dcntl, Pgetpgrp, Pgetpid;
  42.  
  43. FROM ctype IMPORT
  44. (* PROC *) tocard;
  45.  
  46. FROM cstr IMPORT
  47. (* PROC *) strlen, AssignM2ToC;
  48.  
  49. FROM pSTRING IMPORT
  50. (* PROC *) SLEN, APPEND;
  51.  
  52. FROM types IMPORT
  53. (* CONST*) EOS, DDRVPOSTFIX, DDIRSEP,
  54. (* TYPE *) int, PathName, uidT, gidT, inoT, timeT, offT, sizeT, ssizeT, devT,
  55.            pidT, StrPtr, StrRange, TimeCast;
  56.  
  57. IMPORT e;
  58.  
  59. FROM DosSystem IMPORT
  60. (* PROC *) DosVersion, FileLocking, FcntlAvail, MiNTVersion;
  61.  
  62. FROM DosSupport IMPORT
  63. (* CONST*) FINDALL, DINCR, MinHandle, MaxHandle, getmask, setmask,
  64. (* TYPE *) DTA, FileAttributes, FileAttribute, DosFlags, DosFlag, HandleRange,
  65.            FileType, DosDate,
  66. (* VAR  *) INODE, FD,
  67. (* PROC *) IsTerm, IsDosDevice, UnixToDos, FindFirst, IsExec, DosToUnix,
  68.            DecodeDate, EncodeDate, DateToSeconds, SecondsToDate;
  69.  
  70. (*==========================================================================*)
  71.  
  72. CONST
  73.   EOKL  = LIC(0);
  74.   FSTAT = 00004600H;
  75.  
  76.   BLKSIZE  = 1024;
  77.   LBLKSIZE = 256; (* BLKSIZE DIV 4 *)
  78.  
  79.   STDPERM = modeT{sIRUSR,sIWUSR,sIRGRP,sIWGRP,sIROTH,sIWOTH};
  80.  
  81. TYPE
  82.   XATTR = RECORD
  83.     mode    : modeT;
  84.     index   : UNSIGNEDLONG;
  85.     dev     : UNSIGNEDWORD;
  86.     rdev    : UNSIGNEDWORD; (* Ab MiNT 1.10 mit sinnvollem Wert *)
  87.     nlink   : UNSIGNEDWORD;
  88.     uid     : UNSIGNEDWORD;
  89.     gid     : UNSIGNEDWORD;
  90.     size    : SIGNEDLONG;
  91.     blksize : SIGNEDLONG;
  92.     nblocks : SIGNEDLONG;
  93.     mtime   : WORDSET;
  94.     mdate   : WORDSET;
  95.     atime   : WORDSET;
  96.     adate   : WORDSET;
  97.     ctime   : WORDSET;
  98.     cdate   : WORDSET;
  99.     attr    : WORDSET;
  100.     res2    : SIGNEDWORD;
  101.     res3    : ARRAY [0..1] OF SIGNEDLONG;
  102.   END;
  103.  
  104. CONST
  105.   FRDLCK = 0;
  106.   FWRLCK = 1;
  107.   FUNLCK = 3;
  108.  
  109. TYPE
  110.   FLOCK = RECORD
  111.     type   : UNSIGNEDWORD;
  112.     whence : UNSIGNEDWORD;
  113.     start  : SIGNEDLONG;
  114.     len    : SIGNEDLONG;
  115.     pid    : SIGNEDWORD;
  116.   END;
  117.  
  118. VAR
  119.   UMASK      : modeT;
  120.   zerofill   : ARRAY [0..LBLKSIZE-1] OF UNSIGNEDLONG;
  121.   hasFcntl   : BOOLEAN; (* Wird 'Fcntl'-Aufruf unterstuetzt ? *)
  122.   MiNT       : BOOLEAN; (* Ist MiNT aktiv ? *)
  123.   DOSVersion : CARDINAL;
  124.  
  125. (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
  126.  
  127. PROCEDURE open ((* EIN/ -- *) REF file   : ARRAY OF CHAR;
  128.                 (* EIN/ -- *)     access : OpenMode;
  129.                 (* EIN/ -- *)     mode   : modeT         ): int;
  130.  
  131. CONST TIOCGPGRP = 5406H; (* ('T'<<8)|6 *)
  132.  
  133. VAR res     : INTEGER;
  134.     handle  : INTEGER;
  135.     fd      : HandleRange;
  136.     accMask : OpenMode;
  137.     attr    : WORDSET;
  138.     lres    : SIGNEDLONG;
  139.     arg     : SIGNEDLONG;
  140.     done    : BOOLEAN;
  141.     tty     : BOOLEAN;
  142.     msize   : CARDINAL;
  143.     stack   : ADDRESS;
  144.     path0   : StrPtr;
  145.  
  146. BEGIN
  147.  (* Pfadname DOS-konform gestalten *)
  148.  msize := SLEN(file) + DINCR;
  149.  memalloc(VAL(sizeT,msize), stack, path0);
  150.  UnixToDos(CAST(StrPtr,REFADR(file)), msize - DINCR, VAL(StrRange,msize),
  151.            path0, tty, done);
  152.  IF NOT done THEN
  153.    memdealloc(stack);
  154.    RETURN(MINHANDLE-1);
  155.  END;
  156.  
  157.  (* Flags ermitteln, die das OS selbst auswerten kann *)
  158.  IF hasFcntl THEN
  159.    (* ANNAHME: Wenn 'Fcntl' unterstuetzt wird, kann das OS den Dateimodus
  160.     *          selbst verwalten.
  161.     *)
  162.    accMask := oACCMODE + OpenMode{oAPPEND, oNONBLOCK, oCREAT, oTRUNC, oEXCL};
  163.  ELSE
  164.    accMask := oACCMODE;
  165.  END;
  166.  
  167.  IF Fattrib(path0, 0, 0, attr) THEN
  168.    (* Datei existiert bereits *)
  169.    IF OpenMode{oCREAT, oEXCL} <= access THEN
  170.      (* Exklusiver Zugriff nicht moeglich *)
  171.      handle := e.EEXIST;
  172.    ELSE
  173.      (* Datei im angegebenen Modus oeffnen *)
  174.      done := Fopen(path0, access * accMask, handle);
  175.      IF NOT hasFcntl AND (oTRUNC IN access) AND (handle >= 0) THEN
  176.        (* TOS kann oTRUNC bei einer normalen Datei (kein Geraet) nicht
  177.         * selbst behandeln.
  178.         *)
  179.        done := Fclose(handle, res);
  180.        IF access * oACCMODE = oRDONLY THEN
  181.          (* Wenn die Datei nur zum Lesen geoeffnet wurde, ist kein
  182.           * Kuerzen moeglich.
  183.           *)
  184.          handle := e.EACCES;
  185.        ELSE
  186.          (* Sonst wird die Datei neu erzeugt und mit dem gewuenschten
  187.           * Zugriffsmodus geoeffnet. Die alten Dateiattribute werden
  188.           * uebernommen (auch faHIDDEN und faSYSTEM).
  189.           *
  190.           * Unter alten TOS-Versionen wurde nach einem 'Fcreate' eine
  191.           * alte Datei gleichen Namens manchmal nicht geloescht, deswegen
  192.           * zuerst das 'Fdelete'.
  193.           *)
  194.          done :=     Fdelete(path0, handle)
  195.                  AND Fcreate(path0, 0, handle)
  196.                  AND Fclose(handle, handle)
  197.                  AND Fopen(path0, access * accMask, handle)
  198.                  AND Fattrib(path0, 1, attr, attr);
  199.        END;
  200.      END;
  201.    END;
  202.  ELSIF oCREAT IN access THEN
  203.    (* Datei soll mit den angegebenen Attributen neu angelegt werden *)
  204.    mode := mode - UMASK;
  205.    (* Auch fuer MiNT, da 'Fchmod' die Prozessmaske nicht beruecksichtigt *)
  206.    IF hasFcntl THEN
  207.      (* oCREAT wird vom OS erledigt *)
  208.      done :=     Fopen(path0, access * accMask, handle)
  209.              AND Fchmod(path0, mode, res);
  210.    ELSE
  211.      (* Sonst wird die Datei neu erzeugt und mit dem gewuenschten
  212.       * Zugriffsmodus geoeffnet. Fuer die Attribute der neuen Datei
  213.       * wird die Prozessmaske beruecksichtigt.
  214.       *)
  215.      IF sIWUSR IN mode THEN
  216.        attr := WORDSET{};
  217.      ELSE
  218.        attr := CAST(WORDSET,FileAttribute{faRDONLY});
  219.      END;
  220.      done :=     Fcreate(path0, 0, handle)
  221.              AND Fclose(handle, handle)
  222.              AND Fopen(path0, access * accMask, handle)
  223.              AND Fattrib(path0, 1, attr, attr);
  224.    END;
  225.  ELSE
  226.    (* Datei existiert nicht und soll auch nicht neu angelegt werden *)
  227.    handle := e.ENOENT;
  228.  END;
  229.  
  230.  memdealloc(stack);
  231.  IF handle < MINHANDLE THEN
  232.    e.errno := handle;
  233.    RETURN(MINHANDLE-1);
  234.  END;
  235.  
  236.  tty := IsTerm(handle);
  237.  
  238.  IF hasFcntl THEN
  239.    (* Die kleinste Kennung, die 'Fopen' fuer eine Datei liefert,
  240.     * ist auch unter MiNT gleich 6. Falls aber eine kleinere Kennung
  241.     * frei ist, kann diese stattdessen benutzt werden. Also wird
  242.     * eine weitere Kennung fuer diese Datei erzeugt, und die kleinere
  243.     * der beiden verwendet, waehrend die andere wieder freigegeben wird.
  244.     * Eine andere Kennung veraendert nicht das Ergebnis von "IsTerm"!
  245.     *)
  246.    IF Fcntl(handle, 0, ORD(fDUPFD), lres) THEN
  247.      res := INT(lres);
  248.      IF res < handle THEN
  249.        (* Eine kleinere Kennung ist frei, also diese nehmen und die
  250.         * andere freigeben.
  251.         *)
  252.        done   := Fclose(handle, handle);
  253.        handle := res;
  254.      ELSE
  255.        (* Die von 'Fopen' gelieferte Kennung ist bereits die kleinste
  256.         * freie gewesen, also die neue wieder freigeben.
  257.         *)
  258.        done := Fclose(res, res);
  259.      END;
  260.    END;
  261.  
  262.    (* MiNT schliesst normalerweise alle Dateikennungen, ausser den
  263.     * Standardkanaelen, bei Ausfuehren eines 'Pexec'.
  264.     *)
  265.    done := Fcntl(handle, 0, ORD(fGETFD), lres);
  266.    IF ODD(lres) THEN
  267.      DEC(lres);
  268.    END;
  269.    done := Fcntl(handle, lres, ORD(fSETFD), lres);
  270.    IF tty THEN
  271.      FD[VAL(HandleRange,handle)].ftype := istty;
  272.      IF    NOT(oNOCTTY IN access)
  273.        AND NOT IsTerm(-1)
  274.        AND (Pgetpgrp() >= 0) AND (Pgetpgrp() = Pgetpid())
  275.        AND Fcntl(handle, ADR(arg), TIOCGPGRP, lres)
  276.        AND (arg = VAL(SIGNEDLONG,0))
  277.      THEN
  278.        (* Wenn Handle -1 (aktuelles Kontrollterminal) kein Terminal ist
  279.         * (auf /dev/null umgelenkt), aber die geoeffnete Datei, wird die neu
  280.         * geoffnete Datei zum Kontrollterminal, wenn sie noch kein
  281.         * Kontrollterminal eines anderen Prozesses ist, und der aufrufende
  282.         * Prozess eine Prozessgruppe anfuehrt, ausser, sowas ist unerwuenscht.
  283.         * (Kann nur unter MiNT auftreten.)
  284.         *)
  285.        done := Fforce(-1, handle, res);
  286.        FD[VAL(HandleRange,-1)].ftype := istty;
  287.      END;
  288.    ELSE
  289.      FD[VAL(HandleRange,handle)].ftype := notty;
  290.    END;
  291.  ELSE
  292.    WITH FD[VAL(HandleRange,handle)] DO
  293.      cloex := FALSE;
  294.      IF tty THEN
  295.        ftype := istty;
  296.      ELSE
  297.        ftype := notty;
  298.      END;
  299.      flags := CAST(DosFlag,access);
  300.    END;
  301.  END; (* IF MiNT *)
  302.  RETURN(handle);
  303. END open;
  304.  
  305. (*--------------------------------------------------------------------------*)
  306.  
  307. PROCEDURE creat ((* EIN/ -- *) REF file : ARRAY OF CHAR;
  308.                  (* EIN/ -- *)     mode : modeT         ): int;
  309.  
  310. BEGIN
  311.  RETURN(open(file, oWRONLY + OpenMode{oCREAT,oTRUNC}, mode));
  312. END creat;
  313.  
  314. (*--------------------------------------------------------------------------*)
  315.  
  316. PROCEDURE fcntl ((* EIN/ -- *)     h   : int;
  317.                  (* EIN/ -- *)     cmd : FcntlCmd;
  318.                  (* EIN/AUS *) VAR arg : FcntlArg ): int;
  319.  
  320. VAR done : BOOLEAN;
  321.     res  : INTEGER;
  322.     lres : SIGNEDLONG;
  323.     lock : FLOCK;
  324.     par  : SIGNEDLONG;
  325.  
  326. BEGIN
  327.  IF hasFcntl THEN
  328.    WITH arg DO
  329.      CASE cmd OF
  330.        fDUPFD  : par := VAL(SIGNEDLONG,handle);
  331.       |fSETFD  : par := VAL(SIGNEDLONG,CAST(UNSIGNEDWORD,fdflags));
  332.       |fSETFL  : par := VAL(SIGNEDLONG,CAST(UNSIGNEDWORD,mode));
  333.       |fGETLK,
  334.        fSETLK,
  335.        fSETLKW : WITH flock DO WITH lock DO
  336.                    IF lType <= fWRLCK THEN
  337.                      type := VAL(UNSIGNEDWORD,lType);
  338.                    ELSE
  339.                      type := FUNLCK;
  340.                    END;
  341.                    whence := VAL(UNSIGNEDWORD,lWhence);
  342.                    start  := VAL(SIGNEDLONG,lStart);
  343.                    len    := VAL(SIGNEDLONG,lLen);
  344.                    pid    := VAL(SIGNEDWORD,lPid);
  345.                  END; END;
  346.                  par := CAST(SIGNEDLONG,ADR(lock));
  347.      ELSE (* fGETFD, fGETFL *)
  348.        par := 0;
  349.      END;
  350.      IF Fcntl(h, par, ORD(cmd), lres) THEN
  351.        CASE cmd OF
  352.          fDUPFD  : handle := INT(lres);
  353.                    FD[VAL(HandleRange,handle)] := FD[VAL(HandleRange,h)];
  354.         |fGETFD  : fdflags := CAST(FDFlag,VAL(UNSIGNEDWORD,lres));
  355.         |fGETFL  : mode    := CAST(OpenMode,VAL(UNSIGNEDWORD,lres));
  356.         |fGETLK,
  357.          fSETLK,
  358.          fSETLKW : WITH flock DO WITH lock DO
  359.                      IF type <= FWRLCK THEN
  360.                        lType := VAL(LockType,type);
  361.                      ELSE
  362.                        lType := fUNLCK;
  363.                      END;
  364.                      lWhence := VAL(SeekMode,whence);
  365.                      lStart  := VAL(offT,start);
  366.                      lLen    := VAL(offT,len);
  367.                      lPid    := VAL(pidT,pid);
  368.                    END; END;
  369.        ELSE
  370.          (* fSETFD, fSETFL *)
  371.        END;
  372.        RETURN(0);
  373.      ELSE
  374.        e.errno := INT(lres);
  375.        IF (e.errno = e.eLOCKED) OR (e.errno = e.eNSLOCK) THEN
  376.          e.errno := e.EACCES;
  377.        END;
  378.        RETURN(-1);
  379.      END;
  380.    END; (* WITH arg *)
  381.  ELSE (* NOT hasFcntl *)
  382.    IF (h<MinHandle) OR (h>MaxHandle) THEN
  383.      e.errno := e.EBADF;
  384.      RETURN(-1);
  385.    END;
  386.    WITH arg DO
  387.      CASE cmd OF
  388.        fSETFD : FD[VAL(HandleRange,h)].cloex := FdCloExec IN fdflags;
  389.       |fGETFD : IF FD[VAL(HandleRange,h)].cloex THEN
  390.                   fdflags := FDFlag{FdCloExec};
  391.                 ELSE
  392.                   fdflags := FDFlag{};
  393.                 END;
  394.       |fSETFL : WITH FD[VAL(HandleRange,h)] DO
  395.                   flags := flags * setmask + (CAST(DosFlag,mode) - setmask);
  396.                 END;
  397.       |fGETFL : mode := CAST(OpenMode,FD[VAL(HandleRange,h)].flags * getmask);
  398.       |fDUPFD : IF Fdup(h, handle) THEN
  399.                   FD[VAL(HandleRange,handle)]       := FD[VAL(HandleRange,h)];
  400.                   FD[VAL(HandleRange,handle)].cloex := FALSE;
  401.                 ELSE
  402.                   e.errno := handle;
  403.                   RETURN(-1);
  404.                 END;
  405.       |fSETLK : WITH flock DO
  406.                   res := e.EINVAL;
  407.                   IF    NOT FileLocking()
  408.                      OR (lType = fRDLCK) OR (lWhence <> SeekSet)
  409.                      OR NOT Flock(h, ORD(lType), lStart, lLen, res)
  410.                   THEN
  411.                     IF (res = e.eLOCKED) OR (res = e.eNSLOCK) THEN
  412.                       e.errno := e.EACCES;
  413.                     ELSE
  414.                       e.errno := res;
  415.                     END;
  416.                     RETURN(-1);
  417.                   END;
  418.                 END;
  419.      ELSE
  420.        e.errno := e.EINVAL;
  421.        RETURN(-1);
  422.      END; (* CASE *)
  423.      RETURN(0);
  424.    END; (* WITH arg *)
  425.  END; (* IF hasFcntl *)
  426. END fcntl;
  427.  
  428. (*--------------------------------------------------------------------------*)
  429.  
  430. PROCEDURE close ((* EIN/ -- *) h : int ): int;
  431.  
  432. VAR res : INTEGER;
  433.  
  434. BEGIN
  435.  IF (h<MinHandle) OR (h>MaxHandle) THEN
  436.    e.errno := e.EBADF;
  437.    RETURN(-1);
  438.  END;
  439.  IF Fclose(h, res) THEN
  440.    WITH FD[VAL(HandleRange,h)] DO
  441.      ftype := unknown;
  442.      cloex := FALSE;
  443.    END;
  444.    RETURN(0);
  445.  ELSE
  446.    e.errno := res;
  447.    RETURN(-1);
  448.  END;
  449. END close;
  450.  
  451. (*--------------------------------------------------------------------------*)
  452.  
  453. PROCEDURE read ((* EIN/ -- *) h   : int;
  454.                 (* EIN/ -- *) buf : ADDRESS;
  455.                 (* EIN/ -- *) len : sizeT   ): ssizeT;
  456.  
  457. VAR lres : SIGNEDLONG;
  458.  
  459. BEGIN
  460.  IF Fread(h, VAL(SIGNEDLONG,len), buf, lres) THEN
  461.    RETURN(VAL(ssizeT,lres));
  462.  ELSE
  463.    e.errno := INT(lres);
  464.    RETURN(-1);
  465.  END;
  466. END read;
  467.  
  468. (*--------------------------------------------------------------------------*)
  469.  
  470. PROCEDURE write ((* EIN/ -- *) h   : int;
  471.                  (* EIN/ -- *) buf : ADDRESS;
  472.                  (* EIN/ -- *) len : sizeT   ): ssizeT;
  473.  
  474. VAR lres : SIGNEDLONG;
  475.  
  476. BEGIN
  477.  IF NOT hasFcntl THEN
  478.    IF (h<MinHandle) OR (h>MaxHandle) THEN
  479.      e.errno := e.EBADF;
  480.      RETURN(-1);
  481.    ELSIF append IN FD[VAL(HandleRange,h)].flags THEN
  482.      IF NOT Fseek(0, h, ORD(SeekEnd), lres) THEN
  483.        e.errno := INT(lres);
  484.        RETURN(-1);
  485.      END;
  486.    END;
  487.  END;
  488.  IF Fwrite(h, VAL(SIGNEDLONG,len), buf, lres) THEN
  489.    RETURN(VAL(ssizeT,lres));
  490.  ELSE
  491.    e.errno := INT(lres);
  492.    RETURN(-1);
  493.  END;
  494. END write;
  495.  
  496. (*--------------------------------------------------------------------------*)
  497.  
  498. PROCEDURE lseek ((* EIN/ -- *) h    : int;
  499.                  (* EIN/ -- *) off  : offT;
  500.                  (* EIN/ -- *) mode : SeekMode ): offT;
  501.  
  502. CONST ERANGEL = LIC(-64);
  503.       EACCDNL = LIC(-36);
  504.  
  505. VAR lres   : SIGNEDLONG;
  506.     curPos : SIGNEDLONG;
  507.     newPos : SIGNEDLONG;
  508.     len    : SIGNEDLONG;
  509.     done   : BOOLEAN;
  510.  
  511. BEGIN
  512.  len := VAL(SIGNEDLONG,off);
  513.  
  514.  IF len <= LIC(0) THEN
  515.    (* Datei braucht nicht verlaengert zu werden *)
  516.    IF Fseek(len, h, ORD(mode), lres) THEN
  517.      RETURN(VAL(offT,lres));
  518.    ELSIF MiNT AND (lres = EACCDNL) THEN
  519.      e.errno := e.ESPIPE;
  520.    ELSE
  521.      e.errno := INT(lres);
  522.    END;
  523.    RETURN(-1);
  524.  END;
  525.  
  526.  (* Augenblickliche Position feststellen, bei 'SeekEnd' gleich
  527.   * ans Ende der Datei.
  528.   *)
  529.  IF mode = SeekEnd THEN
  530.    done := Fseek(0, h, ORD(SeekEnd), curPos);
  531.  ELSE
  532.    done := Fseek(0, h, ORD(SeekCur), curPos);
  533.  END;
  534.  IF NOT done THEN
  535.    IF MiNT AND (curPos = EACCDNL) THEN
  536.      e.errno := e.ESPIPE;
  537.    ELSE
  538.      e.errno := INT(curPos);
  539.    END;
  540.    RETURN(-1);
  541.  END;
  542.  
  543.  (* gewuenschte Position berechnen. 'SeekEnd' und 'SeekCur' koennen
  544.   * gleichbehandelt werden, da der Zeiger bei 'SeekEnd' schon am
  545.   * Ende der Datei steht.
  546.   *)
  547.  IF mode = SeekSet THEN
  548.    newPos := len;
  549.  ELSE
  550.    newPos := curPos + len;
  551.  END;
  552.  
  553.  (* Es kann sein (ist auch meistens der Fall), dass die gewuenschte
  554.   * Position innerhalb der bestehenden Datei liegt. Deswegen wird zuerst
  555.   * versucht, die gewuenschte Position direkt anzufahren. Wenn dabei ein
  556.   * ``Range-Fehler'' auftritt, muss die Datei verlaengert werden.
  557.   * Ein ``Range-Fehler'' tritt nicht auf, wenn das Dateisystem
  558.   * (z.B. MinixFS) ein Fseek hinter das Dateiende selbst verwaltet.
  559.   *)
  560.  done := Fseek(len, h, ORD(mode), curPos);
  561.  IF curPos = newPos THEN
  562.    RETURN(VAL(offT,curPos));
  563.  ELSIF NOT done AND (curPos <> ERANGEL) THEN
  564.    e.errno := INT(curPos);
  565.    RETURN(-1);
  566.  END;
  567.  
  568.  
  569.  done := Fseek(0, h, ORD(SeekEnd), curPos);
  570.  
  571.  (* Solange Nullbytes schreiben, bis die Datei auf die gewuenschte
  572.   * Laenge gebracht ist.
  573.   *)
  574.  REPEAT
  575.    len := newPos - curPos;
  576.    IF  len > VAL(SIGNEDLONG,BLKSIZE)  THEN
  577.      len := VAL(SIGNEDLONG,BLKSIZE);
  578.    END;
  579.    done := Fwrite(h, len, ADR(zerofill), lres);
  580.    IF  lres <> len  THEN
  581.      IF done THEN
  582.        RETURN(VAL(offT,curPos + lres));
  583.      ELSE
  584.        e.errno := INT(lres);
  585.        RETURN(VAL(offT,curPos));
  586.      END;
  587.    END;
  588.    INC(curPos, len);
  589.  UNTIL curPos >= newPos;
  590.  RETURN(VAL(offT,curPos));
  591. END lseek;
  592.  
  593. (*--------------------------------------------------------------------------*)
  594.  
  595. PROCEDURE ftruncate ((* EIN/ -- *) h   : int;
  596.                      (* EIN/ -- *) len : offT ): int;
  597.  
  598. (* MinixFS 0.60pl6 funktioniert nur, wenn die Datei mit oWRONLY
  599.    geoeffnet wurde.
  600.  *)
  601. CONST FTRUNCATE = 4604H; (* ('F'<<8)|4 *)
  602.  
  603. VAR lres : SIGNEDLONG;
  604.  
  605. BEGIN
  606.  IF Fcntl(h, ADR(len), FTRUNCATE, lres) THEN
  607.    RETURN(0);
  608.  ELSE
  609.    e.errno := INT(lres);
  610.    RETURN(-1);
  611.  END;
  612. END ftruncate;
  613.  
  614. (*--------------------------------------------------------------------------*)
  615.  
  616. PROCEDURE dup ((* EIN/ -- *) h : int ): int;
  617.  
  618. VAR lres : SIGNEDLONG;
  619.     done : BOOLEAN;
  620.     newh : INTEGER;
  621.  
  622. BEGIN
  623.  IF hasFcntl THEN
  624.    done := Fcntl(h, 0, ORD(fDUPFD), lres);
  625.    newh := INT(lres);
  626.    IF done THEN
  627.      (* 'FdCloExec'-Flag loeschen, falls gesetzt *)
  628.      done := Fcntl(newh, 0, ORD(fGETFD), lres);
  629.      IF ODD(lres) THEN
  630.        DEC(lres);
  631.      END;
  632.      done := Fcntl(newh, lres, ORD(fSETFD), lres);
  633.      FD[VAL(HandleRange,newh)].ftype := FD[VAL(HandleRange,h)].ftype;
  634.      RETURN(newh);
  635.    ELSE
  636.      e.errno := newh;
  637.      RETURN(-1);
  638.    END;
  639.  ELSE
  640.    IF (h<MinHandle) OR (h>MaxHandle) THEN
  641.      e.errno := e.EBADF;
  642.      RETURN(-1);
  643.    END;
  644.    IF Fdup(h, newh) THEN
  645.      FD[VAL(HandleRange,newh)]       := FD[VAL(HandleRange,h)];
  646.      FD[VAL(HandleRange,newh)].cloex := FALSE;
  647.      RETURN(newh);
  648.    ELSE
  649.      e.errno := newh;
  650.      RETURN(-1);
  651.    END;
  652.  END;
  653. END dup;
  654.  
  655. (*--------------------------------------------------------------------------*)
  656.  
  657. PROCEDURE dup2 ((* EIN/ -- *) oldh : int;
  658.                 (* EIN/ -- *) newh : int ): int;
  659.  
  660. VAR res  : INTEGER;
  661.     lres : SIGNEDLONG;
  662.     void : BOOLEAN;
  663.  
  664. BEGIN
  665.  IF oldh = newh THEN
  666.    RETURN(newh);
  667.  END;
  668.  (* Das Schliessen eines Standardkanals macht eine vorherige
  669.   * Umleitung rueckgaengig. Ist aber erst seit dem GEMDOS des TOS 1.04
  670.   * anwendbar.
  671.   *)
  672.  IF DOSVersion >= 1500H THEN
  673.    void := Fclose(newh, res);
  674.  END;
  675.  
  676.  IF Fforce(newh, oldh, res) THEN
  677.    IF hasFcntl THEN
  678.      (* 'FdCloExec'-Flag loeschen, falls gesetzt *)
  679.      void := Fcntl(newh, 0, ORD(fGETFD), lres);
  680.      IF ODD(lres) THEN
  681.        DEC(lres);
  682.      END;
  683.      void := Fcntl(newh, lres, ORD(fSETFD), lres);
  684.      FD[VAL(HandleRange,newh)].ftype := FD[VAL(HandleRange,oldh)].ftype;
  685.    ELSE
  686.      IF (newh<MinHandle) OR (newh>MaxHandle) THEN
  687.        e.errno := e.EBADF;
  688.        RETURN(-1);
  689.      END;
  690.      FD[VAL(HandleRange,newh)]       := FD[VAL(HandleRange,oldh)];
  691.      FD[VAL(HandleRange,newh)].cloex := FALSE;
  692.    END;
  693.    RETURN(newh);
  694.  ELSE
  695.    e.errno := res;
  696.    RETURN(-1);
  697.  END;
  698. END dup2;
  699.  
  700. (*--------------------------------------------------------------------------*)
  701.  
  702. PROCEDURE umask ((* EIN/ -- *) excl : modeT ): modeT;
  703.  
  704. VAR oldmask : modeT;
  705.     lres    : SIGNEDLONG;
  706.  
  707. BEGIN
  708.  oldmask := UMASK;
  709.  UMASK   := excl;
  710.  lres    := Pumask(excl);
  711.  IF lres < VAL(SIGNEDLONG,0) THEN
  712.    (* Aufruf wird nicht unterstuetzt *)
  713.    RETURN(oldmask);
  714.  ELSE
  715.    RETURN(CAST(modeT,VAL(UNSIGNEDWORD,lres)));
  716.  END;
  717. END umask;
  718.  
  719. (*---------------------------------------------------------------------------*)
  720.  
  721. PROCEDURE chmod ((* EIN/ -- *) REF file : ARRAY OF CHAR;
  722.                  (* EIN/ -- *)     mode : modeT         ): int;
  723.  
  724. VAR         res    : INTEGER;
  725.             dot    : BOOLEAN;
  726.             done   : BOOLEAN;
  727.             dta    : DTA;
  728.     __REG__ attr   : FileAttribute;
  729.             old    : WORDSET;
  730.             stack  : ADDRESS;
  731.             msize  : CARDINAL;
  732.             path0  : StrPtr;
  733.  
  734. BEGIN
  735.  msize := SLEN(file) + DINCR;
  736.  memalloc(VAL(sizeT,msize), stack, path0);
  737.  UnixToDos(CAST(StrPtr,REFADR(file)), msize - DINCR, VAL(StrRange,msize),
  738.            path0, dot, done);
  739.  IF NOT done THEN
  740.    memdealloc(stack);
  741.    RETURN(-1);
  742.  END;
  743.  
  744.  IF Fchmod(path0, mode, res) THEN
  745.    res := 0;
  746.  ELSIF res <> e.eINVFN THEN
  747.    (* 'Fchmod'-Aufruf wird unterstuetzt, anderer Fehler *)
  748.    e.errno := res;
  749.    res     := -1;
  750.  ELSIF FindFirst(path0, FINDALL, dta, res) THEN
  751.    (* 'Fchmod'-Aufruf wird nicht unterstuetzt *)
  752.    attr := dta.attr;
  753.    IF faSUBDIR IN attr THEN
  754.      (* Verzeichnisse in Ruhe lassen (duerfen keine weiteren Attribute haben)*)
  755.      memdealloc(stack);
  756.      RETURN(0);
  757.    END;
  758.    IF faCHANGED IN attr THEN
  759.      (* Archivbit nicht veraendern *)
  760.      attr := FileAttribute{faRDONLY, faCHANGED};
  761.    ELSE
  762.      attr := FileAttribute{faRDONLY};
  763.    END;
  764.    IF sIWUSR IN mode THEN
  765.      EXCL(attr, faRDONLY);
  766.    END;
  767.    IF Fattrib(path0, 1, attr, old) THEN
  768.      res := 0;
  769.    ELSE
  770.      e.errno := INT(CAST(SIGNEDWORD,old));
  771.      res     := -1;
  772.    END;
  773.  ELSE
  774.    e.errno := res;
  775.    res     := -1;
  776.  END;
  777.  memdealloc(stack);
  778.  RETURN(res);
  779. END chmod;
  780.  
  781. (*--------------------------------------------------------------------------*)
  782.  
  783. PROCEDURE chown ((* EIN/ -- *) REF file : ARRAY OF CHAR;
  784.                  (* EIN/ -- *)     uid  : uidT;
  785.                  (* EIN/ -- *)     gid  : gidT          ): int;
  786.  
  787. VAR res    : INTEGER;
  788.     dot    : BOOLEAN;
  789.     done   : BOOLEAN;
  790.     stack  : ADDRESS;
  791.     msize  : CARDINAL;
  792.     path0  : StrPtr;
  793.  
  794. BEGIN
  795.  msize := SLEN(file) + DINCR;
  796.  memalloc(VAL(sizeT,msize), stack, path0);
  797.  UnixToDos(CAST(StrPtr,REFADR(file)), msize - DINCR, VAL(StrRange,msize),
  798.            path0, dot, done);
  799.  IF NOT done THEN
  800.    memdealloc(stack);
  801.    RETURN(-1);
  802.  END;
  803.  
  804.  IF Fchown(path0, uid, gid, res) THEN
  805.    res     := 0;
  806.  ELSIF res <> e.eINVFN THEN
  807.    (* 'Fchown'-Aufruf wird unterstuetzt, anderer Fehler *)
  808.    e.errno := res;
  809.    res     := -1;
  810.  ELSIF (uid = 0) AND (gid = 0) THEN
  811.    res     := 0;
  812.  ELSE
  813.    e.errno := e.EINVAL;
  814.    res     := -1;
  815.  END;
  816.  memdealloc(stack);
  817.  RETURN(res);
  818. END chown;
  819.  
  820. (*--------------------------------------------------------------------------*)
  821.  
  822. PROCEDURE utime ((* EIN/ -- *) REF file : ARRAY OF CHAR;
  823.                  (* EIN/ -- *)     time : UTimPtr       ): int;
  824. (**)
  825. CONST FUTIME = 4603H; (* ('F'<<8)|3 *)
  826.  
  827. VAR lres   : SIGNEDLONG;
  828.     hndl   : INTEGER;
  829.     void   : BOOLEAN;
  830.     done   : BOOLEAN;
  831.     tmp    : WORDSET;
  832.     stack  : ADDRESS;
  833.     tptr   : ADDRESS;
  834.     msize  : CARDINAL;
  835.     path0  : StrPtr;
  836.     date   : DosDate;
  837.     tm : RECORD
  838.       actime  : TimeCast;
  839.       modtime : TimeCast;
  840.     END;
  841.  
  842. BEGIN
  843.  msize := SLEN(file) + DINCR;
  844.  memalloc(VAL(sizeT,msize), stack, path0);
  845.  UnixToDos(CAST(StrPtr,REFADR(file)), msize - DINCR, VAL(StrRange,msize),
  846.            path0, void, done);
  847.  IF NOT done THEN
  848.    memdealloc(stack);
  849.    RETURN(-1);
  850.  END;
  851.  
  852.  WITH tm DO
  853.    IF time = NULL THEN
  854.      (* Fcntl bzw. Dcntl entscheiden selbst weiter *)
  855.      tptr := NULL;
  856.    ELSE
  857.      SecondsToDate(time^.modtime, date);
  858.      EncodeDate(date, modtime.date, modtime.time);
  859.      SecondsToDate(time^.actime, date);
  860.      EncodeDate(date, actime.date, actime.time);
  861.      tptr := ADR(tm);
  862.    END;
  863.    IF Dcntl(FUTIME, path0, tptr, lres) THEN
  864.      memdealloc(stack);
  865.      RETURN(0);
  866.    ELSIF INT(lres) <> e.eINVFN THEN
  867.      (* Dateisystem unterstuetzt den FUTIME-Aufruf, aber anderer
  868.       * Fehler, deswegen abbrechen.
  869.       *)
  870.      memdealloc(stack);
  871.      e.errno := INT(lres);
  872.      RETURN(-1);
  873.    END;
  874.  
  875.    done := Fopen(path0, oWRONLY, hndl);
  876.    IF done THEN
  877.      IF NOT Fcntl(hndl, tptr, FUTIME, lres) THEN
  878.        (* 'Fcntl' oder FUTIME werden nicht unterstuetzt oder anderer Fehler *)
  879.        modtime.time := Tgettime();
  880.        modtime.date := Tgetdate();
  881.        Fdatime(ADR(modtime), hndl, 1);
  882.      END;
  883.      void := Fclose(hndl, hndl);
  884.    ELSIF hndl = e.eFILNF THEN
  885.      void := Fattrib(path0, 0, 0, tmp);
  886.      IF faSUBDIR IN CAST(FileAttribute,tmp) THEN
  887.        (* Verzeichnisse in Ruhe lassen *)
  888.        done := TRUE;
  889.      END;
  890.    END;
  891.  END; (* WITH *)
  892.  IF done THEN
  893.    hndl := 0;
  894.  ELSE
  895.    e.errno := hndl;
  896.    hndl    := -1;
  897.  END;
  898.  memdealloc(stack);
  899.  RETURN(hndl);
  900. END utime;
  901.  
  902. (*---------------------------------------------------------------------------*)
  903.  
  904. PROCEDURE pipe ((* -- /AUS *) VAR ph : PipeBuf ): int;
  905.  
  906. VAR handle : ARRAY [0..1] OF SIGNEDWORD;
  907.     res    : INTEGER;
  908.  
  909. BEGIN
  910.  ph.readh  := 0;
  911.  ph.writeh := 0;
  912.  IF Fpipe(ADR(handle), res) THEN
  913.    ph.readh  := INT(handle[0]);
  914.    ph.writeh := INT(handle[1]);
  915.    FD[handle[0]].ftype := notty;
  916.    FD[handle[1]].ftype := notty;
  917.    RETURN(0);
  918.  ELSE
  919.    (* 'Fpipe'-Aufruf wird nicht unterstuetzt oder anderer Fehler *)
  920.    e.errno := res;
  921.    RETURN(-1);
  922.  END;
  923. END pipe;
  924.  
  925. (*---------------------------------------------------------------------------*)
  926.  
  927. PROCEDURE MiNTstat ((* EIN/ -- *)     hndl : BOOLEAN;
  928.                     (* EIN/ -- *)     sym  : BOOLEAN;
  929.                     (* EIN/ -- *)     h    : INTEGER;
  930.                     (* EIN/ -- *)     path : StrPtr;
  931.                     (* -- /AUS *) VAR st   : StatRec ): INTEGER;
  932.  
  933. VAR
  934.   lres  : SIGNEDLONG;
  935.   done  : BOOLEAN;
  936.   dlen  : INTEGER;
  937.   xlen  : INTEGER;
  938.   xattr : XATTR;
  939.   stack : ADDRESS;
  940.   msize : CARDINAL;
  941.   slink : StrPtr;
  942.   date  : DosDate;
  943.  
  944. BEGIN
  945.  IF hndl THEN
  946.    done := Fcntl(h, ADR(xattr), FSTAT, lres);
  947.    h    := INT(lres);
  948.  ELSE
  949.    done := Fxattr(ORD(sym), path, ADR(xattr), h);
  950.    IF sym AND done AND (xattr.mode * sIFMT = sIFLNK) THEN
  951.      msize := VAL(CARDINAL,xattr.size) + 1;
  952.      memalloc(VAL(sizeT,msize), stack, slink);
  953.      done := Freadlink(msize, slink, path, h);
  954.      IF done THEN
  955.        DosToUnix(slink, 0, NULL, dlen, xlen);
  956.        xattr.size := VAL(SIGNEDLONG,xlen);
  957.      END;
  958.      memdealloc(stack);
  959.    END;
  960.  END;
  961.  IF NOT done THEN
  962.    RETURN(h);
  963.  END;
  964.  
  965.  WITH st DO WITH xattr DO
  966.    stMode    := mode;
  967.    stIno     := index;
  968.    stDev     := dev;
  969.    stRdev    := rdev;
  970.    stNlink   := nlink;
  971.    stUid     := uid;
  972.    stGid     := gid;
  973.    stSize    := size;
  974.    stBlksize := blksize;
  975.    stBlocks  := (CAST(UNSIGNEDLONG,nblocks) * CAST(UNSIGNEDLONG,blksize))
  976.                 DIV VAL(UNSIGNEDLONG,512);
  977.  
  978.    DecodeDate(mdate, mtime, date);
  979.    stMtime := DateToSeconds(date);
  980.    DecodeDate(adate, atime, date);
  981.    stAtime := DateToSeconds(date);
  982.    DecodeDate(cdate, ctime, date);
  983.    stCtime := DateToSeconds(date);
  984.  END; END;
  985.  RETURN(0);
  986. END MiNTstat;
  987.  
  988. (*--------------------------------------------------------------------------*)
  989.  
  990. PROCEDURE istat (VAR name : ARRAY OF CHAR;
  991.                  VAR st   : StatRec;
  992.                      sym  : BOOLEAN       ): INTEGER;
  993.  
  994. CONST DIRSIZE = 1024;
  995.       BLKSIZE = 1024;
  996.  
  997. VAR         dta    : DTA;
  998.             err    : INTEGER;
  999.     __REG__ pLen   : UNSIGNEDWORD;
  1000.             ROOT   : BOOLEAN;
  1001.             DOT    : BOOLEAN;
  1002.             drv    : BOOLEAN;
  1003.             stack  : ADDRESS;
  1004.             msize  : CARDINAL;
  1005.             path0  : StrPtr;
  1006.             date   : DosDate;
  1007.  
  1008. BEGIN
  1009.  msize := SLEN(name) + DINCR + 4; (* + 4 wegen ++ "\*.*" *)
  1010.  memalloc(VAL(sizeT,msize), stack, path0);
  1011.  UnixToDos(CAST(StrPtr,REFADR(name)), msize - DINCR - 4, VAL(StrRange,msize),
  1012.            path0, DOT, drv);
  1013.  IF NOT drv THEN
  1014.    memdealloc(stack);
  1015.    RETURN(-1);
  1016.  END;
  1017.  
  1018.  err := MiNTstat(FALSE, sym, 0, path0, st);
  1019.  IF err <> e.eINVFN THEN
  1020.    (* 'Fxattr'-Aufruf wird unterstuetzt *)
  1021.    memdealloc(stack);
  1022.    IF err < 0 THEN
  1023.      e.errno := err;
  1024.      RETURN(-1);
  1025.    ELSE
  1026.      RETURN(0);
  1027.    END;
  1028.  END;
  1029.  
  1030.  (* 'Fxattr'-Aufruf wird nicht unterstuetzt, TOS-Emulation *)
  1031.  
  1032.  pLen := VAL(UNSIGNEDWORD,strlen(path0));
  1033.  WITH st DO
  1034.    stUid     := 0;
  1035.    stGid     := 0;
  1036.    stRdev    := 0;
  1037.    stBlksize := BLKSIZE;
  1038.  END;
  1039.  
  1040.  IF IsDosDevice(path0) THEN
  1041.    WITH st DO
  1042.      stIno    := VAL(inoT,INODE); INC(INODE);
  1043.      stMode   := sIFCHR + STDPERM;
  1044.      stDev    := 0;
  1045.      DecodeDate(Tgetdate(), Tgettime(), date);
  1046.      stMtime  := DateToSeconds(date);
  1047.      stAtime  := stMtime;
  1048.      stCtime  := stMtime;
  1049.      stNlink  := 1;
  1050.      stSize   := 0;
  1051.      stBlocks := 0;
  1052.    END;
  1053.    memdealloc(stack);
  1054.    RETURN(0);
  1055.  END;
  1056.  
  1057.  IF path0^[1] = DDRVPOSTFIX THEN
  1058.    st.stDev := VAL(devT,tocard(path0^[0]) - 10);
  1059.    drv      := TRUE;
  1060.  ELSE
  1061.    st.stDev := VAL(devT,Dgetdrv());
  1062.    drv      := FALSE;
  1063.  END;
  1064.  
  1065.  (* Hauptverzeichnisse muessen gesondert behandelt werden, da sie nicht
  1066.   * wie Unterverzeichnisse in der Baumstruktur eingebunden sind - sie
  1067.   * haben kein Erstellungsdatum und besitzen nicht die Eintraege
  1068.   * "." und ".." zur Verkettung.
  1069.   *)
  1070.  IF            (pLen = 1) AND (path0^[0] = DDIRSEP)
  1071.     OR drv AND (pLen = 3) AND (path0^[2] = DDIRSEP)
  1072.  THEN
  1073.    (* Ein Hauptverzeichnis ist direkt angegeben, deshalb sind keine
  1074.     * weiteren Tests noetig.
  1075.     *)
  1076.    ROOT := TRUE;
  1077.  ELSE
  1078.    IF path0^[pLen-1] = DDIRSEP THEN
  1079.      (* Verzeichnisse nicht extra kennzeichnen.
  1080.       * 'pLen' ist mindestens zwei, da der Fall 'pLen' = 1
  1081.       * oben abgefangen wird.
  1082.       *)
  1083.      path0^[pLen-1] := 0C;
  1084.      DEC(pLen);
  1085.    ELSIF drv AND (pLen = 2) THEN
  1086.      (* "Fsfirst("x:")" funktioniert nicht *)
  1087.      path0^[2] := '.';
  1088.      path0^[3] := 0C;
  1089.      DOT       := TRUE;
  1090.      INC(pLen);
  1091.    END;
  1092.  
  1093.    IF DOT THEN
  1094.      AssignM2ToC("\*.*", msize - VAL(CARDINAL,pLen), ADDADR(path0, pLen));
  1095.      (* Den ersten Eintrag suchen, sodass bei allen Verzeichnissen - ausser
  1096.       * den Hauptverzeichnissen - der Eintrag "." gefunden wird.
  1097.       * (Bei "..\*.*" wird das "." des uebergeordneten Verzeichnisses
  1098.       * gefunden.)
  1099.       *)
  1100.    END;
  1101.  
  1102.    IF FindFirst(path0, FINDALL, dta, err) THEN
  1103.      ROOT := DOT AND ((dta.name[0] <> '.') OR (dta.name[1] <> 0C));
  1104.      (* nicht-leeres Hauptverzeichnis, falls der erste Eintrag nicht
  1105.       * mit einem Punkt beginnt (normaler Dateiname), oder nach dem Punkt
  1106.       * nicht beendet ist (dann kann es nicht "." sein, das in allen
  1107.       * Verzeichnissen zuerst steht.
  1108.       *)
  1109.    ELSE
  1110.      (* Wenn kein Eintrag gefunden wird und "." oder ".." angegeben
  1111.       * wurden, handelt es sich um ein leeres Hauptverzeichnis,
  1112.       * ansonsten ist ein Fehler aufgetreten (angegebene Datei wurde
  1113.       * nicht gefunden).
  1114.       *)
  1115.      IF DOT AND (err = e.eFILNF) THEN
  1116.        ROOT := TRUE;
  1117.      ELSE
  1118.        e.errno := err;
  1119.        memdealloc(stack);
  1120.        RETURN(-1);
  1121.      END;
  1122.    END;
  1123.  END;
  1124.  
  1125.  IF ROOT THEN
  1126.    (* Einem Hauptverzeichnis lassen sich leider kaum Informationen
  1127.     * entlocken.
  1128.     *)
  1129.    WITH st DO
  1130.      stIno    := 2; (* ?? *)
  1131.      stSize   := DIRSIZE;
  1132.      stBlocks := 2;
  1133.      stNlink  := 2;
  1134.      stMode   := sIFDIR + STDPERM + modeT{sIXUSR, sIXGRP, sIXOTH};
  1135.      stMtime  := 0;
  1136.      stAtime  := 0;
  1137.      stCtime  := 0;
  1138.    END;
  1139.    memdealloc(stack);
  1140.    RETURN(0);
  1141.  END;
  1142.  
  1143.  WITH st DO
  1144.    stIno   := VAL(inoT,INODE); INC(INODE);
  1145.    DecodeDate(dta.date, dta.time, date);
  1146.    stMtime := DateToSeconds(date);
  1147.    stAtime := stMtime;
  1148.    stCtime := stMtime;
  1149.    IF faSUBDIR IN dta.attr THEN
  1150.      stSize   := DIRSIZE;
  1151.      stBlocks := 2;
  1152.      stNlink  := 2;
  1153.    ELSE
  1154.      stSize   := dta.size;
  1155.      stBlocks := (CAST(UNSIGNEDLONG,stSize) + VAL(UNSIGNEDLONG,BLKSIZE - 1))
  1156.                  DIV VAL(UNSIGNEDLONG,512);
  1157.      stNlink  := 1;
  1158.    END;
  1159.    IF faSUBDIR IN dta.attr THEN
  1160.      stMode := sIFDIR + STDPERM + modeT{sIXUSR, sIXGRP, sIXOTH};
  1161.    ELSIF IsExec(path0) THEN
  1162.      stMode := sIFREG + STDPERM + modeT{sIXUSR, sIXGRP, sIXOTH};
  1163.    ELSE
  1164.      stMode := sIFREG + STDPERM;
  1165.    END;
  1166.    IF faRDONLY IN dta.attr THEN
  1167.      stMode := stMode - modeT{sIWUSR, sIWGRP, sIWOTH};
  1168.    END;
  1169.    IF faHIDDEN IN dta.attr THEN
  1170.      stMode := stMode - modeT{sIRUSR, sIRGRP, sIROTH};
  1171.    END;
  1172.  END; (* WITH st *)
  1173.  memdealloc(stack);
  1174.  RETURN(0);
  1175. END istat;
  1176.  
  1177. (*--------------------------------------------------------------------------*)
  1178.  
  1179. PROCEDURE stat ((* EIN/ -- *) REF file : ARRAY OF CHAR;
  1180.                 (* -- /AUS *) VAR st   : StatRec       ): int;
  1181.  
  1182. BEGIN
  1183.  RETURN(istat(file, st, FALSE));
  1184. END stat;
  1185.  
  1186. (*--------------------------------------------------------------------------*)
  1187.  
  1188. PROCEDURE lstat ((* EIN/ -- *) REF file : ARRAY OF CHAR;
  1189.                  (* -- /AUS *) VAR st   : StatRec       ): int;
  1190.  
  1191. BEGIN
  1192.  RETURN(istat(file, st, TRUE));
  1193. END lstat;
  1194.  
  1195. (*--------------------------------------------------------------------------*)
  1196.  
  1197. PROCEDURE fstat ((* EIN/ -- *)     h  : int;
  1198.                  (* -- /AUS *) VAR st : StatRec ): int;
  1199.  
  1200. CONST BLKSIZE = 1024;
  1201.  
  1202. VAR         err    : INTEGER;
  1203.             pos    : SIGNEDLONG;
  1204.             size   : SIGNEDLONG;
  1205.     __REG__ void   : BOOLEAN;
  1206.             time   : ARRAY [0..1] OF WORDSET;
  1207.             lres   : SIGNEDLONG;
  1208.             magic  : UNSIGNEDWORD;
  1209.             dummy  : StrPtr;
  1210.             tc     : TimeCast;
  1211.             date   : DosDate;
  1212.  
  1213. BEGIN
  1214.  err := MiNTstat(TRUE, FALSE, h, dummy, st);
  1215.  IF err <> e.eINVFN THEN
  1216.    (* 'Fcntl'-Aufruf wird unterstuetzt *)
  1217.    IF err < 0 THEN
  1218.      e.errno := err;
  1219.      RETURN(-1);
  1220.    ELSE
  1221.      RETURN(0);
  1222.    END;
  1223.  END;
  1224.  
  1225.  (* 'Fcntl'-Aufruf wird nicht unterstuetzt, TOS-Emulation *)
  1226.  
  1227.  IF (h<MinHandle) OR (h>MaxHandle) THEN
  1228.    e.errno := e.EBADF;
  1229.    RETURN(-1);
  1230.  END;
  1231.  WITH FD[VAL(HandleRange,h)] DO
  1232.    IF ftype = unknown THEN
  1233.      IF IsTerm(h) THEN
  1234.        ftype := istty;
  1235.      ELSE
  1236.        ftype := notty;
  1237.      END;
  1238.    END;
  1239.  END;
  1240.  WITH st DO
  1241.    IF FD[VAL(HandleRange,h)].ftype = istty THEN
  1242.      stMode  := sIFCHR + STDPERM;
  1243.      stSize  := 0;
  1244.      tc.time := Tgettime();
  1245.      tc.date := Tgetdate();
  1246.    ELSE
  1247.      Fdatime(ADR(time), h, 0);
  1248.      tc.time := time[0];
  1249.      tc.date := time[1];
  1250.  
  1251.      IF Fseek(0, h, ORD(SeekCur), pos) THEN
  1252.        void   := Fseek(0, h, ORD(SeekEnd), size);
  1253.        stSize := size;
  1254.  
  1255.        void := Fseek(0, h, ORD(SeekSet), size);
  1256.        void := Fread(h, 2, ADR(magic), lres);
  1257.        IF (lres = LIC(2)) AND ((magic = 601AH) OR (magic = 2321H))(* #! *) THEN
  1258.          stMode := sIFREG + STDPERM + modeT{sIXUSR, sIXGRP, sIXOTH};
  1259.        ELSE
  1260.          stMode := sIFREG + STDPERM;
  1261.        END;
  1262.        void := Fseek(pos, h, ORD(SeekSet), size);
  1263.      ELSE
  1264.        e.errno := e.EBADF;
  1265.        RETURN(-1);
  1266.      END;
  1267.    END;
  1268.  
  1269.    DecodeDate(tc.date, tc.time, date);
  1270.    stMtime   := DateToSeconds(date);
  1271.    stAtime   := stMtime;
  1272.    stCtime   := stMtime;
  1273.    stUid     := 0;
  1274.    stGid     := 0;
  1275.    stDev     := VAL(devT,Dgetdrv());
  1276.    stRdev    := 0;
  1277.    stNlink   := 1;
  1278.    stBlksize := BLKSIZE;
  1279.    stBlocks  := (CAST(UNSIGNEDLONG,stSize) + VAL(UNSIGNEDLONG,BLKSIZE - 1))
  1280.                 DIV VAL(UNSIGNEDLONG,512);
  1281.    stIno     := VAL(inoT,INODE); INC(INODE);
  1282.  END; (* WITH *)
  1283.  RETURN(0);
  1284. END fstat;
  1285.  
  1286. (*--------------------------------------------------------------------------*)
  1287.  
  1288. PROCEDURE sISCHR ((* EIN/ -- *) stMode : modeT ): BOOLEAN;
  1289. BEGIN
  1290.  RETURN(stMode * sIFMT = sIFCHR);
  1291. END sISCHR;
  1292.  
  1293. (*--------------------------------------------------------------------------*)
  1294.  
  1295. PROCEDURE sISDIR ((* EIN/ -- *) stMode : modeT ): BOOLEAN;
  1296. BEGIN
  1297.  RETURN(stMode * sIFMT = sIFDIR);
  1298. END sISDIR;
  1299.  
  1300. (*--------------------------------------------------------------------------*)
  1301.  
  1302. PROCEDURE sISBLK ((* EIN/ -- *) stMode : modeT ): BOOLEAN;
  1303. BEGIN
  1304.  RETURN(stMode * sIFMT = sIFBLK);
  1305. END sISBLK;
  1306.  
  1307. (*--------------------------------------------------------------------------*)
  1308.  
  1309. PROCEDURE sISREG ((* EIN/ -- *) stMode : modeT ): BOOLEAN;
  1310. BEGIN
  1311.  RETURN(stMode * sIFMT = sIFREG);
  1312. END sISREG;
  1313.  
  1314. (*--------------------------------------------------------------------------*)
  1315.  
  1316. PROCEDURE sISFIFO ((* EIN/ -- *) stMode : modeT ): BOOLEAN;
  1317. BEGIN
  1318.  RETURN(stMode * sIFMT = sIFIFO);
  1319. END sISFIFO;
  1320.  
  1321. (*--------------------------------------------------------------------------*)
  1322.  
  1323. PROCEDURE sISLNK ((* EIN/ -- *) stMode : modeT ): BOOLEAN;
  1324. BEGIN
  1325.  RETURN(stMode * sIFMT = sIFLNK);
  1326. END sISLNK;
  1327.  
  1328. (*--------------------------------------------------------------------------*)
  1329.  
  1330. PROCEDURE access ((* EIN/ -- *) REF file : ARRAY OF CHAR;
  1331.                   (* EIN/ -- *)     acc  : AccessMode    ): int;
  1332.  
  1333. VAR dta : DTA;
  1334.     st  : StatRec;
  1335.     uid : INTEGER;
  1336.  
  1337. BEGIN
  1338.  IF istat(file, st, FALSE) < 0 THEN
  1339.    RETURN(-1);
  1340.  ELSIF acc = fOK THEN
  1341.    RETURN(0);
  1342.  END;
  1343.  
  1344.  uid := Pgetuid();
  1345.  IF (uid < 0) OR (uid = INT(st.stUid)) THEN
  1346.    IF acc <= CAST(AccessMode,VAL(UNSIGNEDWORD,
  1347.                CAST(UNSIGNEDWORD,st.stMode * sIRWXU) DIV 64))
  1348.    THEN
  1349.      RETURN(0);
  1350.    ELSE
  1351.      e.errno := e.EACCES;
  1352.      RETURN(-1);
  1353.    END;
  1354.  END;
  1355.  
  1356.  IF Pgetgid() = INT(st.stGid) THEN
  1357.    IF acc <= CAST(AccessMode,VAL(UNSIGNEDWORD,
  1358.                CAST(UNSIGNEDWORD,st.stMode * sIRWXG) DIV 8))
  1359.    THEN
  1360.      RETURN(0);
  1361.    ELSE
  1362.      e.errno := e.EACCES;
  1363.      RETURN(-1);
  1364.    END;
  1365.  END;
  1366.  
  1367.  IF acc <= CAST(AccessMode,st.stMode * sIRWXO) THEN
  1368.    RETURN(0);
  1369.  ELSE
  1370.    e.errno := e.EACCES;
  1371.    RETURN(-1);
  1372.  END;
  1373. END access;
  1374.  
  1375. (*==========================================================================*)
  1376.  
  1377. VAR
  1378.   i   : CARDINAL;
  1379.   res : SIGNEDLONG;
  1380.  
  1381. BEGIN (* file *)
  1382.  FOR i := 0 TO LBLKSIZE - 1 DO
  1383.    zerofill[i] := 0;
  1384.  END;
  1385.  hasFcntl   := FcntlAvail();
  1386.  DOSVersion := DosVersion();
  1387.  MiNT       := MiNTVersion() > 0;
  1388.  res        := Pumask(0);
  1389.  IF res < VAL(SIGNEDLONG,0) THEN
  1390.    (* Aufruf wird nicht unterstuetzt *)
  1391.    UMASK := modeT{};
  1392.  ELSE
  1393.    UMASK := CAST(modeT,VAL(UNSIGNEDWORD,res));
  1394.    res   := Pumask(UMASK);
  1395.  END;
  1396. END file.
  1397.