home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Misc / VIDEOTEXT.LZX / VTsrc / datei.p < prev    next >
Encoding:
Text File  |  1996-02-21  |  10.3 KB  |  320 lines
  1. UNIT datei; {$project vt}
  2. { Dateioperationen zum Programm VideoText }
  3.  
  4. INTERFACE; FROM vt USES bildschirm;
  5.  
  6. VAR iconpath: Str80;
  7.  
  8. FUNCTION filetype(name: Str80): Integer;
  9. FUNCTION getpages(filename: Str80; sorted: Boolean): Integer;
  10. FUNCTION printpage(seite: p_onepage): Boolean;
  11. FUNCTION iffdump: Boolean;
  12. FUNCTION save_action(seite: p_onepage; mode: Integer): Integer;
  13. PROCEDURE namefrompage(VAR filename: str80; seite: p_onepage);
  14.  
  15. { ---------------------------------------------------------------------- }
  16.  
  17. IMPLEMENTATION;
  18. {$ opt q,s+,i+} { keine Laufzeitprüfungen außer Stack und Feldindizes }
  19.  
  20. CONST STITLE = $0040; { C6 }
  21.       HEADLN = $0020; { C5 }
  22.  
  23. { FUNCTION's filetype() und getpages() includen: }
  24. CONST unit_datei=1701; {$path "PAS:prg/vt/"; incl "dbluse.p" }
  25.  
  26. FUNCTION printpage{(seite: p_onepage): Boolean};
  27. { Druckerausgabe, simpelste Ausführung }
  28. VAR drucker: Text;
  29.     i: Integer;
  30.     s: Str80;
  31.     monster: ^String[1000]
  32. BEGIN
  33.   printpage := False;
  34.   Reset(drucker,'PRT:');
  35.   IF IOResult<>0 THEN Exit;
  36.   New(monster); monster^ := '';
  37.   FOR i := 0 TO 23 DO BEGIN
  38.     makeascii(seite, i, True, s);
  39.     monster^ := monster^ + s + Chr(10);
  40.   END;
  41.   Write(drucker,monster^);
  42.   Dispose(monster);
  43.   Close(drucker); printpage := True;
  44. END;
  45.  
  46. FUNCTION iffdump{: Boolean};
  47. { IFF-Bild erzeugen }
  48. VAR i, j, k, zeile, bunt, packbar: Integer;
  49.     l: Long;
  50.     s: str80;
  51.     bytes: ^ARRAY [1..41] OF Char;
  52.     datei: Text;
  53. PROCEDURE putshort(w: Word);
  54.   BEGIN Write(datei,chr(Hi(w)),chr(Lo(w))); END;
  55. PROCEDURE putlong(l: Long);
  56.   BEGIN putshort(Word(l SHR 16)); putshort(Word(l AND $FFFF)); END;
  57. BEGIN
  58.   iffdump := False;
  59.   Rewrite(datei,iffpicname);
  60.   IF IOresult<>0 THEN     { wahrscheinlich 'Object in use' }
  61.     Exit;
  62.   IF withicon THEN BEGIN
  63.     s := iconpath + 'IFF';
  64.     create_icon(s,iffpicname);
  65.   END;
  66.   { IFF-ILBM erzeugen, LoRes, 320x256, 3 Bitplanes }
  67.   Write(datei,'FORM'); putlong(10084);  { wird später korrigiert }
  68.   Write(datei,'ILBM');
  69.   Write(datei,'BMHD'); putlong(20);
  70.   putshort(320); putshort(216); { Breite, Höhe der Bitmap }
  71.   putshort(0); putshort(0); { x/y-Offset }
  72.   Write(datei,Chr(3)); { 3 Bitplanes }
  73.   Write(datei,Chr(0)); { keine Maske }
  74.   Write(datei,Chr(1)); { Grafikdaten mit Byte-Running gepackt !!! }
  75.   Write(datei,Chr(0)); { Füllbyte }
  76.   putshort(0); { transparente Farbe }
  77.   Write(datei, Chr(10), Chr(11));  { x/y-Verhältnis ~1:1 }
  78.   putshort(320); putshort(256); { Breite, Höhe des Bildschirms }
  79.   Write(datei,'CMAP'); putlong(24);
  80.   FOR i := 0 TO 7 DO
  81.     FOR j := 0 TO 7 DO
  82.       IF (colperm SHR (4*(7-j))) AND $F = i THEN
  83.         Write(datei,Chr($F0*(j AND 1)),Chr($78*(j AND 2)),
  84.                         Chr($3C*(j AND 4)));
  85.   Write(datei,'CAMG'); putlong(4);
  86.   putlong(0);  { ViewMode: weder HIRES noch LACE! }
  87.   Write(datei,'BODY'); putlong(10000);    { Wert wird später korrigiert }
  88.   FOR zeile := 0 TO 215 DO BEGIN
  89.     FOR i := 0 TO 2 DO BEGIN
  90.       bytes := Ptr(Long(bitmapzeile(i,zeile))+39);
  91.       { Zeile von bytes[] nach s[] packen (Byte-Running): }
  92.       j := 1; k := 0;
  93.       bunt := 0;
  94.       REPEAT
  95.         packbar := 1;
  96.         WHILE (bytes^[j+packbar]=bytes^[j+packbar-1]) AND (j+packbar<40) DO
  97.           Inc(packbar);
  98.         IF packbar>2 THEN BEGIN { lohnt packen? }
  99.           Inc(k); s[k] := Chr(257-packbar); Inc(k); s[k] := bytes^[j];
  100.           j := j + packbar; bunt := 0;
  101.         END ELSE BEGIN
  102.           Inc(bunt); IF bunt=1 THEN Inc(k);
  103.           Inc(k); s[k] := bytes^[j]; s[k-bunt] := Chr(bunt-1);
  104.           Inc(j);
  105.         END;
  106.       UNTIL j>40;
  107.       BlockWrite(datei,s,k); IF IOResult<>0 THEN BEGIN 
  108.         Close(datei); Exit; { wahrscheinlich Disk full oder so was }
  109.       END; 
  110.     END;
  111.   END;
  112.   { Chunk-Größen korrigieren }
  113.   l := FileSize(datei);
  114.   IF Odd(l) THEN BEGIN Write(datei,Chr(0)); Inc(l); END;
  115.   Seek(datei,4); putlong(l-8);
  116.   Seek(datei,88); putlong(l-92);
  117.   Close(datei);
  118.   iffdump := True;
  119. END;
  120.  
  121. FUNCTION savepage(seite: p_onepage; filename: Str80): Boolean;
  122. { Seite abspeichern, ASCII oder rohes VT-Format }
  123. { ASCII-Text wird für Untertitel und Schlagzeilen 'komprimiert' ausgegeben: }
  124. { nur die auf der Seite befindliche Box (mindestens aber eine Leerzeile, bei }
  125. { Schlagzeilen zusätzlich die Kopfzeile). }
  126. { Bei Untertiteln werden die Farbsteuerzeichen in Klartext umgesetzt. }
  127. VAR i, zeile: Integer;
  128.     s: str80;
  129.     bytes: ^ARRAY [1..41] OF Char;
  130.     datei: Text;
  131.     is_stitle,is_headln,visible: Boolean;
  132. BEGIN
  133.   savepage := False; IF seite=Nil THEN Exit;
  134.   IF overwrite THEN
  135.     Rewrite(datei,filename)
  136.   ELSE BEGIN
  137.     Reset(datei,filename);
  138.     IF (IOresult<>0) THEN { Datei existiert vermutlich nicht }
  139.       Rewrite(datei,filename);
  140.   END;
  141.   IF IOresult<>0 THEN     { wahrscheinlich 'Object in use' }
  142.     Exit;
  143.   IF withicon THEN IF FileSize(datei)=0 THEN BEGIN
  144.     IF asciifile THEN  s := iconpath + 'ASCII'
  145.     ELSE  s := iconpath + 'VT';
  146.     create_icon(s,filename);
  147.   END;
  148.   Buffer(datei,500);
  149.   Seek(datei,FileSize(datei));
  150.   IF asciifile THEN BEGIN  { ASCII-Textausgabe }
  151.     is_stitle := (seite^.cbits AND STITLE)<>0;
  152.     is_headln := (seite^.cbits AND HEADLN)<>0;
  153.     FOR zeile := 0 to 23 DO BEGIN
  154.       IF is_stitle OR is_headln THEN BEGIN
  155.         visible := False;
  156.         FOR i := 0 TO 39 DO
  157.           IF (seite^.chars[zeile*40+i]=11) THEN visible := True;
  158.         IF is_headln AND (zeile=0) THEN
  159.           visible := True;
  160.       END ELSE
  161.         visible := True;
  162.       IF visible THEN BEGIN
  163.         makeascii(seite, zeile, NOT is_stitle, s);
  164.         WriteLn(datei, s); IF IOResult<>0 THEN BEGIN
  165.           Close(datei); Exit; { Disk full o. ä. }
  166.         END;
  167.       END;
  168.     END;
  169.     WriteLn(datei);
  170.   END ELSE BEGIN   { (beinahe) rohes VT-Format }
  171.     WriteLn(datei,'VTPG');
  172.     FOR zeile := 0 to 23 DO BEGIN
  173.       bytes := Ptr(^seite^.chars[40*zeile]);
  174.       BlockWrite(datei,bytes^,40); IF IOResult<>0 THEN BEGIN
  175.         Close(datei); Exit; { Disk full o. ä. }
  176.       END;
  177.       WriteLn(datei);
  178.     END;
  179.     Write(datei,hexstr(seite^.pg,0)); Write(datei,' ');
  180.     Write(datei,hexstr(seite^.sp,0)); Write(datei,' $');
  181.     Write(datei,hexstr(seite^.cbits,4)); WriteLn(datei);
  182.   END;
  183.   Close(datei);
  184.   savepage := True;
  185. END;
  186.  
  187. FUNCTION save_action{(seite: p_onepage; mode: Integer): Integer};
  188. { Verwaltungskram für savepage(). }
  189. { Bedeutung von <mode>: }
  190. { 1=nur <seite> speichern, 2=mit allen Unterseiten, 3=ganze Seitenliste }
  191. { Ergebnis: }
  192. { 0: OK, 1: Benutzer wollte nicht, 2: Anhängen unzulässig, 3: IO-Fehler }
  193. VAR ft: Integer;
  194.     save_ovrw,dont_ask: Boolean;
  195.     fullname,lastname: Str80;
  196.     pg1,pg2: p_onepage;
  197. BEGIN
  198.   save_action := 1;
  199.   IF seite=Nil THEN Exit;
  200.   fileinfo;
  201.   dont_ask := False;
  202.   IF mode=3 THEN  { Ctrl-S: *alle* Seiten Speichern }
  203.     IF numbering THEN BEGIN
  204.       IF NOT ja_nein('Jede Seite einzeln speichern?') THEN Exit;
  205.       dont_ask := True; { mehrere Ausgabedateien: Rückfragen zwecklos }
  206.     END ELSE BEGIN
  207.       IF NOT ja_nein('Alle Seiten speichern?') THEN Exit;
  208.     END;
  209.   fullname := outputname;
  210.   IF numbering THEN fullname := outputname + '.' + hexstr(seite^.pg,3)
  211.   { evtl. Benutzerrückfragen zu dieser Ausgabedatei: }
  212.   IF NOT dont_ask THEN BEGIN
  213.     ft := filetype(fullname);
  214.     { Sicherheitsprüfungen: Überschreiben nur mit Bestätigung ... }
  215.     IF overwrite THEN BEGIN
  216.       IF ft<>-1 THEN
  217.         IF NOT ja_nein('Überschreiben - sicher?') THEN Exit;
  218.     { ... Anhängen nur an geeignete Dateien: }
  219.     END ELSE BEGIN
  220.       mainline; Write(#155'2m');
  221.       IF ft IN [2,3,4] THEN BEGIN
  222.         CASE ft OF
  223.           2: Write('Programmdatei');
  224.           3: Write('IFF-Datei');
  225.           4: Write('Icon-Datei');
  226.         END;
  227.         Write(', Anh{ngen unzul{ssig!');
  228.         save_action := 2; Exit;
  229.       END;
  230.       IF NOT asciifile AND NOT (ft IN [1,-1]) THEN BEGIN
  231.         Write('VT nur an VT-Format anh{ngen!');
  232.         save_action := 2; Exit;
  233.       END;
  234.     END;
  235.   END;
  236.   { Alle Rückfragen überstanden -> speichern: }
  237.   busy_pointer; save_ovrw := overwrite; lastname := '';
  238.   pg1 := root;
  239.   { um aber auch Seiten speichern zu können, die nicht in der Liste stehen: }
  240.   IF (seite^.prev=Nil) AND (root<>seite) THEN pg1 := seite;
  241.   WHILE pg1<>NIL DO BEGIN
  242.     IF (mode=3) OR ((mode=2) AND (pg1^.pg=seite^.pg))
  243.     OR (pg1=seite) THEN BEGIN
  244.       IF numbering THEN fullname := outputname + '.' + hexstr(pg1^.pg,3)
  245.       IF fullname<>lastname THEN overwrite := save_ovrw;
  246.       mainline;
  247.       Write('Seite ',hexstr(pg1^.pg,0),'/',hexstr(pg1^.sp,0),' ...');
  248.       IF savepage(pg1,fullname) THEN
  249.         Write(' gespeichert.')
  250.       ELSE BEGIN
  251.         Write(#155'2m Dateifehler!');
  252.         save_action := 3;
  253.         pg1 := Nil;
  254.       END;
  255.       lastname := fullname; overwrite := False;
  256.     END;
  257.     IF pg1<>Nil THEN pg1 := pg1^.next;
  258.   END;
  259.   normal_pointer; overwrite := save_ovrw;
  260.   save_action := 0;
  261. END;
  262.  
  263. PROCEDURE namefrompage{(VAR filename: str80; seite: p_onepage)};
  264. { Dateinamen aus der Titelzeile einer Seite übernehmen }
  265. VAR i,j,l: Integer;
  266.     pfad,name,s: str80;
  267.     has_letters: Boolean;
  268. PROCEDURE extract(i,j: Integer); { Stück aus s nach filename übertragen }
  269. VAR k,l: Integer;
  270.     sonder: String[8];
  271.     uebers: String[15];
  272. BEGIN
  273.   sonder := 'äöüÄÖÜß'; uebers := 'aeoeueAEOEUEss';
  274.   k := 1;
  275.   REPEAT
  276.     CASE s[i] OF
  277.       ' ': filename[k] := '_'; { Leerzeichen }
  278.       '/',':': filename[k] := '-'; { Verzeichnis-Begrenzer }
  279.       OTHERWISE filename[k] := s[i];
  280.     END;
  281.     l := Pos(s[i],sonder);
  282.     IF l>0 THEN BEGIN
  283.       filename[k] := uebers[2*l-1]; Inc(k); filename[k] := uebers[2*l];
  284.     END;                                                             
  285.     Inc(i); Inc(k);
  286.   UNTIL i>=j;
  287.   filename[k] := #0;
  288. END;
  289. BEGIN
  290.   IF seite=Nil THEN Exit;
  291.   l := Length(filename);
  292.   j := 0; FOR i := 1 TO l DO
  293.     IF filename[i] IN ['/',':'] THEN j := i;
  294.   IF j=0 THEN pfad := '' ELSE pfad := Copy(filename,1,j);
  295.   IF j=l THEN name := '' ELSE name := Copy(filename,j+1,l-j);
  296.   { Das 1. Wort in der Titelzeile finden, das auch Buchstaben enthält: }
  297.   makeascii(seite, 0, True, s); j := 1;
  298.   REPEAT
  299.     i := j; has_letters := False;
  300.     WHILE (s[i]=' ') AND (i<=40) DO Inc(i);
  301.     j := i; REPEAT
  302.       IF s[j] IN ['a'..'z','A'..'Z'] THEN has_letters := True;
  303.       Inc(j);
  304.     UNTIL (s[j]=' ') OR (j>40);
  305.   UNTIL has_letters OR (i>40);
  306.   IF i<=40 THEN extract(i,j) ELSE filename :='';
  307.   IF filename=name THEN BEGIN { Oh, hier war ich schon mal }
  308.     WHILE s[j]=' ' DO Inc(j);
  309.     REPEAT Inc(j) UNTIL (s[j]=' ') OR (j>40);
  310.     extract(i,j);
  311.   END;
  312.   IF filename<>'' THEN name := filename;
  313.   filename := pfad + name;
  314. END;
  315.  
  316. BEGIN  { Initialisierungen }
  317.   iconpath := 'Icons/';
  318. END.
  319.  
  320.