unit1.pas

在delphi中实现windows核心编程.原书光盘代码核心编程.原书光盘代码

unit Unit1;

interface

uses
    Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
    Dialogs, StdCtrls,Aclapi,Accctrl;

type
    TForm1 = class(TForm)
        Button1: TButton;
    Edit2: TEdit;
        Label1: TLabel;
    Edit1: TEdit;
        Label2: TLabel;
    ListBox1: TListBox;
        procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    private
        { Private declarations }
    public
        { Public declarations }
    end;
    PUnicodeString = ^TUnicodeString;
    TUnicodeString = packed record
        Length: Word;
        MaximumLength: Word;
        Buffer: PWideChar;
    end;
    NTSTATUS = Integer;
    PObjectAttributes = ^TObjectAttributes;
    TObjectAttributes = packed record
        Length: DWORD;
        RootDirectory: THandle;
        ObjectName: PUnicodeString;
        Attributes: DWORD;
        SecurityDescriptor: PSecurityDescriptor;
        SecurityQualityOfService: PSecurityQualityOfService;
    end;
{    SECTION_INHERIT = (
        ViewShare = 1,
        ViewUnmap = 2); }
    TZwOpenSection = function(var SectionHandle: THandle;
        DesiredAccess: ACCESS_MASK;
        var ObjectAttributes: TObjectAttributes): NTSTATUS;stdcall;
    TzwClose=procedure(Sectionhandle:Thandle);stdcall;
    TRtlInitUnicodeString = procedure(var DestinationString: TUnicodeString;
        vSourceString: WideString);stdcall;
{    TNTOpenSection = function(var SectionHandle: THandle;
        DesiredAccess: ACCESS_MASK;
        var ObjectAttributes: TObjectAttributes): NTSTATUS;
    stdcall;
    TRtlNtStatusToDosError = function(Status: NTSTATUS): DWORD; stdcall;
    TNtMapViewOfSection = function(SectionHandle, ProcessHandle: Thandle;
        BaseAddress: Pointer; ZeroBits, CommitSize: NTSTATUS;
        SectionOffset: PLARGEINTEGER;
        Viewsize: PDWORD; InheritDisposition: SECTION_INHERIT;
        AllocationType, Protect: DWORD): NTSTATUS; stdcall;
    TNtUnmapViewOfSection = function(ProcessHandle: Thandle; BaseAddress:
        pointer): NTSTATUS; stdcall; }

const
    STATUS_SUCCESS = NTSTATUS(0);
    STATUS_INVALID_HANDLE = NTSTATUS($C0000008);
    STATUS_ACCESS_DENIED = NTSTATUS($C0000022);

    OBJ_INHERIT = $00000002;
    OBJ_PERMANENT = $00000010;
    OBJ_EXCLUSIVE = $00000020;
    OBJ_CASE_INSENSITIVE = $00000040;
    OBJ_OPENIF = $00000080;
    OBJ_OPENLINK = $00000100;
    OBJ_KERNEL_HANDLE = $00000200;
    OBJ_VALID_ATTRIBUTES = $000003F2;

    ObjectPhysicalMemoryDeviceName = '\Device\Physicalmemory';
{    ObjectPhysicalMemoryName: TUnicodeString = (
        Length: Length(ObjectPhysicalMemoryDeviceName) * 2;
        MaximumLength: Length(ObjectPhysicalMemoryDeviceName) * 2 + 2;
        Buffer: ObjectPhysicalMemoryDeviceName;
        );
    ObjectPhysicalMemoryAccessMask: ACCESS_MASK = SECTION_MAP_READ;
    ObjectPhysicalMemoryAttributes: TObjectAttributes = (
        Length: SizeOf(TObjectAttributes);
        RootDirectory: 0;
        ObjectName: @ObjectPhysicalMemoryName;
        Attributes: OBJ_CASE_INSENSITIVE;
        SecurityDescriptor: nil;
        SecurityQualityOfService: nil;
        ); }
    ntdll = 'ntdll.dll';

var
    ZwOpenSection: TZwOpenSection;
    zwClose:TzwClose;
    RtlInitUnicodeString: TRtlInitUnicodeString;    
{    NtOpenSection: TNTOpenSection;
    RtlNtStatusToDosError: TRtlNtStatusToDosError;
    NtUnmapViewOfSection: TNtUnmapViewOfSection;
    NtMapViewOfSection: TNtMapViewOfSection; }

var
    Form1: TForm1;
    NtLayer: HMODULE;

implementation

{$R *.dfm}

function NT_SUCCESS(var Status: longint): boolean;
begin
    result := longint(Status) >= 0;
end;

procedure InitializeObjectAttributes(var p: TOBJECTATTRIBUTES; n: PUNICODESTRING;
    a: DWORD; r: Thandle; s: PSecurityDescriptor);
begin
    p.Length := sizeof(TOBJECTATTRIBUTES);
    p.RootDirectory := r;
    p.Attributes := a;
    p.ObjectName := n;
    p.SecurityDescriptor := s;
    p.SecurityQualityOfService := nil;
