home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / turbo4 / dos_50.pas < prev    next >
Pascal/Delphi Source File  |  1989-08-15  |  11KB  |  382 lines
  1. (*--------------------------------------------------------*)
  2. (*                       DOS_50.PAS                       *)
  3. (*   Die zusätzlichen Routinen der Turbo 5.0 - Unit DOS   *)
  4. (*                  für die Version 4.0 .                 *)
  5. (*           (c) 1989 Roland Geier & TOOLBOX              *)
  6. (*--------------------------------------------------------*)
  7. {$B-,D-,R-,S-,V-}
  8. UNIT DOS_50;
  9.  
  10. INTERFACE
  11.  
  12. USES Dos;                            { Turbo 4.0 DOS-Unit }
  13.  
  14. TYPE
  15.   PathStr = STRING[79];        { zusätzliche String-Typen }
  16.   DirStr  = STRING[67];
  17.   NameStr = STRING[8];
  18.   ExtStr  = STRING[4];
  19.  
  20.   PROCEDURE SwapVectors;
  21.   { vertauscht die von System belegten Interrupt-Vektoren  }
  22.   { mit den entsprechenden Variablen des Units System.     }
  23.  
  24.   FUNCTION  DOSVersion : WORD;
  25.   { übergibt im Lo-Byte die Hauptversionsnummer, im Hi-    }
  26.   { Byte die Unterversionsnummer der DOS-Version.          }
  27.  
  28.   PROCEDURE GetVerify(VAR verify : BOOLEAN);
  29.   { ermittelt, ob das DOS-Verify-Flag gesetzt ist.         }
  30.  
  31.   PROCEDURE SetVerify(verify : BOOLEAN);
  32.   { setzt (Verify=True) bzw. löscht (Verify = False) das   }
  33.   { DOS-Verify-Flag.                                       }
  34.  
  35.   PROCEDURE GetCBreak(VAR break : BOOLEAN);
  36.   { ermittelt, bei welchen Operationen DOS auf CTRL-Break  }
  37.   { prüft:                                                 }
  38.   {       Break = True : bei jedem Funktionsaufruf         }
  39.   {       Break = False: nur bei Ein-/Ausgaben über Tasta- }
  40.   {                      tur, Drucker, serielle Schnitt-   }
  41.   {                      stelle und Bildschirm             }
  42.  
  43.   PROCEDURE SetCBreak(break : BOOLEAN);
  44.   { setzt (Break=True) bzw. löscht (Break=False) das DOS-  }
  45.   { Breakflag.                                             }
  46.  
  47.   FUNCTION GetEnv(EnvStr : STRING) : STRING;
  48.   { liest einen Eintrag aus dem Environment.               }
  49.  
  50.   FUNCTION EnvCount : INTEGER;
  51.   { liefert die Anzahl der Environmenteinträge.            }
  52.  
  53.   FUNCTION EnvStr(index : INTEGER) : STRING;
  54.   { liefert den Environmenteintrag mit der Nummer Index    }
  55.   { als kompletten Eintrag zurück.                         }
  56.  
  57.   PROCEDURE FSplit(path : PathStr; VAR dir : DirStr;
  58.                    VAR Name : NameStr; VAR Ext : ExtStr);
  59.   { zerlegt einen vollständigen Dateinamen in die Kompo-   }
  60.   { nenten Suchweg, Name und Suffix.                       }
  61.  
  62.   FUNCTION FExpand(path : PathStr) : PathStr;
  63.   { erweitert einen unvollständig angegebenen Dateinamen   }
  64.   { um den dazugehörigen Suchweg.                          }
  65.  
  66.   FUNCTION FSearch(path : PathStr;
  67.                    DirList : STRING) : PathStr;
  68.   { sucht das aktuelle Directory und die Directoryliste    }
  69.   { DirList nach einem Dateinamen ab.                      }
  70.  
  71. IMPLEMENTATION
  72.  
  73. CONST
  74.   OddCall    : BOOLEAN = TRUE;
  75. VAR
  76.   Int00Save  : POINTER;
  77.   Int02Save  : POINTER;
  78.   Int23Save  : POINTER;
  79.   Int24Save  : POINTER;
  80.   Int75Save  : POINTER;
  81.  
  82.   PROCEDURE SwapVectors;
  83.   BEGIN
  84.     IF OddCall THEN BEGIN
  85.                           { n-facher Aufruf mit n ungerade }
  86.       GetIntVec($00, Int00Save);
  87.       SetIntVec($00, SaveInt00);
  88.       GetIntVec($02, Int02Save);
  89.       SetIntVec($02, SaveInt02);
  90.       GetIntVec($23, Int23Save);
  91.       SetIntVec($23, SaveInt23);
  92.       GetIntVec($24, Int24Save);
  93.       SetIntVec($24, SaveInt24);
  94.       GetIntVec($75, Int75Save);
  95.       SetIntVec($75, SaveInt75);
  96.     END ELSE BEGIN          { n-facher Aufruf mit n gerade }
  97.       SetIntVec($00, Int00Save);
  98.       SetIntVec($02, Int02Save);
  99.       SetIntVec($23, Int23Save);
  100.       SetIntVec($24, Int24Save);
  101.       SetIntVec($75, Int75Save);
  102.     END;
  103.     OddCall := NOT(OddCall);
  104.   END;
  105.  
  106.   FUNCTION DOSVersion : WORD;
  107.   VAR
  108.     Regs : Registers;
  109.   BEGIN
  110.     Regs.ah := $30;
  111.     MsDos(Regs);
  112.     DosVersion := Regs.ax;
  113.   END;
  114.  
  115.   PROCEDURE GetVerify(VAR verify : BOOLEAN);
  116.   VAR
  117.     Regs : Registers;
  118.   BEGIN
  119.     Regs.ah := $54;
  120.     MsDos(Regs);
  121.     IF Regs.al = 0 THEN verify := FALSE
  122.                    ELSE verify := TRUE;
  123.   END;
  124.  
  125.   PROCEDURE SetVerify(verify : BOOLEAN);
  126.   VAR
  127.     Regs: Registers;
  128.   BEGIN
  129.     Regs.ah := $2E;  Regs.dl := 0;
  130.     IF verify THEN Regs.al := 1
  131.               ELSE Regs.al := 0;
  132.     MsDos(Regs);
  133.   END;
  134.  
  135.   PROCEDURE GetCBreak(VAR break : BOOLEAN);
  136.   VAR
  137.     Regs : Registers;
  138.   BEGIN
  139.     Regs.ah := $33;  Regs.al := 0;
  140.     MsDos(Regs);
  141.     IF Regs.dl = 1 THEN break := TRUE
  142.                    ELSE break := FALSE;
  143.   END;
  144.  
  145.   PROCEDURE SetCBreak(break : BOOLEAN);
  146.   VAR
  147.     Regs : Registers;
  148.   BEGIN
  149.     Regs.ah := $33;  Regs.al := 1;
  150.     IF break THEN Regs.dl := 1
  151.              ELSE Regs.dl := 0;
  152.     MsDos(Regs);
  153.   END;
  154.  
  155.   Procedure UpString(Var St: String);
  156.   { Umwandlung eines Strings in Großbuchstaben             }
  157.   VAR
  158.     i : ShortInt;
  159.   BEGIN
  160.     FOR i := 1 TO Length(St) DO BEGIN
  161.       IF (St[i] = 'ä') OR (St[i] = 'ö') OR
  162.          (St[i] = 'ü') THEN BEGIN
  163.         CASE St[i] OF
  164.           'ä': St[i] := 'Ä';
  165.           'ö': St[i] := 'Ö';
  166.           'ü': St[i] := 'Ü';
  167.         END;
  168.       END ELSE
  169.         St[i] := UpCase(St[i]);
  170.     END;
  171.   END;
  172.  
  173.   FUNCTION GetEnv(EnvStr : STRING) : STRING;
  174.   VAR
  175.     Eintrag : STRING;
  176.     Equal   : BOOLEAN;
  177.     EnvCh   : CHAR;
  178.     i       : BYTE;
  179.   BEGIN
  180.     Equal := FALSE;  i := 0;
  181.     UpString(EnvStr);
  182.     REPEAT
  183.       Eintrag := UpCase
  184.                  (Chr(Mem[MemW[PrefixSeg:$002C]:$0000+i]));
  185.       WHILE UpCase
  186.             (Chr(Mem[MemW[PrefixSeg:$002C]:$0000+i])) <> #0
  187.             DO BEGIN
  188.         Inc(i);
  189.         Eintrag := Eintrag +
  190.         UpCase(Chr(Mem[MemW[PrefixSeg:$002C]:$0000+i]));
  191.       END;
  192.       Inc(i);
  193.       Equal := POS(EnvStr, Eintrag) = 1;
  194.     UNTIL Equal OR (UpCase
  195.           (Chr(Mem[MemW[PrefixSeg:$002C]:$0000+(i+1)]))=#0);
  196.     IF NOT(Equal) THEN
  197.       GetEnv := ''
  198.     ELSE BEGIN
  199.       Delete(Eintrag,1,Succ(Length(EnvStr)));
  200.                          { EnvStr+'='aus Eintrag entfernen }
  201.       GetEnv := Eintrag;
  202.     END;
  203.   END;
  204.  
  205.   FUNCTION EnvCount : INTEGER;
  206.   VAR
  207.     EnvCh : CHAR;
  208.     EnvNr : INTEGER;
  209.     i     : ShortInt;
  210.   BEGIN
  211.     EnvNr := 0;  i := 0;
  212.     REPEAT
  213.       EnvCh := Chr(Mem[MemW[PrefixSeg:$002C]:$0000+i]);
  214.       IF (EnvCh = #0) THEN Inc(EnvNr);
  215.       Inc(i);
  216.     UNTIL (EnvCh = #0) AND
  217.           (Chr(Mem[MemW[PrefixSeg:$002C]:$0000+i]) = #0);
  218.     EnvCount := EnvNr;
  219.   END;
  220.  
  221.   FUNCTION EnvStr(index : INTEGER) : STRING;
  222.   CONST
  223.     EnvAnz : INTEGER = 0;
  224.   VAR
  225.     EnvCh  : CHAR;
  226.     TmpStr : STRING;
  227.     i      : ShortInt;
  228.   BEGIN
  229.     EnvAnz := EnvCount;  TmpStr := '';  i := 0;
  230.     IF (index = 0) OR (index > EnvAnz) THEN
  231.       EnvStr := ''
  232.     ELSE BEGIN
  233.       EnvAnz := 0;
  234.       IF index > 1 THEN
  235.         REPEAT
  236.           EnvCh := Chr(Mem[MemW[PrefixSeg:$002C]:$0000+i]);
  237.           IF EnvCh = #0 THEN Inc(EnvAnz);
  238.           Inc(i);
  239.         UNTIL EnvAnz = Pred(index);
  240.       REPEAT
  241.         TmpStr := TmpStr +
  242.                Chr(Mem[MemW[PrefixSeg:$002C]:$0000+i]);
  243.         Inc(i);
  244.       UNTIL Chr(Mem[MemW[PrefixSeg:$002C]:$0000+i]) = #0;
  245.       EnvStr := TmpStr;
  246.     END;
  247.   END;
  248.  
  249.   PROCEDURE FSplit(path : PathStr;  VAR dir : DirStr;
  250.                    VAR name : NameStr; VAR ext: ExtStr );
  251.   VAR
  252.     pl, i, k, Marker    : ShortInt;
  253.     WorkPath            : PathStr ;
  254.     DCh                 : CHAR;
  255.     CpyNr               : INTEGER;
  256.     ExtFound, NameFound : BOOLEAN;
  257.   BEGIN
  258.     i := 8;  k := 1;
  259.     ExtFound := FALSE;  NameFound := FALSE;
  260.     IF Length(Path) = 0 THEN BEGIN
  261.       Dir := '';  Name := '';  Ext := '';
  262.     END ELSE BEGIN
  263.       WorkPath := Path; pl := Length(WorkPath);
  264.       Marker := pl;
  265.       REPEAT
  266.         DCh := WorkPath[pl];
  267.         IF (DCh = '.') AND NOT(ExtFound) AND
  268.        (WorkPath[Pred(pl)] <> '.') THEN BEGIN
  269.         Ext := Copy(WorkPath, pl, 4);
  270.           Delete(WorkPath, pl, Succ(Marker-pl));
  271.           ExtFound := TRUE;
  272.         END;
  273.         Dec(pl);
  274.       UNTIL ExtFound OR (pl = 0);
  275.       pl := Length(WorkPath);
  276.       IF WorkPath[pl] = '\' THEN
  277.         name := ''
  278.       ELSE
  279.         REPEAT
  280.           DCh := WorkPath[pl];
  281.           IF (DCh = '\') OR (Pred(pl) = 0) THEN BEGIN
  282.             CpyNr := Length(WorkPath) - pl + 1;
  283.             IF CpyNr > 8 THEN CpyNr := 8;
  284.             IF DCh = '\' THEN Inc(pl);
  285.             Name := Copy(WorkPath, pl, CpyNr);
  286.             NameFound := TRUE;
  287.             Delete(WorkPath, pl, Marker-pl);
  288.           END;
  289.           Dec(pl);
  290.         UNTIL NameFound OR (pl = 0);
  291.       IF NOT(NameFound) THEN Name := '';
  292.       Dir := WorkPath;
  293.     END;
  294.   END;
  295.  
  296.   FUNCTION FExpand(Path : PathStr) : PathStr;
  297.   VAR
  298.     CurrentDir : DirStr;
  299.     WorkStr    : DirStr;
  300.     DirSt      : DirStr;
  301.     NameSt     : NameStr;
  302.     ExtSt      : ExtStr;
  303.     pl         : ShortInt;
  304.   BEGIN
  305.     IF Length(Path) > 0 THEN BEGIN
  306.       UpString(Path);
  307.       {$I-} GetDir(0, CurrentDir); {$I-}
  308.       IF IOResult = 0 THEN CurrentDir := CurrentDir + '\';
  309.       IF IOResult > 0 THEN Exit;
  310.       IF (Pos('\', Path) = 0) AND (Path[2] <> ':') THEN
  311.         FExpand := CurrentDir + Path
  312.       ELSE BEGIN
  313.         FSplit(Path, DirSt, NameSt, ExtSt);
  314.         WorkStr := DirSt;  pl := Length(WorkStr);
  315.         IF WorkStr = CurrentDir THEN
  316.           FExpand := Path
  317.         ELSE BEGIN
  318.           IF Pos(':', WorkStr) <> 2 THEN
  319.             WorkStr := CurrentDir + WorkStr;
  320.             IF Pos('\..\', WorkStr) > 0 THEN
  321.               REPEAT
  322.               pl := Pos('\..\', WorkStr);
  323.             Delete(WorkStr, pl, 3);
  324.             IF pl > 3 THEN { Bei <Laufwerk>:\..\ nicht }
  325.                   REPEAT
  326.                     Delete(WorkStr, pl, 1);  Dec(pl);
  327.                   UNTIL (WorkStr[pl] = '\') OR
  328.                  ((Length(WorkStr)=2) AND (WorkStr[2]=':'));
  329.               UNTIL Pos('\..\', WorkStr) = 0;
  330.           IF Pos('\.\', WorkStr) > 0 THEN
  331.             REPEAT
  332.               pl := Pos('\.\', WorkStr);
  333.               Delete(WorkStr, pl, 2);
  334.             UNTIL Pos('\.\', WorkStr) = 0;
  335.           FExpand := WorkStr + NameSt + ExtSt;
  336.         END;
  337.       END;
  338.     END;
  339.   END;
  340.  
  341.   FUNCTION FSearch(path : PathStr;
  342.                    DirList : STRING) : PathStr;
  343.   VAR
  344.     CurrentDir : DirStr;
  345.     SearchDir  : DirStr;
  346.     pl         : ShortInt;
  347.     SR         : SearchRec;
  348.   BEGIN
  349.     FindFirst(Path, Archive, SR);
  350.     IF DOSError = 0 THEN
  351.       FSearch := Path
  352.     ELSE BEGIN
  353.       IF Length(DirList) = 0 THEN
  354.         FSearch := ''
  355.       ELSE BEGIN
  356.         REPEAT
  357.       pl := 0;  SearchDir := '';
  358.       REPEAT
  359.         Inc(pl);  SearchDir := SearchDir + DirList[pl];
  360.       UNTIL (DirList[pl] = ';') OR
  361.                 (pl >= Length(DirList));
  362.         IF SearchDir[pl] = ';' THEN
  363.             Delete(SearchDir, pl, 1);
  364.       IF SearchDir[Length(SearchDir)] <> '\' THEN
  365.         SearchDir := SearchDir + '\';
  366.       FindFirst(SearchDir + Path, Archive, SR);
  367.       IF DOSError = 0 THEN BEGIN
  368.         FSearch := SearchDir + Path;  Exit;
  369.       END;
  370.       Delete(DirList, 1, Succ(Length(SearchDir)));
  371.         UNTIL Length(DirList) = 0;
  372.         FSearch := '';
  373.       END;
  374.     END;
  375.   END;
  376.  
  377. END.
  378. (* ------------------------------------------------------ *)
  379. (*                Ende von DOS_50.PAS                     *)
  380.  
  381.  
  382.