UNIT datei; {$project vt}
{ Dateioperationen zum Programm VideoText }

INTERFACE; FROM vt USES bildschirm;

VAR iconpath: Str80;

FUNCTION filetype(name: Str80): Integer;
FUNCTION getpages(filename: Str80; sorted: Boolean): Integer;
FUNCTION printpage(seite: p_onepage): Boolean;
FUNCTION iffdump: Boolean;
FUNCTION save_action(seite: p_onepage; mode: Integer): Integer;
PROCEDURE namefrompage(VAR filename: str80; seite: p_onepage);

{ ---------------------------------------------------------------------- }

IMPLEMENTATION;
{$ opt q,s+,i+} { keine Laufzeitprüfungen außer Stack und Feldindizes }

CONST STITLE = $0040; { C6 }
      HEADLN = $0020; { C5 }

{ FUNCTION's filetype() und getpages() includen: }
CONST unit_datei=1701; {$path "PAS:prg/vt/"; incl "dbluse.p" }

FUNCTION printpage{(seite: p_onepage): Boolean};
{ Druckerausgabe, simpelste Ausführung }
VAR drucker: Text;
    i: Integer;
    s: Str80;
    monster: ^String[1000]
BEGIN
  printpage := False;
  Reset(drucker,'PRT:');
  IF IOResult<>0 THEN Exit;
  New(monster); monster^ := '';
  FOR i := 0 TO 23 DO BEGIN
    makeascii(seite, i, True, s);
    monster^ := monster^ + s + Chr(10);
  END;
  Write(drucker,monster^);
  Dispose(monster);
  Close(drucker); printpage := True;
END;

FUNCTION iffdump{: Boolean};
{ IFF-Bild erzeugen }
VAR i, j, k, zeile, bunt, packbar: Integer;
    l: Long;
    s: str80;
    bytes: ^ARRAY [1..41] OF Char;
    datei: Text;
PROCEDURE putshort(w: Word);
  BEGIN Write(datei,chr(Hi(w)),chr(Lo(w))); END;
PROCEDURE putlong(l: Long);
  BEGIN putshort(Word(l SHR 16)); putshort(Word(l AND $FFFF)); END;
BEGIN
  iffdump := False;
  Rewrite(datei,iffpicname);
  IF IOresult<>0 THEN     { wahrscheinlich 'Object in use' }
    Exit;
  IF withicon THEN BEGIN
    s := iconpath + 'IFF';
    create_icon(s,iffpicname);
  END;
  { IFF-ILBM erzeugen, LoRes, 320x256, 3 Bitplanes }
  Write(datei,'FORM'); putlong(10084);  { wird später korrigiert }
  Write(datei,'ILBM');
  Write(datei,'BMHD'); putlong(20);
  putshort(320); putshort(216); { Breite, Höhe der Bitmap }
  putshort(0); putshort(0); { x/y-Offset }
  Write(datei,Chr(3)); { 3 Bitplanes }
  Write(datei,Chr(0)); { keine Maske }
  Write(datei,Chr(1)); { Grafikdaten mit Byte-Running gepackt !!! }
  Write(datei,Chr(0)); { Füllbyte }
  putshort(0); { transparente Farbe }
  Write(datei, Chr(10), Chr(11));  { x/y-Verhältnis ~1:1 }
  putshort(320); putshort(256); { Breite, Höhe des Bildschirms }
  Write(datei,'CMAP'); putlong(24);
  FOR i := 0 TO 7 DO
    FOR j := 0 TO 7 DO
      IF (colperm SHR (4*(7-j))) AND $F = i THEN
        Write(datei,Chr($F0*(j AND 1)),Chr($78*(j AND 2)),
                        Chr($3C*(j AND 4)));
  Write(datei,'CAMG'); putlong(4);
  putlong(0);  { ViewMode: weder HIRES noch LACE! }
  Write(datei,'BODY'); putlong(10000);    { Wert wird später korrigiert }
  FOR zeile := 0 TO 215 DO BEGIN
    FOR i := 0 TO 2 DO BEGIN
      bytes := Ptr(Long(bitmapzeile(i,zeile))+39);
      { Zeile von bytes[] nach s[] packen (Byte-Running): }
      j := 1; k := 0;
      bunt := 0;
      REPEAT
        packbar := 1;
        WHILE (bytes^[j+packbar]=bytes^[j+packbar-1]) AND (j+packbar<40) DO
          Inc(packbar);
        IF packbar>2 THEN BEGIN { lohnt packen? }
          Inc(k); s[k] := Chr(257-packbar); Inc(k); s[k] := bytes^[j];
          j := j + packbar; bunt := 0;
        END ELSE BEGIN
          Inc(bunt); IF bunt=1 THEN Inc(k);
          Inc(k); s[k] := bytes^[j]; s[k-bunt] := Chr(bunt-1);
          Inc(j);
        END;
      UNTIL j>40;
      BlockWrite(datei,s,k); IF IOResult<>0 THEN BEGIN 
        Close(datei); Exit; { wahrscheinlich Disk full oder so was }
      END; 
    END;
  END;
  { Chunk-Größen korrigieren }
  l := FileSize(datei);
  IF Odd(l) THEN BEGIN Write(datei,Chr(0)); Inc(l); END;
  Seek(datei,4); putlong(l-8);
  Seek(datei,88); putlong(l-92);
  Close(datei);
  iffdump := True;
END;

FUNCTION savepage(seite: p_onepage; filename: Str80): Boolean;
{ Seite abspeichern, ASCII oder rohes VT-Format }
{ ASCII-Text wird für Untertitel und Schlagzeilen 'komprimiert' ausgegeben: }
{ nur die auf der Seite befindliche Box (mindestens aber eine Leerzeile, bei }
{ Schlagzeilen zusätzlich die Kopfzeile). }
{ Bei Untertiteln werden die Farbsteuerzeichen in Klartext umgesetzt. }
VAR i, zeile: Integer;
    s: str80;
    bytes: ^ARRAY [1..41] OF Char;
    datei: Text;
    is_stitle,is_headln,visible: Boolean;
BEGIN
  savepage := False; IF seite=Nil THEN Exit;
  IF overwrite THEN
    Rewrite(datei,filename)
  ELSE BEGIN
    Reset(datei,filename);
    IF (IOresult<>0) THEN { Datei existiert vermutlich nicht }
      Rewrite(datei,filename);
  END;
  IF IOresult<>0 THEN     { wahrscheinlich 'Object in use' }
    Exit;
  IF withicon THEN IF FileSize(datei)=0 THEN BEGIN
    IF asciifile THEN  s := iconpath + 'ASCII'
    ELSE  s := iconpath + 'VT';
    create_icon(s,filename);
  END;
  Buffer(datei,500);
  Seek(datei,FileSize(datei));
  IF asciifile THEN BEGIN  { ASCII-Textausgabe }
    is_stitle := (seite^.cbits AND STITLE)<>0;
    is_headln := (seite^.cbits AND HEADLN)<>0;
    FOR zeile := 0 to 23 DO BEGIN
      IF is_stitle OR is_headln THEN BEGIN
        visible := False;
        FOR i := 0 TO 39 DO
          IF (seite^.chars[zeile*40+i]=11) THEN visible := True;
        IF is_headln AND (zeile=0) THEN
          visible := True;
      END ELSE
        visible := True;
      IF visible THEN BEGIN
        makeascii(seite, zeile, NOT is_stitle, s);
        WriteLn(datei, s); IF IOResult<>0 THEN BEGIN
          Close(datei); Exit; { Disk full o. ä. }
        END;
      END;
    END;
    WriteLn(datei);
  END ELSE BEGIN   { (beinahe) rohes VT-Format }
    WriteLn(datei,'VTPG');
    FOR zeile := 0 to 23 DO BEGIN
      bytes := Ptr(^seite^.chars[40*zeile]);
      BlockWrite(datei,bytes^,40); IF IOResult<>0 THEN BEGIN
        Close(datei); Exit; { Disk full o. ä. }
      END;
      WriteLn(datei);
    END;
    Write(datei,hexstr(seite^.pg,0)); Write(datei,' ');
    Write(datei,hexstr(seite^.sp,0)); Write(datei,' $');
    Write(datei,hexstr(seite^.cbits,4)); WriteLn(datei);
  END;
  Close(datei);
  savepage := True;
END;

FUNCTION save_action{(seite: p_onepage; mode: Integer): Integer};
{ Verwaltungskram für savepage(). }
{ Bedeutung von <mode>: }
{ 1=nur <seite> speichern, 2=mit allen Unterseiten, 3=ganze Seitenliste }
{ Ergebnis: }
{ 0: OK, 1: Benutzer wollte nicht, 2: Anhängen unzulässig, 3: IO-Fehler }
VAR ft: Integer;
    save_ovrw,dont_ask: Boolean;
    fullname,lastname: Str80;
    pg1,pg2: p_onepage;
BEGIN
  save_action := 1;
  IF seite=Nil THEN Exit;
  fileinfo;
  dont_ask := False;
  IF mode=3 THEN  { Ctrl-S: *alle* Seiten Speichern }
    IF numbering THEN BEGIN
      IF NOT ja_nein('Jede Seite einzeln speichern?') THEN Exit;
      dont_ask := True; { mehrere Ausgabedateien: Rückfragen zwecklos }
    END ELSE BEGIN
      IF NOT ja_nein('Alle Seiten speichern?') THEN Exit;
    END;
  fullname := outputname;
  IF numbering THEN fullname := outputname + '.' + hexstr(seite^.pg,3)
  { evtl. Benutzerrückfragen zu dieser Ausgabedatei: }
  IF NOT dont_ask THEN BEGIN
    ft := filetype(fullname);
    { Sicherheitsprüfungen: Überschreiben nur mit Bestätigung ... }
    IF overwrite THEN BEGIN
      IF ft<>-1 THEN
        IF NOT ja_nein('Überschreiben - sicher?') THEN Exit;
    { ... Anhängen nur an geeignete Dateien: }
    END ELSE BEGIN
      mainline; Write(#155'2m');
      IF ft IN [2,3,4] THEN BEGIN
        CASE ft OF
          2: Write('Programmdatei');
          3: Write('IFF-Datei');
          4: Write('Icon-Datei');
        END;
        Write(', Anh{ngen unzul{ssig!');
        save_action := 2; Exit;
      END;
      IF NOT asciifile AND NOT (ft IN [1,-1]) THEN BEGIN
        Write('VT nur an VT-Format anh{ngen!');
        save_action := 2; Exit;
      END;
    END;
  END;
  { Alle Rückfragen überstanden -> speichern: }
  busy_pointer; save_ovrw := overwrite; lastname := '';
  pg1 := root;
  { um aber auch Seiten speichern zu können, die nicht in der Liste stehen: }
  IF (seite^.prev=Nil) AND (root<>seite) THEN pg1 := seite;
  WHILE pg1<>NIL DO BEGIN
    IF (mode=3) OR ((mode=2) AND (pg1^.pg=seite^.pg))
    OR (pg1=seite) THEN BEGIN
      IF numbering THEN fullname := outputname + '.' + hexstr(pg1^.pg,3)
      IF fullname<>lastname THEN overwrite := save_ovrw;
      mainline;
      Write('Seite ',hexstr(pg1^.pg,0),'/',hexstr(pg1^.sp,0),' ...');
      IF savepage(pg1,fullname) THEN
        Write(' gespeichert.')
      ELSE BEGIN
        Write(#155'2m Dateifehler!');
        save_action := 3;
        pg1 := Nil;
      END;
      lastname := fullname; overwrite := False;
    END;
    IF pg1<>Nil THEN pg1 := pg1^.next;
  END;
  normal_pointer; overwrite := save_ovrw;
  save_action := 0;
END;

PROCEDURE namefrompage{(VAR filename: str80; seite: p_onepage)};
{ Dateinamen aus der Titelzeile einer Seite übernehmen }
VAR i,j,l: Integer;
    pfad,name,s: str80;
    has_letters: Boolean;
PROCEDURE extract(i,j: Integer); { Stück aus s nach filename übertragen }
VAR k,l: Integer;
    sonder: String[8];
    uebers: String[15];
BEGIN
  sonder := 'äöüÄÖÜß'; uebers := 'aeoeueAEOEUEss';
  k := 1;
  REPEAT
    CASE s[i] OF
      ' ': filename[k] := '_'; { Leerzeichen }
      '/',':': filename[k] := '-'; { Verzeichnis-Begrenzer }
      OTHERWISE filename[k] := s[i];
    END;
    l := Pos(s[i],sonder);
    IF l>0 THEN BEGIN
      filename[k] := uebers[2*l-1]; Inc(k); filename[k] := uebers[2*l];
    END;                                                             
    Inc(i); Inc(k);
  UNTIL i>=j;
  filename[k] := #0;
END;
BEGIN
  IF seite=Nil THEN Exit;
  l := Length(filename);
  j := 0; FOR i := 1 TO l DO
    IF filename[i] IN ['/',':'] THEN j := i;
  IF j=0 THEN pfad := '' ELSE pfad := Copy(filename,1,j);
  IF j=l THEN name := '' ELSE name := Copy(filename,j+1,l-j);
  { Das 1. Wort in der Titelzeile finden, das auch Buchstaben enthält: }
  makeascii(seite, 0, True, s); j := 1;
  REPEAT
    i := j; has_letters := False;
    WHILE (s[i]=' ') AND (i<=40) DO Inc(i);
    j := i; REPEAT
      IF s[j] IN ['a'..'z','A'..'Z'] THEN has_letters := True;
      Inc(j);
    UNTIL (s[j]=' ') OR (j>40);
  UNTIL has_letters OR (i>40);
  IF i<=40 THEN extract(i,j) ELSE filename :='';
  IF filename=name THEN BEGIN { Oh, hier war ich schon mal }
    WHILE s[j]=' ' DO Inc(j);
    REPEAT Inc(j) UNTIL (s[j]=' ') OR (j>40);
    extract(i,j);
  END;
  IF filename<>'' THEN name := filename;
  filename := pfad + name;
END;

BEGIN  { Initialisierungen }
  iconpath := 'Icons/';
END.