home *** CD-ROM | disk | FTP | other *** search
/ Vectronix 2 / VECTRONIX2.iso / FILES_07 / ACS_PRO.LZH / ASC / PURE.PAS / WWRITELN.PAS < prev   
Pascal/Delphi Source File  |  1993-01-27  |  3KB  |  123 lines
  1. unit WWRITELN;
  2. {
  3.     (c) 1993 Stefan Bachert
  4.  
  5.     Dieser Texttreiber erlaubt es die ACS pro 2.00 Fenster
  6.     mit dem Befehl write und writeln anzusprechen
  7.  
  8.     Beispiel:
  9.  
  10.         var
  11.            t : Text;
  12.         begin
  13.            ACSprotocol( t );
  14.            Rewrite( t );
  15.            Writeln( t, 'This is ACS pro 2.00 output!' );
  16.            Close( t );
  17.         end.
  18. }
  19.  
  20. interface
  21.  
  22. Procedure ACSprotocol (var f: Text);  { spezieller Assign für ACS Protocol-Fenster}
  23.  
  24. implementation
  25.  
  26. uses acs, dos;
  27.  
  28. Type
  29.     MyUserPtr = ^AwindowPtr;
  30. Const
  31.     form: packed array [0..2] of char = '%s'#0;
  32.  
  33. Function InOutFunc (var t: TextRec): Integer;
  34. Begin
  35.     InOutFunc := 0;
  36. End;
  37.  
  38. Function FlushFunc (var t: TextRec): Integer;
  39. Var
  40.     i: Integer;
  41.     Buf: ^TextBuf;
  42.     strng: packed array [0..128] of char;
  43.     user: MyUserPtr;
  44.     wi: AwindowPtr;
  45.     p: Pointer;
  46. Begin
  47.     user := @(t. userdata);
  48.     wi := user^;
  49.     if ((wi <> NIL) AND (t. mode = fmOutput)) Then Begin
  50.         if (t. BufPos > 0) Then BEGIN
  51.             Buf := Pointer(t. BufPtr);
  52.             if (t. Bufpos >= t. Bufsize) then BEGIN
  53.                 for i:= 0 to t. BufPos do strng [i] := Buf^[i];
  54.                 p := @strng;
  55.             END ELSE BEGIN
  56.                 t. BufPtr^[t. BufPos] := chr(0);
  57.                 p := t. BufPtr;
  58.             END;
  59.             wvprintf (wi, @form, @p);
  60.             t. BufPos := 0;
  61.         END;
  62.         FlushFunc := 0;
  63.     END ELSE FlushFunc := 1;
  64. END;
  65.  
  66. Function CloseFunc (var t: TextRec): Integer;
  67. Var
  68.     user: MyUserPtr;
  69.     wi: AwindowPtr;
  70.     db: Boolean;
  71. Begin
  72.     user := @(t. userdata);
  73.     wi := user^;
  74.     if (wi <> NIL) Then Begin
  75.         db := wi^. service (wi, AS_TERM, wi);
  76.         user^ := NIL;
  77.         CloseFunc := 0;
  78.     End Else CloseFunc := 1;
  79. End;
  80.  
  81. Function OpenFunc (var t: TextRec): Integer;
  82. Var
  83.     user: MyUserPtr;
  84.     wi: AwindowPtr;
  85.     di: Integer;
  86. Begin
  87.     OpenFunc := 0;
  88.     if (t. mode = fmOutput) Then Begin
  89.         user := @(t. userdata);
  90.         if (user^ = NIL) Then Begin {    Noch nicht offen }
  91.             wi := get_protocol^. create (NIL);
  92.             if (wi <> NIL) Then Begin
  93.                 user^ := wi;
  94.                 t. InOutFunc := @InOutFunc;
  95.                 t. FlushFunc := @FlushFunc;
  96.                 t. CloseFunc := @CloseFunc;
  97.                 di := wi^. open (wi);
  98.             End Else Begin     {    Konnte kein Fenster erzeugen }
  99.                 OpenFunc := 1;
  100.             END
  101.         END;
  102.     End Else Begin        { Nur Output erlaubt }
  103.         OpenFunc := 1;
  104.     End;
  105. End;
  106.  
  107. Procedure ACSprotocol (var f: Text);
  108. Var
  109.     t: ^TextRec;
  110.     user: MyUserPtr;
  111. Begin
  112.     t := @f;
  113.     t^. OpenFunc := @OpenFunc;
  114.     t^. BufSize := 128;
  115.     t^. BufPtr := @(t^. Buffer);
  116.     t^. mode := fmClosed;
  117.     user := @(t^. userdata);
  118.     user^ := NIL;
  119. End;
  120.  
  121. begin
  122. end.
  123.