home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TFDD.ZIP / WRITATTR.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1990-07-13  |  3.7 KB  |  125 lines
  1. (******************************************************************************
  2.  
  3.                                 UNIT  WRITATTR
  4.  
  5.  
  6. -------------------------------------------------------------------------------
  7. Philippe Ranger  (514) 274 4653
  8. First version  26-6-90          Present version  13-7-90
  9. -------------------------------------------------------------------------------
  10. SPECIFICATION
  11.    Defines a class of TFDD, writAttrC, and declares, initalizes and opens one
  12.       instance, wa (text file is wa.t).
  13.    WritAttrC executes standard screen writes except that the following control
  14.       chars are not written but command a change in attribute (permanent until
  15.       changed again):
  16.       ^N = normal;
  17.       ^B = bold;
  18.       ^C = not bold;
  19.       ^U = underline;
  20.       ^V = no underline;
  21.       ^R = reverse;
  22.       ^S = not reverse;
  23.       ^O = blink (on-off);
  24.       ^P = no blink.
  25.    On color screens, underline is blue. Utilities such as PCMag's Undrlin2
  26.       allow regaining the underline instead. Other attributes may be added
  27.       for other colors; this unit is aimed at working with most screens.
  28.    Unit uses Crt. Output can be redirected through
  29.             assign ('', filename); rewrite ('');
  30.       Filename will hold everything written to wa minus the above attribute
  31.       codes. Attribute changes will carry onscreen.
  32. ******************************************************************************)
  33.  
  34. UNIT writAttr;
  35.  
  36. INTERFACE
  37.  
  38. USES tfdd;
  39.  
  40. TYPE
  41.    writAttrC = object (tfddC)
  42.       constructor init
  43.       end;
  44.  
  45. VAR  wa: writAttrC;
  46.  
  47. IMPLEMENTATION
  48.  
  49. USES crt, dos;
  50.  
  51. {$F+}
  52.  
  53. PROCEDURE initialize; BEGIN  wa.init  END;
  54.  
  55.  
  56. FUNCTION attrWrite (var t: textRec): integer;
  57. (*=============================================================================
  58. PRE t open for output only;
  59. -------------------------------------------------------------------------------
  60. POST See unit specification.
  61. =============================================================================*)
  62.  
  63. TYPE
  64.    dispAttrT = (Fb, Fg, Fr, Fhi, Bb, Bg, Br, onOff);
  65.    dispAttrE = set of dispAttrT;
  66.  
  67. VAR
  68.    attr: dispAttrE absolute textAttr;
  69.    i, i0: word;
  70.    s: string;
  71.    s0: byte absolute s;
  72.  
  73. BEGIN
  74. with t do begin
  75.    attrWrite := 0;
  76.    i0 := 0; i := 0;
  77.    while i < bufPos do begin
  78.       i0 := i;
  79.       while (i < bufPos) and (i - i0 < 255) and (bufPtr^[i] >= ' ') do
  80.          inc(i);
  81.       move (bufPtr^[i0], s[1], i - i0);
  82.       s0 := i - i0;
  83.       write (s);
  84.       if i < bufPos then begin
  85.          case bufPtr^[i] of
  86.             ^N: attr := [Fb, Fg, Fr];
  87.             ^B: attr := attr + [Fhi];
  88.             ^C: attr := attr - [Fhi];
  89.             ^U: attr := attr - [Fg, Fr];
  90.             ^V: attr := attr + [Fg, Fr];
  91.             ^R: begin
  92.                if Fb in attr then attr := attr + [Bb];
  93.                if Fg in attr then attr := attr + [Bg];
  94.                if Fr in attr then attr := attr + [Br];
  95.                attr := attr - [Fb, Fg, Fr]
  96.                end;
  97.             ^S: begin
  98.                if Bb in attr then attr := attr + [Fb];
  99.                if Bg in attr then attr := attr + [Fg];
  100.                if Br in attr then attr := attr + [Fr];
  101.                attr := attr - [Bb, Bg, Br]
  102.                end;
  103.             ^O: attr := attr + [onOff];
  104.             ^P: attr := attr - [onOff];
  105.             else write (bufPtr^[i])
  106.             end;
  107.          inc (i)
  108.          end
  109.       end
  110.    end
  111. END;  (*attrWrite*)
  112.  
  113.  
  114. CONSTRUCTOR writAttrC.init;
  115. BEGIN
  116.    tfddC.init;
  117.    textRec(t).inoutFunc := @attrWrite;                           (*on principle*)
  118.    textRec(t).flushFunc := @attrWrite;
  119.               (*Flush seems to be the only function actually called for writes*)
  120.    rewrite (t)
  121. END;
  122.  
  123.  
  124. BEGIN INITIALIZE END.
  125.