end;

function SetPhyscialMemorySectionCanBeWrited(hSection:Thandle):boolean;
var
  pDacl:PACL;
  pNewDacl:PACL;
  pSD:PPSECURITY_DESCRIPTOR;
  dwRes:cardinal;
  ea:EXPLICIT_ACCESS_A;
  label CleanUp;
begin
      result:=false;
      pDacl:=nil;
      pNewDacl:=nil;
      pSD:=nil;
      dwres:=GetSecurityInfo(hSection,SE_KERNEL_OBJECT,DACL_SECURITY_INFORMATION,nil,nil,@pDacl,nil,pSD);
      if(dwres<>ERROR_SUCCESS)  then
      begin
         goto CleanUp;
      end;
      Fillchar(ea, sizeof(EXPLICIT_ACCESS),0);
      ea.grfAccessPermissions := SECTION_MAP_WRITE;
      ea.grfAccessMode := GRANT_ACCESS;
      ea.grfInheritance:= NO_INHERITANCE;
      ea.Trustee.TrusteeForm := TRUSTEE_IS_NAME;
      ea.Trustee.TrusteeType := TRUSTEE_IS_USER;
      ea.Trustee.ptstrName := 'CURRENT_USER';
      
      dwRes:=SetEntriesInAcl(1,@ea,nil,pNewDacl);
      if(dwRes<>ERROR_SUCCESS) then
      begin
  //       goto CleanUp;
      end;
      dwRes:=SetSecurityInfo(hSection,SE_KERNEL_OBJECT,DACL_SECURITY_INFORMATION,nil,nil,pNewDacl,nil);
      if(dwRes=ERROR_SUCCESS) then
      begin
          goto CleanUp;
      end;
      result:=true;
  CleanUp:
      if(pSD<>nil) then
         LocalFree(cardinal(pSD^));
      if(pNewDacl<>nil) then
         LocalFree(cardinal(psD^));
end;

function OpenPhysicalMemory(ReadOrNot:boolean): Thandle;
var
    status: NTSTATUS;
    physmem: Thandle;
    physmemString: TUnicodeString;
    attributes: TObjectAttributes;
    SectionAttrib:integer;
    physmemName: WideString;
begin
    result:=0;
    physmemName := ObjectPhysicalMemoryDeviceName;
    RtlInitUnicodeString(physmemString, physmemName);
    InitializeObjectAttributes(attributes, @physmemString,
        OBJ_CASE_INSENSITIVE or OBJ_KERNEL_HANDLE, 0, nil);
//       SectionAttrib:=SECTION_MAP_READ;
//       status := NtOpenSection(physmem, SectionAttrib, attributes);
    if ReadorNot then
       SectionAttrib:=SECTION_MAP_READ
    else SectionAttrib:=SECTION_MAP_READ or SECTION_MAP_WRITE;
    status := ZwOpenSection(physmem, SectionAttrib, attributes);
    if not ReadorNot then
    begin
       if(status=STATUS_ACCESS_DENIED)then
       begin
          status := ZwOpenSection(physmem,READ_CONTROL or WRITE_DAC,Attributes);
          SetPhyscialMemorySectionCanBeWrited(physmem);
          zwClose(physmem);
          status :=ZwOpenSection(physmem,SectionAttrib,Attributes);
       end;
    end;
    if (not NT_SUCCESS(status)) then
    begin
       //showmessagefmt('Could not open \device\physicalmemory %d', [status] );
       exit;
    end;
    result := physmem;
end;

function MapPhysicalMemory(ReadOrNot:boolean;PhysicalMemory:THandle;Address,
   Length:DWORD;var VirtualAddress: Pchar): boolean;
var
   Access:Cardinal;
begin
{    viewBase.QuadPart := Address;
    ntStatus1: NTSTATUS;
    viewBase: ULARGE_INTEGER;
    StartPage,EndPage,PageCount:dword;
       VirtualAddress := nil;
       StartPage:=(viewBase.QuadPart+$FFF)div $1000;// 每页4K，即$1000字节
       EndPage:=(viewBase.QuadPart+Length+$FFF)div $1000;// 每页4K，即$1000字节
       PageCount:=EndPage-StartPage+1;
       ntStatus1 := NtMapViewOfSection(PhysicalMemory,
           THandle(-1),
           @VirtualAddress,
           $0,
           PageCount, //页数
           @viewBase,
           @PageCount,//调用前是页数,调用后是字节数
           ViewShare,
           0,
           PAGE_READONLY);
       if (not NT_SUCCESS(ntStatus1)) then
       begin
          result:=false;
          exit;
       end;
       inc(DWORD(VirtualAddress) , Address-viewBase.LowPart); }
    if ReadOrNot then Access:=FILE_MAP_READ
    else Access:=FILE_MAP_READ or FILE_MAP_WRITE;
    VirtualAddress:=MapViewOfFile(PhysicalMemory,Access,0,Address,Length);
    inc(DWORD(VirtualAddress) , Address mod $1000);
    result:=true;
