home *** CD-ROM | disk | FTP | other *** search
/ Crawly Crypt Collection 1 / crawlyvol1.bin / program / compiler / m2posx14 / src / sys.ipp < prev    next >
Encoding:
Modula Implementation  |  1994-05-14  |  11.4 KB  |  446 lines
  1. IMPLEMENTATION MODULE sys;
  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. (* 14-Mai-94, Holger Kleinschmidt                                            *)
  17. (*****************************************************************************)
  18.  
  19. VAL_INTRINSIC
  20. CAST_IMPORT
  21.  
  22. FROM SYSTEM IMPORT
  23. (* TYPE *) ADDRESS,
  24. (* PROC *) ADR;
  25. #ifdef MM2
  26. FROM SYSTEM IMPORT CADR;
  27. #endif
  28.  
  29. FROM PORTAB IMPORT
  30. (* CONST*) NULL,
  31. (* TYPE *) SIGNEDWORD, UNSIGNEDWORD, SIGNEDLONG, WORDSET;
  32.  
  33. FROM MEMBLK IMPORT
  34. (* PROC *) memalloc, memdealloc;
  35.  
  36. FROM ctype IMPORT
  37. (* PROC *) todigit, isgraph;
  38.  
  39. FROM cstr IMPORT
  40. (* PROC *) strncpy;
  41.  
  42. FROM types IMPORT
  43. (* CONST*) ClkTck, EOS,
  44. (* TYPE *) int, long, StrPtr, StrRange, PathName, sizeT, timeT, TimeCast;
  45.  
  46. FROM OSCALLS IMPORT
  47. (* PROC *) Dpathconf, Dcntl, Dfree, Sysconf, Tgettime, Tgetdate, Tsetdate,
  48.            Tsettime, Fopen, Fread, Fclose, Sversion;
  49.  
  50. IMPORT e;
  51.  
  52. FROM pSTRING IMPORT
  53. (* PROC *) SLEN;
  54.  
  55. FROM cmdline IMPORT
  56. (* PROC *) GetEnvVar;
  57.  
  58. FROM DosSystem IMPORT
  59. (* TYPE *) CPUType, MachineType, OsPtr, OsHeader,
  60. (* PROC *) CPU, Machine, GetOsHeader, SysconfAvail, DpathconfAvail,
  61.            MiNTVersion, MagiXVersion;
  62.  
  63. FROM DosSupport IMPORT
  64. (* CONST*) DINCR,
  65. (* TYPE *) DosDate,
  66. (* VAR  *) ROOTDIR,
  67. (* PROC *) UnixToDos, DecodeDate, EncodeDate, DateToSeconds, SecondsToDate;
  68.  
  69. FROM file IMPORT
  70. (* TYPE *) StatRec,
  71. (* PROC *) stat;
  72.  
  73. FROM tim IMPORT
  74. (* TYPE *) TmRec, TmPtr,
  75. (* PROC *) strftime;
  76.  
  77. (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
  78.  
  79. VAR
  80.   hasDpathconf : BOOLEAN;
  81.   hasSysconf   : BOOLEAN;
  82.  
  83. (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
  84.  
  85. PROCEDURE gethostname ((* EIN/ -- *) buf  : StrPtr;
  86.                        (* EIN/ -- *) blen : sizeT  ): int;
  87.  
  88. VAR tmp  : ARRAY [0..MAXHOSTNAMELEN-1] OF CHAR;
  89.     hd   : INTEGER;
  90.     idx  : UNSIGNEDWORD;
  91.     len  : SIGNEDLONG;
  92.     void : BOOLEAN;
  93.  
  94. BEGIN
  95.  IF NOT GetEnvVar("HOSTNAME", tmp) THEN
  96.    IF ROOTDIR <> 0C THEN
  97.      tmp    := "@:\etc\hostname";
  98.      tmp[0] := ROOTDIR;
  99.    ELSE
  100.      tmp := "\etc\hostname";
  101.    END;
  102.    IF Fopen(ADR(tmp), 0, hd) THEN
  103.      tmp := "";
  104.      IF Fread(hd, MAXHOSTNAMELEN, ADR(tmp), len) THEN
  105.        idx := 0;
  106.        WHILE (idx < VAL(UNSIGNEDWORD,len)) AND isgraph(tmp[idx]) DO
  107.          INC(idx);
  108.        END;
  109.        IF idx < MAXHOSTNAMELEN THEN
  110.          tmp[idx] := EOS;
  111.        END;
  112.      END;
  113.      void := Fclose(hd, hd);
  114.    ELSE
  115.      tmp := "";
  116.    END;
  117.    IF tmp[0] = EOS THEN
  118.      tmp := "?";
  119.    END;
  120.  END;
  121.  strncpy(buf, ADR(tmp), blen);
  122.  RETURN(0);
  123. END gethostname;
  124.  
  125. (*---------------------------------------------------------------------------*)
  126.  
  127. PROCEDURE uname ((* --/AUS *) VAR info : UtsnameRec ): int;
  128.  
  129. VAR void  : INTEGER;
  130.     MiNT  : CARDINAL;
  131.     MagiX : CARDINAL;
  132.     date  : DosDate;
  133.     time  : TmRec;
  134.     osP   : OsPtr;
  135.     idx   : UNSIGNEDWORD;
  136.     fmt   : ARRAY [0..2] OF CHAR;
  137.  
  138. PROCEDURE putvers ((* EIN/ -- *)     ver  : CARDINAL;
  139.                    (* EIN/ -- *)     base : CARDINAL;
  140.                    (* EIN/ -- *)     lohi : BOOLEAN;
  141.                    (* EIN/ -- *) VAR idx  : UNSIGNEDWORD );
  142.  
  143. VAR __REG__ high : CARDINAL;
  144.     __REG__ low  : CARDINAL;
  145.     __REG__ i    : UNSIGNEDWORD;
  146.  
  147. BEGIN
  148.  WITH info DO
  149.    i    := idx;
  150.    IF lohi THEN
  151.      low  := ver DIV 256;
  152.      high := ver MOD 256;
  153.    ELSE
  154.      high := ver DIV 256;
  155.      low  := ver MOD 256;
  156.    END;
  157.    IF high >= base THEN
  158.      version[i] := todigit(high DIV base); INC(i);
  159.    END;
  160.    version[i] := todigit(high MOD base); INC(i);
  161.    version[i] := '.'; INC(i);
  162.    version[i] := todigit(low DIV base); INC(i);
  163.    version[i] := todigit(low MOD base); INC(i);
  164.    idx := i;
  165.  END;
  166. END putvers;
  167.  
  168. BEGIN
  169.  fmt   := "%x"; (* Lokales Datumsformat *)
  170.  MiNT  := MiNTVersion();
  171.  MagiX := MagiXVersion();
  172.  GetOsHeader(osP);
  173.  DecodeDate(osP^.osDosdate, WORDSET{}, date);
  174.  WITH time DO WITH date DO
  175.    tmMDay := day;
  176.    tmMon  := mon;
  177.    tmYear := year - 1900;
  178.  END; END;
  179.  
  180.  WITH info DO
  181.    void := gethostname(ADR(nodename), MAXHOSTNAMELEN);
  182.    void := INT(strftime(ADR(release), 20, ADR(fmt), ADR(time)));
  183.  
  184.    idx := 0;
  185.    putvers(VAL(CARDINAL,osP^.osVersion), 16, FALSE, idx);
  186.    IF MagiX > 0 THEN
  187.      version[idx] := '/'; INC(idx);
  188.      putvers(MagiX, 16, FALSE, idx);
  189.      sysname := "Mag!X";
  190.    ELSIF MiNT > 0 THEN
  191.      version[idx] := '/'; INC(idx);
  192.      putvers(MiNT, 10, FALSE, idx);
  193.      sysname := "TOS/MiNT";
  194.    ELSE
  195.      version[idx] := '/'; INC(idx);
  196.      putvers(Sversion(), 16, TRUE, idx);
  197.      sysname := "TOS/GEMDOS";
  198.    END;
  199.    version[idx] := 0C;
  200.  
  201.    CASE Machine() OF
  202.      atariST   : machine := "Atari ST";
  203.     |atariSTE  : machine := "Atari STE";
  204.     |atariTT   : machine := "Atari TT030";
  205.     |atariF030 : machine := "Atari Falcon030";
  206.     |atariMSTE : machine := "Atari MEGA/STE";
  207.    ELSE
  208.                  machine := "Atari";
  209.    END;
  210.  END; (* WITH *)
  211.  RETURN(0);
  212. END uname;
  213.  
  214. (*---------------------------------------------------------------------------*)
  215.  
  216. PROCEDURE pathconf ((* EIN/ -- *) REF file  : ARRAY OF CHAR;
  217.                     (* EIN/ -- *)     which : PConfVal      ): long;
  218.  
  219. VAR dot   : BOOLEAN;
  220.     done  : BOOLEAN;
  221.     limit : SIGNEDLONG;
  222.     stack : ADDRESS;
  223.     msize : CARDINAL;
  224.     path0 : StrPtr;
  225.  
  226. BEGIN
  227.  IF hasDpathconf THEN
  228.    msize := SLEN(file) + DINCR;
  229.    memalloc(VAL(sizeT,msize), stack, path0);
  230.    UnixToDos(CAST(StrPtr,REFADR(file)), msize - DINCR, VAL(StrRange,msize),
  231.              path0, dot, done);
  232.    IF NOT done THEN
  233.      memdealloc(stack);
  234.      RETURN(-1);
  235.    END;
  236.    CASE which OF
  237.      pcMaxCanon : limit := -1; (* ?? *)
  238.     |pcMaxInput : limit := -1; (* ?? *)
  239.     |pcChownRestricted: limit := 0; (* ja *)
  240.     |pcVdisable : limit := 0;
  241.    ELSE
  242.      IF NOT Dpathconf(path0, INT(which)+1, limit) THEN
  243.        e.errno := INT(limit);
  244.        limit   := -1;
  245.      ELSIF which = pcNoTrunc THEN
  246.        IF limit > LIC(0) THEN
  247.          limit := -1; (* <=> Dateinamen werden gekuerzt *)
  248.        ELSE
  249.          limit := 0;
  250.        END;
  251.      END;
  252.    END;
  253.    memdealloc(stack);
  254.    RETURN(limit);
  255.  ELSE (* NOT hasDpathconf *)
  256.    CASE which OF
  257.      pcLinkMax  : RETURN(1);
  258.     |pcPathMax  : RETURN(128);
  259.     |pcNameMax  : RETURN(12);
  260.     |pcNoTrunc  : RETURN(-1); (* -1 <=> es wird gekuerzt *)
  261.     |pcVdisable : RETURN(0);
  262.     |pcMaxInput : RETURN(-1); (* ? *)
  263.     |pcMaxCanon : RETURN(-1); (* ? *)
  264.    ELSE (* pcPipeBuf, pcChownRestricted... *)
  265.      e.errno := e.EINVAL;
  266.      RETURN(-1);
  267.    END;
  268.  END;
  269. END pathconf;
  270.  
  271. (*---------------------------------------------------------------------------*)
  272.  
  273. PROCEDURE sysconf ((* EIN/ -- *) which : SConfVal ): long;
  274.  
  275. VAR limit : SIGNEDLONG;
  276.  
  277. BEGIN
  278.  IF which = scVersion THEN
  279.    e.errno := e.EINVAL;
  280.    RETURN(-1);
  281.  END;
  282.  IF hasSysconf THEN
  283.    CASE which OF
  284.      scArgMax     : RETURN(UNLIMITED); (* wegen "ARGV" *)
  285.     |scClkTck     : RETURN(ClkTck);
  286.     |scJobControl : RETURN(1);  (* ja *)
  287.     |scSavedIds   : RETURN(-1); (* nein ?? *)
  288.    ELSE
  289.      IF Sysconf(INT(which)+1, limit) THEN
  290.        RETURN(limit);
  291.      ELSE
  292.        e.errno := INT(limit);
  293.        RETURN(-1);
  294.      END;
  295.    END;
  296.  ELSE
  297.    CASE which OF
  298.      scArgMax     : RETURN(UNLIMITED); (* wegen "ARGV" *)
  299.     |scOpenMax    : RETURN(81);        (* max. Kennung = 80 *)
  300.     |scNGroupsMax : RETURN(0);
  301.     |scChildMax   : RETURN(UNLIMITED);
  302.     |scClkTck     : RETURN(ClkTck);
  303.     |scJobControl : RETURN(-1); (* kein ``Job Control'' *)
  304.     |scSavedIds   : RETURN(-1); (* aber kein Fehler ! *)
  305.    ELSE
  306.      e.errno := e.EINVAL;
  307.      RETURN(-1);
  308.    END;
  309.  END;
  310. END sysconf;
  311.  
  312. (*---------------------------------------------------------------------------*)
  313.  
  314. PROCEDURE statfs ((* EIN/ -- *) REF path : ARRAY OF CHAR;
  315.                   (* -- /AUS *) VAR buf  : StatfsRec     ): int;
  316. (*T*)
  317. CONST MFSINFO  = 0104H;
  318.       MFSBSIZE = 1024;
  319.  
  320. VAR dot   : BOOLEAN;
  321.     done  : BOOLEAN;
  322.     stack : ADDRESS;
  323.     msize : CARDINAL;
  324.     res   : INTEGER;
  325.     lres  : SIGNEDLONG;
  326.     path0 : StrPtr;
  327.     st    : StatRec;
  328.     mfsinfo : RECORD
  329.       ninodes   : SIGNEDLONG; (* I-Nodes insgesamt *)
  330.       nzones    : SIGNEDLONG; (* Bloecke insgesamt *)
  331.       finodes   : SIGNEDLONG; (* freie I-Nodes *)
  332.       fzones    : SIGNEDLONG; (* freie Bloecke *)
  333.       version   : SIGNEDWORD; (* Typ des Dateisystems *)
  334.       increment : SIGNEDWORD; (* -> max. Laenge von Dateinamen *)
  335.       res       : ARRAY [0..3] OF SIGNEDLONG;
  336.     END;
  337.     diskinfo : RECORD
  338.       bFree   : SIGNEDLONG; (* freie Bloecke *)
  339.       bTotal  : SIGNEDLONG; (* Bloecke insgesamt *)
  340.       bSecsiz : SIGNEDLONG; (* Sektorgroesse in Bytes *)
  341.       bClsiz  : SIGNEDLONG; (* Blockgroesse in Sektoren *)
  342.     END;
  343.  
  344. BEGIN
  345.  IF stat(path, st) < 0 THEN
  346.    RETURN(-1);
  347.  END;
  348.  msize := SLEN(path) + DINCR;
  349.  memalloc(VAL(sizeT,msize), stack, path0);
  350.  UnixToDos(CAST(StrPtr,REFADR(path)), msize - DINCR, VAL(StrRange,msize),
  351.            path0, dot, done);
  352.  IF NOT done THEN
  353.    memdealloc(stack);
  354.    RETURN(-1);
  355.  END;
  356.  
  357.  IF Dcntl(MFSINFO, path0, ADR(mfsinfo), lres) THEN
  358.    WITH buf DO WITH mfsinfo DO
  359.      fType        := 0;
  360.      fFsid.val[0] := VAL(SIGNEDLONG,version);
  361.      fFsid.val[1] := 0;
  362.      fBsize       := MFSBSIZE;
  363.      fBlocks      := nzones;
  364.      fBfree       := fzones;
  365.      fBavail      := fzones;
  366.      fFiles       := ninodes;
  367.      fFfree       := finodes;
  368.    END; END;
  369.    memdealloc(stack);
  370.    RETURN(0);
  371.  END;
  372.  
  373.  IF NOT Dfree(ADR(diskinfo), VAL(CARDINAL,st.stDev + 1), res) THEN
  374.    memdealloc(stack);
  375.    e.errno := res;
  376.    RETURN(-1);
  377.  END;
  378.  
  379.  WITH buf DO WITH diskinfo DO
  380.    fType        := 0;
  381.    fFsid.val[0] := 0;
  382.    fFsid.val[1] := 0;
  383.    fBsize       := bSecsiz * bClsiz;
  384.    fBlocks      := bTotal;
  385.    fBfree       := bFree;
  386.    fBavail      := bFree;
  387.    fFiles       := -1;
  388.    fFfree       := -1;
  389.  END; END;
  390.  
  391.  memdealloc(stack);
  392.  RETURN(0);
  393. END statfs;
  394.  
  395. (*---------------------------------------------------------------------------*)
  396.  
  397. PROCEDURE time ((* EIN/ -- *) buf : ADDRESS ): timeT;
  398.  
  399. TYPE timeTP = POINTER TO timeT;
  400.  
  401. VAR timep : timeTP;
  402.     time  : timeT;
  403.     date  : DosDate;
  404.  
  405. BEGIN
  406.  DecodeDate(Tgetdate(), Tgettime(), date);
  407.  time := DateToSeconds(date);
  408.  IF buf <> NULL THEN
  409.    timep  := CAST(timeTP,buf);
  410.    timep^ := time;
  411.  END;
  412.  RETURN(time);
  413. END time;
  414.  
  415. (*---------------------------------------------------------------------------*)
  416.  
  417. PROCEDURE stime ((* EIN/ -- *) time : timeT ): int;
  418. (**)
  419. VAR date : DosDate;
  420.     tc   : TimeCast;
  421.     res  : INTEGER;
  422.  
  423. BEGIN
  424.  IF time < VAL(timeT,0) THEN
  425.    e.errno := e.EINVAL;
  426.    RETURN(-1);
  427.  END;
  428.  SecondsToDate(time, date);
  429.  DecodeDate(tc.date, tc.time, date);
  430.  IF Tsetdate(tc.date, res) AND Tsettime(tc.time, res) THEN
  431.    RETURN(0);
  432.  END;
  433.  IF res <> e.eACCDN THEN
  434.    res := e.EINVAL;
  435.  END;
  436.  e.errno := res;
  437.  RETURN(-1);
  438. END stime;
  439.  
  440. (*===========================================================================*)
  441.  
  442. BEGIN (* sys *)
  443.  hasDpathconf := DpathconfAvail();
  444.  hasSysconf   := SysconfAvail();
  445. END sys.
  446.