Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

  • Congratulations Mike Lewis on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

How do I write a text file device driver?

How To

How do I write a text file device driver?

by  Glenn9999  Posted    (Edited  )
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.
Register to rate this FAQ  : BAD 1 2 3 4 5 6 7 8 9 10 GOOD
Please Note: 1 is Bad, 10 is Good :-)

Part and Inventory Search

Back
Top