Mega Code Archive
How do I write a text file device driver
<![CDATA[
Title: How do I write a text file device driver?
Often being able to run a text source through the standard Delphi text routines (assign, reset, rewrite, readln, read, etc) can be very useful. You can either support a new device or make changes to how a current device is supported. This is an example of how to write one.
This example writes to and reads from some things on a console. Text is changed by default to magenta.
Bonus: You don't need {$APPTYPE CONSOLE} for this program to work, so this is an improvement on the earlier tip I wrote about in trying to make a universal interface - you can create a console at your option.
CODE
program tfdd; uses sysutils, windows;
{ demo of a text file device driver - no need for $APPTYPE C0NS0LE here!}
const
{ color definitions }
FOREGROUND_MAGENTA = FOREGROUND_RED or FOREGROUND_BLUE;
FOREGROUND_BR_MAGENTA = FOREGROUND_MAGENTA or FOREGROUND_INTENSITY;
type
IOFunc = function(var F : TTextRec) : integer;
var
infile, outfile: text; // using different file handles than input/output to
// show we are really taking things to console ourselves
function CRTinput(var F: TTextRec): integer;
{ input function for CRT, reads in up to bufsize bytes and places number of bytes
actually read into BufEnd. }
begin
if ReadConsole(F.Handle, F.BufPtr, DWord(F.BufSize), DWord(F.BufEnd), nil) then
Result := 0
else
Result := 8;
F.BufPos := 0;
end;
function CRTOutput(var F: TTextRec): integer;
{ output function for CRT, writes BufPos bytes and resets the buffer position }
var
numwritten: integer;
begin
if WriteConsole(F.Handle, F.BufPtr, F.BufPos, NumWritten, nil) then
Result := 0
else
Result := 8;
F.BufPos := 0;
end;
function CRTflush(var F: TTextRec): integer;
{ flushes the buffer of the file -
for input, sets the buffer position and end to 0 - effectively wiping
out what is read
for output, calls InOutFunc to write the buffer out }
var
FPtr: IOFunc;
begin
if F.Mode = fmInput then
begin
F.BufPos := 0;
F.BufEnd := 0;
end;
if F.Mode = fmOutput then
begin
FPtr := F.InOutFunc;
Result := FPtr(F); // address call to function, if not zero return, quit
if Result 0 then
exit;
end;
Result := 0;
end;
function CRTclose(var F: TTextRec): integer;
{ called upon close file to do the work, flush buffer if output }
var
FPtr: IOFunc;
begin
if F.Mode = fmOutput then // if output then need to flush the buffer }
begin
FPtr := F.InOutFunc;
Result := FPtr(F); // address call to function, if not zero return, quit
if Result 0 then
exit;
end;
CloseHandle(F.Handle); // close file here
Result := 0;
end;
function CRTopen(var F: TTextRec): integer;
{ called by reset/rewrite/append. fmInput, fmOutput, fmInOut
this function opens the file for read or write, also sets proper read and
write routines for the file }
begin
F.CloseFunc := @CRTClose;
if F.Mode = fmInput then
begin
F.Handle := GetStdHandle(STD_INPUT_HANDLE); // open CRT input handle
F.InOutFunc := @CRTInput;
F.FlushFunc := @CRTFlush;
end;
if F.Mode = fmOutput then
begin
F.Handle := GetStdHandle(STD_OUTPUT_HANDLE); // open CRT output handle
F.InOutFunc := @CRTOutput;
F.FlushFunc := @CRTFlush;
SetConsoleTextAttribute(F.Handle, FOREGROUND_BR_MAGENTA); // to make it do something interesting
end;
if F.Mode = fmInOut then
{F.Mode := fmOutput;} // normally do this, but for CRT, make error:
Result := 8 // since fmInOut doesn't make sense
else
Result := 0;
end;
procedure CRTassign(var f: Text);
{ prepares special file for assign }
begin
// start console
FreeConsole;
AllocConsole;
SetConsoleTitle('CRT Assign Console');
// standard initializations
With TTextRec(F) do
begin
Mode := fmClosed;
BufSize := SizeOf(Buffer);
BufPtr := @Buffer;
OpenFunc := @CrtOpen;
Name[0] := #0;
end;
end;
var
mystring: string;
begin
{ if we set this to standard input and output, we can condense this section
into CRTAssign, or even make this into initialization code for our special
file }
CRTAssign(Infile);
CRTAssign(Outfile);
reset(infile);
rewrite(Outfile);
{ *** end section }
writeln(outfile, 'test write');
write(outfile, 'now type something to be echoed back to screen: ');
readln(infile, mystring);
writeln(outfile, 'Echoed text is: ', mystring);
write('Press ENTER to quit.');
readln(infile);
{ close input files - this can be placed into finalization as well }
Close(Infile);
Close(Outfile);
// FreeConsole; is also possible here instead of the two closes
end.
]]>