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