home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / oberon / ps2asc.pas < prev    next >
Pascal/Delphi Source File  |  1991-10-14  |  8KB  |  307 lines
  1. {$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,R-,S-,V-,X-}
  2. {$M 16384,0,0}
  3.  
  4. (*------------------------------------------------*)
  5. (*             PS2ASC.PAS Version 0.9             *)
  6. (*------------------------------------------------*)
  7. (*   Copyright (C) 1991 J. Braun & DMV-Verlag     *)
  8. (*                                                *)
  9. (*   wandelt eine Postscript-Datei in das ASCII-  *)
  10. (*                Format zurück.                  *)
  11. (*------------------------------------------------*)
  12.  
  13. PROGRAM Postscript2Ascii;
  14.  
  15. USES
  16.   Dos;
  17.  
  18. VAR
  19.   InFileName, OutFileName : PathStr;
  20.   InFile, OutFile         : TEXT;
  21.  
  22. CONST
  23.   Init        : BOOLEAN    = FALSE;
  24.   OldNum      : LONGINT    = 0;
  25.   InFileOpen  : BOOLEAN    = FALSE;
  26.   OutFileOpen : BOOLEAN    = FALSE;
  27.   DefExt      : STRING[4]  = '.PS';
  28.   Version     : STRING[4]  = 'v0.9';
  29.   Copyright   : STRING[41] = 'Copyright (C) 1991 J. Braun '
  30.                            + '& DOS-toolbox';
  31.  
  32. CONST
  33.   TAB = Chr(9);
  34.   LF  = Chr(10);
  35.   FF  = Chr(12);
  36.   CR  = Chr(13);
  37.   SPC = Chr(32);
  38.  
  39. PROCEDURE ErrorMessage(Msg: BYTE);
  40. VAR
  41.   s: STRING;
  42. BEGIN
  43.   CASE Msg OF
  44.     1: s := 'Datei wurde nicht gefunden oder kann nicht ' +
  45.             'bearbeitet werden.';
  46.     2: s := 'Kein Dateiname angegeben.';
  47.     ELSE s := '';
  48.   END;
  49.   WriteLn(s);
  50. END;
  51.  
  52. PROCEDURE Terminate(ExitCode: WORD);
  53. BEGIN
  54.   IF ExitCode > 0 THEN
  55.     WriteLn(CR + LF + 'Programm wurde abgebrochen!');
  56.   IF InFileOpen  THEN Close(InFile);
  57.   IF OutFileOpen THEN Close(OutFile);
  58.   Halt(ExitCode);
  59. END;
  60.  
  61. PROCEDURE Help;
  62. BEGIN
  63.   WriteLn(CR + LF + 'PS2ASC Postscript nach ASCII-Wandler '
  64.          + Version);
  65.   WriteLn(Copyright);
  66.   WriteLn('  Aufruf:');
  67.   WriteLn(TAB + 'PS2ASC [Dateiname[.Ext]]');
  68.   WriteLn(TAB + 'Default-Extension ist .PS');
  69.   Terminate(0);
  70. END;
  71.  
  72. FUNCTION WhichFile: PathStr;
  73. VAR
  74.   InFileName: PathStr;
  75.   HasExt,
  76.   Exists: BOOLEAN;
  77.   Attr  : WORD;
  78.   s     : SearchRec;
  79.   i     : BYTE;
  80. BEGIN
  81.   IF ParamCount = 0 THEN BEGIN
  82.     Write('Dateiname mit Pfad: ');
  83.     ReadLn(InFileName);
  84.   END ELSE InFileName := ParamStr(1);
  85.   IF Length(InFileName) > 0 THEN
  86.     IF (Pos('?' , InFileName) > 0) OR
  87.        (Pos('*' , InFileName) > 0) THEN Help;
  88.   IF Length(InFileName) = 0 THEN BEGIN
  89.     ErrorMessage(2);
  90.     Terminate(2);
  91.   END
  92.   ELSE FOR i := 1 TO Length(InFileName) DO
  93.     InFileName[i] := UpCase(InFileName[i]);
  94.   HasExt := Pos(DefExt, InFileName) > 0;
  95.   IF NOT HasExt THEN
  96.     IF InFileName[Length(InFileName)] = '.' THEN
  97.       HasExt := TRUE;
  98.   IF NOT HasExt THEN
  99.     InFileName := Concat(InFileName, DefExt);
  100.   FindFirst(InFileName, Archive, s);
  101.   Exists := DosError = 0;
  102.   IF NOT Exists THEN BEGIN
  103.     ErrorMessage(1);
  104.     Terminate(4);
  105.   END;
  106.   WriteLn('PS2ASC Postscript nach ASCII-Wandler '
  107.          + Version);
  108.   WriteLn(Copyright + CR + LF);
  109.   Assign(InFile, InFileName);
  110.   Reset(InFile);
  111.   InFileOpen := TRUE;
  112.   WhichFile := InFileName;
  113. END;
  114.  
  115. PROCEDURE Convert(InFileName: PathStr);
  116. VAR
  117.   Line, NewLine : STRING;
  118.   FPath         : DirStr;
  119.   FName         : NameStr;
  120.   FExt          : ExtStr;
  121.  
  122.   PROCEDURE ParseLine(Line: STRING; VAR NewLine: STRING);
  123.   VAR
  124.     NewNum   : LONGINT;
  125.     TextRest : STRING;
  126.  
  127.     PROCEDURE SearchEndComment;
  128.     (*--------------------------------------------*)
  129.     (* Hier sollten auch noch die Makrobezeichner *)
  130.     (* gesucht werden !                           *)
  131.     (*--------------------------------------------*)
  132.     VAR
  133.       Level : SHORTINT;
  134.       i     : BYTE;
  135.     BEGIN
  136.       REPEAT
  137.         Level := 0;
  138.         FOR i := 1 TO Length(Line) DO BEGIN
  139.           IF Line[i] = '{' THEN Inc(Level);
  140.           IF Line[i] = '}' THEN Dec(Level);
  141.         END;
  142.         IF (Level > 0) OR (i >= Length(Line)) THEN
  143.           ReadLn(InFile, Line);
  144.       UNTIL (Pos('def', Line) > 0) AND (Level = 0);
  145.     END; (* SearchEndComment *)
  146.  
  147.     FUNCTION SplitLine(Line: STRING;
  148.                    VAR Rest: STRING): LONGINT;
  149.     VAR
  150.       Done  : BOOLEAN;
  151.       Number: LONGINT;
  152.  
  153.       FUNCTION Parse1stNum(Line: STRING;
  154.                        VAR Rest: STRING): BOOLEAN;
  155.       VAR
  156.         s : STRING;
  157.         l : LONGINT;
  158.         i : BYTE;
  159.       BEGIN
  160.         i := 1;
  161.         s := '';
  162.         WHILE Line[i] <> SPC DO
  163.         BEGIN
  164.           s := Concat(s, Line[i]);
  165.           Inc(i);
  166.         END;
  167.         Delete(Line, 1, Length(s) + 1);
  168.         Rest := Line;
  169.         Parse1stNum := TRUE;
  170.       END;
  171.  
  172.       FUNCTION Parse2ndNum(VAR Rest: STRING;
  173.                            VAR Number: LONGINT): BOOLEAN;
  174.       VAR
  175.         s    : STRING;
  176.         i    : BYTE;
  177.         code : INTEGER;
  178.       BEGIN
  179.         i := 1;
  180.         s := '';
  181.         WHILE Rest[i] <> SPC DO
  182.         BEGIN
  183.           s := Concat(s, Rest[i]);
  184.           Inc(i);
  185.         END;
  186.         Delete(Rest, 1, Length(s) + 1);
  187.         Val(s, Number, code);
  188.         IF code <> 0 THEN
  189.         BEGIN
  190.           Number := 0;
  191.           IF s = 'p' THEN WriteLn(OutFile, FF);
  192.         END;
  193.         Parse2ndNum := code = 0;
  194.       END;
  195.  
  196.       FUNCTION ParseText(VAR Rest: STRING): BOOLEAN;
  197.       VAR
  198.         Level : SHORTINT;
  199.         i, l  : INTEGER;
  200.         s     : STRING;
  201.  
  202.         PROCEDURE OpenBracket;
  203.         BEGIN
  204.           IF (i > 1) AND (i < l)  THEN BEGIN
  205.             IF Rest[i + 1] = ')' THEN
  206.               IF Rest[i-1] <> '\' THEN Rest[i] := CR;
  207.             IF (Rest[i - 1] <> '\') THEN
  208.             BEGIN
  209.               Inc(Level);
  210.               Rest[i] := SPC;
  211.             END;
  212.  
  213.           END;
  214.         END;
  215.  
  216.         PROCEDURE CloseBracket;
  217.         BEGIN
  218.           IF i > 1 THEN
  219.            IF Rest[i - 1] = CR THEN Rest[i] := LF;
  220.            IF NOT (Rest[i - 1] IN ['\', '(']) THEN BEGIN
  221.              Dec(Level);
  222.              Rest[i] := SPC;
  223.            END;
  224.         END;
  225.  
  226.         PROCEDURE BackSlash;
  227.         BEGIN
  228.           IF i < l THEN
  229.             IF Rest[i + 1] IN [')', '('] THEN Inc(i);
  230.         END;
  231.  
  232.       BEGIN
  233.         Level := 0; l := Length(Rest); s := ''; i := 1;
  234.         REPEAT
  235.           CASE Rest[i] OF
  236.             '(': OpenBracket;
  237.             ')': CloseBracket; 
  238.             '\': BackSlash;
  239.           END;
  240.           IF Level <> 0 THEN s := s + Rest[i];
  241.           Inc(i);
  242.         UNTIL i >= l;
  243.         IF Level <> 0 THEN s := Concat(s, Rest[i]);
  244.         IF (Pos('Syntax', s) > 0) AND
  245.            (Pos('.Fnt', s) > 0) THEN BEGIN
  246.           Delete(s, Pos('Syntax', s),
  247.                     Pos('.Fnt', s) + 4 - Pos('Syntax', s));
  248.         END;
  249.         Rest := s;
  250.         ParseText := TRUE;
  251.       END;
  252.  
  253.     BEGIN
  254.       Number := 0;
  255.       Done := Parse1stNum(Line, Rest);
  256.       IF Parse2ndNum(Rest, Number) THEN
  257.         Done := ParseText(Rest);
  258.       SplitLine := Number;
  259.     END; (* SplitLine *)
  260.  
  261.   BEGIN
  262.     IF (Line[1] = '/') THEN
  263.       IF UpCase(Line[2]) IN ['A' .. 'Z'] THEN BEGIN
  264.         SearchEndComment;
  265.         Exit;
  266.       END;
  267.     IF Pos('init', Line) = 1 THEN
  268.     BEGIN
  269.       Init := TRUE;
  270.       ReadLn(InFile, Line);
  271.     END;
  272.     IF Init THEN
  273.     BEGIN
  274.       IF Line[1] IN ['1' .. '9'] THEN
  275.         NewNum := SplitLine(Line, TextRest)
  276.       ELSE TextRest := '';
  277.       IF (NewNum <> OldNum) THEN BEGIN
  278.         WriteLn(OutFile); WriteLn;
  279.       END;
  280.       Write(TextRest);
  281.       Write(OutFile, TextRest);
  282.       OldNum := NewNum;
  283.     END;
  284.   END; (* ParseLine *)
  285.  
  286. BEGIN
  287.   NewLine := '';
  288.   FSplit(InFileName, FPath, FName, FExt);
  289.   OutFileName := Concat(FPath, FName, '.ASC');
  290.   Assign(OutFile, OutFileName);
  291.   ReWrite(OutFile);
  292.   OutFileOpen := TRUE;
  293.   WHILE NOT EoF(InFile) DO BEGIN
  294.     ReadLn(InFile, Line);
  295.     IF Length(Line) > 0 THEN BEGIN
  296.       IF Line[1] <> '%' THEN (* Kommentarzeile *)
  297.         ParseLine(Line, NewLine);
  298.     END;
  299.   END;
  300.   Close(InFile); Close(OutFile);
  301.   InFileOpen := FALSE; OutFileOpen := FALSE;
  302. END;
  303.  
  304. BEGIN
  305.   Convert(WhichFile);
  306. END.
  307.