1{
2    This file is part of the Free Component Library (FCL)
3    Copyright (c) 1999-2000 by the Free Pascal development team
4
5    This unit converts a stream to a regular text file.
6
7    See the file COPYING.FPC, included in this distribution,
8    for details about the copyright.
9
10    This program is distributed in the hope that it will be useful,
11    but WITHOUT ANY WARRANTY; without even the implied warranty of
12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
13
14 **********************************************************************}
15
16{$mode objfpc}
17{$H+}
18
19unit StreamIO;
20
21interface
22
23uses Classes,SysUtils;
24
25Procedure AssignStream(var F: Textfile; Stream: TStream);
26Function GetStream(var F: TTextRec) : TStream;
27
28implementation
29
30ResourceString
31  SErrNilStream = 'Can not assign file to Nil stream';
32
33Type
34  PStream = ^TStream;
35
36{ ---------------------------------------------------------------------
37    Text IO functions
38  ---------------------------------------------------------------------}
39
40
41procedure StreamRead(var F: TTextRec);
42
43begin
44  InOutRes:=0;
45  With F do
46    Try
47      Bufend:=GetStream(F).Read(BufPtr^,BufSize);
48      BufPos:=0;
49    except
50      InOutRes:=100;
51    end;
52end;
53
54
55procedure StreamWrite(var F: TTextRec );
56begin
57  InOutRes:=0;
58  with F do
59    if (BufPos>0) then
60      try
61        GetStream(F).WriteBuffer(BufPtr^,BufPos);
62        BufPos:=0;
63      except
64        InOutRes:=101;
65      end;
66end;
67
68
69{$PUSH}
70{$WARN 5024 OFF : Parameter "$1" not used}
71Procedure StreamFlush(var F: TTextRec);
72
73begin
74  InOutRes:=0;
75end;
76
77
78procedure StreamClose(var F: TTextRec);
79begin
80  InOutRes:=0;
81end;
82{$POP}
83
84Procedure StreamOpen(var F: TTextRec );
85
86begin
87  InOutRes:=0;
88  with F do
89    begin
90    BufPos:=0;
91    Bufend:=0;
92    case Mode of
93      fmInput:
94        begin
95        InOutFunc:=@StreamRead;
96        FlushFunc:=@StreamFlush;
97        end;
98      fmOutput,fmAppend:
99        begin
100        InOutFunc:=@StreamWrite;
101        FlushFunc:=@StreamWrite;
102        if Mode=fmAppend then
103          begin
104            Mode:=fmOutput; // see comments in text.inc
105            Try
106              GetStream(F).Seek(0,soFromEnd);
107            except
108              InOutRes:=156;
109            end;
110          end;
111        end;
112    end;
113    end;
114end;
115
116
117{ ---------------------------------------------------------------------
118    Public functions
119  ---------------------------------------------------------------------}
120
121
122Procedure AssignStream(var F: Textfile; Stream : TStream);
123
124Var
125  E : EInoutError;
126
127begin
128  if (Stream=Nil) then
129    begin
130    E:=EInOutError.Create(SErrNilStream);
131    E.ErrorCode:=6;
132    Raise E;
133    end;
134  with TTextRec(F) do
135    begin
136
137    OpenFunc:=@StreamOpen;
138    CloseFunc:=@StreamClose;
139    Case DefaultTextLineBreakStyle Of
140      tlbsLF: LineEnd:=#10;
141      tlbsCRLF: LineEnd:=#13#10;
142      tlbsCR: LineEnd:=#13;
143    End;
144    PStream(@UserData)^:=Stream;
145    Mode:=fmClosed;
146    BufSize:=SizeOf(Buffer);
147    BufPtr:=@Buffer;
148    Name[0]:=#0;
149    end;
150   SetTextCodePage(F,CP_ACP);
151end;
152
153
154Function GetStream(var F: TTextRec) : TStream;
155
156begin
157  Result:=PStream(@F.Userdata)^;
158end;
159
160end.
161