home *** CD-ROM | disk | FTP | other *** search
/ TopWare Tools / TOOLS.iso / tools / top1014 / gepackt.exe / PD / T2EPD.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1993-07-09  |  14.0 KB  |  423 lines
  1. PROGRAM txt2exe_Uebersetzer;
  2. {
  3.   Dies ist der Turbo-Pascal-Quelltext zu einer einfachen Version von
  4.   TXT2EXE. Benötigt wird TP6.0 oder TP7.0/BP7.0
  5.  
  6.   * Beliebige Textlänge (max 2 GigaByte // maxLongInt )
  7.   * max. 80 Z. / Zeile   (sorry)
  8.   * keine Maus           ( ""  )
  9.   * keine Überschrift    ( ""  )
  10.   * keine Stichwortlite  ( ""  )
  11.     ....                 ( ""  )
  12.  
  13.  Autor : P.Fischer-Haaser
  14.          Mozartstr. 10
  15.          74072 Heilbronn
  16.          Tel.: 07131/81947
  17.          Fax: 07131/962843
  18. }
  19.  
  20. {$DEFINE FalscherCompiler}
  21.  
  22. {$IFNDEF Ver60}
  23.    {$ifdef Ver70}   
  24.      {$undef FalscherCompiler}
  25.    {$EndIF}
  26. {$else}
  27.      {$undef FalscherCompiler}
  28. {$Endif}
  29.  
  30. {$ifdef FalscherCompiler}
  31.   BEGIN
  32.     WriteLn('Turbo Pascal Version 6.0 / 7.0 besorgen');
  33.  
  34. {$else}
  35.   {$Ifdef Ver60}    
  36.  
  37.   {$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,R-,S-,V-,X+}
  38.   {$M 8192,0,64000}
  39.  
  40.   {$else}
  41.  
  42.   {$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,P-,R-,S-,V-,X+,Y-}
  43.   {$M 8192,0,64000}
  44.  
  45. { ACHTUNG: wenn Programm als DPMI-Anwendung sind einige Änderungen notwendig... }
  46.  
  47.   {$endif}
  48.  
  49.   USES crt,dos;
  50.  
  51. (***************************************************************************)
  52.  
  53.   CONST
  54.     MAGIC = 3727;                                   { Länge von T2BR.EXE }
  55.     TmpFile = '~TXT2EXE.$$1';
  56.     TmpLong = '~TXT2EXE.$$2';
  57.     Browser = 'T2BR.EXE';
  58.     t2e : STRING[4] = 'T2E ';
  59.     Version :STRING[32] = '(2.01) PD Version (incl. Source)';
  60.     Zeilen : LongInt = 0;
  61.     TabOffset : LongInt = 0;
  62.  
  63. (***************************************************************************)
  64.  
  65.   TYPE
  66.     PuffTyp = ARRAY[0..8192] OF Byte;
  67.     PuffPtr = ^PuffTyp;
  68.  
  69. (***************************************************************************)
  70.  
  71.   VAR
  72.     geLesen, geSchrieben : Word;
  73.     TxtPuffer : PuffPtr;
  74.     Puffer : PuffPtr;
  75.     prgdir,prgname,prgext : STRING;
  76.  
  77. (***************************************************************************)
  78.  
  79.     FUNCTION HeapFunc(size : word) : Integer; FAR;  
  80.      { getmem liefert NIL-Ptr wenn zu wenig Speicher da }
  81.     BEGIN
  82.       HeapFunc := 1
  83.     END;
  84.  
  85. (***************************************************************************)
  86.  
  87.     PROCEDURE addch(VAR S : STRING; c : Char);
  88.      { sehr schnelles S :=S + c }
  89.     VAR
  90.       L : Byte ABSOLUTE S;
  91.     BEGIN
  92.       IF L = 255 THEN Exit;
  93.       Inc(L);
  94.       S[L] := c
  95.     END;                                           { addch }
  96.  
  97. (***************************************************************************)
  98.     
  99.     PROCEDURE AddStr(VAR S1, s2 : STRING);
  100.      { sehr schnelles S1 := S1 + s2 }
  101.     VAR
  102.       L1 : Byte ABSOLUTE S1;
  103.       L2 : Byte ABSOLUTE s2;
  104.       i : Byte;
  105.     BEGIN
  106.       FOR i := 1 TO L2 DO
  107.         BEGIN
  108.           Inc(L1);
  109.           S1[L1] := s2[i]
  110.         END
  111.     END;                                          { addstr }
  112.     
  113. (***************************************************************************)
  114.  
  115.     FUNCTION UpString(s:STRING) : STRING;
  116.      {  Ersatz für :
  117.         for i := 1 to length(S) do 
  118.            s[i] := upcase(s[i]) }
  119.     VAR
  120.       L : Byte ABSOLUTE S;
  121.       i : Byte;
  122.       tmpS : STRING;
  123.     BEGIN
  124.       tmpS := '';
  125.       FOR i := 1 TO L DO
  126.         addch(tmpS,UpCase(s[i]));
  127.       UpString := tmpS
  128.     END;
  129.  
  130. (***************************************************************************)
  131.  
  132.     FUNCTION Replicate(nr : Byte; ch : Char) : STRING;
  133.      { Replicate := String aus 'nr' mal 'ch' }
  134.     VAR
  135.       i : Byte;
  136.       tmp : STRING;
  137.     BEGIN
  138.       tmp := '';
  139.       FOR i := 1 TO nr DO addch(tmp,ch);
  140.       Replicate := tmp
  141.     END;                                           { replicate }
  142.     
  143. (***************************************************************************)
  144.  
  145.     PROCEDURE HaltError(s : STRING);
  146.      { s Schreiben un STOP !!! }
  147.     BEGIN
  148.       WriteLn(s);
  149.       Halt(255)
  150.     END;                                           { Halterror }
  151.  
  152. (***************************************************************************)
  153.  
  154.     PROCEDURE FileError(nr : Integer);
  155.      { mögliche Fehler ... }
  156.     VAR
  157.       msg : STRING;
  158.     BEGIN
  159.       CASE nr OF
  160.         1 : msg := 'Lesefehler';
  161.         2 : msg := 'Schreibfehler';
  162.         3 : msg := 'Zu wenig Speicher';
  163.         4 : msg := 'Abbruch';
  164.         5 : msg := 'Fehler in Browser-Modul'
  165.       END;
  166.       HaltError(msg)
  167.     END;                                           { FileError }
  168.     
  169. (***************************************************************************)
  170.     
  171.     FUNCTION Exist(FName : STRING) : Boolean;
  172.       { Existiert Datei (FName) aus TP-PROF }
  173.     VAR
  174.       R : Registers;
  175.       FLen : Byte ABSOLUTE FName;
  176.     BEGIN
  177.       IF Length(FName) = 0 THEN
  178.         Exist := False
  179.       ELSE WITH R DO BEGIN
  180.         Inc(FLen);
  181.         FName[FLen] := #0;                         { Dateinamen mit #0 terminieren }
  182.         AX := $4300;                               { ah : $43 }
  183.         DS := Seg(FName);                          { ds:dx : Filename (ASIIZ) }
  184.         DX := Ofs(FName[1]);
  185.         MsDos(R);                                  { DOS - Call }
  186.         Exist := (NOT Odd(Flags)) AND (IOResult = 0) AND
  187.                  (CX AND (VolumeID+Directory) = 0)
  188.       END
  189.     END;                                           { Exist }
  190.     
  191. (***************************************************************************)
  192.     
  193.     FUNCTION GetKey : Integer;
  194.      { so was wie ReadKey aber MIT Sondertasten (Code > 1000) }
  195.     VAR
  196.       r : Registers;
  197.     BEGIN
  198.       r.Ah := 0;                                  { BIOS - WAIT-Key }
  199.       Intr($16, r);
  200.       IF r.AL = 0 THEN
  201.         GetKey := 1000+r.Ah
  202.       ELSE
  203.         GetKey := r.AL
  204.     END;                                           { GetKey }
  205.     
  206. (***************************************************************************)
  207.  
  208.     PROCEDURE Help;
  209.      { Signon-Message }
  210.     BEGIN
  211.       WriteLn('Zweck  : Texte in lauffähige EXE-Dateien umwandeln.');
  212.       WriteLn('Aufruf : ',t2e,' <Textdatei> <Programmdatei.EXE>');
  213.       Halt(1)
  214.     END;                                           { Help }
  215.     
  216.     
  217. (***************************************************************************)
  218.     
  219.     FUNCTION GetFileLength(FN : STRING) : LongInt;
  220.      { Datei-Länge kommt zurück }
  221.     VAR
  222.       len : LongInt;
  223.       f : FILE;
  224.       savemode : Byte;
  225.     BEGIN
  226.       savemode := filemode;
  227.       filemode := 0;                               { readonly->egal }
  228.       Assign(f, FN);
  229.       Reset(f, 1);
  230.       IF IOResult <> 0 THEN
  231.         FileError(1);                              { nicht da }
  232.       len := FileSize(f);                          { Länge in Bytes feststellen }
  233.       Close(f);
  234.       filemode := savemode;
  235.       GetFileLength := len
  236.     END;                                           { Checklength }
  237.     
  238. (***************************************************************************)
  239.     
  240.     PROCEDURE Compile;
  241.     VAR
  242.       fprg, ftxt , long : FILE;
  243.       txt : Text;
  244.       c : Char;
  245.       s : STRING;
  246.       txtpos : LongInt;
  247.       DummyStr : STRING;
  248.     BEGIN
  249.       
  250.       WriteLn(T2E+version);                        { Meldung }
  251.       
  252.       IF ParamCount < 2 THEN                       { T2E benötigt 2 Parameter }
  253.         Help
  254.       ELSE
  255.         BEGIN
  256.           IF NOT EXIST(prgdir+browser) THEN        { Browser im Programm-Verzeichnis ? }
  257.             Halterror('Browser-Modul (T2BR.EXE) nicht gefunden');
  258.           
  259.           IF NOT Exist(ParamStr(1)) THEN
  260.             Halterror('Datei >>'+UpString(ParamStr(1))+'<< nicht gefunden'); ;
  261.           
  262.           IF Exist(ParamStr(2)) THEN               { Abfrage wenn EXE schon da ... }
  263.             BEGIN
  264.               WriteLn('Achtung : >>'+UpString(ParamStr(2))+'<< existiert');
  265.               Write('Überschreiben ? [J/N]');
  266.               REPEAT
  267.                 c := UpCase(Chr(GetKey));
  268.               UNTIL c IN ['J', 'N'];
  269.               WriteLn(c);
  270.               IF c = 'N' THEN
  271.                 FileError(4)                       { "Abbruch" }
  272.               ELSE
  273.                 BEGIN                              { löschen der Datei .... }
  274.                   filemode := 2;                   { read/write }
  275.                   Assign(fprg, ParamStr(2));
  276.                   SetFAttr(fprg, archive);         { sicher ist sicher }
  277.                   Erase(fprg)
  278.                 END
  279.             END;
  280.  
  281.           New(puffer);                             { Puffer allokieren }
  282.           IF puffer = NIL THEN                     { genug Speicher ? }
  283.             FileError(3);
  284.  
  285.           New(txtPuffer);                          { TextPufer allokieren }
  286.           IF txtPuffer = NIL THEN                  { genug Speicher ? }
  287.             FileError(3);
  288.  
  289.           WriteLn('Übersetzung...');
  290.  
  291.           filemode := 0;                           { read-only ist hier OK }
  292.           Assign(fprg, prgdir+browser);
  293.           {$i-}
  294.           Reset(fprg, 1);
  295.           BlockRead(fprg, puffer^, MAGIC, geLesen);
  296.                                                    { T2BR.EXE in puffer^ lesen }
  297.           IF geLesen <> MAGIC THEN
  298.             FileError(1);                          { Schade ... }
  299.           Close(fprg);
  300.  
  301.           filemode := 2;                           { hier read/write }
  302.           Assign(ftxt, TmpFile);                   { neues File : T2BR.EXE aus puffer^ schreiben }
  303.           Rewrite(ftxt, 1);
  304.           BlockWrite(ftxt, puffer^, MAGIC, geSchrieben);
  305.           IF geSchrieben <> MAGIC THEN
  306.             FileError(2);                          { Schade }
  307.  
  308.           BlockWrite(ftxt, dummyStr, 4);           { Zeilen-Zahl : longint (momentan noch dummy-wert) }
  309.           BlockWrite(ftxt, dummyStr, 4);           { taboffset : longint  (momentan noch dummy-wert) }
  310.  
  311.           filemode := 0;                           { read-only }
  312.           Assign(txt, ParamStr(1));
  313.           SetTextBuf(txt, TxtPuffer^);             { schnell, schnell... }
  314.           Reset(txt);                              { nicht Reset(txt,1) wg.
  315.                                                       TP/BP var txt : TEXT }
  316.                 { jetzt keine IO-Prüfung, da s.o. if exist(..) }
  317.  
  318.           filemode := 2;
  319.           Assign(long, TmpLong);                   { Verweis - Datei erstellen }
  320.           Rewrite(long, 1);
  321.           IF IOResult <> 0 THEN
  322.             FileError(2);                          { war wohl nix } 
  323.  
  324.           REPEAT
  325.             Inc(Zeilen);
  326.  
  327.             txtpos := FilePos(ftxt);
  328.             BlockWrite(long, txtpos, sizeof(longint)); { Verweis ablegen }
  329.  
  330.             ReadLn(txt, s);                    { String aus Text-Datei lesen }
  331.             IF s[0] > #80 THEN                 { max. 80 Zeichen }
  332.               s[0] := #80;
  333.             BlockWrite(ftxt, s, Length(s)+1, geSchrieben);
  334.                                                { und String in neuer EXE ablegen }
  335.  
  336.             IF geSchrieben <> Length(s)+1 THEN
  337.               FileError(2);                    { Mist!! Platte zu klein oder so } 
  338.  
  339.             IF Zeilen mod 10 = 0 then
  340.               BEGIN
  341.                 GotoXY(1,WhereY);                   { wer schreibt der bleibt ...}
  342.                 ClrEol;                             { wir zeigen, was wir tun } 
  343.                 Write(Zeilen, ' Zeilen bearbeitet') { sonst wird's langweilig } 
  344.               END
  345.           UNTIL Eof(txt) ;
  346.           Close(long);
  347.  
  348.           WriteLn(#13#10'Verweise anhängen');       { da fehlt noch was }  
  349.  
  350.           Close(txt);
  351.  
  352.           TabOffset := FilePos(ftxt);               { wo kommt denn jetzt die Tabelle hin ? }
  353.  
  354.           Reset(long, 1);                          { Verweis-Tabelle anhängen }
  355.  
  356.           REPEAT
  357.             BlockRead(long, puffer^, MAGIC, geLesen);
  358.  
  359.             BlockWrite(ftxt, puffer^, geLesen, geSchrieben);
  360.  
  361.           UNTIL (geLesen = 0) OR (geLesen <> geSchrieben);
  362.           
  363.           Close(long);
  364.           Erase(long);                             { Verweis-Datei wird nicht mehr benötigt }
  365.  
  366.                                                    { wichtig, direkt nach MAGIC !!! }          
  367.           Seek(ftxt, MAGIC);                       { Zeilen, Offset Tabelle speichern  }
  368.  
  369.           BlockWrite(ftxt, Zeilen, 4);
  370.           BlockWrite(ftxt, TabOffset, 4);
  371.  
  372.           Close(ftxt);                             { schließen und umbenennen }
  373.  
  374.           Rename(ftxt, ParamStr(2));               { VORSICHT : }
  375.                          { hier kann evtl. rename nicht funktionieren,
  376.                            [ z.b. wenn von C: nach D: oder so]
  377.                            ->man/frau nehme dann so was wie copy xy }
  378.  
  379.           WriteLn('Fertig')
  380.         END
  381.     END;                                           { Compile }
  382.  
  383. (***************************************************************************)
  384. (****** M A I N ************************************************************)
  385. (***************************************************************************)
  386.  
  387. BEGIN
  388.   {$i-}
  389.   directvideo := true;                           { fast, compatible crt... }
  390.  
  391.   HeapError := @HeapFunc;                        { wg. GetMem(...) }
  392.  
  393.   IF Lo(DosVersion) < 3 THEN                     { nur mit DOS ab Ver 3.xx }
  394.     Halterror('DOS ab Ver 3.0 wird benötigt');
  395.  
  396.   IF MaxAvail < 2*SizeOf(PuffTyp) THEN           { Speicher-Platz da ?? }
  397.     FileError(3);
  398.  
  399.   FSplit(ParamStr(0),prgdir,prgname,prgext);    { wo sind wir denn auf der Platte }
  400.   IF prgdir[Length(prgdir)] <> '\' THEN
  401.     addch(prgdir,'\');
  402.  
  403.   IF GetFileLength(prgdir+Browser) = MAGIC THEN  { Browser-Länge auswerten }
  404.  
  405.     Compile                        { scheinbar OK --> gutgläubig übersetzen }
  406.  
  407.   ELSE
  408.  
  409.     fileerror(5);                  { Patch, Virus, oder wa ?? }
  410.  
  411.  
  412.                                    { das MUß jetzt doch noch kommen... }
  413.   WriteLn(#13#10'Idee+Code : P.Fischer-Haaser, D-74072 Heilbronn, Mozartstr. 10'+#13#10+
  414.                 'Tel.:07131/81947, FAX:962843'#13#10)
  415.                                    { sonst tut's net ....}
  416.   {$ENDIF}
  417. END.
  418. (***************************************************************************)
  419.  
  420.  
  421.     
  422.     
  423.