驅動程式 - Windows Driver Model (WDM) - 使用範例 - Pascal (DDDK) - Queue IRP

參考資訊：
https://wasm.in/
http://four-f.narod.ru/
https://github.com/steward-fu/ddk

main.pas

unit main;
 
interface
    uses
        DDDK;
         
    const
        DEV_NAME = '\Device\MyDriver';
        SYM_NAME = '\DosDevices\MyDriver';

        IOCTL_QUEUE   = (FILE_DEVICE_UNKNOWN shl 16) or (FILE_ANY_ACCESS shl 14) or ($800 shl 2) or (METHOD_BUFFERED);
        IOCTL_PROCESS = (FILE_DEVICE_UNKNOWN shl 16) or (FILE_ANY_ACCESS shl 14) or ($801 shl 2) or (METHOD_BUFFERED);
 
    function _DriverEntry(pMyDriver : PDRIVER_OBJECT; pMyRegistry : PUNICODE_STRING) : NTSTATUS; stdcall;
 
implementation
var
    dpc : TKDpc;
    obj : KTIMER;
    queue : LIST_ENTRY;
    pNextDevice : PDEVICE_OBJECT;
 
procedure OnTimer(Dpc : KDPC; pContext : Pointer; pArg1 : Pointer; pArg2 : Pointer); stdcall;
var
    pCurIrp : PIRP;
    pList : PLIST_ENTRY;
        
begin
    if IsListEmpty(@queue) = True then
    begin
        KeCancelTimer(@obj);
        DbgPrint('Finish', []);
    end
    else
    begin
        pList := RemoveHeadList(@queue);
            
        // CONTAINING_RECORD(IRP.Tail.Overlay.ListEntry)
        pCurIrp := Pointer(Integer(pList) - 88);
        pCurIrp^.IoStatus.Status := STATUS_SUCCESS;
        pCurIrp^.IoStatus.Information := 0;
        IoCompleteRequest(pCurIrp, IO_NO_INCREMENT);
        DbgPrint('Complete Irp', []);
    end;
end;
 
procedure Unload(pMyDriver : PDRIVER_OBJECT); stdcall;
begin
end;
 
function IrpFile(pMyDevice : PDEVICE_OBJECT; pIrp : PIRP) : NTSTATUS; stdcall;
var
    pStack : PIO_STACK_LOCATION;
     
begin
    pStack := IoGetCurrentIrpStackLocation(pIrp);
    case pStack^.MajorFunction of
    IRP_MJ_CREATE:
        DbgPrint('IRP_MJ_CREATE', []);
    IRP_MJ_CLOSE:
        DbgPrint('IRP_MJ_CLOSE', []);
    end;
     
    Result := STATUS_SUCCESS;
    pIrp^.IoStatus.Status := Result;
    pIrp^.IoStatus.Information := 0;
    IoCompleteRequest(pIrp, IO_NO_INCREMENT);
end;
 
function IrpIOCTL(pMyDevice : PDeviceObject; pIrp : PIrp) : NTSTATUS; stdcall;
var
    dwCode : ULONG;
    tt : LARGE_INTEGER;
    pStack : PIO_STACK_LOCATION;
        
begin
    pStack := IoGetCurrentIrpStackLocation(pIrp);
    dwCode := pStack^.Parameters.DeviceIoControl.IoControlCode;
    case dwCode of
    IOCTL_QUEUE:
        begin
            DbgPrint('IOCTL_QUEUE', []);
            InsertHeadList(@queue, @pIrp^.Tail.Overlay.s1.ListEntry);
            IoMarkIrpPending(pIrp);
            Result := STATUS_PENDING;
            exit
        end;
    IOCTL_PROCESS:
        begin
            DbgPrint('IOCTL_PROCESS', []);
            tt.HighPart := tt.HighPart or -1;
            tt.LowPart := ULONG(-10000000);
            KeSetTimerEx(@obj, tt.LowPart, tt.HighPart, 1000, @dpc);
        end;
    end;
        
    Result := STATUS_SUCCESS;
    pIrp^.IoStatus.Information := 0;
    pIrp^.IoStatus.Status := Result;
    IoCompleteRequest(pIrp, IO_NO_INCREMENT);
end;
 
function IrpPnp(pMyDevice : PDEVICE_OBJECT; pIrp : PIRP) : NTSTATUS; stdcall;
var
    pStack : PIO_STACK_LOCATION;
    suSymName : UNICODE_STRING;
           