end;

procedure UnmapPhysicalMemory(Address: Pointer);
//var
//    status: NTSTATUS;
begin
{   if ReadOrNot then
   begin
     //status :=
     NtUnmapViewOfSection(Thandle(-1), Address);
   end
   else }
   UnMapViewOfFile(Address);
end;

function LocateNtdllEntryPoints: BOOLEAN;
begin
    NtLayer := GetModuleHandle(ntdll);
    if NtLayer = 0 then
    begin
        SetLastError(ERROR_CALL_NOT_IMPLEMENTED);
        result := false;
        exit;
    end
    else
    begin
        if not Assigned(ZwOpenSection) then
            ZwOpenSection := GetProcAddress(NtLayer, 'ZwOpenSection');
        if not assigned(zwClose) then
            zwClose:=GetProcAddress(ntlayer,'ZwClose');
        if not Assigned(RtlInitUnicodeString) then
            RtlInitUnicodeString := GetProcAddress(NtLayer,
                'RtlInitUnicodeString');
{        if not Assigned(NtOpenSection) then
            NtOpenSection := GetProcAddress(NtLayer, 'NtOpenSection');
        if not Assigned(RtlNtStatusToDosError) then
            RtlNtStatusToDosError := GetProcAddress(NtLayer,
                'RtlNtStatusToDosError');
        if not Assigned(NtUnmapViewOfSection) then
            NtUnmapViewOfSection := GetProcAddress(NtLayer,
                'NtUnmapViewOfSection');
        if not Assigned(NtMapViewOfSection) then
            NtMapViewOfSection := GetProcAddress(NtLayer, 'NtMapViewOfSection'); }
    end;
    result := true;
end;

function ReadWritePhyMem(ReadOrNot:boolean;Address,length:dword;buffer:pchar):boolean;
var
   physmem: Thandle;
   vaddress: Pchar;
begin
   result:=false;
   if not Assigned(ZwOpenSection) then exit;
   physmem := OpenPhysicalMemory(ReadOrNot);
   if (physmem = 0) then exit;

   if not MapPhysicalMemory(ReadOrNot,physmem,address,Length,vaddress) then exit;
   try
     if ReadOrNot then
        move(vaddress^,buffer^,Length)
     else
        move(buffer^,vaddress^,Length);
     result:=true;
   except
     on e:exception do
     begin
        MessageDlg('缓中区长度不足或内存跨段。'+#$D+
           '每个内存段为4K的整数倍，每次读写不能跨越多个不同的内存段。',
           mtError, [mbok],0);
     end;
   end;

   UnmapPhysicalMemory(vaddress);
   {if ReadOrNot then CloseHandle(physmem)
   else }zwClose(physmem);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
   p:PBytearray;
   i, address, length, lines: DWORD;
   str: string;
begin
    address := StrToInt('$'+edit1.Text);
    length := strToInt('$'+edit2.text);
    if length=0 then exit;
    getmem(p,length);
    if ReadWritePhyMem(true,address,length,pchar(p)) then
    begin
       str:='';
       lines:=0;
       for i:=0 to length-1 do
       begin
           str := str + format('%2.2X ',[p^[i]]);
           if(i mod 16=15)or(i=length-1)then
           begin
              str:=str+#$D#$A;
              inc(lines);
              if (lines=16)or(i=length-1) then
              begin
                 lines:=0;
                 if MessageDlg(str,mtconfirmation,[mbyes,mbno],0)<>mryes then
                    break;
                 str:='';
              end;
           end;
       end;
{       if not ReadWritePhyMem(false,address,length,pchar(p)) then
          showmessage('写物理内存出错！'); }
    end;
    freemem(p,length);
end;

procedure TForm1.FormCreate(Sender: TObject);
var
   p:Pchar;
   Length:DWORD;
   i:integer;
begin
    if (not LocateNtdllEntryPoints) then
    begin
        showmessage('Unable to locate NTDLL entry points.');
        exit;
    end
    else begin
      length:=$B;
      getmem(p,length);
      if ReadWritePhyMem(true,$ffff5,length,p) then
      begin
          listbox1.Items.Add('BIOS日期：'+string(p));
      end;
      freemem(p,length);

      //串口
      Length:=$E;
      getmem(p,Length);
      if ReadWritePhyMem(true,$400,Length,p) then
      begin
         for i:=0 to 3 do
         begin
            listbox1.Items.add(format('串口%d输入/输出范围: %X',[i+1,pword(@p[i*2])^]));
         end;
         for i:=0 to 2 do
         begin
            listbox1.Items.add(format('并口%d输入/输出范围: %X',[i+1,pword(@p[8+i*2])^]));
         end;
      end;
      freemem(p,length);
    end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
   FreeLibrary(NtLayer);
end;

end.