← Back to branch summary

~ubuntu-branches/debian/lenny/fpc/lenny

« back to all changes in this revision

Viewing changes to fpcsrc/fv/colortxt.pas

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-05-17 17:12:11 UTC
  • mfrom: (3.1.9 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080517171211-9qi33xhd9evfa0kg
Tags: 2.2.0-dfsg1-9
http://bugs.debian.org/477743
[ Torsten Werner ]
* Add Mazen Neifer to Uploaders field.

[ Mazen Neifer ]
* Moved FPC sources into a version dependent directory from /usr/share/fpcsrc
  to /usr/share/fpcsrc/${FPCVERSION}. This allow installing more than on FPC
  release.
* Fixed far call issue in compiler preventing building huge binearies.
  (closes: #477743)
* Updated building dependencies, recomennded and suggested packages.
* Moved fppkg to fp-utils as it is just a helper tool and is not required by
  compiler.

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcsrc/fv/colortxt.pas
 
1
unit ColorTxt;
 
2
 
 
3
{
 
4
  TColoredText is a descendent of TStaticText designed to allow the writing
 
5
  of colored text when color monitors are used.  With a monochrome or BW
 
6
  monitor, TColoredText acts the same as TStaticText.
 
7
 
 
8
  TColoredText is used in exactly the same way as TStaticText except that
 
9
  the constructor has an extra Byte parameter specifying the attribute
 
10
  desired.  (Do not use a 0 attribute, black on black).
 
11
}
 
12
 
 
13
{$i platform.inc}
 
14
 
 
15
{$ifdef PPC_FPC}
 
16
  {$H-}
 
17
{$else}
 
18
  {$F+,O+,E+,N+}
 
19
{$endif}
 
20
{$X+,R-,I-,Q-,V-}
 
21
{$ifndef OS_UNIX}
 
22
  {$S-}
 
23
{$endif}
 
24
 
 
25
interface
 
26
 
 
27
uses
 
28
  objects, drivers, views, dialogs, app, fvconsts;
 
29
 
 
30
type
 
31
  PColoredText = ^TColoredText;
 
32
  TColoredText = object(TStaticText)
 
33
    Attr : Byte;
 
34
    constructor Init(var Bounds: TRect; const AText: String; Attribute : Byte);
 
35
    constructor Load(var S: TStream);
 
36
    function GetTheColor : byte; virtual;
 
37
    procedure Draw; virtual;
 
38
    procedure Store(var S: TStream);
 
39
  end;
 
40
 
 
41
const
 
42
  RColoredText: TStreamRec = (
 
43
     ObjType: idColoredText;
 
44
     VmtLink: Ofs(TypeOf(TColoredText)^);
 
45
     Load:    @TColoredText.Load;
 
46
     Store:   @TColoredText.Store
 
47
  );
 
48
 
 
49
implementation
 
50
 
 
51
constructor TColoredText.Init(var Bounds: TRect; const AText: String;
 
52
                                  Attribute : Byte);
 
53
begin
 
54
TStaticText.Init(Bounds, AText);
 
55
Attr := Attribute;
 
56
end;
 
57
 
 
58
constructor TColoredText.Load(var S: TStream);
 
59
begin
 
60
TStaticText.Load(S);
 
61
S.Read(Attr, Sizeof(Attr));
 
62
end;
 
63
 
 
64
procedure TColoredText.Store(var S: TStream);
 
65
begin
 
66
TStaticText.Store(S);
 
67
S.Write(Attr, Sizeof(Attr));
 
68
end;
 
69
 
 
70
function TColoredText.GetTheColor : byte;
 
71
begin
 
72
if AppPalette = apColor then
 
73
  GetTheColor := Attr
 
74
else
 
75
  GetTheColor := GetColor(1);
 
76
end;
 
77
 
 
78
procedure TColoredText.Draw;
 
79
var
 
80
  Color: Byte;
 
81
  Center: Boolean;
 
82
  I, J, L, P, Y: Sw_Integer;
 
83
  B: TDrawBuffer;
 
84
  S: String;
 
85
begin
 
86
  Color := GetTheColor;
 
87
  GetText(S);
 
88
  L := Length(S);
 
89
  P := 1;
 
90
  Y := 0;
 
91
  Center := False;
 
92
  while Y < Size.Y do
 
93
  begin
 
94
    MoveChar(B, ' ', Color, Size.X);
 
95
    if P <= L then
 
96
    begin
 
97
      if S[P] = #3 then
 
98
      begin
 
99
        Center := True;
 
100
        Inc(P);
 
101
      end;
 
102
      I := P;
 
103
      repeat
 
104
        J := P;
 
105
        while (P <= L) and (S[P] = ' ') do Inc(P);
 
106
        while (P <= L) and (S[P] <> ' ') and (S[P] <> #13) do Inc(P);
 
107
      until (P > L) or (P >= I + Size.X) or (S[P] = #13);
 
108
      if P > I + Size.X then
 
109
        if J > I then P := J else P := I + Size.X;
 
110
      if Center then J := (Size.X - P + I) div 2 else J := 0;
 
111
      MoveBuf(B[J], S[I], Color, P - I);
 
112
      while (P <= L) and (S[P] = ' ') do Inc(P);
 
113
      if (P <= L) and (S[P] = #13) then
 
114
      begin
 
115
        Center := False;
 
116
        Inc(P);
 
117
        if (P <= L) and (S[P] = #10) then Inc(P);
 
118
      end;
 
119
    end;
 
120
    WriteLine(0, Y, Size.X, 1, B);
 
121
    Inc(Y);
 
122
  end;
 
123
end;
 
124
 
 
125
 
 
126
end.