begin
    pStack := IoGetCurrentIrpStackLocation(pIrp);
    if pStack^.MinorFunction = IRP_MN_REMOVE_DEVICE then
        begin
            RtlInitUnicodeString(@suSymName, SYM_NAME);
            IoDetachDevice(pNextDevice);
            IoDeleteDevice(pMyDevice);
            IoDeleteSymbolicLink(@suSymName);
            IoCompleteRequest(pIrp, IO_NO_INCREMENT);
            Result := STATUS_SUCCESS;
        end
    else
        begin
            IoSkipCurrentIrpStackLocation(pIrp);
            Result := IoCallDriver(pNextDevice, pIrp);
        end;
end;
 
function AddDevice(pMyDriver : PDRIVER_OBJECT; pPhyDevice : PDEVICE_OBJECT) : NTSTATUS; stdcall;
var
    suDevName : UNICODE_STRING;
    suSymName : UNICODE_STRING;
    pMyDevice : PDEVICE_OBJECT;
     
begin
    RtlInitUnicodeString(@suDevName, DEV_NAME);
    RtlInitUnicodeString(@suSymName, SYM_NAME);
    IoCreateDevice(pMyDriver, 0, @suDevName, FILE_DEVICE_UNKNOWN, 0, FALSE, pMyDevice);
    pNextDevice := IoAttachDeviceToDeviceStack(pMyDevice, pPhyDevice);
    pMyDevice^.Flags := pMyDevice^.Flags or DO_BUFFERED_IO;
    pMyDevice^.Flags := pMyDevice^.Flags and not DO_DEVICE_INITIALIZING;
    InitializeListHead(@queue);
    KeInitializeTimer(@obj);
    KeInitializeDpc(@dpc, OnTimer, pMyDevice);
    Result := IoCreateSymbolicLink(@suSymName, @suDevName);
end;
 
function _DriverEntry(pMyDriver : PDRIVER_OBJECT; pMyRegistry : PUNICODE_STRING) : NTSTATUS; stdcall;
begin
    pMyDriver^.MajorFunction[IRP_MJ_PNP]            := @IrpPnp;
    pMyDriver^.MajorFunction[IRP_MJ_CREATE]         := @IrpFile;
    pMyDriver^.MajorFunction[IRP_MJ_CLOSE]          := @IrpFile;
    pMyDriver^.MajorFunction[IRP_MJ_DEVICE_CONTROL] := @IrpIOCTL;
    pMyDriver^.DriverExtension^.AddDevice := @AddDevice;
    pMyDriver^.DriverUnload := @Unload;
    Result := STATUS_SUCCESS;
end;
end.

app.pas

program main;
 
{$APPTYPE CONSOLE}
 
uses
    Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs;
 
const
    METHOD_BUFFERED = 0;
    METHOD_IN_DIRECT = 1;
    METHOD_OUT_DIRECT = 2;
    METHOD_NEITHER = 3;

    FILE_ANY_ACCESS = 0;
    FILE_DEVICE_UNKNOWN = $22;

    IOCTL_QUEUE   = (FILE_DEVICE_UNKNOWN shl 16) or (FILE_ANY_ACCESS shl 14) or ($800 shl 2) or (METHOD_BUFFERED);
    IOCTL_PROCESS = (FILE_DEVICE_UNKNOWN shl 16) or (FILE_ANY_ACCESS shl 14) or ($801 shl 2) or (METHOD_BUFFERED);
 
var
    hFile : DWORD;
    dwRet : DWORD;
    dwCnt : DWORD;
    ov : array [0..2] of OVERLAPPED;
     
begin
    hFile := CreateFile('\\.\MyDriver', GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_FLAG_OVERLAPPED or FILE_ATTRIBUTE_NORMAL, 0);

    for dwCnt:= 0 to 2 do
    begin
        ov[dwCnt].hEvent:= CreateEvent(nil, TRUE, FALSE, nil);
        DeviceIoControl(hFile, IOCTL_QUEUE, nil, 0, nil, 0, dwRet, @ov[dwCnt]);
        WriteLn(Output, 'Queued event');
    end;
     
    WriteLn(Output, 'Processing All Events');
    DeviceIoControl(hFile, IOCTL_PROCESS, nil, 0, nil, 0, dwRet, nil);
    for dwCnt:= 0 to 2 do
    begin
        WaitForSingleObject(ov[dwCnt].hEvent, INFINITE);
        CloseHandle(ov[dwCnt].hEvent);
        WriteLn(Output, 'Complete');
    end;

    CloseHandle(hFile);
end.

完成